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