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

   1 package Fieldmapper;
   2 use OpenSRF::Utils::JSON;
   3 use Data::Dumper;
   4 use OpenSRF::Utils::Logger;
   5 use OpenSRF::Utils::SettingsClient;
   6 use OpenSRF::System;
   7 use XML::LibXML;
   8 use Scalar::Util 'blessed';
   9
  10 my $log = 'OpenSRF::Utils::Logger';
  11
  12 use vars qw/$fieldmap $VERSION/;
  13
  14 #
  15 # To dump the Javascript version of the fieldmapper struct use the command:
  16 #
  17 #   PERL5LIB=:~/vcs/ILS/Open-ILS/src/perlmods/lib/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
  18 #
  19 # ... adjusted for your VCS sandbox of choice, of course.
  20 #
  21
  22 sub classes {
  23     return () unless (defined $fieldmap);
  24     return keys %$fieldmap;
  25 }
  26
  27 # Find a Fieldmapper class given the json hint.
  28 sub class_for_hint {
  29     my $hint = shift;
  30     foreach (keys %$fieldmap) {
  31         return $_ if ($fieldmap->{$_}->{hint} eq $hint);
  32     }
  33     return undef;
  34 }
  35
  36 sub get_attribute {
  37     my $attr_list = shift;
  38     my $attr_name = shift;
  39
  40     my $attr = $attr_list->getNamedItem( $attr_name );
  41     if( defined( $attr ) ) {
  42         return $attr->getValue();
  43     }
  44     return undef;
  45 }
  46
  47 sub load_fields {
  48     my $field_list = shift;
  49     my $fm = shift;
  50
  51     # Get attributes of the field list.  Since there is only one
  52     # <field> per class, these attributes logically belong to the
  53     # enclosing class, and that's where we load them.
  54
  55     my $field_attr_list = $field_list->attributes();
  56
  57     my $sequence  = get_attribute( $field_attr_list, 'oils_persist:sequence' );
  58     if( ! defined( $sequence ) ) {
  59         $sequence = '';
  60     }
  61     my $primary   = get_attribute( $field_attr_list, 'oils_persist:primary' );
  62
  63     # Load attributes into the Fieldmapper ----------------------
  64
  65     $$fieldmap{$fm}{ sequence } = $sequence;
  66     $$fieldmap{$fm}{ identity } = $primary;
  67
  68     # Load each field -------------------------------------------
  69
  70     my $array_position = 0;
  71     for my $field ( $field_list->childNodes() ) {    # For each <field>
  72         if( $field->nodeName eq 'field' ) {
  73
  74             my $attribute_list = $field->attributes();
  75
  76             my $name     = get_attribute( $attribute_list, 'name' );
  77             next if( $name eq 'isnew' || $name eq 'ischanged' || $name eq 'isdeleted' );
  78             my $required  = get_attribute( $attribute_list, 'oils_obj:required' ) || "false";
  79             my $validate  = get_attribute( $attribute_list, 'oils_obj:validate' );
  80             my $virtual  = get_attribute( $attribute_list, 'oils_persist:virtual' );
  81             if( ! defined( $virtual ) ) {
  82                 $virtual = "false";
  83             }
  84             my $selector = get_attribute( $attribute_list, 'reporter:selector' );
  85             my $datatype = get_attribute( $attribute_list, 'reporter:datatype' );
  86
  87             $$fieldmap{$fm}{fields}{ $name } =
  88                 { virtual => ( $virtual eq 'true' ) ? 1 : 0,
  89                   required => ( $required eq 'true' ) ? 1 : 0,
  90                   position => $array_position,
  91                   datatype => $datatype,
  92                 };
  93
  94             $$fieldmap{$fm}{fields}{ $name }{validate} = qr/$validate/ if (defined($validate));
  95
  96             # The selector attribute, if present at all, attaches to only one
  97             # of the fields in a given class.  So if we see it, we store it at
  98             # the level of the enclosing class.
  99
 100             if( defined( $selector ) ) {
 101                 $$fieldmap{$fm}{selector} = $selector;
 102             }
 103
 104             ++$array_position;
 105         }
 106     }
 107
 108     # Load the standard 3 virtual fields ------------------------
 109
 110     for my $vfield ( qw/isnew ischanged isdeleted/ ) {
 111         $$fieldmap{$fm}{fields}{ $vfield } =
 112             { position => $array_position,
 113               virtual => 1
 114             };
 115         ++$array_position;
 116     }
 117 }
 118
 119 sub load_links {
 120     my $link_list = shift;
 121     my $fm = shift;
 122
 123     for my $link ( $link_list->childNodes() ) {    # For each <link>
 124         if( $link->nodeName eq 'link' ) {
 125             my $attribute_list = $link->attributes();
 126
 127             my $field   = get_attribute( $attribute_list, 'field' );
 128             my $reltype = get_attribute( $attribute_list, 'reltype' );
 129             my $key     = get_attribute( $attribute_list, 'key' );
 130             my $class   = get_attribute( $attribute_list, 'class' );
 131             my $map     = get_attribute( $attribute_list, 'map' );
 132
 133             $$fieldmap{$fm}{links}{ $field } =
 134                 { class   => $class,
 135                   reltype => $reltype,
 136                   key     => $key,
 137                   map     => $map
 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 toXML {
 325     my $self = shift;
 326     return undef unless (ref $self);
 327
 328     my $opts = shift || {};
 329     my $no_virt = $$opts{no_virt}; # skip virtual fields
 330     my $skip_fields = $$opts{skip_fields} || {}; # eg. {au => ['passwd']}
 331     my @to_skip = @{$$skip_fields{$self->json_hint}}
 332         if $$skip_fields{$self->json_hint};
 333
 334     my $dom = XML::LibXML::Document->new;
 335     my $root = $dom->createElement( $self->json_hint );
 336     $dom->setDocumentElement( $root );
 337
 338     my @field_names = $no_virt ? $self->real_fields : $self->properties;
 339
 340     for my $f (@field_names) {
 341         next if ($f eq 'isnew');
 342         next if ($f eq 'ischanged');
 343         next if ($f eq 'isdeleted');
 344         next if (grep {$_ eq $f} @to_skip);
 345
 346         my $value = $self->$f();
 347         my $element = $dom->createElement( $f );
 348
 349         $value = [$value] if (blessed($value)); # fm object
 350
 351         if (ref($value)) { # array
 352             for my $k (@$value) {
 353                 if (blessed($k)) {
 354                     my $subdoc = $k->toXML($opts);
 355                     next unless $subdoc;
 356                     my $subnode = $subdoc->documentElement;
 357                     $dom->adoptNode($subnode);
 358                     $element->appendChild($subnode);
 359                 } elsif (ref $k) { # not sure what to do here
 360                     $element->appendText($k);
 361                 } else { # meh .. just append, I guess
 362                     $element->appendText($k);
 363                 }
 364             }
 365         } else {
 366             $element->appendText($value);
 367         }
 368
 369         $root->appendChild($element);
 370     }
 371
 372     return $dom;
 373 }
 374
 375 sub ValidateField {
 376     my $self = shift;
 377     my $f = shift;
 378     return undef unless ($f);
 379     return 1 if (!exists($$fieldmap{$self->class_name}{fields}{$f}{validate}));
 380     return $self->$f =~ $$fieldmap{$self->class_name}{fields}{$f}{validate};
 381 }
 382
 383 sub FieldInfo {
 384     my $self = shift;
 385     my $field = shift;
 386     my $class_name = $self->class_name;
 387     return undef unless ($field && $$fieldmap{$class_name}{fields}{$field});
 388     return $$fieldmap{$class_name}{fields}{$field};
 389 }
 390
 391 sub FieldDatatype {
 392     my $self = shift;
 393     my $field = shift;
 394     my $class_name = $self->class_name;
 395     return undef unless ($field && $$fieldmap{$class_name}{fields}{$field});
 396     return $$fieldmap{$class_name}{fields}{$field}{datatype};
 397 }
 398
 399 sub class_name {
 400     my $class_name = shift;
 401     return ref($class_name) || $class_name;
 402 }
 403
 404 sub real_fields {
 405     my $self = shift;
 406     my $class_name = $self->class_name;
 407     my $fields = $$fieldmap{$class_name}{fields};
 408
 409     my @f = grep {
 410             !$$fields{$_}{virtual}
 411         } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
 412
 413     return @f;
 414 }
 415
 416 sub has_field {
 417     my $self = shift;
 418     my $field = shift;
 419     my $class_name = $self->class_name;
 420     return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
 421     return 0;
 422 }
 423
 424 sub properties {
 425     my $self = shift;
 426     my $class_name = $self->class_name;
 427     return keys %{$$fieldmap{$class_name}{fields}};
 428 }
 429
 430 sub to_bare_hash {
 431     my $self = shift;
 432
 433     my %hash = ();
 434     for my $f ($self->properties) {
 435         my $val = $self->$f;
 436         $hash{$f} = $val;
 437     }
 438
 439     return \%hash;
 440 }
 441
 442 sub clone {
 443     my $self = shift;
 444     return $self->new( [@$self] );
 445 }
 446
 447 sub api_level {
 448     my $self = shift;
 449     return $fieldmap->{$self->class_name}->{api_level};
 450 }
 451
 452 sub cdbi {
 453     my $self = shift;
 454     return $fieldmap->{$self->class_name}->{cdbi};
 455 }
 456
 457 sub is_virtual {
 458     my $self = shift;
 459     my $field = shift;
 460     return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
 461     return $fieldmap->{$self->class_name}->{virtual};
 462 }
 463
 464 sub is_readonly {
 465     my $self = shift;
 466     my $field = shift;
 467     return $fieldmap->{$self->class_name}->{readonly};
 468 }
 469
 470 sub json_hint {
 471     my $self = shift;
 472     return $fieldmap->{$self->class_name}->{hint};
 473 }
 474
 475
 476 1;