File Coverage

blib/lib/Image/Xpm.pm

Criterion	Covered	Total	%
statement	202	246	82.1
branch	83	138	60.1
condition	35	69	50.7
subroutine	13	18	72.2
pod	9	9	100.0
total	342	480	71.2

package Image::Xpm;    # Documented at the __END__

use strict;

use vars qw($VERSION @ISA);
$VERSION = '1.12';

use Image::Base;

@ISA = qw(Image::Base);


use Carp qw(carp croak);
use Symbol ();

### Data structures
#
# We will call the characters that are used to signify a particular colour the
# cc's.
#
# -palette is a hash keyed by the cc's whose values are hashes of palette
# colours, e.g. key x colour pairs.
#
# -cindex hash is a hash keyed by colour name ('#ffffff', 'blue' etc) whose
# values are the cc's in the palette that represent that colour. Note that the
# colour names are all lowercased even if they are mixed case in the palette
# itself.
#
# -pixels is a string of cc's which is effectively a vector of 8, 16, 24, 32
# bits, etc.
#
# -extlines are lines of text used for any extensions; if we read any in we
# hold them with the image and write them out if the image is saved, but we do
# not process them.


# Private class data

# If you inherit don't clobber these fields!
my @FIELD = qw(-file -width -height -ncolours -cpp -hotx -hoty -cc
               -palette -cindex -pixels
               -extname -extlines -comments -commentpixel -commentcolour);

# States for parsing an xpm file
my $STATE_START      =   0;
my $STATE_IN_COMMENT =   1;
my $STATE_ARRAY      =   2;
my $STATE_VALUES     =   3;
my $STATE_COLOURS    =   4;
my $STATE_PIXELS     =   5;
my $STATE_EXTENSIONS =   6;
my $STATE_FINISH     =   7;

my $MAX_CH           = 255;
my $CH_BS            = 127;
my $CH_BSLASH        =  92;
my $CH_QUOTE         =  39;
my $CH_DQUOTE        =  34;
my $CH_SPACE         =  32;

my $UNSET            =  -1;

### Private methods
#
# _get          object inherited
# _set          object inherited
# _nextcc       object
# _add_colour   object
# _add_color    object


sub _nextcc { # Object method
    my $self  = shift;
#    my $class = ref($self) || $self;

    while (exists $self->{-palette}{$self->{-cc}}) {
        my @ch    = unpack "C$self->{-cpp}", $self->{-cc};
        my $found = 0;
        foreach my $i (reverse 0..$self->{-cpp} - 1) {
            if ($ch[$i] < $MAX_CH) {
                $ch[$i]++;
                $ch[$i]++ # Skip BS, \, ' and " -- using magic nums for speed
                while $ch[$i] == $CH_BS    or $ch[$i] == $CH_BSLASH or
                      $ch[$i] == $CH_QUOTE or $ch[$i] == $CH_DQUOTE;
                $found++;
                last; # Finish as soon as we've incremented something
            }
            else {
                $ch[$i] = $CH_SPACE; # Skip control chars
            }
        }
        croak "_nextcc() ran out of palette characters" unless $found;
        $self->{-cc} = pack "C$self->{-cpp}", @ch;
    }

    croak "_nextcc() cpp is too small"
    if length($self->{-cc}) > $self->{-cpp};

    $self->{-cc};
}


*_add_color = \&_add_colour;

sub _add_colour { # Object method
    my $self     = shift;
#    my $class    = ref($self) || $self;
    my $colour   = shift;
    my $lccolour = lc $colour;

    return $self->{-cindex}{$lccolour} if exists $self->{-cindex}{$lccolour};

    $self->{-cc} = $self->_nextcc if exists $self->{-palette}{$self->{-cc}};
    $self->{-palette}{$self->{-cc}} = { c => $colour };
    $self->{-cindex}{$lccolour}     = $self->{-cc};
    $self->{-ncolours}++;

    $self->{-cc};
}



sub DESTROY {
   ; # Save's time
}


### Public methods


