diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/AutoSplit.pm | 14 | ||||
| -rw-r--r-- | lib/SelfLoader.pm | 10 | ||||
| -rw-r--r-- | lib/attributes.pm | 379 |
3 files changed, 399 insertions, 4 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 33c0b9a03d..feecd58bf1 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -11,7 +11,7 @@ use vars qw( $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime ); -$VERSION = "1.0303"; +$VERSION = "1.0304"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -147,6 +147,13 @@ if (defined (&Dos::UseLFN)) { } my $Is_VMS = ($^O eq 'VMS'); +# allow checking for valid ': attrlist' attachments +my $nested; +$nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x; +my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) [\s,]* }x; +my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; + + sub autosplit{ my($file, $autodir, $keep, $ckal, $ckmt) = @_; @@ -289,7 +296,7 @@ sub autosplit_file { if (/^package\s+([\w:]+)\s*;/) { $this_package = $def_package = $1; } - if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { + if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { print OUT "# end of $last_package\::$subname\n1;\n" if $last_package; $subname = $1; @@ -459,3 +466,6 @@ sub test6 { return join ":", __FILE__,__LINE__; } package Yet::Another::AutoSplit; sub testtesttesttest4_1 ($) { "another test 4\n"; } sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } +package Yet::More::Attributes; +sub test_a1 ($) : locked { 1; } +sub test_a2 : locked { 1; } diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm index c4e9175a79..4672ac49da 100644 --- a/lib/SelfLoader.pm +++ b/lib/SelfLoader.pm @@ -3,12 +3,18 @@ package SelfLoader; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(AUTOLOAD); -$VERSION = "1.08"; +$VERSION = "1.09"; sub Version {$VERSION} $DEBUG = 0; my %Cache; # private cache for all SelfLoader's client packages +# allow checking for valid ': attrlist' attachments +my $nested; +$nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x; +my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) [\s,]* }x; +my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; + sub croak { require Carp; goto &Carp::croak } AUTOLOAD { @@ -50,7 +56,7 @@ sub _load_stubs { local($/) = "\n"; while(defined($line = <$fh>) and $line !~ m/^__END__/) { - if ($line =~ m/^sub\s+([\w:]+)\s*(\([\\\$\@\%\&\*\;]*\))?/) { + if ($line =~ m/^sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$attr_list)?)/) { push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); $protoype = $2; @lines = ($line); diff --git a/lib/attributes.pm b/lib/attributes.pm new file mode 100644 index 0000000000..e49204fc76 --- /dev/null +++ b/lib/attributes.pm @@ -0,0 +1,379 @@ +package attributes; + +$VERSION = 0.01; + +#@EXPORT_OK = qw(get reftype); +#@EXPORT = (); + +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 ; +#sub _warn_reserved () ; +# +# The extra trips through newATTRSUB in the interpreter wipe out any savings +# from avoiding the BEGIN block. Just do the bootstrap now. +BEGIN { bootstrap } + +sub import { + @_ > 2 && ref $_[2] or + croak 'Usage: use '.__PACKAGE__.' $home_stash, $ref, @attrlist'; + 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, @attrs); + if (!@badattrs && @pkgattrs) { + return unless _warn_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 export { +# require Exporter; +# goto &Exporter::import; +#} +# +#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 ; + my $s = sub : method { ... }; + + use attributes (); # optional, to get subroutine declarations + my @attrlist = attributes::get(\&foo); + +=head1 DESCRIPTION + +Subroutine declarations and definitions may optionally have attribute lists +associated with them. (Variable C<my> 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, 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 __PACKAGE__, \$x, 'Bent'; + use attributes __PACKAGE__, \@y, 'Bent'; + use attributes __PACKAGE__, \%z, 'Bent'; + +Yes, that's three invocations. + +B<WARNING>: attribute declarations for variables are an I<experimental> +feature. The semantics of such declarations could change or be removed +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 attributes happens at compile time. An attempt to set +an unrecognized attribute is a fatal error. (The error is trappable, but +it still stops the compilation within that C<eval>.) 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<use warnings 'reserved'>. + +=head2 Built-in Attributes + +The following are the built-in attributes for subroutines: + +=over 4 + +=item locked + +Setting this attribute is only meaningful when the subroutine or +method is to be called by multiple threads. When set on a method +subroutine (i.e., one marked with the B<method> attribute below), +Perl ensures that any invocation of it implicitly locks its first +argument before execution. When set on a non-method subroutine, +Perl ensures that a lock is taken on the subroutine itself before +execution. The semantics of the lock are exactly those of one +explicitly taken with the C<lock> operator immediately after the +subroutine is entered. + +=item method + +Indicates that the referenced subroutine is a method. +This has a meaning when taken together with the B<locked> attribute, +as described there. It also means that a subroutine so marked +will not trigger the "Ambiguous call resolved as CORE::%s" warning. + +=back + +There are no built-in attributes for anything other than subroutines. + +=head2 Available Subroutines + +The following subroutines are available for general use once this module +has been loaded: + +=over 4 + +=item get + +This routine expects a single parameter--a reference to a +subroutine or variable. It returns a list of attributes, which may be +empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>) +to raise a fatal exception. If it can find an appropriate package name +for a class method lookup, it will include the results from a +C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in +L"Package-specific Attribute Handling"> below. +Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned. + +=item reftype + +This routine expects a single parameter--a reference to a subroutine or +variable. It returns the built-in type of the referenced variable, +ignoring any package into which it might have been blessed. +This can be useful for determining the I<type> value which forms part of +the method names described in L"Package-specific Attribute Handling"> below. + +=back + +Note that these routines are I<not> exported. This is primarily because +the C<use> mechanism which would normally import them is already in use +by Perl itself to implement the C<sub : attributes> syntax. + +=head2 Package-specific Attribute Handling + +B<WARNING>: the mechanisms described here are still experimental. Do not +rely on the current implementation. In particular, there is no provision +for applying package attributes to 'cloned' copies of subroutines used as +closures. (See L<perlref/"Making References"> for information on closures.) +Package-specific attribute handling may change incompatibly in a future +release. + +When an attribute list is present in a declaration, a check is made to see +whether an attribute 'modify' handler is present in the appropriate package +(or its @ISA inheritance tree). Similarly, when C<attributes::get> is +called on a valid reference, a check is made for an appropriate attribute +'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package" +determination works. + +The handler names are based on the underlying type of the variable being +declared or of the reference passed. Because these attributes are +associated with subroutine or variable declarations, this deliberately +ignores any possibility of being blessed into some package. Thus, a +subroutine declaration uses "CODE" as its I<type>, and even a blessed +hash reference uses "HASH" as its I<type>. + +The class methods invoked for modifying and fetching are these: + +=over 4 + +=item FETCH_I<type>_ATTRIBUTES + +This method receives a single argument, which is a reference to the +variable or subroutine for which package-defined attributes are desired. +The expected return value is a list of associated attributes. +This list may be empty. + +=item MODIFY_I<type>_ATTRIBUTES + +This method is called with two fixed arguments, followed by the list of +attributes from the relevant declaration. The two fixed arguments are +the relevant package name and a reference to the declared subroutine or +variable. The expected return value as a list of attributes which were +not recognized by this handler. Note that this allows for a derived class +to delegate a call to its base class, and then only examine the attributes +which the base class didn't already handle for it. + +The call to this method is currently made I<during> the processing of the +declaration. In particular, this means that a subroutine reference will +probably be for an undefined subroutine, even if this declaration is +actually part of the definition. + +=back + +Calling C<attributes::get()> from within the scope of a null package +declaration C<package ;> for an unblessed variable reference will +not provide any starting package name for the 'fetch' method lookup. +Thus, this circumstance will not result in a method call for package-defined +attributes. A named subroutine knows to which symbol table entry it belongs +(or originally belonged), and it will use the corresponding package. +An anonymous subroutine knows the package name into which it was compiled +(unless it was also compiled with a null package declaration), and so it +will use that package name. + +=head2 Syntax of Attribute Lists + +An attribute list is a sequence of attribute specifications, separated by +whitespace, commas, or both. Each attribute specification is a simple +name, optionally followed by a parenthesised parameter list. +If such a parameter list is present, it is scanned past as for the rules +for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.) +The parameter list is passed as it was found, however, and not as per C<q()>. + +Some examples of syntactically valid attribute lists: + + switch(10,foo(7,3)) , , expensive + Ugly('\(") , Bad + _5x5 + locked method + +Some examples of syntactically invalid attribute lists (with annotation): + + switch(10,foo() # ()-string not balanced + Ugly('(') # ()-string not balanced + 5x5 # "5x5" not a valid identifier + Y2::north # "Y2::north" not a simple identifier + foo + bar # "+" neither a comma nor whitespace + +=head1 EXAMPLES + +Here are some samples of syntactically valid declarations, with annotation +as to how they resolve internally into C<use attributes> invocations by +perl. These examples are primarily useful to see how the "appropriate +package" is found for the possible method lookups for package-defined +attributes. + +=over 4 + +=item 1. + +Code: + + package Canine; + package Dog; + my Canine $spot : Watchful ; + +Effect: + + use attributes Canine => \$spot, "Watchful"; + +=item 2. + +Code: + + package Felis; + my $cat : Nervous; + +Effect: + + use attributes Felis => \$cat, "Nervous"; + +=item 3. + +Code: + + package X; + sub foo : locked ; + +Effect: + + use attributes X => \&foo, "locked"; + +=item 4. + +Code: + + package X; + sub Y::x : locked { 1 } + +Effect: + + use attributes Y => \&Y::x, "locked"; + +=item 5. + +Code: + + package X; + sub foo { 1 } + + package Y; + BEGIN { *bar = \&X::foo; } + + package Z; + sub Y::bar : locked ; + +Effect: + + use attributes X => \&X::foo, "locked"; + +=back + +This last example is purely for purposes of completeness. You should not +be trying to mess with the attributes of something in a package that's +not your own. + +=head1 SEE ALSO + +L<perlsub/"Private Variables via my()"> and +L<perlsub/"Subroutine Attributes"> for details on the basic declarations; +L<attrs> for the obsolescent form of subroutine attribute specification +which this module replaces; +L<perlfunc/use> for details on the normal invocation mechanism. + +=cut + |