Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / demos / widget_lib / clrpick.pl

# 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;
    }
}