File Coverage

blib/lib/Whatever.pm

Criterion	Covered	Total	%
statement	54	59	91.5
branch	11	16	68.7
condition	6	6	100.0
subroutine	25	29	86.2
pod			n/a
total	96	110	87.2

package Whatever;
    use warnings;
    use strict;
    use Carp ();

    sub star (&) {
        my $code = shift;
        bless sub :lvalue {
            goto &$code if @_ < 2;
            my $star = $code;
            {$star = $star->(shift);
                @_ and ref $star eq 'Whatever' ? redo
                       : Carp::croak 'too many arguments for Whatever'}
            $star
        }
    }
    use overload fallback => 1,
        (# infix
            map {
                my $code = /atan2/ ? sub {atan2 $_[0], $_[1]}
                                   : eval "sub {\$_[0] $_ \$_[1]}" or die $@;
                $_ => sub {
                    my ($self, $flip) = @_[0, 2];
                    my $arg2 = \$_[1];
                    star {
                        $code->($flip ? ($$arg2, &$self)
                                      : (&$self, $$arg2))
                    }
                }
            } qw (+ - * / % ** << >> x . & | ^ < <= > >= == != lt le gt
                  ge eq ne <=> cmp atan2), $^V >= 5.010 ? '~~' : ()
        ),
        (# prefix
            map {
                my $code = eval "sub {$_ \$_[0]}" or die $@;
                ($_ eq '-' ? 'neg' : $_) => sub {
                    my $self = $_[0];
                    star {$code->(&$self)}
                }
            } qw (- ! ~)
        ),
        (# functions
            map {
                my $code = eval "sub {$_(\$_[0])}" or die $@;
                $_ => sub {
                    my $self = $_[0];
                    star {$code->(&$self)}
                }
            } qw (cos sin exp abs log sqrt)
        ),
        '@{}' => sub {tie my @ret => 'Whatever::ARRAY', shift; \@ret},
        '%{}' => sub {tie my %ret => 'Whatever::HASH',  shift; \%ret};

    {
        my $star = star sub :lvalue {@_ ? $_[0] : $_};
        my $arg  = star sub :lvalue {$_[0]};
        my $it   = star sub :lvalue {$_};
        ** = sub :lvalue {my $x = $star};
        *@ = sub {$arg};
        *_ = sub {$it};
        ** = \$star;
    }
    eval {Internals::SvREADONLY($*, 1)}
        or warn 'Whatever could not set $* readonly: '.$@;

    my $av_push = eval {
        require Array::RefElem;
        \&Array::RefElem::av_push
    };
    sub AUTOLOAD {
        my $self = shift;
        my $args = \@_;
        my $method = substr our $AUTOLOAD, 2 + length __PACKAGE__;
        star {
            if ($av_push) {
                $av_push->(\@_, $_)
                    for scalar &$self, @$args, @_ = ();
            } else {
                @_ = (scalar &$self, @$args)
            }
            goto &{$_[0]->can($method)}
        }
    } sub DESTROY {}

    {package
        Whatever::ARRAY;
        sub TIEARRAY {bless \\pop}
        sub FETCH {
            my ($self, $key) = @_;
            Whatever::star sub :lvalue {
                (&$$$self ||= [])->[$key - ($key > 2**30 and 2**31-1)]
            }
        }
        sub FETCHSIZE {2**31-1}
        sub AUTOLOAD {Carp::croak our $AUTOLOAD . " unsupported"}
        sub DESTROY {}
    }
    {package
        Whatever::HASH;
        sub TIEHASH {bless \\pop}
        sub FETCH {
            my ($self, $key) = @_;
            Whatever::star sub :lvalue {(&$$$self ||= {})->{$key}}
        }
        sub AUTOLOAD {Carp::croak our $AUTOLOAD . " unsupported"}
        sub DESTROY {}
    }
    delete $Whatever::{star};
    our $VERSION = '0.23';

=head1 NAME

Whatever - a perl6ish whatever-star for perl5

=head1 VERSION

Version 0.23

=head1 SYNOPSIS

this module provides a whatever-star C< * > term for perl 5. since this
module is B a source filter, the name C< &* > or C< $* > is as close as
it's going to get.

    use Whatever;

    my $greet = 'hello, ' . &* . '!';

    say $greet->('world'); # prints 'hello, world!'

what was:

    my $result = $someobj->map(sub{$_ * 2});

can now be:

    my $result = $someobj->map(&* * 2);

