"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Attribute/Handlers.pm" (10 Mar 2019, 30449 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package Attribute::Handlers;
    2 use 5.006;
    3 use Carp;
    4 use warnings;
    5 use strict;
    6 our $AUTOLOAD;
    7 our $VERSION = '1.01'; # remember to update version in POD!
    8 # $DB::single=1;
    9 
   10 my %symcache;
   11 sub findsym {
   12     my ($pkg, $ref, $type) = @_;
   13     return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
   14     $type ||= ref($ref);
   15     no strict 'refs';
   16     my $symtab = \%{$pkg."::"};
   17     for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
   18         if (ref $sym && $sym == $ref) {
   19         return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
   20         }
   21         use strict;
   22         next unless ref ( \$sym ) eq 'GLOB';
   23             return $symcache{$pkg,$ref} = \$sym
   24         if *{$sym}{$type} && *{$sym}{$type} == $ref;
   25     }}
   26 }
   27 
   28 my %validtype = (
   29     VAR => [qw[SCALAR ARRAY HASH]],
   30         ANY => [qw[SCALAR ARRAY HASH CODE]],
   31         ""  => [qw[SCALAR ARRAY HASH CODE]],
   32         SCALAR  => [qw[SCALAR]],
   33         ARRAY   => [qw[ARRAY]],
   34         HASH    => [qw[HASH]],
   35         CODE    => [qw[CODE]],
   36 );
   37 my %lastattr;
   38 my @declarations;
   39 my %raw;
   40 my %phase;
   41 my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
   42 my $global_phase = 0;
   43 my %global_phases = (
   44     BEGIN   => 0,
   45     CHECK   => 1,
   46     INIT    => 2,
   47     END => 3,
   48 );
   49 my @global_phases = qw(BEGIN CHECK INIT END);
   50 
   51 sub _usage_AH_ {
   52     croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
   53 }
   54 
   55 my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
   56 
   57 sub import {
   58     my $class = shift @_;
   59     return unless $class eq "Attribute::Handlers";
   60     while (@_) {
   61     my $cmd = shift;
   62         if ($cmd =~ /^autotie((?:ref)?)$/) {
   63         my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
   64             my $mapping = shift;
   65         _usage_AH_ $class unless ref($mapping) eq 'HASH';
   66         while (my($attr, $tieclass) = each %$mapping) {
   67                 $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
   68         my $args = $3||'()';
   69         _usage_AH_ $class unless $attr =~ $qual_id
   70                          && $tieclass =~ $qual_id
   71                          && eval "use base q\0$tieclass\0; 1";
   72             if ($tieclass->isa('Exporter')) {
   73             local $Exporter::ExportLevel = 2;
   74             $tieclass->import(eval $args);
   75             }
   76         $attr =~ s/__CALLER__/caller(1)/e;
   77         $attr = caller()."::".$attr unless $attr =~ /::/;
   78             eval qq{
   79                 sub $attr : ATTR(VAR) {
   80             my (\$ref, \$data) = \@_[2,4];
   81             my \$was_arrayref = ref \$data eq 'ARRAY';
   82             \$data = [ \$data ] unless \$was_arrayref;
   83             my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
   84              (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
   85             :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
   86             :(\$type eq 'HASH')  ? tie \%\$ref,'$tieclass',$tiedata
   87             : die "Can't autotie a \$type\n"
   88                 } 1
   89             } or die "Internal error: $@";
   90         }
   91         }
   92         else {
   93             croak "Can't understand $_"; 
   94         }
   95     }
   96 }
   97 
   98 # On older perls, code attribute handlers run before the sub gets placed
   99 # in its package.  Since the :ATTR handlers need to know the name of the
  100 # sub they're applied to, the name lookup (via findsym) needs to be
  101 # delayed: we do it immediately before we might need to find attribute
  102 # handlers from their name.  However, on newer perls (which fix some
  103 # problems relating to attribute application), a sub gets placed in its
  104 # package before its attributes are processed.  In this case, the
  105 # delayed name lookup might be too late, because the sub we're looking
  106 # for might have already been replaced.  So we need to detect which way
  107 # round this perl does things, and time the name lookup accordingly.
  108 BEGIN {
  109     my $delayed;
  110     sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
  111         $delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
  112         return ();
  113     }
  114     sub Attribute::Handlers::_TEST_::t :T { }
  115     *_delayed_name_resolution = sub() { $delayed };
  116     undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
  117     undef &Attribute::Handlers::_TEST_::t;
  118 }
  119 
  120 sub _resolve_lastattr {
  121     return unless $lastattr{ref};
  122     my $sym = findsym @lastattr{'pkg','ref'}
  123         or die "Internal error: $lastattr{pkg} symbol went missing";
  124     my $name = *{$sym}{NAME};
  125     warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
  126         if $^W and $name !~ /[A-Z]/;
  127     foreach ( @{$validtype{$lastattr{type}}} ) {
  128         no strict 'refs';
  129         *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
  130     }
  131     %lastattr = ();
  132 }
  133 
  134 sub AUTOLOAD {
  135     return if $AUTOLOAD =~ /::DESTROY$/;
  136     my ($class) = $AUTOLOAD =~ m/(.*)::/g;
  137     $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
  138         croak "Can't locate class method '$AUTOLOAD' via package '$class'";
  139     croak "Attribute handler '$2' doesn't handle $1 attributes";
  140 }
  141 
  142 my $builtin = $] ge '5.027000'
  143     ? qr/lvalue|method|shared/
  144     : qr/lvalue|method|locked|shared|unique/;
  145 
  146 sub _gen_handler_AH_() {
  147     return sub {
  148         _resolve_lastattr if _delayed_name_resolution;
  149         my ($pkg, $ref, @attrs) = @_;
  150         my (undef, $filename, $linenum) = caller 2;
  151         foreach (@attrs) {
  152         my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
  153         if ($attr eq 'ATTR') {
  154             no strict 'refs';
  155             $data ||= "ANY";
  156             $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
  157             $phase{$ref}{BEGIN} = 1
  158                 if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
  159             $phase{$ref}{INIT} = 1
  160                 if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
  161             $phase{$ref}{END} = 1
  162                 if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
  163             $phase{$ref}{CHECK} = 1
  164                 if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
  165                 || ! keys %{$phase{$ref}};
  166             # Added for cleanup to not pollute next call.
  167             (%lastattr = ()),
  168             croak "Can't have two ATTR specifiers on one subroutine"
  169                 if keys %lastattr;
  170             croak "Bad attribute type: ATTR($data)"
  171                 unless $validtype{$data};
  172             %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
  173             _resolve_lastattr unless _delayed_name_resolution;
  174         }
  175         else {
  176             my $type = ref $ref;
  177             my $handler = $pkg->can("_ATTR_${type}_${attr}");
  178             next unless $handler;
  179                 my $decl = [$pkg, $ref, $attr, $data,
  180                     $raw{$handler}, $phase{$handler}, $filename, $linenum];
  181             foreach my $gphase (@global_phases) {
  182                 _apply_handler_AH_($decl,$gphase)
  183                 if $global_phases{$gphase} <= $global_phase;
  184             }
  185             if ($global_phase != 0) {
  186                 # if _gen_handler_AH_ is being called after 
  187                 # CHECK it's for a lexical, so make sure
  188                 # it didn't want to run anything later
  189             
  190                 local $Carp::CarpLevel = 2;
  191                 carp "Won't be able to apply END handler"
  192                     if $phase{$handler}{END};
  193             }
  194             else {
  195                 push @declarations, $decl
  196             }
  197         }
  198         $_ = undef;
  199         }
  200         return grep {defined && !/$builtin/} @attrs;
  201     }
  202 }
  203 
  204 {
  205     no strict 'refs';
  206     *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
  207     _gen_handler_AH_ foreach @{$validtype{ANY}};
  208 }
  209 push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
  210        unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
  211 
  212 sub _apply_handler_AH_ {
  213     my ($declaration, $phase) = @_;
  214     my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
  215     return unless $handlerphase->{$phase};
  216     # print STDERR "Handling $attr on $ref in $phase with [$data]\n";
  217     my $type = ref $ref;
  218     my $handler = "_ATTR_${type}_${attr}";
  219     my $sym = findsym($pkg, $ref);
  220     $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
  221     no warnings;
  222     if (!$raw && defined($data)) {
  223         if ($data ne '') {
  224         my $evaled = eval("package $pkg; no warnings; no strict;
  225                    local \$SIG{__WARN__}=sub{die}; [$data]");
  226         $data = $evaled unless $@;
  227         }
  228         else { $data = undef }
  229     }
  230     $pkg->$handler($sym,
  231                (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
  232                $attr,
  233                $data,
  234                $phase,
  235                $filename,
  236                $linenum,
  237               );
  238     return 1;
  239 }
  240 
  241 {
  242         no warnings 'void';
  243         CHECK {
  244                 $global_phase++;
  245                 _resolve_lastattr if _delayed_name_resolution;
  246                 foreach my $decl (@declarations) {
  247                         _apply_handler_AH_($decl, 'CHECK');
  248                 }
  249         }
  250 
  251         INIT {
  252                 $global_phase++;
  253                 foreach my $decl (@declarations) {
  254                         _apply_handler_AH_($decl, 'INIT');
  255                 }
  256         }
  257 }
  258 
  259 END {
  260         $global_phase++;
  261         foreach my $decl (@declarations) {
  262                 _apply_handler_AH_($decl, 'END');
  263         }
  264 }
  265 
  266 1;
  267 __END__
  268 
  269 =head1 NAME
  270 
  271 Attribute::Handlers - Simpler definition of attribute handlers
  272 
  273 =head1 VERSION
  274 
  275 This document describes version 1.01 of Attribute::Handlers.
  276 
  277 =head1 SYNOPSIS
  278 
  279     package MyClass;
  280     require 5.006;
  281     use Attribute::Handlers;
  282     no warnings 'redefine';
  283 
  284 
  285     sub Good : ATTR(SCALAR) {
  286     my ($package, $symbol, $referent, $attr, $data) = @_;
  287 
  288     # Invoked for any scalar variable with a :Good attribute,
  289     # provided the variable was declared in MyClass (or
  290     # a derived class) or typed to MyClass.
  291 
  292     # Do whatever to $referent here (executed in CHECK phase).
  293     ...
  294     }
  295 
  296     sub Bad : ATTR(SCALAR) {
  297     # Invoked for any scalar variable with a :Bad attribute,
  298     # provided the variable was declared in MyClass (or
  299     # a derived class) or typed to MyClass.
  300     ...
  301     }
  302 
  303     sub Good : ATTR(ARRAY) {
  304     # Invoked for any array variable with a :Good attribute,
  305     # provided the variable was declared in MyClass (or
  306     # a derived class) or typed to MyClass.
  307     ...
  308     }
  309 
  310     sub Good : ATTR(HASH) {
  311     # Invoked for any hash variable with a :Good attribute,
  312     # provided the variable was declared in MyClass (or
  313     # a derived class) or typed to MyClass.
  314     ...
  315     }
  316 
  317     sub Ugly : ATTR(CODE) {
  318     # Invoked for any subroutine declared in MyClass (or a 
  319     # derived class) with an :Ugly attribute.
  320     ...
  321     }
  322 
  323     sub Omni : ATTR {
  324     # Invoked for any scalar, array, hash, or subroutine
  325     # with an :Omni attribute, provided the variable or
  326     # subroutine was declared in MyClass (or a derived class)
  327     # or the variable was typed to MyClass.
  328     # Use ref($_[2]) to determine what kind of referent it was.
  329     ...
  330     }
  331 
  332 
  333     use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
  334 
  335     my $next : Cycle(['A'..'Z']);
  336 
  337 
  338 =head1 DESCRIPTION
  339 
  340 This module, when inherited by a package, allows that package's class to
  341 define attribute handler subroutines for specific attributes. Variables
  342 and subroutines subsequently defined in that package, or in packages
  343 derived from that package may be given attributes with the same names as
  344 the attribute handler subroutines, which will then be called in one of
  345 the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
  346 block). (C<UNITCHECK> blocks don't correspond to a global compilation
  347 phase, so they can't be specified here.)
  348 
  349 To create a handler, define it as a subroutine with the same name as
  350 the desired attribute, and declare the subroutine itself with the  
  351 attribute C<:ATTR>. For example:
  352 
  353     package LoudDecl;
  354     use Attribute::Handlers;
  355 
  356     sub Loud :ATTR {
  357     my ($package, $symbol, $referent, $attr, $data, $phase,
  358         $filename, $linenum) = @_;
  359     print STDERR
  360         ref($referent), " ",
  361         *{$symbol}{NAME}, " ",
  362         "($referent) ", "was just declared ",
  363         "and ascribed the ${attr} attribute ",
  364         "with data ($data)\n",
  365         "in phase $phase\n",
  366         "in file $filename at line $linenum\n";
  367     }
  368 
  369 This creates a handler for the attribute C<:Loud> in the class LoudDecl.
  370 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
  371 LoudDecl:
  372 
  373     package LoudDecl;
  374 
  375     sub foo: Loud {...}
  376 
  377 causes the above handler to be invoked, and passed:
  378 
  379 =over
  380 
  381 =item [0]
  382 
  383 the name of the package into which it was declared;
  384 
  385 =item [1]
  386 
  387 a reference to the symbol table entry (typeglob) containing the subroutine;
  388 
  389 =item [2]
  390 
  391 a reference to the subroutine;
  392 
  393 =item [3]
  394 
  395 the name of the attribute;
  396 
  397 =item [4]
  398 
  399 any data associated with that attribute;
  400 
  401 =item [5]
  402 
  403 the name of the phase in which the handler is being invoked;
  404 
  405 =item [6]
  406 
  407 the filename in which the handler is being invoked;
  408 
  409 =item [7]
  410 
  411 the line number in this file.
  412 
  413 =back
  414 
  415 Likewise, declaring any variables with the C<:Loud> attribute within the
  416 package:
  417 
  418     package LoudDecl;
  419 
  420     my $foo :Loud;
  421     my @foo :Loud;
  422     my %foo :Loud;
  423 
  424 will cause the handler to be called with a similar argument list (except,
  425 of course, that C<$_[2]> will be a reference to the variable).
  426 
  427 The package name argument will typically be the name of the class into
  428 which the subroutine was declared, but it may also be the name of a derived
  429 class (since handlers are inherited).
  430 
  431 If a lexical variable is given an attribute, there is no symbol table to 
  432 which it belongs, so the symbol table argument (C<$_[1]>) is set to the
  433 string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
  434 an anonymous subroutine results in a symbol table argument of C<'ANON'>.
  435 
  436 The data argument passes in the value (if any) associated with the
  437 attribute. For example, if C<&foo> had been declared:
  438 
  439         sub foo :Loud("turn it up to 11, man!") {...}
  440 
  441 then a reference to an array containing the string
  442 C<"turn it up to 11, man!"> would be passed as the last argument.
  443 
  444 Attribute::Handlers makes strenuous efforts to convert
  445 the data argument (C<$_[4]>) to a usable form before passing it to
  446 the handler (but see L<"Non-interpretive attribute handlers">).
  447 If those efforts succeed, the interpreted data is passed in an array
  448 reference; if they fail, the raw data is passed as a string.
  449 For example, all of these:
  450 
  451     sub foo :Loud(till=>ears=>are=>bleeding) {...}
  452     sub foo :Loud(qw/till ears are bleeding/) {...}
  453     sub foo :Loud(qw/till, ears, are, bleeding/) {...}
  454     sub foo :Loud(till,ears,are,bleeding) {...}
  455 
  456 causes it to pass C<['till','ears','are','bleeding']> as the handler's
  457 data argument. While:
  458 
  459     sub foo :Loud(['till','ears','are','bleeding']) {...}
  460 
  461 causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
  462 reference specified in the data being passed inside the standard
  463 array reference indicating successful interpretation.
  464 
  465 However, if the data can't be parsed as valid Perl, then
  466 it is passed as an uninterpreted string. For example:
  467 
  468     sub foo :Loud(my,ears,are,bleeding) {...}
  469     sub foo :Loud(qw/my ears are bleeding) {...}
  470 
  471 cause the strings C<'my,ears,are,bleeding'> and
  472 C<'qw/my ears are bleeding'> respectively to be passed as the
  473 data argument.
  474 
  475 If no value is associated with the attribute, C<undef> is passed.
  476 
  477 =head2 Typed lexicals
  478 
  479 Regardless of the package in which it is declared, if a lexical variable is
  480 ascribed an attribute, the handler that is invoked is the one belonging to
  481 the package to which it is typed. For example, the following declarations:
  482 
  483     package OtherClass;
  484 
  485     my LoudDecl $loudobj : Loud;
  486     my LoudDecl @loudobjs : Loud;
  487     my LoudDecl %loudobjex : Loud;
  488 
  489 causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
  490 defines a handler for C<:Loud> attributes).
  491 
  492 
  493 =head2 Type-specific attribute handlers
  494 
  495 If an attribute handler is declared and the C<:ATTR> specifier is
  496 given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
  497 the handler is only applied to declarations of that type. For example,
  498 the following definition:
  499 
  500     package LoudDecl;
  501 
  502     sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
  503 
  504 creates an attribute handler that applies only to scalars:
  505 
  506 
  507     package Painful;
  508     use base LoudDecl;
  509 
  510     my $metal : RealLoud;           # invokes &LoudDecl::RealLoud
  511     my @metal : RealLoud;           # error: unknown attribute
  512     my %metal : RealLoud;           # error: unknown attribute
  513     sub metal : RealLoud {...}      # error: unknown attribute
  514 
  515 You can, of course, declare separate handlers for these types as well
  516 (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
  517 
  518     package LoudDecl;
  519     use Attribute::Handlers;
  520     no warnings 'redefine';
  521 
  522     sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
  523     sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
  524     sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
  525     sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
  526 
  527 You can also explicitly indicate that a single handler is meant to be
  528 used for all types of referents like so:
  529 
  530     package LoudDecl;
  531     use Attribute::Handlers;
  532 
  533     sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
  534 
  535 (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
  536 
  537 
  538 =head2 Non-interpretive attribute handlers
  539 
  540 Occasionally the strenuous efforts Attribute::Handlers makes to convert
  541 the data argument (C<$_[4]>) to a usable form before passing it to
  542 the handler get in the way.
  543 
  544 You can turn off that eagerness-to-help by declaring
  545 an attribute handler with the keyword C<RAWDATA>. For example:
  546 
  547     sub Raw          : ATTR(RAWDATA) {...}
  548     sub Nekkid       : ATTR(SCALAR,RAWDATA) {...}
  549     sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
  550 
  551 Then the handler makes absolutely no attempt to interpret the data it
  552 receives and simply passes it as a string:
  553 
  554     my $power : Raw(1..100);        # handlers receives "1..100"
  555 
  556 =head2 Phase-specific attribute handlers
  557 
  558 By default, attribute handlers are called at the end of the compilation
  559 phase (in a C<CHECK> block). This seems to be optimal in most cases because
  560 most things that can be defined are defined by that point but nothing has
  561 been executed.
  562 
  563 However, it is possible to set up attribute handlers that are called at
  564 other points in the program's compilation or execution, by explicitly
  565 stating the phase (or phases) in which you wish the attribute handler to
  566 be called. For example:
  567 
  568     sub Early    :ATTR(SCALAR,BEGIN) {...}
  569     sub Normal   :ATTR(SCALAR,CHECK) {...}
  570     sub Late     :ATTR(SCALAR,INIT) {...}
  571     sub Final    :ATTR(SCALAR,END) {...}
  572     sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
  573 
  574 As the last example indicates, a handler may be set up to be (re)called in
  575 two or more phases. The phase name is passed as the handler's final argument.
  576 
  577 Note that attribute handlers that are scheduled for the C<BEGIN> phase
  578 are handled as soon as the attribute is detected (i.e. before any
  579 subsequently defined C<BEGIN> blocks are executed).
  580 
  581 
  582 =head2 Attributes as C<tie> interfaces
  583 
  584 Attributes make an excellent and intuitive interface through which to tie
  585 variables. For example:
  586 
  587     use Attribute::Handlers;
  588     use Tie::Cycle;
  589 
  590     sub UNIVERSAL::Cycle : ATTR(SCALAR) {
  591     my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
  592     $data = [ $data ] unless ref $data eq 'ARRAY';
  593     tie $$referent, 'Tie::Cycle', $data;
  594     }
  595 
  596     # and thereafter...
  597 
  598     package main;
  599 
  600     my $next : Cycle('A'..'Z');     # $next is now a tied variable
  601 
  602     while (<>) {
  603     print $next;
  604     }
  605 
  606 Note that, because the C<Cycle> attribute receives its arguments in the
  607 C<$data> variable, if the attribute is given a list of arguments, C<$data>
  608 will consist of a single array reference; otherwise, it will consist of the
  609 single argument directly. Since Tie::Cycle requires its cycling values to
  610 be passed as an array reference, this means that we need to wrap
  611 non-array-reference arguments in an array constructor:
  612 
  613     $data = [ $data ] unless ref $data eq 'ARRAY';
  614 
  615 Typically, however, things are the other way around: the tieable class expects
  616 its arguments as a flattened list, so the attribute looks like:
  617 
  618     sub UNIVERSAL::Cycle : ATTR(SCALAR) {
  619     my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
  620     my @data = ref $data eq 'ARRAY' ? @$data : $data;
  621     tie $$referent, 'Tie::Whatever', @data;
  622     }
  623 
  624 
  625 This software pattern is so widely applicable that Attribute::Handlers
  626 provides a way to automate it: specifying C<'autotie'> in the
  627 C<use Attribute::Handlers> statement. So, the cycling example,
  628 could also be written:
  629 
  630     use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
  631 
  632     # and thereafter...
  633 
  634     package main;
  635 
  636     my $next : Cycle(['A'..'Z']);     # $next is now a tied variable
  637 
  638     while (<>) {
  639     print $next;
  640     }
  641 
  642 Note that we now have to pass the cycling values as an array reference,
  643 since the C<autotie> mechanism passes C<tie> a list of arguments as a list
  644 (as in the Tie::Whatever example), I<not> as an array reference (as in
  645 the original Tie::Cycle example at the start of this section).
  646 
  647 The argument after C<'autotie'> is a reference to a hash in which each key is
  648 the name of an attribute to be created, and each value is the class to which
  649 variables ascribed that attribute should be tied.
  650 
  651 Note that there is no longer any need to import the Tie::Cycle module --
  652 Attribute::Handlers takes care of that automagically. You can even pass
  653 arguments to the module's C<import> subroutine, by appending them to the
  654 class name. For example:
  655 
  656     use Attribute::Handlers
  657      autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
  658 
  659 If the attribute name is unqualified, the attribute is installed in the
  660 current package. Otherwise it is installed in the qualifier's package:
  661 
  662     package Here;
  663 
  664     use Attribute::Handlers autotie => {
  665          Other::Good => Tie::SecureHash, # tie attr installed in Other::
  666                  Bad => Tie::Taxes,      # tie attr installed in Here::
  667      UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
  668     };
  669 
  670 Autoties are most commonly used in the module to which they actually tie, 
  671 and need to export their attributes to any module that calls them. To
  672 facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
  673 C<__CALLER__>, which may be specified as the qualifier of an attribute:
  674 
  675     package Tie::Me::Kangaroo:Down::Sport;
  676 
  677     use Attribute::Handlers autotie =>
  678      { '__CALLER__::Roo' => __PACKAGE__ };
  679 
  680 This causes Attribute::Handlers to define the C<Roo> attribute in the package
  681 that imports the Tie::Me::Kangaroo:Down::Sport module.
  682 
  683 Note that it is important to quote the __CALLER__::Roo identifier because
  684 a bug in perl 5.8 will refuse to parse it and cause an unknown error.
  685 
  686 =head3 Passing the tied object to C<tie>
  687 
  688 Occasionally it is important to pass a reference to the object being tied
  689 to the TIESCALAR, TIEHASH, etc. that ties it. 
  690 
  691 The C<autotie> mechanism supports this too. The following code:
  692 
  693     use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
  694     my $var : Selfish(@args);
  695 
  696 has the same effect as:
  697 
  698     tie my $var, 'Tie::Selfish', @args;
  699 
  700 But when C<"autotieref"> is used instead of C<"autotie">:
  701 
  702     use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
  703     my $var : Selfish(@args);
  704 
  705 the effect is to pass the C<tie> call an extra reference to the variable
  706 being tied:
  707 
  708     tie my $var, 'Tie::Selfish', \$var, @args;
  709 
  710 
  711 
  712 =head1 EXAMPLES
  713 
  714 If the class shown in L</SYNOPSIS> were placed in the MyClass.pm
  715 module, then the following code:
  716 
  717     package main;
  718     use MyClass;
  719 
  720     my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
  721 
  722     package SomeOtherClass;
  723     use base MyClass;
  724 
  725     sub tent { 'acle' }
  726 
  727     sub fn :Ugly(sister) :Omni('po',tent()) {...}
  728     my @arr :Good :Omni(s/cie/nt/);
  729     my %hsh :Good(q/bye/) :Omni(q/bus/);
  730 
  731 
  732 would cause the following handlers to be invoked:
  733 
  734     # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
  735 
  736     MyClass::Good:ATTR(SCALAR)( 'MyClass',          # class
  737                                 'LEXICAL',          # no typeglob
  738                                 \$slr,              # referent
  739                                 'Good',             # attr name
  740                                 undef               # no attr data
  741                                 'CHECK',            # compiler phase
  742                               );
  743 
  744     MyClass::Bad:ATTR(SCALAR)( 'MyClass',           # class
  745                                'LEXICAL',           # no typeglob
  746                                \$slr,               # referent
  747                                'Bad',               # attr name
  748                                0                    # eval'd attr data
  749                                'CHECK',             # compiler phase
  750                              );
  751 
  752     MyClass::Omni:ATTR(SCALAR)( 'MyClass',          # class
  753                                 'LEXICAL',          # no typeglob
  754                                 \$slr,              # referent
  755                                 'Omni',             # attr name
  756                                 '-vorous'           # eval'd attr data
  757                                 'CHECK',            # compiler phase
  758                               );
  759 
  760 
  761     # sub fn :Ugly(sister) :Omni('po',tent()) {...}
  762 
  763     MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass',     # class
  764                               \*SomeOtherClass::fn, # typeglob
  765                               \&SomeOtherClass::fn, # referent
  766                               'Ugly',               # attr name
  767                               'sister'              # eval'd attr data
  768                               'CHECK',              # compiler phase
  769                             );
  770 
  771     MyClass::Omni:ATTR(CODE)( 'SomeOtherClass',     # class
  772                               \*SomeOtherClass::fn, # typeglob
  773                               \&SomeOtherClass::fn, # referent
  774                               'Omni',               # attr name
  775                               ['po','acle']         # eval'd attr data
  776                               'CHECK',              # compiler phase
  777                             );
  778 
  779 
  780     # my @arr :Good :Omni(s/cie/nt/);
  781 
  782     MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass',    # class
  783                                'LEXICAL',           # no typeglob
  784                                \@arr,               # referent
  785                                'Good',              # attr name
  786                                undef                # no attr data
  787                                'CHECK',             # compiler phase
  788                              );
  789 
  790     MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass',    # class
  791                                'LEXICAL',           # no typeglob
  792                                \@arr,               # referent
  793                                'Omni',              # attr name
  794                                ""                   # eval'd attr data 
  795                                'CHECK',             # compiler phase
  796                              );
  797 
  798 
  799     # my %hsh :Good(q/bye) :Omni(q/bus/);
  800 
  801     MyClass::Good:ATTR(HASH)( 'SomeOtherClass',     # class
  802                               'LEXICAL',            # no typeglob
  803                               \%hsh,                # referent
  804                               'Good',               # attr name
  805                               'q/bye'               # raw attr data
  806                               'CHECK',              # compiler phase
  807                             );
  808 
  809     MyClass::Omni:ATTR(HASH)( 'SomeOtherClass',     # class
  810                               'LEXICAL',            # no typeglob
  811                               \%hsh,                # referent
  812                               'Omni',               # attr name
  813                               'bus'                 # eval'd attr data
  814                               'CHECK',              # compiler phase
  815                             );
  816 
  817 
  818 Installing handlers into UNIVERSAL, makes them...err..universal.
  819 For example:
  820 
  821     package Descriptions;
  822     use Attribute::Handlers;
  823 
  824     my %name;
  825     sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
  826 
  827     sub UNIVERSAL::Name :ATTR {
  828         $name{$_[2]} = $_[4];
  829     }
  830 
  831     sub UNIVERSAL::Purpose :ATTR {
  832         print STDERR "Purpose of ", &name, " is $_[4]\n";
  833     }
  834 
  835     sub UNIVERSAL::Unit :ATTR {
  836         print STDERR &name, " measured in $_[4]\n";
  837     }
  838 
  839 Let's you write:
  840 
  841     use Descriptions;
  842 
  843     my $capacity : Name(capacity)
  844                  : Purpose(to store max storage capacity for files)
  845                  : Unit(Gb);
  846 
  847 
  848     package Other;
  849 
  850     sub foo : Purpose(to foo all data before barring it) { }
  851 
  852     # etc.
  853 
  854 =head1 UTILITY FUNCTIONS
  855 
  856 This module offers a single utility function, C<findsym()>.
  857 
  858 =over 4
  859 
  860 =item findsym
  861 
  862     my $symbol = Attribute::Handlers::findsym($package, $referent);
  863 
  864 The function looks in the symbol table of C<$package> for the typeglob for
  865 C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
  866 HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
  867 undef. Note that C<findsym> memoizes the typeglobs it has previously
  868 successfully found, so subsequent calls with the same arguments should be
  869 much faster.
  870 
  871 =back
  872 
  873 =head1 DIAGNOSTICS
  874 
  875 =over
  876 
  877 =item C<Bad attribute type: ATTR(%s)>
  878 
  879 An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
  880 type of referent it was defined to handle wasn't one of the five permitted:
  881 C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
  882 
  883 =item C<Attribute handler %s doesn't handle %s attributes>
  884 
  885 A handler for attributes of the specified name I<was> defined, but not
  886 for the specified type of declaration. Typically encountered when trying
  887 to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
  888 attribute handler to some other type of variable.
  889 
  890 =item C<Declaration of %s attribute in package %s may clash with future reserved word>
  891 
  892 A handler for an attributes with an all-lowercase name was declared. An
  893 attribute with an all-lowercase name might have a meaning to Perl
  894 itself some day, even though most don't yet. Use a mixed-case attribute
  895 name, instead.
  896 
  897 =item C<Can't have two ATTR specifiers on one subroutine>
  898 
  899 You just can't, okay?
  900 Instead, put all the specifications together with commas between them
  901 in a single C<ATTR(I<specification>)>.
  902 
  903 =item C<Can't autotie a %s>
  904 
  905 You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
  906 C<"HASH">. They're the only things (apart from typeglobs -- which are
  907 not declarable) that Perl can tie.
  908 
  909 =item C<Internal error: %s symbol went missing>
  910 
  911 Something is rotten in the state of the program. An attributed
  912 subroutine ceased to exist between the point it was declared and the point
  913 at which its attribute handler(s) would have been called.
  914 
  915 =item C<Won't be able to apply END handler>
  916 
  917 You have defined an END handler for an attribute that is being applied
  918 to a lexical variable.  Since the variable may not be available during END
  919 this won't happen.
  920 
  921 =back
  922 
  923 =head1 AUTHOR
  924 
  925 Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
  926 Garcia-Suarez (rgarciasuarez@gmail.com).
  927 
  928 Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
  929 Contact him with technical difficulties with respect to the packaging of the
  930 CPAN module.
  931 
  932 =head1 BUGS
  933 
  934 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
  935 Bug reports and other feedback are most welcome.
  936 
  937 =head1 COPYRIGHT AND LICENSE
  938 
  939          Copyright (c) 2001-2014, Damian Conway. All Rights Reserved.
  940        This module is free software. It may be used, redistributed
  941            and/or modified under the same terms as Perl itself.