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