local-lib5/lib/perl5/Hook/LexWrap.pm

   1 package Hook::LexWrap;
   2 use 5.006;
   3 use strict;
   4 use warnings;
   5 our $VERSION = '0.22';
   6 use Carp;
   7
   8 {
   9 no warnings 'redefine';
  10 *CORE::GLOBAL::caller = sub (;$) {
  11         my ($height) = ($_[0]||0);
  12         my $i=1;
  13         my $name_cache;
  14         while (1) {
  15                 my @caller = CORE::caller($i++) or return;
  16                 $caller[3] = $name_cache if $name_cache;
  17                 $name_cache = $caller[0] eq 'Hook::LexWrap' ? $caller[3] : '';
  18                 next if $name_cache || $height-- != 0;
  19                 return wantarray ? @_ ? @caller : @caller[0..2] : $caller[0];
  20         }
  21 };
  22 }
  23
  24 sub import { no strict 'refs'; *{caller()."::wrap"} = \&wrap }
  25
  26 sub wrap (*@) {  ## no critic Prototypes
  27         my ($typeglob, %wrapper) = @_;
  28         $typeglob = (ref $typeglob || $typeglob =~ /::/)
  29                 ? $typeglob
  30                 : caller()."::$typeglob";
  31         my $original;
  32         {
  33                 no strict 'refs';
  34                 $original = ref $typeglob eq 'CODE' && $typeglob
  35                      || *$typeglob{CODE}
  36                      || croak "Can't wrap non-existent subroutine ", $typeglob;
  37         }
  38         croak "'$_' value is not a subroutine reference"
  39                 foreach grep {$wrapper{$_} && ref $wrapper{$_} ne 'CODE'}
  40                         qw(pre post);
  41         no warnings 'redefine';
  42         my ($caller, $unwrap) = *CORE::GLOBAL::caller{CODE};
  43         my $imposter = sub {
  44                 if ($unwrap) { goto &$original }
  45                 my ($return, $prereturn);
  46                 if (wantarray) {
  47                         $prereturn = $return = [];
  48                         () = $wrapper{pre}->(@_,$return) if $wrapper{pre};
  49                         if (ref $return eq 'ARRAY' && $return == $prereturn && !@$return) {
  50                                 $return = [ &$original ];
  51                                 () = $wrapper{post}->(@_, $return)
  52                                         if $wrapper{post};
  53                         }
  54                         return ref $return eq 'ARRAY' ? @$return : ($return);
  55                 }
  56                 elsif (defined wantarray) {
  57                         $return = bless sub {$prereturn=1}, 'Hook::LexWrap::Cleanup';
  58                         my $dummy = $wrapper{pre}->(@_, $return) if $wrapper{pre};
  59                         unless ($prereturn) {
  60                                 $return = &$original;
  61                                 $dummy = scalar $wrapper{post}->(@_, $return)
  62                                         if $wrapper{post};
  63                         }
  64                         return $return;
  65                 }
  66                 else {
  67                         $return = bless sub {$prereturn=1}, 'Hook::LexWrap::Cleanup';
  68                         $wrapper{pre}->(@_, $return) if $wrapper{pre};
  69                         unless ($prereturn) {
  70                                 &$original;
  71                                 $wrapper{post}->(@_, $return)
  72                                         if $wrapper{post};
  73                         }
  74                         return;
  75                 }
  76         };
  77         ref $typeglob eq 'CODE' and return defined wantarray
  78                 ? $imposter
  79                 : carp "Uselessly wrapped subroutine reference in void context";
  80         {
  81                 no strict 'refs';
  82                 *{$typeglob} = $imposter;
  83         }
  84         return unless defined wantarray;
  85         return bless sub{ $unwrap=1 }, 'Hook::LexWrap::Cleanup';
  86 }
  87
  88 package Hook::LexWrap::Cleanup;
  89
  90 sub DESTROY { $_[0]->() }
  91 use overload
  92         q{""}   => sub { undef },
  93         q{0+}   => sub { undef },
  94         q{bool} => sub { undef };
  95
  96 1;
  97
  98 __END__
  99
 100
 101 =head1 NAME
 102
 103 Hook::LexWrap - Lexically scoped subroutine wrappers
 104
 105 =head1 VERSION
 106
 107 This document describes version 0.21 of Hook::LexWrap,
 108 released November  6, 2008.
 109
 110 =head1 SYNOPSIS
 111
 112         use Hook::LexWrap;
 113
 114         sub doit { print "[doit:", caller, "]"; return {my=>"data"} }
 115
 116         SCOPED: {
 117                 wrap doit,
 118                         pre  => sub { print "[pre1: @_]\n" },
 119                         post => sub { print "[post1:@_]\n"; $_[1]=9; };
 120
 121                 my $temporarily = wrap doit,
 122                         post => sub { print "[post2:@_]\n" },
 123                         pre  => sub { print "[pre2: @_]\n  "};
 124
 125                 @args = (1,2,3);
 126                 doit(@args);    # pre2->pre1->doit->post1->post2
 127         }
 128
 129         @args = (4,5,6);
 130         doit(@args);            # pre1->doit->post1
 131
 132
 133 =head1 DESCRIPTION
 134
 135 Hook::LexWrap allows you to install a pre- or post-wrapper (or both)
 136 around an existing subroutine. Unlike other modules that provide this
 137 capacity (e.g. Hook::PreAndPost and Hook::WrapSub), Hook::LexWrap
 138 implements wrappers in such a way that the standard C<caller> function
 139 works correctly within the wrapped subroutine.
 140
 141 To install a prewrappers, you write:
 142
 143         use Hook::LexWrap;
 144
 145         wrap 'subroutine_name', pre => \&some_other_sub;
 146
 147    #or: wrap *subroutine_name,  pre => \&some_other_sub;
 148
 149 The first argument to C<wrap> is a string containing the name of the
 150 subroutine to be wrapped (or the typeglob containing it, or a
 151 reference to it). The subroutine name may be qualified, and the
 152 subroutine must already be defined. The second argument indicates the
 153 type of wrapper being applied and must be either C<'pre'> or
 154 C<'post'>. The third argument must be a reference to a subroutine that
 155 implements the wrapper.
 156
 157 To install a post-wrapper, you write:
 158
 159         wrap 'subroutine_name', post => \&yet_another_sub;
 160
 161    #or: wrap *subroutine_name,  post => \&yet_another_sub;
 162
 163 To install both at once:
 164
 165         wrap 'subroutine_name',
 166              pre  => \&some_other_sub,
 167              post => \&yet_another_sub;
 168
 169 or:
 170
 171         wrap *subroutine_name,
 172              post => \&yet_another_sub,  # order in which wrappers are
 173              pre  => \&some_other_sub;   # specified doesn't matter
 174
 175 Once they are installed, the pre- and post-wrappers will be called before
 176 and after the subroutine itself, and will be passed the same argument list.
 177
 178 The pre- and post-wrappers and the original subroutine also all see the same
 179 (correct!) values from C<caller> and C<wantarray>.
 180
 181
 182 =head2 Short-circuiting and long-circuiting return values
 183
 184 The pre- and post-wrappers both receive an extra argument in their @_
 185 arrays. That extra argument is appended to the original argument list
 186 (i.e. is can always be accessed as $_[-1]) and acts as a place-holder for
 187 the original subroutine's return value.
 188
 189 In a pre-wrapper, $_[-1] is -- for obvious reasons -- C<undef>. However,
 190 $_[-1] may be assigned to in a pre-wrapper, in which case Hook::LexWrap
 191 assumes that the original subroutine has been "pre-empted", and that
 192 neither it, nor the corresponding post-wrapper, nor any wrappers that
 193 were applied I<before> the pre-empting pre-wrapper was installed, need
 194 be run. Note that any post-wrappers that were installed after the
 195 pre-empting pre-wrapper was installed I<will> still be called before the
 196 original subroutine call returns.
 197
 198 In a post-wrapper, $_[-1] contains the return value produced by the
 199 wrapped subroutine. In a scalar return context, this value is the scalar
 200 return value. In an list return context, this value is a reference to
 201 the array of return values. $_[-1] may be assigned to in a post-wrapper,
 202 and this changes the return value accordingly.
 203
 204 Access to the arguments and return value is useful for implementing
 205 techniques such as memoization:
 206
 207         my %cache;
 208         wrap fibonacci,
 209                 pre  => sub { $_[-1] = $cache{$_[0]} if $cache{$_[0]} },
 210                 post => sub { $cache{$_[0]} = $_[-1] };
 211
 212
 213 or for converting arguments and return values in a consistent manner:
 214
 215         # set_temp expects and returns degrees Fahrenheit,
 216         # but we want to use Celsius
 217         wrap set_temp,
 218                 pre   => sub { splice @_, 0, 1, $_[0] * 1.8 + 32 },
 219                 post  => sub { $_[-1] = ($_[0] - 32) / 1.8 };
 220
 221
 222 =head2 Lexically scoped wrappers
 223
 224 Normally, any wrappers installed by C<wrap> remain attached to the
 225 subroutine until it is undefined. However, it is possible to make
 226 specific wrappers lexically bound, so that they operate only until
 227 the end of the scope in which they're created (or until some other
 228 specific point in the code).
 229
 230 If C<wrap> is called in a I<non-void> context:
 231
 232         my $lexical = wrap 'sub_name', pre => \&wrapper;
 233
 234 it returns a special object corresponding to the particular wrapper being
 235 placed around the original subroutine. When that object is destroyed
 236 -- when its container variable goes out of scope, or when its
 237 reference count otherwise falls to zero (e.g. C<undef $lexical>), or
 238 when it is explicitly destroyed (C<$lexical-E<gt>DESTROY>) --
 239 the corresponding wrapper is removed from around
 240 the original subroutine. Note, however, that all other wrappers around the
 241 subroutine are preserved.
 242
 243
 244 =head2 Anonymous wrappers
 245
 246 If the subroutine to be wrapped is passed as a reference (rather than by name
 247 or by typeglob), C<wrap> does not install the wrappers around the
 248 original subroutine. Instead it generates a new subroutine which acts
 249 as if it were the original with those wrappers around it.
 250 It then returns a reference to that new subroutine. Only calls to the original
 251 through that wrapped reference invoke the wrappers. Direct by-name calls to
 252 the original, or calls through another reference, do not.
 253
 254 If the original is subsequently wrapped by name, the anonymously wrapped
 255 subroutine reference does not see those wrappers. In other words,
 256 wrappers installed via a subroutine reference are completely independent
 257 of those installed via the subroutine's name (or typeglob).
 258
 259 For example:
 260
 261         sub original { print "ray" }
 262
 263         # Wrap anonymously...
 264         my $anon_wrapped = wrap \&original, pre => sub { print "do..." };
 265
 266         # Show effects...
 267         original();             # prints "ray"
 268         $anon_wrapped->();      # prints "do..ray"
 269
 270         # Wrap nonymously...
 271         wrap *original,
 272                 pre  => sub { print "fa.." },
 273                 post => sub { print "..mi" };
 274
 275         # Show effects...
 276         original();             #   now prints "fa..ray..mi"
 277         $anon_wrapped->();      # still prints "do...ray"
 278
 279
 280 =head1 DIAGNOSTICS
 281
 282 =over
 283
 284 =item C<Can't wrap non-existent subroutine %s>
 285
 286 An attempt was made to wrap a subroutine that was not defined at the
 287 point of wrapping.
 288
 289 =item C<'pre' value is not a subroutine reference>
 290
 291 The value passed to C<wrap> after the C<'pre'> flag was not
 292 a subroutine reference. Typically, someone forgot the C<sub> on
 293 the anonymous subroutine:
 294
 295         wrap 'subname', pre => { your_code_here() };
 296
 297 and Perl interpreted the last argument as a hash constructor.
 298
 299 =item C<'post' value is not a subroutine reference>
 300
 301 The value passed to C<wrap> after the C<'post'> flag was not
 302 a subroutine reference.
 303
 304 =item C<Uselessly wrapped subroutine reference in void context> (warning only)
 305
 306 When the subroutine to be wrapped is passed as a subroutine reference,
 307 C<wrap> does not install the wrapper around the original, but instead
 308 returns a reference to a subroutine which wraps the original
 309 (see L<Anonymous wrappers>).
 310
 311 However, there's no point in doing this if you don't catch the resulting
 312 subroutine reference.
 313
 314 =back
 315
 316 =head1 AUTHOR
 317
 318 Damian Conway (damian@conway.org)
 319
 320
 321 =head1 BLAME
 322
 323 Schwern made me do this (by implying it wasn't possible ;-)
 324
 325
 326 =head1 BUGS
 327
 328 There are undoubtedly serious bugs lurking somewhere in code this funky :-)
 329
 330 Bug reports and other feedback are most welcome.
 331
 332
 333 =head1 SEE ALSO
 334
 335 Sub::Prepend
 336
 337 =head1 COPYRIGHT
 338
 339       Copyright (c) 2001, Damian Conway. All Rights Reserved.
 340     This module is free software. It may be used, redistributed
 341         and/or modified under the same terms as Perl itself.