5.11.2 fix

[perl/modules/subs-auto.git] / lib / subs / auto.pm

diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 0625cc68078143780a94d44baace6d99a9f4259d..6b2dd5959af8fe6009c9398fb2c96ea398b66286 100644 (file)
--- 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.01
+Version 0.05
 
 =cut
 
-our $VERSION = '0.01';
+our $VERSION = '0.05';
 
 =head1 SYNOPSIS
 
@@ -35,7 +35,7 @@ our $VERSION = '0.01';
      foo->meth;       # "'foo'->meth" if you have use'd foo somewhere,
                       #  or "foo()->meth" otherwise
      print foo 'wut'; # print to the filehandle foo if it's actually one,
-                      #  or "foo()->print('wut')" otherwise
+                      #  or "print(foo('wut'))" otherwise
     } # ... but function calls will fail at run-time if you don't
       # actually define foo somewhere
     
@@ -43,7 +43,7 @@ our $VERSION = '0.01';
 
 =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<import> as key / value pairs :
 
@@ -53,10 +53,12 @@ You can pass options to C<import> as key / value pairs :
 
 C<< in => $pkg >>
 
-Specifies on which package the pragma should act. Defaults to the current package.
+Specifies on which package the pragma should act. Setting C<$pkg> to C<Some::Package> allows you to resolve all functions name of the type C<Some::Package::func ...> in the current scope. You can use the pragma several times with different package names to allow resolution of all the corresponding barewords. Defaults to the current package.
 
 =back
 
+This module is B<not> a source filter.
+
 =cut
 
 BEGIN {
@@ -88,14 +90,18 @@ my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
               time times truncate uc ucfirst umask undef unlink unpack unshift
               untie use utime values vec wait waitpid wantarray warn when
               write/;
-push @core,qw/not __LINE__ __FILE__/;
+push @core,qw/not __LINE__ __FILE__ DATA/;
 
 my %core;
 @core{@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/) {
@@ -119,24 +127,29 @@ sub _reset {
 
 sub _fetch {
  (undef, my $data, my $func) = @_;
- return if $data->{guard};
- return unless $func !~ /::/ and not exists $core{$func};
+ return if $data->{guard} or $func =~ /::/ or exists $core{$func};
  local $data->{guard} = 1;
  my $hints = (caller 0)[10];
- if ($hints and $hints->{bareword}) {
+ 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} and not *$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);
@@ -152,7 +165,7 @@ sub _store {
  return;
 }
 
-my $wiz = wizard data  => sub { +{ pkg => $_[1] } },
+my $wiz = wizard data  => sub { +{ pkg => $_[1], guard => 0 } },
                  fetch => \&_fetch,
                  store => \&_store;
 
@@ -175,14 +188,14 @@ sub import {
  my %args = @_;
  my $cur  = (caller 1)[0];
  my $in   = _validate_pkg $args{in}, $cur;
- $^H{bareword} = 1;
+ $^H{subs__auto} = 1;
  ++$pkgs{$in};
  no strict 'refs';
  cast %{$in . '::'}, $wiz, $in;
 }
 
 sub unimport {
- $^H{bareword} = 0;
+ $^H{subs__auto} = 0;
 }
 
 {
@@ -215,7 +228,7 @@ L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the req
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
 
 =head1 BUGS