sub new { # Class and object method
    my $self  = shift;
    my $class = ref($self) || $self;
    my $obj   = ref $self ? $self : undef;
    my %arg   = @_;

    # Defaults
    $self = {
            '-hotx'          => $UNSET,
            '-hoty'          => $UNSET,
            '-cpp'           => 1,
            '-palette'       => {},
            '-cindex'        => {},
            '-pixels'        => '',
            '-comments'      => [],
            '-commentpixel'  => '', # Typically /* pixels */
            '-commentcolour' => '', # Typically /* colors */
            '-extlines'      => [],
        };

    bless $self, $class;

    # If $obj->new copy original object's data
    if (defined $obj) {
        foreach my $field (@FIELD) {
            $self->_set($field, $obj->_get($field));
        }
    }

    # Any options specified override
    foreach my $field (@FIELD) {
        $self->_set($field, $arg{$field}) if defined $arg{$field};
    }

    $self->{-cc} = ' ' x $self->{-cpp};

    my $file = $self->get('-file');
    if (defined $file and not $self->{-pixels}) {
    	$self->load if ref $file or -r $file;
    }
    croak "new() `$file' not found or unreadable"
    if defined $file and not defined $self->get('-width');

    foreach my $field (qw(-width -height -cpp)) {
        croak "new() $field must be set" unless defined $self->get($field);
    }

    if (not $self->{-pixels}) {
        $self->{-pixels} = ' ' x
            ($self->{-width} * $self->{-height} * $self->{-cpp});
        $self->_add_colour('white');
    }

    $self;
}


# get() is inherited


sub set { # Object method
    my $self  = shift;
#    my $class = ref($self) || $self;

    while (@_) {
        my $field = shift;
        my $val   = shift;

        carp "set() -field has no value" unless defined $val;
        carp "set() $field is read-only"
        if $field =~
            /^-(?:cpp|comments|cindex|ncolours|palette|pixels|
                  width|height|ext(?:name|lines))/ox;
        carp "set() -hotx `$val' is out of range"
        if $field eq '-hotx' and ($val < $UNSET or $val >= $self->get('-width'));
        carp "set() -hoty `$val' is out of range"
        if $field eq '-hoty' and ($val < $UNSET or $val >= $self->get('-height'));

        $self->_set($field, $val);
    }
}


sub xy { # Object method
    my $self = shift;

    my ($x, $y, $colour) = @_;

    # xy() is common so we can't afford the expense of method calls
    if (defined $colour) {
        substr($self->{-pixels},
            ($y * $self->{-width} * $self->{-cpp}) + ($x * $self->{-cpp}),
            $self->{-cpp}) =
            $self->{-cindex}{lc $colour} || $self->_add_colour($colour);
    }
    else {
        my $cc = substr($self->{-pixels},
                    ($y * $self->{-width} * $self->{-cpp}) + ($x * $self->{-cpp}),
                    $self->{-cpp});
        return $self->{-palette}{$cc}{c} ||
               $self->{-palette}{$cc}{m} ||
               $self->{-palette}{$cc}{s} ||
               $self->{-palette}{$cc}{g} ||
               $self->{-palette}{$cc}{g4};
    }
}


sub vec { # Object method
    my $self = shift;

    my ($offset, $colour) = @_;

    if (defined $colour) {
        substr($self->{-pixels}, $offset, $self->{-cpp}) =
            $self->{-cindex}{lc $colour} || $self->_add_colour($colour);
    }
    else {
        my $cc = substr($self->{-pixels}, $offset, $self->{-cpp});
        return $self->{-palette}{$cc}{c} ||
               $self->{-palette}{$cc}{m} ||
               $self->{-palette}{$cc}{s} ||
               $self->{-palette}{$cc}{g} ||
               $self->{-palette}{$cc}{g4};
    }
}


*rgb2color = \&rgb2colour;

sub rgb2colour { # Class or object method
    my $self   = shift;
#    my $class  = ref($self) || $self;

    sprintf "#%02x%02x%02x", @_;
}


*add_colors = \&add_colours;

sub add_colours { # Object method
    my $self   = shift;
#    my $class  = ref($self) || $self;

    $self->_add_colour(shift @_) while @_;
}


*del_color = \&del_colour;

sub del_colour { # Object method
    my $self   = shift;
#    my $class  = ref($self) || $self;
    my $colour = lc shift;

    my $cc = $self->{-cindex}{$colour};
    return undef unless defined $cc; # Colour isn't there to delete

    my $cpp = $self->get(-cpp);

    for (my $i = 0; $i < length($self->{-pixels}) / $cpp; $i += $cpp) {
        return 0 if substr($self->{-pixels}, $i, $cpp) eq $cc;
    }

    delete $self->{-palette}{$cc};
    delete $self->{-colours}{$colour};
    $self->{-ncolours}--;

    1;
}


