1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
#!/usr/bin/perl
use strict;
use Test::More tests => 54;
use Test::Exception;
use_ok('Graphics::ColorNames', '2.10', qw( hex2tuple tuple2hex all_schemes ));
{
my %schemes = map { $_=>1, } all_schemes();
ok((keys %schemes) >= 4); # Windows, Netscape, HTML, and X
ok($schemes{X});
ok($schemes{HTML});
ok($schemes{Windows});
ok($schemes{Netscape});
}
tie my %colors, 'Graphics::ColorNames';
ok(tied %colors);
my $count = 0;
foreach my $name (keys %colors)
{
my @RGB = hex2tuple($colors{$name});
$count++, if (tuple2hex(@RGB) eq $colors{$name} );
}
ok($count == keys %colors);
$count = 0;
foreach my $name (keys %colors)
{
$count++, if ($colors{lc($name)} eq $colors{uc($name)});
}
ok($count == keys %colors);
$count = 0;
foreach my $name (keys %colors)
{
$count++, if (exists($colors{$name}))
}
ok($count == keys %colors);
$count = 0;
foreach my $name (keys %colors)
{
my $rgb = $colors{$name};
$count++, if (defined $colors{$rgb});
$count++, if (defined $colors{"\x23".$rgb});
}
ok($count == (2*(keys %colors)));
# Test CLEAR, DELETE and STORE as returning errors
dies_ok { undef %colors } "undef %colors";
dies_ok { %colors = (); } "%colors = ()";
dies_ok { $colors{MyCustomColor} = 'FFFFFF'; } "STORE";
dies_ok { delete($colors{MyCustomColor}); } "DELETE";
# Test RGB values being passed through
foreach my $rgb (qw(
000000 000001 000010 000100 001000 010000 100000
111111 123abc abc123 123ABC ABC123 abcdef ABCDEF
)) {
ok($colors{ "\x23" . $rgb } eq lc($rgb));
ok($colors{ $rgb } eq lc($rgb));
}
# Test using multiple schemes, with issues in overlapping
tie my %colors2, 'Graphics::ColorNames', qw( X Netscape );
ok(!exists $colors{Silver}); # Silver doesn't exist in X
ok(defined $colors2{Silver}); # It does in Netscape
# Test precedence
ok($colors{DarkGreen} eq '006400'); # DarkGreen in X
ok($colors2{DarkGreen} eq '006400'); # DarkGreen in X
ok($colors2{DarkGreen} ne '2f4f2f'); # DarkGreen in Netscape
tie my %colors3, 'Graphics::ColorNames', qw( Netscape X );
ok($colors{Brown} eq 'a52a2a'); # Brown in X
ok($colors2{Brown} eq 'a52a2a'); # Brown in X (don't try Netscape)
ok($colors3{Brown} eq 'a62a2a'); # Brown in Netscape (don't try X)
# Test handling of non-existent color names
ok(!defined $colors{NonExistentColorName});
ok(!exists $colors{NonExistentColorName});
# Test dynamic loading of scheme
my $colorobj = tied(%colors);
$colorobj->load_scheme({ nonexistentcolorname => 0x123456 } );
ok($colors{NonExistentColorName} eq '123456');
|
