Commit | Line | Data |
65d35121 |
1 | package DBICTest::Util; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
6 | use Carp; |
8d6b1478 |
7 | use Config; |
65d35121 |
8 | |
9 | use base 'Exporter'; |
218b7c12 |
10 | our @EXPORT_OK = qw/local_umask stacktrace/; |
8d6b1478 |
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 | |
65d35121 |
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 | |
65d35121 |
49 | 1; |