g0n has asked for the wisdom of the Perl Monks concerning the following question:

Esteemed monks,

I'm writing a Tk-perl script, where there are a different number of textfields to complete, and their labels are different, according to the choice of "type". I thought a neat way to do this would be a callback attached to the drop down menu that creates a subframe. Then, if you switch to the other "type", the subroutine checks to see if the other type of frame exists, destroys it if it does, and creates the selected subframe.

Conceptually, I think the approach is OK, but the script dies with

Aborted

[download]

when destroy is called.

The script itself is fairly huge, so I've worked up a minimal test case. Could someone tell me a) what's going wrong, or b) whether it works on their set up, or c) whether there's a better way of doing it?

Code below:


#!/usr/bin/perl

use strict;
use warnings;
use Tk;

main();

######################################################################
+##################
# main
######################################################################
+##################
sub main {
    my %tkobjects;

    # mainwindow
    my $MW;

    #
    # User-defined variables (if any)
    #
    my @TYPES  = qw(one two);
    my %config = ( 'sourcetype' => "one" );

    my %typeframes = (
        'source' => {
            'one' => \&makeSourceoneFrame,
            'two' => \&makeSourcetwoFrame
        }
    );

    ######################
    #
    # Create the MainWindow
    #
    ######################

    $MW = MainWindow->new;

    # Widget Frame1 isa Frame
    $tkobjects{'Frame1'} = $MW->Frame()->grid(
        -row    => 2,
        -column => 0,
        -sticky => 'e',
    );

######################################################################
+###
    # source frame
######################################################################
+###

    # Widget SourceFrame isa Labelframe
    $tkobjects{'SourceFrame'} =
      $tkobjects{Frame1}->Labelframe( -text => 'Source' )->grid(
        -row    => 1,
        -column => 0,
        -sticky => 'ns',
      );

    # Widget SourceTypeLabel isa Label
    $tkobjects{'SourceTypeLabel'} =
      $tkobjects{SourceFrame}->Label( -text => 'Type', )->grid(
        -row    => 1,
        -column => 0,
      );

    # Widget SourceTypeMenu isa Optionmenu
    $tkobjects{'SourceTypeMenu'} = $tkobjects{SourceFrame}->Optionmenu
+(
        -variable => \$config{'sourcetype'},
        -command  =>
          $typeframes{'source'}->{ $config{'sourcetype'} }->( \%tkobje
+cts ),
        -options => \@TYPES
      )->grid(
        -row    => 1,
        -column => 1,
      );

    $typeframes{'source'}->{ $config{'sourcetype'} }->( \%tkobjects );

    ###############
    #
    # MainLoop
    #
    ###############

    MainLoop;

}

######################################################################
+###
# make source one frame
######################################################################
+###
sub makeSourceoneFrame {
    my $tkobjectsref = shift;
    my %tkobjects    = %$tkobjectsref;

    # if switching to one, destroy the twoframe
    if ( $tkobjects{'sourcetwoFrame'} ) {
        $tkobjects{'sourcetwoFrame'}->destroy;
    }

    $tkobjects{'sourceoneFrame'} = $tkobjects{'SourceFrame'}->Frame()-
+>grid(
        -row    => 2,
        -column => 0
    );

    # Widget SourceSelectString isa Label
    $tkobjects{'StringLabel'} =
      $tkobjects{SourceFrame}->Label( -text => "string two", )->grid(
        -row    => 3,
        -column => 0,
      );

}

######################################################################
+###
# make source two frame
######################################################################
+###
sub makeSourcetwoFrame {
    my $tkobjectsref = shift;
    my %tkobjects    = %$tkobjectsref;

    # if switching to two, destroy the one frame
    if ( $tkobjects{'sourceoneFrame'} ) {
        $tkobjects{'sourceoneFrame'}->destroy;
    }

    $tkobjects{'sourcetwoFrame'} = $tkobjects{'SourceFrame'}->Frame()-
+>grid(
        -row    => 2,
        -column => 0
    );

    $tkobjects{'StringLabel'} =
      $tkobjects{SourceFrame}->Label( -text => "string two", )->grid(
        -row    => 3,
        -column => 0,
      );

}

