package attributes;
our $VERSION = 0.09;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
use strict;
sub croak {
require Carp;
goto &Carp::croak;
}
sub carp {
require Carp;
goto &Carp::carp;
}
## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{}
#sub reftype ($) ;
#sub _fetch_attrs ($) ;
#sub _guess_stash ($) ;
#sub _modify_attrs ;
#
# The extra trips through newATTRSUB in the interpreter wipe out any savings
# from avoiding the BEGIN block. Just do the bootstrap now.
BEGIN { bootstrap attributes }
sub import {
@_ > 2 && ref $_[2] or do {
require Exporter;
goto &Exporter::import;
};
my (undef,$home_stash,$svref,@attrs) = @_;
my $svtype = uc reftype($svref);
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
if defined $home_stash && $home_stash ne '';
my @badattrs;
if ($pkgmeth) {
my @pkgattrs = _modify_attrs($svref, @attrs);
@badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
if (!@badattrs && @pkgattrs) {
require warnings;
return unless warnings::enabled('reserved');
@pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
if (@pkgattrs) {
for my $attr (@pkgattrs) {
$attr =~ s/\(.+\z//s;
}
my $s = ((@pkgattrs == 1) ? '' : 's');
carp "$svtype package attribute$s " .
"may clash with future reserved word$s: " .
join(' : ' , @pkgattrs);
}
}
}
else {
@badattrs = _modify_attrs($svref, @attrs);
}
if (@badattrs) {
croak "Invalid $svtype attribute" .
(( @badattrs == 1 ) ? '' : 's') .
": " .
join(' : ', @badattrs);
}
}
sub get ($) {
@_ == 1 && ref $_[0] or
croak 'Usage: '.__PACKAGE__.'::get $ref';
my $svref = shift;
my $svtype = uc reftype $svref;
my $stash = _guess_stash $svref;
$stash = caller unless defined $stash;
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
if defined $stash && $stash ne '';
return $pkgmeth ?
(_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
(_fetch_attrs($svref))
;
}
sub require_version { goto &UNIVERSAL::VERSION }
1;
__END__
#The POD goes here
=head1 NAME
attributes - get/set subroutine or variable attributes
=head1 SYNOPSIS
sub foo : method ;
my ($x,@y,%z) : Bent = 1;
my $s = sub : method { ... };
use attributes (); # optional, to get subroutine declarations
my @attrlist = attributes::get(\&foo);
use attributes 'get'; # import the attributes::get subroutine
my @attrlist = get \&foo;
=head1 DESCRIPTION
Subroutine declarations and definitions may optionally have attribute lists
associated with them. (Variable C declarations also may, but see the
warning below.) Perl handles these declarations by passing some information
about the call site and the thing being declared along with the attribute
list to this module. In particular, the first example above is equivalent to
the following:
use attributes __PACKAGE__, \&foo, 'method';
The second example in the synopsis does something equivalent to this:
use attributes ();
my ($x,@y,%z);
attributes::->import(__PACKAGE__, \$x, 'Bent');
attributes::->import(__PACKAGE__, \@y, 'Bent');
attributes::->import(__PACKAGE__, \%z, 'Bent');
($x,@y,%z) = 1;
Yes, that's a lot of expansion.
B: attribute declarations for variables are still evolving.
The semantics and interfaces of such declarations could change in
future versions. They are present for purposes of experimentation
with what the semantics ought to be. Do not rely on the current
implementation of this feature.
There are only a few attributes currently handled by Perl itself (or
directly by this module, depending on how you look at it.) However,
package-specific attributes are allowed by an extension mechanism.
(See L<"Package-specific Attribute Handling"> below.)
The setting of subroutine attributes happens at compile time.
Variable attributes in C declarations are also applied at compile time.
However, C variables get their attributes applied at run-time.
This means that you have to I the run-time component of the C
before those attributes will get applied. For example:
my $x : Bent = 42 if 0;
will neither assign 42 to $x I will it apply the C attribute
to the variable.
An attempt to set an unrecognized attribute is a fatal error. (The
error is trappable, but it still stops the compilation within that
C.) Setting an attribute with a name that's all lowercase
letters that's not a built-in attribute (such as "foo") will result in
a warning with B<-w> or C