first cut of ScriptRunner absorbtion of O::U::SM; readonly flag for insert; eating...
[Evergreen.git] / Open-ILS / src / perlmods / OpenILS / Utils / SpiderMonkey.pm
1 package OpenILS::Utils::SpiderMonkey;
2 use strict; use warnings;
3 use OpenSRF::Utils::Logger qw(:logger);
4 use OpenSRF::EX qw(:try);
5 use OpenILS::Utils::ScriptRunner;
6 use base 'OpenILS::Utils::ScriptRunner';
7 use JavaScript::SpiderMonkey;
8 use LWP::UserAgent;
9 use XML::LibXML;
10 use Time::HiRes qw/time/;
11 use vars qw/%_paths/;
12
13 sub new {
14         my ( $class, %params ) = @_;
15         $class = ref($class) || $class;
16         $params{paths} ||= [];
17
18         my $self = { file => $params{file}, libs => $params{libs}, _path => {%_paths} };
19         bless( $self, $class );
20
21         $self->add_path($_) for @{$params{paths}};
22         return $self;
23 }
24
25 sub context {
26         my( $self, $context ) = @_;
27         $self->{ctx} = $context if $context;
28         return $self->{ctx};
29 }
30
31 sub init {
32         my $self = shift;
33         my $js = JavaScript::SpiderMonkey->new();
34         $js->init();
35
36         $js->function_set(perl_print    => sub { print "@_\n"; } );
37         $js->function_set(perl_warn     => sub { warn @_; } );
38         $js->function_set(log_activity  => sub { $logger->activity(@_); return 1;} );
39         $js->function_set(log_error     => sub { $logger->error(@_); return 1;} );
40         $js->function_set(log_warn      => sub { $logger->warn(@_); return 1;} );
41         $js->function_set(log_info      => sub { $logger->info(@_); return 1;} );
42         $js->function_set(log_debug     => sub { $logger->debug(@_); return 1;} );
43         $js->function_set(log_internal  => sub { $logger->internal(@_); return 1;} );
44         $js->function_set(debug         => sub { $logger->debug(@_); return 1;} );
45         $js->function_set(alert         => sub { $logger->warn(@_); return 1;} );
46         
47         $js->function_set(load_lib      => sub { $self->load_lib(@_); });
48
49         # XML support functions
50         $js->function_set(
51                 _OILS_FUNC_xmlhttprequest_send  => sub { $self->_xmlhttprequest_send(@_); });
52         $js->function_set(
53                 _OILS_FUNC_xml_parse_string     => sub { $self->_parse_xml_string(@_); });
54         
55         $self->context($js);
56         $self->load_lib($_) for @{$self->{libs}};
57
58         return $self;
59 }
60
61
62 sub load {
63         my( $self, $filename ) = @_;
64         $self->{file} = $filename;
65 }
66
67 sub run {
68         my $self = shift;
69         my $file = shift() || $self->{file};
70         my $js = $self->context;
71
72         $file = $self->_find_file($file);
73
74         if( ! open(F, $file) ) {
75                 $logger->error("Error opening script file: $file");
76                 return 0;
77         }
78
79         {       local $/ = undef;
80                 my $content = <F>;
81                 my $s = time();
82                 if( !$js || !$content || !$js->eval($content) ) {
83                         $logger->error("$file Eval failed: $@");  
84                         return 0;
85                 }
86                 $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
87         }
88
89         close(F);
90         return 1;
91 }
92
93 sub remove_path { 
94         my( $self, $path ) = @_;
95         if (ref($self)) {
96                 if ($self->{_path}{$path}) {
97                         $self->{_path}{$path} = 0;
98                 }
99                 return $self->{_path}{$path};
100         } else {
101                 if ($_paths{$path}) {
102                         $_paths{$path} = 0;
103                 }
104                 return $_paths{$path};
105         }
106 }
107
108 sub add_path { 
109         my( $self, $path ) = @_;
110         if (ref($self)) {
111                 if (!$self->{_path}{$path}) {
112                         $self->{_path}{$path} = 1;
113                 }
114         } else {
115                 if (!$_paths{$path}) {
116                         $_paths{$path} = 1;
117                 }
118         }
119         return $self;
120 }
121
122 sub _find_file {
123         my $self = shift;
124         my $file = shift;
125         for my $p ( keys %{ $self->{_path} } ) {
126                 next unless ($self->{_path}{$p});
127                 my $full = join('/',$p,$file);
128                 return $full if (-e $full);
129         }
130 }
131
132 sub load_lib { 
133         my( $self, $file ) = @_;
134         if (!$self->{_loaded}{$file} && $self->run( $file )) {
135                 $self->{_loaded}{$file} = 1;
136         }
137         return $self->{_loaded}{$file};
138 }
139
140 sub _js_prop_name {
141         my $name = shift;
142         $name =~ s/^.*\.//o;
143         return $name;
144 }
145
146 sub retrieve {
147         my( $self, $key ) = @_;
148         return $self->context->property_get($key);
149 }
150
151 sub insert_method {
152         my( $self, $obj_key, $meth_name, $sub ) = @_;
153         my $obj = $self->context->object_by_path( $obj_key );
154         $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
155 }
156
157
158 sub insert {
159         my( $self, $key, $val ) = @_;
160         return unless defined($key);
161
162         if (ref($val) =~ /^Fieldmapper/o) {
163                 $self->insert_fm($key, $val);
164         } elsif (ref($val) and $val =~ /ARRAY/o) {
165                 $self->insert_array($key, $val);
166         } elsif (ref($val) and $val =~ /HASH/o) {
167                 $self->insert_hash($key, $val);
168         } elsif (ref($val) and $val =~ /CODE/o) {
169                 $self->context->function_set( $key, $val );
170         } elsif (!ref($val)) {
171                 if( defined($val) ) {
172                         $self->context->property_by_path(
173                                 $key, $val,
174                                 sub { $val },
175                                 sub { my( $k, $v ) = @_; $val = $v; }
176                         );
177                 } else {
178                         $self->context->property_by_path($key);
179                 }
180
181         } else {
182                 return 0;
183         }
184
185         return 1;
186 }
187
188 sub insert_fm {
189
190         my( $self, $key, $fm ) = @_;
191         my $ctx = $self->context;
192         return undef unless ($ctx and $key and $fm);
193         my $o = $ctx->object_by_path($key);
194         
195         for my $f ( $fm->properties ) {
196                 my $val = $fm->$f();
197                 if (ref $val) {
198                         $self->insert("$key.$f", $val);
199                 } else {
200                         $ctx->property_by_path(
201                                 "$key.$f",
202                                 $val,
203                                 sub {
204                                         my $k = _js_prop_name(shift());
205                                         $fm->$k();
206                                 }, 
207
208                                 sub {
209                                         my $k = _js_prop_name(shift());
210                                         $fm->ischanged(1);
211                                         $fm->$k(@_);
212                                 }
213                         );
214                 }
215         }
216 }
217
218 sub insert_hash {
219
220         my( $self, $key, $hash ) = @_;
221         my $ctx = $self->context;
222         return undef unless ($ctx and $key and $hash);
223         $ctx->object_by_path($key);
224         
225         for my $k ( keys %$hash ) {
226                 my $v = $hash->{$k};
227                 if (ref $v) {
228                         $self->insert("$key.$k", $v);
229                 } else {
230                         $ctx->property_by_path(
231                                 "$key.$k", $v,
232                                 sub { $hash->{_js_prop_name(shift())} },
233                                 sub { 
234                                         my( $key, $val ) = @_;
235                                         $hash->{_js_prop_name($key)} = $val; }
236                         );
237                 }
238         }
239 }
240
241 my $__array_id = 0;
242 sub insert_array {
243
244         my( $self, $key, $array ) = @_;
245         my $ctx = $self->context;
246         return undef unless ($ctx and $key and $array);
247
248         my $a = $ctx->array_by_path($key);
249         
250         my $ind = 0;
251         for my $v ( @$array ) {
252                 if (ref $v) {
253                         my $elobj = $ctx->object_by_path('__tmp_arr_el'.$__array_id);
254                         $self->insert('__tmp_arr_el'.$__array_id, $v);
255                         $ctx->array_set_element_as_object( $a, $ind, $elobj );
256                         $__array_id++;
257                 } else {
258                         $ctx->array_set_element( $a, $ind, $v ) if defined($v);
259                 }
260                 $ind++;
261         }
262 }
263
264 sub _xmlhttprequest_send {
265         my $self = shift;
266         my $id = shift;
267         my $method = shift;
268         my $url = shift;
269         my $blocking = shift;
270         my $headerlist = shift;
271         my $data = shift;
272
273         my $ctx = $self->context;
274
275         # just so perl has access to it...
276         $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
277
278         my $headers = new HTTP::Headers;
279         my @lines = split(/\n/so, $headerlist);
280         for my $line (@lines) {
281                 if ($line =~ /^(.+?)|(.+)$/o) {
282                         $headers->header($1 => $2);
283                 }
284         }
285
286         my $ua = LWP::UserAgent->new;
287         $ua->agent("OpenILS/0.1");
288
289         my $req = HTTP::Request->new($method => $url => $headers => $data);
290         my $res = $ua->request($req);
291
292         if ($res->is_success) {
293                 
294                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
295                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
296                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
297                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
298
299         }
300                 
301 }
302
303 sub _parse_xml_string {
304         my $self = shift;
305         my $string = shift;
306         my $key = shift;
307
308
309         my $doc;
310         my $s = 0;
311         try {
312                 $doc = XML::LibXML->new->parse_string( $string );
313                 $s = 1;
314         } catch Error with {
315                 my $e = shift;
316                 warn "Could not parse document: $e\n";
317         };
318         return unless ($s);
319
320         _JS_DOM($self->context, $key, $doc);
321 }
322
323 sub _JS_DOM {
324         my $ctx = shift;
325         my $key = shift;
326         my $node = shift;
327
328         if ($node->nodeType == 9) {
329                 $node = $node->documentElement;
330
331                 my $n = $node->nodeName;
332                 my $ns = $node->namespaceURI;
333                 $ns =~ s/'/\'/gso if ($ns);
334                 $ns = "'$ns'" if ($ns);
335                 $ns = 'null' unless ($ns);
336                 $n =~ s/'/\'/gso;
337
338                 #warn("$key = DOMImplementation().createDocument($ns,'$n');");
339                 $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
340
341                 $key = $key.'.documentElement';
342         }
343
344         for my $a ($node->attributes) {
345                 my $n = $a->nodeName;
346                 my $v = $a->value;
347                 $n =~ s/'/\'/gso;
348                 $v =~ s/'/\'/gso;
349                 #warn("$key.setAttribute('$n','$v');");
350                 $ctx->eval("$key.setAttribute('$n','$v');");
351
352         }
353
354         my $k = 0;
355         for my $c ($node->childNodes) {
356                 if ($c->nodeType == 1) {
357                         my $n = $c->nodeName;
358                         my $ns = $node->namespaceURI;
359
360                         $n =~ s/'/\'/gso;
361                         $ns =~ s/'/\'/gso if ($ns);
362                         $ns = "'$ns'" if ($ns);
363                         $ns = 'null' unless ($ns);
364
365                         #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
366                         $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
367                         _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
368
369                 } elsif ($c->nodeType == 3) {
370                         my $n = $c->data;
371                         $n =~ s/'/\'/gso;
372                         #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
373                         #warn("path is $key.item($k);");
374                         $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
375
376                 } elsif ($c->nodeType == 4) {
377                         my $n = $c->data;
378                         $n =~ s/'/\'/gso;
379                         #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
380                         $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
381
382                 } elsif ($c->nodeType == 8) {
383                         my $n = $c->data;
384                         $n =~ s/'/\'/gso;
385                         #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
386                         $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
387
388                 } else {
389                         warn "ACK! I don't know how to handle node type ".$c->nodeType;
390                 }
391                 
392
393                 $k++;
394         }
395
396         return 1;
397 }
398
399
400
401 1;