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.06
  15
  16 =cut
  17
  18 our $VERSION;
  19 BEGIN {
  20  $VERSION = '0.06';
  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.
  55 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.
  56 You can use the pragma several times with different package names to allow resolution of all the corresponding barewords.
  57
  58 Defaults to the current package.
  59
  60 =back
  61
  62 This module is B<not> a source filter.
  63
  64 =cut
  65
  66 use B;
  67
  68 use B::Keywords;
  69
  70 use Variable::Magic 0.31 qw/wizard cast dispell getdata/;
  71
  72 BEGIN {
  73  unless (Variable::Magic::VMG_UVAR) {
  74   require Carp;
  75   Carp::croak('uvar magic not available');
  76  }
  77  require XSLoader;
  78  XSLoader::load(__PACKAGE__, $VERSION);
  79 }
  80
  81 my %core;
  82 @core{
  83  @B::Keywords::Barewords,
  84  @B::Keywords::Functions,
  85  'DATA',
  86 } = ();
  87 delete @core{qw/my local/};
  88
  89 BEGIN {
  90  *_REFCNT_PLACEHOLDERS = eval 'sub () { ' . ($] < 5.011002 ? 0 : 1) . '}'
  91 }
  92
  93 my $tag = wizard data => sub { \(my $data = _REFCNT_PLACEHOLDERS ? 2 : 1) };
  94
  95 sub _reset {
  96  my $fqn = join '::', @_;
  97
  98  my $cb = do {
  99   no strict 'refs';
 100   no warnings 'once';
 101   *$fqn{CODE};
 102  };
 103
 104  if ($cb and defined(my $data = getdata(&$cb, $tag))) {
 105   $$data--;
 106   return if $$data > 0;
 107
 108   _delete_sub($fqn);
 109  }
 110 }
 111
 112 sub _fetch {
 113  (undef, my $data, my $name) = @_;
 114
 115  return if $data->{guard};
 116  local $data->{guard} = 1;
 117
 118  return if $name =~ /::/
 119         or exists $core{$name};
 120
 121  my $op_name = $_[-1] || '';
 122  return if $op_name =~ /method/;
 123
 124  my $pkg = $data->{pkg};
 125
 126  my $hints = (caller 0)[10];
 127  if ($hints and $hints->{+(__PACKAGE__)}) {
 128   my $pm = $name . '.pm';
 129   return if exists $INC{$pm};
 130
 131   my $fqn = $pkg . '::' . $name;
 132   my $cb  = do { no strict 'refs'; *$fqn{CODE} };
 133   if ($cb) {
 134    if (_REFCNT_PLACEHOLDERS and defined(my $data = getdata(&$cb, $tag))) {
 135     ++$$data;
 136    }
 137    return;
 138   }
 139   return if do { no strict 'refs'; *$fqn{IO} };
 140
 141   $cb = sub {
 142    my ($file, $line) = (caller 0)[1, 2];
 143    ($file, $line) = ('(eval 0)', 0) unless $file && $line;
 144    die "Undefined subroutine &$fqn called at $file line $line\n";
 145   };
 146   cast &$cb, $tag;
 147
 148   no strict 'refs';
 149   *$fqn = $cb;
 150  } else {
 151   _reset($pkg, $name);
 152  }
 153
 154  return;
 155 }
 156
 157 sub _store {
 158  (undef, my $data, my $name) = @_;
 159
 160  return if $data->{guard};
 161  local $data->{guard} = 1;
 162
 163  _reset($data->{pkg}, $name);
 164
 165  return;
 166 }
 167
 168 my $wiz = wizard data    => sub { +{ pkg => $_[1], guard => 0 } },
 169                  fetch   => \&_fetch,
 170                  store   => \&_store,
 171                  op_info => Variable::Magic::VMG_OP_INFO_NAME;
 172
 173 my %pkgs;
 174
 175 my $pkg_rx = qr/
 176  ^(?:
 177      ::
 178     |
 179      (?:::)?
 180      [A-Za-z_][A-Za-z0-9_]*
 181      (?:::[A-Za-z_][A-Za-z0-9_]*)*
 182      (?:::)?
 183   )$
 184 /x;
 185
 186 sub _validate_pkg {
 187  my ($pkg, $cur) = @_;
 188
 189  return $cur unless defined $pkg;
 190
 191  if (ref $pkg or $pkg !~ $pkg_rx) {
 192   require Carp;
 193   Carp::croak('Invalid package name');
 194  }
 195
 196  $pkg =~ s/::$//;
 197  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
 198  $pkg;
 199 }
 200
 201 sub import {
 202  shift;
 203  if (@_ % 2) {
 204   require Carp;
 205   Carp::croak('Optional arguments must be passed as keys/values pairs');
 206  }
 207  my %args = @_;
 208
 209  my $cur = caller;
 210  my $in  = _validate_pkg $args{in}, $cur;
 211  ++$pkgs{$in};
 212  {
 213   no strict 'refs';
 214   cast %{$in . '::'}, $wiz, $in;
 215  }
 216
 217  $^H{+(__PACKAGE__)} = 1;
 218  $^H |= 0x020000;
 219
 220  return;
 221 }
 222
 223 sub unimport {
 224  $^H{+(__PACKAGE__)} = 0;
 225 }
 226
 227 {
 228  no warnings 'void';
 229  CHECK {
 230   no strict 'refs';
 231   dispell %{$_ . '::'}, $wiz for keys %pkgs;
 232  }
 233 }
 234
 235 =head1 EXPORT
 236
 237 None.
 238
 239 =head1 CAVEATS
 240
 241 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.
 242 This may or may not be considered as Doing The Right Thing.
 243 However, C<*{'::foo'}{CODE}> will always return the right value if you fetch it outside the pragma's scope.
 244 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 ?).
 245
 246 You have to open global filehandles outside of the scope of this pragma if you want them not to be treated as function calls.
 247 Or just use lexical filehandles and default ones as you should be.
 248
 249 This pragma doesn't propagate into C<eval STRING>.
 250
 251 =head1 DEPENDENCIES
 252
 253 L<perl> 5.10.0.
 254
 255 L<Variable::Magic> with C<uvar> magic enabled (this should be assured by the required perl version).
 256
 257 L<B::Keywords>.
 258
 259 L<Carp> (standard since perl 5), L<XSLoader> (since 5.006).
 260
 261 =head1 AUTHOR
 262
 263 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 264
 265 You can contact me by mail or on C<irc.perl.org> (vincent).
 266
 267 =head1 BUGS
 268
 269 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>.
 270 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 271
 272 =head1 SUPPORT
 273
 274 You can find documentation for this module with the perldoc command.
 275
 276     perldoc subs::auto
 277
 278 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/subs-auto>.
 279
 280 =head1 ACKNOWLEDGEMENTS
 281
 282 Thanks to Sebastien Aperghis-Tramoni for helping to name this pragma.
 283
 284 =head1 COPYRIGHT & LICENSE
 285
 286 Copyright 2008,2009,2010,2011 Vincent Pit, all rights reserved.
 287
 288 This program is free software; you can redistribute it and/or modify it
 289 under the same terms as Perl itself.
 290
 291 =cut
 292
 293 1; # End of subs::auto