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