diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/clrpick.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/clrpick.pl | 45 |
1 files changed, 45 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/clrpick.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/clrpick.pl new file mode 100644 index 00000000000..df9d3a72cd7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/demos/widget_lib/clrpick.pl @@ -0,0 +1,45 @@ +# clrpick.pl + +use Tk qw/catch/; +use subs qw/setColor setColor_helper/; +use vars qw/$TOP/; + +sub clrpick { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'Press the buttons below to choose the foreground and background colors for the widgets in this window.', + -title => 'chooseColor Demo', + -iconname => 'chooseColor', + ); + + my(@pl) = qw/-side top -anchor c -pady 2m/; + my($back, $front); + $back = $TOP->Button(-text => 'Set background color ...')->pack(@pl); + $back->configure(-command => [\&setColor => $TOP, $back, '-background', + [-background, -highlightbackground]]); + $front = $TOP->Button(-text => 'Set foreground color ...')->pack(@pl); + $front->configure(-command => [\&setColor => $TOP, $front, '-foreground', + [-foreground]]); +} + +sub setColor { + my($top, $button, $name, $options) = @_; + my $initialColor = $button->cget($name); + my $color = $button->chooseColor(-title => "Choose a $name color", + -initialcolor => $initialColor); + setColor_helper $top, $options, $color if defined $color; +} + +sub setColor_helper { + my($widget, $options, $color) = @_; + foreach my $option (@$options) { + catch { + $widget->configure($option => $color); + } + } + foreach my $child ($widget->children) { + setColor_helper $child, $options, $color; + } +} + |