This commit breaks compatibility with OpenSRF 0.9.
[Evergreen.git] / Open-ILS / src / perlmods / OpenILS / Utils / ScriptRunner.pm
1 package OpenILS::Utils::ScriptRunner;
2 use strict; use warnings;
3 use OpenSRF::Utils::Logger qw(:logger);
4 use OpenSRF::EX qw(:try);
5 use OpenSRF::Utils::JSON;
6 use JavaScript::SpiderMonkey;
7 use LWP::UserAgent;
8 use XML::LibXML;
9 use Time::HiRes qw/time/;
10 use vars qw/%_paths/;
11
12 sub DESTROY {
13         my $self = shift;
14         $logger->info("script_runner: destroying self: $self");
15 }
16
17 sub cleanup {
18         my $runner = shift;
19         $logger->info("script_runner: destroying context...");
20         $runner->context->destroy;
21         delete($$runner{$_}) for (keys %$runner);
22 }
23
24 sub new {
25         my $class = shift;
26         my %params = @_;
27         $class = ref($class) || $class;
28         $params{paths} ||= [];
29         $params{reset_count} ||= 0;
30
31         my $self = bless {      file => $params{file},
32                                 libs => $params{libs},
33                                 reset_count => $params{reset_count},
34                                 _runs => 0,
35                                 _path => {%_paths} } => $class;
36
37         $self->add_path($_) for @{$params{paths}};
38         return $self->init; 
39 }
40
41 sub context {
42         my( $self, $context ) = @_;
43         $self->{ctx} = $context if $context;
44         return $self->{ctx};
45 }
46
47 sub init {
48         my $self = shift;
49         $self->context( new JavaScript::SpiderMonkey );
50         $self->context->init();
51
52         $self->{_runs} = 0;
53
54         # eating our own dog food with insert
55         $self->insert(log_stdout        => sub { print "@_\n"; } );
56         $self->insert(log_stderr        => sub { warn "@_\n"; } );
57         $self->insert(log_activity      => sub { $logger->activity("script_runner: @_"); return 1;} );
58         $self->insert(log_error         => sub { $logger->error("script_runner: @_"); return 1;} );
59         $self->insert(log_warn          => sub { $logger->warn("script_runner: @_"); return 1;} );
60         $self->insert(log_info          => sub { $logger->info("script_runner: @_"); return 1;} );
61         $self->insert(log_debug         => sub { $logger->debug("script_runner: @_"); return 1;} );
62         $self->insert(log_internal      => sub { $logger->internal("script_runner: @_"); return 1;} );
63         $self->insert(debug             => sub { $logger->debug("script_runner: @_"); return 1;} );
64         $self->insert(alert             => sub { $logger->warn("script_runner: @_"); return 1;} );
65         $self->insert(load_lib          => sub { $self->load_lib(@_); return 1;});
66
67         # OpenSRF support functions
68         $self->insert(
69                 _OILS_FUNC_jsonopensrfrequest_send =>
70                         sub { $self->_jsonopensrfrequest_send(@_); }
71         );
72         $self->insert(
73                 _OILS_FUNC_jsonopensrfrequest_connect =>
74                         sub { $self->_jsonopensrfrequest_connect(@_); }
75         );
76         $self->insert(
77                 _OILS_FUNC_jsonopensrfrequest_disconnect =>
78                         sub { $self->_jsonopensrfrequest_disconnect(@_); }
79         );
80         $self->insert(
81                 _OILS_FUNC_jsonopensrfrequest_finish =>
82                         sub { $self->_jsonopensrfrequest_finish(@_); }
83         );
84
85         # XML support functions
86         $self->insert(
87                 _OILS_FUNC_xmlhttprequest_send  =>
88                         sub { $self->_xmlhttprequest_send(@_); }
89         );
90         $self->insert(
91                 _OILS_FUNC_xml_parse_string     =>
92                         sub { $self->_parse_xml_string(@_); }
93         );
94         
95         while ( my $e = shift @{$self->{_env}} ) {
96                 $self->insert( @$e{ qw/key value readonly/ } => 1 );
97         }
98
99         while ( my $e = shift @{$self->{_methods}} ) {
100                 $self->insert_method( @$e{ qw/key name meth/ } => 1 );
101         }
102
103         $self->load_lib($_) for @{$self->{libs}};
104
105         return $self;
106 }
107
108 sub refresh_context {
109         my $self = shift;
110         $logger->debug("Refreshing JavaScript Context...");
111         $self->context->destroy;
112         $logger->debug("Context destroyed");
113         $self->{_loaded} = {};
114         $logger->debug("Loaded scripts removed");
115         $self->init;
116         $logger->debug("New Context initialized");
117         return $self;
118 }
119
120 sub load {
121         my( $self, $filename ) = @_;
122         $self->{file} = $filename;
123 }
124
125 sub runs { shift()->{_runs} }
126
127 sub reset_count {
128         my $self = shift;
129         my $count = shift;
130
131         $self->{reset_count} = $count if ($count);
132         return $self->{reset_count};
133 }
134
135 sub run {
136         my $self = shift;
137         my $file = shift();
138
139         my $_real = 0;
140         if(!$file) {
141                 $_real = 1;
142                 $file = $self->{file};
143         }
144
145         $self->refresh_context
146                 if ($self->reset_count && $self->runs > $self->reset_count);
147
148         $self->{_runs}++ if ($_real);
149
150         $file = $self->_find_file($file);
151         $logger->debug("full script file path: $file");
152
153         if( ! open(F, $file) ) {
154                 $logger->error("Error opening script file: $file");
155                 return 0;
156         }
157
158         my $js = $self->context;
159
160         my $res = '';
161         {       local $/ = undef;
162
163                 $self->insert('environment.result' => {});
164
165                 my $content = <F>;
166                 #print ( "full script is [$content]" );
167
168                 my $s = time();
169                 if( !$js || !$content || !$js->eval($content) ) {
170                         $logger->error("$file Eval failed: $@");  
171                         return 0;
172                 }
173                 $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
174
175                 if ($_real) {
176                         $self->insert('__' => {'OILS_RESULT' => ''});
177                         $js->eval("__.OILS_RESULT = js2JSON(environment.result);");
178                         $res = $self->retrieve('__.OILS_RESULT');
179                 }
180         }
181
182         close(F);
183         $logger->debug( "script result is [$res]" );
184         return OpenSRF::Utils::JSON->JSON2perl( $res );
185 }
186
187 sub remove_path { 
188         my( $self, $path ) = @_;
189         if (ref($self)) {
190                 if ($self->{_path}{$path}) {
191                         $self->{_path}{$path} = 0;
192                 }
193                 return $self->{_path}{$path};
194         } else {
195                 if ($_paths{$path}) {
196                         $_paths{$path} = 0;
197                 }
198                 return $_paths{$path};
199         }
200 }
201
202 sub add_path { 
203         my( $self, $path ) = @_;
204         if (ref($self)) {
205                 if (!$self->{_path}{$path}) {
206                         $self->{_path}{$path} = 1;
207                 }
208         } else {
209                 if (!$_paths{$path}) {
210                         $_paths{$path} = 1;
211                 }
212         }
213         return $self;
214 }
215
216 sub _find_file {
217         my $self = shift;
218         my $file = shift;
219         for my $p ( keys %{ $self->{_path} } ) {
220                 next unless ($self->{_path}{$p});
221                 my $full = join('/',$p,$file);
222                 return $full if (-e $full);
223         }
224 }
225
226 sub load_lib { 
227         my( $self, $file ) = @_;
228
229         my @paths = keys %{$self->{_path}};
230         $logger->debug("script_runner: Loading lib file $file : paths=[@paths]");
231
232         push @{ $self->{libs} }, $file
233                 if (! grep {$_ eq $file} @{ $self->{libs} });
234
235         if (!$self->{_loaded}{$file}) {
236                 $self->run( $file );
237                 $self->{_loaded}{$file} = 1;
238         }
239         return $self->{_loaded}{$file};
240 }
241
242 sub _js_prop_name {
243         my $name = shift;
244         $name =~ s/^.*\.//o;
245         return $name;
246 }
247
248 sub retrieve {
249         my( $self, $key ) = @_;
250         return $self->context->property_get($key);
251 }
252
253 sub insert_method {
254         my( $self, $obj_key, $meth_name, $sub, $stop) = @_;
255
256         push @{$self->{_methods}}, { key => $obj_key => name => $meth_name, meth => $sub } unless ($stop);
257         
258         my $obj = $self->context->object_by_path( $obj_key );
259         $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
260 }
261
262
263 sub insert {
264         my( $self, $key, $val, $RO, $stop ) = @_;
265         return unless defined($key);
266
267         push @{$self->{_env}}, { key => $key => value => $val, readonly => $RO } unless ($stop);
268
269         if (ref($val) =~ /^Fieldmapper/o) {
270                 $self->insert_fm($key, $val, $RO);
271         } elsif (ref($val) and $val =~ /ARRAY/o) {
272                 $self->insert_array($key, $val, $RO);
273         } elsif (ref($val) and $val =~ /HASH/o) {
274                 $self->insert_hash($key, $val, $RO);
275         } elsif (ref($val) and $val =~ /CODE/o) {
276                 $self->context->function_set( $key, $val );
277         } elsif (!ref($val)) {
278                 if( defined($val) ) {
279                         $self->context->property_by_path(
280                                 $key, $val,
281                                 ( !$RO ?  (sub { $val }, sub { my( $k, $v ) = @_; $val = $v; }) : () )
282                         );
283                 } else {
284                         $self->context->property_by_path($key, "");
285                 }
286
287         } else {
288                 return 0;
289         }
290
291         return 1;
292 }
293
294 sub insert_fm {
295
296         my( $self, $key, $fm, $RO ) = @_;
297         my $ctx = $self->context;
298         return undef unless ($ctx and $key and $fm);
299         my $o = $ctx->object_by_path($key);
300         
301         for my $f ( $fm->properties ) {
302                 my $val = $fm->$f();
303                 if (ref $val) {
304                         $self->insert("$key.$f", $val);
305                 } else {
306                         $ctx->property_by_path(
307                                 "$key.$f",
308                                 $val,
309                                 ( !$RO ? 
310                                         (sub {
311                                                 my $k = _js_prop_name(shift());
312                                                 $fm->$k();
313                                         }, 
314                                         sub {
315                                                 my $k = _js_prop_name(shift());
316                                                 $fm->ischanged(1);
317                                                 $fm->$k(@_);
318                                         }) :
319                                         ()
320                                 )
321                         );
322                 }
323         }
324 }
325
326 sub insert_hash {
327
328         my( $self, $key, $hash, $RO ) = @_;
329         my $ctx = $self->context;
330         return undef unless ($ctx and $key and $hash);
331         $ctx->object_by_path($key);
332         
333         for my $k ( keys %$hash ) {
334                 my $v = $hash->{$k};
335                 if (ref $v) {
336                         $self->insert("$key.$k", $v);
337                 } else {
338                         $ctx->property_by_path(
339                                 "$key.$k", $v,
340                                 ( !$RO ? 
341                                         (sub { $hash->{_js_prop_name(shift())} },
342                                         sub {
343                                                 my( $hashkey, $val ) = @_;
344                                                 $hash->{_js_prop_name($hashkey)} = $val;
345                                         }) :
346                                         ()
347                                 )
348                         );
349                 }
350         }
351 }
352
353 my $__array_id = 0;
354 sub insert_array {
355
356         my( $self, $key, $array ) = @_;
357         my $ctx = $self->context;
358         return undef unless ($ctx and $key and $array);
359
360         my $a = $ctx->array_by_path($key);
361         
362         my $ind = 0;
363         for my $v ( @$array ) {
364                 if (ref $v) {
365                         my $tmp_index = $__array_id++;
366                         my $elobj = $ctx->object_by_path('__tmp_arr_el'.$tmp_index);
367                         $self->insert('__tmp_arr_el'.$tmp_index, $v);
368                         $ctx->array_set_element_as_object( $a, $ind, $elobj );
369                 } else {
370                         $ctx->array_set_element( $a, $ind, $v ) if defined($v);
371                 }
372                 $ind++;
373         }
374 }
375
376 sub _xmlhttprequest_send {
377         my $self = shift;
378         my $id = shift;
379         my $method = shift;
380         my $url = shift;
381         my $blocking = shift;
382         my $headerlist = shift;
383         my $data = shift;
384
385         my $ctx = $self->context;
386
387         # just so perl has access to it...
388         $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
389
390         my $headers = new HTTP::Headers;
391         my @lines = split(/\n/so, $headerlist);
392         for my $line (@lines) {
393                 if ($line =~ /^(.+?)|(.+)$/o) {
394                         $headers->header($1 => $2);
395                 }
396         }
397
398         my $ua = LWP::UserAgent->new;
399         $ua->agent("OpenILS/0.1");
400
401         my $req = HTTP::Request->new($method => $url => $headers => $data);
402         my $res = $ua->request($req);
403
404         if ($res->is_success) {
405                 
406                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
407                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
408                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
409                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
410
411         }
412                 
413 }
414
415 our %_jsonopensrfrequest_cache = ();
416
417 sub _jsonopensrfrequest_connect {
418         my $self = shift;
419         my $id = shift;
420         my $service = shift;
421
422         my $ctx = $self->context;
423         $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
424
425         my $ses = $_jsonopensrfrequest_cache{$id} ||
426                         do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
427
428         if($ses->connect) {
429                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 1);
430         } else {
431                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 0);
432         }
433 }
434
435 sub _jsonopensrfrequest_disconnect {
436         my $self = shift;
437         my $id = shift;
438
439         my $ctx = $self->context;
440         $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
441
442         my $ses = $_jsonopensrfrequest_cache{$id};
443         return unless $ses;
444
445         $ses->disconnect;
446 }
447
448 sub _jsonopensrfrequest_finish {
449         my $self = shift;
450         my $id = shift;
451
452         my $ctx = $self->context;
453         $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
454
455         my $ses = $_jsonopensrfrequest_cache{$id};
456         return unless $ses;
457
458         $ses->finish;
459         delete $_jsonopensrfrequest_cache{$id};
460 }
461
462 sub _jsonopensrfrequest_send {
463         my $self = shift;
464         my $id = shift;
465         my $service = shift;
466         my $method = shift;
467         my $blocking = shift;
468         my $params = shift;
469
470         my @p = @{ OpenSRF::Utils::JSON->JSON2perl($params) };
471
472         my $ctx = $self->context;
473
474         # just so perl has access to it...
475         $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
476
477         my $ses = $_jsonopensrfrequest_cache{$id} ||
478                         do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
479         my $req = $ses->request($method,@p);
480
481         $req->wait_complete;
482         if (!$req->failed) {
483                 my $res = $req->recv->content;
484                 
485                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', OpenSRF::Utils::JSON->perl2JSON($res));
486                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
487                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', 'OK');
488                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', '200');
489
490         } else {
491                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', '');
492                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
493                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', $req->failed->status );
494                 $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', $req->failed->statusCode );
495         }
496
497         $req->finish;
498                 
499 }
500
501 sub _parse_xml_string {
502         my $self = shift;
503         my $string = shift;
504         my $key = shift;
505
506
507         my $doc;
508         my $s = 0;
509         try {
510                 $doc = XML::LibXML->new->parse_string( $string );
511                 $s = 1;
512         } catch Error with {
513                 my $e = shift;
514                 warn "Could not parse document: $e\n";
515         };
516         return unless ($s);
517
518         _JS_DOM($self->context, $key, $doc);
519 }
520
521 sub _JS_DOM {
522         my $ctx = shift;
523         my $key = shift;
524         my $node = shift;
525
526         if ($node->nodeType == 9) {
527                 $node = $node->documentElement;
528
529                 my $n = $node->nodeName;
530                 my $ns = $node->namespaceURI;
531                 $ns =~ s/'/\'/gso if ($ns);
532                 $ns = "'$ns'" if ($ns);
533                 $ns = 'null' unless ($ns);
534                 $n =~ s/'/\'/gso;
535
536                 #warn("$key = DOMImplementation().createDocument($ns,'$n');");
537                 $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
538
539                 $key = $key.'.documentElement';
540         }
541
542         for my $a ($node->attributes) {
543                 my $n = $a->nodeName;
544                 my $v = $a->value;
545                 $n =~ s/'/\'/gso;
546                 $v =~ s/'/\'/gso;
547                 #warn("$key.setAttribute('$n','$v');");
548                 $ctx->eval("$key.setAttribute('$n','$v');");
549
550         }
551
552         my $k = 0;
553         for my $c ($node->childNodes) {
554                 if ($c->nodeType == 1) {
555                         my $n = $c->nodeName;
556                         my $ns = $node->namespaceURI;
557
558                         $n =~ s/'/\'/gso;
559                         $ns =~ s/'/\'/gso if ($ns);
560                         $ns = "'$ns'" if ($ns);
561                         $ns = 'null' unless ($ns);
562
563                         #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
564                         $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
565                         _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
566
567                 } elsif ($c->nodeType == 3) {
568                         my $n = $c->data;
569                         $n =~ s/'/\'/gso;
570                         #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
571                         #warn("path is $key.item($k);");
572                         $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
573
574                 } elsif ($c->nodeType == 4) {
575                         my $n = $c->data;
576                         $n =~ s/'/\'/gso;
577                         #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
578                         $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
579
580                 } elsif ($c->nodeType == 8) {
581                         my $n = $c->data;
582                         $n =~ s/'/\'/gso;
583                         #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
584                         $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
585
586                 } else {
587                         warn "ACK! I don't know how to handle node type ".$c->nodeType;
588                 }
589                 
590
591                 $k++;
592         }
593
594         return 1;
595 }
596
597
598
599 1;