File Coverage

blib/lib/GD/Graph/colour.pm
Criterion Covered Total %
statement 36 76 47.3
branch 12 32 37.5
condition 1 3 33.3
subroutine 8 16 50.0
pod 6 10 60.0
total 63 137 45.9


line stmt bran cond sub pod time code
1             #==========================================================================
2             # Copyright (c) 1995-1998 Martien Verbruggen
3             #--------------------------------------------------------------------------
4             #
5             # Name:
6             # GD::Graph::colour.pm
7             #
8             # Description:
9             # Package of colour manipulation routines, to be used
10             # with GD::Graph.
11             #
12             # $Id: colour.pm,v 1.10 2005/12/14 04:09:40 ben Exp $
13             #
14             #==========================================================================
15              
16            
17             package GD::Graph::colour;
18              
19             ($GD::Graph::colour::VERSION) = '$Revision: 1.10 $' =~ /\s([\d.]+)/;
20              
21             =head1 NAME
22              
23             GD::Graph::colour - Colour manipulation routines for use with GD::Graph
24              
25             =head1 SYNOPSIS
26              
27             use GD::Graph::colour qw(:colours :lists :files :convert);
28              
29             =head1 DESCRIPTION
30              
31             The B package provides a few routines to work with
32             colours. The functionality of this package is mainly defined by what is
33             needed, now and historically, by the GD::Graph modules.
34              
35             =cut
36              
37 1     1   6024 use vars qw( @EXPORT_OK %EXPORT_TAGS );
  1         2  
  1         53  
38 1     1   5 use strict;
  1         2  
  1         26  
39             require Exporter;
40 1     1   10 use Carp;
  1         2  
  1         1174  
