lib/indirect.pm

   1 package indirect;
   2
   3 use 5.008;
   4
   5 use strict;
   6 use warnings;
   7
   8 =head1 NAME
   9
  10 indirect - Lexically warn about using the indirect object syntax.
  11
  12 =head1 VERSION
  13
  14 Version 0.19
  15
  16 =cut
  17
  18 our $VERSION;
  19 BEGIN {
  20  $VERSION = '0.19';
  21 }
  22
  23 =head1 SYNOPSIS
  24
  25     # In a script
  26     no indirect;
  27     my $x = new Apple 1, 2, 3; # warns
  28     {
  29      use indirect;
  30      my $y = new Pear; # ok
  31      {
  32       no indirect hook => sub { die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]" };
  33       my $z = new Pineapple 'fresh'; # croaks 'You really wanted Pineapple->new at blurp.pm:13'
  34      }
  35     }
  36     try { ... }; # warns
  37
  38     no indirect ':fatal';
  39     if (defied $foo) { ... } # croaks, note the typo
  40
  41     # From the command-line
  42     perl -M-indirect -e 'my $x = new Banana;' # warns
  43
  44     # Or each time perl is ran
  45     export PERL5OPT="-M-indirect"
  46     perl -e 'my $y = new Coconut;' # warns
  47
  48 =head1 DESCRIPTION
  49
  50 When enabled (or disabled as some may prefer to say, since you actually turn it on by calling C<no indirect>), this pragma warns about indirect object syntax constructs that may have slipped into your code.
  51 This syntax is now considered harmful, since its parsing has many quirks and its use is error prone (when C<swoosh> isn't defined, C<swoosh $x> actually compiles to C<< $x->swoosh >>).
  52
  53 It currently does not warn for core functions (C<print>, C<say>, C<exec> or C<system>).
  54 This may change in the future, or may be added as optional features that would be enabled by passing options to C<unimport>.
  55
  56 This module is B<not> a source filter.
  57
  58 =cut
  59
  60 BEGIN {
  61  if ($ENV{PERL_INDIRECT_PM_DISABLE}) {
  62   *_tag = sub ($) { 1 };
  63   *I_THREADSAFE = sub () { 1 };
  64   *I_FORKSAFE   = sub () { 1 };
  65  } else {
  66   require XSLoader;
  67   XSLoader::load(__PACKAGE__, $VERSION);
  68  }
  69 }
  70
  71 =head1 METHODS
  72
  73 =head2 C<< unimport [ hook => $hook | ':fatal' ] >>
  74
  75 Magically called when C<no indirect @opts> is encountered.
  76 Turns the module on.
  77 The policy to apply depends on what is first found in C<@opts> :
  78
  79 =over 4
  80
  81 =item *
  82
  83 If it's the string C<':fatal'>, the compilation will croak on the first indirect syntax met.
  84
  85 =item *
  86
  87 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]>.
  88 If and only if the object is actually a block, C<$_[0]> is assured to start by C<'{'>.
  89
  90 =item *
  91
  92 Otherwise, a warning will be emitted for each indirect construct.
  93
  94 =back
  95
  96 =cut
  97
  98 sub unimport {
  99  shift;
 100
 101  my $hook;
 102  while (@_) {
 103   my $arg = shift;
 104   if ($arg eq 'hook') {
 105    $hook = shift;
 106   } elsif ($arg eq ':fatal') {
 107    $hook = sub { die msg(@_) };
 108   }
 109   last if $hook;
 110  }
 111  $hook = sub { warn msg(@_) } unless defined $hook;
 112
 113  $^H |= 0x00020000;
 114  $^H{+(__PACKAGE__)} = _tag($hook);
 115
 116  ();
 117 }
 118
 119 =head2 C<import>
 120
 121 Magically called at each C<use indirect>. Turns the module off.
 122
 123 =cut
 124
 125 sub import {
 126  $^H{+(__PACKAGE__)} = undef;
 127  ();
 128 }
 129
 130 =head1 FUNCTIONS
 131
 132 =head2 C<msg $object, $method, $file, $line>
 133
 134 Returns the default error message generated by C<indirect> when an invalid construct is reported.
 135
 136 =cut
 137
 138 sub msg {
 139  my $obj = $_[0];
 140
 141  join ' ', "Indirect call of method \"$_[1]\" on",
 142            ($obj =~ /^\s*\{/ ? "a block" : "object \"$obj\""),
 143            "at $_[2] line $_[3].\n";
 144 };
 145
 146 =head1 CONSTANTS
 147
 148 =head2 C<I_THREADSAFE>
 149
 150 True iff the module could have been built with thread-safety features enabled.
 151
 152 =head2 C<I_FORKSAFE>
 153
 154 True iff this module could have been built with fork-safety features enabled.
 155 This will always be true except on Windows where it's false for perl 5.10.0 and below .
 156
 157 =head1 DIAGNOSTICS
 158
 159 =head2 C<Indirect call of method "%s" on object "%s" at %s line %d.>
 160
 161 The default warning/exception message thrown when an indirect call on an object is found.
 162
 163 =head2 C<Indirect call of method "%s" on a block at %s line %d.>
 164
 165 The default warning/exception message thrown when an indirect call on a block is found.
 166
 167 =head1 ENVIRONMENT
 168
 169 =head2 C<PERL_INDIRECT_PM_DISABLE>
 170
 171 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.
 172 In this case, the pragma will always be considered to be thread-safe, and as such L</I_THREADSAFE> will be true.
 173 This is useful for disabling C<indirect> in production environments.
 174
 175 Note that clearing this variable after C<indirect> was loaded has no effect.
 176 If you want to reenable the pragma later, you also need to reload it by deleting the C<'indirect.pm'> entry from C<%INC>.
 177
 178 =head1 CAVEATS
 179
 180 The implementation was tweaked to work around several limitations of vanilla C<perl> pragmas : it's thread safe, and doesn't suffer from a C<perl 5.8.x-5.10.0> bug that causes all pragmas to propagate into C<require>d scopes.
 181
 182 C<meth $obj> (no semicolon) at the end of a file won't be seen as an indirect object syntax, although it will as soon as there is another token before the end (as in C<meth $obj;> or C<meth $obj 1>).
 183
 184 With 5.8 perls, the pragma does not propagate into C<eval STRING>.
 185 This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10.
 186
 187 The search for indirect method calls happens before constant folding.
 188 Hence C<my $x = new Class if 0> will be caught.
 189
 190 =head1 DEPENDENCIES
 191
 192 L<perl> 5.8.
 193
 194 L<XSLoader> (standard since perl 5.006).
 195
 196 =head1 AUTHOR
 197
 198 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 199
 200 You can contact me by mail or on C<irc.perl.org> (vincent).
 201
 202 =head1 BUGS
 203
 204 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>.
 205 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 206
 207 =head1 SUPPORT
 208
 209 You can find documentation for this module with the perldoc command.
 210
 211     perldoc indirect
 212
 213 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/indirect>.
 214
 215 =head1 ACKNOWLEDGEMENTS
 216
 217 Bram, for motivation and advices.
 218
 219 Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues.
 220
 221 =head1 COPYRIGHT & LICENSE
 222
 223 Copyright 2008-2009 Vincent Pit, all rights reserved.
 224
 225 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 226
 227 =cut
 228
 229 1; # End of indirect