File Coverage

blib/lib/Tk/ColourChooser.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Tk::ColourChooser ;    # Documented at the __END__.
#use Data::Dumper;

# $Id: ColourChooser.pm,v 1.32 2000/05/05 16:40:27 root Exp $

require 5.004 ;

use strict ;
use warnings;

use Carp ;
use Symbol ;
use Tk ;

require Tk::Toplevel ;

use vars qw( $VERSION @ISA %Translate ) ;

$VERSION = '1.52';

@ISA = qw( Tk::Toplevel ) ;

Construct Tk::Widget 'ColourChooser' ;

# Global hashes available to all instances
my( %Name2hex, %Hex2name ) ;
my $Loaded ; # Flag indicating whether we're read the colour data or not.


#############################
sub Populate {
    my( $win, $args ) = @_ ;

    $win->{-language} = delete $args->{-language} || 'en' ;
    $win->{-showhex}  = delete $args->{-showhex}  || 0 ;
    $win->{-language} = 'en' if $win->{-language} eq 'english' ; # Backward compatibility.
    $args->{-title}   = $Translate{$win->{-language}}{-title}
                        unless defined $args->{-title} ;
    my $hexonly       = delete $args->{-hexonly} ;
    $win->{HEX_ONLY}  = defined $hexonly and $hexonly ? 1 : 0 ;
    my $transparent   = delete $args->{-transparent} ;
    my $colour        = delete $args->{-colour} ;

    $win->SUPER::Populate( $args ) ;

    $win->withdraw ;
    $win->iconname( $args->{-title} ) ;
    $win->protocol( 'WM_DELETE_WINDOW' => sub { } ) ;
    $win->transient( $win->parent ) ;

    &_read_rgb( $win ) ;

    # Create listbox.
    my $Frame     = $win->Frame()->pack( -fill => 'x' ) ;
    $win->{COLOUR_FRAME} = $Frame ;
    my $scrollbar = $Frame->Scrollbar->pack( -side => 'right', -fill => 'y' ) ;
    my $list      = $Frame->Listbox(
        -height          => 1,
        -selectmode      => 'single',
        -background      => 'white',
        -exportselection => 0,
        )->pack( -expand => 'ns', -fill => 'x', -pady => 20, -padx => 10 ) ;
    $list->configure(
        -yscrollcommand => [ \&_listbox_scroll, $scrollbar, $list, $win ] ) ;
    $scrollbar->configure( -command => [ $list => 'yview' ] ) ;

    $list->insert( 'end', sort { lc $a cmp lc $b } keys %Name2hex ) ;

    $list->bind( '', [ \&_set_colour_from_list, $win ] ) ;
    $list->bind( '',   [ \&_set_colour_from_list, $win ] ) ;
    $list->bind( '<1>',    [ \&_set_colour_from_list, $win ] ) ;

    $win->{COLOUR_LIST} = $list ;

    &_set_list( $win, 0 ) ;

    # Colour sliders.
    foreach my $colour ( qw( red green blue ) ) {
        my $scale = $win->Scale(
            -orient       => 'horizontal',
            -from         => 0,
            -to           => 255,
            -tickinterval => 25,
            -label        => $Translate{$win->{-language}}{'-' . $colour},
            -fg           => "dark$colour",
            '-length'     => 300,
            )->pack( -fill => 'x' ) ;
        $win->{'-' . $colour} = 0 ;
        $scale->configure(
            -variable => \$win->{'-' . $colour},
            -command  => [ \&_set_colour, $win ],
            ) ;
    }

    # Create buttons.
    $Frame  = $win->Frame()->pack() ;
    my $column = 0 ;
    foreach my $button ( $Translate{$win->{-language}}{-ok},
                         $Translate{$win->{-language}}{-transparent},
                         $Translate{$win->{-language}}{-cancel} ) {
        next if $button eq $Translate{$win->{-language}}{-transparent} and
                defined $transparent and
                        $transparent == 0 ;

        my $Button = $Frame->Button(
            -text      => $button,
            -underline => 0,
            -width     => 10,
            -command   => [ \&_close, $win, $button ],
            )->grid( -row => 0, -column => $column++, -pady => 5 ) ;

        my $char = lc substr( $button, 0, 1 ) ;

        $win->bind( "", [ \&_close, $win, $button ] ) ;
        $win->bind( "",     [ \&_close, $win, $button ] ) ;
        $win->bind( "<${char}>",         [ \&_close, $win, $button ] ) ;
    }

    $win->bind( "",
        [ \&_close, $win, $Translate{$win->{-language}}{-ok} ] ) ;
    $win->bind( "",
        [ \&_close, $win, $Translate{$win->{-language}}{-cancel} ] ) ;

    # Set initial colour if given.
    if( defined $colour ) {
        if( lc $colour eq 'none' ) {
            $win->{-red} = $win->{-green} = $win->{-blue} = 0 ;
        }
        elsif( $colour =~
            /^#?([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})([0-9A-Fa-f]{2})$/o ) {
            $win->{-red}   = hex $1 ;
            $win->{-green} = hex $2 ;
            $win->{-blue}  = hex $3 ;
        }
        else {
            my $hex        = $Name2hex{$colour} ;
            if (defined $hex) {
                $win->{-red}   = hex substr( $hex, 0, 2 ) ;
                $win->{-green} = hex substr( $hex, 2, 2 ) ;
                $win->{-blue}  = hex substr( $hex, 4, 2 ) ;
            }
        }
        &_set_colour( $win ) ;
    }

    $win->{-colour} = undef ;
}

