CF: Step #1 of Perl/Tk client

[krisb@ender.ring.org]

Tested on Perl 5.004 (AIX) and Tk "402.000"

Currently does not handle monochrome (only color)
Deliberately ignoring XPM "extensions"

Please let me know if this breaks and send me a test case

-Kris

## xpm2photo.pl 
## copywrite 1999 Kris Bosland
## All rights reserved
## permission granted to use under the GPL
## This notice must be included in all uses
## USAGE:
##
##        use Tk;
##        my $main = MainWindow->new();
##        my $photo = $main->Photo();
##        open(IN, "test.xpm");
##        my @xpm = <IN>;
##        close(IN);
##
## ====>  xpm2photo($photo,@xpm);
##
##        my $label = $main->Label( '-image' => $photo )->pack();
##        MainLoop();
##
sub xpm2photo ($@) {
    my $photo = shift;
    
    my (%colormap, $char, $tmp, $line, @tmp,
        %tmpmap, $i, $j, $height, $width, $colors,
	@tmp2, $char_per_color);

    my $mode = 'c'; #Add ability to change mode later?
    
    $i = 0;  #Track the value of "y"
    $photo->blank();
    LINE: foreach $line (@_) {
        chomp $line;

        #Comment line: =>/* pixels */<=
        next LINE if $line =~ m=^\s*/\*.*\*/\s*$=;

	#Ignore opening line =>static char * my_xpm[] = {<= 
	#"}" for editor match
	next LINE if !defined($height) and $line =~ /^\s*static/i;

        #Get data between first and second quote =>"24 24 4 1",<=
        $line =~ s/^[^"]*"([^"]*)".*$/$1/;
	
	#Try to get height =>24 24 4 1<=
	if(!defined($height)) {
	    die "Bad Line! =>$line<= before height, etc. line"
	        if not ($height, $width, $colors, $char_per_color) = 
		($line =~ /^\s*(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s*$/);

            #Now that we know the height and width,
	    #we can configure the Photo
            $photo->configure(
		'-height' => $height,
		'-width' => $width,
	    );
	    next LINE;
	}

        #Try to get next color
	#All this tmp stuff is yucky to me.  I would like more
	#list operator stuff...
	if($colors) {
	    $colors--;
	    $char = substr($line, 0, $char_per_color);
	    (undef, @tmp) = split(/\cI/, substr($line, $char_per_color));
	    for $tmp (@tmp) {
	        push(@tmp2, split(' ', $tmp, 2)) or
	            die "Bad color map line: =>$line<= (want mode $mode)";
	    }
	    %tmpmap = @tmp2;
	    die "Bad color map line: =>$line<= (want mode $mode)"
	        if !defined($tmpmap{$mode});
	    $colormap{$char} = $tmpmap{$mode};
	    next LINE;
	}

        #Actual data line.  Go through the line
	#and try to place pixels into the photo
        #$i is the line#, starting with 0 and incr after...
	#NOTE: i == "y" and j == "x".
	for($j = 0; $j < $width; $j++) {
	    $char = substr($line, 
	        $j * $char_per_color, $char_per_color);
	    die "No color for char: =>$char<="
	        unless defined($colormap{$char});
	    $photo->put(
	        $colormap{$char},
		'-to', $j, $i,
	    ) if $colormap{$char} !~ /^none$/i;
	}
	$i++;
    }
}


-
[you can put yourself on the announcement list only or unsubscribe altogether
by sending an email stating your wishes to crossfire-request@ifi.uio.no]