File Coverage

blib/lib/Graphics/ColorNames.pm

Criterion	Covered	Total	%
statement	149	171	87.1
branch	53	74	71.6
condition	17	27	62.9
subroutine	29	29	100.0
pod	6	7	85.7
total	254	308	82.4

package Graphics::ColorNames;
use 5.006;

# ABSTRACT: defines RGB values for common color names

use strict;
use warnings;

use version;

use Exporter qw/ import /;

use Carp;
use File::Spec::Functions qw/ file_name_is_absolute /;
use Module::Load 0.10;
use Module::Loaded;

our $VERSION = 'v3.4.0';

our %EXPORT_TAGS = (
    'all'     => [qw( hex2tuple tuple2hex all_schemes )],
    'utility' => [qw( hex2tuple tuple2hex )],
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT    = ();

sub VERSION {
    my ( $class, $wanted ) = @_;
    return version->parse($VERSION);
}

# We store Schemes in a hash as a quick-and-dirty way to filter
# duplicates (which sometimes occur when directories are repeated in
# @INC or via symlinks).  The order does not matter.

my %FoundSchemes = ();

sub _load {
    while ( my $module = shift ) {
        unless ( is_loaded($module) ) {
            load($module);
            mark_as_loaded($module) unless ( is_loaded($module) );
        }
    }
}

# TODO - see if using Tie::Hash::Layered gives an improvement

sub _load_scheme_from_module {
    my ($self, $scheme) = @_;

    my $module =
        $scheme =~ /^\+/ ? substr( $scheme, 1 )
      : $scheme =~ /^Color::Library::Dictionary::/ ? $scheme
      :   __PACKAGE__ . '::' . $scheme;

    eval { _load($module); };
    if ($@) {
        croak "Cannot load color naming scheme module $module";
    }

    if ($module->can('NamesRgbTable')) {
        $self->load_scheme( $module->NamesRgbTable );
    }
    elsif ($module->can('_load_color_list')) {
        $self->load_scheme( $module->_load_color_list );
    }
    else {
        croak "Unknown scheme type: $module";
    }
}

sub TIEHASH {
    my $class = shift || __PACKAGE__;
    my $self = {
        _schemes  => [],
        _iterator => 0,
    };

    bless $self, $class;

    if (@_) {
        foreach my $scheme (@_) {
            if ( ref $scheme ) {
                $self->load_scheme($scheme);
            }
            elsif ($scheme =~ /^\+?(?:\w+[:][:])*\w+$/) {
                $self->_load_scheme_from_module($scheme);
            }
            elsif ( file_name_is_absolute($scheme) ) {
                $self->_load_scheme_from_file($scheme);
            }
            else {
                croak "Unknown color scheme: $scheme";
            }
        }
    }
    else {
        $self->_load_scheme_from_module('X');
    }

    return $self;
}

sub FETCH {
    my $self = shift;
    my $key = lc( shift || "" );

    # If we're passing it an RGB value, return that value

    if ( $key =~ m/^(?:\x23|0x)?([0-9a-f]{6})$/ ) {
        return $1;
    }
    else {

        $key =~ s/[^0-9a-z\%]//g;    # ignore non-word characters

        my $val = undef;
        my $i   = 0;
        while ( ( !defined $val ) && ( $i < @{ $self->{_schemes} } ) ) {
            $val = $self->{_schemes}->[ $i++ ]->{$key};
        }

        if ( defined $val ) {
            return sprintf( '%06x', $val ),;
        }
        else {
            return;
        }
    }
}

sub EXISTS {
    my ( $self, $key ) = @_;
    defined( $self->FETCH($key) );
}

sub FIRSTKEY {
    ( my $self = shift )->{_iterator} = 0;
    each %{ $self->{_schemes}->[ $self->{_iterator} ] };
}

sub NEXTKEY {
    my $self = shift;
    my ( $key, $val ) = each %{ $self->{_schemes}->[ $self->{_iterator} ] };
    unless ( defined $key ) {
        ( $key, $val ) = each %{ $self->{_schemes}->[ ++$self->{_iterator} ] };
    }
    return $key;
}

sub load_scheme {
    my $self   = shift;
    my $scheme = shift;

    if ( ref($scheme) eq "HASH" ) {
        push @{ $self->{_schemes} }, $scheme;
    }
    elsif ( ref($scheme) eq "CODE" ) {
        _load("Tie::Sub");
        push @{ $self->{_schemes} }, {};
        tie %{ $self->{_schemes}->[-1] }, 'Tie::Sub', $scheme;
    }
    elsif ( ref($scheme) eq "ARRAY" ) {

        # assumes these are Color::Library::Dictionary 0.02 files
        my $s = {};
        foreach my $rec (@$scheme) {
            my $key  = $rec->[0];
            my $name = $rec->[1];
            my $code = $rec->[5];
            $name =~ s/[\W\_]//g;    # ignore non-word characters
            $s->{$name} = $code unless ( exists $s->{$name} );
            if ( $key =~ /^(.+\:.+)\.([0-9]+)$/ ) {
                $s->{"$name$2"} = $code;
            }
        }
        push @{ $self->{_schemes} }, $s;
    }
    else {
        # TODO - use Exception
        undef $!;
        eval {
            if (   ( ref($scheme) eq 'GLOB' )
                || ref($scheme) eq "IO::File"
                || $scheme->isa('IO::File')
                || ref($scheme) eq "FileHandle"
                || $scheme->isa('FileHandle') )
            {
                $self->_load_scheme_from_file($scheme);
            }
        };
        if ($@) {
            croak "Error $@ on scheme type ", ref($scheme);
        }
        elsif ($!) {
            croak "$!";
        }
        else {
            # everything is ok?
        }
    }
}

sub _find_schemes {

    my $path = shift;

    # BUG: deep-named schemes such as Graphics::ColorNames::Foo::Bar
    # are not supported.

    if ( -d $path ) {
        my $dh = DirHandle->new($path)
          || croak "Unable to access directory $path";
        while ( defined( my $fn = $dh->read ) ) {
            if (   ( -r File::Spec->catdir( $path, $fn ) )
                && ( $fn =~ /(.+)\.pm$/ ) )
            {
                $FoundSchemes{$1}++;
            }
        }
    }
}

sub _readonly_error {
    croak "Cannot modify a read-only value";
}

sub DESTROY {
    my $self = shift;
    delete $self->{_schemes};
    delete $self->{_iterator};
}

BEGIN {
    no strict 'refs';
    *STORE  = \&_readonly_error;
    *DELETE = \&_readonly_error;
    *CLEAR  = \&_readonly_error;    # causes problems with 'undef'

    *new = \&TIEHASH;
}

# Convert 6-digit hexidecimal code (used for HTML etc.) to an array of
# RGB values

sub hex2tuple {
    my $rgb = CORE::hex(shift);
    my ( $red, $green, $blue );
    $blue  = ( $rgb & 0x0000ff );
    $green = ( $rgb & 0x00ff00 ) >> 8;
    $red   = ( $rgb & 0xff0000 ) >> 16;
    return ( $red, $green, $blue );
}

# Convert list of RGB values to 6-digit hexidecimal code (used for HTML, etc.)

sub tuple2hex {
    my ( $red, $green, $blue ) = @_;
    my $rgb = sprintf "%.2x%.2x%.2x", $red, $green, $blue;
    return $rgb;
}

sub all_schemes {
    unless (%FoundSchemes) {

        _load( "DirHandle", "File::Spec" );

        foreach my $dir (@INC) {
            _find_schemes(
                File::Spec->catdir( $dir, split( /::/, __PACKAGE__ ) ) );
        }
    }
    return ( keys %FoundSchemes );
}

sub _load_scheme_from_file {
    my $self = shift;
    my $file = shift;

    unless ( ref $file ) {
        unless ( -r $file ) {
            croak "Cannot load scheme from file: \'$file\'";
        }
        _load("IO::File");
    }

    my $fh = ref($file) ? $file : ( IO::File->new );
    unless ( ref $file ) {
        open( $fh, $file )
          || croak "Cannot open file: \'$file\'";
    }

    my $scheme = {};

    while ( my $line = <$fh> ) {
        chomp($line);
        $line =~ s/[\!\#].*$//;
        if ( $line ne "" ) {
            my $name = lc( substr( $line, 12 ) );
            $name =~ s/[\W]//g;  # remove anything that isn't a letter or number

            croak "Missing color name",
              unless ( $name ne "" );

            # TODO? Should we add an option to warn if overlapping names
            # are defined? This seems to be too common to be useful.

            # unless (exists $scheme->{$name}) {

            $scheme->{$name} = 0;
            foreach ( 0, 4, 8 ) {
                $scheme->{$name} <<= 8;
                $scheme->{$name} |= ( eval substr( $line, $_, 3 ) );
            }

            # }
        }
    }
    $self->load_scheme($scheme);

    unless ( ref $file ) {
        close $fh;
    }
}

sub hex {
    my ($self, $name, $prefix) = @_;
    my $rgb  = $self->FETCH($name);

    return '' unless defined $rgb;

    return $rgb unless defined $prefix;

    return $prefix . $rgb;
}

sub rgb {
    my ($self, $name, $separator) = @_;
    my $rgb = $self->FETCH($name);
    my @rgb = (defined $rgb) ? hex2tuple( $rgb ) : ();
    return wantarray ? @rgb : join($separator || ',', @rgb);
}

1;

__END__