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 $pkg = $data->{pkg};
 115
 116  my $hints = (caller 0)[10];
 117  if ($hints and $hints->{+(__PACKAGE__)}) {
 118   my $pm = $func . '.pm';
 119   return if exists $INC{$pm};
 120
 121   my $fqn = $pkg . '::' . $func;
 122   my $cb = do { no strict 'refs'; *$fqn{CODE} };
 123   if ($cb) {
 124    if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
 125     ++$$data;
 126    }
 127    return;
 128   }
 129   return if do { no strict 'refs'; *$fqn{IO} };
 130
 131   $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
 138   no strict 'refs';
 139   *$fqn = $cb;
 140  } else {
 141   _reset($pkg, $func);
 142  }
 143
 144  return;
 145 }
 146
 147 sub _store {
 148  (undef, my $data, my $func) = @_;
 149
 150  return if $data->{guard};
 151  local $data->{guard} = 1;
 152
 153  _reset($data->{pkg}, $func);
 154
 155  return;
 156 }
 157
 158 my $wiz = wizard data  => sub { +{ pkg => $_[1], guard => 0 } },
 159                  fetch => \&_fetch,
 160                  store => \&_store;
 161
 162 my %pkgs;
 163
 164 my $pkg_rx = qr/
 165  ^(?:
 166      ::
 167     |
 168      (?:::)?
 169      [A-Za-z_][A-Za-z0-9_]*
 170      (?:::[A-Za-z_][A-Za-z0-9_]*)*
 171      (?:::)?
 172   )$
 173 /x;
 174
 175 sub _validate_pkg {
 176  my ($pkg, $cur) = @_;
 177
 178  return $cur unless defined $pkg;
 179
 180  if (ref $pkg or $pkg !~ $pkg_rx) {
 181   require Carp;
 182   Carp::croak('Invalid package name');
 183  }
 184
 185  $pkg =~ s/::$//;
 186  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
 187  $pkg;
 188 }
 189
 190 sub import {
 191  shift;
 192  if (@_ % 2) {
 193   require Carp;
 194   Carp::croak('Optional arguments must be passed as keys/values pairs');
 195  }
 196  my %args = @_;
 197
 198  my $cur = (caller 1)[0];
 199  my $in  = _validate_pkg $args{in}, $cur;
 200  ++$pkgs{$in};
 201  {
 202   no strict 'refs';
 203   cast %{$in . '::'}, $wiz, $in;
 204  }
 205
 206  $^H{+(__PACKAGE__)} = 1;
 207  $^H |= 0x020000;
 208
 209  return;
 210 }
 211
 212 sub unimport {
 213  $^H{+(__PACKAGE__)} = 0;
 214 }
 215
 216 {
 217  no warnings 'void';
 218  CHECK {
 219   no strict 'refs';
 220   dispell %{$_ . '::'}, $wiz for keys %pkgs;
 221  }
 222 }
 223
 224 =head1 EXPORT
 225
 226 None.
 227
 228 =head1 CAVEATS
 229
 230 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 ?).
 231
 232 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.
 233
 234 This pragma doesn't propagate into C<eval STRING>.
 235
 236 =head1 DEPENDENCIES
 237
 238 L<perl> 5.10.0.
 239
 240 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 241
 242 L<B::Keywords>.
 243
 244 L<Carp> (standard since perl 5), L<XSLoader> (since 5.006).
 245
 246 =head1 AUTHOR
 247
 248 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 249
 250 You can contact me by mail or on C<irc.perl.org> (vincent).
 251
 252 =head1 BUGS
 253
 254 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.
 255
 256 =head1 SUPPORT
 257
 258 You can find documentation for this module with the perldoc command.
 259
 260     perldoc subs::auto
 261
 262 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
 263
 264 =head1 ACKNOWLEDGEMENTS
 265
 266 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
 267
 268 =head1 COPYRIGHT & LICENSE
 269
 270 Copyright 2008,2009,2010 Vincent Pit, all rights reserved.
 271
 272 This program is free software; you can redistribute it and/or modify it
 273 under the same terms as Perl itself.
 274
 275 =cut
 276
 277 1; # End of subs::auto