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