X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2Fsubs%2Fauto.pm;h=6b2dd5959af8fe6009c9398fb2c96ea398b66286;hb=3fcfcabe180fd621d86f1652b8a79ff2f702cf6d;hp=64e9d57cd574b4ea933267bb1377b9082cda7b52;hpb=630e6dba42a899a6fdb2bcc9f4dda685e6c70584;p=perl%2Fmodules%2Fsubs-auto.git diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm index 64e9d57..6b2dd59 100644 --- a/lib/subs/auto.pm +++ b/lib/subs/auto.pm @@ -16,11 +16,11 @@ subs::auto - Read barewords as subroutine names. =head1 VERSION -Version 0.03 +Version 0.05 =cut -our $VERSION = '0.03'; +our $VERSION = '0.05'; =head1 SYNOPSIS @@ -43,7 +43,7 @@ our $VERSION = '0.03'; =head1 DESCRIPTION -This pragma lexically enables the parsing of any bareword as a subroutine name, except those which corresponds to an entry in C<%INC> (expected to be class names) or whose symbol table entry has a IO slot (expected to be filehandles). +This pragma lexically enables the parsing of any bareword as a subroutine name, except those which corresponds to an entry in C<%INC> (expected to be class names) or whose symbol table entry has an IO slot (expected to be filehandles). You can pass options to C as key / value pairs : @@ -57,6 +57,8 @@ Specifies on which package the pragma should act. Setting C<$pkg> to C a source filter. + =cut BEGIN { @@ -95,7 +97,11 @@ my %core; delete @core{qw/my local/}; undef @core; -my $tag = wizard data => sub { 1 }; +BEGIN { + *_REFCNT_PLACEHOLDERS = eval 'sub () { ' . ($] < 5.011002 ? 0 : 1) . '}' +} + +my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) }; sub _reset { my ($pkg, $func) = @_; @@ -105,7 +111,9 @@ sub _reset { no warnings 'once'; *$fqn{CODE}; }; - if ($cb and getdata(&$cb, $tag)) { + if ($cb and defined(my $data = getdata(&$cb, $tag))) { + $$data--; + return if $$data > 0; no strict 'refs'; my $sym = gensym; for (qw/SCALAR ARRAY HASH IO FORMAT/) { @@ -120,40 +128,44 @@ sub _reset { sub _fetch { (undef, my $data, my $func) = @_; return if $data->{guard} or $func =~ /::/ or exists $core{$func}; - $data->{guard} = 1; + local $data->{guard} = 1; my $hints = (caller 0)[10]; if ($hints and $hints->{subs__auto}) { my $mod = $func . '.pm'; if (not exists $INC{$mod}) { my $fqn = $data->{pkg} . '::' . $func; - if (do { no strict 'refs'; not *$fqn{CODE} || *$fqn{IO}}) { - my $cb = sub { - my ($file, $line) = (caller 0)[1, 2]; - ($file, $line) = ('(eval 0)', 0) unless $file && $line; - die "Undefined subroutine &$fqn called at $file line $line\n"; - }; - cast &$cb, $tag; - no strict 'refs'; - *$fqn = $cb; + my $cb = do { no strict 'refs'; *$fqn{CODE} }; + if ($cb) { + if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) { + ++$$data; + } + return; } + return if do { no strict 'refs'; *$fqn{IO} }; + $cb = sub { + my ($file, $line) = (caller 0)[1, 2]; + ($file, $line) = ('(eval 0)', 0) unless $file && $line; + die "Undefined subroutine &$fqn called at $file line $line\n"; + }; + cast &$cb, $tag; + no strict 'refs'; + *$fqn = $cb; } } else { _reset($data->{pkg}, $func); } - $data->{guard} = 0; return; } sub _store { (undef, my $data, my $func) = @_; return if $data->{guard}; - $data->{guard} = 1; + local $data->{guard} = 1; _reset($data->{pkg}, $func); - $data->{guard} = 0; return; } -my $wiz = wizard data => sub { +{ pkg => $_[1] } }, +my $wiz = wizard data => sub { +{ pkg => $_[1], guard => 0 } }, fetch => \&_fetch, store => \&_store; @@ -216,7 +228,7 @@ L with C magic enabled (this should be assured by the req Vincent Pit, C<< >>, L. -You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). +You can contact me by mail or on C (vincent). =head1 BUGS