File Coverage

File:blib/lib/subs/auto.pm
Coverage:98.3%

linestmtbranpathcondsubtimecode
1package subs::auto;
2
3
6
6
6
6
6
6
6
6
52
93
21
5045
26
57
use 5.010;
4
5
6
6
6
6
61
24
85
use strict;
6
6
6
6
6
57
23
98
use warnings;
7
8
6
6
6
6
62
21
66
use Carp qw/croak/;
9
6
6
6
6
63
23
74
use Symbol qw/gensym/;
10
11
6
6
6
6
144
25
107
use Variable::Magic qw/wizard cast dispell getdata/;
12
13 - 21
=head1 NAME

subs::auto - Read barewords as subroutine names.

=head1 VERSION

Version 0.05

=cut
22
23our $VERSION = '0.05';
24
25 - 62
=head1 SYNOPSIS

    {
     use subs::auto;
     foo;             # Compile to "foo()"     instead of "'foo'"
                      #                        or croaking on strict subs
     foo $x;          # Compile to "foo($x)"   instead of "$x->foo"
     foo 1;           # Compile to "foo(1)"    instead of croaking
     foo 1, 2;        # Compile to "foo(1, 2)" instead of croaking
     foo(@a);         # Still ok
     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 "print(foo('wut'))" otherwise
    } # ... but function calls will fail at run-time if you don't
      # actually define foo somewhere
    
    foo; # BANG

=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 an IO slot (expected to be filehandles).

You can pass options to C<import> as key / value pairs :

=over 4

=item *

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.

=back

This module is B<not> a source filter.

=cut
63
64BEGIN {
65
6
6
42
 croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
66}
67
68my @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
92              write/;
93push @core,qw/not __LINE__ __FILE__ DATA/;
94
95my %core;
96@core{@core} = ();
97delete @core{qw/my local/};
98undef @core;
99
100my $tag = wizard data => sub { 1 };
101
102sub _reset {
103
355
355
1436
 my ($pkg, $func) = @_;
104
355
1391
 my $fqn = join '::', @_;
105
355
918
 my $cb = do {
106
6
6
6
6
80
26
53
  no strict 'refs';
107
6
6
6
6
60
21
49
  no warnings 'once';
108
355
1
1
1
1
573
3
4
4
  *$fqn{CODE};
109 };
110
355
100
100
3809
 if ($cb and getdata(&$cb, $tag)) {
111
6
6
6
6
66
23
47
  no strict 'refs';
112
28
149
  my $sym = gensym;
113
28
118
  for (qw/SCALAR ARRAY HASH IO FORMAT/) {
114
6
6
6
6
62
21
39
   no warnings 'once';
115
140
100
228
   *$sym = *$fqn{$_} if defined *$fqn{$_}
116  }
117
28
48
  undef *$fqn;
118
28
42
  *$fqn = *$sym;
119 }
120}
121
122sub _fetch {
123
566
566
3711
 (undef, my $data, my $func) = @_;
124
566
100
100
5076
 return if $data->{guard} or $func =~ /::/ or exists $core{$func};
125
210
809
 local $data->{guard} = 1;
126
210
442
 my $hints = (caller 0)[10];
127
210
100
100
2764
 if ($hints and $hints->{subs__auto}) {
128
148
471
  my $mod = $func . '.pm';
129
148
100
636
  if (not exists $INC{$mod}) {
130
147
528
   my $fqn = $data->{pkg} . '::' . $func;
131
6
6
6
147
147
100
100
6
78
39
53
346
260
   if (do { no strict 'refs'; not *$fqn{CODE} || *$fqn{IO}}) {
132    my $cb = sub {
133
2
2
42
     my ($file, $line) = (caller 0)[1, 2];
134
2
50
33
33
     ($file, $line) = ('(eval 0)', 0) unless $file && $line;
135
2
6
     die "Undefined subroutine &$fqn called at $file line $line\n";
136
33
449
    };
137
33
75
    cast &$cb, $tag;
138
6
6
6
6
72
624
47
    no strict 'refs';
139
33
58
    *$fqn = $cb;
140   }
141  }
142 } else {
143
62
253
  _reset($data->{pkg}, $func);
144 }
145
210
1585
 return;
146}
147
148sub _store {
149
2126
2126
9944
 (undef, my $data, my $func) = @_;
150
2126
100
8786
 return if $data->{guard};
151
293
1084
 local $data->{guard} = 1;
152
293
1118
 _reset($data->{pkg}, $func);
153
293
1112
 return;
154}
155
156my $wiz = wizard data => sub { +{ pkg => $_[1], guard => 0 } },
157                 fetch => \&_fetch,
158                 store => \&_store;
159
160my %pkgs;
161
162sub _validate_pkg {
163
16
16
82
 my ($pkg, $cur) = @_;
164
16
100
89
 return $cur unless $pkg;
165
10
100
100
264
 croak 'Invalid package name' if ref $pkg
166                              or $pkg =~ /(?:-|[^\w:])/
167                              or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
168
3
18
 $pkg =~ s/::$//;
169
3
100
100
30
 $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
170
3
16
 $pkg;
171}
172
173sub import {
174
17
17
74
 shift;
175
17
100
116
 croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
176
16
105
 my %args = @_;
177
16
179
 my $cur = (caller 1)[0];
178
16
134
 my $in = _validate_pkg $args{in}, $cur;
179
9
68
 $^H{subs__auto} = 1;
180
9
35
 ++$pkgs{$in};
181
6
6
6
6
90
23
49
 no strict 'refs';
182
9
9
28
34
 cast %{$in . '::'}, $wiz, $in;
183}
184
185sub unimport {
186
4
4
610
 $^H{subs__auto} = 0;
187}
188
189{
190
6
6
6
6
63
22
47
 no warnings 'void';
191 CHECK {
192
6
6
6
6
61
23
39
  no strict 'refs';
193
4
4
6
4
50
50
65
  dispell %{$_ . '::'}, $wiz for keys %pkgs;
194 }
195}
196
197 - 244
=head1 EXPORT

None.

=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 ?).

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.

=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).

=head1 AUTHOR

Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.

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.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc subs::auto

Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.

=head1 ACKNOWLEDGEMENTS

Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.

=head1 COPYRIGHT & LICENSE

Copyright 2008 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.

=cut
245
2461; # End of subs::auto