Better be on irc.perl.org

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

diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 13568acf02ac3419c0fb6222aa4b22c2cf50cedc..66c26a34b5b97911417460d188727cecc2a10b5a 100644 (file)
--- a/lib/subs/auto.pm
+++ b/lib/subs/auto.pm
@@ -5,6 +5,7 @@ use 5.010;
 use strict;
 use warnings;
 
+use Carp qw/croak/;
 use Symbol qw/gensym/;
 
 use Variable::Magic qw/wizard cast dispell getdata/;
@@ -15,11 +16,11 @@ subs::auto - Read barewords as subroutine names.
 
 =head1 VERSION
 
-Version 0.01
+Version 0.04
 
 =cut
 
-our $VERSION = '0.01';
+our $VERSION = '0.04';
 
 =head1 SYNOPSIS
 
@@ -34,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
     
@@ -44,13 +45,24 @@ our $VERSION = '0.01';
 
 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).
 
+You can pass options to C<import> as key / value pairs :
+
+=over 4
+
+=item *
+
+C<< in => $pkg >>
+
+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 {
- if (!Variable::Magic::VMG_UVAR) {
-  require Carp;
-  Carp::croak('uvar magic not available');
- }
+ croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
 }
 
 my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
@@ -78,7 +90,7 @@ 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/;
+push @core,qw/not __LINE__ __FILE__ DATA/;
 
 my %core;
 @core{@core} = ();
@@ -109,15 +121,14 @@ sub _reset {
 
 sub _fetch {
  (undef, my $data, my $func) = @_;
- return if $data->{guard};
- return unless $func !~ /::/ and not exists $core{$func};
- local $data->{guard} = 1;
+ return if $data->{guard} or $func =~ /::/ or exists $core{$func};
+ $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}}) {
+   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;
@@ -131,14 +142,16 @@ sub _fetch {
  } else {
   _reset($data->{pkg}, $func);
  }
+ $data->{guard} = 0;
  return;
 }
 
 sub _store {
  (undef, my $data, my $func) = @_;
  return if $data->{guard};
- local $data->{guard} = 1;
+ $data->{guard} = 1;
  _reset($data->{pkg}, $func);
+ $data->{guard} = 0;
  return;
 }
 
@@ -148,16 +161,31 @@ my $wiz = wizard data  => sub { +{ pkg => $_[1] } },
 
 my %pkgs;
 
+sub _validate_pkg {
+ my ($pkg, $cur) = @_;
+ return $cur unless $pkg;
+ croak 'Invalid package name' if ref $pkg
+                              or $pkg =~ /(?:-|[^\w:])/
+                              or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
+ $pkg =~ s/::$//;
+ $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
+ $pkg;
+}
+
 sub import {
- my $pkg = caller 1;
- $^H{bareword} = 1;
- ++$pkgs{$pkg};
+ shift;
+ croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
+ my %args = @_;
+ my $cur  = (caller 1)[0];
+ my $in   = _validate_pkg $args{in}, $cur;
+ $^H{subs__auto} = 1;
+ ++$pkgs{$in};
  no strict 'refs';
- cast %{$pkg . '::'}, $wiz, $pkg;
+ cast %{$in . '::'}, $wiz, $in;
 }
 
 sub unimport {
- $^H{bareword} = 0;
+ $^H{subs__auto} = 0;
 }
 
 {
@@ -176,6 +204,8 @@ None.
 
 C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enabled, C<foo> is used as a bareword, but is never actually defined afterwards. This may or may not be considered as Doing The Right Thing. However, C<*{'::foo'}{CODE}> will always return the right value if you fetch it outside the pragma's scope. Actually, you can make it return the right value even in the pragma's scope by reading C<*{'::foo'}{CODE}> outside (or by actually defining C<foo>, which is ultimately why you use this pragma, right ?).
 
+You have to open global filehandles outside of the scope of this pragma if you want them not to be treated as function calls. Or just use lexical filehandles and default ones as you should be.
+
 =head1 DEPENDENCIES
 
 L<perl> 5.10.0.
@@ -188,7 +218,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