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