diff --git a/MANIFEST b/MANIFEST index b967739..c6d4ec9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -15,14 +15,12 @@ dbi_sql.h Definitions based on SQL CLI / ODBC (#inc'd by DBIXS.h) dbipport.h Perl portability macros (from Devel::PPort) dbilogstrip.PL Utility to normalise DBI logs so they can be compared with diff dbiprof.PL -dbiproxy.PL Frontend for DBI::ProxyServer dbivport.h DBI version portability macros (for drivers to copy) dbixs_rev.h Defines DBIXS_REVISION macro holding DBIXS.h subversion revision number dbixs_rev.pl Utility to write dbixs_rev.h ex/perl_dbi_nulls_test.pl A test script for forms of IS NULL qualification in SQL ex/profile.pl A test script for DBI::Profile ex/corogofer.pl A test script for DBD::Gofer::Transport::corostream -lib/Bundle/DBI.pm A bundle for automatic installation via CPAN. lib/DBD/DBM.pm A driver for DBM files (uses DBD::File) lib/DBD/ExampleP.pm A very simple example Driver module lib/DBD/File.pm A driver base class for simple drivers @@ -41,7 +39,6 @@ lib/DBD/Gofer/Transport/pipeone.pm DBD::Gofer transport to new subprocess for ea lib/DBD/Gofer/Transport/stream.pm DBD::Gofer transport for ssh etc lib/DBD/Mem.pm A pure-perl in-memory driver using DBI::DBD::SqlEngine lib/DBD/NullP.pm An empty example Driver module -lib/DBD/Proxy.pm Proxy driver lib/DBD/Sponge.pm A driver for fake cursors (precached data) lib/DBI/Const/GetInfo/ANSI.pm GetInfo data based on ANSI standard lib/DBI/Const/GetInfo/ODBC.pm GetInfo data based on ODBC standard @@ -66,13 +63,10 @@ lib/DBI/ProfileData.pm lib/DBI/ProfileDumper.pm lib/DBI/ProfileDumper/Apache.pm lib/DBI/ProfileSubs.pm -lib/DBI/ProxyServer.pm The proxy drivers server lib/DBI/PurePerl.pm A DBI.xs emulation in Perl lib/DBI/SQL/Nano.pm A 'smaller than micro' SQL parser lib/DBI/Util/_accessor.pm A very�cut-down version of Class::Accessor::Fast lib/DBI/Util/CacheMemory.pm A very cut-down version of Cache::Memory -lib/DBI/W32ODBC.pm An experimental DBI emulation layer for Win32::ODBC -lib/Win32/DBIODBC.pm An experimental Win32::ODBC emulation layer for DBI t/01basics.t t/02dbidrv.t t/03handle.t @@ -110,7 +104,6 @@ t/65transact.t t/70callbacks.t t/72childhandles.t t/73cachedkids.t -t/80proxy.t t/85gofer.t t/86gofer_fail.t t/87gofer_cache.t diff --git a/Makefile.PL b/Makefile.PL index 4a58334..8b3254b 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -88,7 +88,7 @@ my %opts = ( 'DBD::Amazon' => '0.10', }, LICENSE => 'perl', - EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl", "dbilogstrip$ext_pl" ], + EXE_FILES => [ "dbiprof$ext_pl", "dbilogstrip$ext_pl" ], DIR => [ ], dynamic_lib => { OTHERLDFLAGS => "$::opt_g" }, clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t dbi__null_test_tmp* test_output_*" diff --git a/dbiproxy.PL b/dbiproxy.PL deleted file mode 100644 index c2d93d0..0000000 --- a/dbiproxy.PL +++ /dev/null @@ -1,208 +0,0 @@ -# -*- perl -*- - -my $file = $ARGV[0] || 'dbiproxy'; - -my $script = <<'SCRIPT'; -~startperl~ - -use strict; - -my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); - -my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test'; -$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//; - -require DBI::ProxyServer; - -# XXX these should probably be moved into DBI::ProxyServer -delete $ENV{IFS}; -delete $ENV{CDPATH}; -delete $ENV{ENV}; -delete $ENV{BASH_ENV}; - -if ($arg_test) { - require RPC::PlServer::Test; - @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI); -} - -DBI::ProxyServer::main(@ARGV); - -exit(0); - - -__END__ - -=head1 NAME - -dbiproxy - A proxy server for the DBD::Proxy driver - -=head1 SYNOPSIS - - dbiproxy --localport= - - -=head1 DESCRIPTION - -This tool is just a front end for the DBI::ProxyServer package. All it -does is picking options from the command line and calling -DBI::ProxyServer::main(). See L for details. - -Available options include: - -=over 4 - -=item B<--chroot=dir> - -(UNIX only) After doing a bind(), change root directory to the given -directory by doing a chroot(). This is useful for security, but it -restricts the environment a lot. For example, you need to load DBI -drivers in the config file or you have to create hard links to Unix -sockets, if your drivers are using them. For example, with MySQL, a -config file might contain the following lines: - - my $rootdir = '/var/dbiproxy'; - my $unixsockdir = '/tmp'; - my $unixsockfile = 'mysql.sock'; - foreach $dir ($rootdir, "$rootdir$unixsockdir") { - mkdir 0755, $dir; - } - link("$unixsockdir/$unixsockfile", - "$rootdir$unixsockdir/$unixsockfile"); - require DBD::mysql; - - { - 'chroot' => $rootdir, - ... - } - -If you don't know chroot(), think of an FTP server where you can see a -certain directory tree only after logging in. See also the --group and ---user options. - -=item B<--configfile=file> - -Config files are assumed to return a single hash ref that overrides the -arguments of the new method. However, command line arguments in turn take -precedence over the config file. See the "CONFIGURATION FILE" section -in the L documentation for details on the config file. - -=item B<--debug> - -Turn debugging mode on. Mainly this asserts that logging messages of -level "debug" are created. - -=item B<--facility=mode> - -(UNIX only) Facility to use for L. The default is -B. - -=item B<--group=gid> - -After doing a bind(), change the real and effective GID to the given. -This is useful, if you want your server to bind to a privileged port -(<1024), but don't want the server to execute as root. See also -the --user option. - -GID's can be passed as group names or numeric values. - -=item B<--localaddr=ip> - -By default a daemon is listening to any IP number that a machine -has. This attribute allows one to restrict the server to the given -IP number. - -=item B<--localport=port> - -This attribute sets the port on which the daemon is listening. It -must be given somehow, as there's no default. - -=item B<--logfile=file> - -Be default logging messages will be written to the syslog (Unix) or -to the event log (Windows NT). On other operating systems you need to -specify a log file. The special value "STDERR" forces logging to -stderr. See L for details. - -=item B<--mode=modename> - -The server can run in three different modes, depending on the environment. - -If you are running Perl 5.005 and did compile it for threads, then the -server will create a new thread for each connection. The thread will -execute the server's Run() method and then terminate. This mode is the -default, you can force it with "--mode=threads". - -If threads are not available, but you have a working fork(), then the -server will behave similar by creating a new process for each connection. -This mode will be used automatically in the absence of threads or if -you use the "--mode=fork" option. - -Finally there's a single-connection mode: If the server has accepted a -connection, he will enter the Run() method. No other connections are -accepted until the Run() method returns (if the client disconnects). -This operation mode is useful if you have neither threads nor fork(), -for example on the Macintosh. For debugging purposes you can force this -mode with "--mode=single". - -=item B<--pidfile=file> - -(UNIX only) If this option is present, a PID file will be created at the -given location. Default is to not create a pidfile. - -=item B<--user=uid> - -After doing a bind(), change the real and effective UID to the given. -This is useful, if you want your server to bind to a privileged port -(<1024), but don't want the server to execute as root. See also -the --group and the --chroot options. - -UID's can be passed as group names or numeric values. - -=item B<--version> - -Suppresses startup of the server; instead the version string will -be printed and the program exits immediately. - -=back - - -=head1 AUTHOR - - Copyright (c) 1997 Jochen Wiedmann - Am Eisteich 9 - 72555 Metzingen - Germany - - Email: joe@ispsoft.de - Phone: +49 7123 14881 - -The DBI::ProxyServer module is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. In particular -permission is granted to Tim Bunce for distributing this as a part of -the DBI. - - -=head1 SEE ALSO - -L, L, L - -=cut -SCRIPT - - -require Config; -my $config = {}; -$config->{'startperl'} = $Config::Config{'startperl'}; - -$script =~ s/\~(\w+)\~/$config->{$1}/eg; -if (!(open(FILE, ">$file")) || - !(print FILE $script) || - !(close(FILE))) { - die "Error while writing $file: $!\n"; -} -chmod 0755, $file; -print "Extracted $file from ",__FILE__," with variable substitutions.\n"; - -# syntax check resulting file, but only for developers -exit 1 if -d ".svn" || -d ".git" and system($^X, '-wc', '-Mblib', $file) != 0; - diff --git a/dbixs_rev.pl b/dbixs_rev.pl index 9e83eb1..1bbc7cf 100644 --- a/dbixs_rev.pl +++ b/dbixs_rev.pl @@ -1,4 +1,4 @@ -#!perl -w +#!/usr/bin/perl -w use strict; my $dbixs_rev_file = "dbixs_rev.h"; diff --git a/ex/corogofer.pl b/ex/corogofer.pl index 8baa587..4b97567 100644 --- a/ex/corogofer.pl +++ b/ex/corogofer.pl @@ -1,4 +1,4 @@ -#!perl +#!/usr/bin/perl use strict; use warnings; diff --git a/lib/Bundle/DBI.pm b/lib/Bundle/DBI.pm deleted file mode 100644 index 08bff92..0000000 --- a/lib/Bundle/DBI.pm +++ /dev/null @@ -1,52 +0,0 @@ -# -*- perl -*- - -package Bundle::DBI; - -use strict; -our $VERSION = "12.008696"; - -1; - -__END__ - -=head1 NAME - -Bundle::DBI - A bundle to install DBI and required modules. - -=head1 SYNOPSIS - - perl -MCPAN -e 'install Bundle::DBI' - -=head1 CONTENTS - -DBI - for to get to know thyself - -DBI::Shell 11.91 - the DBI command line shell - -Storable 2.06 - for DBD::Proxy, DBI::ProxyServer, DBD::Forward - -Net::Daemon 0.37 - for DBD::Proxy and DBI::ProxyServer - -RPC::PlServer 0.2016 - for DBD::Proxy and DBI::ProxyServer - -DBD::Multiplex 1.19 - treat multiple db handles as one - -=head1 DESCRIPTION - -This bundle includes all the modules used by the Perl Database -Interface (DBI) module, created by Tim Bunce. - -A I is a module that simply defines a collection of other -modules. It is used by the L module to automate the fetching, -building and installing of modules from the CPAN ftp archive sites. - -This bundle does not deal with the various database drivers (e.g. -DBD::Informix, DBD::Oracle etc), most of which require software from -sources other than CPAN. You'll need to fetch and build those drivers -yourself. - -=head1 AUTHORS - -Jonathan Leffler, Jochen Wiedmann and Tim Bunce. - -=cut diff --git a/lib/DBD/Gofer.pm b/lib/DBD/Gofer.pm index 681ed02..bf2ceac 100644 --- a/lib/DBD/Gofer.pm +++ b/lib/DBD/Gofer.pm @@ -1090,7 +1090,7 @@ See the GoferTransport-http distribution on CPAN: http://search.cpan.org/dist/Go =head3 Gearman -I know Ask Bj�rn Hansen has implemented a transport for the C distributed +I know Ask Bjørn Hansen has implemented a transport for the C distributed job system, though it's not on CPAN at the time of writing this. =head1 CONNECTING diff --git a/lib/DBD/Gofer/Transport/corostream.pm b/lib/DBD/Gofer/Transport/corostream.pm deleted file mode 100644 index 6e79278..0000000 --- a/lib/DBD/Gofer/Transport/corostream.pm +++ /dev/null @@ -1,144 +0,0 @@ -package DBD::Gofer::Transport::corostream; - -use strict; -use warnings; - -use Carp; - -use Coro::Select; # a slow but coro-aware replacement for CORE::select (global effect!) - -use Coro; -use Coro::Handle; - -use base qw(DBD::Gofer::Transport::stream); - -# XXX ensure DBI_PUREPERL for parent doesn't pass to child -sub start_pipe_command { - local $ENV{DBI_PUREPERL} = $ENV{DBI_PUREPERL_COROCHILD}; # typically undef - my $connection = shift->SUPER::start_pipe_command(@_); - return $connection; -} - - - -1; - -__END__ - -=head1 NAME - -DBD::Gofer::Transport::corostream - Async DBD::Gofer stream transport using Coro and AnyEvent - -=head1 SYNOPSIS - - DBI_AUTOPROXY="dbi:Gofer:transport=corostream" perl some-perl-script-using-dbi.pl - -or - - $dsn = ...; # the DSN for the driver and database you want to use - $dbh = DBI->connect("dbi:Gofer:transport=corostream;dsn=$dsn", ...); - -=head1 DESCRIPTION - -The I from using L is that it enables the use of existing -DBI frameworks like L. - -=head1 KNOWN ISSUES AND LIMITATIONS - - - Uses Coro::Select so alters CORE::select globally - Parent class probably needs refactoring to enable a more encapsulated approach. - - - Doesn't prevent multiple concurrent requests - Probably just needs a per-connection semaphore - - - Coro has many caveats. Caveat emptor. - -=head1 STATUS - -THIS IS CURRENTLY JUST A PROOF-OF-CONCEPT IMPLEMENTATION FOR EXPERIMENTATION. - -Please note that I have no plans to develop this code further myself. -I'd very much welcome contributions. Interested? Let me know! - -=head1 AUTHOR - -Tim Bunce, L - -=head1 LICENCE AND COPYRIGHT - -Copyright (c) 2010, Tim Bunce, Ireland. All rights reserved. - -This module is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. See L. - -=head1 SEE ALSO - -L - -L - -=head1 APPENDIX - -Example code: - - #!perl - - use strict; - use warnings; - use Time::HiRes qw(time); - - BEGIN { $ENV{PERL_ANYEVENT_STRICT} = 1; $ENV{PERL_ANYEVENT_VERBOSE} = 1; } - - use AnyEvent; - - BEGIN { $ENV{DBI_TRACE} = 0; $ENV{DBI_GOFER_TRACE} = 0; $ENV{DBD_GOFER_TRACE} = 0; }; - - use DBI; - - $ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=corostream'; - - my $ticker = AnyEvent->timer( after => 0, interval => 0.1, cb => sub { - warn sprintf "-tick- %.2f\n", time - } ); - - warn "connecting...\n"; - my $dbh = DBI->connect("dbi:NullP:"); - warn "...connected\n"; - - for (1..3) { - warn "entering DBI...\n"; - $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver - warn "...returned\n"; - } - - warn "done."; - -Example output: - - $ perl corogofer.pl - connecting... - -tick- 1293631437.14 - -tick- 1293631437.14 - ...connected - entering DBI... - -tick- 1293631437.25 - -tick- 1293631437.35 - -tick- 1293631437.45 - -tick- 1293631437.55 - ...returned - entering DBI... - -tick- 1293631437.66 - -tick- 1293631437.76 - -tick- 1293631437.86 - ...returned - entering DBI... - -tick- 1293631437.96 - -tick- 1293631438.06 - -tick- 1293631438.16 - ...returned - done. at corogofer.pl line 39. - -You can see that the timer callback is firing while the code 'waits' inside the -do() method for the response from the database. Normally that would block. - -=cut diff --git a/lib/DBD/Proxy.pm b/lib/DBD/Proxy.pm deleted file mode 100644 index 4240dab..0000000 --- a/lib/DBD/Proxy.pm +++ /dev/null @@ -1,1004 +0,0 @@ -# -*- perl -*- -# -# -# DBD::Proxy - DBI Proxy driver -# -# -# Copyright (c) 1997,1998 Jochen Wiedmann -# -# The DBD::Proxy module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. In particular permission -# is granted to Tim Bunce for distributing this as a part of the DBI. -# -# -# Author: Jochen Wiedmann -# Am Eisteich 9 -# 72555 Metzingen -# Germany -# -# Email: joe@ispsoft.de -# Phone: +49 7123 14881 -# - -use strict; -use Carp; - -require DBI; -DBI->require_version(1.0201); - -use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released - -{ package DBD::Proxy::RPC::PlClient; - @DBD::Proxy::RPC::PlClient::ISA = qw(RPC::PlClient); - sub Call { - my $self = shift; - if ($self->{debug}) { - my ($rpcmeth, $obj, $method, @args) = @_; - local $^W; # silence undefs - Carp::carp("Server $rpcmeth $method(@args)"); - } - return $self->SUPER::Call(@_); - } -} - - -package DBD::Proxy; - -use vars qw($VERSION $drh %ATTR); - -$VERSION = "0.2004"; - -$drh = undef; # holds driver handle once initialised - -%ATTR = ( # common to db & st, see also %ATTR in DBD::Proxy::db & ::st - 'Warn' => 'local', - 'Active' => 'local', - 'Kids' => 'local', - 'CachedKids' => 'local', - 'PrintError' => 'local', - 'RaiseError' => 'local', - 'HandleError' => 'local', - 'TraceLevel' => 'cached', - 'CompatMode' => 'local', -); - -sub driver ($$) { - if (!$drh) { - my($class, $attr) = @_; - - $class .= "::dr"; - - $drh = DBI::_new_drh($class, { - 'Name' => 'Proxy', - 'Version' => $VERSION, - 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', - }); - $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) - } - $drh; -} - -sub CLONE { - undef $drh; -} - -sub proxy_set_err { - my ($h,$errmsg) = @_; - my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//) - ? ($1, $2) : (1, ' ' x 5); - return $h->set_err($err, $errmsg, $state); -} - -package DBD::Proxy::dr; # ====== DRIVER ====== - -$DBD::Proxy::dr::imp_data_size = 0; - -sub connect ($$;$$) { - my($drh, $dsn, $user, $auth, $attr)= @_; - my($dsnOrig) = $dsn; - - my %attr = %$attr; - my ($var, $val); - while (length($dsn)) { - if ($dsn =~ /^dsn=(.*)/) { - $attr{'dsn'} = $1; - last; - } - if ($dsn =~ /^(.*?);(.*)/) { - $var = $1; - $dsn = $2; - } else { - $var = $dsn; - $dsn = ''; - } - if ($var =~ /^(.*?)=(.*)/) { - $var = $1; - $val = $2; - $attr{$var} = $val; - } - } - - my $err = ''; - if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } - if (!defined($attr{'port'})) { $err .= " Missing port."; } - if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } - - # Create a cipher object, if requested - my $cipherRef = undef; - if ($attr{'cipher'}) { - $cipherRef = eval { $attr{'cipher'}->new(pack('H*', - $attr{'key'})) }; - if ($@) { $err .= " Cannot create cipher object: $@."; } - } - my $userCipherRef = undef; - if ($attr{'userkey'}) { - my $cipher = $attr{'usercipher'} || $attr{'cipher'}; - $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; - if ($@) { $err .= " Cannot create usercipher object: $@."; } - } - - return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef - - my %client_opts = ( - 'peeraddr' => $attr{'hostname'}, - 'peerport' => $attr{'port'}, - 'socket_proto' => 'tcp', - 'application' => $attr{dsn}, - 'user' => $user || '', - 'password' => $auth || '', - 'version' => $DBD::Proxy::VERSION, - 'cipher' => $cipherRef, - 'debug' => $attr{debug} || 0, - 'timeout' => $attr{timeout} || undef, - 'logfile' => $attr{logfile} || undef - ); - # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after - # stripping the prefix. - while (my($var,$val) = each %attr) { - if ($var =~ s/^proxy_rpc_//) { - $client_opts{$var} = $val; - } - } - # Create an RPC::PlClient object. - my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) }; - - return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@") - if $@; # Returns undef - return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg") - unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef - - $msg = RPC::PlClient::Object->new($1, $client, $msg); - - my $max_proto_ver; - my ($server_ver_str) = eval { $client->Call('Version') }; - if ( $@ ) { - # Server denies call, assume legacy protocol. - $max_proto_ver = 1; - } else { - # Parse proxy server version. - my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/; - $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1; - } - my $req_proto_ver; - if ( exists $attr{proxy_lazy_prepare} ) { - $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1; - return DBD::Proxy::proxy_set_err($drh, - "DBI::ProxyServer does not support synchronous statement preparation.") - if $max_proto_ver < $req_proto_ver; - } - - # Switch to user specific encryption mode, if desired - if ($userCipherRef) { - $client->{'cipher'} = $userCipherRef; - } - - # create a 'blank' dbh - my $this = DBI::_new_dbh($drh, { - 'Name' => $dsnOrig, - 'proxy_dbh' => $msg, - 'proxy_client' => $client, - 'RowCacheSize' => $attr{'RowCacheSize'} || 20, - 'proxy_proto_ver' => $req_proto_ver || 1 - }); - - foreach $var (keys %attr) { - if ($var =~ /proxy_/) { - $this->{$var} = $attr{$var}; - } - } - $this->SUPER::STORE('Active' => 1); - - $this; -} - - -sub DESTROY { undef } - - -package DBD::Proxy::db; # ====== DATABASE ====== - -$DBD::Proxy::db::imp_data_size = 0; - -# XXX probably many more methods need to be added here -# in order to trigger our AUTOLOAD to redirect them to the server. -# (Unless the sub is declared it's bypassed by perl method lookup.) -# See notes in ToDo about method metadata -# The question is whether to add all the methods in %DBI::DBI_methods -# to the corresponding classes (::db, ::st etc) -# Also need to consider methods that, if proxied, would change the server state -# in a way that might not be visible on the client, ie begin_work -> AutoCommit. - -sub commit; -sub rollback; -sub ping; - -use vars qw(%ATTR $AUTOLOAD); - -# inherited: STORE / FETCH against this class. -# local: STORE / FETCH against parent class. -# cached: STORE to remote and local objects, FETCH from local. -# remote: STORE / FETCH against remote object only (default). -# -# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. -# -%ATTR = ( # see also %ATTR in DBD::Proxy::st - %DBD::Proxy::ATTR, - RowCacheSize => 'inherited', - #AutoCommit => 'cached', - 'FetchHashKeyName' => 'cached', - Statement => 'local', - Driver => 'local', - dbi_connect_closure => 'local', - Username => 'local', -); - -sub AUTOLOAD { - my $method = $AUTOLOAD; - $method =~ s/(.*::(.*)):://; - my $class = $1; - my $type = $2; - #warn "AUTOLOAD of $method (class=$class, type=$type)"; - my %expand = ( - 'method' => $method, - 'class' => $class, - 'type' => $type, - 'call' => "$method(\@_)", - # XXX was trying to be smart but was tripping up over the DBI's own - # smartness. Disabled, but left here in case there are issues. - # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')", - ); - - my $method_code = q{ - package ~class~; - sub ~method~ { - my $h = shift; - local $@; - my @result = wantarray - ? eval { $h->{'proxy_~type~h'}->~call~ } - : eval { scalar $h->{'proxy_~type~h'}->~call~ }; - return DBD::Proxy::proxy_set_err($h, $@) if $@; - return wantarray ? @result : $result[0]; - } - }; - $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; - local $SIG{__DIE__} = 'DEFAULT'; - my $err = do { local $@; eval $method_code.2; $@ }; - die $err if $err; - goto &$AUTOLOAD; -} - -sub DESTROY { - my $dbh = shift; - local $@ if $@; # protect $@ - $dbh->disconnect if $dbh->SUPER::FETCH('Active'); -} - - -sub connected { } # client-side not server-side, RT#75868 - -sub disconnect ($) { - my ($dbh) = @_; - - # Sadly the Proxy too-often disagrees with the backend database - # on the subject of 'Active'. In the short term, I'd like the - # Proxy to ease up and let me decide when it's proper to go over - # the wire. This ultimately applies to finish() as well. - #return unless $dbh->SUPER::FETCH('Active'); - - # Drop database connection at remote end - my $rdbh = $dbh->{'proxy_dbh'}; - if ( $rdbh ) { - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - eval { $rdbh->disconnect() } ; - DBD::Proxy::proxy_set_err($dbh, $@) if $@; - } - - # Close TCP connect to remote - # XXX possibly best left till DESTROY? Add a config attribute to choose? - #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module - $dbh->{proxy_client}->{socket} = undef; # hack - - $dbh->SUPER::STORE('Active' => 0); - 1; -} - - -sub STORE ($$$) { - my($dbh, $attr, $val) = @_; - my $type = $ATTR{$attr} || 'remote'; - - if ($attr eq 'TraceLevel') { - warn("TraceLevel $val"); - my $pc = $dbh->{proxy_client} || die; - $pc->{logfile} ||= 1; # XXX hack - $pc->{debug} = ($val && $val >= 4); - $pc->Debug("$pc debug enabled") if $pc->{debug}; - } - - if ($attr =~ /^proxy_/ || $type eq 'inherited') { - $dbh->{$attr} = $val; - return 1; - } - - if ($type eq 'remote' || $type eq 'cached') { - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; - return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef - $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; - return $result; - } - return $dbh->SUPER::STORE($attr => $val); -} - -sub FETCH ($$) { - my($dbh, $attr) = @_; - # we only get here for cached attribute values if the handle is in CompatMode - # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache. - my $type = $ATTR{$attr} || 'remote'; - - if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { - return $dbh->{$attr}; - } - - return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; - - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; - return DBD::Proxy::proxy_set_err($dbh, $@) if $@; - return $result; -} - -sub prepare ($$;$) { - my($dbh, $stmt, $attr) = @_; - my $sth = DBI::_new_sth($dbh, { - 'Statement' => $stmt, - 'proxy_attr' => $attr, - 'proxy_cache_only' => 0, - 'proxy_params' => [], - } - ); - my $proto_ver = $dbh->{'proxy_proto_ver'}; - if ( $proto_ver > 1 ) { - $sth->{'proxy_attr_cache'} = {cache_filled => 0}; - my $rdbh = $dbh->{'proxy_dbh'}; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") - unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); - - my $client = $dbh->{'proxy_client'}; - $rsth = RPC::PlClient::Object->new($1, $client, $rsth); - - $sth->{'proxy_sth'} = $rsth; - # If statement is a positioned update we do not want any readahead. - $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i; - # Since resources are used by prepared remote handle, mark us active. - $sth->SUPER::STORE(Active => 1); - } - $sth; -} - -sub quote { - my $dbh = shift; - my $proxy_quote = $dbh->{proxy_quote} || 'remote'; - - return $dbh->SUPER::quote(@_) - if $proxy_quote eq 'local' && @_ == 1; - - # For the common case of only a single argument - # (no $data_type) we could learn and cache the behaviour. - # Or we could probe the driver with a few test cases. - # Or we could add a way to ask the DBI::ProxyServer - # if $dbh->can('quote') == \&DBI::_::db::quote. - # Tim - # - # Sounds all *very* smart to me. I'd rather suggest to - # implement some of the typical quote possibilities - # and let the user set - # $dbh->{'proxy_quote'} = 'backslash_escaped'; - # for example. - # Jochen - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; - return DBD::Proxy::proxy_set_err($dbh, $@) if $@; - return $result; -} - -sub table_info { - my $dbh = shift; - my $rdbh = $dbh->{'proxy_dbh'}; - #warn "table_info(@_)"; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; - return DBD::Proxy::proxy_set_err($dbh, $@) if $@; - my ($sth, $inner) = DBI::_new_sth($dbh, { - 'Statement' => "SHOW TABLES", - 'proxy_params' => [], - 'proxy_data' => \@rows, - 'proxy_attr_cache' => { - 'NUM_OF_PARAMS' => 0, - 'NUM_OF_FIELDS' => $numFields, - 'NAME' => $names, - 'TYPE' => $types, - 'cache_filled' => 1 - }, - 'proxy_cache_only' => 1, - }); - $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); - $inner->{NAME} = $names; - $inner->{TYPE} = $types; - $sth->SUPER::STORE('Active' => 1); # already execute()'d - $sth->{'proxy_rows'} = @rows; - return $sth; -} - -sub tables { - my $dbh = shift; - #warn "tables(@_)"; - return $dbh->SUPER::tables(@_); -} - - -sub type_info_all { - my $dbh = shift; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; - return DBD::Proxy::proxy_set_err($dbh, $@) if $@; - return $result; -} - - -package DBD::Proxy::st; # ====== STATEMENT ====== - -$DBD::Proxy::st::imp_data_size = 0; - -use vars qw(%ATTR); - -# inherited: STORE to current object. FETCH from current if exists, else call up -# to the (proxy) database object. -# local: STORE / FETCH against parent class. -# cache_only: STORE noop (read-only). FETCH from private_* if exists, else call -# remote and cache the result. -# remote: STORE / FETCH against remote object only (default). -# -# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. -# -%ATTR = ( # see also %ATTR in DBD::Proxy::db - %DBD::Proxy::ATTR, - 'Database' => 'local', - 'RowsInCache' => 'local', - 'RowCacheSize' => 'inherited', - 'NULLABLE' => 'cache_only', - 'NAME' => 'cache_only', - 'TYPE' => 'cache_only', - 'PRECISION' => 'cache_only', - 'SCALE' => 'cache_only', - 'NUM_OF_FIELDS' => 'cache_only', - 'NUM_OF_PARAMS' => 'cache_only' -); - -*AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; - -sub execute ($@) { - my $sth = shift; - my $params = @_ ? \@_ : $sth->{'proxy_params'}; - - # new execute, so delete any cached rows from previous execute - undef $sth->{'proxy_data'}; - undef $sth->{'proxy_rows'}; - - my $rsth = $sth->{proxy_sth}; - my $dbh = $sth->FETCH('Database'); - my $proto_ver = $dbh->{proxy_proto_ver}; - - my ($numRows, @outData); - - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - if ( $proto_ver > 1 ) { - ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - - # Attributes passed back only on the first execute() of a statement. - unless ($sth->{proxy_attr_cache}->{cache_filled}) { - my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); - $sth->{'proxy_attr_cache'} = { - 'NUM_OF_FIELDS' => $numFields, - 'NUM_OF_PARAMS' => $numParams, - 'NAME' => $names, - 'cache_filled' => 1 - }; - $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); - $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); - } - - } - else { - if ($rsth) { - ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - - } - else { - my $rdbh = $dbh->{'proxy_dbh'}; - - # Legacy prepare is actually prepare + first execute on the server. - ($rsth, @outData) = - eval { $rdbh->prepare($sth->{'Statement'}, - $sth->{'proxy_attr'}, $params, $proto_ver) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") - unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); - - my $client = $dbh->{'proxy_client'}; - $rsth = RPC::PlClient::Object->new($1, $client, $rsth); - - my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); - $sth->{'proxy_sth'} = $rsth; - $sth->{'proxy_attr_cache'} = { - 'NUM_OF_FIELDS' => $numFields, - 'NUM_OF_PARAMS' => $numParams, - 'NAME' => $names - }; - $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); - $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); - $numRows = shift @outData; - } - } - # Always condition active flag. - $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT - $sth->{'proxy_rows'} = $numRows; - # Any remaining items are output params. - if (@outData) { - foreach my $p (@$params) { - if (ref($p->[0])) { - my $ref = shift @outData; - ${$p->[0]} = $$ref; - } - } - } - - $sth->{'proxy_rows'} || '0E0'; -} - -sub fetch ($) { - my $sth = shift; - - my $data = $sth->{'proxy_data'}; - - $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'}; - - if(!$data || !@$data) { - return undef unless $sth->SUPER::FETCH('Active'); - - my $rsth = $sth->{'proxy_sth'}; - if (!$rsth) { - die "Attempt to fetch row without execute"; - } - my $num_rows = $sth->FETCH('RowCacheSize') || 20; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my @rows = eval { $rsth->fetch($num_rows) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - unless (@rows == $num_rows) { - undef $sth->{'proxy_data'}; - # server side has already called finish - $sth->SUPER::STORE(Active => 0); - } - return undef unless @rows; - $sth->{'proxy_data'} = $data = [@rows]; - } - my $row = shift @$data; - - $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); - $sth->{'proxy_rows'}++; - return $sth->_set_fbav($row); -} -*fetchrow_arrayref = \&fetch; - -sub rows ($) { - my $rows = shift->{'proxy_rows'}; - return (defined $rows) ? $rows : -1; -} - -sub finish ($) { - my($sth) = @_; - return 1 unless $sth->SUPER::FETCH('Active'); - my $rsth = $sth->{'proxy_sth'}; - $sth->SUPER::STORE('Active' => 0); - return 0 unless $rsth; # Something's out of sync - my $no_finish = exists($sth->{'proxy_no_finish'}) - ? $sth->{'proxy_no_finish'} - : $sth->FETCH('Database')->{'proxy_no_finish'}; - unless ($no_finish) { - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $rsth->finish() }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - return $result; - } - 1; -} - -sub STORE ($$$) { - my($sth, $attr, $val) = @_; - my $type = $ATTR{$attr} || 'remote'; - - if ($attr =~ /^proxy_/ || $type eq 'inherited') { - $sth->{$attr} = $val; - return 1; - } - - if ($type eq 'cache_only') { - return 0; - } - - if ($type eq 'remote' || $type eq 'cached') { - my $rsth = $sth->{'proxy_sth'} or return undef; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $rsth->STORE($attr => $val) }; - return DBD::Proxy::proxy_set_err($sth, $@) if ($@); - return $result if $type eq 'remote'; # else fall through to cache locally - } - return $sth->SUPER::STORE($attr => $val); -} - -sub FETCH ($$) { - my($sth, $attr) = @_; - - if ($attr =~ /^proxy_/) { - return $sth->{$attr}; - } - - my $type = $ATTR{$attr} || 'remote'; - if ($type eq 'inherited') { - if (exists($sth->{$attr})) { - return $sth->{$attr}; - } - return $sth->FETCH('Database')->{$attr}; - } - - if ($type eq 'cache_only' && - exists($sth->{'proxy_attr_cache'}->{$attr})) { - return $sth->{'proxy_attr_cache'}->{$attr}; - } - - if ($type ne 'local') { - my $rsth = $sth->{'proxy_sth'} or return undef; - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - my $result = eval { $rsth->FETCH($attr) }; - return DBD::Proxy::proxy_set_err($sth, $@) if $@; - return $result; - } - elsif ($attr eq 'RowsInCache') { - my $data = $sth->{'proxy_data'}; - $data ? @$data : 0; - } - else { - $sth->SUPER::FETCH($attr); - } -} - -sub bind_param ($$$@) { - my $sth = shift; my $param = shift; - $sth->{'proxy_params'}->[$param-1] = [@_]; -} -*bind_param_inout = \&bind_param; - -sub DESTROY { - my $sth = shift; - $sth->finish if $sth->SUPER::FETCH('Active'); -} - - -1; - - -__END__ - -=head1 NAME - -DBD::Proxy - A proxy driver for the DBI - -=head1 SYNOPSIS - - use DBI; - - $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", - $user, $passwd); - - # See the DBI module documentation for full details - -=head1 DESCRIPTION - -DBD::Proxy is a Perl module for connecting to a database via a remote -DBI driver. See L for an alternative with different trade-offs. - -This is of course not needed for DBI drivers which already -support connecting to a remote database, but there are engines which -don't offer network connectivity. - -Another application is offering database access through a firewall, as -the driver offers query based restrictions. For example you can -restrict queries to exactly those that are used in a given CGI -application. - -Speaking of CGI, another application is (or rather, will be) to reduce -the database connect/disconnect overhead from CGI scripts by using -proxying the connect_cached method. The proxy server will hold the -database connections open in a cache. The CGI script then trades the -database connect/disconnect overhead for the DBD::Proxy -connect/disconnect overhead which is typically much less. - - -=head1 CONNECTING TO THE DATABASE - -Before connecting to a remote database, you must ensure, that a Proxy -server is running on the remote machine. There's no default port, so -you have to ask your system administrator for the port number. See -L for details. - -Say, your Proxy server is running on machine "alpha", port 3334, and -you'd like to connect to an ODBC database called "mydb" as user "joe" -with password "hello". When using DBD::ODBC directly, you'd do a - - $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); - -With DBD::Proxy this becomes - - $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; - $dbh = DBI->connect($dsn, "joe", "hello"); - -You see, this is mainly the same. The DBD::Proxy module will create a -connection to the Proxy server on "alpha" which in turn will connect -to the ODBC database. - -Refer to the L documentation on the C method for a way -to automatically use DBD::Proxy without having to change your code. - -DBD::Proxy's DSN string has the format - - $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; - -In other words, it is a collection of key/value pairs. The following -keys are recognized: - -=over 4 - -=item hostname - -=item port - -Hostname and port of the Proxy server; these keys must be present, -no defaults. Example: - - hostname=alpha;port=3334 - -=item dsn - -The value of this attribute will be used as a dsn name by the Proxy -server. Thus it must have the format C, in particular -it will contain colons. The I value may contain semicolons, hence -this key *must* be the last and it's value will be the complete -remaining part of the dsn. Example: - - dsn=DBI:ODBC:mydb - -=item cipher - -=item key - -=item usercipher - -=item userkey - -By using these fields you can enable encryption. If you set, -for example, - - cipher=$class;key=$key - -(note the semicolon) then DBD::Proxy will create a new cipher object -by executing - - $cipherRef = $class->new(pack("H*", $key)); - -and pass this object to the RPC::PlClient module when creating a -client. See L. Example: - - cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 - -The usercipher/userkey attributes allow you to use two phase encryption: -The cipher/key encryption will be used in the login and authorisation -phase. Once the client is authorised, he will change to usercipher/userkey -encryption. Thus the cipher/key pair is a B based secret, typically -less secure than the usercipher/userkey secret and readable by anyone. -The usercipher/userkey secret is B private secret. - -Of course encryption requires an appropriately configured server. See -L. - -=item debug - -Turn on debugging mode - -=item stderr - -This attribute will set the corresponding attribute of the RPC::PlClient -object, thus logging will not use syslog(), but redirected to stderr. -This is the default under Windows. - - stderr=1 - -=item logfile - -Similar to the stderr attribute, but output will be redirected to the -given file. - - logfile=/dev/null - -=item RowCacheSize - -The DBD::Proxy driver supports this attribute (which is DBI standard, -as of DBI 1.02). It's used to reduce network round-trips by fetching -multiple rows in one go. The current default value is 20, but this may -change. - - -=item proxy_no_finish - -This attribute can be used to reduce network traffic: If the -application is calling $sth->finish() then the proxy tells the server -to finish the remote statement handle. Of course this slows down things -quite a lot, but is perfectly good for reducing memory usage with -persistent connections. - -However, if you set the I attribute to a TRUE value, -either in the database handle or in the statement handle, then finish() -calls will be suppressed. This is what you want, for example, in small -and fast CGI applications. - -=item proxy_quote - -This attribute can be used to reduce network traffic: By default calls -to $dbh->quote() are passed to the remote driver. Of course this slows -down things quite a lot, but is the safest default behaviour. - -However, if you set the I attribute to the value 'C' -either in the database handle or in the statement handle, and the call -to quote has only one parameter, then the local default DBI quote -method will be used (which will be faster but may be wrong). - -=back - -=head1 KNOWN ISSUES - -=head2 Unproxied method calls - -If a method isn't being proxied, try declaring a stub sub in the appropriate -package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method). -For example: - - sub DBD::Proxy::db::selectall_arrayref; - -That will enable selectall_arrayref to be proxied. - -Currently many methods aren't explicitly proxied and so you get the DBI's -default methods executed on the client. - -Some of those methods, like selectall_arrayref, may then call other methods -that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch -which is proxied). So things may appear to work but operate more slowly than -the could. - -This may all change in a later version. - -=head2 Complex handle attributes - -Sometimes handles are having complex attributes like hash refs or -array refs and not simple strings or integers. For example, with -DBD::CSV, you would like to write something like - - $dbh->{"csv_tables"}->{"passwd"} = - { "sep_char" => ":", "eol" => "\n"; - -The above example would advice the CSV driver to assume the file -"passwd" to be in the format of the /etc/passwd file: Colons as -separators and a line feed without carriage return as line -terminator. - -Surprisingly this example doesn't work with the proxy driver. To understand -the reasons, you should consider the following: The Perl compiler is -executing the above example in two steps: - -=over - -=item 1 - -The first step is fetching the value of the key "csv_tables" in the -handle $dbh. The value returned is complex, a hash ref. - -=item 2 - -The second step is storing some value (the right hand side of the -assignment) as the key "passwd" in the hash ref from step 1. - -=back - -This becomes a little bit clearer, if we rewrite the above code: - - $tables = $dbh->{"csv_tables"}; - $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; - -While the examples work fine without the proxy, the fail due to a -subtle difference in step 1: By DBI magic, the hash ref -$dbh->{'csv_tables'} is returned from the server to the client. -The client creates a local copy. This local copy is the result of -step 1. In other words, step 2 modifies a local copy of the hash ref, -but not the server's hash ref. - -The workaround is storing the modified local copy back to the server: - - $tables = $dbh->{"csv_tables"}; - $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; - $dbh->{"csv_tables"} = $tables; - - -=head1 SECURITY WARNING - -L used underneath is not secure due to serializing and -deserializing data with L module. Use the proxy driver only in -trusted environment. - - -=head1 AUTHOR AND COPYRIGHT - -This module is Copyright (c) 1997, 1998 - - Jochen Wiedmann - Am Eisteich 9 - 72555 Metzingen - Germany - - Email: joe@ispsoft.de - Phone: +49 7123 14887 - -The DBD::Proxy module is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. In particular permission -is granted to Tim Bunce for distributing this as a part of the DBI. - - -=head1 SEE ALSO - -L, L, L - -=cut diff --git a/lib/DBI/ProxyServer.pm b/lib/DBI/ProxyServer.pm deleted file mode 100644 index ef21849..0000000 --- a/lib/DBI/ProxyServer.pm +++ /dev/null @@ -1,897 +0,0 @@ -# $Header: /home/timbo/dbi/lib/DBI/RCS/ProxyServer.pm,v 11.9 2003/05/14 11:08:17 timbo Exp $ -# -*- perl -*- -# -# DBI::ProxyServer - a proxy server for DBI drivers -# -# Copyright (c) 1997 Jochen Wiedmann -# -# The DBD::Proxy module is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. In particular permission -# is granted to Tim Bunce for distributing this as a part of the DBI. -# -# -# Author: Jochen Wiedmann -# Am Eisteich 9 -# 72555 Metzingen -# Germany -# -# Email: joe@ispsoft.de -# Phone: +49 7123 14881 -# -# -############################################################################## - - -require 5.004; -use strict; - -use RPC::PlServer 0.2001; -require DBI; -require Config; - - -package DBI::ProxyServer; - - - -############################################################################ -# -# Constants -# -############################################################################ - -use vars qw($VERSION @ISA); - -$VERSION = "0.3005"; -@ISA = qw(RPC::PlServer DBI); - - -# Most of the options below are set to default values, we note them here -# just for the sake of documentation. -my %DEFAULT_SERVER_OPTIONS; -{ - my $o = \%DEFAULT_SERVER_OPTIONS; - $o->{'chroot'} = undef, # To be used in the initfile, - # after loading the required - # DBI drivers. - $o->{'clients'} = - [ { 'mask' => '.*', - 'accept' => 1, - 'cipher' => undef - } - ]; - $o->{'configfile'} = '/etc/dbiproxy.conf' if -f '/etc/dbiproxy.conf'; - $o->{'debug'} = 0; - $o->{'facility'} = 'daemon'; - $o->{'group'} = undef; - $o->{'localaddr'} = undef; # Bind to any local IP number - $o->{'localport'} = undef; # Must set port number on the - # command line. - $o->{'logfile'} = undef; # Use syslog or EventLog. - - # XXX don't restrict methods that can be called (trust users once connected) - $o->{'XXX_methods'} = { - 'DBI::ProxyServer' => { - 'Version' => 1, - 'NewHandle' => 1, - 'CallMethod' => 1, - 'DestroyHandle' => 1 - }, - 'DBI::ProxyServer::db' => { - 'prepare' => 1, - 'commit' => 1, - 'rollback' => 1, - 'STORE' => 1, - 'FETCH' => 1, - 'func' => 1, - 'quote' => 1, - 'type_info_all' => 1, - 'table_info' => 1, - 'disconnect' => 1, - }, - 'DBI::ProxyServer::st' => { - 'execute' => 1, - 'STORE' => 1, - 'FETCH' => 1, - 'func' => 1, - 'fetch' => 1, - 'finish' => 1 - } - }; - if ($Config::Config{'usethreads'} eq 'define') { - $o->{'mode'} = 'threads'; - } elsif ($Config::Config{'d_fork'} eq 'define') { - $o->{'mode'} = 'fork'; - } else { - $o->{'mode'} = 'single'; - } - # No pidfile by default, configuration must provide one if needed - $o->{'pidfile'} = 'none'; - $o->{'user'} = undef; -}; - - -############################################################################ -# -# Name: Version -# -# Purpose: Return version string -# -# Inputs: $class - This class -# -# Result: Version string; suitable for printing by "--version" -# -############################################################################ - -sub Version { - my $version = $DBI::ProxyServer::VERSION; - "DBI::ProxyServer $version, Copyright (C) 1998, Jochen Wiedmann"; -} - - -############################################################################ -# -# Name: AcceptApplication -# -# Purpose: Verify DBI DSN -# -# Inputs: $self - This instance -# $dsn - DBI dsn -# -# Returns: TRUE for a valid DSN, FALSE otherwise -# -############################################################################ - -sub AcceptApplication { - my $self = shift; my $dsn = shift; - $dsn =~ /^dbi:\w+:/i; -} - - -############################################################################ -# -# Name: AcceptVersion -# -# Purpose: Verify requested DBI version -# -# Inputs: $self - Instance -# $version - DBI version being requested -# -# Returns: TRUE for ok, FALSE otherwise -# -############################################################################ - -sub AcceptVersion { - my $self = shift; my $version = shift; - require DBI; - DBI::ProxyServer->init_rootclass(); - $DBI::VERSION >= $version; -} - - -############################################################################ -# -# Name: AcceptUser -# -# Purpose: Verify user and password by connecting to the client and -# creating a database connection -# -# Inputs: $self - Instance -# $user - User name -# $password - Password -# -############################################################################ - -sub AcceptUser { - my $self = shift; my $user = shift; my $password = shift; - return 0 if (!$self->SUPER::AcceptUser($user, $password)); - my $dsn = $self->{'application'}; - $self->Debug("Connecting to $dsn as $user"); - local $ENV{DBI_AUTOPROXY} = ''; # :-) - $self->{'dbh'} = eval { - DBI::ProxyServer->connect($dsn, $user, $password, - { 'PrintError' => 0, - 'Warn' => 0, - 'RaiseError' => 1, - 'HandleError' => sub { - my $err = $_[1]->err; - my $state = $_[1]->state || ''; - $_[0] .= " [err=$err,state=$state]"; - return 0; - } }) - }; - if ($@) { - $self->Error("Error while connecting to $dsn as $user: $@"); - return 0; - } - [1, $self->StoreHandle($self->{'dbh'}) ]; -} - - -sub CallMethod { - my $server = shift; - my $dbh = $server->{'dbh'}; - # We could store the private_server attribute permanently in - # $dbh. However, we'd have a reference loop in that case and - # I would be concerned about garbage collection. :-( - $dbh->{'private_server'} = $server; - $server->Debug("CallMethod: => " . do { local $^W; join(",", @_)}); - my @result = eval { $server->SUPER::CallMethod(@_) }; - my $msg = $@; - undef $dbh->{'private_server'}; - if ($msg) { - $server->Debug("CallMethod died with: $@"); - die $msg; - } else { - $server->Debug("CallMethod: <= " . do { local $^W; join(",", @result) }); - } - @result; -} - - -sub main { - my $server = DBI::ProxyServer->new(\%DEFAULT_SERVER_OPTIONS, \@_); - $server->Bind(); -} - - -############################################################################ -# -# The DBI part of the proxyserver is implemented as a DBI subclass. -# Thus we can reuse some of the DBI methods and overwrite only -# those that need additional handling. -# -############################################################################ - -package DBI::ProxyServer::dr; - -@DBI::ProxyServer::dr::ISA = qw(DBI::dr); - - -package DBI::ProxyServer::db; - -@DBI::ProxyServer::db::ISA = qw(DBI::db); - -sub prepare { - my($dbh, $statement, $attr, $params, $proto_ver) = @_; - my $server = $dbh->{'private_server'}; - if (my $client = $server->{'client'}) { - if ($client->{'sql'}) { - if ($statement =~ /^\s*(\S+)/) { - my $st = $1; - if (!($statement = $client->{'sql'}->{$st})) { - die "Unknown SQL query: $st"; - } - } else { - die "Cannot parse restricted SQL statement: $statement"; - } - } - } - my $sth = $dbh->SUPER::prepare($statement, $attr); - my $handle = $server->StoreHandle($sth); - - if ( $proto_ver and $proto_ver > 1 ) { - $sth->{private_proxyserver_described} = 0; - return $handle; - - } else { - # The difference between the usual prepare and ours is that we implement - # a combined prepare/execute. The DBD::Proxy driver doesn't call us for - # prepare. Only if an execute happens, then we are called with method - # "prepare". Further execute's are called as "execute". - my @result = $sth->execute($params); - my ($NAME, $TYPE); - my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS}; - if ($NUM_OF_FIELDS) { # is a SELECT - $NAME = $sth->{NAME}; - $TYPE = $sth->{TYPE}; - } - ($handle, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, - $NAME, $TYPE, @result); - } -} - -sub table_info { - my $dbh = shift; - my $sth = $dbh->SUPER::table_info(); - my $numFields = $sth->{'NUM_OF_FIELDS'}; - my $names = $sth->{'NAME'}; - my $types = $sth->{'TYPE'}; - - # We wouldn't need to send all the rows at this point, instead we could - # make use of $rsth->fetch() on the client as usual. - # The problem is that some drivers (namely DBD::ExampleP, DBD::mysql and - # DBD::mSQL) are returning foreign sth's here, thus an instance of - # DBI::st and not DBI::ProxyServer::st. We could fix this by permitting - # the client to execute method DBI::st, but I don't like this. - my @rows; - while (my ($row) = $sth->fetch()) { - last unless defined $row; - push(@rows, [@$row]); - } - ($numFields, $names, $types, @rows); -} - - -package DBI::ProxyServer::st; - -@DBI::ProxyServer::st::ISA = qw(DBI::st); - -sub execute { - my $sth = shift; my $params = shift; my $proto_ver = shift; - my @outParams; - if ($params) { - for (my $i = 0; $i < @$params;) { - my $param = $params->[$i++]; - if (!ref($param)) { - $sth->bind_param($i, $param); - } - else { - if (!ref(@$param[0])) {#It's not a reference - $sth->bind_param($i, @$param); - } - else { - $sth->bind_param_inout($i, @$param); - my $ref = shift @$param; - push(@outParams, $ref); - } - } - } - } - my $rows = $sth->SUPER::execute(); - if ( $proto_ver and $proto_ver > 1 and not $sth->{private_proxyserver_described} ) { - my ($NAME, $TYPE); - my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS}; - if ($NUM_OF_FIELDS) { # is a SELECT - $NAME = $sth->{NAME}; - $TYPE = $sth->{TYPE}; - } - $sth->{private_proxyserver_described} = 1; - # First execution, we ship back description. - return ($rows, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, $NAME, $TYPE, @outParams); - } - ($rows, @outParams); -} - -sub fetch { - my $sth = shift; my $numRows = shift || 1; - my($ref, @rows); - while ($numRows-- && ($ref = $sth->SUPER::fetch())) { - push(@rows, [@$ref]); - } - @rows; -} - - -1; - - -__END__ - -=head1 NAME - -DBI::ProxyServer - a server for the DBD::Proxy driver - -=head1 SYNOPSIS - - use DBI::ProxyServer; - DBI::ProxyServer::main(@ARGV); - -=head1 DESCRIPTION - -DBI::Proxy Server is a module for implementing a proxy for the DBI proxy -driver, DBD::Proxy. It allows access to databases over the network if the -DBMS does not offer networked operations. But the proxy server might be -useful for you, even if you have a DBMS with integrated network -functionality: It can be used as a DBI proxy in a firewalled environment. - -DBI::ProxyServer runs as a daemon on the machine with the DBMS or on the -firewall. The client connects to the agent using the DBI driver DBD::Proxy, -thus in the exactly same way than using DBD::mysql, DBD::mSQL or any other -DBI driver. - -The agent is implemented as a RPC::PlServer application. Thus you have -access to all the possibilities of this module, in particular encryption -and a similar configuration file. DBI::ProxyServer adds the possibility of -query restrictions: You can define a set of queries that a client may -execute and restrict access to those. (Requires a DBI driver that supports -parameter binding.) See L. - -The provided driver script, L, may either be used as it is or -used as the basis for a local version modified to meet your needs. - -=head1 OPTIONS - -When calling the DBI::ProxyServer::main() function, you supply an -array of options. These options are parsed by the Getopt::Long module. -The ProxyServer inherits all of RPC::PlServer's and hence Net::Daemon's -options and option handling, in particular the ability to read -options from either the command line or a config file. See -L. See L. Available options include - -=over 4 - -=item I (B<--chroot=dir>) - -(UNIX only) After doing a bind(), change root directory to the given -directory by doing a chroot(). This is useful for security, but it -restricts the environment a lot. For example, you need to load DBI -drivers in the config file or you have to create hard links to Unix -sockets, if your drivers are using them. For example, with MySQL, a -config file might contain the following lines: - - my $rootdir = '/var/dbiproxy'; - my $unixsockdir = '/tmp'; - my $unixsockfile = 'mysql.sock'; - foreach $dir ($rootdir, "$rootdir$unixsockdir") { - mkdir 0755, $dir; - } - link("$unixsockdir/$unixsockfile", - "$rootdir$unixsockdir/$unixsockfile"); - require DBD::mysql; - - { - 'chroot' => $rootdir, - ... - } - -If you don't know chroot(), think of an FTP server where you can see a -certain directory tree only after logging in. See also the --group and ---user options. - -=item I - -An array ref with a list of clients. Clients are hash refs, the attributes -I (0 for denying access and 1 for permitting) and I, a Perl -regular expression for the clients IP number or its host name. - -=item I (B<--configfile=file>) - -Config files are assumed to return a single hash ref that overrides the -arguments of the new method. However, command line arguments in turn take -precedence over the config file. See the L<"CONFIGURATION FILE"> section -below for details on the config file. - -=item I (B<--debug>) - -Turn debugging mode on. Mainly this asserts that logging messages of -level "debug" are created. - -=item I (B<--facility=mode>) - -(UNIX only) Facility to use for L. The default is -B. - -=item I (B<--group=gid>) - -After doing a bind(), change the real and effective GID to the given. -This is useful, if you want your server to bind to a privileged port -(<1024), but don't want the server to execute as root. See also -the --user option. - -GID's can be passed as group names or numeric values. - -=item I (B<--localaddr=ip>) - -By default a daemon is listening to any IP number that a machine -has. This attribute allows one to restrict the server to the given -IP number. - -=item I (B<--localport=port>) - -This attribute sets the port on which the daemon is listening. It -must be given somehow, as there's no default. - -=item I (B<--logfile=file>) - -Be default logging messages will be written to the syslog (Unix) or -to the event log (Windows NT). On other operating systems you need to -specify a log file. The special value "STDERR" forces logging to -stderr. See L for details. - -=item I (B<--mode=modename>) - -The server can run in three different modes, depending on the environment. - -If you are running Perl 5.005 and did compile it for threads, then the -server will create a new thread for each connection. The thread will -execute the server's Run() method and then terminate. This mode is the -default, you can force it with "--mode=threads". - -If threads are not available, but you have a working fork(), then the -server will behave similar by creating a new process for each connection. -This mode will be used automatically in the absence of threads or if -you use the "--mode=fork" option. - -Finally there's a single-connection mode: If the server has accepted a -connection, he will enter the Run() method. No other connections are -accepted until the Run() method returns (if the client disconnects). -This operation mode is useful if you have neither threads nor fork(), -for example on the Macintosh. For debugging purposes you can force this -mode with "--mode=single". - -=item I (B<--pidfile=file>) - -(UNIX only) If this option is present, a PID file will be created at the -given location. Default is to not create a pidfile. - -=item I (B<--user=uid>) - -After doing a bind(), change the real and effective UID to the given. -This is useful, if you want your server to bind to a privileged port -(<1024), but don't want the server to execute as root. See also -the --group and the --chroot options. - -UID's can be passed as group names or numeric values. - -=item I (B<--version>) - -Suppresses startup of the server; instead the version string will -be printed and the program exits immediately. - -=back - -=head1 SHUTDOWN - -DBI::ProxyServer is built on L which is, in turn, built on L. - -You should refer to L for how to shutdown the server, except that -you can't because it's not currently documented there (as of v0.43). -The bottom-line is that it seems that there's no support for graceful shutdown. - -=head1 CONFIGURATION FILE - -The configuration file is just that of I or I -with some additional attributes in the client list. - -The config file is a Perl script. At the top of the file you may include -arbitrary Perl source, for example load drivers at the start (useful -to enhance performance), prepare a chroot environment and so on. - -The important thing is that you finally return a hash ref of option -name/value pairs. The possible options are listed above. - -All possibilities of Net::Daemon and RPC::PlServer apply, in particular - -=over 4 - -=item Host and/or User dependent access control - -=item Host and/or User dependent encryption - -=item Changing UID and/or GID after binding to the port - -=item Running in a chroot() environment - -=back - -Additionally the server offers you query restrictions. Suggest the -following client list: - - 'clients' => [ - { 'mask' => '^admin\.company\.com$', - 'accept' => 1, - 'users' => [ 'root', 'wwwrun' ], - }, - { - 'mask' => '^admin\.company\.com$', - 'accept' => 1, - 'users' => [ 'root', 'wwwrun' ], - 'sql' => { - 'select' => 'SELECT * FROM foo', - 'insert' => 'INSERT INTO foo VALUES (?, ?, ?)' - } - } - -then only the users root and wwwrun may connect from admin.company.com, -executing arbitrary queries, but only wwwrun may connect from other -hosts and is restricted to - - $sth->prepare("select"); - -or - - $sth->prepare("insert"); - -which in fact are "SELECT * FROM foo" or "INSERT INTO foo VALUES (?, ?, ?)". - - -=head1 Proxyserver Configuration file (bigger example) - -This section tells you how to restrict a DBI-Proxy: Not every user from -every workstation shall be able to execute every query. - -There is a perl program "dbiproxy" which runs on a machine which is able -to connect to all the databases we wish to reach. All Perl-DBD-drivers must -be installed on this machine. You can also reach databases for which drivers -are not available on the machine where you run the program querying the -database, e.g. ask MS-Access-database from Linux. - -Create a configuration file "proxy_oracle.cfg" at the dbproxy-server: - - { - # This shall run in a shell or a DOS-window - # facility => 'daemon', - pidfile => 'your_dbiproxy.pid', - logfile => 1, - debug => 0, - mode => 'single', - localport => '12400', - - # Access control, the first match in this list wins! - # So the order is important - clients => [ - # hint to organize: - # the most specialized rules for single machines/users are 1st - # then the denying rules - # then the rules about whole networks - - # rule: internal_webserver - # desc: to get statistical information - { - # this IP-address only is meant - mask => '^10\.95\.81\.243$', - # accept (not defer) connections like this - accept => 1, - # only users from this list - # are allowed to log on - users => [ 'informationdesk' ], - # only this statistical query is allowed - # to get results for a web-query - sql => { - alive => 'select count(*) from dual', - statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?', - } - }, - - # rule: internal_bad_guy_1 - { - mask => '^10\.95\.81\.1$', - accept => 0, - }, - - # rule: employee_workplace - # desc: get detailed information - { - # any IP-address is meant here - mask => '^10\.95\.81\.(\d+)$', - # accept (not defer) connections like this - accept => 1, - # only users from this list - # are allowed to log on - users => [ 'informationdesk', 'lippmann' ], - # all these queries are allowed: - sql => { - search_city => 'select ort_nr, plz, ort from e01admin.e01e200 where plz like ?', - search_area => 'select gebiettyp, geb_bezei from e01admin.e01e203 where geb_bezei like ? or geb_bezei like ?', - } - }, - - # rule: internal_bad_guy_2 - # This does NOT work, because rule "employee_workplace" hits - # with its ip-address-mask of the whole network - { - # don't accept connection from this ip-address - mask => '^10\.95\.81\.5$', - accept => 0, - } - ] - } - -Start the proxyserver like this: - - rem well-set Oracle_home needed for Oracle - set ORACLE_HOME=d:\oracle\ora81 - dbiproxy --configfile proxy_oracle.cfg - - -=head2 Testing the connection from a remote machine - -Call a program "dbish" from your commandline. I take the machine from rule "internal_webserver" - - dbish "dbi:Proxy:hostname=oracle.zdf;port=12400;dsn=dbi:Oracle:e01" informationdesk xxx - -There will be a shell-prompt: - - informationdesk@dbi...> alive - - Current statement buffer (enter '/'...): - alive - - informationdesk@dbi...> / - COUNT(*) - '1' - [1 rows of 1 fields returned] - - -=head2 Testing the connection with a perl-script - -Create a perl-script like this: - - # file: oratest.pl - # call me like this: perl oratest.pl user password - - use strict; - use DBI; - - my $user = shift || die "Usage: $0 user password"; - my $pass = shift || die "Usage: $0 user password"; - my $config = { - dsn_at_proxy => "dbi:Oracle:e01", - proxy => "hostname=oechsle.zdf;port=12400", - }; - my $dsn = sprintf "dbi:Proxy:%s;dsn=%s", - $config->{proxy}, - $config->{dsn_at_proxy}; - - my $dbh = DBI->connect( $dsn, $user, $pass ) - || die "connect did not work: $DBI::errstr"; - - my $sql = "search_city"; - printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; - my $cur = $dbh->prepare($sql); - $cur->bind_param(1,'905%'); - &show_result ($cur); - - my $sql = "search_area"; - printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; - my $cur = $dbh->prepare($sql); - $cur->bind_param(1,'Pfarr%'); - $cur->bind_param(2,'Bronnamberg%'); - &show_result ($cur); - - my $sql = "statistic_area"; - printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; - my $cur = $dbh->prepare($sql); - $cur->bind_param(1,'Pfarr%'); - &show_result ($cur); - - $dbh->disconnect; - exit; - - - sub show_result { - my $cur = shift; - unless ($cur->execute()) { - print "Could not execute\n"; - return; - } - - my $rownum = 0; - while (my @row = $cur->fetchrow_array()) { - printf "Row is: %s\n", join(", ",@row); - if ($rownum++ > 5) { - print "... and so on\n"; - last; - } - } - $cur->finish; - } - -The result - - C:\>perl oratest.pl informationdesk xxx - ======================================== - search_city - ======================================== - Row is: 3322, 9050, Chemnitz - Row is: 3678, 9051, Chemnitz - Row is: 10447, 9051, Chemnitz - Row is: 12128, 9051, Chemnitz - Row is: 10954, 90513, Zirndorf - Row is: 5808, 90513, Zirndorf - Row is: 5715, 90513, Zirndorf - ... and so on - ======================================== - search_area - ======================================== - Row is: 101, Bronnamberg - Row is: 400, Pfarramt Zirndorf - Row is: 400, Pfarramt Rosstal - Row is: 400, Pfarramt Oberasbach - Row is: 401, Pfarramt Zirndorf - Row is: 401, Pfarramt Rosstal - ======================================== - statistic_area - ======================================== - DBD::Proxy::st execute failed: Server returned error: Failed to execute method CallMethod: Unknown SQL query: statistic_area at E:/Perl/site/lib/DBI/ProxyServer.pm line 258. - Could not execute - - -=head2 How the configuration works - -The most important section to control access to your dbi-proxy is "client=>" -in the file "proxy_oracle.cfg": - -Controlling which person at which machine is allowed to access - -=over 4 - -=item * "mask" is a perl regular expression against the plain ip-address of the machine which wishes to connect _or_ the reverse-lookup from a nameserver. - -=item * "accept" tells the dbiproxy-server whether ip-adresse like in "mask" are allowed to connect or not (0/1) - -=item * "users" is a reference to a list of usernames which must be matched, this is NOT a regular expression. - -=back - -Controlling which SQL-statements are allowed - -You can put every SQL-statement you like in simply omitting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible. - -If you include an sql-section in your config-file like this: - - sql => { - alive => 'select count(*) from dual', - statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?', - } - -The user is allowed to put two queries against the dbi-proxy. The queries are _not_ "select count(*)...", the queries are "alive" and "statistic_area"! These keywords are replaced by the real query. So you can run a query for "alive": - - my $sql = "alive"; - my $cur = $dbh->prepare($sql); - ... - -The flexibility is that you can put parameters in the where-part of the query so the query are not static. Simply replace a value in the where-part of the query through a question mark and bind it as a parameter to the query. - - my $sql = "statistic_area"; - my $cur = $dbh->prepare($sql); - $cur->bind_param(1,'905%'); - # A second parameter would be called like this: - # $cur->bind_param(2,'98%'); - -The result is this query: - - select count(*) from e01admin.e01e203 - where geb_bezei like '905%' - -Don't try to put parameters into the sql-query like this: - - # Does not work like you think. - # Only the first word of the query is parsed, - # so it's changed to "statistic_area", the rest is omitted. - # You _have_ to work with $cur->bind_param. - my $sql = "statistic_area 905%"; - my $cur = $dbh->prepare($sql); - ... - - -=head2 Problems - -=over 4 - -=item * I don't know how to restrict users to special databases. - -=item * I don't know how to pass query-parameters via dbish - -=back - - -=head1 SECURITY WARNING - -L used underneath is not secure due to serializing and -deserializing data with L module. Use the proxy driver only in -trusted environment. - - -=head1 AUTHOR - - Copyright (c) 1997 Jochen Wiedmann - Am Eisteich 9 - 72555 Metzingen - Germany - - Email: joe@ispsoft.de - Phone: +49 7123 14881 - -The DBI::ProxyServer module is free software; you can redistribute it -and/or modify it under the same terms as Perl itself. In particular -permission is granted to Tim Bunce for distributing this as a part of -the DBI. - - -=head1 SEE ALSO - -L, L, L, L, -L, L, L, -L, L, L diff --git a/lib/DBI/W32ODBC.pm b/lib/DBI/W32ODBC.pm deleted file mode 100644 index 2689968..0000000 --- a/lib/DBI/W32ODBC.pm +++ /dev/null @@ -1,181 +0,0 @@ -package - DBI; # hide this non-DBI package from simple indexers - -# $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z Tim $ -# -# Copyright (c) 1997,1999 Tim Bunce -# With many thanks to Patrick Hollins for polishing. -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the Perl README file. - -=head1 NAME - -DBI::W32ODBC - An experimental DBI emulation layer for Win32::ODBC - -=head1 SYNOPSIS - - use DBI::W32ODBC; - - # apart from the line above everything is just the same as with - # the real DBI when using a basic driver with few features. - -=head1 DESCRIPTION - -This is an experimental pure perl DBI emulation layer for Win32::ODBC - -If you can improve this code I'd be interested in hearing about it. If -you are having trouble using it please respect the fact that it's very -experimental. Ideally fix it yourself and send me the details. - -=head2 Some Things Not Yet Implemented - - Most attributes including PrintError & RaiseError. - type_info and table_info - -Volunteers welcome! - -=cut - -${'DBI::VERSION'} # hide version from PAUSE indexer - = "0.01"; - -my $Revision = sprintf("12.%06d", q$Revision: 8696 $ =~ /(\d+)/o); - - -sub DBI::W32ODBC::import { } # must trick here since we're called DBI/W32ODBC.pm - - -use Carp; - -use Win32::ODBC; - -@ISA = qw(Win32::ODBC); - -use strict; - -$DBI::dbi_debug = $ENV{PERL_DBI_DEBUG} || 0; -carp "Loaded (W32ODBC) DBI.pm ${'DBI::VERSION'} (debug $DBI::dbi_debug)" - if $DBI::dbi_debug; - - - -sub connect { - my ($class, $dbname, $dbuser, $dbpasswd, $module, $attr) = @_; - $dbname .= ";UID=$dbuser" if $dbuser; - $dbname .= ";PWD=$dbpasswd" if $dbpasswd; - my $h = new Win32::ODBC $dbname; - warn "Error connecting to $dbname: ".Win32::ODBC::Error()."\n" unless $h; - bless $h, $class if $h; # rebless into our class - $h; -} - - -sub quote { - my ($h, $string) = @_; - return "NULL" if !defined $string; - $string =~ s/'/''/g; # standard - # This hack seems to be required for Access but probably breaks for - # other databases when using \r and \n. It would be better if we could - # use ODBC options to detect that we're actually using Access. - $string =~ s/\r/' & chr\$(13) & '/g; - $string =~ s/\n/' & chr\$(10) & '/g; - "'$string'"; -} - -sub do { - my($h, $statement, $attribs, @params) = @_; - Carp::carp "\$h->do() attribs unused" if $attribs; - my $new_h = $h->prepare($statement) or return undef; ## - pop @{ $h->{'___sths'} }; ## certain death assured - $new_h->execute(@params) or return undef; ## - my $rows = $new_h->rows; ## - $new_h->finish; ## bang bang - ($rows == 0) ? "0E0" : $rows; -} - -# --- - -sub prepare { - my ($h, $sql) = @_; - ## opens a new connection with every prepare to allow - ## multiple, concurrent queries - my $new_h = new Win32::ODBC $h->{DSN}; ## - return undef if not $new_h; ## bail if no connection - bless $new_h; ## shouldn't be sub-classed... - $new_h->{'__prepare'} = $sql; ## - $new_h->{NAME} = []; ## - $new_h->{NUM_OF_FIELDS} = -1; ## - push @{ $h->{'___sths'} } ,$new_h; ## save sth in parent for mass destruction - return $new_h; ## -} - -sub execute { - my ($h) = @_; - my $rc = $h->Sql($h->{'__prepare'}); - return undef if $rc; - my @fields = $h->FieldNames; - $h->{NAME} = \@fields; - $h->{NUM_OF_FIELDS} = scalar @fields; - $h; # return dbh as pseudo sth -} - - -sub fetchrow_hashref { ## provide DBI compatibility - my $h = shift; - my $NAME = shift || "NAME"; - my $row = $h->fetchrow_arrayref or return undef; - my %hash; - @hash{ @{ $h->{$NAME} } } = @$row; - return \%hash; -} - -sub fetchrow { - my $h = shift; - return unless $h->FetchRow(); - my $fields_r = $h->{NAME}; - return $h->Data(@$fields_r); -} -sub fetch { - my @row = shift->fetchrow; - return undef unless @row; - return \@row; -} -*fetchrow_arrayref = \&fetch; ## provide DBI compatibility -*fetchrow_array = \&fetchrow; ## provide DBI compatibility - -sub rows { - shift->RowCount; -} - -sub finish { - shift->Close; ## uncommented this line -} - -# --- - -sub commit { - shift->Transact(ODBC::SQL_COMMIT); -} -sub rollback { - shift->Transact(ODBC::SQL_ROLLBACK); -} - -sub disconnect { - my ($h) = shift; ## this will kill all the statement handles - foreach (@{$h->{'___sths'}}) { ## created for a specific connection - $_->Close if $_->{DSN}; ## - } ## - $h->Close; ## -} - -sub err { - (shift->Error)[0]; -} -sub errstr { - scalar( shift->Error ); -} - -# --- - -1; diff --git a/lib/Win32/DBIODBC.pm b/lib/Win32/DBIODBC.pm deleted file mode 100644 index f033444..0000000 --- a/lib/Win32/DBIODBC.pm +++ /dev/null @@ -1,248 +0,0 @@ -package # hide this package from CPAN indexer - Win32::ODBC; - -use strict; - -use DBI; - -# once we've been loaded we don't want perl to load the real Win32::ODBC -$INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1; - -#my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};"); - -#EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;"); -sub new -{ - shift; - my $connect_line= shift; - -# [R] self-hack to allow empty UID and PWD - my $temp_connect_line; - $connect_line=~/DSN=\w+/; - $temp_connect_line="$&;"; - if ($connect_line=~/UID=\w?/) - {$temp_connect_line.="$&;";} - else {$temp_connect_line.="UID=;";}; - if ($connect_line=~/PWD=\w?/) - {$temp_connect_line.="$&;";} - else {$temp_connect_line.="PWD=;";}; - $connect_line=$temp_connect_line; -# -[R]- - - my $self= {}; - - - $_=$connect_line; - /^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/; - - #---- DBI CONNECTION VARIABLES - - $self->{ODBC_DSN}=$2; - $self->{ODBC_UID}=$4; - $self->{ODBC_PWD}=$6; - - - #---- DBI CONNECTION VARIABLES - $self->{DBI_DBNAME}=$self->{ODBC_DSN}; - $self->{DBI_USER}=$self->{ODBC_UID}; - $self->{DBI_PASSWORD}=$self->{ODBC_PWD}; - $self->{DBI_DBD}='ODBC'; - - #---- DBI CONNECTION - $self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'}, - $self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'}); - - warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'}; - - - #---- RETURN - - bless $self; -} - - -#EMU --- $db->Sql('SELECT * FROM DUAL'); -sub Sql -{ - my $self= shift; - my $SQL_statment=shift; - - # print " SQL : $SQL_statment \n"; - - $self->{'DBI_SQL_STATMENT'}=$SQL_statment; - - my $dbh=$self->{'DBI_DBH'}; - - # print " DBH : $dbh \n"; - - my $sth=$dbh->prepare("$SQL_statment"); - - # print " STH : $sth \n"; - - $self->{'DBI_STH'}=$sth; - - if ($sth) - { - $sth->execute(); - } - - #--- GET ERROR MESSAGES - $self->{DBI_ERR}=$DBI::err; - $self->{DBI_ERRSTR}=$DBI::errstr; - - if ($sth) - { - #--- GET COLUMNS NAMES - $self->{'DBI_NAME'} = $sth->{NAME}; - } - -# [R] provide compatibility with Win32::ODBC's way of identifying erroneous SQL statements - return ($self->{'DBI_ERR'})?1:undef; -# -[R]- -} - - -#EMU --- $db->FetchRow()) -sub FetchRow -{ - my $self= shift; - - my $sth=$self->{'DBI_STH'}; - if ($sth) - { - my @row=$sth->fetchrow_array; - $self->{'DBI_ROW'}=\@row; - - if (scalar(@row)>0) - { - #-- the row of result is not nul - #-- return something nothing will be return else - return 1; - } - } - return undef; -} - -# [R] provide compatibility with Win32::ODBC's Data() method. -sub Data -{ - my $self=shift; - my @array=@{$self->{'DBI_ROW'}}; - foreach my $element (@array) - { - # remove padding of spaces by DBI - $element=~s/(\s*$)//; - }; - return (wantarray())?@array:join('', @array); -}; -# -[R]- - -#EMU --- %record = $db->DataHash; -sub DataHash -{ - my $self= shift; - - my $p_name=$self->{'DBI_NAME'}; - my $p_row=$self->{'DBI_ROW'}; - - my @name=@$p_name; - my @row=@$p_row; - - my %DataHash; -#print @name; print "\n"; print @row; -# [R] new code that seems to work consistent with Win32::ODBC - while (@name) - { - my $name=shift(@name); - my $value=shift(@row); - - # remove padding of spaces by DBI - $name=~s/(\s*$)//; - $value=~s/(\s*$)//; - - $DataHash{$name}=$value; - }; -# -[R]- - -# [R] old code that didn't appear to work -# foreach my $name (@name) -# { -# $name=~s/(^\s*)|(\s*$)//; -# my @arr=@$name; -# foreach (@arr) -# { -# print "lot $name name col $_ or ROW= 0 $row[0] 1 $row[1] 2 $row[2] \n "; -# $DataHash{$name}=shift(@row); -# } -# } -# -[R]- - - #--- Return Hash - return %DataHash; -} - - -#EMU --- $db->Error() -sub Error -{ - my $self= shift; - - if ($self->{'DBI_ERR'} ne '') - { - #--- Return error message - $self->{'DBI_ERRSTR'}; - } - - #-- else good no error message - -} - -# [R] provide compatibility with Win32::ODBC's Close() method. -sub Close -{ - my $self=shift; - - my $dbh=$self->{'DBI_DBH'}; - $dbh->disconnect; -} -# -[R]- - -1; - -__END__ - -# [R] to -[R]- indicate sections edited by me, Roy Lee - -=head1 NAME - -Win32::DBIODBC - Win32::ODBC emulation layer for the DBI - -=head1 SYNOPSIS - - use Win32::DBIODBC; # instead of use Win32::ODBC - -=head1 DESCRIPTION - -This is a I basic I alpha quality Win32::ODBC emulation -for the DBI. To use it just replace - - use Win32::ODBC; - -in your scripts with - - use Win32::DBIODBC; - -or, while experimenting, you can pre-load this module without changing your -scripts by doing - - perl -MWin32::DBIODBC your_script_name - -=head1 TO DO - -Error handling is virtually non-existent. - -=head1 AUTHOR - -Tom Horen - -=cut diff --git a/t/80proxy.t b/t/80proxy.t deleted file mode 100644 index ab529b6..0000000 --- a/t/80proxy.t +++ /dev/null @@ -1,473 +0,0 @@ -#!perl -w # -*- perl -*- -# vim:sw=4:ts=8 - -require 5.004; -use strict; - - -use DBI; -use Config; -require VMS::Filespec if $^O eq 'VMS'; -require Cwd; - -my $haveFileSpec = eval { require File::Spec }; -my $failed_tests = 0; - -$| = 1; -$^W = 1; - -# $\ = "\n"; # XXX Triggers bug, check this later (JW, 1998-12-28) - -# Can we load the modules? If not, exit the test immediately: -# Reason is most probable a missing prerequisite. -# -# Is syslog available (required for the server)? - -eval { - local $SIG{__WARN__} = sub { $@ = shift }; - require Storable; - require DBD::Proxy; - require DBI::ProxyServer; - require RPC::PlServer; - require Net::Daemon::Test; -}; -if ($@) { - if ($@ =~ /^Can't locate (\S+)/) { - print "1..0 # Skipped: modules required for proxy are probably not installed (e.g., $1)\n"; - exit 0; - } - die $@; -} - -if ($DBI::PurePerl) { - # XXX temporary I hope - print "1..0 # Skipped: DBD::Proxy currently has a problem under DBI::PurePerl\n"; - exit 0; -} - -{ - my $numTest = 0; - sub _old_Test($;$) { - my $result = shift; my $str = shift || ''; - printf("%sok %d%s\n", ($result ? "" : "not "), ++$numTest, $str); - $result; - } - sub Test ($;$) { - my($ok, $msg) = @_; - $msg = ($msg) ? " ($msg)" : ""; - my $line = (caller)[2]; - ++$numTest; - ($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n"; - warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok; - ++$failed_tests unless $ok; - return $ok; - } -} - - -# Create an empty config file to make sure that settings aren't -# overloaded by /etc/dbiproxy.conf -my $config_file = "dbiproxytst.conf"; -unlink $config_file; -(open(FILE, ">$config_file") and - (print FILE "{}\n") and - close(FILE)) - or die "Failed to create config file $config_file: $!"; - -my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0; -my $dbitracelog = "dbiproxy.dbilog"; - -my ($handle, $port, @child_args); - -my $numTests = 136; - -if (@ARGV) { - $port = $ARGV[0]; -} -else { - - unlink $dbitracelog; - unlink "dbiproxy.log"; - unlink "dbiproxy.truss"; - - # Uncommentand adjust this to isolate pure-perl client from server settings: - # local $ENV{DBI_PUREPERL} = 0; - - # If desperate uncomment this and add '-d' after $^X below: - # local $ENV{PERLDB_OPTS} = "AutoTrace NonStop=1 LineInfo=dbiproxy.dbg"; - - # pass our @INC to children (e.g., so -Mblib passes through) - $ENV{PERL5LIB} = join($Config{path_sep}, @INC); - - # server DBI trace level always at least 1 - my $dbitracelevel = DBI->trace(0) || 1; - @child_args = ( - #'truss', '-o', 'dbiproxy.truss', - $^X, 'dbiproxy', '--test', # --test must be first command line arg - "--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg - '--configfile', $config_file, - ($dbitracelevel >= 2 ? ('--debug') : ()), - '--mode=single', - '--logfile=STDERR', - '--timeout=90' - ); - warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0); - ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args); -} - -my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:"; - -print "Making a first connection and closing it immediately.\n"; -Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) }) - or print "Connect error: " . $DBI::errstr . "\n"; - -print "Making a second connection.\n"; -my $dbh; -Test($dbh = eval { DBI->connect($dsn, '', '', { 'PrintError' => 0 }) }) - or print "Connect error: " . $DBI::errstr . "\n"; - -print "example_driver_path=$dbh->{example_driver_path}\n"; -Test($dbh->{example_driver_path}); - -print "Setting AutoCommit\n"; -$@ = "old-error"; # should be preserved across DBI calls -Test($dbh->{AutoCommit} = 1); -Test($dbh->{AutoCommit}); -Test($@ eq "old-error", "\$@ now '$@'"); -#$dbh->trace(2); - -eval { - local $dbh->{ AutoCommit } = 1; # This breaks die! - die "BANG!!!\n"; -}; -Test($@ eq "BANG!!!\n", "\$@ value lost"); - - -print "begin_work...\n"; -Test($dbh->{AutoCommit}); -Test(!$dbh->{BegunWork}); - -Test($dbh->begin_work); -Test(!$dbh->{AutoCommit}); -Test($dbh->{BegunWork}); - -$dbh->commit; -Test(!$dbh->{BegunWork}); -Test($dbh->{AutoCommit}); - -Test($dbh->begin_work({})); -$dbh->rollback; -Test($dbh->{AutoCommit}); -Test(!$dbh->{BegunWork}); - - -print "Doing a ping.\n"; -$_ = $dbh->ping; -Test($_); -Test($_ eq '2'); # ping was DBD::ExampleP's ping - -print "Ensure CompatMode enabled.\n"; -Test($dbh->{CompatMode}); - -print "Trying local quote.\n"; -$dbh->{'proxy_quote'} = 'local'; -Test($dbh->quote("quote's") eq "'quote''s'"); -Test($dbh->quote(undef) eq "NULL"); - -print "Trying remote quote.\n"; -$dbh->{'proxy_quote'} = 'remote'; -Test($dbh->quote("quote's") eq "'quote''s'"); -Test($dbh->quote(undef) eq "NULL"); - -# XXX the $optional param is undocumented and may be removed soon -Test($dbh->quote_identifier('foo') eq '"foo"', $dbh->quote_identifier('foo')); -Test($dbh->quote_identifier('f"o') eq '"f""o"', $dbh->quote_identifier('f"o')); -Test($dbh->quote_identifier('foo','bar') eq '"foo"."bar"'); -Test($dbh->quote_identifier('foo',undef,'bar') eq '"foo"."bar"'); -Test($dbh->quote_identifier(undef,undef,'bar') eq '"bar"'); - -print "Trying commit with invalid number of parameters.\n"; -eval { $dbh->commit('dummy') }; -Test($@ =~ m/^DBI commit: invalid number of arguments:/) - unless $DBI::PurePerl && Test(1); - -print "Trying select with unknown field name.\n"; -my $cursor_e = $dbh->prepare("select unknown_field_name from ?"); -Test(defined $cursor_e); -Test(!$cursor_e->execute('a')); -Test($DBI::err); -Test($DBI::err == $dbh->err); -Test($DBI::errstr =~ m/unknown_field_name/, $DBI::errstr); - -Test($DBI::errstr eq $dbh->errstr); -Test($dbh->errstr eq $dbh->func('errstr')); - -my $dir = Cwd::cwd(); # a dir always readable on all platforms -$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; - -print "Trying a real select.\n"; -my $csr_a = $dbh->prepare("select mode,name from ?"); -Test(ref $csr_a); -Test($csr_a->execute($dir)) - or print "Execute failed: ", $csr_a->errstr(), "\n"; - -print "Repeating the select with second handle.\n"; -my $csr_b = $dbh->prepare("select mode,name from ?"); -Test(ref $csr_b); -Test($csr_b->execute($dir)); -Test($csr_a != $csr_b); -Test($csr_a->{NUM_OF_FIELDS} == 2); -if ($DBI::PurePerl) { - $csr_a->trace(2); - use Data::Dumper; - warn Dumper($csr_a->{Database}); -} -Test($csr_a->{Database}->{Driver}->{Name} eq 'Proxy', "Name=$csr_a->{Database}->{Driver}->{Name}"); -$csr_a->trace(0), die if $DBI::PurePerl; - -my($col0, $col1); -my(@row_a, @row_b); - -#$csr_a->trace(2); -print "Trying bind_columns.\n"; -Test($csr_a->bind_columns(undef, \($col0, $col1)) ); -Test($csr_a->execute($dir)); -@row_a = $csr_a->fetchrow_array; -Test(@row_a); -Test($row_a[0] eq $col0); -Test($row_a[1] eq $col1); - -print "Trying bind_param.\n"; -Test($csr_b->bind_param(1, $dir)); -Test($csr_b->execute()); -@row_b = @{ $csr_b->fetchrow_arrayref }; -Test(@row_b); - -Test("@row_a" eq "@row_b"); -@row_b = $csr_b->fetchrow_array; -Test("@row_a" ne "@row_b") - or printf("Expected something different from '%s', got '%s'\n", "@row_a", - "@row_b"); - -print "Trying fetchrow_hashref.\n"; -Test($csr_b->execute()); -my $row_b = $csr_b->fetchrow_hashref; -Test($row_b); -print "row_a: @{[ @row_a ]}\n"; -print "row_b: @{[ %$row_b ]}\n"; -Test($row_b->{mode} == $row_a[0]); -Test($row_b->{name} eq $row_a[1]); - -print "Trying fetchrow_hashref with FetchHashKeyName.\n"; -do { -#local $dbh->{TraceLevel} = 9; -local $dbh->{FetchHashKeyName} = 'NAME_uc'; -Test($dbh->{FetchHashKeyName} eq 'NAME_uc'); -my $csr_c = $dbh->prepare("select mode,name from ?"); -Test($csr_c->execute($dir), $DBI::errstr); -$row_b = $csr_c->fetchrow_hashref; -Test($row_b); -print "row_b: @{[ %$row_b ]}\n"; -Test($row_b->{MODE} eq $row_a[0]); -}; - -print "Trying finish.\n"; -Test($csr_a->finish); -#Test($csr_b->finish); -Test(1); - -print "Forcing destructor.\n"; -$csr_a = undef; # force destruction of this cursor now -Test(1); - -print "Trying fetchall_arrayref.\n"; -Test($csr_b->execute()); -my $r = $csr_b->fetchall_arrayref; -Test($r); -Test(@$r); -Test($r->[0]->[0] == $row_a[0]); -Test($r->[0]->[1] eq $row_a[1]); - -Test($csr_b->finish); - - -print "Retrying unknown field name.\n"; -my $csr_c; -$csr_c = $dbh->prepare("select unknown_field_name1 from ?"); -Test($csr_c); -Test(!$csr_c->execute($dir)); -Test($DBI::errstr =~ m/Unknown field names: unknown_field_name1/) - or printf("Wrong error string: %s", $DBI::errstr); - -print "Trying RaiseError.\n"; -$dbh->{RaiseError} = 1; -Test($dbh->{RaiseError}); -Test($csr_c = $dbh->prepare("select unknown_field_name2 from ?")); -Test(!eval { $csr_c->execute(); 1 }); -#print "$@\n"; -Test($@ =~ m/Unknown field names: unknown_field_name2/); -$dbh->{RaiseError} = 0; -Test(!$dbh->{RaiseError}); - -print "Trying warnings.\n"; -{ - my @warn; - local($SIG{__WARN__}) = sub { push @warn, @_ }; - $dbh->{PrintError} = 1; - Test($dbh->{PrintError}); - Test(($csr_c = $dbh->prepare("select unknown_field_name3 from ?"))); - Test(!$csr_c->execute()); - Test("@warn" =~ m/Unknown field names: unknown_field_name3/); - $dbh->{PrintError} = 0; - Test(!$dbh->{PrintError}); -} -$csr_c->finish(); - - -print "Trying type_info_all.\n"; -my $array = $dbh->type_info_all(); -Test($array and ref($array) eq 'ARRAY') - or printf("Expected ARRAY, got %s, error %s\n", DBI::neat($array), - $dbh->errstr()); -Test($array->[0] and ref($array->[0]) eq 'HASH'); -my $ok = 1; -for (my $i = 1; $i < @{$array}; $i++) { - print "$array->[$i]\n"; - $ok = 0 unless ($array->[$i] and ref($array->[$i]) eq 'ARRAY'); - print "$ok\n"; -} -Test($ok); - -# Test the table_info method -# First generate a list of all subdirectories -$dir = $haveFileSpec ? File::Spec->curdir() : "."; -Test(opendir(DIR, $dir)); -my(%dirs, %unexpected, %missing); -while (defined(my $file = readdir(DIR))) { - $dirs{$file} = 1 if -d $file; -} -closedir(DIR); -my $sth = $dbh->table_info(undef, undef, undef, undef); -Test($sth) or warn "table_info failed: ", $dbh->errstr(), "\n"; -%missing = %dirs; -%unexpected = (); -while (my $ref = $sth->fetchrow_hashref()) { - print "table_info: Found table $ref->{'TABLE_NAME'}\n"; - if (exists($missing{$ref->{'TABLE_NAME'}})) { - delete $missing{$ref->{'TABLE_NAME'}}; - } else { - $unexpected{$ref->{'TABLE_NAME'}} = 1; - } -} -Test(!$sth->errstr()) - or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; -Test(keys %unexpected == 0) - or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; -Test(keys %missing == 0) - or print "Missing directories: ", join(",", keys %missing), "\n"; - -# Test the tables method -%missing = %dirs; -%unexpected = (); -print "Expecting directories ", join(",", keys %dirs), "\n"; -foreach my $table ($dbh->tables()) { - print "tables: Found table $table\n"; - if (exists($missing{$table})) { - delete $missing{$table}; - } else { - $unexpected{$table} = 1; - } -} -Test(!$sth->errstr()) - or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; -Test(keys %unexpected == 0) - or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; -Test(keys %missing == 0) - or print "Missing directories: ", join(",", keys %missing), "\n"; - - -# Test large recordsets -for (my $i = 0; $i <= 300; $i += 100) { - print "Testing the fake directories ($i).\n"; - Test($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i")); - Test($csr_a->execute(), $DBI::errstr); - my $ary = $csr_a->fetchall_arrayref; - Test(!$DBI::errstr, $DBI::errstr); - Test(@$ary == $i, "expected $i got ".@$ary); - if ($i) { - my @n1 = map { $_->[0] } @$ary; - my @n2 = reverse map { "file$_" } 1..$i; - Test("@n1" eq "@n2"); - } - else { - Test(1); - } -} - - -# Test the RowCacheSize attribute -Test($csr_a = $dbh->prepare("SELECT * FROM ?")); -Test($dbh->{'RowCacheSize'} == 20); -Test($csr_a->{'RowCacheSize'} == 20); -Test($csr_a->execute('long_list_50')); -Test($csr_a->fetchrow_arrayref()); -Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 19); -Test($csr_a->finish()); - -Test($dbh->{'RowCacheSize'} = 30); -Test($dbh->{'RowCacheSize'} == 30); -Test($csr_a->{'RowCacheSize'} == 30); -Test($csr_a->execute('long_list_50')); -Test($csr_a->fetchrow_arrayref()); -Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 29) - or print("Expected 29 records in cache, got " . @{$csr_a->{'proxy_data'}} . - "\n"); -Test($csr_a->finish()); - - -Test($csr_a->{'RowCacheSize'} = 10); -Test($dbh->{'RowCacheSize'} == 30); -Test($csr_a->{'RowCacheSize'} == 10); -Test($csr_a->execute('long_list_50')); -Test($csr_a->fetchrow_arrayref()); -Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 9) - or print("Expected 9 records in cache, got " . @{$csr_a->{'proxy_data'}} . - "\n"); -Test($csr_a->finish()); - -$dbh->disconnect; - -# Test $dbh->func() -# print "Testing \$dbh->func().\n"; -# my %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables(); -# $ok = 1; -# foreach my $t ($dbh->func('lib', 'examplep_tables')) { -# defined(delete $tables{$t}) or print "Unexpected table: $t\n"; -# } -# Test(%tables == 0); - -if ($failed_tests) { - warn "Proxy: @child_args\n"; - for my $class (qw(Net::Daemon RPC::PlServer Storable)) { - (my $pm = $class) =~ s/::/\//g; $pm .= ".pm"; - my $version = eval { $class->VERSION } || '?'; - warn sprintf "Using %-13s %-6s %s\n", $class, $version, $INC{$pm}; - } - warn join(", ", map { "$_=$ENV{$_}" } grep { /^LC_|LANG/ } keys %ENV)."\n"; - warn "More info can be found in $dbitracelog\n"; - #system("cat $dbitracelog"); -} - - -END { - local $?; - $handle->Terminate() if $handle; - undef $handle; - unlink $config_file if $config_file; - if (!$failed_tests) { - unlink 'dbiproxy.log'; - unlink $dbitracelog if $dbitracelog; - } -}; - -1;