| 1 | package attributes; |
| 2 | |
| 3 | our $VERSION = 0.06; |
| 4 | |
| 5 | @EXPORT_OK = qw(get reftype); |
| 6 | @EXPORT = (); |
| 7 | %EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); |
| 8 | |
| 9 | use strict; |
| 10 | |
| 11 | sub croak { |
| 12 | require Carp; |
| 13 | goto &Carp::croak; |
| 14 | } |
| 15 | |
| 16 | sub carp { |
| 17 | require Carp; |
| 18 | goto &Carp::carp; |
| 19 | } |
| 20 | |
| 21 | ## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{} |
| 22 | #sub reftype ($) ; |
| 23 | #sub _fetch_attrs ($) ; |
| 24 | #sub _guess_stash ($) ; |
| 25 | #sub _modify_attrs ; |
| 26 | #sub _warn_reserved () ; |
| 27 | # |
| 28 | # The extra trips through newATTRSUB in the interpreter wipe out any savings |
| 29 | # from avoiding the BEGIN block. Just do the bootstrap now. |
| 30 | BEGIN { bootstrap attributes } |
| 31 | |
| 32 | sub import { |
| 33 | @_ > 2 && ref $_[2] or do { |
| 34 | require Exporter; |
| 35 | goto &Exporter::import; |
| 36 | }; |
| 37 | my (undef,$home_stash,$svref,@attrs) = @_; |
| 38 | |
| 39 | my $svtype = uc reftype($svref); |
| 40 | my $pkgmeth; |
| 41 | $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES") |
| 42 | if defined $home_stash && $home_stash ne ''; |
| 43 | my @badattrs; |
| 44 | if ($pkgmeth) { |
| 45 | my @pkgattrs = _modify_attrs($svref, @attrs); |
| 46 | @badattrs = $pkgmeth->($home_stash, $svref, @attrs); |
| 47 | if (!@badattrs && @pkgattrs) { |
| 48 | return unless _warn_reserved; |
| 49 | @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs; |
| 50 | if (@pkgattrs) { |
| 51 | for my $attr (@pkgattrs) { |
| 52 | $attr =~ s/\(.+\z//s; |
| 53 | } |
| 54 | my $s = ((@pkgattrs == 1) ? '' : 's'); |
| 55 | carp "$svtype package attribute$s " . |
| 56 | "may clash with future reserved word$s: " . |
| 57 | join(' : ' , @pkgattrs); |
| 58 | } |
| 59 | } |
| 60 | } |
| 61 | else { |
| 62 | @badattrs = _modify_attrs($svref, @attrs); |
| 63 | } |
| 64 | if (@badattrs) { |
| 65 | croak "Invalid $svtype attribute" . |
| 66 | (( @badattrs == 1 ) ? '' : 's') . |
| 67 | ": " . |
| 68 | join(' : ', @badattrs); |
| 69 | } |
| 70 | } |
| 71 | |
| 72 | sub get ($) { |
| 73 | @_ == 1 && ref $_[0] or |
| 74 | croak 'Usage: '.__PACKAGE__.'::get $ref'; |
| 75 | my $svref = shift; |
| 76 | my $svtype = uc reftype $svref; |
| 77 | my $stash = _guess_stash $svref; |
| 78 | $stash = caller unless defined $stash; |
| 79 | my $pkgmeth; |
| 80 | $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") |
| 81 | if defined $stash && $stash ne ''; |
| 82 | return $pkgmeth ? |
| 83 | (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : |
| 84 | (_fetch_attrs($svref)) |
| 85 | ; |
| 86 | } |
| 87 | |
| 88 | sub require_version { goto &UNIVERSAL::VERSION } |
| 89 | |
| 90 | 1; |
| 91 | __END__ |
| 92 | #The POD goes here |
| 93 | |
| 94 | =head1 NAME |
| 95 | |
| 96 | attributes - get/set subroutine or variable attributes |
| 97 | |
| 98 | =head1 SYNOPSIS |
| 99 | |
| 100 | sub foo : method ; |
| 101 | my ($x,@y,%z) : Bent = 1; |
| 102 | my $s = sub : method { ... }; |
| 103 | |
| 104 | use attributes (); # optional, to get subroutine declarations |
| 105 | my @attrlist = attributes::get(\&foo); |
| 106 | |
| 107 | use attributes 'get'; # import the attributes::get subroutine |
| 108 | my @attrlist = get \&foo; |
| 109 | |
| 110 | =head1 DESCRIPTION |
| 111 | |
| 112 | Subroutine declarations and definitions may optionally have attribute lists |
| 113 | associated with them. (Variable C<my> declarations also may, but see the |
| 114 | warning below.) Perl handles these declarations by passing some information |
| 115 | about the call site and the thing being declared along with the attribute |
| 116 | list to this module. In particular, the first example above is equivalent to |
| 117 | the following: |
| 118 | |
| 119 | use attributes __PACKAGE__, \&foo, 'method'; |
| 120 | |
| 121 | The second example in the synopsis does something equivalent to this: |
| 122 | |
| 123 | use attributes (); |
| 124 | my ($x,@y,%z); |
| 125 | attributes::->import(__PACKAGE__, \$x, 'Bent'); |
| 126 | attributes::->import(__PACKAGE__, \@y, 'Bent'); |
| 127 | attributes::->import(__PACKAGE__, \%z, 'Bent'); |
| 128 | ($x,@y,%z) = 1; |
| 129 | |
| 130 | Yes, that's a lot of expansion. |
| 131 | |
| 132 | B<WARNING>: attribute declarations for variables are still evolving. |
| 133 | The semantics and interfaces of such declarations could change in |
| 134 | future versions. They are present for purposes of experimentation |
| 135 | with what the semantics ought to be. Do not rely on the current |
| 136 | implementation of this feature. |
| 137 | |
| 138 | There are only a few attributes currently handled by Perl itself (or |
| 139 | directly by this module, depending on how you look at it.) However, |
| 140 | package-specific attributes are allowed by an extension mechanism. |
| 141 | (See L<"Package-specific Attribute Handling"> below.) |
| 142 | |
| 143 | The setting of subroutine attributes happens at compile time. |
| 144 | Variable attributes in C<our> declarations are also applied at compile time. |
| 145 | However, C<my> variables get their attributes applied at run-time. |
| 146 | This means that you have to I<reach> the run-time component of the C<my> |
| 147 | before those attributes will get applied. For example: |
| 148 | |
| 149 | my $x : Bent = 42 if 0; |
| 150 | |
| 151 | will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute |
| 152 | to the variable. |
| 153 | |
| 154 | An attempt to set an unrecognized attribute is a fatal error. (The |
| 155 | error is trappable, but it still stops the compilation within that |
| 156 | C<eval>.) Setting an attribute with a name that's all lowercase |
| 157 | letters that's not a built-in attribute (such as "foo") will result in |
| 158 | a warning with B<-w> or C<use warnings 'reserved'>. |
| 159 | |
| 160 | =head2 Built-in Attributes |
| 161 | |
| 162 | The following are the built-in attributes for subroutines: |
| 163 | |
| 164 | =over 4 |
| 165 | |
| 166 | =item locked |
| 167 | |
| 168 | B<5.005 threads only! The use of the "locked" attribute currently |
| 169 | only makes sense if you are using the deprecated "Perl 5.005 threads" |
| 170 | implementation of threads.> |
| 171 | |
| 172 | Setting this attribute is only meaningful when the subroutine or |
| 173 | method is to be called by multiple threads. When set on a method |
| 174 | subroutine (i.e., one marked with the B<method> attribute below), |
| 175 | Perl ensures that any invocation of it implicitly locks its first |
| 176 | argument before execution. When set on a non-method subroutine, |
| 177 | Perl ensures that a lock is taken on the subroutine itself before |
| 178 | execution. The semantics of the lock are exactly those of one |
| 179 | explicitly taken with the C<lock> operator immediately after the |
| 180 | subroutine is entered. |
| 181 | |
| 182 | =item method |
| 183 | |
| 184 | Indicates that the referenced subroutine is a method. |
| 185 | This has a meaning when taken together with the B<locked> attribute, |
| 186 | as described there. It also means that a subroutine so marked |
| 187 | will not trigger the "Ambiguous call resolved as CORE::%s" warning. |
| 188 | |
| 189 | =item lvalue |
| 190 | |
| 191 | Indicates that the referenced subroutine is a valid lvalue and can |
| 192 | be assigned to. The subroutine must return a modifiable value such |
| 193 | as a scalar variable, as described in L<perlsub>. |
| 194 | |
| 195 | =back |
| 196 | |
| 197 | For global variables there is C<unique> attribute: see L<perlfunc/our>. |
| 198 | |
| 199 | =head2 Available Subroutines |
| 200 | |
| 201 | The following subroutines are available for general use once this module |
| 202 | has been loaded: |
| 203 | |
| 204 | =over 4 |
| 205 | |
| 206 | =item get |
| 207 | |
| 208 | This routine expects a single parameter--a reference to a |
| 209 | subroutine or variable. It returns a list of attributes, which may be |
| 210 | empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>) |
| 211 | to raise a fatal exception. If it can find an appropriate package name |
| 212 | for a class method lookup, it will include the results from a |
| 213 | C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in |
| 214 | L<"Package-specific Attribute Handling"> below. |
| 215 | Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned. |
| 216 | |
| 217 | =item reftype |
| 218 | |
| 219 | This routine expects a single parameter--a reference to a subroutine or |
| 220 | variable. It returns the built-in type of the referenced variable, |
| 221 | ignoring any package into which it might have been blessed. |
| 222 | This can be useful for determining the I<type> value which forms part of |
| 223 | the method names described in L<"Package-specific Attribute Handling"> below. |
| 224 | |
| 225 | =back |
| 226 | |
| 227 | Note that these routines are I<not> exported by default. |
| 228 | |
| 229 | =head2 Package-specific Attribute Handling |
| 230 | |
| 231 | B<WARNING>: the mechanisms described here are still experimental. Do not |
| 232 | rely on the current implementation. In particular, there is no provision |
| 233 | for applying package attributes to 'cloned' copies of subroutines used as |
| 234 | closures. (See L<perlref/"Making References"> for information on closures.) |
| 235 | Package-specific attribute handling may change incompatibly in a future |
| 236 | release. |
| 237 | |
| 238 | When an attribute list is present in a declaration, a check is made to see |
| 239 | whether an attribute 'modify' handler is present in the appropriate package |
| 240 | (or its @ISA inheritance tree). Similarly, when C<attributes::get> is |
| 241 | called on a valid reference, a check is made for an appropriate attribute |
| 242 | 'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package" |
| 243 | determination works. |
| 244 | |
| 245 | The handler names are based on the underlying type of the variable being |
| 246 | declared or of the reference passed. Because these attributes are |
| 247 | associated with subroutine or variable declarations, this deliberately |
| 248 | ignores any possibility of being blessed into some package. Thus, a |
| 249 | subroutine declaration uses "CODE" as its I<type>, and even a blessed |
| 250 | hash reference uses "HASH" as its I<type>. |
| 251 | |
| 252 | The class methods invoked for modifying and fetching are these: |
| 253 | |
| 254 | =over 4 |
| 255 | |
| 256 | =item FETCH_I<type>_ATTRIBUTES |
| 257 | |
| 258 | This method receives a single argument, which is a reference to the |
| 259 | variable or subroutine for which package-defined attributes are desired. |
| 260 | The expected return value is a list of associated attributes. |
| 261 | This list may be empty. |
| 262 | |
| 263 | =item MODIFY_I<type>_ATTRIBUTES |
| 264 | |
| 265 | This method is called with two fixed arguments, followed by the list of |
| 266 | attributes from the relevant declaration. The two fixed arguments are |
| 267 | the relevant package name and a reference to the declared subroutine or |
| 268 | variable. The expected return value is a list of attributes which were |
| 269 | not recognized by this handler. Note that this allows for a derived class |
| 270 | to delegate a call to its base class, and then only examine the attributes |
| 271 | which the base class didn't already handle for it. |
| 272 | |
| 273 | The call to this method is currently made I<during> the processing of the |
| 274 | declaration. In particular, this means that a subroutine reference will |
| 275 | probably be for an undefined subroutine, even if this declaration is |
| 276 | actually part of the definition. |
| 277 | |
| 278 | =back |
| 279 | |
| 280 | Calling C<attributes::get()> from within the scope of a null package |
| 281 | declaration C<package ;> for an unblessed variable reference will |
| 282 | not provide any starting package name for the 'fetch' method lookup. |
| 283 | Thus, this circumstance will not result in a method call for package-defined |
| 284 | attributes. A named subroutine knows to which symbol table entry it belongs |
| 285 | (or originally belonged), and it will use the corresponding package. |
| 286 | An anonymous subroutine knows the package name into which it was compiled |
| 287 | (unless it was also compiled with a null package declaration), and so it |
| 288 | will use that package name. |
| 289 | |
| 290 | =head2 Syntax of Attribute Lists |
| 291 | |
| 292 | An attribute list is a sequence of attribute specifications, separated by |
| 293 | whitespace or a colon (with optional whitespace). |
| 294 | Each attribute specification is a simple |
| 295 | name, optionally followed by a parenthesised parameter list. |
| 296 | If such a parameter list is present, it is scanned past as for the rules |
| 297 | for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.) |
| 298 | The parameter list is passed as it was found, however, and not as per C<q()>. |
| 299 | |
| 300 | Some examples of syntactically valid attribute lists: |
| 301 | |
| 302 | switch(10,foo(7,3)) : expensive |
| 303 | Ugly('\(") :Bad |
| 304 | _5x5 |
| 305 | locked method |
| 306 | |
| 307 | Some examples of syntactically invalid attribute lists (with annotation): |
| 308 | |
| 309 | switch(10,foo() # ()-string not balanced |
| 310 | Ugly('(') # ()-string not balanced |
| 311 | 5x5 # "5x5" not a valid identifier |
| 312 | Y2::north # "Y2::north" not a simple identifier |
| 313 | foo + bar # "+" neither a colon nor whitespace |
| 314 | |
| 315 | =head1 EXPORTS |
| 316 | |
| 317 | =head2 Default exports |
| 318 | |
| 319 | None. |
| 320 | |
| 321 | =head2 Available exports |
| 322 | |
| 323 | The routines C<get> and C<reftype> are exportable. |
| 324 | |
| 325 | =head2 Export tags defined |
| 326 | |
| 327 | The C<:ALL> tag will get all of the above exports. |
| 328 | |
| 329 | =head1 EXAMPLES |
| 330 | |
| 331 | Here are some samples of syntactically valid declarations, with annotation |
| 332 | as to how they resolve internally into C<use attributes> invocations by |
| 333 | perl. These examples are primarily useful to see how the "appropriate |
| 334 | package" is found for the possible method lookups for package-defined |
| 335 | attributes. |
| 336 | |
| 337 | =over 4 |
| 338 | |
| 339 | =item 1. |
| 340 | |
| 341 | Code: |
| 342 | |
| 343 | package Canine; |
| 344 | package Dog; |
| 345 | my Canine $spot : Watchful ; |
| 346 | |
| 347 | Effect: |
| 348 | |
| 349 | use attributes (); |
| 350 | attributes::->import(Canine => \$spot, "Watchful"); |
| 351 | |
| 352 | =item 2. |
| 353 | |
| 354 | Code: |
| 355 | |
| 356 | package Felis; |
| 357 | my $cat : Nervous; |
| 358 | |
| 359 | Effect: |
| 360 | |
| 361 | use attributes (); |
| 362 | attributes::->import(Felis => \$cat, "Nervous"); |
| 363 | |
| 364 | =item 3. |
| 365 | |
| 366 | Code: |
| 367 | |
| 368 | package X; |
| 369 | sub foo : locked ; |
| 370 | |
| 371 | Effect: |
| 372 | |
| 373 | use attributes X => \&foo, "locked"; |
| 374 | |
| 375 | =item 4. |
| 376 | |
| 377 | Code: |
| 378 | |
| 379 | package X; |
| 380 | sub Y::x : locked { 1 } |
| 381 | |
| 382 | Effect: |
| 383 | |
| 384 | use attributes Y => \&Y::x, "locked"; |
| 385 | |
| 386 | =item 5. |
| 387 | |
| 388 | Code: |
| 389 | |
| 390 | package X; |
| 391 | sub foo { 1 } |
| 392 | |
| 393 | package Y; |
| 394 | BEGIN { *bar = \&X::foo; } |
| 395 | |
| 396 | package Z; |
| 397 | sub Y::bar : locked ; |
| 398 | |
| 399 | Effect: |
| 400 | |
| 401 | use attributes X => \&X::foo, "locked"; |
| 402 | |
| 403 | =back |
| 404 | |
| 405 | This last example is purely for purposes of completeness. You should not |
| 406 | be trying to mess with the attributes of something in a package that's |
| 407 | not your own. |
| 408 | |
| 409 | =head1 SEE ALSO |
| 410 | |
| 411 | L<perlsub/"Private Variables via my()"> and |
| 412 | L<perlsub/"Subroutine Attributes"> for details on the basic declarations; |
| 413 | L<attrs> for the obsolescent form of subroutine attribute specification |
| 414 | which this module replaces; |
| 415 | L<perlfunc/use> for details on the normal invocation mechanism. |
| 416 | |
| 417 | =cut |
| 418 | |