Open-ILS/src/perlmods/lib/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::LibXML;
   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=:~/vcs/ILS/Open-ILS/src/perlmods/lib/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
  31 #
  32 # ... adjusted for your VCS sandbox of choice, of course.
  33 #
  34
  35 sub classes {
  36         return () unless (defined $fieldmap);
  37         return keys %$fieldmap;
  38 }
  39
  40 sub get_attribute {
  41         my $attr_list = shift;
  42         my $attr_name = shift;
  43
  44         my $attr = $attr_list->getNamedItem( $attr_name );
  45         if( defined( $attr ) ) {
  46                 return $attr->getValue();
  47         }
  48         return undef;
  49 }
  50
  51 sub load_fields {
  52         my $field_list = shift;
  53         my $fm = shift;
  54
  55         # Get attributes of the field list.  Since there is only one
  56         # <field> per class, these attributes logically belong to the
  57         # enclosing class, and that's where we load them.
  58
  59         my $field_attr_list = $field_list->attributes();
  60
  61         my $sequence  = get_attribute( $field_attr_list, 'oils_persist:sequence' );
  62         if( ! defined( $sequence ) ) {
  63                 $sequence = '';
  64         }
  65         my $primary   = get_attribute( $field_attr_list, 'oils_persist:primary' );
  66
  67         # Load attributes into the Fieldmapper ----------------------
  68
  69         $$fieldmap{$fm}{ sequence } = $sequence;
  70         $$fieldmap{$fm}{ identity } = $primary;
  71
  72         # Load each field -------------------------------------------
  73
  74         my $array_position = 0;
  75         for my $field ( $field_list->childNodes() ) {    # For each <field>
  76                 if( $field->nodeName eq 'field' ) {
  77
  78                         my $attribute_list = $field->attributes();
  79
  80                         my $name     = get_attribute( $attribute_list, 'name' );
  81                         next if( $name eq 'isnew' || $name eq 'ischanged' || $name eq 'isdeleted' );
  82                         my $required  = get_attribute( $attribute_list, 'oils_obj:required' );
  83                         my $validate  = get_attribute( $attribute_list, 'oils_obj:validate' );
  84                         my $virtual  = get_attribute( $attribute_list, 'oils_persist:virtual' );
  85                         if( ! defined( $virtual ) ) {
  86                                 $virtual = "false";
  87                         }
  88                         my $selector = get_attribute( $attribute_list, 'reporter:selector' );
  89
  90                         $$fieldmap{$fm}{fields}{ $name } =
  91                                 { virtual => ( $virtual eq 'true' ) ? 1 : 0,
  92                                   required => ( $required eq 'true' ) ? 1 : 0,
  93                                   position => $array_position,
  94                                 };
  95
  96                         $$fieldmap{$fm}{fields}{ $name }{validate} = qr/$validate/ if (defined($validate));
  97
  98                         # The selector attribute, if present at all, attaches to only one
  99                         # of the fields in a given class.  So if we see it, we store it at
 100                         # the level of the enclosing class.
 101
 102                         if( defined( $selector ) ) {
 103                                 $$fieldmap{$fm}{selector} = $selector;
 104                         }
 105
 106                         ++$array_position;
 107                 }
 108         }
 109
 110         # Load the standard 3 virtual fields ------------------------
 111
 112         for my $vfield ( qw/isnew ischanged isdeleted/ ) {
 113                 $$fieldmap{$fm}{fields}{ $vfield } =
 114                         { position => $array_position,
 115                           virtual => 1
 116                         };
 117                 ++$array_position;
 118         }
 119 }
 120
 121 sub load_links {
 122         my $link_list = shift;
 123         my $fm = shift;
 124
 125         for my $link ( $link_list->childNodes() ) {    # For each <link>
 126                 if( $link->nodeName eq 'link' ) {
 127                         my $attribute_list = $link->attributes();
 128
 129                         my $field   = get_attribute( $attribute_list, 'field' );
 130                         my $reltype = get_attribute( $attribute_list, 'reltype' );
 131                         my $key     = get_attribute( $attribute_list, 'key' );
 132                         my $class   = get_attribute( $attribute_list, 'class' );
 133
 134                         $$fieldmap{$fm}{links}{ $field } =
 135                                 { class   => $class,
 136                                   reltype => $reltype,
 137                                   key     => $key,
 138                                 };
 139                 }
 140         }
 141 }
 142
 143 sub load_class {
 144         my $class_node = shift;
 145
 146         # Get attributes ---------------------------------------------
 147
 148         my $attribute_list = $class_node->attributes();
 149
 150         my $fm               = get_attribute( $attribute_list, 'oils_obj:fieldmapper' );
 151         $fm                  = 'Fieldmapper::' . $fm;
 152         my $id               = get_attribute( $attribute_list, 'id' );
 153         my $controller       = get_attribute( $attribute_list, 'controller' );
 154         my $virtual          = get_attribute( $attribute_list, 'virtual' );
 155         if( ! defined( $virtual ) ) {
 156                 $virtual = 'false';
 157         }
 158         my $tablename        = get_attribute( $attribute_list, 'oils_persist:tablename' );
 159         if( ! defined( $tablename ) ) {
 160                 $tablename = '';
 161         }
 162         my $restrict_primary = get_attribute( $attribute_list, 'oils_persist:restrict_primary' );
 163         my $field_safe = get_attribute( $attribute_list, 'oils_persist:field_safe' );
 164
 165         # Load the attributes into the Fieldmapper --------------------
 166
 167         $log->debug("Building Fieldmapper class for [$fm] from IDL");
 168
 169         $$fieldmap{$fm}{ hint }             = $id;
 170         $$fieldmap{$fm}{ virtual }          = ( $virtual eq 'true' ) ? 1 : 0;
 171         $$fieldmap{$fm}{ table }            = $tablename;
 172         $$fieldmap{$fm}{ controller }       = [ split ' ', $controller ];
 173         $$fieldmap{$fm}{ restrict_primary } = $restrict_primary;
 174         $$fieldmap{$fm}{ field_safe }       = $field_safe;
 175
 176         # Load fields and links
 177
 178         for my $child ( $class_node->childNodes() ) {
 179                 my $nodeName = $child->nodeName;
 180                 if( $nodeName eq 'fields' ) {
 181                         load_fields( $child, $fm );
 182                 } elsif( $nodeName eq 'links' ) {
 183                         load_links( $child, $fm );
 184                 }
 185         }
 186 }
 187
 188 import();
 189 sub import {
 190         my $class = shift;
 191         my %args = @_;
 192
 193         return if (keys %$fieldmap);
 194         return if (!OpenSRF::System->connected && !$args{IDL});
 195
 196         # parse the IDL ...
 197         my $parser = XML::LibXML->new();
 198         my $file = $args{IDL} || OpenSRF::Utils::SettingsClient->new->config_value( 'IDL' );
 199         my $fmdoc = $parser->parse_file( $file );
 200         my $rootnode = $fmdoc->documentElement();
 201
 202         for my $child ( $rootnode->childNodes() ) {    # For each <class>
 203                 my $nodeName = $child->nodeName;
 204                 if( $nodeName eq 'class' ) {
 205                         load_class( $child );
 206                 }
 207         }
 208
 209         #-------------------------------------------------------------------------------
 210         # Now comes the evil!  Generate classes
 211
 212         for my $pkg ( __PACKAGE__->classes ) {
 213                 (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
 214
 215                 eval <<"                PERL";
 216                         package $pkg;
 217                         use base 'Fieldmapper';
 218                 PERL
 219
 220                 if (exists $$fieldmap{$pkg}{proto_fields}) {
 221                         for my $pfield ( sort keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
 222                                 $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
 223                                 $pos++;
 224                         }
 225                 }
 226
 227                 OpenSRF::Utils::JSON->register_class_hint(
 228                         hint => $pkg->json_hint,
 229                         name => $pkg,
 230                         type => 'array',
 231                 );
 232
 233         }
 234 }
 235
 236 sub new {
 237         my $self = shift;
 238         my $value = shift;
 239         $value = [] unless (defined $value);
 240         return bless $value => $self->class_name;
 241 }
 242
 243 sub decast {
 244         my $self = shift;
 245         return [ @$self ];
 246 }
 247
 248 sub DESTROY {}
 249
 250 sub AUTOLOAD {
 251         my $obj = shift;
 252         my $value = shift;
 253         (my $field = $AUTOLOAD) =~ s/^.*://o;
 254         my $class_name = $obj->class_name;
 255
 256         my $fpos = $field;
 257         $fpos  =~ s/^clear_//og ;
 258
 259         my $pos = $$fieldmap{$class_name}{fields}{$fpos}{position};
 260
 261         if ($field =~ /^clear_/o) {
 262                 {       no strict 'subs';
 263                         *{$obj->class_name."::$field"} = sub {
 264                                 my $self = shift;
 265                                 $self->[$pos] = undef;
 266                                 return 1;
 267                         };
 268                 }
 269                 return $obj->$field();
 270         }
 271
 272         die "No field by the name $field in $class_name!"
 273                 unless (exists $$fieldmap{$class_name}{fields}{$field} && defined($pos));
 274
 275
 276         {       no strict 'subs';
 277                 *{$obj->class_name."::$field"} = sub {
 278                         my $self = shift;
 279                         my $new_val = shift;
 280                         $self->[$pos] = $new_val if (defined $new_val);
 281                         return $self->[$pos];
 282                 };
 283         }
 284         return $obj->$field($value);
 285 }
 286
 287 sub Selector {
 288         my $self = shift;
 289         return $$fieldmap{$self->class_name}{selector};
 290 }
 291
 292 sub Identity {
 293         my $self = shift;
 294         return $$fieldmap{$self->class_name}{identity};
 295 }
 296
 297 sub RestrictPrimary {
 298         my $self = shift;
 299         return $$fieldmap{$self->class_name}{restrict_primary};
 300 }
 301
 302 sub Sequence {
 303         my $self = shift;
 304         return $$fieldmap{$self->class_name}{sequence};
 305 }
 306
 307 sub Table {
 308         my $self = shift;
 309         return $$fieldmap{$self->class_name}{table};
 310 }
 311
 312 sub Controller {
 313         my $self = shift;
 314         return $$fieldmap{$self->class_name}{controller};
 315 }
 316
 317 sub RequiredField {
 318         my $self = shift;
 319         my $f = shift;
 320     return undef unless ($f);
 321         return $$fieldmap{$self->class_name}{fields}{$f}{required};
 322 }
 323
 324 sub ValidateField {
 325         my $self = shift;
 326         my $f = shift;
 327     return undef unless ($f);
 328         return 1 if (!exists($$fieldmap{$self->class_name}{fields}{$f}{validate}));
 329         return $self->$f =~ $$fieldmap{$self->class_name}{fields}{$f}{validate};
 330 }
 331
 332 sub class_name {
 333         my $class_name = shift;
 334         return ref($class_name) || $class_name;
 335 }
 336
 337 sub real_fields {
 338         my $self = shift;
 339         my $class_name = $self->class_name;
 340         my $fields = $$fieldmap{$class_name}{fields};
 341
 342         my @f = grep {
 343                         !$$fields{$_}{virtual}
 344                 } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
 345
 346         return @f;
 347 }
 348
 349 sub has_field {
 350         my $self = shift;
 351         my $field = shift;
 352         my $class_name = $self->class_name;
 353         return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
 354         return 0;
 355 }
 356
 357 sub properties {
 358         my $self = shift;
 359         my $class_name = $self->class_name;
 360         return keys %{$$fieldmap{$class_name}{fields}};
 361 }
 362
 363 sub to_bare_hash {
 364         my $self = shift;
 365
 366         my %hash = ();
 367         for my $f ($self->properties) {
 368                 my $val = $self->$f;
 369                 $hash{$f} = $val;
 370         }
 371
 372         return \%hash;
 373 }
 374
 375 sub clone {
 376         my $self = shift;
 377         return $self->new( [@$self] );
 378 }
 379
 380 sub api_level {
 381         my $self = shift;
 382         return $fieldmap->{$self->class_name}->{api_level};
 383 }
 384
 385 sub cdbi {
 386         my $self = shift;
 387         return $fieldmap->{$self->class_name}->{cdbi};
 388 }
 389
 390 sub is_virtual {
 391         my $self = shift;
 392         my $field = shift;
 393         return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
 394         return $fieldmap->{$self->class_name}->{virtual};
 395 }
 396
 397 sub is_readonly {
 398         my $self = shift;
 399         my $field = shift;
 400         return $fieldmap->{$self->class_name}->{readonly};
 401 }
 402
 403 sub json_hint {
 404         my $self = shift;
 405         return $fieldmap->{$self->class_name}->{hint};
 406 }
 407
 408
 409 1;