use Tk 8.0;
use subs qw/native_optionmenu/;
use strict;

my $mw = MainWindow->new;

my $palette;
my @colors = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue
    gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/;

my $nom = native_optionmenu(
    $mw,
    \$palette,
    [sub {print "args=@_.\n"}, 'First'],
    @colors,
)->pack;
my $menu = $nom->cget(-menu);

my $topborder    = 'gray50';
my $bottomborder = 'gray75';

foreach my $i (0 .. $#colors) {

    # Create a 16 pixel x 16 pixel solid color swatch.
    # Add a black ring around the currently selected item.

    my $color = $menu->entrycget($i, -label);
    my $p = $mw->Photo(qw/-width 16 -height 16/);
    $p->put($topborder,    qw/-to  0  0 16  1/);
    $p->put($topborder,    qw/-to  0  1  1 16/);
    $p->put($bottomborder, qw/-to  1 15 16 16/);
    $p->put($bottomborder, qw/-to 15  1 16 15/);
    $p->put($color,        qw/-to  1  1 15 15/);

    my $r = $mw->Photo(qw/-width 16 -height 16/);
    $r->put(qw/black          -to  0  0 16  2/);
    $r->put(qw/black          -to  0  2  2 16/);
    $r->put(qw/black          -to  2 14 16 16/);
    $r->put(qw/black          -to 14  2 16 14/);
    $r->put($color       , qw/-to  2  2 14 14/);

    $menu->entryconfigure($i, -columnbreak => 1) unless $i % 4;
    $menu->entryconfigure($i,
        -image       => $p,
        -hidemargin  => 1,
        -selectimage => $r,
    );

}

$menu->configure(-tearoff => 1);

$menu->bind('<<MenuSelect>>' => sub {
    my $label = undef;
    my $w = $Tk::event->W;
    Tk::catch {$label = $w->entrycget('active', -label)};
    print "palette=$palette, menu label=$label!\n" if defined $label;
});

MainLoop;

sub native_optionmenu {

    my($parent, $varref, $command, @optionvals) = @_;

    $$varref = $optionvals[0];

    my $mb = $parent->Menubutton(
        -textvariable       => $varref,
        -indicatoron        => 1,
        -relief             => 'raised',
        -borderwidth        => 2,
        -highlightthickness => 2,
        -anchor             => 'c',
        -direction          => 'flush',
    );
    my $menu = $mb->Menu(-tearoff => 0);
    $mb->configure(-menu => $menu);

    my $callback = ref($command) =~ /CODE/ ? [$command] : $command;

    foreach (@optionvals) {
    $menu->radiobutton(
            -label     => $_,
            -variable  => $varref,
            -command   => [@$callback, $_],
        );
    }

   $mb;

} # end native_optionmenu