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