Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[#672] Added Attrbute::Handlers from CPAN in to extlib and the prequi…

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

0 comments on commit cf24dd5

Please sign in to comment.
Something went wrong with that request. Please try again.