sub : attrlist

To: Mailing list Perl5 <perl5-porters@perl.org>
Message-Id: <199908290702.DAA32191@Orb.Nashua.NH.US>

p4raw-id: //depot/cfgperl@4043

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
+