File Coverage

lib/Graphics/Fig/Color.pm
Criterion Covered Total %
statement 50 85 58.8
branch 7 22 31.8
condition 1 6 16.6
subroutine 8 10 80.0
pod 0 3 0.0
total 66 126 52.3


line stmt bran cond sub pod time code
1             #
2             # XFig Drawing Library
3             #
4             # Copyright (c) 2017 D Scott Guthridge
5             #
6             # This program is free software: you can redistribute it and/or modify it under
7             # the terms of the Artistic License as published by the Perl Foundation, either
8             # version 2.0 of the License, or (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful, but WITHOUT
11             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12             # FOR A PARTICULAR PURPOSE. See the Artistic License for more details.
13             #
14             # You should have received a copy of the Artistic License along with this
15             # program. If not, see .
16             #
17             package Graphics::Fig::Color;
18             our $VERSION = 'v1.0.8';
19              
20 12     12   67 use strict;
  12         15  
  12         290  
21 12     12   43 use warnings;
  12         15  
  12         209  
22 12     12   81 use Carp;
  12         17  
  12         496  
23 12     12   4668 use Graphics::ColorNames;
  12         67956  
  12         11236  
24              
25             my %DefaultColors = (
26             default => -1,
27             black => 0,
28             blue => 1,
29             blue1 => 1, # unofficial alias
30             green => 2,
31             green1 => 2, # unofficial alias
32             cyan => 3,
33             cyan1 => 3, # unofficial alias
34             red => 4,
35             red1 => 4, # unofficial alias
36             magenta => 5,
37             magenta1 => 5, # unofficial alias
38             yellow => 6,
39             white => 7,
40             blue4 => 8,
41             blue3 => 9,
42             blue2 => 10,
43             ltblue => 11,
44             green4 => 12,
45             green3 => 13,
46             green2 => 14,
47             cyan4 => 15,
48             cyan3 => 16,
49             cyan2 => 17,
50             red4 => 18,
51             red3 => 19,
52             red2 => 20,
53             magenta4 => 21,
54             magenta3 => 22,
55             magenta2 => 23,
56             brown4 => 24,
57             brown3 => 25,
58             brown => 25, # unofficial alias
59             brown2 => 26,
60             pink4 => 27,
61             pink3 => 28,
62             pink2 => 29,
63             pink1 => 30, # unofficial alias
64             pink => 30,
65             gold => 31,
66             );
67              
68             #
69             # Graphics::Fig::Color::_validateName: validate a color name
70             # $self: object
71             # $name: color name
72             #
73             sub _validateName {
74 0     0   0 my $self = shift;
75 0         0 my $name = shift;
76              
77 0 0       0 if (!($name =~ m/^[^#\s]([^#]*[^# ])?$/)) {
78 0         0 croak("${name}: error: invalid color name");
79             }
80 0         0 return 1;
81             }
82              
83             #
84             # Graphics::Fig::Color::_validateHex validate a hexadecimal color code
85             # $self: object
86             # $hex: hex code
87             #
88             sub _validateHex {
89 11     11   13 my $self = shift;
90 11         13 my $hex = shift;
91              
92 11 50       32 if (!($hex =~ m/^#[[:xdigit:]]{6}$/)) {
93 0         0 croak("${hex}: error: invalid hex color name; #xxxxxx expected");
94             }
95 11         14 return 1;
96             }
97              
98             #
99             # Graphics::Fig::Color::_hexToNumber: map a hex color to xfig color number
100             # $self: object
101             # $hex: hex code
102             #
103             sub _hexToNumber {
104 11     11   15 my $self = shift;
105 11         12 my $hex = shift;
106 11         11 my $hexToNumber = ${$self}{"hexToNumber"};
  11         14  
107 11         13 my $number;
108              
109 11 100       23 if (defined($number = $hexToNumber->{$hex})) {
110 6         14 return $number;
111             }
112              
113 5         13 my $customHex = ${$self}{"customHex"};
  5         9  
114 5 50       6 if ($#{$customHex} == 511) {
  5         14  
115 0         0 croak("error: too many colors");
116             }
117 5         6 $number = 31 + push(@{$customHex}, $hex);
  5         10  
118 5         9 $hexToNumber->{$hex} = $number;
119 5         13 return $number;
120             }
121              
122             #
123             # Graphics::Fig::Color::new: constructor
124             # $proto: prototype
125             #
126             sub new {
127 64     64 0 105 my $proto = shift;
128 64   33     197 my $class = ref($proto) || $proto;
129              
130 64         257 my $self = {
131             nameToNumber => {}, # color name to xfig number
132             hexToNumber => {}, # "#xxxxxx" to xfig number
133             customHex => [], # table of custom hex colors
134             colorNames => undef, # Graphics::ColorNames object
135             };
136 64         455 %{${$self}{"nameToNumber"}} = %DefaultColors;
  64         78  
  64         785  
137              
138 64         192 bless($self, $class);
139 64         368 return $self;
140             }
141              
142             #
143             # Graphics::Fig::Color::convert map color name to xfig number
144             # $self: object
145             # $color: color name or #xxxxxx hex code
146             #
147             sub convert {
148 42     42 0 50 my $self = shift;
149 42         44 my $color = shift;
150 42         38 my $nameToNumber = ${$self}{"nameToNumber"};
  42         52  
151 42         44 my $temp;
152              
153             #
154             # If the mapping already exists in nameToNumber, return it.
155             #
156 42         61 $color = lc($color);
157 42 100       76 if (defined($temp = $nameToNumber->{$color})) {
158 31         56 return $temp;
159             }
160              
161             #
162             # If a hex color was given, validate it.
163             #
164 11 50       40 if ($color =~ m/^#/) {
165 11         26 $self->_validateHex($color);
166 11         17 return $self->_hexToNumber($color);
167             }
168              
169             #
170             # Look for a definition in Graphics::ColorNames.
171             #
172 0           $self->_validateName($color);
173 0 0         if (!defined($self->{"colorNames"})) {
174 0           $self->{"colorNames"} = Graphics::ColorNames->new(qw[X]);
175             }
176 0           $temp = $self->{"colorNames"}->hex($color, '#');
177 0 0 0       if (defined($temp) && $temp ne "") {
178 0           my $number = $self->_hexToNumber($temp);
179 0           $nameToNumber->{$color} = $number;
180 0           return $number;
181             }
182              
183 0           croak("${color}: error: invalid color");
184             }
185              
186             #
187             # Graphics::Fig::Color::define define a custom color
188             # $self: object
189             # $name: color name
190             # $hex: custom color in hex
191             #
192             sub define {
193 0     0 0   my $self = shift;
194 0           my $name = shift;
195 0           my $hex = shift;
196 0           my $nameToNumber = ${$self}{"nameToNumber"};
  0            
197 0           my $number;
198              
199 0           $self->_validateName($name);
200 0           $self->_validateHex($hex);
201 0 0         if (defined($number = $nameToNumber->{$name})) {
202 0 0         if ($number < 32) {
203 0           croak("${name}: error: can't redefine built-in color");
204             }
205 0           my $customHex = ${$self}{"customHex"};
  0            
206 0 0         if ($hex ne ${$customHex}[$number - 32]) {
  0            
207 0           carp("${name}: warning: color redefined");
208             }
209             }
210 0           $number = $self->_hexToNumber($hex);
211 0           $nameToNumber->{$name} = $number;
212 0           return 1;
213             }
214              
215             1;