Commit | Line | Data |
65d35121 |
1 | package DBICTest::Util; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
8d6b1478 |
6 | use Config; |
a3a17a15 |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed'; |
65d35121 |
9 | |
10 | use base 'Exporter'; |
a3a17a15 |
11 | our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args); |
8d6b1478 |
12 | |
13 | sub local_umask { |
14 | return unless defined $Config{d_umask}; |
15 | |
16 | die 'Calling local_umask() in void context makes no sense' |
17 | if ! defined wantarray; |
18 | |
19 | my $old_umask = umask(shift()); |
20 | die "Setting umask failed: $!" unless defined $old_umask; |
21 | |
22 | return bless \$old_umask, 'DBICTest::Util::UmaskGuard'; |
23 | } |
24 | { |
25 | package DBICTest::Util::UmaskGuard; |
26 | sub DESTROY { |
27 | local ($@, $!); |
28 | eval { defined (umask ${$_[0]}) or die }; |
29 | warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') ) |
30 | if ($@ || $!); |
31 | } |
32 | } |
33 | |
65d35121 |
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 | |
a3a17a15 |
49 | sub check_customcond_args ($) { |
50 | my $args = shift; |
51 | |
52 | confess "Expecting a hashref" |
53 | unless ref $args eq 'HASH'; |
54 | |
55 | for (qw(foreign_relname self_alias foreign_alias)) { |
56 | confess "Custom condition argument '$_' must be a plain string" |
57 | if length ref $args->{$_} or ! length $args->{$_}; |
58 | } |
59 | |
60 | confess "Custom condition argument 'self_resultsource' must be a rsrc instance" |
61 | unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource'); |
62 | |
63 | confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc" |
64 | unless ref $args->{self_resultsource}->relationship_info($args->{foreign_relname}); |
65 | |
66 | if (defined $args->{self_rowobj}) { |
67 | confess "Custom condition argument 'self_rowobj' must be a result instance" |
68 | unless defined blessed $args->{self_rowobj} and $args->{self_rowobj}->isa('DBIx::Class::Row'); |
69 | } |
70 | |
71 | $args; |
72 | } |
73 | |
65d35121 |
74 | 1; |