From perl-5.8.0@ton.iguana.be

Created by perl-5.8.0@ton.iguana.be

#!/usr/bin/perl -w

sub DESTROY {
  my $o = shift;
  1 for my @​alarms;
  print STDERR "DESTROY $o\n";
}

$server->{foo} = bless [];
delete $server->{foo} for $server->{foo}, undef;

my @​bar;
$bar[$_] = [] for 1..2;

This will output​:
DESTROY main=ARRAY(0x8162170)
DESTROY main=ARRAY(0x8162170)
Attempt to free unreferenced scalar​: SV 0x81733ec.

Notice how the object is destroyed twice. The @​bar stuff afterward is just
to perturb things enough to see the "Attempt to free unreferenced scalar"
Other perturbations make it into coredumps.

Also fun is​:
#!/usr/bin/perl -w

sub DESTROY {
  1 for my @​alarms;
  print STDERR "DESTROY ", shift;
}

$server->{foo} = bless [];
delete $server->{foo} for $server->{foo}, undef;

which goes into deep recursion (and then cores)

Flags:
    category=core
    severity=medium

Site configuration information for perl v5.8.4:

Configured by ton at Thu Jun  3 13:28:19 CEST 2004.

Summary of my perl5 (revision 5 version 8 subversion 4) configuration:
  Platform:
    osname=linux, osvers=2.6.5, archname=i686-linux-64int-ld
    uname='linux quasar 2.6.5 #8 mon apr 5 05:41:20 cest 2004 i686 gnulinux '
    config_args=''
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=define use64bitall=undef uselongdouble=define
    usemymalloc=y, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2 -fomit-frame-pointer',
    cppflags='-fno-strict-aliasing -I/usr/local/include'
    ccversion='', gccversion='3.4.0 20031231 (experimental)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long long', ivsize=8, nvtype='long double', nvsize=12, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -ldb -ldl -lm -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    libc=/lib/libc-2.3.2.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.3.2'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.8.4:
    /usr/lib/perl5/5.8.4/i686-linux-64int-ld
    /usr/lib/perl5/5.8.4
    /usr/lib/perl5/site_perl/5.8.4/i686-linux-64int-ld
    /usr/lib/perl5/site_perl/5.8.4
    /usr/lib/perl5/site_perl
    .


Environment for perl v5.8.4:
    HOME=/home/ton
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/ton/bin.Linux:/home/ton/bin:/home/ton/bin.SampleSetup:/usr/local/bin:/usr/local/sbin:/usr/local/jre/bin:/home/oracle/product/9.0.1/bin:/usr/local/ar/bin:/usr/games/bin:/usr/X11R6/bin:/usr/share/bin:/usr/bin:/usr/sbin:/bin:/sbin:.
    PERL_BADLANG (unset)
    SHELL=/bin/bash

From @iabyn

On Sun, Jun 06, 2004 at 02​:27​:34AM -0000, perl-5. 8. 0 @​ ton. iguana. be wrote​:

sub DESTROY {
my $o = shift;
1 for my @​alarms;
print STDERR "DESTROY $o\n";
}

$server->{foo} = bless [];
delete $server->{foo} for $server->{foo}, undef;

my @​bar;
$bar[$_] = [] for 1..2;

This will output​:
DESTROY main=ARRAY(0x8162170)
DESTROY main=ARRAY(0x8162170)

Fixed by the change below.

Dave.

--
A walk of a thousand miles begins with a single step...
then continues for another 1,999,999 or so.

Change 22913 by davem@​davem-splatty on 2004/06/08 22​:20​:40

  [perl #30061] double DESTROY in for loop
  pp_iter decremented the ref count of the previous iterant before
  unaliasing it. This could lead to DESTROY being called with the
  loop variable still aliased to the freed value. If the DESTROY
  also contained a for loop with the same iterator variable, the
  freed value would get resurrected then freed for a second time.

Affected files ...

... //depot/perl/pp_hot.c#354 edit
... //depot/perl/t/cmd/for.t#10 edit

Differences ...

==== //depot/perl/pp_hot.c#354 (text) ====

@​@​ -1824,7 +1824,7 @​@​
{
  dSP;
  register PERL_CONTEXT *cx;
- SV* sv;
+ SV *sv, *oldsv;
  AV* av;
  SV **itersvp;

@​@​ -1852,8 +1852,9 @​@​
  /* we need a fresh SV every time so that loop body sees a
  * completely new SV for closures/references to work as
  * they used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
  *itersvp = newSVsv(cur);
+ SvREFCNT_dec(oldsv);
  }
  if (strEQ(SvPVX(cur), max))
  sv_setiv(cur, 0); /* terminate next time */
@​@​ -1877,8 +1878,9 @​@​
  /* we need a fresh SV every time so that loop body sees a
  * completely new SV for closures/references to work as they
  * used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
  *itersvp = newSViv(cx->blk_loop.iterix++);
+ SvREFCNT_dec(oldsv);
  }
  RETPUSHYES;
  }
@​@​ -1887,8 +1889,6 @​@​
  if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
  RETPUSHNO;

- SvREFCNT_dec(*itersvp);
-
  if (SvMAGICAL(av) || AvREIFY(av)) {
  SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
  if (svp)
@​@​ -1928,7 +1928,10 @​@​
  sv = (SV*)lv;
  }

+ oldsv = *itersvp;
  *itersvp = SvREFCNT_inc(sv);
+ SvREFCNT_dec(oldsv);
+
  RETPUSHYES;
}

==== //depot/perl/t/cmd/for.t#10 (xtext) ====

@​@​ -1,6 +1,6 @​@​
#!./perl

-print "1..13\n";
+print "1..14\n";

for ($i = 0; $i <= 10; $i++) {
  $x[$i] = $i;
@​@​ -76,3 +76,22 @​@​
@​a = (3,4);
eval { @​a = () for (1,2,@​a) };
print $@​ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n";
+
+# [perl #30061] double destory when same iterator variable (eg $_) used in
+# DESTROY as used in for loop that triggered the destroy
+
+{
+
+ my $x = 0;
+ sub X​::DESTROY {
+ my $o = shift;
+ $x++;
+ 1 for (1);
+ }
+
+ my %h;
+ $h{foo} = bless [], 'X';
+ delete $h{foo} for $h{foo}, 1;
+ print $x == 1 ? "ok" : "not ok", " 14 - double destroy, x=$x\n";
+}
+

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

@iabyn - Status changed from 'open' to 'resolved'