The -validatecommand option seems to work fine, up to a point.  As soon as the first option "Choose shape" is selected, the shape no longer appears, leading me to believe that the validation is no longer being performed.

Strangely, the behavior gets worse when the $mw->update line is uncommented out (in the section marked "Anomaly #1").  In that case, only the first shape chosen takes effect; any others do not display.  I'm supposing that this behavior is due to trying to perform an update during a validation, which I could understand might be problematic.

Even stranger, though, is what happens when the debug line printf "TFD> ppoints => %s\n", Dumper($ppoints); is uncommented out (in the section marked "Anomaly #2").  In that case, the program works as expected, and new shapes can again be chosen after selecting the "Choose shape" option!

Can anyone shed light on what's going on here?  Can someone suggest a way to fix this, or a better way to do it?  Thanks in advance for any insights!

#!/usr/bin/perl

# Strict;
use strict;
use warnings;


# User-defined
my $pshapes = [
    [ 'Choose shape' => "" ],
    [ 'triangle'     => "80,100,60:360,-120x2" ],
    [ 'square'       => "100,100,90:320,-90x3" ],
    [ 'pentagon'     => "100,290,36:200,-72x4" ],
    [ 'hexagon'      => "80,250,60:180,-60x5"  ],
];


# Libraries
use File::Basename;
use Data::Dumper;
use Tk;


# Globals
my $shape = "";        # Algorithm for drawing shape
my $ppoints = [ ];     # Point data ( [x0, y0, x1, y1, id] )
my $mw = "";           # Main Window object
my $cv = "";           # Canvas object
my $cvfr = "";         # Canvas frame


####################
### Main program ###
####################
create_gui();


###################
### Subroutines ###
###################
sub create_gui {
    my $ver = $Tk::VERSION;
    $mw = new MainWindow(-title => "Shape chooser (Tk version $ver)");
    my $f1 = $mw->Frame()->pack(-expand => '0', -fill => 'x');
    $cvfr = $mw->Frame()->pack(-expand => '1', -fill => 'both');
    my $b1 = $f1->Button(-text => 'Exit (Esc)', -bg => 'skyblue');
    $b1->configure(-command => sub { $mw->destroy() });
    $b1->pack(-side => 'right');
    $mw->bind("<Escape>" => sub { $b1->invoke() });
    my $om = $f1->Optionmenu(-options => $pshapes, -variable => \$shap
+e);
    $om->pack(-side => 'left');
    my $fr = $f1->Frame()->pack(-side => 'left');
    $fr->Label(-text => ' Shape: ')->pack(-side => 'left');
    my @vopts = (-validate => 'focusout', -validatecommand => \&new_sh
+ape);
    my $en = $fr->Entry(-width => 50, -textvar => \$shape, @vopts);
    $en->pack(-side => 'left');
    $cv = $cvfr->Canvas(-bg => 'black', -height => 512, -width => 512)
+;
    $cv->pack();
    MainLoop;
}


sub new_shape {
    print "\nChanging shape...\n";

    # Clear canvas
    foreach my $ppoint (@$ppoints) {
        my $id = $ppoint->[-1];
        $cv->delete($id);
    }

    $ppoints = draw_shape($shape);

    # Anomoly #1
    #
    # Uncommenting the following line allows only ONE shape to be draw
+n!??
    #
    # $mw->update;

    # Anomoly #2
    #
    # Uncommenting the following line makes everything suddenly work!?
+?
    #
    # printf "TFD> ppoints => %s\n", Dumper($ppoints);
}


sub draw_shape {
    my ($shapestr) = @_;

    my $pnewpoints = [ ];
    my @shapeargs = split(',', $shapestr);
    printf "Shape args [%s]\n", Dumper([@shapeargs]);

    my $pargs = [ -fill => 'pink', -width => 2 ];

    if (@shapeargs > 1) {
        my $x = my $x0 = shift @shapeargs;
        my $y = my $y0 = 512 - shift @shapeargs;
        my ($r, $q);

        for (@shapeargs) {
            if ($_ eq '+') {
                my @pts = ($x, $y, $x0, $y0);
                my $ppoint = [ @pts, $cv->createLine(@pts, @$pargs) ];
                push @$pnewpoints, $ppoint;
                last;
            }

            my ($ang, $sep, $N) = /(-?\d+)([:x]?)(-?\d+)?/;
            ($sep eq ':') and ($N,$r) = (1,$N);
            $N ||= 1;
            while ($N--) {
                $q += $ang;

                my $newq = (180 + $q) / 57.2957;
                my ($dx, $dy) = ($r * cos($newq), $r * sin($newq));
                my ($x1, $y1) = ($x - $dx, $y + $dy);
                my @pts = ($x, $y, $x1, $y1);
                my $ppoint = [ @pts, $cv->createLine(@pts, @$pargs) ];
                push @$pnewpoints, $ppoint;
                ($x, $y) = ($x1, $y1);
            }
        }
    }

    $mw->update();
    return $pnewpoints;
}
[download]