t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Carp;
   7 use Config;
   8
   9 use base 'Exporter';
  10 our @EXPORT_OK = qw/local_umask stacktrace/;
  11
  12 sub local_umask {
  13   return unless defined $Config{d_umask};
  14
  15   die 'Calling local_umask() in void context makes no sense'
  16     if ! defined wantarray;
  17
  18   my $old_umask = umask(shift());
  19   die "Setting umask failed: $!" unless defined $old_umask;
  20
  21   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
  22 }
  23 {
  24   package DBICTest::Util::UmaskGuard;
  25   sub DESTROY {
  26     local ($@, $!);
  27     eval { defined (umask ${$_[0]}) or die };
  28     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
  29       if ($@ || $!);
  30   }
  31 }
  32
  33
  34 sub stacktrace {
  35   my $frame = shift;
  36   $frame++;
  37   my (@stack, @frame);
  38
  39   while (@frame = caller($frame++)) {
  40     push @stack, [@frame[3,1,2]];
  41   }
  42
  43   return undef unless @stack;
  44
  45   $stack[0][0] = '';
  46   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
  47 }
  48
  49 1;