samples/tag.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use blib;
   7
   8 package Scope;
   9
  10 use Scope::Upper qw<reap localize localize_elem localize_delete :words>;
  11
  12 sub new {
  13  my ($class, $name) = @_;
  14
  15  localize '$tag' => bless({ name => $name }, $class) => UP;
  16
  17  reap { print Scope->tag->name, ": end\n" } UP;
  18 }
  19
  20 # Get the tag stored in the caller namespace
  21 sub tag {
  22  my $l   = 0;
  23  my $pkg = __PACKAGE__;
  24  $pkg    = caller $l++ while $pkg eq __PACKAGE__;
  25
  26  no strict 'refs';
  27  ${$pkg . '::tag'};
  28 }
  29
  30 sub name { shift->{name} }
  31
  32 # Locally capture warnings and reprint them with the name prefixed
  33 sub catch {
  34  localize_elem '%SIG', '__WARN__' => sub {
  35   print Scope->tag->name, ': ', @_;
  36  } => UP;
  37 }
  38
  39 # Locally clear @INC
  40 sub private {
  41  for (reverse 0 .. $#INC) {
  42   # First UP is the for loop, second is the sub boundary
  43   localize_delete '@INC', $_ => UP UP;
  44  }
  45 }
  46
  47 package UserLand;
  48
  49 {
  50  Scope->new("top");      # initializes $UserLand::tag
  51
  52  {
  53   Scope->catch;
  54   my $one = 1 + undef;   # prints "top: Use of uninitialized value..."
  55
  56   {
  57    Scope->private;
  58    eval { delete $INC{"Cwd.pm"}; require Cwd }; # blib loads Cwd
  59    print $@;             # prints "Can't locate Cwd.pm in @INC (@INC contains:) at..."
  60   }
  61
  62   require Cwd;           # loads Cwd.pm
  63  }
  64
  65 }                        # prints "top: done"