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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
{
package DBD::NullP;
require DBI;
require Carp;
@EXPORT = qw(); # Do NOT @EXPORT anything.
$VERSION = sprintf("12.%06d", q$Revision: 14714 $ =~ /(\d+)/o);
# $Id: NullP.pm 14714 2011-02-22 17:27:07Z timbo $
#
# Copyright (c) 1994-2007 Tim Bunce
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
$drh = undef; # holds driver handle once initialised
sub driver{
return $drh if $drh;
my($class, $attr) = @_;
$class .= "::dr";
($drh) = DBI::_new_drh($class, {
'Name' => 'NullP',
'Version' => $VERSION,
'Attribution' => 'DBD Example Null Perl stub by Tim Bunce',
}, [ qw'example implementors private data']);
$drh;
}
sub CLONE {
undef $drh;
}
}
{ package DBD::NullP::dr; # ====== DRIVER ======
$imp_data_size = 0;
use strict;
sub connect { # normally overridden, but a handy default
my $dbh = shift->SUPER::connect(@_)
or return;
$dbh->STORE(Active => 1);
$dbh;
}
sub DESTROY { undef }
}
{ package DBD::NullP::db; # ====== DATABASE ======
$imp_data_size = 0;
use strict;
use Carp qw(croak);
sub prepare {
my ($dbh, $statement)= @_;
my ($outer, $sth) = DBI::_new_sth($dbh, {
'Statement' => $statement,
});
return $outer;
}
sub FETCH {
my ($dbh, $attrib) = @_;
# In reality this would interrogate the database engine to
# either return dynamic values that cannot be precomputed
# or fetch and cache attribute values too expensive to prefetch.
return $dbh->SUPER::FETCH($attrib);
}
sub STORE {
my ($dbh, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
if ($attrib eq 'AutoCommit') {
Carp::croak("Can't disable AutoCommit") unless $value;
# convert AutoCommit values to magic ones to let DBI
# know that the driver has 'handled' the AutoCommit attribute
$value = ($value) ? -901 : -900;
}
return $dbh->SUPER::STORE($attrib, $value);
}
sub ping { 1 }
sub disconnect {
shift->STORE(Active => 0);
}
}
{ package DBD::NullP::st; # ====== STATEMENT ======
$imp_data_size = 0;
use strict;
sub bind_param {
my ($sth, $param, $value, $attr) = @_;
$sth->{ParamValues}{$param} = $value;
$sth->{ParamAttr}{$param} = $attr
if defined $attr; # attr is sticky if not explicitly set
return 1;
}
sub execute {
my $sth = shift;
$sth->bind_param($_, $_[$_-1]) for (1..@_);
if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) {
$sth->STORE(NUM_OF_FIELDS => 1);
$sth->{NAME} = [ "fieldname" ];
# just for the sake of returning something, we return the params
my $params = $sth->{ParamValues} || {};
$sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
$sth->STORE(Active => 1);
}
# force a sleep - handy for testing
elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) {
my $secs = $1;
if (eval { require Time::HiRes; defined &Time::HiRes::sleep }) {
Time::HiRes::sleep($secs);
}
else {
sleep $secs;
}
}
# force an error - handy for testing
elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) {
return $sth->set_err($1, $2);
}
# anything else is silently ignored, sucessfully
1;
}
sub fetchrow_arrayref {
my $sth = shift;
my $data = $sth->{dbd_nullp_data};
if (!$data || !@$data) {
$sth->finish; # no more data so finish
return undef;
}
return $sth->_set_fbav(shift @$data);
}
*fetch = \&fetchrow_arrayref; # alias
sub FETCH {
my ($sth, $attrib) = @_;
# would normally validate and only fetch known attributes
# else pass up to DBI to handle
return $sth->SUPER::FETCH($attrib);
}
sub STORE {
my ($sth, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
return $sth->SUPER::STORE($attrib, $value);
}
}
1;
|
