Dpkg::Control: Fix memory leak due to objects not being garbage-collected

When runnung a Perl script that repeatedly creates unreferenced
Dpkg::Control objects, the perl process consumes memory without limit.

A one-line sample:

  perl -MDpkg::Control -e 'Dpkg::Control->new while 1'

It would be expected from a script like this to have a constant memory
usage, as the Dpkg::Control objects are garbage-collected soon after
being created. What happens instead, is that after running for thirty
seconds, perl has consumed over 100 MiB of memory.

By contrast, the same test using Dpkg::Index consumes a constant 6 MiB.

This problem effectively means that a process can't operate on a large
number of Dpkg::Control objects sequentially.

The cause of the problem appears to be a circular reference between a
Dpkg::Control::Hash and its contained tied hash. This patch explicitly
breaks this loop when a Dpkg::Control::Hash is destroyed, following
the advice in perlobj(1).

Closes: #669012

Signed-off-by: Guillem Jover <guillem@debian.org>

1 files changed, 19 insertions, 8 deletions

diff --git a/scripts/Dpkg/Control/Hash.pm b/scripts/Dpkg/Control/Hash.pm
index 82157d952..5ab28c1d5 100644
--- a/scripts/Dpkg/Control/Hash.pm
+++ b/scripts/Dpkg/Control/Hash.pm
@@ -119,6 +119,16 @@ sub new {
     return $self;
 }
 
+# There is naturally a circular reference between the tied hash and its
+# containing object. Happily, the extra layer of scalar reference can
+# be used to detect the destruction of the object and break the loop so
+# that everything gets garbage-collected.
+
+sub DESTROY {
+    my ($self) = @_;
+    delete $$self->{'fields'};
+}
+
 =item $c->set_options($option, %opts)
 
 Changes the value of one or more options.
@@ -392,9 +402,10 @@ sub field_capitalize($) {
 }
 
 # $self->[0] is the real hash
-# $self->[1] is an array containing the ordered list of keys
-# $self->[2] is an hash describing the relative importance of each field
-# (used to sort the output).
+# $self->[1] is a reference to the hash contained by the parent object.
+# This reference bypasses the top-level scalar reference of a
+# Dpkg::Control::Hash, hence ensuring that that reference gets DESTROYed
+# properly.
 
 # Dpkg::Control::Hash->new($parent)
 #
@@ -412,7 +423,7 @@ sub TIEHASH  {
     my ($class, $parent) = @_;
     die "Parent object must be Dpkg::Control::Hash"
         if not $parent->isa("Dpkg::Control::Hash");
-    return bless [ {}, $parent ], $class;
+    return bless [ {}, $$parent ], $class;
 }
 
 sub FETCH {
@@ -427,7 +438,7 @@ sub STORE {
     my $parent = $self->[1];
     $key = lc($key);
     if (not exists $self->[0]->{$key}) {
-	push @{$$parent->{'in_order'}}, field_capitalize($key);
+	push @{$parent->{'in_order'}}, field_capitalize($key);
     }
     $self->[0]->{$key} = $value;
 }
@@ -441,7 +452,7 @@ sub EXISTS {
 sub DELETE {
     my ($self, $key) = @_;
     my $parent = $self->[1];
-    my $in_order = $$parent->{'in_order'};
+    my $in_order = $parent->{'in_order'};
     $key = lc($key);
     if (exists $self->[0]->{$key}) {
 	delete $self->[0]->{$key};
@@ -455,7 +466,7 @@ sub DELETE {
 sub FIRSTKEY {
     my $self = shift;
     my $parent = $self->[1];
-    foreach (@{$$parent->{'in_order'}}) {
+    foreach (@{$parent->{'in_order'}}) {
 	return $_ if exists $self->[0]->{lc($_)};
     }
 }
@@ -464,7 +475,7 @@ sub NEXTKEY {
     my ($self, $last) = @_;
     my $parent = $self->[1];
     my $found = 0;
-    foreach (@{$$parent->{'in_order'}}) {
+    foreach (@{$parent->{'in_order'}}) {
 	if ($found) {
 	    return $_ if exists $self->[0]->{lc($_)};
 	} else {