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