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