]> git.vpit.fr Git - perl/modules/subs-auto.git/blob - lib/subs/auto.pm
Ignore MYMETA.yml
[perl/modules/subs-auto.git] / 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