home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / PPM.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-06  |  1.6 KB  |  81 lines
  1. package Image::Info::PPM;
  2.  
  3. # Copyright 2000, Gisle Aas.
  4. #
  5. # This library is free software; you can redistribute it and/or
  6. # modify it under the same terms as Perl itself.
  7.  
  8. =begin register
  9.  
  10. MAGIC: /^P[1-6]/;
  11.  
  12. =item PBM/PGM/PPM
  13.  
  14. All information available is extracted.
  15.  
  16. =end register
  17.  
  18. =cut
  19.  
  20. use strict;
  21.  
  22. sub process_file
  23. {
  24.     my($info, $fh) = @_;
  25.  
  26.  
  27.     my @header;
  28.     my $type;
  29.     my $num_wanted = 3;
  30.     my $binary;
  31.  
  32.     local($/, $_) = ("\n");
  33.     while (<$fh>) {
  34.     if (s/#\s*(.*)//) {
  35.         $info->push_info(0, "Comment", $1);
  36.     }
  37.     push(@header, split(' '));
  38.     if (!$type && @header) {
  39.         $type = shift(@header);
  40.         $type =~ s/^P// || die;
  41.         $binary++ if $type > 3;
  42.         $type = "p" . qw/p b g/[$type % 3] . "m";
  43.         $num_wanted = 2 if $type eq "pbm";
  44.     }
  45.  
  46.     for (@header) {
  47.         unless (/^\d+$/) {
  48.         die "Badly formatted $type file";
  49.         }
  50.     }
  51.  
  52.     next unless @header >= $num_wanted;
  53.  
  54.     # Now we know everything there is to know...
  55.     $info->push_info(0, "file_media_type" => "image/$type");
  56.     $info->push_info(0, "file_ext" => "$type");
  57.     $info->push_info(0, "width", shift @header);
  58.     $info->push_info(0, "height", shift @header);
  59.     $info->push_info(0, "resolution", "1/1");
  60.     if ($type eq "ppm") {
  61.         $info->push_info(0, "color_type", "RGB");
  62.         $info->push_info(0, "SamplesPerPixel", 3);
  63.         if ($binary) {
  64.         for (1..3) {
  65.             $info->push_info(0, "BitsPerSample", 8);
  66.         }
  67.         }
  68.     }
  69.     else {
  70.         $info->push_info(0, "color_type", "Gray");
  71.         $info->push_info(0, "SamplesPerPixel", 1);
  72.         $info->push_info(0, "BitsPerSample", ($type eq "pbm") ? 1 : 8)
  73.         if $binary;
  74.     }
  75.     $info->push_info(0, "MaxSampleValue", shift @header) if $type ne "pbm";
  76.     last;
  77.     }
  78. }
  79.  
  80. 1;
  81.