(travis) Temporarily allow-fail all trusty-based builds
[dbsrgits/DBIx-Class.git] / t / storage / debug.t
CommitLineData
c0329273 1BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
2
004d31fb 3use strict;
f54428ab 4use warnings;
64b3598f 5no warnings 'once';
004d31fb 6
db83437e 7BEGIN {
8 delete @ENV{qw(
9 DBIC_TRACE
10 DBIC_TRACE_PROFILE
11 DBICTEST_SQLITE_USE_FILE
12 DBICTEST_VIA_REPLICATED
13 )};
14}
8b60b921 15
004d31fb 16use Test::More;
f410ea47 17use Test::Exception;
68367f1f 18use Try::Tiny;
9d522a4e 19use File::Spec;
c0329273 20
004d31fb 21use DBICTest;
e48635f7 22use DBICTest::Util 'slurp_bytes';
004d31fb 23
24my $schema = DBICTest->init_schema();
25
e48635f7 26my $log_fn = "t/var/sql-$$.log";
27unlink $log_fn or die $! if -e $log_fn;
64b3598f 28
f410ea47 29# make sure we are testing the vanilla debugger and not ::PrettyPrint
2cfc22dd 30require DBIx::Class::Storage::Statistics;
f410ea47 31$schema->storage->debugobj(DBIx::Class::Storage::Statistics->new);
004d31fb 32
33ok ( $schema->storage->debug(1), 'debug' );
e48635f7 34{
35 open my $dbgfh, '>', $log_fn or die $!;
36 $schema->storage->debugfh($dbgfh);
37 $schema->storage->debugfh->autoflush(1);
38 $schema->resultset('CD')->count;
39 $schema->storage->debugfh(undef);
40}
70f39278 41
e48635f7 42my @loglines = slurp_bytes $log_fn;
64b3598f 43is (@loglines, 1, 'one line of log');
44like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success');
70f39278 45
64b3598f 46
47{
e48635f7 48 local $ENV{DBIC_TRACE} = "=$log_fn";
49 unlink $log_fn;
64b3598f 50
51 $schema->resultset('CD')->count;
52
53 my $schema2 = DBICTest->init_schema(no_deploy => 1);
54 $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms
55
e48635f7 56 my @loglines = slurp_bytes $log_fn;
64b3598f 57 is(@loglines, 2, '2 lines of log');
58 like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success');
59 like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success');
60
61 $schema->storage->debugobj->debugfh(undef)
62}
f410ea47 63
8d6b1478 64END {
e48635f7 65 unlink $log_fn if $log_fn;
8d6b1478 66}
67
70f39278 68open(STDERRCOPY, '>&STDERR');
68367f1f 69
68b8ba54 70my $exception_line_number;
68367f1f 71# STDERR will be closed, no T::B diag in blocks
72my $exception = try {
73 close(STDERR);
68b8ba54 74 $exception_line_number = __LINE__ + 1; # important for test, do not reformat
64b3598f 75 $schema->resultset('CD')->search({})->count;
68367f1f 76} catch {
77 $_
78} finally {
79 # restore STDERR
80 open(STDERR, '>&STDERRCOPY');
81};
82
e93fb362 83ok $exception =~ /
68b8ba54 84 \QDuplication of STDERR for debug output failed (perhaps your STDERR is closed?)\E
85 .+
86 \Qat @{[__FILE__]} line $exception_line_number\E$
e93fb362 87/xms
88 or diag "Unexpected exception text:\n\n$exception\n";
68367f1f 89
9d522a4e 90my @warnings;
91$exception = try {
92 local $SIG{__WARN__} = sub { push @warnings, @_ if $_[0] =~ /character/i };
93 close STDERR;
94 open(STDERR, '>', File::Spec->devnull) or die $!;
95 $schema->resultset('CD')->search({ title => "\x{1f4a9}" })->count;
96 '';
97} catch {
98 $_;
99} finally {
100 # restore STDERR
101 close STDERR;
102 open(STDERR, '>&STDERRCOPY');
103};
104
105die "How did that fail... $exception"
106 if $exception;
107
108is_deeply(\@warnings, [], 'No warnings with unicode on STDERR');
f410ea47 109
2cfc22dd 110# test debugcb and debugobj protocol
e5d9ee92 111{
2cfc22dd 112 my $rs = $schema->resultset('CD')->search( {
113 artist => 1,
114 cdid => { -between => [ 1, 3 ] },
115 title => { '!=' => \[ '?', undef ] }
116 });
117
118 my $sql_trace = 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( artist = ? AND ( cdid BETWEEN ? AND ? ) AND title != ? ) )';
119 my @bind_trace = qw( '1' '1' '3' NULL ); # quotes are in fact part of the trace </facepalm>
120
121
122 my @args;
123 $schema->storage->debugcb(sub { push @args, @_ } );
124
125 $rs->all;
126
127 is_deeply( \@args, [
128 "SELECT",
129 sprintf( "%s: %s\n", $sql_trace, join ', ', @bind_trace ),
130 ]);
131
132 {
133 package DBICTest::DebugObj;
134 our @ISA = 'DBIx::Class::Storage::Statistics';
135
136 sub query_start {
137 my $self = shift;
138 ( $self->{_traced_sql}, @{$self->{_traced_bind}} ) = @_;
139 }
140 }
141
142 my $do = $schema->storage->debugobj(DBICTest::DebugObj->new);
143
144 $rs->all;
145
146 is( $do->{_traced_sql}, $sql_trace );
147
148 is_deeply ( $do->{_traced_bind}, \@bind_trace );
e5d9ee92 149}
150
8494142c 151# recreate test as seen in DBIx::Class::QueryLog
152# the rationale is that if someone uses a non-IO::Handle object
153# on CPAN, many are *bound* to use one on darkpan. Thus this
154# test to ensure there is no future silent breakage
155{
156 my $output = "";
157
158 {
159 package DBICTest::_Printable;
160
161 sub print {
162 my ($self, @args) = @_;
163 $output .= join('', @args);
164 }
165 }
166
167 $schema->storage->debugobj(undef);
168 $schema->storage->debug(1);
169 $schema->storage->debugfh( bless {}, "DBICTest::_Printable" );
170 $schema->storage->txn_do( sub { $schema->resultset('Artist')->count } );
171
172 like (
173 $output,
174 qr/
175 \A
176 ^ \QBEGIN WORK\E \s*?
177 ^ \QSELECT COUNT( * ) FROM artist me:\E \s*?
178 ^ \QCOMMIT\E \s*?
179 \z
180 /xm
181 );
182
183 $schema->storage->debug(0);
184 $schema->storage->debugfh(undef);
185}
186
c9d29bb2 187done_testing;