This file is indexed.

/usr/share/perl5/Hook/LexWrap.pm is in libhook-lexwrap-perl 0.24-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
package Hook::LexWrap;
use 5.006;
use strict;
use warnings;
our $VERSION = '0.24';
use Carp;

{
no warnings 'redefine';
*CORE::GLOBAL::caller = sub (;$) {
	my ($height) = ($_[0]||0);
	my $i=1;
	my $name_cache;
	while (1) {
		my @caller = CORE::caller($i++) or return;
		$caller[3] = $name_cache if $name_cache;
		$name_cache = $caller[0] eq 'Hook::LexWrap' ? $caller[3] : '';
		next if $name_cache || $height-- != 0;
		return wantarray ? @_ ? @caller : @caller[0..2] : $caller[0];
	}
};
}

sub import { no strict 'refs'; *{caller()."::wrap"} = \&wrap }

sub wrap (*@) {  ## no critic Prototypes
	my ($typeglob, %wrapper) = @_;
	$typeglob = (ref $typeglob || $typeglob =~ /::/)
		? $typeglob
		: caller()."::$typeglob";
	my $original;
	{
	        no strict 'refs';
	        $original = ref $typeglob eq 'CODE' && $typeglob
		     || *$typeglob{CODE}
		     || croak "Can't wrap non-existent subroutine ", $typeglob;
	}
	croak "'$_' value is not a subroutine reference"
		foreach grep {$wrapper{$_} && ref $wrapper{$_} ne 'CODE'}
			qw(pre post);
	no warnings 'redefine';
	my ($caller, $unwrap) = *CORE::GLOBAL::caller{CODE};
	my $imposter = sub {
		if ($unwrap) { goto &$original }
		my ($return, $prereturn);
		if (wantarray) {
			$prereturn = $return = [];
			() = $wrapper{pre}->(@_,$return) if $wrapper{pre};
			if (ref $return eq 'ARRAY' && $return == $prereturn && !@$return) {
				$return = [ &$original ];
				() = $wrapper{post}->(@_, $return)
					if $wrapper{post};
			}
			return ref $return eq 'ARRAY' ? @$return : ($return);
		}
		elsif (defined wantarray) {
			$return = bless sub {$prereturn=1}, 'Hook::LexWrap::Cleanup';
			my $dummy = $wrapper{pre}->(@_, $return) if $wrapper{pre};
			unless ($prereturn) {
				$return = &$original;
				$dummy = scalar $wrapper{post}->(@_, $return)
					if $wrapper{post};
			}
			return $return;
		}
		else {
			$return = bless sub {$prereturn=1}, 'Hook::LexWrap::Cleanup';
			$wrapper{pre}->(@_, $return) if $wrapper{pre};
			unless ($prereturn) {
				&$original;
				$wrapper{post}->(@_, $return)
					if $wrapper{post};
			}
			return;
		}
	};
	ref $typeglob eq 'CODE' and return defined wantarray
		? $imposter
		: carp "Uselessly wrapped subroutine reference in void context";
	{
	        no strict 'refs';
	        *{$typeglob} = $imposter;
	}
	return unless defined wantarray;
	return bless sub{ $unwrap=1 }, 'Hook::LexWrap::Cleanup';
}

package Hook::LexWrap::Cleanup;

sub DESTROY { $_[0]->() }
use overload 
	q{""}   => sub { undef },
	q{0+}   => sub { undef },
	q{bool} => sub { undef },
	q{fallback}=>1; #fallback=1 - like no overloading for other operations

1;

__END__


=head1 NAME

Hook::LexWrap - Lexically scoped subroutine wrappers

=head1 VERSION

This document describes version 0.23 of Hook::LexWrap.

=head1 SYNOPSIS

	use Hook::LexWrap;

	sub doit { print "[doit:", caller, "]"; return {my=>"data"} }

	SCOPED: {
		wrap doit,
			pre  => sub { print "[pre1: @_]\n" },
			post => sub { print "[post1:@_]\n"; $_[1]=9; };

		my $temporarily = wrap doit,
			post => sub { print "[post2:@_]\n" },
			pre  => sub { print "[pre2: @_]\n  "};

		@args = (1,2,3);
		doit(@args);	# pre2->pre1->doit->post1->post2
	}

	@args = (4,5,6);
	doit(@args);		# pre1->doit->post1


=head1 DESCRIPTION

Hook::LexWrap allows you to install a pre- or post-wrapper (or both)
around an existing subroutine. Unlike other modules that provide this
capacity (e.g. Hook::PreAndPost and Hook::WrapSub), Hook::LexWrap
implements wrappers in such a way that the standard C<caller> function
works correctly within the wrapped subroutine.

To install a prewrappers, you write:

        use Hook::LexWrap;

        wrap 'subroutine_name', pre => \&some_other_sub;

   #or: wrap *subroutine_name,  pre => \&some_other_sub;

The first argument to C<wrap> is a string containing the name of the
subroutine to be wrapped (or the typeglob containing it, or a
reference to it). The subroutine name may be qualified, and the
subroutine must already be defined. The second argument indicates the
type of wrapper being applied and must be either C<'pre'> or
C<'post'>. The third argument must be a reference to a subroutine that
implements the wrapper.

To install a post-wrapper, you write:

        wrap 'subroutine_name', post => \&yet_another_sub;

   #or: wrap *subroutine_name,  post => \&yet_another_sub;

To install both at once:

        wrap 'subroutine_name',
             pre  => \&some_other_sub,
             post => \&yet_another_sub;

