Commit | Line | Data |
---|---|---|
920dae64 AT |
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 |