package readxpm; # Strict use strict; use warnings; # Libraries use IO::File; # Subroutines sub new { my ($class, $fname) = @_; (ref $class) and $class = ref $class; # Create blessed reference my $self = { 'xpm' => 0 }; bless $self, $class; # Parse filename, if given if (defined $fname) { $self->{'xpm'} = $self->read($fname); } # Return the object return $self; } sub width { my ($self) = @_; (my $pxpm = $self->{'xpm'}) or return; return $pxpm->{'width'}; } sub height { my ($self) = @_; (my $pxpm = $self->{'xpm'}) or return; return $pxpm->{'height'}; } sub ncolors { my ($self) = @_; (my $pxpm = $self->{'xpm'}) or return; return $pxpm->{'ncolors'}; } sub colors { my ($self) = @_; (my $pxpm = $self->{'xpm'}) or return; return $pxpm->{'colors'}; } sub pixels { my ($self) = @_; (my $pxpm = $self->{'xpm'}) or return; return $pxpm->{'pixels'}; } # # sub read # # in: $1 ... filename of the XPM image. # # out: $1 ... a hash pointer with the following 5 keys # and values: # # 'width' ..... number of columns in the image # 'height' .... number of rows in the image # 'ncolors' ... number of pixel colors in the image # 'colors' .... an array mapping index to color # 'pixels' .... a 2-dimensional color index array # sub read { my ($self, $fname) = @_; # Read lines from .xpm file my $fh = new IO::File($fname) or die "Can't read '$fname' ($!)\n"; my $plines = [ ]; map { chomp; push @$plines, $_ } <$fh>; close $fh; # Discard header (' shift @$plines; # eg. '/* XPM */' shift @$plines; # eg. 'static char * my_xpm[] = {' # Get parameters (shift @$plines) =~ /(\d+)\s(\d+)\s(\d+)\s(\d+)/; my $pxpm = { width => $1, height => $2, ncolors => $3 }; my $charsize = $4; # Table for converting gray names to RGB my $p_gray_values = [qw( 00 03 05 08 0a 0d 0f 12 14 17 1a 1c 1f 21 24 26 29 2b 2e 30 33 36 38 3b 3d 40 42 45 47 4a 4d 4f 52 54 57 59 5c 5e 61 63 66 69 6b 6e 70 73 75 78 7a 7d 7f 82 85 87 8a 8c 8f 91 94 96 99 9c 9e a1 a3 a6 a8 ab ad b0 b3 b5 b8 ba bd bf c2 c4 c7 c9 cc cf d1 d4 d6 d9 db de e0 e3 e5 e8 eb ed f0 f2 f5 f7 fa fc )]; # Get color information my $pindex = { }; $pxpm->{'colors'} = [ ]; my $re = sprintf "^\"(.{%d})\\s+c\\s+#?(.+)\",", $charsize; for (my $i = 0; $i < $pxpm->{'ncolors'}; $i++) { my $line = shift @$plines; ($line =~ /$re/) or die "Invalid color line: '$line'\n"; my ($sym, $color) = ($1, lc $2); if ($color !~ /^[0-9a-f]{6}$/) { if ($color =~ /^(black|white|gr[ae]y100)$/) { $color = ($color eq 'black')? '000000': 'ffffff'; } elsif ($color eq 'none') { $color = 'none'; } elsif ($color =~ /^gr[ae]y(\d+){2}$/) { $color = $p_gray_values->[$1] x 3; } else { die "Unknown color name '$color'\n"; } } $pindex->{$sym} = $i; # Symbol to color index $pxpm->{'colors'}->[$i] = $color; # Color index to color } # Parse the pixel data $pxpm->{'pixels'} = [ ]; for (my $i = 0; $i < $pxpm->{'height'}; $i++) { my $prow = $pxpm->{'pixels'}->[$i] = [ ]; (my $line = shift @$plines) =~ s/^"//; for (my $j = 0; $j < $pxpm->{'width'}; $j++) { push @$prow, $pindex->{substr($line, 0, $charsize, "")}; } } return $pxpm; } sub to_html { my ($self, $fname) = @_; (my $pcolors = $self->colors) or return; (my $ppixels = $self->pixels) or return; (my $width = $self->width) or return; my $fh = new IO::File($fname, ">") or die "Can't write '$fname' ($!)\n"; print $fh "\n"; print $fh '', "\n"; printf $fh '', $width, "\n"; foreach my $prow (@$ppixels) { print $fh '', "\n"; while (1) { last unless (@$prow > 0); my $pixel = shift @$prow; my $colspan = 1; while (@$prow > 0 and $prow->[0] eq $pixel) { shift @$prow; ++$colspan; } my $color = $pcolors->[$pixel]; print $fh ' ', $color; print $fh "\n"; } print $fh "\n"; } print $fh "
\n"; close $fh; } 1; __END__ =head1 NAME readxpm - Parses XPM image files =head1 SYNOPSIS use readxpm my $p = new readxpm("myimage.xpm"); my $pxpm = $p->xpm(); =head1 DESCRIPTION This module parses .xpm image files. For example, given an .xpm file called "dot.xpm", containing the following image (a yellow circle with a black border): /* XPM */ static char * dot_xpm[] = { "22 22 3 1", " c #FFFFFF", "# c #000000", "* c #FFF000", " ", " ######## ", " #********# ", " #**********# ", " #************# ", " #**************# ", " #****************# ", " #******************# ", " #******************# ", " #******************# ", " #******************# ", " #******************# ", " #******************# ", " #******************# ", " #******************# ", " #****************# ", " #**************# ", " #************# ", " #**********# ", " #********# ", " ######## ", " "} Then performing the following command: my $p = new readxpm("dot.xpm"); or: my $p = new readxpm(); $p->read("dot.xpm"); would parse the .xpm file to create the following hash reference: { 'width' => 22, 'height' => 22, 'ncolors' => 3, 'colors' => [ 'ffffff', '000000', 'fff000' ], 'pixels' => [ [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; [ 0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0 ]; [ 0,0,0,0,0,0,1,2,2,2,2,2,2,2,2,1,0,0,0,0,0,0 ]; [ 0,0,0,0,0,1,2,2,2,2,2,2,2,2,2,2,1,0,0,0,0,0 ]; [ 0,0,0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0,0,0 ]; [ 0,0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0,0 ]; [ 0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0 ]; [ 0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0 ]; [ 0,0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0,0 ]; [ 0,0,0,0,1,2,2,2,2,2,2,2,2,2,2,2,2,1,0,0,0,0 ]; [ 0,0,0,0,0,1,2,2,2,2,2,2,2,2,2,2,1,0,0,0,0,0 ]; [ 0,0,0,0,0,0,1,2,2,2,2,2,2,2,2,1,0,0,0,0,0,0 ]; [ 0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0 ]; [ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 ]; ], } $p->width $p->height $p->ncolors $p->colors $p->pixels =head2 Methods =over 4 =item I->new([I]) Creates a blessed readxpm object. If an XPM filename is given, it is parsed. =item I(I) Reads and parses the XPM image in the given filename. =item I() Returns the width of the parsed XPM image. =item I() Returns the height of the parsed XPM image. =item I() Returns the number of distinct colors in the parsed XPM image. =item I() Returns the table of colors (in RRGGBB format) of the parsed XPM image. =item I() Returns an array of arrays, representing the indices of the colors from the XPM image. =item I(I) Creates a filename with the html text necessary to render the XPM image in a table. =back =head1 AUTHOR John C. Norton jcnorton@charter.net Copyright (c) 2007 John C. Norton. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 VERSION Version 1.000 (February 2007) =head1 SEE ALSO perl(1) =cut