Permalink
Browse files

C.xs 1.42_54: support utf8 hash keys by adding B::HV::HvARRAY_utf8

See RT #120535 for the core perl fix
This fixes also the 2nd compile-time case of #200.
  • Loading branch information...
Reini Urban
Reini Urban committed Nov 13, 2013
1 parent be620a1 commit 53fc84e28c9d04d14fb5b76664dad3fbbfff4706
Showing with 112 additions and 8 deletions.
  1. +94 −0 C.xs
  2. +5 −4 lib/B/C.pm
  3. +4 −4 t/issue200.t
  4. +9 −0 typemap
View
94 C.xs
@@ -1,3 +1,4 @@
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
@@ -26,6 +27,7 @@ typedef struct p5rx *B__REGEXP;
#endif
typedef COP *B__COP;
typedef OP *B__OP;
+typedef HV *B__HV;
STATIC U32 a_hash = 0;
@@ -34,6 +36,69 @@ typedef struct {
IV require_tag;
} a_hint_t;
+static const char* const svclassnames[] = {
+ "B::NULL",
+#if PERL_VERSION < 19
+ "B::BIND",
+#endif
+ "B::IV",
+ "B::NV",
+#if PERL_VERSION <= 10
+ "B::RV",
+#endif
+ "B::PV",
+#if PERL_VERSION >= 19
+ "B::INVLIST",
+#endif
+ "B::PVIV",
+ "B::PVNV",
+ "B::PVMG",
+#if PERL_VERSION >= 11
+ "B::REGEXP",
+#endif
+ "B::GV",
+ "B::PVLV",
+ "B::AV",
+ "B::HV",
+ "B::CV",
+ "B::FM",
+ "B::IO",
+};
+
+#define MY_CXT_KEY "B::C::_guts" XS_VERSION
+
+typedef struct {
+ int x_walkoptree_debug; /* Flag for walkoptree debug hook */
+ SV * x_specialsv_list[7];
+} my_cxt_t;
+
+START_MY_CXT
+
+#define walkoptree_debug (MY_CXT.x_walkoptree_debug)
+#define specialsv_list (MY_CXT.x_specialsv_list)
+
+static SV *
+make_sv_object(pTHX_ SV *sv)
+{
+ SV *const arg = sv_newmortal();
+ const char *type = 0;
+ IV iv;
+ dMY_CXT;
+
+ for (iv = 0; iv < (IV)(sizeof(specialsv_list)/sizeof(SV*)); iv++) {
+ if (sv == specialsv_list[iv]) {
+ type = "B::SPECIAL";
+ break;
+ }
+ }
+ if (!type) {
+ type = svclassnames[SvTYPE(sv)];
+ iv = PTR2IV(sv);
+ }
+ sv_setiv(newSVrv(arg, type), iv);
+ return arg;
+}
+
static int
my_runops(pTHX)
{
@@ -218,6 +283,27 @@ op_folded(op)
#endif
+MODULE = B PACKAGE = B::HV PREFIX = Hv
+
+void
+HvARRAY_utf8(hv)
+ B::HV hv
+ PPCODE:
+ if (HvKEYS(hv) > 0) {
+ HE *he;
+ (void)hv_iterinit(hv);
+ EXTEND(sp, HvKEYS(hv) * 2);
+ while ((he = hv_iternext(hv))) {
+ if (HeSVKEY(he)) {
+ mPUSHs(HeSVKEY(he));
+ } else if (HeKUTF8(he)) {
+ PUSHs(newSVpvn_flags(HeKEY(he), HeKLEN(he), SVf_UTF8|SVs_TEMP));
+ } else {
+ mPUSHp(HeKEY(he), HeKLEN(he));
+ }
+ PUSHs(make_sv_object(aTHX_ HeVAL(he)));
+ }
+ }
MODULE = B__C PACKAGE = B::C
@@ -258,4 +344,12 @@ method_cv(meth, packname)
#endif
BOOT:
+ MY_CXT_INIT;
PL_runops = my_runops;
+ specialsv_list[0] = Nullsv;
+ specialsv_list[1] = &PL_sv_undef;
+ specialsv_list[2] = &PL_sv_yes;
+ specialsv_list[3] = &PL_sv_no;
+ specialsv_list[4] = (SV *) pWARN_ALL;
+ specialsv_list[5] = (SV *) pWARN_NONE;
+ specialsv_list[6] = (SV *) pWARN_STD;
View
@@ -12,7 +12,7 @@
package B::C;
use strict;
-our $VERSION = '1.42_53';
+our $VERSION = '1.42_54';
my %debug;
our $check;
my $eval_pvs = '';
@@ -3974,7 +3974,8 @@ sub B::HV::save {
my $sv_list_index = $svsect->index;
warn sprintf( "saving HV $fullname &sv_list[$sv_list_index] 0x%x MAX=%d\n",
$$hv, $hv->MAX ) if $debug{hv};
- my @contents = $hv->ARRAY;
+ # XXX B does not keep the UTF8 flag [RT 120535] #200
+ my @contents = $hv->can('ARRAY_utf8') ? $hv->ARRAY_utf8 : $hv->ARRAY; # our fixed C.xs variant
# protect against recursive self-reference
# i.e. with use Moose at stash Class::MOP::Class::Immutable::Trait
# value => rv => cv => ... => rv => same hash
@@ -4016,8 +4017,8 @@ sub B::HV::save {
$value = "(SV*)$value" unless $value =~ /^&sv_list/;
my $cur = length( pack "a*", $key );
if (!$PERL56) {
- my $pv = $key;
- if (utf8::is_utf8($pv)) { #FIXME: B does not keep the UTF8 flag here (#200)
+ if (utf8::is_utf8($key)) {
+ my $pv = $key;
utf8::encode($pv);
$cur = 0 - length($pv);
}
View
@@ -13,12 +13,12 @@ sub test3 {
my $script = shift;
my $cmt = join('',@_);
my $todo = "";
- #$todo = 'TODO ' if $] > 5.015;
- plctestok($i*3+1, $name, $script, $cmt);
+ $todo = 'TODO ' if $name eq 'ccode200i_c';
+ plctestok($i*3+1, $name, $script, $todo.$cmt);
ctestok($i*3+2, "C", $name, $script, "C $cmt");
- ctestok($i*3+3, "CC", $name, $script, $todo."CC $cmt");
+ ctestok($i*3+3, "CC", $name, $script, "CC $cmt");
$i++;
}
test3('ccode200i_r', '%u=("\x{123}"=>"fo"); print "ok" if $u{"\x{123}"} eq "fo"', 'run-time utf8 hek');
-test3('ccode200i_c', 'BEGIN{%u=("\x{123}"=>"fo")} print "ok" if $u{"\x{123}"} eq "fo"', 'TODO compile-time utf8 hek');
+test3('ccode200i_c', 'BEGIN{%u=("\x{123}"=>"fo")} print "ok" if $u{"\x{123}"} eq "fo"', 'compile-time utf8 hek');
View
@@ -2,6 +2,7 @@ B::MAGIC T_MG_OBJ
B::REGEXP T_RX_OBJ
B::COP T_OP_OBJ
B::OP T_OP_OBJ
+B::HV T_SV_OBJ
INPUT
T_RX_OBJ
@@ -31,3 +32,11 @@ T_OP_OBJ
}
else
croak(\"$var is not a reference\")
+
+T_SV_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")

0 comments on commit 53fc84e

Please sign in to comment.