File Coverage

blib/lib/JE.pm
Criterion Covered Total %
statement 352 388 90.7
branch 203 240 84.5
condition 33 45 73.3
subroutine 76 99 76.7
pod 13 13 100.0
total 677 785 86.2


line stmt bran cond sub pod time code
1             package JE;
2              
3             # If you are looking at the source code (which you are obviously doing
4             # if you are reading this), note that '# ~~~' is my way of marking
5             # something to be done still (except in this sentence).
6              
7             # Note also that comments like "# E 7.1" refer to the indicated
8             # clause (7.1 in this case) in the ECMA-262 standard.
9              
10 99     99   1518394 use 5.008004;
  99         286  
  99         3255  
11 99     99   395 use strict;
  99         115  
  99         2314  
12 99     99   372 use warnings; no warnings 'utf8';
  99     99   191  
  99         2273  
  99         346  
  99         166  
  99         4004  
13              
14             our $VERSION = '0.064';
15              
16 99     99   418 use Carp 'croak';
  99         118  
  99         5162  
17 99     99   19872 use JE::Code 'add_line_number';
  99         249  
  99         4604  
18 99     99   16078 use JE::_FieldHash;
  99         189  
  99         4676  
19 99     99   475 use Scalar::Util 1.09 qw'blessed refaddr weaken';
  99         1582  
  99         11972  
