Document that the pragma doesn't propagate into eval STRING

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

diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 3657b1d3b6dbc7e4de61a54778fef9cde0a357ce..465d2d8dca084e97e03228bceb21ca8b002a53a2 100644 (file)
--- a/lib/subs/auto.pm
+++ b/lib/subs/auto.pm
@@ -5,13 +5,6 @@ use 5.010;
 use strict;
 use warnings;
 
-use B::Keywords;
-
-use Carp qw/croak/;
-use Symbol qw/gensym/;
-
-use Variable::Magic qw/wizard cast dispell getdata/;
-
 =head1 NAME
 
 subs::auto - Read barewords as subroutine names.
@@ -22,7 +15,10 @@ Version 0.05
 
 =cut
 
-our $VERSION = '0.05';
+our $VERSION;
+BEGIN {
+ $VERSION = '0.05';
+}
 
 =head1 SYNOPSIS
 
@@ -63,8 +59,19 @@ This module is B<not> a source filter.
 
 =cut
 
+use B;
+
+use B::Keywords;
+
+use Variable::Magic qw/wizard cast dispell getdata/;
+
 BEGIN {
- croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
+ unless (Variable::Magic::VMG_UVAR) {
+  require Carp;
+  Carp::croak('uvar magic not available');
+ }
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
 }
 
 my %core;
@@ -82,64 +89,67 @@ BEGIN {
 my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) };
 
 sub _reset {
- my ($pkg, $func) = @_;
  my $fqn = join '::', @_;
+
  my $cb = do {
   no strict 'refs';
   no warnings 'once';
   *$fqn{CODE};
  };
+
  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/) {
-   no warnings 'once';
-   *$sym = *$fqn{$_} if defined *$fqn{$_}
-  }
-  undef *$fqn;
-  *$fqn = *$sym;
+
+  _delete_sub($fqn);
  }
 }
 
 sub _fetch {
  (undef, my $data, my $func) = @_;
+
  return if $data->{guard} or $func =~ /::/ or exists $core{$func};
  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;
-   my $cb = do { no strict 'refs'; *$fqn{CODE} };
-   if ($cb) {
-    if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
-     ++$$data;
-    }
-    return;
+ if ($hints and $hints->{+(__PACKAGE__)}) {
+  my $pm = $func . '.pm';
+  return if exists $INC{$pm};
+
+  my $fqn = $data->{pkg} . '::' . $func;
+  my $cb = do { no strict 'refs'; *$fqn{CODE} };
+  if ($cb) {
+   if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
+    ++$$data;
    }
-   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;
+   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);
  }
+
  return;
 }
 
 sub _store {
  (undef, my $data, my $func) = @_;
+
  return if $data->{guard};
  local $data->{guard} = 1;
+
  _reset($data->{pkg}, $func);
+
  return;
 }
 
@@ -149,12 +159,27 @@ my $wiz = wizard data  => sub { +{ pkg => $_[1], guard => 0 } },
 
 my %pkgs;
 
+my $pkg_rx = qr/
+ ^(?:
+     ::
+    |
+     (?:::)?
+     [A-Za-z_][A-Za-z0-9_]*
+     (?:::[A-Za-z_][A-Za-z0-9_]*)*
+     (?:::)?
+  )$
+/x;
+
 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))/;
+
+ return $cur unless defined $pkg;
+
+ if (ref $pkg or $pkg !~ $pkg_rx) {
+  require Carp;
+  Carp::croak('Invalid package name');
+ }
+
  $pkg =~ s/::$//;
  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
  $pkg;
@@ -162,18 +187,28 @@ sub _validate_pkg {
 
 sub import {
  shift;
- croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
+ if (@_ % 2) {
+  require Carp;
+  Carp::croak('Optional arguments must be passed as keys/values pairs');
+ }
  my %args = @_;
- my $cur  = (caller 1)[0];
- my $in   = _validate_pkg $args{in}, $cur;
- $^H{subs__auto} = 1;
+
+ my $cur = (caller 1)[0];
+ my $in  = _validate_pkg $args{in}, $cur;
  ++$pkgs{$in};
- no strict 'refs';
- cast %{$in . '::'}, $wiz, $in;
+ {
+  no strict 'refs';
+  cast %{$in . '::'}, $wiz, $in;
+ }
+
+ $^H{+(__PACKAGE__)} = 1;
+ $^H |= 0x020000;
+
+ return;
 }
 
 sub unimport {
- $^H{subs__auto} = 0;
+ $^H{+(__PACKAGE__)} = 0;
 }
 
 {
@@ -194,16 +229,18 @@ C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enable
 
 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.
 
+This pragma doesn't propagate into C<eval STRING>.
+
 =head1 DEPENDENCIES
 
 L<perl> 5.10.0.
 
-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>.
 
+L<Carp> (standard since perl 5), L<XSLoader> (since 5.006).
+
 =head1 AUTHOR
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.