1: =head1 NAME
2:
3: Graphics::ACT - A module to manipulate Photoshop Style Color Tables (.act)
4:
5: =head1 DESCRIPTION
6:
7: Foobar.ACT are color table files that come with Adobe Photoshop.
8: Adobe Photoshop expects them to have exactly 256 entries(go figure).
9: Each color is represented by 3 bytes corresponding to RGB.
10: Other applications probably use these types of color tables, but I don't know that.
11:
12: =head1 SYNOPSIS
13:
14: use Graphics::ACT;
15: #
16: use strict;
17: BEGIN{eval'use warnings;'; $^W=1 if$@;}# must to have some kind of warning
18: #
19: dumpAsHtml($_) for @ARGV;
20: #
21: sub dumpAsHtml {
22: local $\="\n";
23: my $file = shift;
24: my $cT = Graphics::ACT->new($file);
25: my $s = $cT->size();
26: print "<h1>$file = $s colors</h1>";
27: print "<table border=1>";
28: while($cT->canRead){
29: print "<tr>";
30: for(1..8){
31: my $color = $cT->getColor(1);
32: print qq[<td bgcolor="#$color">#$color</td>];
33: }
34: print "</tr>";
35: }
36: print "</table>";
37: }
38: __END__
39:
40: #create the infamous 'Black Body' color table (can't make fire without it)
41: use Graphics::ACT;
42: use strict;
43: BEGIN{eval'use warnings;'; $^W=1 if$@;}# must to have some kind of warning
44: #
45: Fyack(
46: [ 255, 0, 0 ] => [ 255, 255, 0 ],
47: Graphics::ACT->new('black.body',1)
48: );
49: #
50: sub Fyack {
51: my( $one, $two, $yF) = @_;
52: $yF->YuckFoo( 85, [0,0,0] => $one );
53: $yF->YuckFoo( 85, $one => $two );
54: $yF->YuckFoo( 86, $two => [255,255,255] );
55: }
56:
57: =cut
58:
59: package Graphics::ACT;
60: use Carp;
61: use IO::File();
62: use vars qw[ $VERSION ];
63: $VERSION = 0.1;
64:
65: use strict;
66: BEGIN{eval q[use warnings];}
67:
68: =head1 METHODS
69:
70: =head2 C<new>
71:
72: This is the constructor. It takes 2 arguments:
73:
74: =over 4
75:
76: =item C<$file>
77:
78: A required argument, a filename of a color table to read/create.
79:
80: =item C<$w>
81:
82: Optional. If you pass a true value, C<$file> will be clobbered,
83: and L<C<canRead>|"canRead"> will always return undef.
84:
85: If you pass a false value (or none), L<C<canWrite>|"canWrite"> will always return undef.
86:
87: =back
88:
89: =cut
90:
91: sub new {
92: my( $class, $file, $w ) = @_;
93:
94: croak " you need to pass a filename to new" unless $file;
95:
96: my $self = { fileN => $file, w => $w ? 1 : 0 };
97: my $fh = new IO::File($file, $self->{w} ? 'w' : 'r');
98:
99: croak "couldn't create a filehandle $! $@" unless defined $fh;
100:
101: binmode $fh;
102: $self->{fileH} = $fh;
103: $self->{fileS} = -s $fh;
104: $self->{size} = $self->{fileS} / 3; #/
105:
106: croak "file size ain't divisible by 3, this color table is corrupted"
107: if int $self->{size} != $self->{size};
108:
109: return bless $self, $class;
110: }
111:
112:
113:
114: =head2 C<canRead>
115:
116: Returns 1 if the filehandle is still open (if $w was true), and undef otherwise.
117:
118: =cut
119:
120: sub canRead {
121: return not eof $_[0]->{fileH} unless $_[0]->{w};
122: return undef;
123: }
124:
125: =head2 C<canWrite>
126:
127: If you created a new color table($w was true), returns C<fileno> of the filehandle, and undef otherwise.
128:
129: =cut
130:
131: sub CanWrite {
132: return fileno $_[0]->{fileH} if $_[0]->{w};
133: return undef;
134: }
135:
136: =head2 C<getColor>
137:
138: Optionally takes a true value as an argument, and returns a hex string color representation.
139: Returns an arrayref of rgb colors otherwise, like:
140:
141: $VAR1 = [ 255, 255, 255 ];
142:
143: B<BEWARE>, this method does not check if it L<C<canRead>|"canRead">.
144:
145: =cut
146:
147: sub getColor {
148: my( $self, $asHex ) = @_;
149: my $rgb = "";
150: my $stat = read($self->{fileH},$rgb,3);
151: unless(defined $stat or $stat == 3){
152: carp(" Didn't read 3 bytes (a color) $! $@");
153: return undef;
154: }else{
155: if($asHex){
156: $rgb = unpack 'h*', $rgb;
157: }else{
158: $rgb = [ unpack 'C*', $rgb];
159: }
160: }
161: return $rgb;
162: }
163:
164:
165: =head2 C<putColor>
166:
167: This method requires 1 argument, a color, either a 6-digit hex string,
168: or an array ref (basically what L<C<getColor>|"getColor"> returns).
169:
170: B<BEWARE>, this method does not check if it L<C<canWrite>|"canWrite">.
171:
172: B<BEWARE>, this method does not check to see if you're passing a valid color
173: ( a valid color would be one with RGB values ranging from 0 to 255).
174:
175: =cut
176:
177:
178: sub putColor{
179: my( $self, $color ) = @_;
180: unless($color){
181: carp "you need to pass a color to putColor()";
182: return();
183: }elsif(ref $color eq 'ARRAY'){
184: $color = join '', map { pack('c',$_) } @$color;
185: }else{
186: $color = join '', pack 'h*', $color;
187: }
188:
189: my $fh = $self->{fileH};
190: print $fh $color;
191: }
192:
193: =head2 C<size>
194:
195: Returns the size of the Color Table (should be 256, every .act file i've encountered is)
196:
197: =cut
198:
199: sub size { return $_[0]->{size} }
200:
201: =head2 C<YuckFoo>
202:
203: A utility method for creating gradients courtesy of the perlmonk YuckFoo.
204:
205: my $colorTable = Graphics::ACT->new('grayscale.act',1);
206: $colorTable->(256, [0,0,0] => [255,255,255] ); # write a grayscale color table
207:
208: B<BEWARE>, this method does not check if it L<C<canWrite>|"canWrite">.
209:
210: It takes 3 arguments:
211:
212: =over 4
213:
214: =item C<$steps>
215:
216: The nuber of color create.
217: If you call this method more than once, you should probably make sure the steps add up to 256.
218:
219: =item C<$beg>
220:
221: A beginning color (array ref only)
222:
223: =item C<$end>
224:
225: An ending color (array ref only)
226:
227: =back
228:
229: =cut
230:
231: sub YuckFoo {
232: my( $self, $steps, $beg, $end) = @_;
233:
234: # RGB rate of change from beginning to ending color
235: my @delta = (
236: ($$end[0] - $$beg[0]) / ($steps-1),
237: ($$end[1] - $$beg[1]) / ($steps-1),
238: ($$end[2] - $$beg[2]) / ($steps-1),
239: );
240:
241: # Calculate colors using beginning color and rate of change
242: my $i = 0;
243: while($i < $steps) {
244: my $color = [
245: $$beg[0] + $i * $delta[0],
246: $$beg[1] + $i * $delta[1],
247: $$beg[2] + $i * $delta[2]
248: ];
249: $self->putColor($color);
250: $i++;
251: }
252: }
253:
254:
255: 1;
256:
257:
258: =head1 AUTHOR
259:
260: D.H. <podmaster@cpan.org>
261:
262: =head1 LICENSE
263:
264: copyright (c) D.H. 2002
265: All rights reserved.
266:
267: This program is released under the same terms as perl itself.
268: If you don't know what that means, visit http://perl.com
269: or execute C<perl -v> at a commandline (assuming you have perl installed).
270:
271: =cut
272:
273: 1;