File Coverage

blib/lib/JE/Object/Function.pm
Criterion Covered Total %
statement 196 203 96.5
branch 90 108 83.3
condition 28 38 73.6
subroutine 33 35 94.2
pod 8 8 100.0
total 355 392 90.5


line stmt bran cond sub pod time code
1             package JE::Object::Function;
2              
3             our $VERSION = '0.064';
4              
5              
6 101     101   34740 use strict;
  101         126  
  101         3086  
7 101     101   397 use warnings; no warnings 'utf8';
  101     101   119  
  101         2092  
  101         869  
  101         114  
  101         2424  
8 101     101   400 use Carp ;
  101         115  
  101         5827  
9 101     101   431 use Scalar::Util 'blessed';
  101         140  
  101         9615  
10              
11             use overload
12             fallback => 1,
13             '&{}' => sub {
14 11     11   282 my $self = shift;
15             sub {
16 11     11   55 my $ret = $self->call($self->global->upgrade(@_));
17 11 100       42 typeof $ret eq 'undefined' ? undef : $ret
18             }
19 101     101   1432 };
  101         850  
  101         694  
  11         60  
20              
21             our @ISA = 'JE::Object';
22              
23             require JE::Code ;
24             require JE::Number ;
25             require JE::Object ;
26             require JE::Object::Error::TypeError;
27             require JE::Parser ;
28             require JE::Scope ;
29              
30             import JE::Code 'add_line_number';
31             sub add_line_number;
32              
33             =head1 NAME
34              
35             JE::Object::Function - JavaScript function class
36              
37             =head1 SYNOPSIS
38              
39             use JE::Object::Function;
40              
41             # simple constructors:
42              
43             $f = new JE::Object::Function $scope, @argnames, $function;
44             $f = new JE::Object::Function $scope, $function;
45              
46             # constructor that lets you do anything:
47              
48             $f = new JE::Object::Function {
49             name => $name,
50             scope => $scope,
51             length => $number_of_args,
52             argnames => [ @argnames ],
53             function => $function,
54             function_args => [ $arglist ],
55             constructor => sub { ... },
56             constructor_args => [ $arglist ],
57             downgrade => 0,
58             };
59              
60              
61             $f->(@args);
62             $f->call_with($obj, @args);
63              
64             =head1 DESCRIPTION
65              
66             All JavaScript functions are instances of this class. If you want to call
67             a JavaScript function from Perl, just treat is as a coderef (C<< $f->() >>)
68             or use the C method (C<< $f->call_with($obj, @args) >>) if you
69             want to specify the invocant (the 'this' value).
70              
71             =head1 OBJECT CREATION
72              
73             =over 4
74              
75             =item new
76              
77             Creates and returns a new function (see the next few items for its usage).
78             The new function will have a C property that is an object with
79             a C property that refers to the function itself.
80              
81             The return value of the function will be upgraded if necessary (see
82             L in the JE::Types man page),
83             which is why C I to be given a reference to the global object
84             or the scope chain. (But see also L and L.)
85              
86             A function written in Perl can return an lvalue if it wants to. Use
87             S<< C >> to create it. To create
88             an lvalue
89             that
90             refers to a variable visible within the function's scope, use
91             S<< C<<< $scope->var('varname') >>> >> (this assumes that you have
92             shifted the scope object off C<@_> and called it C<$scope>; you also need
93             to call C with hashref syntax and specify the C [see
94             below]).
95              
96             =item new JE::Object::Function $scope_or_global, @argnames, $function;
97              
98             =item new JE::Object::Function $scope_or_global, $function;
99              
100             C<$scope_or_global> is one of the following:
101              
102             - a global (JE) object
103             - a scope chain (JE::Scope) object
104              
105             C<@argnames> is a list of argument names, that JavaScript functions use to access the arguments.
106              
107             $function is one of
108              
109             - a string containing the body of the function (JavaScript code)
110             - a JE::Code object
111             - a coderef
112              
113             =item new JE::Object::Function { ... };
114              
115             This is the big fancy way of creating a function that lets you do anything.
116             The elements of the hash ref passed to C are as follows (they are
117             all optional, except for C):
118              
119             =over 4
120              
121             =item name
122              
123             The name of the function. This is used only by C.
124              
125             =item scope
126              
127             A global object or scope chain object.
128              
129             =item length
130              
131             The number of arguments expected. If this is omitted, the number of
132             elements of C will be used. If that is omitted, 0 will be used.
133             Note that this does not cause the argument list to be checked. It only
134             provides the C property (and possibly, later, an C property)
135             for inquisitive scripts to look at.
136              
137             =item argnames
138              
139             An array ref containing the variable names that a JS function uses to
140             access the
141             arguments.
142              
143             =item function
144              
145             A coderef, string of JS code or JE::Code object (the body of the function).
146              
147             This will be run when the function is called from JavaScript without the
148             C keyword, or from Perl via the C method.
149              
150             =item function_args
151              
152             This only applies when C is a code ref. C is an
153             array ref, the elements being strings that indicated what arguments should
154             be passed to the Perl subroutine. The strings, and what they mean, are
155             as follows:
156              
157             self the function object itself
158             scope the scope chain
159             global the global object
160             this the invocant
161             args the arguments passed to the function (as individual
162             arguments)
163             [args] the arguments passed to the function (as an array ref)
164              
165             If C is omitted, 'args' will be assumed.
166              
167             =item constructor
168              
169             A code ref that creates and initialises a new object. This is called when
170             the C keyword is used in JavaScript, or when the C method
171             is used in Perl.
172              
173             If this is omitted, when C or C is used, a new empty object
174             will be created and passed to the
175             sub specified under C as its 'this' value. The return value of
176             the sub will be
177             returned I it is an object; the (possibly modified) object originally
178             passed to the function will be returned otherwise.
179              
180             =item constructor_args
181              
182             Like C, but the C<'this'> string does not apply. If
183             C is
184             omitted, the arg list will be set to
185             C<[ qw( scope args ) ]> (B).
186              
187             This is completely ignored if C is
188             omitted.
189              
190             =item downgrade (not yet implemented)
191              
192             This applies only when C or C is a code ref. This
193             is a boolean indicating whether the arguments to the function should have
194             their C methods called automatically.; i.e., as though
195             S<<< C<< map $_->value, @args >> >>> were used instead of C<@args>.
196              
197             =item no_proto
198              
199             If this is set to true, the returned function will have no C
200             property.
201              
202             =back
203              
204             =back
205              
206             =head1 METHODS
207              
208             =over 4
209              
210             =item new JE::Object::Function
211              
212             See L.
213              
214             =cut
215              
216             sub new {
217             # E 15.3.2
218 3791     3791 1 6249 my($class,$scope) = (shift,shift);
219 3791         3638 my %opts;
220              
221 3791 100       6711 if(ref $scope eq 'HASH') {
222 3733         13125 %opts = %$scope;
223 3733         6090 $scope = $opts{scope};
224             }
225             else {
226             %opts = @_ == 1 # bypass param-parsing for the sake of
227             # efficiency
228             ? ( function => shift )
229 58 100       171 : ( argnames => do {
230 35         333 my $src = '(' . join(',', @_[0..$#_-1]) .
231             ')';
232 35     1   171 $src =~ s/\p{Cf}//g;
  1         698  
  1         8  
  1         10  
233             # ~~~ What should I do here for the file
234             # name and the starting line number?
235 35         105 my $params = JE::Parser::_parse(
236             params => $src, $scope
237             );
238 35 100       71 $@ and die $@;
239 31         97 $params;
240             },
241             function => pop )
242             ;
243             }
244              
245 3787 0       11256 defined blessed $scope
    50          
246             or croak "The 'scope' passed to JE::Object::Function->new (" .
247             (defined $scope ? $scope : 'undef') . ") is not an object";
248              
249             # ~~~ I should be able to remove the need for this to be a JE::Scope. Per-
250             # haps it could be an array ref instead. That way, the caller won’t
251             # have to bless something that we copy & bless further down anyway.
252             # Right now, other parts of the code base rely on it, so it would
253             # require a marathon debugging session.
254 3787 100       12390 ref $scope ne 'JE::Scope' and $scope = bless [$scope], 'JE::Scope';
255 3787         5415 my $global = $$scope[0];
256              
257 3787         8861 my $self = $class->SUPER::new($global, {
258             prototype => $global->prototype_for('Function')
259             });
260 3787         7857 my $guts = $$self;
261              
262 3787         5023 $$guts{scope} = $scope;
263              
264              
265 3787 100       9107 $opts{no_proto} or $self->prop({
266             name => 'prototype',
267             dontdel => 1,
268             value => JE::Object->new($global),
269             })->prop({
270             name => 'constructor',
271             dontenum => 1,
272             value => $self,
273             });
274              
275 101     101   98129 { no warnings 'uninitialized';
  101         144  
  101         77697  
  3787         4598  
276              
277 3787 100 66     20046 $$guts{function} =
278             ref($opts{function}) =~ /^(?:JE::Code|CODE)\z/ ? $opts{function}
279             : length $opts{function} &&
280             (
281             parse $global $opts{function} or die
282             )
283             ;
284              
285             $self->prop({
286             name => 'length',
287             value => JE::Number->new($global, $opts{length} ||
288             (ref $opts{argnames} eq 'ARRAY'
289 3781   66     16169 ? scalar @{$opts{argnames}} : 0)),
290             dontenum => 1,
291             dontdel => 1,
292             readonly => 1,
293             });
294              
295             } #warnings back on
296              
297 2065         4235 $$guts{func_argnames} = [
298 3781 100       10771 ref $opts{argnames} eq 'ARRAY' ? @{$opts{argnames}} : ()
299             ];
300 3380         6116 $$guts{func_args} = [
301             ref $opts{function_args} eq 'ARRAY'
302 3781 100       6931 ? @{$opts{function_args}} :
303             'args'
304             ];
305              
306 3781 100       7112 if(exists $opts{constructor}) {
307 192         358 $$guts{constructor} = $opts{constructor};
308 192         451 $$guts{constructor_args} = [
309             ref $opts{constructor_args} eq 'ARRAY'
310 192 50       512 ? @{$opts{constructor_args}} : ('scope', 'args')
311             # ~~~ what is the most useful default here?
312             ];
313             }
314 3781 100       6674 if(exists $opts{name}) {
315 3555         5282 $$guts{func_name} = $opts{name};
316             }
317              
318 3781         9343 $self->prop({dontdel=>1, name=>'arguments',value=>$global->null});
319            
320 3781         18937 $self;
321             }
322              
323              
324             =item call_with ( $obj, @args )
325              
326             Calls a function with the given arguments. The C<$obj> becomes the
327             function's invocant. This method is intended for general use from the Perl
328             side. The arguments (including C<$obj>) are automatically upgraded.
329              
330             =cut
331              
332             sub call_with {
333 2     2 1 4 my $func = shift;
334 2         8 my $ret = $func->apply( $func->global->upgrade(@_) );
335 2 100       15 typeof $ret eq 'undefined' ? undef : $ret
336             }
337              
338             =item call ( @args )
339              
340             This method, intended mainly for internal use, calls a function with the
341             given arguments, without upgrading them. The invocant (the 'this' value)
342             will be the global object. This is just a wrapper around C.
343              
344             This method is very badly named and will probably be renamed in a future
345             version. Does anyone have any suggestions?
346              
347             =cut
348              
349             sub call {
350 186     186 1 259 my $self = shift;
351 186         566 $self->apply($$$self{global}, @_);
352             }
353              
354              
355              
356              
357             =item construct
358              
359             This method, likewise intended mainly for internal use, calls the
360             constructor, if this function has one (functions written in JS
361             don't have this). Otherwise, an object will be created and passed to the
362             function as its invocant. The return value of the function will be
363             discarded, and the object (possibly modified) will be returned instead.
364              
365             =cut
366              
367             sub construct { # ~~~ we need to upgrade the args passed to construct, but
368             # still retain the unupgraded values to pass to the
369             # function *if* the function wants them downgraded
370 1115     1115 1 1199 my $self = shift;
371 1115         1410 my $guts = $$self;
372 1115         1593 my $global = $$guts{global};
373 1115 100 66     4902 if(exists $$guts{constructor}
374             and ref $$guts{constructor} eq 'CODE') {
375 1012         1099 my $code = $$guts{constructor};
376 1012         962 my @args;
377 1012         961 for( @{ $$guts{constructor_args} } ) {
  1012         2278  
378 2002 0       8506 push @args,
    50          
    100          
    100          
    50          
379             $_ eq 'self'
380             ? $self
381             : $_ eq 'scope'
382             ? _init_scope($self, $$guts{scope},
383             [], @_)
384             : $_ eq 'global'
385             ? $global
386             : $_ eq 'args'
387             ? @_ # ~~~ downgrade if wanted
388             : $_ eq '[args]'
389             ? [@_] # ~~~ downgrade if wanted
390             : undef;
391             }
392             # ~~~ What can we do to avoid the upgrade overhead for
393             # JS internal functions?
394 1012         3197 return $global->upgrade($code->(@args));
395             }
396             else {
397             # If the prototype property does not exist, then, since it
398             # is undeletable, this can only be a function created with
399             # no_proto => 1, i.e., an internal functions that’s meant
400             # to die here.
401 103 100 100     286 defined(my $proto = $self->prop('prototype'))
402             or die JE::Object::Error::TypeError->new(
403             $global, add_line_number
404             +($$guts{func_name} || 'The function').
405             " cannot be called as a constructor");
406              
407 20 100       62 my $obj = JE::Object->new($global,
408             !$proto->primitive ?
409             { prototype => $proto }
410             : ()
411             );
412 20         61 my $return = $global->upgrade(
413             $self->apply($obj, @_)
414             );
415 20 100 66     143 return $return->can('primitive') && !$return->primitive
416             ? $return
417             : $obj;
418             }
419             }
420              
421              
422              
423              
424             =item apply ( $obj, @args )
425              
426             This method, intended mainly for internal use just like the two above,
427             calls the function with $obj as the invocant and @args as the args. No
428             upgrading occurs.
429              
430             This method is very badly named and will probably be renamed in a future
431             version. Does anyone have any suggestions?
432              
433             =cut
434              
435             sub apply { # ~~~ we need to upgrade the args passed to apply, but still
436             # retain the unupgraded values to pass to the function *if*
437             # the function wants them downgraded
438 24074     24074 1 28330 my ($self, $obj) = (shift, shift);
439 24074         27927 my $guts = $$self;
440 24074         30544 my $global = $$guts{global};
441              
442 24074 100 100     160211 if(!blessed $obj or ref $obj eq 'JE::Object::Function::Call'
      100        
443             or ref($obj) =~ /^JE::(?:Null|Undefined)\z/) {
444 25         38 $obj = $global;
445             }
446              
447 24074 100       54761 if(ref $$guts{function} eq 'CODE') {
    100          
448 22168         20676 my @args;
449 22168         18889 for( @{ $$guts{func_args} } ) {
  22168         42329  
450 27077 0       117804 push @args,
    50          
    100          
    100          
    100          
    50          
451             $_ eq 'self'
452             ? $self
453             : $_ eq 'scope'
454             ? _init_scope($self, $$guts{scope},
455             $$guts{func_argnames}, @_)
456             : $_ eq 'global'
457             ? $global
458             : $_ eq 'this'
459             ? $obj
460             : $_ eq 'args'
461             ? @_ # ~~~ downgrade if wanted
462             : $_ eq '[args]'
463             ? [@_] # ~~~ downgrade if wanted
464             : undef;
465             }
466 22168         62962 return $global->upgrade(
467             # This list slice is necessary to work around a bug
468             # in perl5.8.8 (but not in 5.8.6 or 5.10). Try
469             # running this code to see what I mean:
470             #
471             # bless ($foo=[]); sub bar{print "ok\n"}
472             # $foo->bar(sub{warn;return "anything"}->())
473             #
474             (scalar $$guts{function}->(@args))[0]
475             );
476             }
477             elsif ($$guts{function}) {
478 1896         2515 my $at = $@;
479 1896         4402 my $scope = _init_scope(
480             $self, $$guts{scope},
481             $$guts{func_argnames}, @_
482             );
483 1896         5950 my $time_bomb = bless [$self, $self->prop('arguments')],
484             'JE::Object::Function::_arg_wiper';
485 1896         6232 $self->prop('arguments', $$scope[-1]{-arguments});
486 1896         5162 my $ret = $$guts{function}->execute(
487             $obj->to_object, $scope, 2
488             );
489 1896 100       3801 defined $ret or die;
490 1892         2062 $@ = $at;
491 1892         5678 return $ret;
492             }
493             else {
494 101 50   101   555 if (!defined $global) { use Carp; Carp::cluck() }
  101         137  
  101         48444  
  10         27  
  0         0  
495 10         26 return $global->undefined;
496             }
497             }
498              
499             sub JE::Object::Function::_arg_wiper::DESTROY {
500 1896     1896   6365 $_[0][0] # function
501             ->prop(
502             'arguments', $_[0][1] # old arguments value
503             )
504             }
505              
506             sub _init_scope { # initialise the new scope for the function call
507 6377     6377   11139 my($self, $scope, $argnames, @args) = @_;
508              
509 6377         35905 bless([ @$scope, JE::Object::Function::Call->new({
510             global => $$$self{global},
511             argnames => $argnames,
512             args => [@args],
513             function => $self,
514             })], 'JE::Scope');
515             }
516              
517              
518              
519              
520             =item typeof
521              
522             This returns the string 'function'.
523              
524             =cut
525              
526 324     324 1 1198 sub typeof { 'function' }
527              
528              
529              
530              
531             =item class
532              
533             This returns the string 'Function'.
534              
535             =cut
536              
537 121     121 1 593 sub class { 'Function' }
538              
539              
540              
541              
542             =item value
543              
544             Not yet implemented.
545              
546             =cut
547              
548 0     0 1 0 sub value { die "JE::Object::Function::value is not yet implemented." }
549              
550              
551             #----------- PRIVATE SUBROUTINES ---------------#
552              
553             # _init_proto takes the Function prototype (Function.prototype) as its sole
554             # arg and adds all the default properties thereto.
555              
556             sub _init_proto {
557 106     106   204 my $proto = shift;
558 106         266 my $scope = $$proto->{global};
559              
560             # E 15.3.4
561 106         446 $proto->prop({
562             dontenum => 1,
563             name => 'constructor',
564             value => $scope->prop('Function'),
565             });
566              
567             $proto->prop({
568             name => 'toString',
569             value => JE::Object::Function->new({
570             scope => $scope,
571             name => 'toString',
572             no_proto => 1,
573             function_args => ['this'],
574             function => sub {
575 38     38   45 my $self = shift;
576 38 100       185 $self->isa(__PACKAGE__) or die new
577             JE::Object::Error::TypeError
578             $scope, add_line_number "Function."
579             ."prototype.toString can only be "
580             ."called on functions";
581 37         47 my $guts = $$self;
582 37         42 my $str = 'function ';
583 37         180 JE::String->_new($scope,
584             'function ' .
585             ( exists $$guts{func_name} ?
586             $$guts{func_name} :
587             'anon'.$self->id) .
588             '(' .
589             join(',', @{$$guts{func_argnames}})
590             . ") {" .
591             ( ref $$guts{function}
592             eq 'JE::Code'
593 37 100       160 ? do {
    100          
594 27         34 my $code =
595             $$guts{function};
596 27         56 my $offsets =
597             $$guts{function}
598             {tree}[0];
599 27         26 $code = substr ${$$code{source}},
  27         104  
600             $$offsets[0],
601             $$offsets[1] -
602             $$offsets[0];
603             # We have to check for a final line
604             # break in case it ends with a sin-
605             # gle-line comment.
606 27 50       251 $code =~ /[\cm\cj\x{2028}\x{2029}]\z/
607             ? $code : $code . "\n"
608             }
609             : "\n // [native code]\n"
610             ) . '}'
611             # ~~~ perhaps this should be changed so it doesn't comment out the
612             # the [native code] thingy. That way an attempt to
613             # eval the strung version will fail. (In this case, I need to add a
614             # teest too make sure it dies.)
615             );
616             },
617 106         1309 }),
618             dontenum => 1,
619             });
620             $proto->prop({
621             name => 'apply',
622             value => JE::Object::Function->new({
623             scope => $scope,
624             name => 'apply',
625             argnames => [qw/thisArg argArray/],
626             no_proto => 1,
627             function_args => ['this','args'],
628             function => sub {
629 178     178   306 my($self,$obj,$args) = @_;
630              
631 178         259 my $at = $@;
632              
633 101     101   547 no warnings 'uninitialized';
  101         158  
  101         94862  
634 178 100 100     542 if(defined $args and
  5   100     21  
635             ref($args) !~ /^JE::(Null|Undefined|
636             Object::Function::Arguments)\z/x
637             and eval{$args->class} ne 'Array') {
638             die JE::Object::Error::TypeError
639             ->new($scope, add_line_number
640             "Second argument to "
641             . "'apply' is of type '" .
642             (eval{$args->class} ||
643 4   33     5 eval{$args->typeof} ||
644             ref $args) .
645             "', not 'Arguments' or " .
646             "'Array'");
647             }
648 174         240 $@ = $at;
649 174 100       404 $args = $args->value if defined $args;
650 174 100       645 $self->apply($obj, defined $args ?
651             @$args : ());
652             },
653 106         1520 }),
654             dontenum => 1,
655             });
656             $proto->prop({
657             name => 'call',
658             value => JE::Object::Function->new({
659             scope => $scope,
660             name => 'call',
661             argnames => ['thisArg'],
662             no_proto => 1,
663             function_args => ['this','args'],
664             function => sub {
665 104     104   262 shift->apply(@_);
666             },
667 106         1462 }),
668             dontenum => 1,
669             });
670             }
671              
672              
673             #----------- THE REST OF THE DOCUMENTATION ---------------#
674              
675             =back
676              
677             =head1 OVERLOADING
678              
679             You can use a JE::Object::Function as a coderef. The sub returned simply
680             invokes the C method, so the following are equivalent:
681              
682             $function->call( $function->global->upgrade(@args) )
683             $function->(@args)
684              
685             The stringification, numification, boolification, and hash dereference ops
686             are also overloaded. See L, which this class inherits from.
687              
688             =head1 SEE ALSO
689              
690             =over 4
691              
692             =item JE
693              
694             =item JE::Object
695              
696             =item JE::Types
697              
698             =item JE::Scope
699              
700             =item JE::LValue
701              
702             =back
703              
704             =cut
705              
706              
707             package JE::Object::Function::Call;
708              
709             our $VERSION = '0.064';
710              
711             sub new {
712             # See sub JE::Object::Function::_init_sub for the usage.
713              
714 6377     6377   7201 my($class,$opts) = @_;
715 6377         5575 my @args = @{$$opts{args}};
  6377         11920  
716 6377         5964 my(%self,$arg_val);
717 6377         5205 for(@{$$opts{argnames}}){
  6377         11041  
718 8151         8831 $arg_val = shift @args;
719 8151         20608 $self{-dontdel}{$_} = 1;
720 8151 100       19913 $self{$_} = defined $arg_val ? $arg_val :
721             $$opts{global}->undefined;
722             }
723              
724 6377         13034 $self{-dontdel}{arguments} = 1;
725              
726 6377         9840 $self{'-global'} = $$opts{global};
727             # A call object's properties can never be accessed via bracket
728             # syntax, so '-global' cannot conflict with properties, since the
729             # latter have to be valid identifiers. Same 'pplies to dontdel, o'
730             # course.
731            
732             # Note on arguments vs -arguments: ‘arguments’ represents the
733             # actual ‘arguments’ property, which may or may not refer to the
734             # Arguments object, depending on whether there is an argument
735             # named ‘arguments’. ‘-arguments’ always refers to the Arguments
736             # object, which we need further up when we assign to the arguments
737             # property of the function itself.
738              
739 6377         17275 $self{-arguments} =
740             JE::Object::Function::Arguments->new(
741             $$opts{global},
742             $$opts{function},
743             \%self,
744             $$opts{argnames},
745 6377         11245 @{$$opts{args}},
746             );
747 6377 100       14406 unless (exists $self{arguments}) {
748 6376         10232 $self{arguments} = $self{-arguments}
749             };
750              
751 6377         36862 return bless \%self, $class;
752             }
753              
754             sub prop {
755 9407     9407   11440 my ($self, $name) =(shift,shift);
756              
757 9407 100       15722 if(ref $name eq 'HASH') {
758 272         327 my $opts = $name;
759 272         372 $name = $$opts{name};
760 272 50       663 @_ = exists($$opts{value}) ? $$opts{value} : ();
761 272 50       1037 $$self{'-dontdel'}{$name} = !!$$opts{dontdel}
762             if exists $$opts{dontdel};
763             }
764              
765 9407 100       15532 if (@_ ) {
766 901         3053 return $$self{$name} = shift;
767             }
768              
769 8506 100       15396 if (exists $$self{$name}) {
770 8177         17149 return $$self{$name};
771             }
772              
773             return
774 329         867 }
775              
776             sub delete {
777 92     92   138 my ($self,$varname) = @_;
778 92 100       175 unless($_[2]) { # if $_[2] is true we delete it anyway
779 39 100 66     171 exists $$self{-dontdel}{$varname}
780             && $$self{-dontdel}{$varname}
781             && return !1;
782             }
783 88         208 delete $$self{-dontdel}{$varname};
784 88         130 delete $$self{$varname};
785 88         231 return 1;
786             }
787              
788 8670     8670   29481 sub exists { exists $_[0]{$_[1]} }
789 1795     1795   5622 sub prototype{}
790              
791              
792              
793              
794             package JE::Object::Function::Arguments;
795              
796             our $VERSION = '0.064';
797              
798             our @ISA = 'JE::Object';
799              
800             sub new {
801 6377     6377   10807 my($class,$global,$function,$call,$argnames,@args) = @_;
802            
803 6377         19784 my $self = $class->SUPER::new($global);
804 6377         10879 my $guts = $$self;
805              
806 6377         9185 $$guts{args_call} = $call;
807 6377         23783 $self->prop({
808             name => 'callee',
809             value => $function,
810             dontenum => 1,
811             });
812 6377         24144 $self->prop({
813             name => 'length',
814             value => JE::Number->new($global, scalar @args),
815             dontenum => 1,
816             });
817 6377         13409 $$guts{args_length} = @args; # in case the length prop
818             # gets changed
819              
820             =begin pseudocode
821              
822             Go through the named args one by one in reverse order, starting from $#args
823             if $#args < $#params
824              
825             If an arg with the same name as the current one has been seen
826             Create a regular numbered property for that arg.
827             Else
828             Create a magical property.
829              
830             =end pseudocode
831              
832             =cut
833              
834 6377         6704 my (%seen,$name,$val);
835 6377         14039 for (reverse 0..($#args,$#$argnames)[$#$argnames < $#args]) {
836 8057         14037 ($name,$val) = ($$argnames[$_], $args[$_]);
837 8057 100       16847 if($seen{$name}++) {
838 2         10 $self->prop({
839             name => $_,
840             value => $val,
841             dontenum => 1,
842             });
843             }
844             else {
845 8055         20592 $$guts{args_magic}{$_} = $name;
846             }
847             }
848              
849             # deal with any extra properties
850 6377         15685 for (@$argnames..$#args) {
851 1399         3650 $self->prop({
852             name => $_,
853             value => $args[$_],
854             dontenum => 1,
855             });
856             }
857              
858 6377         20939 $self;
859             }
860              
861             sub prop {
862             # Some properties are magically linked to properties of
863             # the call object.
864              
865 14244     14244   14351 my($self,$name) = @_;
866 14244         14263 my $guts = $$self;
867 14244 100 100     30058 if (exists $$guts{args_magic} and exists $$guts{args_magic}{$name})
868             {
869 13         40 return $$guts{args_call}->prop(
870             $$guts{args_magic}{$name}, @_[2..$#_]
871             );
872             }
873 14231         38479 SUPER::prop $self @_[1..$#_];
874             }
875              
876             sub delete {
877             # Magical properties are still deleteable.
878 0     0   0 my($self,$name) = @_;
879 0         0 my $guts = $$self;
880 0 0 0     0 if (exists $$guts{args_magic} and exists $$guts{args_magic}{$name})
881             {
882 0         0 delete $$guts{args_magic}{$name}
883             }
884 0         0 SUPER::delete $self @_[1..$#_];
885             }
886              
887             sub value {
888 1     1   3 my $self = shift;
889 1         6 [ map $self->prop($_), 0..$$$self{args_length}-1 ];
890             }
891              
892             1;