summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/ExtUtils/Constant
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/ExtUtils/Constant')
-rw-r--r--Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm14
-rw-r--r--Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm345
-rw-r--r--Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm36
3 files changed, 272 insertions, 123 deletions
diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm
index b5b79af1ea7..b6abe1c201a 100644
--- a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm
+++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Base.pm
@@ -5,7 +5,7 @@ use vars qw($VERSION);
use Carp;
use Text::Wrap;
use ExtUtils::Constant::Utils qw(C_stringify perl_stringify);
-$VERSION = '0.04';
+$VERSION = '0.05';
use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
@@ -83,6 +83,18 @@ sub macro_to_ifdef {
return "";
}
+sub macro_to_ifndef {
+ my ($self, $macro) = @_;
+ if (ref $macro) {
+ # Can't invert these stylishly, so "bodge it"
+ return "$macro->[0]#else\n";
+ }
+ if (defined $macro && $macro ne "" && $macro ne "1") {
+ return $macro ? "#ifndef $macro\n" : "#if 1\n";
+ }
+ croak "Can't generate an ifndef for unconditional code";
+}
+
sub macro_to_endif {
my ($self, $macro) = @_;
diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm
index c3fe8ed3c56..545d3221a01 100644
--- a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm
+++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/ProxySubs.pm
@@ -9,7 +9,7 @@ require ExtUtils::Constant::XS;
use ExtUtils::Constant::Utils qw(C_stringify);
use ExtUtils::Constant::XS qw(%XS_TypeSet);
-$VERSION = '0.06';
+$VERSION = '0.08';
@ISA = 'ExtUtils::Constant::XS';
%type_to_struct =
@@ -123,7 +123,7 @@ sub partition_names {
}
sub boottime_iterator {
- my ($self, $type, $iterator, $hash, $subname) = @_;
+ my ($self, $type, $iterator, $hash, $subname, $push) = @_;
my $extractor = $type_from_struct{$type};
die "Can't find extractor code for type $type"
unless defined $extractor;
@@ -133,13 +133,24 @@ sub boottime_iterator {
my $athx = $self->C_constant_prefix_param();
- return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
+ if ($push) {
+ return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
+ while ($iterator->name) {
+ he = $subname($athx $hash, $iterator->name,
+ $iterator->namelen, %s);
+ av_push(push, newSVhek(HeKEY_hek(he)));
+ ++$iterator;
+ }
+EOBOOT
+ } else {
+ return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
while ($iterator->name) {
$subname($athx $hash, $iterator->name,
$iterator->namelen, %s);
- ++$iterator;
+ ++$iterator;
}
EOBOOT
+ }
}
sub name_len_value_macro {
@@ -164,14 +175,39 @@ sub WriteConstants {
my $self = shift;
my $ARGS = {@_};
- my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
- = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};
+ my ($c_fh, $xs_fh, $c_subname, $default_type, $package)
+ = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)};
+
+ my $xs_subname
+ = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant';
my $options = $ARGS->{PROXYSUBS};
$options = {} unless ref $options;
+ my $push = $options->{push};
my $explosives = $options->{croak_on_read};
-
- $xs_subname ||= 'constant';
+ my $croak_on_error = $options->{croak_on_error};
+ my $autoload = $options->{autoload};
+ {
+ my $exclusive = 0;
+ ++$exclusive if $explosives;
+ ++$exclusive if $croak_on_error;
+ ++$exclusive if $autoload;
+
+ # Until someone patches this (with test cases):
+ carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together")
+ if $exclusive > 1;
+ }
+ # Strictly it requires Perl_caller_cx
+ carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later")
+ if $croak_on_error && $^V < v5.13.5;
+ # Strictly this is actually 5.8.9, but it's not well tested there
+ my $can_do_pcs = $] >= 5.009;
+ # Until someone patches this (with test cases)
+ carp ("PROXYSUBS option 'push' requires v5.10 or later")
+ if $push && !$can_do_pcs;
+ # Until someone patches this (with test cases)
+ carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together")
+ if $explosives && $push;
# If anyone is insane enough to suggest a package name containing %
my $package_sprintf_safe = $package;
@@ -196,12 +232,29 @@ sub WriteConstants {
my $pthx = $self->C_constant_prefix_param_defintion();
my $athx = $self->C_constant_prefix_param();
my $symbol_table = C_stringify($package) . '::';
-
- my $can_do_pcs = $] >= 5.009;
+ $push = C_stringify($package . '::' . $push) if $push;
my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';
- print $c_fh $self->header(), <<"EOADD";
-static void
+ print $c_fh $self->header();
+ if ($autoload || $croak_on_error) {
+ print $c_fh <<'EOC';
+
+/* This allows slightly more efficient code on !USE_ITHREADS: */
+#ifdef USE_ITHREADS
+# define COP_FILE(c) CopFILE(c)
+# define COP_FILE_F "s"
+#else
+# define COP_FILE(c) CopFILESV(c)
+# define COP_FILE_F SVf
+#endif
+EOC
+ }
+
+ my $return_type = $push ? 'HE *' : 'void';
+
+ print $c_fh <<"EOADD";
+
+static $return_type
${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
EOADD
if (!$can_do_pcs) {
@@ -210,12 +263,16 @@ EOADD
EO_NOPCS
} else {
print $c_fh <<"EO_PCS";
- SV **sv = hv_fetch(hash, name, namelen, TRUE);
- if (!sv) {
+ HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
+ 0);
+ SV *sv;
+
+ if (!he) {
Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
name);
}
- if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
+ sv = HeVAL(he);
+ if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) {
/* Someone has been here before us - have to make a real sub. */
EO_PCS
}
@@ -226,9 +283,9 @@ EOADD
if ($can_do_pcs) {
print $c_fh <<'EO_PCS';
} else {
- SvUPGRADE(*sv, SVt_RV);
- SvRV_set(*sv, value);
- SvROK_on(*sv);
+ SvUPGRADE(sv, SVt_RV);
+ SvRV_set(sv, value);
+ SvROK_on(sv);
SvREADONLY_on(value);
}
EO_PCS
@@ -237,6 +294,7 @@ EO_PCS
}
EO_NOPCS
}
+ print $c_fh " return he;\n" if $push;
print $c_fh <<'EOADD';
}
@@ -319,10 +377,13 @@ BOOT:
dTHX;
#endif
HV *symbol_table = get_hv("$symbol_table", GV_ADD);
-#ifndef SYMBIAN
- HV *${c_subname}_missing;
-#endif
EOBOOT
+ if ($push) {
+ print $xs_fh <<"EOC";
+ AV *push = get_av(\"$push\", GV_ADD);
+ HE *he;
+EOC
+ }
my %iterator;
@@ -336,11 +397,17 @@ EOBOOT
die "Can't find structure definition for type $type"
unless defined $struct;
- my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
+ my $lc_type = $type ? lc($type) : 'notfound';
+ my $struct_type = $lc_type . '_s';
+ my $array_name = 'values_for_' . $lc_type;
+ $iterator{$type} = 'value_for_' . $lc_type;
+ # Give the notfound struct file scope. The others are scoped within the
+ # BOOT block
+ my $struct_fh = $type ? $xs_fh : $c_fh;
+
print $c_fh "struct $struct_type $struct;\n";
- my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
- print $xs_fh <<"EOBOOT";
+ print $struct_fh <<"EOBOOT";
static const struct $struct_type $array_name\[] =
{
@@ -356,105 +423,114 @@ EOBOOT
carp("Attempting to supply a default for '$name' which has no conditional macro");
next;
}
- print $xs_fh $ifdef;
if ($item->{invert_macro}) {
- print $xs_fh
- " /* This is the default value: */\n" if $type;
- print $xs_fh "#else\n";
+ print $struct_fh $self->macro_to_ifndef($macro);
+ print $struct_fh
+ " /* This is the default value: */\n" if $type;
+ } else {
+ print $struct_fh $ifdef;
}
- print $xs_fh " { ", join (', ', "\"$name\"", $namelen,
- &$type_to_value($value)), " },\n",
+ print $struct_fh " { ", join (', ', "\"$name\"", $namelen,
+ &$type_to_value($value)),
+ " },\n",
$self->macro_to_endif($macro);
}
-
# Terminate the list with a NULL
- print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
+ print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
- $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
-
- print $xs_fh <<"EOBOOT";
+ print $xs_fh <<"EOBOOT" if $type;
const struct $struct_type *$iterator{$type} = $array_name;
EOBOOT
}
delete $found->{''};
- print $xs_fh <<"EOBOOT";
-#ifndef SYMBIAN
- ${c_subname}_missing = get_missing_hash(aTHX);
-#endif
-EOBOOT
-
my $add_symbol_subname = $c_subname . '_add_symbol';
foreach my $type (sort keys %$found) {
print $xs_fh $self->boottime_iterator($type, $iterator{$type},
'symbol_table',
- $add_symbol_subname);
+ $add_symbol_subname, $push);
}
print $xs_fh <<"EOBOOT";
- while (value_for_notfound->name) {
+ if (C_ARRAY_LENGTH(values_for_notfound) > 1) {
+#ifndef SYMBIAN
+ HV *const ${c_subname}_missing = get_missing_hash(aTHX);
+#endif
+ const struct notfound_s *value_for_notfound = values_for_notfound;
+ do {
EOBOOT
print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
- SV *tripwire = newSV(0);
-
- sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
- SvPV_set(tripwire, (char *)value_for_notfound->name);
- if(value_for_notfound->namelen >= 0) {
- SvCUR_set(tripwire, value_for_notfound->namelen);
- } else {
- SvCUR_set(tripwire, -value_for_notfound->namelen);
- SvUTF8_on(tripwire);
- }
- SvPOKp_on(tripwire);
- SvREADONLY_on(tripwire);
- assert(SvLEN(tripwire) == 0);
-
- $add_symbol_subname($athx symbol_table, value_for_notfound->name,
- value_for_notfound->namelen, tripwire);
+ SV *tripwire = newSV(0);
+
+ sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
+ SvPV_set(tripwire, (char *)value_for_notfound->name);
+ if(value_for_notfound->namelen >= 0) {
+ SvCUR_set(tripwire, value_for_notfound->namelen);
+ } else {
+ SvCUR_set(tripwire, -value_for_notfound->namelen);
+ SvUTF8_on(tripwire);
+ }
+ SvPOKp_on(tripwire);
+ SvREADONLY_on(tripwire);
+ assert(SvLEN(tripwire) == 0);
+
+ $add_symbol_subname($athx symbol_table, value_for_notfound->name,
+ value_for_notfound->namelen, tripwire);
EXPLODE
- /* Need to add prototypes, else parsing will vary by platform. */
- SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
- value_for_notfound->namelen, TRUE);
- if (!sv) {
- Perl_croak($athx
- "Couldn't add key '%s' to %%$package_sprintf_safe\::",
- value_for_notfound->name);
- }
- if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
- /* Nothing was here before, so mark a prototype of "" */
- sv_setpvn(*sv, "", 0);
- } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
- /* There is already a prototype of "" - do nothing */
- } else {
- /* Someone has been here before us - have to make a real
- typeglob. */
- /* It turns out to be incredibly hard to deal with all the
- corner cases of sub foo (); and reporting errors correctly,
- so lets cheat a bit. Start with a constant subroutine */
- CV *cv = newCONSTSUB(symbol_table,
- ${cast_CONSTSUB}value_for_notfound->name,
- &PL_sv_yes);
- /* and then turn it into a non constant declaration only. */
- SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
- CvCONST_off(cv);
- CvXSUB(cv) = NULL;
- CvXSUBANY(cv).any_ptr = NULL;
- }
+ /* Need to add prototypes, else parsing will vary by platform. */
+ HE *he = (HE*) hv_common_key_len(symbol_table,
+ value_for_notfound->name,
+ value_for_notfound->namelen,
+ HV_FETCH_LVALUE, NULL, 0);
+ SV *sv;
+#ifndef SYMBIAN
+ HEK *hek;
+#endif
+ if (!he) {
+ Perl_croak($athx
+ "Couldn't add key '%s' to %%$package_sprintf_safe\::",
+ value_for_notfound->name);
+ }
+ sv = HeVAL(he);
+ if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
+ /* Nothing was here before, so mark a prototype of "" */
+ sv_setpvn(sv, "", 0);
+ } else if (SvPOK(sv) && SvCUR(sv) == 0) {
+ /* There is already a prototype of "" - do nothing */
+ } else {
+ /* Someone has been here before us - have to make a real
+ typeglob. */
+ /* It turns out to be incredibly hard to deal with all the
+ corner cases of sub foo (); and reporting errors correctly,
+ so lets cheat a bit. Start with a constant subroutine */
+ CV *cv = newCONSTSUB(symbol_table,
+ ${cast_CONSTSUB}value_for_notfound->name,
+ &PL_sv_yes);
+ /* and then turn it into a non constant declaration only. */
+ SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
+ CvCONST_off(cv);
+ CvXSUB(cv) = NULL;
+ CvXSUBANY(cv).any_ptr = NULL;
+ }
#ifndef SYMBIAN
- if (!hv_store(${c_subname}_missing, value_for_notfound->name,
- value_for_notfound->namelen, &PL_sv_yes, 0))
- Perl_croak($athx "Couldn't add key '%s' to missing_hash",
- value_for_notfound->name);
+ hek = HeKEY_hek(he);
+ if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek),
+ HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE,
+ &PL_sv_yes, HEK_HASH(hek)))
+ Perl_croak($athx "Couldn't add key '%s' to missing_hash",
+ value_for_notfound->name);
#endif
DONT
- print $xs_fh <<"EOBOOT";
+ print $xs_fh " av_push(push, newSVhek(hek));\n"
+ if $push;
- ++value_for_notfound;
+ print $xs_fh <<"EOBOOT";
+ } while ((++value_for_notfound)->name);
}
EOBOOT
@@ -502,14 +578,69 @@ EOBOOT
print $xs_fh $self->macro_to_endif($macro);
}
- print $xs_fh <<EOBOOT;
+ if ($] >= 5.009) {
+ print $xs_fh <<EOBOOT;
+ /* As we've been creating subroutines, we better invalidate any cached
+ methods */
+ mro_method_changed_in(symbol_table);
+ }
+EOBOOT
+ } else {
+ print $xs_fh <<EOBOOT;
/* As we've been creating subroutines, we better invalidate any cached
methods */
++PL_sub_generation;
}
EOBOOT
+ }
- print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
+ return if !defined $xs_subname;
+
+ if ($croak_on_error || $autoload) {
+ print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA';
+
+void
+$xs_subname(sv)
+ INPUT:
+ SV * sv;
+ PREINIT:
+ const PERL_CONTEXT *cx = caller_cx(0, NULL);
+ /* cx is NULL if we've been called from the top level. PL_curcop isn't
+ ideal, but it's much cheaper than other ways of not going SEGV. */
+ const COP *cop = cx ? cx->blk_oldcop : PL_curcop;
+EOC
+
+void
+AUTOLOAD()
+ PROTOTYPE: DISABLE
+ PREINIT:
+ SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv));
+ const COP *cop = PL_curcop;
+EOA
+ print $xs_fh <<"EOC";
+ PPCODE:
+#ifndef SYMBIAN
+ /* It's not obvious how to calculate this at C pre-processor time.
+ However, any compiler optimiser worth its salt should be able to
+ remove the dead code, and hopefully the now-obviously-unused static
+ function too. */
+ HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
+ ? get_missing_hash(aTHX) : NULL;
+ if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
+ ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
+ sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
+ ", used at %" COP_FILE_F " line %d\\n", sv,
+ COP_FILE(cop), CopLINE(cop));
+ } else
+#endif
+ {
+ sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %"
+ COP_FILE_F " line %d\\n", sv, COP_FILE(cop), CopLINE(cop));
+ }
+ croak_sv(sv_2mortal(sv));
+EOC
+ } else {
+ print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
void
$xs_subname(sv)
@@ -523,27 +654,29 @@ EXPLODE
void
$xs_subname(sv)
- PREINIT:
- STRLEN len;
INPUT:
SV * sv;
- const char * s = SvPV(sv, len);
PPCODE:
-#ifdef SYMBIAN
- sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
-#else
- HV *${c_subname}_missing = get_missing_hash(aTHX);
- if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
+#ifndef SYMBIAN
+ /* It's not obvious how to calculate this at C pre-processor time.
+ However, any compiler optimiser worth its salt should be able to
+ remove the dead code, and hopefully the now-obviously-unused static
+ function too. */
+ HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1)
+ ? get_missing_hash(aTHX) : NULL;
+ if ((C_ARRAY_LENGTH(values_for_notfound) > 1)
+ ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
", used", sv);
- } else {
+ } else
+#endif
+ {
sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
sv);
}
-#endif
PUSHs(sv_2mortal(sv));
DONT
-
+ }
}
1;
diff --git a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm
index 016507c72a6..9608256c34c 100644
--- a/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm
+++ b/Master/tlpkg/tlperl/lib/ExtUtils/Constant/Utils.pm
@@ -1,14 +1,16 @@
package ExtUtils::Constant::Utils;
use strict;
-use vars qw($VERSION @EXPORT_OK @ISA $is_perl56);
+use vars qw($VERSION @EXPORT_OK @ISA);
use Carp;
@ISA = 'Exporter';
@EXPORT_OK = qw(C_stringify perl_stringify);
-$VERSION = '0.02';
+$VERSION = '0.03';
-$is_perl56 = ($] < 5.007 && $] > 5.005_50);
+use constant is_perl55 => ($] < 5.005_50);
+use constant is_perl56 => ($] < 5.007 && $] > 5.005_50);
+use constant is_sane_perl => $] > 5.007;
=head1 NAME
@@ -46,7 +48,7 @@ sub C_stringify {
if tr/\0-\377// != length;
# grr 5.6.1 moreso because its regexps will break on data that happens to
# be utf8, which includes my 8 bit test cases.
- $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56;
+ $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if is_perl56;
s/\\/\\\\/g;
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
@@ -54,15 +56,17 @@ sub C_stringify {
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
- if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
- s/([[:^print:]])/sprintf "\\%03o", ord $1/ge;
- } else {
- s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
- }
- unless ($] < 5.006) {
+ unless (is_perl55) {
# This will elicit a warning on 5.005_03 about [: :] being reserved unless
# I cheat
my $cheat = '([[:^print:]])';
+
+ if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
+ s/$cheat/sprintf "\\%03o", ord $1/ge;
+ } else {
+ s/([^\0-\177])/sprintf "\\%03o", ord $1/ge;
+ }
+
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
require POSIX;
@@ -89,10 +93,13 @@ sub perl_stringify {
s/\t/\\t/g;
s/\f/\\f/g;
s/\a/\\a/g;
- unless ($] < 5.006) {
- if ($] > 5.007) {
+ unless (is_perl55) {
+ # This will elicit a warning on 5.005_03 about [: :] being reserved unless
+ # I cheat
+ my $cheat = '([[:^print:]])';
+ if (is_sane_perl) {
if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike.
- s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge;
+ s/$cheat/sprintf "\\x{%X}", ord $1/ge;
} else {
s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge;
}
@@ -107,9 +114,6 @@ sub perl_stringify {
}
$_ = $copy;
}
- # This will elicit a warning on 5.005_03 about [: :] being reserved unless
- # I cheat
- my $cheat = '([[:^print:]])';
s/$cheat/sprintf "\\%03o", ord $1/ge;
} else {
# Turns out "\x{}" notation only arrived with 5.6