=head1 EXPORT

    &*  the whatever-star
    $*  the whatever-star         ($* is deprecated in 5.10+, so I'm taking it)
    &@  the gets-val-from-@_-star
    &_  the gets-val-from-$_-star

like all punctuation variables, the whatever terms are global across all
packages after this module is loaded.

=head1 SUBROUTINES

the C< &* > and C< $* > stars are the most generic terms, which return their
expression as a coderef that will take its argument from C< $_[0] > if it is
available, or C< $_ > otherwise. this allows the terms to dwim in most contexts.
think of the whatever star as C< sub {@_ ? $_[0] : $_} >

the C< &@ > term always uses C< $_[0]>, while the C< &_ > always uses C< $_ >

beyond where they get their eventual argument from, all of the whatever terms
behave the same way.  each is a I overloaded object that will bind to
the operators and variables that it interacts with.  at all times the whatever
star is a coderef that will perform the actions it has accumulated when passed
a value to act on.

a few more examples are probably in order:

=over 4

=item hello world

    my $greet = "hello, $*!";  # the $* term interpolates in strings
    say $greet->('world'); # prints 'hello, world!'

    say "hello, $*!"->('world');

=item simple operations

    my $inc = $* + 1;
    say $inc->(5); # prints 6

    my $inc_x2 = $inc * 2;  # whatever code continues to capture operations
    say $inc_x2->(5); # prints 12

    my $inc_inc = $inc->($inc); # and is fine with recursion
    say $inc_inc->(5); # prints 7

    my $repeat = &* x &*;
    my $line = $repeat->('-');
    my $hr = $line . "\n";

    print $hr->(80);  # prints ('-' x 80)."\n"

=item with object oriented code

assuming this simple C< Array > implementation:

    {package Array;
        sub new  {shift; bless [@_]}
        sub map  {new Array map  $_[1]() => @{$_[0]}}
        sub grep {new Array grep $_[1]() => @{$_[0]}}
        sub str  {join ' ' => @{$_[0]}}
    }
    my $array = new Array 1 .. 10;

    say $array->map(&_ * 2)->str;              # '2 4 6 8 10 12 14 16 18 20'
    say $array->map(&_ * 2)->map(&_ + 1)->str; # '3 5 7 9 11 13 15 17 19 21'
    say $array->map(&_ * 2 + 1)->str;          # '3 5 7 9 11 13 15 17 19 21'

=item method calls

    my $str = &*->str;
    say $str->($array); # prints '1 2 3 4 5 6 7 8 9 10'

    my $multi_call = &*->map(&_ * 2 + 1)->grep(&_ % 5)->str;

    say $multi_call->($array); # prints '3 7 9 11 13 17 19 21'

    $some_obj->map(&*->some_method(...));

arguments of method calls are copied by alias if L is installed.
this provides closure like behavior.  otherwise, the values are fixed to
whatever they were at the time of declaration.

=item multiple whatever stars

when working with subs created by combining multiple stars, you can bind
multiple values at once by passing multiple arguments.

    my $join3 = &* . &* . &*;

    say $join3->(1)(2)(3); # prints '123'
    say $join3->(1 .. 3);  # prints '123'

    my $indent = $join3->(' ', ' ');

    say $indent->('xyz'); # prints '  xyz'

=item arrays and hashes

you can dereference a whatever star as an array or hash (of course the star
expects to be passed a suitable reference):

    my $first = &*->[0];
    my $bob   = &*->{bob};

    say $first->([3 .. 5]); # prints '3'
    say $bob->({bob => 5}); # prints '5'

the subroutine returned by the star is a valid lvalue (can be assigned to).
multi-level calls and calls that would normally autovivify behave as expected.

    &*->[0][0]{x}(my $array) = 4;

    say $$array[0][0]{x}; # prints '4'

=item variables

the stars lazily bind to variables, which allows the variable to get its value
after the star is defined, and to change its value between calls.  this is
analogous to an anonymous sub closing over a variable

    my $future;
    my $delorean = $future . (' ' . $* . '!');
     # works like: sub {$future . (' ' . $_[0] . '!')};

    $future = 1.21;
    say $delorean->('gigawatts'); # prints "1.21 gigawatts!"

    $future = &*;
    say $delorean->('folks')->("that's all");  # prints "that's all folks!"

=back

=head1 AUTHOR

Eric Strom, C<<  >>

=head1 BUGS

this module is new, there are probably some.

please report any bugs or feature requests to C,
or through the web interface at
L.  I will be
notified, and then you'll automatically be notified of progress on your bug as
I make changes.

=head1 ACKNOWLEDGEMENTS

those behind the perl6 whatever-star

=head1 LICENSE AND COPYRIGHT

copyright 2010 Eric Strom.

this program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

see http://dev.perl.org/licenses/ for more information.

=cut

__PACKAGE__ if 'first require';