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