From: Vincent Pit Date: Fri, 16 Apr 2010 14:31:07 +0000 (+0200) Subject: Improved synopsys X-Git-Tag: v0.11~9 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=6090555243b452a17460ab13510b8a15e0c62f5e;p=perl%2Fmodules%2FScope-Upper.git Improved synopsys --- diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 6e02d2c..67cc80f 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -20,50 +20,78 @@ BEGIN { =head1 SYNOPSIS - package X; +L, L, L, L and L : + + package Scope; use Scope::Upper qw/reap localize localize_elem localize_delete :words/; - sub desc { shift->{desc} } + sub new { + my ($class, $name) = @_; + + localize '$tag' => bless({ name => $name }, $class) => UP; - sub set_tag { - my ($desc) = @_; + reap { print Scope->tag->name, ": end\n" } UP; + } - # First localize $x so that it gets destroyed last - localize '$x' => bless({ desc => $desc }, __PACKAGE__) => UP; # one scope up + # Get the tag stored in the caller namespace + sub tag { + my $l = 0; + my $pkg = __PACKAGE__; + $pkg = caller $l++ while $pkg eq __PACKAGE__; + + no strict 'refs'; + ${$pkg . '::tag'}; + } - reap sub { - my $pkg = caller; - my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope - print $x->desc . ": done\n"; - } => SCOPE 1; # same as UP here + sub name { shift->{name} } + # Locally capture warnings and reprint them with the name prefixed + sub catch { localize_elem '%SIG', '__WARN__' => sub { - my $pkg = caller; - my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope - CORE::warn($x->desc . ': ' . join('', @_)); - } => UP CALLER 0; # same as UP here + print Scope->tag->name, ': ', @_; + } => UP; + } - # delete last @ARGV element - localize_delete '@ARGV', -1 => UP SUB HERE; # same as UP here + # Locally clear @INC + sub private { + for (reverse 0 .. $#INC) { + # First UP is the for loop, second is the sub boundary + localize_delete '@INC', $_ => UP UP; + } } - package Y; + ... + + package UserLand; { - X::set_tag('pie'); - # $x is now a X object, and @ARGV has one element less - warn 'what'; # warns "pie: what at ..." - ... - } # "pie: done" is printed + Scope->new("top"); # initializes $UserLand::tag - package Z; + { + Scope->catch; + my $one = 1 + undef; # prints "top: Use of uninitialized value..." + + { + Scope->private; + eval { require Cwd }; + print $@; # prints "Can't locate Cwd.pm in @INC (@INC contains:) at..." + } + + require Cwd; # loads Cwd.pm + } + + } # prints "top: done" + +L and L : + + package Try; use Scope::Upper qw/unwind want_at :words/; sub try (&) { my @result = shift->(); - my $cx = SUB UP SUB; + my $cx = SUB UP; # Point to the sub above this one unwind +(want_at($cx) ? @result : scalar @result) => $cx; } @@ -71,13 +99,15 @@ BEGIN { sub zap { try { + my @things = qw/a b c/; return @things; # returns to try() and then outside zap() # not reached - } + }; # not reached } - my @what = zap(); # @what contains @things + my @stuff = zap(); # @stuff contains qw/a b c/ + my $stuff = zap(); # $stuff contains 3 =head1 DESCRIPTION diff --git a/samples/tag.pl b/samples/tag.pl index e28aae0..ca017dd 100644 --- a/samples/tag.pl +++ b/samples/tag.pl @@ -1,48 +1,63 @@ #!perl -package X; - use strict; use warnings; -use blib; +package Scope; use Scope::Upper qw/reap localize localize_elem localize_delete :words/; -die 'run this script with some arguments!' unless @ARGV; +sub new { + my ($class, $name) = @_; + + localize '$tag' => bless({ name => $name }, $class) => UP; -sub desc { shift->{desc} } + reap { print Scope->tag->name, ": end\n" } UP; +} -sub set_tag { - my ($desc) = @_; +# Get the tag stored in the caller namespace +sub tag { + my $l = 0; + my $pkg = __PACKAGE__; + $pkg = caller $l++ while $pkg eq __PACKAGE__; - # First localize $x so that it gets destroyed last - localize '$x' => bless({ desc => $desc }, __PACKAGE__) => UP; + no strict 'refs'; + ${$pkg . '::tag'}; +} - reap sub { - my $pkg = caller; - my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope - print $x->desc . ": done\n"; - } => SCOPE 1; # same as UP here +sub name { shift->{name} } +# Locally capture warnings and reprint them with the name prefixed +sub catch { localize_elem '%SIG', '__WARN__' => sub { - my $pkg = caller; - my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope - CORE::warn($x->desc . ': ' . join('', @_)); - } => UP CALLER 0; # same as UP here - - # delete last @ARGV element - localize_delete '@ARGV', -1 => UP SUB HERE; # same as UP here + print Scope->tag->name, ': ', @_; + } => UP; } -package main; +# Locally clear @INC +sub private { + for (reverse 0 .. $#INC) { + # First UP is the for loop, second is the sub boundary + localize_delete '@INC', $_ => UP UP; + } +} -use strict; -use warnings; +package UserLand; { - X::set_tag('pie'); - # $x is now a X object, and @ARGV has one element less - warn 'what'; # warns "pie: what at ..." - warn "\@ARGV contains [@ARGV]"; -} # "pie: done" is printed + Scope->new("top"); # initializes $UserLand::tag + + { + Scope->catch; + my $one = 1 + undef; # prints "top: Use of uninitialized value..." + + { + Scope->private; + eval { require Cwd }; + print $@; # prints "Can't locate Cwd.pm in @INC (@INC contains:) at..." + } + + require Cwd; # loads Cwd.pm + } + +} # prints "top: done" diff --git a/samples/try.pl b/samples/try.pl index 305a0ec..7e1cb2a 100644 --- a/samples/try.pl +++ b/samples/try.pl @@ -9,7 +9,7 @@ use Scope::Upper qw/unwind want_at :words/; sub try (&) { my @result = shift->(); - my $cx = SUB UP SUB; + my $cx = SUB UP; # Point to the sub above this one unwind +(want_at($cx) ? @result : scalar @result) => $cx; } @@ -21,7 +21,7 @@ sub zap { print "NOT REACHED\n"; } -my @what = zap(); # @what contains qw/a b c/ -my $what = zap(); # $what contains 3 +my @stuff = zap(); # @stuff contains qw/a b c/ +my $stuff = zap(); # $stuff contains 3 -print "zap() returns @what in list context and $what in scalar context\n"; +print "zap() returns @stuff in list context and $stuff in scalar context\n";