clone mg_ptr for magic

Handle mg_ptr to avoid to share it with other PVs.
garu · Jul 17, 2019 · ea428d1 · ea428d1
1 parent 623c600
commit ea428d1
Show file tree

Hide file tree

Showing 4 changed files with 75 additions and 16 deletions.
diff --git a/.gitignore b/.gitignore
@@ -1,7 +1,9 @@
+.DS_Store
 /Clone.bs
 /Clone.c
 /Clone.o
 /MYMETA.*
 /Makefile
+/Makefile.old
 /blib/
 /pm_to_blib
diff --git a/Clone.xs b/Clone.xs
@@ -290,31 +290,54 @@ sv_clone (SV * ref, HV* hseen, int depth)
               obj = mg->mg_obj; 
               break;
             case 't':	/* PERL_MAGIC_taint */
-	      continue;
-              break;
-            case '<':	/* PERL_MAGIC_backref */
-	      continue;
-              break;
+            case '<': /* PERL_MAGIC_backref */
             case '@':  /* PERL_MAGIC_arylen_p */
-             continue;
+              continue;
               break;
             case 'P': /* PERL_MAGIC_tied */
             case 'p': /* PERL_MAGIC_tiedelem */
             case 'q': /* PERL_MAGIC_tiedscalar */
-	      magic_ref++;
+	            magic_ref++;
 	      /* fall through */
             default:
               obj = sv_clone(mg->mg_obj, hseen, -1); 
           }
         } else {
           TRACEME(("magic object for type %c in NULL\n", mg->mg_type));
         }
-	/* this is plain old magic, so do the same thing */
-        sv_magic(clone, 
-                 obj,
-                 mg->mg_type, 
-                 mg->mg_ptr, 
-                 mg->mg_len);
+
+        { /* clone the mg_ptr pv */
+          char *mg_ptr = mg->mg_ptr; /* default */
+
+          if (mg->mg_len >= 0) { /* copy the pv */
+            if (mg_ptr) {
+              Newxz(mg_ptr, mg->mg_len+1, char); /* add +1 for the NULL at the end? */
+              Copy(mg->mg_ptr, mg_ptr, mg->mg_len, char);
+            }
+          } else if (mg->mg_len == HEf_SVKEY) {
+            /* let's share the SV for now */
+            SvREFCNT_inc((SV*)mg->mg_ptr);
+            /* maybe we also want to clone the SV... */
+            //if (mg_ptr) mg->mg_ptr = (char*) sv_clone((SV*)mg->mg_ptr, hseen, -1); 
+          } else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8) { /* copy the cache */
+            if (mg->mg_ptr) {
+              STRLEN *cache;
+              Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+              mg_ptr = (char *) cache;
+              Copy(mg->mg_ptr, mg_ptr, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+            }
+          } else {
+            croak("Unsupported magic_ptr clone");
+          }
+
+          /* this is plain old magic, so do the same thing */
+          sv_magic(clone,
+                   obj,
+                   mg->mg_type,
+                   mg_ptr,
+                   mg->mg_len);
+
+        }
       }
       /* major kludge - why does the vtable for a qr type need to be null? */
       if ( (mg = mg_find(clone, 'r')) )

diff --git a/t/03scalar.t b/t/03scalar.t
@@ -129,7 +129,7 @@ ok( $$a == $$b, 'int check' );
 my $str = 'abcdefg';
 my $qr = qr/$str/;
 my $qc = clone( $qr );
-ok( $qr eq $qc, 'string check' );
+ok( $qr eq $qc, 'string check' ) or warn "$qr vs $qc";
 ok( $str =~ /$qc/, 'regexp check' );
 
 # test for unicode support

diff --git a/t/07magic.t b/t/07magic.t
@@ -1,9 +1,9 @@
-# $Id: 07magic.t,v 1.8 2007/04/20 05:40:48 ray Exp $
+# $Id: 07magic.t,v 1.8 2019/07/16 15:32:45 ray Exp $
 
 use strict;
 
 use Clone;
-use Test::More tests => 3;
+use Test::More tests => 10;
 
 SKIP: {
   eval "use Data::Dumper";
@@ -53,3 +53,37 @@ SKIP: {
   ok( Dumper($x) eq Dumper($y), "Tainted input");
 }
 
+SKIP: {
+  eval q{require Devel::Peek; require B; 1 } or skip "Devel::Peek or B missing", 7;
+
+  my $clone_ref;
+
+  {
+      # one utf8 string
+      my $content = "a\r\n";
+      utf8::upgrade($content);
+
+      # set the PERL_MAGIC_utf8
+      index($content, "\n");
+
+      my $pv = B::svref_2object( \$content );
+      is ref($pv), 'B::PVMG', "got a PV";
+      ok $pv->MAGIC, "PV as a magic set";
+      is $pv->MAGIC->TYPE, 'w', 'PERL_MAGIC_utf8';
+      Devel::Peek::Dump(  $content );
+
+      # Now clone it
+      $clone_ref = Clone::clone(\$content);
+      #is svref_2object( $clone_ref )->MAGIC->PTR, undef, 'undef ptr';
+      # And inspect it with Devel::Peek.
+      $pv = B::svref_2object( $clone_ref );
+      is ref($pv), 'B::PVMG', "clone - got a PV";
+      ok $pv->MAGIC, "clone - PV as a magic set";
+      is $pv->MAGIC->TYPE, 'w', 'clone - PERL_MAGIC_utf8';
+
+      Devel::Peek::Dump(  $$clone_ref );
+
+      ok 1, "Dump without segfault";
+  }
+}
+