summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl122
1 files changed, 122 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl
new file mode 100644
index 00000000000..9fd624bdc22
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/menbut.pl
@@ -0,0 +1,122 @@
+# menbut.pl
+
+use vars qw/$TOP/;
+
+sub menbut {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => '',
+ -title => 'Menubutton Demo',
+ -iconname => 'Menubutton',
+ );
+
+ my @menubuttons;
+ foreach (qw/below right left above/) {
+ my $pos = ucfirst;
+ my $menubutton = $TOP->Menubutton(qw/-underline 0 -relief raised/,
+ -text => $pos, -direction => $_);
+ push @menubuttons, $menubutton;
+ my $menu = $menubutton->menu(qw/-tearoff 0/);
+ $menubutton->configure(-menu => $menu);
+ $menubutton->command(-label => "$pos menu: first item", -command =>
+ sub {print "You selected the first item from the $pos menu.\n"});
+ $menubutton->command(-label => "$pos menu: second item", -command =>
+ sub {print "You selected the second item from the $pos menu.\n"});
+ }
+ $menubuttons[0]->grid(qw/-row 0 -column 1 -sticky n/);
+ $menubuttons[3]->grid(qw/-row 2 -column 1 -sticky n/);
+ $menubuttons[1]->grid(qw/-row 1 -column 0 -sticky w/);
+ $menubuttons[2]->grid(qw/-row 1 -column 2 -sticky e/);
+
+ my $body = $TOP->Frame;
+ $body->grid(qw/-row 1 -column 1 -sticky news/);
+ $body->Label(qw/-wraplength 300 -justify left/, -font => 'Helvetica 14',
+ -text => 'This is a demonstration of menubuttons. The "Below" menubutton pops its menu below the button; the "Right" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette.')->pack(qw/-side top -padx 25
+ -pady 25/);
+ $bbutt = $body->Frame->pack(qw/-padx 25 -pady 25/);
+ $bbutt->Optionmenu(-options => [qw/one two three/])->pack(qw/-side left
+ -padx 25 -pady 25/);
+
+ my $palette;
+ my(@colors) = qw/Black red4 DarkGreen NavyBlue gray75 Red Green Blue
+ gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet/;
+
+ my $colors = native_optionmenu(
+ $bbutt,
+ \$palette,
+ [sub {print "args=@_.\n"}, 'First'],
+ @colors,
+ );
+ $colors->pack(qw/-side left -padx 25 -pady 25/);
+
+ my $menu = $colors->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 = $TOP->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 = $TOP->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,
+ );
+
+ } # forend all colors
+
+ $menu->configure(-tearoff => 1);
+
+} # end menbut
+
+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
+
+1;