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

   1 package Fieldmapper;
   2 use JSON;
   3 use Data::Dumper;
   4 use OpenILS::Application::Storage::CDBI;
   5 use OpenILS::Application::Storage::CDBI::actor;
   6 use OpenILS::Application::Storage::CDBI::biblio;
   7 use OpenILS::Application::Storage::CDBI::config;
   8 use OpenILS::Application::Storage::CDBI::metabib;
   9
  10 use vars qw/$fieldmap $VERSION/;
  11
  12 _init();
  13
  14 #
  15 # To dump the Javascript version of the fieldmapper struct use the command:
  16 #
  17 #       PERL5LIB=~/cvs/ILS/OpenSRF/src/perlmods/:~/cvs/ILS/Open-ILS/src/perlmods/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
  18 #
  19 # ... adjusted for your CVS sandbox, of course.
  20 #
  21
  22 sub classes {
  23         return () unless (defined $fieldmap);
  24         return keys %$fieldmap;
  25 }
  26
  27 sub _init {
  28         return if (defined $fieldmap);
  29
  30         $fieldmap =
  31         {
  32                 'Fieldmapper::actor::user'                      => { hint => 'au'   },
  33                 'Fieldmapper::actor::org_unit'                  => { hint => 'aou'  },
  34                 'Fieldmapper::actor::org_unit_type'             => { hint => 'aout' },
  35
  36                 'Fieldmapper::biblio::record_node'              => { hint               => 'brn',
  37                                                                      proto_fields       => { children => 1 } },
  38                 'Fieldmapper::biblio::record_entry'             => { hint => 'bre'  },
  39                 'Fieldmapper::biblio::record_mods'              => { hint => 'brm'  },
  40                 'Fieldmapper::biblio::record_marc'              => { hint => 'brx'  },
  41
  42                 'Fieldmapper::config::bib_source'               => { hint => 'cbs'  },
  43                 'Fieldmapper::config::metabib_field'            => { hint => 'cmf'  },
  44
  45                 'Fieldmapper::metabib::metarecord'              => { hint => 'mmr'  },
  46                 'Fieldmapper::metabib::title_field_entry'       => { hint => 'mtfe' },
  47                 'Fieldmapper::metabib::author_field_entry'      => { hint => 'mafe' },
  48                 'Fieldmapper::metabib::subject_field_entry'     => { hint => 'msfe' },
  49                 'Fieldmapper::metabib::keyword_field_entry'     => { hint => 'mkfe' },
  50                 'Fieldmapper::metabib::full_rec'                => { hint => 'mfr'  },
  51         };
  52
  53         #-------------------------------------------------------------------------------
  54         # Now comes the evil!  Generate classes
  55
  56         for my $pkg ( keys %$fieldmap ) {
  57                 (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
  58
  59                 eval <<"                PERL";
  60                         package $pkg;
  61                         use base 'Fieldmapper';
  62                 PERL
  63
  64                 $$fieldmapp{$pkg}{cdbi} = $cdbi;
  65
  66                 my $pos = 0;
  67                 for my $vfield ( qw/isnew ischanged isdeleted/ ) {
  68                         $$fieldmap{$pkg}{fields}{$vfield} = { position => $pos, virtual => 1 };
  69                         $pos++;
  70                 }
  71
  72                 if (exists $$fieldmap{$pkg}{proto_fields}) {
  73                         for my $pfield ( keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
  74                                 $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
  75                                 $pos++;
  76                         }
  77                 }
  78
  79                 for my $col ( $cdbi->columns('All') ) {
  80                         $$fieldmap{$pkg}{fields}{$col} = { position => $pos, virtual => 0 };
  81                         $pos++;
  82                 }
  83
  84                 JSON->register_class_hint(
  85                         hint => $pkg->json_hint,
  86                         name => $pkg,
  87                         type => 'array',
  88                 );
  89
  90         }
  91
  92         print Fieldmapper->javascript() if ($ENV{GEN_JS});
  93 }
  94
  95 sub new {
  96         my $self = shift;
  97         my $value = shift;
  98         $value = [] unless (defined $value);
  99         return bless $value => $self->class_name;
 100 }
 101
 102 sub javascript {
 103         my $class_name = shift;
 104         return 'var fieldmap = ' . JSON->perl2JSON($fieldmap) . ';'
 105 }
 106
 107 sub DESTROY {}
 108
 109 sub AUTOLOAD {
 110         my $obj = shift;
 111         my $value = shift;
 112         (my $field = $AUTOLOAD) =~ s/^.*://o;
 113         my $class_name = $obj->class_name;
 114
 115
 116         if ($field =~ /^clear_/o) {
 117                 {       no strict 'subs';
 118                         *{$obj->class_name."::$field"} = sub {
 119                                 my $self = shift;
 120                                 $self->[$pos] = undef;
 121                                 return 1;
 122                         };
 123                 }
 124                 return $obj->$field();
 125         }
 126
 127         die "No field by the name $field in $class_name!"
 128                 unless (exists $$fieldmap{$class_name}{fields}{$field});
 129
 130         my $pos = $$fieldmap{$class_name}{fields}{$field}{position};
 131
 132         {       no strict 'subs';
 133                 *{$obj->class_name."::$field"} = sub {
 134                         my $self = shift;
 135                         my $new_val = shift;
 136                         $self->[$pos] = $new_val if (defined $new_val);
 137                         return $self->[$pos];
 138                 };
 139         }
 140         return $obj->$field($value);
 141 }
 142
 143 sub class_name {
 144         my $class_name = shift;
 145         return ref($class_name) || $class_name;
 146 }
 147
 148 sub real_fields {
 149         my $self = shift;
 150         my $class_name = $self->class_name;
 151         my $fields = $$fieldmap{$class_name}{fields};
 152
 153         my @f = grep {
 154                         !$$fields{$_}{virtual}
 155                 } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
 156
 157         return @f;
 158 }
 159
 160 sub api_level {
 161         my $self = shift;
 162         return $fieldmap->{$self->class_name}->{api_level};
 163 }
 164
 165 sub json_hint {
 166         my $self = shift;
 167         return $fieldmap->{$self->class_name}->{hint};
 168 }
 169
 170
 171 1;