File Coverage

blib/lib/Image/TextMode/Reader/ADF.pm

Criterion	Covered	Total	%
statement	39	39	100.0
branch	3	4	75.0
condition	1	3	33.3
subroutine	4	4	100.0
pod			n/a
total	47	50	94.0

package Image::TextMode::Reader::ADF;

use Moo;

extends 'Image::TextMode::Reader';

my @color_idx = ( 0, 1, 2, 3, 4, 5, 20, 7, 56, 57, 58, 59, 60, 61, 62, 63 );

sub _read {
    my ( $self, $image, $fh, $options ) = @_;

    my $version;
    read( $fh, $version, 1 );
    $version = unpack( 'C', $version );
    $image->header( { version => $version } );

    my $paldata;
    read( $fh, $paldata, 192 );
    _parse_palette( $image, $paldata );

    my $fontdata;
    read( $fh, $fontdata, 4096 );
    _parse_font( $image, $fontdata );

    my ( $x, $y ) = ( 0, 0 );
    my $chardata;
    while ( read( $fh, $chardata, 2 ) ) {
        my @data = unpack( 'aC', $chardata );
        last if tell( $fh ) > $options->{ filesize } || $data[ 0 ] eq chr( 26 );
        $image->putpixel( { char => $data[ 0 ], attr => $data[ 1 ] }, $x,
            $y );

        $x++;
        if ( $x == 80 ) {
            $x = 0;
            $y++;
        }
    }

    return $image;
}

sub _parse_palette {
    my ( $image, $data ) = @_;

    my @pal = unpack( 'C*', $data );
    my @colors;
    for ( @color_idx ) {
        my $offset = $_ * 3;
        push @colors, [ map { $_ << 2 | $_ >> 4 } @pal[ $offset .. $offset + 2 ] ];
    }

    $image->palette(
        Image::TextMode::Palette->new( { colors => \@colors } ) );
}

sub _parse_font {
    my ( $image, $data ) = @_;
    my $height = 16;
    my @chars;

    for ( 0 .. ( length( $data ) / $height ) - 1 ) {
        push @chars,
            [ unpack( 'C*', substr( $data, $_ * $height, $height ) ) ];
    }

    $image->font(
        Image::TextMode::Font->new(
            {   width  => 8,
                height => $height,
                chars  => \@chars,
            }
        )
    );
}

=head1 NAME

Image::TextMode::Reader::ADF - Reads ADF files

=head1 DESCRIPTION

Provides reading capabilities for the ADF format.

=head1 AUTHOR

Brian Cassidy [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright 2008-2014 by Brian Cassidy

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;