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;