diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-28 10:48:53 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-28 10:48:53 +0100 |
commit | 5fe6925c645093b14564777709b7e36a489625c8 (patch) | |
tree | 8d0d59c1a28ce26bb8e2e1140297e3d74c7e06d9 /dist/Attribute-Handlers | |
parent | d284e2f9a7b9f1200f7e4be388deac2dd968a435 (diff) | |
download | perl-5fe6925c645093b14564777709b7e36a489625c8.tar.gz |
Move Attribute::Handlers from ext/ to dist/
Diffstat (limited to 'dist/Attribute-Handlers')
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 ); |