X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fsubs-auto.git;a=blobdiff_plain;f=lib%2Fsubs%2Fauto.pm;h=c079d7cc2c830011ee1ce9719c9eab89c2567820;hp=13568acf02ac3419c0fb6222aa4b22c2cf50cedc;hb=d027f9e2d01eea3b32eff74cc1e89fae7e8927df;hpb=8d9466619cdc7aaf876803a49d8857ce55e114d0 diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm index 13568ac..c079d7c 100644 --- a/lib/subs/auto.pm +++ b/lib/subs/auto.pm @@ -5,21 +5,20 @@ use 5.010; use strict; use warnings; -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.01 +Version 0.06 =cut -our $VERSION = '0.01'; +our $VERSION; +BEGIN { + $VERSION = '0.06'; +} =head1 SYNOPSIS @@ -34,7 +33,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 @@ -42,122 +41,187 @@ our $VERSION = '0.01'; =head1 DESCRIPTION -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). +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 an IO slot (expected to be filehandles). + +You can pass options to C as key / value pairs : + +=over 4 + +=item * + +C<< in => $pkg >> + +Specifies on which package the pragma should act. +Setting C<$pkg> to C allows you to resolve all functions name of the type C 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 a source filter. =cut +use B; + +use B::Keywords; + +use Variable::Magic 0.31 qw/wizard cast dispell getdata/; + BEGIN { - if (!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/; - 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) = @_; + (undef, my $data, my $name) = @_; + return if $data->{guard}; - return unless $func !~ /::/ and not exists $core{$func}; local $data->{guard} = 1; + + return if $name =~ /::/ + or exists $core{$name}; + + my $op_name = $_[-1] || ''; + return if $op_name =~ /method/; + + my $pkg = $data->{pkg}; + my $hints = (caller 0)[10]; - if ($hints and $hints->{bareword}) { - 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}}) { - 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 = $name . '.pm'; + return if exists $INC{$pm}; + + my $fqn = $pkg . '::' . $name; + 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); + _reset($pkg, $name); } + return; } sub _store { - (undef, my $data, my $func) = @_; + (undef, my $data, my $name) = @_; + return if $data->{guard}; local $data->{guard} = 1; - _reset($data->{pkg}, $func); + + _reset($data->{pkg}, $name); + return; } -my $wiz = wizard data => sub { +{ pkg => $_[1] } }, - fetch => \&_fetch, - store => \&_store; +my $wiz = wizard data => sub { +{ pkg => $_[1], guard => 0 } }, + fetch => \&_fetch, + store => \&_store, + op_info => Variable::Magic::VMG_OP_INFO_NAME; 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 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; +} + sub import { - my $pkg = caller 1; - $^H{bareword} = 1; - ++$pkgs{$pkg}; - no strict 'refs'; - cast %{$pkg . '::'}, $wiz, $pkg; + shift; + if (@_ % 2) { + require Carp; + Carp::croak('Optional arguments must be passed as keys/values pairs'); + } + my %args = @_; + + my $cur = caller; + my $in = _validate_pkg $args{in}, $cur; + ++$pkgs{$in}; + { + no strict 'refs'; + cast %{$in . '::'}, $wiz, $in; + } + + $^H{+(__PACKAGE__)} = 1; + $^H |= 0x020000; + + return; } sub unimport { - $^H{bareword} = 0; + $^H{+(__PACKAGE__)} = 0; } { @@ -174,25 +238,36 @@ None. =head1 CAVEATS -C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enabled, C 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, which is ultimately why you use this pragma, right ?). +C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enabled, C 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, 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. + +This pragma doesn't propagate into C. =head1 DEPENDENCIES 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. -You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). +You can contact me by mail or on C (vincent). =head1 BUGS -Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT @@ -208,7 +283,7 @@ Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma. =head1 COPYRIGHT & LICENSE -Copyright 2008 Vincent Pit, all rights reserved. +Copyright 2008,2009,2010 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.