Open-ILS/src/perlmods/lib/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;