From: Jarkko Hietaniemi Date: Fri, 1 Jun 2001 22:12:48 +0000 (+0000) Subject: Add Attribute::Handlers 0.61 from Damian Conway. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dc6b6eef939bf30a0281954cf74dd650e3850bc5;p=p5sagit%2Fp5-mst-13.2.git Add Attribute::Handlers 0.61 from Damian Conway. p4raw-id: //depot/perl@10385 --- diff --git a/MANIFEST b/MANIFEST index 2af84c0..8c1d6f3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -669,6 +669,7 @@ jpl/install-jpl JPL install utility keywords.h The keyword numbers keywords.pl Program to write keywords.h lib/AnyDBM_File.pm Perl module to emulate dbmopen +lib/Attribute/Handlers.pm Attribute::Handlers lib/AutoLoader.pm Autoloader base class lib/AutoSplit.pm Split up autoload functions lib/Benchmark.pm Measure execution time @@ -1463,6 +1464,7 @@ t/lib/Test/todo.t See if Test works t/lib/abbrev.t See if Text::Abbrev works t/lib/ansicolor.t See if Term::ANSIColor works t/lib/anydbm.t See if AnyDBM_File works +t/lib/attrhand.t See if Attribute::Handlers works t/lib/attrs.t See if attrs works with C t/lib/autoloader.t See if AutoLoader works t/lib/b-debug.t See if B::Debug works diff --git a/lib/Attribute/Handlers.pm b/lib/Attribute/Handlers.pm new file mode 100644 index 0000000..96d4f68 --- /dev/null +++ b/lib/Attribute/Handlers.pm @@ -0,0 +1,642 @@ +package Attribute::Handlers; +use 5.006; +use Carp; +use warnings; +$VERSION = '0.61'; +$DB::single=1; + +sub findsym { + my ($pkg, $ref, $type) = @_; + $type ||= ref($ref); + foreach my $sym ( values %{$pkg."::"} ) { + return $sym if *{$sym}{$type} && *{$sym}{$type} == $ref; + } +} + +my %validtype = ( + VAR => [qw[SCALAR ARRAY HASH]], + ANY => [qw[SCALAR ARRAY HASH CODE]], + "" => [qw[SCALAR ARRAY HASH CODE]], + SCALAR => [qw[SCALAR]], + ARRAY => [qw[ARRAY]], + HASH => [qw[HASH]], + CODE => [qw[CODE]], +); +my %lastattr; +my @declarations; +my %raw; +my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%'); + +sub usage {croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}"} + +sub import { + my $class = shift @_; + while (@_) { + my $cmd = shift; + if ($cmd eq 'autotie') { + my $mapping = shift; + usage $class unless ref($mapping) eq 'HASH'; + while (my($attr, $tieclass) = each %$mapping) { + usage $class unless $attr =~ m/^[a-z]\w*(::[a-z]\w*)*$/i + && $tieclass =~ m/^[a-z]\w*(::[a-z]\w*)*$/i + && eval "use base $tieclass; 1"; + eval qq{ + sub $attr : ATTR(VAR) { + my (\$ref, \$data) = \@_[2,4]; + \$data = [ \$data ] unless ref \$data eq 'ARRAY'; + my \$type = ref \$ref; + (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',\@\$data + :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data + :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',\@\$data + : die "Internal error: can't autotie \$type" + } 1 + } or die "Internal error: $@"; + } + } + else { + croak "Can't understand $_"; + } + } +} +sub resolve_lastattr { + return unless $lastattr{ref}; + my $sym = findsym @lastattr{'pkg','ref'} + or die "Internal error: $lastattr{pkg} symbol went missing"; + my $name = *{$sym}{NAME}; + warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n" + if $^W and $name !~ /[A-Z]/; + foreach ( @{$validtype{$lastattr{type}}} ) { + *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref}; + } + %lastattr = (); +} + +sub AUTOLOAD { + my ($class) = @_; + $AUTOLOAD =~ /_ATTR_(.*?)_(.*)/ or + croak "Can't locate class method '$AUTOLOAD' via package '$class'"; + croak "Attribute handler '$2' doesn't handle $1 attributes"; +} + +sub DESTROY {} + +my $builtin = qr/lvalue|method|locked/; + +sub handler() { + return sub { + resolve_lastattr; + my ($pkg, $ref, @attrs) = @_; + foreach (@attrs) { + my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/i or next; + if ($attr eq 'ATTR') { + $data ||= "ANY"; + $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//; + croak "Bad attribute type: ATTR($data)" + unless $validtype{$data}; + %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data); + } + else { + my $handler = $pkg->can($attr); + next unless $handler; + push @declarations, + [$pkg, $ref, $attr, $data, $raw{$handler}]; + } + $_ = undef; + } + return grep {defined && !/$builtin/} @attrs; + } +} + +*{"MODIFY_${_}_ATTRIBUTES"} = handler foreach @{$validtype{ANY}}; +push @UNIVERSAL::ISA, 'Attribute::Handlers' + unless grep /^Attribute::Handlers$/, @UNIVERSAL::ISA; + +CHECK { + resolve_lastattr; + foreach (@declarations) { + my ($pkg, $ref, $attr, $data, $raw) = @$_; + my $type = ref $ref; + my $sym = findsym($pkg, $ref); + $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL'; + my $handler = "_ATTR_${type}_${attr}"; + no warnings; + my $evaled = !$raw && eval("package $pkg; no warnings; + \$SIG{__WARN__}=sub{die}; [$data]"); + $data = ($evaled && $data =~ /^\s*\[/) ? [$evaled] + : ($evaled) ? $evaled + : [$data]; + $pkg->$handler($sym, $ref, $attr, @$data>1? $data : $data->[0]); + } +} + +1; +__END__ + +=head1 NAME + +Attribute::Handlers - Simpler definition of attribute handlers + +=head1 VERSION + +This document describes version 0.61 of Attribute::Handlers, +released May 10, 2001. + +=head1 SYNOPSIS + + package MyClass; + require v5.6.0; + use Attribute::Handlers; + no warnings 'redefine'; + + + sub Good : ATTR(SCALAR) { + my ($package, $symbol, $referent, $attr, $data) = @_; + + # Invoked for any scalar variable with a :Good attribute, + # provided the variable was declared in MyClass (or + # a derived class) or typed to MyClass. + + # Do whatever to $referent here (executed in CHECK phase). + ... + } + + sub Bad : ATTR(SCALAR) { + # Invoked for any scalar variable with a :Bad attribute, + # provided the variable was declared in MyClass (or + # a derived class) or typed to MyClass. + ... + } + + sub Good : ATTR(ARRAY) { + # Invoked for any array variable with a :Good attribute, + # provided the variable was declared in MyClass (or + # a derived class) or typed to MyClass. + ... + } + + sub Good : ATTR(HASH) { + # Invoked for any hash variable with a :Good attribute, + # provided the variable was declared in MyClass (or + # a derived class) or typed to MyClass. + ... + } + + sub Ugly : ATTR(CODE) { + # Invoked for any subroutine declared in MyClass (or a + # derived class) with an :Ugly attribute. + ... + } + + sub Omni : ATTR { + # Invoked for any scalar, array, hash, or subroutine + # with an :Omni attribute, provided the variable or + # subroutine was declared in MyClass (or a derived class) + # or the variable was typed to MyClass. + # Use ref($_[2]) to determine what kind of referent it was. + ... + } + + + use Attribute::Handlers autotie => { Cycle => Tie::Cycle }; + + my $next : Cycle(['A'..'Z']); + + +=head1 DESCRIPTION + +This module, when inherited by a package, allows that package's class to +define attribute handler subroutines for specific attributes. Variables +and subroutines subsequently defined in that package, or in packages +derived from that package may be given attributes with the same names as +the attribute handler subroutines, which will then be called at the end +of the compilation phase (i.e. in a C block). + +To create a handler, define it as a subroutine with the same name as +the desired attribute, and declare the subroutine itself with the +attribute C<:ATTR>. For example: + + package LoudDecl; + use Attribute::Handlers; + + sub Loud :ATTR { + my ($package, $symbol, $referent, $attr, $data) = @_; + print STDERR + ref($referent), " ", + *{$symbol}{NAME}, " ", + "($referent) ", "was just declared ", + "and ascribed the ${attr} attribute ", + "with data ($data)\n"; + } + +This creates an handler for the attribute C<:Loud> in the class LoudDecl. +Thereafter, any subroutine declared with a C<:Loud> attribute in the class +LoudDecl: + + package LoudDecl; + + sub foo: Loud {...} + +causes the above handler to be invoked, and passed: + +=over + +=item [0] + +the name of the package into which it was declared; + +=item [1] + +a reference to the symbol table entry (typeglob) containing the subroutine; + +=item [2] + +a reference to the subroutine; + +=item [3] + +the name of the attribute; + +=item [4] + +any data associated with that attribute. + +=back + +Likewise, declaring any variables with the C<:Loud> attribute within the +package: + + package LoudDecl; + + my $foo :Loud; + my @foo :Loud; + my %foo :Loud; + +will cause the handler to be called with a similar argument list (except, +of course, that C<$_[2]> will be a reference to the variable). + +The package name argument will typically be the name of the class into +which the subroutine was declared, but it may also be the name of a derived +class (since handlers are inherited). + +If a lexical variable is given an attribute, there is no symbol table to +which it belongs, so the symbol table argument (C<$_[1]>) is set to the +string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to +an anonymous subroutine results in a symbol table argument of C<'ANON'>. + +The data argument passes in the value (if any) associated with the +attribute. For example, if C<&foo> had been declared: + + sub foo :Loud("turn it up to 11, man!") {...} + +then the string C<"turn it up to 11, man!"> would be passed as the +last argument. + +Attribute::Handlers makes strenuous efforts to convert +the data argument (C<$_[4]>) to a useable form before passing it to +the handler (but see L<"Non-interpretive attribute handlers">). +For example, all of these: + + sub foo :Loud(till=>ears=>are=>bleeding) {...} + sub foo :Loud(['till','ears','are','bleeding']) {...} + sub foo :Loud(qw/till ears are bleeding/) {...} + sub foo :Loud(qw/my, ears, are, bleeding/) {...} + sub foo :Loud(till,ears,are,bleeding) {...} + +causes it to pass C<['till','ears','are','bleeding']> as the handler's +data argument. However, if the data can't be parsed as valid Perl, then +it is passed as an uninterpreted string. For example: + + sub foo :Loud(my,ears,are,bleeding) {...} + sub foo :Loud(qw/my ears are bleeding) {...} + +cause the strings C<'my,ears,are,bleeding'> and C<'qw/my ears are bleeding'> +respectively to be passed as the data argument. + +If the attribute has only a single associated scalar data value, that value is +passed as a scalar. If multiple values are associated, they are passed as an +array reference. If no value is associated with the attribute, C is +passed. + + +=head2 Typed lexicals + +Regardless of the package in which it is declared, if a lexical variable is +ascribed an attribute, the handler that is invoked is the one belonging to +the package to which it is typed. For example, the following declarations: + + package OtherClass; + + my LoudDecl $loudobj : Loud; + my LoudDecl @loudobjs : Loud; + my LoudDecl %loudobjex : Loud; + +causes the LoudDecl::Loud handler to be invoked (even if OtherClass also +defines a handler for C<:Loud> attributes). + + +=head2 Type-specific attribute handlers + +If an attribute handler is declared and the C<:ATTR> specifier is +given the name of a built-in type (C, C, C, or C), +the handler is only applied to declarations of that type. For example, +the following definition: + + package LoudDecl; + + sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" } + +creates an attribute handler that applies only to scalars: + + + package Painful; + use base LoudDecl; + + my $metal : RealLoud; # invokes &LoudDecl::RealLoud + my @metal : RealLoud; # error: unknown attribute + my %metal : RealLoud; # error: unknown attribute + sub metal : RealLoud {...} # error: unknown attribute + +You can, of course, declare separate handlers for these types as well +(but you'll need to specify C to do it quietly): + + package LoudDecl; + use Attribute::Handlers; + no warnings 'redefine'; + + sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" } + sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" } + sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" } + sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" } + +You can also explicitly indicate that a single handler is meant to be +used for all types of referents like so: + + package LoudDecl; + use Attribute::Handlers; + + sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" } + +(I.e. C is a synonym for C<:ATTR>). + + +=head2 Non-interpretive attribute handlers + +Occasionally the strenuous efforts Attribute::Handlers makes to convert +the data argument (C<$_[4]>) to a useable form before passing it to +the handler get in the way. + +You can turn off that eagerness-to-help by declaring +an attribute handler with the the keyword C. For example: + + sub Raw : ATTR(RAWDATA) {...} + sub Nekkid : ATTR(SCALAR,RAWDATA) {...} + sub Au::Naturale : ATTR(RAWDATA,ANY) {...} + +Then the handler makes absolutely no attempt to interpret the data it +receives and simply passes it as a string: + + my $power : Raw(1..100); # handlers receives "1..100" + + +=head2 Attributes as C interfaces + +Attributes make an excellent and intuitive interface through which to tie +variables. For example: + + use Attribute::Handlers; + use Tie::Cycle; + + sub UNIVERSAL::Cycle : ATTR(SCALAR) { + my ($package, $symbol, $referent, $attr, $data) = @_; + $data = [ $data ] unless ref $data eq 'ARRAY'; + tie $$referent, 'Tie::Cycle', $data; + } + + # and thereafter... + + package main; + + my $next : Cycle('A'..'Z'); # $next is now a tied variable + + while (<>) { + print $next; + } + +In fact, this pattern is so widely applicable that Attribute::Handlers +provides a way to automate it: specifying C<'autotie'> in the +C statement. So, the previous example, +could also be written: + + use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' }; + + # and thereafter... + + package main; + + my $next : Cycle('A'..'Z'); # $next is now a tied variable + + while (<>) { + print $next; + +The argument after C<'autotie'> is a reference to a hash in which each key is +the name of an attribute to be created, and each value is the class to which +variables ascribed that attribute should be tied. + +Note that there is no longer any need to import the Tie::Cycle module -- +Attribute::Handlers takes care of that automagically. + +If the attribute name is unqualified, the attribute is installed in the +current package. Otherwise it is installed in the qualifier's package: + + + package Here; + + use Attribute::Handlers autotie => { + Other::Good => Tie::SecureHash, # tie attr installed in Other:: + Bad => Tie::Taxes, # tie attr installed in Here:: + UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere + }; + + +=head1 EXAMPLES + +If the class shown in L were placed in the MyClass.pm +module, then the following code: + + package main; + use MyClass; + + my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous); + + package SomeOtherClass; + use base MyClass; + + sub tent { 'acle' } + + sub fn :Ugly(sister) :Omni('po',tent()) {...} + my @arr :Good :Omni(s/cie/nt/); + my %hsh :Good(q/bye) :Omni(q/bus/); + + +would cause the following handlers to be invoked: + + # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous); + + MyClass::Good:ATTR(SCALAR)( 'MyClass', # class + 'LEXICAL', # no typeglob + \$slr, # referent + 'Good', # attr name + undef # no attr data + ); + + MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class + 'LEXICAL', # no typeglob + \$slr, # referent + 'Bad', # attr name + 0 # eval'd attr data + ); + + MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class + 'LEXICAL', # no typeglob + \$slr, # referent + 'Omni', # attr name + '-vorous' # eval'd attr data + ); + + + # sub fn :Ugly(sister) :Omni('po',tent()) {...} + + MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class + \*SomeOtherClass::fn, # typeglob + \&SomeOtherClass::fn, # referent + 'Ugly', # attr name + 'sister' # eval'd attr data + ); + + MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class + \*SomeOtherClass::fn, # typeglob + \&SomeOtherClass::fn, # referent + 'Omni', # attr name + ['po','acle'] # eval'd attr data + ); + + + # my @arr :Good :Omni(s/cie/nt/); + + MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class + 'LEXICAL', # no typeglob + \@arr, # referent + 'Good', # attr name + undef # no attr data + ); + + MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class + 'LEXICAL', # no typeglob + \@arr, # referent + 'Omni', # attr name + "" # eval'd attr data + ); + + + # my %hsh :Good(q/bye) :Omni(q/bus/); + + MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class + 'LEXICAL', # no typeglob + \%hsh, # referent + 'Good', # attr name + 'q/bye' # raw attr data + ); + + MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class + 'LEXICAL', # no typeglob + \%hsh, # referent + 'Omni', # attr name + 'bus' # eval'd attr data + ); + + +Installing handlers into UNIVERSAL, makes them...err..universal. +For example: + + package Descriptions; + use Attribute::Handlers; + + my %name; + sub name { return $name{$_[2]}||*{$_[1]}{NAME} } + + sub UNIVERSAL::Name :ATTR { + $name{$_[2]} = $_[4]; + } + + sub UNIVERSAL::Purpose :ATTR { + print STDERR "Purpose of ", &name, " is $_[4]\n"; + } + + sub UNIVERSAL::Unit :ATTR { + print STDERR &name, " measured in $_[4]\n"; + } + +Let's you write: + + use Descriptions; + + my $capacity : Name(capacity) + : Purpose(to store max storage capacity for files) + : Unit(Gb); + + + package Other; + + sub foo : Purpose(to foo all data before barring it) { } + + # etc. + + +=head1 DIAGNOSTICS + +=over + +=item C + +An attribute handler was specified with an C<:ATTR(I)>, but the +type of referent it was defined to handle wasn't one of the five permitted: +C, C, C, C, or C. + +=item C + +A handler for attributes of the specified name I defined, but not +for the specified type of declaration. Typically encountered whe trying +to apply a C attribute handler to a subroutine, or a C +attribute handler to some other type of variable. + +=item C + +A handler for an attributes with an all-lowercase name was declared. An +attribute with an all-lowercase name might have a meaning to Perl +itself some day, even though most don't yet. Use a mixed-case attribute +name, instead. + +=item C + +Something is rotten in the state of the program. An attributed +subroutine ceased to exist between the point it was declared and the end +of the compilation phase (when its attribute handler(s) would have been +called). + +=back + +=head1 AUTHOR + +Damian Conway (damian@conway.org) + +=head1 BUGS + +There are undoubtedly serious bugs lurking somewhere in code this funky :-) +Bug reports and other feedback are most welcome. + +=head1 COPYRIGHT + + Copyright (c) 2001, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed + and/or modified under the terms of the Perl Artistic License + (see http://www.perl.com/perl/misc/Artistic.html) diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index 1310b14..bc62a25 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -166,6 +166,10 @@ Exporter module. See their own documentation for details. Provide framework for multiple DBMs +=item Attribute::Handlers + +Simpler definition of attribute handlers + =item AutoLoader Load subroutines only on demand diff --git a/pod/perltoc.pod b/pod/perltoc.pod index 1240ef2..8138823 100644 --- a/pod/perltoc.pod +++ b/pod/perltoc.pod @@ -2195,39 +2195,40 @@ warnings::register =item Standard Modules -AnyDBM_File, AutoLoader, AutoSplit, B, B::Asmdata, B::Assembler, B::Bblock, -B::Bytecode, B::C, B::CC, B::Concise, B::Debug, B::Deparse, -B::Disassembler, B::Lint, B::Showlex, B::Stackobj, B::Stash, B::Terse, -B::Xref, Benchmark, ByteLoader, CGI, CGI::Apache, CGI::Carp, CGI::Cookie, -CGI::Fast, CGI::Pretty, CGI::Push, CGI::Switch, CGI::Util, CPAN, -CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, Class::ISA, Class::Struct, -Cwd, DB, DB_File, Devel::SelfStubber, Digest, DirHandle, Dumpvalue, Encode, -Encode::EncodeFormat, Encode::Tcl, English, Env, Exporter, Exporter::Heavy, -ExtUtils::Command, ExtUtils::Constant, ExtUtils::Embed, ExtUtils::Install, -ExtUtils::Installed, ExtUtils::Liblist, ExtUtils::MM_Cygwin, -ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, ExtUtils::MM_Win32, -ExtUtils::MakeMaker, ExtUtils::Manifest, ExtUtils::Mkbootstrap, -ExtUtils::Mksymlists, ExtUtils::Packlist, ExtUtils::testlib, Fatal, Fcntl, -File::Basename, File::CheckTree, File::Compare, File::Copy, File::DosGlob, -File::Find, File::Path, File::Spec, File::Spec::Epoc, -File::Spec::Functions, File::Spec::Mac, File::Spec::OS2, File::Spec::Unix, -File::Spec::VMS, File::Spec::Win32, File::Temp, File::stat, FileCache, -FileHandle, Filter::Simple, FindBin, Getopt::Long, Getopt::Std, -I18N::Collate, I18N::LangTags, I18N::LangTags::List, IO, IPC::Open2, -IPC::Open3, Locale::Constants, Locale::Country, Locale::Currency, -Locale::Language, Locale::Maketext, Locale::Maketext::TPJ13, -Math::BigFloat, Math::BigInt, Math::Complex, Math::Trig, NDBM_File, NEXT, -Net::Ping, Net::hostent, Net::netent, Net::protoent, Net::servent, O, -ODBM_File, Opcode, POSIX, PerlIO, Pod::Checker, Pod::Find, Pod::Html, -Pod::InputObjects, Pod::LaTeX, Pod::Man, Pod::ParseUtils, Pod::Parser, -Pod::Plainer, Pod::Select, Pod::Text, Pod::Text::Color, -Pod::Text::Overstrike, Pod::Text::Termcap, Pod::Usage, SDBM_File, Safe, -Search::Dict, SelectSaver, SelfLoader, Shell, Socket, Storable, Switch, -Symbol, Term::ANSIColor, Term::Cap, Term::Complete, Term::ReadLine, Test, -Test::Harness, Text::Abbrev, Text::Balanced, Text::ParseWords, -Text::Soundex, Text::Tabs, Text::Wrap, Tie::Array, Tie::Handle, Tie::Hash, -Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime, -Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent, Win32 +AnyDBM_File, Attribute::Handlers, AutoLoader, AutoSplit, B, B::Asmdata, +B::Assembler, B::Bblock, B::Bytecode, B::C, B::CC, B::Concise, B::Debug, +B::Deparse, B::Disassembler, B::Lint, B::Showlex, B::Stackobj, B::Stash, +B::Terse, B::Xref, Benchmark, ByteLoader, CGI, CGI::Apache, CGI::Carp, +CGI::Cookie, CGI::Fast, CGI::Pretty, CGI::Push, CGI::Switch, CGI::Util, +CPAN, CPAN::FirstTime, CPAN::Nox, Carp, Carp::Heavy, Class::ISA, +Class::Struct, Cwd, DB, DB_File, Devel::SelfStubber, Digest, DirHandle, +Dumpvalue, Encode, Encode::EncodeFormat, Encode::Tcl, English, Env, +Exporter, Exporter::Heavy, ExtUtils::Command, ExtUtils::Constant, +ExtUtils::Embed, ExtUtils::Install, ExtUtils::Installed, ExtUtils::Liblist, +ExtUtils::MM_Cygwin, ExtUtils::MM_OS2, ExtUtils::MM_Unix, ExtUtils::MM_VMS, +ExtUtils::MM_Win32, ExtUtils::MakeMaker, ExtUtils::Manifest, +ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::Packlist, +ExtUtils::testlib, Fatal, Fcntl, File::Basename, File::CheckTree, +File::Compare, File::Copy, File::DosGlob, File::Find, File::Path, +File::Spec, File::Spec::Epoc, File::Spec::Functions, File::Spec::Mac, +File::Spec::OS2, File::Spec::Unix, File::Spec::VMS, File::Spec::Win32, +File::Temp, File::stat, FileCache, FileHandle, Filter::Simple, FindBin, +Getopt::Long, Getopt::Std, I18N::Collate, I18N::LangTags, +I18N::LangTags::List, IO, IPC::Open2, IPC::Open3, Locale::Constants, +Locale::Country, Locale::Currency, Locale::Language, Locale::Maketext, +Locale::Maketext::TPJ13, Math::BigFloat, Math::BigInt, Math::Complex, +Math::Trig, NDBM_File, NEXT, Net::Ping, Net::hostent, Net::netent, +Net::protoent, Net::servent, O, ODBM_File, Opcode, POSIX, PerlIO, +Pod::Checker, Pod::Find, Pod::Html, Pod::InputObjects, Pod::LaTeX, +Pod::Man, Pod::ParseUtils, Pod::Parser, Pod::Plainer, Pod::Select, +Pod::Text, Pod::Text::Color, Pod::Text::Overstrike, Pod::Text::Termcap, +Pod::Usage, SDBM_File, Safe, Search::Dict, SelectSaver, SelfLoader, Shell, +Socket, Storable, Switch, Symbol, Term::ANSIColor, Term::Cap, +Term::Complete, Term::ReadLine, Test, Test::Harness, Text::Abbrev, +Text::Balanced, Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, +Tie::Array, Tie::Handle, Tie::Hash, Tie::RefHash, Tie::Scalar, +Tie::SubstrHash, Time::Local, Time::gmtime, Time::localtime, Time::tm, +UNIVERSAL, User::grent, User::pwent, Win32 =item Extension Modules @@ -7149,6 +7150,46 @@ warnings::warnif($object, $message) =back +=head2 Attribute::Handlers - Simpler definition of attribute handlers + +=over 4 + +=item VERSION + +=item SYNOPSIS + +=item DESCRIPTION + +[0], [1], [2], [3], [4] + +=over 4 + +=item Typed lexicals + +=item Type-specific attribute handlers + +=item Non-interpretive attribute handlers + +=item Attributes as C interfaces + +=back + +=item EXAMPLES + +=item DIAGNOSTICS + +C, C, C, C + +=item AUTHOR + +=item BUGS + +=item COPYRIGHT + +=back + =head2 AutoLoader - load subroutines only on demand =over 4 diff --git a/t/lib/1_compile.t b/t/lib/1_compile.t index e46e14b..7d28d00 100644 --- a/t/lib/1_compile.t +++ b/t/lib/1_compile.t @@ -110,6 +110,7 @@ sub compile_module { # need not be test-compiled by 1_compile.t. __DATA__ AnyDBM_File +Attribute::Handlers AutoLoader B B::Debug diff --git a/t/lib/attrhand.t b/t/lib/attrhand.t new file mode 100644 index 0000000..5056fa8 --- /dev/null +++ b/t/lib/attrhand.t @@ -0,0 +1,130 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +END {print "not ok 1\n" unless $loaded;} +use v5.6.0; +use Attribute::Handlers; +$loaded = 1; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not "]; } + +END { print "1..$::count\n"; + print map "$_->[1]ok $_->[0]\n", sort {$a->[0]<=>$b->[0]} @::results } + +package Test; +use warnings; +no warnings 'redefine'; + +sub UNIVERSAL::Okay :ATTR { ::ok @{$_[4]} } + +sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} } +sub Dokay :ATTR(HASH) { ::ok @{$_[4]} } +sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} } +sub Dokay :ATTR(CODE) { ::ok @{$_[4]} } + +sub Vokay :ATTR(VAR) { ::ok @{$_[4]} } + +sub Aokay :ATTR(ANY) { ::ok @{$_[4]} } + +package main; +use warnings; + +my $x1 :Okay(1,1); +my @x1 :Okay(1=>2); +my %x1 :Okay(1,3); +sub x1 :Okay(1,4) {} + +my Test $x2 :Dokay(1,5); + +package Test; +my $x3 :Dokay(1,6); +my Test $x4 :Dokay(1,7); +sub x3 :Dokay(1,8) {} + +my $y1 :Okay(1,9); +my @y1 :Okay(1,10); +my %y1 :Okay(1,11); +sub y1 :Okay(1,12) {} + +my $y2 :Vokay(1,13); +my @y2 :Vokay(1,14); +my %y2 :Vokay(1,15); +# BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or +::ok(1,16); +# } + +my $z :Aokay(1,17); +my @z :Aokay(1,18); +my %z :Aokay(1,19); +sub z :Aokay(1,20) {}; + +package DerTest; +use base 'Test'; +use warnings; + +my $x5 :Dokay(1,21); +my Test $x6 :Dokay(1,22); +sub x5 :Dokay(1,23); + +my $y3 :Okay(1,24); +my @y3 :Okay(1,25); +my %y3 :Okay(1,26); +sub y3 :Okay(1,27) {} + +package Unrelated; + +BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); } +my Test $x8 :Dokay(1,29); +eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30); + + +package Tie::Loud; + +sub TIESCALAR { ::ok(1,31); bless {}, $_[0] } +sub FETCH { ::ok(1,32); return 1 } +sub STORE { ::ok(1,33); return 1 } + +package Tie::Noisy; + +sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] } +sub FETCH { ::ok(1,35); return 1 } +sub STORE { ::ok(1,36); return 1 } +sub FETCHSIZE { 100 } + +package Tie::Rowdy; + +sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] } +sub FETCH { ::ok(1,38); return 1 } +sub STORE { ::ok(1,39); return 1 } + +package main; + +use Attribute::Handlers autotie => { Other::Loud => Tie::Loud, + Noisy => Tie::Noisy, + UNIVERSAL::Rowdy => Tie::Rowdy, + }; + +my Other $loud : Loud; +$loud++; + +my @noisy : Noisy(34); +$noisy[0]++; + +my %rowdy : Rowdy(37); +$rowdy{key}++;