Bug #23568 for Class-Singleton: Fix for objects stored in singleton instace not having destructors called.

Thu Nov 23 08:14:59 2006 cmanley [...] cpan.org - Ticket created

Subject:

Fix for objects stored in singleton instace not having destructors called.

I patched Class::Singleton because when objects were being stored in an instance of it, their destructors weren't being called when Perl terminated. Also incorporated is a CVS tag patch so that a "cvs export - kv" doesn't cause syntax errors. Attached is the diff.

Subject:

diff.txt

--- Singleton.pm.orig 2006-09-06 15:15:39.927839600 +0200 +++ Singleton.pm 2006-11-22 08:22:28.000000000 +0100 @@ -13,7 +13,7 @@ # #---------------------------------------------------------------------------- # -# $Id: Singleton.pm,v 1.3 1999/01/19 15:57:43 abw Exp $ +# $Id: Singleton.pm,v 1.3 2006/11/21 20:04:48 cmanley Exp $ # #============================================================================ @@ -22,10 +22,13 @@ require 5.004; use strict; -use vars qw( $RCS_ID $VERSION ); +use vars qw( $RCS_ID $VERSION %_INSTANCES); +$VERSION = sprintf '%d.%02d', q|$Revision: 1.3 $| =~ m/ (\d+) \. (\d+) /xg; +$RCS_ID = q|$Id: Singleton.pm,v 1.3 2006/11/21 20:04:48 cmanley Exp $|; -$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/); -$RCS_ID = q$Id: Singleton.pm,v 1.3 1999/01/19 15:57:43 abw Exp $; +END { + undef(%_INSTANCES); # dereferences and effectively causes the proper destruction of all instances. +} @@ -59,14 +62,14 @@ sub instance { my $class = shift; - - # get a reference to the _instance variable in the $class package - no strict 'refs'; - my $instance = \${ "$class\::_instance" }; - - defined $$instance - ? $$instance - : ($$instance = $class->_new_instance(@_)); + if (ref($class)) { + return $class; + } + my $instance = $_INSTANCES{$class}; + unless(defined($instance)) { + $_INSTANCES{$class} = $instance = $class->_new_instance(@_); + } + return $instance; }

Fri Sep 28 04:27:24 2007 cpan [...] wardley.org - Correspondence added

Thanks for the patch, but I think it's solving a problem that doesn't exist. Destructors *do* get called when Perl exits. I've released a new version (1.4) which contains a test to explicitly check this. Cheers A

Fri Sep 28 04:27:27 2007 The RT System itself - Status changed from 'new' to 'open'

Fri Sep 28 04:27:29 2007 cpan [...] wardley.org - Status changed from 'open' to 'resolved'

Fri Nov 09 10:44:13 2007 cmanley [...] cpan.org - Correspondence added

From:

CMANLEY [...] cpan.org

On Fri Sep 28 04:27:24 2007, ABW wrote: Show quoted text

> Thanks for the patch, but I think it's solving a problem that doesn't > exist. Destructors *do* get called when Perl exits. > > I've released a new version (1.4) which contains a test to explicitly > check this. > > Cheers > A

Hi Andy, Unfortunately it is still a problem (in some cases). It wasn't easy to nail the cause since it was happening in a large application and not in a simple test case I wrote. Anyway, I came across the problem again in another class I was writing (a DBI named connection manager) so I suspected that using DBI may be triggering the problem and indeed it is. I've attached a very simplified test script that demonstrates the problem. Regards, Craig

#!/usr/local/bin/perl -w # $Id$ use strict; { package Puppy; sub new { my $proto = shift; my $name = shift; my $class = ref($proto) || $proto; my $self = {'name' => $name}; bless($self,$class); return $self; } sub dispose { my $self = shift; print ref($self) . ' ' . $self->{'name'} . " has been disposed of.\n"; } sub DESTROY { my $self = shift; print ref($self) . ' ' . $self->{'name'} . " has been destroyed.\n"; } } { package Home; use DBI; # <======= If you remove comment this line out then the unpatched Class::Singleton works fine. use base qw(Class::Singleton); sub _new_instance { my $proto = shift; my $class = ref($proto) || $proto; my $self = { (__PACKAGE__) => { 'puppies' => {}, }, }; bless($self,$class); print "$class built using Class::Singleton version $Class::Singleton::VERSION\n"; return $self; } sub DESTROY { my $self = shift; $self->dispose_of_puppies(); print ref($self) . " has been destroyed.\n"; } sub dispose_of_puppies { my $proto = shift; my $self = ref($proto) ? $proto : $proto->can('has_instance') ? $proto->has_instance() : undef; my $result = 0; if ($self) { my $puppies = $self->{(__PACKAGE__)}->{'puppies'}; foreach my $key (keys %{$puppies}) { my $puppy = $puppies->{$key}; if (defined($puppy)) { eval { $puppy->dispose(); }; if ($@) { warn("Failed to dispose of puppy with tag '$key': $@"); } $result++; } else { warn("Failed to dispose of puppy with tag '$key' because the object has gone MIA!"); } delete($puppies->{$key}); } } return $result; } sub add { my $self = shift; my $tag = shift; my $o = shift; my $privates = $self->{(__PACKAGE__)}; $privates->{'puppies'}->{$tag} = $o; } } my $puppy = Puppy->new('Fifi'); my $home = Home->instance(); $home->add('test', $puppy); # If you see this warning with 'use DBI;' enabled in class Home, then Class::Singleton needs to be patched: # Failed to dispose of puppy with tag 'test' because the object has gone MIA! at csbug.pl line 63 during global destruction.

