X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2Fsubs%2Fauto.pm;h=98b02e5636d0d521f3143b7a7b5456e22e5252d5;hb=f3015fc0f10b75a7e7073d450605029e3cf83978;hp=978ce41fc91b9b3aab744a98fd3415f3b9bfc11f;hpb=dbcfb4682f32b8e308025d9fb2ceaac416f42cce;p=perl%2Fmodules%2Fsubs-auto.git diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm index 978ce41..98b02e5 100644 --- a/lib/subs/auto.pm +++ b/lib/subs/auto.pm @@ -5,22 +5,20 @@ use 5.010; use strict; use warnings; -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. =head1 VERSION -Version 0.04 +Version 0.05 =cut -our $VERSION = '0.04'; +our $VERSION; +BEGIN { + $VERSION = '0.05'; +} =head1 SYNOPSIS @@ -61,112 +59,127 @@ This module is B 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 = 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)) { - 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; + + if ($cb and defined(my $data = getdata(&$cb, $tag))) { + $$data--; + return if $$data > 0; + + _delete_sub($fqn); } } sub _fetch { (undef, my $data, my $func) = @_; + return if $data->{guard} or $func =~ /::/ or exists $core{$func}; - $data->{guard} = 1; + 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); } - $data->{guard} = 0; + return; } sub _store { (undef, my $data, my $func) = @_; + return if $data->{guard}; - $data->{guard} = 1; + local $data->{guard} = 1; + _reset($data->{pkg}, $func); - $data->{guard} = 0; + return; } -my $wiz = wizard data => sub { +{ pkg => $_[1] } }, +my $wiz = wizard data => sub { +{ pkg => $_[1], guard => 0 } }, fetch => \&_fetch, store => \&_store; 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; @@ -174,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; } { @@ -210,10 +233,12 @@ You have to open global filehandles outside of the scope of this pragma if you w L 5.10.0. -L (standard since perl 5), L (since 5.002). - L with C magic enabled (this should be assured by the required perl version). +L. + +L (standard since perl 5), L (since 5.006). + =head1 AUTHOR Vincent Pit, C<< >>, L.