#############################
sub _find_rgb {

    if ($ENV{RGB_TEXT}) {
        return $ENV{RGB_TEXT} if -r $ENV{RGB_TEXT};
    }
    else {
        foreach my $file (
            '/usr/local/lib/X11/rgb.txt',       '/usr/lib/X11/rgb.txt',
            '/usr/local/X11R5/lib/X11/rgb.txt', '/X11/R5/lib/X11/rgb.txt',
            '/X11/R4/lib/rgb/rgb.txt',          '/usr/openwin/lib/X11/rgb.txt',
            '/usr/X11R6/lib/X11/rgb.txt',
            ) {
            return $file if -e $file ;
        }
    }
    carp "Failed to find `rgb.txt', set \$ENV{RGB_TEXT} to the filename" ;

    return;
}

#############################
sub _read_rgb {
    my $win = shift ;

    return if $Loaded ;
    $Loaded = 1 ;

    my $file = &_find_rgb ;

    if( defined $file ) {
        $Name2hex{'_Unnamed'} = '000000' ;
        $Hex2name{'000000'}  = '_Unnamed' ;
        my $fh = gensym ;
        open $fh, $file or croak "Failed to open `$file': $!" ;
        local $_ ;
        while( <$fh> ) {
            chomp ;
            my @array = split ;
            if( scalar @array == 4 ) {
                my $hex = sprintf "%02X%02X%02X", @array[0..2] ;
                # We only use the first name for a given colour.
                if( not exists $Name2hex{$array[3]} ) {
                    $Name2hex{$array[3]} = $hex ;
                    $Hex2name{$hex}      = $array[3] ;
                }
            }
        }
        close $fh or carp "Failed to close `$file': $!" ;
    }
}

#############################
sub _listbox_scroll {
    my( $scrollbar, $list, $win, @args ) = @_ ;

    $scrollbar->set( @args ) ;
    my $index = int( $list->size * $args[0] ) ;
    $list->activate( $index ) ;
    $list->selectionSet( $index ) ;
}

#############################
sub _set_colour {
    my $win = shift ;

    my $hex = sprintf "%02X%02X%02X",
                $win->{-red}, $win->{-green}, $win->{-blue} ;

    my $index = 0 ;
    if( exists $Hex2name{$hex} ) {
        my $list = $win->{COLOUR_LIST} ;
        for( $index = 0 ; $index < $list->size ; $index++ ) {
            last if $list->get( $index ) eq $Hex2name{$hex} ;
        }
    }
    &_set_list( $win, $index ) ;

    &_update_colour( $win, $hex ) ;
}

#############################
sub _set_colour_from_list {
    my( $list, $win ) = @_ ;

    $list->selectionSet( 'active' ) ;
    my $colour     = $list->get( 'active' ) ;
    my $hex        = $Name2hex{$colour} ;
    $win->{-red}   = hex substr( $hex, 0, 2 ) ;
    $win->{-green} = hex substr( $hex, 2, 2 ) ;
    $win->{-blue}  = hex substr( $hex, 4, 2 ) ;

    &_update_colour( $win, $hex ) ;
}


#############################
sub _update_colour {
    my( $win, $hex ) = @_ ;

    if( $win->{-showhex} ) {
        my $title = $win->cget( -title ) ;
        $title = substr( $title, 0, index( $title, ' -' ) ) ;
        $win->configure( -title, "$title - #$hex" ) ;
    }
    $win->{COLOUR_FRAME}->configure( -bg => "#$hex" ) ;
}


#############################
sub _set_list {
    my( $win, $index ) = @_ ;

    my $list = $win->{COLOUR_LIST} ;
    $list->activate( $index ) ;
    $list->see( $index ) ;
    $list->selectionSet( $index ) ;
}

#############################
sub Show {
    my $win = shift ;

    $win->Popup() ;

    my $list = $win->{COLOUR_LIST} ;
    $list->focus ;

    $win->waitVariable( \$win->{-colour} ) ;
    $win->withdraw ;

    $win->{-colour} ;
}

#############################
sub _close {

    my $win ;
    while( ref $_[0] ) {
        $win = shift ;
        last if ref $win =~ /ColourChooser/o ;
    }
    my $button = shift ;

    if( $button eq $Translate{$win->{-language}}{-transparent} ) {
        $win->{-colour} = 'None' ;
    }
    elsif( $button eq $Translate{$win->{-language}}{-cancel} ) {
        $win->{-colour} = '' ;
    }
    else {
        my $hex = sprintf "%02X%02X%02X",
                    $win->{-red}, $win->{-green}, $win->{-blue} ;
        if( exists $Hex2name{$hex} and not $win->{HEX_ONLY} ) {
            $win->{-colour} = $Hex2name{$hex} ;
        }
        else {
            $win->{-colour} = "#$hex" ;
        }
    }

    $win->{-colour} ;
}

#############################
BEGIN {
    %Translate = (
        'de' => {
            -title       => 'Farbe Chooser',
            -red         => 'Rot',
            -blue        => 'Blau',
            -green       => 'Grün',
            -ok          => 'OK',
            -transparent => 'Transparent',
            -cancel      => 'Löschen',
            },
        'en' => {
            -title       => 'Colour Chooser',
            -red         => 'Red',
            -blue        => 'Blue',
            -green       => 'Green',
            -ok          => 'OK',
            -transparent => 'Transparent',
            -cancel      => 'Cancel',
            },
        'fr' => {
            -title       => 'Couleur Chooser',
            -red         => 'Rouge',
            -blue        => 'Bleu',
            -green       => 'Vert',
            -ok          => 'OK',
            -transparent => 'Transparent',
            -cancel      => 'Annulent',
            },
         ) ;
}

1 ;

__END__