From pdoru@kappa.ro

Created by pdoru@kappa.ro

While palying with the objects in perl, i've got some strange messages about
Attempt to free non-existent shared string
and
Attempt to free unreferenced scalar

The 2 messages are linked together, I either get both or none. This is no
random thing, but if i make some small changes aparently not related the
warnings disappear :-)))

I've tryed to make a short program that produce the same warnings. But while
doing it i've got another problem​: 'Deep recursion ....'

I've tested them on Linux 2.2x, and this is the result​:
- perl 5.005_03​: both scripts do kind of the same thing (just 'Attempt to free' warns)
- perl 5.005_57​: a_deep_recursion script end with SIGSEGV
- perl 5.005_61​: works as on 5.005_03
- perl 5.6.0​: a_deep_recursion generates the 'deep recursion' warning then SIGSEGV

on 5.005_57, the a_deep_recursion script apear to go recursive for few levels
and then crash. it also give me a LOT or warnings (and stack dumps because of carp)
But on 5.6.0 it takes a LOT more levels of recursion more to get SIGSEGV and
does not produce warnings.

on 5.005_03 both scripts do the same thing, that is generate the
'Attempt to free' warnings and exist.

I think that the problem is​:
- undef %OBJECTS will cause DESTROY() on the object
- but the %OBJECTS still exists and is valid but somehow is marked as freed ?!?!
- DESTROY() will attempt to re-delete the entry but it is probably already
marked as deleted, so a warning is generated.

- i have no idea why i get the deep_recursion. it just happened while i was
wrinting the example script for this email, so i decided to report it also.

This is quite hard to produce. if i delete the 'my $xx' from the the main script
the warns will disapear. is something wrong with my coding style ? but anyway
i shouldn't see internal-data-consistency-failure like warnings :-))))

Best regards,
------
Doru Petrescu
KappaNet - Software Engineer
E-mail​: pdoru@​kappa.ro LINUX - the choice of the GNU generation

########### script 1​: a_attempt_to_free ###################

#!/usr/bin/perl -w
use Data​::Dumper;
use Carp;
BEGIN {
  $SIG{__WARN__} = sub { Carp​::cluck(@​_); print "\n\n"; };
  $SIG{__DIE__} = sub { Carp​::confess(@​_); print "\n\n"; };

  $|=1; open(STDERR, ">&STDOUT"); select STDERR; $|=1; select STDOUT;
}
select STDERR;

my ($xx, $yy);
$xx = TEST->new('object1');
$yy = TEST->new('object1');

exit;
#########################################
package TEST;
use Data​::Dumper;
use Carp;

%OBJECTS = ();
sub new {
  my ($class, $name) = @​_;
  my $obj = { name => $name };

  return $OBJECTS{$name} if (exists $OBJECTS{$name});
 
  $OBJECTS{$name} = bless($obj, $class);
  return $OBJECTS{$name};
}
sub DESTROY {
# print Dumper \%OBJECTS;

  my ($self) = @​_;
  my $name = $self->{name};
  warn "DESTROYing($name) = $self\n";

  delete $OBJECTS{ $name };
  print "DESTROYed($name) = $self\n";
# print Dumper $self;
}
sub DESTROY_all {
  undef %OBJECTS;
}
END { &TEST​::DESTROY_all(); }

########### script 1 ends here ###########################
##########################################################

############### script 2​: a_deep_recursion ################

#!/usr/bin/perl -w
use Data​::Dumper;
use Carp;
BEGIN {
  $SIG{__WARN__} = sub { Carp​::cluck(@​_); print "\n\n"; };
  $SIG{__DIE__} = sub { Carp​::confess(@​_); print "\n\n"; };

  $|=1; open(STDERR, ">&STDOUT"); select STDERR; $|=1; select STDOUT;
}
select STDERR;

my ($xx, $yy);
$xx = TEST->new('object1');
$yy = TEST->new('object1');

exit;
#########################################
package TEST;
use Data​::Dumper;
use Carp;

%OBJECTS = ();
sub new {
  my ($class, $name) = @​_;
  my $obj = { name => $name };

  return $OBJECTS{$name} if (exists $OBJECTS{$name});
 
  $OBJECTS{$name} = bless($obj, $class);
  return $OBJECTS{$name};
}
sub DESTROY {
  print Dumper \%OBJECTS;

  my ($self) = @​_;
  my $name = $self->{name};
  warn "DESTROYing($name) = $self\n";

  delete $OBJECTS{ $name };
  print "DESTROYed($name) = $self\n";
# print Dumper $self;
}
sub DESTROY_all {
  undef %OBJECTS;
}
END { &TEST​::DESTROY_all(); }

#################### script 2 ends here ####################
############################################################

Site configuration information for perl 5.00503:

Configured by root at Sun Jul 18 14:58:08 CDT 1999.

