Smart-Args

 view release on metacpan or  search on metacpan

lib/Smart/Args.pm  view on Meta::CPAN

package Smart::Args;
use strict;
use warnings;
use 5.008001;
our $VERSION = '0.14';
use Exporter 'import';
use PadWalker qw/var_name/;
use Carp ();
use Mouse::Util::TypeConstraints ();

*_get_isa_type_constraint = \&Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint;
*_get_does_type_constraint = \&Mouse::Util::TypeConstraints::find_or_create_does_type_constraint;

our @EXPORT = qw/args args_pos/;

our $VERBOSE = 1;

my %is_invocant = map{ $_ => undef } qw($self $class);

sub args {
    {
        package DB;
        # call of caller in DB package sets @DB::args,
        # which requires list context, but we don't need return values
        () = CORE::caller(1);
    }

    if(@_) {
        my $name = var_name(1, \$_[0]) || '';
        if(exists $is_invocant{ $name }){ # seems method call
            $_[0] = shift @DB::args; # set the invocant
            if(defined $_[1]) { # has rule?
                $name =~ s/^\$//;
                # validate_pos($value, $exists, $name, $basic_rule, $used_ref)
                $_[0] = _validate_by_rule($_[0], 1, $name, $_[1]);
                shift;
            }
            shift;
        }
    }

    my $args = ( @DB::args == 1 && ref($DB::args[0]) )
            ?    $DB::args[0]  # must be hash
            : +{ @DB::args };  # must be key-value list

    ### $args
    ### @_

    # args my $var => RULE
    #         ~~~~    ~~~~
    #         undef   defined

    my $used = 0;
    for(my $i = 0; $i < @_; $i++){

        (my $name = var_name(1, \$_[$i]))
            or  Carp::croak('usage: args my $var => TYPE, ...');
        $name =~ s/^\$//;

        # with rule  (my $foo => $rule, ...)
        if(defined $_[ $i + 1 ]) {
            # validate_pos($value, $exists, $name, $basic_rule, $used_ref)
            $_[$i] = _validate_by_rule($args->{$name}, exists($args->{$name}), $name, $_[$i + 1], \$used);
            $i++;
        }
        # without rule (my $foo, my $bar, ...)
        else {



( run in 1.607 second using v1.01-cache-2.11-cpan-39bf76dae61 )