File Coverage

blib/lib/Sub/Parameters.pm

Criterion	Covered	Total	%
statement	56	71	78.8
branch	6	26	23.0
condition	4	16	25.0
subroutine	15	16	93.7
pod	0	3	0.0
total	81	132	61.3

package Sub::Parameters;
use strict;
use warnings;
use Hook::LexWrap;
use Devel::Caller qw(caller_cv called_with);
use Devel::LexAlias qw(lexalias);
use Carp qw(croak);
use Attribute::Handlers;

require Exporter;
use base 'Exporter';
our @EXPORT_OK = qw( Param );
our $VERSION = '0.03';

my @stack;

sub UNIVERSAL::WantParam : ATTR(CODE) {
    my ($symbol, $sub, $data) = @_[1, 2, 4];

    $data ||= 'positional';
    wrap $symbol,
      pre  => sub {
          my %order;
          if ($data eq 'named') {
              # prechew the ordering information
              for (my $i = 0; $i < $#_; $i += 2) {
                  $order{ $_[$i] } = $i + 1;
              }
          }
          push @stack, { data  => $data,
                         sub   => $sub,
                         order => \%order,
                         args  => \@_ };
      },
      post => sub { pop  @stack };
}


# you know, this would be a lot tidier if we could use ourselves
# already...

sub Param {
    local $Carp::CarpLevel = 3;
    _Parameter(caller_cv(1), called_with(0), called_with(0,1), $_[0]);
}

sub UNIVERSAL::Parameter : ATTR(VAR) {
    # 4 is a magic number dependant on Attribute::Handlers
    local $Carp::CarpLevel = 4;
    croak "your perl is not new enough to use the :Parameter form"
      if $] < 5.007002;

    my $sub = caller_cv($Carp::CarpLevel);
    my $referent = $_[2];

    require PadWalker;
    my %names = reverse %{ PadWalker::peek_sub( $sub ) };
    my $fullname = $names{$referent}
      or croak "couldn't find the name of $referent";

    ++$Carp::CarpLevel;
    _Parameter($sub, $referent, $fullname, $_[4]);
}

sub _Parameter {
    my ($sub, $referent, $fullname, $data) = @_;
    $data ||= 'copy';   # valid values: qw(copy rw)

    my $frame = $stack[-1];
    croak "attempt to use a Parameter in an undecorated subroutine"
      unless $frame->{sub} && $sub == $frame->{sub};

    my ($sigil, $name) = ($fullname =~ /^([\$@%])(.*)$/);

    # set the offset based on the scheme
    my $offset;
    if ($frame->{data} eq 'positional') {
        $offset = $frame->{index}++;
    }
    elsif ($frame->{data} eq 'named') {
        $offset = $frame->{order}{$name}
          or croak "can't find a parameter for '$sigil$name'";
    }
    else {
        croak "don't know what kind of processing to do!";
    }

    if ( $sigil eq '@' || $sigil eq '%' ) { # expect refs
        my $value = $frame->{args}[ $offset ];
        ref $value eq 'ARRAY' || croak "can't assign non-arrayref to '$sigil$name'"
          if $sigil eq '@';
        ref $value eq 'HASH'  || croak "can't assign non-hashref to '$sigil$name'"
          if $sigil eq '%';

        $value = (ref $value eq 'ARRAY' ? [ @$value ] : { %$value })
          if $data ne 'rw';

        lexalias($sub, $sigil.$name, $value);
        return;
    }

    # simple scalars
    if ($data eq 'rw') {
        lexalias($sub, $sigil.$name, \$frame->{args}[ $offset ]);
    }
    else {
        $$referent = $frame->{args}[ $offset ];
    }
}

1;
__END__