Skip to content

Commit ccf3ed2

Browse files
lichtkindlichtkind
committed
draf format imlementation further
1 parent 8007e30 commit ccf3ed2

File tree

3 files changed

+38
-73
lines changed

3 files changed

+38
-73
lines changed

‎lib/Graphics/Toolkit/Color/Space.pm

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ sub new {
1414
return $basis unless ref $basis;
1515
my $shape = Graphics::Toolkit::Color::Space::Shape->new( $basis, $args{'type'}, $args{'range'}, $args{'precision'} );
1616
return $shape unless ref $shape;
17-
my $format = Graphics::Toolkit::Color::Space::Format->new( $basis, $shape, $args{'suffix'} );
17+
my $format = Graphics::Toolkit::Color::Space::Format->new( $basis, $args{'suffix'} );
1818
return $format unless ref $format;
1919
bless { basis => $basis, shape => $shape, format => $format, convert => {} };
2020
}

‎lib/Graphics/Toolkit/Color/Space/Format.pm

Lines changed: 30 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,9 @@ use warnings;
66
package Graphics::Toolkit::Color::Space::Format;
77

88
sub new {
9-
my ($pkg, $basis, $shape, $suffix ) = @_;
9+
my ($pkg, $basis, $suffix ) = @_;
1010
return 'first argument has to be an Color::Space::Basis reference'
1111
unless ref $basis eq 'Graphics::Toolkit::Color::Space::Basis';
12-
return 'second argument (axis names) has to be an Color::Space::Shape reference'
13-
unless ref $shape eq 'Graphics::Toolkit::Color::Space::Shape';
1412

1513
my $count = $basis->count;
1614
$suffix = [('') x $count] unless defined $suffix;
@@ -21,23 +19,22 @@ sub new {
2119
# format --> tuple
2220
my %deformats = ( hash => sub { $basis->tuple_from_hash(@_) if $basis->is_hash(@_) },
2321
named_array => sub { [ @{$_[0]}[1 .. $#{$_[0]}] ] if is_named_array(@_) },
24-
string => sub { tuple_from_string(@_) if is_string(@_) },
22+
string => sub { tuple_from_string(@_) if is_named_string(@_) },
2523
css_string => sub { tuple_from_css(@_) if is_css_string(@_) },
2624
);
2725
# tuple --> format
2826
my %formats = (list => sub { @$_ }, # 1, 2, 3
2927
hash => sub { $basis->long_hash_from_tuple(@_) }, # { red => 1, green => 2, blue => 3 }
3028
char_hash => sub { $basis->short_hash_from_tuple(@_) }, # { r =>1, g => 2, b => 3 }
3129
array => sub { [$basis->space_name, @$_] }, # ['rgb',1,2,3]
32-
string => sub { named_string_from_list(@_) }, # 'rgb: 1, 2, 3'
33-
css_string => sub { css_string_from_list(@_) }, # 'rgb(1,2,3)'
30+
string => sub { named_string_from_tuple(@_) }, # 'rgb: 1, 2, 3'
31+
css_string => sub { css_string_from_tuple(@_) }, # 'rgb(1,2,3)'
3432
);
35-
bless { basis => $basis, shape => $shape, suffix => $suffix, format => \%formats, deformat => \%deformats, }
33+
bless { basis => $basis, suffix => $suffix, format => \%formats, deformat => \%deformats, }
3634
}
3735

3836
########################################################################
3937
sub basis { $_[0]{'basis'}}
40-
4138
sub has_format { (defined $_[1] and exists $_[0]{'format'}{ lc $_[1] }) ? 1 : 0 }
4239
sub has_deformat { (defined $_[1] and exists $_[0]{'deformat'}{ lc $_[1] }) ? 1 : 0 }
4340
sub add_formatter {
@@ -55,17 +52,18 @@ sub add_deformatter {
5552
########################################################################
5653

5754
sub format {
58-
my ($self, $values, $format) = @_;
55+
my ($self, $values, $format, $suffix) = @_;
5956
return unless $self->basis->is_value_tuple( $values );
57+
$values = self->add_suffix($values, $suffix);
6058
$self->{'format'}{ lc $format }->(@$values) if $self->has_format( $format );
6159
}
6260

6361
sub deformat {
64-
my ($self, $color) = @_;
62+
my ($self, $color, $suffix) = @_;
6563
return undef unless defined $color;
6664
for my $deformatter (values %{$self->{'deformat'}}){
6765
my $values = $deformatter->( $color );
68-
return $values if $self->basis->is_value_tuple( $values );
66+
return self->remove_suffix($values, $suffix) if $self->basis->is_value_tuple( $values );
6967
}
7068
return undef;
7169
}
@@ -86,99 +84,65 @@ sub remove_suffix {
8684
$suffix = [($suffix) x $self->basis->count] unless ref $suffix;
8785
[ map { ($self->{'suffix'}[$_] and
8886
substr( $values->[$_], - length($self->{'suffix'}[$_])) eq $self->{'suffix'}[$_])
89-
? (substr( $values->[$_], 0, length($values->[$_]) - length($self->{'suffix'}[$_]))) : $values->[$_] } $self->iterator ];
87+
? (substr( $values->[$_], 0, length($values->[$_]) - length($self->{'suffix'}[$_]))) : $values->[$_] } $self->basis->iterator ];
9088
}
9189

9290
########################################################################
9391

94-
########################################################################
95-
96-
sub is_string { #
92+
sub is_named_string { #
9793
my ($self, $string) = @_;
9894
return 0 unless defined $string and not ref $string;
9995
$string = lc $string;
100-
my $name = lc $self->name;
96+
my $name = lc $self->basis->space_name;
10197
return 0 unless index($string, $name.':') == 0;
10298
my $nr = '\s*-?\d+(?:\.\d+)?\s*';
103-
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->count);
99+
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->basis->count);
104100
($string =~ /^$name:$nrs$/) ? 1 : 0;
105101
}
106102
sub is_css_string {
107103
my ($self, $string) = @_;
108104
return 0 unless defined $string and not ref $string;
109105
$string = lc $string;
110-
my $name = lc $self->name;
106+
my $name = lc $self->basis->space_name;
111107
return 0 unless index($string, $name.'(') == 0;
112108
my $nr = '\s*-?\d+(?:\.\d+)?\s*';
113-
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->count);
109+
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->basis->count);
114110
($string =~ /^$name\($nrs\)$/) ? 1 : 0;
115111
}
116112
sub is_named_array {
117113
my ($self, $value_array) = @_;
118-
(ref $value_array eq 'ARRAY' and @$value_array == ($self->{'count'}+1)
119-
and uc $value_array->[0] eq uc $self->name) ? 1 : 0;
120-
}
121-
122-
########################################################################
123-
124-
########################################################################
125-
126-
sub list_from_hash {
127-
my ($self, $value_hash) = @_;
128-
return undef unless ref $value_hash eq 'HASH' and CORE::keys %$value_hash == $self->{'count'};
129-
my @values = (0) x $self->{'count'};
130-
for my $value_key (CORE::keys %$value_hash) {
131-
if ($self->is_key( $value_key )) { $values[ $self->{'key_order'}{ lc $value_key } ] = $value_hash->{ $value_key } }
132-
elsif ($self->is_shortcut( $value_key )) { $values[ $self->{'shortcut_order'}{ lc $value_key } ] = $value_hash->{ $value_key } }
133-
else { return }
134-
}
135-
return @values;
136-
}
137-
138-
sub deformat_partial_hash {
139-
my ($self, $value_hash) = @_;
140-
return unless ref $value_hash eq 'HASH';
141-
my @keys_got = CORE::keys %$value_hash;
142-
return unless @keys_got and @keys_got <= $self->{'count'};
143-
my $result = {};
144-
for my $key (@keys_got) {
145-
if ($self->is_key( $key )) { $result->{ int $self->key_pos( $key ) } = $value_hash->{ $key } }
146-
elsif ($self->is_shortcut( $key )){ $result->{ int $self->shortcut_pos( $key ) } = $value_hash->{ $key } }
147-
else { return undef }
148-
}
149-
return $result;
114+
(ref $value_array eq 'ARRAY' and @$value_array == ($self->basis->count+1)
115+
and uc $value_array->[0] eq uc $self->basis->space_name) ? 1 : 0;
150116
}
151117

152118
########################################################################
153119

154-
sub list_from_string {
120+
sub tuple_from_string {
155121
my ($self, $string) = @_;
156122
my @parts = split(/:/, $string);
157-
return split(/,/, $parts[1]);
123+
return [split(/,/, $parts[1])];
158124
}
159125

160-
sub list_from_css {
126+
sub tuple_from_css {
161127
my ($self, $string) = @_;
162128
1 until chop($string) eq ')';
163129
my @parts = split(/\(/, $string);
164-
return split(/,/, $parts[1]);
130+
return [split(/,/, $parts[1])];
165131
}
166132

167-
sub named_array_from_list {
168-
my ($self, @values) = @_;
169-
return [lc $self->name, @values] if @values == $self->{'count'};
133+
sub named_array_from_tuple {
134+
my ($self, $values) = @_;
135+
return [$self->basis->space_name, @$values] unless $self->basis->is_value_tuple( $values );
170136
}
171137

172-
sub named_string_from_list {
173-
my ($self, @values) = @_;
174-
return unless @values == $self->{'count'};
175-
lc( $self->name).': '.join(', ', @values);
138+
sub named_string_from_tuple {
139+
my ($self, $values) = @_;
140+
lc( $self->basis->space_name).': '.join(', ', @$values);
176141
}
177142

178-
sub css_string_from_list {
179-
my ($self, @values) = @_;
180-
return unless @values == $self->{'count'};
181-
lc( $self->name).'('.join(',', @values).')';
143+
sub css_string_from_tuple {
144+
my ($self, $values) = @_;
145+
lc( $self->basis->space_name).'('.join(',', @$values).')';
182146
}
183147

184148
1;

‎t/04_space_format.t

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,16 @@ use warnings;
55
use Test::More tests => 153;
66

77
BEGIN { unshift @INC, 'lib', '../lib'}
8-
my $module = 'Graphics::Toolkit::Color::Space::Basis';
8+
my $module = 'Graphics::Toolkit::Color::Space::Format';
99

10-
eval "use $module";
11-
is( not($@), 1, 'could load the module');
10+
use_ok( $module, 'could load the module');
11+
use Graphics::Toolkit::Color::Space::Basis;
12+
my $basis = Graphics::Toolkit::Color::Space::Basis->new([qw/alpha beta gamma/]);
1213

13-
my $obj = Graphics::Toolkit::Color::Space::Basis->new();
14-
like( $obj, qr/first argument/, 'constructor needs arguments');
14+
my $obj = Graphics::Toolkit::Color::Space::Format->new( );
15+
like( $obj, qr/first argument/, 'constructor needs basis as first argument');
1516

16-
$obj = Graphics::Toolkit::Color::Space::Basis->new([1]);
17+
$obj = Graphics::Toolkit::Color::Space::Format->new( $basis );
1718
is( ref $obj, $module, 'one constructor argument is enough');
1819

1920
my $bad = Graphics::Toolkit::Color::Space::Basis->new(qw/Aleph beth gimel daleth he/);

0 commit comments

Comments
 (0)