X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2Fsubs%2Fauto.pm;h=3657b1d3b6dbc7e4de61a54778fef9cde0a357ce;hb=966c26dceba593e4ccb48ea0fd521c3a7d403330;hp=87fcc5528712605318d73b56163c74e510f04e1c;hpb=8c014a64b4ed83a697c0109af2c1555bc8c26ae9;p=perl%2Fmodules%2Fsubs-auto.git

diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 87fcc55..3657b1d 100644
--- a/lib/subs/auto.pm
+++ b/lib/subs/auto.pm
@@ -5,6 +5,8 @@ use 5.010;
 use strict;
 use warnings;
 
+use B::Keywords;
+
 use Carp qw/croak/;
 use Symbol qw/gensym/;
 
@@ -16,11 +18,11 @@ subs::auto - Read barewords as subroutine names.
 
 =head1 VERSION
 
-Version 0.02
+Version 0.05
 
 =cut
 
-our $VERSION = '0.02';
+our $VERSION = '0.05';
 
 =head1 SYNOPSIS
 
@@ -35,7 +37,7 @@ our $VERSION = '0.02';
      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 +45,7 @@ our $VERSION = '0.02';
 
 =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 :
 
@@ -57,45 +59,27 @@ Specifies on which package the pragma should act. Setting C<$pkg> to C<Some::Pac
 
 =back
 
+This module is B<not> a source filter.
+
 =cut
 
 BEGIN {
  croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
 }
 
-my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
-              chmod chomp chop chown chr chroot close closedir connect
-              continue cos crypt dbmclose dbmopen default defined delete die
-              do dump each endgrent endhostent endnetent endprotoent endpwent
-              endservent eof eval exec exists exit exp fcntl fileno flock fork
-              format formline getc getgrent getgrgid getgrnam gethostbyaddr
-              gethostbyname gethostent getlogin getnetbyaddr getnetbyname
-              getnetent getpeername getpgrp getppid getpriority getprotobyname
-              getprotobynumber getprotoent getpwent getpwnam getpwuid
-              getservbyname getservbyport getservent getsockname getsockopt
-              given glob gmtime goto grep hex index int ioctl join keys kill
-              last lc lcfirst length link listen local localtime lock log
-              lstat map mkdir msgctl msgget msgrcv msgsnd my next no oct open
-              opendir ord our pack package pipe pop pos print printf prototype
-              push quotemeta rand read readdir readline readlink readpipe recv
-              redo ref rename require reset return reverse rewinddir rindex
-              rmdir say scalar seek seekdir select semctl semget semop send
-              setgrent sethostent setnetent setpgrp setpriority setprotoent
-              setpwent setservent setsockopt shift shmctl shmget shmread
-              shmwrite shutdown sin sleep socket socketpair sort splice split
-              sprintf sqrt srand stat state study sub substr symlink syscall
-              sysopen sysread sysseek system syswrite tell telldir tie tied
-              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__ DATA/;
-
 my %core;
-@core{@core} = ();
+@core{
+ @B::Keywords::Barewords,
+ @B::Keywords::Functions,
+ 'DATA',
+} = ();
 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 +89,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 +105,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 +143,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 +166,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;
 }
 
 {
@@ -211,11 +202,13 @@ L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
 
 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 
+L<B::Keywords>.
+
 =head1 AUTHOR
 
 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