File Coverage

blib/lib/JE/Object/Array.pm
Criterion Covered Total %
statement 194 281 69.0
branch 64 132 48.4
condition 21 42 50.0
subroutine 33 41 80.4
pod 5 9 55.5
total 317 505 62.7


line stmt bran cond sub pod time code
1             package JE::Object::Array;
2              
3             our $VERSION = '0.064';
4              
5 101     101   33088 use strict;
  101         138  
  101         3245  
6 101     101   548 use warnings; no warnings 'utf8';
  101     101   129  
  101         2377  
  101         399  
  101         124  
  101         3830  
7              
8 101         616 use overload fallback => 1,
9 101     101   398 '@{}'=> \&_get_tie;
  101         1875  
10              
11              
12 101     101   5713 use List::Util qw/min max/;
  101         180  
  101         5518  
13 101     101   462 use Scalar::Util 'blessed';
  101         120  
  101         222755  
14              
15             our @ISA = 'JE::Object';
16              
17             require JE::Code;
18             require JE::Object ;
19             require JE::Object::Error::TypeError ;
20             require JE::Object::Function ;
21             require JE::String ;
22             require JE::Number ;
23              
24             import JE::Code 'add_line_number';
25             sub add_line_number;
26              
27             =head1 NAME
28              
29             JE::Object - JavaScript Array object class
30              
31             =head1 SYNOPSIS
32              
33             use JE;
34             use JE::Object::Array;
35              
36             $j = new JE;
37              
38             $js_array = new JE::Object::Array $j, 1, 2, 3;
39              
40             $perl_arrayref = $js_array->value; # returns [1, 2, 3]
41              
42             $js_array->[1]; # same as $js_array->value->[1]
43              
44             "$js_array"; # returns "1,2,3"
45              
46             =head1 DESCRIPTION
47              
48             This module implements JavaScript Array objects.
49              
50             The C<@{}> (array ref) operator is overloaded and returns a tied array that
51             you can use to modify the array object itself. The limitations and caveats
52             mentioned in
53             C apply here, too.
54              
55             =head1 METHODS
56              
57             See L for descriptions of most of the methods. Only what
58             is specific to JE::Object::Array is explained here.
59              
60             =over 4
61              
62             =item $a = JE::Object::Array->new($global_obj, \@elements)
63              
64             =item $a = JE::Object::Array->new($global_obj, $length)
65              
66             =item $a = JE::Object::Array->new($global_obj, @elements)
67              
68             This creates a new Array object.
69              
70             If the second argument is an unblessed array ref, the elements of that
71             array become the elements of the new array object.
72              
73             If there are two arguments and the second
74             is a JE::Number, a new array is created with that number as the length.
75              
76             Otherwise, all arguments starting from the second one become elements of
77             the new array object.
78              
79             =cut
80              
81             sub new {
82 5456     5456 1 7037 my($class,$global) = (shift,shift);
83              
84 5456         4546 my @array;
85 5456 100 100     16308 if (ref $_[0] eq 'ARRAY') {
    100          
86 154         158 @array = $global->upgrade(@{+shift});
  154         436  
87             } elsif (@_ == 1 && UNIVERSAL::isa $_[0], 'JE::Number') {
88 9         59 my $num = 0+shift;
89 9 100       68 $num == int($num) % 2**32
90             or require JE::Object::Error::RangeError,
91             die JE::Object::Error::RangeError->new($global,
92             add_line_number "$num is not a valid array index");
93 5         17 $#array = $num - 1;
94             }
95             else {
96 5293         12036 @array = $global->upgrade(@_);
97             }
98 5452   33     12409 my $self = SUPER::new $class $global, {
99             prototype => $global->prototype_for('Array') ||
100             $global->prop('Array')->prop('prototype')
101             };
102              
103 5452         10743 my $guts = $$self;
104              
105 5452         8929 $$guts{array} = \@array;
106 5452         13116 bless $self, $class;
107             }
108              
109              
110              
111              
112             sub prop {
113 47882     47882 1 75339 my ($self, $name, $val) = (shift, @_);
114 47882         56973 my $guts = $$self;
115              
116 47882 100 66     312879 if ($name eq 'length') {
    100          
117 1580 100       2944 if (@_ > 1) { # assignment
118 51 50       109 $val == int($val) % 2**32 or
119             require JE::Object::Error::RangeError,
120             die new JE::Object::Error::RangeError
121             $$guts{global},
122             add_line_number
123             "$val is not a valid value for length";
124 51         93 $#{$$guts{array}} = $val - 1;
  51         104  
125 51         130 return JE::Number->new($$guts{global}, $val);
126             }
127             else {
128 1529         5045 return JE::Number->new($$guts{global},
129 1529         2384 $#{$$guts{array}} + 1);
130             }
131             }
132             elsif ($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295) {
133 45212 100       68961 if (@_ > 1) { # assignment
134 54         141 return $$guts{array}[$name] =
135             $$guts{global}->upgrade($val);
136             }
137             else {
138 45158 100       172275 return exists $$guts{array}[$name]
139             ? $$guts{array}[$name] : undef;
140             }
141             }
142 1090         2637 $self->SUPER::prop(@_);
143             }
144              
145              
146              
147              
148             sub is_enum {
149 6     6 0 11 my ($self,$name) = @_;
150 6 100       19 $name eq 'length' and return !1;
151 5 100 66     29 if ($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295) {
152 2         7 my $array = $$$self{array};
153 2   66     22 return $name < @$array && defined $$array[$name];
154             }
155 3         15 SUPER::is_enum $self $name;
156             }
157              
158              
159              
160              
161             sub keys { # length is not enumerable
162 28     28 0 305 my $self = shift;
163 28         49 my $array = $$$self{array};
164 28         1288 grep(defined $$array[$_], 0..$#$array),
165             SUPER::keys $self;
166             }
167              
168              
169              
170              
171             sub delete { # array indices are deletable; length is not
172 53     53 1 72 my($self,$name) = @_;
173 53 100       114 $name eq 'length' and return !1;
174 52 100 66     254 if($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295) {
175 49         75 my $array = $$$self{array};
176 49 100       108 $name < @$array and $$array[$name] = undef;
177 49         84 return 1;
178             }
179 3         30 SUPER::delete $self $name;
180             }
181              
182              
183              
184              
185             =item $a->value
186              
187             This returns a reference to an array. This is a copy of the Array object's
188             internal array. If you want an array through which you can modify the
189             object, use C<@$a>.
190              
191             =cut
192              
193 5     5 1 1913 sub value { [@{$${+shift}{array}}] };
  5         8  
  5         35  
194             *TO_JSON=*value;
195              
196              
197             sub exists {
198 13     13 0 26 my ($self, $name) = (shift, @_);
199 13         21 my $guts = $$self;
200              
201 13 100 66     83 if ($name eq 'length') {
    100          
202 2         7 return 1
203             }
204             elsif ($name =~ /^(?:0|[1-9]\d*)\z/ and $name < 4294967295) {
205 6   66     44 return exists $$guts{array}[$name]
206             && defined $$guts{array}[$name];
207             }
208 5         21 $self->SUPER::exists(@_);
209             }
210              
211 197     197 1 741 sub class { 'Array' }
212              
213              
214              
215             sub _new_constructor {
216 23     23   43 my $global = shift;
217             my $construct_cref = sub {
218 29     29   106 __PACKAGE__->new(@_);
219 23         118 };
220 23         305 my $f = JE::Object::Function->new({
221             name => 'Array',
222             scope => $global,
223             function => $construct_cref,
224             function_args => ['global','args'],
225             length => 1,
226             constructor => $construct_cref,
227             constructor_args => ['global','args'],
228             });
229              
230 23         186 my $proto = $f->prop({
231             name => 'prototype',
232             dontenum => 1,
233             readonly => 1,
234             });
235 23         72 bless $proto, __PACKAGE__;
236 23         1241 $$$proto{array} = [];
237 23         94 $global->prototype_for('Array',$proto);
238              
239 23         203 $proto->prop({
240             name => 'toString',
241             value => JE::Object::Function->new({
242             scope => $global,
243             name => 'toString',
244             length => 0,
245             no_proto => 1,
246             function_args => ['this'],
247             function => \&_toString,
248             }),
249             dontenum => 1,
250             });
251              
252 23         226 $proto->prop({
253             name => 'toLocaleString',
254             value => JE::Object::Function->new({
255             scope => $global,
256             name => 'toLocaleString',
257             length => 0,
258             no_proto => 1,
259             function_args => ['this'],
260             function => \&_toLocaleString,
261             }),
262             dontenum => 1,
263             });
264              
265 23         233 $proto->prop({
266             name => 'concat',
267             value => JE::Object::Function->new({
268             scope => $global,
269             name => 'concat',
270             length => 1,
271             no_proto => 1,
272             function_args => ['this','args'],
273             function => \&_concat,
274             }),
275             dontenum => 1,
276             });
277              
278 23         250 $proto->prop({
279             name => 'join',
280             value => JE::Object::Function->new({
281             scope => $global,
282             name => 'join',
283             argnames => ['separator'],
284             no_proto => 1,
285             function_args => ['this','args'],
286             function => \&_join,
287             }),
288             dontenum => 1,
289             });
290              
291 23         214 $proto->prop({
292             name => 'pop',
293             value => JE::Object::Function->new({
294             scope => $global,
295             name => 'pop',
296             length => 0,
297             no_proto => 1,
298             function_args => ['this'],
299             function => \&_pop,
300             }),
301             dontenum => 1,
302             });
303              
304 23         217 $proto->prop({
305             name => 'push',
306             value => JE::Object::Function->new({
307             scope => $global,
308             name => 'push',
309             length => 1,
310             no_proto => 1,
311             function_args => ['this','args'],
312             function => \&_push,
313             }),
314             dontenum => 1,
315             });
316              
317 23         224 $proto->prop({
318             name => 'reverse',
319             value => JE::Object::Function->new({
320             scope => $global,
321             name => 'reverse',
322             length => 0,
323             no_proto => 1,
324             function_args => ['this'],
325             function => \&_reverse,
326             }),
327             dontenum => 1,
328             });
329              
330 23         235 $proto->prop({
331             name => 'shift',
332             value => JE::Object::Function->new({
333             scope => $global,
334             name => 'shift',
335             length => 0,
336             no_proto => 1,
337             function_args => ['this'],
338             function => \&_shift,
339             }),
340             dontenum => 1,
341             });
342              
343 23         249 $proto->prop({
344             name => 'slice',
345             value => JE::Object::Function->new({
346             scope => $global,
347             name => 'shift',
348             argnames => [qw/start end/],
349             no_proto => 1,
350             function_args => ['this','args'],
351             function => \&_slice,
352             }),
353             dontenum => 1,
354             });
355              
356 23         247 $proto->prop({
357             name => 'sort',
358             value => JE::Object::Function->new({
359             scope => $global,
360             name => 'sort',
361             argnames => [qw/comparefn/],
362             no_proto => 1,
363             function_args => ['this','args'],
364             function => \&_sort,
365             }),
366             dontenum => 1,
367             });
368              
369 23         306 $proto->prop({
370             name => 'splice',
371             value => JE::Object::Function->new({
372             scope => $global,
373             name => 'splice',
374             argnames => [qw/start
375             deleteCount/],
376             no_proto => 1,
377             function_args => ['this','args'],
378             function => \&_splice,
379             }),
380             dontenum => 1,
381             });
382              
383 23         222 $proto->prop({
384             name => 'unshift',
385             value => JE::Object::Function->new({
386             scope => $global,
387             name => 'unshift',
388             length => 1,
389             no_proto => 1,
390             function_args => ['this','args'],
391             function => \&_unshift,
392             }),
393             dontenum => 1,
394             });
395              
396 23         240 $f
397             }
398              
399             # ~~~ I should be able to optimise those methods that are designed to work
400             # with any JS object by checking first to see whether ref eq __PACKAGE__
401             # and then doing a fast Perl-style algorithm (reverse would be a good
402             # candidate for this)
403              
404             sub _toString {
405 156     156   183 my $self = shift;
406              
407 156 50       233 eval{$self->class} eq 'Array'
  156         326  
408             or die JE::Object::Error::TypeError->new($self->global,
409             add_line_number 'Object is not an Array');
410              
411 156         232 my $guts = $$self;
412 156         1226 JE::String->_new(
413             $$guts{global},
414             join ',', map
415             defined $_ && ref !~ /^JE::(?:Undefined|Null)\z/
416             ? $_->to_string->value : '',
417 156 100 100     238 @{ $$guts{array} }
418             );
419             }
420              
421             sub _toLocaleString {
422 0     0   0 my $self = shift;
423              
424 0 0       0 eval{$self->class} eq 'Array'
  0         0  
425             or die JE::Object::Error::TypeError->new($self->global,
426             'Object is not an Array');
427              
428 0         0 my $guts = $$self;
429 0         0 JE::String->_new(
430             $$guts{global},
431             join ',', map
432             defined $_ && defined $_->value
433             ? $_->method('toLocaleString')->value : '',
434 0 0 0     0 @{ $$guts{array} }
435             );
436             }
437              
438             sub _concat {
439 0     0   0 unshift @_, shift->to_object;
440 0         0 my $thing;
441 0         0 my $new = __PACKAGE__->new(my $global = $_[0]->global);
442 0         0 my @new;
443 0         0 while(@_) {
444 0         0 $thing = shift;
445 0 0       0 if(eval{$thing->class} eq 'Array') {
  0         0  
446 0         0 push @new, @{ $$$thing{array} };
  0         0  
447             }
448             else {
449 0         0 push @new, $thing;
450             }
451             }
452              
453 0         0 $$$new{array} = \@new;
454              
455 0         0 $new;
456             }
457              
458             sub _join {
459 6     6   13 my( $self,$sep) = @_;
460 6 50 33     31 !defined $sep || $sep->id eq 'undef' and $sep = ',';
461              
462 6         16 my $length = $self->prop('length');
463 6 50       15 if(defined $length) {
464 6         23 $length = $length->to_number->value % 2**32;
465 6 50       25 $length == $length or $length = 0;
466 0         0 } else { $length = 0 }
467            
468              
469 6         8 my $val;
470 27         37 JE::String->_new(
471             $self->global,
472             join $sep,
473             map {
474 6         34 my $val = $self->prop($_);
475 27 50 33     83 defined $val && defined $val->value
476             ? $val->to_string->value : ''
477             } 0..$length-1
478             );
479             }
480              
481             sub _pop {
482 34     34   45 my( $self) = @_;
483              
484 34         63 my $length = $self->prop('length');
485 34 50       64 if(defined $length) {
486 34         86 $length = (int $length->to_number->value) % 2**32;
487 34 50       87 $length == $length or $length = 0;
488 0         0 } else { $length = 0 }
489            
490 34         90 my $global = $self->global;
491 34 100       65 $length or
492             $self->prop('length', JE::Number->new($global,0)),
493             return $global->undefined;
494              
495            
496 33         34 $length--;
497 33         49 my $val = $self->prop($length);
498 33         71 $self->delete($length);
499 33         77 $self->prop(length => JE::Number->new($global,$length));
500 33         119 $val;
501             }
502              
503             sub _push {
504 13     13   21 my( $self) = shift;
505              
506 13         22 my $length = $self->prop('length');
507 13 50       33 if(defined $length) {
508 13         39 $length = (int $length->to_number->value) % 2**32;
509 13 50       45 $length == $length or $length = 0;
510 0         0 } else { $length = 0 }
511            
512 13         63 while(@_) {
513 13         30 $self->prop($length++, shift);
514             }
515              
516 13         47 $self->prop(length => JE::Number->new($self->global,$length));
517             }
518              
519             sub _reverse {
520 0     0   0 my $self = shift;
521            
522 0         0 my $length = $self->prop('length');
523 0 0       0 if(defined $length) {
524 0         0 $length = (int $length->to_number->value) % 2**32;
525 0 0       0 $length == $length or $length = 0;
526 0         0 } else { $length = 0 }
527            
528 0         0 my($elem1,$elem2,$indx2);
529              
530 0         0 for (0..int $length/2-1) {
531 0         0 $elem1 = $self->prop($_);
532 0         0 $elem2 = $self->prop($indx2 = $length - $_ - 1);
533              
534 0 0       0 defined $elem2
535             ? $self->prop($_ => $elem2)
536             : $self->delete($_);
537              
538 0 0       0 defined $elem1
539             ? $self->prop($indx2 => $elem1)
540             : $self->delete($indx2);
541             }
542              
543 0         0 $self;
544             }
545              
546             sub _shift {
547 1     1   2 my( $self) = @_;
548              
549 1         2 my $length = $self->prop('length');
550 1 50       4 if(defined $length) {
551 1         3 $length = (int $length->to_number->value) % 2**32;
552 1 50       5 $length == $length or $length = 0;
553 0         0 } else { $length = 0 }
554            
555 1 50       9 $length or
556             $self->prop('length', 0),
557             return $self->global->undefined;
558              
559 1         2 my $ret = $self->prop(0);
560 1         2 my $val;
561              
562 1         4 for (0..$length-2) {
563 3         8 $val = $self->prop($_+1);
564 3 100       12 defined $val
565             ? $self-> prop($_ => $val)
566             : $self->delete($_);
567             }
568 1         3 $self->delete(--$length);
569 1         4 $self->prop(length => $length);
570              
571 1         4 $ret;
572             }
573              
574             sub _slice {
575 0     0   0 my( $self,$start,$end) = @_;
576              
577 0         0 my $length = $self->prop('length');
578 0 0       0 if(defined $length) {
579 0         0 $length = (int $length->to_number->value) % 2**32;
580 0 0       0 $length == $length or $length = 0;
581 0         0 } else { $length = 0 }
582            
583 0         0 my $new = __PACKAGE__->new(my $global = $self->global);
584 0         0 my @new;
585              
586 0 0       0 if (defined $start) {
587 0         0 $start = int $start->to_number->value;
588 0 0       0 $start = $start == $start
    0          
589             ? $start < 0
590             ? max($start + $length,0)
591             : min($start, $length)
592             : 0;
593             }
594             else {
595 0         0 $start = 0
596             }
597              
598 0 0 0     0 if (defined $end and $end->id ne 'undef') {
599 0         0 $end = $end->to_number->value;
600 0 0       0 $end = $end == $end
    0          
601             ? $end < 0
602             ? max($end + $length,0)
603             : min($end, $length)
604             : 0;
605             }
606             else {
607 0         0 $end = $length
608             }
609            
610              
611 0         0 for ($start..$end-1) {
612 0         0 push @new, $self->prop($_);
613             }
614              
615 0         0 $$$new{array} = \@new;
616              
617 0         0 $new;
618             }
619              
620             sub _sort {
621 0     0   0 my($self, $comp) = @_;
622            
623 0         0 my $length = $self->prop('length');
624 0 0       0 if(defined $length) {
625 0         0 $length = (int $length->to_number->value) % 2**32;
626 0 0       0 $length == $length or $length = 0;
627 0         0 } else { $length = 0 }
628            
629 0         0 my(@sortable, @undef, $nonexistent, $val);
630 0         0 for(0..$length-1) {
631 0 0       0 defined($val = $self->prop($_))
    0          
632             ? $val->id eq 'undef'
633             ? (push @undef, $val)
634             : (push @sortable, $val)
635             : ++$nonexistent;
636             }
637              
638             my $comp_sub = defined $comp && $comp->can('call')
639 0     0   0 ? sub { 0+$comp->call($a,$b) }
640 0 0 0 0   0 : sub { $a->to_string->value16 cmp $b->to_string->value16};
  0         0  
641              
642 0         0 my @sorted = ((sort $comp_sub @sortable),@undef);
643              
644 0         0 for (0..$#sorted) {
645 0         0 $self->prop($_ => $sorted[$_]);
646             }
647              
648 101     101   610 no warnings 'uninitialized';
  101         129  
  101         67699  
649 0         0 for (@sorted .. $#sorted + $nonexistent) {
650 0         0 $self->delete($_);
651             }
652              
653 0         0 $self;
654             }
655              
656             sub _splice {
657 1     1   3 my ($self, $start, $del_count) = (shift, shift, shift);
658 1         3 my $global = $self->global;
659              
660 1         4 my $length = $self->prop('length');
661 1 50       3 if(defined $length) {
662 1         3 $length = ($length->to_number->value) % 2**32;
663 1 50       5 $length == $length or $length = 0;
664 0         0 } else { $length = 0 };
665            
666 1 50       3 if (defined $start) {
667 1         3 $start = int $start->to_number->value;
668 1 50       13 $start = $start == $start
    50          
669             ? $start < 0
670             ? max($start + $length,0)
671             : min($start, $length)
672             : 0;
673             }
674             else {
675 0         0 $start = 0
676             }
677              
678 1 50       3 if(defined $del_count) {
679 1         3 $del_count = int $del_count->to_number->value;
680 1 50       11 $del_count = $del_count >= 0
681             ? min($del_count, $length-$start)
682             : 0;
683             }
684             else {
685 0         0 $del_count = 0
686             }
687              
688 1         5 my @new = map $self->prop($_),
689             $start..(my $end = $start+$del_count-1);
690              
691 1         2 my $val;
692 1 50       4 if (@_ < $del_count) {
    50          
693 0         0 my $diff = $del_count - @_;
694 0         0 for ($end+1..$length-1) {
695 0 0       0 defined ($val = $self->prop($_))
696             ? $self->prop ($_ - $diff => $val)
697             : $self->delete($_ - $diff);
698             }
699 0         0 $self->prop(length =>
700             JE::Number->new($global, $length - $diff)
701             );
702             }
703             elsif (@_ > $del_count) {
704 1         2 my $diff = @_ - $del_count;
705 1         3 for (reverse $end+1..$length-1) {
706 0 0       0 defined ($val = $self->prop($_))
707             ? $self->prop ($_ + $diff => $val)
708             : $self->delete($_ + $diff);
709             }
710 1         5 $self->prop(length =>
711             JE::Number->new($global, $length + $diff)
712             );
713             }
714             else {
715 0         0 $self->prop(length => JE::Number->new($global,$length));
716             }
717              
718 1         5 for (0..$#_) {
719 3         7 $self->prop($_+$start => $_[$_]);
720             }
721              
722 1         4 my $new = __PACKAGE__->new($self->global);
723 1         2 $$new->{array} = \@new;
724            
725 1         3 $new;
726             }
727              
728             sub _unshift {
729 1     1   3 my ($self) = (shift,);
730              
731 1         3 my $length = $self->prop('length');
732 1 50       8 if(defined $length) {
733 1         5 $length = (int $length->to_number->value) % 2**32;
734 1 50       6 $length == $length or $length = 0;
735 0         0 } else { $length = 0 }
736              
737 1         3 my $val;
738 1         5 for (reverse 0..$length-1) {
739 3 100       6 defined ($val = $self->prop($_))
740             ? $self->prop ($_ + @_ => $val)
741             : $self->delete($_ + @_);
742             }
743              
744 1         7 for (0..$#_) {
745 1         3 $self->prop($_ => $_[$_]);
746             }
747 1         3 $self->prop(length => $length += @_);
748              
749 1         3 return JE::Number->new($self->global, $length);
750             }
751              
752              
753             #----------- TYING MAGIC ---------------#
754              
755             sub _get_tie {
756 11     11   15 my $self = shift;
757 11         15 my $guts = $$self;
758 11 100       31 $$guts{array_tie} or tie @{ $$guts{array_tie} }, __PACKAGE__,
  8         34  
759             $self;
760 11         44 $$guts{array_tie};
761             }
762              
763             # The qw/FETCH EXISTS DELETE/ methods are inherited from JE::Object.
764              
765 11     11   28 sub TIEARRAY { $_[1] }
766 13     13   383 sub FETCHSIZE { $_[0]->prop('length') }
767 1     1   4 sub STORESIZE { $_[0]->prop('length' => $_[1]) }
768 1     1   5 sub PUSH { shift->method(push => @_) }
769 1     1   5 sub POP { $_[0]->method('pop') }
770 1     1   5 sub SHIFT { $_[0]->method('shift') }
771 1     1   18 sub UNSHIFT { shift->method(unshift => @_) }
772 1     1   2 sub SPLICE { @{ shift->method(splice => @_)->value } }
  1         4  
773             sub DDS_freeze {
774 0     0 0   my $self = shift;
775 0           delete $$$self{array_tie};
776 0           SUPER::DDS_freeze $self;
777             }
778              
779             =back
780              
781             =head1 SEE ALSO
782              
783             L
784              
785             L
786              
787             L
788              
789             =cut
790              
791             1;