20              
21             our @ISA = 'JE::Object';
22              
23             require JE::Null ;
24             require JE::Number ;
25             require JE::Object ;
26             require JE::Object::Function;
27             require JE::Parser ;
28             require JE::Scope ;
29             require JE::String ;
30             require JE::Undefined ;
31              
32             =encoding UTF-8
33              
34             =head1 NAME
35              
36             JE - Pure-Perl ECMAScript (JavaScript) Engine
37              
38             =head1 VERSION
39              
40             Version 0.064 (alpha release)
41              
42             The API is still subject to change. If you have the time and the interest,
43             please experiment with this module (or even lend a hand :-).
44             If you have any ideas for the API, or would like to help with development,
45             please e-mail the author.
46              
47             =head1 SYNOPSIS
48              
49             use JE;
50              
51             $j = new JE; # create a new global object
52              
53             $j->eval('({"this": "that", "the": "other"}["this"])');
54             # returns "that"
55              
56             $parsed = $j->parse('new Array(1,2,3)');
57            
58             $rv = $parsed->execute; # returns a JE::Object::Array
59             $rv->value; # returns a Perl array ref
60              
61             $obj = $j->eval('new Object');
62             # create a new object
63              
64             $foo = $j->{document}; # get property
65             $j->{document} = $obj; # set property
66             $j->{document} = {}; # gets converted to a JE::Object
67             $j->{document}{location}{href}; # autovivification
68              
69             $j->method(alert => "text"); # invoke a method
70              
71              
72             # create global function from a Perl subroutine:
73             $j->new_function(print => sub { print @_, "\n" } );
74              
75             $j->eval(<<'--end--');
76             function correct(s) {
77             s = s.replace(/[EA]/g, function(s){
78             return ['E','A'][+(s=='E')]
79             })
80             return s.charAt(0) +
81             s.substring(1,4).toLowerCase() +
82             s.substring(4)
83             }
84             print(correct("ECMAScript")) // :-)
85             --end--
86              
87             =head1 DESCRIPTION
88              
89             JE, short for JavaScript::Engine (imaginative, isn't it?), is a pure-Perl
90             JavaScript engine. Here are some of its
91             strengths:
92              
93             =over 4
94              
95             =item -
96              
97             Easy to install (no C compiler necessary*)
98              
99             =item -
100              
101             The parser can be extended/customised to support extra (or
102             fewer) language features (not yet complete)
103              
104             =item -
105              
106             All JavaScript datatypes can be manipulated directly from Perl (they all
107             have overloaded operators)
108              
109             =item -
110              
111             The JavaScript datatypes provide C methods for compatibility with
112             L.
113              
114             =back
115              
116             JE's greatest weakness is that it's slow (well, what did you expect?). It
117             also uses and leaks lots of memory. (There is an experimental
118             L module that solves this if you load
119             it first and then call C on the JE object when
120             you have finished with it.)
121              
122             * If you are using perl 5.9.3 or lower, then L is
123             required. Recent versions of it require L, an XS module
124             (which requires a compiler of course), but version 0.02 of the former is
125             just pure Perl with no XS dependencies.
126              
127             There is currently an experimental version of the run-time engine, which is
128             supposed to be faster, although it currently makes compilation slower. (If
129             you serialise the compiled code and use that, you should notice a
130             speed-up.) It will eventually replace the current one when it is complete.
131             (It does not yet respect tainting or max_ops, or report line numbers
132             correctly.) You can activate it by setting to 1 the ridiculously named
133             YES_I_WANT_JE_TO_OPTIMISE environment variable, which is just a
134             temporary hack that will later be removed.
135              
136             =head1 USAGE
137              
138             =head2 Simple Use
139              
140             If you simply need to run a few JS functions from Perl, create a new JS
141             environment like this:
142              
143             my $je = new JE;
144              
145             If necessary, make Perl subroutines available to JavaScript:
146              
147             $je->new_function(warn => sub { warn @_ });
148             $je->new_function(ok => \&Test::More::ok);
149              
150             Then pass the JavaScript functions to C:
151              
152             $je->eval(<<'___');
153              
154             function foo() {
155             return 42
156             }
157             // etc.
158             ___
159              
160             # or perhaps:
161             use File::Slurp;
162             $je->eval(scalar read_file 'functions.js');
163              
164             Then you can access those function from Perl like this:
165              
166             $return_val = $je->{foo}->();
167             $return_val = $je->eval('foo()');
168              
169             The return value will be a special object that, when converted to a string,
170             boolean or number, will behave exactly as in JavaScript. You can also use
171             it as a hash, to access or modify its properties. (Array objects can be
172             used as arrays, too.) To call one of its
173             JS methods, you should use the C method:
174             C<< $return_val->method('foo') >>. See L for more information.
175              
176             =head2 Custom Global Objects
177              
178             To create a custom global object, you have to subclass JE. For instance,
179             if all you need to do is add a C property that refers to the global
180             object, then override the C method like this:
181              
182             package JEx::WithSelf;
183             @ISA = 'JE';
184             sub new {
185             my $self = shift->SUPER::new(@_);
186             $self->{self} = $self;
187             return $self;
188             }
189              
190             =head2 Using Perl Objects from JS
191              
192             See C, below.
193              
194             =head2 Writing Custom Data Types
195              
196             See L.
197              
198             =head1 METHODS
199              
200             See also L<< C >>, which this
201             class inherits from, and L<< C >>.
202              
203             =over 4
204              
205             =item $j = JE->new( %opts )
206              
207             This class method constructs and returns a new JavaScript environment, the
208             JE object itself being the global object.
209              
210             The (optional) options it can take are C and C, which
211             correspond to the methods listed below.
212              
213             =cut
214              
215             our $s = qr.[\p{Zs}\s\ck]*.;
216              
217             sub new {
218 106     106 1 7810 my $class = shift;
219              
220             # I can't use the usual object and function constructors, since
221             # they both rely on the existence of the global object and its
222             # 'Object' and 'Function' properties.
223              
224 106 50       412 if(ref $class) {
225 0         0 croak "JE->new is a class method and cannot be called " .
226             "on a" . ('n' x ref($class) =~ /^[aoeui]/i) . ' ' .
227             ref($class). " object."
228             }
229              
230             # Commented lines here are just for reference:
231             my $self = bless \{
232             #prototype => (Object.prototype)
233             #global => ...
234             keys => [],
235             props => {
236             Object => bless(\{
237             #prototype => (Function.prototype)
238             #global => ...
239             #scope => bless [global], JE::Scope
240             func_name => 'Object',
241             func_argnames => [],
242             func_args => ['global','args'],
243             function => sub { # E 15.2.1
244 15     15   48 return JE::Object->new( @_ );
245             },
246             constructor_args => ['global','args'],
247             constructor => sub {
248 24     24   69 return JE::Object->new( @_ );
249             },
250             keys => [],
251             props => {
252             #length => JE::Number->new(1),
253             prototype => bless(\{
254             #global => ...
255             keys => [],
256             props => {},
257             }, 'JE::Object')
258             },
259             prop_readonly => {
260             prototype => 1,
261             length => 1,
262             },
263             prop_dontdel => {
264             prototype => 1,
265             length => 1,
266             },
267             }, 'JE::Object::Function'),
268             Function => bless(\{
269             #prototype => (Function.prototype)
270             #global => ...
271             #scope => bless [global], JE::Scope
272             func_name => 'Function',
273             func_argnames => [],
274             func_args => ['scope','args'],
275             function => sub { # E 15.3.1
276 20         93 JE::Object::Function->new(
277 20     20   22 $${$_[0][0]}{global},
278             @_[1..$#_]
279             );
280             },
281             constructor_args => ['scope','args'],
282             constructor => sub {
283 34         172 JE::Object::Function->new(
284 34     34   44 $${$_[0][0]}{global},
285             @_[1..$#_]
286             );
287             },
288 106         4470 keys => [],
289             props => {
290             #length => JE::Number->new(1),
291             prototype => bless(\{
292             #prototype=>(Object.proto)
293             #global => ...
294             func_argnames => [],
295             func_args => [],
296             function => '',
297             keys => [],
298             props => {},
299             }, 'JE::Object::Function')
300             },
301             prop_readonly => {
302             prototype => 1,
303             length => 1,
304             },
305             prop_dontdel => {
306             prototype => 1,
307             length => 1,
308             },
309             }, 'JE::Object::Function'),
310             },
311             }, $class;
312              
313 106         983 my $obj_proto =
314             (my $obj_constr = $self->prop('Object')) ->prop('prototype');
315 106         415 my $func_proto =
316             (my $func_constr = $self->prop('Function'))->prop('prototype');
317              
318 106         641 $self->prototype( $obj_proto );
319 106         255 $$$self{global} = $self;
320              
321 106         468 $obj_constr->prototype( $func_proto );
322 106         224 $$$obj_constr{global} = $self;
323 106         477 my $scope = $$$obj_constr{scope} = bless [$self], 'JE::Scope';
324              
325 106         298 $func_constr->prototype( $func_proto );
326 106         192 $$$func_constr{global} = $self;
327 106         214 $$$func_constr{scope} = $scope;
328              
329 106         2459 $$$obj_proto{global} = $self;
330              
331 106         306 $func_proto->prototype( $obj_proto );
332 106         201 $$$func_proto{global} = $self;
333              
334 106         798 $obj_constr ->prop(
335             {name=>'length',dontenum=>1,value=>new JE::Number $self,1}
336             );
337 106         495 $func_constr->prop(
338             {name=>'length',dontenum=>1,value=>new JE::Number $self,1}
339             );
340 106         526 $func_proto->prop({name=>'length', value=>0, dontenum=>1});
341              
342 106 50       378 if($JE::Destroyer) {
343 0         0 JE::Destroyer'register($_) for $obj_constr, $func_constr;
344             }
345              
346             # Before we add anything else, we need to make sure that our global
347             # true/false/undefined/null values are available.
348 106         780 @{$$self}{qw{ t f u n }} = (
  106         532  
349             JE::Boolean->new($self, 1),
350             JE::Boolean->new($self, 0),
351             JE::Undefined->new($self),
352             JE::Null->new($self),
353             );
354              
355 106         443 $self->prototype_for('Object', $obj_proto);
356 106         268 $self->prototype_for('Function', $func_proto);
357 106         427 JE::Object::_init_proto($obj_proto);
358 106         615 JE::Object::Function::_init_proto($func_proto);
359              
360              
361             # The rest of the constructors
362             # E 15.1.4
363 106         824 $self->prop({
364             name => 'Array',
365             autoload =>
366             'require JE::Object::Array;
367             JE::Object::Array::_new_constructor($global)',
368             dontenum => 1,
369             });
370 106         591 $self->prop({
371             name => 'String',
372             autoload =>
373             'require JE::Object::String;
374             JE::Object::String::_new_constructor($global)',
375             dontenum => 1,
376             });
377 106         534 $self->prop({
378             name => 'Boolean',
379             autoload =>
380             'require JE::Object::Boolean;
381             JE::Object::Boolean::_new_constructor($global)',
382             dontenum => 1,
383             });
384 106         527 $self->prop({
385             name => 'Number',
386             autoload =>
387             'require JE::Object::Number;
388             JE::Object::Number::_new_constructor($global)',
389             dontenum => 1,
390             });
391 106         502 $self->prop({
392             name => 'Date',
393             autoload =>
394             'require JE::Object::Date;
395             JE::Object::Date::_new_constructor($global)',
396             dontenum => 1,
397             });
398 106         501 $self->prop({
399             name => 'RegExp',
400             autoload =>
401             'require JE::Object::RegExp;
402             JE::Object::RegExp->new_constructor($global)',
403             dontenum => 1,
404             });
405 106         498 $self->prop({
406             name => 'Error',
407             autoload =>
408             'require JE::Object::Error;
409             JE::Object::Error::_new_constructor($global)',
410             dontenum => 1,
411             });
412             # No EvalError
413 106         533 $self->prop({
414             name => 'RangeError',
415             autoload => 'require JE::Object::Error::RangeError;
416             JE::Object::Error::RangeError
417             ->_new_subclass_constructor($global)',
418             dontenum => 1,
419             });
420 106         529 $self->prop({
421             name => 'ReferenceError',
422             autoload => 'require JE::Object::Error::ReferenceError;
423             JE::Object::Error::ReferenceError
424             ->_new_subclass_constructor($global)',
425             dontenum => 1,
426             });
427 106         555 $self->prop({
428             name => 'SyntaxError',
429             autoload => 'require JE::Object::Error::SyntaxError;
430             JE::Object::Error::SyntaxError
431             ->_new_subclass_constructor($global)',
432             dontenum => 1,
433             });
434 106         491 $self->prop({
435             name => 'TypeError',
436             autoload => 'require JE::Object::Error::TypeError;
437             JE::Object::Error::TypeError
438             ->_new_subclass_constructor($global)',
439             dontenum => 1,
440             });
441 106         483 $self->prop({
442             name => 'URIError',
443             autoload => 'require JE::Object::Error::URIError;
444             JE::Object::Error::URIError
445             ->_new_subclass_constructor($global)',
446             dontenum => 1,
447             });
448              
449             # E 15.1.1
450 106         465 $self->prop({
451             name => 'NaN',
452             value => JE::Number->new($self, 'NaN'),
453             dontenum => 1,
454             dontdel => 1,
455             });
456 106         541 $self->prop({
457             name => 'Infinity',
458             value => JE::Number->new($self, 'Infinity'),
459             dontenum => 1,
460             dontdel => 1,
461             });
462 106         478 $self->prop({
463             name => 'undefined',
464             value => $self->undefined,
465             dontenum => 1,
466             dontdel => 1,
467             });
468              
469              
470             # E 15.1.2
471             $self->prop({
472             name => 'eval',
473             value => JE::Object::Function->new({
474             scope => $self,
475             name => 'eval',
476             argnames => ['x'],
477             function_args => [qw< args >],
478             function => sub {
479 104     104   140 my($code) = @_;
480 104 100       220 return $self->undefined unless defined
481             $code;
482 103 100       320 return $code if typeof $code ne 'string';
483 101         138 my $old_at = $@; # hope it's not tied
484 101 100 66     432 defined (my $tree =
485             ($JE::Code::parser||$self)
486             ->parse($code))
487             or die;
488 94         345 my $ret = execute $tree
489             $JE::Code::this,
490             $JE::Code::scope, 1;
491              
492 94 100       354 ref $@ ne '' and die;
493            
494 88         119 $@ = $old_at;
495 88         672 $ret;
496             },
497 106         1363 no_proto => 1,
498             }),
499             dontenum => 1,
500             });
501             $self->prop({
502             name => 'parseInt',
503             value => JE::Object::Function->new({
504             scope => $self,
505             name => 'parseInt', # E 15.1.2.2
506             argnames => [qw/string radix/],
507             no_proto => 1,
508             function_args => [qw< scope args >],
509             function => sub {
510 2687     2687   3376 my($scope,$str,$radix) = @_;
511 2687 100       8374 $radix = defined $radix
512             ? $radix->to_number->value
513             : 0;
514 2687 100 100     14921 $radix == $radix and $radix != $radix+1
515             or $radix = 0;
516            
517 2687 100       4810 if(defined $str) {
518 2686         6053 ($str = $str->to_string)
519             =~ s/^$s//;
520 1         2 } else { $str = 'undefined' };
521 2687 100       13396 my $sign = $str =~ s/^([+-])//
522             ? (-1,1)[$1 eq '+']
523             : 1;
524 2687         5108 $radix = (int $radix) % 2 ** 32;
525 2687 100       6433 $radix -= 2**32 if $radix >= 2**31;
526 2687 100 66     6799 $radix ||= $str =~ /^0x/i
527             ? 16
528             : 10
529             ;
530 2687 100       10928 $radix == 16 and
531             $str =~ s/^0x//i;
532              
533 2687 100 100     11349 $radix < 2 || $radix > 36 and return
534             JE::Number->new($self,'nan');
535            
536 2043         10897 my @digits = (0..9, 'a'..'z')[0
537             ..$radix-1];
538 2043         7647 my $digits = join '', @digits;
539 2043         51962 $str =~ /^([$digits]*)/i;
540 2043         6002 $str = $1;
541              
542 2043         2078 my $ret;
543 2043 100       8867 if(!length $str){
    100          
    100          
    100          
    100          
544 707         1116 $ret= 'nan' ;
545             }
546             elsif($radix == 10) {
547 204         529 $ret= $sign * $str;
548             }
549             elsif($radix == 16) {
550 161         556 $ret= $sign * hex $str;
551             }
552             elsif($radix == 8) {
553 28         127 $ret= $sign * oct $str;
554             }
555             elsif($radix == 2) {
556 28         1453 $ret= $sign * eval
557             "0b$str";
558             }
559 915         1116 else { my($num, $place);
560 915         2559 for (reverse split //, $str){
561 1657 100       6965 $num += ($_ =~ /[0-9]/ ? $_
562             : ord(uc) - 55)
563             * $radix**$place++
564             }
565 915         1376 $ret= $num*$sign;
566             }
567              
568 2043         6671 return JE::Number->new($self,$ret);
569             },
570 106         1721 }),
571             dontenum => 1,
572             });
573             $self->prop({
574             name => 'parseFloat',
575             value => JE::Object::Function->new({
576             scope => $self,
577             name => 'parseFloat', # E 15.1.2.3
578             argnames => [qw/string/],
579             no_proto => 1,
580             function_args => [qw< scope args >],
581             function => sub {
582 694     694   1191 my($scope,$str,$radix) = @_;
583            
584 694 100       1460 defined $str or $str = '';
585 694 100       1652 ref $str eq 'JE::Number' and return $str;
586 692 50       1323 ref $str eq 'JE::Object::Number'
587             and return $str->to_number;
588 692 100       3419 return JE::Number->new($self, $str =~
589             /^$s
590             (
591             [+-]?
592             (?:
593             (?=[0-9]|\.[0-9]) [0-9]*
594             (?:\.[0-9]*)?
595             (?:[Ee][+-]?[0-9]+)?
596             |
597             Infinity
598             )
599             )
600             /ox
601             ? $1 : 'nan');
602             },
603 106         1371 }),
604             dontenum => 1,
605             });
606             $self->prop({
607             name => 'isNaN',
608             value => JE::Object::Function->new({
609             scope => $self,
610             name => 'isNaN',
611             argnames => [qw/number/],
612             no_proto => 1,
613             function_args => ['args'],
614             function => sub {
615 99   100 99   416 JE::Boolean->new($self,
616             !defined $_[0] ||
617             shift->to_number->id eq 'num:nan');
618             },
619 106         1207 }),
620             dontenum => 1,
621             });
622             $self->prop({
623             name => 'isFinite',
624             value => JE::Object::Function->new({
625             scope => $self,
626             name => 'isFinite',
627             argnames => [qw/number/],
628             no_proto => 1,
629             function_args => ['args'],
630             function => sub {
631 12     12   14 my $val = shift;
632 12   100     67 JE::Boolean->new($self,
633             defined $val &&
634             ($val = $val->to_number->value)
635             == $val &&
636             $val + 1 != $val
637             );
638             },
639 106         1273 }),
640             dontenum => 1,
641             });
642              
643             # E 15.1.3
644 106         641 $self->prop({
645             name => 'decodeURI',
646             autoload => q{ require 'JE/escape.pl';
647             JE::Object::Function->new({
648             scope => $global,
649             name => 'decodeURI',
650             argnames => [qw/encodedURI/],
651             no_proto => 1,
652             function_args => ['scope','args'],
653             function => \&JE'_decodeURI,
654             })
655             },
656             dontenum => 1,
657             });
658 106         527 $self->prop({
659             name => 'decodeURIComponent',
660             autoload => q{ require 'JE/escape.pl';
661             JE::Object::Function->new({
662             scope => $global,
663             name => 'decodeURIComponent',
664             argnames => [qw/encodedURIComponent/],
665             no_proto => 1,
666             function_args => ['scope','args'],
667             function => \&JE'_decodeURIComponent
668             })
669             },
670             dontenum => 1,
671             });
672 106         538 $self->prop({
673             name => 'encodeURI',
674             autoload => q{ require 'JE/escape.pl';
675             JE::Object::Function->new({
676             scope => $global,
677             name => 'encodeURI',
678             argnames => [qw/uri/],
679             no_proto => 1,
680             function_args => ['scope','args'],
681             function => \&JE'_encodeURI,
682             })
683             },
684             dontenum => 1,
685             });
686 106         507 $self->prop({
687             name => 'encodeURIComponent',
688             autoload => q{ require 'JE/escape.pl';
689             JE::Object::Function->new({
690             scope => $global,
691             name => 'encodeURIComponent',
692             argnames => [qw/uriComponent/],
693             no_proto => 1,
694             function_args => ['scope','args'],
695             function => \&JE'_encodeURIComponent,
696             })
697             },
698             dontenum => 1,
699             });
700              
701             # E 15.1.5 / 15.8
702 106         2408 $self->prop({
703             name => 'Math',
704             autoload => 'require JE::Object::Math;
705             JE::Object::Math->new($global)',
706             dontenum => 1,
707             });
708              
709             # E B.2
710 106         568 $self->prop({
711             name => 'escape',
712             autoload => q{
713             require 'JE/escape.pl';
714             JE::Object::Function->new({
715             scope => $global,
716             name => 'escape',
717             argnames => [qw/string/],
718             no_proto => 1,
719             function_args => ['scope','args'],
720             function => \&JE'_escape,
721             })
722             },
723             dontenum => 1,
724             });
725 106         545 $self->prop({
726             name => 'unescape',
727             autoload => q{
728             require 'JE/escape.pl';
729             JE::Object::Function->new({
730             scope => $global,
731             name => 'unescape',
732             argnames => [qw/string/],
733             no_proto => 1,
734             function_args => ['scope','args'],
735             function => \&JE'_unescape,
736             })
737             },
738             dontenum => 1,
739             });
740              
741              
742             # Constructor args
743 106         251 my %args = @_;
744 106         363 $$$self{max_ops} = delete $args{max_ops};
745 106         286 $$$self{html_mode} = delete $args{html_mode};
746              
747 106         500 $self;
748             }
749              
750              
751              
752              
753             =item $j->parse( $code, $filename, $first_line_no )
754              
755             C parses the code contained in C<$code> and returns a parse
756             tree (a JE::Code object).
757              
758             If the syntax is not valid, C will be returned and C<$@> will
759             contain an
760             error message. Otherwise C<$@> will be a null string.
761              
762             The JE::Code class provides the method
763             C for executing the
764             pre-compiled syntax tree.
765              
766             C<$filename> and C<$first_line_no>, which are both optional, will be stored
767             inside the JE::Code object and used for JS error messages. (See also
768             L in the JE::Code man page.)
769              
770             =item $j->compile( STRING )
771              
772             Just an alias for C.
773              
774             =cut
775              
776             sub parse {
777 340     340 1 31141 goto &JE::Code::parse;
778             }
779             *compile = \&parse;
780              
781              
782             =item $j->eval( $code, $filename, $lineno )
783              
784             C evaluates the JavaScript code contained in C<$code>. E.g.:
785              
786             $j->eval('[1,2,3]') # returns a JE::Object::Array which can be used as
787             # an array ref
788              
789             If C<$filename> and C<$lineno> are specified, they will be used in error
790             messages. C<$lineno> is the number of the first line; it defaults to 1.
791              
792             If an error occurs, C will be returned and C<$@> will contain the
793             error message. If no error occurs, C<$@> will be a null string.
794              
795             This is actually just
796             a wrapper around C and the C method of the
797             JE::Code class.
798              
799             If the JavaScript code evaluates to an lvalue, a JE::LValue object will be
800             returned. You can use this like any other return value (e.g., as an array
801             ref if it points to a JS array). In addition, you can use the C and
802             C methods to set/get the value of the property to which the lvalue
803             refers. (See also L.) E.g., this will create a new object
804             named C:
805              
806             $j->eval('this.document')->set({});
807              
808             Note that I used C rather than just C, since the
809             latter would throw an error if the variable did not exist.
810              
811             =cut
812              
813             sub eval {
814 118     118 1 613 my $code = shift->parse(@_);
815 118 100       304 $@ and return;
816              
817 115         449 $code->execute;
818             }
819              
820              
821              
822              
823             =item $j->new_function($name, sub { ... })
824              
825             =item $j->new_function(sub { ... })
826              
827             This creates and returns a new function object. If $name is given,
828             it will become a property of the global object.
829              
830             Use this to make a Perl subroutine accessible from JavaScript.
831              
832             For more ways to create functions, see L.
833              
834             This is actually a method of JE::Object, so you can use it on any object:
835              
836             $j->{Math}->new_function(double => sub { 2 * shift });
837              
838              
839             =item $j->new_method($name, sub { ... })
840              
841             This is just like C, except that, when the function is
842             called, the subroutine's first argument (number 0) will be the object
843             with which the function is called. E.g.:
844              
845             $j->eval('String.prototype')->new_method(
846             reverse => sub { scalar reverse shift }
847             );
848             # ... then later ...
849             $j->eval(q[ 'a string'.reverse() ]); # returns 'gnirts a'
850              
851              
852             =item $j->max_ops
853              
854             =item $j->max_ops( $new_value )
855              
856             Use this to set the maximum number of operations that C (or
857             JE::Code's C) will run before terminating. (You can use this for
858             runaway scripts.) The exact method of counting operations
859             is consistent from one run to another, but is not guaranteed to be consistent between versions of JE. In the current implementation, an
860             operation means an expression or sub-expression, so a simple C
861             statement with no arguments is not counted.
862              
863             With no arguments, this method returns the current value.
864              
865             As shorthand, you can pass C<< max_ops => $foo >> to the constructor.
866              
867             If the number of operations is exceeded, then C will return undef and
868             set C<$@> to a 'max_ops (xxx) exceeded.
869              
870             =cut
871              
872             sub max_ops {
873 2207     2207 1 2497 my $self = shift;
874 2207 100       3756 if(@_) { $$$self{max_ops} = shift; return }
  1         3  
  1         3  
875 2206         8911 else { return $$$self{max_ops} }
876             }
877              
878              
879             =item $j->html_mode
880              
881             =item $j->html_mode( $new_value )
882              
883             Use this to turn on 'HTML mode', in which HTML comment delimiters are
884             treated much like C. C is a boolean. Since this violates
885             ECMAScript, it is off by default.
886              
887             With no arguments, this method returns the current value.
888              
889             As shorthand, you can pass C<< html_mode => 1 >> to the constructor.
890              
891             =cut
892              
893             sub html_mode {
894 391     391 1 560 my $self = shift;
895 391 100       926 if(@_) { $$$self{html_mode} = shift; return }
  3         10  
  3         7  
896 388         1901 else { return $$$self{html_mode} }
897             }
898              
899              
900             =item $j->upgrade( @values )
901              
902             This method upgrades the value or values given to it. See
903             L for more detail.
904              
905              
906             If you pass it more
907             than one
908             argument in scalar context, it returns the number of arguments--but that
909             is subject to change, so don't do that.
910              
911             =cut
912              
913             fieldhash my %wrappees;
914              
915             sub upgrade {
916 29661     29661 1 8027611 my @__;
917 29661         32299 my $self = shift;
918 29661         25786 my($classes,$proxy_cache);
919 29661         51882 for (@_) {
920 24619 100       63441 if (defined blessed $_) {
921 9675 100       31183 $classes or ($classes,$proxy_cache) =
922             @$$self{'classes','proxy_cache'};
923 9675         16084 my $ident = refaddr $_;
924 9675         12028 my $class = ref;
925             push @__, exists $$classes{$class}
926             ? exists $$proxy_cache{$ident}
927             ? $$proxy_cache{$ident}
928             : ($$proxy_cache{$ident} =
929             exists $$classes{$class}{wrapper}
930 9675 100       31584 ? do {
    100          
    100          
931             weaken( $wrappees{
932 1         5 my $proxy
933             = $$classes{$class}{wrapper}(
934             $self,$_
935             )
936             } = $_);
937 1         15 $proxy
938             }
939             : JE::Object::Proxy->new($self,$_)
940             )
941             : $_;
942             } else {
943 14944 100 66     139230 push @__,
    100          
    100          
    100          
    100          
944             !defined()
945             ? $self->undefined
946             : ref($_) eq 'ARRAY'
947             ? JE::Object::Array->new($self, $_)
948             : ref($_) eq 'HASH'
949             ? JE::Object->new($self, { value => $_ })
950             : ref($_) eq 'CODE'
951             ? JE::Object::Function->new($self, $_)
952             : $_ eq '0' || $_ eq '-0'
953             ? JE::Number->new($self, 0)
954             : JE::String->new($self, $_)
955             ;
956             }
957             }
958 29661 100       216330 @__ > 1 ? @__ : @__ == 1 ? $__[0] : ();
    100          
959             }
960              
961             sub _upgr_def {
962             # ~~~ maybe I should make this a public method named upgrade_defined
963 0 0   0   0 return defined $_[1] ? shift->upgrade(shift) : undef
964             }
965              
966              
967             =item $j->undefined
968              
969             Returns the JavaScript undefined value.
970              
971             =cut
972              
973             sub undefined {
974 1473     1473 1 3079 $${+shift}{u}
  1473         5247  
975             }
976              
977              
978              
979              
980             =item $j->null
981              
982             Returns the JavaScript null value.
983              
984             =cut
985              
986             sub null {
987 4221     4221 1 3741 $${+shift}{n}
  4221         18118  
988             }
989              
990              
991              
992             =item $j->true
993              
994             Returns the JavaScript true value.
995              
996             =item $j->false
997              
998             Returns the JavaScript false value.
999              
1000             =cut
1001              
1002 731     731 1 743 sub true { $${+shift}{t} }
  731         4841  
1003 629     629 1 642 sub false { $${+shift}{f} }
  629         4693  
1004              
1005              
1006              
1007              
1008             =item $j->bind_class( LIST )
1009              
1010             (This method can create a potential security hole. Please see L,
1011             below.)
1012              
1013             =back
1014              
1015             =head2 Synopsis
1016              
1017             $j->bind_class(
1018             package => 'Net::FTP',
1019             name => 'FTP', # if different from package
1020             constructor => 'new', # or sub { Net::FTP->new(@_) }
1021              
1022             methods => [ 'login','get','put' ],
1023             # OR:
1024             methods => {
1025             log_me_in => 'login', # or sub { shift->login(@_) }
1026             chicken_out => 'quit',
1027             }
1028             static_methods => {
1029             # etc. etc. etc.
1030             }
1031             to_primitive => \&to_primitive # or a method name
1032             to_number => \&to_number
1033             to_string => \&to_string
1034              
1035             props => [ 'status' ],
1036             # OR:
1037             props => {
1038             status => {
1039             fetch => sub { 'this var never changes' }
1040             store => sub { system 'say -vHysterical hah hah' }
1041             },
1042             # OR:
1043             status => \&fetch_store # or method name
1044             },
1045             static_props => { ... }
1046              
1047             hash => 1, # Perl obj can be used as a hash
1048             array => 1, # or as an array
1049             # OR (not yet implemented):
1050             hash => 'namedItem', # method name or code ref
1051             array => 'item', # likewise
1052             # OR (not yet implemented):
1053             hash => {
1054             fetch => 'namedItem',
1055             store => sub { shift->{+shift} = shift },
1056             },
1057             array => {
1058             fetch => 'item',
1059             store => sub { shift->[shift] = shift },
1060             },
1061              
1062             isa => 'Object',
1063             # OR:
1064             isa => $j->{Object}{prototype},
1065             );
1066            
1067             # OR:
1068            
1069             $j->bind_class(
1070             package => 'Net::FTP',
1071             wrapper => sub { new JE_Proxy_for_Net_FTP @_ }
1072             );
1073              
1074              
1075             =head2 Description
1076              
1077             (Some of this is random order, and probably needs to be rearranged.)
1078              
1079             This method binds a Perl class to JavaScript. LIST is a hash-style list of
1080             key/value pairs. The keys, listed below, are all optional except for
1081             C or
1082             C--you must specify at least one of the two.
1083              
1084             Whenever it says you can pass a method name to a particular option, and
1085             that method is expected to return a value (i.e., this does not apply to
1086             C<< props => { property_name => { store => 'method' } } >>), you may append
1087             a colon and a data type (such as ':String') to the method name, to indicate
1088             to what JavaScript type to convert the return value. Actually, this is the
1089             name of a JS function to which the return value will be passed, so 'String'
1090             has to be capitalised. This also means than you can use 'method:eval' to
1091             evaluate the return value of 'method' as JavaScript code. One exception to
1092             this is that the special string ':null' indicates that Perl's C
1093             should become JS's C, but other values will be converted the default
1094             way. This is useful, for instance, if a method should return an object or
1095             C, from JavaScript's point of view. This ':' feature does not stop
1096             you from using double colons in method names, so you can write
1097             C<'Package::method:null'> if you like, and rest assured that it will split
1098             on the last colon. Furthermore, just C<'Package::method'> will also work.
1099             It won't split it at all.
1100              
1101             =over 4
1102              
1103             =item package
1104              
1105             The name of the Perl class. If this is omitted, C will be used
1106             instead.
1107              
1108             =item name
1109              
1110             The name the class will have in JavaScript. This is used by
1111             C and as the name of the constructor. If
1112             omitted, C will be used.
1113              
1114             =item constructor => 'method_name'
1115              
1116             =item constructor => sub { ... }
1117              
1118             If C is given a string, the constructor will treat it as the
1119             name of a class method of C.
1120              
1121             If it is a coderef, it will be used as the constructor.
1122              
1123             If this is omitted, the constructor will raise an error when called. If
1124             there is already a constructor with the same name, however, it will be left
1125             as it is (though methods will still be added to its prototype object). This
1126             allows two Perl classes to be bound to a single JavaScript class:
1127              
1128             $j->bind_class( name => 'Foo', package => 'Class::One', methods => ... );
1129             $j->bind_class( name => 'Foo', package => 'Class::Two' );
1130              
1131             =item methods => [ ... ]
1132              
1133             =item methods => { ... }
1134              
1135             If an array ref is supplied, the named methods will be bound to JavaScript
1136             functions of the same names.
1137              
1138             If a hash ref is used, the keys will be the
1139             names of the methods from JavaScript's point of view. The values can be
1140             either the names of the Perl methods, or code references.
1141              
1142             =item static_methods
1143              
1144             Like C but they will become methods of the constructor itself, not
1145             of its C property.
1146              
1147             =item to_primitive => sub { ... }
1148              
1149             =item to_primitive => 'method_name'
1150              
1151             When the object is converted to a primitive value in JavaScript, this
1152             coderef or method will be called. The first argument passed will, of
1153             course, be the object. The second argument will be the hint ('number' or
1154             'string') or will be omitted.
1155              
1156             If to_primitive is omitted, the usual valueOf and
1157             toString methods will be tried as with built-in JS
1158             objects, if the object does not have overloaded string/boolean/number
1159             conversions. If the object has even one of those three, then conversion to
1160             a primitive will be the same as in Perl.
1161              
1162             If C<< to_primitive => undef >> is specified, primitivisation
1163             without a hint (which happens with C<< < >> and C<==>) will throw a
1164             TypeError.
1165              
1166             =item to_number
1167              
1168             If this is omitted, C will be
1169             used.
1170             If set to undef, a TypeError will be thrown whenever the
1171             object is numified.
1172              
1173             =item to_string
1174              
1175             If this is omitted, C will be
1176             used.
1177             If set to undef, a TypeError will be thrown whenever the
1178             object is strung.
1179              
1180             =item props => [ ... ]
1181              
1182             =item props => { ... }
1183              
1184             Use this to add properties that will trigger the provided methods or
1185             subroutines when accessed. These property definitions can also be inherited
1186             by subclasses, as long as, when the subclass is registered with
1187             C, the superclass is specified as a string (via C, below).
1188              
1189             If this is an array ref, its elements will be the names of the properties.
1190             When a property is retrieved, a method of the same name is called. When a
1191             property is set, the same method is called, with the new value as the
1192             argument.
1193              
1194             If a hash ref is given, for each element, if the value is a simple scalar,
1195             the property named by the key will trigger the method named by the value.
1196             If the value is a coderef, it will be called with the object as its
1197             argument when the variable is read, and with the object and
1198             the new
1199             value as its two arguments when the variable is set.
1200             If the value is a hash ref, the C and C keys will be
1201             expected to be either coderefs or method names. If only C is given,
1202             the property will be read-only. If only C is given, the property
1203             will
1204             be write-only and will appear undefined when accessed. (If neither is
1205             given,
1206             it will be a read-only undefined property--really useful.)
1207              
1208             =item static_props
1209              
1210             Like C but they will become properties of the constructor itself,
1211             not
1212             of its C property.
1213              
1214             =item hash
1215              
1216             If this option is present, then this indicates that the Perl object
1217             can be used
1218             as a hash. An attempt to access a property not defined by C or
1219             C will result in the retrieval of a hash element instead (unless
1220             the property name is a number and C is specified as well).
1221              
1222             =begin comment
1223              
1224             There are several values this option can take:
1225              
1226             =over 4
1227              
1228             =item *
1229              
1230             One of the strings '1-way' and '2-way' (also 1 and 2 for short). This will
1231             indicate that the object being wrapped can itself be used as a hash.
1232              
1233             =end comment
1234              
1235             The value you give this option should be one of the strings '1-way' and
1236             '2-way' (also 1 and 2 for short).
1237              
1238             If
1239             you specify '1-way', only properties corresponding to existing hash
1240             elements will be linked to those elements;
1241             properties added to the object from JavaScript will
1242             be JavaScript's own, and will not affect the wrapped object. (Consider how
1243             node lists and collections work in web browsers.)
1244              
1245             If you specify '2-way', an attempt to create a property in JavaScript will
1246             be reflected in the underlying object.
1247              
1248             =begin comment
1249              
1250             =item *
1251              
1252             A method name (that does not begin with a number). This method will be
1253             called on the object with the object as the first arg (C<$_[0]>), the
1254             property name as the second, and, if an assignment is being made, the new
1255             value as the third. This will be a one-way hash.
1256              
1257             =item *
1258              
1259             A reference to a subroutine. This sub will be called with the same
1260             arguments as a method. Again, this will be a one-way hash.
1261              
1262             =item *
1263              
1264             A hash with C and C keys, which should be set to method names
1265             or coderefs. Actually, you may omit C to create a one-way binding,
1266             as per '1-way', above, except that the properties that correspond to hash
1267             keys will be read-only as well.
1268              
1269             =back
1270              
1271             =end comment
1272              
1273             B Make this accept '1-way:String', etc.
1274              
1275             =item array
1276              
1277             This is just like C, but for arrays. This will also create a property
1278             named 'length'.
1279              
1280             =for comment
1281             if passed '1-way' or '2-way'.
1282              
1283             B Make this accept '1-way:String', etc.
1284              
1285             =begin comment
1286              
1287             =item keys
1288              
1289             This should be a method name or coderef that takes the object as its first
1290             argument and
1291             returns a list of hash keys. This only applies if C is specified
1292             and passed a method name, coderef, or hash.
1293              
1294             =end comment
1295              
1296             =item unwrap => 1
1297              
1298             If you specify this and it's true, objects passed as arguments to the
1299             methods or code
1300             refs specified above are 'unwrapped' if they are proxies for Perl objects
1301             (see below). And null and undefined are converted to C.
1302              
1303             This is experimental right now. I might actually make this the default.
1304             Maybe this should provide more options for fine-tuning, or maybe what is
1305             currently the default behaviour should be removed. If
1306             anyone has any opinions on this, please e-mail the author.
1307              
1308             =item isa => 'ClassName'
1309              
1310             =item isa => $prototype_object
1311              
1312             (Maybe this should be renamed 'super'.)
1313              
1314             The name of the superclass. 'Object' is the default. To make this new
1315             class's prototype object have no prototype, specify
1316             C. Instead of specifying the name of the superclass, you
1317             can
1318             provide the superclass's prototype object.
1319              
1320             If you specify a name, a constructor function by that name must already
1321             exist, or an exception will be thrown. (I supposed I could make JE smart
1322             enough to defer retrieving the prototype object until the superclass is
1323             registered. Well, maybe later.)
1324              
1325             =item wrapper => sub { ... }
1326              
1327             If C is specified, all other arguments will be ignored except for
1328             C (or C if C is not present).
1329              
1330             When an object of the Perl class in question is 'upgraded,' this subroutine
1331             will be called with the global object as its first argument and the object
1332             to be 'wrapped' as the second. The subroutine is expected to return
1333             an object compatible with the interface described in L.
1334              
1335             If C is supplied, no constructor will be created.
1336              
1337             =back
1338              
1339             After a class has been bound, objects of the Perl class will, when passed
1340             to JavaScript (or the C method), appear as instances of the
1341             corresponding JS class. Actually, they are 'wrapped up' in a proxy object
1342             (a JE::Object::Proxy
1343             object), that provides the interface that JS operators require (see
1344             L). If the
1345             object is passed back to Perl, it is the I
1346             not the original object that is returned. The proxy's C method will
1347             return the original object. I if the C option above is used
1348             when a class is bound, the original Perl object will be passed to any
1349             methods or properties belonging to that class. B
1350             subject to change.> See L, above.
1351              
1352             Note that, if you pass a Perl object to JavaScript before binding its
1353             class,
1354             JavaScript's reference to it (if any) will remain as it is, and will not be
1355             wrapped up inside a proxy object.
1356              
1357             To use Perl's overloading within JavaScript, well...er, you don't have to
1358             do
1359             anything. If the object has C<"">, C<0+> or C overloading, that will
1360             automatically be detected and used.
1361              
1362             =cut
1363              
1364 68 100   68   337 sub _split_meth { $_[0] =~ /(.*[^:]):([^:].*)/s ? ($1, $2) : $_[0] }
1365             # This function splits a method specification of the form 'method:Func'
1366             # into its two constituent parts, returning ($_[0],undef) if it is a simple
1367             # method name. The [^:] parts of the regexp are to allow things like
1368             # "HTML::Element::new:null" and to prevent "Foo::bar" from being turned
1369             # into qw(Foo: bar).
1370              
1371             sub _cast {
1372 31     31   130 my ($self,$val,$type) = @_;
1373 31 100       62 return $self->upgrade($val) unless defined $type;
1374 29 100       46 if($type eq 'null') {
1375 19 100       49 defined $val ? $self->upgrade($val) : $self->null
1376             }
1377             else {
1378 10         26 $self->prop($type)->call($self->upgrade($val));
1379             }
1380             }
1381              
1382             sub _unwrap {
1383 0     0   0 my ($self) = shift;
1384 0         0 my @ret;
1385 0         0 for(@_){
1386 0 0       0 push @ret,
    0          
1387             ref =~ # Check the most common classes for efficiency.
1388             /^JE::(?:Object::Proxy(?:::Array)?|Undefined|Null)\z/
1389             ? $_->value
1390             : exists $wrappees{$_}
1391             ? $wrappees{$_}
1392             : $_
1393             }
1394 0         0 @ret;
1395             }
1396              
1397             sub bind_class {
1398 36     36 1 3044 require JE::Object::Proxy;
1399              
1400 36         48 my $self = shift;
1401 36         111 my %opts = @_;
1402             #{ no warnings;
1403             #warn refaddr $self, " ", $opts{name} , ' ' ,$opts{package}; }
1404              
1405              
1406             # &upgrade relies on this, because it
1407             # takes the value of ->{proxy_cache},
1408             # sticks it in a scalar, then modifies
1409             # it through that scalar.
1410 36   66     125 $$$self{proxy_cache} ||= &fieldhash({}); # & to bypass prototyping
1411              
1412 36 100       113 if(exists $opts{wrapper}) { # special case
1413 1         4 my $pack = $opts{qw/name package/[exists $opts{package}]};
1414 1         5 $$$self{classes}{$pack} = {wrapper => $opts{wrapper}};
1415 1         4 return;
1416             }
1417              
1418 35         37 my($pack, $class);
1419 35 100       69 if(exists $opts{package}) {
1420 26         39 $pack = "$opts{package}";
1421 26 100       45 $class = exists $opts{name} ? $opts{name} : $pack;
1422             }
1423             else {
1424 9         15 $class = $opts{name};
1425 9         17 $pack = "$class";
1426             }
1427            
1428 35         72 my %class = ( name => $class );
1429 35         117 $$$self{classes}{$pack} = $$$self{classes_by_name}{$class} =
1430             \%class;
1431              
1432 35         52 my $unwrap = delete $opts{unwrap};
1433              
1434 35         33 my ($constructor,$proto,$coderef);
1435 35 100       66 if (exists $opts{constructor}) {
1436 21         29 my $c = $opts{constructor};
1437              
1438             $coderef = ref eq 'CODE'
1439 0     0   0 ? sub { $self->upgrade(scalar &$c(@_)) }
1440 21 50   21   80 : sub { $self->upgrade(scalar $pack->$c(@_)) };
  21         104  
1441             }
1442             else {
1443             $coderef = sub {
1444 2     2   9 die JE::Code::add_line_number(
1445             "$class cannot be instantiated");
1446 14         60 };
1447 14         44 $constructor = $self->prop($class);
1448 14 50 66     51 defined $constructor and $constructor->typeof ne 'function'
1449             and $constructor = undef;
1450             }
1451 35   66     275 $class{prototype} = $proto = ( $constructor || $self->prop({
1452             name => $class,
1453             value => $constructor = JE::Object::Function->new({
1454             name => $class,
1455             scope => $self,
1456             function => $coderef,
1457             function_args => ['args'],
1458             constructor => $coderef,
1459             constructor_args => ['args'],
1460             }),
1461             }) )->prop('prototype');
1462              
1463 35         98 my $super;
1464 35 100       68 if(exists $opts{isa}) {
1465 3         4 my $isa = $opts{isa};
1466             $proto->prototype(
1467             !defined $isa || defined blessed $isa
1468             ? $isa
1469 3 100 100     17 : do {
1470 1         1 $super = $isa;
1471 1 50       3 defined(my $super_constr = $self->prop($isa)) ||
1472             croak("JE::bind_class: The $isa" .
1473             " constructor does not exist");
1474 1         3 $super_constr->prop('prototype')
1475             }
1476             );
1477             }
1478              
1479 35 100       69 if(exists $opts{methods}) {
1480 8         11 my $methods = $opts{methods};
1481 8 100       17 if (ref $methods eq 'ARRAY') { for (@$methods) {
  2         4  
1482 6         11 my($m, $type) = _split_meth $_;
1483 6 100       12 if (defined $type) {
1484             $proto->new_method(
1485             $m => $unwrap
1486             ? sub {
1487 0     0   0 $self->_cast(
1488             scalar shift->value->$m(
1489             $self->_unwrap(@_)),
1490             $type
1491             );
1492             }
1493             : sub {
1494 3     3   8 $self->_cast(
1495             scalar shift->value->$m(@_),
1496             $type
1497             );
1498             }
1499 3 50       19 );
1500             }else {
1501             $proto->new_method(
1502             $m => $unwrap
1503 0     0   0 ? sub { shift->value->$m(
1504             $self->_unwrap(@_)) }
1505 3     3   13 : sub { shift->value->$m(@_) },
1506 3 50       23 );
1507             }
1508             }} else { # it'd better be a hash!
1509 6         26 while( my($name, $m) = each %$methods) {
1510 14 100       30 if(ref $m eq 'CODE') {
1511             $proto->new_method(
1512             $name => $unwrap
1513             ? sub {
1514 0     0   0 &$m($self->_unwrap(@_))
1515             }
1516             : sub {
1517 4     4   14 &$m($_[0]->value,@_[1..$#_])
1518             }
1519 8 50       60 );
1520             } else {
1521 6         12 my ($method, $type) = _split_meth $m;
1522             $proto->new_method(
1523             $name => defined $type
1524             ? $unwrap
1525             ? sub {
1526 0     0   0 $self->_cast(
1527             scalar shift->value->$method(
1528             $self->_unwrap(@_)),
1529             $type
1530             );
1531             }
1532             : sub {
1533 3     3   7 $self->_cast(
1534             scalar shift->value->$method(@_),
1535             $type
1536             );
1537             }
1538             : $unwrap
1539 0     0   0 ? sub { shift->value->$m(
1540             $self->_unwrap(@_)) }
1541 3     3   14 : sub { shift->value->$m(@_) },
1542 6 50       55 );
    50          
    100          
1543             }
1544             }}
1545             }
1546              
1547 35 100       88 if(exists $opts{static_methods}) {
1548 5         9 my $methods = $opts{static_methods};
1549 5 100       13 if (ref $methods eq 'ARRAY') { for (@$methods) {
  2         11  
1550 6         15 my($m, $type) = _split_meth $_;
1551             $constructor->new_function(
1552             $m => defined $type
1553             ? $unwrap
1554 0     0   0 ? sub { $self->_cast(
1555             scalar $pack->$m(
1556             $self->_unwrap(@_)), $type
1557             ) }
1558 3     3   20 : sub { $self->_cast(
1559             scalar $pack->$m(@_), $type
1560             ) }
1561             : $unwrap
1562 0     0   0 ? sub { $pack->$m(
1563             $self->_unwrap(@_)) }
1564 3     3   24 : sub { $pack->$m(@_) }
1565 6 50       57 );
    50          
    100          
1566             # new_function makes the functions enumerable,
1567             # unlike new_method. This code is here to make
1568             # things consistent. I'll delete it if someone
1569             # convinces me otherwise. (I can't make
1570             # up my mind.)
1571 6         22 $constructor->prop({
1572             name => $m, dontenum => 1
1573             });
1574             }} else { # it'd better be a hash!
1575 3         11 while( my($name, $m) = each %$methods) {
1576 8 100       14 if(ref $m eq 'CODE') {
1577             $constructor->new_function(
1578             $name => $unwrap
1579             ? sub {
1580 0     0   0 @_ = $self->_unwrap(@_);
1581 0         0 unshift @_, $pack;
1582 0         0 goto $m;
1583             }
1584             : sub {
1585 2     2   6 unshift @_, $pack;
1586 2         9 goto $m;
1587             }
1588 2 50       14 );
1589             } else {
1590 6         15 ($m, my $type) = _split_meth $m;
1591             $constructor->new_function(
1592             $name => defined $type
1593 3     3   23 ? sub { $self->_cast(
1594             scalar $pack->$m,
1595             $type
1596             ) }
1597             : $unwrap
1598 0     0   0 ? sub { $pack->$m(
1599             $self->_unwrap(@_)) }
1600 3     3   22 : sub { $pack->$m(@_) },
1601 6 50       47 );
    100          
1602             }
1603             # new_function makes the functions enumerable,
1604             # unlike new_method. This code is here to make
1605             # things consistent. I'll delete it if someone
1606             # convinces me otherwise. (I can't make
1607             # up my mind.)
1608 8         27 $constructor->prop({
1609             name => $name, dontenum => 1
1610             });
1611             }}
1612             }
1613              
1614 35         60 for(qw/to_primitive to_string to_number/) {
1615 105 100       229 exists $opts{$_} and $class{$_} = $opts{$_}
1616             }
1617              
1618             # The properties enumerated by the 'props' option need to be made
1619             # instance properties, since assignment never falls through to the
1620             # prototype, and a fetch routine is passed the property's actual
1621             # owner; i.e., the prototype, if it is an inherited property. So
1622             # we'll make a list of argument lists which &JE::Object::Proxy::new
1623             # will take care of passing to each object's prop method.
1624 35         36 { my %props;
  35         30  
1625 35 100       74 if(exists $opts{props}) {
1626 11         15 my $props = $opts{props};
1627 11         15 $class{props} = \%props;
1628 11 100       26 if (ref $props eq 'ARRAY') {
1629 2         5 for(@$props) {
1630 6         10 my ($p,$type) = _split_meth $_;
1631             $props{$p} = [
1632             fetch => defined $type
1633             ? sub {
1634 3     3   12 $self->_cast(
1635             scalar $_[0]->value->$p, $type
1636             )
1637             }
1638             : sub {
1639 4     4   15 $self->upgrade(scalar $_[0]->value->$p)
1640             },
1641             store => $unwrap
1642 0     0   0 ? sub { $_[0]->value->$p(
1643             $self->_unwrap($_[1])) }
1644 2     2   6 : sub { $_[0]->value->$p($_[1]) },
1645 6 100       48 ];
    50          
1646             }
1647             } else { # it'd better be a hash!
1648 9         34 while( my($name, $p) = each %$props) {
1649 20         15 my @prop_args;
1650 20 100       37 if (ref $p eq 'HASH') {
1651 11 100       19 if(exists $$p{fetch}) {
1652 9         10 my $fetch = $$p{fetch};
1653             @prop_args = ( fetch =>
1654             ref $fetch eq 'CODE'
1655 3     3   10 ? sub { $self->upgrade(
1656             scalar &$fetch($_[0]->value)
1657             ) }
1658 9 100       20 : do {
1659 7         11 my($f,$t) = _split_meth $fetch;
1660 3     3   8 defined $t ? sub { $self->_cast(
1661             scalar shift->value->$f, $t
1662             ) }
1663 5     5   14 : sub { $self->upgrade(
1664             scalar shift->value->$fetch
1665             ) }
1666 7 100       34 }
1667             );
1668             }
1669 2         6 else { @prop_args =
1670             (value => $self->undefined);
1671             }
1672 11 100       21 if(exists $$p{store}) {
1673 5         5 my $store = $$p{store};
1674             push @prop_args, ( store =>
1675             ref $store eq 'CODE'
1676             ? $unwrap
1677             ? sub {
1678 0     0   0 &$store($_[0]->value,
1679             $self->_unwrap($_[1]))
1680             }
1681             : sub {
1682 2     2   7 &$store($_[0]->value, $_[1])
1683             }
1684             : $unwrap
1685             ? sub {
1686 0     0   0 $_[0]->value->$store(
1687             $self->_unwrap($_[1]))
1688             }
1689             : sub {
1690 3     3   11 $_[0]->value->$store($_[1])
1691             }
1692 5 50       23 );
    50          
    100          
1693             }
1694             else {
1695 6         9 push @prop_args, readonly => 1;
1696             }
1697             }
1698             else {
1699 9 100       19 if(ref $p eq 'CODE') {
1700             @prop_args = (
1701 3     3   12 fetch => sub { $self->upgrade(
1702             scalar &$p($_[0]->value)
1703             ) },
1704             store => $unwrap
1705             ? sub {
1706 0     0   0 &$p(
1707             scalar $_[0]->value,
1708             $self->_unwrap($_[1])
1709             )
1710             }
1711             : sub {
1712 2     2   7 &$p(
1713             scalar $_[0]->value, $_[1]
1714             )
1715             },
1716 2 50       13 );
1717             }else{
1718 7         10 ($p, my $t) = _split_meth($p);
1719             @prop_args = (
1720             fetch => defined $t
1721 3     3   9 ? sub { $self->_cast(
1722             scalar $_[0]->value->$p, $t
1723             ) }
1724 6     6   20 : sub { $self->upgrade(
1725             scalar $_[0]->value->$p
1726             ) },
1727             store => $unwrap
1728             ? sub {
1729 0     0   0 $_[0]->value->$p(
1730             $self->_unwrap($_[1]))
1731             }
1732             : sub {
1733 2     2   6 $_[0]->value->$p($_[1])
1734             },
1735 7 100       60 );
    50          
1736             }
1737             }
1738 20         68 $props{$name} = \@prop_args;
1739             }}
1740             }
1741 35 100       76 if(defined $super){
1742 1   50     6 $class{props} ||= \%props;
1743             {
1744 1   50     1 my $super_props =
  1         6  
1745             $$$self{classes_by_name}{$super}{props}
1746             || last;
1747 0         0 for (keys %$super_props) {
1748 0 0       0 exists $props{$_} or
1749             $props{$_} = $$super_props{$_}
1750             }
1751             }
1752             }}
1753              
1754 35 100       75 if(exists $opts{static_props}) {
1755 11         15 my $props = $opts{static_props};
1756 11 100       19 if (ref $props eq 'ARRAY') { for (@$props) {
  2         4  
1757 6         8 my($p,$t) = _split_meth $_;
1758             $constructor->prop({
1759             name => $p,
1760             fetch => defined $t
1761 3     3   20 ? sub { $self->_cast(
1762             scalar $pack->$p, $t
1763             ) }
1764 3     3   17 : sub { $self->upgrade(
1765             scalar $pack->$p
1766             ) },
1767 0     0   0 store => $unwrap
1768             ? sub {$pack->$p($self->_unwrap($_[1]))}
1769 2     2   11 : sub { $pack->$p($_[1]) },
1770 6 100       50 });
    50          
1771             }} else { # it'd better be a hash!
1772 9         28 while( my($name, $p) = each %$props) {
1773 19         20 my @prop_args;
1774 19 100       28 if (ref $p eq 'HASH') {
1775 11 100       18 if(exists $$p{fetch}) {
1776 9         11 my $fetch = $$p{fetch};
1777             @prop_args = ( fetch =>
1778             ref $fetch eq 'CODE'
1779             ? sub {
1780 2     2   7 $self->upgrade(
1781             scalar &$fetch($pack))
1782             }
1783 9 100       18 : do {
1784 7         11 my($f,$t) = _split_meth $fetch;
1785             defined $t ? sub {
1786 1     1   78 $self->_cast(
1787             scalar $pack->$f,$t)
1788             }
1789             : sub {
1790 3     3   14 $self->upgrade(
1791             scalar $pack->$f)
1792             }
1793 7 100       33 }
1794             );
1795             }
1796 2         5 else { @prop_args =
1797             (value => $self->undefined);
1798             }
1799 11 100       22 if(exists $$p{store}) {
1800 5         7 my $store = $$p{store};
1801             push @prop_args, ( store =>
1802             ref $store eq 'CODE'
1803             ? $unwrap
1804             ? sub {
1805 0     0   0 &$store($pack,
1806             $self->_unwrap($_[1]))
1807             }
1808             : sub {
1809 2     2   8 &$store($pack, $_[1])
1810             }
1811             : $unwrap
1812             ? sub {
1813 0     0   0 $pack->$store(
1814             $self->_unwrap($_[1]))
1815             }
1816             : sub {
1817 3     3   15 $pack->$store($_[1])
1818             }
1819 5 50       20 );
    50          
    100          
1820             }
1821             else {
1822 6         8 push @prop_args, readonly => 1;
1823             }
1824             }
1825             else {
1826 8 100       14 if(ref $p eq 'CODE') {
1827             @prop_args = (
1828             fetch => sub {
1829 2     2   6 $self->upgrade(
1830             scalar &$p($pack))
1831             },
1832             store => $unwrap
1833             ? sub {
1834 0     0   0 &$p($pack,
1835             $self->_unwrap($_[1]))
1836             }
1837             : sub {
1838 2     2   10 &$p($pack, $_[1])
1839             },
1840 2 50       12 );
1841             } else {
1842 6         10 ($p, my $t) = _split_meth $p;
1843             @prop_args = (
1844             fetch => defined $t
1845             ? sub {
1846 3     3   19 $self->_cast(
1847             scalar $pack->$p,$t)
1848             }
1849             : sub {
1850 3     3   16 $self->upgrade(
1851             scalar $pack->$p)
1852             },
1853             store => $unwrap
1854             ? sub {
1855 0     0   0 $pack->$p(
1856             $self->_unwrap($_[1]))
1857             }
1858             : sub {
1859 2     2   12 $pack->$p($_[1])
1860             },
1861 6 100       40 );
    50          
1862             }
1863             }
1864 19         64 $constructor->prop({name => $name, @prop_args});
1865             }}
1866             }
1867              
1868             # ~~~ needs to be made more elaborate
1869             # ~~~ for later: exists $opts{keys} and $class{keys} = $$opts{keys};
1870              
1871              
1872              
1873             # $class{hash}{store} will be a coderef that returns true or false,
1874             # depending on whether it was able to write the property. With two-
1875             # way hash bindings, it will always return true
1876              
1877 35 100       68 if($opts{hash}) {
1878 3 50 33     24 if(!ref $opts{hash} # ) {
1879             #if(
1880             && $opts{hash} =~ /^(?:1|(2))/) {
1881             $class{hash} = {
1882 8 100   8   24 fetch => sub { exists $_[0]{$_[1]}
1883             ? $self->upgrade(
1884             $_[0]{$_[1]})
1885             : undef
1886             },
1887             store => $1 # two-way?
1888 1     1   3 ? sub { $_[0]{$_[1]}=$_[2]; 1 }
  1         6  
1889             : sub {
1890 1 50   1   13 exists $_[0]{$_[1]} and
1891             ($_[0]{$_[1]}=$_[2], 1)
1892             },
1893 3 100       26 };
1894 3   50 0   20 $class{keys} ||= sub { keys %{$_[0]} };
  0         0  
  0         0  
1895             }
1896 0         0 else { croak
1897             "Invalid value for the 'hash' option: $opts{hash}";
1898             }
1899              
1900             =begin comment
1901              
1902             # I haven't yet figured out a logical way for this to work:
1903              
1904             else { # method name
1905             my $m = $opts{hash};
1906             $class{hash} = {
1907             fetch => sub {
1908             $self->_upgr_def(
1909             $_[0]->value->$m($_[1])
1910             )
1911             },
1912             store => sub {
1913             my $wrappee = shift->value;
1914             defined $wrappee->$m($_[0]) &&
1915             ($wrappee->$m(@_), 1)
1916             },
1917             };
1918             }
1919             } elsif (ref $opts{hash} eq 'CODE') {
1920             my $cref = $opts{hash};
1921             $class{hash} = {
1922             fetch => sub {
1923             $self->_upgr_def(
1924             &$cref($_[0]->value, $_[1])
1925             )
1926             },
1927             store => sub {
1928             my $wrappee = shift->value;
1929             defined &$cref($wrappee, $_[0]) &&
1930             (&$cref($wrappee, @_), 1)
1931             },
1932             };
1933             } else { # it'd better be a hash!
1934             my $opt = $opts{hash_elem};
1935             if(exists $$opt{fetch}) {
1936             my $fetch = $$opt{fetch};
1937             $class{hash}{fetch} =
1938             ref $fetch eq 'CODE'
1939             ? sub { $self-> _upgr_def(
1940             &$fetch($_[0]->value, $_[1])
1941             ) }
1942             : sub { $self-> _upgr_def(
1943             shift->value->$fetch(shift)
1944             ) }
1945             ;
1946             }
1947             if(exists $$opt{store}) {
1948             my $store = $$opt{store};
1949             $class{hash}{store} =
1950             ref $store eq 'CODE'
1951             ? sub {
1952             my $wrappee = shift->value;
1953             defined &$store($wrappee, $_[0])
1954             and &$store($wrappee, @_), 1
1955             }
1956             : sub {
1957             my $wrappee = shift->value;
1958             defined $wrappee->$store($_[0])
1959             and &$store($wrappee, @_), 1
1960             $_[0]->value->$store(@_[1,2])
1961             }
1962             ;
1963             }
1964             }
1965              
1966             =end comment
1967              
1968             =cut
1969              
1970             }
1971              
1972 35 100       74 if($opts{array}) {
1973 3 50       17 if($opts{array} =~ /^(?:1|(2))/) {
1974             $class{array} = {
1975 11 100   11   13 fetch => sub { $_[1] < @{$_[0]}
  11         38  
1976             ? $self->upgrade(
1977             $_[0][$_[1]])
1978             : undef
1979             },
1980             store => $1 # two-way?
1981 1     1   4 ? sub { $_[0][$_[1]]=$_[2]; 1 }
  1         6  
1982             : sub {
1983 1 50   1   2 $_[1] < @{$_[0]} and
  1         8  
1984             ($_[0]{$_[1]}=$_[2], 1)
1985             },
1986 3 100       31 };
1987             }
1988 0         0 else { croak
1989             "Invalid value for the 'array' option: $opts{array}";
1990             }
1991              
1992             =begin comment
1993              
1994             } elsif (exists $opts{array_elem}) {
1995             if (!ref $opts{array_elem}) {
1996             my $m = $opts{array_elem};
1997             $class{array} = {
1998             fetch => sub {
1999             $self->upgrade(
2000             $_[0]->value->$m($_[1])
2001             )
2002             },
2003             store => sub { $_[0]->value->$m(@_[1,2]) },
2004             };
2005             } else { # it'd better be a hash!
2006             my $opt = $opts{array_elem};
2007             if(exists $$opt{fetch}) {
2008             my $fetch = $$opt{fetch};
2009             $class{array}{fetch} =
2010             ref $fetch eq 'CODE'
2011             ? sub { $self->upgrade(
2012             &$fetch($_[0]->value, $_[1])
2013             ) }
2014             : sub { $self->upgrade(
2015             shift->value->$fetch(shift)
2016             ) }
2017             ;
2018             }
2019             if(exists $$opt{store}) {
2020             my $store = $$opt{store};
2021             $class{array}{store} =
2022             ref $store eq 'CODE'
2023             ? sub {
2024             &$store($_[0]->value, @_[1,2])
2025             }
2026             : sub {
2027             $_[0]->value->$store(@_[1,2])
2028             }
2029             ;
2030             }
2031             }
2032              
2033             =end comment
2034              
2035             =cut
2036              
2037             }
2038              
2039 35         82 weaken $self; # we've got closures
2040              
2041             return # nothing
2042 35         132 }
2043              
2044             =over
2045              
2046             =item $j->new_parser
2047              
2048             This returns a parser object (see L) which allows you to
2049             customise the way statements are parsed and executed (only partially
2050             implemented).
2051              
2052             =cut
2053              
2054             sub new_parser {
2055 1     1 1 5 JE::Parser->new(shift);
2056             }
2057              
2058              
2059              
2060              
2061             =item $j->prototype_for( $class_name )
2062              
2063             =item $j->prototype_for( $class_name, $new_val )
2064              
2065             Mostly for internal use, this method is used to store/retrieve the
2066             prototype objects used by JS's built-in data types. The class name should
2067             be 'String', 'Number', etc., but you can actually store anything you like
2068             in here. :-)
2069              
2070             =cut
2071              
2072             sub prototype_for {
2073 20637     20637 1 21190 my $self = shift;
2074 20637         20342 my $class = shift;
2075 20637 100       32541 if(@_) {
2076 371         1095 return $$$self{pf}{$class} = shift
2077             }
2078             else {
2079 20266   66     63428 return $$$self{pf}{$class} ||
2080             ($self->prop($class) || return undef)->prop('prototype');
2081             }
2082             }
2083              
2084              
2085              
2086             =back
2087              
2088             =cut
2089              
2090              
2091              
2092             1;
2093             __END__