1#line 1 2package attributes; 3 4our $VERSION = 0.06; 5 6@EXPORT_OK = qw(get reftype); 7@EXPORT = (); 8%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); 9 10use strict; 11 12sub croak { 13 require Carp; 14 goto &Carp::croak; 15} 16 17sub carp { 18 require Carp; 19 goto &Carp::carp; 20} 21 22## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{} 23#sub reftype ($) ; 24#sub _fetch_attrs ($) ; 25#sub _guess_stash ($) ; 26#sub _modify_attrs ; 27#sub _warn_reserved () ; 28# 29# The extra trips through newATTRSUB in the interpreter wipe out any savings 30# from avoiding the BEGIN block. Just do the bootstrap now. 31BEGIN { bootstrap attributes } 32 33sub import { 34 @_ > 2 && ref $_[2] or do { 35 require Exporter; 36 goto &Exporter::import; 37 }; 38 my (undef,$home_stash,$svref,@attrs) = @_; 39 40 my $svtype = uc reftype($svref); 41 my $pkgmeth; 42 $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES") 43 if defined $home_stash && $home_stash ne ''; 44 my @badattrs; 45 if ($pkgmeth) { 46 my @pkgattrs = _modify_attrs($svref, @attrs); 47 @badattrs = $pkgmeth->($home_stash, $svref, @attrs); 48 if (!@badattrs && @pkgattrs) { 49 return unless _warn_reserved; 50 @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs; 51 if (@pkgattrs) { 52 for my $attr (@pkgattrs) { 53 $attr =~ s/\(.+\z//s; 54 } 55 my $s = ((@pkgattrs == 1) ? '' : 's'); 56 carp "$svtype package attribute$s " . 57 "may clash with future reserved word$s: " . 58 join(' : ' , @pkgattrs); 59 } 60 } 61 } 62 else { 63 @badattrs = _modify_attrs($svref, @attrs); 64 } 65 if (@badattrs) { 66 croak "Invalid $svtype attribute" . 67 (( @badattrs == 1 ) ? '' : 's') . 68 ": " . 69 join(' : ', @badattrs); 70 } 71} 72 73sub get ($) { 74 @_ == 1 && ref $_[0] or 75 croak 'Usage: '.__PACKAGE__.'::get $ref'; 76 my $svref = shift; 77 my $svtype = uc reftype $svref; 78 my $stash = _guess_stash $svref; 79 $stash = caller unless defined $stash; 80 my $pkgmeth; 81 $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") 82 if defined $stash && $stash ne ''; 83 return $pkgmeth ? 84 (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : 85 (_fetch_attrs($svref)) 86 ; 87} 88 89sub require_version { goto &UNIVERSAL::VERSION } 90 911; 92__END__ 93#The POD goes here 94 95#line 417 96 97