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.03
+Version 0.06
=cut
-our $VERSION = '0.03';
+our $VERSION;
+BEGIN {
+ $VERSION = '0.06';
+}
=head1 SYNOPSIS
=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<import> as key / value pairs :
C<< in => $pkg >>
-Specifies on which package the pragma should act. Setting C<$pkg> to C<Some::Package> allows you to resolve all functions name of the type C<Some::Package::func ...> 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.
+Specifies on which package the pragma should act.
+Setting C<$pkg> to C<Some::Package> allows you to resolve all functions name of the type C<Some::Package::func ...> 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
=cut
+use B;
+
+use B::Keywords;
+
+use Variable::Magic 0.31 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;
+ (undef, my $data, my $name) = @_;
+
+ return if $data->{guard};
+ 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->{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 = $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);
}
- $data->{guard} = 0;
+
return;
}
sub _store {
- (undef, my $data, my $func) = @_;
+ (undef, my $data, my $name) = @_;
+
return if $data->{guard};
- $data->{guard} = 1;
- _reset($data->{pkg}, $func);
- $data->{guard} = 0;
+ local $data->{guard} = 1;
+
+ _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 $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;
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;
+ 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;
}
{
=head1 CAVEATS
-C<*{'::foo'}{CODE}> will appear as defined in a scope where the pragma is enabled, C<foo> 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<foo>, 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<foo> 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<foo>, 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.
-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>.
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
=head1 BUGS
-Please report any bugs or feature requests to C<bug-subs-auto at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=subs-auto>. 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<bug-subs-auto at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=subs-auto>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
=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.
projects / perl / modules / subs-auto.git / blobdiff