or:

        wrap *subroutine_name,
             post => \&yet_another_sub,  # order in which wrappers are
             pre  => \&some_other_sub;   # specified doesn't matter

Once they are installed, the pre- and post-wrappers will be called before
and after the subroutine itself, and will be passed the same argument list.

The pre- and post-wrappers and the original subroutine also all see the same
(correct!) values from C<caller> and C<wantarray>.


=head2 Short-circuiting and long-circuiting return values

The pre- and post-wrappers both receive an extra argument in their @_
arrays. That extra argument is appended to the original argument list
(i.e. is can always be accessed as $_[-1]) and acts as a place-holder for
the original subroutine's return value.

In a pre-wrapper, $_[-1] is -- for obvious reasons -- C<undef>. However,
$_[-1] may be assigned to in a pre-wrapper, in which case Hook::LexWrap
assumes that the original subroutine has been "pre-empted", and that
neither it, nor the corresponding post-wrapper, nor any wrappers that
were applied I<before> the pre-empting pre-wrapper was installed, need
be run. Note that any post-wrappers that were installed after the
pre-empting pre-wrapper was installed I<will> still be called before the
original subroutine call returns.

In a post-wrapper, $_[-1] contains the return value produced by the
wrapped subroutine. In a scalar return context, this value is the scalar
return value. In an list return context, this value is a reference to
the array of return values. $_[-1] may be assigned to in a post-wrapper,
and this changes the return value accordingly.

Access to the arguments and return value is useful for implementing
techniques such as memoization:

        my %cache;
        wrap fibonacci,
                pre  => sub { $_[-1] = $cache{$_[0]} if $cache{$_[0]} },
                post => sub { $cache{$_[0]} = $_[-1] };


or for converting arguments and return values in a consistent manner:

	# set_temp expects and returns degrees Fahrenheit,
	# but we want to use Celsius
        wrap set_temp,
                pre   => sub { splice @_, 0, 1, $_[0] * 1.8 + 32 },
                post  => sub { $_[-1] = ($_[0] - 32) / 1.8 };


=head2 Lexically scoped wrappers

Normally, any wrappers installed by C<wrap> remain attached to the 
subroutine until it is undefined. However, it is possible to make
specific wrappers lexically bound, so that they operate only until
the end of the scope in which they're created (or until some other
specific point in the code).

If C<wrap> is called in a I<non-void> context:

        my $lexical = wrap 'sub_name', pre => \&wrapper;

it returns a special object corresponding to the particular wrapper being
placed around the original subroutine. When that object is destroyed
-- when its container variable goes out of scope, or when its
reference count otherwise falls to zero (e.g. C<undef $lexical>), or 
when it is explicitly destroyed (C<$lexical-E<gt>DESTROY>) --
the corresponding wrapper is removed from around
the original subroutine. Note, however, that all other wrappers around the
subroutine are preserved.


=head2 Anonymous wrappers

If the subroutine to be wrapped is passed as a reference (rather than by name
or by typeglob), C<wrap> does not install the wrappers around the 
original subroutine. Instead it generates a new subroutine which acts
as if it were the original with those wrappers around it.
It then returns a reference to that new subroutine. Only calls to the original
through that wrapped reference invoke the wrappers. Direct by-name calls to
the original, or calls through another reference, do not.

If the original is subsequently wrapped by name, the anonymously wrapped
subroutine reference does not see those wrappers. In other words,
wrappers installed via a subroutine reference are completely independent
of those installed via the subroutine's name (or typeglob).

For example:

        sub original { print "ray" }

        # Wrap anonymously...
        my $anon_wrapped = wrap \&original, pre => sub { print "do..." };

        # Show effects...
        original();             # prints "ray"
        $anon_wrapped->();      # prints "do..ray"

        # Wrap nonymously...
        wrap *original,
                pre  => sub { print "fa.." },
                post => sub { print "..mi" };

        # Show effects...
        original();             #   now prints "fa..ray..mi"
        $anon_wrapped->();      # still prints "do...ray"


=head1 DIAGNOSTICS

=over

=item C<Can't wrap non-existent subroutine %s>

An attempt was made to wrap a subroutine that was not defined at the
point of wrapping.

=item C<'pre' value is not a subroutine reference>

The value passed to C<wrap> after the C<'pre'> flag was not
a subroutine reference. Typically, someone forgot the C<sub> on
the anonymous subroutine:

        wrap 'subname', pre => { your_code_here() };

and Perl interpreted the last argument as a hash constructor.

=item C<'post' value is not a subroutine reference>

The value passed to C<wrap> after the C<'post'> flag was not
a subroutine reference.

=item C<Uselessly wrapped subroutine reference in void context> (warning only)

When the subroutine to be wrapped is passed as a subroutine reference,
C<wrap> does not install the wrapper around the original, but instead
returns a reference to a subroutine which wraps the original
(see L<Anonymous wrappers>). 

However, there's no point in doing this if you don't catch the resulting
subroutine reference.

=back

=head1 AUTHOR

Damian Conway (damian@conway.org)


=head1 BLAME

Schwern made me do this (by implying it wasn't possible ;-)


=head1 BUGS

There are undoubtedly serious bugs lurking somewhere in code this funky :-)

Bug reports and other feedback are most welcome.


=head1 SEE ALSO

Sub::Prepend

=head1 COPYRIGHT

      Copyright (c) 2001, Damian Conway. All Rights Reserved.
    This module is free software. It may be used, redistributed
        and/or modified under the same terms as Perl itself.