lib/Attribute/Handlers.pm

   1 package Attribute::Handlers;
   2 use 5.006;
   3 use Carp;
   4 use warnings;
   5 $VERSION = '0.61';
   6 $DB::single=1;
   7
   8 sub findsym {
   9         my ($pkg, $ref, $type) = @_;
  10         $type ||= ref($ref);
  11         foreach my $sym ( values %{$pkg."::"} ) {
  12                return $sym if *{$sym}{$type} && *{$sym}{$type} == $ref;
  13         }
  14 }
  15
  16 my %validtype = (
  17         VAR     => [qw[SCALAR ARRAY HASH]],
  18         ANY     => [qw[SCALAR ARRAY HASH CODE]],
  19         ""      => [qw[SCALAR ARRAY HASH CODE]],
  20         SCALAR  => [qw[SCALAR]],
  21         ARRAY   => [qw[ARRAY]],
  22         HASH    => [qw[HASH]],
  23         CODE    => [qw[CODE]],
  24 );
  25 my %lastattr;
  26 my @declarations;
  27 my %raw;
  28 my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
  29
  30 sub usage {croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}"}
  31
  32 sub import {
  33     my $class = shift @_;
  34     while (@_) {
  35         my $cmd = shift;
  36         if ($cmd eq 'autotie') {
  37             my $mapping = shift;
  38             usage $class unless ref($mapping) eq 'HASH';
  39             while (my($attr, $tieclass) = each %$mapping) {
  40                 usage $class unless $attr =~ m/^[a-z]\w*(::[a-z]\w*)*$/i
  41                                  && $tieclass =~ m/^[a-z]\w*(::[a-z]\w*)*$/i
  42                                  && eval "use base $tieclass; 1";
  43                 eval qq{
  44                     sub $attr : ATTR(VAR) {
  45                         my (\$ref, \$data) = \@_[2,4];
  46                         \$data = [ \$data ] unless ref \$data eq 'ARRAY';
  47                         my \$type = ref \$ref;
  48                          (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',\@\$data
  49                         :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data
  50                         :(\$type eq 'HASH')  ? tie \%\$ref,'$tieclass',\@\$data
  51                         : die "Internal error: can't autotie \$type"
  52                     } 1
  53                 } or die "Internal error: $@";
  54             }
  55         }
  56         else {
  57             croak "Can't understand $_";
  58         }
  59     }
  60 }
  61 sub resolve_lastattr {
  62         return unless $lastattr{ref};
  63         my $sym = findsym @lastattr{'pkg','ref'}
  64                 or die "Internal error: $lastattr{pkg} symbol went missing";
  65         my $name = *{$sym}{NAME};
  66         warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
  67                 if $^W and $name !~ /[A-Z]/;
  68         foreach ( @{$validtype{$lastattr{type}}} ) {
  69                 *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
  70         }
  71         %lastattr = ();
  72 }
  73
  74 sub AUTOLOAD {
  75         my ($class) = @_;
  76         $AUTOLOAD =~ /_ATTR_(.*?)_(.*)/ or
  77             croak "Can't locate class method '$AUTOLOAD' via package '$class'";
  78         croak "Attribute handler '$2' doesn't handle $1 attributes";
  79 }
  80
  81 sub DESTROY {}
  82
  83 my $builtin = qr/lvalue|method|locked/;
  84
  85 sub handler() {
  86         return sub {
  87             resolve_lastattr;
  88             my ($pkg, $ref, @attrs) = @_;
  89             foreach (@attrs) {
  90                 my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/i or next;
  91                 if ($attr eq 'ATTR') {
  92                         $data ||= "ANY";
  93                         $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
  94                         croak "Bad attribute type: ATTR($data)"
  95                                 unless $validtype{$data};
  96                         %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
  97                 }
  98                 else {
  99                         my $handler = $pkg->can($attr);
 100                         next unless $handler;
 101                         push @declarations,
 102                              [$pkg, $ref, $attr, $data, $raw{$handler}];
 103                 }
 104                 $_ = undef;
 105             }
 106             return grep {defined && !/$builtin/} @attrs;
 107         }
 108 }
 109
 110 *{"MODIFY_${_}_ATTRIBUTES"} = handler foreach @{$validtype{ANY}};
 111 push @UNIVERSAL::ISA, 'Attribute::Handlers'
 112         unless grep /^Attribute::Handlers$/, @UNIVERSAL::ISA;
 113
 114 CHECK {
 115         resolve_lastattr;
 116         foreach (@declarations) {
 117                 my ($pkg, $ref, $attr, $data, $raw) = @$_;
 118                 my $type = ref $ref;
 119                 my $sym = findsym($pkg, $ref);
 120                 $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
 121                 my $handler = "_ATTR_${type}_${attr}";
 122                 no warnings;
 123                 my $evaled = !$raw && eval("package $pkg; no warnings;
 124                                             \$SIG{__WARN__}=sub{die}; [$data]");
 125                 $data = ($evaled && $data =~ /^\s*\[/)  ? [$evaled]
 126                       : ($evaled)                       ? $evaled
 127                       :                                   [$data];
 128                 $pkg->$handler($sym, $ref, $attr, @$data>1? $data : $data->[0]);
 129         }
 130 }
 131
 132 1;
 133 __END__
 134
 135 =head1 NAME
 136
 137 Attribute::Handlers - Simpler definition of attribute handlers
 138
 139 =head1 VERSION
 140
 141 This document describes version 0.61 of Attribute::Handlers,
 142 released May 10, 2001.
 143
 144 =head1 SYNOPSIS
 145
 146         package MyClass;
 147         require v5.6.0;
 148         use Attribute::Handlers;
 149         no warnings 'redefine';
 150
 151
 152         sub Good : ATTR(SCALAR) {
 153                 my ($package, $symbol, $referent, $attr, $data) = @_;
 154
 155                 # Invoked for any scalar variable with a :Good attribute,
 156                 # provided the variable was declared in MyClass (or
 157                 # a derived class) or typed to MyClass.
 158
 159                 # Do whatever to $referent here (executed in CHECK phase).
 160                 ...
 161         }
 162
 163         sub Bad : ATTR(SCALAR) {
 164                 # Invoked for any scalar variable with a :Bad attribute,
 165                 # provided the variable was declared in MyClass (or
 166                 # a derived class) or typed to MyClass.
 167                 ...
 168         }
 169
 170         sub Good : ATTR(ARRAY) {
 171                 # Invoked for any array variable with a :Good attribute,
 172                 # provided the variable was declared in MyClass (or
 173                 # a derived class) or typed to MyClass.
 174                 ...
 175         }
 176
 177         sub Good : ATTR(HASH) {
 178                 # Invoked for any hash variable with a :Good attribute,
 179                 # provided the variable was declared in MyClass (or
 180                 # a derived class) or typed to MyClass.
 181                 ...
 182         }
 183
 184         sub Ugly : ATTR(CODE) {
 185                 # Invoked for any subroutine declared in MyClass (or a
 186                 # derived class) with an :Ugly attribute.
 187                 ...
 188         }
 189
 190         sub Omni : ATTR {
 191                 # Invoked for any scalar, array, hash, or subroutine
 192                 # with an :Omni attribute, provided the variable or
 193                 # subroutine was declared in MyClass (or a derived class)
 194                 # or the variable was typed to MyClass.
 195                 # Use ref($_[2]) to determine what kind of referent it was.
 196                 ...
 197         }
 198
 199
 200         use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
 201
 202         my $next : Cycle(['A'..'Z']);
 203
 204
 205 =head1 DESCRIPTION
 206
 207 This module, when inherited by a package, allows that package's class to
 208 define attribute handler subroutines for specific attributes. Variables
 209 and subroutines subsequently defined in that package, or in packages
 210 derived from that package may be given attributes with the same names as
 211 the attribute handler subroutines, which will then be called at the end
 212 of the compilation phase (i.e. in a C<CHECK> block).
 213
 214 To create a handler, define it as a subroutine with the same name as
 215 the desired attribute, and declare the subroutine itself with the
 216 attribute C<:ATTR>. For example:
 217
 218         package LoudDecl;
 219         use Attribute::Handlers;
 220
 221         sub Loud :ATTR {
 222                 my ($package, $symbol, $referent, $attr, $data) = @_;
 223                 print STDERR
 224                         ref($referent), " ",
 225                         *{$symbol}{NAME}, " ",
 226                         "($referent) ", "was just declared ",
 227                         "and ascribed the ${attr} attribute ",
 228                         "with data ($data)\n";
 229         }
 230
 231 This creates an handler for the attribute C<:Loud> in the class LoudDecl.
 232 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
 233 LoudDecl:
 234
 235         package LoudDecl;
 236
 237         sub foo: Loud {...}
 238
 239 causes the above handler to be invoked, and passed:
 240
 241 =over
 242
 243 =item [0]
 244
 245 the name of the package into which it was declared;
 246
 247 =item [1]
 248
 249 a reference to the symbol table entry (typeglob) containing the subroutine;
 250
 251 =item [2]
 252
 253 a reference to the subroutine;
 254
 255 =item [3]
 256
 257 the name of the attribute;
 258
 259 =item [4]
 260
 261 any data associated with that attribute.
 262
 263 =back
 264
 265 Likewise, declaring any variables with the C<:Loud> attribute within the
 266 package:
 267
 268         package LoudDecl;
 269
 270         my $foo :Loud;
 271         my @foo :Loud;
 272         my %foo :Loud;
 273
 274 will cause the handler to be called with a similar argument list (except,
 275 of course, that C<$_[2]> will be a reference to the variable).
 276
 277 The package name argument will typically be the name of the class into
 278 which the subroutine was declared, but it may also be the name of a derived
 279 class (since handlers are inherited).
 280
 281 If a lexical variable is given an attribute, there is no symbol table to
 282 which it belongs, so the symbol table argument (C<$_[1]>) is set to the
 283 string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
 284 an anonymous subroutine results in a symbol table argument of C<'ANON'>.
 285
 286 The data argument passes in the value (if any) associated with the
 287 attribute. For example, if C<&foo> had been declared:
 288
 289         sub foo :Loud("turn it up to 11, man!") {...}
 290
 291 then the string C<"turn it up to 11, man!"> would be passed as the
 292 last argument.
 293
 294 Attribute::Handlers makes strenuous efforts to convert
 295 the data argument (C<$_[4]>) to a useable form before passing it to
 296 the handler (but see L<"Non-interpretive attribute handlers">).
 297 For example, all of these:
 298
 299         sub foo :Loud(till=>ears=>are=>bleeding) {...}
 300         sub foo :Loud(['till','ears','are','bleeding']) {...}
 301         sub foo :Loud(qw/till ears are bleeding/) {...}
 302         sub foo :Loud(qw/my, ears, are, bleeding/) {...}
 303         sub foo :Loud(till,ears,are,bleeding) {...}
 304
 305 causes it to pass C<['till','ears','are','bleeding']> as the handler's
 306 data argument. However, if the data can't be parsed as valid Perl, then
 307 it is passed as an uninterpreted string. For example:
 308
 309         sub foo :Loud(my,ears,are,bleeding) {...}
 310         sub foo :Loud(qw/my ears are bleeding) {...}
 311
 312 cause the strings C<'my,ears,are,bleeding'> and C<'qw/my ears are bleeding'>
 313 respectively to be passed as the data argument.
 314
 315 If the attribute has only a single associated scalar data value, that value is
 316 passed as a scalar. If multiple values are associated, they are passed as an
 317 array reference. If no value is associated with the attribute, C<undef> is
 318 passed.
 319
 320
 321 =head2 Typed lexicals
 322
 323 Regardless of the package in which it is declared, if a lexical variable is
 324 ascribed an attribute, the handler that is invoked is the one belonging to
 325 the package to which it is typed. For example, the following declarations:
 326
 327         package OtherClass;
 328
 329         my LoudDecl $loudobj : Loud;
 330         my LoudDecl @loudobjs : Loud;
 331         my LoudDecl %loudobjex : Loud;
 332
 333 causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
 334 defines a handler for C<:Loud> attributes).
 335
 336
 337 =head2 Type-specific attribute handlers
 338
 339 If an attribute handler is declared and the C<:ATTR> specifier is
 340 given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
 341 the handler is only applied to declarations of that type. For example,
 342 the following definition:
 343
 344         package LoudDecl;
 345
 346         sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
 347
 348 creates an attribute handler that applies only to scalars:
 349
 350
 351         package Painful;
 352         use base LoudDecl;
 353
 354         my $metal : RealLoud;           # invokes &LoudDecl::RealLoud
 355         my @metal : RealLoud;           # error: unknown attribute
 356         my %metal : RealLoud;           # error: unknown attribute
 357         sub metal : RealLoud {...}      # error: unknown attribute
 358
 359 You can, of course, declare separate handlers for these types as well
 360 (but you'll need to specify C<no warnings 'redefine'> to do it quietly):
 361
 362         package LoudDecl;
 363         use Attribute::Handlers;
 364         no warnings 'redefine';
 365
 366         sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
 367         sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
 368         sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
 369         sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
 370
 371 You can also explicitly indicate that a single handler is meant to be
 372 used for all types of referents like so:
 373
 374         package LoudDecl;
 375         use Attribute::Handlers;
 376
 377         sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
 378
 379 (I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
 380
 381
 382 =head2 Non-interpretive attribute handlers
 383
 384 Occasionally the strenuous efforts Attribute::Handlers makes to convert
 385 the data argument (C<$_[4]>) to a useable form before passing it to
 386 the handler get in the way.
 387
 388 You can turn off that eagerness-to-help by declaring
 389 an attribute handler with the the keyword C<RAWDATA>. For example:
 390
 391         sub Raw          : ATTR(RAWDATA) {...}
 392         sub Nekkid       : ATTR(SCALAR,RAWDATA) {...}
 393         sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
 394
 395 Then the handler makes absolutely no attempt to interpret the data it
 396 receives and simply passes it as a string:
 397
 398         my $power : Raw(1..100);        # handlers receives "1..100"
 399
 400
 401 =head2 Attributes as C<tie> interfaces
 402
 403 Attributes make an excellent and intuitive interface through which to tie
 404 variables. For example:
 405
 406         use Attribute::Handlers;
 407         use Tie::Cycle;
 408
 409         sub UNIVERSAL::Cycle : ATTR(SCALAR) {
 410                 my ($package, $symbol, $referent, $attr, $data) = @_;
 411                 $data = [ $data ] unless ref $data eq 'ARRAY';
 412                 tie $$referent, 'Tie::Cycle', $data;
 413         }
 414
 415         # and thereafter...
 416
 417         package main;
 418
 419         my $next : Cycle('A'..'Z');     # $next is now a tied variable
 420
 421         while (<>) {
 422                 print $next;
 423         }
 424
 425 In fact, this pattern is so widely applicable that Attribute::Handlers
 426 provides a way to automate it: specifying C<'autotie'> in the
 427 C<use Attribute::Handlers> statement. So, the previous example,
 428 could also be written:
 429
 430         use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
 431
 432         # and thereafter...
 433
 434         package main;
 435
 436         my $next : Cycle('A'..'Z');     # $next is now a tied variable
 437
 438         while (<>) {
 439                 print $next;
 440
 441 The argument after C<'autotie'> is a reference to a hash in which each key is
 442 the name of an attribute to be created, and each value is the class to which
 443 variables ascribed that attribute should be tied.
 444
 445 Note that there is no longer any need to import the Tie::Cycle module --
 446 Attribute::Handlers takes care of that automagically.
 447
 448 If the attribute name is unqualified, the attribute is installed in the
 449 current package. Otherwise it is installed in the qualifier's package:
 450
 451
 452         package Here;
 453
 454         use Attribute::Handlers autotie => {
 455                 Other::Good => Tie::SecureHash, # tie attr installed in Other::
 456                         Bad => Tie::Taxes,      # tie attr installed in Here::
 457             UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
 458         };
 459
 460
 461 =head1 EXAMPLES
 462
 463 If the class shown in L<SYNOPSIS> were placed in the MyClass.pm
 464 module, then the following code:
 465
 466         package main;
 467         use MyClass;
 468
 469         my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
 470
 471         package SomeOtherClass;
 472         use base MyClass;
 473
 474         sub tent { 'acle' }
 475
 476         sub fn :Ugly(sister) :Omni('po',tent()) {...}
 477         my @arr :Good :Omni(s/cie/nt/);
 478         my %hsh :Good(q/bye) :Omni(q/bus/);
 479
 480
 481 would cause the following handlers to be invoked:
 482
 483         # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
 484
 485         MyClass::Good:ATTR(SCALAR)( 'MyClass',          # class
 486                                     'LEXICAL',          # no typeglob
 487                                     \$slr,              # referent
 488                                     'Good',             # attr name
 489                                     undef               # no attr data
 490                                   );
 491
 492         MyClass::Bad:ATTR(SCALAR)( 'MyClass',           # class
 493                                    'LEXICAL',           # no typeglob
 494                                    \$slr,               # referent
 495                                    'Bad',               # attr name
 496                                    0                    # eval'd attr data
 497                                  );
 498
 499         MyClass::Omni:ATTR(SCALAR)( 'MyClass',          # class
 500                                     'LEXICAL',          # no typeglob
 501                                     \$slr,              # referent
 502                                     'Omni',             # attr name
 503                                     '-vorous'           # eval'd attr data
 504                                   );
 505
 506
 507         # sub fn :Ugly(sister) :Omni('po',tent()) {...}
 508
 509         MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass',     # class
 510                                   \*SomeOtherClass::fn, # typeglob
 511                                   \&SomeOtherClass::fn, # referent
 512                                   'Ugly',               # attr name
 513                                   'sister'              # eval'd attr data
 514                                 );
 515
 516         MyClass::Omni:ATTR(CODE)( 'SomeOtherClass',     # class
 517                                   \*SomeOtherClass::fn, # typeglob
 518                                   \&SomeOtherClass::fn, # referent
 519                                   'Omni',               # attr name
 520                                   ['po','acle']         # eval'd attr data
 521                                 );
 522
 523
 524         # my @arr :Good :Omni(s/cie/nt/);
 525
 526         MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass',    # class
 527                                    'LEXICAL',           # no typeglob
 528                                    \@arr,               # referent
 529                                    'Good',              # attr name
 530                                    undef                # no attr data
 531                                  );
 532
 533         MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass',    # class
 534                                    'LEXICAL',           # no typeglob
 535                                    \@arr,               # referent
 536                                    'Omni',              # attr name
 537                                    ""                   # eval'd attr data
 538                                  );
 539
 540
 541         # my %hsh :Good(q/bye) :Omni(q/bus/);
 542
 543         MyClass::Good:ATTR(HASH)( 'SomeOtherClass',     # class
 544                                   'LEXICAL',            # no typeglob
 545                                   \%hsh,                # referent
 546                                   'Good',               # attr name
 547                                   'q/bye'               # raw attr data
 548                                 );
 549
 550         MyClass::Omni:ATTR(HASH)( 'SomeOtherClass',     # class
 551                                   'LEXICAL',            # no typeglob
 552                                   \%hsh,                # referent
 553                                   'Omni',               # attr name
 554                                   'bus'                 # eval'd attr data
 555                                 );
 556
 557
 558 Installing handlers into UNIVERSAL, makes them...err..universal.
 559 For example:
 560
 561         package Descriptions;
 562         use Attribute::Handlers;
 563
 564         my %name;
 565         sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
 566
 567         sub UNIVERSAL::Name :ATTR {
 568                 $name{$_[2]} = $_[4];
 569         }
 570
 571         sub UNIVERSAL::Purpose :ATTR {
 572                 print STDERR "Purpose of ", &name, " is $_[4]\n";
 573         }
 574
 575         sub UNIVERSAL::Unit :ATTR {
 576                 print STDERR &name, " measured in $_[4]\n";
 577         }
 578
 579 Let's you write:
 580
 581         use Descriptions;
 582
 583         my $capacity : Name(capacity)
 584                      : Purpose(to store max storage capacity for files)
 585                      : Unit(Gb);
 586
 587
 588         package Other;
 589
 590         sub foo : Purpose(to foo all data before barring it) { }
 591
 592         # etc.
 593
 594
 595 =head1 DIAGNOSTICS
 596
 597 =over
 598
 599 =item C<Bad attribute type: ATTR(%s)>
 600
 601 An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
 602 type of referent it was defined to handle wasn't one of the five permitted:
 603 C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
 604
 605 =item C<Attribute handler %s doesn't handle %s attributes>
 606
 607 A handler for attributes of the specified name I<was> defined, but not
 608 for the specified type of declaration. Typically encountered whe trying
 609 to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
 610 attribute handler to some other type of variable.
 611
 612 =item C<Declaration of %s attribute in package %s may clash with future reserved word>
 613
 614 A handler for an attributes with an all-lowercase name was declared. An
 615 attribute with an all-lowercase name might have a meaning to Perl
 616 itself some day, even though most don't yet. Use a mixed-case attribute
 617 name, instead.
 618
 619 =item C<Internal error: %s symbol went missing>
 620
 621 Something is rotten in the state of the program. An attributed
 622 subroutine ceased to exist between the point it was declared and the end
 623 of the compilation phase (when its attribute handler(s) would have been
 624 called).
 625
 626 =back
 627
 628 =head1 AUTHOR
 629
 630 Damian Conway (damian@conway.org)
 631
 632 =head1 BUGS
 633
 634 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
 635 Bug reports and other feedback are most welcome.
 636
 637 =head1 COPYRIGHT
 638
 639          Copyright (c) 2001, Damian Conway. All Rights Reserved.
 640        This module is free software. It may be used, redistributed
 641       and/or modified under the terms of the Perl Artistic License
 642             (see http://www.perl.com/perl/misc/Artistic.html)