File Coverage

blib/lib/Image/TextMode/Writer/IDF.pm
Criterion Covered Total %
statement 21 21 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 24 24 100.0


line stmt bran cond sub pod time code
1             package Image::TextMode::Writer::IDF;
2              
3 1     1   380 use Moo;
  1         2  
  1         7  
4 1     1   718 use charnames ':full';
  1         24617  
  1         5  
5              
6             extends 'Image::TextMode::Writer';
7              
8             my $header_template = 'A4 v v v v';
9              
10             sub _write {
11 1     1   2 my ( $self, $image, $fh, $options ) = @_;
12              
13 1         13 my ( $max_x, $max_y ) = map { $_ - 1 } $image->dimensions;
  2         36  
14              
15 1         16 print $fh pack( $header_template,
16             "\N{END OF TRANSMISSION}1.4",
17             0, 0, $max_x, $max_y );
18              
19             # Don't bother with RLE compression for now
20 1         3 for my $y ( 0 .. $max_y ) {
21 1         1 for my $x ( 0 .. $max_x ) {
22 80         173 my $pixel = $image->getpixel( $x, $y );
23 80         461 print $fh pack( 'aC', $pixel->{ char }, $pixel->{ attr } );
24             }
25             }
26              
27 1         3 for my $char ( @{ $image->font->chars } ) {
  1         39  
28 256         1087 print $fh pack( 'C*', @$char );
29             }
30              
31 1         2 for my $color ( @{ $image->palette->colors } ) {
  1         33  
32 16         496 print $fh pack( 'C*', map { $_ >> 2 } @$color );
  48         63  
33             }
34             }
35              
36             =head1 NAME
37              
38             Image::TextMode::Writer::IDF - Writes IDF files
39              
40             =head1 DESCRIPTION
41              
42             Provides writing capabilities for the IDF format. It currently does not
43             support any RLE compression.
44              
45             =head1 AUTHOR
46              
47             Brian Cassidy Ebricas@cpan.orgE
48              
49             =head1 COPYRIGHT AND LICENSE
50              
51             Copyright 2008-2014 by Brian Cassidy
52              
53             This library is free software; you can redistribute it and/or modify
54             it under the same terms as Perl itself.
55              
56             =cut
57              
58             1;