Storable: sv_upgrade from type 7 down to type 1

[p5pRT]

Migrated from rt.perl.org#134179 (status was 'pending release')

Searchable as RT134179$

[p5pRT]

From alex.karelas@gmail.com

https://gist.github.com/akarelas-pt/f53e3f474e9cefbce8cf00af88f18c08

The above page demonstrates a Storable bug.

I cannot find anywhere instructions on how to submit bugs for Storable.

How do I submit bugs for Storable, and, more importantly, how do I find instructions for how to submit bugs for Storable?

Thank you Sirs,

- Alexander

[p5pRT]

From @ilmari

Hi Porters,

daxim reported on IRC that the following program errors with $subject

  use Storable qw(dclone);
  use Scalar​::Util qw(weaken);

  my $foo = [qr//,[]];
  weaken($foo->[1][0][0] = $foo->[1]);
  dclone $foo;

Both the preceding qr// and the two-level weakened cycle are necessary
to trigger it.

Backtrace​:

$ gdb -q --args perl -MStorable=dclone -MScalar​::Util=weaken \
  -e 'my $foo = [qr//,[]]; weaken($foo->[1][0][0] = $foo->[1]); dclone $foo;'
Reading symbols from perl...done.
(gdb) b Perl_croak
Function "Perl_croak" not defined.
Make breakpoint pending on future shared library load? (y or [n]) y
Breakpoint 1 (Perl_croak) pending.
(gdb) r
Starting program​: /home/ilmari/perl5/perlbrew/perls/30.0td/bin/perl -MStorable=dclone -MScalar​::Util=weaken -e my\ \$foo\ =\ \[qr//,\[\]\]\;\ weaken\(\$foo-\>\[1\]\[0\]\[0\]\ =\ \$foo-\>\[1\]\)\;\ dclone\ \$foo\;
[Thread debugging using libthread_db enabled]
Using host libthread_db library "/lib/x86_64-linux-gnu/libthread_db.so.1".

Breakpoint 1, Perl_croak (my_perl=my_perl@​entry=0x555555757010, pat=pat@​entry=0x7ffff7b49ee0 "sv_upgrade from type %d down to type %d")
  at util.c​:1753
1753 {
(gdb) bt full
#0 Perl_croak (my_perl=my_perl@​entry=0x555555757010, pat=pat@​entry=0x7ffff7b49ee0 "sv_upgrade from type %d down to type %d") at util.c​:1753
  args = {{gp_offset = 27, fp_offset = 0, overflow_arg_area = 0x7ffff6206717 <retrieve+903>, reg_save_area = 0x555555757010}}
#1 0x00007ffff78d16e6 in Perl_sv_upgrade (my_perl=my_perl@​entry=0x555555757010, sv=sv@​entry=0x555555794858, new_type=new_type@​entry=SVt_IV)
  at sv.c​:1307
  old_body = <optimized out>
  new_body = <optimized out>
  old_type = SVt_PVMG
  new_type_details = <optimized out>
  old_type_details = 0x7ffff7b56798 <bodies_by_type+56>
  referent = <optimized out>
  __PRETTY_FUNCTION__ = "Perl_sv_upgrade"
#2 0x00007ffff620d0b5 in retrieve_ref (my_perl=0x555555757010, cxt=0x555555795378, cname=0x0) at Storable.xs​:5435
  rv = 0x555555794858
  sv = 0x555555794450
  stash = 0x0
  __PRETTY_FUNCTION__ = "retrieve_ref"
#3 0x00007ffff6206717 in retrieve (my_perl=my_perl@​entry=0x555555757010, cxt=cxt@​entry=0x555555795378, cname=cname@​entry=0x0)
  at Storable.xs​:7350
  type = 4
  svh = <optimized out>
  sv = <optimized out>
  __PRETTY_FUNCTION__ = "retrieve"
#4 0x00007ffff6215735 in retrieve_array (my_perl=0x555555757010, cxt=0x555555795378, cname=<optimized out>) at Storable.xs​:6292
  len = 1
  i = 0
  av = 0x5555557887e8
  sv = <optimized out>
  stash = <optimized out>
  seen_null = false
  __PRETTY_FUNCTION__ = "retrieve_array"
#5 0x00007ffff6206717 in retrieve (my_perl=my_perl@​entry=0x555555757010, cxt=cxt@​entry=0x555555795378, cname=cname@​entry=0x0)
  at Storable.xs​:7350
  type = 2
  svh = <optimized out>
  sv = <optimized out>
  __PRETTY_FUNCTION__ = "retrieve"
#6 0x00007ffff620ce34 in retrieve_ref (my_perl=0x555555757010, cxt=0x555555795378, cname=0x0) at Storable.xs​:5410
  rv = 0x55555575a348
  sv = <optimized out>
  stash = 0x0
  __PRETTY_FUNCTION__ = "retrieve_ref"
#7 0x00007ffff6206717 in retrieve (my_perl=my_perl@​entry=0x555555757010, cxt=cxt@​entry=0x555555795378, cname=cname@​entry=0x0)
  at Storable.xs​:7350
  type = 4
  svh = <optimized out>
  sv = <optimized out>
  __PRETTY_FUNCTION__ = "retrieve"
#8 0x00007ffff6215735 in retrieve_array (my_perl=0x555555757010, cxt=0x555555795378, cname=<optimized out>) at Storable.xs​:6292
  len = 2
  i = 1
  av = 0x55555577d520
  sv = <optimized out>
  stash = <optimized out>
  seen_null = false
  __PRETTY_FUNCTION__ = "retrieve_array"
#9 0x00007ffff6206717 in retrieve (my_perl=my_perl@​entry=0x555555757010, cxt=cxt@​entry=0x555555795378, cname=cname@​entry=0x0)
  at Storable.xs​:7350
  type = 2
  svh = <optimized out>
  sv = <optimized out>
  __PRETTY_FUNCTION__ = "retrieve"
#10 0x00007ffff6207d1d in do_retrieve (my_perl=my_perl@​entry=0x555555757010, f=f@​entry=0x0, in=in@​entry=0x0, optype=6, optype@​entry=4,
  flags=flags@​entry=6) at Storable.xs​:7540
  perinterp_sv = <optimized out>
  cxt = 0x555555795378
  __PRETTY_FUNCTION__ = "do_retrieve"
  sv = <optimized out>
  is_tainted = <optimized out>
  pre_06_fmt = 0
#11 0x00007ffff620b60d in dclone (sv=0x5555557888a8, my_perl=0x555555757010) at Storable.xs​:7741
  cxt = 0x555555795378
  real_context = 0x555555795378
  perinterp_sv = <optimized out>
  size = 51
  out = <optimized out>
#12 XS_Storable_dclone (my_perl=0x555555757010, cv=<optimized out>) at Storable.xs​:7879
  sv = 0x5555557888a8
  RETVAL = <optimized out>
  sp = <optimized out>
  ax = 1
  mark = <optimized out>
  items = <optimized out>
#13 0x00007ffff78b5236 in Perl_pp_entersub (my_perl=0x555555757010) at pp_hot.c​:5237
  is_scalar = <optimized out>
  sp = <optimized out>
  sv = 0x555555788d40
  gv = 0x7ffff78a3e87 <Perl_pp_sassign+119>
  cv = <optimized out>
  old_savestack_ix = <optimized out>
  __PRETTY_FUNCTION__ = "Perl_pp_entersub"
#14 0x00007ffff786d10a in Perl_runops_debug (my_perl=0x555555757010) at dump.c​:2537
  orig_stack_hwm = 0
#15 0x00007ffff77ccb5b in S_run_body (oldscope=1, my_perl=0x555555757010) at perl.c​:2716
No locals.
#16 perl_run (my_perl=0x555555757010) at perl.c​:2639
  oldscope = 1
  ret = <optimized out>
  cur_env = {je_prev = 0x555555757320, je_buf = {{__jmpbuf = {1, -5698547751553798909, 93824992235440, 140737488346176, 0, 0,
  -1891542260264669949, -1891523593628226301}, __mask_was_saved = 0, __saved_mask = {__val = {93824994451896, 93824994451944,
  93824994451992, 93824994452040, 93824994452088, 93824994452136, 93824994452184, 93824994340880, 140737353934488,
  993451154919501312, 140737488346176, 93824994340880, 139637976727552, 0, 140737488346176, 993451154919501312}}}},
  je_ret = 0, je_mustcatch = false, je_old_delaymagic = 0, je_old_stack_hwm = 0}
  __PRETTY_FUNCTION__ = "perl_run"
#17 0x0000555555554f98 in main (argc=<optimized out>, argv=<optimized out>, env=<optimized out>) at perlmain.c​:127
  exitstatus = <optimized out>
  i = <optimized out>

Summary of my perl5 (revision 5 version 30 subversion 0) configuration​:
 
  Platform​:
  osname=linux
  osvers=4.19.0-0.bpo.4-amd64
  archname=x86_64-linux-thread-multi
  uname='linux ilmari-thinkpad 4.19.0-0.bpo.4-amd64 #1 smp debian 4.19.28-2~bpo9+1 (2019-03-27) x86_64 gnulinux '
  config_args='-de -Dprefix=/home/ilmari/perl5/perlbrew/perls/30.0td -Duseshrplib -Dusethreads -Dman1dir=none -Dman3dir=none -DDEBUGGING -Aeval​:scriptdir=/home/ilmari/perl5/perlbrew/perls/30.0td/bin'
  hint=recommended
  useposix=true
  d_sigaction=define
  useithreads=define
  usemultiplicity=define
  use64bitint=define
  use64bitall=define
  uselongdouble=undef
  usemymalloc=n
  default_inc_excludes_dot=define
  bincompat5005=undef
  Compiler​:
  cc='cc'
  ccflags ='-D_REENTRANT -D_GNU_SOURCE -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2'
  optimize='-O2 -g'
  cppflags='-D_REENTRANT -D_GNU_SOURCE -fwrapv -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include'
  ccversion=''
  gccversion='6.3.0 20170516'
  gccosandvers=''
  intsize=4
  longsize=8
  ptrsize=8
  doublesize=8
  byteorder=12345678
  doublekind=3
  d_longlong=define
  longlongsize=8
  d_longdbl=define
  longdblsize=16
  longdblkind=3
  ivtype='long'
  ivsize=8
  nvtype='double'
  nvsize=8
  Off_t='off_t'
  lseeksize=8
  alignbytes=8
  prototype=define
  Linker and Libraries​:
  ld='cc'
  ldflags =' -fstack-protector-strong -L/usr/local/lib'
  libpth=/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/6/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib
  libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
  perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
  libc=libc-2.24.so
  so=so
  useshrplib=true
  libperl=libperl.so
  gnulibc_version='2.24'
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs
  dlext=so
  d_dlsymun=undef
  ccdlflags='-Wl,-E -Wl,-rpath,/home/ilmari/perl5/perlbrew/perls/30.0td/lib/5.30.0/x86_64-linux-thread-multi/CORE'
  cccdlflags='-fPIC'
  lddlflags='-shared -O2 -g -L/usr/local/lib -fstack-protector-strong'

Characteristics of this binary (from libperl)​:
  Compile-time options​:
  DEBUGGING
  HAS_TIMES
  MULTIPLICITY
  PERLIO_LAYERS
  PERL_COPY_ON_WRITE
  PERL_DONT_CREATE_GVSV
  PERL_IMPLICIT_CONTEXT
  PERL_MALLOC_WRAP
  PERL_OP_PARENT
  PERL_PRESERVE_IVUV
  PERL_TRACK_MEMPOOL
  USE_64_BIT_ALL
  USE_64_BIT_INT
  USE_ITHREADS
  USE_LARGE_FILES
  USE_LOCALE
  USE_LOCALE_COLLATE
  USE_LOCALE_CTYPE
  USE_LOCALE_NUMERIC
  USE_LOCALE_TIME
  USE_PERLIO
  USE_PERL_ATOF
  USE_REENTRANT_API
  USE_THREAD_SAFE_LOCALE
  Built under linux
  Compiled at May 24 2019 16​:22​:48
  %ENV​:
  PERL5LIB="/home/ilmari/.perlbrew/libs/30.0td@​std/lib/perl5"
  PERLBREW_HOME="/home/ilmari/.perlbrew"
  PERLBREW_LIB="std"
  PERLBREW_MANPATH="/home/ilmari/.perlbrew/libs/30.0td@​std/man​:/home/ilmari/perl5/perlbrew/perls/30.0td/man"
  PERLBREW_PATH="/home/ilmari/.perlbrew/libs/30.0td@​std/bin​:/home/ilmari/perl5/perlbrew/bin​:/home/ilmari/perl5/perlbrew/perls/30.0td/bin"
  PERLBREW_PERL="30.0td"
  PERLBREW_ROOT="/home/ilmari/perl5/perlbrew"
  PERLBREW_SHELLRC_VERSION="0.82"
  PERLBREW_VERSION="0.84"
  PERL_LOCAL_LIB_ROOT="/home/ilmari/.perlbrew/libs/30.0td@​std"
  PERL_MB_OPT="--install_base /home/ilmari/.perlbrew/libs/30.0td@​std"
  PERL_MM_OPT="INSTALL_BASE=/home/ilmari/.perlbrew/libs/30.0td@​std"
  @​INC​:
  /home/ilmari/.perlbrew/libs/30.0td@​std/lib/perl5/x86_64-linux-thread-multi
  /home/ilmari/.perlbrew/libs/30.0td@​std/lib/perl5
  /home/ilmari/perl5/perlbrew/perls/30.0td/lib/site_perl/5.30.0/x86_64-linux-thread-multi
  /home/ilmari/perl5/perlbrew/perls/30.0td/lib/site_perl/5.30.0
  /home/ilmari/perl5/perlbrew/perls/30.0td/lib/5.30.0/x86_64-linux-thread-multi
  /home/ilmari/perl5/perlbrew/perls/30.0td/lib/5.30.0

--
"The surreality of the universe tends towards a maximum" -- Skud's Law
"Never formulate a law or axiom that you're not prepared to live with
the consequences of." -- Skud's Meta-Law

[p5pRT]

From @tonycoz

On Wed, 05 Jun 2019 07​:41​:27 -0700, ilmari wrote​:

Hi Porters,

daxim reported on IRC that the following program errors with $subject

use Storable qw(dclone);
use Scalar​::Util qw(weaken);

my $foo = [qr//,[]];
weaken($foo->[1][0][0] = $foo->[1]);
dclone $foo;

The attached fixes it for me.

Tony

[p5pRT]

From @tonycoz

134179-storable-regexp-self-ref.patch

From 911c22769d23520ac44e33511a52cd04341fba10 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 10 Jun 2019 10:17:20 +1000
Subject: (perl #134179) include regexps in the seen objects table on retrieve

Also, bless the regexp object, so freezing/thawing bless qr//, "Foo"
returns a "Foo" blesses regexp.
---
 dist/Storable/Storable.xs |  3 +++
 dist/Storable/t/regexp.t  |  4 +++-
 dist/Storable/t/weak.t    | 10 +++++++++-
 3 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index ed729c94a6..ea794bbfe6 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -6808,6 +6808,7 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
     SV *sv;
     dSP;
     I32 count;
+    HV *stash;
 
     PERL_UNUSED_ARG(cname);
 
@@ -6857,6 +6858,8 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
 
     sv = SvRV(re_ref);
     SvREFCNT_inc(sv);
+    stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+    SEEN_NN(sv, stash, 0);
     
     FREETMPS;
     LEAVE;
diff --git a/dist/Storable/t/regexp.t b/dist/Storable/t/regexp.t
index acf28cfec6..e7c6c7e94a 100644
--- a/dist/Storable/t/regexp.t
+++ b/dist/Storable/t/regexp.t
@@ -37,7 +37,7 @@ while (<DATA>) {
     }
 }
 
-plan tests => 9 + 3*scalar(@tests);
+plan tests => 10 + 3*scalar(@tests);
 
 SKIP:
 {
@@ -75,6 +75,8 @@ SKIP:
     ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'");
 }
 
+is(ref(dclone(bless qr//, "Foo")), "Foo", "check reblessed regexps");
+
 for my $test (@tests) {
     my ($code, $not, $match, $matchc, $name) = @$test;
     my $qr = eval $code;
diff --git a/dist/Storable/t/weak.t b/dist/Storable/t/weak.t
index 220c70160f..48752fbec4 100644
--- a/dist/Storable/t/weak.t
+++ b/dist/Storable/t/weak.t
@@ -29,7 +29,7 @@ sub BEGIN {
 }
 
 use Test::More 'no_plan';
-use Storable qw (store retrieve freeze thaw nstore nfreeze);
+use Storable qw (store retrieve freeze thaw nstore nfreeze dclone);
 require 'testlib.pl';
 our $file;
 use strict;
@@ -143,3 +143,11 @@ foreach (@tests) {
   $stored = nfreeze $input;
   tester($stored, \&freeze_and_thaw, $testsub, 'network string');
 }
+
+{
+    # [perl #134179] sv_upgrade from type 7 down to type 1
+    my $foo = [qr//,[]];
+    weaken($foo->[1][0][0] = $foo->[1]);
+    my $out = dclone($foo); # croaked here
+    is_deeply($out, $foo, "check they match");
+}
-- 
2.11.0


From 040de379ce9b7bec47a258d8b1d7449b21f70d2b Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Mon, 10 Jun 2019 10:42:45 +1000
Subject: bump $Storable::VERSION

and update Changes
---
 dist/Storable/ChangeLog       | 5 +++++
 dist/Storable/__Storable__.pm | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/dist/Storable/ChangeLog b/dist/Storable/ChangeLog
index 04881992e2..4745c74b85 100644
--- a/dist/Storable/ChangeLog
+++ b/dist/Storable/ChangeLog
@@ -1,3 +1,8 @@
+2019-06-11 10:43:00 TonyC
+    version 3.16
+        * (perl #134179) fix self-referencing structures that include regexps
+        * bless regexps to preserve bless qr//, "Foo"
+
 2019-04-23 16:00:00 xsawyerx
     version 3.15
     * Fix leaking.
diff --git a/dist/Storable/__Storable__.pm b/dist/Storable/__Storable__.pm
index 9237371234..8ed247f96f 100644
--- a/dist/Storable/__Storable__.pm
+++ b/dist/Storable/__Storable__.pm
@@ -27,7 +27,7 @@ our @EXPORT_OK = qw(
 
 our ($canonical, $forgive_me);
 
-our $VERSION = '3.15';
+our $VERSION = '3.16';
 
 our $recursion_limit;
 our $recursion_limit_hash;
-- 
2.11.0

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @ilmari

"Tony Cook via RT" <perlbug-followup@​perl.org> writes​:

On Wed, 05 Jun 2019 07​:41​:27 -0700, ilmari wrote​:

Hi Porters,

daxim reported on IRC that the following program errors with $subject

use Storable qw(dclone);
use Scalar​::Util qw(weaken);

my $foo = [qr//,[]];
weaken($foo->[1][0][0] = $foo->[1]);
dclone $foo;

The attached fixes it for me.

Looks good to me, and matches how other potentially-blessed refs are
handled.

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index ed729c94a6..ea794bbfe6 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@​@​ -6808,6 +6808,7 @​@​ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
SV *sv;
dSP;
I32 count;
+ HV *stash;

 PERL\_UNUSED\_ARG\(cname\);

This is no longer unused.

- ilmari
--
"I use RMS as a guide in the same way that a boat captain would use
a lighthouse. It's good to know where it is, but you generally
don't want to find yourself in the same spot." - Tollef Fog Heen

[p5pRT]

From @jkeenan

On Tue, 04 Jun 2019 20​:20​:41 GMT, alex.karelas@​gmail.com wrote​:

https://gist.github.com/akarelas-pt/f53e3f474e9cefbce8cf00af88f18c08

The above page demonstrates a Storable bug.

I cannot find anywhere instructions on how to submit bugs for
Storable.

How do I submit bugs for Storable, and, more importantly, how do I
find instructions for how to submit bugs for Storable?

Thank you Sirs,

- Alexander

Your bug report was sent to 'perlbug-admin@​perl.org'. It should have been sent to 'perlbug@​perl.org'.

The sysadmins have moved it to the proper queue.

Please include the string​: [perl #134176]
in the subject line of all future correspondence about this issue.

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

[p5pRT]

The RT System itself - Status changed from 'new' to 'open'

[p5pRT]

From @tonycoz

On Mon, 10 Jun 2019 02​:53​:18 -0700, ilmari wrote​:

"Tony Cook via RT" <perlbug-followup@​perl.org> writes​:

On Wed, 05 Jun 2019 07​:41​:27 -0700, ilmari wrote​:

Hi Porters,

daxim reported on IRC that the following program errors with
$subject

use Storable qw(dclone);
use Scalar​::Util qw(weaken);

my $foo = [qr//,[]];
weaken($foo->[1][0][0] = $foo->[1]);
dclone $foo;

The attached fixes it for me.

Looks good to me, and matches how other potentially-blessed refs are
handled.

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index ed729c94a6..ea794bbfe6 100644
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@​@​ -6808,6 +6808,7 @​@​ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt,
const char *cname) {
SV *sv;
dSP;
I32 count;
+ HV *stash;

PERL_UNUSED_ARG(cname);

This is no longer unused.

Thanks, fixed in the version committed.

The fix itself is 16f2ddb and the version bump is 5afa8ff.

This fixes both this ticket and the DateTime​::Format​::Strptime issue now merged into 134179 (since the DateTime​::Format​::Strptime object has a regular expression embedded in it.)

Tony

[p5pRT]

@tonycoz - Status changed from 'open' to 'pending release'

[p5pRT]

From alex.karelas@gmail.com

Is it my fault I sent it there? That's the instructions on the screen
said. (I reached them by clicking on 'Issues' on the left-hand side on
metacpan's page for Storable)

On 10/6/19 7​:33 μ.μ., James E Keenan via RT wrote​:

On Tue, 04 Jun 2019 20​:20​:41 GMT, alex.karelas@​gmail.com wrote​:

https://gist.github.com/akarelas-pt/f53e3f474e9cefbce8cf00af88f18c08

The above page demonstrates a Storable bug.

I cannot find anywhere instructions on how to submit bugs for
Storable.

How do I submit bugs for Storable, and, more importantly, how do I
find instructions for how to submit bugs for Storable?

Thank you Sirs,

- Alexander
Your bug report was sent to 'perlbug-admin@​perl.org'. It should have been sent to 'perlbug@​perl.org'.

The sysadmins have moved it to the proper queue.

Please include the string​: [perl #134176]
in the subject line of all future correspondence about this issue.

Thank you very much.