Fri Nov 09 10:44:19 2007 The RT System itself - Status changed from 'resolved' to 'open'

Wed May 22 02:36:53 2013 cmanley [...] cpan.org - Correspondence added

On Fri Sep 28 04:27:24 2007, ABW wrote: Show quoted text

> Thanks for the patch, but I think it's solving a problem that doesn't > exist. Destructors *do* get called when Perl exits. > > I've released a new version (1.4) which contains a test to explicitly > check this. > > Cheers > A

It's been 6 years, since the bug report, and the issue still persists, even with Perl 5.16.2. I posted a test script to prove that the problem exists but nothing seems to have been done with it.

Wed May 22 02:36:53 2013 cmanley [...] cpan.org - Given to ABW

Sat Aug 16 16:51:44 2014 $_ = 'spro^^*%*^6ut# [...] &$%*c>#!^!#&!pan.org'; y/a-z.@//cd; print - Correspondence added

On Fri Sep 28 04:27:24 2007, ABW wrote: Show quoted text

> Thanks for the patch, but I think it's solving a problem that doesn't > exist. Destructors *do* get called when Perl exits. > > I've released a new version (1.4) which contains a test to explicitly > check this.

That test fails for me intermittently. Sometimes the Test::Builder object can be destroyed before the Class::Singleton object. In that case, ok(...) ends up creating a new Test::Builder object that counts tests from 1, so the test harness considers the output malformed: 1..29 ok 1 - loaded Class::Singleton ok 2 - no Class::Singleton instance yet ok 3 - created Class::Singleton instance 1 ... ok 27 - ConfigSingleton 1 has 3 keys ok 28 - ConfigSingleton 2 has 3 keys ok 1 - destructor called The test should at least make sure that doesn’t happen, but I can’t see an easy way to do that without avoid Test::More altogether, since destruction order at program exit is not predictable. Perhaps you might want to take perl’s t/test.pl and use that instead. OTOH, destroying all Class::Singleton objects explicitly in a END block may solve the problem another way.

Fri Nov 07 04:12:38 2014 shay [...] cpan.org - Correspondence added

I have a simple test script on #68526 which fails due to the same problem as causes the failures here: the unpredictable order of global destruction. The patch in this bug report fixes my problem too. I am attaching an updated version of the patch (against Class-Singleton-1.4) in the hope that a new release can be made with it.

Subject:

instances.patch

diff -ruN Class-Singleton-1.4.orig/lib/Class/Singleton.pm Class-Singleton-1.4/lib/Class/Singleton.pm --- Class-Singleton-1.4.orig/lib/Class/Singleton.pm 2007-09-28 09:18:04.000000000 +0100 +++ Class-Singleton-1.4/lib/Class/Singleton.pm 2014-11-07 09:02:25.589131700 +0000 @@ -20,7 +20,7 @@ use warnings; our $VERSION = 1.4; - +my %_INSTANCES = (); #======================================================================== # @@ -53,11 +53,11 @@ return $class if ref $class; # we store the instance in the _instance variable in the $class package. - no strict 'refs'; - my $instance = \${ "$class\::_instance" }; - defined $$instance - ? $$instance - : ($$instance = $class->_new_instance(@_)); + my $instance = $_INSTANCES{$class}; + unless(defined($instance)) { + $_INSTANCES{$class} = $instance = $class->_new_instance(@_); + } + return $instance; } @@ -90,6 +90,11 @@ } +END { + # dereferences and causes the orderly destruction of all instances. + undef(%_INSTANCES); +} + 1;

Fri Nov 07 16:53:56 2014 shay [...] cpan.org - Correspondence added

Many thanks to Craig for the original patch. Andy has kindly given me co-maint on Class-Singleton and I've just uploaded version 1.5 with the patch applied (plus the appropriate documentation changes) to fix this issue.

Fri Nov 07 16:53:59 2014 shay [...] cpan.org - Status changed from 'open' to 'resolved'