[libyaml-libyaml-perl] 01/02: Inhibit blessing only if the class has a DESTROY method

[Christoph Biedl]

This is an automated email from the git hooks/post-receive script.

cbiedl-guest pushed a commit to branch yaml-unsafe
in repository libyaml-libyaml-perl.

commit 02d65fc9b648065309abff3bb26b0db2cb87a684
Author: Christoph Biedl <debian.axhn at manchmal.in-ulm.de>
Date:   Sat May 20 11:19:45 2017 +0000

    Inhibit blessing only if the class has a DESTROY method
---
 debian/patches/control-blessing.patch | 76 +++++++++++++++++++++++------------
 1 file changed, 51 insertions(+), 25 deletions(-)

diff --git a/debian/patches/control-blessing.patch b/debian/patches/control-blessing.patch
index 289a9bf..62ef61e 100644
--- a/debian/patches/control-blessing.patch
+++ b/debian/patches/control-blessing.patch
@@ -1,14 +1,37 @@
 --- a/LibYAML/perl_libyaml.c
 +++ b/LibYAML/perl_libyaml.c
-@@ -290,6 +290,19 @@
+@@ -290,6 +290,42 @@
  }
  
  /*
 + * Check for the unsafe YAML instantiation flag
 + */
 +int
-+use_yaml_unsafe()
++unsafe_yaml_acceptable(const char *class)
 +{
++    /* UNIVERSAL::can (class, 'DESTROY') or return 1; */
++    int count;
++    SV *can = NULL;
++
++    dSP;
++    ENTER;
++    SAVETMPS;
++    PUSHMARK(SP);
++    EXTEND(SP, 2);
++    PUSHs(sv_2mortal(newSVpv(class, strlen(class))));
++    PUSHs(sv_2mortal(newSVpv("DESTROY", strlen("DESTROY"))));
++    PUTBACK;
++    count = call_pv("UNIVERSAL::can", G_SCALAR);
++    SPAGAIN;
++    if (count == 1)
++        can = POPs;
++    PUTBACK;
++    FREETMPS;
++    LEAVE;
++    if (can == NULL || can == &PL_sv_undef)
++        return 1;
++
++    /* return $ENV{'PERL_USE_UNSAFE_YAML'}; */
 +    HV *env = get_hv("ENV", 0);
 +    if (!env)
 +        return 0;
@@ -20,30 +43,33 @@
   * Load a YAML mapping into a Perl hash
   */
  SV *
-@@ -320,7 +333,7 @@
-     /* Deal with possibly blessing the hash if the YAML tag has a class */
-     if (tag && strEQ(tag, TAG_PERL_PREFIX "hash"))
-         tag = NULL;
--    if (tag) {
-+    if (use_yaml_unsafe() && tag) {
-         char *class;
-         char *prefix = TAG_PERL_PREFIX "hash:";
-         if (*tag == '!') {
-@@ -354,7 +367,7 @@
+@@ -332,7 +368,8 @@
+             loader_error_msg(loader, form("bad tag found for hash: '%s'", tag))
+         );
+         class = tag + strlen(prefix);
+-        sv_bless(hash_ref, gv_stashpv(class, TRUE));
++        if (unsafe_yaml_acceptable(class))
++            sv_bless(hash_ref, gv_stashpv(class, TRUE));
+     }
+ 
+     return hash_ref;
+@@ -365,7 +402,8 @@
+             loader_error_msg(loader, form("bad tag found for array: '%s'", tag))
+         );
+         class = tag + strlen(prefix);
+-        sv_bless(array_ref, gv_stashpv(class, TRUE));
++        if (unsafe_yaml_acceptable(class))
++            sv_bless(array_ref, gv_stashpv(class, TRUE));
      }
-     if (tag && strEQ(tag, TAG_PERL_PREFIX "array"))
-         tag = NULL;
--    if (tag) {
-+    if (use_yaml_unsafe() && tag) {
-         char *class;
-         char *prefix = TAG_PERL_PREFIX "array:";
-         if (*tag == '!')
-@@ -448,7 +461,7 @@
-     SPAGAIN;
-     regexp = newSVsv(POPs);
+     return array_ref;
+ }
+@@ -450,7 +488,8 @@
  
--    if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
-+    if (use_yaml_unsafe() && strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
+     if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
          char *class = tag + strlen(prefix);
-         sv_bless(regexp, gv_stashpv(class, TRUE));
+-        sv_bless(regexp, gv_stashpv(class, TRUE));
++        if (unsafe_yaml_acceptable(class))
++            sv_bless(regexp, gv_stashpv(class, TRUE));
      }
+ 
+     if (anchor)

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libyaml-libyaml-perl.git