41              
42             @GD::Graph::colour::ISA = qw( Exporter );
43              
44             @EXPORT_OK = qw(
45             _rgb _luminance _hue add_colour
46             colour_list sorted_colour_list
47             read_rgb
48             hex2rgb rgb2hex
49             );
50             %EXPORT_TAGS = (
51             colours => [qw( add_colour _rgb _luminance _hue )],
52             lists => [qw( colour_list sorted_colour_list )],
53             files => [qw( read_rgb )],
54             convert => [qw( hex2rgb rgb2hex )],
55             );
56              
57             my %RGB = (
58             white => [0xFF,0xFF,0xFF],
59             lgray => [0xBF,0xBF,0xBF],
60             gray => [0x7F,0x7F,0x7F],
61             dgray => [0x3F,0x3F,0x3F],
62             black => [0x00,0x00,0x00],
63             lblue => [0x00,0x00,0xFF],
64             blue => [0x00,0x00,0xBF],
65             dblue => [0x00,0x00,0x7F],
66             gold => [0xFF,0xD7,0x00],
67             lyellow => [0xFF,0xFF,0x00],
68             yellow => [0xBF,0xBF,0x00],
69             dyellow => [0x7F,0x7F,0x00],
70             lgreen => [0x00,0xFF,0x00],
71             green => [0x00,0xBF,0x00],
72             dgreen => [0x00,0x7F,0x00],
73             lred => [0xFF,0x00,0x00],
74             red => [0xBF,0x00,0x00],
75             dred => [0x7F,0x00,0x00],
76             lpurple => [0xFF,0x00,0xFF],
77             purple => [0xBF,0x00,0xBF],
78             dpurple => [0x7F,0x00,0x7F],
79             lorange => [0xFF,0xB7,0x00],
80             orange => [0xFF,0x7F,0x00],
81             pink => [0xFF,0xB7,0xC1],
82             dpink => [0xFF,0x69,0xB4],
83             marine => [0x7F,0x7F,0xFF],
84             cyan => [0x00,0xFF,0xFF],
85             lbrown => [0xD2,0xB4,0x8C],
86             dbrown => [0xA5,0x2A,0x2A],
87             );
88              
89             =head1 FUNCTIONS
90              
91             =head2 colour_list( I )
92              
93             Returns a list of I colour names known to the package.
94             Exported with the :lists tag.
95              
96             =cut
97              
98             sub colour_list
99             {
100 4 100   4 1 116 my $n = ( $_[0] ) ? $_[0] : keys %RGB;
101 4         121 return (keys %RGB)[0 .. $n-1];
102             }
103              
104             =head2 sorted_colour_list( I )
105              
106             Returns a list of I colour names known to the package,
107             sorted by luminance or hue.
108             B Right now it always sorts by luminance. Will add an option in a later
109             stage to decide sorting method at run time.
110             Exported with the :lists tag.
111              
112             =cut
113              
114             sub sorted_colour_list
115 0         0 {
116 0 0   0 1 0 my $n = $_[0] ? $_[0] : keys %RGB;
117 0         0 return (sort by_luminance keys %RGB)[0 .. $n-1];
118             # return (sort by_hue keys %rgb)[0..$n-1];
119              
120 0     0 0 0 sub by_luminance { _luminance(@{$RGB{$b}}) <=> _luminance(@{$RGB{$a}}) }
  0         0  
  0         0  
121 0     0 0 0 sub by_hue { _hue(@{$RGB{$b}}) <=> _hue(@{$RGB{$a}}) }
  0         0  
  0         0  
122             }
123              
124             =head2 _rgb( I )
125              
126             Returns a list of the RGB values of I. if the colour name
127             is a string of the form that is acceptable to the hex2rgb sub, then the
128             colour will be added to the list dynamically.
129             Exported with the :colours tag.
130              
131             =cut
132              
133             my %warned_clrs = ();
134              
135             # return the RGB values of the colour name
136             sub _rgb
137             {
138 2 50   2   61 my $clr = shift or return;
139              
140             # Try adding the colour if it doesn't exist yet. It may be of a
141             # parseable form
142 2 100       9 add_colour($clr) unless exists $RGB{$clr};
143              
144 2         5 my $rgb_ref = $RGB{$clr};
145 2 50       7 if (!defined $rgb_ref)
146             {
147 0         0 $rgb_ref = $RGB{'black'};
148 0 0       0 unless ($warned_clrs{$clr})
149             {
150 0         0 $warned_clrs{$clr}++;
151 0         0 carp "Colour $clr is not defined, reverting to black";
152             }
153             };
154              
155 2         5 @{$rgb_ref};
  2         9  
156             }
157              
158             =head2 _hue( I )
159              
160             Returns the hue of the colour with the specified RGB values.
161             Exported with the :colours tag.
162              
163             =head2 _luminance( I )
164              
165             Returns the luminance of the colour with the specified RGB values.
166             Exported with the :colours tag.
167              
168             =cut
169              
170             # return the luminance of the colour (RGB)
171             sub _luminance
172             {
173 0     0   0 (0.212671 * $_[0] + 0.715160 * $_[1] + 0.072169 * $_[2])/0xFF
174             }
175              
176             # return the hue of the colour (RGB)
177             sub _hue
178             {
179 0     0   0 ($_[0] + $_[1] + $_[2])/(3 * 0xFF)
180             }
181              
182             =head2 add_colour(colourname => [$r, $g, $b]) or
183             add_colour('#7fe310')
184              
185             Self-explanatory.
186             Exported with the :colours tag.
187              
188             =cut
189              
190             sub add_colour
191             {
192 2     2 1 13 my $name = shift;
193 2         3 my $val = shift;
194              
195 2 100       10 if (!defined $val)
196             {
197 1 50       4 my @rgb = hex2rgb($name) or return;
198 1         5 $val = [@rgb];
199             }
200              
201 2 50 33     17 if (ref $val && ref $val eq 'ARRAY')
202             {
203 2         4 $RGB{$name} = [@{$val}];
  2         8  
204 2         7 return $name;
205             }
206              
207 0         0 return;
208             }
209              
210             =head2 rgb2hex($red, $green, $blue)
211              
212             =head2 hex2rgb('#7fe310')
213              
214             These functions translate a list of RGB values into a hexadecimal
215             string, as is commonly used in HTML and the Image::Magick API, and vice
216             versa.
217             Exported with the :convert tag.
218              
219             =cut
220              
221             # Color translation
222             sub rgb2hex
223             {
224 1 50   1 1 62 return unless @_ == 3;
225 1         3 my $color = '#';
226 1         3 foreach my $cc (@_)
227             {
228 3         12 $color .= sprintf("%02x", $cc);
229             }
230 1         6 return $color;
231             }
232              
233             sub hex2rgb
234             {
235 2     2 1 94 my $clr = shift;
236 2         15 my @rgb = $clr =~ /^#([a-f0-9]{2})([a-f0-9]{2})([a-f0-9]{2})$/i;
237 2 50       11 return unless @rgb;
238 2         4 return map { hex $_ } @rgb;
  6         21  
239             }
240              
241             =head2 read_rgb( F )
242              
243             Reads in colours from a rgb file as used by the X11 system.
244              
245             Doing something like:
246              
247             use GD::Graph::bars;
248             use GD::Graph::colour;
249              
250             GD::Graph::colour::read_rgb("rgb.txt") or die "cannot read colours";
251              
252             Will allow you to use any colours defined in rgb.txt in your graph.
253             Exported with the :files tag.
254              
255             =cut
256              
257             #
258             # Read a rgb.txt file (X11)
259             #
260             # Expected format of the file:
261             #
262             # R G B colour name
263             #
264             # Fields can be separated by any number of whitespace
265             # Lines starting with an exclamation mark (!) are comment and
266             # will be ignored.
267             #
268             # returns number of colours read
269              
270             sub read_rgb($) # (filename)
271             {
272 0     0 1   my $fn = shift;
273 0           my $n = 0;
274 0           my $line;
275              
276 0 0         open(RGB, $fn) or return 0;
277              
278 0           while (defined($line = ))
279             {
280 0 0         next if ($line =~ /\s*!/);
281 0           chomp($line);
282              
283             # remove leading white space
284 0           $line =~ s/^\s+//;
285              
286             # get the colours
287 0           my ($r, $g, $b, $name) = split(/\s+/, $line, 4);
288            
289             # Ignore bad lines
290 0 0         next unless (defined $name);
291              
292 0           $RGB{$name} = [$r, $g, $b];
293 0           $n++;
294             }
295              
296 0           close(RGB);
297              
298 0           return $n;
299             }
300              
301 0     0 0   sub version { $GD::Graph::colour::VERSION }
302              
303             sub dump_colours
304             {
305 0 0   0 0   my $max = $_[0] ? $_[0] : keys %RGB;
306 0           my $n = 0;
307              
308 0           my $clr;
309 0           foreach $clr (sorted_colour_list($max))
310             {
311 0 0         last if $n > $max;
312 0           print "colour: $clr, " .
313 0           "${$RGB{$clr}}[0], ${$RGB{$clr}}[1], ${$RGB{$clr}}[2]\n"
  0            
  0            
314             }
315             }
316              
317              
318             "Just another true value";
319              
320             __END__