| Subject: | Loading !!perl/code with LoadCode = 0 inconsistent with YAML.pm |
YAML.pm returns a coderef that does nothing (i.e. sub {}). YAML::Syck
returns the actual code of the sub as a string.
The attached patch makes things work like in YAML.pm and adds tests for
this behaviour.
-Flo
| Subject: | YAML-Syck-FLORA-NoLoadCode.diff |
diff --git a/perl_syck.h b/perl_syck.h
index 4a8e292..cb4afc7 100644
--- a/perl_syck.h
+++ b/perl_syck.h
@@ -203,46 +203,52 @@ yaml_syck_parser_handler
sv = newSVpv(blob, len);
#ifndef YAML_IS_JSON
#ifdef PERL_LOADMOD_NOIMPORT
- } else if (load_code && (strEQ(id, "perl/code") || strnEQ(id, "perl/code:", 10))) {
- SV *cv;
- SV *text, *sub;
- char *pkg = id + 10;
+ } else if (strEQ(id, "perl/code") || strnEQ(id, "perl/code:", 10)) {
+ SV *cv;
+ SV *sub;
+ char *pkg = id + 10;
- /* This code is copypasted from Storable.xs */
+ if (load_code) {
+ SV *text;
- /*
- * prepend "sub " to the source
- */
+ /* This code is copypasted from Storable.xs */
- text = newSVpvn(n->data.str->ptr, n->data.str->len);
+ /*
+ * prepend "sub " to the source
+ */
- sub = newSVpvn("sub ", 4);
- sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
- SvREFCNT_dec(text);
+ text = newSVpvn(n->data.str->ptr, n->data.str->len);
- ENTER;
- SAVETMPS;
+ sub = newSVpvn("sub ", 4);
+ sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */
+ SvREFCNT_dec(text);
+ } else {
+ sub = newSVpvn("sub {}", 6);
+ }
- cv = eval_pv(SvPV_nolen(sub), TRUE);
+ ENTER;
+ SAVETMPS;
- sv_2mortal(sub);
+ cv = eval_pv(SvPV_nolen(sub), TRUE);
- if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
- sv = cv;
- } else {
- croak("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub));
- }
+ sv_2mortal(sub);
- if ( (*(pkg - 1) != '\0') && (*pkg != '\0') ) {
- sv_bless(sv, gv_stashpv(pkg, TRUE));
- }
+ if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
+ sv = cv;
+ } else {
+ croak("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub));
+ }
+
+ SvREFCNT_inc(sv); /* XXX seems to be necessary */
- SvREFCNT_inc(sv); /* XXX seems to be necessary */
+ FREETMPS;
+ LEAVE;
- FREETMPS;
- LEAVE;
+ if ( (*(pkg - 1) != '\0') && (*pkg != '\0') ) {
+ sv_bless(sv, gv_stashpv(pkg, TRUE));
+ }
- /* END Storable */
+ /* END Storable */
} else if (strnEQ( n->data.str->ptr, REF_LITERAL, 1+REF_LITERAL_LENGTH)) {
/* type tag in a scalar ref */
diff --git a/t/2-scalars.t b/t/2-scalars.t
index 77e2c0a..bc7cf13 100644
--- a/t/2-scalars.t
+++ b/t/2-scalars.t
@@ -1,4 +1,4 @@
-use t::TestYAML tests => 71;
+use t::TestYAML tests => 75;
local $SIG{__WARN__} = sub { 1 } if $Test::VERSION < 1.20;
@@ -20,6 +20,19 @@ is(Dump(sub{ 42 }), "--- !!perl/code: '{ \"DUMMY\" }'\n");
$YAML::Syck::DumpCode = 1;
ok(Dump(sub{ 42 }) =~ m#--- !!perl/code.*?{.*?42.*?}$#s);
+$YAML::Syck::LoadCode = 0;
+{
+ my $not_sub = Load("--- !!perl/code:Some::Class '{ \"foo\" . shift }'\n");
+ is( ref $not_sub, "Some::Class" );
+ is( $not_sub->("bar"), undef );
+}
+
+{
+ my $sub = Load("--- !!perl/code '{ \"foo\" . shift }'\n");
+ is( ref $sub, "CODE" );
+ is( $sub->("bar"), undef );
+}
+
my $like_yaml_pm = 0;
$YAML::Syck::LoadCode = 0;
ok( my $not_sub = Load("--- !!perl/Class '{ \"foo\" . shift }'\n") );