samples/tag.pl

   1 #!perl
   2
   3 package X;
   4
   5 use strict;
   6 use warnings;
   7
   8 use blib;
   9
  10 use Scope::Upper qw/reap localize localize_elem localize_delete :words/;
  11
  12 die 'run this script with some arguments!' unless @ARGV;
  13
  14 sub desc { shift->{desc} }
  15
  16 sub set_tag {
  17  my ($desc) = @_;
  18
  19  # First localize $x so that it gets destroyed last
  20  localize '$x' => bless({ desc => $desc }, __PACKAGE__) => UP;
  21
  22  reap sub {
  23   my $pkg = caller;
  24   my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
  25   print $x->desc . ": done\n";
  26  } => SCOPE 1; # same as UP here
  27
  28  localize_elem '%SIG', '__WARN__' => sub {
  29   my $pkg = caller;
  30   my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
  31   CORE::warn($x->desc . ': ' . join('', @_));
  32  } => UP CALLER 0; # same as UP here
  33
  34  # delete last @ARGV element
  35  localize_delete '@ARGV', -1 => UP SUB HERE; # same as UP here
  36 }
  37
  38 package main;
  39
  40 use strict;
  41 use warnings;
  42
  43 {
  44  X::set_tag('pie');
  45  # $x is now a X object, and @ARGV has one element less
  46  warn 'what'; # warns "pie: what at ..."
  47  warn "\@ARGV contains [@ARGV]";
  48 } # "pie: done" is printed