Author: timbo
Date: Mon Jun 2 03:43:48 2008
New Revision: 11371
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/05concathash.t
Log:
Fixup some _concat_hash_sorted use_neat inversion issues.
Remove extra_sv arg and logic from _concat_hash_sorted, and tidy it.
Add t/05concathash.t to manifest
Fix handling of non-printables in DBI::PurePerl neat().
Update DBI::PurePerl _concat_hash_sorted.
Update Changes and tests.
Use _concat_hash_sorted for connect_cached and prepare_cahed.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Jun 2 03:43:48 2008
@@ -68,11 +68,16 @@
inner sth handle when passed a $sth instead of an sql string.
Drivers will need to be recompiled to pick up this change.
Fixed leak in neat() for some kinds of values thanks to Rudolf Lippan.
+ Fixed DBI::PurePerl neat() to behave more like XS neat().
+ Fixed the placeholder values reported by ShowErrorStatement
+ to be shown in sorted order.
Increased timeout on tests to accomodate very slow systems.
Removed the beeps "\a" from Makefile.PL warnings.
Removed check for PlRPC-modules from Makefile.PL
Clarified docs re ":N" style placeholders.
+ Changed the format of the key used for $h->{CachedKids}
+ (which is undocumented so you shouldn't depend on it anyway)
Added cache miss trace message to DBD::Gofer transport class.
Added $drh->dbixs_revision method.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Jun 2 03:43:48 2008
@@ -1428,14 +1428,13 @@
my ($dsn, $user, $auth, $attr) = @_;
my $cache = $drh->{CachedKids} ||= {};
-
- my @attr_keys = $attr ? sort keys %$attr : ();
- my $key = do { local $^W; # silence undef warnings
- join "~~", $dsn, $user, $auth, $attr ? (@attr_keys,@[EMAIL
PROTECTED]) : ()
+ my $key = do { local $^W;
+ join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr,
"=\001", ",\001", 0, 0)
};
my $dbh = $cache->{$key};
$drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh
$dbh\n", DBI::neat($key), DBI::neat($dbh)))
if $DBI::dbi_debug >= 4;
+
my $cb = $attr->{Callbacks}; # take care not to autovivify
if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
# If the caller has provided a callback then call it
@@ -1636,13 +1635,16 @@
sub prepare_cached {
my ($dbh, $statement, $attr, $if_active) = @_;
+
# Needs support at dbh level to clear cache before complaining about
# active children. The XS template code does this. Drivers not using
# the template must handle clearing the cache themselves.
my $cache = $dbh->{CachedKids} ||= {};
- my @attr_keys = ($attr) ? sort keys %$attr : ();
- my $key = ($attr) ? join("~~", $statement, @attr_keys, @[EMAIL
PROTECTED]) : $statement;
+ my $key = do { local $^W;
+ join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001",
",\001", 0, 0)
+ };
my $sth = $cache->{$key};
+
if ($sth) {
return $sth unless $sth->FETCH('Active');
Carp::carp("prepare_cached($statement) statement handle $sth still
Active")
@@ -1650,8 +1652,10 @@
$sth->finish if $if_active <= 1;
return $sth if $if_active <= 2;
}
+
$sth = $dbh->prepare($statement, $attr);
$cache->{$key} = $sth if $sth;
+
return $sth;
}
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Jun 2 03:43:48 2008
@@ -331,6 +331,9 @@
}
if (use_neat) {
+ sv_catpv(return_sv, neatsvpv(*hash_svp,0));
+ }
+ else {
if (SvOK(*hash_svp)) {
STRLEN hv_val_len;
char *hv_val = SvPV(*hash_svp, hv_val_len);
@@ -340,7 +343,6 @@
}
else sv_catpvn(return_sv, "undef", 5);
}
- else sv_catpv(return_sv, neatsvpv(*hash_svp,0));
if (i < hv_len-1)
sv_catpvn(return_sv, pair_sep, pair_sep_len);
@@ -4388,44 +4390,31 @@
SV *
-_concat_hash_sorted(hash_sv, kv_sep_sv, pair_sep_sv, use_neat_sv, num_sort_sv,
extra_sv=Nullsv)
+_concat_hash_sorted(hash_sv, kv_sep_sv, pair_sep_sv, use_neat_sv, num_sort_sv)
SV *hash_sv
SV *kv_sep_sv
SV *pair_sep_sv
SV *use_neat_sv
SV *num_sort_sv
- SV *extra_sv
PREINIT:
- STRLEN kv_sep_len, pair_sep_len;
char *kv_sep, *pair_sep;
- int use_neat, num_sort;
+ STRLEN kv_sep_len, pair_sep_len;
CODE:
if (!SvOK(hash_sv))
XSRETURN_UNDEF;
if (!SvROK(hash_sv) || SvTYPE(SvRV(hash_sv))!=SVt_PVHV)
croak("hash is not a hash reference");
+
kv_sep = SvPV(kv_sep_sv, kv_sep_len);
pair_sep = SvPV(pair_sep_sv, pair_sep_len);
- /* use_neat should be undef, 0 or 1, may allow sprintf format strings
later */
- use_neat = (SvOK(use_neat_sv)) ? SvIV(use_neat_sv) : 0;
- num_sort = (SvOK(num_sort_sv)) ? SvIV(num_sort_sv) : -1;
-
- RETVAL = _join_hash_sorted((HV*)SvRV(hash_sv), kv_sep, kv_sep_len,
pair_sep, pair_sep_len, use_neat, num_sort);
-
- /* efficient way for the caller to tack extra info onto the return
string */
- if (extra_sv && SvOK(extra_sv) && SvROK(extra_sv) &&
SvTYPE(SvRV(extra_sv))==SVt_PVAV) {
- AV *extra_av = (AV*)SvRV(extra_sv);
- int i, items = AvFILL(extra_av)+1;
- for (i=0; i < items; ++i) {
- SV *e_sv = *av_fetch(extra_av, i, 1);
- if (SvTRUE(RETVAL))
- sv_catsv(RETVAL, kv_sep_sv);
- if (SvOK(e_sv))
- sv_catsv(RETVAL, *av_fetch(extra_av, i, 1));
- else sv_catpvn(RETVAL, "undef", 5);
- }
- }
+ RETVAL = _join_hash_sorted( (HV*)SvRV(hash_sv),
+ kv_sep, kv_sep_len,
+ pair_sep, pair_sep_len,
+ /* use_neat should be undef, 0 or 1, may allow sprintf format
strings later */
+ (SvOK(use_neat_sv)) ? SvIV(use_neat_sv) : 0,
+ (SvOK(num_sort_sv)) ? SvIV(num_sort_sv) : -1
+ );
OUTPUT:
RETVAL
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Mon Jun 2 03:43:48 2008
@@ -70,6 +70,7 @@
t/02dbidrv.t
t/03handle.t
t/04mods.t
+t/05concathash.t
t/06attrs.t
t/07kids.t
t/08keeperr.t
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Jun 2 03:43:48 2008
@@ -664,6 +664,7 @@
$v = substr($v,0,$maxlen-5);
$v .= '...';
}
+ $v =~ s/[^[:print:]]/./g;
return "$quote$v$quote";
}
@@ -674,21 +675,21 @@
sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
sub _concat_hash_sorted {
- my ( $hash_ref, $kv_separator, $pair_separator, $value_format, $sort_type
) = @_;
- # $value_format: false=use neat(), true=dumb quotes
- # $sort_type: 0=lexical, 1=numeric, undef=try to guess
+ my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) =
@_;
+ # $num_sort: 0=lexical, 1=numeric, undef=try to guess
+ return undef unless defined $hash_ref;
die "hash is not a hash reference" unless ref $hash_ref eq 'HASH';
- my $keys = _get_sorted_hash_keys($hash_ref, $sort_type);
+ my $keys = _get_sorted_hash_keys($hash_ref, $num_sort);
my $string = '';
for my $key (@$keys) {
$string .= $pair_separator if length $string > 0;
my $value = $hash_ref->{$key};
- if ($value_format) {
- $value = (defined $value) ? "'$value'" : 'undef';
+ if ($use_neat) {
+ $value = DBI::neat($value, 0);
}
else {
- $value = DBI::neat($value,0);
+ $value = (defined $value) ? "'$value'" : 'undef';
}
$string .= $key . $kv_separator . $value;
}
@@ -696,20 +697,19 @@
}
sub _get_sorted_hash_keys {
- my ($hash_ref, $sort_type) = @_;
- if (not defined $sort_type) {
+ my ($hash_ref, $num_sort) = @_;
+ if (not defined $num_sort) {
my $sort_guess = 1;
$sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess
for keys %$hash_ref;
- $sort_type = $sort_guess;
+ $num_sort = $sort_guess;
}
my @keys = keys %$hash_ref;
no warnings 'numeric';
- my @sorted = ($sort_type)
+ my @sorted = ($num_sort)
? sort { $a <=> $b or $a cmp $b } @keys
: sort @keys;
- #warn "$sort_type = @sorted\n";
return [EMAIL PROTECTED];
}
Modified: dbi/trunk/t/05concathash.t
==============================================================================
--- dbi/trunk/t/05concathash.t (original)
+++ dbi/trunk/t/05concathash.t Mon Jun 2 03:43:48 2008
@@ -29,9 +29,9 @@
# (nul byte in hash not supported)
is DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=\000=", ":\000:", undef,
undef),
"1=\000='a':\000:2=\000='b'", 'should work with nul bytes in kv_sep and
pair_sep';
-is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 0, undef),
- "1='a.a':2='b'", 'should work with nul bytes in hash value (neat)';
is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 1, undef),
+ "1='a.a':2='b'", 'should work with nul bytes in hash value (neat)';
+is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 0, undef),
"1='a\000a':2='b'", 'should work with nul bytes in hash value (not neat)';
# Simple stress tests
@@ -144,22 +144,22 @@
#CatHash::_concat_hash_values({ }, ":-",,"::",1,1);
-sub _concat_hash_sorted {
- my ( $hash_ref, $kv_separator, $pair_separator, $value_format, $sort_type
) = @_;
- # $value_format: false=use neat(), true=dumb quotes
- # $sort_type: 0=lexical, 1=numeric, undef=try to guess
-
+sub _concat_hash_sorted {
+ my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) =
@_;
+ # $num_sort: 0=lexical, 1=numeric, undef=try to guess
+
+ return undef unless defined $hash_ref;
die "hash is not a hash reference" unless ref $hash_ref eq 'HASH';
- my $keys = _get_sorted_hash_keys($hash_ref, $sort_type);
+ my $keys = _get_sorted_hash_keys($hash_ref, $num_sort);
my $string = '';
for my $key (@$keys) {
$string .= $pair_separator if length $string > 0;
my $value = $hash_ref->{$key};
- if ($value_format) {
- $value = (defined $value) ? "'$value'" : 'undef';
- }
+ if ($use_neat) {
+ $value = DBI::neat($value, 0);
+ }
else {
- $value = DBI::neat($value,0);
+ $value = (defined $value) ? "'$value'" : 'undef';
}
$string .= $key . $kv_separator . $value;
}
