1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
package DBICTest::Util;
use warnings;
use strict;
# this noop trick initializes the STDOUT, so that the TAP::Harness
# issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
# keep spinning and scheduling jobs
# This results in an overall much smoother job-queue drainage, since
# the Harness blocks less
# (ideally this needs to be addressed in T::H, but a quick patchjob
# broke everything so tabling it for now)
BEGIN {
if ($INC{'Test/Builder.pm'}) {
local $| = 1;
print "#\n";
}
}
use Module::Runtime 'module_notional_filename';
BEGIN {
for my $mod (qw( SQL::Abstract::Test SQL::Abstract )) {
if ( $INC{ module_notional_filename($mod) } ) {
# FIXME this does not seem to work in BEGIN - why?!
#require Carp;
#$Carp::Internal{ (__PACKAGE__) }++;
#Carp::croak( __PACKAGE__ . " must be loaded before $mod" );
my ($fr, @frame) = 1;
while (@frame = caller($fr++)) {
last if $frame[1] !~ m|^t/lib/DBICTest|;
}
die __PACKAGE__ . " must be loaded before $mod (or modules using $mod) at $frame[1] line $frame[2]\n";
}
}
}
use Config;
use Carp 'confess';
use Scalar::Util qw(blessed refaddr);
use base 'Exporter';
our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args);
sub local_umask {
return unless defined $Config{d_umask};
die 'Calling local_umask() in void context makes no sense'
if ! defined wantarray;
my $old_umask = umask(shift());
die "Setting umask failed: $!" unless defined $old_umask;
return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
}
{
package DBICTest::Util::UmaskGuard;
sub DESTROY {
local ($@, $!);
eval { defined (umask ${$_[0]}) or die };
warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
if ($@ || $!);
}
}
sub stacktrace {
my $frame = shift;
$frame++;
my (@stack, @frame);
while (@frame = caller($frame++)) {
push @stack, [@frame[3,1,2]];
}
return undef unless @stack;
$stack[0][0] = '';
return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
}
sub check_customcond_args ($) {
my $args = shift;
confess "Expecting a hashref"
unless ref $args eq 'HASH';
for (qw(rel_name foreign_relname self_alias foreign_alias)) {
confess "Custom condition argument '$_' must be a plain string"
if length ref $args->{$_} or ! length $args->{$_};
}
confess "Current and legacy rel_name arguments do not match"
if $args->{rel_name} ne $args->{foreign_relname};
confess "Custom condition argument 'self_resultsource' must be a rsrc instance"
unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource');
confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc"
unless ref $args->{self_resultsource}->relationship_info($args->{rel_name});
my $struct_cnt = 0;
if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) {
$struct_cnt++;
for (qw(self_result_object self_rowobj)) {
confess "Custom condition argument '$_' must be a result instance"
unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row');
}
confess "Current and legacy self_result_object arguments do not match"
if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj});
}
if (defined $args->{foreign_values}) {
$struct_cnt++;
confess "Custom condition argument 'foreign_values' must be a hash reference"
unless ref $args->{foreign_values} eq 'HASH';
}
confess "Data structures supplied on both ends of a relationship"
if $struct_cnt == 2;
$args;
}
1;
|
