The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# Tk::ToolBar - a draggable ToolBar widget

#!perl -w

use strict;
use Tk;
use Tk::ToolBar;
#use Tk::LabOptionmenu;

my $mw = MainWindow->new;
my $tb = $mw->ToolBar;

my $cv = $mw->Canvas(qw/-bg black/)->pack(qw/-fill both -expand 1/);
$cv->createPolygon(0, 0, 50, 100, 100, 0, 0, 50, 100, 50, 0, 0,
		   -fill => 'white');

$mw->Button(-text    => 'See built-in images',
	    -command => \&seeBuiltIns,
	   )->pack;

for my $img (qw/filenew22 fileopen22 filesave22/) {
  $tb->ToolButton(-image => $img,
		  -tip => $img);
}

$tb->separator;

for my $img (qw/editcopy22 editcut22 editpaste22 editdelete22/) {
  $tb->ToolButton(-image => $img,
		  -tip => $img);
}

$tb->separator;

$tb->ToolButton(-image   => 'actexit22',
		-tip     => 'Quit',
		-command => [$mw, 'destroy']);

MainLoop;

sub seeBuiltIns {
  #my @files  = qw/tkIcons tkIcons.crystal tkIcons.klassic/;
  my @files  = qw/tkIcons/;

  my $t = $mw->Toplevel;
  $t->title("Tk::ToolBar's built-in images");

  my $g = $t->Frame->pack(qw/-side top -fill x/);
  $t->Label(-text => 'Click on icon to see its name')->pack(qw/-side top -expand 1/);

  my %frame;
  $frame{$_} = $t->Frame for @files;

  my ($sel, $cur);

  $g->Button(-text    => 'Close Window',
	     -command => [$t => 'destroy'],
	    )->pack(qw/-side left -expand 1/);

  $g->Label(-text => 'Icon Style')->pack(qw/-side left/);
  $g->Optionmenu(
		 #-label    => 'Icon Style',
		 -options  => \@files,
		 -variable => \$sel,
		 -command  => sub {
		   $frame{$cur}->packForget if $cur;
		   $frame{$sel}->pack(qw/-side bottom/);
		   $cur = $sel;
		 })->pack(qw/-side left/);

  for my $ff (@files) {
    my $frame = $frame{$ff};
    my $file  = Tk->findINC("ToolBar/$ff");
    die "ERROR: Can't find tkIcons!\n" unless defined $file;

    open my $fh, $file or die $!;

    my %icons;

    while (<$fh>) {
      chomp;
      my ($n, $d) = (split /:/)[0, 4];

      $icons{$n} = $mw->Photo("$ff.$n", -data => $d);
    }

    close $fh;

    my $selected = 'None';
    $frame->Label(-textvariable => \$selected)->pack(qw/-side top/);

    my $f = $frame->Frame->pack(qw/-fill both -expand 1/);

    my $r = my $c = 0;
    my %labels;

    for my $n (sort keys %icons) {
      my $l = $f->Label(
			-image         => "$ff.$n",
		       )->grid(-column => $c,
			       -row    => $r,
			      );

      $labels{$n} = $l;

      $l->bind('<1>' => sub {
		 if ($selected ne 'None') {
		   $labels{$selected}->configure(-borderwidth => 0, -bg => Tk::ACTIVE_BG);#defaultthing);
		 }

		 $selected = $n;
		 $l->configure(-borderwidth => 2, -bg => 'white');
	       });

      $c++;
      if ($c == 20) {
	$r++;
	$c = 0;
      }
    }
  }
}