Author: timbo
Date: Tue May 27 04:11:28 2008
New Revision: 11327
Added:
dbi/trunk/t/ConcatHash.t
Modified:
dbi/trunk/DBI.xs
Log:
Apply original _concat_hash_sorted implementation patch from Rudolf Lippan.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue May 27 04:11:28 2008
@@ -209,6 +209,141 @@
return buf;
}
+typedef struct num_srt_info {
+ char *key;
+ UV numeric;
+} num_srt_info;
+
+static int
+_cmp_number (val1, val2)
+ const void *val1;
+ const void *val2;
+{
+ int first, second;
+
+ first = ((struct num_srt_info *)val1)->numeric;
+ second = ((struct num_srt_info *)val2)->numeric;
+
+ if (first == second)
+ return 0;
+ else if (first > second)
+ return 1;
+ else
+ return -1;
+}
+
+static int
+_cmp_str (val1, val2)
+ const void *val1;
+ const void *val2;
+{
+ return strcmp( *(char **)val1, *(char **)val2);
+}
+
+static char **
+_sort_hash_keys (hash, sort_order, total_length)
+ HV *hash;
+ int sort_order;
+ STRLEN *total_length;
+{
+ dTHX;
+ I32 hv_len, key_len;
+ HE *entry;
+ char **keys;
+ unsigned int idx = 0;
+ STRLEN tot_len = 0;
+ bool numberish = 1;
+ struct num_srt_info *numbers;
+
+ hv_len = hv_iterinit(hash);
+ if (!hv_len)
+ return 0;
+
+ Newx(keys, hv_len, char *);
+ Newx(numbers, hv_len, struct num_srt_info);
+
+ while ((entry = hv_iternext(hash))) {
+ *(keys+idx) = hv_iterkey(entry, &key_len);
+ tot_len += key_len;
+
+ if (grok_number(*(keys+idx), key_len, &(numbers+idx)->numeric) !=
IS_NUMBER_IN_UV)
+ numberish = 0;
+
+ (numbers+idx)->key = *(keys+idx);
+ ++idx;
+ }
+
+ if (0 != total_length)
+ *total_length = tot_len;
+
+ if (sort_order <0)
+ sort_order = numberish ? 1 : 0;
+
+ if (0 == sort_order || 0 == numberish ) {
+ qsort(keys, hv_len, sizeof(char*), _cmp_str);
+ } else {
+ qsort(numbers, hv_len, sizeof(struct num_srt_info), _cmp_number);
+ for (idx = 0; idx < hv_len; ++idx)
+ *(keys+idx) = (numbers+idx)->key;
+/* SvPV_nolen(sv_2mortal(newSViv(numbers[idx]))); */
+ }
+
+ Safefree(numbers);
+ return keys;
+}
+
+
+static SV *
+_join_hash_sorted (hash, kv_sep, pair_sep, not_neat, sort)
+ HV *hash;
+ char *kv_sep;
+ char *pair_sep;
+ int not_neat;
+ int sort;
+{
+ dTHX;
+ I32 hv_len;
+ STRLEN kv_sep_len, pair_sep_len, hv_val_len, total_len = 0;
+ char **keys;
+ char *value_string;
+ unsigned int i = 0;
+ SV **hash_svp;
+ SV *return_sv;
+
+ kv_sep_len = strlen(kv_sep);
+ pair_sep_len = strlen(pair_sep);
+
+ keys = _sort_hash_keys(hash, sort, &total_len);
+ if (!keys)
+ return newSVpv("", 0);
+
+ hv_len = hv_iterinit(hash);
+ /* total_len += Separators + quotes + term null */
+ total_len += kv_sep_len*hv_len + pair_sep_len*hv_len+2*hv_len+1;
+ return_sv = newSV(total_len);
+ sv_setpv(return_sv, ""); /* quell undef warnings */
+
+ for (i=0; i<hv_len; ++i) {
+ hash_svp = hv_fetch(hash, keys[i], strlen(keys[i]), 0);
+ if (!hash_svp) {
+ warn("No Hash entry with key: %s", keys[i]);
+ continue;
+ }
+
+ value_string = (not_neat) ?
+ (SvOK(*hash_svp) ? SvPV(*hash_svp, hv_val_len) : "") :
+ neatsvpv(*hash_svp,0);
+ sv_catpvf(return_sv, (not_neat) ? "%s%s'%s'%s" : "%s%s%s%s",
+ keys[i], kv_sep, value_string, (i<hv_len-1) ? pair_sep : "");
+ }
+
+ Safefree(keys);
+
+ return return_sv;
+}
+
+
+
/* handy for embedding into condition expression for debugging */
/*
static int warn1(char *s) { warn(s); return 1; }
@@ -4236,6 +4371,43 @@
RETVAL
+SV *
+_concat_hash_sorted (hash, kv_sep_sv, pair_sep_sv,
value_format_sv,sort_type_sv)
+ HV *hash
+ SV *kv_sep_sv
+ SV *pair_sep_sv
+ SV *value_format_sv
+ SV *sort_type_sv
+
+ PREINIT:
+
+ STRLEN kv_sep_len, pair_sep_len;
+ char *kv_sep, *pair_sep;
+ int not_neat, sort;
+
+ CODE:
+
+ kv_sep = SvPV(kv_sep_sv, kv_sep_len);
+ pair_sep = SvPV(pair_sep_sv, pair_sep_len);
+
+ if (SvGMAGICAL(value_format_sv))
+ mg_get(value_format_sv);
+ not_neat = SvTRUE(value_format_sv);
+
+
+ sort = (SvOK(sort_type_sv)) ? SvIV(sort_type_sv) : -1;
+
+
+ RETVAL = _join_hash_sorted(hash,kv_sep, pair_sep, not_neat, sort);
+
+ OUTPUT:
+ RETVAL
+
+
+
+
+
+
MODULE = DBI PACKAGE = DBI::var
void
Added: dbi/trunk/t/ConcatHash.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/ConcatHash.t Tue May 27 04:11:28 2008
@@ -0,0 +1,191 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl CatHash.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 36;
+BEGIN { use_ok('DBI') };
+no warnings 'uninitialized';
+
+# null and undefs -- segfaults?;
+is (DBI::_concat_hash_sorted({ }, "=", ":", 0, undef), "");
+eval {DBI::_concat_hash_sorted(undef, "=", ":", 0, undef), undef};
+like ($@ || "", qr/hash is not a hash reference/); #XXX check this
+is (DBI::_concat_hash_sorted({ }, undef, ":", 0, undef), "");
+
+is (DBI::_concat_hash_sorted({ }, "=", undef, 0, undef), "");
+is (DBI::_concat_hash_sorted({ }, "=", ":", undef, undef),"");
+
+# Simple segfault tests?
+ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "="x12000, ":", 1,
undef));
+ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "=", ":"x12000, 1,
undef));
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "="x12000, ":", 1,
undef));
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..10000)}, "=", ":"x12000, 1,
undef), 'test');
+ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..100)}, "="x12000, ":"x12000,
1, undef), 'test');
+
+my $simple_hash = {
+ bob=>"there",
+ jack=>12,
+ fred=>"there",
+ norman=>"there",
+ # sam =>undef
+};
+
+my $simple_numeric = {
+ 1=>"there",
+ 2=>"there",
+ 3=>"there",
+ 32=>"there",
+ 16 => 'yo',
+ 07 => "buddy",
+ 49 => undef,
+};
+
+my $simple_mixed = {
+ bob=>"there",
+ jack=>12,
+ fred=>"there",
+ norman=>"there",
+ sam =>undef,
+ 1=>"there",
+ 2=>"there",
+ 3=>"there",
+ 32=>"there",
+ 16 => 'yo',
+ 07 => "buddy",
+ 49 => undef,
+};
+
+my $simple_float = {
+ 1.12 =>"there",
+ 3.1415926 =>"there",
+ 2.718281828 =>"there",
+ 32=>"there",
+ 1.6 => 'yo',
+ 0.78 => "buddy",
+ 49 => undef,
+};
+
+#eval {
+# DBI::_concat_hash_sorted($simple_hash, "=",,":",1,12);
+#};
+ok(1," Unknown sort order");
+#like ($@, qr/Unknown sort order/, "Unknown sort order");
+
+
+
+## Loopify and Add Neat
+
+
+my %neats = (
+ "Neat"=>0,
+ "Not Neat"=> 1
+);
+my %sort_types = (
+ guess=>undef,
+ numeric => 1,
+ lexical=> 0
+);
+my %hashes = (
+ Numeric=>$simple_numeric,
+ "Simple Hash" => $simple_hash,
+ "Mixed Hash" => $simple_mixed,
+ "Float Hash" => $simple_float
+);
+
+for $sort_type (keys %sort_types){
+ for $neat (keys %neats) {
+ for $hash(keys %hashes) {
+ test_concat_hash($hash, $neat, $sort_type);
+ }
+ }
+}
+
+sub test_concat_hash {
+ my ($hash, $neat, $sort_type) = @_;
+ is (
+ #DBI::_concat_hash_sorted(
+ _concat_hash_sorted(
+ $hashes{$hash}, "=", ":",$neats{$neat}, $sort_types{$sort_type}
+ ),
+ _concat_hash_sorted(
+ $hashes{$hash} , "=", ":",$neats{$neat}, $sort_types{$sort_type}
+ ),
+ "$hash - $neat $sort_type"
+ );
+}
+
+if (0) {
+ eval {
+ use Benchmark qw(:all);
+ cmpthese(200_000, {
+ Perl => sub {_concat_hash_sorted($simple_hash, "=", ":",0,undef); },
+ C=> sub {DBI::_concat_hash_sorted($simple_hash, "=", ":",0,1);}
+ });
+
+ print "\n";
+ cmpthese(200_000, {
+ NotNeat => sub {DBI::_concat_hash_sorted(
+ $simple_hash, "=", ":",1,undef);
+ },
+ Neat => sub {DBI::_concat_hash_sorted(
+ $simple_hash, "=", ":",0,undef);
+ }
+ });
+ };
+
+}
+#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
+
+ $keys = _get_sorted_hash_keys($hash_ref, $sort_type);
+ 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';
+ }
+ else {
+ $value = DBI::neat($value,0);
+ }
+ $string .= $key . $kv_separator . $value;
+ }
+ return $string;
+}
+
+use Scalar::Util qw(looks_like_number);
+sub _get_sorted_hash_keys {
+ my ($hash_ref, $sort_type) = @_;
+ my $sort_guess = 1;
+ if (not defined $sort_type) {
+ #my $first_key = (each %$hash_ref)[0];
+ #$sort_type = looks_like_number($first_key);
+
+ $sort_guess =
+ (1!=looks_like_number($_)) ? 0:$sort_guess for keys %$hash_ref;
+ $sort_type = $sort_guess unless (defined $sort_type);
+ }
+
+ my @keys = keys %$hash_ref;
+ no warnings 'numeric';
+ return [ ($sort_type && $sort_guess)
+ ? sort {$a <=> $b} @keys
+ : sort @keys
+ ];
+}
+
+
+
+#########################
+
+# Insert your test code below, the Test::More module is use()ed here so read
+# its man page ( perldoc Test::More ) for help writing this test script.
+
