From: Vincent Pit <vince@profvince.com>
Date: Sat, 24 Jul 2010 19:52:28 +0000 (+0200)
Subject: Code cleanup
X-Git-Tag: v0.06~10
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=d876ff436156a4746f13aad51501eb73e710137f;p=perl%2Fmodules%2Fsubs-auto.git

Code cleanup
---

diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 3657b1d..3cc549d 100644
--- a/lib/subs/auto.pm
+++ b/lib/subs/auto.pm
@@ -7,7 +7,6 @@ use warnings;
 
 use B::Keywords;
 
-use Carp qw/croak/;
 use Symbol qw/gensym/;
 
 use Variable::Magic qw/wizard cast dispell getdata/;
@@ -64,7 +63,10 @@ This module is B<not> a source filter.
 =cut
 
 BEGIN {
- croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
+ unless (Variable::Magic::VMG_UVAR) {
+  require Carp;
+  Carp::croak('uvar magic not available');
+ }
 }
 
 my %core;
@@ -83,15 +85,18 @@ 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/) {
@@ -105,41 +110,49 @@ sub _reset {
 
 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 +162,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 +190,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;
 }
 
 {