line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
######################################################################## |
2
|
|
|
|
|
|
|
package # hide from PAUSE |
3
|
|
|
|
|
|
|
DBI; |
4
|
|
|
|
|
|
|
# vim: ts=8:sw=4 |
5
|
|
|
|
|
|
|
######################################################################## |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# Copyright (c) 2002,2003 Tim Bunce Ireland. |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# See COPYRIGHT section in DBI.pm for usage and distribution rights. |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
######################################################################## |
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
# Please send patches and bug reports to |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# Jeff Zucker with cc to |
16
|
|
|
|
|
|
|
# |
17
|
|
|
|
|
|
|
######################################################################## |
18
|
|
|
|
|
|
|
|
19
|
90
|
|
|
90
|
|
420
|
use strict; |
|
90
|
|
|
|
|
113
|
|
|
90
|
|
|
|
|
3531
|
|
20
|
90
|
|
|
90
|
|
345
|
use Carp; |
|
90
|
|
|
|
|
112
|
|
|
90
|
|
|
|
|
22131
|
|
21
|
|
|
|
|
|
|
require Symbol; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
require utf8; |
24
|
|
|
|
|
|
|
*utf8::is_utf8 = sub { # hack for perl 5.6 |
25
|
|
|
|
|
|
|
require bytes; |
26
|
|
|
|
|
|
|
return unless defined $_[0]; |
27
|
|
|
|
|
|
|
return !(length($_[0]) == bytes::length($_[0])) |
28
|
|
|
|
|
|
|
} unless defined &utf8::is_utf8; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; |
31
|
|
|
|
|
|
|
$DBI::PurePerl::VERSION = "2.014286"; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
$DBI::neat_maxlen ||= 400; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$DBI::tfh = Symbol::gensym(); |
36
|
|
|
|
|
|
|
open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; |
37
|
|
|
|
|
|
|
select( (select($DBI::tfh), $| = 1)[0] ); # autoflush |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# check for weaken support, used by ChildHandles |
40
|
|
|
|
|
|
|
my $HAS_WEAKEN = eval { |
41
|
|
|
|
|
|
|
require Scalar::Util; |
42
|
|
|
|
|
|
|
# this will croak() if this Scalar::Util doesn't have a working weaken(). |
43
|
|
|
|
|
|
|
Scalar::Util::weaken( my $test = [] ); |
44
|
|
|
|
|
|
|
1; |
45
|
|
|
|
|
|
|
}; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); |
48
|
|
|
|
|
|
|
|
49
|
90
|
|
|
90
|
|
477
|
use constant SQL_ALL_TYPES => 0; |
|
90
|
|
|
|
|
118
|
|
|
90
|
|
|
|
|
5935
|
|
50
|
90
|
|
|
90
|
|
412
|
use constant SQL_ARRAY => 50; |
|
90
|
|
|
|
|
117
|
|
|
90
|
|
|
|
|
3532
|
|
51
|
90
|
|
|
90
|
|
354
|
use constant SQL_ARRAY_LOCATOR => 51; |
|
90
|
|
|
|
|
131
|
|
|
90
|
|
|
|
|
3731
|
|
52
|
90
|
|
|
90
|
|
351
|
use constant SQL_BIGINT => (-5); |
|
90
|
|
|
|
|
128
|
|
|
90
|
|
|
|
|
4002
|
|
53
|
90
|
|
|
90
|
|
369
|
use constant SQL_BINARY => (-2); |
|
90
|
|
|
|
|
110
|
|
|
90
|
|
|
|
|
3578
|
|
54
|
90
|
|
|
90
|
|
351
|
use constant SQL_BIT => (-7); |
|
90
|
|
|
|
|
117
|
|
|
90
|
|
|
|
|
4558
|
|
55
|
90
|
|
|
90
|
|
748
|
use constant SQL_BLOB => 30; |
|
90
|
|
|
|
|
104
|
|
|
90
|
|
|
|
|
4042
|
|
56
|
90
|
|
|
90
|
|
345
|
use constant SQL_BLOB_LOCATOR => 31; |
|
90
|
|
|
|
|
118
|
|
|
90
|
|
|
|
|
4048
|
|
57
|
90
|
|
|
90
|
|
730
|
use constant SQL_BOOLEAN => 16; |
|
90
|
|
|
|
|
105
|
|
|
90
|
|
|
|
|
3859
|
|
58
|
90
|
|
|
90
|
|
345
|
use constant SQL_CHAR => 1; |
|
90
|
|
|
|
|
110
|
|
|
90
|
|
|
|
|
3118
|
|
59
|
90
|
|
|
90
|
|
1606
|
use constant SQL_CLOB => 40; |
|
90
|
|
|
|
|
120
|
|
|
90
|
|
|
|
|
3393
|
|
60
|
90
|
|
|
90
|
|
350
|
use constant SQL_CLOB_LOCATOR => 41; |
|
90
|
|
|
|
|
85
|
|
|
90
|
|
|
|
|
3046
|
|
61
|
90
|
|
|
90
|
|
330
|
use constant SQL_DATE => 9; |
|
90
|
|
|
|
|
467
|
|
|
90
|
|
|
|
|
3347
|
|
62
|
90
|
|
|
90
|
|
349
|
use constant SQL_DATETIME => 9; |
|
90
|
|
|
|
|
116
|
|
|
90
|
|
|
|
|
3520
|
|
63
|
90
|
|
|
90
|
|
329
|
use constant SQL_DECIMAL => 3; |
|
90
|
|
|
|
|
496
|
|
|
90
|
|
|
|
|
3780
|
|
64
|
90
|
|
|
90
|
|
735
|
use constant SQL_DOUBLE => 8; |
|
90
|
|
|
|
|
1088
|
|
|
90
|
|
|
|
|
3524
|
|
65
|
90
|
|
|
90
|
|
387
|
use constant SQL_FLOAT => 6; |
|
90
|
|
|
|
|
503
|
|
|
90
|
|
|
|
|
4340
|
|
66
|
90
|
|
|
90
|
|
378
|
use constant SQL_GUID => (-11); |
|
90
|
|
|
|
|
115
|
|
|
90
|
|
|
|
|
4091
|
|
67
|
90
|
|
|
90
|
|
357
|
use constant SQL_INTEGER => 4; |
|
90
|
|
|
|
|
138
|
|
|
90
|
|
|
|
|
3292
|
|
68
|
90
|
|
|
90
|
|
335
|
use constant SQL_INTERVAL => 10; |
|
90
|
|
|
|
|
95
|
|
|
90
|
|
|
|
|
3140
|
|
69
|
90
|
|
|
90
|
|
343
|
use constant SQL_INTERVAL_DAY => 103; |
|
90
|
|
|
|
|
153
|
|
|
90
|
|
|
|
|
3211
|
|
70
|
90
|
|
|
90
|
|
347
|
use constant SQL_INTERVAL_DAY_TO_HOUR => 108; |
|
90
|
|
|
|
|
104
|
|
|
90
|
|
|
|
|
3225
|
|
71
|
90
|
|
|
90
|
|
321
|
use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; |
|
90
|
|
|
|
|
111
|
|
|
90
|
|
|
|
|
3133
|
|
72
|
90
|
|
|
90
|
|
330
|
use constant SQL_INTERVAL_DAY_TO_SECOND => 110; |
|
90
|
|
|
|
|
100
|
|
|
90
|
|
|
|
|
3125
|
|
73
|
90
|
|
|
90
|
|
312
|
use constant SQL_INTERVAL_HOUR => 104; |
|
90
|
|
|
|
|
101
|
|
|
90
|
|
|
|
|
3055
|
|
74
|
90
|
|
|
90
|
|
331
|
use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; |
|
90
|
|
|
|
|
119
|
|
|
90
|
|
|
|
|
3214
|
|
75
|
90
|
|
|
90
|
|
342
|
use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; |
|
90
|
|
|
|
|
103
|
|
|
90
|
|
|
|
|
3302
|
|
76
|
90
|
|
|
90
|
|
355
|
use constant SQL_INTERVAL_MINUTE => 105; |
|
90
|
|
|
|
|
101
|
|
|
90
|
|
|
|
|
3650
|
|
77
|
90
|
|
|
90
|
|
350
|
use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; |
|
90
|
|
|
|
|
105
|
|
|
90
|
|
|
|
|
3080
|
|
78
|
90
|
|
|
90
|
|
337
|
use constant SQL_INTERVAL_MONTH => 102; |
|
90
|
|
|
|
|
98
|
|
|
90
|
|
|
|
|
3253
|
|
79
|
90
|
|
|
90
|
|
358
|
use constant SQL_INTERVAL_SECOND => 106; |
|
90
|
|
|
|
|
100
|
|
|
90
|
|
|
|
|
3256
|
|
80
|
90
|
|
|
90
|
|
334
|
use constant SQL_INTERVAL_YEAR => 101; |
|
90
|
|
|
|
|
107
|
|
|
90
|
|
|
|
|
3214
|
|
81
|
90
|
|
|
90
|
|
396
|
use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; |
|
90
|
|
|
|
|
103
|
|
|
90
|
|
|
|
|
3483
|
|
82
|
90
|
|
|
90
|
|
350
|
use constant SQL_LONGVARBINARY => (-4); |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3344
|
|
83
|
90
|
|
|
90
|
|
330
|
use constant SQL_LONGVARCHAR => (-1); |
|
90
|
|
|
|
|
194
|
|
|
90
|
|
|
|
|
3355
|
|
84
|
90
|
|
|
90
|
|
323
|
use constant SQL_MULTISET => 55; |
|
90
|
|
|
|
|
121
|
|
|
90
|
|
|
|
|
3162
|
|
85
|
90
|
|
|
90
|
|
332
|
use constant SQL_MULTISET_LOCATOR => 56; |
|
90
|
|
|
|
|
109
|
|
|
90
|
|
|
|
|
3407
|
|
86
|
90
|
|
|
90
|
|
333
|
use constant SQL_NUMERIC => 2; |
|
90
|
|
|
|
|
111
|
|
|
90
|
|
|
|
|
3092
|
|
87
|
90
|
|
|
90
|
|
336
|
use constant SQL_REAL => 7; |
|
90
|
|
|
|
|
99
|
|
|
90
|
|
|
|
|
3117
|
|
88
|
90
|
|
|
90
|
|
349
|
use constant SQL_REF => 20; |
|
90
|
|
|
|
|
138
|
|
|
90
|
|
|
|
|
3202
|
|
89
|
90
|
|
|
90
|
|
346
|
use constant SQL_ROW => 19; |
|
90
|
|
|
|
|
115
|
|
|
90
|
|
|
|
|
3246
|
|
90
|
90
|
|
|
90
|
|
325
|
use constant SQL_SMALLINT => 5; |
|
90
|
|
|
|
|
113
|
|
|
90
|
|
|
|
|
3112
|
|
91
|
90
|
|
|
90
|
|
321
|
use constant SQL_TIME => 10; |
|
90
|
|
|
|
|
108
|
|
|
90
|
|
|
|
|
3192
|
|
92
|
90
|
|
|
90
|
|
334
|
use constant SQL_TIMESTAMP => 11; |
|
90
|
|
|
|
|
92
|
|
|
90
|
|
|
|
|
3297
|
|
93
|
90
|
|
|
90
|
|
352
|
use constant SQL_TINYINT => (-6); |
|
90
|
|
|
|
|
95
|
|
|
90
|
|
|
|
|
3389
|
|
94
|
90
|
|
|
90
|
|
336
|
use constant SQL_TYPE_DATE => 91; |
|
90
|
|
|
|
|
116
|
|
|
90
|
|
|
|
|
3664
|
|
95
|
90
|
|
|
90
|
|
339
|
use constant SQL_TYPE_TIME => 92; |
|
90
|
|
|
|
|
91
|
|
|
90
|
|
|
|
|
3021
|
|
96
|
90
|
|
|
90
|
|
305
|
use constant SQL_TYPE_TIMESTAMP => 93; |
|
90
|
|
|
|
|
157
|
|
|
90
|
|
|
|
|
2995
|
|
97
|
90
|
|
|
90
|
|
355
|
use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; |
|
90
|
|
|
|
|
103
|
|
|
90
|
|
|
|
|
3552
|
|
98
|
90
|
|
|
90
|
|
352
|
use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; |
|
90
|
|
|
|
|
100
|
|
|
90
|
|
|
|
|
3140
|
|
99
|
90
|
|
|
90
|
|
361
|
use constant SQL_UDT => 17; |
|
90
|
|
|
|
|
110
|
|
|
90
|
|
|
|
|
3140
|
|
100
|
90
|
|
|
90
|
|
353
|
use constant SQL_UDT_LOCATOR => 18; |
|
90
|
|
|
|
|
109
|
|
|
90
|
|
|
|
|
2980
|
|
101
|
90
|
|
|
90
|
|
321
|
use constant SQL_UNKNOWN_TYPE => 0; |
|
90
|
|
|
|
|
107
|
|
|
90
|
|
|
|
|
5814
|
|
102
|
90
|
|
|
90
|
|
421
|
use constant SQL_VARBINARY => (-3); |
|
90
|
|
|
|
|
94
|
|
|
90
|
|
|
|
|
3364
|
|
103
|
90
|
|
|
90
|
|
348
|
use constant SQL_VARCHAR => 12; |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3303
|
|
104
|
90
|
|
|
90
|
|
356
|
use constant SQL_WCHAR => (-8); |
|
90
|
|
|
|
|
109
|
|
|
90
|
|
|
|
|
3450
|
|
105
|
90
|
|
|
90
|
|
343
|
use constant SQL_WLONGVARCHAR => (-10); |
|
90
|
|
|
|
|
114
|
|
|
90
|
|
|
|
|
3475
|
|
106
|
90
|
|
|
90
|
|
328
|
use constant SQL_WVARCHAR => (-9); |
|
90
|
|
|
|
|
107
|
|
|
90
|
|
|
|
|
3167
|
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# for Cursor types |
109
|
90
|
|
|
90
|
|
339
|
use constant SQL_CURSOR_FORWARD_ONLY => 0; |
|
90
|
|
|
|
|
104
|
|
|
90
|
|
|
|
|
3109
|
|
110
|
90
|
|
|
90
|
|
345
|
use constant SQL_CURSOR_KEYSET_DRIVEN => 1; |
|
90
|
|
|
|
|
105
|
|
|
90
|
|
|
|
|
3132
|
|
111
|
90
|
|
|
90
|
|
349
|
use constant SQL_CURSOR_DYNAMIC => 2; |
|
90
|
|
|
|
|
93
|
|
|
90
|
|
|
|
|
3141
|
|
112
|
90
|
|
|
90
|
|
321
|
use constant SQL_CURSOR_STATIC => 3; |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
4147
|
|
113
|
90
|
|
|
90
|
|
345
|
use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3581
|
|
114
|
|
|
|
|
|
|
|
115
|
90
|
|
|
90
|
|
351
|
use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ |
|
90
|
|
|
|
|
109
|
|
|
90
|
|
|
|
|
3430
|
|
116
|
90
|
|
|
90
|
|
340
|
use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ |
|
90
|
|
|
|
|
106
|
|
|
90
|
|
|
|
|
3120
|
|
117
|
90
|
|
|
90
|
|
326
|
use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3143
|
|
118
|
90
|
|
|
90
|
|
356
|
use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ |
|
90
|
|
|
|
|
114
|
|
|
90
|
|
|
|
|
3142
|
|
119
|
90
|
|
|
90
|
|
352
|
use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ |
|
90
|
|
|
|
|
109
|
|
|
90
|
|
|
|
|
3288
|
|
120
|
90
|
|
|
90
|
|
329
|
use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3117
|
|
121
|
90
|
|
|
90
|
|
353
|
use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ |
|
90
|
|
|
|
|
102
|
|
|
90
|
|
|
|
|
3143
|
|
122
|
90
|
|
|
90
|
|
370
|
use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ |
|
90
|
|
|
|
|
99
|
|
|
90
|
|
|
|
|
3130
|
|
123
|
90
|
|
|
90
|
|
352
|
use constant IMA_STUB => 0x0100; #/* do nothing eg $dbh->connected */ |
|
90
|
|
|
|
|
123
|
|
|
90
|
|
|
|
|
3216
|
|
124
|
90
|
|
|
90
|
|
337
|
use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ |
|
90
|
|
|
|
|
125
|
|
|
90
|
|
|
|
|
3060
|
|
125
|
90
|
|
|
90
|
|
328
|
use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ |
|
90
|
|
|
|
|
93
|
|
|
90
|
|
|
|
|
3347
|
|
126
|
90
|
|
|
90
|
|
348
|
use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ |
|
90
|
|
|
|
|
103
|
|
|
90
|
|
|
|
|
3175
|
|
127
|
90
|
|
|
90
|
|
319
|
use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ |
|
90
|
|
|
|
|
116
|
|
|
90
|
|
|
|
|
3215
|
|
128
|
90
|
|
|
90
|
|
353
|
use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ |
|
90
|
|
|
|
|
101
|
|
|
90
|
|
|
|
|
3286
|
|
129
|
90
|
|
|
90
|
|
361
|
use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ |
|
90
|
|
|
|
|
101
|
|
|
90
|
|
|
|
|
3220
|
|
130
|
90
|
|
|
90
|
|
395
|
use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ |
|
90
|
|
|
|
|
144
|
|
|
90
|
|
|
|
|
3246
|
|
131
|
90
|
|
|
90
|
|
340
|
use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ |
|
90
|
|
|
|
|
132
|
|
|
90
|
|
|
|
|
3102
|
|
132
|
|
|
|
|
|
|
|
133
|
90
|
|
|
90
|
|
318
|
use constant DBIstcf_STRICT => 0x0001; |
|
90
|
|
|
|
|
97
|
|
|
90
|
|
|
|
|
3119
|
|
134
|
90
|
|
|
90
|
|
399
|
use constant DBIstcf_DISCARD_STRING => 0x0002; |
|
90
|
|
|
|
|
105
|
|
|
90
|
|
|
|
|
67294
|
|
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
my %is_flag_attribute = map {$_ =>1 } qw( |
137
|
|
|
|
|
|
|
Active |
138
|
|
|
|
|
|
|
AutoCommit |
139
|
|
|
|
|
|
|
ChopBlanks |
140
|
|
|
|
|
|
|
CompatMode |
141
|
|
|
|
|
|
|
Executed |
142
|
|
|
|
|
|
|
Taint |
143
|
|
|
|
|
|
|
TaintIn |
144
|
|
|
|
|
|
|
TaintOut |
145
|
|
|
|
|
|
|
InactiveDestroy |
146
|
|
|
|
|
|
|
AutoInactiveDestroy |
147
|
|
|
|
|
|
|
LongTruncOk |
148
|
|
|
|
|
|
|
MultiThread |
149
|
|
|
|
|
|
|
PrintError |
150
|
|
|
|
|
|
|
PrintWarn |
151
|
|
|
|
|
|
|
RaiseError |
152
|
|
|
|
|
|
|
ShowErrorStatement |
153
|
|
|
|
|
|
|
Warn |
154
|
|
|
|
|
|
|
); |
155
|
|
|
|
|
|
|
my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( |
156
|
|
|
|
|
|
|
ActiveKids |
157
|
|
|
|
|
|
|
Attribution |
158
|
|
|
|
|
|
|
BegunWork |
159
|
|
|
|
|
|
|
CachedKids |
160
|
|
|
|
|
|
|
Callbacks |
161
|
|
|
|
|
|
|
ChildHandles |
162
|
|
|
|
|
|
|
CursorName |
163
|
|
|
|
|
|
|
Database |
164
|
|
|
|
|
|
|
DebugDispatch |
165
|
|
|
|
|
|
|
Driver |
166
|
|
|
|
|
|
|
Err |
167
|
|
|
|
|
|
|
Errstr |
168
|
|
|
|
|
|
|
ErrCount |
169
|
|
|
|
|
|
|
FetchHashKeyName |
170
|
|
|
|
|
|
|
HandleError |
171
|
|
|
|
|
|
|
HandleSetErr |
172
|
|
|
|
|
|
|
ImplementorClass |
173
|
|
|
|
|
|
|
Kids |
174
|
|
|
|
|
|
|
LongReadLen |
175
|
|
|
|
|
|
|
NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash |
176
|
|
|
|
|
|
|
NULLABLE |
177
|
|
|
|
|
|
|
NUM_OF_FIELDS |
178
|
|
|
|
|
|
|
NUM_OF_PARAMS |
179
|
|
|
|
|
|
|
Name |
180
|
|
|
|
|
|
|
PRECISION |
181
|
|
|
|
|
|
|
ParamValues |
182
|
|
|
|
|
|
|
Profile |
183
|
|
|
|
|
|
|
Provider |
184
|
|
|
|
|
|
|
ReadOnly |
185
|
|
|
|
|
|
|
RootClass |
186
|
|
|
|
|
|
|
RowCacheSize |
187
|
|
|
|
|
|
|
RowsInCache |
188
|
|
|
|
|
|
|
SCALE |
189
|
|
|
|
|
|
|
State |
190
|
|
|
|
|
|
|
Statement |
191
|
|
|
|
|
|
|
TYPE |
192
|
|
|
|
|
|
|
Type |
193
|
|
|
|
|
|
|
TraceLevel |
194
|
|
|
|
|
|
|
Username |
195
|
|
|
|
|
|
|
Version |
196
|
|
|
|
|
|
|
)); |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub valid_attribute { |
199
|
0
|
|
|
0
|
0
|
0
|
my $attr = shift; |
200
|
0
|
0
|
|
|
|
0
|
return 1 if $is_valid_attribute{$attr}; |
201
|
0
|
0
|
|
|
|
0
|
return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter |
202
|
0
|
|
|
|
|
0
|
return 0 |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
my $initial_setup; |
206
|
|
|
|
|
|
|
sub initial_setup { |
207
|
90
|
|
|
90
|
0
|
208
|
$initial_setup = 1; |
208
|
90
|
50
|
|
|
|
460
|
print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" |
209
|
|
|
|
|
|
|
if $DBI::dbi_debug & 0xF; |
210
|
90
|
|
|
|
|
1052
|
untie $DBI::err; |
211
|
90
|
|
|
|
|
201
|
untie $DBI::errstr; |
212
|
90
|
|
|
|
|
162
|
untie $DBI::state; |
213
|
90
|
|
|
|
|
220
|
untie $DBI::rows; |
214
|
|
|
|
|
|
|
#tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub _install_method { |
218
|
8256
|
|
|
8256
|
|
11644
|
my ( $caller, $method, $from, $param_hash ) = @_; |
219
|
8256
|
100
|
|
|
|
13881
|
initial_setup() unless $initial_setup; |
220
|
|
|
|
|
|
|
|
221
|
8256
|
|
|
|
|
56016
|
my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; |
222
|
8256
|
|
100
|
|
|
26041
|
my $bitmask = $param_hash->{'O'} || 0; |
223
|
8256
|
|
|
|
|
7634
|
my @pre_call_frag; |
224
|
|
|
|
|
|
|
|
225
|
8256
|
100
|
|
|
|
14805
|
return if $method_name eq 'can'; |
226
|
|
|
|
|
|
|
|
227
|
8166
|
100
|
|
|
|
12356
|
push @pre_call_frag, q{ |
228
|
|
|
|
|
|
|
# ignore DESTROY for outer handle (DESTROY for inner likely to follow soon) |
229
|
|
|
|
|
|
|
return if $h_inner; |
230
|
|
|
|
|
|
|
# handle AutoInactiveDestroy and InactiveDestroy |
231
|
|
|
|
|
|
|
$h->{InactiveDestroy} = 1 |
232
|
|
|
|
|
|
|
if $h->{AutoInactiveDestroy} and $$ != $h->{dbi_pp_pid}; |
233
|
|
|
|
|
|
|
$h->{Active} = 0 |
234
|
|
|
|
|
|
|
if $h->{InactiveDestroy}; |
235
|
|
|
|
|
|
|
# copy err/errstr/state up to driver so $DBI::err etc still work |
236
|
|
|
|
|
|
|
if ($h->{err} and my $drh = $h->{Driver}) { |
237
|
|
|
|
|
|
|
$drh->{$_} = $h->{$_} for ('err','errstr','state'); |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} if $method_name eq 'DESTROY'; |
240
|
|
|
|
|
|
|
|
241
|
8166
|
100
|
100
|
|
|
15716
|
push @pre_call_frag, q{ |
242
|
|
|
|
|
|
|
return $h->{$_[0]} if exists $h->{$_[0]}; |
243
|
|
|
|
|
|
|
} if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? |
244
|
|
|
|
|
|
|
|
245
|
8166
|
50
|
|
|
|
13269
|
push @pre_call_frag, "return;" |
246
|
|
|
|
|
|
|
if IMA_STUB & $bitmask; |
247
|
|
|
|
|
|
|
|
248
|
8166
|
100
|
|
|
|
11846
|
push @pre_call_frag, q{ |
249
|
|
|
|
|
|
|
$method_name = pop @_; |
250
|
|
|
|
|
|
|
} if IMA_FUNC_REDIRECT & $bitmask; |
251
|
|
|
|
|
|
|
|
252
|
8166
|
100
|
|
|
|
12351
|
push @pre_call_frag, q{ |
253
|
|
|
|
|
|
|
my $parent_dbh = $h->{Database}; |
254
|
|
|
|
|
|
|
} if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; |
255
|
|
|
|
|
|
|
|
256
|
8166
|
100
|
|
|
|
11696
|
push @pre_call_frag, q{ |
257
|
|
|
|
|
|
|
warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems |
258
|
|
|
|
|
|
|
$parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; |
259
|
|
|
|
|
|
|
} if IMA_COPY_UP_STMT & $bitmask; |
260
|
|
|
|
|
|
|
|
261
|
8166
|
100
|
|
|
|
11529
|
push @pre_call_frag, q{ |
262
|
|
|
|
|
|
|
$h->{Executed} = 1; |
263
|
|
|
|
|
|
|
$parent_dbh->{Executed} = 1 if $parent_dbh; |
264
|
|
|
|
|
|
|
} if IMA_EXECUTE & $bitmask; |
265
|
|
|
|
|
|
|
|
266
|
8166
|
100
|
|
|
|
11536
|
push @pre_call_frag, q{ |
267
|
|
|
|
|
|
|
%{ $h->{CachedKids} } = () if $h->{CachedKids}; |
268
|
|
|
|
|
|
|
} if IMA_CLEAR_CACHED_KIDS & $bitmask; |
269
|
|
|
|
|
|
|
|
270
|
8166
|
100
|
|
|
|
12534
|
if (IMA_KEEP_ERR & $bitmask) { |
271
|
2450
|
|
|
|
|
3581
|
push @pre_call_frag, q{ |
272
|
|
|
|
|
|
|
my $keep_error = DBI::_err_hash($h); |
273
|
|
|
|
|
|
|
}; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
else { |
276
|
5716
|
50
|
|
|
|
8071
|
my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) |
277
|
|
|
|
|
|
|
? q{= ($h->{dbi_pp_parent}->{dbi_pp_call_depth} && DBI::_err_hash($h)) } |
278
|
|
|
|
|
|
|
: ""; |
279
|
5716
|
|
|
|
|
9218
|
push @pre_call_frag, qq{ |
280
|
|
|
|
|
|
|
my \$keep_error $ke_init; |
281
|
|
|
|
|
|
|
}; |
282
|
5716
|
|
|
|
|
4739
|
my $clear_error_code = q{ |
283
|
|
|
|
|
|
|
#warn "$method_name cleared err"; |
284
|
|
|
|
|
|
|
$h->{err} = $DBI::err = undef; |
285
|
|
|
|
|
|
|
$h->{errstr} = $DBI::errstr = undef; |
286
|
|
|
|
|
|
|
$h->{state} = $DBI::state = ''; |
287
|
|
|
|
|
|
|
}; |
288
|
5716
|
100
|
|
|
|
11346
|
$clear_error_code = q{ |
289
|
|
|
|
|
|
|
printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". |
290
|
|
|
|
|
|
|
$h->{err}, $h->{err} |
291
|
|
|
|
|
|
|
if defined $h->{err} && $DBI::dbi_debug & 0xF; |
292
|
|
|
|
|
|
|
}. $clear_error_code |
293
|
|
|
|
|
|
|
if exists $ENV{DBI_TRACE}; |
294
|
5716
|
50
|
|
|
|
14868
|
push @pre_call_frag, ($ke_init) |
|
|
100
|
|
|
|
|
|
295
|
|
|
|
|
|
|
? qq{ unless (\$keep_error) { $clear_error_code }} |
296
|
|
|
|
|
|
|
: $clear_error_code |
297
|
|
|
|
|
|
|
unless $method_name eq 'set_err'; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
8166
|
|
|
|
|
7684
|
push @pre_call_frag, q{ |
301
|
|
|
|
|
|
|
my $ErrCount = $h->{ErrCount}; |
302
|
|
|
|
|
|
|
}; |
303
|
|
|
|
|
|
|
|
304
|
8166
|
100
|
|
|
|
14320
|
push @pre_call_frag, q{ |
305
|
|
|
|
|
|
|
if (($DBI::dbi_debug & 0xF) >= 2) { |
306
|
|
|
|
|
|
|
local $^W; |
307
|
|
|
|
|
|
|
my $args = join " ", map { DBI::neat($_) } ($h, @_); |
308
|
|
|
|
|
|
|
printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
} if exists $ENV{DBI_TRACE}; # note use of 'exists' |
311
|
|
|
|
|
|
|
|
312
|
8166
|
100
|
|
|
|
15208
|
push @pre_call_frag, q{ |
313
|
|
|
|
|
|
|
$h->{'dbi_pp_last_method'} = $method_name; |
314
|
|
|
|
|
|
|
} unless exists $DBI::last_method_except{$method_name}; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# --- post method call code fragments --- |
317
|
8166
|
|
|
|
|
6187
|
my @post_call_frag; |
318
|
|
|
|
|
|
|
|
319
|
8166
|
100
|
|
|
|
12636
|
push @post_call_frag, q{ |
320
|
|
|
|
|
|
|
if (my $trace_level = ($DBI::dbi_debug & 0xF)) { |
321
|
|
|
|
|
|
|
if ($h->{err}) { |
322
|
|
|
|
|
|
|
printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
my $ret = join " ", map { DBI::neat($_) } @ret; |
325
|
|
|
|
|
|
|
my $msg = " < $method_name= $ret"; |
326
|
|
|
|
|
|
|
$msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; |
327
|
|
|
|
|
|
|
print $DBI::tfh $msg; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
} if exists $ENV{DBI_TRACE}; # note use of exists |
330
|
|
|
|
|
|
|
|
331
|
8166
|
100
|
|
|
|
12099
|
push @post_call_frag, q{ |
332
|
|
|
|
|
|
|
$h->{Executed} = 0; |
333
|
|
|
|
|
|
|
if ($h->{BegunWork}) { |
334
|
|
|
|
|
|
|
$h->{BegunWork} = 0; |
335
|
|
|
|
|
|
|
$h->{AutoCommit} = 1; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
} if IMA_END_WORK & $bitmask; |
338
|
|
|
|
|
|
|
|
339
|
8166
|
100
|
|
|
|
11362
|
push @post_call_frag, q{ |
340
|
|
|
|
|
|
|
if ( ref $ret[0] and |
341
|
|
|
|
|
|
|
UNIVERSAL::isa($ret[0], 'DBI::_::common') and |
342
|
|
|
|
|
|
|
defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) |
343
|
|
|
|
|
|
|
) { |
344
|
|
|
|
|
|
|
# copy up info/warn to drh so PrintWarn on connect is triggered |
345
|
|
|
|
|
|
|
$h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
} if IMA_IS_FACTORY & $bitmask; |
348
|
|
|
|
|
|
|
|
349
|
8166
|
|
|
|
|
7269
|
push @post_call_frag, q{ |
350
|
|
|
|
|
|
|
if ($keep_error) { |
351
|
|
|
|
|
|
|
$keep_error = 0 |
352
|
|
|
|
|
|
|
if $h->{ErrCount} > $ErrCount |
353
|
|
|
|
|
|
|
or DBI::_err_hash($h) ne $keep_error; |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
$DBI::err = $h->{err}; |
357
|
|
|
|
|
|
|
$DBI::errstr = $h->{errstr}; |
358
|
|
|
|
|
|
|
$DBI::state = $h->{state}; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
if ( !$keep_error |
361
|
|
|
|
|
|
|
&& defined(my $err = $h->{err}) |
362
|
|
|
|
|
|
|
&& ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) |
363
|
|
|
|
|
|
|
) { |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)}; |
366
|
|
|
|
|
|
|
my $msg; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
if ($err && ($pe || $re || $he) # error |
369
|
|
|
|
|
|
|
or (!$err && length($err) && $pw) # warning |
370
|
|
|
|
|
|
|
) { |
371
|
|
|
|
|
|
|
my $last = ($DBI::last_method_except{$method_name}) |
372
|
|
|
|
|
|
|
? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; |
373
|
|
|
|
|
|
|
my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; |
374
|
|
|
|
|
|
|
my $msg = sprintf "%s %s %s: %s", $imp, $last, |
375
|
|
|
|
|
|
|
($err eq "0") ? "warning" : "failed", $errstr; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { |
378
|
|
|
|
|
|
|
$msg .= ' [for Statement "' . $Statement; |
379
|
|
|
|
|
|
|
if (my $ParamValues = $h->FETCH('ParamValues')) { |
380
|
|
|
|
|
|
|
$msg .= '" with ParamValues: '; |
381
|
|
|
|
|
|
|
$msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); |
382
|
|
|
|
|
|
|
$msg .= "]"; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
else { |
385
|
|
|
|
|
|
|
$msg .= '"]'; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
if ($err eq "0") { # is 'warning' (not info) |
389
|
|
|
|
|
|
|
carp $msg if $pw; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
else { |
392
|
|
|
|
|
|
|
my $do_croak = 1; |
393
|
|
|
|
|
|
|
if (my $subsub = $h->{'HandleError'}) { |
394
|
|
|
|
|
|
|
$do_croak = 0 if &$subsub($msg,$h,$ret[0]); |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
if ($do_croak) { |
397
|
|
|
|
|
|
|
printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" |
398
|
|
|
|
|
|
|
if ($DBI::dbi_debug & 0xF) >= 4; |
399
|
|
|
|
|
|
|
carp $msg if $pe; |
400
|
|
|
|
|
|
|
die $msg if $h->{RaiseError}; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
}; |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
|
408
|
8166
|
100
|
|
|
|
45129
|
my $method_code = q[ |
409
|
|
|
|
|
|
|
sub { |
410
|
|
|
|
|
|
|
my $h = shift; |
411
|
|
|
|
|
|
|
my $h_inner = tied(%$h); |
412
|
|
|
|
|
|
|
$h = $h_inner if $h_inner; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
my $imp; |
415
|
|
|
|
|
|
|
if ($method_name eq 'DESTROY') { |
416
|
|
|
|
|
|
|
# during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" |
417
|
|
|
|
|
|
|
# implying that tied() above lied to us, so we need to use eval |
418
|
|
|
|
|
|
|
local $@; # protect $@ |
419
|
|
|
|
|
|
|
$imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
else { |
422
|
|
|
|
|
|
|
$imp = $h->{"ImplementorClass"} or do { |
423
|
|
|
|
|
|
|
warn "Can't call $method_name method on handle $h after take_imp_data()\n" |
424
|
|
|
|
|
|
|
if not exists $h->{Active}; |
425
|
|
|
|
|
|
|
return; # or, more likely, global destruction |
426
|
|
|
|
|
|
|
}; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
] . join("\n", '', @pre_call_frag, '') . q[ |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
my $call_depth = $h->{'dbi_pp_call_depth'} + 1; |
432
|
|
|
|
|
|
|
local ($h->{'dbi_pp_call_depth'}) = $call_depth; |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
my @ret; |
435
|
|
|
|
|
|
|
my $sub = $imp->can($method_name); |
436
|
|
|
|
|
|
|
if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { |
437
|
|
|
|
|
|
|
push @_, $method_name; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
if ($sub) { |
440
|
|
|
|
|
|
|
(wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
else { |
443
|
|
|
|
|
|
|
# XXX could try explicit fallback to $imp->can('AUTOLOAD') etc |
444
|
|
|
|
|
|
|
# which would then let Multiplex pass PurePerl tests, but some |
445
|
|
|
|
|
|
|
# hook into install_method may be better. |
446
|
|
|
|
|
|
|
croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" |
447
|
|
|
|
|
|
|
if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
] . join("\n", '', @post_call_frag, '') . q[ |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
return (wantarray) ? @ret : $ret[0]; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
]; |
455
|
90
|
|
|
90
|
|
523
|
no strict qw(refs); |
|
90
|
|
|
|
|
207
|
|
|
90
|
|
|
|
|
148062
|
|
456
|
8166
|
|
|
|
|
5397721
|
my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; |
457
|
8166
|
50
|
|
|
|
110636
|
warn "$@\n$method_code\n" if $@; |
458
|
8166
|
50
|
|
|
|
13287
|
die "$@\n$method_code\n" if $@; |
459
|
8166
|
|
|
|
|
35912
|
*$method = $code_ref; |
460
|
8166
|
|
|
|
|
50475
|
if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool |
461
|
|
|
|
|
|
|
my $l=0; # show line-numbered code for method |
462
|
|
|
|
|
|
|
warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
sub _new_handle { |
468
|
2975
|
|
|
2975
|
|
5057
|
my ($class, $parent, $attr, $imp_data, $imp_class) = @_; |
469
|
|
|
|
|
|
|
|
470
|
2975
|
100
|
100
|
|
|
6572
|
DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") |
471
|
|
|
|
|
|
|
if $DBI::dbi_debug >= 3; |
472
|
|
|
|
|
|
|
|
473
|
2975
|
50
|
|
|
|
7806
|
$attr->{ImplementorClass} = $imp_class |
474
|
|
|
|
|
|
|
or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# This is how we create a DBI style Object: |
477
|
|
|
|
|
|
|
# %outer gets tied to %$attr (which becomes the 'inner' handle) |
478
|
2975
|
|
|
|
|
2862
|
my (%outer, $i, $h); |
479
|
2975
|
|
|
|
|
10559
|
$i = tie %outer, $class, $attr; # ref to inner hash (for driver) |
480
|
2975
|
|
|
|
|
5176
|
$h = bless \%outer, $class; # ref to outer hash (for application) |
481
|
|
|
|
|
|
|
# The above tie and bless may migrate down into _setup_handle()... |
482
|
|
|
|
|
|
|
# Now add magic so DBI method dispatch works |
483
|
2975
|
|
|
|
|
5835
|
DBI::_setup_handle($h, $imp_class, $parent, $imp_data); |
484
|
2975
|
100
|
|
|
|
6999
|
return $h unless wantarray; |
485
|
2325
|
|
|
|
|
7752
|
return ($h, $i); |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub _setup_handle { |
489
|
2975
|
|
|
2975
|
|
3903
|
my($h, $imp_class, $parent, $imp_data) = @_; |
490
|
2975
|
|
33
|
|
|
7117
|
my $h_inner = tied(%$h) || $h; |
491
|
2975
|
100
|
|
|
|
6088
|
if (($DBI::dbi_debug & 0xF) >= 4) { |
492
|
3
|
|
|
|
|
8
|
local $^W; |
493
|
3
|
|
|
|
|
40
|
print $DBI::tfh " _setup_handle(@_)\n"; |
494
|
|
|
|
|
|
|
} |
495
|
2975
|
|
|
|
|
4843
|
$h_inner->{"imp_data"} = $imp_data; |
496
|
2975
|
|
|
|
|
3683
|
$h_inner->{"ImplementorClass"} = $imp_class; |
497
|
2975
|
|
|
|
|
5134
|
$h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained |
498
|
2975
|
100
|
|
|
|
4877
|
if ($parent) { |
499
|
2879
|
|
|
|
|
5640
|
foreach (qw( |
500
|
|
|
|
|
|
|
RaiseError PrintError PrintWarn HandleError HandleSetErr |
501
|
|
|
|
|
|
|
Warn LongTruncOk ChopBlanks AutoCommit ReadOnly |
502
|
|
|
|
|
|
|
ShowErrorStatement FetchHashKeyName LongReadLen CompatMode |
503
|
|
|
|
|
|
|
)) { |
504
|
40306
|
100
|
66
|
|
|
125213
|
$h_inner->{$_} = $parent->{$_} |
505
|
|
|
|
|
|
|
if exists $parent->{$_} && !exists $h_inner->{$_}; |
506
|
|
|
|
|
|
|
} |
507
|
2879
|
100
|
|
|
|
15174
|
if (ref($parent) =~ /::db$/) { # is sth |
|
|
50
|
|
|
|
|
|
508
|
2000
|
|
|
|
|
3341
|
$h_inner->{Database} = $parent; |
509
|
2000
|
|
|
|
|
2984
|
$parent->{Statement} = $h_inner->{Statement}; |
510
|
2000
|
|
|
|
|
3661
|
$h_inner->{NUM_OF_PARAMS} = 0; |
511
|
2000
|
|
|
|
|
2748
|
$h_inner->{Active} = 0; # driver sets true when there's data to fetch |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
elsif (ref($parent) =~ /::dr$/){ # is dbh |
514
|
879
|
|
|
|
|
1789
|
$h_inner->{Driver} = $parent; |
515
|
879
|
|
|
|
|
1549
|
$h_inner->{Active} = 0; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
else { |
518
|
0
|
|
|
|
|
0
|
warn "panic: ".ref($parent); # should never happen |
519
|
|
|
|
|
|
|
} |
520
|
2879
|
|
|
|
|
3993
|
$h_inner->{dbi_pp_parent} = $parent; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
# add to the parent's ChildHandles |
523
|
2879
|
50
|
|
|
|
5373
|
if ($HAS_WEAKEN) { |
524
|
2879
|
|
100
|
|
|
7442
|
my $handles = $parent->{ChildHandles} ||= []; |
525
|
2879
|
|
|
|
|
4061
|
push @$handles, $h; |
526
|
2879
|
|
|
|
|
8729
|
Scalar::Util::weaken($handles->[-1]); |
527
|
|
|
|
|
|
|
# purge destroyed handles occasionally |
528
|
2879
|
100
|
|
|
|
7695
|
if (@$handles % 120 == 0) { |
529
|
10
|
|
|
|
|
38
|
@$handles = grep { defined } @$handles; |
|
1200
|
|
|
|
|
1298
|
|
530
|
10
|
|
|
|
|
57
|
Scalar::Util::weaken($_) for @$handles; # re-weaken after grep |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
else { # setting up a driver handle |
535
|
96
|
|
|
|
|
214
|
$h_inner->{Warn} = 1; |
536
|
96
|
|
|
|
|
189
|
$h_inner->{PrintWarn} = 1; |
537
|
96
|
|
|
|
|
188
|
$h_inner->{AutoCommit} = 1; |
538
|
96
|
|
|
|
|
168
|
$h_inner->{TraceLevel} = 0; |
539
|
96
|
|
|
|
|
281
|
$h_inner->{CompatMode} = (1==0); |
540
|
96
|
|
50
|
|
|
277
|
$h_inner->{FetchHashKeyName} ||= 'NAME'; |
541
|
96
|
|
50
|
|
|
499
|
$h_inner->{LongReadLen} ||= 80; |
542
|
96
|
50
|
50
|
|
|
621
|
$h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; |
543
|
96
|
|
50
|
|
|
451
|
$h_inner->{Type} ||= 'dr'; |
544
|
96
|
|
|
|
|
185
|
$h_inner->{Active} = 1; |
545
|
|
|
|
|
|
|
} |
546
|
2975
|
|
|
|
|
4412
|
$h_inner->{"dbi_pp_call_depth"} = 0; |
547
|
2975
|
|
|
|
|
6826
|
$h_inner->{"dbi_pp_pid"} = $$; |
548
|
2975
|
|
|
|
|
5095
|
$h_inner->{ErrCount} = 0; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
sub constant { |
552
|
0
|
|
|
0
|
0
|
0
|
warn "constant(@_) called unexpectedly"; return undef; |
|
0
|
|
|
|
|
0
|
|
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub trace { |
556
|
18
|
|
|
18
|
1
|
10491
|
my ($h, $level, $file) = @_; |
557
|
18
|
50
|
66
|
|
|
84
|
$level = $h->parse_trace_flags($level) |
558
|
|
|
|
|
|
|
if defined $level and !DBI::looks_like_number($level); |
559
|
18
|
|
|
|
|
26
|
my $old_level = $DBI::dbi_debug; |
560
|
18
|
100
|
|
|
|
50
|
_set_trace_file($file) if $level; |
561
|
18
|
100
|
|
|
|
46
|
if (defined $level) { |
562
|
16
|
|
|
|
|
28
|
$DBI::dbi_debug = $level; |
563
|
16
|
100
|
|
|
|
388
|
print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " |
564
|
|
|
|
|
|
|
. "dispatch trace level set to $DBI::dbi_debug\n" |
565
|
|
|
|
|
|
|
if $DBI::dbi_debug & 0xF; |
566
|
|
|
|
|
|
|
} |
567
|
18
|
100
|
|
|
|
91
|
_set_trace_file($file) if !$level; |
568
|
18
|
|
|
|
|
48
|
return $old_level; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub _set_trace_file { |
572
|
38
|
|
|
38
|
|
48
|
my ($file) = @_; |
573
|
|
|
|
|
|
|
# |
574
|
|
|
|
|
|
|
# DAA add support for filehandle inputs |
575
|
|
|
|
|
|
|
# |
576
|
|
|
|
|
|
|
# DAA required to avoid closing a prior fh trace() |
577
|
38
|
100
|
|
|
|
76
|
$DBI::tfh = undef unless $DBI::tfh_needs_close; |
578
|
|
|
|
|
|
|
|
579
|
38
|
100
|
|
|
|
130
|
if (ref $file eq 'GLOB') { |
580
|
8
|
|
|
|
|
8
|
$DBI::tfh = $file; |
581
|
8
|
|
|
|
|
61
|
select((select($DBI::tfh), $| = 1)[0]); |
582
|
8
|
|
|
|
|
39
|
$DBI::tfh_needs_close = 0; |
583
|
8
|
|
|
|
|
13
|
return 1; |
584
|
|
|
|
|
|
|
} |
585
|
30
|
100
|
100
|
|
|
157
|
if ($file && ref \$file eq 'GLOB') { |
586
|
4
|
|
|
|
|
6
|
$DBI::tfh = *{$file}{IO}; |
|
4
|
|
|
|
|
11
|
|
587
|
4
|
|
|
|
|
54
|
select((select($DBI::tfh), $| = 1)[0]); |
588
|
4
|
|
|
|
|
9
|
$DBI::tfh_needs_close = 0; |
589
|
4
|
|
|
|
|
6
|
return 1; |
590
|
|
|
|
|
|
|
} |
591
|
26
|
|
|
|
|
39
|
$DBI::tfh_needs_close = 1; |
592
|
26
|
100
|
100
|
|
|
116
|
if (!$file || $file eq 'STDERR') { |
|
|
100
|
|
|
|
|
|
593
|
12
|
50
|
|
|
|
647
|
open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
elsif ($file eq 'STDOUT') { |
596
|
8
|
50
|
|
|
|
125
|
open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
else { |
599
|
6
|
50
|
|
|
|
399
|
open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; |
600
|
|
|
|
|
|
|
} |
601
|
26
|
|
|
|
|
147
|
select((select($DBI::tfh), $| = 1)[0]); |
602
|
26
|
|
|
|
|
47
|
return 1; |
603
|
|
|
|
|
|
|
} |
604
|
2
|
|
|
2
|
|
1445
|
sub _get_imp_data { shift->{"imp_data"}; } |
605
|
0
|
|
|
0
|
|
0
|
sub _svdump { } |
606
|
|
|
|
|
|
|
sub dump_handle { |
607
|
4
|
|
|
4
|
0
|
160
|
my ($h,$msg,$level) = @_; |
608
|
4
|
|
33
|
|
|
11
|
$msg||="dump_handle $h"; |
609
|
4
|
|
|
|
|
41
|
print $DBI::tfh "$msg:\n"; |
610
|
4
|
|
|
|
|
69
|
for my $attrib (sort keys %$h) { |
611
|
136
|
|
|
|
|
243
|
print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
sub _handles { |
616
|
14
|
|
|
14
|
|
14
|
my $h = shift; |
617
|
14
|
|
|
|
|
21
|
my $h_inner = tied %$h; |
618
|
14
|
50
|
|
|
|
25
|
if ($h_inner) { # this is okay |
619
|
14
|
50
|
|
|
|
27
|
return $h unless wantarray; |
620
|
14
|
|
|
|
|
31
|
return ($h, $h_inner); |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
# XXX this isn't okay... we have an inner handle but |
623
|
|
|
|
|
|
|
# currently have no way to get at its outer handle, |
624
|
|
|
|
|
|
|
# so we just warn and return the inner one for both... |
625
|
0
|
|
|
|
|
0
|
Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); |
626
|
0
|
0
|
|
|
|
0
|
return $h unless wantarray; |
627
|
0
|
|
|
|
|
0
|
return ($h,$h); |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
sub hash { |
631
|
8
|
|
|
8
|
1
|
47272
|
my ($key, $type) = @_; |
632
|
8
|
|
|
|
|
13
|
my ($hash); |
633
|
8
|
100
|
|
|
|
26
|
if (!$type) { |
|
|
50
|
|
|
|
|
|
634
|
6
|
|
|
|
|
5
|
$hash = 0; |
635
|
|
|
|
|
|
|
# XXX The C version uses the "char" type, which could be either |
636
|
|
|
|
|
|
|
# signed or unsigned. I use signed because so do the two |
637
|
|
|
|
|
|
|
# compilers on my system. |
638
|
6
|
|
|
|
|
29
|
for my $char (unpack ("c*", $key)) { |
639
|
24
|
|
|
|
|
36
|
$hash = $hash * 33 + $char; |
640
|
|
|
|
|
|
|
} |
641
|
6
|
|
|
|
|
11
|
$hash &= 0x7FFFFFFF; # limit to 31 bits |
642
|
6
|
|
|
|
|
7
|
$hash |= 0x40000000; # set bit 31 |
643
|
6
|
|
|
|
|
29
|
return -$hash; # return negative int |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
elsif ($type == 1) { # Fowler/Noll/Vo hash |
646
|
|
|
|
|
|
|
# see http://www.isthe.com/chongo/tech/comp/fnv/ |
647
|
2
|
|
|
|
|
22
|
require Math::BigInt; # feel free to reimplement w/o BigInt! |
648
|
2
|
|
50
|
|
|
12
|
(my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01" |
649
|
2
|
50
|
|
|
|
72
|
if ($version >= 1.56) { |
650
|
2
|
|
|
|
|
10
|
$hash = Math::BigInt->new(0x811c9dc5); |
651
|
2
|
|
|
|
|
29027
|
for my $uchar (unpack ("C*", $key)) { |
652
|
|
|
|
|
|
|
# multiply by the 32 bit FNV magic prime mod 2^64 |
653
|
10
|
|
|
|
|
1339
|
$hash = ($hash * 0x01000193) & 0xffffffff; |
654
|
|
|
|
|
|
|
# xor the bottom with the current octet |
655
|
10
|
|
|
|
|
3576
|
$hash ^= $uchar; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
# cast to int |
658
|
2
|
|
|
|
|
391
|
return unpack "i", pack "i", $hash; |
659
|
|
|
|
|
|
|
} |
660
|
0
|
|
|
|
|
0
|
croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)"); |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
else { |
663
|
0
|
|
|
|
|
0
|
croak("bad hash type $type"); |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
sub looks_like_number { |
668
|
4882
|
|
|
4882
|
1
|
58266
|
my @new = (); |
669
|
4882
|
|
|
|
|
4275
|
for my $thing(@_) { |
670
|
4894
|
100
|
100
|
|
|
12739
|
if (!defined $thing or $thing eq '') { |
671
|
8
|
|
|
|
|
21
|
push @new, undef; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
else { |
674
|
4886
|
100
|
|
|
|
14827
|
push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
} |
677
|
4882
|
100
|
|
|
|
13098
|
return (@_ >1) ? @new : $new[0]; |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
sub neat { |
681
|
5595
|
|
|
5595
|
1
|
13955
|
my $v = shift; |
682
|
5595
|
100
|
|
|
|
9117
|
return "undef" unless defined $v; |
683
|
1213
|
|
|
|
|
1053
|
my $quote = q{"}; |
684
|
1213
|
50
|
|
|
|
2253
|
if (not utf8::is_utf8($v)) { |
685
|
1213
|
100
|
|
|
|
4531
|
return $v if (($v & ~ $v) eq "0"); # is SvNIOK |
686
|
616
|
|
|
|
|
670
|
$quote = q{'}; |
687
|
|
|
|
|
|
|
} |
688
|
616
|
|
66
|
|
|
1204
|
my $maxlen = shift || $DBI::neat_maxlen; |
689
|
616
|
100
|
66
|
|
|
2343
|
if ($maxlen && $maxlen < length($v) + 2) { |
690
|
4
|
|
|
|
|
14
|
$v = substr($v,0,$maxlen-5); |
691
|
4
|
|
|
|
|
7
|
$v .= '...'; |
692
|
|
|
|
|
|
|
} |
693
|
616
|
|
|
|
|
996
|
$v =~ s/[^[:print:]]/./g; |
694
|
616
|
|
|
|
|
2199
|
return "$quote$v$quote"; |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
sub sql_type_cast { |
698
|
28
|
|
|
28
|
1
|
16560
|
my (undef, $sql_type, $flags) = @_; |
699
|
|
|
|
|
|
|
|
700
|
28
|
100
|
|
|
|
70
|
return -1 unless defined $_[0]; |
701
|
|
|
|
|
|
|
|
702
|
26
|
|
|
|
|
29
|
my $cast_ok = 1; |
703
|
|
|
|
|
|
|
|
704
|
26
|
100
|
33
|
|
|
28
|
my $evalret = eval { |
705
|
90
|
|
|
90
|
|
540
|
use warnings FATAL => qw(numeric); |
|
90
|
|
|
|
|
134
|
|
|
90
|
|
|
|
|
38067
|
|
706
|
26
|
100
|
|
|
|
57
|
if ($sql_type == SQL_INTEGER) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
707
|
16
|
|
|
|
|
66
|
my $dummy = $_[0] + 0; |
708
|
12
|
|
|
|
|
28
|
return 1; |
709
|
|
|
|
|
|
|
} |
710
|
|
|
|
|
|
|
elsif ($sql_type == SQL_DOUBLE) { |
711
|
4
|
|
|
|
|
45
|
my $dummy = $_[0] + 0.0; |
712
|
0
|
|
|
|
|
0
|
return 1; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
elsif ($sql_type == SQL_NUMERIC) { |
715
|
4
|
|
|
|
|
46
|
my $dummy = $_[0] + 0.0; |
716
|
0
|
|
|
|
|
0
|
return 1; |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
else { |
719
|
2
|
|
|
|
|
9
|
return -2; |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
} or $^W && warn $@; # XXX warnings::warnif("numeric", $@) ? |
722
|
|
|
|
|
|
|
|
723
|
26
|
100
|
100
|
|
|
90
|
return $evalret if defined($evalret) && ($evalret == -2); |
724
|
24
|
100
|
|
|
|
39
|
$cast_ok = 0 unless $evalret; |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
# DBIstcf_DISCARD_STRING not supported for PurePerl currently |
727
|
|
|
|
|
|
|
|
728
|
24
|
100
|
|
|
|
54
|
return 2 if $cast_ok; |
729
|
12
|
100
|
|
|
|
32
|
return 0 if $flags & DBIstcf_STRICT; |
730
|
6
|
|
|
|
|
16
|
return 1; |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
sub dbi_time { |
734
|
0
|
|
|
0
|
0
|
0
|
return time(); |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
2975
|
|
|
2975
|
|
8132
|
sub DBI::st::TIEHASH { bless $_[1] => $_[0] }; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
sub _concat_hash_sorted { |
740
|
222
|
|
|
222
|
|
27979
|
my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; |
741
|
|
|
|
|
|
|
# $num_sort: 0=lexical, 1=numeric, undef=try to guess |
742
|
|
|
|
|
|
|
|
743
|
222
|
100
|
|
|
|
632
|
return undef unless defined $hash_ref; |
744
|
211
|
100
|
|
|
|
572
|
die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; |
745
|
209
|
|
|
|
|
447
|
my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); |
746
|
209
|
|
|
|
|
284
|
my $string = ''; |
747
|
209
|
|
|
|
|
411
|
for my $key (@$keys) { |
748
|
5630
|
100
|
|
|
|
7892
|
$string .= $pair_separator if length $string > 0; |
749
|
5630
|
|
|
|
|
4676
|
my $value = $hash_ref->{$key}; |
750
|
5630
|
100
|
|
|
|
5159
|
if ($use_neat) { |
751
|
4412
|
|
|
|
|
4037
|
$value = DBI::neat($value, 0); |
752
|
|
|
|
|
|
|
} |
753
|
|
|
|
|
|
|
else { |
754
|
1218
|
100
|
|
|
|
1742
|
$value = (defined $value) ? "'$value'" : 'undef'; |
755
|
|
|
|
|
|
|
} |
756
|
5630
|
|
|
|
|
8297
|
$string .= $key . $kv_separator . $value; |
757
|
|
|
|
|
|
|
} |
758
|
209
|
|
|
|
|
3295
|
return $string; |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
sub _get_sorted_hash_keys { |
762
|
209
|
|
|
209
|
|
248
|
my ($hash_ref, $num_sort) = @_; |
763
|
209
|
100
|
|
|
|
413
|
if (not defined $num_sort) { |
764
|
50
|
|
|
|
|
46
|
my $sort_guess = 1; |
765
|
|
|
|
|
|
|
$sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess |
766
|
50
|
100
|
|
|
|
564
|
for keys %$hash_ref; |
767
|
50
|
|
|
|
|
278
|
$num_sort = $sort_guess; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
209
|
|
|
|
|
1476
|
my @keys = keys %$hash_ref; |
771
|
90
|
|
|
90
|
|
488
|
no warnings 'numeric'; |
|
90
|
|
|
|
|
107
|
|
|
90
|
|
|
|
|
190601
|
|
772
|
36341
|
50
|
|
|
|
40828
|
my @sorted = ($num_sort) |
773
|
209
|
100
|
|
|
|
1251
|
? sort { $a <=> $b or $a cmp $b } @keys |
774
|
|
|
|
|
|
|
: sort @keys; |
775
|
209
|
|
|
|
|
635
|
return \@sorted; |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
sub _err_hash { |
779
|
72182
|
100
|
|
72182
|
|
4247046
|
return 1 unless defined $_[0]->{err}; |
780
|
863
|
|
|
|
|
2645
|
return "$_[0]->{err} $_[0]->{errstr}" |
781
|
|
|
|
|
|
|
} |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
package |
785
|
|
|
|
|
|
|
DBI::var; |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
sub FETCH { |
788
|
0
|
|
|
0
|
|
0
|
my($key)=shift; |
789
|
0
|
0
|
|
|
|
0
|
return $DBI::err if $$key eq '*err'; |
790
|
0
|
0
|
|
|
|
0
|
return $DBI::errstr if $$key eq '&errstr'; |
791
|
0
|
|
|
|
|
0
|
Carp::confess("FETCH $key not supported when using DBI::PurePerl"); |
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
package |
795
|
|
|
|
|
|
|
DBD::_::common; |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
sub swap_inner_handle { |
798
|
0
|
|
|
0
|
|
0
|
my ($h1, $h2) = @_; |
799
|
|
|
|
|
|
|
# can't make this work till we can get the outer handle from the inner one |
800
|
|
|
|
|
|
|
# probably via a WeakRef |
801
|
0
|
|
|
|
|
0
|
return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl"); |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
sub trace { # XXX should set per-handle level, not global |
805
|
160
|
|
|
160
|
|
2111
|
my ($h, $level, $file) = @_; |
806
|
160
|
100
|
100
|
|
|
447
|
$level = $h->parse_trace_flags($level) |
807
|
|
|
|
|
|
|
if defined $level and !DBI::looks_like_number($level); |
808
|
160
|
|
|
|
|
354
|
my $old_level = $DBI::dbi_debug; |
809
|
160
|
100
|
|
|
|
267
|
DBI::_set_trace_file($file) if defined $file; |
810
|
160
|
100
|
|
|
|
268
|
if (defined $level) { |
811
|
116
|
|
|
|
|
116
|
$DBI::dbi_debug = $level; |
812
|
116
|
100
|
|
|
|
193
|
if ($DBI::dbi_debug) { |
813
|
78
|
|
|
|
|
2682
|
printf $DBI::tfh |
814
|
|
|
|
|
|
|
" %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n", |
815
|
|
|
|
|
|
|
$h, $DBI::dbi_debug; |
816
|
78
|
100
|
|
|
|
976
|
print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n" |
817
|
|
|
|
|
|
|
unless exists $ENV{DBI_TRACE}; |
818
|
|
|
|
|
|
|
} |
819
|
|
|
|
|
|
|
} |
820
|
160
|
|
|
|
|
543
|
return $old_level; |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
*debug = \&trace; *debug = \&trace; # twice to avoid typo warning |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
sub FETCH { |
825
|
4334
|
|
|
4334
|
|
10250
|
my($h,$key)= @_; |
826
|
4334
|
|
|
|
|
5086
|
my $v = $h->{$key}; |
827
|
|
|
|
|
|
|
#warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n"); |
828
|
4334
|
100
|
|
|
|
8811
|
return $v if defined $v; |
829
|
3698
|
100
|
|
|
|
8066
|
if ($key =~ /^NAME_.c$/) { |
830
|
105
|
|
|
|
|
298
|
my $cols = $h->FETCH('NAME'); |
831
|
105
|
100
|
|
|
|
840
|
return undef unless $cols; |
832
|
101
|
|
|
|
|
181
|
my @lcols = map { lc $_ } @$cols; |
|
273
|
|
|
|
|
596
|
|
833
|
101
|
|
|
|
|
273
|
$h->{NAME_lc} = \@lcols; |
834
|
101
|
|
|
|
|
161
|
my @ucols = map { uc $_ } @$cols; |
|
273
|
|
|
|
|
420
|
|
835
|
101
|
|
|
|
|
218
|
$h->{NAME_uc} = \@ucols; |
836
|
101
|
|
|
|
|
247
|
return $h->FETCH($key); |
837
|
|
|
|
|
|
|
} |
838
|
3593
|
100
|
|
|
|
6874
|
if ($key =~ /^NAME.*_hash$/) { |
839
|
60
|
|
|
|
|
111
|
my $i=0; |
840
|
60
|
100
|
|
|
|
103
|
for my $c(@{$h->FETCH('NAME')||[]}) { |
|
60
|
|
|
|
|
286
|
|
841
|
124
|
|
|
|
|
922
|
$h->{'NAME_hash'}->{$c} = $i; |
842
|
124
|
|
|
|
|
381
|
$h->{'NAME_lc_hash'}->{"\L$c"} = $i; |
843
|
124
|
|
|
|
|
342
|
$h->{'NAME_uc_hash'}->{"\U$c"} = $i; |
844
|
124
|
|
|
|
|
223
|
$i++; |
845
|
|
|
|
|
|
|
} |
846
|
60
|
|
|
|
|
326
|
return $h->{$key}; |
847
|
|
|
|
|
|
|
} |
848
|
3533
|
50
|
33
|
|
|
10857
|
if (!defined $v && !exists $h->{$key}) { |
849
|
3533
|
100
|
33
|
|
|
5656
|
return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint'; |
850
|
3525
|
100
|
|
|
|
9050
|
return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef |
851
|
2377
|
100
|
|
|
|
4090
|
return $DBI::dbi_debug if $key eq 'TraceLevel'; |
852
|
2279
|
100
|
66
|
|
|
5002
|
return [] if $key eq 'ChildHandles' && $HAS_WEAKEN; |
853
|
2237
|
100
|
|
|
|
3599
|
if ($key eq 'Type') { |
854
|
50
|
50
|
|
|
|
192
|
return "dr" if $h->isa('DBI::dr'); |
855
|
50
|
100
|
|
|
|
137
|
return "db" if $h->isa('DBI::db'); |
856
|
44
|
50
|
|
|
|
185
|
return "st" if $h->isa('DBI::st'); |
857
|
0
|
|
|
|
|
0
|
Carp::carp( sprintf "Can't determine Type for %s",$h ); |
858
|
|
|
|
|
|
|
} |
859
|
2187
|
100
|
100
|
|
|
6886
|
if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) { |
860
|
2
|
|
|
|
|
7
|
local $^W; # hide undef warnings |
861
|
2
|
|
|
|
|
6
|
Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key ) |
|
2
|
|
|
|
|
315
|
|
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
} |
864
|
2187
|
|
|
|
|
5838
|
return $v; |
865
|
|
|
|
|
|
|
} |
866
|
|
|
|
|
|
|
sub STORE { |
867
|
13271
|
|
|
13271
|
|
19739
|
my ($h,$key,$value) = @_; |
868
|
13271
|
100
|
100
|
|
|
71990
|
if ($key eq 'AutoCommit') { |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
869
|
547
|
50
|
66
|
|
|
3088
|
Carp::croak("DBD driver has not implemented the AutoCommit attribute") |
870
|
|
|
|
|
|
|
unless $value == -900 || $value == -901; |
871
|
547
|
|
|
|
|
922
|
$value = ($value == -901); |
872
|
|
|
|
|
|
|
} |
873
|
|
|
|
|
|
|
elsif ($key =~ /^Taint/ ) { |
874
|
24
|
50
|
|
|
|
45
|
Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key) |
875
|
|
|
|
|
|
|
if $value; |
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
elsif ($key eq 'TraceLevel') { |
878
|
94
|
|
|
|
|
278
|
$h->trace($value); |
879
|
94
|
|
|
|
|
731
|
return 1; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
elsif ($key eq 'NUM_OF_FIELDS') { |
882
|
2090
|
|
|
|
|
3763
|
$h->{$key} = $value; |
883
|
2090
|
100
|
|
|
|
3700
|
if ($value) { |
884
|
1605
|
|
|
|
|
2771
|
my $fbav = DBD::_::st::dbih_setup_fbav($h); |
885
|
1605
|
100
|
|
|
|
4043
|
@$fbav = (undef) x $value if @$fbav != $value; |
886
|
|
|
|
|
|
|
} |
887
|
2090
|
|
|
|
|
5528
|
return 1; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) { |
890
|
2
|
|
|
|
|
470
|
Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s", |
891
|
|
|
|
|
|
|
$h,$key,$value); |
892
|
|
|
|
|
|
|
} |
893
|
11087
|
100
|
|
|
|
26166
|
$h->{$key} = $is_flag_attribute{$key} ? !!$value : $value; |
894
|
11087
|
|
|
|
|
26848
|
return 1; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
sub DELETE { |
897
|
4
|
|
|
4
|
|
68
|
my ($h, $key) = @_; |
898
|
4
|
100
|
|
|
|
24
|
return $h->FETCH($key) unless $key =~ /^private_/; |
899
|
2
|
|
|
|
|
9
|
return delete $h->{$key}; |
900
|
|
|
|
|
|
|
} |
901
|
55
|
|
|
55
|
|
944
|
sub err { return shift->{err} } |
902
|
70
|
|
|
70
|
|
1198
|
sub errstr { return shift->{errstr} } |
903
|
10
|
|
|
10
|
|
266
|
sub state { return shift->{state} } |
904
|
|
|
|
|
|
|
sub set_err { |
905
|
1129
|
|
|
1129
|
|
60150
|
my ($h, $errnum,$msg,$state, $method, $rv) = @_; |
906
|
1129
|
|
33
|
|
|
4248
|
$h = tied(%$h) || $h; |
907
|
|
|
|
|
|
|
|
908
|
1129
|
100
|
|
|
|
2723
|
if (my $hss = $h->{HandleSetErr}) { |
909
|
38
|
100
|
|
|
|
78
|
return if $hss->($h, $errnum, $msg, $state, $method); |
910
|
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
|
|
912
|
1127
|
100
|
|
|
|
4747
|
if (!defined $errnum) { |
913
|
787
|
|
|
|
|
1479
|
$h->{err} = $DBI::err = undef; |
914
|
787
|
|
|
|
|
1067
|
$h->{errstr} = $DBI::errstr = undef; |
915
|
787
|
|
|
|
|
1283
|
$h->{state} = $DBI::state = ''; |
916
|
787
|
|
|
|
|
2033
|
return; |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
340
|
100
|
|
|
|
768
|
if ($h->{errstr}) { |
920
|
27
|
100
|
100
|
|
|
206
|
$h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum |
|
|
|
100
|
|
|
|
|
921
|
|
|
|
|
|
|
if $h->{err} && $errnum && $h->{err} ne $errnum; |
922
|
27
|
100
|
100
|
|
|
182
|
$h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
923
|
|
|
|
|
|
|
if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state; |
924
|
27
|
100
|
|
|
|
85
|
$h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg; |
925
|
27
|
|
|
|
|
51
|
$DBI::errstr = $h->{errstr}; |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
else { |
928
|
313
|
|
|
|
|
832
|
$h->{errstr} = $DBI::errstr = $msg; |
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
# assign if higher priority: err > "0" > "" > undef |
932
|
340
|
|
|
|
|
609
|
my $err_changed; |
933
|
340
|
100
|
100
|
|
|
987
|
if ($errnum # new error: so assign |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
934
|
|
|
|
|
|
|
or !defined $h->{err} # no existing warn/info: so assign |
935
|
|
|
|
|
|
|
# new warn ("0" len 1) > info ("" len 0): so assign |
936
|
|
|
|
|
|
|
or defined $errnum && length($errnum) > length($h->{err}) |
937
|
|
|
|
|
|
|
) { |
938
|
331
|
|
|
|
|
529
|
$h->{err} = $DBI::err = $errnum; |
939
|
331
|
100
|
|
|
|
699
|
++$h->{ErrCount} if $errnum; |
940
|
331
|
|
|
|
|
398
|
++$err_changed; |
941
|
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
|
|
943
|
340
|
100
|
|
|
|
634
|
if ($err_changed) { |
944
|
331
|
100
|
100
|
|
|
1192
|
$state ||= "S1000" if $DBI::err; |
945
|
331
|
100
|
|
|
|
1081
|
$h->{state} = $DBI::state = ($state eq "00000") ? "" : $state |
|
|
100
|
|
|
|
|
|
946
|
|
|
|
|
|
|
if $state; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
340
|
100
|
|
|
|
828
|
if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY) |
950
|
198
|
|
|
|
|
288
|
$p->{err} = $DBI::err; |
951
|
198
|
|
|
|
|
269
|
$p->{errstr} = $DBI::errstr; |
952
|
198
|
|
|
|
|
300
|
$p->{state} = $DBI::state; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
340
|
|
|
|
|
446
|
$h->{'dbi_pp_last_method'} = $method; |
956
|
340
|
|
|
|
|
1033
|
return $rv; # usually undef |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
sub trace_msg { |
959
|
4374
|
|
|
4374
|
|
22636
|
my ($h, $msg, $minlevel)=@_; |
960
|
4374
|
100
|
|
|
|
8936
|
$minlevel = 1 unless defined $minlevel; |
961
|
4374
|
100
|
|
|
|
12891
|
return unless $minlevel <= ($DBI::dbi_debug & 0xF); |
962
|
73
|
|
|
|
|
1341
|
print $DBI::tfh $msg; |
963
|
73
|
|
|
|
|
212
|
return 1; |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
sub private_data { |
966
|
0
|
|
|
0
|
|
0
|
warn "private_data @_"; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
sub take_imp_data { |
969
|
1
|
|
|
1
|
|
1916
|
my $dbh = shift; |
970
|
|
|
|
|
|
|
# A reasonable default implementation based on the one in DBI.xs. |
971
|
|
|
|
|
|
|
# Typically a pure-perl driver would have their own take_imp_data method |
972
|
|
|
|
|
|
|
# that would delete all but the essential items in the hash before ending with: |
973
|
|
|
|
|
|
|
# return $dbh->SUPER::take_imp_data(); |
974
|
|
|
|
|
|
|
# Of course it's useless if the driver doesn't also implement support for |
975
|
|
|
|
|
|
|
# the dbi_imp_data attribute to the connect() method. |
976
|
1
|
|
|
|
|
725
|
require Storable; |
977
|
1
|
50
|
|
|
|
2636
|
croak("Can't take_imp_data from handle that's not Active") |
978
|
|
|
|
|
|
|
unless $dbh->{Active}; |
979
|
1
|
50
|
|
|
|
2
|
for my $sth (@{ $dbh->{ChildHandles} || [] }) { |
|
1
|
|
|
|
|
5
|
|
980
|
3
|
100
|
|
|
|
6
|
next unless $sth; |
981
|
2
|
100
|
|
|
|
12
|
$sth->finish if $sth->{Active}; |
982
|
2
|
|
|
|
|
29
|
bless $sth, 'DBI::zombie'; |
983
|
|
|
|
|
|
|
} |
984
|
1
|
|
|
|
|
27
|
delete $dbh->{$_} for (keys %is_valid_attribute); |
985
|
1
|
|
|
|
|
6
|
delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh; |
|
11
|
|
|
|
|
40
|
|
986
|
|
|
|
|
|
|
# warn "@{[ %$dbh ]}"; |
987
|
1
|
|
|
|
|
3
|
local $Storable::forgive_me = 1; # in case there are some CODE refs |
988
|
1
|
|
|
|
|
3
|
my $imp_data = Storable::freeze($dbh); |
989
|
|
|
|
|
|
|
# XXX um, should probably untie here - need to check dispatch behaviour |
990
|
1
|
|
|
|
|
84
|
return $imp_data; |
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
sub rows { |
993
|
0
|
|
|
0
|
|
0
|
return -1; # always returns -1 here, see DBD::_::st::rows below |
994
|
|
|
|
|
|
|
} |
995
|
1993
|
|
|
1993
|
|
23973
|
sub DESTROY { |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
package |
999
|
|
|
|
|
|
|
DBD::_::dr; |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
sub dbixs_revision { |
1002
|
4
|
|
|
4
|
|
76
|
return 0; |
1003
|
|
|
|
|
|
|
} |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
package |
1006
|
|
|
|
|
|
|
DBD::_::db; |
1007
|
|
|
|
|
|
|
|
1008
|
634
|
|
|
634
|
|
9620
|
sub connected { |
1009
|
|
|
|
|
|
|
} |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
package |
1013
|
|
|
|
|
|
|
DBD::_::st; |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
sub fetchrow_arrayref { |
1016
|
0
|
|
|
0
|
|
0
|
my $h = shift; |
1017
|
|
|
|
|
|
|
# if we're here then driver hasn't implemented fetch/fetchrow_arrayref |
1018
|
|
|
|
|
|
|
# so we assume they've implemented fetchrow_array and call that instead |
1019
|
0
|
0
|
|
|
|
0
|
my @row = $h->fetchrow_array or return; |
1020
|
0
|
|
|
|
|
0
|
return $h->_set_fbav(\@row); |
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
# twice to avoid typo warning |
1023
|
|
|
|
|
|
|
*fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref; |
1024
|
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
sub fetchrow_array { |
1026
|
4
|
|
|
4
|
|
1843
|
my $h = shift; |
1027
|
|
|
|
|
|
|
# if we're here then driver hasn't implemented fetchrow_array |
1028
|
|
|
|
|
|
|
# so we assume they've implemented fetch/fetchrow_arrayref |
1029
|
4
|
50
|
|
|
|
18
|
my $row = $h->fetch or return; |
1030
|
4
|
|
|
|
|
93
|
return @$row; |
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array; |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
sub fetchrow_hashref { |
1035
|
26
|
|
|
26
|
|
5317
|
my $h = shift; |
1036
|
26
|
100
|
|
|
|
62
|
my $row = $h->fetch or return; |
1037
|
24
|
|
|
|
|
408
|
my $FetchCase = shift; |
1038
|
24
|
|
50
|
|
|
116
|
my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME'; |
1039
|
24
|
|
|
|
|
75
|
my $FetchHashKeys = $h->FETCH($FetchHashKeyName); |
1040
|
24
|
|
|
|
|
177
|
my %rowhash; |
1041
|
24
|
|
|
|
|
123
|
@rowhash{ @$FetchHashKeys } = @$row; |
1042
|
22
|
|
|
|
|
69
|
return \%rowhash; |
1043
|
|
|
|
|
|
|
} |
1044
|
|
|
|
|
|
|
sub dbih_setup_fbav { |
1045
|
1805
|
|
|
1805
|
|
1828
|
my $h = shift; |
1046
|
1805
|
|
66
|
|
|
4461
|
return $h->{'_fbav'} || do { |
1047
|
|
|
|
|
|
|
$DBI::rows = $h->{'_rows'} = 0; |
1048
|
|
|
|
|
|
|
my $fields = $h->{'NUM_OF_FIELDS'} |
1049
|
|
|
|
|
|
|
or DBI::croak("NUM_OF_FIELDS not set"); |
1050
|
|
|
|
|
|
|
my @row = (undef) x $fields; |
1051
|
|
|
|
|
|
|
\@row; |
1052
|
|
|
|
|
|
|
}; |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
sub _get_fbav { |
1055
|
140
|
|
|
140
|
|
6443
|
my $h = shift; |
1056
|
140
|
|
66
|
|
|
758
|
my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h); |
1057
|
140
|
|
|
|
|
282
|
$DBI::rows = ++$h->{'_rows'}; |
1058
|
140
|
|
|
|
|
1193
|
return $av; |
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
sub _set_fbav { |
1061
|
1522
|
|
|
1522
|
|
24332
|
my $h = shift; |
1062
|
1522
|
|
|
|
|
1615
|
my $fbav = $h->{'_fbav'}; |
1063
|
1522
|
100
|
|
|
|
1924
|
if ($fbav) { |
1064
|
1388
|
|
|
|
|
1641
|
$DBI::rows = ++$h->{'_rows'}; |
1065
|
|
|
|
|
|
|
} |
1066
|
|
|
|
|
|
|
else { |
1067
|
134
|
|
|
|
|
572
|
$fbav = $h->_get_fbav; |
1068
|
|
|
|
|
|
|
} |
1069
|
1522
|
|
|
|
|
2521
|
my $row = shift; |
1070
|
1522
|
100
|
|
|
|
2284
|
if (my $bc = $h->{'_bound_cols'}) { |
1071
|
182
|
|
|
|
|
433
|
for my $i (0..@$row-1) { |
1072
|
474
|
|
|
|
|
445
|
my $bound = $bc->[$i]; |
1073
|
474
|
100
|
|
|
|
1098
|
$fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i]; |
1074
|
|
|
|
|
|
|
} |
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
else { |
1077
|
1340
|
|
|
|
|
2430
|
@$fbav = @$row; |
1078
|
|
|
|
|
|
|
} |
1079
|
1522
|
|
|
|
|
3127
|
return $fbav; |
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
sub bind_col { |
1082
|
162
|
|
|
162
|
|
7137
|
my ($h, $col, $value_ref,$from_bind_columns) = @_; |
1083
|
162
|
|
66
|
|
|
521
|
my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() |
1084
|
162
|
|
|
|
|
208
|
my $num_of_fields = @$fbav; |
1085
|
162
|
100
|
100
|
|
|
1668
|
DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") |
1086
|
|
|
|
|
|
|
if $col < 1 or $col > $num_of_fields; |
1087
|
156
|
100
|
|
|
|
330
|
return 1 if not defined $value_ref; # ie caller is just trying to set TYPE |
1088
|
154
|
50
|
|
|
|
341
|
DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar") |
1089
|
|
|
|
|
|
|
unless ref $value_ref eq 'SCALAR'; |
1090
|
154
|
|
|
|
|
330
|
$h->{'_bound_cols'}->[$col-1] = $value_ref; |
1091
|
154
|
|
|
|
|
368
|
return 1; |
1092
|
|
|
|
|
|
|
} |
1093
|
|
|
|
|
|
|
sub finish { |
1094
|
1204
|
|
|
1204
|
|
24471
|
my $h = shift; |
1095
|
1204
|
|
|
|
|
1973
|
$h->{'_fbav'} = undef; |
1096
|
1204
|
|
|
|
|
1808
|
$h->{'Active'} = 0; |
1097
|
1204
|
|
|
|
|
2711
|
return 1; |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
sub rows { |
1100
|
3
|
|
|
3
|
|
56
|
my $h = shift; |
1101
|
3
|
|
|
|
|
6
|
my $rows = $h->{'_rows'}; |
1102
|
3
|
50
|
|
|
|
16
|
return -1 unless defined $rows; |
1103
|
3
|
|
|
|
|
8
|
return $rows; |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
1; |
1107
|
|
|
|
|
|
|
__END__ |