lib/subs/auto.pm

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