Author: timbo Date: Wed Jun 15 08:45:34 2005 New Revision: 1083 Modified: dbi/trunk/Changes dbi/trunk/DBI.pm dbi/trunk/lib/DBD/Proxy.pm dbi/trunk/t/80proxy.t Log: Fixed assorted bugs with attribute handling in DBD::Proxy. (also added some debugging/tracing support)
Modified: dbi/trunk/Changes ============================================================================== --- dbi/trunk/Changes (original) +++ dbi/trunk/Changes Wed Jun 15 08:45:34 2005 @@ -6,6 +6,7 @@ DBI::Changes - List of significant chang =head2 Changes in DBI 1.49 (svn rev XXX), 2005 + Fixed assorted attribute handling bugs in DBD::Proxy. Fixed croak() in DBD::NullP thanks to Sergey Skvortsov. Fixed handling of take_imp_data() and dbi_imp_data attribute. Fixed bugs in DBD::DBM thanks to Jeff Zucker. Modified: dbi/trunk/DBI.pm ============================================================================== --- dbi/trunk/DBI.pm (original) +++ dbi/trunk/DBI.pm Wed Jun 15 08:45:34 2005 @@ -7015,7 +7015,7 @@ Security, especially the "SQL Injection" http://www.ngssoftware.com/papers/more_advanced_sql_injection.pdf http://www.esecurityplanet.com/trends/article.php/2243461 http://www.spidynamics.com/papers/SQLInjectionWhitePaper.pdf - http://www.webcohort.com/Blindfolded_SQL_Injection.pdf + http://www.imperva.com/application_defense_center/white_papers/blind_sql_server_injection.html http://online.securityfocus.com/infocus/1644 Commercial and Data Warehouse Links Modified: dbi/trunk/lib/DBD/Proxy.pm ============================================================================== --- dbi/trunk/lib/DBD/Proxy.pm (original) +++ dbi/trunk/lib/DBD/Proxy.pm Wed Jun 15 08:45:34 2005 @@ -21,12 +21,25 @@ # 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; @@ -45,6 +58,8 @@ $drh = undef; # holds driver handle onc 'PrintError' => 'local', 'RaiseError' => 'local', 'HandleError' => 'local', + 'TraceLevel' => 'cached', + 'CompatMode' => 'local', ); sub driver ($$) { @@ -57,7 +72,8 @@ sub driver ($$) { 'Name' => 'Proxy', 'Version' => $VERSION, 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', - }); + }); + $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) } $drh; } @@ -144,7 +160,7 @@ sub connect ($$;$$) { } } # Create an RPC::PlClient object. - my($client, $msg) = eval { RPC::PlClient->new(%client_opts) }; + 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 @@ -218,7 +234,8 @@ use vars qw(%ATTR $AUTOLOAD); %ATTR = ( # see also %ATTR in DBD::Proxy::st %DBD::Proxy::ATTR, RowCacheSize => 'inherited', - AutoCommit => 'cached', + #AutoCommit => 'cached', + 'FetchHashKeyName' => 'cached', Statement => 'local', Driver => 'local', dbi_connect_closure => 'local', @@ -300,17 +317,25 @@ 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') { + 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->{$attr} = $val if $type eq 'cached'; + $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; return $result; } return $dbh->SUPER::STORE($attr => $val); @@ -318,10 +343,11 @@ sub STORE ($$$) { 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') { + if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { return $dbh->{$attr}; } @@ -620,13 +646,13 @@ sub STORE ($$$) { return 0; } - if ($type eq 'remote') { + 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; + return $result if $type eq 'remote'; # else fall through to cache locally } return $sth->SUPER::STORE($attr => $val); } Modified: dbi/trunk/t/80proxy.t ============================================================================== --- dbi/trunk/t/80proxy.t (original) +++ dbi/trunk/t/80proxy.t Wed Jun 15 08:45:34 2005 @@ -71,7 +71,7 @@ unlink $config_file; or die "Failed to create config file $config_file: $!"; my($handle, $port); -my $numTests = 119; +my $numTests = 124; if (@ARGV) { $port = $ARGV[0]; } else { @@ -103,11 +103,11 @@ if (@ARGV) { ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args); } -my @opts = ('peeraddr' => '127.0.0.1', 'peerport' => $port, 'debug' => 1); -my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=1;dsn=DBI:ExampleP:"; +my $debug = ($ENV{DBI_TRACE}) ? 1 : 0; +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' => 0 }) }) +Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) }) or print "Connect error: " . $DBI::errstr . "\n"; print "Making a second connection.\n"; @@ -134,6 +134,9 @@ Test($@ eq "BANG!!!\n", "\$@ value lost" print "Doing a ping.\n"; Test($dbh->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'"); @@ -225,6 +228,19 @@ Test($row_b->{mode} == $row_a[0]); Test($row_b->{size} == $row_a[1]); Test($row_b->{name} eq $row_a[2]); +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,size,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);
