path: root/net-print/lprng/files/lpdomatic

#! /usr/bin/perl
# $Header: /var/cvsroot/gentoo-x86/net-print/lprng/files/lpdomatic,v 1.1 2002/05/04 22:45:53 woodchip Exp $

# This is lpdomatic, a filter script for LPD.  It is designed to be
# used together with a printer definition file.
#
# Save it somewhere, mark it executable, and point your lpd queue's
# if= attribute at it.  Also, point the af= attribute at an
# LPD-O-Matic printer definition file obtained from the Linux Printing
# website.  
#
# See http://www.picante.com/~gtaylor/pht/lpd-doc.html

# Set this to a command you've got installed
my $enscriptcommand = "mpage -o -1 -P- -";

# my $enscriptcommand = "enscript args???";
# my $enscriptcommand = "nenscript args??";
# my $enscriptcommand = "a2ps args??";

# Set debug to 1 to enable the debug logfile for this filter; it will
# appear as /tmp/prnlog It will contain status from this filter, plus
# Ghostscript stderr output.
#
# WARNING: This logfile is a security hole; do not use in production.

my $debug=0;

# Where to send debugging log output to
if ($debug) {
    # Grotesquely unsecure; use for debugging only
    open LOG, ">/tmp/prnlog";
    $logh = *LOG;

    use IO::Handle;
    $logh->autoflush(1);
} else {
    $logh=*STDERR;
}

######### End interesting enduser options ##############

#
# lpdomatic Perl Foomatic filter script for LPD
#
# Copyright 1997-2000 Grant Taylor <gtaylor@picante.com>
#
#   This program is free software; you can redistribute it and/or modify it
#   under the terms of the GNU General Public License as published by the Free
#   Software Foundation; either version 2 of the License, or (at your option)
#   any later version.
#
#   This program is distributed in the hope that it will be useful, but
#   WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
#   or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
#   for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#



# Flush everything immediately.
$|=1;
$SIG{PIPE}='IGNORE';

my $lomversion='$Revision: 1.1 $';
print $logh "Lpdomatic backend version $lomversion running...\n";
print $logh "$0: called with arguments: '",join("','",@ARGV),"'\n";