sub load { # Object method
    my $self  = shift;
#    my $class = ref($self) || $self;

    my $file  = shift() || $self->get('-file');

    croak "load() no file specified" unless $file;

    $self->set('-file', $file);

    my ($width, $height, $ncolours, $cpp, $hotx, $hoty, $extname);
    my $next_state = $STATE_START;
    my $state      = $STATE_START;
    my $err        = "load() file `$file' ";
    my %palette;
    my $i;
    local $_;
    my $fh = Symbol::gensym;

    if( not ref $file ) {
        open $fh, $file or croak "load() failed to open `$file': $!" ;
    }
    elsif( ref($file) eq 'SCALAR' ) {
	if( $] >= 5.008001 ) { # 5.8.0 dumps core when using "scalar open"
	    eval q{ open $fh, "<", $file } # avoid syntax error with pre-5.6 perls
		or croak "cannot handle scalar value: $!";
	}
	else {
	    require IO::String;
	    $fh = IO::String->new( $$file );
	}
    }
    else {
        seek($file, 0, 0) or croak "load() can't rewind handle for `$file': $!";
        $fh = $file;
    }

    $self->{-palette}       = {};
    $self->{-cindex}        = {};
    $self->{-comments}      = [];
    $self->{-extlines}      = [];
    $self->{-pixels}        = '';
    $self->{-commentpixel}  = '';
    $self->{-commentcolour} = '';

    LINE:
    while (<$fh>) {
        # Blank lines
        next LINE if /^\s*$/o;
        # Starting comment
        if ($state == $STATE_START) {
            croak "$err does not begin with /* XPM */"
            unless m,/\*\s*XPM\s*\*/,o;
            $state = $STATE_ARRAY;
            next LINE;
        }
        # Comment only lines
        if (m,^(\s*/\*.*\*/\s*)$,o) {
            my $comment = $1;
            if ($comment =~ m,^\s*/\*\s*colou?rs?\s*\*/\s*$,o) {
                $self->set(-commentcolour, $comment);
            }
            elsif ($comment =~ m,^\s*/\*\s*pixels?\s*\*/\s*$,o) {
                $self->set(-commentpixel, $comment);
            }
            else {
                push @{$self->{-comments}}, $comment;
            }
            next LINE;
        }
        # Start of multi-line comment
        if ($state != $STATE_IN_COMMENT and m,^\s*/\*,o) {
            push @{$self->{-comments}}, $_;
            $next_state = $state; # Remember the state we're due for
            $state      = $STATE_IN_COMMENT;
            next LINE;
        }
        # End of multi-line comment
        if ($state == $STATE_IN_COMMENT) {
            push @{$self->{-comments}}, $_;
            $state = $next_state if m,\*/,o;
            next LINE;
        }
        # Name of C string
        if ($state == $STATE_ARRAY) {
## While this line is specified in the xpm.ps document, the libXpm
## library itself seems to ignore the contents of this line
## completely. So Image::Xpm should also do.
#            croak "$err does not have a proper C array name"
#            unless /static\s+(?:const\s+)?char\s*\*\s*(?:const\s+)?[A-Za-z0-9_-]+\s*\[\s*\]\s*=\s*\{/o; #}
            $state = $STATE_VALUES;
            next LINE;
        }
        # Values line
        if ($state == $STATE_VALUES) {
            ($width, $height, $ncolours, $cpp, $hotx, $hoty, $extname) =
            /"\s*(\d+)\s+(\d+)\s+(\d+)\s+(\d+)
                 (?:\s+(-?\d+)\s+(-?\d+))?(?:\s+(\w+))?\s*"/ox;
            croak "$err missing width"            unless defined $width;
            croak "$err missing height"           unless defined $height;
            croak "$err missing ncolours"         unless defined $ncolours;
            croak "$err missing cpp"              unless defined $cpp;
            croak "$err zero width is invalid"    if $width    == 0;
            croak "$err zero height is invalid"   if $height   == 0;
            croak "$err zero ncolours is invalid" if $ncolours == 0;
            croak "$err zero cpp is invalid"      if $cpp      == 0;
            if ((defined $hotx and not defined $hoty) or
                (defined $hotx and $hotx >= $width) or
                (defined $hoty and $hoty >= $height)) {
                carp "$err deleted invalid hotspot";
                $hotx = $hoty = $UNSET;
            }
            $hotx = $hoty = $UNSET unless defined $hotx ;
            carp "$err unusually large cpp `$cpp'" if $cpp > 4;
            $self->{-cpp} = $cpp; # Have to do this early as possible.
            $i     = 0;
            $state = $STATE_COLOURS;
            next LINE;
        }
        # Colour palette
        if ($state == $STATE_COLOURS) {
            /"(.{$cpp})/; #" No /o since this can vary between images!
            my $cc   = $1;
            my %pair = /\s+(m|s|g4|g|c)\s+(#[A-Fa-f\d]{3,}|\w+)/go;
            $self->{-cindex}{lc $pair{'c'}} = $cc if exists $pair{'c'};
            $self->{-palette}{$cc} = { %pair };
            $i++;
            croak "$err palette larger than ncolors" if $i > $ncolours;
            if ($i == $ncolours) {
                $i = 0;
                $state = $STATE_PIXELS;
            }
            next LINE;
        }
        # Pixels
        if ($state == $STATE_PIXELS) {
            /^\s*"(.*)"/o;
            $self->{-pixels} .= $1;
            $i++;
            croak "$err more pixels than height indicates" if $i > $height;
            $state = defined $extname ? $STATE_EXTENSIONS : $STATE_FINISH
            if $i == $height;
            next LINE;
        }
        # Extensions
        if ($state == $STATE_EXTENSIONS) {
            if (/XPMENDEXT/o) {
                $state = $STATE_FINISH;
            }
            else {
                push @{$self->{-extlines}}, $_;
            }
            next LINE;
        }
        # Finish
        if ($state == $STATE_FINISH) {
## The ending brace could also happened in the line before. So don't
## do any checks anymore here.
#            croak "$err invalid ending" unless /\}\s*;/;
            last LINE;
        }
    }

    close $fh or croak "load() failed to close `$file': $!";

    push @{$self->{-extlines}}, "XPMENDEXT\n" if scalar @{$self->{-extlines}};

    $self->_set(-cpp      => $cpp);
    $self->_set(-width    => $width);
    $self->_set(-height   => $height);
    $self->_set(-ncolours => $ncolours);
    $self->_set(-extname  => $extname);

    $self->set(-hotx => $hotx, -hoty => $hoty);
}


