PPM.pm 4.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169
  1. #------------------------------------------------------------------------------
  2. # File: PPM.pm
  3. #
  4. # Description: Read and write PPM meta information
  5. #
  6. # Revisions: 09/03/2005 - P. Harvey Created
  7. #
  8. # References: 1) http://netpbm.sourceforge.net/doc/ppm.html
  9. # 2) http://netpbm.sourceforge.net/doc/pgm.html
  10. # 3) http://netpbm.sourceforge.net/doc/pbm.html
  11. #------------------------------------------------------------------------------
  12. package Image::ExifTool::PPM;
  13. use strict;
  14. use vars qw($VERSION);
  15. use Image::ExifTool qw(:DataAccess :Utils);
  16. $VERSION = '1.08';
  17. #------------------------------------------------------------------------------
  18. # Read or write information in a PPM/PGM/PBM image
  19. # Inputs: 0) ExifTool object reference, 1) Directory information reference
  20. # Returns: 1 on success, 0 if this wasn't a valid PPM file, -1 on write error
  21. sub ProcessPPM($$)
  22. {
  23. my ($et, $dirInfo) = @_;
  24. my $raf = $$dirInfo{RAF};
  25. my $outfile = $$dirInfo{OutFile};
  26. my $verbose = $et->Options('Verbose');
  27. my $out = $et->Options('TextOut');
  28. my ($buff, $num, $type, %info);
  29. #
  30. # read as much of the image as necessary to extract the header and comments
  31. #
  32. for (;;) {
  33. if (defined $buff) {
  34. # need to read some more data
  35. my $tmp;
  36. return 0 unless $raf->Read($tmp, 1024);
  37. $buff .= $tmp;
  38. } else {
  39. return 0 unless $raf->Read($buff, 1024);
  40. }
  41. # verify this is a valid PPM file
  42. return 0 unless $buff =~ /^P([1-6])\s+/g;
  43. $num = $1;
  44. # note: may contain comments starting with '#'
  45. if ($buff =~ /\G#/gc) {
  46. # must read more if we are in the middle of a comment
  47. next unless $buff =~ /\G ?(.*\n(#.*\n)*)\s*/g;
  48. $info{Comment} = $1;
  49. next if $buff =~ /\G#/gc;
  50. } else {
  51. delete $info{Comment};
  52. }
  53. next unless $buff =~ /\G(\S+)\s+(\S+)\s/g;
  54. $info{ImageWidth} = $1;
  55. $info{ImageHeight} = $2;
  56. $type = [qw{PPM PBM PGM}]->[$num % 3];
  57. last if $type eq 'PBM'; # (no MaxVal for PBM images)
  58. if ($buff =~ /\G\s*#/gc) {
  59. next unless $buff =~ /\G ?(.*\n(#.*\n)*)\s*/g;
  60. $info{Comment} = '' unless exists $info{Comment};
  61. $info{Comment} .= $1;
  62. next if $buff =~ /\G#/gc;
  63. }
  64. next unless $buff =~ /\G(\S+)\s/g;
  65. $info{MaxVal} = $1;
  66. last;
  67. }
  68. # validate numerical values
  69. foreach (keys %info) {
  70. next if $_ eq 'Comment';
  71. return 0 unless $info{$_} =~ /^\d+$/;
  72. }
  73. if (defined $info{Comment}) {
  74. $info{Comment} =~ s/^# ?//mg; # remove "# " at the start of each line
  75. $info{Comment} =~ s/\n$//; # remove trailing newline
  76. }
  77. $et->SetFileType($type);
  78. my $len = pos($buff);
  79. #
  80. # rewrite the file if requested
  81. #
  82. if ($outfile) {
  83. my $nvHash;
  84. my $newComment = $et->GetNewValue('Comment', \$nvHash);
  85. my $oldComment = $info{Comment};
  86. if ($et->IsOverwriting($nvHash, $oldComment)) {
  87. ++$$et{CHANGED};
  88. $et->VerboseValue('- Comment', $oldComment) if defined $oldComment;
  89. $et->VerboseValue('+ Comment', $newComment) if defined $newComment;
  90. } else {
  91. $newComment = $oldComment; # use existing comment
  92. }
  93. my $hdr = "P$num\n";
  94. if (defined $newComment) {
  95. $newComment =~ s/\n/\n# /g;
  96. $hdr .= "# $newComment\n";
  97. }
  98. $hdr .= "$info{ImageWidth} $info{ImageHeight}\n";
  99. $hdr .= "$info{MaxVal}\n" if $type ne 'PBM';
  100. # write header and start of image
  101. Write($outfile, $hdr, substr($buff, $len)) or return -1;
  102. # copy over the rest of the image
  103. while ($raf->Read($buff, 0x10000)) {
  104. Write($outfile, $buff) or return -1;
  105. }
  106. return 1;
  107. }
  108. #
  109. # save extracted information
  110. #
  111. if ($verbose > 2) {
  112. print $out "$type header ($len bytes):\n";
  113. HexDump(\$buff, $len, Out => $out);
  114. }
  115. my $tag;
  116. foreach $tag (qw{Comment ImageWidth ImageHeight MaxVal}) {
  117. $et->FoundTag($tag, $info{$tag}) if defined $info{$tag};
  118. }
  119. return 1;
  120. }
  121. 1; # end
  122. __END__
  123. =head1 NAME
  124. Image::ExifTool::PPM - Read and write PPM meta information
  125. =head1 SYNOPSIS
  126. This module is used by Image::ExifTool
  127. =head1 DESCRIPTION
  128. This module contains definitions required by Image::ExifTool to read and
  129. write PPM (Portable Pixel Map), PGM (Portable Gray Map) and PBM (Portable
  130. BitMap) images.
  131. =head1 AUTHOR
  132. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  133. This library is free software; you can redistribute it and/or modify it
  134. under the same terms as Perl itself.
  135. =head1 REFERENCES
  136. =over 4
  137. =item L<http://netpbm.sourceforge.net/doc/ppm.html>
  138. =item L<http://netpbm.sourceforge.net/doc/pgm.html>
  139. =item L<http://netpbm.sourceforge.net/doc/pbm.html>
  140. =back
  141. =head1 SEE ALSO
  142. L<Image::ExifTool::TagNames/PPM Tags>,
  143. L<Image::ExifTool(3pm)|Image::ExifTool>
  144. =cut