=head1 NAME

Graphics::ACT - A module to manipulate Photoshop Style Color Tables (.act)

=head1 DESCRIPTION

Foobar.ACT are color table files that come with Adobe Photoshop.
Adobe Photoshop expects them to have exactly 256 entries(go figure).
Each color is represented by 3 bytes corresponding to RGB.
Other applications probably use these types of color tables, but I don't know that.

=head1 SYNOPSIS

    use Graphics::ACT;
                                                            #
    use strict;
    BEGIN{eval'use warnings;'; $^W=1 if$@;}# must to have some kind of warning
                                                            #
    dumpAsHtml($_) for @ARGV;
                                                            #
    sub dumpAsHtml {
        local $\="\n";
        my $file = shift;
        my $cT = Graphics::ACT->new($file);
        my $s = $cT->size();
        print "<h1>$file = $s colors</h1>";
        print "<table border=1>";
        while($cT->canRead){
            print "<tr>";
            for(1..8){
                my $color = $cT->getColor(1);
                print qq[<td bgcolor="#$color">#$color</td>];
            }
            print "</tr>";
        }
        print "</table>";
    }
    __END__

    #create the infamous 'Black Body' color table (can't make fire without it)
    use Graphics::ACT;
    use strict;
    BEGIN{eval'use warnings;'; $^W=1 if$@;}# must to have some kind of warning
                                                            #
    Fyack(
        [ 255, 0, 0 ] => [ 255, 255, 0 ],
        Graphics::ACT->new('black.body',1)
    );
                                                            #
    sub Fyack {
        my( $one, $two, $yF) = @_;
        $yF->YuckFoo( 85, [0,0,0] => $one );
        $yF->YuckFoo( 85, $one => $two );
        $yF->YuckFoo( 86, $two => [255,255,255] );
    }

=cut

package Graphics::ACT;
use Carp;
use IO::File();
use vars qw[ $VERSION ];
$VERSION = 0.1;

use strict;
BEGIN{eval q[use warnings];}

=head1 METHODS

=head2 C<new>

This is the constructor.  It takes 2 arguments:

=over 4

=item C<$file>

A required argument, a filename of a color table to read/create.

=item C<$w>

Optional.  If you pass a true value, C<$file> will be clobbered,
and L<C<canRead>|"canRead"> will always return undef.

If you pass a false value (or none), L<C<canWrite>|"canWrite"> will always return undef.

=back

=cut

sub new {
    my( $class, $file, $w ) = @_;

    croak " you need to pass a filename to new" unless $file;

    my $self = { fileN => $file, w => $w ? 1 : 0 };
    my $fh = new IO::File($file, $self->{w} ? 'w' : 'r');

    croak "couldn't create a filehandle $! $@" unless defined $fh;

    binmode $fh;
    $self->{fileH} = $fh;
    $self->{fileS} = -s $fh;
    $self->{size} = $self->{fileS} / 3; #/

    croak "file size ain't divisible by 3, this color table is corrupted"
    if int $self->{size} != $self->{size};

    return bless $self, $class;
}



=head2 C<canRead>

Returns 1 if the filehandle is still open (if $w was true), and undef otherwise.

=cut

sub canRead {
    return not eof $_[0]->{fileH} unless $_[0]->{w};
    return undef;
}

=head2 C<canWrite>

If you created a new color table($w was true), returns C<fileno> of the filehandle, and undef otherwise.

=cut

sub CanWrite {
    return fileno $_[0]->{fileH} if $_[0]->{w};
    return undef;
}

=head2 C<getColor>

Optionally takes a true value as an argument, and returns a hex string color representation.
Returns an arrayref of rgb colors otherwise, like:

    $VAR1 = [ 255, 255, 255 ];

B<BEWARE>, this method does not check if it L<C<canRead>|"canRead">. 

=cut

sub getColor {
    my( $self, $asHex ) = @_;
    my $rgb = "";
    my $stat = read($self->{fileH},$rgb,3);
    unless(defined $stat or $stat == 3){
        carp(" Didn't read 3 bytes (a color) $! $@");
        return undef;
    }else{
        if($asHex){
            $rgb = unpack 'h*', $rgb;
        }else{
            $rgb = [ unpack 'C*', $rgb];
        }
    }
    return $rgb;
}


=head2 C<putColor>

This method requires 1 argument, a color, either a 6-digit hex string, 
or an array ref (basically what L<C<getColor>|"getColor"> returns).

B<BEWARE>, this method does not check if it L<C<canWrite>|"canWrite">.

B<BEWARE>, this method does not check to see if you're passing a valid color
( a valid color would be one with RGB values ranging from 0 to 255).

=cut


sub putColor{
    my( $self, $color ) = @_;
    unless($color){
        carp "you need to pass a color to putColor()";
        return();
    }elsif(ref $color eq 'ARRAY'){
        $color = join '', map { pack('c',$_) } @$color;
    }else{
        $color = join '', pack 'h*', $color;
    }

    my $fh = $self->{fileH}; 
    print $fh $color;
}

=head2 C<size>

Returns the size of the Color Table (should be 256, every .act file i've encountered is)

=cut

sub size { return $_[0]->{size} }

=head2 C<YuckFoo>

A utility method for creating gradients courtesy of the perlmonk YuckFoo.

    my $colorTable = Graphics::ACT->new('grayscale.act',1);
    $colorTable->(256, [0,0,0] => [255,255,255] ); # write a grayscale color table

B<BEWARE>, this method does not check if it L<C<canWrite>|"canWrite">. 

It takes 3 arguments:

=over 4

=item C<$steps>

The nuber of color create.
If you call this method more than once, you should probably make sure the steps add up to 256.

=item C<$beg>

A beginning color (array ref only)

=item C<$end>

An ending color (array ref only)

=back

=cut

sub YuckFoo {
    my( $self, $steps, $beg, $end) = @_;

   # RGB rate of change from beginning to ending color
    my @delta = ( 
        ($$end[0] - $$beg[0]) / ($steps-1),
        ($$end[1] - $$beg[1]) / ($steps-1),
        ($$end[2] - $$beg[2]) / ($steps-1),
    );
   
# Calculate colors using beginning color and rate of change
    my $i = 0;
    while($i < $steps) {
        my $color = [
            $$beg[0] + $i * $delta[0],
            $$beg[1] + $i * $delta[1],
            $$beg[2] + $i * $delta[2]
        ];
        $self->putColor($color);       
        $i++;
    }
}


1;


=head1 AUTHOR

D.H. <podmaster@cpan.org>

=head1 LICENSE

copyright (c) D.H. 2002
All rights reserved.

This program is released under the same terms as perl itself.
If you don't know what that means, visit http://perl.com
or execute C<perl -v> at a commandline (assuming you have perl installed).

=cut

1;