1package attributes; 2 3our $VERSION = 0.27; 4 5@EXPORT_OK = qw(get reftype); 6@EXPORT = (); 7%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); 8 9use strict; 10 11sub croak { 12 require Carp; 13 goto &Carp::croak; 14} 15 16sub carp { 17 require Carp; 18 goto &Carp::carp; 19} 20 21my %deprecated; 22$deprecated{CODE} = qr/\A-?(locked)\z/; 23$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} 24 = qr/\A-?(unique)\z/; 25 26my %msg = ( 27 lvalue => 'lvalue attribute applied to already-defined subroutine', 28 -lvalue => 'lvalue attribute removed from already-defined subroutine', 29 const => 'Useless use of attribute "const"', 30); 31 32sub _modify_attrs_and_deprecate { 33 my $svtype = shift; 34 # Now that we've removed handling of locked from the XS code, we need to 35 # remove it here, else it ends up in @badattrs. (If we do the deprecation in 36 # XS, we can't control the warning based on *our* caller's lexical settings, 37 # and the warned line is in this package) 38 grep { 39 $deprecated{$svtype} && /$deprecated{$svtype}/ ? do { 40 require warnings; 41 warnings::warnif('deprecated', "Attribute \"$1\" is deprecated"); 42 0; 43 } : $svtype eq 'CODE' && exists $msg{$_} ? do { 44 require warnings; 45 warnings::warnif( 46 'misc', 47 $msg{$_} 48 ); 49 0; 50 } : 1 51 } _modify_attrs(@_); 52} 53 54sub import { 55 @_ > 2 && ref $_[2] or do { 56 require Exporter; 57 goto &Exporter::import; 58 }; 59 my (undef,$home_stash,$svref,@attrs) = @_; 60 61 my $svtype = uc reftype($svref); 62 my $pkgmeth; 63 $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES") 64 if defined $home_stash && $home_stash ne ''; 65 my @badattrs; 66 if ($pkgmeth) { 67 my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); 68 @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs); 69 if (!@badattrs && @pkgattrs) { 70 require warnings; 71 return unless warnings::enabled('reserved'); 72 @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs; 73 if (@pkgattrs) { 74 for my $attr (@pkgattrs) { 75 $attr =~ s/\(.+\z//s; 76 } 77 my $s = ((@pkgattrs == 1) ? '' : 's'); 78 carp "$svtype package attribute$s " . 79 "may clash with future reserved word$s: " . 80 join(' : ' , @pkgattrs); 81 } 82 } 83 } 84 else { 85 @badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); 86 } 87 if (@badattrs) { 88 croak "Invalid $svtype attribute" . 89 (( @badattrs == 1 ) ? '' : 's') . 90 ": " . 91 join(' : ', @badattrs); 92 } 93} 94 95sub get ($) { 96 @_ == 1 && ref $_[0] or 97 croak 'Usage: '.__PACKAGE__.'::get $ref'; 98 my $svref = shift; 99 my $svtype = uc reftype($svref); 100 my $stash = _guess_stash($svref); 101 $stash = caller unless defined $stash; 102 my $pkgmeth; 103 $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") 104 if defined $stash && $stash ne ''; 105 return $pkgmeth ? 106 (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : 107 (_fetch_attrs($svref)) 108 ; 109} 110 111sub require_version { goto &UNIVERSAL::VERSION } 112 113require XSLoader; 114XSLoader::load(); 115 1161; 117__END__ 118#The POD goes here 119 120=head1 NAME 121 122attributes - get/set subroutine or variable attributes 123 124=head1 SYNOPSIS 125 126 sub foo : method ; 127 my ($x,@y,%z) : Bent = 1; 128 my $s = sub : method { ... }; 129 130 use attributes (); # optional, to get subroutine declarations 131 my @attrlist = attributes::get(\&foo); 132 133 use attributes 'get'; # import the attributes::get subroutine 134 my @attrlist = get \&foo; 135 136=head1 DESCRIPTION 137 138Subroutine declarations and definitions may optionally have attribute lists 139associated with them. (Variable C<my> declarations also may, but see the 140warning below.) Perl handles these declarations by passing some information 141about the call site and the thing being declared along with the attribute 142list to this module. In particular, the first example above is equivalent to 143the following: 144 145 use attributes __PACKAGE__, \&foo, 'method'; 146 147The second example in the synopsis does something equivalent to this: 148 149 use attributes (); 150 my ($x,@y,%z); 151 attributes::->import(__PACKAGE__, \$x, 'Bent'); 152 attributes::->import(__PACKAGE__, \@y, 'Bent'); 153 attributes::->import(__PACKAGE__, \%z, 'Bent'); 154 ($x,@y,%z) = 1; 155 156Yes, that's a lot of expansion. 157 158B<WARNING>: attribute declarations for variables are still evolving. 159The semantics and interfaces of such declarations could change in 160future versions. They are present for purposes of experimentation 161with what the semantics ought to be. Do not rely on the current 162implementation of this feature. 163 164There are only a few attributes currently handled by Perl itself (or 165directly by this module, depending on how you look at it.) However, 166package-specific attributes are allowed by an extension mechanism. 167(See L<"Package-specific Attribute Handling"> below.) 168 169The setting of subroutine attributes happens at compile time. 170Variable attributes in C<our> declarations are also applied at compile time. 171However, C<my> variables get their attributes applied at run-time. 172This means that you have to I<reach> the run-time component of the C<my> 173before those attributes will get applied. For example: 174 175 my $x : Bent = 42 if 0; 176 177will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute 178to the variable. 179 180An attempt to set an unrecognized attribute is a fatal error. (The 181error is trappable, but it still stops the compilation within that 182C<eval>.) Setting an attribute with a name that's all lowercase 183letters that's not a built-in attribute (such as "foo") will result in 184a warning with B<-w> or C<use warnings 'reserved'>. 185 186=head2 What C<import> does 187 188In the description it is mentioned that 189 190 sub foo : method; 191 192is equivalent to 193 194 use attributes __PACKAGE__, \&foo, 'method'; 195 196As you might know this calls the C<import> function of C<attributes> at compile 197time with these parameters: 'attributes', the caller's package name, the reference 198to the code and 'method'. 199 200 attributes->import( __PACKAGE__, \&foo, 'method' ); 201 202So you want to know what C<import> actually does? 203 204First of all C<import> gets the type of the third parameter ('CODE' in this case). 205C<attributes.pm> checks if there is a subroutine called C<< MODIFY_<reftype>_ATTRIBUTES >> 206in the caller's namespace (here: 'main'). In this case a 207subroutine C<MODIFY_CODE_ATTRIBUTES> is required. Then this 208method is called to check if you have used a "bad attribute". 209The subroutine call in this example would look like 210 211 MODIFY_CODE_ATTRIBUTES( 'main', \&foo, 'method' ); 212 213C<< MODIFY_<reftype>_ATTRIBUTES >> has to return a list of all "bad attributes". 214If there are any bad attributes C<import> croaks. 215 216(See L<"Package-specific Attribute Handling"> below.) 217 218=head2 Built-in Attributes 219 220The following are the built-in attributes for subroutines: 221 222=over 4 223 224=item lvalue 225 226Indicates that the referenced subroutine is a valid lvalue and can 227be assigned to. The subroutine must return a modifiable value such 228as a scalar variable, as described in L<perlsub>. 229 230This module allows one to set this attribute on a subroutine that is 231already defined. For Perl subroutines (XSUBs are fine), it may or may not 232do what you want, depending on the code inside the subroutine, with details 233subject to change in future Perl versions. You may run into problems with 234lvalue context not being propagated properly into the subroutine, or maybe 235even assertion failures. For this reason, a warning is emitted if warnings 236are enabled. In other words, you should only do this if you really know 237what you are doing. You have been warned. 238 239=item method 240 241Indicates that the referenced subroutine 242is a method. A subroutine so marked 243will not trigger the "Ambiguous call resolved as CORE::%s" warning. 244 245=item prototype(..) 246 247The "prototype" attribute is an alternate means of specifying a prototype 248on a sub. The desired prototype is within the parens. 249 250The prototype from the attribute is assigned to the sub immediately after 251the prototype from the sub, which means that if both are declared at the 252same time, the traditionally defined prototype is ignored. In other words, 253C<sub foo($$) : prototype(@) {}> is indistinguishable from C<sub foo(@){}>. 254 255If illegalproto warnings are enabled, the prototype declared inside this 256attribute will be sanity checked at compile time. 257 258=item locked 259 260The "locked" attribute is deprecated, and has no effect in 5.10.0 and later. 261It was used as part of the now-removed "Perl 5.005 threads". 262 263=item const 264 265This experimental attribute, introduced in Perl 5.22, only applies to 266anonymous subroutines. It causes the subroutine to be called as soon as 267the C<sub> expression is evaluated. The return value is captured and 268turned into a constant subroutine. 269 270=back 271 272The following are the built-in attributes for variables: 273 274=over 4 275 276=item shared 277 278Indicates that the referenced variable can be shared across different threads 279when used in conjunction with the L<threads> and L<threads::shared> modules. 280 281=item unique 282 283The "unique" attribute is deprecated, and has no effect in 5.10.0 and later. 284It used to indicate that a single copy of an C<our> variable was to be used by 285all interpreters should the program happen to be running in a 286multi-interpreter environment. 287 288=back 289 290=head2 Available Subroutines 291 292The following subroutines are available for general use once this module 293has been loaded: 294 295=over 4 296 297=item get 298 299This routine expects a single parameter--a reference to a 300subroutine or variable. It returns a list of attributes, which may be 301empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>) 302to raise a fatal exception. If it can find an appropriate package name 303for a class method lookup, it will include the results from a 304C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in 305L<"Package-specific Attribute Handling"> below. 306Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned. 307 308=item reftype 309 310This routine expects a single parameter--a reference to a subroutine or 311variable. It returns the built-in type of the referenced variable, 312ignoring any package into which it might have been blessed. 313This can be useful for determining the I<type> value which forms part of 314the method names described in L<"Package-specific Attribute Handling"> below. 315 316=back 317 318Note that these routines are I<not> exported by default. 319 320=head2 Package-specific Attribute Handling 321 322B<WARNING>: the mechanisms described here are still experimental. Do not 323rely on the current implementation. In particular, there is no provision 324for applying package attributes to 'cloned' copies of subroutines used as 325closures. (See L<perlref/"Making References"> for information on closures.) 326Package-specific attribute handling may change incompatibly in a future 327release. 328 329When an attribute list is present in a declaration, a check is made to see 330whether an attribute 'modify' handler is present in the appropriate package 331(or its @ISA inheritance tree). Similarly, when C<attributes::get> is 332called on a valid reference, a check is made for an appropriate attribute 333'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package" 334determination works. 335 336The handler names are based on the underlying type of the variable being 337declared or of the reference passed. Because these attributes are 338associated with subroutine or variable declarations, this deliberately 339ignores any possibility of being blessed into some package. Thus, a 340subroutine declaration uses "CODE" as its I<type>, and even a blessed 341hash reference uses "HASH" as its I<type>. 342 343The class methods invoked for modifying and fetching are these: 344 345=over 4 346 347=item FETCH_I<type>_ATTRIBUTES 348 349This method is called with two arguments: the relevant package name, 350and a reference to a variable or subroutine for which package-defined 351attributes are desired. The expected return value is a list of 352associated attributes. This list may be empty. 353 354=item MODIFY_I<type>_ATTRIBUTES 355 356This method is called with two fixed arguments, followed by the list of 357attributes from the relevant declaration. The two fixed arguments are 358the relevant package name and a reference to the declared subroutine or 359variable. The expected return value is a list of attributes which were 360not recognized by this handler. Note that this allows for a derived class 361to delegate a call to its base class, and then only examine the attributes 362which the base class didn't already handle for it. 363 364The call to this method is currently made I<during> the processing of the 365declaration. In particular, this means that a subroutine reference will 366probably be for an undefined subroutine, even if this declaration is 367actually part of the definition. 368 369=back 370 371Calling C<attributes::get()> from within the scope of a null package 372declaration C<package ;> for an unblessed variable reference will 373not provide any starting package name for the 'fetch' method lookup. 374Thus, this circumstance will not result in a method call for package-defined 375attributes. A named subroutine knows to which symbol table entry it belongs 376(or originally belonged), and it will use the corresponding package. 377An anonymous subroutine knows the package name into which it was compiled 378(unless it was also compiled with a null package declaration), and so it 379will use that package name. 380 381=head2 Syntax of Attribute Lists 382 383An attribute list is a sequence of attribute specifications, separated by 384whitespace or a colon (with optional whitespace). 385Each attribute specification is a simple 386name, optionally followed by a parenthesised parameter list. 387If such a parameter list is present, it is scanned past as for the rules 388for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.) 389The parameter list is passed as it was found, however, and not as per C<q()>. 390 391Some examples of syntactically valid attribute lists: 392 393 switch(10,foo(7,3)) : expensive 394 Ugly('\(") :Bad 395 _5x5 396 lvalue method 397 398Some examples of syntactically invalid attribute lists (with annotation): 399 400 switch(10,foo() # ()-string not balanced 401 Ugly('(') # ()-string not balanced 402 5x5 # "5x5" not a valid identifier 403 Y2::north # "Y2::north" not a simple identifier 404 foo + bar # "+" neither a colon nor whitespace 405 406=head1 EXPORTS 407 408=head2 Default exports 409 410None. 411 412=head2 Available exports 413 414The routines C<get> and C<reftype> are exportable. 415 416=head2 Export tags defined 417 418The C<:ALL> tag will get all of the above exports. 419 420=head1 EXAMPLES 421 422Here are some samples of syntactically valid declarations, with annotation 423as to how they resolve internally into C<use attributes> invocations by 424perl. These examples are primarily useful to see how the "appropriate 425package" is found for the possible method lookups for package-defined 426attributes. 427 428=over 4 429 430=item 1. 431 432Code: 433 434 package Canine; 435 package Dog; 436 my Canine $spot : Watchful ; 437 438Effect: 439 440 use attributes (); 441 attributes::->import(Canine => \$spot, "Watchful"); 442 443=item 2. 444 445Code: 446 447 package Felis; 448 my $cat : Nervous; 449 450Effect: 451 452 use attributes (); 453 attributes::->import(Felis => \$cat, "Nervous"); 454 455=item 3. 456 457Code: 458 459 package X; 460 sub foo : lvalue ; 461 462Effect: 463 464 use attributes X => \&foo, "lvalue"; 465 466=item 4. 467 468Code: 469 470 package X; 471 sub Y::x : lvalue { 1 } 472 473Effect: 474 475 use attributes Y => \&Y::x, "lvalue"; 476 477=item 5. 478 479Code: 480 481 package X; 482 sub foo { 1 } 483 484 package Y; 485 BEGIN { *bar = \&X::foo; } 486 487 package Z; 488 sub Y::bar : lvalue ; 489 490Effect: 491 492 use attributes X => \&X::foo, "lvalue"; 493 494=back 495 496This last example is purely for purposes of completeness. You should not 497be trying to mess with the attributes of something in a package that's 498not your own. 499 500=head1 MORE EXAMPLES 501 502=over 4 503 504=item 1. 505 506 sub MODIFY_CODE_ATTRIBUTES { 507 my ($class,$code,@attrs) = @_; 508 509 my $allowed = 'MyAttribute'; 510 my @bad = grep { $_ ne $allowed } @attrs; 511 512 return @bad; 513 } 514 515 sub foo : MyAttribute { 516 print "foo\n"; 517 } 518 519This example runs. At compile time 520C<MODIFY_CODE_ATTRIBUTES> is called. In that 521subroutine, we check if any attribute is disallowed and we return a list of 522these "bad attributes". 523 524As we return an empty list, everything is fine. 525 526=item 2. 527 528 sub MODIFY_CODE_ATTRIBUTES { 529 my ($class,$code,@attrs) = @_; 530 531 my $allowed = 'MyAttribute'; 532 my @bad = grep{ $_ ne $allowed }@attrs; 533 534 return @bad; 535 } 536 537 sub foo : MyAttribute Test { 538 print "foo\n"; 539 } 540 541This example is aborted at compile time as we use the attribute "Test" which 542isn't allowed. C<MODIFY_CODE_ATTRIBUTES> 543returns a list that contains a single 544element ('Test'). 545 546=back 547 548=head1 SEE ALSO 549 550L<perlsub/"Private Variables via my()"> and 551L<perlsub/"Subroutine Attributes"> for details on the basic declarations; 552L<perlfunc/use> for details on the normal invocation mechanism. 553 554=cut 555