lib/Image/Info/XPM.pm

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