lib/subs/auto.pm

   1 package subs::auto;
   2
   3 use 5.010;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp qw/croak/;
   9 use Symbol qw/gensym/;
  10
  11 use Variable::Magic qw/wizard cast dispell getdata/;
  12
  13 =head1 NAME
  14
  15 subs::auto - Read barewords as subroutine names.
  16
  17 =head1 VERSION
  18
  19 Version 0.05
  20
  21 =cut
  22
  23 our $VERSION = '0.05';
  24
  25 =head1 SYNOPSIS
  26
  27     {
  28      use subs::auto;
  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
  34      foo(@a);         # Still ok
  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
  41
  42     foo; # BANG
  43
  44 =head1 DESCRIPTION
  45
  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).
  47
  48 You can pass options to C<import> as key / value pairs :
  49
  50 =over 4
  51
  52 =item *
  53
  54 C<< in => $pkg >>
  55
  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.
  57
  58 =back
  59
  60 This module is B<not> a source filter.
  61
  62 =cut
  63
  64 BEGIN {
  65  croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
  66 }
  67
  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
  92               write/;
  93 push @core,qw/not __LINE__ __FILE__ DATA/;
  94
  95 my %core;
  96 @core{@core} = ();
  97 delete @core{qw/my local/};
  98 undef @core;
  99
 100 BEGIN {
 101  *_REFCNT_PLACEHOLDERS = eval 'sub () { ' . ($] < 5.011002 ? 0 : 1) . '}'
 102 }
 103
 104 my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) };
 105
 106 sub _reset {
 107  my ($pkg, $func) = @_;
 108  my $fqn = join '::', @_;
 109  my $cb = do {
 110   no strict 'refs';
 111   no warnings 'once';
 112   *$fqn{CODE};
 113  };
 114  if ($cb and defined(my $data = getdata(&$cb, $tag))) {
 115   $$data--;
 116   return if $$data > 0;
 117   no strict 'refs';
 118   my $sym = gensym;
 119   for (qw/SCALAR ARRAY HASH IO FORMAT/) {
 120    no warnings 'once';
 121    *$sym = *$fqn{$_} if defined *$fqn{$_}
 122   }
 123   undef *$fqn;
 124   *$fqn = *$sym;
 125  }
 126 }
 127
 128 sub _fetch {
 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} };
 138    if ($cb) {
 139     if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
 140      ++$$data;
 141     }
 142     return;
 143    }
 144    return if do { no strict 'refs'; *$fqn{IO} };
 145    $cb = sub {
 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";
 149    };
 150    cast &$cb, $tag;
 151    no strict 'refs';
 152    *$fqn = $cb;
 153   }
 154  } else {
 155   _reset($data->{pkg}, $func);
 156  }
 157  return;
 158 }
 159
 160 sub _store {
 161  (undef, my $data, my $func) = @_;
 162  return if $data->{guard};
 163  local $data->{guard} = 1;
 164  _reset($data->{pkg}, $func);
 165  return;
 166 }
 167
 168 my $wiz = wizard data  => sub { +{ pkg => $_[1], guard => 0 } },
 169                  fetch => \&_fetch,
 170                  store => \&_store;
 171
 172 my %pkgs;
 173
 174 sub _validate_pkg {
 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))/;
 180  $pkg =~ s/::$//;
 181  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
 182  $pkg;
 183 }
 184
 185 sub import {
 186  shift;
 187  croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
 188  my %args = @_;
 189  my $cur  = (caller 1)[0];
 190  my $in   = _validate_pkg $args{in}, $cur;
 191  $^H{subs__auto} = 1;
 192  ++$pkgs{$in};
 193  no strict 'refs';
 194  cast %{$in . '::'}, $wiz, $in;
 195 }
 196
 197 sub unimport {
 198  $^H{subs__auto} = 0;
 199 }
 200
 201 {
 202  no warnings 'void';
 203  CHECK {
 204   no strict 'refs';
 205   dispell %{$_ . '::'}, $wiz for keys %pkgs;
 206  }
 207 }
 208
 209 =head1 EXPORT
 210
 211 None.
 212
 213 =head1 CAVEATS
 214
 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 ?).
 216
 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.
 218
 219 =head1 DEPENDENCIES
 220
 221 L<perl> 5.10.0.
 222
 223 L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
 224
 225 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 226
 227 =head1 AUTHOR
 228
 229 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 230
 231 You can contact me by mail or on C<irc.perl.org> (vincent).
 232
 233 =head1 BUGS
 234
 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.
 236
 237 =head1 SUPPORT
 238
 239 You can find documentation for this module with the perldoc command.
 240
 241     perldoc subs::auto
 242
 243 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
 244
 245 =head1 ACKNOWLEDGEMENTS
 246
 247 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
 248
 249 =head1 COPYRIGHT & LICENSE
 250
 251 Copyright 2008 Vincent Pit, all rights reserved.
 252
 253 This program is free software; you can redistribute it and/or modify it
 254 under the same terms as Perl itself.
 255
 256 =cut
 257
 258 1; # End of subs::auto