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.02
  20
  21 =cut
  22
  23 our $VERSION = '0.02';
  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 "foo()->print('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 a 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 =cut
  61
  62 BEGIN {
  63  croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
  64 }
  65
  66 my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
  67               chmod chomp chop chown chr chroot close closedir connect
  68               continue cos crypt dbmclose dbmopen default defined delete die
  69               do dump each endgrent endhostent endnetent endprotoent endpwent
  70               endservent eof eval exec exists exit exp fcntl fileno flock fork
  71               format formline getc getgrent getgrgid getgrnam gethostbyaddr
  72               gethostbyname gethostent getlogin getnetbyaddr getnetbyname
  73               getnetent getpeername getpgrp getppid getpriority getprotobyname
  74               getprotobynumber getprotoent getpwent getpwnam getpwuid
  75               getservbyname getservbyport getservent getsockname getsockopt
  76               given glob gmtime goto grep hex index int ioctl join keys kill
  77               last lc lcfirst length link listen local localtime lock log
  78               lstat map mkdir msgctl msgget msgrcv msgsnd my next no oct open
  79               opendir ord our pack package pipe pop pos print printf prototype
  80               push quotemeta rand read readdir readline readlink readpipe recv
  81               redo ref rename require reset return reverse rewinddir rindex
  82               rmdir say scalar seek seekdir select semctl semget semop send
  83               setgrent sethostent setnetent setpgrp setpriority setprotoent
  84               setpwent setservent setsockopt shift shmctl shmget shmread
  85               shmwrite shutdown sin sleep socket socketpair sort splice split
  86               sprintf sqrt srand stat state study sub substr symlink syscall
  87               sysopen sysread sysseek system syswrite tell telldir tie tied
  88               time times truncate uc ucfirst umask undef unlink unpack unshift
  89               untie use utime values vec wait waitpid wantarray warn when
  90               write/;
  91 push @core,qw/not __LINE__ __FILE__ DATA/;
  92
  93 my %core;
  94 @core{@core} = ();
  95 delete @core{qw/my local/};
  96 undef @core;
  97
  98 my $tag = wizard data => sub { 1 };
  99
 100 sub _reset {
 101  my ($pkg, $func) = @_;
 102  my $fqn = join '::', @_;
 103  my $cb = do {
 104   no strict 'refs';
 105   no warnings 'once';
 106   *$fqn{CODE};
 107  };
 108  if ($cb and getdata(&$cb, $tag)) {
 109   no strict 'refs';
 110   my $sym = gensym;
 111   for (qw/SCALAR ARRAY HASH IO FORMAT/) {
 112    no warnings 'once';
 113    *$sym = *$fqn{$_} if defined *$fqn{$_}
 114   }
 115   undef *$fqn;
 116   *$fqn = *$sym;
 117  }
 118 }
 119
 120 sub _fetch {
 121  (undef, my $data, my $func) = @_;
 122  return if $data->{guard};
 123  return unless $func !~ /::/ and not exists $core{$func};
 124  $data->{guard} = 1;
 125  my $hints = (caller 0)[10];
 126  if ($hints and $hints->{subs__auto}) {
 127   my $mod = $func . '.pm';
 128   if (not exists $INC{$mod}) {
 129    my $fqn = $data->{pkg} . '::' . $func;
 130    if (do { no strict 'refs'; not *$fqn{CODE} and not *$fqn{IO}}) {
 131     my $cb = sub {
 132      my ($file, $line) = (caller 0)[1, 2];
 133      ($file, $line) = ('(eval 0)', 0) unless $file && $line;
 134      die "Undefined subroutine &$fqn called at $file line $line\n";
 135     };
 136     cast &$cb, $tag;
 137     no strict 'refs';
 138     *$fqn = $cb;
 139    }
 140   }
 141  } else {
 142   _reset($data->{pkg}, $func);
 143  }
 144  $data->{guard} = 0;
 145  return;
 146 }
 147
 148 sub _store {
 149  (undef, my $data, my $func) = @_;
 150  return if $data->{guard};
 151  $data->{guard} = 1;
 152  _reset($data->{pkg}, $func);
 153  $data->{guard} = 0;
 154  return;
 155 }
 156
 157 my $wiz = wizard data  => sub { +{ pkg => $_[1] } },
 158                  fetch => \&_fetch,
 159                  store => \&_store;
 160
 161 my %pkgs;
 162
 163 sub _validate_pkg {
 164  my ($pkg, $cur) = @_;
 165  return $cur unless $pkg;
 166  croak 'Invalid package name' if ref $pkg
 167                               or $pkg =~ /(?:-|[^\w:])/
 168                               or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
 169  $pkg =~ s/::$//;
 170  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
 171  $pkg;
 172 }
 173
 174 sub import {
 175  shift;
 176  croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
 177  my %args = @_;
 178  my $cur  = (caller 1)[0];
 179  my $in   = _validate_pkg $args{in}, $cur;
 180  $^H{subs__auto} = 1;
 181  ++$pkgs{$in};
 182  no strict 'refs';
 183  cast %{$in . '::'}, $wiz, $in;
 184 }
 185
 186 sub unimport {
 187  $^H{subs__auto} = 0;
 188 }
 189
 190 {
 191  no warnings 'void';
 192  CHECK {
 193   no strict 'refs';
 194   dispell %{$_ . '::'}, $wiz for keys %pkgs;
 195  }
 196 }
 197
 198 =head1 EXPORT
 199
 200 None.
 201
 202 =head1 CAVEATS
 203
 204 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 ?).
 205
 206 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.
 207
 208 =head1 DEPENDENCIES
 209
 210 L<perl> 5.10.0.
 211
 212 L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
 213
 214 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 215
 216 =head1 AUTHOR
 217
 218 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 219
 220 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 221
 222 =head1 BUGS
 223
 224 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.
 225
 226 =head1 SUPPORT
 227
 228 You can find documentation for this module with the perldoc command.
 229
 230     perldoc subs::auto
 231
 232 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
 233
 234 =head1 ACKNOWLEDGEMENTS
 235
 236 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
 237
 238 =head1 COPYRIGHT & LICENSE
 239
 240 Copyright 2008 Vincent Pit, all rights reserved.
 241
 242 This program is free software; you can redistribute it and/or modify it
 243 under the same terms as Perl itself.
 244
 245 =cut
 246
 247 1; # End of subs::auto