1#!perl -w
2# vim:sw=4:ts=8
3
4use strict;
5
6use Test::More tests => 99;
7
8## ----------------------------------------------------------------------------
9## 09trace.t
10## ----------------------------------------------------------------------------
11#
12## ----------------------------------------------------------------------------
13
14BEGIN {
15    $ENV{DBI_TRACE} = 0; # for PurePerl - ensure DBI_TRACE is in the env
16    use_ok( 'DBI' );
17}
18
19$|=1;
20
21
22my $trace_file = "dbitrace$$.log";
23
241 while unlink $trace_file;
25warn "Can't unlink existing $trace_file: $!" if -e $trace_file;
26
27my $orig_trace_level = DBI->trace;
28DBI->trace(3, $trace_file);             # enable trace before first driver load
29
30my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
31die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
32
33isa_ok($dbh, 'DBI::db');
34
35$dbh->dump_handle("dump_handle test, write to log file", 2);
36
37DBI->trace(0, undef);   # turn off and restore to STDERR
38
39SKIP: {
40        skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
41        ok( -s $trace_file, "trace file size = " . -s $trace_file);
42}
43
44DBI->trace($orig_trace_level);  # no way to restore previous outfile XXX
45
46
47# Clean up when we're done.
48END { $dbh->disconnect if $dbh;
49      1 while unlink $trace_file; };
50
51## ----------------------------------------------------------------------------
52# Check the database handle attributes.
53
54cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute');
55
561 while unlink $trace_file;
57
58$dbh->trace(0, $trace_file);
59ok( -f $trace_file, '... trace file successfully created');
60
61my @names = qw(
62	SQL
63    CON
64    ENC
65    DBD
66    TXN
67	foo bar baz boo bop
68);
69my %flag;
70my $all_flags = 0;
71
72foreach my $name (@names) {
73    print "parse_trace_flag $name\n";
74    ok( my $flag1 = $dbh->parse_trace_flag($name) );
75    ok( my $flag2 = $dbh->parse_trace_flags($name) );
76    is( $flag1, $flag2 );
77
78    $dbh->{TraceLevel} = $flag1;
79    is( $dbh->{TraceLevel}, $flag1 );
80
81    $dbh->{TraceLevel} = 0;
82    is( $dbh->{TraceLevel}, 0 );
83
84    $dbh->trace($flag1);
85    is $dbh->trace,        $flag1;
86    is $dbh->{TraceLevel}, $flag1;
87
88    $dbh->{TraceLevel} = $name;		# set by name
89    $dbh->{TraceLevel} = undef;		# check no change on undef
90    is( $dbh->{TraceLevel}, $flag1 );
91
92    $flag{$name} = $flag1;
93    $all_flags |= $flag1
94        if defined $flag1; # reduce noise if there's a bug
95}
96
97print "parse_trace_flag @names\n";
98ok(eq_set([ keys %flag ], [ @names ]), '...');
99$dbh->{TraceLevel} = 0;
100$dbh->{TraceLevel} = join "|", @names;
101is($dbh->{TraceLevel}, $all_flags, '...');
102
103{
104    print "inherit\n";
105    my $sth = $dbh->prepare("select ctime, name from foo");
106    isa_ok( $sth, 'DBI::st' );
107    is( $sth->{TraceLevel}, $all_flags );
108}
109
110$dbh->{TraceLevel} = 0;
111ok !$dbh->{TraceLevel};
112$dbh->{TraceLevel} = 'ALL';
113ok $dbh->{TraceLevel};
114
115{
116    print "test unknown parse_trace_flag\n";
117    my $warn = 0;
118    local $SIG{__WARN__} = sub {
119        if ($_[0] =~ /unknown/i) { ++$warn; print "caught warn: ",@_ }else{ warn @_ }
120        };
121    is $dbh->parse_trace_flag("nonesuch"), undef;
122    is $warn, 0;
123    is $dbh->parse_trace_flags("nonesuch"), 0;
124    is $warn, 1;
125    is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL");
126    is $warn, 2;
127}
128
129$dbh->dump_handle("dump_handle test, write to log file", 2);
130
131$dbh->trace(0);
132ok !$dbh->{TraceLevel};
133$dbh->trace(undef, "STDERR");	# close $trace_file
134ok( -s $trace_file );
135
1361;
137# end
138