diff --git a/.gitignore b/.gitignore index 08a90b5..defcde9 100644 --- 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 index 4b65987..f4cd2c2 100644 --- a/Clone.xs +++ b/Clone.xs @@ -290,18 +290,14 @@ 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); @@ -309,12 +305,39 @@ sv_clone (SV * ref, HV* hseen, int depth) } 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 index 4b9dad8..bbed4d1 100755 --- 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 index 904f523..249f52a 100755 --- 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"; + } +} +