summaryrefslogtreecommitdiff
path: root/dist/Attribute-Handlers
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2009-09-28 10:48:53 +0100
committerNicholas Clark <nick@ccl4.org>2009-09-28 10:48:53 +0100
commit5fe6925c645093b14564777709b7e36a489625c8 (patch)
tree8d0d59c1a28ce26bb8e2e1140297e3d74c7e06d9 /dist/Attribute-Handlers
parentd284e2f9a7b9f1200f7e4be388deac2dd968a435 (diff)
downloadperl-5fe6925c645093b14564777709b7e36a489625c8.tar.gz
Move Attribute::Handlers from ext/ to dist/
Diffstat (limited to 'dist/Attribute-Handlers')
-rw-r--r--dist/Attribute-Handlers/Changes155
-rw-r--r--dist/Attribute-Handlers/README605
-rw-r--r--dist/Attribute-Handlers/demo/Demo.pm50
-rw-r--r--dist/Attribute-Handlers/demo/Descriptions.pm25
-rw-r--r--dist/Attribute-Handlers/demo/MyClass.pm64
-rwxr-xr-xdist/Attribute-Handlers/demo/demo.pl31
-rwxr-xr-xdist/Attribute-Handlers/demo/demo2.pl21
-rwxr-xr-xdist/Attribute-Handlers/demo/demo3.pl16
-rwxr-xr-xdist/Attribute-Handlers/demo/demo4.pl9
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_call.pl11
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_chain.pl27
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_cycle.pl25
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_hashdir.pl9
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_phases.pl18
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_range.pl21
-rwxr-xr-xdist/Attribute-Handlers/demo/demo_rawdata.pl12
-rw-r--r--dist/Attribute-Handlers/lib/Attribute/Handlers.pm924
-rw-r--r--dist/Attribute-Handlers/t/constants.t7
-rw-r--r--dist/Attribute-Handlers/t/data_convert.t47
-rw-r--r--dist/Attribute-Handlers/t/linerep.t42
-rw-r--r--dist/Attribute-Handlers/t/multi.t225
21 files changed, 2344 insertions, 0 deletions
diff --git a/dist/Attribute-Handlers/Changes b/dist/Attribute-Handlers/Changes
new file mode 100644
index 0000000000..f91fa607a8
--- /dev/null
+++ b/dist/Attribute-Handlers/Changes
@@ -0,0 +1,155 @@
+t Revision history for Perl extension Attribute-Handlers
+
+0.50 Sat Apr 21 16:09:31 2001
+ - original version;
+
+0.51 Tue May 1 06:33:15 2001
+
+ - Fixed fatal file path error in MANIFEST (thanks Marcel and Jost)
+
+
+0.60 Thu May 10 15:46:02 2001
+
+ - Added RAWDATA specifier
+
+ - Cleaned up documentation (thanks Garrett)
+
+ - Added warning for all-lowercase handlers (thanks Garrett)
+
+ - Added autotie functionality
+
+ - Tweaked handling of anon arrays as attribute args
+
+
+0.61 Thu May 10 16:28:06 2001
+
+ - Critical doc patch
+
+
+0.70 Sun Jun 3 07:40:03 2001
+
+ - Added __CALLER__ pseudo class for 'autotie'
+
+ - Added multi-phasic attribute handlers (thanks Garrett)
+
+ - Fixed nasty $SIG{__WARN__}-induced bug
+
+ - Cached ref/symbol mapping for better performance and more
+ reliable symbol identification under evil typeglob manipulations
+
+ - Added option to pass arguments when autotied classes are imported
+ (thanks Marcel)
+
+ - Fixed bug in handling of lexical SCALAR refs
+
+ - Cleaned up interactions with other class hierarchies
+ (due to being base class of UNIVERSAL)
+
+
+0.75 Mon Sep 3 09:07:08 2001
+
+ - Cleaned up AUTOLOAD
+
+ - Numerous bug fixes (thanks Pete)
+
+ - Fixed handling of attribute data that includes a newline (thanks Pete)
+
+ - Added "autotieref" option (thanks Pete)
+
+ - Switched off $DB::single
+
+ - Changed licence for inclusion in core distribution
+
+ - Fixed 'autotie' for tied classes with multi-level names (thanks Jeff)
+
+
+0.76 Thu Nov 15 06:31:51 2001
+
+ - Fixed documentation nit (thanks Rick)
+
+ - Improving intuitiveness of autotie mechanism (thanks Marcel)
+
+ - Added $VERSION numbrs to demo modules (seems bizarre to me, but
+ they're core too now).
+
+
+0.77 Sat Jun 8 22:58:56 CEST 2002
+
+ - Since Attribute::Handlers now is core, I will refer to changes
+ with their patch number, please read Porting/repository.pod from
+ your a perl tarball for more information.
+
+ - Brought up to date with perl 5.8RC1 version
+ will be 5.8 if no more changes come in
+
+ - [#13686] This changes the behaviour of lexical attributes.
+ Prior to this lexical attributes were done at a compile time,
+ and they would loose their attribute on the next run over them.
+ Now perl 5.8 calls the attribute handler runtime whenever it hits my.
+
+ - [#14448] Fixes cases with too high refcounts on lexical attributes
+
+ - [#15945] Do not warn about too late CHECK and INIT block if
+ A::H is pulled in using a require.
+
+0.78 Sat Oct 5 07:18:09 CEST 2002
+
+ - [#17940] Includes :unique and :shared in the builtin types
+
+ - From perl 5.8 { __CALLER__::foo => __PACKAGE } is missparsed,
+ the proper approach is to use { '__CALLER__::foo' => __PACKAGE }.
+ The documentation is updated to reflect this.
+ Reported by Dave Cross
+
+0.79
+
+ - The version released with Perl 5.10.0
+ - All interpreted attributes are now passed as array references,
+ eventually nested.
+ - Don't AUTOLOAD DESTROY (Jerry D Hedden, cpan bug #1911)
+ - A::H is now able to report caller's file and line number
+ (David Feldman)
+
+0.80 Fri Oct 24 12:06:00 CEST 2008
+ - CPAN release of the Attribute::Handlers version in bleadperl.
+
+0.81 Sun Nov 9 22:47:00 CET 2008
+ - Fix to make tests work on 5.6.X (Eric Rybski, RT #40781)
+
+0.82 Wed Mar 11 17:17:00 CET 2009
+ - Bring test code in line with core perl.
+
+0.83 Fri Mar 13 15:14:00 CET 2009
+ - Re-add a TODO marker in the tests that would fail on 5.6.2.
+
+0.84 Wed Jun 10 15:14:00 CET 2009
+ - Core-CPAN synchronization
+
+0.85 Thu Jun 11 09:31:00 CET 2009
+ - Document findsym for the sake of mod_perl. (David Wheeler)
+ - Remove unused variable. (David Wheeler)
+
+0.86 Sat Aug 8 12:41:00 CET 2009
+ - Add resources (bugtracker, ...) section to META.yml
+
+0.86_01 Thu Sep 17 10:01:00 CET 2009
+ - From perl change 09330df80caf214f375fcf0c04857347e3b17c69 (Zefram):
+
+ Fix [perl #66970] Incorrect coderef in MODIFY_CODE_ATTRIBUTES
+
+ Attribute handlers being applied to a temporary CV has actually been
+ reported as a bug, #66970. The attached patch fixes the bug, by
+ changing the order in which things happen: attributes are now applied
+ after the temporary CV has been merged into the existing CV or has
+ otherwise been added to the appropriate GV.
+
+ The change breaks part of Attribute::Handlers. Part of A:H searches the
+ package to find the name of the sub to which a :ATTR attribute is being
+ applied, and the correct time at which to launch that search depends
+ crucially on the order in which the CV construction events occur. So
+ this patch also includes a change to A:H, to make it detect which way
+ things happen. The resulting A:H works either way, which is essential
+ for its dual-life nature.
+
+0.87 Mon Sep 21 15:55:00 CET 2009
+ - Promote to stable release
diff --git a/dist/Attribute-Handlers/README b/dist/Attribute-Handlers/README
new file mode 100644
index 0000000000..539de1fca5
--- /dev/null
+++ b/dist/Attribute-Handlers/README
@@ -0,0 +1,605 @@
+==============================================================================
+ Attribute::Handlers
+==============================================================================
+
+
+NAME
+ Attribute::Handlers - Simpler definition of attribute handlers
+
+VERSION
+ This document describes version 0.79 of Attribute::Handlers, released
+ November 25, 2007.
+
+SYNOPSIS
+ package MyClass;
+ require 5.006;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ ...
+ }
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ ...
+ }
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ ...
+ }
+
+
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+DESCRIPTION
+ This module, when inherited by a package, allows that package's class to
+ define attribute handler subroutines for specific attributes. Variables
+ and subroutines subsequently defined in that package, or in packages
+ derived from that package may be given attributes with the same names as
+ the attribute handler subroutines, which will then be called in one of
+ the compilation phases (i.e. in a "BEGIN", "CHECK", "INIT", or "END"
+ block). ("UNITCHECK" blocks don't correspond to a global compilation
+ phase, so they can't be specified here.)
+
+ To create a handler, define it as a subroutine with the same name as the
+ desired attribute, and declare the subroutine itself with the attribute
+ ":ATTR". For example:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ print STDERR
+ ref($referent), " ",
+ *{$symbol}{NAME}, " ",
+ "($referent) ", "was just declared ",
+ "and ascribed the ${attr} attribute ",
+ "with data ($data)\n",
+ "in phase $phase\n",
+ "in file $filename at line $linenum\n";
+ }
+
+ This creates a handler for the attribute ":Loud" in the class LoudDecl.
+ Thereafter, any subroutine declared with a ":Loud" attribute in the
+ class LoudDecl:
+
+ package LoudDecl;
+
+ sub foo: Loud {...}
+
+ causes the above handler to be invoked, and passed:
+
+ [0] the name of the package into which it was declared;
+
+ [1] a reference to the symbol table entry (typeglob) containing the
+ subroutine;
+
+ [2] a reference to the subroutine;
+
+ [3] the name of the attribute;
+
+ [4] any data associated with that attribute;
+
+ [5] the name of the phase in which the handler is being invoked;
+
+ [6] the filename in which the handler is being invoked;
+
+ [7] the line number in this file.
+
+ Likewise, declaring any variables with the ":Loud" attribute within the
+ package:
+
+ package LoudDecl;
+
+ my $foo :Loud;
+ my @foo :Loud;
+ my %foo :Loud;
+
+ will cause the handler to be called with a similar argument list
+ (except, of course, that $_[2] will be a reference to the variable).
+
+ The package name argument will typically be the name of the class into
+ which the subroutine was declared, but it may also be the name of a
+ derived class (since handlers are inherited).
+
+ If a lexical variable is given an attribute, there is no symbol table to
+ which it belongs, so the symbol table argument ($_[1]) is set to the
+ string 'LEXICAL' in that case. Likewise, ascribing an attribute to an
+ anonymous subroutine results in a symbol table argument of 'ANON'.
+
+ The data argument passes in the value (if any) associated with the
+ attribute. For example, if &foo had been declared:
+
+ sub foo :Loud("turn it up to 11, man!") {...}
+
+ then a reference to an array containing the string "turn it up to 11,
+ man!" would be passed as the last argument.
+
+ Attribute::Handlers makes strenuous efforts to convert the data argument
+ ($_[4]) to a useable form before passing it to the handler (but see
+ "Non-interpretive attribute handlers"). If those efforts succeed, the
+ interpreted data is passed in an array reference; if they fail, the raw
+ data is passed as a string. For example, all of these:
+
+ sub foo :Loud(till=>ears=>are=>bleeding) {...}
+ sub foo :Loud(qw/till ears are bleeding/) {...}
+ sub foo :Loud(qw/my, ears, are, bleeding/) {...}
+ sub foo :Loud(till,ears,are,bleeding) {...}
+
+ causes it to pass "['till','ears','are','bleeding']" as the handler's
+ data argument. While:
+
+ sub foo :Loud(['till','ears','are','bleeding']) {...}
+
+ causes it to pass "[ ['till','ears','are','bleeding'] ]"; the array
+ reference specified in the data being passed inside the standard array
+ reference indicating successful interpretation.
+
+ However, if the data can't be parsed as valid Perl, then it is passed as
+ an uninterpreted string. For example:
+
+ sub foo :Loud(my,ears,are,bleeding) {...}
+ sub foo :Loud(qw/my ears are bleeding) {...}
+
+ cause the strings 'my,ears,are,bleeding' and 'qw/my ears are bleeding'
+ respectively to be passed as the data argument.
+
+ If no value is associated with the attribute, "undef" is passed.
+
+ Typed lexicals
+ Regardless of the package in which it is declared, if a lexical variable
+ is ascribed an attribute, the handler that is invoked is the one
+ belonging to the package to which it is typed. For example, the
+ following declarations:
+
+ package OtherClass;
+
+ my LoudDecl $loudobj : Loud;
+ my LoudDecl @loudobjs : Loud;
+ my LoudDecl %loudobjex : Loud;
+
+ causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
+ defines a handler for ":Loud" attributes).
+
+ Type-specific attribute handlers
+ If an attribute handler is declared and the ":ATTR" specifier is given
+ the name of a built-in type ("SCALAR", "ARRAY", "HASH", or "CODE"), the
+ handler is only applied to declarations of that type. For example, the
+ following definition:
+
+ package LoudDecl;
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+
+ creates an attribute handler that applies only to scalars:
+
+ package Painful;
+ use base LoudDecl;
+
+ my $metal : RealLoud; # invokes &LoudDecl::RealLoud
+ my @metal : RealLoud; # error: unknown attribute
+ my %metal : RealLoud; # error: unknown attribute
+ sub metal : RealLoud {...} # error: unknown attribute
+
+ You can, of course, declare separate handlers for these types as well
+ (but you'll need to specify "no warnings 'redefine'" to do it quietly):
+
+ package LoudDecl;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+ sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
+ sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
+ sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
+
+ You can also explicitly indicate that a single handler is meant to be
+ used for all types of referents like so:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
+
+ (I.e. "ATTR(ANY)" is a synonym for ":ATTR").
+
+ Non-interpretive attribute handlers
+ Occasionally the strenuous efforts Attribute::Handlers makes to convert
+ the data argument ($_[4]) to a useable form before passing it to the
+ handler get in the way.
+
+ You can turn off that eagerness-to-help by declaring an attribute
+ handler with the keyword "RAWDATA". For example:
+
+ sub Raw : ATTR(RAWDATA) {...}
+ sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
+ sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
+
+ Then the handler makes absolutely no attempt to interpret the data it
+ receives and simply passes it as a string:
+
+ my $power : Raw(1..100); # handlers receives "1..100"
+
+ Phase-specific attribute handlers
+ By default, attribute handlers are called at the end of the compilation
+ phase (in a "CHECK" block). This seems to be optimal in most cases
+ because most things that can be defined are defined by that point but
+ nothing has been executed.
+
+ However, it is possible to set up attribute handlers that are called at
+ other points in the program's compilation or execution, by explicitly
+ stating the phase (or phases) in which you wish the attribute handler to
+ be called. For example:
+
+ sub Early :ATTR(SCALAR,BEGIN) {...}
+ sub Normal :ATTR(SCALAR,CHECK) {...}
+ sub Late :ATTR(SCALAR,INIT) {...}
+ sub Final :ATTR(SCALAR,END) {...}
+ sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
+
+ As the last example indicates, a handler may be set up to be (re)called
+ in two or more phases. The phase name is passed as the handler's final
+ argument.
+
+ Note that attribute handlers that are scheduled for the "BEGIN" phase
+ are handled as soon as the attribute is detected (i.e. before any
+ subsequently defined "BEGIN" blocks are executed).
+
+ Attributes as "tie" interfaces
+ Attributes make an excellent and intuitive interface through which to
+ tie variables. For example:
+
+ use Attribute::Handlers;
+ use Tie::Cycle;
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+ tie $$referent, 'Tie::Cycle', $data;
+ }
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+ }
+
+ Note that, because the "Cycle" attribute receives its arguments in the
+ $data variable, if the attribute is given a list of arguments, $data
+ will consist of a single array reference; otherwise, it will consist of
+ the single argument directly. Since Tie::Cycle requires its cycling
+ values to be passed as an array reference, this means that we need to
+ wrap non-array-reference arguments in an array constructor:
+
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+
+ Typically, however, things are the other way around: the tieable class
+ expects its arguments as a flattened list, so the attribute looks like:
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ my @data = ref $data eq 'ARRAY' ? @$data : $data;
+ tie $$referent, 'Tie::Whatever', @data;
+ }
+
+ This software pattern is so widely applicable that Attribute::Handlers
+ provides a way to automate it: specifying 'autotie' in the "use
+ Attribute::Handlers" statement. So, the cycling example, could also be
+ written:
+
+ use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle(['A'..'Z']); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+
+ Note that we now have to pass the cycling values as an array reference,
+ since the "autotie" mechanism passes "tie" a list of arguments as a list
+ (as in the Tie::Whatever example), *not* as an array reference (as in
+ the original Tie::Cycle example at the start of this section).
+
+ The argument after 'autotie' is a reference to a hash in which each key
+ is the name of an attribute to be created, and each value is the class
+ to which variables ascribed that attribute should be tied.
+
+ Note that there is no longer any need to import the Tie::Cycle module --
+ Attribute::Handlers takes care of that automagically. You can even pass
+ arguments to the module's "import" subroutine, by appending them to the
+ class name. For example:
+
+ use Attribute::Handlers
+ autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+ If the attribute name is unqualified, the attribute is installed in the
+ current package. Otherwise it is installed in the qualifier's package:
+
+ package Here;
+
+ use Attribute::Handlers autotie => {
+ Other::Good => Tie::SecureHash, # tie attr installed in Other::
+ Bad => Tie::Taxes, # tie attr installed in Here::
+ UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
+ };
+
+ Autoties are most commonly used in the module to which they actually
+ tie, and need to export their attributes to any module that calls them.
+ To facilitate this, Attribute::Handlers recognizes a special
+ "pseudo-class" -- "__CALLER__", which may be specified as the qualifier
+ of an attribute:
+
+ package Tie::Me::Kangaroo:Down::Sport;
+
+ use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
+
+ This causes Attribute::Handlers to define the "Roo" attribute in the
+ package that imports the Tie::Me::Kangaroo:Down::Sport module.
+
+ Note that it is important to quote the __CALLER__::Roo identifier
+ because a bug in perl 5.8 will refuse to parse it and cause an unknown
+ error.
+
+ Passing the tied object to "tie"
+ Occasionally it is important to pass a reference to the object being
+ tied to the TIESCALAR, TIEHASH, etc. that ties it.
+
+ The "autotie" mechanism supports this too. The following code:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+ has the same effect as:
+
+ tie my $var, 'Tie::Selfish', @args;
+
+ But when "autotieref" is used instead of "autotie":
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+ the effect is to pass the "tie" call an extra reference to the variable
+ being tied:
+
+ tie my $var, 'Tie::Selfish', \$var, @args;
+
+EXAMPLES
+ If the class shown in SYNOPSIS were placed in the MyClass.pm module,
+ then the following code:
+
+ package main;
+ use MyClass;
+
+ my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub fn :Ugly(sister) :Omni('po',tent()) {...}
+ my @arr :Good :Omni(s/cie/nt/);
+ my %hsh :Good(q/bye/) :Omni(q/bus/);
+
+ would cause the following handlers to be invoked:
+
+ # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Bad', # attr name
+ 0 # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Omni', # attr name
+ '-vorous' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # sub fn :Ugly(sister) :Omni('po',tent()) {...}
+
+ MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Ugly', # attr name
+ 'sister' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Omni', # attr name
+ ['po','acle'] # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my @arr :Good :Omni(s/cie/nt/);
+
+ MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Omni', # attr name
+ "" # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my %hsh :Good(q/bye) :Omni(q/bus/);
+
+ MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Good', # attr name
+ 'q/bye' # raw attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Omni', # attr name
+ 'bus' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ Installing handlers into UNIVERSAL, makes them...err..universal. For
+ example:
+
+ package Descriptions;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+ Let's you write:
+
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+ # etc.
+
+DIAGNOSTICS
+ "Bad attribute type: ATTR(%s)"
+ An attribute handler was specified with an ":ATTR(*ref_type*)", but
+ the type of referent it was defined to handle wasn't one of the five
+ permitted: "SCALAR", "ARRAY", "HASH", "CODE", or "ANY".
+
+ "Attribute handler %s doesn't handle %s attributes"
+ A handler for attributes of the specified name *was* defined, but
+ not for the specified type of declaration. Typically encountered whe
+ trying to apply a "VAR" attribute handler to a subroutine, or a
+ "SCALAR" attribute handler to some other type of variable.
+
+ "Declaration of %s attribute in package %s may clash with future
+ reserved word"
+ A handler for an attributes with an all-lowercase name was declared.
+ An attribute with an all-lowercase name might have a meaning to Perl
+ itself some day, even though most don't yet. Use a mixed-case
+ attribute name, instead.
+
+ "Can't have two ATTR specifiers on one subroutine"
+ You just can't, okay? Instead, put all the specifications together
+ with commas between them in a single "ATTR(*specification*)".
+
+ "Can't autotie a %s"
+ You can only declare autoties for types "SCALAR", "ARRAY", and
+ "HASH". They're the only things (apart from typeglobs -- which are
+ not declarable) that Perl can tie.
+
+ "Internal error: %s symbol went missing"
+ Something is rotten in the state of the program. An attributed
+ subroutine ceased to exist between the point it was declared and the
+ point at which its attribute handler(s) would have been called.
+
+ "Won't be able to apply END handler"
+ You have defined an END handler for an attribute that is being
+ applied to a lexical variable. Since the variable may not be
+ available during END this won't happen.
+
+AUTHOR
+ Damian Conway (damian@conway.org). The maintainer of this module is now
+ Rafael Garcia-Suarez (rgarciasuarez@gmail.com).
+
+ Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
+ Contact him with technical difficulties with respect to the packaging of
+ the CPAN module.
+
+BUGS
+ There are undoubtedly serious bugs lurking somewhere in code this funky
+ :-) Bug reports and other feedback are most welcome.
+
+COPYRIGHT AND LICENSE
+ Copyright (c) 2001-2009, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
+
diff --git a/dist/Attribute-Handlers/demo/Demo.pm b/dist/Attribute-Handlers/demo/Demo.pm
new file mode 100644
index 0000000000..e763d23b90
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/Demo.pm
@@ -0,0 +1,50 @@
+$DB::single = 1;
+
+package Demo;
+$VERSION = '1.00';
+use Attribute::Handlers;
+no warnings 'redefine';
+
+sub Demo : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Scalar $', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr}\n",
+ "with data ($data)\nin phase $phase\n";
+};
+
+sub This : ATTR(SCALAR) {
+ print STDERR "This at ",
+ join(":", map { defined() ? $_ : "" } caller(1)),
+ "\n";
+}
+
+sub Demo : ATTR(HASH) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Hash %', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub Demo : ATTR(CODE) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR 'Sub &', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub Multi : ATTR {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR ref($referent), ' ', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub ExplMulti : ATTR(ANY) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ $data = '<undef>' unless defined $data;
+ print STDERR ref($referent), ' ', *{$symbol}{NAME},
+ " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+1;
diff --git a/dist/Attribute-Handlers/demo/Descriptions.pm b/dist/Attribute-Handlers/demo/Descriptions.pm
new file mode 100644
index 0000000000..023f6f752f
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/Descriptions.pm
@@ -0,0 +1,25 @@
+package Descriptions;
+$VERSION = '1.00';
+
+use Attribute::Handlers;
+
+my %name;
+
+sub name {
+ return $name{$_[2]}||*{$_[1]}{NAME};
+}
+
+sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+}
+
+sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+}
+
+sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+}
+
+
+1;
diff --git a/dist/Attribute-Handlers/demo/MyClass.pm b/dist/Attribute-Handlers/demo/MyClass.pm
new file mode 100644
index 0000000000..d012b9f1c4
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/MyClass.pm
@@ -0,0 +1,64 @@
+package MyClass;
+$VERSION = '1.00';
+use 5.006;
+use base Attribute::Handlers;
+no warnings 'redefine';
+
+
+sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ local $" = ", ";
+ print "MyClass::Good:ATTR(SCALAR)(@_);\n";
+};
+
+sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Bad:ATTR(SCALAR)(@_);\n";
+}
+
+sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Good:ATTR(ARRAY)(@_);\n";
+};
+
+sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ local $" = ", ";
+ print "MyClass::Good:ATTR(HASH)(@_);\n";
+};
+
+sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ local $" = ", ";
+ print "MyClass::UGLY:ATTR(CODE)(@_);\n";
+};
+
+sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ local $" = ", ";
+ my $type = ref $_[2];
+ print "MyClass::OMNI:ATTR($type)(@_);\n";
+ use Data::Dumper 'Dumper';
+ print Dumper [ \@_ ];
+};
+
+1;
diff --git a/dist/Attribute-Handlers/demo/demo.pl b/dist/Attribute-Handlers/demo/demo.pl
new file mode 100755
index 0000000000..23c8334c0b
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo.pl
@@ -0,0 +1,31 @@
+#! /usr/local/bin/perl -w
+
+use 5.006;
+use base Demo;
+
+my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+sub x : Demo(4, 5, 6) :Multi {}
+my %z : Demo(hash) :Multi(method,maybe);
+# my %a : NDemo(hash);
+
+{
+ package Named;
+
+ use base Demo;
+
+ sub Demo :ATTR(SCALAR) { print STDERR "tada\n" }
+
+ my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+ sub x : ExplMulti :Demo(4,5,6) {}
+ my %z : ExplMulti :Demo(hash);
+ my Named $q : Demo;
+}
+
+package Other;
+
+my Demo $dother : Demo :This($this) = "okay";
+my Named $nother : Demo :This($this) = "okay";
+
+# my $unnamed : Demo;
+
+# sub foo : Demo();
diff --git a/dist/Attribute-Handlers/demo/demo2.pl b/dist/Attribute-Handlers/demo/demo2.pl
new file mode 100755
index 0000000000..46ed594225
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo2.pl
@@ -0,0 +1,21 @@
+#! /usr/local/bin/perl -w
+
+use 5.006;
+use base Demo;
+no warnings 'redefine';
+
+my %z1 :Multi(method?maybe);
+my %z2 :Multi(method,maybe);
+my %z3 :Multi(qw(method,maybe));
+my %z4 :Multi(qw(method maybe));
+my %z5 :Multi('method','maybe');
+
+sub foo :Demo(till=>ears=>are=>bleeding) {}
+sub foo :Demo(['till','ears','are','bleeding']) {}
+sub foo :Demo(qw/till ears are bleeding/) {}
+sub foo :Demo(till,ears,are,bleeding) {}
+
+sub foo :Demo(my,ears,are,bleeding) {}
+sub foo :Demo(my=>ears=>are=>bleeding) {}
+sub foo :Demo(qw/my, ears, are, bleeding/) {}
+sub foo :Demo(qw/my ears are bleeding) {}
diff --git a/dist/Attribute-Handlers/demo/demo3.pl b/dist/Attribute-Handlers/demo/demo3.pl
new file mode 100755
index 0000000000..6760fc08ba
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo3.pl
@@ -0,0 +1,16 @@
+package main;
+use MyClass;
+
+my MyClass $x :Good :Bad(1**1-1) :Omni(vorous);
+
+package SomeOtherClass;
+use base MyClass;
+
+sub tent { 'acle' }
+
+sub w :Ugly(sister) :Omni('po',tent()) {}
+
+my @y :Good :Omni(s/cie/nt/);
+
+my %y :Good(q/bye) :Omni(q/bus/);
+
diff --git a/dist/Attribute-Handlers/demo/demo4.pl b/dist/Attribute-Handlers/demo/demo4.pl
new file mode 100755
index 0000000000..22d9fd983b
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo4.pl
@@ -0,0 +1,9 @@
+use Descriptions;
+
+my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+package Other;
+
+sub foo : Purpose(to foo all data before barring it) { }
diff --git a/dist/Attribute-Handlers/demo/demo_call.pl b/dist/Attribute-Handlers/demo/demo_call.pl
new file mode 100755
index 0000000000..1a97342116
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_call.pl
@@ -0,0 +1,11 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+
+sub Call : ATTR {
+ use Data::Dumper 'Dumper';
+ print Dumper [ @_ ];
+}
+
+
+sub x : Call(some,data) { };
diff --git a/dist/Attribute-Handlers/demo/demo_chain.pl b/dist/Attribute-Handlers/demo/demo_chain.pl
new file mode 100755
index 0000000000..8999c1ccc7
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_chain.pl
@@ -0,0 +1,27 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+
+sub Prefix : ATTR {
+ my ($glob, $sub) = @_[1,2];
+ no warnings 'redefine';
+ *$glob = sub {
+ print "This happens first\n";
+ $sub->(@_);
+ };
+}
+
+sub Postfix : ATTR {
+ my ($glob, $sub) = @_[1,2];
+ no warnings 'redefine';
+ *$glob = sub {
+ $sub->(@_);
+ print "This happens last\n";
+ };
+}
+
+sub test : Postfix Prefix {
+ print "Hello World\n";
+}
+
+test();
diff --git a/dist/Attribute-Handlers/demo/demo_cycle.pl b/dist/Attribute-Handlers/demo/demo_cycle.pl
new file mode 100755
index 0000000000..5f307a7036
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_cycle.pl
@@ -0,0 +1,25 @@
+package Selfish;
+
+sub TIESCALAR {
+ use Data::Dumper 'Dumper';
+ print Dumper [ \@_ ];
+ bless [ @_[1..$#_] ], $_[0];
+}
+
+sub FETCH {
+ use Data::Dumper 'Dumper';
+ Dumper [ @{$_[0]} ];
+}
+
+package main;
+
+use Attribute::Handlers autotieref => { Selfish => Selfish };
+
+my $next : Selfish("me");
+print "$next\n";
+
+my $last : Selfish("you","them","who?");
+print "$last\n";
+
+my $other : Selfish(["you","them","who?"]);
+print "$other\n";
diff --git a/dist/Attribute-Handlers/demo/demo_hashdir.pl b/dist/Attribute-Handlers/demo/demo_hashdir.pl
new file mode 100755
index 0000000000..75e252b1a0
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_hashdir.pl
@@ -0,0 +1,9 @@
+use Attribute::Handlers autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+my %dot : Dir('.', DIR_UNLINK);
+
+print join "\n", keys %dot;
+
+delete $dot{killme};
+
+print join "\n", keys %dot;
diff --git a/dist/Attribute-Handlers/demo/demo_phases.pl b/dist/Attribute-Handlers/demo/demo_phases.pl
new file mode 100755
index 0000000000..022f7e1537
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_phases.pl
@@ -0,0 +1,18 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+use Data::Dumper 'Dumper';
+
+sub UNIVERSAL::Beginner : ATTR(SCALAR,BEGIN,END)
+ { print STDERR "Beginner: ", Dumper \@_}
+
+sub UNIVERSAL::Checker : ATTR(CHECK,SCALAR)
+ { print STDERR "Checker: ", Dumper \@_}
+
+sub UNIVERSAL::Initer : ATTR(SCALAR,INIT)
+ { print STDERR "Initer: ", Dumper \@_}
+
+package Other;
+
+my $x :Initer(1) :Checker(2) :Beginner(3);
+my $y :Initer(4) :Checker(5) :Beginner(6);
diff --git a/dist/Attribute-Handlers/demo/demo_range.pl b/dist/Attribute-Handlers/demo/demo_range.pl
new file mode 100755
index 0000000000..b63d518ee5
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_range.pl
@@ -0,0 +1,21 @@
+package UNIVERSAL;
+use Attribute::Handlers;
+use Tie::RangeHash;
+
+sub Ranged : ATTR(HASH) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+ tie %$referent, 'Tie::RangeHash';
+}
+
+package main;
+
+my %next : Ranged;
+
+$next{'cat,dog'} = "animal";
+$next{'fish,fowl'} = "meal";
+$next{'heaven,hell'} = "reward";
+
+while (<>) {
+ chomp;
+ print $next{$_}||"???", "\n";
+}
diff --git a/dist/Attribute-Handlers/demo/demo_rawdata.pl b/dist/Attribute-Handlers/demo/demo_rawdata.pl
new file mode 100755
index 0000000000..c0754f06a9
--- /dev/null
+++ b/dist/Attribute-Handlers/demo/demo_rawdata.pl
@@ -0,0 +1,12 @@
+package UNIVERSAL;
+use Attribute::Handlers;
+
+sub Cooked : ATTR(SCALAR) { print pop, "\n" }
+sub PostRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+sub PreRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+
+package main;
+
+my $x : Cooked(1..5);
+my $y : PreRaw(1..5);
+my $z : PostRaw(1..5);
diff --git a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm
new file mode 100644
index 0000000000..ea11b8f7ed
--- /dev/null
+++ b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm
@@ -0,0 +1,924 @@
+package Attribute::Handlers;
+use 5.006;
+use Carp;
+use warnings;
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+$VERSION = '0.87'; # remember to update version in POD!
+# $DB::single=1;
+
+my %symcache;
+sub findsym {
+ my ($pkg, $ref, $type) = @_;
+ return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
+ $type ||= ref($ref);
+ no strict 'refs';
+ foreach my $sym ( values %{$pkg."::"} ) {
+ use strict;
+ next unless ref ( \$sym ) eq 'GLOB';
+ return $symcache{$pkg,$ref} = \$sym
+ if *{$sym}{$type} && *{$sym}{$type} == $ref;
+ }
+}
+
+my %validtype = (
+ VAR => [qw[SCALAR ARRAY HASH]],
+ ANY => [qw[SCALAR ARRAY HASH CODE]],
+ "" => [qw[SCALAR ARRAY HASH CODE]],
+ SCALAR => [qw[SCALAR]],
+ ARRAY => [qw[ARRAY]],
+ HASH => [qw[HASH]],
+ CODE => [qw[CODE]],
+);
+my %lastattr;
+my @declarations;
+my %raw;
+my %phase;
+my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
+my $global_phase = 0;
+my %global_phases = (
+ BEGIN => 0,
+ CHECK => 1,
+ INIT => 2,
+ END => 3,
+);
+my @global_phases = qw(BEGIN CHECK INIT END);
+
+sub _usage_AH_ {
+ croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
+}
+
+my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
+
+sub import {
+ my $class = shift @_;
+ return unless $class eq "Attribute::Handlers";
+ while (@_) {
+ my $cmd = shift;
+ if ($cmd =~ /^autotie((?:ref)?)$/) {
+ my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
+ my $mapping = shift;
+ _usage_AH_ $class unless ref($mapping) eq 'HASH';
+ while (my($attr, $tieclass) = each %$mapping) {
+ $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
+ my $args = $3||'()';
+ _usage_AH_ $class unless $attr =~ $qual_id
+ && $tieclass =~ $qual_id
+ && eval "use base q\0$tieclass\0; 1";
+ if ($tieclass->isa('Exporter')) {
+ local $Exporter::ExportLevel = 2;
+ $tieclass->import(eval $args);
+ }
+ $attr =~ s/__CALLER__/caller(1)/e;
+ $attr = caller()."::".$attr unless $attr =~ /::/;
+ eval qq{
+ sub $attr : ATTR(VAR) {
+ my (\$ref, \$data) = \@_[2,4];
+ my \$was_arrayref = ref \$data eq 'ARRAY';
+ \$data = [ \$data ] unless \$was_arrayref;
+ my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
+ (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
+ :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
+ :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
+ : die "Can't autotie a \$type\n"
+ } 1
+ } or die "Internal error: $@";
+ }
+ }
+ else {
+ croak "Can't understand $_";
+ }
+ }
+}
+
+# On older perls, code attribute handlers run before the sub gets placed
+# in its package. Since the :ATTR handlers need to know the name of the
+# sub they're applied to, the name lookup (via findsym) needs to be
+# delayed: we do it immediately before we might need to find attribute
+# handlers from their name. However, on newer perls (which fix some
+# problems relating to attribute application), a sub gets placed in its
+# package before its attributes are processed. In this case, the
+# delayed name lookup might be too late, because the sub we're looking
+# for might have already been replaced. So we need to detect which way
+# round this perl does things, and time the name lookup accordingly.
+BEGIN {
+ my $delayed;
+ sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
+ $delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
+ return ();
+ }
+ sub Attribute::Handlers::_TEST_::t :T { }
+ *_delayed_name_resolution = sub() { $delayed };
+ undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
+ undef &Attribute::Handlers::_TEST_::t;
+}
+
+sub _resolve_lastattr {
+ return unless $lastattr{ref};
+ my $sym = findsym @lastattr{'pkg','ref'}
+ or die "Internal error: $lastattr{pkg} symbol went missing";
+ my $name = *{$sym}{NAME};
+ warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
+ if $^W and $name !~ /[A-Z]/;
+ foreach ( @{$validtype{$lastattr{type}}} ) {
+ no strict 'refs';
+ *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
+ }
+ %lastattr = ();
+}
+
+sub AUTOLOAD {
+ return if $AUTOLOAD =~ /::DESTROY$/;
+ my ($class) = $AUTOLOAD =~ m/(.*)::/g;
+ $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
+ croak "Can't locate class method '$AUTOLOAD' via package '$class'";
+ croak "Attribute handler '$2' doesn't handle $1 attributes";
+}
+
+my $builtin = qr/lvalue|method|locked|unique|shared/;
+
+sub _gen_handler_AH_() {
+ return sub {
+ _resolve_lastattr if _delayed_name_resolution;
+ my ($pkg, $ref, @attrs) = @_;
+ my (undef, $filename, $linenum) = caller 2;
+ foreach (@attrs) {
+ my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
+ if ($attr eq 'ATTR') {
+ no strict 'refs';
+ $data ||= "ANY";
+ $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
+ $phase{$ref}{BEGIN} = 1
+ if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
+ $phase{$ref}{INIT} = 1
+ if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
+ $phase{$ref}{END} = 1
+ if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
+ $phase{$ref}{CHECK} = 1
+ if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
+ || ! keys %{$phase{$ref}};
+ # Added for cleanup to not pollute next call.
+ (%lastattr = ()),
+ croak "Can't have two ATTR specifiers on one subroutine"
+ if keys %lastattr;
+ croak "Bad attribute type: ATTR($data)"
+ unless $validtype{$data};
+ %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
+ _resolve_lastattr unless _delayed_name_resolution;
+ }
+ else {
+ my $type = ref $ref;
+ my $handler = $pkg->can("_ATTR_${type}_${attr}");
+ next unless $handler;
+ my $decl = [$pkg, $ref, $attr, $data,
+ $raw{$handler}, $phase{$handler}, $filename, $linenum];
+ foreach my $gphase (@global_phases) {
+ _apply_handler_AH_($decl,$gphase)
+ if $global_phases{$gphase} <= $global_phase;
+ }
+ if ($global_phase != 0) {
+ # if _gen_handler_AH_ is being called after
+ # CHECK it's for a lexical, so make sure
+ # it didn't want to run anything later
+
+ local $Carp::CarpLevel = 2;
+ carp "Won't be able to apply END handler"
+ if $phase{$handler}{END};
+ }
+ else {
+ push @declarations, $decl
+ }
+ }
+ $_ = undef;
+ }
+ return grep {defined && !/$builtin/} @attrs;
+ }
+}
+
+{
+ no strict 'refs';
+ *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
+ _gen_handler_AH_ foreach @{$validtype{ANY}};
+}
+push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
+ unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
+
+sub _apply_handler_AH_ {
+ my ($declaration, $phase) = @_;
+ my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
+ return unless $handlerphase->{$phase};
+ # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
+ my $type = ref $ref;
+ my $handler = "_ATTR_${type}_${attr}";
+ my $sym = findsym($pkg, $ref);
+ $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
+ no warnings;
+ if (!$raw && defined($data)) {
+ if ($data ne '') {
+ my $evaled = eval("package $pkg; no warnings; no strict;
+ local \$SIG{__WARN__}=sub{die}; [$data]");
+ $data = $evaled unless $@;
+ }
+ else { $data = undef }
+ }
+ $pkg->$handler($sym,
+ (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
+ $attr,
+ $data,
+ $phase,
+ $filename,
+ $linenum,
+ );
+ return 1;
+}
+
+{
+ no warnings 'void';
+ CHECK {
+ $global_phase++;
+ _resolve_lastattr if _delayed_name_resolution;
+ _apply_handler_AH_($_,'CHECK') foreach @declarations;
+ }
+
+ INIT {
+ $global_phase++;
+ _apply_handler_AH_($_,'INIT') foreach @declarations
+ }
+}
+
+END { $global_phase++; _apply_handler_AH_($_,'END') foreach @declarations }
+
+1;
+__END__
+
+=head1 NAME
+
+Attribute::Handlers - Simpler definition of attribute handlers
+
+=head1 VERSION
+
+This document describes version 0.87 of Attribute::Handlers,
+released September 21, 2009.
+
+=head1 SYNOPSIS
+
+ package MyClass;
+ require 5.006;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+
+ sub Good : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data) = @_;
+
+ # Invoked for any scalar variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+
+ # Do whatever to $referent here (executed in CHECK phase).
+ ...
+ }
+
+ sub Bad : ATTR(SCALAR) {
+ # Invoked for any scalar variable with a :Bad attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(ARRAY) {
+ # Invoked for any array variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Good : ATTR(HASH) {
+ # Invoked for any hash variable with a :Good attribute,
+ # provided the variable was declared in MyClass (or
+ # a derived class) or typed to MyClass.
+ ...
+ }
+
+ sub Ugly : ATTR(CODE) {
+ # Invoked for any subroutine declared in MyClass (or a
+ # derived class) with an :Ugly attribute.
+ ...
+ }
+
+ sub Omni : ATTR {
+ # Invoked for any scalar, array, hash, or subroutine
+ # with an :Omni attribute, provided the variable or
+ # subroutine was declared in MyClass (or a derived class)
+ # or the variable was typed to MyClass.
+ # Use ref($_[2]) to determine what kind of referent it was.
+ ...
+ }
+
+
+ use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+ my $next : Cycle(['A'..'Z']);
+
+
+=head1 DESCRIPTION
+
+This module, when inherited by a package, allows that package's class to
+define attribute handler subroutines for specific attributes. Variables
+and subroutines subsequently defined in that package, or in packages
+derived from that package may be given attributes with the same names as
+the attribute handler subroutines, which will then be called in one of
+the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
+block). (C<UNITCHECK> blocks don't correspond to a global compilation
+phase, so they can't be specified here.)
+
+To create a handler, define it as a subroutine with the same name as
+the desired attribute, and declare the subroutine itself with the
+attribute C<:ATTR>. For example:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ print STDERR
+ ref($referent), " ",
+ *{$symbol}{NAME}, " ",
+ "($referent) ", "was just declared ",
+ "and ascribed the ${attr} attribute ",
+ "with data ($data)\n",
+ "in phase $phase\n",
+ "in file $filename at line $linenum\n";
+ }
+
+This creates a handler for the attribute C<:Loud> in the class LoudDecl.
+Thereafter, any subroutine declared with a C<:Loud> attribute in the class
+LoudDecl:
+
+ package LoudDecl;
+
+ sub foo: Loud {...}
+
+causes the above handler to be invoked, and passed:
+
+=over
+
+=item [0]
+
+the name of the package into which it was declared;
+
+=item [1]
+
+a reference to the symbol table entry (typeglob) containing the subroutine;
+
+=item [2]
+
+a reference to the subroutine;
+
+=item [3]
+
+the name of the attribute;
+
+=item [4]
+
+any data associated with that attribute;
+
+=item [5]
+
+the name of the phase in which the handler is being invoked;
+
+=item [6]
+
+the filename in which the handler is being invoked;
+
+=item [7]
+
+the line number in this file.
+
+=back
+
+Likewise, declaring any variables with the C<:Loud> attribute within the
+package:
+
+ package LoudDecl;
+
+ my $foo :Loud;
+ my @foo :Loud;
+ my %foo :Loud;
+
+will cause the handler to be called with a similar argument list (except,
+of course, that C<$_[2]> will be a reference to the variable).
+
+The package name argument will typically be the name of the class into
+which the subroutine was declared, but it may also be the name of a derived
+class (since handlers are inherited).
+
+If a lexical variable is given an attribute, there is no symbol table to
+which it belongs, so the symbol table argument (C<$_[1]>) is set to the
+string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
+an anonymous subroutine results in a symbol table argument of C<'ANON'>.
+
+The data argument passes in the value (if any) associated with the
+attribute. For example, if C<&foo> had been declared:
+
+ sub foo :Loud("turn it up to 11, man!") {...}
+
+then a reference to an array containing the string
+C<"turn it up to 11, man!"> would be passed as the last argument.
+
+Attribute::Handlers makes strenuous efforts to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler (but see L<"Non-interpretive attribute handlers">).
+If those efforts succeed, the interpreted data is passed in an array
+reference; if they fail, the raw data is passed as a string.
+For example, all of these:
+
+ sub foo :Loud(till=>ears=>are=>bleeding) {...}
+ sub foo :Loud(qw/till ears are bleeding/) {...}
+ sub foo :Loud(qw/my, ears, are, bleeding/) {...}
+ sub foo :Loud(till,ears,are,bleeding) {...}
+
+causes it to pass C<['till','ears','are','bleeding']> as the handler's
+data argument. While:
+
+ sub foo :Loud(['till','ears','are','bleeding']) {...}
+
+causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
+reference specified in the data being passed inside the standard
+array reference indicating successful interpretation.
+
+However, if the data can't be parsed as valid Perl, then
+it is passed as an uninterpreted string. For example:
+
+ sub foo :Loud(my,ears,are,bleeding) {...}
+ sub foo :Loud(qw/my ears are bleeding) {...}
+
+cause the strings C<'my,ears,are,bleeding'> and
+C<'qw/my ears are bleeding'> respectively to be passed as the
+data argument.
+
+If no value is associated with the attribute, C<undef> is passed.
+
+=head2 Typed lexicals
+
+Regardless of the package in which it is declared, if a lexical variable is
+ascribed an attribute, the handler that is invoked is the one belonging to
+the package to which it is typed. For example, the following declarations:
+
+ package OtherClass;
+
+ my LoudDecl $loudobj : Loud;
+ my LoudDecl @loudobjs : Loud;
+ my LoudDecl %loudobjex : Loud;
+
+causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
+defines a handler for C<:Loud> attributes).
+
+
+=head2 Type-specific attribute handlers
+
+If an attribute handler is declared and the C<:ATTR> specifier is
+given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
+the handler is only applied to declarations of that type. For example,
+the following definition:
+
+ package LoudDecl;
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+
+creates an attribute handler that applies only to scalars:
+
+
+ package Painful;
+ use base LoudDecl;
+
+ my $metal : RealLoud; # invokes &LoudDecl::RealLoud
+ my @metal : RealLoud; # error: unknown attribute
+ my %metal : RealLoud; # error: unknown attribute
+ sub metal : RealLoud {...} # error: unknown attribute
+
+You can, of course, declare separate handlers for these types as well
+(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
+
+ package LoudDecl;
+ use Attribute::Handlers;
+ no warnings 'redefine';
+
+ sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
+ sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
+ sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
+ sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
+
+You can also explicitly indicate that a single handler is meant to be
+used for all types of referents like so:
+
+ package LoudDecl;
+ use Attribute::Handlers;
+
+ sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
+
+(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
+
+
+=head2 Non-interpretive attribute handlers
+
+Occasionally the strenuous efforts Attribute::Handlers makes to convert
+the data argument (C<$_[4]>) to a useable form before passing it to
+the handler get in the way.
+
+You can turn off that eagerness-to-help by declaring
+an attribute handler with the keyword C<RAWDATA>. For example:
+
+ sub Raw : ATTR(RAWDATA) {...}
+ sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
+ sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
+
+Then the handler makes absolutely no attempt to interpret the data it
+receives and simply passes it as a string:
+
+ my $power : Raw(1..100); # handlers receives "1..100"
+
+=head2 Phase-specific attribute handlers
+
+By default, attribute handlers are called at the end of the compilation
+phase (in a C<CHECK> block). This seems to be optimal in most cases because
+most things that can be defined are defined by that point but nothing has
+been executed.
+
+However, it is possible to set up attribute handlers that are called at
+other points in the program's compilation or execution, by explicitly
+stating the phase (or phases) in which you wish the attribute handler to
+be called. For example:
+
+ sub Early :ATTR(SCALAR,BEGIN) {...}
+ sub Normal :ATTR(SCALAR,CHECK) {...}
+ sub Late :ATTR(SCALAR,INIT) {...}
+ sub Final :ATTR(SCALAR,END) {...}
+ sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
+
+As the last example indicates, a handler may be set up to be (re)called in
+two or more phases. The phase name is passed as the handler's final argument.
+
+Note that attribute handlers that are scheduled for the C<BEGIN> phase
+are handled as soon as the attribute is detected (i.e. before any
+subsequently defined C<BEGIN> blocks are executed).
+
+
+=head2 Attributes as C<tie> interfaces
+
+Attributes make an excellent and intuitive interface through which to tie
+variables. For example:
+
+ use Attribute::Handlers;
+ use Tie::Cycle;
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+ tie $$referent, 'Tie::Cycle', $data;
+ }
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle('A'..'Z'); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+ }
+
+Note that, because the C<Cycle> attribute receives its arguments in the
+C<$data> variable, if the attribute is given a list of arguments, C<$data>
+will consist of a single array reference; otherwise, it will consist of the
+single argument directly. Since Tie::Cycle requires its cycling values to
+be passed as an array reference, this means that we need to wrap
+non-array-reference arguments in an array constructor:
+
+ $data = [ $data ] unless ref $data eq 'ARRAY';
+
+Typically, however, things are the other way around: the tieable class expects
+its arguments as a flattened list, so the attribute looks like:
+
+ sub UNIVERSAL::Cycle : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+ my @data = ref $data eq 'ARRAY' ? @$data : $data;
+ tie $$referent, 'Tie::Whatever', @data;
+ }
+
+
+This software pattern is so widely applicable that Attribute::Handlers
+provides a way to automate it: specifying C<'autotie'> in the
+C<use Attribute::Handlers> statement. So, the cycling example,
+could also be written:
+
+ use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
+
+ # and thereafter...
+
+ package main;
+
+ my $next : Cycle(['A'..'Z']); # $next is now a tied variable
+
+ while (<>) {
+ print $next;
+
+Note that we now have to pass the cycling values as an array reference,
+since the C<autotie> mechanism passes C<tie> a list of arguments as a list
+(as in the Tie::Whatever example), I<not> as an array reference (as in
+the original Tie::Cycle example at the start of this section).
+
+The argument after C<'autotie'> is a reference to a hash in which each key is
+the name of an attribute to be created, and each value is the class to which
+variables ascribed that attribute should be tied.
+
+Note that there is no longer any need to import the Tie::Cycle module --
+Attribute::Handlers takes care of that automagically. You can even pass
+arguments to the module's C<import> subroutine, by appending them to the
+class name. For example:
+
+ use Attribute::Handlers
+ autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+If the attribute name is unqualified, the attribute is installed in the
+current package. Otherwise it is installed in the qualifier's package:
+
+ package Here;
+
+ use Attribute::Handlers autotie => {
+ Other::Good => Tie::SecureHash, # tie attr installed in Other::
+ Bad => Tie::Taxes, # tie attr installed in Here::
+ UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
+ };
+
+Autoties are most commonly used in the module to which they actually tie,
+and need to export their attributes to any module that calls them. To
+facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
+C<__CALLER__>, which may be specified as the qualifier of an attribute:
+
+ package Tie::Me::Kangaroo:Down::Sport;
+
+ use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
+
+This causes Attribute::Handlers to define the C<Roo> attribute in the package
+that imports the Tie::Me::Kangaroo:Down::Sport module.
+
+Note that it is important to quote the __CALLER__::Roo identifier because
+a bug in perl 5.8 will refuse to parse it and cause an unknown error.
+
+=head3 Passing the tied object to C<tie>
+
+Occasionally it is important to pass a reference to the object being tied
+to the TIESCALAR, TIEHASH, etc. that ties it.
+
+The C<autotie> mechanism supports this too. The following code:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+has the same effect as:
+
+ tie my $var, 'Tie::Selfish', @args;
+
+But when C<"autotieref"> is used instead of C<"autotie">:
+
+ use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+ my $var : Selfish(@args);
+
+the effect is to pass the C<tie> call an extra reference to the variable
+being tied:
+
+ tie my $var, 'Tie::Selfish', \$var, @args;
+
+
+
+=head1 EXAMPLES
+
+If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
+module, then the following code:
+
+ package main;
+ use MyClass;
+
+ my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ package SomeOtherClass;
+ use base MyClass;
+
+ sub tent { 'acle' }
+
+ sub fn :Ugly(sister) :Omni('po',tent()) {...}
+ my @arr :Good :Omni(s/cie/nt/);
+ my %hsh :Good(q/bye/) :Omni(q/bus/);
+
+
+would cause the following handlers to be invoked:
+
+ # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
+
+ MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Bad', # attr name
+ 0 # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
+ 'LEXICAL', # no typeglob
+ \$slr, # referent
+ 'Omni', # attr name
+ '-vorous' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # sub fn :Ugly(sister) :Omni('po',tent()) {...}
+
+ MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Ugly', # attr name
+ 'sister' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
+ \*SomeOtherClass::fn, # typeglob
+ \&SomeOtherClass::fn, # referent
+ 'Omni', # attr name
+ ['po','acle'] # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my @arr :Good :Omni(s/cie/nt/);
+
+ MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Good', # attr name
+ undef # no attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \@arr, # referent
+ 'Omni', # attr name
+ "" # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+ # my %hsh :Good(q/bye) :Omni(q/bus/);
+
+ MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Good', # attr name
+ 'q/bye' # raw attr data
+ 'CHECK', # compiler phase
+ );
+
+ MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
+ 'LEXICAL', # no typeglob
+ \%hsh, # referent
+ 'Omni', # attr name
+ 'bus' # eval'd attr data
+ 'CHECK', # compiler phase
+ );
+
+
+Installing handlers into UNIVERSAL, makes them...err..universal.
+For example:
+
+ package Descriptions;
+ use Attribute::Handlers;
+
+ my %name;
+ sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
+
+ sub UNIVERSAL::Name :ATTR {
+ $name{$_[2]} = $_[4];
+ }
+
+ sub UNIVERSAL::Purpose :ATTR {
+ print STDERR "Purpose of ", &name, " is $_[4]\n";
+ }
+
+ sub UNIVERSAL::Unit :ATTR {
+ print STDERR &name, " measured in $_[4]\n";
+ }
+
+Let's you write:
+
+ use Descriptions;
+
+ my $capacity : Name(capacity)
+ : Purpose(to store max storage capacity for files)
+ : Unit(Gb);
+
+
+ package Other;
+
+ sub foo : Purpose(to foo all data before barring it) { }
+
+ # etc.
+
+=head1 UTILITY FUNCTIONS
+
+This module offers a single utility function, C<findsym()>.
+
+=over 4
+
+=item findsym
+
+ my $symbol = Attribute::Handlers::findsym($package, $referent);
+
+The function looks in the symbol table of C<$package> for the typeglob for
+C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
+HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
+undef. Note that C<findsym> memoizes the typeglobs it has previously
+successfully found, so subsequent calls with the same arguments should be
+must faster.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over
+
+=item C<Bad attribute type: ATTR(%s)>
+
+An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
+type of referent it was defined to handle wasn't one of the five permitted:
+C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
+
+=item C<Attribute handler %s doesn't handle %s attributes>
+
+A handler for attributes of the specified name I<was> defined, but not
+for the specified type of declaration. Typically encountered whe trying
+to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
+attribute handler to some other type of variable.
+
+=item C<Declaration of %s attribute in package %s may clash with future reserved word>
+
+A handler for an attributes with an all-lowercase name was declared. An
+attribute with an all-lowercase name might have a meaning to Perl
+itself some day, even though most don't yet. Use a mixed-case attribute
+name, instead.
+
+=item C<Can't have two ATTR specifiers on one subroutine>
+
+You just can't, okay?
+Instead, put all the specifications together with commas between them
+in a single C<ATTR(I<specification>)>.
+
+=item C<Can't autotie a %s>
+
+You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
+C<"HASH">. They're the only things (apart from typeglobs -- which are
+not declarable) that Perl can tie.
+
+=item C<Internal error: %s symbol went missing>
+
+Something is rotten in the state of the program. An attributed
+subroutine ceased to exist between the point it was declared and the point
+at which its attribute handler(s) would have been called.
+
+=item C<Won't be able to apply END handler>
+
+You have defined an END handler for an attribute that is being applied
+to a lexical variable. Since the variable may not be available during END
+this won't happen.
+
+=back
+
+=head1 AUTHOR
+
+Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
+Garcia-Suarez (rgarciasuarez@gmail.com).
+
+Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
+Contact him with technical difficulties with respect to the packaging of the
+CPAN module.
+
+=head1 BUGS
+
+There are undoubtedly serious bugs lurking somewhere in code this funky :-)
+Bug reports and other feedback are most welcome.
+
+=head1 COPYRIGHT AND LICENSE
+
+ Copyright (c) 2001-2009, Damian Conway. All Rights Reserved.
+ This module is free software. It may be used, redistributed
+ and/or modified under the same terms as Perl itself.
diff --git a/dist/Attribute-Handlers/t/constants.t b/dist/Attribute-Handlers/t/constants.t
new file mode 100644
index 0000000000..4e5108e131
--- /dev/null
+++ b/dist/Attribute-Handlers/t/constants.t
@@ -0,0 +1,7 @@
+use strict;
+use Test::More tests => 1;
+use Attribute::Handlers;
+# This had been failing since the introduction of proxy constant subroutines
+use constant SETUP => undef;
+sub Test : ATTR(CODE) { };
+ok(1, "If we got here, CHECK didn't fail");
diff --git a/dist/Attribute-Handlers/t/data_convert.t b/dist/Attribute-Handlers/t/data_convert.t
new file mode 100644
index 0000000000..4357c53964
--- /dev/null
+++ b/dist/Attribute-Handlers/t/data_convert.t
@@ -0,0 +1,47 @@
+#!/usr/bin/perl -w
+
+# Test attribute data conversion using examples from the docs
+
+use Test::More tests => 8;
+
+package LoudDecl;
+use Attribute::Handlers;
+
+sub Loud :ATTR {
+ my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+
+ ::is_deeply( $data, $referent->(), *{$symbol}{NAME} );
+}
+
+
+sub test1 :Loud(till=>ears=>are=>bleeding) {
+ [qw(till ears are bleeding)]
+}
+
+sub test2 :Loud(['till','ears','are','bleeding']) {
+ [[qw(till ears are bleeding)]]
+}
+
+sub test3 :Loud(qw/till ears are bleeding/) {
+ [qw(till ears are bleeding)]
+}
+
+sub test4 :Loud(qw/my, ears, are, bleeding/) {
+ [('my,', 'ears,', 'are,', 'bleeding')]
+}
+
+sub test5 :Loud(till,ears,are,bleeding) {
+ [qw(till ears are bleeding)]
+}
+
+sub test6 :Loud(my,ears,are,bleeding) {
+ 'my,ears,are,bleeding';
+}
+
+sub test7 :Loud(qw/my ears are bleeding) {
+ 'qw/my ears are bleeding'; #'
+}
+
+sub test8 :Loud("turn it up to 11, man!") {
+ ['turn it up to 11, man!'];
+}
diff --git a/dist/Attribute-Handlers/t/linerep.t b/dist/Attribute-Handlers/t/linerep.t
new file mode 100644
index 0000000000..885abe0950
--- /dev/null
+++ b/dist/Attribute-Handlers/t/linerep.t
@@ -0,0 +1,42 @@
+#!perl
+
+use Test::More tests => 18;
+use Attribute::Handlers;
+
+sub Args : ATTR(CODE) {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ is( $package, 'main', 'package' );
+ is( $symbol, \*foo, 'symbol' );
+ is( $referent, \&foo, 'referent' );
+ is( $attr, 'Args', 'attr' );
+ is( ref $data, 'ARRAY', 'data' );
+ is( $data->[0], 'bar', 'data' );
+ is( $phase, 'CHECK', 'phase' );
+ is( $filename, __FILE__, 'filename' );
+ is( $linenum, 19, 'linenum' );
+}
+
+sub foo :Args(bar) {}
+
+my $ref;
+sub myref { $ref = shift; }
+my $b;
+#line 42
+eval "my \$bar :SArgs(grumpf); \$b = \\\$bar";
+is( $b, $ref, 'referent' );
+
+sub SArgs : ATTR(SCALAR) {
+ my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+ is( $package, 'main', 'package' );
+ is( $symbol, 'LEXICAL', 'symbol' );
+ myref($referent);
+ is( $attr, 'SArgs', 'attr' );
+ is( ref $data, 'ARRAY', 'data' );
+ is( $data->[0], 'grumpf', 'data' );
+ is( $phase, 'CHECK', 'phase' );
+ TODO: {
+ local $TODO = "Doesn't work correctly" if $] < 5.008;
+ is( $filename, __FILE__, 'filename' );
+ is( $linenum, 42, 'linenum' );
+ }
+}
diff --git a/dist/Attribute-Handlers/t/multi.t b/dist/Attribute-Handlers/t/multi.t
new file mode 100644
index 0000000000..5c80f82b10
--- /dev/null
+++ b/dist/Attribute-Handlers/t/multi.t
@@ -0,0 +1,225 @@
+#!perl
+
+# This test file contains 57 tests.
+# You need to number them manually. Don't forget to update this line for the
+# next kind hacker.
+
+END {print "not ok 1\n" unless $loaded;}
+use v5.6.0;
+use Attribute::Handlers;
+$loaded = 1;
+
+CHECK { $main::phase++ }
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
+sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not ", defined($_[2])?$_[2]:""]; }
+
+END { print "1..$::count\n";
+ print map "$_->[1]ok $_->[0] $_->[2]\n",
+ sort {$a->[0]<=>$b->[0]}
+ grep $_->[0], @::results }
+
+package Test;
+use warnings;
+no warnings 'redefine';
+
+sub UNIVERSAL::Lastly :ATTR(INIT) { ::ok $_[4][0] && $main::phase, $_[4][1] }
+
+sub UNIVERSAL::Okay :ATTR(BEGIN) {
+::ok $_[4][0] && (!$main::phase || !ref $_[1] && $_[1] eq 'LEXICAL'), $_[4][1];
+}
+
+sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} }
+sub Dokay :ATTR(HASH) { ::ok @{$_[4]} }
+sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} }
+sub Dokay :ATTR(CODE) { ::ok @{$_[4]} }
+
+sub Vokay :ATTR(VAR) { ::ok @{$_[4]} }
+
+sub Aokay :ATTR(ANY) { ::ok @{$_[4]} }
+
+package main;
+use warnings;
+
+my $x1 :Lastly(1,41);
+my @x1 :Lastly(1=>42);
+my %x1 :Lastly(1,43);
+sub x1 :Lastly(1,44) {}
+
+my Test $x2 :Dokay(1,5);
+
+if ($] < 5.011) {
+ ::ok(1, $_, '# skip : invalid before 5.11') for 55 .. 57;
+} else {
+ my $c = $::count;
+ eval '
+ my Test @x2 :Dokay(1,55);
+ my Test %x2 :Dokay(1,56);
+ ';
+ $c = $c + 2 - $::count;
+ while ($c > 0) {
+ ::ok(0, 57 - $c);
+ --$c;
+ }
+ ::ok(!$@, 57);
+}
+
+package Test;
+my $x3 :Dokay(1,6);
+my Test $x4 :Dokay(1,7);
+sub x3 :Dokay(1,8) {}
+
+my $y1 :Okay(1,9);
+my @y1 :Okay(1,10);
+my %y1 :Okay(1,11);
+sub y1 :Okay(1,12) {}
+
+my $y2 :Vokay(1,13);
+my @y2 :Vokay(1,14);
+my %y2 :Vokay(1,15);
+# BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or
+::ok(1,16);
+# }
+
+my $z :Aokay(1,17);
+my @z :Aokay(1,18);
+my %z :Aokay(1,19);
+sub z :Aokay(1,20) {};
+
+package DerTest;
+use base 'Test';
+use warnings;
+
+my $x5 :Dokay(1,21);
+my Test $x6 :Dokay(1,22);
+sub x5 :Dokay(1,23);
+
+my $y3 :Okay(1,24);
+my @y3 :Okay(1,25);
+my %y3 :Okay(1,26);
+sub y3 :Okay(1,27) {}
+
+package Unrelated;
+
+my $x11 :Okay(1,1);
+my @x11 :Okay(1=>2);
+my %x11 :Okay(1,3);
+sub x11 :Okay(1,4) {}
+
+BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); }
+my Test $x8 :Dokay(1,29);
+eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30);
+
+
+package Tie::Loud;
+
+sub TIESCALAR { ::ok(1,31); bless {}, $_[0] }
+sub FETCH { ::ok(1,32); return 1 }
+sub STORE { ::ok(1,33); return 1 }
+
+package Tie::Noisy;
+
+sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] }
+sub FETCH { ::ok(1,35); return 1 }
+sub STORE { ::ok(1,36); return 1 }
+sub FETCHSIZE { 100 }
+
+package Tie::Row::dy;
+
+sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] }
+sub FETCH { ::ok(1,38); return 1 }
+sub STORE { ::ok(1,39); return 1 }
+
+package main;
+
+eval 'sub x7 :ATTR(SCALAR) :ATTR(CODE) {}' and ::ok(0,40) or ::ok(1,40);
+
+use Attribute::Handlers autotie => { Other::Loud => Tie::Loud,
+ Noisy => Tie::Noisy,
+ UNIVERSAL::Rowdy => Tie::Row::dy,
+ };
+
+my Other $loud : Loud;
+$loud++;
+
+my @noisy : Noisy(34);
+$noisy[0]++;
+
+my %rowdy : Rowdy(37,'this arg should be ignored');
+$rowdy{key}++;
+
+
+# check that applying attributes to lexicals doesn't unduly worry
+# their refcounts
+my $out = "begin\n";
+my $applied;
+sub UNIVERSAL::Dummy :ATTR { ++$applied };
+sub Dummy::DESTROY { $out .= "bye\n" }
+
+{ my $dummy; $dummy = bless {}, 'Dummy'; }
+ok( $out eq "begin\nbye\n", 45 );
+
+{ my $dummy : Dummy; $dummy = bless {}, 'Dummy'; }
+if($] < 5.008) {
+ok( 1, 46, " # skip lexicals are not runtime prior to 5.8");
+} else {
+ok( $out eq "begin\nbye\nbye\n", 46);
+}
+# are lexical attributes reapplied correctly?
+sub dummy { my $dummy : Dummy; }
+$applied = 0;
+dummy(); dummy();
+if($] < 5.008) {
+ok(1, 47, " # skip does not work with perl prior to 5.8");
+} else {
+ok( $applied == 2, 47 );
+}
+# 45-47 again, but for our variables
+$out = "begin\n";
+{ our $dummy; $dummy = bless {}, 'Dummy'; }
+ok( $out eq "begin\n", 48 );
+{ no warnings; our $dummy : Dummy; $dummy = bless {}, 'Dummy'; }
+ok( $out eq "begin\nbye\n", 49 );
+undef $::dummy;
+ok( $out eq "begin\nbye\nbye\n", 50 );
+
+# are lexical attributes reapplied correctly?
+sub dummy_our { no warnings; our $banjo : Dummy; }
+$applied = 0;
+dummy_our(); dummy_our();
+ok( $applied == 0, 51 );
+
+sub UNIVERSAL::Stooge :ATTR(END) {};
+eval {
+ local $SIG{__WARN__} = sub { die @_ };
+ my $groucho : Stooge;
+};
+my $match = $@ =~ /^Won't be able to apply END handler/;
+if($] < 5.008) {
+ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers prior to 5.8");
+} else {
+ok( $match, 52 );
+}
+
+
+# The next two check for the phase invariance that Marcel spotted.
+# Subject: Attribute::Handlers phase variance
+# Message-Id: <54EDDB80-FD75-11D6-A18D-00039379E28A@noug.at>
+
+my ($code_applied, $scalar_applied);
+sub Scotty :ATTR(CODE,BEGIN) { $code_applied = $_[5] }
+{
+no warnings 'redefine';
+sub Scotty :ATTR(SCALAR,CHECK) { $scalar_applied = $_[5] }
+}
+
+sub warp_coil :Scotty {}
+my $photon_torpedo :Scotty;
+
+ok( $code_applied eq 'BEGIN', 53, "# phase variance" );
+ok( $scalar_applied eq 'CHECK', 54 );