OUTPUT:
RETVAL
+SV *
+delete(hash, key_sv)
+ PREINIT:
+ STRLEN len;
+ const char *key;
+ INPUT:
+ HV *hash
+ SV *key_sv
+ CODE:
+ key = SvPV(key_sv, len);
+ /* It's already mortal, so need to increase reference count. */
+ RETVAL = SvREFCNT_inc(hv_delete(hash, key,
+ SvUTF8(key_sv) ? -len : len, 0));
+ OUTPUT:
+ RETVAL
+
+SV *
+store(hash, key_sv, value)
+ PREINIT:
+ STRLEN len;
+ const char *key;
+ SV *copy;
+ SV **result;
+ INPUT:
+ HV *hash
+ SV *key_sv
+ SV *value
+ CODE:
+ key = SvPV(key_sv, len);
+ copy = newSV(0);
+ result = hv_store(hash, key, SvUTF8(key_sv) ? -len : len, copy, 0);
+ SvSetMagicSV(*result, value);
+ if (!result) {
+ SvREFCNT_dec(copy);
+ XSRETURN_EMPTY;
+ }
+ /* It's about to become mortal, so need to increase reference count.
+ */
+ RETVAL = SvREFCNT_inc(*result);
+ OUTPUT:
+ RETVAL
+
+
+SV *
+fetch(hash, key_sv)
+ PREINIT:
+ STRLEN len;
+ const char *key;
+ SV **result;
+ INPUT:
+ HV *hash
+ SV *key_sv
+ CODE:
+ key = SvPV(key_sv, len);
+ result = hv_fetch(hash, key, SvUTF8(key_sv) ? -len : len, 0);
+ if (!result) {
+ XSRETURN_EMPTY;
+ }
+ /* Force mg_get */
+ RETVAL = newSVsv(*result);
+ OUTPUT:
+ RETVAL
+
=pod
sub TIEHASH { bless {}, $_[0] }
my @testkeys = ('N', chr 256);
-my $temp = chr 258;
-utf8::encode $temp;
+my $utf8_for_258 = chr 258;
+utf8::encode $utf8_for_258;
-my @keys = (@testkeys, $temp);
+my @keys = (@testkeys, $utf8_for_258);
my (%hash, %tiehash);
tie %tiehash, 'Tie::StdHash';
-@hash{@keys} = ();
-@tiehash{@keys} = ();
+@hash{@keys} = @keys;
+@tiehash{@keys} = @keys;
use Test::More 'no_plan';
"hv_exists tie absent $printable");
}
+sub test_delete_present {
+ my $key = shift;
+ my $printable = join ',', map {ord} split //, $key;
+
+ my $copy = {%hash};
+ is (delete $copy->{$key}, $key, "hv_delete_ent present $printable");
+ $copy = {%hash};
+ is (XS::APItest::Hash::delete ($copy, $key), $key,
+ "hv_delete present $printable");
+
+ $copy = {};
+ tie %$copy, 'Tie::StdHash';
+ %$copy = %tiehash;
+ is (delete $copy->{$key}, $key, "hv_delete_ent tie present $printable");
+
+ %$copy = %tiehash;
+ is (XS::APItest::Hash::delete ($copy, $key), $key,
+ "hv_delete tie present $printable");
+}
+
+sub test_delete_absent {
+ my $key = shift;
+ my $printable = join ',', map {ord} split //, $key;
+
+ my $copy = {%hash};
+ is (delete $copy->{$key}, undef, "hv_delete_ent absent $printable");
+ $copy = {%hash};
+ is (XS::APItest::Hash::delete ($copy, $key), undef,
+ "hv_delete absent $printable");
+
+ $copy = {};
+ tie %$copy, 'Tie::StdHash';
+ %$copy = %tiehash;
+ is (delete $copy->{$key}, undef, "hv_delete_ent tie absent $printable");
+
+ %$copy = %tiehash;
+ is (XS::APItest::Hash::delete ($copy, $key), undef,
+ "hv_delete tie absent $printable");
+}
+
+sub brute_force_exists {
+ my ($hash, $key) = @_;
+ foreach (keys %$hash) {
+ return 1 if $key eq $_;
+ }
+ return 0;
+}
+
+sub test_store {
+ my $key = shift;
+ my $printable = join ',', map {ord} split //, $key;
+
+ # We are cheating - hv_store returns NULL for a store into an empty
+ # tied hash. This isn't helpful here.
+
+ my %h1 = (a=>'cheat');
+ is ($h1{$key} = 1, 1);
+ ok (brute_force_exists (\%h1, $key), "hv_store_ent $printable");
+ my %h2 = (a=>'cheat');
+ is (XS::APItest::Hash::store(\%h2, $key, 1), 1);
+ ok (brute_force_exists (\%h2, $key), "hv_store $printable");
+ my %h3 = (a=>'cheat');
+ tie %h3, 'Tie::StdHash';
+ is ($h3{$key} = 1, 1);
+ ok (brute_force_exists (\%h3, $key), "hv_store_ent tie $printable");
+
+ my %h4 = (a=>'cheat');
+ tie %h4, 'Tie::StdHash';
+ is (XS::APItest::Hash::store(\%h4, $key, 1), 1);
+ ok (brute_force_exists (\%h4, $key), "hv_store tie $printable");
+}
+
+sub test_fetch_present {
+ my $key = shift;
+ my $printable = join ',', map {ord} split //, $key;
+
+ is ($hash{$key}, $key, "hv_fetch_ent present $printable");
+ is (XS::APItest::Hash::fetch (\%hash, $key), $key,
+ "hv_fetch present $printable");
+
+ is ($tiehash{$key}, $key, "hv_fetch_ent tie present $printable");
+ is (XS::APItest::Hash::fetch (\%tiehash, $key), $key,
+ "hv_fetch tie present $printable");
+}
+
+sub test_fetch_absent {
+ my $key = shift;
+ my $printable = join ',', map {ord} split //, $key;
+
+ is ($hash{$key}, undef, "hv_fetch_ent absent $printable");
+ is (XS::APItest::Hash::fetch (\%hash, $key), undef,
+ "hv_fetch absent $printable");
+
+ is ($tiehash{$key}, undef, "hv_fetch_ent tie absent $printable");
+ is (XS::APItest::Hash::fetch (\%tiehash, $key), undef,
+ "hv_fetch tie absent $printable");
+}
+
foreach my $key (@testkeys) {
test_present ($key);
+ test_fetch_present ($key);
+ test_delete_present ($key);
+
+ test_store ($key);
my $lckey = lc $key;
test_absent ($lckey);
+ test_fetch_absent ($lckey);
+ test_delete_absent ($lckey);
my $unikey = $key;
utf8::encode $unikey;
- test_absent ($unikey) unless $unikey eq $key;
+ next if $unikey eq $key;
+
+ test_absent ($unikey);
+ test_fetch_absent ($unikey);
+ test_delete_absent ($unikey);
}
+# hv_exists was buggy for tied hashes, in that the raw utf8 key was being
+# used - the utf8 flag was being lost.
test_absent (chr 258);
+test_fetch_absent (chr 258);
+test_delete_absent (chr 258);
+
+{
+ my %h = (a=>'cheat');
+ tie %h, 'Tie::StdHash';
+ is (XS::APItest::Hash::store(\%h, chr 258, 1), 1);
+
+ ok (!exists $h{$utf8_for_258},
+ "hv_store doesn't insert a key with the raw utf8 on a tied hash");
+}
return 0;
if (SvRMAGICAL(hv)) {
- /* All this clause seems to be utf8 unaware.
- By moving the utf8 stuff out to hv_fetch_flags I need to ensure
- key doesn't leak. I've not tried solving the utf8-ness.
- NWC.
- */
if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
sv = sv_newmortal();
sv_upgrade(sv, SVt_PVLV);
- mg_copy((SV*)hv, sv, key, klen);
+ if (flags & HVhek_UTF8) {
+ /* This hack based on the code in hv_exists_ent seems to be
+ the easiest way to pass the utf8 flag through and fix
+ the bug in hv_exists for tied hashes with utf8 keys. */
+ SV *keysv = sv_2mortal(newSVpvn(key, klen));
+ SvUTF8_on(keysv);
+ mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
+ } else {
+ mg_copy((SV*)hv, sv, key, klen);
+ }
if (flags & HVhek_FREEKEY)
Safefree(key);
LvTYPE(sv) = 't';
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
if (needs_copy) {
- mg_copy((SV*)hv, val, key, klen);
+ if (flags & HVhek_UTF8) {
+ /* This hack based on the code in hv_exists_ent seems to be
+ the easiest way to pass the utf8 flag through and fix
+ the bug in hv_exists for tied hashes with utf8 keys. */
+ SV *keysv = sv_2mortal(newSVpvn(key, klen));
+ SvUTF8_on(keysv);
+ mg_copy((SV*)hv, val, (char *)keysv, HEf_SVKEY);
+ } else {
+ mg_copy((SV*)hv, val, key, klen);
+ }
if (!xhv->xhv_array /* !HvARRAY */ && !needs_store) {
if (flags & HVhek_FREEKEY)
Safefree(key);
bool needs_store;
hv_magic_check (hv, &needs_copy, &needs_store);
- if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
+// XXX PerlIO_printf(PerlIO_stderr(), "%d %d\n", is_utf8, klen);
+ if (needs_copy
+ && (svp = hv_fetch(hv, key, is_utf8 ? -klen : klen, TRUE))) {
sv = *svp;
if (SvMAGICAL(sv)) {
mg_clear(sv);
projects / p5sagit/p5-mst-13.2.git / commitdiff