Open-ILS/src/perlmods/OpenILS/Utils/Fieldmapper.pm

   1 package Fieldmapper;
   2 use JSON;
   3 use Data::Dumper;
   4 use base 'OpenSRF::Application';
   5 use OpenSRF::Utils::Logger;
   6 use OpenSRF::Utils::SettingsClient;
   7 use OpenSRF::System;
   8 use XML::Simple;
   9
  10 my $log = 'OpenSRF::Utils::Logger';
  11
  12 use vars qw/$fieldmap $VERSION/;
  13
  14 sub publish_fieldmapper {
  15         my ($self,$client,$class) = @_;
  16
  17         return $fieldmap unless (defined $class);
  18         return undef unless (exists($$fieldmap{$class}));
  19         return {$class => $$fieldmap{$class}};
  20 }
  21 __PACKAGE__->register_method(
  22         api_name        => 'opensrf.open-ils.system.fieldmapper',
  23         api_level       => 1,
  24         method          => 'publish_fieldmapper',
  25 );
  26
  27 #
  28 # To dump the Javascript version of the fieldmapper struct use the command:
  29 #
  30 #       PERL5LIB=~/cvs/ILS/OpenSRF/src/perlmods/:~/cvs/ILS/Open-ILS/src/perlmods/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
  31 #
  32 # ... adjusted for your CVS sandbox, of course.
  33 #
  34
  35 sub classes {
  36         return () unless (defined $fieldmap);
  37         return keys %$fieldmap;
  38 }
  39
  40 import();
  41 sub import {
  42         my $class = shift;
  43         my %args = @_;
  44
  45         return if (keys %$fieldmap);
  46         return if (!OpenSRF::System->connected && !$args{IDL});
  47
  48         # parse the IDL ...
  49         my $file = $args{IDL} || OpenSRF::Utils::SettingsClient->new->config_value( 'IDL' );
  50         my $idl = XMLin( $file, ForceArray => 0, KeyAttr => ['name', 'key', 'id'] )->{class};
  51         for my $c ( keys %$idl ) {
  52                 next unless ($idl->{$c}{'oils_obj:fieldmapper'});
  53                 my $n = 'Fieldmapper::'.$idl->{$c}{'oils_obj:fieldmapper'};
  54
  55                 $log->debug("Building Fieldmapper clas for [$n] from IDL");
  56
  57                 $$fieldmap{$n}{hint} = $c;
  58                 $$fieldmap{$n}{virtual} = ($idl->{$c}{'oils_persist:virtual'} eq 'true') ? 1 : 0;
  59                 $$fieldmap{$n}{identity} = $idl->{$c}{fields}{'oils_persist:primary'};
  60
  61                 for my $f ( keys %{ $idl->{$c}{fields}{field} } ) {
  62                         $$fieldmap{$n}{fields}{$f} =
  63                                 { virtual => ($idl->{$c}{fields}{field}{$f}{'oils_persist:virtual'} eq 'true') ? 1 : 0,
  64                                   position => $idl->{$c}{fields}{field}{$f}{'oils_obj:array_position'},
  65                                 };
  66                 }
  67         }
  68
  69
  70         #-------------------------------------------------------------------------------
  71         # Now comes the evil!  Generate classes
  72
  73         for my $pkg ( __PACKAGE__->classes ) {
  74                 (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
  75
  76                 eval <<"                PERL";
  77                         package $pkg;
  78                         use base 'Fieldmapper';
  79                 PERL
  80
  81                 my $pos = 0;
  82                 for my $vfield ( qw/isnew ischanged isdeleted/ ) {
  83                         $$fieldmap{$pkg}{fields}{$vfield} = { position => $pos, virtual => 1 };
  84                         $pos++;
  85                 }
  86
  87                 if (exists $$fieldmap{$pkg}{proto_fields}) {
  88                         for my $pfield ( sort keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
  89                                 $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
  90                                 $pos++;
  91                         }
  92                 }
  93
  94                 JSON->register_class_hint(
  95                         hint => $pkg->json_hint,
  96                         name => $pkg,
  97                         type => 'array',
  98                 );
  99
 100         }
 101 }
 102
 103 sub new {
 104         my $self = shift;
 105         my $value = shift;
 106         $value = [] unless (defined $value);
 107         return bless $value => $self->class_name;
 108 }
 109
 110 sub decast {
 111         my $self = shift;
 112         return [ @$self ];
 113 }
 114
 115 sub DESTROY {}
 116
 117 sub AUTOLOAD {
 118         my $obj = shift;
 119         my $value = shift;
 120         (my $field = $AUTOLOAD) =~ s/^.*://o;
 121         my $class_name = $obj->class_name;
 122
 123         my $fpos = $field;
 124         $fpos  =~ s/^clear_//og ;
 125
 126         my $pos = $$fieldmap{$class_name}{fields}{$fpos}{position};
 127
 128         if ($field =~ /^clear_/o) {
 129                 {       no strict 'subs';
 130                         *{$obj->class_name."::$field"} = sub {
 131                                 my $self = shift;
 132                                 $self->[$pos] = undef;
 133                                 return 1;
 134                         };
 135                 }
 136                 return $obj->$field();
 137         }
 138
 139         die "No field by the name $field in $class_name!"
 140                 unless (exists $$fieldmap{$class_name}{fields}{$field} && defined($pos));
 141
 142
 143         {       no strict 'subs';
 144                 *{$obj->class_name."::$field"} = sub {
 145                         my $self = shift;
 146                         my $new_val = shift;
 147                         $self->[$pos] = $new_val if (defined $new_val);
 148                         return $self->[$pos];
 149                 };
 150         }
 151         return $obj->$field($value);
 152 }
 153
 154 sub Identity {
 155         my $class_name = shift;
 156         return $$fieldmap{$class_name}{identity};
 157 }
 158
 159 sub class_name {
 160         my $class_name = shift;
 161         return ref($class_name) || $class_name;
 162 }
 163
 164 sub real_fields {
 165         my $self = shift;
 166         my $class_name = $self->class_name;
 167         my $fields = $$fieldmap{$class_name}{fields};
 168
 169         my @f = grep {
 170                         !$$fields{$_}{virtual}
 171                 } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
 172
 173         return @f;
 174 }
 175
 176 sub has_field {
 177         my $self = shift;
 178         my $field = shift;
 179         my $class_name = $self->class_name;
 180         return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
 181         return 0;
 182 }
 183
 184 sub properties {
 185         my $self = shift;
 186         my $class_name = $self->class_name;
 187         return keys %{$$fieldmap{$class_name}{fields}};
 188 }
 189
 190 sub to_bare_hash {
 191         my $self = shift;
 192
 193         my %hash = ();
 194         for my $f ($self->properties) {
 195                 my $val = $self->$f;
 196                 $hash{$f} = $val;
 197         }
 198
 199         return \%hash;
 200 }
 201
 202 sub clone {
 203         my $self = shift;
 204         return $self->new( [@$self] );
 205 }
 206
 207 sub api_level {
 208         my $self = shift;
 209         return $fieldmap->{$self->class_name}->{api_level};
 210 }
 211
 212 sub cdbi {
 213         my $self = shift;
 214         return $fieldmap->{$self->class_name}->{cdbi};
 215 }
 216
 217 sub is_virtual {
 218         my $self = shift;
 219         my $field = shift;
 220         return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
 221         return $fieldmap->{$self->class_name}->{virtual};
 222 }
 223
 224 sub is_readonly {
 225         my $self = shift;
 226         my $field = shift;
 227         return $fieldmap->{$self->class_name}->{readonly};
 228 }
 229
 230 sub json_hint {
 231         my $self = shift;
 232         return $fieldmap->{$self->class_name}->{hint};
 233 }
 234
 235
 236 1;