t/lib/DBICTest/Util.pm

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