#!/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);

}
[download]