r6659 - in /branches/upstream/libhook-lexwrap-perl: ./ current/ current/demo/ current/lib/ current/lib/Hook/
menole-guest at users.alioth.debian.org
menole-guest at users.alioth.debian.org
Wed Aug 15 14:27:27 UTC 2007
Author: menole-guest
Date: Wed Aug 15 14:27:26 2007
New Revision: 6659
URL: http://svn.debian.org/wsvn/?sc=1&rev=6659
Log:
[svn-inject] Installing original source of libhook-lexwrap-perl
Added:
branches/upstream/libhook-lexwrap-perl/
branches/upstream/libhook-lexwrap-perl/current/
branches/upstream/libhook-lexwrap-perl/current/Changes (with props)
branches/upstream/libhook-lexwrap-perl/current/MANIFEST (with props)
branches/upstream/libhook-lexwrap-perl/current/Makefile.PL (with props)
branches/upstream/libhook-lexwrap-perl/current/README (with props)
branches/upstream/libhook-lexwrap-perl/current/demo/
branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl (with props)
branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl (with props)
branches/upstream/libhook-lexwrap-perl/current/lib/
branches/upstream/libhook-lexwrap-perl/current/lib/Hook/
branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm (with props)
branches/upstream/libhook-lexwrap-perl/current/test.pl (with props)
Added: branches/upstream/libhook-lexwrap-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/Changes?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/Changes (added)
+++ branches/upstream/libhook-lexwrap-perl/current/Changes Wed Aug 15 14:27:26 2007
@@ -1,0 +1,31 @@
+Revision history for Perl extension Hook::LexWrap.
+
+0.01 Mon Sep 17 21:23:33 EST 2001
+ - original version; created by h2xs 1.18
+
+
+
+0.10 Thu Sep 20 11:22:11 2001
+
+ - Doc tweak (domo Tatsuhiko-san!)
+
+ - Fixed bug with self-destructing destructor destructing too late
+ (thanks Garrett)
+
+ - Rebuilt entire implementation with features missing for previous
+ release, all based on a cunning idea by Michael Schwern
+ (thanks Michael)
+
+ - Added return value access in pre- and post-wrappers
+
+ - Added pre-emption of original if pre-wrapper changes
+ return value
+
+ - Added two demos
+
+
+0.20 Mon Oct 1 16:51:00 2001
+
+ - Fixed various problems in handling C<wantarray> (thanks Marcel)
+
+ - Fixed C<caller> (thanks everyone)
Propchange: branches/upstream/libhook-lexwrap-perl/current/Changes
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/MANIFEST?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/MANIFEST (added)
+++ branches/upstream/libhook-lexwrap-perl/current/MANIFEST Wed Aug 15 14:27:26 2007
@@ -1,0 +1,8 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/Hook/LexWrap.pm
+test.pl
+demo/demo_memo.pl
+demo/demo_temp.pl
Propchange: branches/upstream/libhook-lexwrap-perl/current/MANIFEST
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/Makefile.PL?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/Makefile.PL (added)
+++ branches/upstream/libhook-lexwrap-perl/current/Makefile.PL Wed Aug 15 14:27:26 2007
@@ -1,0 +1,7 @@
+
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Hook::LexWrap',
+ VERSION => '0.20',
+
+ );
Propchange: branches/upstream/libhook-lexwrap-perl/current/Makefile.PL
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/README?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/README (added)
+++ branches/upstream/libhook-lexwrap-perl/current/README Wed Aug 15 14:27:26 2007
@@ -1,0 +1,48 @@
+==============================================================================
+ Release of version 0.20 of Hook::LexWrap
+==============================================================================
+
+
+NAME
+ Hook::LexWrap - Lexically scoped subroutine wrappers
+
+VERSION
+ This document describes version 0.01 of Hook::LexWrap, released
+ September 17, 2001.
+
+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 `caller' function
+ works correctly within the wrapped subroutine.
+
+AUTHOR
+ Damian Conway (damian at conway.org)
+
+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.
+
+
+==============================================================================
+
+CHANGES IN VERSION 0.20
+
+
+ - Fixed various problems in handling C<wantarray> (thanks Marcel)
+
+ - Fixed C<caller> (thanks everyone)
+
+
+==============================================================================
+
+AVAILABILITY
+
+Hook::LexWrap has been uploaded to the CPAN
+and is also available from:
+
+ http://www.csse.monash.edu.au/~damian/CPAN/Hook-LexWrap.tar.gz
+
+==============================================================================
Propchange: branches/upstream/libhook-lexwrap-perl/current/README
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl (added)
+++ branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl Wed Aug 15 14:27:26 2007
@@ -1,0 +1,19 @@
+use Hook::LexWrap;
+
+sub fibonacci {
+ my ($n) = @_;
+ return 1 if $n < 3;
+ return fibonacci($n-1) + fibonacci($n-2);
+}
+
+MEMOIZE: {
+ my %cache;
+ wrap fibonacci,
+ pre => sub { $_[-1] = $cache{$_[0]} if $cache{$_[0]} },
+ post => sub { $cache{$_[0]} = $_[-1] };
+}
+
+while (<>) {
+ chomp;
+ print fibonacci($_), "\n";
+}
Propchange: branches/upstream/libhook-lexwrap-perl/current/demo/demo_memo.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl (added)
+++ branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl Wed Aug 15 14:27:26 2007
@@ -1,0 +1,31 @@
+use Hook::LexWrap;
+
+my $temp;
+sub set_temp {
+ my $oldtemp = $temp;
+ $temp = shift;
+ print "Temp now $temp\n";
+ return $oldtemp;
+}
+
+print "Setting temp to 73 F...\n";
+my $prev = set_temp(73);
+print "Temp was ", $prev||"undef", " F\n";
+
+print "Setting temp to 98 F...\n";
+$prev = set_temp(98);
+print "Temp was ", $prev, " F\n";
+
+{
+ my $lexical = wrap set_temp,
+ pre => sub { splice @_, 0, 1, $_[0] * 1.8 + 32 },
+ post => sub { $_[-1] = ($_[0] - 32) / 1.8 };
+
+ print "Setting temp to 73 C...\n";
+ my $prev = set_temp(73);
+ print "Temp was ", $prev, " C\n";
+}
+
+print "Setting temp to 98 F...\n";
+$prev = set_temp(98);
+print "Temp was ", $prev, " F\n";
Propchange: branches/upstream/libhook-lexwrap-perl/current/demo/demo_temp.pl
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm (added)
+++ branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm Wed Aug 15 14:27:26 2007
@@ -1,0 +1,325 @@
+package Hook::LexWrap;
+our $VERSION = '0.20';
+use 5.006;
+use Carp;
+
+*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 { *{caller()."::wrap"} = \&wrap }
+
+sub wrap (*@) {
+ my ($typeglob, %wrapper) = @_;
+ $typeglob = (ref $typeglob || $typeglob =~ /::/)
+ ? $typeglob
+ : caller()."::$typeglob";
+ my $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};
+ $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";
+ *{$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 };
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Hook::LexWrap - Lexically scoped subroutine wrappers
+
+=head1 VERSION
+
+This document describes version 0.20 of Hook::LexWrap,
+released October 1, 2001.
+
+=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 at 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 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.
Propchange: branches/upstream/libhook-lexwrap-perl/current/lib/Hook/LexWrap.pm
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhook-lexwrap-perl/current/test.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libhook-lexwrap-perl/current/test.pl?rev=6659&op=file
==============================================================================
--- branches/upstream/libhook-lexwrap-perl/current/test.pl (added)
+++ branches/upstream/libhook-lexwrap-perl/current/test.pl Wed Aug 15 14:27:26 2007
@@ -1,0 +1,197 @@
+use Hook::LexWrap;
+print "1..54\n";
+
+sub ok { print "ok $_[0]\n" }
+sub fail(&) { print "not " if $_[0]->() }
+
+sub actual { ok $_[0]; }
+
+
+actual 1;
+
+{
+ my $lexical = wrap actual,
+ pre => sub { ok 2 },
+ post => sub { ok 4 };
+
+ wrap actual, pre => sub { $_[0]++ };
+
+ my $x = 2;
+ actual $x;
+ 1; # delay destruction
+}
+
+wrap *main::actual, post => sub { ok 6 };
+
+actual my $x = 4;
+
+no warnings 'bareword';
+eval { wrap other, pre => sub { print "not ok 7\n" } } or ok 7;
+
+eval { wrap actual, pre => 1 } and print "not ";
+ok 8;
+
+eval { wrap actual, post => [] } and print "not ";
+ok 9;
+
+BEGIN { *{CORE::GLOBAL::sqrt} = sub { CORE::sqrt(shift) } }
+wrap 'CORE::GLOBAL::sqrt', pre => sub { $_[0]++ };
+
+$x = 99;
+ok sqrt($x);
+
+sub temp { ok $_[0] };
+
+my $sub = wrap \&temp,
+ pre => sub { ok $_[0]-1 },
+ post => sub { ok $_[0]+1 };
+
+$sub->(12);
+temp(14);
+
+{
+ local $SIG{__WARN__} = sub { ok 15 };
+ eval { wrap \&temp, pre => sub { ok $_[0]-1 }; 1 } and ok 16;
+}
+
+use Carp;
+
+sub wrapped_callee {
+ return join '|', caller;
+}
+
+wrap wrapped_callee,
+ pre =>sub{
+ print "not " unless $_[0] eq join '|', caller;
+ ok 17
+ },
+ post=>sub{
+ print "not " unless $_[0] eq join '|', caller;
+ ok 18
+ };
+
+sub raw_callee {
+ return join '|', caller;
+}
+
+print "not " unless wrapped_callee(scalar raw_callee); ok 19;
+
+sub scalar_return { return 'string' }
+wrap scalar_return, post => sub { $_[-1] .= 'ent' };
+print "not " unless scalar_return eq 'stringent'; ok 20;
+
+sub list_return { return (0..9) }
+wrap list_return, post => sub { @{$_[-1]} = reverse @{$_[-1]} };
+my @result = list_return;
+for (0..9) {
+ print "not " and last unless $_ + $result[$_] == 9;
+}
+ok 21;
+
+sub shorted_scalar { return 2 };
+wrap shorted_scalar, pre => sub { $_[-1] = 1 };
+fail { shorted_scalar != 1 }; ok 22;
+
+sub shorted_list { return (2..9) };
+{
+ my $lexical = wrap shorted_list, pre => sub { $_[-1] = [1..9] };
+ fail { (shorted_list)[0] != 1 }; ok 23;
+}
+{
+ my $lexical = wrap shorted_list, pre => sub { $_[-1] = 1 };
+ fail { (shorted_list)[0] != 1 }; ok 24;
+}
+{
+ my $lexical = wrap shorted_list, pre => sub { @{$_[-1]} = (1..9) };
+ fail { (shorted_list)[0] != 1 }; ok 25;
+}
+{
+ my $lexical = wrap shorted_list, pre => sub { @{$_[-1]} = [1..9] };
+ fail { (shorted_list)[0]->[0] != 1 }; ok 26;
+}
+{
+ my $lexical = wrap shorted_list, post => sub { $_[-1] = [1..9] };
+ fail { (shorted_list)[0] != 1 }; ok 27;
+}
+{
+ my $lexical = wrap shorted_list, post => sub { $_[-1] = 1 };
+ fail { (shorted_list)[0] != 1 }; ok 28;
+}
+{
+ my $lexical = wrap shorted_list, post => sub { @{$_[-1]} = (1..9) };
+ fail { (shorted_list)[0] != 1 }; ok 29;
+}
+{
+ my $lexical = wrap shorted_list, post => sub { @{$_[-1]} = [1..9] };
+ fail { (shorted_list)[0]->[0] != 1 }; ok 30;
+}
+
+sub howmany { ok 32 if @_ == 3 }
+
+wrap howmany,
+ pre => sub { ok 31 if @_ == 4 },
+ post => sub { ok 33 if @_ == 4 };
+
+howmany(1..3);
+
+sub wanted {
+ my $expected = $_[3];
+ print 'not ' unless defined wantarray == defined $expected
+ && wantarray eq $expected;
+ ok $_[1]
+}
+
+wrap wanted,
+ pre => sub {
+ my $expected = $_[3];
+ print 'not ' unless defined wantarray == defined $expected
+ && wantarray eq $expected;
+ ok $_[0]
+ },
+ post => sub {
+ my $expected = $_[3];
+ print 'not ' unless defined wantarray == defined $expected
+ && wantarray eq $expected;
+ ok $_[2]
+ };
+
+my @array = wanted(34..36, 1);
+my $scalar = wanted(37..39, "");
+wanted(40..42,undef);
+
+sub caller_test {
+ print "not " unless (caller 0)[3] eq 'main::caller_test'; ok $_[0];
+ print "not " unless (caller 1)[3] eq 'main::caller_outer'; ok $_[0]+1;
+ print "not " unless (caller 2)[3] eq 'main::wrapped'; ok $_[0]+2;
+ print "not " unless (caller 3)[3] eq 'main::inner'; ok $_[0]+3;
+ print "not " unless (caller 4)[3] eq 'main::middle'; ok $_[0]+4;
+ print "not " unless (caller 5)[3] eq 'main::outer'; ok $_[0]+5;
+}
+
+sub caller_outer {
+ caller_test(@_);
+}
+
+sub wrapped {
+ caller_outer(@_);
+}
+
+sub outer { middle(@_) }
+sub middle { inner(@_) }
+sub inner { wrapped(@_) }
+
+outer(43..48);
+
+wrap wrapped,
+ pre => sub {},
+ post => sub {};
+
+wrap wrapped,
+ pre => sub {},
+ post => sub {};
+
+wrap wrapped,
+ pre => sub {},
+ post => sub {};
+
+outer(49..54);
Propchange: branches/upstream/libhook-lexwrap-perl/current/test.pl
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-perl-cvs-commits
mailing list