11 use Variable::Magic qw/wizard cast dispell getdata/;
15 subs::auto - Read barewords as subroutine names.
23 our $VERSION = '0.05';
29 foo; # Compile to "foo()" instead of "'foo'"
30 # or croaking on strict subs
31 foo $x; # Compile to "foo($x)" instead of "$x->foo"
32 foo 1; # Compile to "foo(1)" instead of croaking
33 foo 1, 2; # Compile to "foo(1, 2)" instead of croaking
35 foo->meth; # "'foo'->meth" if you have use'd foo somewhere,
36 # or "foo()->meth" otherwise
37 print foo 'wut'; # print to the filehandle foo if it's actually one,
38 # or "print(foo('wut'))" otherwise
39 } # ... but function calls will fail at run-time if you don't
40 # actually define foo somewhere
46 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).
48 You can pass options to C<import> as key / value pairs :
56 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.
60 This module is B<not> a source filter.
65 croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
68 my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
69 chmod chomp chop chown chr chroot close closedir connect
70 continue cos crypt dbmclose dbmopen default defined delete die
71 do dump each endgrent endhostent endnetent endprotoent endpwent
72 endservent eof eval exec exists exit exp fcntl fileno flock fork
73 format formline getc getgrent getgrgid getgrnam gethostbyaddr
74 gethostbyname gethostent getlogin getnetbyaddr getnetbyname
75 getnetent getpeername getpgrp getppid getpriority getprotobyname
76 getprotobynumber getprotoent getpwent getpwnam getpwuid
77 getservbyname getservbyport getservent getsockname getsockopt
78 given glob gmtime goto grep hex index int ioctl join keys kill
79 last lc lcfirst length link listen local localtime lock log
80 lstat map mkdir msgctl msgget msgrcv msgsnd my next no oct open
81 opendir ord our pack package pipe pop pos print printf prototype
82 push quotemeta rand read readdir readline readlink readpipe recv
83 redo ref rename require reset return reverse rewinddir rindex
84 rmdir say scalar seek seekdir select semctl semget semop send
85 setgrent sethostent setnetent setpgrp setpriority setprotoent
86 setpwent setservent setsockopt shift shmctl shmget shmread
87 shmwrite shutdown sin sleep socket socketpair sort splice split
88 sprintf sqrt srand stat state study sub substr symlink syscall
89 sysopen sysread sysseek system syswrite tell telldir tie tied
90 time times truncate uc ucfirst umask undef unlink unpack unshift
91 untie use utime values vec wait waitpid wantarray warn when
93 push @core,qw/not __LINE__ __FILE__ DATA/;
97 delete @core{qw/my local/};
101 *_REFCNT_PLACEHOLDERS = eval 'sub () { ' . ($] < 5.011002 ? 0 : 1) . '}'
104 my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) };
107 my ($pkg, $func) = @_;
108 my $fqn = join '::', @_;
114 if ($cb and defined(my $data = getdata(&$cb, $tag))) {
116 return if $$data > 0;
119 for (qw/SCALAR ARRAY HASH IO FORMAT/) {
121 *$sym = *$fqn{$_} if defined *$fqn{$_}
129 (undef, my $data, my $func) = @_;
130 return if $data->{guard} or $func =~ /::/ or exists $core{$func};
131 local $data->{guard} = 1;
132 my $hints = (caller 0)[10];
133 if ($hints and $hints->{subs__auto}) {
134 my $mod = $func . '.pm';
135 if (not exists $INC{$mod}) {
136 my $fqn = $data->{pkg} . '::' . $func;
137 my $cb = do { no strict 'refs'; *$fqn{CODE} };
139 if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
144 return if do { no strict 'refs'; *$fqn{IO} };
146 my ($file, $line) = (caller 0)[1, 2];
147 ($file, $line) = ('(eval 0)', 0) unless $file && $line;
148 die "Undefined subroutine &$fqn called at $file line $line\n";
155 _reset($data->{pkg}, $func);
161 (undef, my $data, my $func) = @_;
162 return if $data->{guard};
163 local $data->{guard} = 1;
164 _reset($data->{pkg}, $func);
168 my $wiz = wizard data => sub { +{ pkg => $_[1], guard => 0 } },
175 my ($pkg, $cur) = @_;
176 return $cur unless $pkg;
177 croak 'Invalid package name' if ref $pkg
178 or $pkg =~ /(?:-|[^\w:])/
179 or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
181 $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
187 croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
189 my $cur = (caller 1)[0];
190 my $in = _validate_pkg $args{in}, $cur;
194 cast %{$in . '::'}, $wiz, $in;
205 dispell %{$_ . '::'}, $wiz for keys %pkgs;
215 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 ?).
217 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.
223 L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
225 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
229 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
231 You can contact me by mail or on C<irc.perl.org> (vincent).
235 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.
239 You can find documentation for this module with the perldoc command.
243 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
245 =head1 ACKNOWLEDGEMENTS
247 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
249 =head1 COPYRIGHT & LICENSE
251 Copyright 2008 Vincent Pit, all rights reserved.
253 This program is free software; you can redistribute it and/or modify it
254 under the same terms as Perl itself.
258 1; # End of subs::auto