If you comment out show_drawing($MW, $ZC); in makeReviewScreen() the leak goes away. So look in show_drawing()

If you comment out the Photo:

    my $img = 'fred'; # $MW->Photo(
#        -data => encode_base64( $small->png ), -format => 'png'
#    );
[download]

The leak goes away.

If you replace the -data option with a -file option and load a small image straight off disk, each iteration leaks by approximately the size of the loaded image.

Conclusion: Tk::Photo doesn't clean up its memory when you undef the Photo object.

I tried adding $img->blank; before the undef, but it made no difference.

Thank you for this. I believe I need to start doubting the CPAN modules a little more. With your diagnosis, I went to CPAN and found that the bug is already documented.

However, contrary to your diagnosis, the documentation says that use of the -file option does not cause this behaviour. Maybe there is something here I can use...

Thanks again,
Perldough

contrary to your diagnosis, the documentation says that use of the -file option does not cause this behaviour.

Hm. Here are my findings using the -file option:

[18:25:56.31] C:\test>dir test.png
26/05/2012  11:30             7,133 test.png

[18:26:17.25] C:\test>986015.pl
start
perl.exe                      6476 Console                    1     29
+,328 K
end
start
perl.exe                      6476 Console                    1     34
+,652 K
end
start
perl.exe                      6476 Console                    1     38
+,348 K
end
start
perl.exe                      6476 Console                    1     38
+,180 K
end
start
perl.exe                      6476 Console                    1     39
+,324 K
end
start
perl.exe                      6476 Console                    1     42
+,816 K
end
start
perl.exe                      6476 Console                    1     45
+,948 K
end
[download]

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

The start of some sanity?

Looking in the POD for Tk::Image it says:

CAVEATS It's necessary to use the "delete" method to delete an image object and free memory associated with it. Just using a lexical variable for storing the image object and letting the variable to go out of scope or setting to undef is not sufficient.

That said, I tried adding

    $ZC->centerTags($dwg);
    $img->delete;
    undef $img;
[download]

And it made no difference.

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

The start of some sanity?

Thank you for this. I believe I need to start doubting the CPAN modules a little more.

Tk modules are notorious for leaks -- also , if the module builds any kind of tree, and grepping the source for "weak" returns no hits, 97/100 its leaking :)

Toplevels and Photo objects leak memory, and need to be reused, instead of a create/destroy cycle, when called often in a script. See Re^2: Tk and ImageMagick

This solved it: no more memory leaks at all.

Here is my modified code for posteriority:

use Tk;
use Tk;
use Tk::PNG;
use Tk::LabFrame;
use Tk::Radiobutton;
use Tk::Pane;
use Tk::WorldCanvas;
use strict;
use feature 'state';

our $currdwg = "./largeimage.png";
our $ZC;
our $sr;
our ($imgX, $imgY);


our $MW  = MainWindow->new(-title => " PROXY FOR MW");
$MW->geometry("+4+5");

review($MW);

MainLoop;


sub review
{
    my ($MW)    = @_;

    my ($RW, $CW) = makeReviewScreen($MW);  
   
}

sub makeReviewScreen
{
    my ($MW)    = @_;
    our $width  = $MW->screenwidth - 145;


    my $RW = $MW->Toplevel(-title => 'XXX');
    $RW->geometry("+0+5");

    my $LW = $RW->Frame;

    my $CW = $RW->Scrolled('WorldCanvas', -width        => $width,
                                     -height       => '480',
                                     -background   => 'white',
                                     -borderwidth  => '3',
                                     -scrollbars   => 'se',
                                     -relief       => 'sunken',
                                     -scrollregion => [-100,0, 6000,40
+00]);
    $ZC = new ZoomCanvas($CW, 1);

    $LW->pack(-side => 'left', -fill => 'y',    -expand => '1', -ancho
+r => 'nw', );
    $CW->pack(-side => 'left', -fill => 'both', -expand => '1' );
    
    $RW->bind('<Up>' => sub
              {
                    print "start\n";
                    start_problems($MW, $ZC);
                    print "end\n";
              }
            
    );
    
    print "init start\n";
    start_problems($MW, $ZC);
    print "init end\n";


    return ( $RW, $CW);
}

sub start_problems
{
    my ($MW, $ZC) = @_;

    
    my @items = $ZC->find('all');
    for my $item (@items)
    {
        $ZC->delete($item);
    }

    show_drawing($MW, $ZC);
    
 
}


