Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Re: Losing my memory

by kcott (Archbishop)
on Feb 05, 2021 at 12:19 UTC ( #11127923=note: print w/replies, xml ) Need Help??


in reply to Losing my memory

G'day nzsvz9,

This was something that interested me because I write a lot of Tk programs for personal use, and many of them involve images. I've never run out of memory — possibly because I've got lots to start with; 32GB on my current machine — so it has never occurred to me to check for memory leaks.

Your idea of passing around Tk-related data in a hash is, at least in my opinion, a good one. I do it myself and, in the code below, I've provided some basic examples of my type of usage. I do not, however, use package variables; furthermore, my lexical $TK is hidden from almost all of the code in an anonymous block.

You also need to manage your %TK. You didn't show any working code nor give any idea of how many images you're dealing with or how big they are; however, I suspect this is, at least part of, your memory problem. There may well be all sorts of other data you're carrying around well past its use-by-date.

The following code I ran twice. First without, then with, these two lines of code (they're almost at the end of the script):

(delete $TK->{img}{$name})->delete(); $TK->{gui}{can}->delete('all');

The first run chewed up about 200MB which was immediately reclaimed when I used the "Exit" button. The second run used no appreciable amount of memory; system memory was unchanged after hitting "Exit".

I can't fix your code because you didn't show it. I attempted to keep most of what you outlined in your description. Hopefully, you can get some ideas from what follows to make improvements.

#!/usr/bin/env perl use strict; use warnings; use Tk; { my $TK = {}; $TK->{gui}{mw} = MainWindow::->new(); _build_gui($TK); my ($iter, $id) = (0); $id = $TK->{gui}{mw}->repeat(500, sub { $TK->{gui}{start}->invoke(); $TK->{gui}{mw}->after(200, sub { (shift @{$TK->{gui}{quits}})->invoke(); }); $id->cancel if $iter++ > 1_000; }); } MainLoop; sub _build_gui { my ($TK) = @_; $TK->{gui}{mw}->configure(-title => 'Test Tk::Photo Memory Leak'); $TK->{gui}{mw}->geometry('384x216+100+150'); _build_controls($TK); return; } sub _build_controls { my ($TK) = @_; $TK->{gui}{frame} = $TK->{gui}{mw}->Frame()->pack(); $TK->{gui}{start} = $TK->{gui}{frame}->Button( -text => 'Start', -command => sub { _popup($TK) } )->pack(); $TK->{gui}{frame}->Button( -text => 'Exit', -command => sub { exit } )->pack(); return; } sub _popup { my ($TK) = @_; $TK->{img}{id} = 0 unless exists $TK->{img}{id}; my ($w, $h) = (400, 300); $TK->{gui}{top} = $TK->{gui}{frame}->Toplevel(); $TK->{gui}{top}->geometry("${w}x$h+500+550"); $TK->{gui}{top}->overrideredirect(1); push @{$TK->{gui}{quits}}, $TK->{gui}{top}->Button(-text => 'Quit' )->pack(-side => 'bottom'); $TK->{gui}{can} = $TK->{gui}{top}->Canvas( )->pack(-anchor => 'center', -fill => 'both', -expand => 1); my $name = 'earth' . $TK->{img}{id}++; $TK->{img}{$name} = $TK->{gui}{top}->Photo( $name, -file => Tk->findINC('demos/images/earth.gif') ); $TK->{gui}{can}->createImage( $w/2, $h/2, -image => $name, -anchor => 'center' ); $TK->{gui}{quits}[-1]->configure(-command => sub { (delete $TK->{img}{$name})->delete(); $TK->{gui}{can}->delete('all'); $TK->{gui}{top}->destroy(); }); return; }

You should be able to run that without needing to change anything (except maybe the shebang line). The code itself will run on v5.8 (probably even older versions). The image, earth.gif, comes with Tk (it's used in the Widget Demo) so you should already have that.

— Ken

Replies are listed 'Best First'.
Re^2: Losing my memory
by nzsvz9 (Sexton) on Feb 05, 2021 at 20:32 UTC
    Thanks Ken. I've run your test code - thanks, and I'm trying to figure out the differences to apply to my own. When I monitor memory usage with task manager - it does not blow up like my own code, so I reviewing.

    The reason I didn't include my whole code is because I have a large series of subroutines which I use that are pulled in with requires, so the main code won't run without them. Plus at the bottom of the code I put the test routine - so I can recode, save, then run to test. This works for me but YMMV.

    And the $PB stuff at the beginning let's me pull this code into another program, then when I run the main program -v I get a list of all included subroutines at versions.

    In the code, the popout section makes a new popup window if a canvas isn't specified in the incoming name/value pairs (%NVP).

    I'm also suspecting that the resizable code is partially to blame. The memory blows up at this function. I tied a redraw to the configure event - and when I drag the corner the resized image works, but the constant redrawing chews up memory.

    # PB:----------------------------------------------------------------- +------- # $PB{'tk_canvasImage.pl'}{'Author'} ="Thomas M.P. Catsburg"; $PB{'tk_canvasImage.pl'}{'Class'} ="subroutine"; $PB{'tk_canvasImage.pl'}{'Date'} ="19Jun2018"; $PB{'tk_canvasImage.pl'}{'Description'}="Given a configuration - add a +n image to a given canvas or use a popup canvas - resize if needed to + fit given or actual size"; $PB{'tk_canvasImage.pl'}{'Filename'} ="tk_canvasImage.pl"; $PB{'tk_canvasImage.pl'}{'Version'} ="1.0"; # # 1.0 17Jun2019 Initial writing # sub tk_canvasImage { # Get the incoming parameters my %NVP=&nvp(@_); #------------------------------------------------------------------- +-------- ### ##### # # # # # # # # # # # # ### ##### # If not given a key if(! defined $NVP{'Id'}) { # Generate a key $NVP{'Id'}=&newkey({'Join'=>''}); } #------------------------------------------------------------------- +-------- #### ## # # # # ## #### # # # # ## # # # # # # # # # # # # # # # # #### # ###### # # # # # ###### # # # # # # ## # # # # # # #### # # # # ## # # #### # Set a default canvas width my $cw=200; # Set a default canvas height my $ch=200; # Need to look for config{'canvas'} and make that the tk{'canvas'} o +therwise do the popup thing if(Tk::Exists($NVP{'Canvas'})) { # Make the current canvas the given canvas $TK{'canvas-'.$NVP{'Id'}}=$NVP{'Canvas'}; # Update the main window so the canvas sizes $TK{'mw'}->update(); # Get the canvas width $cw=$TK{'canvas-'.$NVP{'Id'}}->width(); # Get the canvas height $ch=$TK{'canvas-'.$NVP{'Id'}}->height(); } else { # Create the popupwindow $TK{'pw-'.$NVP{'Id'}}=$TK{'mw'}->Toplevel('-title' => $NVP{'Title' +}); # Create a geometry string for the popup my $geometry=$NVP{'Width'} . 'x' . $NVP{'Height'}; # Size the popupwindow $TK{'pw-'.$NVP{'Id'}}->geometry($geometry); # Set the maximum size for the popup $TK{'pw-'.$NVP{'Id'}}->maxsize($NVP{'Width'}, $NVP{'Height'}) if($ +NVP{'Maxsize'} =~ /yes|true|1|on/i); # Set the minimum size for the popup $TK{'pw-'.$NVP{'Id'}}->minsize($NVP{'Width'}, $NVP{'Height'}) if($ +NVP{'Minsize'} =~ /yes|true|1|on/i); # Add main window icon if icon is defined if($TK{'icon'}) { # Have no idea what this does but the logo does not work without + it $TK{'pw-'.$NVP{'Id'}}->idletasks; # Change the Tk window and idle icon to the supplied image $TK{'pw-'.$NVP{'Id'}}->iconimage($TK{'icon'}); } # Configure the popup window with the new title $TK{'pw-'.$NVP{'Id'}}->configure('-title' => $NVP{'Title'}); # Create the main canvas $TK{'canvas-'.$NVP{'Id'}}=$TK{'pw-'.$NVP{'Id'}}->Canvas(-backgroun +d => $NVP{'Background'}, -bd + => 1, -relief + => 'sunken')->pack(-fill => 'both', + -anchor => 'center', + -expand => 1); # Set the canvas width $cw=$NVP{'Width'}; # Set the canvas height $ch=$NVP{'Height'}; } #------------------------------------------------------------------- +-------- ##### #### ##### #### # # ##### # # # # # # # # # # # # # # # # # # # # # # ##### # # ##### # # # # # # # # # # # # # # # #### # #### #### # # If popout button is true if($NVP{'Popout'} =~ /yes|true|^1$|on/i) { # If bitmappopoutnw does not exist if($TK{'bitmappopoutnw'} eq '') { # Create an xbm bitmap my $xbmbits = pack("b9" x 9, ".........", ".11111111", ".1.......", ".1.1111..", ".1.11....", ".1.1.1...", ".1.1..1..", ".1.....1.", "........."); # Pack xbmbits into a popout arrow bitmap for the button $TK{'mw'}->DefineBitmap('bitmappopoutnw' => 9, 9, $xbmbits); # Set $TK{'bitmappopoutnw'} so we don't recreate the bitmappopou +tnw $TK{'bitmappopoutnw'}='true'; } # Create a popout button $TK{'popbutton-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Button(-bi +tmap => 'bitmappopoutnw', -co +mmand => sub { &tk_canvasImage({'file' => $NVP{'File'}, + 'title' => $NVP{'Title'}, + 'boundary' => $NVP{'Boundary'}, + 'popout' => 'false', + 'width' => $NVP{'Width'}, + 'height' => $NVP{'Height'}, + 'background' => $NVP{'Background'}, + 'boundary' => $NVP{'Boundary'}}); } +)->place(-x => 5, -y => 5, -anchor => 'nw'); } #------------------------------------------------------------------- +-------- ##### ###### #### ### ###### ## ##### # ###### # # # # # # # # # # # # # # ##### #### # # # # ##### # ##### ##### # # # # ###### # # # # # # # # # # # # # # # # # # # ###### #### ### ###### # # ##### ###### ###### # Add redraw capability bound to canvas resize event if($NVP{'Resizable'} !~ /no|false|^0$|off/i) { # Bind Canvas resizing to clear and redraw the donut graph $TK{'canvas-'.$NVP{'Id'}}->Tk::bind('<Configure>' => sub { # Clear + the graph $TK{'ca +nvas-'.$NVP{'Id'}}->delete('all'); # Redra +w the graph &tk_can +vasImage({'file' => $NVP{'File'}, + 'title' => $NVP{'Title'}, + 'boundary' => $NVP{'Boundary'}, + 'popout' => $NVP{'Popout'}, + 'background' => $NVP{'Background'}, + 'boundary' => $NVP{'Boundary'}, + 'canvas' => $TK{'canvas-'.$NVP{'Id'}}, + 'id' => $NVP{'Id'}}); }); } #------------------------------------------------------------------- +-------- ##### ###### ###### ## # # # ##### #### # # # # # # # # # # # # # ##### ##### # # # # # # #### # # # # ###### # # # # # # # # # # # # # # # # # ##### ###### # # # #### ###### # #### # Set the Tk title as the parameter $NVP{'Title'}='tk_canvasImage() View Image' if($NVP{'Title'} eq ''); # Default background is white $NVP{'Background'}='white' if($NVP{'Background'} eq ''); # Boundary $NVP{'Boundary'}=0 if($NVP{'Boundary'} eq ''); # Default window to minimum of 200 pixels wide or tall $NVP{'Width'}=200 if($NVP{'Width'} < 200); $NVP{'Height'}=200 if($NVP{'Height'} < 200); #------------------------------------------------------------------- +-------- #### ###### ##### # # ##### # # # # # # # #### ##### # # # # # # # # # # ##### # # # # # # # #### ###### # #### # # Get the image extension my $extension=lc(&justext($NVP{'File'})); # Make a unique image name - so each picture is unique my $imagename=&newkey({'Join'=>''}); # Set the canvas width minus 2x boundary $cw=$cw-2*$NVP{'Boundary'}; # Set the canvas height minus 2x boundary $ch=$ch-2*$NVP{'Boundary'}; # Set background color $TK{'canvas-'.$NVP{'Id'}}->configure(-background => $NVP{'Background +'}); # If the image can be read and is a gif or jpg if((-r $NVP{'File'}) && ($extension =~ /gif|jpg/i)) { # Get file information %file=&getFileInfo($NVP{'File'}); # Alter extension for jpg - a Tk thing $extension='jpeg' if($extension =~ /jpg/); # Create an image object for the ploc $TK{'image-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo($imagena +me, -file +=> $NVP{'File'}, -format +=> $extension); # Get original Photo width dimension my $picx=$TK{'image-'.$NVP{'Id'}}->width(); # Get original Photo height dimension my $picy=$TK{'image-'.$NVP{'Id'}}->height(); # Add size to file info $file{'width'}=$picx; $file{'height'}=$picy; # Create an x factor my $xfactor=1; # Create a y factor my $yfactor=1; # If the image width is greater than the canvas width - calculate +a scaling if($picx > $cw) { # Make the scale factor based on the canvas width relative to th +e image width $xfactor=$picx/($cw+.001); } # If the image height is greater than the canvas height - calculat +e a scaling if($picy > $ch) { # Make the scale factor based on the canvas width relative to th +e image width $yfactor=$picy/$ch; } # Set scaling to x factor my $factor=int($xfactor+0.5); # Set scaling to greatest of x or y if($yfactor > $xfactor) { $factor=int($yfactor+0.5); } # Add scale to file info $file{'scale'}=$factor; #----------------------------------------------------------------- +-------- # # Resize or not # # If picy < canvas height and picx < canvas width then display the + unscaled image if(($picy < $ch) && ($picx < $cw)) { # Display the image $TK{'canvasimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->create +Image(int($cw/2)+$NVP{'Boundary'}, int($ch/2)+$NVP{'Boundary'}, + -image => $TK{'image-'.$NVP{'Id'}}, + -anchor => 'c'); } else { # Create a second Photo - scaled from information from the origi +nal image $TK{'resizedimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo +('resized' . $imagename); # Rescale the Photo $TK{'resizedimage-'.$NVP{'Id'}}->copy($TK{'image-'.$NVP{'Id'}}, +-shrink, -subsample => $factor, $factor ); # Display the image $TK{'canvasimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->create +Image(int($cw/2)+$NVP{'Boundary'}, int($ch/2)+$NVP{'Boundary'}, + -image => $TK{'resizedimage-'.$NVP{'Id'}}, + -anchor => 'c'); # Get the resized image width $picx=$TK{'resizedimage-'.$NVP{'Id'}}->width(); # Get the resized image height $picy=$TK{'resizedimage-'.$NVP{'Id'}}->height(); # If a popup then resize the popup! if(! $NVP{'Canvas'}) { my $geometry=int($picx+2*$NVP{'Boundary'}) .'x' . int($picy+2* +$NVP{'Boundary'}); $TK{'pw-'.$NVP{'Id'}}->geometry($geometry); } } } # Error could not read file else { # Set the error $file{'Error'}="ERROR: Could not read file=$NVP{'file'}"; } # Return the parameter set - which includes the canvas - or just the + id # return wantarray ? $NVP{'Id'} : $TK{'canvas-'.$NVP{'Id'}}; return $NVP{'Id'}; } # End # Announce print "execute file=" . __FILE__ . "\n"; ## Require the test setup require "C:/pb/lib/require_test_setup.pl"; # Return if called to not test code return 1 if($0 ne __FILE__); ## Require included subroutines ... instead of pasting them in here require "arraytext.pl"; require "data.pl"; require "getFileInfo.pl"; require "greaterof.pl"; require "hash2table.pl"; require "hashtext.pl"; require "justext.pl"; require "longest.pl"; require "newkey.pl"; require "nvp.pl"; require "loadColors.pl"; require "readFile.pl"; require "someday.pl"; require "tabletext.pl"; ## Require the tk setup require "C:/pb/lib/require_tk_setup.pl"; ## Required tk subroutines require "tk_chooseFile.pl"; require "tk_destroyImages.pl"; require "tk_helpAbout.pl"; require "tk_helpDump.pl"; require "tk_popupClose.pl"; require "tk_viewHash.pl"; # Divider print '- ' x 40 , "\n\n"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +- - - - # # Test cases # print "\n$0 Tests begin:\n\n"; # Announce &tk_console($TK{'console'}, "$0\n"); #--------------------------------------------------------------------- +-------- # # Test specific Tk code # # Create a geometry string for the main window my $geometry='400x800+800+100'; # Size the popupwindow $TK{'mw'}->geometry($geometry); # Add an view table button $TK{'dib'}=$TK{'mw'}->Button(-text => 'Destroy Images', -command => \&tk_destroyImages)->pack(); # Add a dump $TK{'dump'}=$TK{'mw'}->Button(-text => 'Dump TK', -command => \&tk_helpDump)->pack(); # Add a canvas into the main window for embedded $TK{'canvas'}=$TK{'mw'}->Canvas('-background' => 'white', '-bd' => 1, '-relief' => 'sunken')->pack('-fil +l' => 'both', '-anc +hor' => 'center', '-exp +and' => 1); #--------------------------------------------------------------------- +-------- # # Test #1 - Configuration #1 in a popup window # # Add a canvas image button to the test window my $canvasbutton1 = $TK{'mw'}->Button(-text => 'Popup canvas image +- config 1', -command => sub { &tk_canvasImag +e({'background' => 'white', + # Link to the image file + 'file' => "C:\\pb\\test\\images\\2018.06.15_EC_and_MP.jpg", + # Set the title and poup window height and width - this limits the + image display size + 'Title' => 'Our Future President', + 'Width' => 500, + 'Height' => 300, + # Set popout false - since it's already a popout + 'Popout' => 'false', + # Set a background color + 'background' => $COLOR{'purple'}, + # Set a boundary around the image + 'boundary' => 25, + # Set the boundary in pixels around the image in the canvas + 'boundary' => 5}); })->pack(); #--------------------------------------------------------------------- +-------- # # Test #2 - Configuration #2 in the embedded window # # Add a canvas image button to the test window my $canvasbutton2 = $TK{'mw'}->Button(-text => 'Embeded canvas imag +e - config 2', -command => sub { &tk_canvasImag +e({'canvas' => $TK{'canvas'}, + # Link to the image file + 'file' => "C:\\pb\\test\\images\\2018.06.15_EC_and_MP.jpg", + # Set popout true + 'Popout' => 'true', + # Set the title and poup window height and width - this limits the + image display size + 'background' => $COLOR{'lightgray'}, + # Set the boundary in pixels around the image in the canvas + 'boundary' => 20}); })->pack(); # Add a close button to the test window my $clearbutton = $TK{'mw'}->Button(-text => 'Clear Embedded Canvas', +-command => sub{ $TK{'canvas'}->delete('all'); })->pack(); ######################################################### #--------------------------------------------------------------------- +-------- # Start the GUI infinite loop. MainLoop(); #--------------------------------------------------------------------- +-------- ######################################################### # Announce print "\n$0 done.\n"; # End <p> In any case, here's the full code of tk_canvasImage() just for fun ... <code> # PB:----------------------------------------------------------------- +------- # $PB{'tk_canvasImage.pl'}{'Author'} ="Thomas M.P. Catsburg"; $PB{'tk_canvasImage.pl'}{'Class'} ="subroutine"; $PB{'tk_canvasImage.pl'}{'Date'} ="19Jun2018"; $PB{'tk_canvasImage.pl'}{'Description'}="Given a configuration - add a +n image to a given canvas or use a popup canvas - resize if needed to + fit given or actual size"; $PB{'tk_canvasImage.pl'}{'Filename'} ="tk_canvasImage.pl"; $PB{'tk_canvasImage.pl'}{'Version'} ="1.0"; # # 1.0 17Jun2019 Initial writing # sub tk_canvasImage { # Get the incoming parameters my %NVP=&nvp(@_); #------------------------------------------------------------------- +-------- ### ##### # # # # # # # # # # # # ### ##### # If not given a key if(! defined $NVP{'Id'}) { # Generate a key $NVP{'Id'}=&newkey({'Join'=>''}); } #------------------------------------------------------------------- +-------- #### ## # # # # ## #### # # # # ## # # # # # # # # # # # # # # # # #### # ###### # # # # # ###### # # # # # # ## # # # # # # #### # # # # ## # # #### # Set a default canvas width my $cw=200; # Set a default canvas height my $ch=200; # Need to look for config{'canvas'} and make that the tk{'canvas'} o +therwise do the popup thing if(Tk::Exists($NVP{'Canvas'})) { # Make the current canvas the given canvas $TK{'canvas-'.$NVP{'Id'}}=$NVP{'Canvas'}; # Update the main window so the canvas sizes $TK{'mw'}->update(); # Get the canvas width $cw=$TK{'canvas-'.$NVP{'Id'}}->width(); # Get the canvas height $ch=$TK{'canvas-'.$NVP{'Id'}}->height(); } else { # Create the popupwindow $TK{'pw-'.$NVP{'Id'}}=$TK{'mw'}->Toplevel('-title' => $NVP{'Title' +}); # Create a geometry string for the popup my $geometry=$NVP{'Width'} . 'x' . $NVP{'Height'}; # Size the popupwindow $TK{'pw-'.$NVP{'Id'}}->geometry($geometry); # Set the maximum size for the popup $TK{'pw-'.$NVP{'Id'}}->maxsize($NVP{'Width'}, $NVP{'Height'}) if($ +NVP{'Maxsize'} =~ /yes|true|1|on/i); # Set the minimum size for the popup $TK{'pw-'.$NVP{'Id'}}->minsize($NVP{'Width'}, $NVP{'Height'}) if($ +NVP{'Minsize'} =~ /yes|true|1|on/i); # Add main window icon if icon is defined if($TK{'icon'}) { # Have no idea what this does but the logo does not work without + it $TK{'pw-'.$NVP{'Id'}}->idletasks; # Change the Tk window and idle icon to the supplied image $TK{'pw-'.$NVP{'Id'}}->iconimage($TK{'icon'}); } # Configure the popup window with the new title $TK{'pw-'.$NVP{'Id'}}->configure('-title' => $NVP{'Title'}); # Create the main canvas $TK{'canvas-'.$NVP{'Id'}}=$TK{'pw-'.$NVP{'Id'}}->Canvas(-backgroun +d => $NVP{'Background'}, -bd + => 1, -relief + => 'sunken')->pack(-fill => 'both', + -anchor => 'center', + -expand => 1); # Set the canvas width $cw=$NVP{'Width'}; # Set the canvas height $ch=$NVP{'Height'}; } #------------------------------------------------------------------- +-------- ##### #### ##### #### # # ##### # # # # # # # # # # # # # # # # # # # # # # ##### # # ##### # # # # # # # # # # # # # # # #### # #### #### # # If popout button is true if($NVP{'Popout'} =~ /yes|true|^1$|on/i) { # If bitmappopoutnw does not exist if($TK{'bitmappopoutnw'} eq '') { # Create an xbm bitmap my $xbmbits = pack("b9" x 9, ".........", ".11111111", ".1.......", ".1.1111..", ".1.11....", ".1.1.1...", ".1.1..1..", ".1.....1.", "........."); # Pack xbmbits into a popout arrow bitmap for the button $TK{'mw'}->DefineBitmap('bitmappopoutnw' => 9, 9, $xbmbits); # Set $TK{'bitmappopoutnw'} so we don't recreate the bitmappopou +tnw $TK{'bitmappopoutnw'}='true'; } # Create a popout button $TK{'popbutton-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Button(-bi +tmap => 'bitmappopoutnw', -co +mmand => sub { &tk_canvasImage({'file' => $NVP{'File'}, + 'title' => $NVP{'Title'}, + 'boundary' => $NVP{'Boundary'}, + 'popout' => 'false', + 'width' => $NVP{'Width'}, + 'height' => $NVP{'Height'}, + 'background' => $NVP{'Background'}, + 'boundary' => $NVP{'Boundary'}}); } +)->place(-x => 5, -y => 5, -anchor => 'nw'); } #------------------------------------------------------------------- +-------- ##### ###### #### ### ###### ## ##### # ###### # # # # # # # # # # # # # # ##### #### # # # # ##### # ##### ##### # # # # ###### # # # # # # # # # # # # # # # # # # # ###### #### ### ###### # # ##### ###### ###### # Add redraw capability bound to canvas resize event if($NVP{'Resizable'} !~ /no|false|^0$|off/i) { # Bind Canvas resizing to clear and redraw the donut graph $TK{'canvas-'.$NVP{'Id'}}->Tk::bind('<Configure>' => sub { # Clear + the graph $TK{'ca +nvas-'.$NVP{'Id'}}->delete('all'); # Redra +w the graph &tk_can +vasImage({'file' => $NVP{'File'}, + 'title' => $NVP{'Title'}, + 'boundary' => $NVP{'Boundary'}, + 'popout' => $NVP{'Popout'}, + 'background' => $NVP{'Background'}, + 'boundary' => $NVP{'Boundary'}, + 'canvas' => $TK{'canvas-'.$NVP{'Id'}}, + 'id' => $NVP{'Id'}}); }); } #------------------------------------------------------------------- +-------- ##### ###### ###### ## # # # ##### #### # # # # # # # # # # # # # ##### ##### # # # # # # #### # # # # ###### # # # # # # # # # # # # # # # # # ##### ###### # # # #### ###### # #### # Set the Tk title as the parameter $NVP{'Title'}='tk_canvasImage() View Image' if($NVP{'Title'} eq ''); # Default background is white $NVP{'Background'}='white' if($NVP{'Background'} eq ''); # Boundary $NVP{'Boundary'}=0 if($NVP{'Boundary'} eq ''); # Default window to minimum of 200 pixels wide or tall $NVP{'Width'}=200 if($NVP{'Width'} < 200); $NVP{'Height'}=200 if($NVP{'Height'} < 200); #------------------------------------------------------------------- +-------- #### ###### ##### # # ##### # # # # # # # #### ##### # # # # # # # # # # ##### # # # # # # # #### ###### # #### # # Get the image extension my $extension=lc(&justext($NVP{'File'})); # Make a unique image name - so each picture is unique my $imagename=&newkey({'Join'=>''}); # Set the canvas width minus 2x boundary $cw=$cw-2*$NVP{'Boundary'}; # Set the canvas height minus 2x boundary $ch=$ch-2*$NVP{'Boundary'}; # Set background color $TK{'canvas-'.$NVP{'Id'}}->configure(-background => $NVP{'Background +'}); # If the image can be read and is a gif or jpg if((-r $NVP{'File'}) && ($extension =~ /gif|jpg/i)) { # Get file information %file=&getFileInfo($NVP{'File'}); # Alter extension for jpg - a Tk thing $extension='jpeg' if($extension =~ /jpg/); # Create an image object for the ploc $TK{'image-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo($imagena +me, -file +=> $NVP{'File'}, -format +=> $extension); # Get original Photo width dimension my $picx=$TK{'image-'.$NVP{'Id'}}->width(); # Get original Photo height dimension my $picy=$TK{'image-'.$NVP{'Id'}}->height(); # Add size to file info $file{'width'}=$picx; $file{'height'}=$picy; # Create an x factor my $xfactor=1; # Create a y factor my $yfactor=1; # If the image width is greater than the canvas width - calculate +a scaling if($picx > $cw) { # Make the scale factor based on the canvas width relative to th +e image width $xfactor=$picx/($cw+.001); } # If the image height is greater than the canvas height - calculat +e a scaling if($picy > $ch) { # Make the scale factor based on the canvas width relative to th +e image width $yfactor=$picy/$ch; } # Set scaling to x factor my $factor=int($xfactor+0.5); # Set scaling to greatest of x or y if($yfactor > $xfactor) { $factor=int($yfactor+0.5); } # Add scale to file info $file{'scale'}=$factor; #----------------------------------------------------------------- +-------- # # Resize or not # # If picy < canvas height and picx < canvas width then display the + unscaled image if(($picy < $ch) && ($picx < $cw)) { # Display the image $TK{'canvasimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->create +Image(int($cw/2)+$NVP{'Boundary'}, int($ch/2)+$NVP{'Boundary'}, + -image => $TK{'image-'.$NVP{'Id'}}, + -anchor => 'c'); } else { # Create a second Photo - scaled from information from the origi +nal image $TK{'resizedimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo +('resized' . $imagename); # Rescale the Photo $TK{'resizedimage-'.$NVP{'Id'}}->copy($TK{'image-'.$NVP{'Id'}}, +-shrink, -subsample => $factor, $factor ); # Display the image $TK{'canvasimage-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->create +Image(int($cw/2)+$NVP{'Boundary'}, int($ch/2)+$NVP{'Boundary'}, + -image => $TK{'resizedimage-'.$NVP{'Id'}}, + -anchor => 'c'); # Get the resized image width $picx=$TK{'resizedimage-'.$NVP{'Id'}}->width(); # Get the resized image height $picy=$TK{'resizedimage-'.$NVP{'Id'}}->height(); # If a popup then resize the popup! if(! $NVP{'Canvas'}) { my $geometry=int($picx+2*$NVP{'Boundary'}) .'x' . int($picy+2* +$NVP{'Boundary'}); $TK{'pw-'.$NVP{'Id'}}->geometry($geometry); } } } # Error could not read file else { # Set the error $file{'Error'}="ERROR: Could not read file=$NVP{'file'}"; } # Return the parameter set - which includes the canvas - or just the + id # return wantarray ? $NVP{'Id'} : $TK{'canvas-'.$NVP{'Id'}}; return $NVP{'Id'}; } # End # Announce print "execute file=" . __FILE__ . "\n"; ## Require the test setup require "C:/pb/lib/require_test_setup.pl"; # Return if called to not test code return 1 if($0 ne __FILE__); ## Require included subroutines ... instead of pasting them in here require "arraytext.pl"; require "data.pl"; require "getFileInfo.pl"; require "greaterof.pl"; require "hash2table.pl"; require "hashtext.pl"; require "justext.pl"; require "longest.pl"; require "newkey.pl"; require "nvp.pl"; require "loadColors.pl"; require "readFile.pl"; require "someday.pl"; require "tabletext.pl"; ## Require the tk setup require "C:/pb/lib/require_tk_setup.pl"; ## Required tk subroutines require "tk_chooseFile.pl"; require "tk_destroyImages.pl"; require "tk_helpAbout.pl"; require "tk_helpDump.pl"; require "tk_popupClose.pl"; require "tk_viewHash.pl"; # Divider print '- ' x 40 , "\n\n"; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +- - - - # # Test cases # print "\n$0 Tests begin:\n\n"; # Announce &tk_console($TK{'console'}, "$0\n"); #--------------------------------------------------------------------- +-------- # # Test specific Tk code # # Create a geometry string for the main window my $geometry='400x800+800+100'; # Size the popupwindow $TK{'mw'}->geometry($geometry); # Add an view table button $TK{'dib'}=$TK{'mw'}->Button(-text => 'Destroy Images', -command => \&tk_destroyImages)->pack(); # Add a dump $TK{'dump'}=$TK{'mw'}->Button(-text => 'Dump TK', -command => \&tk_helpDump)->pack(); # Add a canvas into the main window for embedded $TK{'canvas'}=$TK{'mw'}->Canvas('-background' => 'white', '-bd' => 1, '-relief' => 'sunken')->pack('-fil +l' => 'both', '-anc +hor' => 'center', '-exp +and' => 1); #--------------------------------------------------------------------- +-------- # # Test #1 - Configuration #1 in a popup window # # Add a canvas image button to the test window my $canvasbutton1 = $TK{'mw'}->Button(-text => 'Popup canvas image +- config 1', -command => sub { &tk_canvasImag +e({'background' => 'white', + # Link to the image file + 'file' => "C:\\pb\\test\\images\\2018.06.15_EC_and_MP.jpg", + # Set the title and poup window height and width - this limits the + image display size + 'Title' => 'Our Future President', + 'Width' => 500, + 'Height' => 300, + # Set popout false - since it's already a popout + 'Popout' => 'false', + # Set a background color + 'background' => $COLOR{'purple'}, + # Set a boundary around the image + 'boundary' => 25, + # Set the boundary in pixels around the image in the canvas + 'boundary' => 5}); })->pack(); #--------------------------------------------------------------------- +-------- # # Test #2 - Configuration #2 in the embedded window # # Add a canvas image button to the test window my $canvasbutton2 = $TK{'mw'}->Button(-text => 'Embeded canvas imag +e - config 2', -command => sub { &tk_canvasImag +e({'canvas' => $TK{'canvas'}, + # Link to the image file + 'file' => "C:\\pb\\test\\images\\2018.06.15_EC_and_MP.jpg", + # Set popout true + 'Popout' => 'true', + # Set the title and poup window height and width - this limits the + image display size + 'background' => $COLOR{'lightgray'}, + # Set the boundary in pixels around the image in the canvas + 'boundary' => 20}); })->pack(); # Add a close button to the test window my $clearbutton = $TK{'mw'}->Button(-text => 'Clear Embedded Canvas', +-command => sub{ $TK{'canvas'}->delete('all'); })->pack(); ######################################################### #--------------------------------------------------------------------- +-------- # Start the GUI infinite loop. MainLoop(); #--------------------------------------------------------------------- +-------- ######################################################### # Announce print "\n$0 done.\n"; # End

      There's an awful lot of problems with that post which you should fix up.

      • You should not be posting huge swathes of code like that.
      • You've actually posted the same code twice.
      • You didn't close the first <code> tag, so you're comment about "just for fun" is lost amongst all the code.
      • You should use <spoiler> or <readmore> tags for any large tracts of code or data. See "Writeup Formatting Tips".
      • The code you post should reproduce your problem. It should also be presented in a way that we can also run it to try to help you. Absolute pathnames on your machine (e.g. C:\\pb\\test\\images\\2018.06.15_EC_and_MP.jpg) are of no use to us. See SSCCE.
      • You should remove all of the ASCII-art banners. If you think the information they convey is essential, replace with a one-line comment.
      • Please read "How do I post a question effectively?".
      • Finally, read "How do I change/delete my post?" and then make appropriate modifications.

      — Ken

        Ken and all who posted,

        I wanted to post what eventually worked - a combination of several items put forward.

        Creating the initial Photo image with no reference, then immediately loading the image from the file.

        # Start with a blank image - somehow this causes memory cleanup $TK{'image-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo(-file => + "" ); # Create an image object for the image file of the correct format $TK{'image-'.$NVP{'Id'}}=$TK{'canvas-'.$NVP{'Id'}}->Photo($NVP{'Id +'}, -file +=> $NVP{'File'}, -format +=> $image{'extension'});
        Adding a trap for catching the closure of the popup window ...
        # Create a "catch" for closing the window $TK{'pw-'.$NVP{'Id'}}->protocol('WM_DELETE_WINDOW' => [\&CleanUpOn +Exit, $NVP{'Id'}]);
        And a subroutine to delete the images on the canvas as well as the images on exit ... using the magic delete -> delete(); thing
        sub CleanUpOnExit { # Get the id my $ID=shift(@_); # Delete images on the canvas $TK{'canvas-' . $ID}->delete("all"); # Delete the original image (delete $TK{'image-' . $ID})->delete(); # Destroy the popup window $TK{'pw-' . $ID}->destroy(); # Exit the Tk window Tk::exit; }
        It no longer chews up memory and even returns memory when the images are closed.

        So I wanted to say thanks.

        nzsvz9 - formerly known as the mad memory monger of my own creation

        Thanks for the tips. This is what happens when you post after your daily sleep deprivation time ...

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11127923]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2023-02-07 17:19 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer not to run the latest version of Perl because:







    Results (40 votes). Check out past polls.

    Notices?