lib/subs/auto.pm

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