File Coverage

blib/lib/Image/PNG.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Image::PNG;
2             require Exporter;
3             @ISA = qw(Exporter);
4             @EXPORT_OK = qw/display_text/;
5 1     1   24761 use Image::PNG::Const ':all';
  0            
  0            
6             use Image::PNG::Libpng;
7             use Image::PNG::Container;
8             use warnings;
9             use strict;
10             use Carp;
11              
12             our $VERSION = '0.22';
13              
14              
15             sub error
16             {
17             my ($png) = @_;
18             return $png->{error_string};
19             }
20              
21             sub fatal_error
22             {
23             my ($png) = @_;
24             return $png->{error_string};
25             }
26              
27             my %IHDR_fields = (
28             width => {
29             },
30             height => {
31             },
32             bit_depth => {
33             default => 8,
34             },
35             color_type => {
36             },
37             interlace_type => {
38             default => PNG_INTERLACE_NONE,
39             },
40             );
41              
42              
43             sub write_info_error
44             {
45             my ($png) = @_;
46             my @unset;
47             for my $field (sort keys %IHDR_fields) {
48             if (!$IHDR_fields{$field}{default}) {
49             push @unset, $field;
50             }
51             print "Set the following fields: ", join ", ", @unset;
52             }
53             }
54              
55             # Return the verbosity.
56              
57             sub verbose
58             {
59             my ($png) = @_;
60             return $png->{verbosity};
61             }
62              
63             # Set the verbosity.
64              
65             sub verbosity
66             {
67             my ($png, $verbosity) = @_;
68             if ($verbosity) {
69             printf "I am a %s. I am going to print messages about what I'm doing. You can surprsss this by calling \$me->verbosity () or by using an option %s->new ({verbosity} = 0);.\n", (__PACKAGE__) x 2;
70             }
71             $png->{verbosity} = 1;
72             }
73              
74             # Make the object.
75              
76             sub new
77             {
78             my ($package, $options) = @_;
79             my $png = {};
80             bless $png;
81             # The marker "error_string" contains the most recent error.
82             $png->{error_string} = '';
83             if ($options && ref $options eq 'HASH') {
84             if ($options->{verbosity}) {
85             $png->verbosity ($options->{verbosity});
86             }
87             if ($options->{file}) {
88             $png->read ($options->{file});
89             }
90             }
91             return $png;
92             }
93              
94             # Read a file
95              
96             sub Image::PNG::read
97             {
98             my ($png, $file_name) = @_;
99             if ($png->verbose) {
100             print "I am going to try to read a file called '$file_name'.\n";
101             }
102             if (! defined $file_name) {
103             carp __PACKAGE__, ": You called 'read' without giving a file name";
104             return;
105             }
106             my $read = Image::PNG::Container->new ({read_only => 1});
107             $read->set_file_name ($file_name);
108             $read->open ();
109             $read->read ();
110             if ($png->verbose) {
111             my $ihdr = Image::PNG::Libpng::get_IHDR ($read->png ());
112             printf ("The size of the image is %d X %d; its colour type is %s; its bit depth is %d\n", $ihdr->{width}, $ihdr->{height}, Image::PNG::Libpng::color_type_name ($ihdr->{color_type}), $ihdr->{bit_depth});
113             }
114              
115             $png->{read} = $read;
116             return 1;
117             }
118              
119             sub handle_error
120             {
121             my ($png, $message) = @_;
122             croak $message;
123             }
124              
125             sub Image::PNG::write
126             {
127             my ($png, $file_name) = @_;
128             if ($png->verbose) {
129             print "I am going to try to write a PNG file called '$file_name'.\n";
130             }
131             if (! $png->{write_ok}) {
132             if (! $png->{read}) {
133             $png->write_info_error ();
134             }
135             $png->init_write ();
136             }
137             my $write = $png->{write};
138             $write->{file_name} = $file_name;
139             # Check whether the image to be written has all of its IHDR information.
140             if (! $write->{ihdr_set}) {
141             if ($png->verbose) {
142             print "The image to be written doesn't seem to know what its header is supposed to be, so I'm going to try to find a substitute.\n";
143             }
144             if ($png->{read}) {
145             if ($png->verbose) {
146             print "I am copying the header from the image which I read in.\n";
147             }
148             my $ihdr = Image::PNG::Libpng::get_IHDR ($png->{read}->png ());
149             if ($png->verbose) {
150             print "I've got a header and now I'm going to try to put it into the output.\n";
151             }
152             Image::PNG::Libpng::set_IHDR ($write->{png}, $ihdr);
153             $write->{ihdr} = $ihdr;
154             }
155             else {
156             $png->handle_error ("I have no IHDR (header) data for the image; use the 'IHDR' method to set the IHDR values");
157             }
158             }
159             if ($png->verbose) {
160             print "I've got a header to write. Now I'm going to check the image data before writing it out.\n";
161             }
162             # Check whether the image data (the rows of the image) exist in
163             # some form or other.
164             if (! $write->{rows_set}) {
165             if ($png->verbose) {
166             print "You haven't specified what data you want me to write.\n";
167             }
168             # If the user has not specified what rows to write, assume
169             # that he wants to use the rows from a PNG object which has
170             # already been read in.
171             if ($png->{read}) {
172             if ($png->verbose) {
173             print "I am setting the image data for the image to write to data which I read in from another image.";
174             }
175             my $rows = Image::PNG::Libpng::get_rows ($png->{read}->png ());
176             if ($png->verbose) {
177             print "I've got the data from the read image and now I'm going to set up the writing to write that data.\n";
178             }
179             Image::PNG::Libpng::set_rows ($write->{png}, $rows);
180             }
181             else {
182             # There is no row data for the image.
183             $png->handle_error ("I have no row data for the image; use the 'rows' method to set the rows.");
184             return;
185             }
186             }
187             if ($png->verbose) {
188             printf ("Its colour type is %s.\n", Image::PNG::Libpng::color_type_name ($write->{ihdr}->{color_type}));
189             }
190             if ($write->{ihdr}->{color_type} == PNG_COLOR_TYPE_PALETTE) {
191             if ($png->verbose) {
192             print "The image you want to write has a palette, so I am going to check whether the palette is ready to be written.\n";
193             }
194             if (! $write->{palette_set}) {
195             print "The image doesn't have a palette set.\n";
196             if ($png->{read}) {
197             print "I am going to try to get one from the image I read in.\n";
198             my $palette = Image::PNG::Libpng::get_PLTE ($png->{read}->png ());
199             for my $color (@$palette) {
200             for my $hue (qw/red green blue/) {
201             printf "%s: %d ", $hue, $color->{$hue};
202             }
203             print "\n";
204             }
205             Image::PNG::Libpng::set_PLTE ($write->{png}, $palette);
206             }
207             else {
208             $png->handle_error ("You asked me to write an image with a palette, but I don't have any information about the palette for the image.");
209             }
210             }
211             }
212              
213             if ($png->verbose) {
214             print "I've got the data for the header and the image now so I can write a minimal PNG.\n";
215             }
216             # Now the rows are set.
217             open my $output, ">:raw", $write->{file_name}
218             or $png->handle_error ("opening file '$write->{file_name}' failed: $!'");
219             Image::PNG::Libpng::init_io ($write->{png}, $output);
220             Image::PNG::Libpng::write_png ($write->{png});
221             }
222              
223             # Private
224              
225             sub do_not_write
226             {
227             my ($png, $chunk) = @_;
228             push @{$png->{write}->{ignored_chunks}}, $chunk;
229             }
230              
231             # Public
232              
233             sub Image::PNG::delete
234             {
235             my ($png, @chunks) = @_;
236             if (! $png->{write_ok}) {
237             if (! $png->{read}) {
238             $png->write_info_error ();
239             }
240             $png->init_write ();
241             }
242             for my $chunk (@chunks) {
243             $png->do_not_write ($chunk);
244             }
245             }
246              
247             sub write_set
248             {
249             my ($png, $key, $value) = @_;
250             if (! $png->{write_ok}) {
251             $png->init_write ();
252             }
253             $png->{write}->{$key} = $value;
254             }
255              
256             # Initialize the object $png for writing (get the libpng things we
257             # need to write an image, set a flag "write_ok" in the image.).
258              
259             sub init_write
260             {
261             my ($png) = @_;
262             if ($png->{write_ok}) {
263             $png->error ("Writing already initialized");
264             return;
265             }
266             $png->{write} = {};
267             $png->{write}->{png} =
268             Image::PNG::Libpng::create_write_struct ();
269             $png->{write_ok} = 1;
270             }
271              
272             sub raise_error
273             {
274             my ($png, $error_level) = @_;
275             }
276              
277             sub print_error
278             {
279             my ($png, $error_level) = @_;
280             }
281              
282             sub data
283             {
284             my ($png, $data) = @_;
285             if (! $data) {
286             # Return the existing data
287             }
288             else {
289             # Put $data into the PNG
290             if ($png->{data}) {
291             carp __PACKAGE__, ": you have asked me to put a scalar value as the PNG data, but I already have PNG data inside me. Please use a fresh object.";
292             }
293             elsif ($png->{read_file_name}) {
294             carp __PACKAGE__, ": you have asked me to put a scalar value as the PNG data, but I already contain PNG data from a file called '$png->{read_file_name}. Please use a fresh object.";
295             }
296             }
297             return $png->{data};
298             }
299              
300             # Public
301              
302             sub IHDR
303             {
304             my ($png, $ihdr) = @_;
305             if ($ihdr) {
306             Image::PNG::Libpng::set_IHDR ($png->{write}->{png},
307             $ihdr);
308             $png->{write}->{ihdr_set} = 1;
309             }
310             else {
311             $ihdr = Image::PNG::Libpng::get_IHDR ($png->{read}->png ());
312             }
313             return $ihdr;
314             }
315              
316             # Private
317              
318             sub get_IHDR
319             {
320             my ($png) = @_;
321             if ($png->{IHDR}) {
322             carp __PACKAGE__, ": I was requested to read the IHDR of the PNG data, but I have already read it.";
323             return;
324             }
325             $png->{IHDR} = Image::PNG::Libpng::get_IHDR ($png->{read}->png ());
326             }
327              
328             # Get $key from the PNG.
329              
330             sub get
331             {
332             my ($png, $key) = @_;
333             if (! $png->{IHDR}) {
334             $png->get_IHDR ();
335             }
336             return $png->{IHDR}->{$key};
337             }
338              
339             # Get/set width of PNG
340              
341             sub width
342             {
343             my ($png, $width) = @_;
344             if ($width) {
345             write_set ($png, 'width', $width);
346             }
347             else {
348             return get ($png, 'width');
349             }
350             }
351              
352             # Get/set height of PNG
353              
354             sub height
355             {
356             my ($png, $height) = @_;
357             if ($height) {
358             write_set ($png, 'height', $height);
359             }
360             else {
361             return get ($png, 'height');
362             }
363             }
364              
365             sub color_type
366             {
367             my ($png, $color_type) = @_;
368             if ($color_type) {
369             write_set ($png, 'color_type', $color_type);
370             }
371             else {
372             return
373             Image::PNG::Libpng::color_type_name (
374             get ($png, 'color_type')
375             );
376             }
377             }
378              
379             sub bit_depth
380             {
381             my ($png, $bit_depth) = @_;
382             if ($bit_depth) {
383             write_set ($png, 'bit_depth', $bit_depth);
384             }
385             else {
386             return get ($png, 'bit_depth')
387             }
388             }
389              
390             sub rows
391             {
392             my ($png, $rows) = @_;
393             if ($rows) {
394             # Set the rows
395             if (! $png->{write_ok}) {
396             $png->init_write ();
397             }
398             if (! $png->{write}->{set_IHDR}) {
399             $png->{write}->{set_IHDR} = 1;
400             Image::PNG::Libpng::set_IHDR ($png->{write}->{png},
401             $png->{write}->{IHDR});
402             }
403             Image::PNG::Libpng::set_rows ($png->{write_png}, $rows);
404             $png->{write}->{rows_set} = 1;
405             }
406             else {
407             # Read the rows
408             if (! $png->{read}) {
409             # $png->handle_error ("");
410             return;
411             }
412             return Image::PNG::Libpng::get_rows ($png->{read}->png ());
413             }
414             }
415              
416             sub rowbytes
417             {
418             my ($png) = @_;
419             if (! $png->{read}) {
420             # $png->handle_error ("");
421             return;
422             }
423             return Image::PNG::Libpng::get_rowbytes ($png->{read}->png ());
424             }
425              
426             sub text
427             {
428             my ($png, $text) = @_;
429             if (! $png->{text}) {
430             my $text_ref =
431             Image::PNG::Libpng::get_text ($png->{read}->png ());
432             $png->{text} = $text_ref;
433             # Change the text compression field to words rather than numbers.
434             for my $text (@{$png->{text}}) {
435             $text->{compression} =
436             Image::PNG::Libpng::text_compression_name ($text->{compression});
437             }
438             }
439             if (! wantarray) {
440             carp __PACKAGE__, ": the 'text' method returns an array";
441             }
442             return @{$png->{text}};
443             }
444              
445             sub time
446             {
447             my ($png) = @_;
448             if (! $png->{read}) {
449             return undef;
450             }
451             return Image::PNG::Libpng::get_tIME ($png->{read}->{png});
452             }
453              
454             # The text segment of the PNG should probably be an object in its own
455             # right.
456              
457             sub display_text
458             {
459             my ($text) = @_;
460             if (! $text || ref $text ne 'HASH' || ! $text->{key}) {
461             carp __PACKAGE__, "::display_text called with something which doesn't seem to be a PNG text chunk";
462             return;
463             }
464             print "\n";
465             print "Key: $text->{key}";
466             if ($text->{translated_keyword}) {
467             print " [$text->{translated_keyword}";
468             if ($text->{lang}) {
469             print " in language $text->{lang}";
470             }
471             print "]";
472             }
473             print "\n";
474             print "Compression: $text->{compression}\n";
475             if ($text->{text}) {
476             printf "Text";
477             if (defined $text->{text_length}) {
478             printf " (length %d)", $text->{text_length};
479             }
480             print ":\n$text->{text}\n"
481             }
482             else {
483             print "Text is empty.\n";
484             }
485             }
486              
487             1;
488              
489             =head1 NAME
490              
491             Image::PNG - Read and write PNG files
492              
493              
494              
495             =head1 SYNOPSIS
496              
497             my $png = Image::PNG->new ();
498             $png->read_file ("crazy.png");
499             printf "Your PNG is %d x %d\n", $png->width, $png->height;
500              
501             =head1 DESCRIPTION
502              
503             Image::PNG is a layer on top of L. Whereas
504             L copies the interface of the C library C,
505             Image::PNG is intended to be a more intuitive way to handle PNG
506             images.
507              
508             Please note that this module is not completed yet and is still under
509             development, so the interface may change. It's also open to
510             suggestions for improvements.
511              
512             =head1 General methods
513              
514             =head2 new
515              
516             my $png = Image::PNG->new ();
517              
518             Create a new PNG-file reading or writing object.
519              
520             Options are
521              
522             =over
523              
524             =item read
525              
526             my $png = Image::PNG->new ({read => 'some.png'});
527              
528             Set the file to read. The file is then read at the time of object
529             creation.
530              
531             =item verbosity
532              
533             my $png = Image::PNG->new ({verbosity => 1});
534              
535             If C is set to a true value, print verbose messages about
536             what the module is doing.
537              
538             =back
539              
540             =head2 read
541              
542             $png->read ("crazy.png")
543             or die "Can't read it: " . $png->error ();
544              
545             Read the PNG from the file name specified as the argument. This dies
546             if there is an error.
547              
548             =head2 write
549              
550             $png->write ("crazy.png")
551             or die "Can't write it: " . $png->error ();
552              
553             Write the PNG to the file name specified as the argument. This dies
554             if there is an error.
555              
556             =head2 data
557              
558             my $data = $png->data ();
559              
560             Get the PNG image data as a Perl scalar.
561              
562             =head2 error
563              
564             Print the most recent error message.
565              
566             =head1 PNG header-related methods
567              
568             These methods are related to the PNG header (the IHDR chunk of the PNG
569             file).
570              
571             =head2 width
572              
573             my $height = $png->width ();
574              
575             Get the width of the current PNG image.
576              
577             =head2 height
578              
579             my $height = $png->height ();
580              
581             Get the height of the current PNG image.
582              
583             =head2 color_type
584              
585             my $color_type = $png->color_type ();
586              
587             Get the name of the colour type of the current PNG image. The possible
588             return values are
589              
590             =over
591              
592             =item PALETTE
593              
594             =item GRAY
595              
596             =item GRAY_ALPHA
597              
598             =item RGB
599              
600             =item RGB_ALPHA
601              
602             =back
603              
604             =head2 bit_depth
605              
606             my $bit_depth = $png->bit_depth ();
607              
608             Get the bit depth of the current PNG image.
609              
610             =head2 interlacing_method
611              
612             my $interlacing_method = $png->interlacing_method ();
613              
614             Get the name of the method of interlacing of the current PNG image.
615              
616             There is no method for dealing with the compression method
617             field of the header, since this only has one possible value.
618              
619             =head1 Image data-related methods
620              
621             =head2 rowbytes
622              
623             my $rowbytes = $png->rowbytes;
624              
625             This method returns the number of bytes in each row of the image. If
626             no image has been read yet, it returns the undefined value.
627              
628             =head2 rows
629              
630             my $rows = $png->rows;
631              
632             This method returns the rows of the image as an array reference,
633             C<$rows>. The array reference is a size equal to the height of the
634             image. Each element has the length of the number of bytes in one row
635             (as given by L) plus one final zero byte.
636              
637             The row data returned is binary data and may contain several bytes
638             with the value zero.
639              
640             =head1 Non-image chunks
641              
642             =head2 text
643              
644             my @text = $png->text;
645              
646             Get the text chunks of the image. Each element of the return value is
647             a hash reference. The keys are the fields of the PNG text chunk, and
648             the values are the values of those fields in the text chunk. The size
649             of the array is equal to the number of text chunks.
650              
651             =head2 time
652              
653             my $time_ref = $png->time;
654             print "The PNG was last modified in $time_ref->{year}.\n";
655              
656             Get the last modified time of the image. The return value is a hash
657             reference containing the following six fields,
658              
659             =over
660              
661             =item year
662              
663             =item month
664              
665             =item day
666              
667             =item hour
668              
669             =item minute
670              
671             =item second
672              
673             =back
674              
675             These represent the last modification time of the image. The
676             modification time of a PNG file is meant to be in the GMT (UCT) time
677             zone so there is no time zone information.
678              
679             If there is no last modification time, the undefined value is returned
680             instead of a hash reference.
681              
682             =head1 FUNCTIONS
683              
684             There are some convenience functions in this module, exported on request.
685              
686             =head2 display_text
687              
688             use Image::PNG qw/display_text/;
689             my @text = $png->text;
690             display_text ($text[3]);
691              
692             Display the text chunk given as an argument on C.
693              
694             This is a convenience function for debugging rather than a
695             general-purpose routine.
696              
697             =head1 SEE ALSO
698              
699             =head2 In this distribution
700              
701             =head3 Image::PNG::Const
702              
703             L contains the libpng constants taken from the libpng
704             header file "png.h".
705              
706             =head3 Image::PNG::Libpng
707              
708             L provides a Perl mirror of the interface of the C
709             PNG library "libpng". Image::PNG is built on top of this module.
710              
711             =head2 libpng download
712              
713             To download libpng, see
714             L. See also L.
715              
716             =head2 Other Perl modules on CPAN
717              
718             =head3 Image::ExifTool
719              
720             L is a pure Perl (doesn't require a C compiler)
721             solution for accessing the text segments of images. It has extensive
722             support for PNG text segments.
723              
724             =head3 Alien::PNG
725              
726             L claims to be a way of "building, finding and using PNG
727             binaries". It may help in installing libpng. I didn't use it as a
728             dependency for this module because it seems not to work in batch mode,
729             but stop and prompt the user. I'm interested in hearing feedback from
730             users whether this works or not on various platforms.
731              
732             =head3 Image::PNG::Rewriter
733              
734             L is a utility for unpacking and recompressing
735             the IDAT (image data) part of a PNG image. The main purpose seems to
736             be to recompress the image data with the module author's other module
737             L. Unfortunately that only works with Perl
738             versions 5.12.
739              
740             =head3 Image::Pngslimmer
741              
742             L reduces the size of dynamically created PNG
743             images. It's very, very slow at reading PNG data, but seems to work
744             OK.
745              
746             =head3 Image::Info
747              
748             L is a module for getting information out of various
749             types of images. It has good support for PNG and is written in pure
750             Perl (doesn't require a C compiler). As well as basics such as height,
751             width, and colour type, it can get text chunks, modification time,
752             palette, gamma (gAMA chunk), resolution (pHYs chunk), and significant
753             bits (sBIT chunk). At the time of writing (version 1.31) it doesn't
754             support other chunks.
755              
756             =head3 Image::Size
757              
758             If you only need to find the size of an image, L can give
759             you the size of PNG and various other image formats. This module is
760             highly recommended on CPAN ratings.
761              
762             =head3 Image::PNGwriter
763              
764             L is an interface to a project called
765             "PNGwriter". At the time of writing (2013-12-01), only one version has
766             been released, in 2005. The most recent version of PNGwriter itself is
767             from 2009.
768              
769              
770              
771              
772             =head2 About the PNG format
773              
774             =head3 Wikipedia article
775              
776             There is L.
777              
778             =head3 The PNG specification
779              
780             L (link to W3
781             consortium) explains the details of the PNG format.
782              
783              
784             =head3 PNG The Definitive Guide by Greg Roelofs
785              
786             The book "PNG - The Definitive Guide" by Greg Roelofs, published in
787             1999 by O'Reilly is available online at
788             L.
789              
790             =head1 AUTHOR
791              
792             Ben Bullock,
793              
794             =head1 COPYRIGHT & LICENCE
795              
796             The Image::PNG package and associated files are copyright (C)
797             2015 Ben Bullock.
798              
799             You can use, copy, modify and redistribute Image::PNG and
800             associated files under the Perl Artistic Licence or the GNU General
801             Public Licence.
802              
803             =head1 FOR PROGRAMMERS
804              
805             The distributed files are not the source code of the module. The
806             source code lives in the "tmpl" directory of the distribution and the
807             distribution is created via scripts.
808              
809              
810              
811             =cut
812              
813             # Local Variables:
814             # mode: perl
815             # End:
816              
817              
818             # Local Variables:
819             # mode: perl
820             # End: