This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make Storable correctly store coderefs with UTF-8 flag
authorDavid Leadbeater <dgl@dgl.cx>
Fri, 3 Dec 2010 09:01:55 +0000 (09:01 +0000)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 4 Dec 2010 19:42:17 +0000 (11:42 -0800)
dist/Storable/Storable.xs
dist/Storable/t/code.t

index 1654557..6a1ddb3 100644 (file)
@@ -2698,7 +2698,10 @@ static int store_code(pTHX_ stcxt_t *cxt, CV *cv)
         * Now store the source code.
         */
 
-       STORE_SCALAR(SvPV_nolen(text), len);
+       if(SvUTF8 (text))
+               STORE_UTF8STR(SvPV_nolen(text), len);
+       else
+               STORE_SCALAR(SvPV_nolen(text), len);
 
        FREETMPS;
        LEAVE;
@@ -5350,7 +5353,7 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
        dSP;
        int type, count, tagnum;
        SV *cv;
-       SV *sv, *text, *sub;
+       SV *sv, *text, *sub, *errsv;
 
        TRACEME(("retrieve_code (#%d)", cxt->tagnum));
 
@@ -5378,6 +5381,12 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
        case SX_LSCALAR:
                text = retrieve_lscalar(aTHX_ cxt, cname);
                break;
+       case SX_UTF8STR:
+               text = retrieve_utf8str(aTHX_ cxt, cname);
+               break;
+       case SX_LUTF8STR:
+               text = retrieve_lutf8str(aTHX_ cxt, cname);
+               break;
        default:
                CROAK(("Unexpected type %d in retrieve_code\n", type));
        }
@@ -5387,6 +5396,8 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
         */
 
        sub = newSVpvn("sub ", 4);
+       if (SvUTF8(text))
+               SvUTF8_on(sub);
        sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
        SvREFCNT_dec(text);
 
@@ -5416,25 +5427,27 @@ static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname)
        ENTER;
        SAVETMPS;
 
+       errsv = get_sv("@", GV_ADD);
+       sv_setpvn(errsv, "", 0);        /* clear $@ */
        if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
-               SV* errsv = get_sv("@", GV_ADD);
-               sv_setpvn(errsv, "", 0);        /* clear $@ */
                PUSHMARK(sp);
                XPUSHs(sv_2mortal(newSVsv(sub)));
                PUTBACK;
                count = call_sv(cxt->eval, G_SCALAR);
-               SPAGAIN;
                if (count != 1)
                        CROAK(("Unexpected return value from $Storable::Eval callback\n"));
-               cv = POPs;
-               if (SvTRUE(errsv)) {
-                       CROAK(("code %s caused an error: %s",
-                               SvPV_nolen(sub), SvPV_nolen(errsv)));
-               }
-               PUTBACK;
        } else {
-               cv = eval_pv(SvPV_nolen(sub), TRUE);
+               eval_sv(sub, G_SCALAR);
        }
+       SPAGAIN;
+       cv = POPs;
+       PUTBACK;
+
+       if (SvTRUE(errsv)) {
+               CROAK(("code %s caused an error: %s",
+                       SvPV_nolen(sub), SvPV_nolen(errsv)));
+       }
+
        if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
            sv = SvRV(cv);
        } else {
index a51dffc..33b52b9 100644 (file)
@@ -33,7 +33,7 @@ BEGIN {
     }
 }
 
-BEGIN { plan tests => 59 }
+BEGIN { plan tests => 63 }
 
 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
 use Safe;
@@ -305,3 +305,13 @@ is(prototype($thawed->[4]), prototype($obj[0]->[4]));
     }
 
 }
+
+{
+    my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}");
+
+    for my $text(@text) {
+        my $res = (thaw freeze eval "sub {'" . $text . "'}")->();
+        ok($res eq $text);
+    }
+}
+