view release on metacpan or  search on metacpan

lib/Attribute/Handlers.pm  view on Meta::CPAN

                }
                else {
                    $attr = caller()."::".$attr unless $attr =~ /::/;
                    eval qq{ sub $attr $code 1; }
                      or die "Internal error: $@";
                }
            }
        }
        else {
            croak "Can't understand $_"; 
        }
    }
}

# On older perls, code attribute handlers run before the sub gets placed
# in its package.  Since the :ATTR handlers need to know the name of the
# sub they're applied to, the name lookup (via findsym) needs to be
# delayed: we do it immediately before we might need to find attribute
# handlers from their name.  However, on newer perls (which fix some
# problems relating to attribute application), a sub gets placed in its
# package before its attributes are processed.  In this case, the
# delayed name lookup might be too late, because the sub we're looking
# for might have already been replaced.  So we need to detect which way
# round this perl does things, and time the name lookup accordingly.
BEGIN {
	my $delayed;
	sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
		$delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
		return ();
	}
	sub Attribute::Handlers::_TEST_::t :T { }
	*_delayed_name_resolution = sub() { $delayed };
	undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
	undef &Attribute::Handlers::_TEST_::t;
}

sub _resolve_lastattr {
	return unless $lastattr{ref};
	my $sym = findsym @lastattr{'pkg','ref'}
		or die "Internal error: $lastattr{pkg} symbol went missing";
	my $name = *{$sym}{NAME};
	warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
		if $^W and $name !~ /[A-Z]/;
	foreach ( @{$validtype{$lastattr{type}}} ) {
		no strict 'refs';
		*{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
	}
	%lastattr = ();
}

sub AUTOLOAD {
	return if $AUTOLOAD =~ /::DESTROY$/;
	my ($class) = $AUTOLOAD =~ m/(.*)::/g;
	$AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
	    croak "Can't locate class method '$AUTOLOAD' via package '$class'";
	croak "Attribute handler '$2' doesn't handle $1 attributes";
}

my $builtin = $] ge '5.027000'
    ? qr/lvalue|method|shared/
    : qr/lvalue|method|locked|shared|unique/;

sub _gen_handler_AH_() {
	return sub {
	    _resolve_lastattr if _delayed_name_resolution;
	    my ($pkg, $ref, @attrs) = @_;
	    my (undef, $filename, $linenum) = caller 2;
	    foreach (@attrs) {
		my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
		if ($attr eq 'ATTR') {
			no strict 'refs';
			$data ||= "ANY";
			$raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
			$phase{$ref}{BEGIN} = 1
				if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
			$phase{$ref}{INIT} = 1
				if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
			$phase{$ref}{END} = 1
				if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
			$phase{$ref}{CHECK} = 1
				if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
				|| ! keys %{$phase{$ref}};
			# Added for cleanup to not pollute next call.
			(%lastattr = ()),
			croak "Can't have two ATTR specifiers on one subroutine"
				if keys %lastattr;
			croak "Bad attribute type: ATTR($data)"
				unless $validtype{$data};
			%lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
			_resolve_lastattr unless _delayed_name_resolution;
		}
		else {
			my $type = ref $ref;
			my $handler = $pkg->can("_ATTR_${type}_${attr}");
			next unless $handler;
		        my $decl = [$pkg, $ref, $attr, $data,
				    $raw{$handler}, $phase{$handler}, $filename, $linenum];
			foreach my $gphase (@global_phases) {
			    _apply_handler_AH_($decl,$gphase)
				if $global_phases{$gphase} <= $global_phase;
			}
			if ($global_phase != 0) {
				# if _gen_handler_AH_ is being called after 
				# CHECK it's for a lexical, so make sure
				# it didn't want to run anything later
			
				local $Carp::CarpLevel = 2;
				carp "Won't be able to apply END handler"
					if $phase{$handler}{END};
			}
			else {
				push @declarations, $decl
			}
		}
		$_ = undef;
	    }
	    return grep {defined && !/$builtin/} @attrs;
	}
}

{