path: root/editor/pnmquant

#!/bin/sh

##############################################################################
# This is essentially a Perl program.  We exec the Perl interpreter specifying
# this same file as the Perl program and use the -x option to cause the Perl
# interpreter to skip down to the Perl code.  The reason we do this instead of
# just making /usr/bin/perl the script interpreter (instead of /bin/sh) is
# that the user may have multiple Perl interpreters and the one he wants to
# use is properly located in the PATH.  The user's choice of Perl interpreter
# may be crucial, such as when the user also has a PERL5LIB environment
# variable and it selects modules that work with only a certain main
# interpreter program.
#
# An alternative some people use is to have /usr/bin/env as the script
# interpreter.  We don't do that because we think the existence and
# compatibility of /bin/sh is more reliable.
#
# Note that we aren't concerned about efficiency because the user who needs
# high efficiency can use directly the programs that this program invokes.
#
##############################################################################

exec perl -w -x -S -- "$0" "$@"

#!/usr/bin/perl
##############################################################################
#                         pnmquant 
##############################################################################
#  By Bryan Henderson, San Jose CA; December 2001.
#
#  Contributed to the public domain by its author.
##############################################################################

use strict;
use English;
use Getopt::Long;
use File::Spec;
#use Fcntl ":seek";  # not available in Perl 5.00503
use Fcntl;  # gets open flags

my ($TRUE, $FALSE) = (1,0);

my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2);

sub tempFile($) {

    # We trust Perl's File::Temp to do a better job of creating the temp
    # file, but it doesn't exist before Perl 5.6.1.

    if (eval { require File::Temp; 1 }) {
        return File::Temp::tempfile("pnmquant_XXXX", 
                                    SUFFIX=>".pnm", 
                                    DIR=>File::Spec->tmpdir(),
                                    UNLINK=>$TRUE);
    } else {
        my ($suffix) = @_;
        my $fileName;
        local *file;  # For some inexplicable reason, must be local, not my
        my $i;
        $i = 0;
        do {
            $fileName = File::Spec->tmpdir() . "/pnmquant_" . $i++ . $suffix;
        } until sysopen(*file, $fileName, O_RDWR|O_CREAT|O_EXCL);

        return(*file, $fileName);
    }
}



sub parseCommandLine(@) {

    local @ARGV = @_;  # GetOptions takes input from @ARGV only

    my %cmdline;

    my $validOptions = GetOptions(\%cmdline,
                                  "center",
                                  "meancolor",
                                  "meanpixel",
                                  "spreadbrightness",
                                  "spreadluminosity",
                                  "floyd|fs!",
                                  "quiet",
                                  "plain");

    if (!$validOptions) {
        print(STDERR "Invalid option syntax.\n");
        exit(1);
    }
    if (@ARGV > 2) {
        print(STDERR "This program takes at most 2 arguments.  You specified ",
              scalar(@ARGV), "\n");
        exit(1);
    } 
    if (@ARGV < 1) {
        print(STDERR 
              "You must specify the number of colors as an argument.\n");
        exit(1);
    }
    my $infile;
    $cmdline{ncolors} = $ARGV[0];
    
    if (!($cmdline{ncolors} =~ m{ ^[[:digit:]]+$ }x ) || 
        $cmdline{ncolors} == 0) {
        print(STDERR 
              "Number of colors argument '$cmdline{ncolors}' " .
              "is not a positive integer.\n");
        exit(1);
    }

    if (@ARGV > 1) {
        $cmdline{infile} = $ARGV[1];
    } else {
        $cmdline{infile} = "-";
    }

    return(\%cmdline);
}



sub setAutoflush($) {
    my ($fh) = @_;

    # Better would be $fh->autoflush() (with use IO:Handle), but older Perl
    # doesn't have it.

    my $oldFh = select($fh);
    $OUTPUT_AUTOFLUSH = $TRUE;
    select ($oldFh);
}



