lib/indirect.pm

   1 package indirect;
   2
   3 use 5.008001;
   4
   5 use strict;
   6 use warnings;
   7
   8 =head1 NAME
   9
  10 indirect - Lexically warn about using the indirect method call syntax.
  11
  12 =head1 VERSION
  13
  14 Version 0.26
  15
  16 =cut
  17
  18 our $VERSION;
  19 BEGIN {
  20  $VERSION = '0.26';
  21 }
  22
  23 =head1 SYNOPSIS
  24
  25 In a script :
  26
  27     no indirect;               # lexically enables the pragma
  28     my $x = new Apple 1, 2, 3; # warns
  29     {
  30      use indirect;     # lexically disables the pragma
  31      my $y = new Pear; # legit, does not warn
  32      {
  33       # lexically specify an hook called for each indirect construct
  34       no indirect hook => sub {
  35        die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]"
  36       };
  37       my $z = new Pineapple 'fresh'; # croaks 'You really wanted...'
  38      }
  39     }
  40     try { ... }; # warns if try() hasn't been declared in this package
  41
  42     no indirect 'fatal';     # or ':fatal', 'FATAL', ':Fatal' ...
  43     if (defied $foo) { ... } # croaks, note the typo
  44
  45 Global uses :
  46
  47     # Globally enable the pragma from the command-line
  48     perl -M-indirect=global -e 'my $x = new Banana;' # warns
  49
  50     # Globally enforce the pragma each time perl is executed
  51     export PERL5OPT="-M-indirect=global,fatal"
  52     perl -e 'my $y = new Coconut;' # croaks
  53
  54 =head1 DESCRIPTION
  55
  56 When enabled, this pragma warns about indirect method calls that are present in your code.
  57
  58 The indirect syntax is now considered harmful, since its parsing has many quirks and its use is error prone : when the subroutine C<foo> has not been declared in the current package, C<foo $x> actually compiles to C<< $x->foo >>, and C<< foo { key => 1 } >> to C<< 'key'->foo(1) >>.
  59 In L<http://www.shadowcat.co.uk/blog/matt-s-trout/indirect-but-still-fatal>, Matt S. Trout gives an example of an undesirable indirect method call on a block that can cause a particularly bewildering error.
  60
  61 This pragma currently does not warn for core functions (C<print>, C<say>, C<exec> or C<system>).
  62 This may change in the future, or may be added as optional features that would be enabled by passing options to C<unimport>.
  63
  64 This module is B<not> a source filter.
  65
  66 =cut
  67
  68 BEGIN {
  69  if ($ENV{PERL_INDIRECT_PM_DISABLE}) {
  70   *_tag = sub ($) { 1 };
  71   *I_THREADSAFE = sub () { 1 };
  72   *I_FORKSAFE   = sub () { 1 };
  73  } else {
  74   require XSLoader;
  75   XSLoader::load(__PACKAGE__, $VERSION);
  76  }
  77 }
  78
  79 =head1 METHODS
  80
  81 =head2 C<< unimport [ 'global', hook => $hook | 'fatal' ] >>
  82
  83 Magically called when C<no indirect @opts> is encountered.
  84 Turns the module on.
  85 The policy to apply depends on what is first found in C<@opts> :
  86
  87 =over 4
  88
  89 =item *
  90
  91 If it is a string that matches C</^:?fatal$/i>, the compilation will croak when the first indirect method call is found.
  92
  93 This option is mutually exclusive with the C<'hook'> option.
  94
  95 =item *
  96
  97 If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with a string representation of the object as C<$_[0]>, the method name as C<$_[1]>, the current file as C<$_[2]> and the line number as C<$_[3]>.
  98 If and only if the object is actually a block, C<$_[0]> is assured to start by C<'{'>.
  99
 100 This option is mutually exclusive with the C<'fatal'> option.
 101
 102 =item *
 103
 104 If none of C<fatal> and C<hook> are specified, a warning will be emitted for each indirect method call.
 105
 106 =item *
 107
 108 If C<@opts> contains a string that matches C</^:?global$/i>, the pragma will be globally enabled for B<all> code compiled after the current C<no indirect> statement, except for code that is in the lexical scope of C<use indirect>.
 109 This option may come indifferently before or after the C<fatal> or C<hook> options, in the case they are also passed to L</unimport>.
 110
 111 The global policy applied is the one resulting of the C<fatal> or C<hook> options, thus defaults to a warning when none of those are specified :
 112
 113     no indirect 'global';                # warn for any indirect call
 114     no indirect qw<global fatal>;        # die on any indirect call
 115     no indirect 'global', hook => \&hook # custom global action
 116
 117 Note that if another policy is installed by a C<no indirect> statement further in the code, it will overrule the global policy :
 118
 119     no indirect 'global';  # warn globally
 120     {
 121      no indirect 'fatal';  # throw exceptions for this lexical scope
 122      ...
 123      require Some::Module; # the global policy will apply for the
 124                            # compilation phase of this module
 125     }
 126
 127 =back
 128
 129 =cut
 130
 131 sub _no_hook_and_fatal {
 132  require Carp;
 133  Carp::croak("The 'fatal' and 'hook' options are mutually exclusive");
 134 }
 135
 136 sub unimport {
 137  shift;
 138
 139  my ($global, $fatal, $hook);
 140
 141  while (@_) {
 142   my $arg = shift;
 143   if ($arg eq 'hook') {
 144    _no_hook_and_fatal() if $fatal;
 145    $hook = shift;
 146   } elsif ($arg =~ /^:?fatal$/i) {
 147    _no_hook_and_fatal() if defined $hook;
 148    $fatal = 1;
 149   } elsif ($arg =~ /^:?global$/i) {
 150    $global = 1;
 151   }
 152  }
 153
 154  unless (defined $hook) {
 155   $hook = $fatal ? sub { die msg(@_) } : sub { warn msg(@_) };
 156  }
 157
 158  $^H |= 0x00020000;
 159  if ($global) {
 160   delete $^H{+(__PACKAGE__)};
 161   _global($hook);
 162  } else {
 163   $^H{+(__PACKAGE__)} = _tag($hook);
 164  }
 165
 166  return;
 167 }
 168
 169 =head2 C<import>
 170
 171 Magically called at each C<use indirect>. Turns the module off.
 172
 173 As explained in L</unimport>'s description, an C<use indirect> statement will lexically override a global policy previously installed by C<no indirect 'global', ...> (if there's one).
 174
 175 =cut
 176
 177 sub import {
 178  $^H |= 0x00020000;
 179  $^H{+(__PACKAGE__)} = _tag(undef);
 180
 181  return;
 182 }
 183
 184 =head1 FUNCTIONS
 185
 186 =head2 C<msg $object, $method, $file, $line>
 187
 188 Returns the default error message that C<indirect> generates when an indirect method call is reported.
 189
 190 =cut
 191
 192 sub msg {
 193  my $obj = $_[0];
 194
 195  join ' ', "Indirect call of method \"$_[1]\" on",
 196            ($obj =~ /^\s*\{/ ? "a block" : "object \"$obj\""),
 197            "at $_[2] line $_[3].\n";
 198 };
 199
 200 =head1 CONSTANTS
 201
 202 =head2 C<I_THREADSAFE>
 203
 204 True iff the module could have been built with thread-safety features enabled.
 205
 206 =head2 C<I_FORKSAFE>
 207
 208 True iff this module could have been built with fork-safety features enabled.
 209 This will always be true except on Windows where it's false for perl 5.10.0 and below .
 210
 211 =head1 DIAGNOSTICS
 212
 213 =head2 C<Indirect call of method "%s" on object "%s" at %s line %d.>
 214
 215 The default warning/exception message thrown when an indirect method call on an object is found.
 216
 217 =head2 C<Indirect call of method "%s" on a block at %s line %d.>
 218
 219 The default warning/exception message thrown when an indirect method call on a block is found.
 220
 221 =head1 ENVIRONMENT
 222
 223 =head2 C<PERL_INDIRECT_PM_DISABLE>
 224
 225 If this environment variable is set to true when the pragma is used for the first time, the XS code won't be loaded and, although the C<'indirect'> lexical hint will be set to true in the scope of use, the pragma itself won't do anything.
 226 In this case, the pragma will always be considered to be thread-safe, and as such L</I_THREADSAFE> will be true.
 227 This is useful for disabling C<indirect> in production environments.
 228
 229 Note that clearing this variable after C<indirect> was loaded has no effect.
 230 If you want to re-enable the pragma later, you also need to reload it by deleting the C<'indirect.pm'> entry from C<%INC>.
 231
 232 =head1 CAVEATS
 233
 234 The implementation was tweaked to work around several limitations of vanilla C<perl> pragmas : it's thread safe, and does not suffer from a C<perl 5.8.x-5.10.0> bug that causes all pragmas to propagate into C<require>d scopes.
 235
 236 Before C<perl> 5.12, C<meth $obj> (no semicolon) at the end of a file is not seen as an indirect method call, although it is as soon as there is another token before the end (as in C<meth $obj;> or C<meth $obj 1>).
 237 If you use C<perl> 5.12 or greater, those constructs are correctly reported.
 238
 239 With 5.8 perls, the pragma does not propagate into C<eval STRING>.
 240 This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10.
 241
 242 The search for indirect method calls happens before constant folding.
 243 Hence C<my $x = new Class if 0> will be caught.
 244
 245 =head1 DEPENDENCIES
 246
 247 L<perl> 5.8.1.
 248
 249 A C compiler.
 250 This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
 251
 252 L<Carp> (standard since perl 5), L<XSLoader> (since perl 5.006).
 253
 254 =head1 AUTHOR
 255
 256 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 257
 258 You can contact me by mail or on C<irc.perl.org> (vincent).
 259
 260 =head1 BUGS
 261
 262 Please report any bugs or feature requests to C<bug-indirect at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=indirect>.
 263 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 264
 265 =head1 SUPPORT
 266
 267 You can find documentation for this module with the perldoc command.
 268
 269     perldoc indirect
 270
 271 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/indirect>.
 272
 273 =head1 ACKNOWLEDGEMENTS
 274
 275 Bram, for motivation and advices.
 276
 277 Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues.
 278
 279 =head1 COPYRIGHT & LICENSE
 280
 281 Copyright 2008,2009,2010,2011 Vincent Pit, all rights reserved.
 282
 283 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 284
 285 =cut
 286
 287 1; # End of indirect