X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2Fsubs%2Fauto.pm;h=3cc549d6dfb05107c06a33da74d0678baf259078;hb=d876ff436156a4746f13aad51501eb73e710137f;hp=e507c5c71aafed9d24140a8a8528a13796ec91b1;hpb=205e44441b8719e69e65284d4d7c44e2627c485f;p=perl%2Fmodules%2Fsubs-auto.git diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm index e507c5c..3cc549d 100644 --- a/lib/subs/auto.pm +++ b/lib/subs/auto.pm @@ -5,7 +5,8 @@ use 5.010; use strict; use warnings; -use Carp qw/croak/; +use B::Keywords; + use Symbol qw/gensym/; use Variable::Magic qw/wizard cast dispell getdata/; @@ -16,11 +17,11 @@ subs::auto - Read barewords as subroutine names. =head1 VERSION -Version 0.04 +Version 0.05 =cut -our $VERSION = '0.04'; +our $VERSION = '0.05'; =head1 SYNOPSIS @@ -62,52 +63,40 @@ This module is B 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 = 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) = @_; + my $fqn = join '::', @_; my $cb = do { no strict 'refs'; 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/) { @@ -121,35 +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; - 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; - die "Undefined subroutine &$fqn called at $file line $line\n"; - }; - cast &$cb, $tag; - no strict 'refs'; - *$fqn = $cb; + 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; } + 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; } @@ -159,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; @@ -172,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; } { @@ -212,6 +240,8 @@ L (standard since perl 5), L (since 5.002). L with C magic enabled (this should be assured by the required perl version). +L. + =head1 AUTHOR Vincent Pit, C<< >>, L.