sub openSeekableAsStdin($) {
    my ($infile) = @_;

    # Open the input file $infile and connect it to Standard Input
    # (assuming Standard Input is now open as the Perl file handle STDIN).
    # If $infile is "-", that means just leave Standard Input alone.  But if
    # Standard Input is not seekable, copy it to a temporary regular
    # file and return a file handle for that.  I.e. the file handle we
    # return is guaranteed to be seekable.

    # Note: this all works only because STDIN is already set up on file
    # descriptor 0.  Otherwise, open(STDIN, ...) would just create a brand
    # new file handle named STDIN on some arbitrary file descriptor.
    
    if ($infile eq "-") {
        my $seekWorked = sysseek(STDIN, 0, $SEEK_SET);
        if ($seekWorked) {
            # STDIN is already as we need it.
        } else {
            # It isn't seekable, so we must copy it to a temporary regular file
            # and return that as the input file.
            
            my ($inFh, $inFilename) = tempFile(".pnm");
            if (!defined($inFh)) {
                die("Unable to create temporary file.  Errno=$ERRNO");
            }
            unlink($inFilename) or
                die("Unable to unlink temporary file.  Errno=$ERRNO");

            setAutoflush($inFh);

            while (<STDIN>) {
                print($inFh $_);
            }
            sysseek($inFh, 0, $SEEK_SET) 
                or die("Seek of temporary input file failed!  " .
                       "Errno = $ERRNO");
            *INFH = *$inFh;  # Because open() rejects '<&$inFh' 
            open(STDIN, "<&INFH");
            tell(INFH);  # Avoids bogus "INFH is not referenced" warning
        }
    } else {
        open(STDIN, "<$infile") 
            or die("Unable to open input file '$infile'.  Errno=$ERRNO");
    }
}



sub makeColormap($$$$$) {

    my ($ncolors, $opt_meanpixel, $opt_meancolor, $opt_spreadluminosity,
        $opt_quiet) = @_;

    # Make a colormap of $ncolors colors from the image on Standard Input.
    # Put it in a temporary file and return its name.

    my ($mapfileFh, $mapfileSpec) = tempFile(".pnm");

    if (!defined($mapfileFh)) {
        print(STDERR "Unable to create temporary file for colormap.  " .
              "errno = $ERRNO\n");
        exit(1);
    }

    my $averageOpt;
    if (defined($opt_meanpixel)) {
        $averageOpt = "-meanpixel";
    } elsif (defined($opt_meancolor)) {
        $averageOpt = "-meancolor";
    } else {
        $averageOpt = "-center";
    }

    my $spreadOpt;
    if (defined($opt_spreadluminosity)) {
        $spreadOpt = "-spreadluminosity";
    } else {
        $spreadOpt = "-spreadbrightness";
    }

    my @options;
    @options = ($averageOpt, $spreadOpt);
    if (defined($opt_quiet)) {
        push(@options, '-quiet');
    }

    open(STDOUT, ">$mapfileSpec");

    my $maprc = system("pnmcolormap", $ncolors, @options);

    if ($maprc != 0) {
        print(STDERR "pnmcolormap failed, rc=$maprc\n");
        exit(1);
    } 
    return $mapfileSpec;
}



sub remap($$$$) {

    my ($mapfileSpec, $opt_floyd, $opt_plain, $opt_quiet) = @_;

    # Remap the image on Standard Input to Standard Output, using the colors
    # from the colormap file named $mapfileSpec.

    my @options;
    @options = ();  # initial value

    if ($opt_floyd) {
        push(@options, "-floyd");
    }
    if ($opt_plain) {
        push(@options, "-plain");
    }
    if ($opt_quiet) {
        push(@options, "-quiet");
    }

    my $remaprc = system("pnmremap", "-mapfile=$mapfileSpec", @options);
    
    if ($remaprc != 0) {
        print(STDERR "pnmremap failed, rc=$remaprc\n");
        exit(1);
    }
}



##############################################################################
#                              MAIN PROGRAM
##############################################################################

my $cmdlineR = parseCommandLine(@ARGV);

openSeekableAsStdin($cmdlineR->{infile}); 

# Save Standard Output for our eventual output
open(OLDOUT, ">&STDOUT");
select(OLDOUT);  # avoids Perl bug where it says we never use OLDOUT 


my $mapfileSpec = makeColormap($cmdlineR->{ncolors}, 
                               $cmdlineR->{meanpixel}, 
                               $cmdlineR->{meancolor}, 
                               $cmdlineR->{spreadluminosity},
                               $cmdlineR->{quiet});

# Note that we use sysseek() instead of seek(), because we're positioning
# the file to be read by our non-Perl child process, rather than for reading
# through the Perl I/O layer.

sysseek(STDIN, 0, $SEEK_SET) 
    or die("seek back to zero on input file failed.");


open(STDOUT, ">&OLDOUT");

remap($mapfileSpec, 
      $cmdlineR->{floyd}, 
      $cmdlineR->{plain},
      $cmdlineR->{quiet});

unlink($mapfileSpec) or
    die("Unable to unlink map file.  Errno=$ERRNO");