1package Graphics::ColorNames; 2use 5.006; 3 4use base "Exporter"; 5 6use strict; 7use warnings; 8 9# use AutoLoader; 10use Carp; 11use Module::Load 0.10; 12use Module::Loaded; 13 14our $VERSION = '2.11'; 15# $VERSION = eval $VERSION; 16 17our %EXPORT_TAGS = ( 18 'all' => [ qw( hex2tuple tuple2hex all_schemes ) ], 19 'utility' => [ qw( hex2tuple tuple2hex ) ], 20); 21our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 22our @EXPORT = ( ); 23 24# We store Schemes in a hash as a quick-and-dirty way to filter 25# duplicates (which sometimes occur when directories are repeated in 26# @INC or via symlinks). The order does not matter. 27 28# If we use AutoLoader, these should be use vars() ? 29 30my %FoundSchemes = ( ); 31 32# Since 2.10_02, we've added autoloading color names to the object- 33# oriented interface. 34 35our $AUTOLOAD; 36 37sub AUTOLOAD { 38 $AUTOLOAD =~ /^(.*:)*([\w\_]+)$/; 39 my $name = $2; 40 my $hex = (my $self = $_[0])->FETCH($name); 41 if (defined $hex) { 42 return $hex; 43 } 44 else { 45 croak "No method or color named $name"; 46 # $AutoLoader::AUTOLOAD = $AUTOLOAD; 47 # goto &AutoLoader::AUTOLOAD; 48 } 49} 50 51 52sub _load { 53 while(my $module = shift) { 54 unless (is_loaded($module)) { 55 load($module); 56 mark_as_loaded($module) unless (is_loaded($module)); 57 } 58 } 59} 60 61# TODO - see if using Tie::Hash::Layered gives an improvement 62 63sub _load_scheme_from_module { 64 my $self = shift; 65 my $base = __PACKAGE__; 66 67 my $module = join('::', $base, (my $scheme = shift)); 68 eval { _load($module); }; 69 if ($@) { 70 eval { _load($module = $scheme); }; 71 if ($@) { 72 croak "Cannot load color naming scheme \`$module\'"; 73 } 74 } 75 76 { 77 no strict 'refs'; 78 if ($module =~ $base) { 79 $self->load_scheme($module->NamesRgbTable); 80 } 81 elsif ($module =~ /Color::Library::Dictionary/) { 82 $self->load_scheme($module->_load_color_list); 83 } 84 else { 85 croak "Unknown scheme type: $module"; 86 } 87 } 88} 89 90sub TIEHASH { 91 my $class = shift || __PACKAGE__; 92 my $self = { 93 _schemes => [ ], 94 _iterator => 0, 95 }; 96 97 bless $self, $class; 98 99 if (@_) { 100 foreach my $scheme (@_) { 101 if (ref $scheme) { 102 $self->load_scheme( $scheme ); 103 } 104 elsif (-r $scheme) { 105 $self->_load_scheme_from_file( $scheme ); 106 } 107 else { 108 $self->_load_scheme_from_module( $scheme ); 109 } 110 } 111 } else { 112 $self->_load_scheme_from_module('X'); 113 } 114 115 return $self; 116} 117 118sub FETCH { 119 my $self = shift; 120 my $key = lc(shift||""); 121 122 # If we're passing it an RGB value, return that value 123 124 if ($key =~ m/^\x23?([\da-f]{6})$/) { 125 return $1; 126 } else { 127 128 $key =~ s/[^a-z\d\%]//g; # ignore non-word characters 129 130 my $val = undef; 131 my $i = 0; 132 while ((!defined $val) && ($i < @{$self->{_schemes}})) { 133 $val = $self->{_schemes}->[$i++]->{$key}; 134 } 135 136 if (defined $val) { 137 return sprintf('%06x', $val ), ; 138 } else { 139 return; 140 } 141 } 142} 143 144sub EXISTS { 145 my ($self, $key) = @_; 146 defined ($self->FETCH($key)); 147} 148 149sub FIRSTKEY { 150 (my $self = shift)->{_iterator} = 0; 151 each %{$self->{_schemes}->[$self->{_iterator}]}; 152} 153 154sub NEXTKEY { 155 my $self = shift; 156 my ($key, $val) = each %{$self->{_schemes}->[$self->{_iterator}]}; 157 unless (defined $key) { 158 ($key, $val) = each %{$self->{_schemes}->[++$self->{_iterator}]}; 159 } 160 return $key; 161} 162 163sub load_scheme { 164 my $self = shift; 165 my $scheme = shift; 166 167 if (ref($scheme) eq "HASH") { 168 push @{$self->{_schemes}}, $scheme; 169 } 170 elsif (ref($scheme) eq "CODE") { 171 _load("Tie::Sub"); 172 push @{$self->{_schemes}}, { }; 173 tie %{$self->{_schemes}->[-1]}, 'Tie::Sub', $scheme; 174 } 175 elsif (ref($scheme) eq "ARRAY") { 176 # assumes these are Color::Library::Dictionary 0.02 files 177 my $s = { }; 178 foreach my $rec (@$scheme) { 179 my $key = $rec->[0]; 180 my $name = $rec->[1]; 181 my $code = $rec->[5]; 182 $name =~ s/[\W\_]//g; # ignore non-word characters 183 $s->{$name} = $code unless (exists $s->{$name}); 184 if ($key =~ /^(.+\:.+)\.(\d+)$/) { 185 $s->{"$name$2"} = $code; 186 } 187 } 188 push @{$self->{_schemes}}, $s; 189 } 190 else { 191 # TODO - use Exception 192 undef $!; 193 eval { 194 if ((ref($scheme) eq 'GLOB') 195 || ref($scheme) eq "IO::File" || $scheme->isa('IO::File') 196 || ref($scheme) eq "FileHandle" || $scheme->isa('FileHandle')) { 197 $self->_load_scheme_from_file($scheme); 198 } 199 }; 200 if ($@) { 201 croak "Error $@ on scheme type ", ref($scheme); 202 } 203 elsif ($!) { 204 croak "$!"; 205 } 206 else { 207 # everything is ok? 208 } 209 } 210} 211 212sub _find_schemes { 213 214 my $path = shift; 215 216 # BUG: deep-named schemes such as Graphics::ColorNames::Foo::Bar 217 # are not supported. 218 219 if (-d $path) { 220 my $dh = DirHandle->new( $path ) 221 || croak "Unable to access directory $path"; 222 while (defined(my $fn = $dh->read)) { 223 if ((-r File::Spec->catdir($path, $fn)) && ($fn =~ /(.+)\.pm$/)) { 224 $FoundSchemes{$1}++; 225 } 226 } 227 } 228 } 229 230sub _readonly_error { 231 croak "Cannot modify a read-only value"; 232} 233 234sub DESTROY { 235 my $self = shift; 236 delete $self->{_schemes}; 237 delete $self->{_iterator}; 238} 239 240sub UNTIE { # stub to avoid AUTOLOAD 241} 242 243BEGIN { 244 no strict 'refs'; 245 *STORE = \ &_readonly_error; 246 *DELETE = \ &_readonly_error; 247 *CLEAR = \ &_readonly_error; # causes problems with 'undef' 248 249 *new = \ &TIEHASH; 250} 251 252 2531; 254 255## __END__ 256 257# Convert 6-digit hexidecimal code (used for HTML etc.) to an array of 258# RGB values 259 260sub hex2tuple { 261 my $rgb = CORE::hex( shift ); 262 my ($red, $green, $blue); 263 $blue = ($rgb & 0x0000ff); 264 $green = ($rgb & 0x00ff00) >> 8; 265 $red = ($rgb & 0xff0000) >> 16; 266 return ($red, $green, $blue); 267} 268 269 270# Convert list of RGB values to 6-digit hexidecimal code (used for HTML, etc.) 271 272sub tuple2hex { 273 my ($red, $green, $blue) = @_; 274 my $rgb = sprintf "%.2x%.2x%.2x", $red, $green, $blue; 275 return $rgb; 276} 277 278sub all_schemes { 279 unless (%FoundSchemes) { 280 281 _load("DirHandle", "File::Spec"); 282 283 foreach my $dir (@INC) { 284 _find_schemes( 285 File::Spec->catdir($dir, split(/::/, __PACKAGE__))); 286 } 287 } 288 return (keys %FoundSchemes); 289 } 290 291sub _load_scheme_from_file { 292 my $self = shift; 293 my $file = shift; 294 295 unless (ref $file) { 296 unless (-r $file) { 297 croak "Cannot load scheme from file: \'$file\'"; 298 } 299 _load("IO::File"); 300 } 301 302 my $fh = ref($file) ? $file : (IO::File->new); 303 unless (ref $file) { 304 open($fh, $file) 305 || croak "Cannot open file: \'$file\'"; 306 } 307 308 my $scheme = { }; 309 310 while (my $line = <$fh>) { 311 chomp($line); 312 $line =~ s/[\!\#].*$//; 313 if ($line ne "") { 314 my $name = lc(substr($line, 12)); 315 $name =~ s/[\W]//g; # remove anything that isn't a letter or number 316 317 croak "Missing color name", 318 unless ($name ne ""); 319 320 # TODO? Should we add an option to warn if overlapping names 321 # are defined? This seems to be too common to be useful. 322 323 # unless (exists $scheme->{$name}) { 324 325 $scheme->{$name} = 0; 326 foreach (0, 4, 8) { 327 $scheme->{$name} <<= 8; 328 $scheme->{$name} |= (eval substr($line, $_, 3)); 329 } 330 331 # } 332 } 333 } 334 $self->load_scheme( $scheme ); 335 336 unless (ref $file) { 337 close $fh; 338 } 339} 340 341 342sub hex { 343 my $self = shift; 344 my $rgb = $self->FETCH(my $name = shift); 345 my $pre = shift || ""; 346 return ($pre.$rgb); 347} 348 349sub rgb { 350 my $self = shift; 351 my @rgb = hex2tuple($self->FETCH(my $name = shift)); 352 my $sep = shift || ','; # (*) 353 return wantarray ? @rgb : join($sep,@rgb); 354# (*) A possible bug, if one uses "0" as a separator. But this is not likely 355} 356 357__END__ 358 359=head1 NAME 360 361Graphics::ColorNames - defines RGB values for common color names 362 363=begin readme 364 365=head1 REQUIREMENTS 366 367C<Graphics::ColorNames> should work on Perl 5.6.0. It requires the 368following non-core (depending on your Perl version) modules: 369 370 Module::Load 371 Module::Loaded 372 373The following modules are not required for using most features but 374are recommended: 375 376 Color::Library 377 Tie::Sub 378 379L<Installation|/INSTALLATION> requires the following testing modules: 380 381 Test::Exception 382 Test::More 383 384If the C<DEVEL_TESTS> environment variable is set, the tests will also 385use the following modules for running developer tests, if they are 386installed: 387 388 Test::Pod 389 Test::Pod::Coverage 390 Test::Portability::Files 391 392The developer tests are for quality-control purposes. 393 394=head1 INSTALLATION 395 396Installation can be done using the traditional Makefile.PL or the newer 397Build.PL methods. 398 399Using Makefile.PL: 400 401 perl Makefile.PL 402 make test 403 make install 404 405(On Windows platforms you should use C<nmake> instead.) 406 407Using Build.PL (if you have L<Module::Build> installed): 408 409 perl Build.PL 410 perl Build test 411 perl Build install 412 413=end readme 414 415=head1 SYNOPSIS 416 417 use Graphics::ColorNames 2.10; 418 419 $po = new Graphics::ColorNames(qw( X )); 420 421 $rgb = $po->hex('green'); # returns '00ff00' 422 $rgb = $po->hex('green', '0x'); # returns '0x00ff00' 423 $rgb = $po->hex('green', '#'); # returns '#00ff00' 424 425 $rgb = $po->rgb('green'); # returns '0,255,0' 426 @rgb = $po->rgb('green'); # returns (0, 255, 0) 427 428 $rgb = $po->green; # same as $po->hex('green'); 429 430 tie %ph, 'Graphics::ColorNames', (qw( X )); 431 432 $rgb = $ph{green}; # same as $po->hex('green'); 433 434=head1 DESCRIPTION 435 436This module provides a common interface for obtaining the RGB values 437of colors by standard names. The intention is to (1) provide a common 438module that authors can use with other modules to specify colors by 439name; and (2) free module authors from having to "re-invent the wheel" 440whenever they decide to give the users the option of specifying a 441color by name rather than RGB value. 442 443=begin readme 444 445See the module POD for complete documentation. 446 447=end readme 448 449=for readme stop 450 451For example, 452 453 use Graphics::ColorNames 2.10; 454 455 use GD; 456 457 $pal = new Graphics::ColorNames; 458 459 $img = new GD::Image(100, 100); 460 461 $bgColor = $img->colorAllocate( $pal->rgb('CadetBlue3') ); 462 463Although this is a little "bureaucratic", the meaning of this code is clear: 464C<$bgColor> (or background color) is 'CadetBlue3' (which is easier to for one 465to understand than C<0x7A, 0xC5, 0xCD>). The variable is named for its 466function, not form (ie, C<$CadetBlue3>) so that if the author later changes 467the background color, the variable name need not be changed. 468 469You can also define L</Custom Color Schemes> for specialised palettes 470for websites or institutional publications: 471 472 $color = $pal->hex('MenuBackground'); 473 474As an added feature, a hexidecimal RGB value in the form of #RRGGBB, 4750xRRGGBB or RRGGBB will return itself: 476 477 $color = $pal->hex('#123abc'); # returns '123abc' 478 479=head2 Tied Interface 480 481The standard interface (prior to version 0.40) is through a tied hash: 482 483 tie %pal, 'Graphics::ColorNames', @schemes; 484 485where C<%pal> is the tied hash and C<@schemes> is a list of 486L<color schemes|/Color Schemes>. 487 488A valid color scheme may be the name of a color scheme (such as C<X> 489or a full module name such as C<Graphics::ColorNames::X>), a reference 490to a color scheme hash or subroutine, or to the path or open 491filehandle for a F<rgb.txt> file. 492 493As of version 2.1002, one can also use L<Color::Library> dictionaries: 494 495 tie %pal, 'Graphics::ColorNames', qw(Color::Library::Dictionary::HTML); 496 497This is an experimental feature which may change in later versions (see 498L</SEE ALSO> for a discussion of the differences between modules). 499 500Multiple schemes can be used: 501 502 tie %pal, 'Graphics::ColorNames', qw(HTML Netscape); 503 504In this case, if the name is not a valid HTML color, the Netscape name 505will be used. 506 507One can load all available schemes in the Graphics::ColorNames namespace 508(as of version 2.0): 509 510 use Graphics::ColorNames 2.0, 'all_schemes'; 511 tie %NameTable, 'Graphics::ColorNames', all_schemes(); 512 513When multiple color schemes define the same name, then the earlier one 514listed has priority (however, hash-based color schemes always have 515priority over code-based color schemes). 516 517When no color scheme is specified, the X-Windows scheme is assumed. 518 519Color names are case insensitive, and spaces or punctuation 520are ignored. So "Alice Blue" returns the same 521value as "aliceblue", "ALICE-BLUE" and "a*lICEbl-ue". (If you are 522using color names based on user input, you may want to add additional 523validation of the color names.) 524 525The value returned is in the six-digit hexidecimal format used in HTML and 526CSS (without the initial '#'). To convert it to separate red, green, and 527blue values (between 0 and 255), use the L</hex2tuple> function. 528 529=head2 Object-Oriented Interface 530 531If you prefer, an object-oriented interface is available: 532 533 use Graphics::ColorNames 0.40; 534 535 $obj = Graphics::ColorNames->new('/etc/rgb.txt'); 536 537 $hex = $obj->hex('skyblue'); # returns "87ceeb" 538 @rgb = $obj->rgb('skyblue'); # returns (0x87, 0xce, 0xeb) 539 540The interface is similar to the L<Color::Rgb> module: 541 542=over 543 544=item new 545 546 $obj = Graphics::ColorNames->new( @SCHEMES ); 547 548Creates the object, using the default L<color schemes|/Color Schemes>. 549If none are specified, it uses the C<X> scheme. 550 551=item load_scheme 552 553 $obj->load_scheme( $scheme ); 554 555Loads a scheme dynamically. The scheme may be any hash or code reference. 556 557=item hex 558 559 $hex = $obj->hex($name, $prefix); 560 561Returns a 6-digit hexidecimal RGB code for the color. If an optional 562prefix is specified, it will prefix the code with that string. For 563example, 564 565 $hex = $obj->hex('blue', '#'); # returns "#0000ff" 566 567=item rgb 568 569 @rgb = $obj->rgb($name); 570 571 $rgb = $obj->rgb($name, $separator); 572 573If called in a list context, returns a triplet. 574 575If called in a scalar context, returns a string separated by an 576optional separator (which defauls to a comma). For example, 577 578 @rgb = $obj->rgb('blue'); # returns (0, 0, 255) 579 580 $rgb = $obj->rgb('blue', ','); # returns "0,0,255" 581 582=back 583 584Since version 2.10_02, the interface will assume method names 585are color names and return the hex value, 586 587 $obj->black eq $obj->hex("black") 588 589Method names are case-insensitive, and underscores are ignored. 590 591=head2 Utility Functions 592 593These functions are not exported by default, so much be specified to 594be used: 595 596 use Graphics::ColorNames qw( all_schemes hex2tuple tuple2hex ); 597 598=over 599 600=item all_schemes 601 602 @schemes = all_schemes(); 603 604Returns a list of all available color schemes installed on the machine 605in the F<Graphics::ColorNames> namespace. 606 607The order has no significance. 608 609=item hex2tuple 610 611 ($red, $green, $blue) = hex2tuple( $colors{'AliceBlue'}); 612 613=item tuple2hex 614 615 $rgb = tuple2hex( $red, $green, $blue ); 616 617=back 618 619=head2 Color Schemes 620 621The following schemes are available by default: 622 623=over 624 625=item X 626 627About 750 color names used in X-Windows (although about 90+ of them are 628duplicate names with spaces). 629 630=item HTML 631 63216 common color names defined in the HTML 4.0 specification. These 633names are also used with older CSS and SVG specifications. (You may 634want to see L<Graphics::ColorNames::SVG> for a complete list.) 635 636=item Netscape 637 638100 color names names associated Netscape 1.1 (I cannot determine whether 639they were once usable in Netscape or were arbitrary names for RGB values-- 640many of these names are not recognized by later versions of Netscape). 641 642This scheme may be deprecated in future versions, but available as a 643separate module. 644 645=item Windows 646 64716 commom color names used with Microsoft Windows and related 648products. These are actually the same colors as the L</HTML> scheme, 649although with different names. 650 651=back 652 653Rather than a color scheme, the path or open filehandle for a 654F<rgb.txt> file may be specified. 655 656Additional color schemes may be available on CPAN. 657 658=head2 Custom Color Schemes 659 660You can add naming scheme files by creating a Perl module is the name 661C<Graphics::ColorNames::SCHEMENAME> which has a subroutine named 662C<NamesRgbTable> that returns a hash of color names and RGB values. 663(Schemes with a different base namespace will require the fill namespace 664to be given.) 665 666The color names must be in all lower-case, and the RGB values must be 66724-bit numbers containing the red, green, and blue values in most- significant 668to least- significant byte order. 669 670An example naming schema is below: 671 672 package Graphics::ColorNames::Metallic; 673 674 sub NamesRgbTable() { 675 use integer; 676 return { 677 copper => 0xb87333, 678 gold => 0xcd7f32, 679 silver => 0xe6e8fa, 680 }; 681 } 682 683You would use the above schema as follows: 684 685 tie %colors, 'Graphics::ColorNames', 'Metallic'; 686 687The behavior of specifying multiple keys with the same name is undefined 688as to which one takes precedence. 689 690As of version 2.10, case, spaces and punctuation are ignored in color 691names. So a name like "Willy's Favorite Shade-of-Blue" is treated the 692same as "willysfavoroteshadeofblue". (If your scheme does not include 693duplicate entrieswith spaces and punctuation, then the minimum 694version of L<Graphics::ColorNames> should be 2.10 in your requirements.) 695 696An example of an additional module is the L<Graphics::ColorNames::Mozilla> 697module by Steve Pomeroy. 698 699Since version 1.03, C<NamesRgbTable> may also return a code reference: 700 701 package Graphics::ColorNames::Orange; 702 703 sub NamesRgbTable() { 704 return sub { 705 my $name = shift; 706 return 0xffa500; 707 }; 708 } 709 710See L<Graphics::ColorNames::GrayScale> for an example. 711 712=head2 Graphics::ColourNames 713 714The alias "Graphics::ColourNames" (British spelling) is no longer available 715as of version 2.01. 716 717It seems absurd to maintain it when all the modules does is provide an 718alternative spelling for the module I<name> without doing anything about 719the component colors of each scheme, and when most other modules 720(and non-Perl software) does not bother with such things. 721 722=head1 SEE ALSO 723 724L<Color::Library> provides an extensive library of color schemes. A notable 725difference is that it supports more complex schemes which contain additional 726information about individual colors and map multiple colors to a single name. 727 728L<Color::Rgb> has a similar function to this module, but parses an 729F<rgb.txt> file. 730 731L<Graphics::ColorObject> can convert between RGB and other color space 732types. 733 734L<Acme::AutoColor> provides subroutines corresponding to color names. 735 736=begin readme 737 738=head1 REVISION HISTORY 739 740Changes since the last release: 741 742=for readme include file=Changes start=^2.11 stop=^2.04 type=text 743 744More details can be found in the F<Changes> file. 745 746=end readme 747 748=for readme continue 749 750=head1 AUTHOR 751 752Robert Rothenberg <rrwo at cpan.org> 753 754=for readme stop 755 756=head2 Acknowledgements 757 758Alan D. Salewski <alans at cji.com> for feedback and the addition of 759C<tuple2hex>. 760 761Steve Pomeroy <xavier at cpan.org>, "chemboy" <chemboy at perlmonk.org> 762and "magnus" <magnus at mbox604.swipnet.se> who pointed out issues 763with various color schemes. 764 765=head2 Suggestions and Bug Reporting 766 767Feedback is always welcome. Please use the CPAN Request Tracker at 768L<http://rt.cpan.org> to submit bug reports. 769 770There is a Sourceforge project for this package at 771L<http://sourceforge.net/projects/colornames/>. 772 773If you create additional color schemes, please make them available 774separately in CPAN rather than submit them to me for inclusion into 775this module. 776 777=for readme continue 778 779=head1 LICENSE 780 781Copyright (c) 2001-2008 Robert Rothenberg. All rights reserved. 782This program is free software; you can redistribute it and/or 783modify it under the same terms as Perl itself. 784 785=cut 786