lib/subs/auto.pm

   1 package subs::auto;
   2
   3 use 5.010;
   4
   5 use strict;
   6 use warnings;
   7
   8 use B::Keywords;
   9
  10 use Carp qw/croak/;
  11 use Symbol qw/gensym/;
  12
  13 use Variable::Magic qw/wizard cast dispell getdata/;
  14
  15 =head1 NAME
  16
  17 subs::auto - Read barewords as subroutine names.
  18
  19 =head1 VERSION
  20
  21 Version 0.05
  22
  23 =cut
  24
  25 our $VERSION = '0.05';
  26
  27 =head1 SYNOPSIS
  28
  29     {
  30      use subs::auto;
  31      foo;             # Compile to "foo()"     instead of "'foo'"
  32                       #                        or croaking on strict subs
  33      foo $x;          # Compile to "foo($x)"   instead of "$x->foo"
  34      foo 1;           # Compile to "foo(1)"    instead of croaking
  35      foo 1, 2;        # Compile to "foo(1, 2)" instead of croaking
  36      foo(@a);         # Still ok
  37      foo->meth;       # "'foo'->meth" if you have use'd foo somewhere,
  38                       #  or "foo()->meth" otherwise
  39      print foo 'wut'; # print to the filehandle foo if it's actually one,
  40                       #  or "print(foo('wut'))" otherwise
  41     } # ... but function calls will fail at run-time if you don't
  42       # actually define foo somewhere
  43
  44     foo; # BANG
  45
  46 =head1 DESCRIPTION
  47
  48 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).
  49
  50 You can pass options to C<import> as key / value pairs :
  51
  52 =over 4
  53
  54 =item *
  55
  56 C<< in => $pkg >>
  57
  58 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.
  59
  60 =back
  61
  62 This module is B<not> a source filter.
  63
  64 =cut
  65
  66 BEGIN {
  67  croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
  68 }
  69
  70 my %core;
  71 @core{
  72  @B::Keywords::Barewords,
  73  @B::Keywords::Functions,
  74  'DATA',
  75 } = ();
  76 delete @core{qw/my local/};
  77
  78 BEGIN {
  79  *_REFCNT_PLACEHOLDERS = eval 'sub () { ' . ($] < 5.011002 ? 0 : 1) . '}'
  80 }
  81
  82 my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) };
  83
  84 sub _reset {
  85  my ($pkg, $func) = @_;
  86  my $fqn = join '::', @_;
  87  my $cb = do {
  88   no strict 'refs';
  89   no warnings 'once';
  90   *$fqn{CODE};
  91  };
  92  if ($cb and defined(my $data = getdata(&$cb, $tag))) {
  93   $$data--;
  94   return if $$data > 0;
  95   no strict 'refs';
  96   my $sym = gensym;
  97   for (qw/SCALAR ARRAY HASH IO FORMAT/) {
  98    no warnings 'once';
  99    *$sym = *$fqn{$_} if defined *$fqn{$_}
 100   }
 101   undef *$fqn;
 102   *$fqn = *$sym;
 103  }
 104 }
 105
 106 sub _fetch {
 107  (undef, my $data, my $func) = @_;
 108  return if $data->{guard} or $func =~ /::/ or exists $core{$func};
 109  local $data->{guard} = 1;
 110  my $hints = (caller 0)[10];
 111  if ($hints and $hints->{subs__auto}) {
 112   my $mod = $func . '.pm';
 113   if (not exists $INC{$mod}) {
 114    my $fqn = $data->{pkg} . '::' . $func;
 115    my $cb = do { no strict 'refs'; *$fqn{CODE} };
 116    if ($cb) {
 117     if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
 118      ++$$data;
 119     }
 120     return;
 121    }
 122    return if do { no strict 'refs'; *$fqn{IO} };
 123    $cb = sub {
 124     my ($file, $line) = (caller 0)[1, 2];
 125     ($file, $line) = ('(eval 0)', 0) unless $file && $line;
 126     die "Undefined subroutine &$fqn called at $file line $line\n";
 127    };
 128    cast &$cb, $tag;
 129    no strict 'refs';
 130    *$fqn = $cb;
 131   }
 132  } else {
 133   _reset($data->{pkg}, $func);
 134  }
 135  return;
 136 }
 137
 138 sub _store {
 139  (undef, my $data, my $func) = @_;
 140  return if $data->{guard};
 141  local $data->{guard} = 1;
 142  _reset($data->{pkg}, $func);
 143  return;
 144 }
 145
 146 my $wiz = wizard data  => sub { +{ pkg => $_[1], guard => 0 } },
 147                  fetch => \&_fetch,
 148                  store => \&_store;
 149
 150 my %pkgs;
 151
 152 sub _validate_pkg {
 153  my ($pkg, $cur) = @_;
 154  return $cur unless $pkg;
 155  croak 'Invalid package name' if ref $pkg
 156                               or $pkg =~ /(?:-|[^\w:])/
 157                               or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
 158  $pkg =~ s/::$//;
 159  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
 160  $pkg;
 161 }
 162
 163 sub import {
 164  shift;
 165  croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
 166  my %args = @_;
 167  my $cur  = (caller 1)[0];
 168  my $in   = _validate_pkg $args{in}, $cur;
 169  $^H{subs__auto} = 1;
 170  ++$pkgs{$in};
 171  no strict 'refs';
 172  cast %{$in . '::'}, $wiz, $in;
 173 }
 174
 175 sub unimport {
 176  $^H{subs__auto} = 0;
 177 }
 178
 179 {
 180  no warnings 'void';
 181  CHECK {
 182   no strict 'refs';
 183   dispell %{$_ . '::'}, $wiz for keys %pkgs;
 184  }
 185 }
 186
 187 =head1 EXPORT
 188
 189 None.
 190
 191 =head1 CAVEATS
 192
 193 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 ?).
 194
 195 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.
 196
 197 =head1 DEPENDENCIES
 198
 199 L<perl> 5.10.0.
 200
 201 L<Carp> (standard since perl 5), L<Symbol> (since 5.002).
 202
 203 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 204
 205 L<B::Keywords>.
 206
 207 =head1 AUTHOR
 208
 209 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 210
 211 You can contact me by mail or on C<irc.perl.org> (vincent).
 212
 213 =head1 BUGS
 214
 215 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.
 216
 217 =head1 SUPPORT
 218
 219 You can find documentation for this module with the perldoc command.
 220
 221     perldoc subs::auto
 222
 223 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
 224
 225 =head1 ACKNOWLEDGEMENTS
 226
 227 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
 228
 229 =head1 COPYRIGHT & LICENSE
 230
 231 Copyright 2008 Vincent Pit, all rights reserved.
 232
 233 This program is free software; you can redistribute it and/or modify it
 234 under the same terms as Perl itself.
 235
 236 =cut
 237
 238 1; # End of subs::auto