# We get the defition filename as the accounting file argument, which
# is the last argument
my $af = $ARGV[$#ARGV];

print $logh "$0: af=$af\n";

open PPD, "$af" || do {
    print $logh "$0: error opening $ppdfile.\n";
    die "unable to open printer declaration file $ppdfile";
};
my @datablob = <PPD>;
close PPD;

# OK, we have the datablob
eval join('',@datablob) || do {
    print $logh "$0: unable to evaluate datablob\n";
    die "error in datablob eval";
};

$dat = $VAR1;

# First, for arguments with a default, stick the default in as the userval.
for $arg (@{$dat->{'args'}}) {
    if ($arg->{'default'}) {
        $arg->{'userval'} = $arg->{'default'};
    }
}



# Do we get options from within the job postscript?  We might from a
# classical ppd-grokking postscript generating application.  In that
# case, we should have stuffed something we can extract into the
# postscript stream (ie, the standard PPD mechanism) and parsed it out
# here.  (Structured comments are probably ideal for this purpose?)
# When we get there, be careful to let command-line options override
# job contents.


# There is no good way to get the options to us easily on the
# commandline.  Some lpr's support -z to pass options, but not the
# usual one that everyone actually uses ;(
#
# We override the -J aka "Job Title" value (passed in as -j to this
# filter) for our own nefarious purposes.

# Get options
use Getopt::Std;
getopts("cw:l:i:n:j:h:z:o:");
my $optstr = $opt_j;
my $sep = ' ';
if (defined($ENV{'LPOPTS'})) {
    # Cool!  We're running under a snazzy lpd that passes options this way
    $optstr = $ENV{'LPOPTS'};
    $gotlpopts = 1;
    $sep = ',';
}

print $logh "$0: options: '", $optstr, "'\n";

# Everything below this point was once identical to cupsomatic.  Now
# it's subtly different and mangled.  I really ought to combine
# scripts, or modularize, or something...

my @opts = split(/$sep/,$optstr);
optionproc: for (@opts) {
    print $logh "$0: pondering option `$_'\n";

    if (lc($_) eq 'docs') {
        $do_docs = 1;
        last;
    }

    my $arg;
    if (m!(.+)=(.+)!) {
        my ($aname, $avalue) = ($1, $2);

        # Standard arguments?
        # media=x,y,z
        # sides=one|two-sided-long|short-edge

        # handled by cups for us?
        # page-ranges=
        # page-set=
        # number-up=

        # brightness= gamma= these probably collide with printer-specific
        # options.  Hmm.  CUPS has a stupid design for option
        # handling; everything gets all muddled together.

        # Rummage around in the media= option for known media, source, etc types.
        # We ought to do something sensible to make the common manual
        # boolean option work when specified as a media= tray thing.
        # 
        # Note that this fails miserably when the option value is in
        # fact a number; they all look alike.  It's unclear how many
        # drivers do that.  We may have to standardize the verbose
        # names to make them work as selections, too.

        if ($aname =~ m!^media$!i) {
            my @values = split(',',$avalue);
            for (@values) {
                if ($dat->{'args_byname'}{'PageSize'}
                    and $val=valbyname($dat->{'args_byname'}{'PageSize'},$_)) {
                    $dat->{'args_byname'}{'PageSize'}{'userval'} = 
                        $val->{'value'};
                } elsif ($dat->{'args_byname'}{'MediaType'}
                         and $val=valbyname($dat->{'args_byname'}{'MediaType'},$_)) {
                    $dat->{'args_byname'}{'MediaType'}{'userval'} =
                        $val->{'value'};
                } elsif ($dat->{'args_byname'}{'InputSlot'}
                         and $val=valbyname($dat->{'args_byname'}{'InputSlot'},$_)) {
                    $dat->{'args_byname'}{'InputSlot'}{'userval'} = 
                        $val->{'value'};
                } elsif (lc($_) eq 'manualfeed') {
                    # Special case for our typical boolean manual
                    # feeder option if we didn't match an InputSlot above
                    if (defined($dat->{'args_byname'}{'ManualFeed'})) {
                        $dat->{'args_byname'}{'ManualFeed'}{'userval'} = 1;
                    }
                } else {
                    print $logh "$0: unknown media= component $_.\n";
                }
            }

        } elsif ($aname =~ m!^sides$!i) {
            # Handle the standard duplex option, mostly
            if ($avalue =~ m!^two-sided!i) {
                if (defined($dat->{'args_byname'}{'Duplex'})) {
                    $dat->{'args_byname'}{'Duplex'}{'userval'} = '1';
                }
            }

            # We should handle the other half of this option - the
            # BindEdge bit.  Also, are there well-known ipp/cups
            # options for Collate and StapleLocation?  These may be
            # here...

        } else {
            # Various non-standard printer-specific options
            if ($arg=argbyname($aname)) {
                $arg->{'userval'} = $avalue;
            } else {
                print $logh "$0: unknown option $aname\n";
            }
        }
    } elsif (m!no(.+)!i) {
        # standard bool args:
        # landscape; what to do here?
        # duplex; we should just handle this one OK now?

        if ($arg=argbyname($1)) {
            $arg->{'userval'} = 0;
        } else {
            print $logh "$0: unknown option $1\n";
        }
    } elsif (m!(.+)!) {
        if ($arg=argbyname($1)) {
            $arg->{'userval'} = 1;
        } else {
            print $logh "$0: unknown option $1\n";
        }
    }
}


#### Everything below here ought to be generic for any printing
#### system?  It just uses the $dat structure, with user values filled
#### in, and turns postscript into printer data.


# Construct the proper command line.
my $commandline = $dat->{'cmd'};
my $arg;
 argument:
    for $arg (sort { $a->{'order'} <=> $b->{'order'} } 
              @{$dat->{'args'}}) {
        
        my $name = $arg->{'name'};
        my $spot = $arg->{'spot'};
        my $varname = $arg->{'varname'};
        my $cmd = $arg->{'proto'};
        my $comment = $arg->{'comment'};
        my $type = $arg->{'type'};
        my $cmdvar = "";
        my $userval = $arg->{'userval'};
        
        if ($type eq 'bool') {

            # If true, stick the proto into the command line
            if (defined($userval) && $userval == 1) {
                $cmdvar = $cmd;
            }

        } elsif ($type eq 'int' or $type eq 'float') {

            # If defined, process the proto and stick the result into
            # the command line or postscript queue.
            if (defined($userval)) {
                my $min = $arg->{'min'};
                my $max = $arg->{'max'};
                if ($userval >= $min and $userval <= $max) {
		    my $sprintfcmd = $cmd;
		    $sprintfcmd =~ s!\%([^s])!\%\%$1!g;
		    $cmdvar = sprintf($sprintfcmd,
                                      ($type eq 'int' 
                                       ? sprintf("%d", $userval)
                                       : sprintf("%f", $userval)));
                } else {
                    print $logh "Value $userval for $name is out of range $min<=x<=$max.\n";
                }
            }

        } elsif ($type eq 'enum') {

            # If defined, stick the selected value into the proto and
            # thence into the commandline
            if (defined($userval)) {
                my $val;
                if ($val=valbyname($arg,$userval)) {
		    my $sprintfcmd = $cmd;
		    $sprintfcmd =~ s!\%([^s])!\%\%$1!g;
		    $cmdvar = sprintf($sprintfcmd,
                                      (defined($val->{'driverval'})
                                       ? $val->{'driverval'}
                                       : $val->{'value'}));
                } else {
                    # User gave unknown value?
                    print $logh "Value $userval for $name is not a valid choice.\n";
                }
            }

        } else {
                    
            print $logh "unknown type for argument $name!?\n";
            # die "evil type!?";
                    
        }
        
        if ($arg->{'style'} eq 'G') {
            # Place this Postscript command onto the prepend queue.
            push (@prepend, "$cmdvar\n");
            print $logh "prepending: $cmdvar\n";

        } elsif ($arg->{'style'} eq 'J') {
           # put PJL commands onto PJL stack...
           if ( "$cmdvar" ne "" ) {
               push (@pjlprepend, "\@PJL $cmdvar\n");
           }

        } elsif ($arg->{'style'} eq 'C') {
            # command-line argument

            # Insert the processed argument in the commandline
            # just before the spot marker.
            $commandline =~ s!\%$spot!$cmdvar\%$spot!;
        }
        
    }


### Tidy up after computing option statements for all of P, J, and C types:

## C type finishing
# Pluck out all of the %n's from the command line prototype
my @letters = qw/A B C D E F G H I J K L M Z/;
for $spot (@letters) {
    # Remove the letter marker from the commandline
    $commandline =~ s!\%$spot!!;
}

## J type finishing
# Compute the proper stuff to say around the job
if ($dat->{'pjl'}) {

    # Stick beginning of job cruft on the front of the pjl stuff...
    unshift (@pjlprepend,
             "\033%-12345X\@PJL JOB NAME=\"LPDOMATIC\"\n");

    # Arrange for PJL EOJ command at end of job
    push (@pjlappend,
          "\33%-12345X\@PJL RESET\n\@PJL EOJ\n");

    print $logh "PJL: ", @pjlprepend, "<job data>\n", @pjlappend;
}


# Debugging printout of all option values
if ($debug) {
    for $arg (@{$dat->{'args'}}) {
        my ($name, $val) = ($arg->{'name'}, $arg->{'userval'});
        print $logh "Final value for option $name is $val\n";
    }
}

if (! $do_docs) {
    # Run the proper command line.
    print $logh "$0: running: $commandline\n";

    # OK.  Examine the input to see if it is text or Postscript
    my $first_line = <STDIN>;
    if ($first_line =~ m/^(.?)%!/) { # optional stupid Windows control-char
        # The job is Postscript...
        print $logh "$0: postscript job line1=>$first_line<\n";

        # get a handle on | commandline | us pjlstuffing | postpipe
        my ($driverhandle, $driverpid) = getdriverhandle();
        
        # Now spew the job into the driver
        print $driverhandle $first_line;
        while (<STDIN>) { 
            print $driverhandle $_; 
        }

        print $logh "closing $driverhandle\n";
        close $driverhandle
            or die "Error closing pipe to $commandline";
        print $logh "closed $driverhandle\n";

	# Wait for driver child
        waitpid($driverpid, 0);

        exit(0);

    } else {
        # The job is ascii, we guess.
        print $logh "$0: ascii job\n";

        # Implement:
        # lpdomatic | $enscriptcommand | getdriverhandle()..
        #       KID1^                  

        # plus an optional | $postpipe on the end, handled by KID3

        my $pid, $sleep_count=0;
        do {
            $pid = open(KID1, "|-");
            unless (defined $pid) {
                warn "cannot fork: $!";
                die "bailing out" if $sleep_count++ > 6;
                sleep 10;
            }
        } until defined $pid;
        
        if ($pid) {
            # parent; write the job data into KID1 aka $enscriptcommand

            print KID1 $first_line;
            print $logh "printing: $first_line";
            while (<STDIN>) { 
                print KID1 $_; 
                print $logh "printing: $_";
            }

            close KID1;

            print $logh "root process done writing job data in\n";
            exit(0);

        } else {

            my ($driverhandle, $driverpid) = getdriverhandle();

            print $logh "setting STDOUT to be $driverhandle and spawning $enscriptcommand\n";

            open (STDOUT, ">&$driverhandle")
                or die "Couldn't dup driverhandle";
            exec "$enscriptcommand" 
                or die "Couldn't exec $enscriptcommand";
        }
    }


    die "shouldn't get here...";


} else {
    print $logh "$0: printing docs\n";
    close $logh;

    $commandline = "| $enscriptcommand | $commandline $postpipe";
    open PRINTER, $commandline || die "unable to run $commandline";
    select PRINTER;

    my ($make, $model, $driver) 
        = ($dat->{'make'}, $dat->{'model'}, $dat->{'driver'});

    my $optstr = ($gotlpopts 
                  ? "Specify each option with a -o argument to lpr ie\n% lpr -o duplex -o two=2 -o three=3"
                  : "Specify space-separated options to lpr with the -J flag ie\n% lpr -J'duplex two=2 three=3'");

    print "Invokation summary for your $make $model printer as driven by
the $driver driver.

$optstr

The following options are available for this printer:

";

    for $arg (@{$dat->{'args'}}) {
        my ($name,
            $required,
            $type,
            $comment,
            $spot,
            $default) = ($arg->{'name'},
                         $arg->{'required'},
                         $arg->{'type'},
                         $arg->{'comment'},
                         $arg->{'spot'},
                         $arg->{'default'});
        
        my $reqstr = ($required ? " required" : "n optional");
        print "Option `$name':\n  A$reqstr $type argument.\n  $comment\n";
        print "  This option corresponds to a PJL command.\n" if ($spot eq 'Y');
        
        if ($type eq 'bool') {
            if (defined($default)) {
                my $defstr = ($default ? "True" : "False");
                print "  Default: $defstr\n";
            }
            print "  Example: `$name'\n";
        } elsif ($type eq 'enum') {
            print "  Possible choices:\n";
            my $exarg;
            for (@{$arg->{'vals'}}) {
                my ($choice, $comment) = ($_->{'value'}, $_->{'comment'});
                print "   o $choice: $comment\n";
                $exarg=$choice;
            }
            if (defined($default)) {
                print "  Default: $default\n";
            }
            print "  Example: $name=$exarg\n";
        } elsif ($type eq 'int' or $type eq 'float') {
            my ($max, $min) = ($arg->{'max'}, $arg->{'min'});
            my $exarg;
            if (defined($max)) {
                print "  Range: $min <= x <= $max\n";
                $exarg=$max;
            }
            if (defined($default)) {
                print "  Default: $default\n";
                $exarg=$default;
            }
            if (!$exarg) { $exarg=0; }
            print "  Example: $name=$exarg\n";
        }

        print "\n";
    }
    
    select STDOUT;
    close PRINTER;
}

# WTF?!
die "unable to run command '$command'\n";

# return glob ref to "| commandline | self(pjlstuffer) | $postpipe"
# also return driver pid.  must wait on diver pid
# ugly, we use $commandline, $postpipe, @prepend, @pjlprepend, @pjlappend globals
sub getdriverhandle {

    pipe KID3_IN, KID3;
    my $pid3 = fork();
    if (!defined($pid3)) {
        print $logh "$0: cannot fork for kid3!\n";
        die "can't for for kid3\n";
    }
    if ($pid3) {

        # we are the parent; return a glob to the filehandle
        close KID3_IN;
        print KID3 @prepend;
        print $logh "$0: prepended:\n", @prepend;

        KID3->flush();
        return ( *KID3, $pid3 );

    } else {
        close KID3;

        pipe KID4_IN, KID4;
        my $pid2 = fork();
        if (!defined($pid2)) {
            print $logh "$0: cannot fork for kid4!\n";
            die "can't fork for kid4\n";
        }
        
        if ($pid2) {
            # parent, child of primary task; we are |commandline|
            close KID4_IN;

            print $logh "gs  PID pid2=$pid2\n";
            
            close STDIN                or die "couldn't close STDIN in $pid2";
            open (STDIN, "<&KID3_IN")  or die "Couldn't dup KID3_IN";
            open (STDOUT, ">&KID4")    or die "Couldn't dup KID4";
	    if ($debug) {
		open (STDERR, ">&$logh") 
		    or die "Couldn't dup logh to stderr";
	    }

            exec "$commandline"        or die "Couldn't exec $commandline";
            
        } else {
            # child, trailing task on the pipe; we write pjl stuff
            close KID4;

            my $fileh = *STDOUT;
            if ($postpipe) {
                open PIPE,$postpipe
                    or "die cannot open postpipe $postpipe";
                $fileh = *PIPE;
            }           

            # wrap the PJL around the job data, if there are any
            # options specified...
	    if ( @pjlprepend > 1 ) {
		print $fileh @pjlprepend;
	    }
            while (<KID4_IN>) {
                print $fileh $_;
            }
	    if ( @pjlprepend > 1 ) {
		print $fileh @pjlappend;
	    }
            
            close $fileh or die "error closing $fileh";
                
            print $logh "tail process done writing data to $fileh\n";

            exit(0);
        }
    }
}

# Find an argument by name in a case-insensitive way
sub argbyname {
    my $name = @_[0];

    my $arg;
    for $arg (@{$dat->{'args'}}) {
        return $arg if (lc($name) eq lc($arg->{'name'}));
    }

    return undef;
}

sub valbyname {
    my ($arg,$name) = @_;

    my $val;
    for $val (@{$arg->{'vals'}}) {
        return $val if (lc($name) eq lc($val->{'value'}));
    }

    return undef;
}