File Coverage

blib/lib/Attribute/Handlers/Prospective.pm

Criterion	Covered	Total	%
statement	83	93	89.2
branch	41	48	85.4
condition	16	25	64.0
subroutine	12	14	85.7
pod	0	6	0.0
total	152	186	81.7

package Attribute::Handlers::Prospective;
$VERSION = '0.01';
use Filter::Simple;
use Text::Balanced ':ALL';
use Carp;

our $id          = qr/(?>[a-z_]\w*(?:::[a-z_]\w*)*)/i;
our $parens      = qr/[(](?:(?>[^()]+)|(??{$parens}))*[)]/;
our $attr        = qr/$id(?:$parens)?/;
our $decl        = qr/my|our|local/;
our $sigil       = qr/[\$\@%*]/;
our $comments	 = qr/(?-sm:\s*#.*\n)*\s*/;

our $attr_list5  = qr/:$comments($attr$comments(?::?$comments$attr$comments)*)/;
our $sub_decl5   = qr/\bsub\s+($id)\s*(?:$attr_list5)?\s*($parens)?/;
our $sub_anon5   = qr/\bsub\s*(?:$attr_list5)?\s*($parens)?/;
our $var_decl5   = qr/\b($decl)\s*($id?)\s*($sigil)($id)\s*$attr_list5\s*(\S)/;
our $var_noattr5 = qr/\b($decl\s*$id?\s*$sigil$id\s*(?=\S)(?!:))/;

our $attr_list6  = qr/\bis\s+($attr(?:\s*(?:(?:\bis\b)?\s*$attr|#[^\n]\n))*)/;
our $sub_decl6   = qr/\bsub\s+($id)\s*(?:$attr_list6)?\s*($parens)?(?=\s*[{])/;
our $sub_anon6   = qr/\bsub\s*(?:$attr_list6)?\s*($parens)?/;
our $var_decl6   = qr/\b($decl)\s*($id?)\s*($sigil)($id)\s*$attr_list6\s*(\S)/;
our $var_noattr6 = qr/\b($decl\s+$id?\s*$sigil$id\s*(?=\S)(?!is\b))/;

our ($attr_list, $sub_decl, $sub_anon, $var_decl, $var_noattrs);

our %ATTRS = ( ATTR => {} );

our @PHASES = qw(BEGIN CHECK INIT RUN END);

sub get_attr {
	my $attr = shift;
	my $package = shift || caller;
	return $ATTRS{$package} unless $attr;
	return $ATTRS{$package}{$attr};
}

sub def_handler {
	my ($location, $type, $phase, $attr, $ATTR) = @_;
	use Data::Dumper 'Dumper';
	return $ATTR->{rawdata} ? "*{'$attr (RAWDATA)'} = \\&$attr;" : ""
		if !$phase && !$type;
	return "*{'$attr ($type)'} = \\&$attr;"
		if !$phase && $ATTR->{types}{$type};
	return "*{'$attr ($type $phase)'} = \\&$attr;"
		if $ATTR->{types}{$type} && $ATTR->{phases}{$phase};
	return "";
}

sub def_attr {
	my ($sub, $data, $pkg) = @_;
	my $ATTR = $ATTRS{$pkg}{$sub} = {};
	$ATTR->{phases}{$_} = $data =~ s/\s*,?\s*($_)\s*,?\s*// for @PHASES;
	$ATTR->{phases}{INIT} = 1 unless grep $ATTR->{phases}{$_}, @PHASES;
	$ATTR->{handler} = $sub =~ /::/ ? $sub : $pkg."::".$sub;
	$data .= ',ANY' unless $data =~/\b(SCALAR|ARRAY|HASH|GLOB|CODE|VAR)\b/;
	$ATTR->{types}{SCALAR} = 1 if $data =~ /\b(undef|ANY|VAR|SCALAR)\b/;
	$ATTR->{types}{ARRAY}  = 1 if $data =~ /\b(undef|ANY|VAR|ARRAY)\b/;
	$ATTR->{types}{HASH}   = 1 if $data =~ /\b(undef|ANY|VAR|HASH)\b/;
	$ATTR->{types}{GLOB}   = 1 if $data =~ /\b(undef|ANY|GLOB)\b/;
	$ATTR->{types}{CODE}   = 1 if $data =~ /\b(undef|ANY|CODE)\b/;
	$ATTR->{rawdata}       = 1 if $data =~ /\b(RAWDATA)\b/;
	return $ATTR;
}

sub def_call {
	my ($impl, $owner, $reftype, $attr, $args) = @_;
	foreach my $phase ( qw(BEGIN CHECK INIT RUN END) ) {
	    $impl->{$phase} .=
		"eval{$owner->\${\\'$attr ($reftype $phase)'}($args,'$phase');1} || " .
		"eval{$owner->\${\\'AUTOATTR ($reftype $phase)'}($args,'$phase');1};";
	}
}

sub def_call_prepost {
	my ($impl, $owner, $reftype, $args, $arglist) = @_;
	foreach my $handler ( qw(PREATTR POSTATTR) ) {
	    foreach my $phase ( qw(BEGIN CHECK INIT RUN END) ) {
		$impl->{$phase} .=
			"eval{$owner->\${\\'$handler ($reftype $phase)'}($args, '$handler',$arglist,'$phase');1}; ";
	    }
	}
}

my %sigil_to_type = (
	'$' => 'SCALAR',
	'@' => 'ARRAY',
	'%' => 'HASH',
	'&' => 'CODE',
	'*' => 'GLOB',
);

sub impl_attrs {
	my ($attrs,$name,$pkg,$sigil,$decl,$type) = @_;
	my %impl;
	my $prepostargs = "";
	my $noprepost = 0;
	my $glob = ($decl eq 'my')            ? "'LEXICAL($sigil$name)'"
	         : ($decl eq 'sub' && !$name) ? "'ANON'"
	         :                              "\\*$name";
	my $referent = $name ? "\\$sigil$name" : '$_';
	my $location = $name && $name =~ /^(.*::)+/ ? $1
		     : 				   '__PACKAGE__';
	my $owner = $type ? $type : $location;
	my $reftype = $sigil_to_type{$sigil};
	while (1) {
		$attrs =~ m/\G:?$comments\s*($id)($parens)?$comments/gc or last;
		my ($attr, $data) = ($1, $2||"");
		$data =~ s/^[(]|[)]$//g;
		$data ||= 'undef';
		if ($attr eq 'ATTR') {
			my $ATTR = def_attr($name, $data, $pkg);
			$noprepost=1;
			$impl{BEGIN} .= def_handler($location, undef, undef, $name, $ATTR);
			foreach my $type ( qw(SCALAR ARRAY HASH CODE GLOB) ) {
			  $impl{BEGIN} .= def_handler($location, $type, undef, $name, $ATTR);
			  foreach my $phase ( qw(BEGIN CHECK INIT RUN END) ) {
			    $impl{BEGIN} .= def_handler($location, $type, $phase, $name, $ATTR);
			}}
			next;
		}
		$data &&= "$owner->can('$attr (RAWDATA)') ? q($data) : eval q([$data])";
		my $args = "$glob,$referent,'$attr',$data";
		$impl{BEGIN} .= "die 'No such $reftype attribute: '.${owner}.'::$attr' unless $owner->can('$attr ($reftype)') || $owner->can('AUTOATTR ($reftype)');";
		def_call(\%impl, $owner, $reftype, $attr, $args);
		$prepostargs .= "[$owner,$args],";
	}
	def_call_prepost(\%impl, $owner, $reftype, "$glob, $referent", "[$prepostargs]")
		unless $noprepost;
	return join " ",
	            map { ($_ eq 'RUN' ? "" : $_) . "{ $impl{$_} }" }
	                grep { defined $impl{$_} }
				qw(BEGIN CHECK INIT RUN END);
}

sub _usage_AH_ {
        croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
}

FILTER {
	my $caller = shift;
	my $classname = shift;
	my $autotied = "";
	while (@_) {
		my $cmd = shift;
		next if $cmd =~ /^Perl\s*6$/;
		if ($cmd =~ /^autotie((?:ref)?)$/) {
		    my $tiedata = $1 ? '$ref, @$data' : '@$data';
		    my $mapping = shift;
		    _usage_AHI_ $class unless ref($mapping) eq 'HASH';
		    while (my($attr, $tieclass) = each %$mapping) {
			$tieclass =~ s/^($id)(.*)/$1/is;
			my $args = $2||'()';
			_usage_AH_ $class unless $attr =~ $id
					 && $tieclass =~ $id;
			$attr =~ s/__CALLER__/$caller/e;
			$attr = $caller."::".$attr unless $attr =~ /::/;
			$autotied .= qq(
			    eval { require $tieclass and $tieclass->import($args) };
			    sub $attr : ATTR(VAR,RUN) {
				my (\$ref, \$data) = \@_[2,4];
				my \$type = ref(\$ref);
				if (\$type eq 'SCALAR') {
				    tie \$\$ref,'$tieclass',$tiedata
				}
			        elsif (\$type eq 'ARRAY') {
				    tie \@\$ref,'$tieclass',$tiedata
			        }
				elsif (\$type eq 'HASH') {
				    tie \%\$ref,'$tieclass',$tiedata
				}
			        else {
				    print STDERR "Can't autotie a \$type\n" and exit
				}
			    }
                       );
		    }
		}
		else {
		    print STDERR "Can't understand $cmd\n" and exit;
		}
	}
	$_ = $autotied . $_;
	pos() ||= 0;
	my $newcode;
	my $extracted;
	while (pos() < length()) {
		my @found;
		if (($extracted) = extract_quotelike($_,q//) and $extracted or
		    ($extracted) = extract_variable($_,q//) and $extracted ) {
			$newcode .= $extracted;
		}
		elsif (m/\G$sub_decl/gc) {
			my ($name, $attrs, $params) = ($1,$2||"",$3||"");
			my ($block) = extract_codeblock;
			$DB::single = 1;
			$newcode .= "sub $name $params $block ;"
			          . impl_attrs($attrs,$name,$caller,'&','sub');
		}
		elsif (m/\G$sub_anon/gc) {
			my ($attrs, $params) = ($1||"",$2||"");
			my ($block) = extract_codeblock;
			$newcode .= "do { local \$_ = sub $params $block; "
			          . impl_attrs($attrs,undef,$caller,'&','sub')
				  . ' ; $_ }';
		}
		elsif (m/\G$var_noattrs/gc) {
			$newcode .= $1;
		}
		elsif (m/\G$var_decl/gc) {
			my ($decl, $type, $sigil, $name, $attrs, $nextchar)
			 = ($1,    $2||"",$3,     $4,    $5||"", $6);
			$newcode .= "$decl $type $sigil$name; "
			          . impl_attrs($attrs,$name,$caller,$sigil,$decl,$type)
				  . "; "
				  . ($nextchar eq '=' ? "$sigil$name " : "")
				  . $nextchar;
		}
		elsif (m/\G($id|$parens|.)/gcs) {
		        $newcode .= $1;
		}
		else {
			die "Internal error";
		}
	}
	$_ = $newcode;
	# print STDERR if $_;
}
qr/^__(END|DATA)__$/m;

no warnings;
my $filterer = *import{CODE};
my $mod_filterer = sub { unshift @_, scalar caller; goto &$filterer };
*import = sub {
	if (grep /Perl\s*6/, @_) {
		$attr_list   = $attr_list6;
		$sub_decl    = $sub_decl6;
		$sub_anon    = $sub_anon6;
		$var_decl    = $var_decl6;
		$var_noattrs = $var_noattr6;
	}
	else {
		$attr_list   = $attr_list5;
		$sub_decl    = $sub_decl5;
		$sub_anon    = $sub_anon5;
		$var_decl    = $var_decl5;
		$var_noattrs = $var_noattr5;
	}
	*{caller()."::import"} = $mod_filterer;
	goto &$mod_filterer
};

1;

__END__