sub save { # Object method
    my $self  = shift;
#    my $class = ref($self) || $self;

    my $file   = shift() || $self->get('-file');

    croak "save() no file specified" unless $file;

    $self->set('-file', $file);

    my ($width, $height, $cpp) = $self->get('-width', '-height', '-cpp');
    my $line;
    my $fh = Symbol::gensym;
    open $fh, ">$file" or croak "save() failed to open `$file': $!";

    $file =~ s,^.*/,,o;
    $file =~ s/\.xpm$//o;
    $file =~ tr/[-_A-Za-z0-9]/_/c;

    print $fh "/* XPM */\nstatic char *", $file, "[] = {\n";
    print $fh @{$self->get(-comments)};
    $line = qq{"$width $height } . $self->get(-ncolours) . " $cpp "; #"
    $line .= $self->get(-hotx) . " " . $self->get(-hoty) . " "
    if $self->get(-hotx) > $UNSET;
    $line .= $self->get(-extname) if defined $self->get(-extname);
    $line =~ s/\s+$//o;
    print $fh qq{$line",\n}, $self->get(-commentcolour); #"

    while (my ($cc, $pairs) = each (%{$self->{-palette}})) {
        $line = qq{"$cc }; #"
        foreach my $key (sort keys %{$pairs}) {
            $line .= "$key $pairs->{$key} ";
        }
        $line =~ s/\s+$//o;
        print $fh qq{$line",\n}; #"
    }

    print $fh $self->get(-commentpixel);

    my $comma = ',';
    for (my $y = 0; $y < $height; $y++) {
        $comma = '' if $y == $height - 1;
        print $fh
            '"',
            substr($self->{-pixels}, $y * $width * $cpp, $width * $cpp),
            qq{"$comma\n}; #"
    }

    print $fh @{$self->get(-extlines)}, "};\n";

    close $fh or croak "save() failed to close `$file': $!";
}


1;


__END__