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