Summary of my perl5 (5.0 patchlevel 5 subversion 3) configuration:
  Platform:
    osname=linux, osvers=2.2.6, archname=i386-linux
    uname='linux xyzzy 2.2.6 #2 wed jun 16 15:23:52 cdt 1999 i686 unknown '
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef useperlio=undef d_sfio=undef
  Compiler:
    cc='cc', optimize='-O2', gccversion=egcs-2.91.66 19990314/Linux (egcs-1.1.2 release)
    cppflags='-Dbool=char -DHAS_BOOL -I/usr/local/include'
    ccflags ='-Dbool=char -DHAS_BOOL -I/usr/local/include'
    stdchar='char', d_stdstdio=undef, usevfork=false
    intsize=4, longsize=4, ptrsize=4, doublesize=8
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    alignbytes=4, usemymalloc=n, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /shlib /lib /usr/lib
    libs=-lnsl -lndbm -lgdbm -ldb -ldl -lm -lc -lposix -lcrypt
    libc=, so=so, useshrplib=false, libperl=libperl.a
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl 5.00503:
    /usr/lib/perl5/i386-linux
    /usr/lib/perl5
    /usr/lib/perl5/site_perl/i386-linux
    /usr/lib/perl5/site_perl
    .


Environment for perl 5.00503:
    HOME=/home/pdoru
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=/usr/local/qt/lib
    LOGDIR (unset)
    PATH=/home/pdoru/bin:/usr/local/qt/bin:/usr/local/bin:/usr/local/sbin:/bin:/sbin:/usr/bin:/usr/sbin:/usr/X11R6/bin:/usr/games:/usr/local/mysql/bin:/usr/local/arts/bin:.:/opt/kde/bin
    PERL_BADLANG (unset)
    SHELL=/bin/bash

From @iabyn

A rather old bug in the bugs database demonstrates a problem with undefining
a hash which contains objects with destructors.
These destructors may try to access that hash, with nasty results
(errors about freeing unrefed values, shared strings etc).

This patch makes a hash that is in the process of being undefed or
cleared, appear to be empty.

Dave.

--
Never do today what you can put off till tomorrow.

--- hv.c-	Thu May  1 13:15:02 2003
+++ hv.c	Thu May  1 13:13:06 2003
@@ -1728,8 +1728,6 @@ Perl_hv_clear(pTHX_ HV *hv)
     }
 
     hfreeentries(hv);
-    xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
-    xhv->xhv_keys = 0; /* HvKEYS(hv) = 0 */
     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
     if (xhv->xhv_array /* HvARRAY(hv) */)
 	(void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
@@ -1758,6 +1756,12 @@ S_hfreeentries(pTHX_ HV *hv)
     riter = 0;
     max = HvMAX(hv);
     array = HvARRAY(hv);
+    /* make everyone else think the array is empty, so that the destructors
+     * called for freed entries can't recusively mess with us */
+    HvARRAY(hv) = Null(HE**); 
+    HvFILL(hv) = 0;
+    ((XPVHV*) SvANY(hv))->xhv_keys = 0;
+
     entry = array[0];
     for (;;) {
 	if (entry) {
@@ -1771,6 +1775,7 @@ S_hfreeentries(pTHX_ HV *hv)
 	    entry = array[riter];
 	}
     }
+    HvARRAY(hv) = array;
     (void)hv_iterinit(hv);
 }
 
@@ -1799,8 +1804,6 @@ Perl_hv_undef(pTHX_ HV *hv)
     }
     xhv->xhv_max   = 7;	/* HvMAX(hv) = 7 (it's a normal hash) */
     xhv->xhv_array = 0;	/* HvARRAY(hv) = 0 */
-    xhv->xhv_fill  = 0;	/* HvFILL(hv) = 0 */
-    xhv->xhv_keys  = 0;	/* HvKEYS(hv) = 0 */
     xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
 
     if (SvRMAGICAL(hv))
--- t/op/undef.t-	Thu May  1 13:15:19 2003
+++ t/op/undef.t	Thu May  1 13:13:39 2003
@@ -5,7 +5,7 @@
     @INC = '../lib';
 }
 
-print "1..28\n";
+print "1..36\n";
 
 print defined($a) ? "not ok 1\n" : "ok 1\n";
 
@@ -85,3 +85,20 @@
     eval 'undef tcp';
     print $@ =~ /^Can't modify constant item/ ? "ok 28\n" : "not ok 28\n";
 }
+
+# bugid 3096
+# undefing a hash may free objects with destructors that then try to
+# modify the hash. To them, the hash should appear empty.
+
+$test = 29;
+%hash = (
+    key1 => bless({}, 'X'),
+    key2 => bless({}, 'X'),
+);
+undef %hash;
+sub X::DESTROY {
+    print "not " if keys   %hash; print "ok $test\n"; $test++;
+    print "not " if values %hash; print "ok $test\n"; $test++;
+    print "not " if each   %hash; print "ok $test\n"; $test++;
+    print "not " if defined delete $hash{'key2'}; print "ok $test\n"; $test++;
+}

From @jhi

Thanks, applied (change #19424).

--
Jarkko Hietaniemi <jhi@​iki.fi> http​://www.iki.fi/jhi/ "There is this special
biologist word we use for 'stable'. It is 'dead'." -- Jack Cohen

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