| Image-TextMode documentation | Contained in the Image-TextMode distribution. |
Image::TextMode::Reader::Tundra - Reads Tundra files
Provides reading capabilities for the Tundra format.
Brian Cassidy <bricas@cpan.org>
Copyright 2008-2011 by Brian Cassidy
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
| Image-TextMode documentation | Contained in the Image-TextMode distribution. |
package Image::TextMode::Reader::Tundra; use Moose; extends 'Image::TextMode::Reader'; sub _read { my ( $self, $image, $fh, $options ) = @_; my ( $buffer, %header ); read( $fh, $buffer, 1 ); $header{ int_id } = unpack( 'C', $buffer ); read( $fh, $buffer, 8 ); $header{ id } = unpack( 'A8', $buffer ); $image->header( \%header ); my $width = $options->{ width } || 80; my $pal = Image::TextMode::Palette->new; my ( $x, $y, $attr, $fg, $bg, $pal_index ) = ( 0 ) x 6; $pal->colors->[ $pal_index++ ] = [ 0, 0, 0 ]; while ( read( $fh, $buffer, 1 ) ) { my $command = ord( $buffer ); if ( $command == 1 ) { # position read( $fh, $buffer, 8 ); ( $y, $x ) = unpack( 'N*', $buffer ); next; } my $char; if ( $command == 2 ) { # fg read( $fh, $char, 1 ); read( $fh, $buffer, 4 ); my $rgb = unpack( 'N', $buffer ); $fg = $pal_index++; $pal->colors->[ $fg ] = [ ( $rgb >> 16 ) & 0x000000ff, ( $rgb >> 8 ) & 0x000000ff, $rgb & 0x000000ff, ]; } elsif ( $command == 4 ) { # bg read( $fh, $char, 1 ); read( $fh, $buffer, 4 ); my $rgb = unpack( 'N', $buffer ); $bg = $pal_index++; $pal->colors->[ $bg ] = [ ( $rgb >> 16 ) & 0x000000ff, ( $rgb >> 8 ) & 0x000000ff, $rgb & 0x000000ff, ]; } elsif ( $command == 6 ) { # fg + bg read( $fh, $char, 1 ); read( $fh, $buffer, 8 ); my @rgb = unpack( 'N*', $buffer ); $fg = $pal_index++; $pal->colors->[ $fg ] = [ ( $rgb[ 0 ] >> 16 ) & 0x000000ff, ( $rgb[ 0 ] >> 8 ) & 0x000000ff, $rgb[ 0 ] & 0x000000ff, ]; $bg = $pal_index++; $pal->colors->[ $bg ] = [ ( $rgb[ 1 ] >> 16 ) & 0x000000ff, ( $rgb[ 1 ] >> 8 ) & 0x000000ff, $rgb[ 1 ] & 0x000000ff, ]; } if ( !$char ) { $char = chr( $command ); } $image->putpixel( { char => $char, fg => $fg, bg => $bg }, $x, $y ); $x++; if ( $x == $width ) { $x = 0; $y++; } } $image->palette( $pal ); return $image; } no Moose; __PACKAGE__->meta->make_immutable;
1;