[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 { 2 package DBD::ExampleP; 3 4 use Symbol; 5 6 use DBI qw(:sql_types); 7 8 @EXPORT = qw(); # Do NOT @EXPORT anything. 9 $VERSION = sprintf("12.%06d", q$Revision: 10007 $ =~ /(\d+)/o); 10 11 12 # $Id: ExampleP.pm 10007 2007-09-27 20:53:04Z timbo $ 13 # 14 # Copyright (c) 1994,1997,1998 Tim Bunce 15 # 16 # You may distribute under the terms of either the GNU General Public 17 # License or the Artistic License, as specified in the Perl README file. 18 19 @statnames = qw(dev ino mode nlink 20 uid gid rdev size 21 atime mtime ctime 22 blksize blocks name); 23 @statnames{@statnames} = (0 .. @statnames-1); 24 25 @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, 26 SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, 27 SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, 28 SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); 29 @stattypes{@statnames} = @stattypes; 30 @statprec = ((10) x (@statnames-1), 1024); 31 @statprec{@statnames} = @statprec; 32 die unless @statnames == @stattypes; 33 die unless @statprec == @stattypes; 34 35 $drh = undef; # holds driver handle once initialised 36 #$gensym = "SYM000"; # used by st::execute() for filehandles 37 38 sub driver{ 39 return $drh if $drh; 40 my($class, $attr) = @_; 41 $class .= "::dr"; 42 ($drh) = DBI::_new_drh($class, { 43 'Name' => 'ExampleP', 44 'Version' => $VERSION, 45 'Attribution' => 'DBD Example Perl stub by Tim Bunce', 46 }, ['example implementors private data '.__PACKAGE__]); 47 $drh; 48 } 49 50 sub CLONE { 51 undef $drh; 52 } 53 } 54 55 56 { package DBD::ExampleP::dr; # ====== DRIVER ====== 57 $imp_data_size = 0; 58 use strict; 59 60 sub connect { # normally overridden, but a handy default 61 my($drh, $dbname, $user, $auth)= @_; 62 my ($outer, $dbh) = DBI::_new_dbh($drh, { 63 Name => $dbname, 64 examplep_private_dbh_attrib => 42, # an example, for testing 65 }); 66 $dbh->{examplep_get_info} = { 67 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR 68 41 => '.', # SQL_CATALOG_NAME_SEPARATOR 69 114 => 1, # SQL_CATALOG_LOCATION 70 }; 71 #$dbh->{Name} = $dbname; 72 $dbh->STORE('Active', 1); 73 return $outer; 74 } 75 76 sub data_sources { 77 return ("dbi:ExampleP:dir=."); # possibly usefully meaningless 78 } 79 80 } 81 82 83 { package DBD::ExampleP::db; # ====== DATABASE ====== 84 $imp_data_size = 0; 85 use strict; 86 87 sub prepare { 88 my($dbh, $statement)= @_; 89 my @fields; 90 my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; 91 92 if (defined $fields and defined $dir) { 93 @fields = ($fields eq '*') 94 ? keys %DBD::ExampleP::statnames 95 : split(/\s*,\s*/, $fields); 96 } 97 else { 98 return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") 99 unless $statement =~ m/^\s*set\s+/; 100 # the SET syntax is just a hack so the ExampleP driver can 101 # be used to test non-select statements. 102 # Now we have DBI::DBM etc., ExampleP should be deprecated 103 } 104 105 my ($outer, $sth) = DBI::_new_sth($dbh, { 106 'Statement' => $statement, 107 examplep_private_sth_attrib => 24, # an example, for testing 108 }, ['example implementors private data '.__PACKAGE__]); 109 110 my @bad = map { 111 defined $DBD::ExampleP::statnames{$_} ? () : $_ 112 } @fields; 113 return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") 114 if @bad; 115 116 $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); 117 118 $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; 119 $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); 120 121 if (@fields) { 122 $outer->STORE('NAME' => \@fields); 123 $outer->STORE('NULLABLE' => [ (0) x @fields ]); 124 $outer->STORE('SCALE' => [ (0) x @fields ]); 125 } 126 127 $outer; 128 } 129 130 131 sub table_info { 132 my $dbh = shift; 133 my ($catalog, $schema, $table, $type) = @_; 134 135 my @types = split(/["']*,["']/, $type || 'TABLE'); 136 my %types = map { $_=>$_ } @types; 137 138 # Return a list of all subdirectories 139 my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; 140 my $haveFileSpec = eval { require File::Spec }; 141 my $dir = $catalog || ($haveFileSpec ? File::Spec->curdir() : "."); 142 my @list; 143 if ($types{VIEW}) { # for use by test harness 144 push @list, [ undef, "schema", "table", 'VIEW', undef ]; 145 push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; 146 push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; 147 push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; 148 push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; 149 } 150 if ($types{TABLE}) { 151 no strict 'refs'; 152 opendir($dh, $dir) 153 or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); 154 while (defined(my $item = readdir($dh))) { 155 if ($^O eq 'VMS') { 156 # if on VMS then avoid warnings from catdir if you use a file 157 # (not a dir) as the item below 158 next if $item !~ /\.dir$/oi; 159 } 160 my $file = ($haveFileSpec) ? File::Spec->catdir($dir,$item) : $item; 161 next unless -d $file; 162 my($dev, $ino, $mode, $nlink, $uid) = lstat($file); 163 my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; 164 push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; 165 } 166 close($dh); 167 } 168 # We would like to simply do a DBI->connect() here. However, 169 # this is wrong if we are in a subclass like DBI::ProxyServer. 170 $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') 171 or return $dbh->set_err($DBI::err, 172 "Failed to connect to DBI::Sponge: $DBI::errstr"); 173 174 my $attr = { 175 'rows' => \@list, 176 'NUM_OF_FIELDS' => 5, 177 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 178 'TABLE_TYPE', 'REMARKS'], 179 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), 180 DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], 181 'NULLABLE' => [1, 1, 1, 1, 1] 182 }; 183 my $sdbh = $dbh->{'dbd_sponge_dbh'}; 184 my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) 185 or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); 186 $sth; 187 } 188 189 190 sub type_info_all { 191 my ($dbh) = @_; 192 my $ti = [ 193 { TYPE_NAME => 0, 194 DATA_TYPE => 1, 195 COLUMN_SIZE => 2, 196 LITERAL_PREFIX => 3, 197 LITERAL_SUFFIX => 4, 198 CREATE_PARAMS => 5, 199 NULLABLE => 6, 200 CASE_SENSITIVE => 7, 201 SEARCHABLE => 8, 202 UNSIGNED_ATTRIBUTE=> 9, 203 FIXED_PREC_SCALE=> 10, 204 AUTO_UNIQUE_VALUE => 11, 205 LOCAL_TYPE_NAME => 12, 206 MINIMUM_SCALE => 13, 207 MAXIMUM_SCALE => 14, 208 }, 209 [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], 210 [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], 211 ]; 212 return $ti; 213 } 214 215 216 sub ping { 217 (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t 218 } 219 220 221 sub disconnect { 222 shift->STORE(Active => 0); 223 return 1; 224 } 225 226 227 sub get_info { 228 my ($dbh, $info_type) = @_; 229 return $dbh->{examplep_get_info}->{$info_type}; 230 } 231 232 233 sub FETCH { 234 my ($dbh, $attrib) = @_; 235 # In reality this would interrogate the database engine to 236 # either return dynamic values that cannot be precomputed 237 # or fetch and cache attribute values too expensive to prefetch. 238 # else pass up to DBI to handle 239 return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; 240 return $dbh->SUPER::FETCH($attrib); 241 } 242 243 244 sub STORE { 245 my ($dbh, $attrib, $value) = @_; 246 # would normally validate and only store known attributes 247 # else pass up to DBI to handle 248 if ($attrib eq 'AutoCommit') { 249 # convert AutoCommit values to magic ones to let DBI 250 # know that the driver has 'handled' the AutoCommit attribute 251 $value = ($value) ? -901 : -900; 252 } 253 return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; 254 return $dbh->SUPER::STORE($attrib, $value); 255 } 256 257 sub DESTROY { 258 my $dbh = shift; 259 $dbh->disconnect if $dbh->FETCH('Active'); 260 undef 261 } 262 263 264 # This is an example to demonstrate the use of driver-specific 265 # methods via $dbh->func(). 266 # Use it as follows: 267 # my @tables = $dbh->func($re, 'examplep_tables'); 268 # 269 # Returns all the tables that match the regular expression $re. 270 sub examplep_tables { 271 my $dbh = shift; my $re = shift; 272 grep { $_ =~ /$re/ } $dbh->tables(); 273 } 274 275 sub parse_trace_flag { 276 my ($h, $name) = @_; 277 return 0x01000000 if $name eq 'foo'; 278 return 0x02000000 if $name eq 'bar'; 279 return 0x04000000 if $name eq 'baz'; 280 return 0x08000000 if $name eq 'boo'; 281 return 0x10000000 if $name eq 'bop'; 282 return $h->SUPER::parse_trace_flag($name); 283 } 284 285 sub private_attribute_info { 286 return { example_driver_path => undef }; 287 } 288 } 289 290 291 { package DBD::ExampleP::st; # ====== STATEMENT ====== 292 $imp_data_size = 0; 293 use strict; no strict 'refs'; # cause problems with filehandles 294 295 my $haveFileSpec = eval { require File::Spec }; 296 297 sub bind_param { 298 my($sth, $param, $value, $attribs) = @_; 299 $sth->{'dbd_param'}->[$param-1] = $value; 300 return 1; 301 } 302 303 304 sub execute { 305 my($sth, @dir) = @_; 306 my $dir; 307 308 if (@dir) { 309 $sth->bind_param($_, $dir[$_-1]) or return 310 foreach (1..@dir); 311 } 312 313 my $dbd_param = $sth->{'dbd_param'} || []; 314 return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") 315 unless @$dbd_param == $sth->{NUM_OF_PARAMS}; 316 317 return 0 unless $sth->{NUM_OF_FIELDS}; # not a select 318 319 $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; 320 return $sth->set_err(2, "No bind parameter supplied") 321 unless defined $dir; 322 323 $sth->finish; 324 325 # 326 # If the users asks for directory "long_list_4532", then we fake a 327 # directory with files "file4351", "file4350", ..., "file0". 328 # This is a special case used for testing, especially DBD::Proxy. 329 # 330 if ($dir =~ /^long_list_(\d+)$/) { 331 $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode 332 $sth->{dbd_datahandle} = undef; 333 } 334 else { 335 $sth->{dbd_dir} = $dir; 336 my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; 337 opendir($sym, $dir) 338 or return $sth->set_err(2, "opendir($dir): $!"); 339 $sth->{dbd_datahandle} = $sym; 340 } 341 $sth->STORE(Active => 1); 342 return 1; 343 } 344 345 346 sub fetch { 347 my $sth = shift; 348 my $dir = $sth->{dbd_dir}; 349 my %s; 350 351 if (ref $dir) { # special fake-data test mode 352 my $num = $dir->[0]--; 353 unless ($num > 0) { 354 $sth->finish(); 355 return; 356 } 357 my $time = time; 358 @s{@DBD::ExampleP::statnames} = 359 ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, 360 $time, $time, $time, 512, 2, "file$num") 361 } 362 else { # normal mode 363 my $dh = $sth->{dbd_datahandle} 364 or return $sth->set_err($DBI::stderr, "fetch without successful execute"); 365 my $f = readdir($dh); 366 unless ($f) { 367 $sth->finish; 368 return; 369 } 370 # untaint $f so that we can use this for DBI taint tests 371 ($f) = ($f =~ m/^(.*)$/); 372 my $file = $haveFileSpec 373 ? File::Spec->catfile($dir, $f) : "$dir/$f"; 374 # put in all the data fields 375 @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); 376 } 377 378 # return just what fields the query asks for 379 my @new = @s{ @{$sth->{NAME}} }; 380 381 return $sth->_set_fbav(\@new); 382 } 383 *fetchrow_arrayref = \&fetch; 384 385 386 sub finish { 387 my $sth = shift; 388 closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; 389 $sth->{dbd_datahandle} = undef; 390 $sth->{dbd_dir} = undef; 391 $sth->SUPER::finish(); 392 return 1; 393 } 394 395 396 sub FETCH { 397 my ($sth, $attrib) = @_; 398 # In reality this would interrogate the database engine to 399 # either return dynamic values that cannot be precomputed 400 # or fetch and cache attribute values too expensive to prefetch. 401 if ($attrib eq 'TYPE'){ 402 return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; 403 } 404 elsif ($attrib eq 'PRECISION'){ 405 return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; 406 } 407 elsif ($attrib eq 'ParamValues') { 408 my $dbd_param = $sth->{dbd_param} || []; 409 my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; 410 return \%pv; 411 } 412 # else pass up to DBI to handle 413 return $sth->SUPER::FETCH($attrib); 414 } 415 416 417 sub STORE { 418 my ($sth, $attrib, $value) = @_; 419 # would normally validate and only store known attributes 420 # else pass up to DBI to handle 421 return $sth->{$attrib} = $value 422 if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; 423 return $sth->SUPER::STORE($attrib, $value); 424 } 425 426 *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; 427 } 428 429 1; 430 # vim: sw=4:ts=8
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 |