File Coverage

blib/lib/JE/Code.pm
Criterion Covered Total %
statement 576 639 90.1
branch 351 414 84.7
condition 170 211 80.5
subroutine 81 92 88.0
pod 4 7 57.1
total 1182 1363 86.7


line stmt bran cond sub pod time code
1             package JE::Code;
2              
3             our $VERSION = '0.066';
4              
5 101     101   40249 use strict;
  101         145  
  101         3372  
6 101     101   446 use warnings; no warnings 'utf8', 'recursion';
  101     101   163  
  101         2751  
  101         434  
  101         130  
  101         3706  
7              
8             #use Data::Dumper;
9 101     101   452 use Carp 1.01 'shortmess';
  101         2379  
  101         6055  
10 101     101   622 use Exporter 5.57 'import';
  101         1499  
  101         3544  
11 101     101   519 use Scalar::Util 'tainted';
  101         178  
  101         9941  
12              
13             our @CARP_NOT = 'JE';
14             our @EXPORT_OK = 'add_line_number';
15              
16 101     101   520 use constant T => ${^TAINT}; # perl doesn’t optimise if(${AINT}) away
  101         140  
  101         139462  
17              
18             require JE::Object::Error;
19             require JE::Object::Error::ReferenceError;
20             require JE::Object::Error::SyntaxError;
21             require JE::Object::Error::TypeError;
22             require JE::Object::Function;
23             require JE::Object::Array;
24             require JE::Boolean;
25             require JE::Object;
26             require JE::Parser;
27             require JE::Number;
28             require JE::LValue;
29             require JE::String;
30             require JE::Scope;
31              
32             sub add_line_number; # so I can call it without parentheses in sub execute
33              
34              
35             # This is documented in a POD comment at the bottom of the file.
36             sub parse {
37 351     351 1 795 my($global, $src, $file, $line) = @_;
38              
39 351         1486 ($src, my ($tree, $vars)) = JE::Parser::_parse(
40             program => $src, $global, $file, $line
41             );
42              
43 351 100       987 $@ and return;
44              
45             #print Dumper $tree;
46              
47 328 100       2549 my $r= bless { global => $global,
48             ( $JE::Parser::_parser
49             ? (parser => $JE::Parser::_parser)
50             : () ),
51             source => \$src,
52             file => $file,
53             line => $line,
54             vars => $vars,
55             tree => $tree };
56             # $self->{source} is a reference, so that we can share the same
57             # source between code objects without the extra memory overhead
58             # that copying it would have. (Some JS script files are
59             # rather large.)
60              
61 328 50 33     1405 $r->optimise
62             if $ENV{'YES_I_WANT_JE_TO_OPTIMISE'}
63             and $ENV{'YES_I_WANT_JE_TO_OPTIMISE'} ne 2;
64              
65 328         2068 $r;
66             }
67              
68              
69              
70              
71             sub execute_till { # ~~~ Should this be made public?
72 2     2 0 3 (my $code, local our $counting) = (shift,shift);
73 2         3 local our $ops = 0;
74 2         4 JE_Code_OP: {
75 2         3 return $code->execute(@_);
76             }
77             # If we get here, then we reached the max number of ops.
78 1         194 $@ = shortmess "max_ops ($counting) exceeded";
79 1         72 return undef;
80             }
81              
82             sub set_global {
83 0     0 1 0 my $code = shift;
84 0         0 my $old = $code->{global};
85 0         0 $code->{global} = $_[0];
86 0 0       0 {for(@{$code->{cache}||last}) {
  0         0  
  0         0  
87 0 0       0 ref eq 'JE::Code' and $_->set_global($_[0]);
88             }}
89 0 0       0 {for(@{$code->{vars}||last}){
  0         0  
  0         0  
90 0 0 0     0 ref && ref $$_[4] eq 'JE::Code'
91             && $$_[4]->set_global($_[0])
92             }}
93 0 0       0 defined $old or return;
94 0         0 my @stack = $code->{tree};
95 0         0 local *@;
96 0         0 while(@stack) {
97 0         0 for(shift @stack) {
98 0         0 for(@$_[1..$#$_]) {
99 0   0     0 my $r = ref || next;
100 0 0       0 $r =~ /^(?:ARRAY\z|JE::Code::)/
101             and push @stack, $_, =~ next;
102 0 0       0 $r eq 'JE::Boolean'
103             and $_ = qw(f t)[$_->value], next;
104 0 0       0 $r eq 'JE::Number'
105             and $_ = $_->value, next;
106 0 0       0 $r eq 'JE::String'
107             and $_ = "s".$_->value16, next;
108 0 0       0 $r eq 'JE::Null' and $_ = 'n', next;
109 0 0       0 $r eq 'JE::Object::RegExp'
110             and $_ = [$_->{source}->value, $$$_{regexp_flags}],
111             next;
112             }
113             }
114             }
115 0         0 return;
116             }
117              
118             sub optimise {
119 0     0 0 0 require 'JE/toperl.pl';
120 0         0 goto &{'optimise'};
  0         0  
121             }
122              
123             # Variables pertaining to the current execution context
124             our $code; # JE::Code object, not source code
125             our $this;
126             our $scope;
127             our $parser;
128             our $pos; # position within the source code; used to calculate a line no.
129             our $taint;
130             our $ops;
131             our $counting;
132             our $global;
133             our $return;
134             our $cache;
135              
136             sub execute {
137 2206     2206 1 5241 local $code = shift;
138 2206         4887 local $global = $$code{global};
139              
140             # We check $ops’ definedness to avoid resetting the op count when
141             # called recursively.
142 2206 100 100     11442 if(!defined our $ops and my $max_ops = $global->max_ops) {
143 2         5 unshift @_, $code, $max_ops;
144 2         7 goto &execute_till;
145             }
146              
147 2204 100       6141 local $this = defined $_[0] ? $_[0] : $global;
148 2204         3051 shift;
149              
150 2204   100     6279 local $scope = shift || bless [$global], 'JE::Scope';
151              
152 2204   100     6006 my $code_type = shift || 0;
153              
154 2204         2496 local our $taint = substr(${$$code{source}},0,0) if T;
  2204         11322  
155              
156 2204         3044 my $rv;
157 2204         3806 eval {
158             # passing these values around is too
159             # cumbersome
160 2204         3936 local $JE::Code::parser = $code->{parser}; # might be
161 2204         2467 local our $pos; # undef
162 2204         2756 local our $code = $code;
163 2204         3530 local $JE::Code::Expression::_eval = $code_type == 1;
164              
165             package JE::Code::Statement;
166 2204         2603 local our $_label;
167             package JE::Code;
168             # This $return variable has two uses. It holds the return
169             # value when the JS 'return' statement calls 'last RETURN'.
170             # It also is used by statements that return values. It is
171             # necessary to use this var, rather than simply returning
172             # the value (as in v0.016 and earlier), in order to make
173             # 'while(true) { 3; break }' return 3, rather than
174             # undefined.
175 2204         2680 local $return;
176 2204   100     7506 local $cache = $$code{cache}||=[];
177              
178 2204         5822 RETURN: {
179 2204         2705 BREAK: {
180 2204         2499 CONT: {
181 2204         2591 JE'Code'Statement'_create_vars();
182 0         0 $$code{sub} ? &{$$code{sub}} :
183             $$code{psrc}? (
184             # ~~~ temporary hack:
185             ($$code{psrc}) = $$code{psrc} =~/(.*)/s,
186 2188 50       12632 &{$$code{sub} =
    50          
187 16   0     68 eval{ eval("sub{$$code{psrc}}")||die }
188             || die "Internal error that should never"
189             . " happen (please report this): $@: "
190             . $$code{psrc}
191             }):
192             $$code{tree}->eval;
193 516 100 66     2699 $code_type == 2 # function
194             or defined $return && ($rv = $return);
195 500         8185 goto FINISH;
196             }
197              
198 0 0       0 if($JE::Code::Statement::_label) {
199 0         0 die new JE::Object::Error::SyntaxError $global,
200             add_line_number
201             "continue $JE::Code::Statement::_label: label " .
202             "'$JE::Code::Statement::_label' not found";
203 0         0 } else { goto FINISH; }
204              
205             } # end of BREAK
206              
207 0 0       0 if($JE::Code::Statement::_label) {
208 0         0 die new JE::Object::Error::SyntaxError $global,
209             add_line_number
210             "break $JE::Code::Statement::_label: label " .
211             "'$JE::Code::Statement::_label' not found";
212 0         0 } else { goto FINISH; }
213              
214             } # end of RETURN
215              
216 1681         2439 $rv = $return;
217              
218              
219             FINISH: # I have to put this here inside the eval,
220             # because 'eval { goto label }; label:' causes a
221             # a bus error in p5.8.8 if a tie handler is in
222             # the call stack (fixed in 5.9.5).
223 2181         6057 };
224              
225 2203 100 100     20386 T and defined $rv and tainted $taint and $rv->can('taint')
      100        
226             and $rv = taint $rv $taint;
227              
228 2203 100 100     10012 if(ref $@ eq '' and $@ eq '') {
229 2165 100       6732 !defined $rv and $rv = $scope->undefined;
230             }
231             else {
232             # Catch-all for any errors not dealt with elsewhere
233 38         235 $@ = _objectify_error($@);
234             }
235              
236 2187         30049 $rv;
237             }
238              
239             sub add_line_number {
240 316     316 1 595 my $msg = shift;
241 316 100       938 my $code = @_ ? shift : $code;
242 316 100       788 my $pos = @_ ? shift : $pos ;
243 316 100       1298 $msg =~ /\n\z/ and return $msg;
244 298 100 100     2299 defined(my $file = ($code || return $msg)->{file})
      100        
245             or defined $pos or return $msg;
246 285         623 my $first_line = $code->{line};
247 285 100       750 defined $first_line or $first_line = 1;
248 285 100       710 if(defined $pos) {
249 101     101   647 no warnings 'uninitialized';
  101         126  
  101         31757  
250 283         483774 "$msg at $file" . ', ' x defined($file) . 'line ' .
251 283         1583 ($first_line + (() = substr(${$code->{source}},0,$pos) =~
252             /\cm\cj?|[\cj\x{2028}\x{2029}]/g))
253             . ".\n";
254             } else {
255 2         9 "$msg in $file.\n"
256             }
257             }
258              
259             sub _objectify_error {
260 312     312   564 my $msg = shift;
261              
262 312 100       1626 ref $msg and return $global->upgrade($msg);
263              
264 36         61 my $class = 'JE::Object::Error';
265              
266 36 100       206 if($msg =~ /^Can't\ locate\ object\ method\
267             "(?:c(?:all|onstruct)|apply|invoke_with)"/x) {
268             # ~~~ the ‘apply’ in there is legacy and can be removed b4 v1
269 18         27 $class = 'JE::Object::Error::TypeError';
270 18         33 $msg = "Argument to new is not a constructor";
271             }
272              
273 36         112 new $class $global, add_line_number $msg;
274             }
275              
276             sub DDS_freeze {
277 0     0 0 0 my $self = shift;
278 0         0 my $copy = bless {%$self}, ref $self;
279 0         0 delete $copy->{sub};
280 0         0 $copy;
281             }
282              
283              
284              
285             package JE::Code::Statement; # This does not cover expression statements.
286              
287             our $VERSION = '0.066';
288              
289 101     101   29659 use subs qw'_eval_term';
  101         30324  
  101         424  
290 101     101   4547 use List::Util 'first';
  101         140  
  101         23974  
291              
292             our( $_label);
293              
294             *_eval_term = *JE::Code::Expression::_eval_term;
295             import JE::Code 'add_line_number';
296             sub add_line_number;
297              
298              
299             # Note: each statement object is an array ref. The elems are:
300             # [0] - an array ref containing
301             # [0] - the starting position in the source code and
302             # [1] - the ending position
303             # [1] - the type of statement
304             # [2..$#] - the various expressions/statements that make up the statement
305              
306             sub eval { # evaluate statement
307 13225     13225   17336 my $stm = shift;
308              
309 13225         21014 my $type = $$stm[1];
310 13225 100 100     57407 $type eq 'empty' || $type eq 'function' and return;
311              
312 12854         13650 my @labels;
313 12854         19317 $pos = $$stm[0][0];
314              
315 12854 100       25785 if ($type eq 'labelled') {
316 28         91 @labels = @$stm[2..$#$stm-1];
317 28 100       148 if ($$stm[-1][1] =~ /^(?:do|while|for|switch)\z/) {
318 14         21 $stm = $$stm[-1];
319 14         20 $type = $$stm[1];
320 101     101   588 no warnings 'deprecated';
  101         159  
  101         14407  
321 14         295 goto LOOPS; # skip unnecessary if statements
322             }
323              
324             BREAK: {
325 14         15 my $returned = $$stm[-1]->eval;
  14         43  
326 6 50       12 defined $returned and $return = $returned
327             }
328              
329             # Note that this has 'defined' in it, whereas the similar
330             # 'if' statement further down where the loop constructs are
331             # doesn't. This is because 'break' without a label sets
332             # $_label to '' and exits loops and switches.
333 13 100 100 7   138 if(! defined $_label || first {$_ eq $_label} @labels) {
  7         27  
334 12         18 undef $_label;
335 12         48 return;
336             } else {
337 101     101   585 no warnings 'exiting';
  101         159  
  101         28757  
338 1         4 last BREAK;
339             }
340             }
341              
342 12826 100       28342 if ($type eq 'statements') {
343              
344             # Execute the statements, one by one, and return the return
345             # value of the last statement that actually returned one.
346 9501         10109 my $returned;
347 9501         27725 for (@$stm[2..$#$stm]) {
348 21757 50       59550 next if $_ eq 'empty';
349 21757 100 66     47792 defined($returned = $_->eval) and
350             $return = $returned,
351             ref $return eq 'JE::LValue'
352             && get $return;
353             }
354 7470         33276 return;
355             }
356 3325 100       7864 if ($type eq 'var') {
357 607 100       1655 for (@$stm[2..$#$stm]) { if (@$_ == 2) {
  653         1869  
358 455         1292 my $ret = _eval_term $$_[1];
359 454 100       1401 ref $ret eq'JE::LValue' and $ret = get $ret;
360 452         1732 $scope->find_var($$_[0])->set($ret);
361             }}
362 604         2739 return;
363             }
364 2718 100       5926 if ($type eq 'if') {
365             # 2 3 4
366             # we have: expr statement statement?
367 212         240 my $returned;
368 212 100       572 if ($$stm[2]->eval->to_boolean->value) {
369 62 50       379 $$stm[3] eq 'empty' or $returned = $$stm[3]->eval;
370             }
371             else {
372 148 100 66     535 exists $$stm[4]
373             && $$stm[4] ne 'empty'
374             and $returned = $$stm[4]->eval;
375             }
376 168 100       538 defined $returned and $return = $returned;
377             return
378 168         657 }
379 2520 100       11535 if ($type =~ /^(?:do|while|for|switch)\z/) {
380             # We have one of the following:
381             #
382             # 1 2 3 4 5
383             # 'do' statement expression
384             # 'while' expression statement
385             # 'for' expression 'in' expression statement
386             # 'for' var_decl 'in' expression statement
387             # 'for' expression expression expression statement
388             # 'for' var_decl expression expression statement
389             #
390             # In those last two cases, expression may be 'empty'.
391             # (See further down for 'switch').
392              
393 101     101   551 no warnings 'exiting';
  101         140  
  101         70010  
394              
395 422         684 LOOPS:
396             my $returned;
397            
398             BREAK: {
399 422 100 100     540 if ($type eq 'do') {
  422 100       3657  
    100          
    100          
400 26         31 do {
401 31 50       129 CONT: {
    100          
402 31         31 defined ($returned = ref $$stm[2]
403             ? $$stm[2]->eval : undef)
404             and $return = $returned;
405             }
406              
407 24 100 100 1   94 if($_label and
  1         5  
408             !first {$_ eq $_label} @labels) {
409 2         93 goto NEXT;
410             }
411 22         78 undef $_label;
412             } while $$stm[3]->eval->to_boolean->value;
413             }
414             elsif ($type eq 'while') {
415 23         70 CONT: while ($$stm[2]->eval->to_boolean->value) {
416 55 50       190 defined ($returned = ref $$stm[3]
    100          
417             ? $$stm[3]->eval : undef)
418             and $return = $returned;
419             }
420             continue {
421 49 100 100 5   243 if($_label and
  5         40  
422             !first {$_ eq $_label} @labels) {
423 2         75 goto NEXT;
424             }
425             }
426 14         37 undef $_label;
427             }
428             elsif ($type eq 'for' and $$stm[3] eq 'in') {
429 40         73 my $left_side = $$stm[2];
430 40 100       117 if ($left_side->[1] eq 'var') {
431 17         96 $left_side->eval;
432 17         50 $left_side = $left_side->[2][0];
433             # now contains the identifier
434             }
435 40         118 my $obj = $$stm[4]->eval;
436 40 100       190 $obj = $obj->get if ref $obj eq 'JE::LValue';
437 40 50       207 ref($obj) =~ /^JE::(?:Undefined|Null)\z/
438             # ~~~ Do we need undef $_label here?
439             and undef $_label, return;
440 40         181 my @keys = $obj->keys;
441 40         260 CONT: for(@keys) {
442 5229 50 33 0   13323 if($_label and
  0         0  
443             !first {$_ eq $_label} @labels) {
444 0         0 goto NEXT;
445             }
446 5229         5992 undef $_label;
447              
448 5229 100       17162 next if not defined $obj->prop($_);
449             # in which case it's been deleted
450            
451 5227 100       22094 (ref $left_side ? $left_side->eval :
452             $scope->find_var($left_side))
453             ->set(_new JE::String $global, $_);
454              
455 5227 50       26969 defined ($returned = ref $$stm[5]
    100          
456             ? $$stm[5]->eval : undef)
457             and $return = $returned;
458             }
459              
460             # In case 'continue LABEL' is called during the
461             # last iteration of the loop
462 40 50 33 0   160 if($_label and
  0         0  
463             !first {$_ eq $_label} @labels) {
464 0         0 next CONT;
465             }
466 40         313 undef $_label;
467              
468             }
469             elsif ($type eq 'for') { # for(;;)
470 317         379 my $tmp;
471 317 100 100 7   1580 CONT: for (
  7   33     26  
      100        
      33        
472             $tmp = ref $$stm[2] && $$stm[2]->eval,
473             ref $tmp eq 'JE::LValue' && get $tmp;
474              
475             ref $$stm[3]
476             ? $$stm[3]->eval->to_boolean->value
477             : 1;
478              
479 2857 100 100     8985 do{if($_label and
480             !first {$_ eq $_label} @labels) {
481 4         206 goto NEXT;
482             }
483 2853         14680 undef $_label;
484             },
485             $tmp = ref $$stm[4] && $$stm[4]->eval,
486             ref $tmp eq 'JE::LValue' && get $tmp
487             ) {
488 2911 50       12456 defined ($returned = ref $$stm[5]
    100          
489             ? $$stm[5]->eval : undef)
490             and $return = $returned;
491             }
492             }
493             else { # switch
494             # $stm->[2] is the parenthesized
495             # expression.
496             # Each pair of elements thereafter
497             # represents one case clause, an expr
498             # followed by statements, except for
499             # the default clause, which has the
500             # string 'default' for its first elem
501              
502            
503             # Evaluate the expression in the header
504 16         35 my $given = $$stm[2]->eval;
505 16 50       36 $given = get $given if ref $given eq 'JE::LValue';
506            
507             # Look through the case clauses to see
508             # which it matches. At the same time,
509             # look for the default clause.
510              
511 101     101   728 no strict 'refs';
  101         157  
  101         21660  
512              
513 16         18 my($n, $default) = 1;
514 16         38 while (($n+=2) < @$stm) {
515 34 100       66 if($$stm[$n] eq 'default') {
516 10         9 $default = $n; next;
  10         21  
517             }
518              
519             # Execute the statements if we have a match
520 24 100       41 if("JE::Code::Expression::in==="->(
521             $given, $$stm[$n]->eval
522             )) {
523 4         5 $n++;
524 4         4 do {
525 6         17 $$stm[$n]->eval;
526             } while ($n+=2) < @$stm;
527 4         5 undef $default;
528 4         5 last;
529             }
530             } ;
531              
532             # If we can't find a case that matches, but we
533             # did find a default (and $default was not erased
534             # when a case matched)
535 16 100       37 if(defined $default) {
536 10         9 $n = $default +1;
537 10         10 do { $$stm[$n]->eval }
  20         36  
538             while ($n+=2) < @$stm;
539             }
540             } # switch
541              
542             } # end of BREAK
543              
544              
545 402 100 100 8   1717 if(!$_label || first {$_ eq $_label} @labels) {
  8         17  
546 398         660 undef $_label;
547 398         2171 return;
548             } else {
549 4         14 last BREAK;
550             }
551            
552 8         47 NEXT: next CONT;
553             }
554 2098 100       4812 if ($type eq 'continue') {
555 101     101   1027 no warnings 'exiting';
  101         191  
  101         6544  
556 20 100       53 $_label = exists $$stm[2] ? $$stm[2] : '';
557 20         79 next CONT;
558             }
559 2078 100       4716 if ($type eq 'break') {
560 101     101   470 no warnings 'exiting';
  101         142  
  101         7642  
561 65 100       158 $_label = exists $$stm[2] ? $$stm[2] : '';
562 65         261 last BREAK;
563             }
564 2013 100       4864 if ($type eq 'return') {
565 101     101   529 no warnings 'exiting';
  101         153  
  101         21584  
566 1666 100       3644 if (exists $$stm[2]) {
567 1664 100       4791 ref ($return = $$stm[2]->eval) eq 'JE::LValue'
568             and $return = get $return;
569 2         4 } else { $return = undef }
570 1665         7962 last RETURN;
571             }
572 347 100       922 if ($type eq 'with') {
573 14         48 local $scope = bless [
574             @$scope, $$stm[2]->eval->to_object
575             ], 'JE::Scope';
576 14         76 my $returned = $$stm[3]->eval;
577 14 100       47 defined $returned and $return = $returned;
578 14         96 return;
579             }
580 333 100       1031 if ($type eq 'throw') {
581 17         27 my $excep;
582 17 50       58 if (exists $$stm[2]) {
583 17 100       48 ref ($excep = $$stm[2]->eval) eq 'JE::LValue'
584             and $excep = get $excep;
585             }
586 17 50       164 die defined $excep? $excep : $global->undefined;
587             }
588 316 50       1045 if ($type eq 'try') {
589             # We have one of the following:
590             # 1 2 3 4 5
591             # 'try' block ident block (catch)
592             # 'try' block block (finally)
593             # 'try' block ident block block (catch & finally)
594              
595 316         579 my $result;
596             my $propagate;
597              
598 316         535 eval { # try
599 316         460 local $return;
600 101     101   608 no warnings 'exiting';
  101         160  
  101         24593  
601 316         1256 RETURN: {
602 316         422 BREAK: {
603 316         373 CONT: {
604 316         384 $result = $$stm[2]->eval;
605 26         145 goto SAVERESULT;
606 0     0   0 } $propagate = sub{ next CONT }; goto SAVERESULT;
  0         0  
  0         0  
607 0     0   0 } $propagate = sub{ last BREAK }; goto SAVERESULT;
  0         0  
  0         0  
608 0     0   0 } $propagate = sub{ last RETURN }; goto SAVERESULT;
  0         0  
  0         0  
609              
610 26 50       79 SAVERESULT:
611             defined $result or $result = $return;
612 26         135 goto FINALLY;
613             };
614             # check ref first to avoid the overhead of overloading
615 290 50 66     11294 if (ref $@ || $@ ne '' and !ref $$stm[3]) { # catch
      33        
616 290         521 undef $result; # prevent { 3; throw ... } from
617             # returning 3
618              
619             # Turn miscellaneous errors into Error objects
620 290         939 $@ = JE'Code'_objectify_error($@);
621              
622 290         1447 (my $new_obj = new JE::Object $global)
623             ->prop({
624             name => $$stm[3],
625             value => $@,
626             dontdel => 1,
627             });
628 290         1277 local $scope = bless [
629             @$scope, $new_obj
630             ], 'JE::Scope';
631            
632 290         552 eval { # in case the catch block ends abruptly
633 290         419 local $return;
634 101     101   537 no warnings 'exiting';
  101         198  
  101         54559  
635 290         998 RETURN: {
636 290         397 BREAK: {
637 290         327 CONT: {
638 290         295 $result = $$stm[4]->eval;
639 290         1669 goto SAVE;
640 0     0   0 } $propagate = sub{ next CONT }; goto SAVE;
  0         0  
  0         0  
641 0     0   0 } $propagate = sub{ last BREAK }; goto SAVE;
  0         0  
  0         0  
642 0     0   0 } $propagate = sub{ last RETURN }; goto SAVE;
  0         0  
  0         0  
643              
644 290 50       832 SAVE:
645             defined $result or $result = $return;
646 290         2093 $@ = '';
647             }
648             }
649             # In case the 'finally' block resets $@:
650 290         1143 my $exception = $@;
651             FINALLY:
652 316 100 100     1862 if ($#$stm == 3 or $#$stm == 5) {
653 6         15 $$stm[-1]->eval;
654             }
655 316 50 33     2224 defined $exception and ref $exception || $exception ne ''
      66        
656             and die $exception;
657 316 100       957 $return = $result if defined $result;
658 316 50       2381 $propagate and &$propagate();
659             }
660             }
661              
662             sub _create_vars { # Process var and function declarations
663 2204     2204   3855 my $vars = $code->{vars};
664 2204         5601 for(@$vars) {
665 773 100       1570 if(ref) { # function
666             # format: [[...], function=> 'name',
667             # [ (params) ], $statements_obj, \@vars ]
668             # With optimisation on, the $statements_obj will
669             # actually be a code object.
670 168         952 $scope->[-1]->delete($$_[2], 1);
671 168         174 my $new_code_obj;
672 168 50       470 if(ref $$_[4] eq 'JE::Code') {
673 0         0 $new_code_obj = $$_[4]
674             }
675             else {
676 168         1323 ($new_code_obj = bless {
677             map+($_=>$code->{$_}),
678             qw/global source file line/
679             }, 'JE::Code')
680             ->{tree} = $$_[4];
681 168         432 $new_code_obj->{vars} = $$_[5];
682             }
683 168         1159 $scope->new_var($$_[2], new JE::Object::Function {
684             scope => $scope,
685             name => $$_[2],
686             argnames => $$_[3],
687             function => $new_code_obj
688             });
689             }
690             else {
691 605         1896 $scope->new_var($_);
692             }
693             }
694             }
695              
696              
697              
698              
699             package JE::Code::Expression;
700              
701             our $VERSION = '0.066';
702              
703             # B::Deparse showed me how to get these values.
704 101     101   694 use constant nan => sin 9**9**9;
  101         184  
  101         7000  
705 101     101   504 use constant inf => 9**9**9;
  101         186  
  101         4751  
706              
707 101     101   468 use subs qw'_eval_term';
  101         160  
  101         418  
708 101     101   30593 use POSIX 'fmod';
  101         559178  
  101         610  
709 101     101   92404 use Scalar::Util 'tainted';
  101         169  
  101         8010  
710              
711             import JE::Code 'add_line_number';
712             sub add_line_number;
713              
714 101     101   3096 BEGIN{*T = *JE::Code::T;}
715              
716              
717             #----------for reference------------#
718             #sub _to_int {
719             # call to_number first
720             # then...
721             # NaN becomes 0
722             # 0 and Infinity remain as they are
723             # other nums are rounded towards zero ($_ <=> 0) * floor(abs)
724             #}
725              
726             # Note that abs in ECMA-262
727             #sub _to_uint32 {
728             # call to_number, then ...
729              
730             # return 0 for Nan, -?inf and 0
731             # (round toward zero) % 2 ** 32
732             #}
733              
734             #sub _to_int32 {
735             # calculate _to_uint32 but subtract 2**32 if the result >= 2**31
736             #}
737              
738             #sub _to_uint16 {
739             # just like _to_uint32, except that 2**16 is used instead.
740             #}
741              
742              
743             #---------------------------------#
744              
745             { # JavaScript operators
746             # Note: some operators are not dealt with here, but inside
747             # sub eval.
748 101     101   538 no strict 'refs';
  101         156  
  101         47420  
749             *{'predelete'} = sub {
750 209 100   209   918 ref(my $term = shift) eq 'JE::LValue' or return
751             new JE::Boolean $global, 1;
752 203         678 my $base = $term->base;
753 203 100       1060 new JE::Boolean $global,
754             defined $base ? $base->delete($term->property) : 1;
755             };
756             *{'prevoid'} = sub {
757 318     318   424 my $term = shift;
758 318         953 $term = get $term while ref $term eq 'JE::LValue';
759 317         1213 return $global->undefined;
760             };
761             *{'pretypeof'} = sub {
762 166     166   347 my $term = shift;
763 166 100 100     1081 ref $term eq 'JE::LValue' and
764             ref base $term eq '' and
765             return _new JE::String $global, 'undefined';
766 165         964 _new JE::String $global, typeof $term;
767             };
768             *{'pre++'} = sub {
769             # ~~~ These is supposed to use the same rules
770             # as the + infix op for the actual
771             # addition part. Verify that it does this.
772 2886     2886   5063 my $term = shift;
773 2886         9084 $term->set(new JE::Number $global,
774             get $term->to_number + 1);
775             };
776             *{'pre--'} = sub {
777             # ~~~ These is supposed to use the same rules
778             # as the - infix op for the actual
779             # subtraction part. Verify that it does this.
780 12     12   18 my $term = shift;
781 12         35 $term->set(new JE::Number $global,
782             get $term->to_number->value - 1);
783             };
784             *{'pre+'} = sub {
785 594     594   1980 shift->to_number;
786             };
787             *{'pre-'} = sub {
788 7307     7307   21013 new JE::Number $global, -shift->to_number->value;
789             };
790             *{'pre~'} = sub {
791 38     38   106 my $num = shift->to_number->value;
792 38 100 100     196 $num =
793             $num != $num || abs($num) == inf # nan/+-inf
794             ? 0
795             : int($num) % 2**32;
796              
797 38 100       81 $num -= 2**32 if $num >= 2**31;
798              
799 101     101   28221 { use integer; # for signed bitwise negation
  101         28458  
  101         423  
  38         66  
800 38         50 $num = ~$num; }
801            
802 38         97 new JE::Number $global, $num;
803             };
804             *{'pre!'} = sub {
805 709     709   2605 new JE::Boolean $global, !shift->to_boolean->value
806             };
807             *{'in*'} = sub {
808 70     70   288 new JE::Number $global,
809             shift->to_number->value *
810             shift->to_number->value;
811             };
812             *{'in/'} = sub {
813 50     50   218 my($num,$denom) = map to_number $_->value, @_[0,1];
814 50 100 66     242 new JE::Number $global,
    100          
815             $denom ?
816             $num/$denom :
817             # Divide by zero:
818             $num && $num == $num # not zero or nan
819             ? $num * inf
820             : nan;
821             };
822             *{'in%'} = sub {
823 46     46   191 my($num,$denom) = map to_number $_->value,
824             @_[0,1];
825 46 100 100     500 new JE::Number $global,
    100          
826             $num+1 == $num ? nan :
827             $num == $num && abs($denom) == inf ?
828             $num :
829             fmod $num, $denom;
830             };
831             *{'in+'} = sub {
832 19803     19803   26808 my($x, $y) = @_;
833 19803         52024 $x = $x->to_primitive;
834 19803         68157 $y = $y->to_primitive;
835 19801 100 100     47220 if($x->typeof eq 'string' or
836             $y->typeof eq 'string') {
837 19494         45545 return _new JE::String $global,
838             $x->to_string->value16 .
839             $y->to_string->value16;
840             }
841 307         858 return new JE::Number $global,
842             $x->to_number->value +
843             $y->to_number->value;
844             };
845             *{'in-'} = sub {
846 57     57   274 new JE::Number $global,
847             shift->to_number->value -
848             shift->to_number->value;
849             };
850             *{'in<<'} = sub {
851 897     897   2947 my $num = shift->to_number->value;
852 897 100 100     5552 $num =
853             $num != $num || abs($num) == inf # nan/+-inf
854             ? $num = 0
855             : int($num) % 2**32;
856 897 100       2602 $num -= 2**32 if $num >= 2**31;
857              
858 897         4541 my $shift_by = shift->to_number->value;
859 897 100 100     4723 $shift_by =
860             $shift_by != $shift_by || abs($shift_by) == inf
861             ? 0
862             : int($shift_by) % 32;
863              
864 897         1383 my $ret = ($num << $shift_by) % 2**32;
865 897 100       1894 $ret -= 2**32 if $ret >= 2**31;
866              
867 897         2707 new JE::Number $global, $ret;
868              
869             # Fails on 64-bit:
870             #use integer;
871             #new JE::Number $global,
872             # $num << $shift_by;
873             };
874             *{'in>>'} = sub {
875 897     897   3428 my $num = shift->to_number->value;
876 897 100 100     5591 $num =
877             $num != $num || abs($num) == inf # nan/+-inf
878             ? $num = 0
879             : int($num) % 2**32;
880 897 100       2322 $num -= 2**32 if $num >= 2**31;
881              
882 897         4782 my $shift_by = shift->to_number->value;
883 897 100 100     4855 $shift_by =
884             $shift_by != $shift_by || abs($shift_by) == inf
885             ? 0
886             : int($shift_by) % 32;
887              
888 101     101   67202 use integer;
  101         164  
  101         355  
889 897         3097 new JE::Number $global,
890             $num >> $shift_by;
891             };
892             *{'in>>>'} = sub {
893 897     897   3253 my $num = shift->to_number->value;
894 897 100 100     5143 $num =
895             $num != $num || abs($num) == inf # nan/+-inf
896             ? $num = 0
897             : int($num) % 2**32;
898              
899 897         4197 my $shift_by = shift->to_number->value;
900 897 100 100     5134 $shift_by =
901             $shift_by != $shift_by || abs($shift_by) == inf
902             ? 0
903             : int($shift_by) % 32;
904              
905 897         3129 new JE::Number $global,
906             $num >> $shift_by;
907             };
908             *{'in<'} = sub {
909 1541     1541   6482 my($x,$y) = map to_primitive $_, @_[0,1];
910 1541 100 100     4513 new JE::Boolean $global,
911             $x->typeof eq 'string' &&
912             $y->typeof eq 'string'
913             ? $x->to_string->value16 lt $y->to_string->value16
914             : $x->to_number->[0] < $y->to_number->[0];
915             };
916             *{'in>'} = sub {
917 80     80   286 my($x,$y) = map to_primitive $_, @_[0,1];
918 80 100 100     226 new JE::Boolean $global,
919             $x->typeof eq 'string' &&
920             $y->typeof eq 'string'
921             ? $x->to_string->value16 gt $y->to_string->value16
922             : $x->to_number->[0] > $y->to_number->[0];
923             };
924             *{'in<='} = sub {
925 1574     1574   7263 my($x,$y) = map to_primitive $_, @_[0,1];
926 1574 100 100     4948 new JE::Boolean $global,
927             $x->typeof eq 'string' &&
928             $y->typeof eq 'string'
929             ? $x->to_string->value16 le $y->to_string->value16
930             : $x->to_number->[0] <= $y->to_number->[0];
931             };
932             *{'in>='} = sub {
933 72     72   244 my($x,$y) = map to_primitive $_, @_[0,1];
934 72 100 100     179 new JE::Boolean $global,
935             $x->typeof eq 'string' &&
936             $y->typeof eq 'string'
937             ? $x->to_string->value16 ge $y->to_string->value16
938             : $x->to_number->[0] >= $y->to_number->[0];
939             };
940             *{'ininstanceof'} = sub {
941 216     216   391 my($obj,$func) = @_;
942 216 100       1330 die new JE::Object::Error::TypeError $global,
943             add_line_number "$func is not an object"
944             if $func->primitive;
945              
946 214 100       978 die new JE::Object::Error::TypeError $global,
947             add_line_number "$func is not a function"
948             if $func->typeof ne 'function';
949            
950 213 100       833 return new JE::Boolean $global, 0 if $obj->primitive;
951              
952 208         884 my $proto_id = $func->prop('prototype');
953 208 100 100     1009 !defined $proto_id || $proto_id->primitive and die new
954             JE::Object::Error::TypeError $global,
955             add_line_number "Function $$$func{func_name} has no prototype property";
956 206         663 $proto_id = $proto_id->id;
957              
958 206   100     1329 0 while (defined($obj = $obj->prototype)
959             or return new JE::Boolean $global, 0),
960             $obj->id ne $proto_id;
961            
962 204         1031 new JE::Boolean $global, 1;
963             };
964             *{'inin'} = sub {
965 309     309   868 my($prop,$obj) = @_;
966 309 100       1302 die new JE::Object::Error::TypeError $global,
967             add_line_number "$obj is not an object"
968             if $obj->primitive;
969 308         1133 new JE::Boolean $global, defined $obj->prop($prop);
970             };
971             *{'in=='} = sub {
972 2724     2724   4765 my($x,$y) = @_;
973 2724         8450 my($xt,$yt) = (typeof $x, typeof $y);
974 2724         8013 my($xi,$yi) = ( id $x, id $y);
975 2724 100 100     22489 $xt eq $yt and return new JE::Boolean $global,
976             $xi eq $yi && $xi ne 'num:nan';
977              
978 146 100       376 $xi eq 'null' and
979             return new JE::Boolean $global,
980             $yi eq 'undef';
981 138 100       379 $xi eq 'undef' and
982             return new JE::Boolean $global,
983             $yi eq 'null';
984 98 100       297 $yi eq 'null' and
985             return new JE::Boolean $global,
986             $xi eq 'undef';
987 92 100       197 $yi eq 'undef' and
988             return new JE::Boolean $global,
989             $xi eq 'null';
990              
991 82 100       260 if($xt eq 'boolean') {
    100          
992 12         28 $x = to_number $x;
993 12         16 $xt = 'number';
994             }
995             elsif($yt eq 'boolean') {
996 8         25 $y = to_number $y;
997 8         13 $yt = 'number';
998             }
999              
1000 82 100 100     706 if($xt eq 'string' || $xt eq 'number' and !primitive $y)
    100 100        
      66        
      66        
1001 12         32 { $y = to_primitive $y; $yt = typeof $y }
  12         28  
1002             elsif
1003             ($yt eq 'string' || $yt eq 'number' and !primitive $x)
1004 42         154 { $x = to_primitive $x; $xt = typeof $x }
  42         101  
1005              
1006 82 50 66     784 ($xt eq 'number' and $yt eq 'string' || $yt eq 'number')
      66        
      33        
      66        
      66        
1007             ||
1008             ($yt eq 'number' and $xt eq 'string' || $xt eq 'number')
1009             and
1010             return new JE::Boolean $global,
1011             to_number $x->[0] == to_number $y->[0];
1012              
1013 20 50 33     132 $xt eq 'string' && $yt eq 'string' and
1014             return new JE::Boolean $global,
1015             $x->value16 eq $y->value16;
1016            
1017 0         0 new JE::Boolean $global, 0;
1018             };
1019             *{'in!='} = sub {
1020 1460     1460   2205 new JE::Boolean $global, !&{'in=='}->[0];
  1460         3815  
1021             };
1022             *{'in==='} = sub {
1023 8959     8959   12832 my($x,$y) = @_;
1024 8959         24569 my($xi,$yi) = ( id $x, id $y);
1025 8959   100     58103 return new JE::Boolean $global,
1026             $xi eq $yi && $xi ne 'num:nan';
1027             };
1028             *{'in!=='} = sub {
1029 68     68   108 new JE::Boolean $global, !&{'in==='}->[0];
  68         170  
1030             };
1031              
1032             # ~~~ These three bitwise operators are slower than molasses. There
1033             # must be some way to speed them up, but I'm not sure the research
1034             # is worth it. Does anyone actually use these in JS?
1035             *{'in&'} = sub {
1036 899     899   2590 my $num = shift->to_number->[0];
1037 899 100 100     4917 $num =
1038             $num != $num || abs($num) == inf
1039             ? 0
1040             : int($num) % 2**32;
1041 899 100       1963 $num -= 2**32 if $num >= 2**31;
1042              
1043 899         4049 my $num2 = shift->to_number->[0];
1044 899 100 100     4313 $num2 =
1045             $num2 != $num2 || abs($num2) == inf
1046             ? 0
1047             : int($num2) % 2**32;
1048 899 100       1934 $num2 -= 2**32 if $num2 >= 2**31;
1049              
1050 101     101   139629 use integer;
  101         181  
  101         416  
1051 899         2830 new JE::Number $global,
1052             $num & $num2;
1053             };
1054             *{'in^'} = sub {
1055 899     899   2961 my $num = shift->to_number->[0];
1056 899 100 100     5510 $num =
1057             $num != $num || abs($num) == inf
1058             ? 0
1059             : int($num) % 2**32;
1060 899 100       2144 $num -= 2**32 if $num >= 2**31;
1061              
1062 899         4596 my $num2 = shift->to_number->[0];
1063 899 100 100     4791 $num2 =
1064             $num2 != $num2 || abs($num2) == inf
1065             ? 0
1066             : int($num2) % 2**32;
1067 899 100       2255 $num2 -= 2**32 if $num2 >= 2**31;
1068              
1069 101     101   15706 use integer;
  101         159  
  101         403  
1070 899         3198 new JE::Number $global,
1071             $num ^ $num2;
1072             };
1073             *{'in|'} = sub {
1074 900     900   2701 my $num = shift->to_number->[0];
1075 900 100 100     5105 $num =
1076             $num != $num || abs($num) == inf
1077             ? 0
1078             : int($num) % 2**32;
1079 900 100       2090 $num -= 2**32 if $num >= 2**31;
1080              
1081 900         4254 my $num2 = shift->to_number->[0];
1082 900 100 100     4917 $num2 =
1083             $num2 != $num2 || abs($num2) == inf
1084             ? 0
1085             : int($num2) % 2**32;
1086 900 100       3685 $num2 -= 2**32 if $num2 >= 2**31;
1087              
1088 101     101   15100 use integer;
  101         155  
  101         422  
1089 900         2914 new JE::Number $global,
1090             $num | $num2;
1091             };
1092             }
1093              
1094             =begin for-me
1095              
1096             Types of expressions:
1097              
1098             'new' term args?
1099              
1100             'member/call' term ( subscript | args) *
1101              
1102             'postfix' term op
1103              
1104             'hash' term*
1105              
1106             'array' term? (comma term?)*
1107              
1108             'prefix' op+ term
1109              
1110             'lassoc' term (op term)*
1111              
1112             'assign' term (op term)* (term term)?
1113             (the last two terms are the 2nd and 3rd terms of ? :
1114              
1115             'expr' term*
1116             (commas are omitted from the array)
1117              
1118             'function' ident? params statements
1119              
1120             =end for-me
1121              
1122             =cut
1123              
1124              
1125             # Note: each expression object is an array ref. The elems are:
1126             # [0] - an array ref containing
1127             # [0] - the starting position in the source code and
1128             # [1] - the ending position
1129             # [1] - the type of expression
1130             # [2..$#] - the various terms/tokens that make up the expr
1131              
1132             sub eval { # evalate (sub)expression
1133 101     101   8066 no warnings 'exiting';
  101         159  
  101         36739  
1134 194631 100 100 194631   345065 ++ $ops>$counting and last JE_Code_OP if $counting;
1135            
1136 194630         185347 my $expr = shift;
1137              
1138 194630         264032 my $type = $$expr[1];
1139 194630         167507 my @labels;
1140              
1141 194630         246273 $pos = $$expr[0][0];
1142              
1143 194630 100       339461 if ($type eq 'expr') {
1144 72832         64461 my $result;
1145 72832 100       128752 if(@$expr == 3) { # no comma
1146 72434         134432 return _eval_term $$expr[-1];
1147             }
1148             else { # comma op
1149 398         1496 for (@$expr[2..$#$expr-1]) {
1150 1362         2532 $result = _eval_term $_ ;
1151 1362 100       5497 get $result if ref $result eq 'JE::LValue';
1152             }
1153 398         1326 $result = _eval_term $$expr[-1] ;
1154 398 100       2717 return ref $result eq 'JE::LValue' ? get $result
1155             : $result;
1156             }
1157             }
1158 121798 100       204618 if ($type eq 'assign') {
1159 7465         26285 my @copy = \(@$expr[2..$#$expr]);
1160             # Evaluation is done left-first in JS, unlike in
1161             # Perl, so a = b = c is evaluated in this order:
1162             # - evaluate a
1163             # - evaluate b
1164             # - evaluate c
1165             # - assign c to b
1166             # - assign b to a
1167              
1168             # Check first to see whether we have the terms
1169             # of a ? : at the end:
1170             my @qc_terms = @copy >= 3 && (
1171             ref ${$copy[-2]} # avoid stringification
1172 7465 100 33     24069 || ${$copy[-2]} =~ /^(?:[tfu]|[si0-9])/
1173             )
1174             ? (pop @copy, pop @copy) : ();
1175             # @qc_terms is now in reverse order
1176              
1177             # Make a list of operands, evalling each
1178 7465         9864 my @terms = _eval_term ${shift @copy};
  7465         17035  
1179 7465         16140 my @ops;
1180 7465         17184 while(@copy) {
1181 6927         8631 push @ops, ${shift @copy};
  6927         12750  
1182 6927         9859 push @terms, _eval_term ${shift @copy};
  6927         13895  
1183             }
1184              
1185 7464         12783 my $val = pop @terms;
1186              
1187             # Now apply ? : if it's there
1188 561         1779 @qc_terms and $val = _eval_term
1189 7464 100       16241 ${$qc_terms[$val->to_boolean->[0]]};
1190              
1191 7464         15512 for (reverse @ops) {
1192 101     101   653 no strict 'refs';
  101         147  
  101         24714  
1193 164         680 length > 1 and $val =
1194 6926 100       21140 &{'in'.substr $_,0,-1}(
1195             $terms[-1], $val
1196             );
1197 6926 100       27299 $val = $val->get if ref $val eq 'JE::LValue';
1198 6926 50 33     29530 T and tainted $taint and $val->can('taint')
1199             and $val = taint $val $taint;
1200 6926         9716 eval { (pop @terms)->set($val) };
  6926         18945  
1201 6926 100       28601 if (my $err = $@) {
1202 1 50       8 die $err if UNIVERSAL::isa($err, 'JE::Object::Error');
1203 1         3 die new JE::Object::Error::ReferenceError
1204             $global, add_line_number "Cannot assign to a non-lvalue";
1205             }
1206             # ~~~ This needs to check whether it was an error
1207             # other than 'Can't locate object method "set"
1208             # since store handlers can thrown other errors.
1209            
1210             }
1211 7463 100       17363 if(!@ops) { # If we only have ? : and no assignment
1212 553 100       1818 $val = $val->get if ref $val eq 'JE::LValue';
1213             }
1214 7463         63346 return $val;
1215             }
1216 114333 100       196133 if($type eq 'lassoc') { # left-associative
1217 32141         99642 my @copy = \(@$expr[2..$#$expr]);
1218 32141         41433 my $result = _eval_term ${shift @copy};
  32141         58269  
1219 32141         72966 while(@copy) {
1220 101     101   574 no strict 'refs';
  101         602  
  101         17997  
1221             # We have to deal with || && here for the sake of
1222             # short-circuiting
1223 41298         41830 my $op = ${$copy[0]};
  41298         66015  
1224 41298 100       110302 if ($op eq '&&') {
    100          
1225 485 100       1309 $result = _eval_term(${$copy[1]}) if
  458         924  
1226             $result->to_boolean->[0];
1227 485 100       1583 $result = $result->get
1228             if ref $result eq 'JE::LValue';
1229             }
1230             elsif($op eq '||') {
1231 110 100       501 $result = _eval_term(${$copy[1]}) unless
  25         63  
1232             $result->to_boolean->[0];
1233 110 100       497 $result = $result->get
1234             if ref $result eq 'JE::LValue';
1235             }
1236             else {
1237 40703 100       113998 $result = $result->get
1238             if ref $result eq 'JE::LValue';
1239 40702         157545 $result = &{"in$op"}(
  40702         80647  
1240 40702         50038 $result, _eval_term ${$copy[1]}
1241             );
1242             }
1243 41289         184441 splice @copy, 0, 2; # double shift
1244             }
1245 32132         108312 return $result;
1246             }
1247 82192 100       138497 if ($type eq 'prefix') {
1248             # $$expr[1] -- 'prefix'
1249             # @$expr[2..-2] -- prefix ops
1250             # $$expr[-1] -- operand
1251 12091         21121 my $term = _eval_term $$expr[-1];
1252              
1253 101     101   551 no strict 'refs';
  101         138  
  101         131532  
1254 12091         39646 $term = &{"pre$_"}($term) for reverse @$expr[2..@$expr-2];
  12239         47931  
1255 12081         43214 return $term;
1256             }
1257 70101 100       117361 if ($type eq 'postfix') {
1258             # ~~~ These are supposed to use the same rules
1259             # as the + and - infix ops for the actual
1260             # addition part. Verify that they do this.
1261              
1262 145         405 my $ret = (my $term = _eval_term $$expr[2])
1263             ->to_number;
1264 145         618 $term->set(new JE::Number $global,
1265             $ret->value + (-1,1)[$$expr[3] eq '++']);
1266 145         665 return $ret;
1267             }
1268 69956 100       119551 if ($type eq 'new') {
1269 1118 50       2882 return _eval_term($$expr[2])->construct(
    50          
    100          
1270             @$expr == 4
1271             ? T && tainted $taint
1272             ? map $_->can('taint') ?taint $_ $taint:$_,
1273             $$expr[-1]->list
1274             : $$expr[-1]->list
1275             : ()
1276             );
1277             }
1278 68838 100       122965 if($type eq 'member/call') {
1279 62931         102129 my $obj = _eval_term $$expr[2];
1280 62931         157663 for (@$expr[3..$#$expr]) {
1281 69246 100       151585 if(ref eq 'JE::Code::Subscript') {
1282 46977 100       159127 $obj = get $obj
1283             if ref $obj eq 'JE::LValue';
1284 46977         122060 $obj = new JE::LValue $obj, $_->str_val;
1285             }
1286             else {
1287 22269 0       78151 $obj = $obj->call(
    50          
1288             T && tainted $taint
1289             ? map $_->can('taint')
1290             ? taint $_ $taint
1291             : $_,
1292             $_->list
1293             : $_->list
1294             );
1295             # If $obj is an lvalue,
1296             # JE::LValue::call will make
1297             # the lvalue's base object the 'this'
1298             # value. Otherwise,
1299             # JE::Object::Function::call
1300             # will make the
1301             # global object the 'this' value.
1302             }
1303             # ~~~ need some error-checking
1304             }
1305 62764         281740 return $obj; # which may be an lvalue
1306             }
1307 5907 100       12366 if($type eq 'array') {
1308 5260         4899 my @ary;
1309 5260         10332 for (2..$#$expr) {
1310 36225 100       65827 if(ref $$expr[$_] eq 'comma') {
1311 15614 100 100     70294 ref $$expr[$_-1] eq 'comma' || $_ == 2
1312             and ++$#ary
1313             }
1314             else {
1315 20611         32639 push @ary, _eval_term $$expr[$_];
1316 20611 100       61219 $ary[-1] = $ary[-1]->get
1317             if ref $ary[-1] eq 'JE::LValue';
1318             }
1319             }
1320              
1321 5259         16661 my $ary = new JE::Object::Array $global;
1322 5259         8640 $$$ary{array} = \@ary; # sticking it in like this
1323             # makes 'undef' elements non-
1324             # existent, rather
1325             # than undefined
1326 5259         17101 return $ary;
1327             }
1328 647 100       1585 if($type eq 'hash') {
1329 463         1770 my $obj = new JE::Object $global;
1330 463         1718 local @_ = \(@$expr[2..$#$expr]);
1331 463         673 my (@keys, $key, $value);
1332 463         1223 while(@_) { # I have to loop through them to keep
1333             # the order.
1334 94         106 $key = ${+shift};
  94         169  
1335 94         110 $value = _eval_term ${shift;};
  94         187  
1336 94 100       308 $value = get $value if ref $value eq 'JE::LValue';
1337 94         265 $obj->prop($key, $value);
1338             }
1339 463         1752 return $obj;
1340             }
1341 184 50       654 if ($type eq 'func') {
1342             # format: [[...], function=> 'name',
1343             # [ params ], $statements_obj, \@vars]
1344             # or: [[...], function =>
1345             # [ params ], $statements_obj, \@vars]
1346 184 100       760 my($name,$params,$statements) = ref $$expr[2] ?
1347             (undef, @$expr[2,3]) : @$expr[2..4];
1348 184 100       423 my $func_scope = $name
1349             ? bless([@$scope, my $obj=new JE::Object $global],
1350             'JE::Scope')
1351             : $scope;
1352 184         2130 (my $new_code_obj = bless {
1353             map+($_=>$code->{$_}),qw/global source file line/
1354             }, 'JE::Code')
1355             ->{tree} = $statements;
1356 184         585 $new_code_obj->{vars} = $$expr[-1];
1357 184 100       1442 my $f = new JE::Object::Function {
1358             scope => $func_scope,
1359             defined $name ? (name => $name) : (),
1360             argnames => $params,
1361             function => $new_code_obj,
1362             };
1363 184 100       607 if($name) {
1364 7         43 $obj->prop({
1365             name => $name,
1366             value => $f,
1367             readonly => 1,
1368             dontdel => 1,
1369             });
1370             }
1371 184         741 return $f;
1372             }
1373             }
1374             sub _eval_term {
1375 300789     300789   356212 my $term = $_[0];
1376              
1377 300789 100       716099 return $term->eval if ref $term eq 'JE::Code::Expression';
1378              
1379 175104 50       1296326 ref $term ? ref $term eq 'ARRAY'
    50          
    50          
    50          
    100          
    100          
    100          
    100          
1380             ? ( require JE::Object::RegExp,
1381             return JE::Object::RegExp->new(
1382             $global, @$term
1383             ) )
1384             : $term :
1385             $term eq'this'? $this :
1386             $term =~ /^s/ ? $_[0] = JE::String->_new($global,substr $term,1) :
1387             $term =~ /^i/ ? $scope->find_var(substr $term,1) :
1388             $term eq 't' ? $global->true :
1389             $term eq 'f' ? $global->false :
1390             $term eq 'n' ? $global->null :
1391             ($_[0] = JE::Number->new($global,$term));
1392             }
1393              
1394              
1395              
1396              
1397             package JE::Code::Subscript;
1398              
1399             our $VERSION = '0.066';
1400              
1401             sub str_val {
1402 46977     46977   70084 my $val = (my $self = shift)->[1];
1403 46977 100       137512 ref $val ? ''.$val->eval : $val;
1404             }
1405              
1406              
1407              
1408              
1409             package JE::Code::Arguments;
1410              
1411             our $VERSION = '0.066';
1412              
1413             sub list {
1414 23217     23217   26096 my $self = shift;
1415              
1416             # I can't use map here, because this method is called from within
1417             # a foreach loop, and an exception might be thrown from within
1418             # _eval_term, which has strange effects in perl 5.8.x (see perl
1419             # bug #24254).
1420              
1421 23217         23373 if(1) {
1422 23217         24458 my @result;
1423 23217         48877 for(@$self[1..$#$self]) {
1424 40871         64525 my $val = JE::Code::Expression::_eval_term($_);
1425 40868 100       136864 push @result, ref $val eq 'JE::LValue' ? $val->get : $val
1426             }
1427 23214         105986 @result;
1428              
1429             }else{ # original code
1430             map { my $val = JE::Code::Expression::_eval_term($_);
1431             ref $val eq 'JE::LValue' ? $val->get : $val }
1432             @$self[1..$#$self];
1433             }
1434             }
1435              
1436              
1437              
1438              
1439             1;
1440             __END__