[download]

Tk version is 804.027, perl version is 5.8.7, OS is Linux.

Update: Fed the code through perltidy.

Update: It appears to be the callback syntax that's causing the error - if the if blocks and their contents calling destroy are commented out, the same thing happens.

Update: Found a solution. The syntax -command  =>sub {$typeframes{'source'}->{ $config{'sourcetype'} }->(\%tkobjects) }, works. I'd still be grateful for comments on that syntax though, because it looks quite nasty.

--------------------------------------------------------------

$perlquestion=~s/Can I/How do I/g;

Replies are listed 'Best First'.
Re: Tk destroy method dies with "Aborted"
by Util (Priest) on Sep 17, 2005 at 03:00 UTC

    First, the minor bugs and questionable code; here is a diagram of your control tree:

    # MainWindow  $MW
# Frame         Frame1
# Labelframe      SourceFrame
# Label             SourceTypeLabel
# Optionmenu        SourceTypeMenu
# Frame             sourceoneFrame # Mutually exclusive
# Frame             sourcetwoFrame # Mutually exclusive
# Label             StringLabel

    [download]

    • Shouldn't $tkobjects{'StringLabel'} be a child of (alternately) sourceoneFrame/sourcetwoFrame?
    • The text for $tkobjects{'StringLabel'} is always "string two"; it should be "string one" for the first case.
    • $tkobjects{'StringLabel'} gets overlaid on each menu swap; should it get explicitly destroyed first?

    To fix the abort, I reached the same conclusion that you did; wrap sub{ } around the value side of

      -command  =>
    $typeframes{'source'}->{ $config{'sourcetype'} }->( \%tkobjects ),

    [download]
    Why did the original version fail? Because -command expects a coderef, but your code is an *immediate* call to
    (Let's see: $config{'sourcetype'} is 'one', and $typeframes{'source'}->{'one'} is &makeSourceoneFrame, so ...)
    makeSourceoneFrame(\%tkobjects), which returns a Label object. When Tk tries to call the Label as a coderef, boom!

    By wrapping it all in sub{ }, you create a closure where (for example) $config{'sourcetype'} will supply its hash value as of the time of invocation, instead of at the time of definition. See perlfaq7 and perlref for more on closures.

    When I refactored the code to reflect the closure, I came up with this version; it replaces the code just before MainLoop: 

        # $option_command will be an anon sub,
    # with sole access to %typeframes.
    my $option_command;
    {
      my %typeframes = (
          'source' => {
              'one' => \&makeSourceoneFrame,
              'two' => \&makeSourcetwoFrame,
          }
      );
      $option_command = sub {
        my $option = shift;
        $typeframes{'source'}->{ $option }->( \%tkobjects );
      }
    }

    $tkobjects{'SourceTypeMenu'}
      = $tkobjects{SourceFrame}->Optionmenu(
#        -variable => \$config{'sourcetype'}, # No longer needed!
        -command  => $option_command,
        -options => \@TYPES
      )->grid(
        -row    => 1,
        -column => 1,
      );

    # By naming the anon sub (via variable), we avoid
    # repeating code here.
    $option_command->('one');
    # Actually, we don't have to manually invoke $option_command;
    # it got called with the first (default) option when
    # the OptionMenu was created!

    MainLoop;

    [download]

[reply]
[d/l]
[select]
      Thanks for a very thorough answer. The dereferencing to get at the coderef had got muddled. Your approach of defining the coderef separately is much clearer. I wasn't sure that defining a coderef that calls a coderef was necessary, but set out like that it appears to be.

      As a bonus, you spotted a bug that I was still struggling with - $tkobjects{'stringlabel'} should have been a child of sourceoneframe or sourcetwoframe, so when I came to destroy the frame and replace it the label didn't disappear.

      Thanks also for taking the time to dig through the code.

      --------------------------------------------------------------

      $perlquestion=~s/Can I/How do I/g;

[reply]
[d/l]

Back to Seekers of Perl Wisdom