JezK
Edit File: 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 use IO::Handle; my ($TRUE, $FALSE) = (1,0); sub pm_message($) { STDERR->print("pnmquant: $_[0]\n"); } my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); sub doVersionHack($) { my ($argvR) = @_; my $arg1 = $argvR->[0]; if (defined($arg1) && (($arg1 eq "--version") || ($arg1 eq "-version"))) { my $termStatus = system('pnmcolormap', '--version'); exit($termStatus == 0 ? 0 : 1); } } sub tempFile($) { my ($suffix) = @_; # 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=>$suffix, DIR=>File::Spec->tmpdir(), UNLINK=>$TRUE); } else { 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 $optsAreValid = GetOptions(\%cmdline, "center", "meancolor", "meanpixel", "spreadbrightness", "spreadluminosity", "floyd|fs!", "norandom", "randomseed=i", "quiet", "plain"); if (!$optsAreValid) { pm_message("Invalid option syntax"); exit(1); } if (@ARGV > 2) { pm_message("This program takes at most 2 arguments. You specified " . scalar(@ARGV)); exit(1); } elsif (@ARGV < 1) { pm_message("You must specify the number of colors as an argument."); exit(1); } my $infile; $cmdline{ncolors} = $ARGV[0]; if (!($cmdline{ncolors} =~ m{ ^[[:digit:]]+$ }x ) || $cmdline{ncolors} == 0) { pm_message("Number of colors argument '$cmdline{ncolors}' " . "is not a positive integer."); 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_center, $opt_meanpixel, $opt_meancolor, $opt_spreadbrightness, $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)) { pm_message("Unable to create temporary file for colormap. " . "errno = $ERRNO"); exit(1); } my $averageOpt; my $colorSummaryOptCt = (defined($opt_meanpixel) ? 1 : 0) + (defined($opt_meancolor) ? 1 : 0) + (defined($opt_center) ? 1 : 0); if ($colorSummaryOptCt > 1) { pm_message("You can specify only one of " . "-meanpixel, -meancolor, and -center"); exit(1); } if (defined($opt_meanpixel)) { $averageOpt = "-meanpixel"; } elsif (defined($opt_meancolor)) { $averageOpt = "-meancolor"; } else { $averageOpt = "-center"; } my $spreadOptCt = (defined($opt_spreadluminosity) ? 1 : 0) + (defined($opt_spreadbrightness) ? 1 : 0); if ($spreadOptCt > 1) { pm_message("You can specify only one of " . "-spreadluminosity and -spreadbrightness"); exit(1); } 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) { pm_message("pnmcolormap failed, rc=$maprc"); exit(1); } return $mapfileSpec; } sub remap($$$$$$) { my ($mapfileSpec, $opt_floyd, $opt_norandom, $opt_randomseed, $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_norandom) { if (defined($opt_randomseed)) { pm_message("You cannot specify -randomseed with -norandom"); exit(1); } push(@options, "-norandom"); } if (defined($opt_randomseed)) { if ($opt_randomseed < 0) { pm_message("-randomseed value must not be negative. " . "You specified $opt_randomseed"); exit(10); } push(@options, "-randomseed=$opt_randomseed"); } if ($opt_plain) { push(@options, "-plain"); } if ($opt_quiet) { push(@options, "-quiet"); } my $remaprc = system("pnmremap", "-mapfile=$mapfileSpec", @options); if ($remaprc != 0) { pm_message("pnmremap failed, rc=$remaprc"); exit(1); } } ############################################################################## # MAIN PROGRAM ############################################################################## doVersionHack(\@ARGV); 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->{center}, $cmdlineR->{meanpixel}, $cmdlineR->{meancolor}, $cmdlineR->{spreadbrightness}, $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->{norandom}, $cmdlineR->{randomseed}, $cmdlineR->{plain}, $cmdlineR->{quiet}); unlink($mapfileSpec) or die("Unable to unlink map file. Errno=$ERRNO");