@EXPORT = qw(); # Do NOT @EXPORT anything.
$VERSION = sprintf("%d.%02d", q
$Revision: 10.14 $ =~ /(\d+)\.(\d+)/o);
# $Id: ExampleP.pm,v 10.14 2001/05/29 23:25:55 timbo Exp $
# Copyright (c) 1994,1997,1998 Tim Bunce
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
@statnames = qw(dev ino mode nlink
@statnames{@statnames} = (0 .. @statnames-1);
@stattypes = (SQL_INTEGER
, SQL_INTEGER
, SQL_INTEGER
, SQL_INTEGER
,
SQL_INTEGER
, SQL_INTEGER
, SQL_INTEGER
, SQL_INTEGER
,
SQL_INTEGER
, SQL_INTEGER
, SQL_INTEGER
,
SQL_INTEGER
, SQL_INTEGER
, SQL_VARCHAR
);
@stattypes{@statnames} = @stattypes;
$drh = undef; # holds driver handle once initialised
$err = 0; # The $DBI::err value
$gensym = "SYM000"; # used by st::execute() for filehandles
($drh) = DBI
::_new_drh
($class, {
'Attribution' => 'DBD Example Perl stub by Tim Bunce',
}, ['example implementors private data']);
{ package DBD
::ExampleP
::dr
; # ====== DRIVER ======
sub connect { # normally overridden, but a handy default
my($drh, $dbname, $user, $auth)= @_;
my($this) = DBI
::_new_dbh
($drh, {
$this->STORE(Active
=> 1);
return ("dbi:ExampleP:dir=."); # possibly usefully meaningless
# we don't need to tidy up anything
{ package DBD
::ExampleP
::db
; # ====== DATABASE ======
my($dbh, $statement)= @_;
= $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i;
return $dbh->DBI::set_err
(1, "Syntax error in select statement (\"$statement\")")
unless defined $fields and defined $dir;
my ($outer, $inner) = DBI
::_new_sth
($dbh, {
'Statement' => $statement,
}, ['example implementors private data']);
my @fields = ($fields eq '*')
?
keys %DBD::ExampleP
::statnames
: split(/\s*,\s*/, $fields);
defined $DBD::ExampleP
::statnames
{$_} ?
() : $_
return $dbh->DBI::set_err
(1, "Unknown field names: @bad")
$inner->{'dbd_param'}->[1] = $dir if $dir !~ /\?/;
$outer->STORE('NAME' => \
@fields);
$outer->STORE('NULLABLE' => [ (0) x
@fields ]);
$outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
$outer->STORE('NUM_OF_PARAMS' => ($dir !~ /\?/) ?
0 : 1);
$outer->STORE('SCALE' => undef);
$outer->STORE('PRECISION' => undef);
# Return a list of all subdirectories
my $dh = "DBD::ExampleP::".++$DBD::ExampleP
::gensym
;
my $haveFileSpec = eval { require File
::Spec
};
my $dir = $haveFileSpec ? File
::Spec
->curdir() : ".";
or return $dbh->DBI::set_err
(int($!),
"Failed to open directory $dir: $!");
while (defined(my $file = readdir($dh))) {
my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
push(@list, [ $dir, $pwnam, $file, 'TABLE']);
# We would like to simply do a DBI->connect() here. However,
# this is wrong if we are in a subclass like DBI::ProxyServer.
$dbh->{'dbd_sponge_dbh'} ||= DBI
->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err
($DBI::err
,
"Failed to connect to DBI::Sponge: $DBI::errstr");
'NAME' => ['TABLE_QUALIFIER', 'TABLE_OWNER', 'TABLE_NAME',
'TYPE' => [DBI
::SQL_VARCHAR
(), DBI
::SQL_VARCHAR
(),
DBI
::SQL_VARCHAR
(), DBI
::SQL_VARCHAR
()],
'NULLABLE' => [1, 1, 1, 1]
my $sdbh = $dbh->{'dbd_sponge_dbh'};
my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr)
or return $dbh->DBI::set_err
($sdbh->err(), $sdbh->errstr());
[ 'VARCHAR', DBI
::SQL_VARCHAR
, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ],
[ 'INTEGER', DBI
::SQL_INTEGER
, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ],
shift->STORE(Active
=> 0);
# In reality this would interrogate the database engine to
# either return dynamic values that cannot be precomputed
# or fetch and cache attribute values too expensive to prefetch.
return 1 if $attrib eq 'AutoCommit';
# else pass up to DBI to handle
return $dbh->SUPER::FETCH
($attrib);
my ($dbh, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
if ($attrib eq 'AutoCommit') {
return 1 if $value; # is already set
Carp
::croak
("Can't disable AutoCommit");
return $dbh->SUPER::STORE
($attrib, $value);
$dbh->disconnect if $dbh->FETCH('Active');
# This is an example to demonstrate the use of driver-specific
# methods via $dbh->func().
# my @tables = $dbh->func($re, 'examplep_tables');
# Returns all the tables that match the regular expression $re.
my $dbh = shift; my $re = shift;
grep { $_ =~ /$re/ } $dbh->tables();
{ package DBD
::ExampleP
::st
; # ====== STATEMENT ======
use strict
; no strict
'refs'; # cause problems with filehandles
my $haveFileSpec = eval { require File
::Spec
};
my($sth, $param, $value, $attribs) = @_;
return $sth->DBI::set_err
(2, "Can't bind_param $param, only one parameter")
$sth->{'dbd_param'}->[$param] = $value;
$dir = $sth->{'dbd_param'}->[1];
return $sth->DBI::set_err
(2, "No bind parameter supplied")
# If the users asks for directory "long_list_4532", then we fake a
# directory with files "file4351", "file4350", ..., "file0".
# This is a special case used for testing, especially DBD::Proxy.
if ($dir =~ /^long_list_(\d+)$/) {
$sth->{dbd_dir
} = [ $1 ]; # array ref indicates special mode
$sth->{dbd_datahandle
} = undef;
$sth->{dbd_datahandle
} = "DBD::ExampleP::".++$DBD::ExampleP
::gensym
;
opendir($sth->{dbd_datahandle
}, $dir)
or return $sth->DBI::set_err
(2, "opendir($dir): $!");
$sth->STORE(Active
=> 1);
my $dh = $sth->{dbd_datahandle
};
my $dir = $sth->{dbd_dir
};
if (ref $dir) { # special fake-data test mode
@s{@DBD::ExampleP
::statnames
} =
( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024,
$time, $time, $time, 512, 2, "file$num")
? File
::Spec
->catfile($dir, $f) : "$dir/$f";
# put in all the data fields
@s{ @DBD::ExampleP
::statnames
} = (lstat($file), $f);
# return just what fields the query asks for
my @new = @s{ @
{$sth->{NAME
}} };
return $sth->_set_fbav(\
@new);
*fetchrow_arrayref
= \
&fetch
;
closedir($sth->{dbd_datahandle
}) if $sth->{dbd_datahandle
};
$sth->{dbd_datahandle
} = undef;
# In reality this would interrogate the database engine to
# either return dynamic values that cannot be precomputed
# or fetch and cache attribute values too expensive to prefetch.
my @t = @DBD::ExampleP
::stattypes
{ @
{ $sth->{NAME
} } };
# else pass up to DBI to handle
return $sth->SUPER::FETCH
($attrib);
my ($sth, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
return $sth->{$attrib} = $value
if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION';
return $sth->SUPER::STORE
($attrib, $value);