[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 { 2 package DBD::Sponge; 3 4 require DBI; 5 require Carp; 6 7 our @EXPORT = qw(); # Do NOT @EXPORT anything. 8 our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o); 9 10 11 # $Id: Sponge.pm 10002 2007-09-26 21:03:25Z timbo $ 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 $drh = undef; # holds driver handle once initialised 19 my $methods_already_installed; 20 21 sub driver{ 22 return $drh if $drh; 23 24 DBD::Sponge::db->install_method("sponge_test_installed_method") 25 unless $methods_already_installed++; 26 27 my($class, $attr) = @_; 28 $class .= "::dr"; 29 ($drh) = DBI::_new_drh($class, { 30 'Name' => 'Sponge', 31 'Version' => $VERSION, 32 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", 33 }); 34 $drh; 35 } 36 37 sub CLONE { 38 undef $drh; 39 } 40 } 41 42 43 { package DBD::Sponge::dr; # ====== DRIVER ====== 44 $imp_data_size = 0; 45 # we use default (dummy) connect method 46 } 47 48 49 { package DBD::Sponge::db; # ====== DATABASE ====== 50 $imp_data_size = 0; 51 use strict; 52 53 sub prepare { 54 my($dbh, $statement, $attribs) = @_; 55 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 (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } 61 qw(execute_hook) 62 ), 63 }); 64 if (my $behave_like = $attribs->{behave_like}) { 65 $outer->{$_} = $behave_like->{$_} 66 foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); 67 } 68 69 if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() 70 $sth->{is_insert} = 1; 71 my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} 72 or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); 73 $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); 74 } 75 else { #assume select 76 77 # we need to set NUM_OF_FIELDS 78 my $numFields; 79 if ($attribs->{'NUM_OF_FIELDS'}) { 80 $numFields = $attribs->{'NUM_OF_FIELDS'}; 81 } elsif ($attribs->{'NAME'}) { 82 $numFields = @{$attribs->{NAME}}; 83 } elsif ($attribs->{'TYPE'}) { 84 $numFields = @{$attribs->{TYPE}}; 85 } elsif (my $firstrow = $rows->[0]) { 86 $numFields = scalar @$firstrow; 87 } else { 88 return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); 89 } 90 $sth->STORE('NUM_OF_FIELDS' => $numFields); 91 $sth->{NAME} = $attribs->{NAME} 92 || [ map { "col$_" } 1..$numFields ]; 93 $sth->{TYPE} = $attribs->{TYPE} 94 || [ (DBI::SQL_VARCHAR()) x $numFields ]; 95 $sth->{PRECISION} = $attribs->{PRECISION} 96 || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; 97 $sth->{SCALE} = $attribs->{SCALE} 98 || [ (0) x $numFields ]; 99 $sth->{NULLABLE} = $attribs->{NULLABLE} 100 || [ (2) x $numFields ]; 101 } 102 103 $outer; 104 } 105 106 sub type_info_all { 107 my ($dbh) = @_; 108 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 return $ti; 128 } 129 130 sub FETCH { 131 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 return 1 if $attrib eq 'AutoCommit'; 136 # else pass up to DBI to handle 137 return $dbh->SUPER::FETCH($attrib); 138 } 139 140 sub STORE { 141 my ($dbh, $attrib, $value) = @_; 142 # would normally validate and only store known attributes 143 # else pass up to DBI to handle 144 if ($attrib eq 'AutoCommit') { 145 return 1 if $value; # is already set 146 Carp::croak("Can't disable AutoCommit"); 147 } 148 return $dbh->SUPER::STORE($attrib, $value); 149 } 150 151 sub sponge_test_installed_method { 152 my ($dbh, @args) = @_; 153 return $dbh->set_err(42, "not enough parameters") unless @args >= 2; 154 return \@args; 155 } 156 } 157 158 159 { package DBD::Sponge::st; # ====== STATEMENT ====== 160 $imp_data_size = 0; 161 use strict; 162 163 sub execute { 164 my $sth = shift; 165 166 # hack to support ParamValues (when not using bind_param) 167 $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; 168 169 if (my $hook = $sth->{execute_hook}) { 170 &$hook($sth, @_) or return; 171 } 172 173 if ($sth->{is_insert}) { 174 my $row; 175 $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; 176 my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; 177 return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") 178 if @$row != $NUM_OF_PARAMS; 179 { local $^W; $sth->trace_msg("inserting (@$row)\n"); } 180 push @{ $sth->{rows} }, $row; 181 } 182 else { # mark select sth as Active 183 $sth->STORE(Active => 1); 184 } 185 # else do nothing for select as data is already in $sth->{rows} 186 return 1; 187 } 188 189 sub fetch { 190 my ($sth) = @_; 191 my $row = shift @{$sth->{'rows'}}; 192 unless ($row) { 193 $sth->STORE(Active => 0); 194 return undef; 195 } 196 return $sth->_set_fbav($row); 197 } 198 *fetchrow_arrayref = \&fetch; 199 200 sub FETCH { 201 my ($sth, $attrib) = @_; 202 # would normally validate and only fetch known attributes 203 # else pass up to DBI to handle 204 return $sth->SUPER::FETCH($attrib); 205 } 206 207 sub STORE { 208 my ($sth, $attrib, $value) = @_; 209 # would normally validate and only store known attributes 210 # else pass up to DBI to handle 211 return $sth->SUPER::STORE($attrib, $value); 212 } 213 } 214 215 1; 216 217 __END__ 218 219 =pod 220 221 =head1 NAME 222 223 DBD::Sponge - Create a DBI statement handle from Perl data 224 225 =head1 SYNOPSIS 226 227 my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); 228 my $sth = $sponge->prepare($statement, { 229 rows => $data, 230 NAME => $names, 231 %attr 232 } 233 ); 234 235 =head1 DESCRIPTION 236 237 DBD::Sponge is useful for making a Perl data structure accessible through a 238 standard DBI statement handle. This may be useful to DBD module authors who 239 need to transform data in this way. 240 241 =head1 METHODS 242 243 =head2 connect() 244 245 my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); 246 247 Here's a sample syntax for creating a database handle for the Sponge driver. 248 No username and password are needed. 249 250 =head2 prepare() 251 252 my $sth = $sponge->prepare($statement, { 253 rows => $data, 254 NAME => $names, 255 %attr 256 } 257 ); 258 259 =over 4 260 261 =item * 262 263 The C<$statement> here is an arbitrary statement or name you want 264 to provide as identity of your data. If you're using DBI::Profile 265 it will appear in the profile data. 266 267 Generally it's expected that you are preparing a statement handle 268 as if a C<select> statement happened. 269 270 =item * 271 272 C<$data> is a reference to the data you are providing, given as an array of arrays. 273 274 =item * 275 276 C<$names> is a reference an array of column names for the C<$data> you are providing. 277 The number and order should match the number and ordering of the C<$data> columns. 278 279 =item * 280 281 C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement. 282 283 Currently only NAME, TYPE, and PRECISION are supported. 284 285 =back 286 287 =head1 BUGS 288 289 Using this module to prepare INSERT-like statements is not currently documented. 290 291 =head1 AUTHOR AND COPYRIGHT 292 293 This module is Copyright (c) 2003 Tim Bunce 294 295 Documentation initially written by Mark Stosberg 296 297 The DBD::Sponge module is free software; you can redistribute it and/or 298 modify it under the same terms as Perl itself. In particular permission 299 is granted to Tim Bunce for distributing this as a part of the DBI. 300 301 =head1 SEE ALSO 302 303 L<DBI> 304 305 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |