view release on metacpan or  search on metacpan

Rgb.pm  view on Meta::CPAN

package Color::Rgb;

# $Id: Rgb.pm,v 1.4 2002/10/23 20:30:46 sherzodr Exp $

require 5.003;
use strict;
use Carp 'croak';
use Fcntl qw(:DEFAULT :flock);
use vars qw($RGB_TXT $VERSION);

###########################################################################
################ Color::Rgb - simple rgb.txt parser #######################
###########################################################################
#                                                                         #
#   Copyright (c) 2002 Sherzod Ruzmetov. All rights reserved              #
#   You can modify and redistribute the following library under the same   #
#   terms as Perl itself.                                                 #
#                                                                         #
#   The library is written with usefulness in mind, but  neither explicit #
#   nor implied guarantee to a particular purpose made.                   #
###########################################################################

$RGB_TXT = '/usr/X11R6/lib/X11/rgb.txt';

($VERSION) = '$Revision: 1.4 $' =~ m/Revision:\s*(\S+)/;





# new(): constructor
# Usage: CLASS->new(rgb_txt=>'/path/to/rgb.txt')
# RETURN VALUE: Color::Rgb object
sub new {
    my $class = shift;
    $class = ref($class) || $class;

    my $self = {
        rgb_txt => $RGB_TXT,
        _rgb_map=> {},
        @_,
    };

    unless (sysopen (RGB, $self->{rgb_txt}, O_RDONLY) ) {
        croak "$self->{rgb_txt}: $!";
    }

    unless ( flock(RGB, LOCK_SH) ) {
        croak "Couldn't acquire LOCK_SH on $self->{rgb_txt}: $!";
    }

    while ( <RGB> ) {
        /^(\n|!|\#)/  and next;     # empty lines and comments
        chomp();
        my ($r, $g, $b, $name) = $_ =~ /^\s*(\d+)\s+(\d+)\s+(\d+)\s+(.+)$/;
        $self->{_rgb_map}->{ lc($name) } = [$r, $g, $b];
    }

    close (RGB) or croak "$self->{rgb_txt}: $!";

    return bless $self => $class;
}









# rgb(): reruns RGB value for an name
# Usage: CLASS->rgb('red' [, ','])
# RETURN VALUE either list or string
sub rgb {
    my ($self, $name, $delim) = @_;

    unless ( $name ) {
        croak "Color::Rgb->rgb(): usage: rgb(\$name [,\$delim]";
    }

    my $rgb = $self->{_rgb_map}->{lc($name) };

    unless ( defined $rgb ) {
        croak "$name doesn't exist";
    }

    my @rgb = @{ $rgb };

    defined $delim and return join ($delim, @rgb);

    return @rgb;
}


sub name2rgb {
    my $self = shift;

    $self->rgb(@_);
}


# hex(): returns a hex value for an name
# Usage: CLASS->hex('red' [,'#'])
# RETURN VALUE: hex string
sub hex {
    my ($self, $name, $pound) = @_;

    unless ( $name ) {
        croak "Color::Rgb->hex(): usage: hex(\$name [,\$prefix]";
    }

    # Using rgb() method to get the RGB list
    my ($r, $g, $b) = $self->rgb(lc($name)) or return;

    return sprintf("$pound%02lx%02lx%02lx", $r, $g, $b);
}


sub name2hex {
    my $self= shift;