From: Tim Bunce <Tim.Bunce@pobox.com>
Date: Sun, 21 Feb 2010 16:39:55 +0000 (+0100)
Subject: [perl #72942] Can't perform unicode operations in Safe compartment
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=900665121b5ecaf606b6bb2bcf350d7f2af158ee;p=p5sagit%2Fp5-mst-13.2.git

[perl #72942] Can't perform unicode operations in Safe compartment

The fix is to make Safe load utf8.pm (and ensure utf8_heavy.pl is run)
so it can always share utf8::SWASHNEW.
---

diff --git a/MANIFEST b/MANIFEST
index 65d13ce..1c34d01 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2755,6 +2755,7 @@ dist/Safe/t/safeload.t		Tests that some modules can be loaded by Safe
 dist/Safe/t/safeops.t		Tests that all ops can be trapped by Safe
 dist/Safe/t/safesort.t		Tests Safe with sort
 dist/Safe/t/safeuniversal.t	Tests Safe with functions from universal.c
+dist/Safe/t/safeutf8.t		Tests Safe with utf8.pm
 dist/SelfLoader/lib/SelfLoader.pm	Load functions only on demand
 dist/SelfLoader/t/01SelfLoader.t	See if SelfLoader works
 dist/SelfLoader/t/02SelfLoader-buggy.t	See if SelfLoader works
diff --git a/dist/Safe/Safe.pm b/dist/Safe/Safe.pm
index e8a16ae..8af4310 100644
--- a/dist/Safe/Safe.pm
+++ b/dist/Safe/Safe.pm
@@ -41,6 +41,23 @@ use Opcode 1.01, qw(
 
 *ops_to_opset = \&opset;   # Temporary alias for old Penguins
 
+# Regular expressions and other unicode-aware code may need to call
+# utf8->SWASHNEW (via perl's utf8.c).  That will fail unless we share the
+# SWASHNEW method.
+# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
+# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
+# and sharing makes it look like the method exists.
+# The simplest and most robust fix is to ensure the utf8 module is loaded when
+# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
+require utf8;
+# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
+# but without depending on knowledge of that implementation detail.
+# This code (//i on a unicode string) ensures utf8 is fully loaded
+# and also loads the ToFold SWASH.
+# (Swashes are cached internally by perl in PL_utf8_* variables
+# independent of being inside/outside of Safe. So once loaded they can be)
+do { my $unicode = pack('U',0xC4).'1a'; $unicode =~ /\xE4/i; };
+# now we can safely include utf8::SWASHNEW in $default_share defined below.
 
 my $default_root  = 0;
 # share *_ and functions defined in universal.c
@@ -60,6 +77,7 @@ my $default_share = [qw[
     &utf8::downgrade
     &utf8::native_to_unicode
     &utf8::unicode_to_native
+    &utf8::SWASHNEW
     $version::VERSION
     $version::CLASS
     $version::STRICT
diff --git a/dist/Safe/t/safeutf8.t b/dist/Safe/t/safeutf8.t
new file mode 100644
index 0000000..28441da
--- /dev/null
+++ b/dist/Safe/t/safeutf8.t
@@ -0,0 +1,46 @@
+#!perl -w
+$|=1;
+BEGIN {
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+        print "1..0\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 7;
+
+use Safe 1.00;
+use Opcode qw(full_opset);
+
+pass;
+
+my $safe = Safe->new('PLPerl');
+$safe->permit(qw(pack));
+
+# Expression that triggers require utf8 and call to SWASHNEW.
+# Fails with "Undefined subroutine PLPerl::utf8::SWASHNEW called"
+# if SWASHNEW is not shared, else returns true if unicode logic is working.
+my $trigger = q{ my $a = pack('U',0xC4); $a =~ /\\xE4/i };
+
+ok $safe->reval( $trigger ), 'trigger expression should return true';
+is $@, '', 'trigger expression should not die';
+
+# return a closure
+my $sub = $safe->reval(q{sub { warn pack('U',0xC4) }});
+
+# define code outside Safe that'll be triggered from inside
+my @warns;
+$SIG{__WARN__} = sub {
+    my $msg = shift;
+    # this regex requires a different SWASH digit data for \d)
+    # than the one used above and by the trigger code in Safe.pm
+    $msg =~ s/\(eval \d+\)/XXX/i; # uses IsDigit SWASH
+    push @warns, $msg;
+};
+
+is eval { $sub->() }, 1, 'warn should return 1';
+is $@, '', '__WARN__ hook should not die';
+is @warns, 1, 'should only be 1 warning';
+like $warns[0], qr/at XXX line/, 'warning should have been edited';
+