projects / OpenSPARC-T2-DV / blame
| Commit | Line | Data |
|---|---|---|
| 86530b38 AT |
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; |