Open-ILS/src/perlmods/lib/OpenILS/Utils/SpiderMonkey.pm

   1 package OpenILS::Utils::SpiderMonkey;
   2 use strict; use warnings;
   3 use OpenSRF::Utils::Logger qw(:logger);
   4 use OpenSRF::EX qw(:try);
   5 use OpenILS::Utils::ScriptRunner;
   6 use base 'OpenILS::Utils::ScriptRunner';
   7 use JavaScript::SpiderMonkey;
   8 use LWP::UserAgent;
   9 use XML::LibXML;
  10 use Time::HiRes qw/time/;
  11 use vars qw/%_paths/;
  12
  13 sub new {
  14         my ( $class, %params ) = @_;
  15         $class = ref($class) || $class;
  16         $params{paths} ||= [];
  17
  18         my $self = { file => $params{file}, libs => $params{libs}, _path => {%_paths} };
  19         bless( $self, $class );
  20
  21         $self->add_path($_) for @{$params{paths}};
  22         return $self;
  23 }
  24
  25 sub context {
  26         my( $self, $context ) = @_;
  27         $self->{ctx} = $context if $context;
  28         return $self->{ctx};
  29 }
  30
  31 sub init {
  32         my $self = shift;
  33         my $js = JavaScript::SpiderMonkey->new();
  34         $js->init();
  35
  36         $js->function_set(perl_print    => sub { print "@_\n"; } );
  37         $js->function_set(perl_warn     => sub { warn @_; } );
  38         $js->function_set(log_activity  => sub { $logger->activity(@_); return 1;} );
  39         $js->function_set(log_error     => sub { $logger->error(@_); return 1;} );
  40         $js->function_set(log_warn      => sub { $logger->warn(@_); return 1;} );
  41         $js->function_set(log_info      => sub { $logger->info(@_); return 1;} );
  42         $js->function_set(log_debug     => sub { $logger->debug(@_); return 1;} );
  43         $js->function_set(log_internal  => sub { $logger->internal(@_); return 1;} );
  44         $js->function_set(debug         => sub { $logger->debug(@_); return 1;} );
  45         $js->function_set(alert         => sub { $logger->warn(@_); return 1;} );
  46
  47         $js->function_set(load_lib      => sub { $self->load_lib(@_); });
  48
  49         # XML support functions
  50         $js->function_set(
  51                 _OILS_FUNC_xmlhttprequest_send  => sub { $self->_xmlhttprequest_send(@_); });
  52         $js->function_set(
  53                 _OILS_FUNC_xml_parse_string     => sub { $self->_parse_xml_string(@_); });
  54
  55         $self->context($js);
  56         $self->load_lib($_) for @{$self->{libs}};
  57
  58         return $self;
  59 }
  60
  61
  62 sub load {
  63         my( $self, $filename ) = @_;
  64         $self->{file} = $filename;
  65 }
  66
  67 sub run {
  68         my $self = shift;
  69         my $file = shift() || $self->{file};
  70         my $js = $self->context;
  71
  72         $file = $self->_find_file($file);
  73
  74         if( ! open(F, $file) ) {
  75                 $logger->error("Error opening script file: $file");
  76                 return 0;
  77         }
  78
  79         {       local $/ = undef;
  80                 my $content = <F>;
  81                 my $s = time();
  82                 if( !$js || !$content || !$js->eval($content) ) {
  83                         $logger->error("$file Eval failed: $@");
  84                         return 0;
  85                 }
  86                 $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
  87         }
  88
  89         close(F);
  90         return 1;
  91 }
  92
  93 sub remove_path {
  94         my( $self, $path ) = @_;
  95         if (ref($self)) {
  96                 if ($self->{_path}{$path}) {
  97                         $self->{_path}{$path} = 0;
  98                 }
  99                 return $self->{_path}{$path};
 100         } else {
 101                 if ($_paths{$path}) {
 102                         $_paths{$path} = 0;
 103                 }
 104                 return $_paths{$path};
 105         }
 106 }
 107
 108 sub add_path {
 109         my( $self, $path ) = @_;
 110         if (ref($self)) {
 111                 if (!$self->{_path}{$path}) {
 112                         $self->{_path}{$path} = 1;
 113                 }
 114         } else {
 115                 if (!$_paths{$path}) {
 116                         $_paths{$path} = 1;
 117                 }
 118         }
 119         return $self;
 120 }
 121
 122 sub _find_file {
 123         my $self = shift;
 124         my $file = shift;
 125         for my $p ( keys %{ $self->{_path} } ) {
 126                 next unless ($self->{_path}{$p});
 127                 my $full = join('/',$p,$file);
 128                 return $full if (-e $full);
 129         }
 130 }
 131
 132 sub load_lib {
 133         my( $self, $file ) = @_;
 134         if (!$self->{_loaded}{$file} && $self->run( $file )) {
 135                 $self->{_loaded}{$file} = 1;
 136         }
 137         return $self->{_loaded}{$file};
 138 }
 139
 140 sub _js_prop_name {
 141         my $name = shift;
 142         $name =~ s/^.*\.//o;
 143         return $name;
 144 }
 145
 146 sub retrieve {
 147         my( $self, $key ) = @_;
 148         return $self->context->property_get($key);
 149 }
 150
 151 sub insert_method {
 152         my( $self, $obj_key, $meth_name, $sub ) = @_;
 153         my $obj = $self->context->object_by_path( $obj_key );
 154         $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
 155 }
 156
 157
 158 sub insert {
 159         my( $self, $key, $val ) = @_;
 160         return unless defined($key);
 161
 162         if (ref($val) =~ /^Fieldmapper/o) {
 163                 $self->insert_fm($key, $val);
 164         } elsif (ref($val) and $val =~ /ARRAY/o) {
 165                 $self->insert_array($key, $val);
 166         } elsif (ref($val) and $val =~ /HASH/o) {
 167                 $self->insert_hash($key, $val);
 168         } elsif (ref($val) and $val =~ /CODE/o) {
 169                 $self->context->function_set( $key, $val );
 170         } elsif (!ref($val)) {
 171                 if( defined($val) ) {
 172                         $self->context->property_by_path(
 173                                 $key, $val,
 174                                 sub { $val },
 175                                 sub { my( $k, $v ) = @_; $val = $v; }
 176                         );
 177                 } else {
 178                         $self->context->property_by_path($key);
 179                 }
 180
 181         } else {
 182                 return 0;
 183         }
 184
 185         return 1;
 186 }
 187
 188 sub insert_fm {
 189
 190         my( $self, $key, $fm ) = @_;
 191         my $ctx = $self->context;
 192         return undef unless ($ctx and $key and $fm);
 193         my $o = $ctx->object_by_path($key);
 194
 195         for my $f ( $fm->properties ) {
 196                 my $val = $fm->$f();
 197                 if (ref $val) {
 198                         $self->insert("$key.$f", $val);
 199                 } else {
 200                         $ctx->property_by_path(
 201                                 "$key.$f",
 202                                 $val,
 203                                 sub {
 204                                         my $k = _js_prop_name(shift());
 205                                         $fm->$k();
 206                                 },
 207
 208                                 sub {
 209                                         my $k = _js_prop_name(shift());
 210                                         $fm->ischanged(1);
 211                                         $fm->$k(@_);
 212                                 }
 213                         );
 214                 }
 215         }
 216 }
 217
 218 sub insert_hash {
 219
 220         my( $self, $key, $hash ) = @_;
 221         my $ctx = $self->context;
 222         return undef unless ($ctx and $key and $hash);
 223         $ctx->object_by_path($key);
 224
 225         for my $k ( keys %$hash ) {
 226                 my $v = $hash->{$k};
 227                 if (ref $v) {
 228                         $self->insert("$key.$k", $v);
 229                 } else {
 230                         $ctx->property_by_path(
 231                                 "$key.$k", $v,
 232                                 sub { $hash->{_js_prop_name(shift())} },
 233                                 sub {
 234                                         my( $key, $val ) = @_;
 235                                         $hash->{_js_prop_name($key)} = $val; }
 236                         );
 237                 }
 238         }
 239 }
 240
 241 my $__array_id = 0;
 242 sub insert_array {
 243
 244         my( $self, $key, $array ) = @_;
 245         my $ctx = $self->context;
 246         return undef unless ($ctx and $key and $array);
 247
 248         my $a = $ctx->array_by_path($key);
 249
 250         my $ind = 0;
 251         for my $v ( @$array ) {
 252                 if (ref $v) {
 253                         my $elobj = $ctx->object_by_path('__tmp_arr_el'.$__array_id);
 254                         $self->insert('__tmp_arr_el'.$__array_id, $v);
 255                         $ctx->array_set_element_as_object( $a, $ind, $elobj );
 256                         $__array_id++;
 257                 } else {
 258                         $ctx->array_set_element( $a, $ind, $v ) if defined($v);
 259                 }
 260                 $ind++;
 261         }
 262 }
 263
 264 sub _xmlhttprequest_send {
 265         my $self = shift;
 266         my $id = shift;
 267         my $method = shift;
 268         my $url = shift;
 269         my $blocking = shift;
 270         my $headerlist = shift;
 271         my $data = shift;
 272
 273         my $ctx = $self->context;
 274
 275         # just so perl has access to it...
 276         $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
 277
 278         my $headers = new HTTP::Headers;
 279         my @lines = split(/\n/so, $headerlist);
 280         for my $line (@lines) {
 281                 if ($line =~ /^(.+?)|(.+)$/o) {
 282                         $headers->header($1 => $2);
 283                 }
 284         }
 285
 286         my $ua = LWP::UserAgent->new;
 287         $ua->agent("OpenILS/0.1");
 288
 289         my $req = HTTP::Request->new($method => $url => $headers => $data);
 290         my $res = $ua->request($req);
 291
 292         if ($res->is_success) {
 293
 294                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
 295                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
 296                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
 297                 $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
 298
 299         }
 300
 301 }
 302
 303 sub _parse_xml_string {
 304         my $self = shift;
 305         my $string = shift;
 306         my $key = shift;
 307
 308
 309         my $doc;
 310         my $s = 0;
 311         try {
 312                 $doc = XML::LibXML->new->parse_string( $string );
 313                 $s = 1;
 314         } catch Error with {
 315                 my $e = shift;
 316                 warn "Could not parse document: $e\n";
 317         };
 318         return unless ($s);
 319
 320         _JS_DOM($self->context, $key, $doc);
 321 }
 322
 323 sub _JS_DOM {
 324         my $ctx = shift;
 325         my $key = shift;
 326         my $node = shift;
 327
 328         if ($node->nodeType == 9) {
 329                 $node = $node->documentElement;
 330
 331                 my $n = $node->nodeName;
 332                 my $ns = $node->namespaceURI;
 333                 $ns =~ s/'/\'/gso if ($ns);
 334                 $ns = "'$ns'" if ($ns);
 335                 $ns = 'null' unless ($ns);
 336                 $n =~ s/'/\'/gso;
 337
 338                 #warn("$key = DOMImplementation().createDocument($ns,'$n');");
 339                 $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
 340
 341                 $key = $key.'.documentElement';
 342         }
 343
 344         for my $a ($node->attributes) {
 345                 my $n = $a->nodeName;
 346                 my $v = $a->value;
 347                 $n =~ s/'/\'/gso;
 348                 $v =~ s/'/\'/gso;
 349                 #warn("$key.setAttribute('$n','$v');");
 350                 $ctx->eval("$key.setAttribute('$n','$v');");
 351
 352         }
 353
 354         my $k = 0;
 355         for my $c ($node->childNodes) {
 356                 if ($c->nodeType == 1) {
 357                         my $n = $c->nodeName;
 358                         my $ns = $node->namespaceURI;
 359
 360                         $n =~ s/'/\'/gso;
 361                         $ns =~ s/'/\'/gso if ($ns);
 362                         $ns = "'$ns'" if ($ns);
 363                         $ns = 'null' unless ($ns);
 364
 365                         #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
 366                         $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
 367                         _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
 368
 369                 } elsif ($c->nodeType == 3) {
 370                         my $n = $c->data;
 371                         $n =~ s/'/\'/gso;
 372                         #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
 373                         #warn("path is $key.item($k);");
 374                         $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
 375
 376                 } elsif ($c->nodeType == 4) {
 377                         my $n = $c->data;
 378                         $n =~ s/'/\'/gso;
 379                         #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
 380                         $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
 381
 382                 } elsif ($c->nodeType == 8) {
 383                         my $n = $c->data;
 384                         $n =~ s/'/\'/gso;
 385                         #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
 386                         $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
 387
 388                 } else {
 389                         warn "ACK! I don't know how to handle node type ".$c->nodeType;
 390                 }
 391
 392
 393                 $k++;
 394         }
 395
 396         return 1;
 397 }
 398
 399
 400
 401 1;