File Coverage

blib/lib/selfvars.pm

Criterion	Covered	Total	%
statement	89	129	68.9
branch	8	10	80.0
condition	10	15	66.6
subroutine	25	50	50.0
pod			n/a
total	132	204	64.7

package selfvars;
use 5.005;
use strict;
use vars qw( $VERSION $self @args %opts %hopts );

BEGIN {
    $VERSION = '0.32';
}

sub import {
    my $class = shift; # Oooh, the irony!
    my %vars  = (-self => undef, -args => undef, -opts => undef, -hopts => undef) unless @_;

    while (@_) {
        my $key = shift;
        if (@_ and $_[0] !~ /^-/) {
            $vars{$key} = shift;
        }
        else {
            $vars{$key} = undef;
        }
    }

    my $pkg = caller;

    no strict 'refs';
    my %map = (self => \$self, args => \@args, opts => \%opts, hopts => \%hopts);
    while (my ($sym, $var) = each %map) {
        exists $vars{"-$sym"} or next;
        $vars{"-$sym"} = $sym unless defined $vars{"-$sym"};
        *{"$pkg\::$vars{qq[-$sym]}"} = $var;
    }
}

package selfvars::self;

sub TIESCALAR {
    my $x;
    bless \$x => $_[0];
}

sub FETCH {
    my $level = 1;
    my @c     = ();
    while ( !defined( $c[3] ) || $c[3] eq '(eval)' ) {
        @c = do {
            package DB;
            @DB::args = ();
            caller($level);
        };
        $level++;
    }
    $DB::args[0];
}

sub STORE {
    require Carp;
    Carp::croak('Modification of a read-only $self attempted');
}

package selfvars::args;
use Tie::Array ();
use vars qw(@ISA);
BEGIN { @ISA = 'Tie::Array' }

sub _args {
    my $level = 2;
    my @c;
    while ( !defined( $c[3] ) || $c[3] eq '(eval)' ) {
        @c = do {
            package DB;
            @DB::args = ();
            caller($level);
        };
        $level++;
    }
    \@DB::args;
}

sub readonly { require Carp; Carp::croak('Modification of a read-only @args attempted'); }

sub TIEARRAY  { my $x; bless \$x => $_[0] }
sub FETCHSIZE { scalar $#{ _args() } }
sub STORESIZE { goto &readonly } # $#{ _args() } = $_[1] + 1;
sub STORE     { _args()->[ $_[1] + 1 ] = $_[2] }
sub FETCH     { _args()->[ $_[1] + 1 ] }
sub CLEAR     { goto &readonly } # $#{ _args() } = 0;
sub POP       { goto &readonly } # my $o = _args(); (@$o > 1) ? pop(@$o) : undef
sub PUSH      { goto &readonly } # my $o = _args(); push( @$o, @_ )
sub SHIFT     { goto &readonly } # my $o = _args(); splice( @$o, 1, 1 )
sub UNSHIFT   { goto &readonly } # my $o = _args(); unshift( @$o, @_ )
sub DELETE    { goto &readonly } # my $o = _args(); delete $o->[ $_[1] + 1 ]
sub SPLICE    { goto &readonly }
    # my $ob  = shift;
    # my $sz  = $ob->FETCHSIZE;
    # my $off = @_ ? shift : 0;
    # $off += $sz if $off < 0;
    # my $len = @_ ? shift : $sz - $off;
    # splice( @$ob, $off + 1, $len, @_ );

BEGIN {
    local $@;
    eval q{
        sub EXISTS    {
            my $o = _args(); exists $o->[ $_[1] + 1 ]
        }
    } if $] >= 5.006;
}

package selfvars::opts;

sub _opts {
    my $level = 2;
    my @c;
    while ( !defined( $c[3] ) || $c[3] eq '(eval)' ) {
        @c = do {
            package DB;
            @DB::args = ();
            caller($level);
        };
        $level++;
    }
    $DB::args[1];
}

sub TIEHASH  { my $x; bless \$x => $_[0] }
sub FETCH    { _opts()->{ $_[1] } }
sub STORE    { _opts()->{ $_[1] } = $_[2] }
sub FIRSTKEY { my $o = _opts(); my $a = scalar keys %$o; each %$o }
sub NEXTKEY  { my $o = _opts(); each %$o }
sub EXISTS   { my $o = _opts(); exists $o->{$_[1]} }
sub DELETE   { my $o = _opts(); delete $o->{$_[1]} }
sub CLEAR    { my $o = _opts(); %$o = () }
sub SCALAR   { my $o = _opts(); scalar %$o }

package selfvars::hopts;

sub _opts {
    my $level = 2;
    my @c;
    while ( !defined( $c[3] ) || $c[3] eq '(eval)' ) {
        @c = do {
            package DB;
            @DB::args = ();
            caller($level);
        };
        $level++;
    }
    shift @DB::args;
    @DB::args;
}

sub readonly { require Carp; Carp::croak('Modification of a read-only %hopts attempted'); }

sub TIEHASH  { my $x; bless \$x => $_[0] }
sub FETCH    { my (%o) = _opts(); $o{ $_[1] } }
sub STORE    { goto &readonly }
sub FIRSTKEY { my (%o) = _opts(); my $a = scalar keys %o; each %o }
sub NEXTKEY  { }
sub EXISTS   { my (%o) = _opts(); exists $o{$_[1]} }
sub DELETE   { goto &readonly }
sub CLEAR    { goto &readonly }
sub SCALAR   { my (%o) = _opts(); scalar %o }


package selfvars;

BEGIN {
    tie $self => __PACKAGE__ . '::self';
    tie @args => __PACKAGE__ . '::args';
    tie %opts => __PACKAGE__ . '::opts';
    tie %hopts => __PACKAGE__ . '::hopts';
}

1;

__END__