| 1 | { |
| 2 | package DBD::ExampleP; |
| 3 | |
| 4 | use DBI qw(:sql_types); |
| 5 | |
| 6 | @EXPORT = qw(); # Do NOT @EXPORT anything. |
| 7 | $VERSION = sprintf("%d.%02d", q$Revision: 10.14 $ =~ /(\d+)\.(\d+)/o); |
| 8 | |
| 9 | # $Id: ExampleP.pm,v 10.14 2001/05/29 23:25:55 timbo Exp $ |
| 10 | # |
| 11 | # Copyright (c) 1994,1997,1998 Tim Bunce |
| 12 | # |
| 13 | # You may distribute under the terms of either the GNU General Public |
| 14 | # License or the Artistic License, as specified in the Perl README file. |
| 15 | |
| 16 | @statnames = qw(dev ino mode nlink |
| 17 | uid gid rdev size |
| 18 | atime mtime ctime |
| 19 | blksize blocks name); |
| 20 | @statnames{@statnames} = (0 .. @statnames-1); |
| 21 | |
| 22 | @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, |
| 23 | SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, |
| 24 | SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, |
| 25 | SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); |
| 26 | @stattypes{@statnames} = @stattypes; |
| 27 | |
| 28 | $drh = undef; # holds driver handle once initialised |
| 29 | $err = 0; # The $DBI::err value |
| 30 | $gensym = "SYM000"; # used by st::execute() for filehandles |
| 31 | |
| 32 | sub driver{ |
| 33 | return $drh if $drh; |
| 34 | my($class, $attr) = @_; |
| 35 | $class .= "::dr"; |
| 36 | ($drh) = DBI::_new_drh($class, { |
| 37 | 'Name' => 'ExampleP', |
| 38 | 'Version' => $VERSION, |
| 39 | 'Attribution' => 'DBD Example Perl stub by Tim Bunce', |
| 40 | }, ['example implementors private data']); |
| 41 | $drh; |
| 42 | } |
| 43 | |
| 44 | sub default_user { |
| 45 | return ('',''); |
| 46 | } |
| 47 | } |
| 48 | |
| 49 | |
| 50 | { package DBD::ExampleP::dr; # ====== DRIVER ====== |
| 51 | $imp_data_size = 0; |
| 52 | use strict; |
| 53 | |
| 54 | sub connect { # normally overridden, but a handy default |
| 55 | my($drh, $dbname, $user, $auth)= @_; |
| 56 | my($this) = DBI::_new_dbh($drh, { |
| 57 | 'Name' => $dbname, |
| 58 | 'User' => $user, |
| 59 | }); |
| 60 | $this->STORE(Active => 1); |
| 61 | $this; |
| 62 | } |
| 63 | |
| 64 | sub data_sources { |
| 65 | return ("dbi:ExampleP:dir=."); # possibly usefully meaningless |
| 66 | } |
| 67 | |
| 68 | sub disconnect_all { |
| 69 | # we don't need to tidy up anything |
| 70 | } |
| 71 | sub DESTROY { undef } |
| 72 | } |
| 73 | |
| 74 | |
| 75 | { package DBD::ExampleP::db; # ====== DATABASE ====== |
| 76 | $imp_data_size = 0; |
| 77 | use strict; |
| 78 | |
| 79 | sub prepare { |
| 80 | my($dbh, $statement)= @_; |
| 81 | |
| 82 | my($fields, $dir) |
| 83 | = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; |
| 84 | return $dbh->DBI::set_err(1, "Syntax error in select statement (\"$statement\")") |
| 85 | unless defined $fields and defined $dir; |
| 86 | |
| 87 | my ($outer, $inner) = DBI::_new_sth($dbh, { |
| 88 | 'Statement' => $statement, |
| 89 | }, ['example implementors private data']); |
| 90 | |
| 91 | my @fields = ($fields eq '*') |
| 92 | ? keys %DBD::ExampleP::statnames |
| 93 | : split(/\s*,\s*/, $fields); |
| 94 | |
| 95 | my @bad = map { |
| 96 | defined $DBD::ExampleP::statnames{$_} ? () : $_ |
| 97 | } @fields; |
| 98 | return $dbh->DBI::set_err(1, "Unknown field names: @bad") |
| 99 | if @bad; |
| 100 | |
| 101 | $inner->{'dbd_param'}->[1] = $dir if $dir !~ /\?/; |
| 102 | |
| 103 | $outer->STORE('NAME' => \@fields); |
| 104 | $outer->STORE('NULLABLE' => [ (0) x @fields ]); |
| 105 | $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); |
| 106 | $outer->STORE('NUM_OF_PARAMS' => ($dir !~ /\?/) ? 0 : 1); |
| 107 | # should do better here: |
| 108 | $outer->STORE('SCALE' => undef); |
| 109 | $outer->STORE('PRECISION' => undef); |
| 110 | |
| 111 | $outer; |
| 112 | } |
| 113 | |
| 114 | |
| 115 | sub table_info { |
| 116 | my $dbh = shift; |
| 117 | |
| 118 | # Return a list of all subdirectories |
| 119 | my $dh = "DBD::ExampleP::".++$DBD::ExampleP::gensym; |
| 120 | my $haveFileSpec = eval { require File::Spec }; |
| 121 | my $dir = $haveFileSpec ? File::Spec->curdir() : "."; |
| 122 | my @list; |
| 123 | { |
| 124 | no strict 'refs'; |
| 125 | opendir($dh, $dir) |
| 126 | or return $dbh->DBI::set_err(int($!), |
| 127 | "Failed to open directory $dir: $!"); |
| 128 | while (defined(my $file = readdir($dh))) { |
| 129 | next unless -d $file; |
| 130 | my($dev, $ino, $mode, $nlink, $uid) = lstat($file); |
| 131 | my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; |
| 132 | push(@list, [ $dir, $pwnam, $file, 'TABLE']); |
| 133 | } |
| 134 | close($dh); |
| 135 | } |
| 136 | # We would like to simply do a DBI->connect() here. However, |
| 137 | # this is wrong if we are in a subclass like DBI::ProxyServer. |
| 138 | $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') |
| 139 | or return $dbh->DBI::set_err($DBI::err, |
| 140 | "Failed to connect to DBI::Sponge: $DBI::errstr"); |
| 141 | |
| 142 | my $attr = { |
| 143 | 'rows' => \@list, |
| 144 | 'NUM_OF_FIELDS' => 4, |
| 145 | 'NAME' => ['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME', |
| 146 | 'TABLE_TYPE'], |
| 147 | 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), |
| 148 | DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR()], |
| 149 | 'NULLABLE' => [1, 1, 1, 1] |
| 150 | }; |
| 151 | my $sdbh = $dbh->{'dbd_sponge_dbh'}; |
| 152 | my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) |
| 153 | or return $dbh->DBI::set_err($sdbh->err(), $sdbh->errstr()); |
| 154 | $sth; |
| 155 | } |
| 156 | |
| 157 | |
| 158 | sub type_info_all { |
| 159 | my ($dbh) = @_; |
| 160 | my $ti = [ |
| 161 | { TYPE_NAME => 0, |
| 162 | DATA_TYPE => 1, |
| 163 | COLUMN_SIZE => 2, |
| 164 | LITERAL_PREFIX => 3, |
| 165 | LITERAL_SUFFIX => 4, |
| 166 | CREATE_PARAMS => 5, |
| 167 | NULLABLE => 6, |
| 168 | CASE_SENSITIVE => 7, |
| 169 | SEARCHABLE => 8, |
| 170 | UNSIGNED_ATTRIBUTE=> 9, |
| 171 | FIXED_PREC_SCALE=> 10, |
| 172 | AUTO_UNIQUE_VALUE => 11, |
| 173 | LOCAL_TYPE_NAME => 12, |
| 174 | MINIMUM_SCALE => 13, |
| 175 | MAXIMUM_SCALE => 14, |
| 176 | }, |
| 177 | [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], |
| 178 | [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], |
| 179 | ]; |
| 180 | return $ti; |
| 181 | } |
| 182 | |
| 183 | |
| 184 | sub disconnect { |
| 185 | shift->STORE(Active => 0); |
| 186 | return 1; |
| 187 | } |
| 188 | |
| 189 | |
| 190 | sub FETCH { |
| 191 | my ($dbh, $attrib) = @_; |
| 192 | # In reality this would interrogate the database engine to |
| 193 | # either return dynamic values that cannot be precomputed |
| 194 | # or fetch and cache attribute values too expensive to prefetch. |
| 195 | return 1 if $attrib eq 'AutoCommit'; |
| 196 | # else pass up to DBI to handle |
| 197 | return $dbh->SUPER::FETCH($attrib); |
| 198 | } |
| 199 | |
| 200 | |
| 201 | sub STORE { |
| 202 | my ($dbh, $attrib, $value) = @_; |
| 203 | # would normally validate and only store known attributes |
| 204 | # else pass up to DBI to handle |
| 205 | if ($attrib eq 'AutoCommit') { |
| 206 | return 1 if $value; # is already set |
| 207 | Carp::croak("Can't disable AutoCommit"); |
| 208 | } |
| 209 | return $dbh->SUPER::STORE($attrib, $value); |
| 210 | } |
| 211 | |
| 212 | sub DESTROY { |
| 213 | my $dbh = shift; |
| 214 | $dbh->disconnect if $dbh->FETCH('Active'); |
| 215 | undef |
| 216 | } |
| 217 | |
| 218 | |
| 219 | # This is an example to demonstrate the use of driver-specific |
| 220 | # methods via $dbh->func(). |
| 221 | # Use it as follows: |
| 222 | # my @tables = $dbh->func($re, 'examplep_tables'); |
| 223 | # |
| 224 | # Returns all the tables that match the regular expression $re. |
| 225 | sub examplep_tables { |
| 226 | my $dbh = shift; my $re = shift; |
| 227 | grep { $_ =~ /$re/ } $dbh->tables(); |
| 228 | } |
| 229 | } |
| 230 | |
| 231 | |
| 232 | { package DBD::ExampleP::st; # ====== STATEMENT ====== |
| 233 | $imp_data_size = 0; |
| 234 | use strict; no strict 'refs'; # cause problems with filehandles |
| 235 | |
| 236 | my $haveFileSpec = eval { require File::Spec }; |
| 237 | |
| 238 | sub bind_param { |
| 239 | my($sth, $param, $value, $attribs) = @_; |
| 240 | return $sth->DBI::set_err(2, "Can't bind_param $param, only one parameter") |
| 241 | unless $param == 1; |
| 242 | $sth->{'dbd_param'}->[$param] = $value; |
| 243 | return 1; |
| 244 | } |
| 245 | |
| 246 | |
| 247 | sub execute { |
| 248 | my($sth, @dir) = @_; |
| 249 | my $dir; |
| 250 | |
| 251 | if (@dir) { |
| 252 | $dir = $dir[0]; |
| 253 | } |
| 254 | else { |
| 255 | $dir = $sth->{'dbd_param'}->[1]; |
| 256 | return $sth->DBI::set_err(2, "No bind parameter supplied") |
| 257 | unless defined $dir; |
| 258 | } |
| 259 | |
| 260 | $sth->finish; |
| 261 | |
| 262 | # |
| 263 | # If the users asks for directory "long_list_4532", then we fake a |
| 264 | # directory with files "file4351", "file4350", ..., "file0". |
| 265 | # This is a special case used for testing, especially DBD::Proxy. |
| 266 | # |
| 267 | if ($dir =~ /^long_list_(\d+)$/) { |
| 268 | $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode |
| 269 | $sth->{dbd_datahandle} = undef; |
| 270 | } |
| 271 | else { |
| 272 | $sth->{dbd_dir} = $dir; |
| 273 | $sth->{dbd_datahandle} = "DBD::ExampleP::".++$DBD::ExampleP::gensym; |
| 274 | opendir($sth->{dbd_datahandle}, $dir) |
| 275 | or return $sth->DBI::set_err(2, "opendir($dir): $!"); |
| 276 | } |
| 277 | $sth->STORE(Active => 1); |
| 278 | 1; |
| 279 | } |
| 280 | |
| 281 | |
| 282 | sub fetch { |
| 283 | my $sth = shift; |
| 284 | my $dh = $sth->{dbd_datahandle}; |
| 285 | my $dir = $sth->{dbd_dir}; |
| 286 | my %s; |
| 287 | |
| 288 | if (ref $dir) { # special fake-data test mode |
| 289 | my $num = $dir->[0]--; |
| 290 | unless ($num > 0) { |
| 291 | $sth->finish(); |
| 292 | return; |
| 293 | } |
| 294 | my $time = time; |
| 295 | @s{@DBD::ExampleP::statnames} = |
| 296 | ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, |
| 297 | $time, $time, $time, 512, 2, "file$num") |
| 298 | } |
| 299 | else { # normal mode |
| 300 | my $f = readdir($dh); |
| 301 | unless ($f) { |
| 302 | $sth->finish; |
| 303 | return; |
| 304 | } |
| 305 | my $file = $haveFileSpec |
| 306 | ? File::Spec->catfile($dir, $f) : "$dir/$f"; |
| 307 | # put in all the data fields |
| 308 | @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); |
| 309 | } |
| 310 | |
| 311 | # return just what fields the query asks for |
| 312 | my @new = @s{ @{$sth->{NAME}} }; |
| 313 | |
| 314 | return $sth->_set_fbav(\@new); |
| 315 | } |
| 316 | *fetchrow_arrayref = \&fetch; |
| 317 | |
| 318 | |
| 319 | sub finish { |
| 320 | my $sth = shift; |
| 321 | closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; |
| 322 | $sth->{dbd_datahandle} = undef; |
| 323 | $sth->{dbd_dir} = undef; |
| 324 | $sth->SUPER::finish(); |
| 325 | return 1; |
| 326 | } |
| 327 | |
| 328 | |
| 329 | sub FETCH { |
| 330 | my ($sth, $attrib) = @_; |
| 331 | # In reality this would interrogate the database engine to |
| 332 | # either return dynamic values that cannot be precomputed |
| 333 | # or fetch and cache attribute values too expensive to prefetch. |
| 334 | if ($attrib eq 'TYPE'){ |
| 335 | my @t = @DBD::ExampleP::stattypes{ @{ $sth->{NAME} } }; |
| 336 | return \@t; |
| 337 | } |
| 338 | # else pass up to DBI to handle |
| 339 | return $sth->SUPER::FETCH($attrib); |
| 340 | } |
| 341 | |
| 342 | |
| 343 | sub STORE { |
| 344 | my ($sth, $attrib, $value) = @_; |
| 345 | # would normally validate and only store known attributes |
| 346 | # else pass up to DBI to handle |
| 347 | return $sth->{$attrib} = $value |
| 348 | if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; |
| 349 | return $sth->SUPER::STORE($attrib, $value); |
| 350 | } |
| 351 | |
| 352 | sub DESTROY { undef } |
| 353 | } |
| 354 | |
| 355 | 1; |