Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Re: Losing my memory

by kcott (Archbishop)
on Feb 05, 2021 at 12:19 UTC ( [id://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');

[download]

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;
}

[download]

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

    [download]
[reply]
[d/l]

      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

[reply]
[d/l]
[select]
        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'});

        [download]
        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'}]);

        [download]
        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;
  }

        [download]
        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

[reply]
[d/l]
[select]
        Thanks for the tips. This is what happens when you post after your daily sleep deprivation time ...
[reply]

In Section Seekers of Perl Wisdom

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: note [id://11127923]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others admiring the Monastery: (3)
As of 2024-04-20 05:47 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found