...
use warnings;
use warnings FATAL => qw(redefine closure);
use Types;
use Scalar::Util qw(looks_like_number);
use constant CLASS => __PACKAGE__;
use Want;
sub _Var ($$$;$) :lvalue { # Wrkhorse code for manufctrd Vars
my ($__, $p, $vn, $wa)=@$_; # vn=varname
our $_=$__; # must not trash '$_'
my $c = ref $p || $p;
my $rfv = ref $p->{$vn}; # rfv=ref(type) of var
my $addrof;
if ($wa && $wa eq 'α') { $wa=undef, $addrof=1 }
my $arg = $_[0];
return $p->{$vn}=want('ASSIGN') if want(qw(LVALUE ASSIGN));
if (@_ && !$addrof) { # arg for "setter"
my $rfa = ref $arg; # ref of the arg
if ( !defined($p->{$vn}) or !defined $arg ){ # either undef
$p->{$vn} = $arg;
} elsif ($rfv eq ARRAY) { ## if type(var)==ARRAY, 1 param
my ($index, $ap) = (shift, $p->{$vn});
if ($p->{':pusharray'} or ( !looks_like_number($index) ||
not( (defined $wa) || @_) )) {
push @{$p->{$vn}}, ($index); ## convert to "push"
return $index; ## return pushed value
} else {
$p->{$vn}[$index] = $_[0] if @_;
return $p->{$vn}[$index];
}
} elsif ($rfv eq HASH) {
my $subvar = shift; ## 1 var w/hash is is a key
$p->{$vn}{$subvar} = $_[0] if @_; ## another? =>assign value
return $p->{$vn}{$subvar};
} else {
if (length $rfv && $rfv ne $rfa ) { ## incompat assignment
warn P "Warning: var type redefined from \"%s\" to \"%s\"",
$rfv, $rfa;
}
$p->{$vn} = $_[0]; ## assignment is default
}
} # how to return results? (below)
if ($rfv eq ARRAY ) {
if (defined($wa)) { # arrays special
$wa? @{$p->{$vn}} : $addrof ? \$p->{$vn} : $p->{$vn};
}
} elsif ($rfv eq HASH ) { $p->{$vn} }
elsif ($addrof) { return $p->{$vn} }
else {
return $p->{$vn};
}
}
sub varname ($) { substr $_[0], (1+rindex $_[0],':') }
sub _access_maker { #{{{
my $pkg = shift; #var in $_
{
my $proc = '# line ' . __LINE__ . ' "' . __FILE__ . "\"\n" . '
{ use warnings;use strict;
package '.$pkg.';
sub '.$_.' (;$) :lvalue {
my $sav = [$_,shift, Data::Vars::varname((caller 0)[3]), wantarray];
our $_=$sav;
goto &Data::Vars::_Var};
1}';
eval $proc;
$@ and die "Fatal error in $pkg\::Vars\::_access_maker?: $@\n";
}
} ## end sub _access_maker }}}
####
sub ARRAY (;*) {
my $p = $_[0];
return @_ ? (ref $p && (1+index($p, '::ARRAY')? 1:0) : 'ARRAY'
}
##
##
my $ptr=[];
say ARRAY if ARRAY $ptr;