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 |
|
---|