File Coverage

blib/lib/DBD/Sponge.pm
Criterion Covered Total %
statement 75 84 89.2
branch 34 44 77.2
condition 8 10 80.0
subroutine 12 14 85.7
pod 0 1 0.0
total 129 153 84.3


line stmt bran cond sub pod time code
1 48     48   347 use strict;
  48         110  
  48         12316  
2             {
3             package DBD::Sponge;
4              
5             require DBI;
6             require Carp;
7              
8             our @EXPORT = qw(); # Do NOT @EXPORT anything.
9             our $VERSION = "12.010003";
10              
11             # $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $
12             #
13             # Copyright (c) 1994-2003 Tim Bunce Ireland
14             #
15             # You may distribute under the terms of either the GNU General Public
16             # License or the Artistic License, as specified in the Perl README file.
17              
18             our $drh = undef; # holds driver handle once initialised
19             my $methods_already_installed;
20              
21             sub driver{
22 48 50   48 0 180 return $drh if $drh;
23              
24 48 50       574 DBD::Sponge::db->install_method("sponge_test_installed_method")
25             unless $methods_already_installed++;
26              
27 48         168 my($class, $attr) = @_;
28 48         137 $class .= "::dr";
29 48         394 ($drh) = DBI::_new_drh($class, {
30             'Name' => 'Sponge',
31             'Version' => $VERSION,
32             'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce",
33             });
34 48         220 $drh;
35             }
36              
37             sub CLONE {
38 0     0   0 undef $drh;
39             }
40             }
41              
42              
43             { package DBD::Sponge::dr; # ====== DRIVER ======
44             our $imp_data_size = 0;
45             # we use default (dummy) connect method
46             }
47              
48              
49             { package DBD::Sponge::db; # ====== DATABASE ======
50             our $imp_data_size = 0;
51 48     48   348 use strict;
  48         202  
  48         35495  
52              
53             sub prepare {
54 92     92   60341 my($dbh, $statement, $attribs) = @_;
55 92 50       395 my $rows = delete $attribs->{'rows'}
56             or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare");
57             my ($outer, $sth) = DBI::_new_sth($dbh, {
58             'Statement' => $statement,
59             'rows' => $rows,
60 92 100       276 (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () }
  92         767  
61             qw(execute_hook)
62             ),
63             });
64 92 50       386 if (my $behave_like = $attribs->{behave_like}) {
65             $outer->{$_} = $behave_like->{$_}
66 0         0 foreach (qw(RaiseError PrintError HandleError ShowErrorStatement));
67             }
68              
69 92 100       387 if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array()
70 8         29 $sth->{is_insert} = 1;
71             my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS}
72 8 50       25 or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement");
73 8         56 $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} );
74             }
75             else { #assume select
76              
77             # we need to set NUM_OF_FIELDS
78 84         154 my $numFields;
79 84 100       354 if ($attribs->{'NUM_OF_FIELDS'}) {
    100          
    50          
    50          
80 20         59 $numFields = $attribs->{'NUM_OF_FIELDS'};
81             } elsif ($attribs->{'NAME'}) {
82 52         106 $numFields = @{$attribs->{NAME}};
  52         140  
83             } elsif ($attribs->{'TYPE'}) {
84 0         0 $numFields = @{$attribs->{TYPE}};
  0         0  
85             } elsif (my $firstrow = $rows->[0]) {
86 12         25 $numFields = scalar @$firstrow;
87             } else {
88 0         0 return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS');
89             }
90 84         582 $sth->STORE('NUM_OF_FIELDS' => $numFields);
91             $sth->{NAME} = $attribs->{NAME}
92 84   100     702 || [ map { "col$_" } 1..$numFields ];
93             $sth->{TYPE} = $attribs->{TYPE}
94 84   100     645 || [ (DBI::SQL_VARCHAR()) x $numFields ];
95             $sth->{PRECISION} = $attribs->{PRECISION}
96 84   50     534 || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ];
97             $sth->{SCALE} = $attribs->{SCALE}
98 84   50     535 || [ (0) x $numFields ];
99             $sth->{NULLABLE} = $attribs->{NULLABLE}
100 84   100     567 || [ (2) x $numFields ];
101             }
102              
103 92         434 $outer;
104             }
105              
106             sub type_info_all {
107 0     0   0 my ($dbh) = @_;
108 0         0 my $ti = [
109             { TYPE_NAME => 0,
110             DATA_TYPE => 1,
111             PRECISION => 2,
112             LITERAL_PREFIX => 3,
113             LITERAL_SUFFIX => 4,
114             CREATE_PARAMS => 5,
115             NULLABLE => 6,
116             CASE_SENSITIVE => 7,
117             SEARCHABLE => 8,
118             UNSIGNED_ATTRIBUTE=> 9,
119             MONEY => 10,
120             AUTO_INCREMENT => 11,
121             LOCAL_TYPE_NAME => 12,
122             MINIMUM_SCALE => 13,
123             MAXIMUM_SCALE => 14,
124             },
125             [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
126             ];
127 0         0 return $ti;
128             }
129              
130             sub FETCH {
131 82     82   11386 my ($dbh, $attrib) = @_;
132             # In reality this would interrogate the database engine to
133             # either return dynamic values that cannot be precomputed
134             # or fetch and cache attribute values too expensive to prefetch.
135 82 100       163 return 1 if $attrib eq 'AutoCommit';
136             # else pass up to DBI to handle
137 78         402 return $dbh->SUPER::FETCH($attrib);
138             }
139              
140             sub STORE {
141 636     636   5212 my ($dbh, $attrib, $value) = @_;
142             # would normally validate and only store known attributes
143             # else pass up to DBI to handle
144 636 100       1144 if ($attrib eq 'AutoCommit') {
145 86 50       430 return 1 if $value; # is already set
146 0         0 Carp::croak("Can't disable AutoCommit");
147             }
148 550         2207 return $dbh->SUPER::STORE($attrib, $value);
149             }
150              
151             sub sponge_test_installed_method {
152 8     8   6852 my ($dbh, @args) = @_;
153 8 100       105 return $dbh->set_err(42, "not enough parameters") unless @args >= 2;
154 4         16 return \@args;
155             }
156             }
157              
158              
159             { package DBD::Sponge::st; # ====== STATEMENT ======
160             our $imp_data_size = 0;
161 48     48   390 use strict;
  48         130  
  48         18462  
162              
163             sub execute {
164 116     116   5032 my $sth = shift;
165              
166             # hack to support ParamValues (when not using bind_param)
167 116 100       429 $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef;
  240         615  
168              
169 116 100       378 if (my $hook = $sth->{execute_hook}) {
170 60 100       146 &$hook($sth, @_) or return;
171             }
172              
173 112 100       1006 if ($sth->{is_insert}) {
174 56         67 my $row;
175 56 50       150 $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ;
176 56         88 my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS};
177 56 50       112 return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected")
178             if @$row != $NUM_OF_PARAMS;
179 56         68 { local $^W; $sth->trace_msg("inserting (@$row)\n"); }
  56         97  
  56         321  
180 56         306 push @{ $sth->{rows} }, $row;
  56         128  
181             }
182             else { # mark select sth as Active
183 56         217 $sth->STORE(Active => 1);
184             }
185             # else do nothing for select as data is already in $sth->{rows}
186 112         702 return 1;
187             }
188              
189             sub fetch {
190 392     392   58770 my ($sth) = @_;
191 392         530 my $row = shift @{$sth->{'rows'}};
  392         738  
192 392 100       831 unless ($row) {
193 64         272 $sth->STORE(Active => 0);
194 64         457 return undef;
195             }
196 328         1685 return $sth->_set_fbav($row);
197             }
198             *fetchrow_arrayref = \&fetch;
199              
200             sub FETCH {
201 61     61   441 my ($sth, $attrib) = @_;
202             # would normally validate and only fetch known attributes
203             # else pass up to DBI to handle
204 61         501 return $sth->SUPER::FETCH($attrib);
205             }
206              
207             sub STORE {
208 272     272   13107 my ($sth, $attrib, $value) = @_;
209             # would normally validate and only store known attributes
210             # else pass up to DBI to handle
211 272         2225 return $sth->SUPER::STORE($attrib, $value);
212             }
213             }
214              
215             1;
216              
217             __END__