File Coverage

blib/lib/autobox/Core.pm
Criterion Covered Total %
statement 320 355 90.1
branch 103 122 84.4
condition 3 6 50.0
subroutine 131 146 89.7
pod n/a
total 557 629 88.5


line stmt bran cond sub pod time code
1             package autobox::Core;
2              
3 63     63   798895 use 5.008;
  63         154  
4              
5 63     63   214 use strict;
  63         65  
  63         970  
6 63     63   179 use warnings;
  63         68  
  63         2082  
7              
8             our $VERSION = '1.33';
9              
10 63     63   217 use base 'autobox';
  63         74  
  63         26626  
11              
12 63     63   366082 use B;
  63         88  
  63         2217  
13 63     63   25304 use Want ();
  63         76659  
  63         97396  
14              
15             # appending the user-supplied arguments allows autobox::Core options to be overridden
16             # or extended in the same statement e.g.
17             #
18             # use autobox::Core UNDEF => 'MyUndef'; # also autobox undef
19             # use autobox::Core CODE => undef; # don't autobox CODE refs
20             # use autobox::Core UNIVERSAL => 'Data::Dumper'; # enable a Dumper() method for all types
21              
22             sub import {
23 63     63   2578 shift->SUPER::import(DEFAULT => 'autobox::Core::', @_);
24             }
25              
26             =encoding UTF-8
27              
28             =head1 NAME
29              
30             autobox::Core - Provide core functions to autoboxed scalars, arrays and hashes.
31              
32             =head1 SYNOPSIS
33              
34             use autobox::Core;
35              
36             "Hello, World\n"->uc->print;
37              
38             my @list = (1, 5, 9, 2, 0, 4, 2, 1);
39             @list->sort->reverse->print;
40              
41             # works with references too!
42             my $list = [1, 5, 9, 2, 0, 4, 2, 1];
43             $list->sort->reverse->print;
44              
45             my %hash = (
46             grass => 'green',
47             apple => 'red',
48             sky => 'blue',
49             );
50              
51             [10, 20, 30, 40, 50]->pop->say;
52             [10, 20, 30, 40, 50]->shift->say;
53              
54             my $lala = "Lalalalala\n";
55             "chomp: "->concat($lala->chomp, " ", $lala)->say;
56              
57             my $hashref = { foo => 10, bar => 20, baz => 30, qux => 40 };
58              
59             print "hash keys: ", $hashref->keys->join(' '), "\n"; # or if you prefer...
60             print "hash keys: ", join ' ', $hashref->keys(), "\n"; # or
61             print "hash keys: "; $hashref->keys->say;
62              
63             =head1 DESCRIPTION
64              
65             The L module promotes Perl's primitive types (literals (strings and
66             numbers), scalars, arrays and hashes) into first-class objects. However,
67             L does not provide any methods for these new classes.
68              
69             L provides a set of methods for these new classes. It includes
70             almost everything in L, some things from L and
71             L, and some Perl 5 versions of methods taken from Perl 6.
72              
73             With F one is able to change this:
74              
75             print join(" ", reverse(split(" ", $string)));
76              
77             to this:
78              
79             use autobox::Core;
80              
81             $string->split(" ")->reverse->print;
82              
83             Likewise you can change this:
84              
85             my $array_ref = [qw(fish dog cat elephant bird)];
86              
87             push @$array_ref, qw(snake lizard giraffe mouse);
88              
89             to this:
90              
91             use autobox::Core;
92             my $array_ref = [qw(fish dog cat elephant bird)];
93              
94             $array_ref->push( qw(snake lizard giraffe mouse));
95              
96             F makes it easier to avoid parentheses pile ups and
97             messy dereferencing syntaxes.
98              
99             F is mostly glue. It presents existing functions with a new
100             interface, while adding few extra. Most of the methods read like
101             C<< sub hex { CORE::hex($_[0]) } >>. In addition to built-ins from
102             L that operate on hashes, arrays, scalars, and code references,
103             some Perl 6-ish things have been included, and some keywords like
104             C are represented too.
105              
106             =head2 What's Implemented?
107              
108             =over 4
109              
110             =item *
111              
112             Many of the functions listed in L under the headings:
113              
114             =over 4
115              
116             =item *
117              
118             "Functions for real @ARRAYs",
119              
120             =item *
121              
122             "Functions for real %HASHes",
123              
124             =item *
125              
126             "Functions for list data",
127              
128             =item *
129              
130             "Functions for SCALARs or strings"
131              
132             =back
133              
134             plus a few taken from other sections and documented below.
135              
136             =item *
137              
138             Some methods from L and L.
139              
140             =item *
141              
142             Some things expected in Perl 6, such as C (C), C, and
143             C.
144              
145             =item *
146              
147             C explicitly flattens an array.
148              
149             =back
150              
151             =head3 String Methods
152              
153             String methods are of the form C<< my $return = $string->method(@args) >>.
154             Some will act on the C<$string> and some will return a new string.
155              
156             Many string methods are simply wrappers around core functions, but
157             there are additional operations and modifications to core behavior.
158              
159             Anything which takes a regular expression, such as L and L,
160             usually take it in the form of a compiled regex (C). Any modifiers
161             can be attached to the C normally. Bare strings may be used in place
162             of regular expressions, and Perl will compile it to a regex, as usual.
163              
164             These built in functions are implemented for scalars, they work just like normal:
165             L, L,L
166             L, L, L
167             L, L, L,
168             L, L (always in scalar
169             context), L,
170             L, L, L
171             L, L, L,
172             L, L,
173             L, L, L.
174              
175             In addition, so are each of the following:
176              
177             =head4 concat
178              
179             $string1->concat($string2);
180              
181             Concatenates C<$string2> to C<$string1>. This
182             corresponds to the C<.> operator used to join two strings. Returns the
183             joined strings.
184              
185             =head4 strip
186              
187             Removes whitespace from the beginning and end of a string.
188              
189             " \t \n \t foo \t \n \t "->strip; # foo
190              
191             This is redundant and subtly different from C which allows for the
192             removal of specific characters from the beginning and end of a string.
193              
194             =head4 trim
195              
196             Removes whitespace from the beginning and end of a string. C
197             can also remove specific characters from the beginning and the end of
198             string.
199              
200             ' hello'->trim; # 'hello'
201             '*+* hello *+*'->trim("*+"); # ' hello '
202             ' *+* hello *+*'->trim("*+"); # ' *+* hello'
203              
204             =head4 ltrim
205              
206             Just like L but it only trims the left side (start) of the string.
207              
208             ' hello'->ltrim; # 'hello'
209             '*+* hello *+*'->ltrim("*+"); # ' hello *+*'
210              
211             =head4 rtrim
212              
213             Just like L but it only trims the right side (end) of the string.
214              
215             'hello '->rtrim; # 'hello'
216             '*+* hello *+*'->rtrim("*+"); # '*+* hello '
217              
218             =head4 split
219              
220             my @split_string = $string->split(qr/.../);
221             my @split_string = $string->split(' ');
222              
223             A wrapper around L. It takes the regular
224             expression as a compiled regex, or a string which Perl parses as a regex.
225              
226             print "10, 20, 30, 40"->split(qr{, ?})->elements, "\n";
227             "hi there"->split(qr/ */); # h i t h e r e
228              
229             The limit argument is not implemented.
230              
231             =head4 title_case
232              
233             C converts the first character of each word in the string to
234             upper case.
235              
236             "this is a test"->title_case; # This Is A Test
237              
238             =head4 center
239              
240             my $centered_string = $string->center($length);
241             my $centered_string = $string->center($length, $character);
242              
243             Centers $string between $character. $centered_string will be of
244             length $length, or the length of $string, whichever is greater.
245              
246             C<$character> defaults to " ".
247              
248             say "Hello"->center(10); # " Hello ";
249             say "Hello"->center(10, '-'); # "---Hello--";
250              
251             C will never truncate C<$string>. If $length is less
252             than C<< $string->length >> it will just return C<$string>.
253              
254             say "Hello"->center(4); # "Hello";
255              
256             =head4 qx
257              
258             my $output = $string->qx;
259              
260             Runs $string as a command just enclosing it backticks, as in C<`$string`>.
261              
262             =head4 nm
263              
264             if( $foo->nm(qr/bar/) ) {
265             say "$foo did not match 'bar'";
266             }
267              
268             "Negative match". Corresponds to C<< !~ >>. Otherwise works in the same
269             way as C.
270              
271             =head4 m
272              
273             if( $foo->m(qr/bar/) ) {
274             say "$foo matched 'bar'";
275             }
276              
277             my $matches = $foo->m( qr/(\d*) (\w+)/ );
278             say $matches->[0];
279             say $matches->[1];
280              
281             Works the same as C<< m// >>, but the regex must be passed in as a C.
282              
283             C returns an array reference so that list functions such as C and
284             C may be called on the result. Use C to turn this into a
285             list of values.
286              
287             my ($street_number, $street_name, $apartment_number) =
288             "1234 Robin Drive #101"->m( qr{(\d+) (.*)(?: #(\d+))?} )->elements;
289              
290             print "$street_number $street_name $apartment_number\n";
291              
292             =head4 s
293              
294             my $string = "the cat sat on the mat";
295             $string->s( qr/cat/, "dog" );
296             $string->say; # the dog sat on the mat
297              
298             String substitution. Works similarly to C<< s/// >>.
299             In boolean context, it returns true/false to indicate whether the substitution succeeded. C, C, C, and so on, all provide boolean context.
300             It either fails or succeeds, having replaced only one occurrence on success -- it doesn't replace globally.
301             In scalar context other than boolean context, it returns the modified string (incompatible change, new as of v 1.31).
302              
303             =head4 undef
304              
305             $string->undef;
306              
307             Assigns C to the C<$string>.
308              
309             =head4 defined
310              
311             my $is_defined = $string->defined;
312              
313             if( not $string->defined ) {
314             # give $string a value...
315             }
316              
317             C tests whether a value is defined (not C).
318              
319             =head4 repeat
320              
321             my $repeated_string = $string->repeat($n);
322              
323             Like the C operator, repeats a string C<$n> times.
324              
325             print 1->repeat(5); # 11111
326             print "\n"->repeat(10); # ten newlines
327              
328             =head3 I/O Methods
329              
330             These are methods having to do with input and ouptut, not filehandles.
331              
332             =head4 print
333              
334             $string->print;
335              
336             Prints a string or a list of strings. Returns true if successful.
337              
338             =head4 say
339              
340             Like L, but implicitly appends a newline to the end.
341              
342             $string->say;
343              
344             =head3 Boolean Methods
345              
346             Methods related to boolean operations.
347              
348             =head4 and
349              
350             C corresponds to C<&&>. Returns true if both operands are true.
351              
352             if( $a->and($b) ) {
353             ...
354             }
355              
356             =head4 not
357              
358             C corresponds to C. Returns true if the subject is false.
359              
360             if( $a->not ) {
361             ...
362             }
363              
364             =head4 or
365              
366             C corresponds to C<||>. Returns true if at least one of the operands
367             is true.
368              
369             if( $a->or($b) ) {
370             ...
371             }
372              
373             =head4 xor
374              
375             C corresponds to C. Returns true if only one of the operands is
376             true.
377              
378             if( $a->xor($b) ) {
379             ...
380             }
381              
382             =head3 Number Related Methods
383              
384             Methods related to numbers.
385              
386             The basic built in functions which operate as normal :
387             L, L, L,
388             L, L, L,
389             L, L, L, and
390             L.
391              
392             The following operators were also included:
393              
394             =head4 dec
395              
396             $number->dec();
397             # $number is smaller by 1.
398              
399             C corresponds to C<++>. Decrements subject, will decrement character
400             strings too: 'b' decrements to 'a'.
401              
402             =head4 inc
403              
404             C corresponds to C<++>. Increments subject, will increment character
405             strings too. 'a' increments to 'b'.
406              
407             =head4 mod
408              
409             C corresponds to C<%>.
410              
411             $number->mod(5);
412              
413             =head4 pow
414              
415             C returns $number raised to the power of the $exponent.
416              
417             my $result = $number->pow($expontent);
418             print 2->pow(8); # 256
419              
420             =head4 is_number
421              
422             $is_a_number = $thing->is_number;
423              
424             Returns true if $thing is a number as understood by Perl.
425              
426             12.34->is_number; # true
427             "12.34"->is_number; # also true
428              
429             =head4 is_positive
430              
431             $is_positive = $thing->is_positive;
432              
433             Returns true if $thing is a positive number.
434              
435             C<0> is not positive.
436              
437             =head4 is_negative
438              
439             $is_negative = $thing->is_negative;
440              
441             Returns true if $thing is a negative number.
442              
443             C<0> is not negative.
444              
445             =head4 is_integer
446              
447             $is_an_integer = $thing->is_integer;
448              
449             Returns true if $thing is an integer.
450              
451             12->is_integer; # true
452             12.34->is_integer; # false
453              
454             =head4 is_int
455              
456             A synonym for is_integer.
457              
458             =head4 is_decimal
459              
460             $is_a_decimal_number = $thing->is_decimal;
461              
462             Returns true if $thing is a decimal number.
463              
464             12->is_decimal; # false
465             12.34->is_decimal; # true
466             ".34"->is_decimal; # true
467              
468             =head3 Reference Related Methods
469              
470             The following core functions are implemented.
471              
472             L, L, L,
473             L.
474              
475             C, C, and C don't work on code references.
476              
477             =head3 Array Methods
478              
479             Array methods work on both arrays and array references:
480              
481             my $arr = [ 1 .. 10 ];
482             $arr->undef;
483              
484             Or:
485              
486             my @arr = ( 1 .. 10 );
487             @arr->undef;
488              
489             List context forces methods to return a list:
490              
491             my @arr = ( 1 .. 10 );
492             print join ' -- ', @arr->grep(sub { $_ > 3 }), "\n";
493              
494             Likewise, scalar context forces methods to return an array reference.
495              
496             As scalar context forces methods to return a reference, methods may be chained
497              
498             my @arr = ( 1 .. 10 );
499             @arr->grep(sub { $_ > 3 })->min->say; # "4\n";
500              
501             These built-in functions are defined as methods:
502              
503             L, L, L,
504             L, L,
505             L, L,
506             L, L, L,
507             L, L, L,
508             L, L, and
509             L, L.
510              
511             As well as:
512              
513             =head4 vdelete
514              
515             Deletes a specified value from the array.
516              
517             $a = 1->to(10);
518             $a->vdelete(3); # deletes 3
519             $a->vdelete(2)->say; # "1 4 5 6 7 8 9 10\n"
520              
521             =head4 uniq
522              
523             Removes all duplicate elements from an array and returns the new array
524             with no duplicates.
525              
526             my @array = qw( 1 1 2 3 3 6 6 );
527             @return = @array->uniq; # @return : 1 2 3 6
528              
529             =head4 first
530              
531             Returns the first element of an array for which a callback returns true:
532              
533             $arr->first(sub { qr/5/ });
534              
535             =head4 max
536              
537             Returns the largest numerical value in the array.
538              
539             $a = 1->to(10);
540             $a->max; # 10
541              
542             =head4 min
543              
544             Returns the smallest numerical value in the array.
545              
546             $a = 1->to(10);
547             $a->min; # 1
548              
549             =head4 mean
550              
551             Returns the mean of elements of an array.
552              
553             $a = 1->to(10);
554             $a->mean; # 55/10
555              
556             =head4 var
557              
558             Returns the variance of the elements of an array.
559              
560             $a = 1->to(10);
561             $a->var; # 33/4
562              
563             =head4 svar
564              
565             Returns the standard variance.
566              
567             $a = 1->to(10);
568             $a->svar; # 55/6
569              
570             =head4 at
571              
572             Returns the element at a specified index. This function does not modify the
573             original array.
574              
575             $a = 1->to(10);
576             $a->at(2); # 3
577              
578             =head4 size, elems, length
579              
580             C, C and C all return the number of elements in an array.
581              
582             my @array = qw(foo bar baz);
583             @array->size; # 3
584              
585             =head4 elements, flatten
586              
587             my @copy_of_array = $array->flatten;
588              
589             Returns the elements of an array ref as an array.
590             This is the same as C<< @{$array} >>.
591              
592             Arrays can be iterated on using C and C. Both take a code
593             reference as the body of the for statement.
594              
595             =head4 foreach
596              
597             @array->foreach(\&code);
598              
599             Calls C<&code> on each element of the @array in order. &code gets the
600             element as its argument.
601              
602             @array->foreach(sub { print $_[0] }); # print each element of the array
603              
604              
605             =head4 for
606              
607             @array->for(\&code);
608              
609             Like L, but C<&code> is called with the index, the value and
610             the array itself.
611              
612             my $arr = [ 1 .. 10 ];
613             $arr->for(sub {
614             my($idx, $value) = @_;
615             print "Value #$idx is $value\n";
616             });
617              
618              
619             =head4 sum
620              
621             my $sum = @array->sum;
622              
623             Adds together all the elements of the array.
624              
625             =head4 count
626              
627             Returns the number of elements in array that are C to a specified value:
628              
629             my @array = qw/one two two three three three/;
630             my $num = @array->count('three'); # returns 3
631              
632             =head4 to, upto, downto
633              
634             C, C, and C create array references:
635              
636             1->to(5); # creates [1, 2, 3, 4, 5]
637             1->upto(5); # creates [1, 2, 3, 4, 5]
638             5->downto(5); # creates [5, 4, 3, 2, 1]
639              
640             Those wrap the C<..> operator.
641              
642             B while working with negative numbers you need to use () so as
643             to avoid the wrong evaluation.
644              
645             my $range = 10->to(1); # this works
646             my $range = -10->to(10); # wrong, interpreted as -( 10->to(10) )
647             my $range = (-10)->to(10); # this works
648              
649             =head4 head
650              
651             Returns the first element from C<@list>. This differs from
652             L in that it does not change the array.
653              
654             my $first = @list->head;
655              
656             =head4 tail
657              
658             Returns all but the first element from C<@list>.
659              
660             my @list = qw(foo bar baz quux);
661             my @rest = @list->tail; # [ 'bar', 'baz', 'quux' ]
662              
663             Optionally, you can pass a number as argument to ask for the last C<$n>
664             elements:
665              
666             @rest = @list->tail(2); # [ 'baz', 'quux' ]
667              
668             =head4 slice
669              
670             Returns a list containing the elements from C<@list> at the indices
671             C<@indices>. In scalar context, returns an array reference.
672              
673             # Return $list[1], $list[2], $list[4] and $list[8].
674             my @sublist = @list->slice(1,2,4,8);
675              
676             =head4 range
677              
678             C returns a list containing the elements from C<@list> with indices
679             ranging from C<$lower_idx> to C<$upper_idx>. It returns an array reference
680             in scalar context.
681              
682             my @sublist = @list->range( $lower_idx, $upper_idx );
683              
684             =head4 last_index
685              
686             my $index = @array->last_index(qr/.../);
687              
688             Returns the highest index whose element matches the given regular expression.
689              
690             my $index = @array->last_index(\&filter);
691              
692             Returns the highest index for an element on which the filter returns true.
693             The &filter is passed in each value of the @array.
694              
695             my @things = qw(pear poll potato tomato);
696             my $last_p = @things->last_index(qr/^p/); # 2
697              
698             Called with no arguments, it corresponds to C<$#array> giving the
699             highest index of the array.
700              
701             my $index = @array->last_index;
702              
703             =head4 first_index
704              
705             Works just like L but it will return the index of the I
706             matching element.
707              
708             my $first_index = @array->first_index; # 0
709              
710             my @things = qw(pear poll potato tomato);
711             my $last_p = @things->first_index(qr/^t/); # 3
712              
713             =head4 at
714              
715             my $value = $array->at($index);
716              
717             Equivalent to C<< $array->[$index] >>.
718              
719             =head3 Hash Methods
720              
721             Hash methods work on both hashes and hash references.
722              
723             The built in functions work as normal:
724              
725             L, L, L,
726             L, L, L,
727             L, L, L,
728              
729             =head4 at, get
730              
731             my @values = %hash->get(@keys);
732              
733             Returns the @values of @keys.
734              
735             =head4 put
736              
737             %hash->put(%other_hash);
738              
739             Overlays %other_hash on top of %hash.
740              
741             my $h = {a => 1, b => 2};
742             $h->put(b => 99, c => 3); # (a => 1, b => 99, c => 3)
743              
744             =head4 set
745              
746             Synonym for L.
747              
748             =head4 each
749              
750             Like C but for hash references. For each key in the hash, the
751             code reference is invoked with the key and the corresponding value as
752             arguments:
753              
754             my $hashref = { foo => 10, bar => 20, baz => 30, quux => 40 };
755             $hashref->each(sub { print $_[0], ' is ', $_[1], "\n" });
756              
757             Or:
758              
759             my %hash = ( foo => 10, bar => 20, baz => 30, quux => 40 );
760             %hash->each(sub { print $_[0], ' is ', $_[1], "\n" });
761              
762             Unlike regular C, this each will always iterate through the entire hash.
763              
764             Hash keys appear in random order that varies from run to run (this is
765             intentional, to avoid calculated attacks designed to trigger
766             algorithmic worst case scenario in C's hash tables).
767              
768             You can get a sorted C by combining C, C, and C:
769              
770             %hash->keys->sort->foreach(sub {
771             print $_[0], ' is ', $hash{$_[0]}, "\n";
772             });
773              
774             =head4 lock_keys
775              
776             %hash->lock_keys;
777              
778             Works as L. No more keys may be added to the hash.
779              
780             =head4 slice
781              
782             Takes a list of hash keys and returns the corresponding values e.g.
783              
784             my %hash = (
785             one => 'two',
786             three => 'four',
787             five => 'six'
788             );
789              
790             print %hash->slice(qw(one five))->join(' and '); # prints "two and six"
791              
792             =head4 flip
793              
794             Exchanges values for keys in a hash:
795              
796             my %things = ( foo => 1, bar => 2, baz => 5 );
797             my %flipped = %things->flip; # { 1 => foo, 2 => bar, 5 => baz }
798              
799             If there is more than one occurrence of a certain value, any one of the
800             keys may end up as the value. This is because of the random ordering
801             of hash keys.
802              
803             # Could be { 1 => foo }, { 1 => bar }, or { 1 => baz }
804             { foo => 1, bar => 1, baz => 1 }->flip;
805              
806             Because references cannot usefully be keys, it will not work where the
807             values are references.
808              
809             { foo => [ 'bar', 'baz' ] }->flip; # dies
810              
811             =head4 flatten
812              
813             my %hash = $hash_ref->flatten;
814              
815             Dereferences a hash reference.
816              
817             =head3 Code Methods
818              
819             Methods which work on code references.
820              
821             These are simple wrappers around the Perl core functions.
822             L, L,
823              
824             Due to Perl's precedence rules, some autoboxed literals may need to be
825             parenthesized. For instance, this works:
826              
827             my $curried = sub { ... }->curry();
828              
829             This does not:
830              
831             my $curried = \&foo->curry();
832              
833             The solution is to wrap the reference in parentheses:
834              
835             my $curried = (\&foo)->curry();
836              
837              
838             =head4 curry
839              
840             my $curried_code = $code->curry(5);
841              
842             Currying takes a code reference and provides the same code, but with
843             the first argument filled in.
844              
845             my $greet_world = sub {
846             my($greeting, $place) = @_;
847             return "$greeting, $place!";
848             };
849             print $greet_world->("Hello", "world"); # "Hello, world!"
850              
851             my $howdy_world = $greet_world->curry("Howdy");
852             print $howdy_world->("Texas"); # "Howdy, Texas!"
853              
854              
855             =head2 What's Missing?
856              
857             =over 4
858              
859             =item *
860              
861             File and socket operations are already implemented in an object-oriented
862             fashion care of L, L, and L.
863              
864             =item *
865              
866             Functions listed in the L headings
867              
868             =over 4
869              
870             =item *
871              
872             "System V interprocess communication functions",
873              
874             =item *
875              
876             "Fetching user and group info",
877              
878             =item *
879              
880             "Fetching network info",
881              
882             =item *
883              
884             "Keywords related to perl modules",
885              
886             =item *
887              
888             "Functions for processes and process groups",
889              
890             =item *
891              
892             "Keywords related to scoping",
893              
894             =item *
895              
896             "Time-related functions",
897              
898             =item *
899              
900             "Keywords related to the control flow of your perl program",
901              
902             =item *
903              
904             "Functions for filehandles, files, or directories",
905              
906             =item *
907              
908             "Input and output functions".
909              
910             =back
911              
912             =item *
913              
914             (Most) binary operators
915              
916             =back
917              
918             These things are likely implemented in an object oriented fashion by other
919             CPAN modules, are keywords and not functions, take no arguments, or don't
920             make sense as part of the string, number, array, hash, or code API.
921              
922             =head2 Autoboxing
923              
924             I
925             Core Ideas Illustrated with Perl 5 by Scott Walters. The text appears in
926             the book starting at page 248. This copy lacks the benefit of copyedit -
927             the finished product is of higher quality.>
928              
929             A I is an object that contains a primitive variable. Boxes are used
930             to endow primitive types with the capabilities of objects which
931             essential in strongly typed languages but never strictly required in Perl.
932             Programmers might write something like C<< my $number = Int->new(5) >>.
933             This is manual boxing. To I is to convert a simple type into an
934             object type automatically, or only conceptually. This is done by the language.
935              
936             Iing makes a language look to programmers as if everything is an
937             object while the interpreter is free to implement data storage however it
938             pleases. Autoboxing is really making simple types such as numbers,
939             strings, and arrays appear to be objects.
940              
941             C, C, C, C, and other types with lower case names, are
942             primitives. They're fast to operate on, and require no more memory to
943             store than the data held strictly requires. C, C, C,
944             C, and other types with an initial capital letter, are objects. These
945             may be subclassed (inherited from) and accept traits, among other things.
946             These objects are provided by the system for the sole purpose of
947             representing primitive types as objects, though this has many ancillary
948             benefits such as making C and C work. Perl provides C to
949             encapsulate an C, C to encapsulate a C, C to
950             encapsulate a C, and so on. As Perl's implementations of hashes and
951             dynamically expandable arrays store any type, not just objects, Perl
952             programmers almost never are required to box primitive types in objects.
953             Perl's power makes this feature less essential than it is in other
954             languages.
955              
956             Iing makes primitive objects and they're boxed versions
957             equivalent. An C may be used as an C with no constructor call,
958             no passing, nothing. This applies to constants too, not just variables.
959             This is a more Perl 6 way of doing things.
960              
961             # Perl 6 - autoboxing associates classes with primitives types:
962              
963             print 4.sqrt, "\n";
964              
965             print [ 1 .. 20 ].elems, "\n";
966              
967             The language is free to implement data storage however it wishes but the
968             programmer sees the variables as objects.
969              
970             Expressions using autoboxing read somewhat like Latin suffixes. In the
971             autoboxing mind-set, you might not say that something is "made more
972             mnemonic", but has been "mnemonicified".
973              
974             Autoboxing may be mixed with normal function calls.
975             In the case where the methods are available as functions and the functions are
976             available as methods, it is only a matter of personal taste how the expression should be written:
977              
978             # Calling methods on numbers and strings, these three lines are equivalent
979             # Perl 6
980              
981             print sqrt 4;
982             print 4.sqrt;
983             4.sqrt.print;
984              
985             The first of these three equivalents assumes that a global C
986             function exists. This first example would fail to operate if this global
987             function were removed and only a method in the C package was left.
988              
989             Perl 5 had the beginnings of autoboxing with filehandles:
990              
991             use IO::Handle;
992             open my $file, '<', 'file.txt' or die $!;
993             $file->read(my $data, -s $file);
994              
995             Here, C is a method on a filehandle we opened but I.
996             This lets us say things like C<< $file->print(...) >> rather than the often
997             ambagious C<< print $file ... >>.
998              
999             To many people, much of the time, it makes more conceptual sense as well.
1000              
1001             =head3 Reasons to Box Primitive Types
1002              
1003             What good is all of this?
1004              
1005             =over 4
1006              
1007             =item *
1008              
1009             Makes conceptual sense to programmers used to object interfaces as I way
1010             to perform options.
1011              
1012             =item *
1013              
1014             Alternative idiom. Doesn't require the programmer to write or read
1015             expressions with complex precedence rules or strange operators.
1016              
1017             =item *
1018              
1019             Many times that parenthesis would otherwise have to span a large
1020             expression, the expression may be rewritten such that the parenthesis span
1021             only a few primitive types.
1022              
1023             =item *
1024              
1025             Code may often be written with fewer temporary variables.
1026              
1027             =item *
1028              
1029             Autoboxing provides the benefits of boxed types without the memory bloat of
1030             actually using objects to represent primitives. Autoboxing "fakes it".
1031              
1032             =item *
1033              
1034             Strings, numbers, arrays, hashes, and so on, each have their own API.
1035             Documentation for an C method for arrays doesn't have to explain
1036             how hashes are handled and vice versa.
1037              
1038             =item *
1039              
1040             Perl tries to accommodate the notion that the "subject" of a statement
1041             should be the first thing on the line, and autoboxing furthers this agenda.
1042              
1043             =back
1044              
1045             Perl is an idiomatic language and this is an important idiom.
1046              
1047             =head3 Subject First: An Aside
1048              
1049             Perl's design philosophy promotes the idea that the language should be
1050             flexible enough to allow programmers to place the subject of a statement
1051             first. For example, C<< die $! unless read $file, 60 >> looks like the
1052             primary purpose of the statement is to C.
1053              
1054             While that might be the programmers primary goal, when it isn't, the
1055             programmer can communicate his real primary intention to programmers by
1056             reversing the order of clauses while keeping the exact same logic: C<< read
1057             $file, 60 or die $! >>.
1058              
1059             Autoboxing is another way of putting the subject first.
1060              
1061             Nouns make good subjects, and in programming, variables, constants, and
1062             object names are the nouns. Function and method names are verbs. C<<
1063             $noun->verb() >> focuses the readers attention on the thing being acted on
1064             rather than the action being performed. Compare to C<< $verb($noun) >>.
1065              
1066             =head3 Autoboxing and Method Results
1067              
1068             Let's look at some examples of ways an expression could be
1069             written.
1070              
1071             # Various ways to do the same thing:
1072              
1073             print(reverse(sort(keys(%hash)))); # Perl 5 - pathological parenthetic
1074             print reverse sort keys %hash; # Perl 5 - no unneeded parenthesis
1075              
1076             print(reverse(sort(%hash,keys)))); # Perl 6 - pathological
1077             print reverse sort %hash.keys; # Perl 6 - no unneeded parenthesis
1078              
1079             %hash.keys ==> sort ==> reverse ==> print; # Perl 6 - pipeline operator
1080              
1081             %hash.keys.sort.reverse.print; # Perl 6 - autobox
1082              
1083             %hash->keys->sort->reverse->print; # Perl 5 - autobox
1084              
1085             This section deals with the last two of these equivalents.
1086             These are method calls
1087              
1088             use autobox::Core;
1089             use Perl6::Contexts;
1090              
1091             my %hash = (foo => 'bar', baz => 'quux');
1092              
1093             %hash->keys->sort->reverse->print; # Perl 5 - autobox
1094              
1095             # prints "foo baz"
1096              
1097             Each method call returns an array reference, in this example. Another
1098             method call is immediately performed on this value. This feeding of the
1099             next method call with the result of the previous call is the common mode of
1100             use of autoboxing. Providing no other arguments to the method calls,
1101             however, is not common.
1102              
1103             C recognizes object context as provided by C<< -> >> and
1104             coerces C<%hash> and C<@array> into references, suitable for use with
1105             C. (Note that C also does this automatically as of
1106             version 2.40.)
1107              
1108             C associates primitive types, such as references of various sorts,
1109             with classes. C throws into those classes methods wrapping
1110             Perl's built-in functions. In the interest of full disclosure,
1111             C and C are my creations.
1112              
1113             =head3 Autobox to Simplify Expressions
1114              
1115             One of my pet peeves in programming is parenthesis that span large
1116             expression. It seems like about the time I'm getting ready to close the
1117             parenthesis I opened on the other side of the line, I realize that I've
1118             forgotten something, and I have to arrow back over or grab the mouse.
1119              
1120             When the expression is too long to fit on a single line, it gets broken up,
1121             then I must decide how to indent it if it grows to 3 or more lines.
1122              
1123             # Perl 5 - a somewhat complex expression
1124              
1125             print join("\n", map { CGI::param($_) } @cgi_vars), "\n";
1126             # Perl 5 - again, using autobox:
1127              
1128             @cgi_vars->map(sub { CGI::param($_[0]) })->join("\n")->concat("\n")->print;
1129              
1130             The autoboxed version isn't shorter, but it reads from left to right, and
1131             the parenthesis from the C don't span nearly as many characters.
1132             The complex expression serving as the value being Ced in the
1133             non-autoboxed version becomes, in the autoboxed version, a value to call
1134             the C method on.
1135              
1136             This C statement takes a list of CGI parameter names, reads the
1137             values for each parameter, joins them together with newlines, and prints
1138             them with a newline after the last one.
1139              
1140             Pretending that this expression were much larger and it had to be broken to span
1141             several lines, or pretending that comments are to be placed after each part of
1142             the expression, you might reformat it as such:
1143              
1144             @cgi_vars->map(sub { CGI::param($_[0]) }) # turn CGI arg names into values
1145             ->join("\n") # join with newlines
1146             ->concat("\n") # give it a trailing newline
1147             ->print; # print them all out
1148              
1149             I
1150              
1151              
1152             =head1 BUGS
1153              
1154             Yes. Report them to the author, scott@slowass.net, or post them to
1155             GitHub's bug tracker at L.
1156              
1157             The API is not yet stable -- Perl 6-ish things and local extensions are
1158             still being renamed.
1159              
1160             =head1 HISTORY
1161              
1162             See the Changes file.
1163              
1164             =head1 COPYRIGHT AND LICENSE
1165              
1166             Copyright (C) 2009, 2010, 2011 by Scott Walters and various contributors listed (and unlisted) below.
1167              
1168             This library is free software; you can redistribute it and/or modify
1169             it under the same terms as Perl itself, either Perl version 5.8.9 or,
1170             at your option, any later version of Perl 5 you may have available.
1171              
1172             This library is distributed in the hope that it will be useful, but without
1173             any warranty; without even the implied warranty of merchantability or fitness
1174             for a particular purpose.
1175              
1176              
1177             =head1 SEE ALSO
1178              
1179             =over 1
1180              
1181             =item L
1182              
1183             =item L
1184              
1185             =item L
1186              
1187             =item L
1188              
1189             =item L
1190              
1191             =item Perl 6: L<< http://dev.perl.org/perl6/apocalypse/ >>.
1192              
1193             =back
1194              
1195              
1196             =head1 AUTHORS
1197              
1198             Scott Walters, scott@slowass.net.
1199              
1200             Tomasz Konojacki has been assisting with maint.
1201              
1202             Jacinta Richardson improved documentation and tidied up the interface.
1203              
1204             Michael Schwern and the L contributors for tests, code, and feedback.
1205              
1206             JJ contributed a C method for scalars - thanks JJ!
1207              
1208             Ricardo SIGNES contributed patches.
1209              
1210             Thanks to Matt Spear, who contributed tests and definitions for numeric operations.
1211              
1212             Mitchell N Charity reported a bug and sent a fix.
1213              
1214             Thanks to chocolateboy for L and for the encouragement.
1215              
1216             Thanks to Bruno Vecchi for bug fixes and many, many new tests going into version 0.8.
1217              
1218             Thanks to L daxim/Lars DIECKOW pushing in fixes and patches from the RT queue
1219             along with fixes to build and additional doc examples.
1220              
1221             Thanks to Johan Lindstrom for bug reports.
1222              
1223             Thanks to everyone else who sent fixes or suggestions -- apologies if I failed to include you here!
1224              
1225             =cut
1226              
1227             #
1228             # SCALAR
1229             #
1230              
1231             package autobox::Core::SCALAR;
1232              
1233             # Functions for SCALARs or strings
1234             # "chomp", "chop", "chr", "crypt", "hex", "index", "lc",
1235             # "lcfirst", "length", "oct", "ord", "pack",
1236             # "q/STRING/", "qq/STRING/", "reverse", "rindex",
1237             # "sprintf", "substr", "tr///", "uc", "ucfirst", "y///"
1238              
1239             # current doesn't handle scalar references - get can't call method chomp on unblessed reference etc when i try to support it
1240              
1241 2     2   15 sub chomp { CORE::chomp($_[0]); }
1242 1     1   13 sub chop { CORE::chop($_[0]); }
1243 1     1   19 sub chr { CORE::chr($_[0]); }
1244 1     1   470 sub crypt { CORE::crypt($_[0], $_[1]); }
1245 2 100   2   30 sub index { $_[2] ? CORE::index($_[0], $_[1], $_[2]) : CORE::index($_[0], $_[1]); }
1246 3     3   25 sub lc { CORE::lc($_[0]); }
1247 1     1   22 sub lcfirst { CORE::lcfirst($_[0]); }
1248 18     18   68 sub length { CORE::length($_[0]); }
1249 1     1   22 sub ord { CORE::ord($_[0]); }
1250 2     2   26 sub pack { CORE::pack(shift, @_); }
1251             sub reverse {
1252             # Always reverse scalars as strings, never as a single element list.
1253 4     4   835 return scalar CORE::reverse($_[0]);
1254             }
1255              
1256             sub rindex {
1257 2 100   2   26 return CORE::rindex($_[0], $_[1]) if @_ == 2;
1258 1         7 return CORE::rindex($_[0], $_[1], @_[2.. $#_]);
1259             }
1260              
1261 1     1   21 sub sprintf { CORE::sprintf($_[0], $_[1], @_[2.. $#_]); }
1262              
1263             sub substr {
1264 5 100   5   1433 return CORE::substr($_[0], $_[1]) if @_ == 2;
1265 3         13 return CORE::substr($_[0], $_[1], @_[2 .. $#_]);
1266             }
1267              
1268 2     2   34 sub uc { CORE::uc($_[0]); }
1269 1     1   10 sub ucfirst { CORE::ucfirst($_[0]); }
1270 1     1   23 sub unpack { CORE::unpack($_[0], @_[1..$#_]); }
1271 1     1   16 sub quotemeta { CORE::quotemeta($_[0]); }
1272 3     3   20 sub vec { CORE::vec($_[0], $_[1], $_[2]); }
1273 1     1   12 sub undef { $_[0] = undef }
1274 0     0   0 sub defined { CORE::defined($_[0]) }
1275 2 100   2   26 sub m { my @ms = $_[0] =~ m{$_[1]} ; return @ms ? \@ms : undef }
  2         11  
1276 2 100   2   27 sub nm { my @ms = $_[0] =~ m{$_[1]} ; return @ms ? undef : \@ms }
  2         12  
1277 2 100   2   42 sub split { wantarray ? split $_[1], $_[0] : [ split $_[1], $_[0] ] }
1278             sub s {
1279 4 100   4   879 my $success = ( $_[0] =~ s{$_[1]}{$_[2]} ) ? 1 : 0;
1280 4 50       11 if (Want::want('LIST')) {
    100          
    100          
1281 0         0 Want::rreturn ($_[0]);
1282             } elsif (Want::want('BOOL')) { # this needs to happen before the SCALAR context test
1283 2         121 Want::rreturn $success;
1284             } elsif (Want::want(qw'SCALAR')) {
1285 1         90 Want::rreturn $_[0];
1286             }
1287 1         139 return; # "You have to put this at the end to keep the compiler happy" from Want docs
1288             }
1289              
1290 1     1   54 sub eval { CORE::eval "$_[0]"; }
1291 1     1   2672 sub system { CORE::system @_; }
1292 1     1   2002 sub backtick { `$_[0]`; }
1293 1     1   1390 sub qx { `$_[0]`; } # per #16, "backtick should probably be called qx"
1294              
1295             # Numeric functions
1296              
1297 1     1   17 sub abs { CORE::abs($_[0]) }
1298 1     1   19 sub atan2 { CORE::atan2($_[0], $_[1]) }
1299 1     1   21 sub cos { CORE::cos($_[0]) }
1300 1     1   10 sub exp { CORE::exp($_[0]) }
1301 2     2   18 sub int { CORE::int($_[0]) }
1302 1     1   6 sub log { CORE::log($_[0]) }
1303 1     1   13 sub oct { CORE::oct($_[0]) }
1304 2     2   9 sub hex { CORE::hex($_[0]); }
1305 1     1   6 sub sin { CORE::sin($_[0]) }
1306 1     1   5 sub sqrt { CORE::sqrt($_[0]) }
1307              
1308             # functions for array creation
1309             sub to {
1310 5 100   5   353 my $res = $_[0] < $_[1] ? [$_[0]..$_[1]] : [CORE::reverse $_[1]..$_[0]];
1311 5 100       18 return wantarray ? @$res : $res
1312             }
1313             sub upto {
1314 2 100   2   578 return wantarray ? ($_[0]..$_[1]) : [ $_[0]..$_[1] ]
1315             }
1316             sub downto {
1317 2     2   538 my $res = [ CORE::reverse $_[1]..$_[0] ];
1318 2 100       13 return wantarray ? @$res : $res
1319             }
1320              
1321             # Lars D didn't explain the intention of this code either in a comment or in docs and I don't see the point
1322             #sub times {
1323             # if ($_[1]) {
1324             # for (0..$_[0]-1) { $_[1]->($_); }; $_[0];
1325             # } else {
1326             # 0..$_[0]-1
1327             # }
1328             #}
1329              
1330             # doesn't minipulate scalars but works on scalars
1331              
1332 0     0   0 sub print { CORE::print @_; }
1333 0     0   0 sub say { CORE::print @_, "\n"}
1334              
1335             # operators that work on scalars:
1336              
1337 2     2   34 sub concat { CORE::join '', @_; }
1338             sub strip {
1339 1     1   12 my $s = CORE::shift;
1340 1         5 $s =~ s/^\s+//; $s =~ s/\s+$//;
  1         4  
1341 1         6 return $s;
1342             }
1343              
1344             # operator schizzle
1345 2 50   2   342 sub and { $_[0] && $_[1]; }
1346 3     3   4 sub dec { my $t = CORE::shift @_; --$t; }
  3         10  
1347 1     1   1 sub inc { my $t = CORE::shift @_; ++$t; }
  1         4  
1348 1     1   3 sub mod { $_[0] % $_[1]; }
1349 1     1   3 sub neg { -$_[0]; }
1350 1     1   4 sub not { !$_[0]; }
1351 1 50   1   4 sub or { $_[0] || $_[1]; }
1352 1     1   4 sub pow { $_[0] ** $_[1]; }
1353 1   25 1   7 sub xor { $_[0] xor $_[1]; }
1354              
1355             # rpt should go
1356 0     0   0 sub repeat { $_[0] x $_[1]; }
1357 1     1   5 sub rpt { $_[0] x $_[1]; }
1358              
1359             # sub bless (\%$) { CORE::bless $_[0], $_[1] } # HASH, ARRAY, CODE already have a bless() and blessing a non-reference works (autobox finds the reference in the pad or stash!). "can't bless a non-referenc value" for non-reference lexical and package scalars. this would work for (\$foo)->bless but then, unlike arrays, we couldn't find the reference to the variable again later so there's not much point I can see.
1360              
1361             # from perl5i:
1362              
1363              
1364             sub title_case {
1365 4     4   17 my ($string) = @_;
1366 4         31 $string =~ s/\b(\w)/\U$1/g;
1367 4         15 return $string;
1368             }
1369              
1370              
1371             sub center {
1372 25     25   5062 my ($string, $size, $char) = @_;
1373 25 50       50 Carp::carp("Use of uninitialized value for size in center()") if !defined $size;
1374 25 50       34 $size = defined($size) ? $size : 0;
1375 25 100       31 $char = defined($char) ? $char : ' ';
1376              
1377 25 50       34 if (CORE::length $char > 1) {
1378 0         0 my $bad = $char;
1379 0         0 $char = CORE::substr $char, 0, 1;
1380 0         0 Carp::carp("'$bad' is longer than one character, using '$char' instead");
1381             }
1382              
1383 25         20 my $len = CORE::length $string;
1384              
1385 25 100       46 return $string if $size <= $len;
1386              
1387 20         16 my $padlen = $size - $len;
1388              
1389             # pad right with half the remaining characters
1390 20         29 my $rpad = CORE::int( $padlen / 2 );
1391              
1392             # bias the left padding to one more space, if $size - $len is odd
1393 20         15 my $lpad = $padlen - $rpad;
1394              
1395 20         65 return $char x $lpad . $string . $char x $rpad;
1396             }
1397              
1398             sub ltrim {
1399 9     9   13 my ($string,$trim_charset) = @_;
1400 9 100       19 $trim_charset = '\s' unless defined $trim_charset;
1401 9         55 my $re = qr/^[$trim_charset]*/;
1402 9         33 $string =~ s/$re//;
1403 9         29 return $string;
1404             }
1405              
1406              
1407             sub rtrim {
1408 9     9   10 my ($string,$trim_charset) = @_;
1409 9 100       15 $trim_charset = '\s' unless defined $trim_charset;
1410 9         43 my $re = qr/[$trim_charset]*$/;
1411 9         40 $string =~ s/$re//;
1412 9         32 return $string;
1413             }
1414              
1415              
1416             sub trim {
1417 5     5   8 my $charset = $_[1];
1418              
1419 5         7 return rtrim(ltrim($_[0], $charset), $charset);
1420             }
1421              
1422             # POSIX is huge
1423             #require POSIX;
1424             #*ceil = \&POSIX::ceil;
1425             #*floor = \&POSIX::floor;
1426             #*round_up = \&ceil;
1427             #*round_down = \&floor;
1428             #sub round {
1429             # abs($_[0] - int($_[0])) < 0.5 ? round_down($_[0])
1430             # : round_up($_[0])
1431             #}
1432              
1433             require Scalar::Util;
1434             *is_number = \&Scalar::Util::looks_like_number;
1435 6 100   6   38 sub is_positive { Scalar::Util::looks_like_number($_[0]) && $_[0] > 0 }
1436 6 100   6   35 sub is_negative { Scalar::Util::looks_like_number($_[0]) && $_[0] < 0 }
1437 6 50   6   48 sub is_integer { Scalar::Util::looks_like_number($_[0]) && ((CORE::int($_[0]) - $_[0]) == 0) }
1438             *is_int = \&is_integer;
1439 4 100   4   32 sub is_decimal { Scalar::Util::looks_like_number($_[0]) && ((CORE::int($_[0]) - $_[0]) != 0) }
1440              
1441              
1442             ##########################################################
1443              
1444             #
1445             # HASH
1446             #
1447              
1448             package autobox::Core::HASH;
1449              
1450 63     63   335 use Carp 'croak';
  63         70  
  63         26697  
1451              
1452             # Functions for real %HASHes
1453              
1454             sub delete {
1455 0     0   0 my $hash = CORE::shift;
1456              
1457 0         0 my @res = ();
1458 0         0 foreach(@_) {
1459 0         0 push @res, CORE::delete $hash->{$_};
1460             }
1461              
1462 0 0       0 return wantarray ? @res : \@res
1463             }
1464              
1465             sub exists {
1466 0     0   0 my $hash = CORE::shift;
1467 0         0 return CORE::exists $hash->{$_[0]};
1468             }
1469              
1470             sub keys {
1471 3 100   3   27 return wantarray ? CORE::keys %{$_[0]} : [ CORE::keys %{$_[0]} ];
  1         12  
  2         12  
1472             }
1473              
1474             sub values {
1475 2 100   2   13 return wantarray ? CORE::values %{$_[0]} : [ CORE::values %{$_[0]} ]
  1         8  
  1         3  
1476             }
1477              
1478             # local extensions
1479              
1480 7     7   362 sub get { @{$_[0]}{@_[1..$#_]}; }
  7         57  
1481             *at = *get;
1482              
1483             sub put {
1484 2     2   3 my $h = CORE::shift @_;
1485 2         10 my %h = @_;
1486              
1487 2         9 while(my ($k, $v) = CORE::each %h) {
1488 4         9 $h->{$k} = $v;
1489             };
1490              
1491 2         3 return $h;
1492             }
1493              
1494             sub set {
1495 2     2   4 my $h = CORE::shift @_;
1496 2         5 my %h = @_;
1497 2         9 while(my ($k, $v) = CORE::each %h) {
1498 2         6 $h->{$k} = $v;
1499             };
1500              
1501 2         4 return $h;
1502             }
1503              
1504 1     1   2 sub flatten { %{$_[0]} }
  1         20  
1505              
1506             sub each {
1507 2     2   448 my $hash = CORE::shift;
1508 2         2 my $cb = CORE::shift;
1509              
1510             # Reset the each iterator. (This is efficient in void context)
1511 2         2 CORE::keys %$hash;
1512              
1513 2         6 while((my $k, my $v) = CORE::each(%$hash)) {
1514             # local $_ = $v; # XXX may I break stuff?
1515 7         20 $cb->($k, $v);
1516             }
1517              
1518 2         7 return;
1519             }
1520              
1521             # Keywords related to classes and object-orientedness
1522              
1523 1     1   375 sub bless { CORE::bless $_[0], $_[1] }
1524 0     0   0 sub tie { CORE::tie $_[0], @_[1 .. $#_] }
1525 0     0   0 sub tied { CORE::tied $_[0] }
1526 1     1   19 sub ref { CORE::ref $_[0] }
1527              
1528 1     1   4 sub undef { $_[0] = {} }
1529              
1530             sub slice {
1531 4     4   1730 my ($h, @keys) = @_;
1532 4 100       10 wantarray ? @{$h}{@keys} : [ @{$h}{@keys} ];
  2         5  
  2         7  
1533             }
1534              
1535             # okey, ::Util stuff should be core
1536              
1537 63     63   28925 use Hash::Util;
  63         120716  
  63         273  
1538              
1539 0     0   0 sub lock_keys { Hash::Util::lock_keys(%{$_[0]}); $_[0]; }
  0         0  
  0         0  
1540              
1541             # from perl5i
1542              
1543             sub flip {
1544             croak "Can't flip hash with references as values"
1545 2 50   2   21 if grep { CORE::ref } CORE::values %{$_[0]};
  4         13  
  2         8  
1546              
1547 2 100       7 return wantarray ? reverse %{$_[0]} : { reverse %{$_[0]} };
  1         4  
  1         13  
1548             }
1549              
1550             #
1551             # ARRAY
1552             #
1553             ##############################################################################################
1554             package autobox::Core::ARRAY;
1555              
1556 63     63   8142 use Carp 'croak';
  63         93  
  63         89893  
1557              
1558             # Functions for list data
1559              
1560             # at one moment, perl5i had this in it:
1561              
1562             #sub grep {
1563             # my ( $array, $filter ) = @_;
1564             # my @result = CORE::grep { $_ ~~ $filter } @$array;
1565             # return wantarray ? @result : \@result;
1566             #}
1567              
1568             sub grep {
1569 9     9   763 my $arr = CORE::shift;
1570 9         6 my $filter = CORE::shift;
1571 9         6 my @result;
1572              
1573 9 100       21 if( CORE::ref $filter eq 'Regexp' ) {
    100          
1574 3         5 @result = CORE::grep { m/$filter/ } @$arr;
  9         25  
1575             } elsif( ! CORE::ref $filter ) {
1576 2         4 @result = CORE::grep { $filter eq $_ } @$arr; # find all of the exact matches
  6         8  
1577             } else {
1578 4         4 @result = CORE::grep { $filter->($_) } @$arr;
  12         28  
1579             }
1580              
1581 9 100       37 return wantarray ? @result : \@result;
1582             }
1583              
1584             # last version: sub map (\@&) { my $arr = CORE::shift; my $sub = shift; [ CORE::map { $sub->($_) } @$arr ]; }
1585              
1586             sub map {
1587 3     3   540 my( $array, $code ) = @_;
1588 3         7 my @result = CORE::map { $code->($_) } @$array;
  16         33  
1589 3 100       18 return wantarray ? @result : \@result;
1590             }
1591              
1592 3     3   26 sub join { my $arr = CORE::shift; my $sep = CORE::shift; CORE::join $sep, @$arr; }
  3         4  
  3         20  
1593              
1594 4 100   4   4 sub reverse { my @res = CORE::reverse @{$_[0]}; wantarray ? @res : \@res; }
  4         11  
  4         25  
1595              
1596             sub sort {
1597 6     6   840 my $arr = CORE::shift;
1598 6   100 43   32 my $sub = CORE::shift() || sub { $a cmp $b };
  43         50  
1599 6         16 my @res = CORE::sort { $sub->($a, $b) } @$arr;
  46         34  
1600 6 100       31 return wantarray ? @res : \@res;
1601             }
1602              
1603             # functionalish stuff
1604              
1605 2     2   14 sub sum { my $arr = CORE::shift; my $res = 0; $res += $_ foreach(@$arr); $res; }
  2         3  
  2         7  
  2         10  
1606              
1607 1     1   3 sub mean { my $arr = CORE::shift; my $res = 0; $res += $_ foreach(@$arr); $res/@$arr; }
  1         1  
  1         3  
  1         6  
1608              
1609             sub var {
1610 1     1   2 my $arr = CORE::shift;
1611 1         1 my $mean = 0;
1612 1         4 $mean += $_ foreach(@$arr);
1613 1         2 $mean /= @$arr;
1614 1         2 my $res = 0;
1615 1         11 $res += ($_-$mean)**2 foreach (@$arr);
1616 1         5 $res/@$arr;
1617             }
1618              
1619             sub svar {
1620 1     1   2 my $arr = CORE::shift;
1621 1         2 my $mean = 0;
1622 1         4 $mean += $_ foreach(@$arr);
1623 1         2 $mean /= @$arr;
1624 1         2 my $res = 0;
1625 1         5 $res += ($_-$mean)**2 foreach (@$arr);
1626 1         4 $res/(@$arr-1);
1627             }
1628              
1629             sub max {
1630 1     1   5 my $arr = CORE::shift;
1631 1         2 my $max = $arr->[0];
1632 1         2 foreach (@$arr) {
1633 10 100       16 $max = $_ if $_ > $max
1634             }
1635              
1636 1         2 return $max;
1637             }
1638              
1639             sub min {
1640 1     1   2 my $arr = CORE::shift;
1641 1         2 my $min = $arr->[0];
1642 1         2 foreach (@$arr) {
1643 10 50       13 $min = $_ if $_ < $min
1644             }
1645              
1646 1         4 return $min;
1647             }
1648              
1649             # Functions for real @ARRAYs
1650              
1651 2     2   16 sub pop { CORE::pop @{$_[0]}; }
  2         10  
1652              
1653             sub push {
1654 3     3   1740 my $arr = CORE::shift;
1655 3         5 CORE::push @$arr, @_;
1656 3 100       9 return wantarray ? return @$arr : $arr;
1657             }
1658              
1659             sub unshift {
1660 4     4   1135 my $a = CORE::shift;
1661 4         9 CORE::unshift(@$a, @_);
1662 4 100       10 return wantarray ? @$a : $a;
1663             }
1664              
1665             sub delete {
1666 0     0   0 my $arr = CORE::shift;
1667 0         0 CORE::delete $arr->[$_[0]];
1668 0 0       0 return wantarray ? @$arr : $arr
1669             }
1670              
1671             sub vdelete {
1672 1     1   2 my $arr = CORE::shift;
1673 1         2 @$arr = CORE::grep {$_ ne $_[0]} @$arr;
  10         12  
1674 1 50       4 return wantarray ? @$arr : $arr
1675             }
1676              
1677             sub shift {
1678 2     2   18 my $arr = CORE::shift;
1679 2         11 return CORE::shift @$arr;
1680             }
1681              
1682 1     1   5 sub undef { $_[0] = [] }
1683              
1684             # doesn't modify array
1685              
1686             sub exists {
1687 4     4   8 my $arr = CORE::shift;
1688 4         5 return CORE::scalar( CORE::grep {$_ eq $_[0]} @$arr ) > 0;
  38         42  
1689             }
1690              
1691             sub at {
1692 1     1   2 my $arr = CORE::shift;
1693 1         3 return $arr->[$_[0]];
1694             }
1695              
1696             sub count {
1697 3     3   7 my $arr = CORE::shift;
1698 3         4 return CORE::scalar(CORE::grep {$_ eq $_[0]} @$arr);
  18         19  
1699             }
1700              
1701             sub uniq {
1702 1     1   1 my $arr = CORE::shift;
1703              
1704             # shamelessly stolen from List::MoreUtils
1705             # fix for code stolen from List::MoreUtils shamelessly stolen from List::MoreUtils
1706              
1707 1         2 my %seen = ();
1708 1         2 my $k;
1709             my $seen_undef;
1710 1 50       1 my @res = CORE::grep { CORE::defined $_ ? not $seen{ $k = $_ }++ : CORE::not $seen_undef++ } @$arr;
  8         22  
1711 1 50       4 return wantarray ? @res : \@res;
1712             }
1713              
1714             # tied and blessed
1715              
1716 1     1   23 sub bless { CORE::bless $_[0], $_[1] }
1717 0     0   0 sub tie { CORE::tie $_[0], @_[1 .. $#_] }
1718 0     0   0 sub tied { CORE::tied $_[0] }
1719 1     1   345 sub ref { CORE::ref $_[0] }
1720              
1721             # perl 6-ish extensions to Perl 5 core stuff
1722              
1723             # sub first(\@) { my $arr = CORE::shift; $arr->[0]; } # old, incompat version
1724              
1725             sub first {
1726             # from perl5i, modified
1727             # XXX needs test. take from perl5i?
1728 3     3   176 my ( $array, $filter ) = @_;
1729              
1730 3 100       14 if ( @_ == 1 ) {
    100          
    50          
1731 1         3 return $array->[0];
1732             } elsif ( CORE::ref $filter eq "Regexp" ) {
1733 1     4   5 return List::Util::first( sub { $_ =~ m/$filter/ }, @$array );
  4         11  
1734             } elsif ( ! CORE::ref $filter ) {
1735 0     0   0 return List::Util::first( sub { $_ eq $filter }, @$array );
  0         0  
1736             } else {
1737 1     4   13 return List::Util::first( sub { $filter->() }, @$array );
  4         11  
1738             }
1739             }
1740              
1741 1     1   30 sub size { my $arr = CORE::shift; CORE::scalar @$arr; }
  1         5  
1742 1     1   16 sub elems { my $arr = CORE::shift; CORE::scalar @$arr; } # Larry announced it would be elems, not size
  1         6  
1743 1     1   1 sub length { my $arr = CORE::shift; CORE::scalar @$arr; }
  1         4  
1744              
1745             # misc
1746              
1747             sub each {
1748             # same as foreach(), apo12 mentions this
1749             # XXX should we try to build a result list if we're in non-void context?
1750 1     1   741 my $arr = CORE::shift; my $sub = CORE::shift;
  1         3  
1751 1         3 foreach my $i (@$arr) {
1752             # local $_ = $i; # XXX may I break stuff?
1753 3         8 $sub->($i);
1754             }
1755             }
1756              
1757             sub foreach {
1758 1     1   21 my $arr = CORE::shift; my $sub = CORE::shift;
  1         1  
1759 1         3 foreach my $i (@$arr) {
1760             # local $_ = $i; # XXX may I break stuff?
1761 3         9 $sub->($i);
1762             }
1763             }
1764              
1765             sub for {
1766 1     1   20 my $arr = CORE::shift; my $sub = CORE::shift;
  1         1  
1767 1         4 for(my $i = 0; $i <= $#$arr; $i++) {
1768             # local $_ = $arr->[$i]; # XXX may I break stuff?
1769 3         13 $sub->($i, $arr->[$i], $arr);
1770             }
1771             }
1772              
1773 0     0   0 sub print { my $arr = CORE::shift; my @arr = @$arr; CORE::print "@arr"; }
  0         0  
  0         0  
1774 0     0   0 sub say { my $arr = CORE::shift; my @arr = @$arr; CORE::print "@arr\n"; }
  0         0  
  0         0  
1775              
1776             # local
1777              
1778 2     2   726 sub elements { ( @{$_[0]} ) }
  2         5  
1779 2     2   567 sub flatten { ( @{$_[0]} ) }
  2         7  
1780              
1781             sub head {
1782 2     2   17 return $_[0]->[0];
1783             }
1784              
1785             sub slice {
1786 5     5   292 my $list = CORE::shift;
1787             # the rest of the arguments in @_ are the indices to take
1788              
1789 5 100       22 return wantarray ? @$list[@_] : [@{$list}[@_]];
  2         9  
1790             }
1791              
1792             sub range {
1793 4     4   394 my ($array, $lower, $upper) = @_;
1794              
1795 4         6 my @slice = @{$array}[$lower .. $upper];
  4         9  
1796              
1797 4 100       16 return wantarray ? @slice : \@slice;
1798              
1799             }
1800              
1801             sub tail {
1802 7     7   294 my $last = $#{$_[0]};
  7         11  
1803              
1804 7 100       13 my $first = defined $_[1] ? $last - $_[1] + 1 : 1;
1805              
1806 7 50       15 Carp::croak("Not enough elements in array") if $first < 0;
1807              
1808             # Yeah... avert your eyes
1809 7 100       12 return wantarray ? @{$_[0]}[$first .. $last] : [@{$_[0]}[$first .. $last]];
  5         22  
  2         7  
1810             }
1811              
1812             sub first_index {
1813 3 100   3   24 if (@_ == 1) {
1814 1         6 return 0;
1815             }
1816             else {
1817 2         3 my ($array, $arg) = @_;
1818              
1819 2 100   2   8 my $filter = CORE::ref($arg) eq 'Regexp' ? sub { $_[0] =~ $arg } : $arg;
  2         13  
1820              
1821 2         7 foreach my $i (0 .. $#$array) {
1822 12 100       29 return $i if $filter->($array->[$i]);
1823             }
1824              
1825             return
1826 0         0 }
1827             }
1828              
1829             sub last_index {
1830 3 100   3   24 if (@_ == 1) {
1831 1         1 return $#{$_[0]};
  1         8  
1832             }
1833             else {
1834 2         4 my ($array, $arg) = @_;
1835              
1836 2 100   1   9 my $filter = CORE::ref($arg) eq 'Regexp' ? sub { $_[0] =~ $arg } : $arg;
  1         10  
1837              
1838 2         6 foreach my $i (CORE::reverse 0 .. $#$array ) {
1839 2 50       5 return $i if $filter->($array->[$i]);
1840             }
1841              
1842             return
1843 0         0 }
1844             }
1845              
1846             ##############################################################################################
1847              
1848             #
1849             # CODE
1850             #
1851              
1852             package autobox::Core::CODE;
1853              
1854 1     1   234 sub bless { CORE::bless $_[0], $_[1] }
1855 1     1   660 sub ref { CORE::ref $_[0] }
1856              
1857             # perl 6-isms
1858              
1859 2     2   854 sub curry { my $code = CORE::shift; my @args = @_; sub { CORE::unshift @_, @args; goto &$code; }; }
  2     2   7  
  2         14  
  2         3  
  2         5  
1860              
1861             1;
1862