Well after removing the hex2dec sub above, I figured.."Why not add an initial color option?". So here is an updated version that accepts an initial hex rgb value, and sets the scales. It may be useful as an example of Tk::Derived, and the trick to add extra options.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
package RGBColorDialog;
use Carp;
use strict;
# basic ideas copied from www.perltk.org/ex/showcolor.pl
# and made to work easily as package/module
# by zentara of Perlmonks, Jun, 22, 2008
# Free to use and modify for your own purposes.
require Tk::Toplevel;
#without Tk::Derived the option -initial_color will fail
use base qw(Tk::Derived Tk::Toplevel);
use Tk::Scale;
Construct Tk::Widget 'RGBColorDialog';
sub Populate {
# SettingsDialog object constructor. Uses `new' method from base
+class
# to create object container then creates the dialog toplevel.
my ($self, $args) = @_;
#take care of args which don't belong to the SUPER, see Tk::Derived
my $xtra_arg = delete $args->{-initial_color}; #delete and read sa
+me time
if( defined $xtra_arg ) { $self->{'initial_color'} = $xtra_arg }
$self->SUPER::Populate($args);
# Create the Toplevel window
$self->{RESULT} = '';
$self->protocol('WM_DELETE_WINDOW' => sub {});
$self->transient($self->Parent->toplevel);
$self->withdraw;
$self->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));
#test for valid Tk color hex string #ffffff etc
if (( $xtra_arg =~ /^#[0-9a-fA-F]+\z/i) and (length $xtra_arg ==
+7)) {
$self->{value} = $self->{initial_color}
#initially black unless given initial_color
}else{ $self->{value} = '#000000' }
$self->{sample} = $self->Frame( -height => '2c',
-relief => 'ridge' )->pack( -side => 'bottom', -fill => 'x' );
$self->{left} = $self->Frame->pack( -side => 'left', -fill => 'y')
+;
# Make a scale for each color component.
makeRGBAScales($self);
$self->{OK_BUTTON} = $self->Button(
-text =>'Ok',
-background => 'lightyellow',
-activebackground => 'yellow',
-font => 'big',
-command => sub{
$self->{RESULT} = $self->{value};
} )->pack();
}
sub makeRGBAScales{
my ( $self ) = shift;
# Stick a message at the top.
$self->{left}->Label( -text => "Slide colors:",
-bg => 'black',
-fg => 'hotpink',
-font => 'big',
-relief => "raised", -bd => 2 )->pack( -side => 'top',
-fill => 'x' );
# Display the current value at the bottom.
$self->{left}->Label( -textvariable => \$self->{value},
-bg => 'white',
-font => 'big',
-relief => "ridge", -bd => 2 )->pack( -side => 'bottom',
-fill => 'x' );
# Make a scale for each color component.
$self->{redScale} = makeScale( $self, 'red' );
$self->{greenScale} = makeScale( $self,'green' );
$self->{blueScale} = makeScale( $self, 'blue' );
# Set each of the scales to the proper setting for initial_color.
$self->{redScale}->set( hex2dec( substr( $self->{value}, 1, 2 )));
$self->{greenScale}->set( hex2dec( substr($self->{value}, 3, 2 )));
$self->{blueScale}->set( hex2dec( substr( $self->{value}, 5, 2 )));
}
sub makeScale{
my ( $self, $color ) = @_;
my $scale = $self->{left}->Scale(
-label => substr( $color, 0, 1 ),
-from => 0, -to => 255,
-troughcolor => $color,
-showvalue => 'yes',
-orient => 'vertical',
-command => [ \&scaleCommand, $self ] );
$scale->pack( -side => 'left', -fill => 'y' );
$scale->bind( '<1>' => sub { $scale->focus } );
return $scale;
}
sub scaleCommand{
my $self = shift;
# Get each scale's setting and recalculate the rgb value.
$self->{value} = sprintf( "#%02x%02x%02x",
$self->{redScale}->get,
$self->{greenScale}->get,
$self->{blueScale}->get );
# Repaint the sample area.
$self->{sample}->configure( -background => $self->{value} );
}
sub hex2dec{
my ($hex) = @_;
my $dec = 0;
while ( length($hex) ){
my ( $digit ) = substr( $hex, 0, 1 );
$hex = substr( $hex, 1 );
if ( $digit eq 'a' ) { $digit = '10'; }
elsif ( $digit eq 'b' ) { $digit = '11'; }
elsif ( $digit eq 'c' ) { $digit = '12'; }
elsif ( $digit eq 'd' ) { $digit = '13'; }
elsif ( $digit eq 'e' ) { $digit = '14'; }
elsif ( $digit eq 'f' ) { $digit = '15'; }
$dec = ( $dec * 16 ) + int($digit);
}
return $dec;
}
sub Show {
# public method - display the dialog.
my ($self, $grab_type) = @_;
croak "Tk::RGBColorDialog: `Show' method requires at least 1 argu
+ment"
if scalar @_ < 1 ;
my $old_focus = $self->focusSave;
my $old_grab = $self->grabSave;
# Update all geometry information, center the dialog in the displa
+y
# and deiconify it
$self->Popup();
# set a grab and claim the focus.
if (defined $grab_type && length $grab_type) {
$self->grab($grab_type);
} else {
$self->grab;
}
$self->waitVisibility unless $self->viewable; # this "unless" clau
+se
# is due to a change
+ in Tk800.015
$self->update;
foreach my $w ( $self->Descendants ) {
$w->update;
}
# needs to be visible to set -bg??
$self->{OK_BUTTON}->configure(-background => 'lightyellow');
$self->{OK_BUTTON}->focus;
# Wait for the user to respond, restore the focus and grab, withdr
+aw
# the dialog and return the label of the selected button.
$self->waitVariable(\$self->{RESULT});
$self->grabRelease;
$self->withdraw;
&$old_focus;
&$old_grab;
return $self->{RESULT};
} # end Show method
1;
package main;
my $mw = MainWindow->new(-title => "Color Dialog Tester");
$mw->geometry("100x100+500+500");
my $dlg = $mw->RGBColorDialog(
-initial_color => '#ffccdd'
# 7letter hex string begining with #
# anything else defaults to black '#000000'
);
my $button = $mw->Button(-text=>'Test',-command=>\&test)->pack();
Tk::MainLoop;
sub test {
my $result = $dlg->Show;
print "$result\n";
$button->configure(-background => $result);
}