draw a crab in Perl/Tk with mega-widget

crab.pl

# Draw a crab in Perl/Tk.  Public domain, see
# https://creativecommons.org/publicdomain/zero/1.0/

use strict;
use warnings;

# ColorChoice is a composite widget (a kind of mega-widget) with
# buttons to choose red, green, or blue.  It always starts on red.
# When the user changes the color, this widget calls its -command.
package ColorChoice;
use Tk;
our @ISA = 'Tk::Frame';

# Make a method $parent->ColorChoice(@options) to construct a
# ColorChoice in its parent widget.
Tk::Widget->Construct('ColorChoice');

# Defines the child widgets.
sub Populate {
  my ($self, $args) = @_;
  $self->SUPER::Populate($args);

  # Define each of the buttons.
  my $first_button;
  for my $color (qw(red green blue)) {
    my $b = $self->Button(-text => $color);
    # The button's command is $self->_change_color($color, $b).
    $b->configure(-command => [$self, '_change_color', $color, $b]);
    unless ($first_button) {
      $first_button = $b;
      _sink_color_button($self->privateData, $color, $b);
    }
    # Pack the buttons from left to right.
    $b->pack(-side => 'left');
  }

  # Define -command as a callback.
  $self->ConfigSpecs(-command => ['CALLBACK']);
}

# Gets the selected color.
sub color {
  my ($self) = @_;
  return $self->privateData->{color};
}

# Responds to a color button.
sub _change_color {
  my ($self, $color, $button) = @_;
  my $private = $self->privateData;

  # Raise and enable the old button; sink the new one.
  $private->{button}->configure(-relief => 'raised', -state => 'normal');
  _sink_color_button($private, $color, $button);

  # Run our -command; $self->color is the new color.
  return $self->Callback(-command => $self);
}

# Sets the selected color, and sinks and disables its button.
sub _sink_color_button {
  my ($private, $color, $button) = @_;
  $private->{color} = $color;
  $private->{button} = $button;
  $button->configure(-relief => 'sunken', -state => 'disabled');
}

package main;
use Tk;

# Appends 'm' for millimeters to some numbers.
sub mm {
  return map({ $_ . 'm' } @_);
}

# Make a crab canvas on the right side of the main window.
my $mw = MainWindow->new;
my $canvas = $mw->Canvas(-height => '40m', -width => '40m');
$canvas->pack(-expand => 1, -fill => 'both', -side => 'right');

# The crab must be red, because ColorChoice starts on red.
my @red = (-fill => 'red', -outline => undef);

# Draw some crab claws near these points.
for ([10, 10], [30, 10]) {
  my ($x, $y) = @$_;
  # This rectangle will go under the shell.
  $canvas->createRectangle(mm($x - 1, $y + 1, $x + 1, $y + 10),
			   @red, -tags => ['claw']);
  # This filled arc looks like a claw.
  $canvas->createArc(mm($x - 5, $y - 5, $x + 5, $y + 5),
		     -start => 125, -extent => 290,
		     @red, -tags => ['claw']);
}

# Draw a crab shell.
$canvas->createOval(mm(3, 17, 37, 35), @red, -tags => ['shell']);

# Make widgets to change the crab's claw color and shell color.
$mw->Label(-text => 'Claws')->pack;
$mw->ColorChoice(-command => sub {
		   my ($w) = @_;
		   $canvas->itemconfigure('claw', -fill => $w->color);
		 })->pack;
$mw->Label(-text => 'Shell')->pack;
$mw->ColorChoice(-command => sub {
		   my ($w) = @_;
		   $canvas->itemconfigure('shell', -fill => $w->color);
		 })->pack;

MainLoop;