lib/Image/Info/XPM.pm

   1 package Image::Info::XPM;
   2 $VERSION = '1.03';
   3 #Path to X11 RGB database
   4 $RGBLIB ||= "/usr/X11R6/lib/X11/rgb.txt";
   5 use strict;
   6 use Image::Xpm;
   7
   8
   9 sub process_file{
  10     my($info, $source, $opts) = @_;
  11     my(@comments, @warnings, $i);
  12
  13     *Image::Xpm::carp  = sub { push @warnings, @_; };
  14     *Image::Xpm::croak = sub { $info->push_info(0, "error", @_); };
  15     if( $Image::Xpm::Version cmp '1.08' < 1){
  16         push @warnings, "This version of Image::Xpm does not support filehandles or scalar references";
  17         $source = $info->get_info(0, "FileName");
  18     }
  19     if( $info->get_info(0, "error") ){
  20         return; }
  21
  22     $i = Image::Xpm->new(-file, $source);
  23     $info->push_info(0, "color_type" => "Indexed-RGB");
  24     $info->push_info(0, "file_ext" => "xpm");
  25     $info->push_info(0, "file_media_type" => "image/x-xpixmap");
  26     $info->push_info(0, "height", $i->get(-height));
  27     $info->push_info(0, "resolution", "1/1");
  28     $info->push_info(0, "width", $i->get(-width));
  29     $info->push_info(0, "BitsPerSample" => 8);
  30     $info->push_info(0, "SamplesPerPixel", 1);
  31
  32     $info->push_info(0, "XPM_CharactersPerPixel" => $i->get(-cpp) );
  33     # XXX is this always?
  34     $info->push_info(0, "ColorResolution", 8);
  35     $info->push_info(0, "ColorTableSize" => $i->get(-ncolours) );
  36     if( $opts->{ColorPalette} ){
  37         $info->push_info(0, "ColorPalette" => [keys %{$i->get(-cindex)}] );
  38     }
  39     if( $opts->{L1D_Histogram} ){
  40         #Do Histograms
  41         my(%RGB, @l1dhist, $R, $G, $B, $color);
  42         for(my $y=0; $y<$i->get(-height); $y++){
  43             for(my $x=0; $x<$i->get(-width); $x++){
  44                 $color = $i->xy($x, $y);
  45                 if( $color !~ /^#/ ){
  46                     unless( exists($RGB{white}) ){
  47                         local $_;
  48                         if( open(RGB, $Image::Info::XPM::RGBLIB) ){
  49                             while(<RGB>){
  50                                 /(\d+)\s+(\d+)\s+(\d+)\s+(.*)/;
  51                                 $RGB{$4}=[$1,$2,$3];
  52                             }
  53                         }
  54                         else{
  55                             $RGB{white} = "0 but true";
  56                             push @warnings, "Unable to open RGB database, you may need to set \$Image::Info::XPM::RGBLIB or define \$RGBLIB in ". __FILE__;
  57                         }
  58                     }
  59                     $R = $RGB{$color}->[0];
  60                     $G = $RGB{$color}->[1];
  61                     $B = $RGB{$color}->[2];
  62                 }
  63                 else{
  64                     $R = hex(substr($color,1,2));
  65                     $G = hex(substr($color,3,2));
  66                     $B = hex(substr($color,5,2));
  67                 }
  68                 if( $opts->{L1D_Histogram} ){
  69                     $l1dhist[(.3*$R + .59*$G + .11*$B)]++;
  70                 }
  71             }
  72         }
  73         if( $opts->{L1D_Histogram} ){
  74             $info->push_info(0, "L1D_Histogram", [@l1dhist]);
  75         }
  76     }
  77     $info->push_info(0, "HotSpotX" => $i->get(-hotx) );
  78     $info->push_info(0, "HotSpotY" => $i->get(-hoty) );
  79     $info->push_info(0, 'XPM_Extension-'.ucfirst($i->get(-extname)) => $i->get(-extlines)) if
  80         $i->get(-extname);
  81     push @comments, @{$i->get(-comments)};
  82
  83     for (@comments) {
  84         $info->push_info(0, "Comment", $_);
  85     }
  86
  87     for (@warnings) {
  88         $info->push_info(0, "Warn", $_);
  89     }
  90 }
  91 1;
  92 __END__
  93 =pod
  94
  95 =head1 NAME
  96
  97 Image::Info::XPM - XPM support for Image::Info
  98
  99 =head1 SYNOPSIS
 100
 101  use Image::Info qw(image_info dim);
 102
 103  my $info = image_info("image.xpm");
 104  if (my $error = $info->{error}) {
 105      die "Can't parse image info: $error\n";
 106  }
 107  my $color = $info->{color_type};
 108
 109  my($w, $h) = dim($info);
 110
 111 =head1 DESCRIPTION
 112
 113 This modules supplies the standard key names
 114 except for Compression, Gamma, Interlace, LastModificationTime, as well as:
 115
 116 =over
 117
 118 =item ColorPalette
 119
 120 Reference to an array of all colors used.
 121 This key is only present if C<image_info> is invoked
 122 as C<image_info({ColorPaletteE<gt>=1})>.
 123
 124 =item ColorTableSize
 125
 126 The number of colors the image uses.
 127
 128 =item HotSpotX
 129
 130 The x-coord of the image's hotspot.
 131 Set to -1 if there is no hotspot.
 132
 133 =item HotSpotY
 134
 135 The y-coord of the image's hotspot.
 136 Set to -1 if there is no hotspot.
 137
 138 =item L1D_Histogram
 139
 140 Reference to an array representing a one dimensioanl luminance
 141 histogram. This key is only present if C<image_info> is invoked
 142 as C<image_info($file, L1D_Histogram=E<gt>1)>. The range is from 0 to 255,
 143 however auto-vivification is used so a null field is also 0,
 144 and the array may not actually contain 255 fields.
 145
 146 =item XPM_CharactersPerPixel
 147
 148 This is typically 1 or 2. See L<Image::Xpm>.
 149
 150 =item XPM_Extension-.*
 151
 152 XPM Extensions (the most common is XPMEXT) if present.
 153
 154 =back
 155
 156 =item FILES
 157
 158 This module requires L<Image::Xpm>
 159
 160 I<$Image::Info::XPM::RGBLIB> is set to F</usr/X11R6/lib/X11/rgb.txt>
 161 by default, this is used to resolve textual color names to their RGB
 162 counterparts.
 163
 164 =head1 SEE ALSO
 165
 166 L<Image::Info>, L<Image::Xpm>
 167
 168 =head1 NOTES
 169
 170 For more information about XPM see:
 171
 172  ftp://ftp.x.org/contrib/libraries/xpm-README.html
 173
 174 =head1 CAVEATS
 175
 176 While the module attempts to be as robust as possible, it may not recognize
 177 older XBMs (Versions 1-3), if this is the case try inserting S</* XPM */>
 178 as the first line.
 179
 180 =head1 AUTHOR
 181
 182 Jerrad Pierce <belg4mit@mit.edu>/<webmaster@pthbb.org>
 183
 184 This library is free software; you can redistribute it and/or
 185 modify it under the same terms as Perl itself.
 186
 187 =cut
 188
 189 =begin register
 190
 191 MAGIC: /(^\/\* XPM \*\/)|(static\s+char\s+\*\w+\[\]\s*=\s*{\s*"\d+)/
 192
 193 See L<Image::Info::XPM> for details.
 194
 195 =end register
 196
 197 =cut