sub show_drawing
{

    use GD::Image;
    use MIME::Base64 qw[ encode_base64 ];
    
    my ($MW, $ZC) = @_;
        
    #----------------- Display drawing at specified +- zoom  ---------
+---------#

    my $orig = GD::Image->new($currdwg);
    
    my ($xMax, $yMax) = $orig->getBounds;
    $sr = 3500/ $xMax;
    ($imgX, $imgY) = map { int($_ * $sr) } $orig->getBounds;
    
    my $small = GD::Image->new($imgX, $imgY);
    $small->copyResampled($orig, 0, 0, 0, 0, $imgX, $imgY, $orig->getB
+ounds);

    # Make sure $img doesn't get released.
    # Only define new object the first time around.
    state $img;
    if (! defined $img)
    {
        $img = $MW->Photo();
    }

    # Modify existing object.
    $img->configure("-format", "png");
    $img->configure("-data", encode_base64( $small->png ));
    
    # Don't define new object every time.
    #my $img = $Tk->{MW}->Photo(-data => encode_base64( $small->png ),
    #                    -format => 'png'
    #                    );

    $MW->configure( -title => " REVIEW INTERLOCKING DRAWING  -  $currd
+wg   ($xMax  x  $yMax)");

    my $dwg = $ZC->createImage($MW,0,0, -anchor => 'nw', -image => $im
+g, -tags => 'dwg');
    $ZC->centerTags($dwg);
    
    undef $small;
    undef $orig;

    # Don't delete $img; keep it for next time.
    #undef $img;

    return ([$xMax, $yMax],[$imgX, $imgY]);
}

package ZoomCanvas;

use strict;
use Tk;
use feature 'state';

sub new
{
    my $class = shift;
    my $canvas = shift;
    my $zoom = shift;
    
    # Quick loose check to ensure $canvas is a WorldCanvas
    my $test1 = (ref($canvas) eq "Tk::Frame");
    use Data::Dumper; my $test2 = (Dumper($canvas) =~ "worldcanvas");
    
    if (! ($test1 && $test2))
    {
        die "ZoomCanvas::new: canvas argument not WorldCanvas!\n"
    }

    if (! defined $zoom) { $zoom =1; }
    
    my $self = {
        CANVAS => $canvas,
        ZOOM   => $zoom
    };
    
    bless $self, $class;
    
    return $self;  
}

sub AUTOLOAD
{
    my @args = @_;
    my $self = shift @args;
    
    my $substring = $ZoomCanvas::AUTOLOAD;
    my @splitSub = split("::", $substring);
    my $sub = $splitSub[1];
    
    my $canvas = $self->{CANVAS};
    
    return $canvas->$sub(@args);
}

sub createImage
{
    use Tk::Photo;
    use Storable;   
    use Storable qw(nstore dclone);
    
    # Create state vars
    state $xoff;
    state $yoff;
    state %miscArgs;
    state $MW;

    my @args = @_;
    my $self = shift @args;
    my $canvas = $self->{CANVAS};
    
    my $MW_tmp = shift @args;
    
    # Original args
    my $xoff_tmp = shift @args;
    my $yoff_tmp = shift @args;
    my %miscArgs_tmp = @args;
    
    if
    (
        defined $MW_tmp
        && defined $xoff_tmp
        && defined $yoff_tmp
        && (keys %miscArgs_tmp)
    )
    {
        $MW   = $MW_tmp;
        $xoff = $xoff_tmp;
        $yoff = $yoff_tmp;
        
        if (exists $miscArgs{-image}) { delete $miscArgs{-image}; }
        %miscArgs = %miscArgs_tmp;
    }
        
    my $img = $miscArgs{-image};
 
    # Make sure $zimg doesn't get released
    # Only define new object the first time around
    state $zimg;
    if (! defined $zimg)
    {
        $zimg = $MW->Photo();
    }
    
    #my $zimg = $MW->Photo();
    ($self->{ZOOM} > 1) ? $zimg->copy($img, -zoom      => $self->{ZOOM
+})
                        : $zimg->copy($img, -subsample => (1 / $self->
+{ZOOM}));
                 
    $miscArgs{-image} = $zimg;
    my @miscArgs_list = %miscArgs;
    
    my $return = $canvas->createImage($xoff,$yoff, @miscArgs_list);

    $miscArgs{-image} = $img;
    delete $miscArgs{-image};
    delete $miscArgs_tmp{-image};

    # Don't delete; keep them for later
    #undef $img;
    #undef $zimg;

    return $return;                                 
}
1;
[download]

Thanks everyone,
Perldough

That's a nice use of state to avoid the global variable. :-)

# Make sure $img doesn't get released.
    # Only define new object the first time around.
    state $img;
    if (! defined $img)
    {
        $img = $MW->Photo();
    }
[download]

---

I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

That is quite the bit of entirely-gratuitous “sleuthing” that you have done in order to solve this problem, BrowserUK.   And thoroughly well-done it was, too.   There are not too many web-sites out there where this sort of thing would be de rigueur, let alone for it all to have been done within just a few hours of the original post.   Very impressive.   Thank you.

That is quite the bit of entirely-gratuitous “sleuthing” that you have done in order to solve this problem,

Arg! Actually, it wasn't that much; and it wasn't gratuitous. About 15 minutes effort total spread over the periods of inane pundit chatter between the events at the velodrome.

And the reason it was so simple is that the OP did all the right things:

1. Provided self-contained code that ran straight out of the download.
2. He provided clear instructions on how to run it to demonstrate the problem.
3. He'd obviously cut it down considerably just for the purpose of posting.

That, combined with the clear, simply-structured code, made it easy to comment out one or two lines here or there to isolate where in the code the problem lay. And that is the essence of debugging -- finding the bug. After that it is just reasoning.

It is also where all the "let's hide the complexity behind yet another layer of abstraction" crowd fall flat on their faces. Their attempts to make things look simple, is their undoing when it comes to trying to track through that hidden complexity. Looks simple is not the same as is simple. And every layer of abstraction adds complexity, and removes none.

---

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

The start of some sanity?

Thanks for the feedback and for your all your efforts!

Most gratefully,
Perldough

Browseruk is the pope around here :D.