From 604c662364bf521ea30fc0e4df9d45b3ed304501 Mon Sep 17 00:00:00 2001
From: Nicolas R <atoomic@cpan.org>
Date: Wed, 10 Oct 2018 14:22:53 -0500
Subject: [PATCH] Cleanup factory from Template::Grammar

Resolves #147

This is providing a unit test to check memory leak
from the provided sample from RT 49456

Test::LeakTrace do detect a leak from the provided sample,
but this is not really a leak, this is just coming from the
fact that Template::Grammar is not reseting its singleton factory
object.

This commit adds a 'convoluted' technique to clear the singleton
on DESTROY when it makes sense.

Upstream-URL: https://github.com/abw/Template2/issues/147
---
 lib/Template/Grammar.pm |  57 +++++++++++++++++++++
 t/zz-process-leak.t     | 108 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 165 insertions(+)
 create mode 100644 t/zz-process-leak.t

diff --git a/lib/Template/Grammar.pm b/lib/Template/Grammar.pm
index cd65d3c2b..360c4714b 100644
--- a/lib/Template/Grammar.pm
+++ b/lib/Template/Grammar.pm
@@ -123,10 +123,67 @@ sub new {
     }, $class;
 }
 
+# track usages of objects using the factory
+#	this is an over complex object
+#	used to track how many objects are currently using the shared factory
+my $_factory_usages;
+
+DESTROY {
+	my ( $self ) = @_;
+
+	# on Grammar destruction check if we can safely trigger the destroy for the factory
+	$self->unregister_factory() if $self;
+
+	return;
+}
+
+sub unregister_factory {
+	my ( $self ) = @_;
+
+	return unless $self && ref $_factory_usages;
+	return unless "$factory" eq $_factory_usages->{CURRENT};
+
+	if ( $_factory_usages->{HOLD_BY}->{ "$self" } ) {
+		delete $_factory_usages->{HOLD_BY}->{ "$self" };
+	}
+
+	if ( ! scalar keys %{ $_factory_usages->{HOLD_BY} } ) {
+		# avoid a memory leak from factory
+		undef $factory;
+		undef $_factory_usages;
+	}
+
+	return;
+}
+
+sub register_factory {
+	my ( $self ) = @_;
+
+	return unless $factory;
+
+	$_factory_usages //= { CURRENT => "", HOLD_BY => {} };
+
+	if ( "$factory" ne $_factory_usages->{CURRENT} ) {
+		# we have updated the factory, should not care about the previous one...
+		$_factory_usages->{HOLD_BY} = {}; 		  # reset who hold the factory
+		$_factory_usages->{CURRENT} = "$factory"; # stringify it
+	}
+
+	$_factory_usages->{HOLD_BY}->{ "$self" } = 1; # we are using this factory
+
+	return;
+}
+
 # update method to set package-scoped $factory lexical
 sub install_factory {
     my ($self, $new_factory) = @_;
+
     $factory = $new_factory;
+
+    # register the current factory in order to clean it on destroy if possible
+    $self->register_factory();
+
+    return $factory;
 }
 
 
diff --git a/t/zz-process-leak.t b/t/zz-process-leak.t
new file mode 100644
index 000000000..228068f7a
--- /dev/null
+++ b/t/zz-process-leak.t
@@ -0,0 +1,108 @@
+#============================================================= -*-perl-*-
+#
+# t/zz-process-leak.t
+#
+# Check for memory leak when using Template::Plugin::Simple
+#
+# Written by Nicolas R. <atoomic@cpan.org>
+#
+# Copyright (C) 2018 cPanel Inc.  All Rights Reserved.
+#
+# This is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+#========================================================================
+
+use strict;
+use lib qw( t/lib ./lib ../lib ../blib/arch );
+
+use Template;
+use Template::Plugin::Simple;
+
+use Test::More tests => 6;
+
+plan( skip_all => "Developer test" ) unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} );
+
+#use Test::LeakTrace;
+eval { require Test::LeakTrace };
+if ($@) {
+    skip_all('Test::LeakTrace not installed');
+}
+
+note "Searching for leak using Test::LeakTrace...";
+
+my $vars1 = {
+    data => [
+        {
+            val => 'value1',
+        }
+    ]
+};
+
+my $vars2 = {
+    data => [
+        {
+            val   => 'value2',
+            stuff => [ { name => 'bob' } ]
+        }
+    ]
+};
+
+my @TESTS;
+
+# we are adding it twice to show that this is not really a leak
+#   as only the first one will leak
+#   the memory 'leak' comes from the factory singleton in Template::Grammar
+push @TESTS, {
+    vars   => $vars1,
+    expect => qq[value1\n],
+} for 1 .. 2;
+
+push @TESTS, {
+    vars   => $vars2,
+    expect => qq[value2\n... one item\n],
+};
+
+my ( $VARS, $OUT );
+my $c = 0;
+foreach my $t (@TESTS) {
+
+    $VARS = $t->{vars};
+    ++$c;
+
+    my $no_leaks = Test::LeakTrace::no_leaks_ok( \&check_leak, "no leak when using for var$c" );
+    is $OUT, $t->{expect}, "output matches what we expect for var$c" or diag $OUT;
+
+    if ( !$no_leaks ) {
+        diag "Memory leak detected when using var$c...";
+        if ( eval { require Devel::Cycle; 1 } ) {
+            Devel::Cycle::find_cycle( check_leak() );
+        }
+        else {
+            diag "consider installing Devel::Cycle to detect leak";
+        }
+    }
+
+}
+
+exit;
+
+sub check_leak {
+
+    my $text = <<'EOT';
+[% FOREACH item IN data -%]
+[% item.val %]
+[% FOREACH data IN item.stuff -%]
+... one item
+[% END -%]
+[% END -%]
+EOT
+
+    $OUT = '';    # reset it before calling
+    local $@;     # avoid a leak from $@
+    my $tt = Template->new();
+    eval { $tt->process( \$text, $VARS, \$OUT ); };
+
+    return $tt;
+}
+