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

   1 package Fieldmapper;
   2 use OpenSRF::Utils::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', 'id'], ValueAttr => {link =>'key'} )->{class};
  51         my $idl = XMLin( $file, ForceArray => 0, KeyAttr => ['name', 'id', 'field'] )->{class};
  52
  53         for my $c ( keys %$idl ) {
  54                 next unless ($idl->{$c}{'oils_obj:fieldmapper'});
  55                 my $n = 'Fieldmapper::'.$idl->{$c}{'oils_obj:fieldmapper'};
  56
  57                 $log->debug("Building Fieldmapper class for [$n] from IDL");
  58
  59                 $$fieldmap{$n}{hint} = $c;
  60                 $$fieldmap{$n}{virtual} = ($idl->{$c}{'oils_persist:virtual'} && $idl->{$c}{'oils_persist:virtual'} eq 'true') ? 1 : 0;
  61                 $$fieldmap{$n}{table} = $idl->{$c}{'oils_persist:tablename'};
  62                 $$fieldmap{$n}{controller} = [ split ' ', $idl->{$c}{'controller'} ];
  63                 $$fieldmap{$n}{restrict_primary} = $idl->{$c}{'oils_persist:restrict_primary'};
  64                 $$fieldmap{$n}{sequence} = $idl->{$c}{fields}{'oils_persist:sequence'};
  65                 $$fieldmap{$n}{identity} = $idl->{$c}{fields}{'oils_persist:primary'};
  66
  67                 for my $f ( keys %{ $idl->{$c}{fields}{field} } ) {
  68                         $$fieldmap{$n}{fields}{$f} =
  69                                 { virtual => ($idl->{$c}{fields}{field}{$f}{'oils_persist:virtual'} eq 'true') ? 1 : 0,
  70                                   position => $idl->{$c}{fields}{field}{$f}{'oils_obj:array_position'},
  71                                 };
  72
  73                         if ($idl->{$c}{fields}{field}{$f}{'reporter:selector'}) {
  74                                 $$fieldmap{$n}{selector} = $idl->{$c}{fields}{field}{$f}{'reporter:selector'};
  75                         }
  76                 }
  77                 for my $f ( keys %{ $idl->{$c}{links}{link} } ) {
  78                         $$fieldmap{$n}{links}{$f} =
  79                                 { class => $idl->{$c}{links}{link}{$f}{class},
  80                                   reltype => $idl->{$c}{links}{link}{$f}{reltype},
  81                                   key => $idl->{$c}{links}{link}{$f}{key},
  82                                 };
  83                 }
  84         }
  85
  86
  87         #-------------------------------------------------------------------------------
  88         # Now comes the evil!  Generate classes
  89
  90         for my $pkg ( __PACKAGE__->classes ) {
  91                 (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
  92
  93                 eval <<"                PERL";
  94                         package $pkg;
  95                         use base 'Fieldmapper';
  96                 PERL
  97
  98                 my $pos = 0;
  99                 for my $vfield ( qw/isnew ischanged isdeleted/ ) {
 100                         $$fieldmap{$pkg}{fields}{$vfield} = { position => $pos, virtual => 1 };
 101                         $pos++;
 102                 }
 103
 104                 if (exists $$fieldmap{$pkg}{proto_fields}) {
 105                         for my $pfield ( sort keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
 106                                 $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
 107                                 $pos++;
 108                         }
 109                 }
 110
 111                 OpenSRF::Utils::JSON->register_class_hint(
 112                         hint => $pkg->json_hint,
 113                         name => $pkg,
 114                         type => 'array',
 115                 );
 116
 117         }
 118 }
 119
 120 sub new {
 121         my $self = shift;
 122         my $value = shift;
 123         $value = [] unless (defined $value);
 124         return bless $value => $self->class_name;
 125 }
 126
 127 sub decast {
 128         my $self = shift;
 129         return [ @$self ];
 130 }
 131
 132 sub DESTROY {}
 133
 134 sub AUTOLOAD {
 135         my $obj = shift;
 136         my $value = shift;
 137         (my $field = $AUTOLOAD) =~ s/^.*://o;
 138         my $class_name = $obj->class_name;
 139
 140         my $fpos = $field;
 141         $fpos  =~ s/^clear_//og ;
 142
 143         my $pos = $$fieldmap{$class_name}{fields}{$fpos}{position};
 144
 145         if ($field =~ /^clear_/o) {
 146                 {       no strict 'subs';
 147                         *{$obj->class_name."::$field"} = sub {
 148                                 my $self = shift;
 149                                 $self->[$pos] = undef;
 150                                 return 1;
 151                         };
 152                 }
 153                 return $obj->$field();
 154         }
 155
 156         die "No field by the name $field in $class_name!"
 157                 unless (exists $$fieldmap{$class_name}{fields}{$field} && defined($pos));
 158
 159
 160         {       no strict 'subs';
 161                 *{$obj->class_name."::$field"} = sub {
 162                         my $self = shift;
 163                         my $new_val = shift;
 164                         $self->[$pos] = $new_val if (defined $new_val);
 165                         return $self->[$pos];
 166                 };
 167         }
 168         return $obj->$field($value);
 169 }
 170
 171 sub Selector {
 172         my $self = shift;
 173         return $$fieldmap{$self->class_name}{selector};
 174 }
 175
 176 sub Identity {
 177         my $self = shift;
 178         return $$fieldmap{$self->class_name}{identity};
 179 }
 180
 181 sub RestrictPrimary {
 182         my $self = shift;
 183         return $$fieldmap{$self->class_name}{restrict_primary};
 184 }
 185
 186 sub Sequence {
 187         my $self = shift;
 188         return $$fieldmap{$self->class_name}{sequence};
 189 }
 190
 191 sub Table {
 192         my $self = shift;
 193         return $$fieldmap{$self->class_name}{table};
 194 }
 195
 196 sub Controller {
 197         my $self = shift;
 198         return $$fieldmap{$self->class_name}{controller};
 199 }
 200
 201 sub class_name {
 202         my $class_name = shift;
 203         return ref($class_name) || $class_name;
 204 }
 205
 206 sub real_fields {
 207         my $self = shift;
 208         my $class_name = $self->class_name;
 209         my $fields = $$fieldmap{$class_name}{fields};
 210
 211         my @f = grep {
 212                         !$$fields{$_}{virtual}
 213                 } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
 214
 215         return @f;
 216 }
 217
 218 sub has_field {
 219         my $self = shift;
 220         my $field = shift;
 221         my $class_name = $self->class_name;
 222         return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
 223         return 0;
 224 }
 225
 226 sub properties {
 227         my $self = shift;
 228         my $class_name = $self->class_name;
 229         return keys %{$$fieldmap{$class_name}{fields}};
 230 }
 231
 232 sub to_bare_hash {
 233         my $self = shift;
 234
 235         my %hash = ();
 236         for my $f ($self->properties) {
 237                 my $val = $self->$f;
 238                 $hash{$f} = $val;
 239         }
 240
 241         return \%hash;
 242 }
 243
 244 sub clone {
 245         my $self = shift;
 246         return $self->new( [@$self] );
 247 }
 248
 249 sub api_level {
 250         my $self = shift;
 251         return $fieldmap->{$self->class_name}->{api_level};
 252 }
 253
 254 sub cdbi {
 255         my $self = shift;
 256         return $fieldmap->{$self->class_name}->{cdbi};
 257 }
 258
 259 sub is_virtual {
 260         my $self = shift;
 261         my $field = shift;
 262         return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
 263         return $fieldmap->{$self->class_name}->{virtual};
 264 }
 265
 266 sub is_readonly {
 267         my $self = shift;
 268         my $field = shift;
 269         return $fieldmap->{$self->class_name}->{readonly};
 270 }
 271
 272 sub json_hint {
 273         my $self = shift;
 274         return $fieldmap->{$self->class_name}->{hint};
 275 }
 276
 277
 278 1;