gnuspool 1.7 / usr / sbin / gspl-ptrinstall

#! /usr/bin/perl

##
## Ptrinstall - script to set up printers for GNUspool
##
## Copyright 2008 Free Software Foundation, Inc.
##
## 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 3 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, see <http://www.gnu.org/licenses/>.
##

use Socket;

# Various options:
# Generally:
# Keyword, default/type, description, [-switch, program default]
# ! before default means don't prompt for it do it another way
# ! before switch means insert only if not specified

$Options = {
    PARALLEL => [
		 [ "open", 30, "Timeout on open before giving up" ],
		 [ "offline", 300, "Timeout on write before regarding device as offline" ],
		 [ "canhang", "N", "Running processes attached to device hard to kill" ],
		 [ "outbuffer", 1024, "Size of output buffer in bytes" ],
		 [ "reopen", "N", "Close and reopen device after each job" ] ],

    USB => [		# USB is a bit dodgy - so deal with as parallel for the time being
		 [ "open", 30, "Timeout on open before giving up" ],
		 [ "offline", 300, "Timeout on write before regarding device as offline" ],
		 [ "canhang", "N", "Running processes attached to device hard to kill" ],
		 [ "outbuffer", 1024, "Size of output buffer in bytes" ],
		 [ "reopen", "N", "Close and reopen device after each job" ] ],

    SERIAL => [		# Serial is a subset of the baud rates leaving out stupid slow ones
	         [ "baud", [ 9600, 1200, 1800, 2400, 4800, 9600, 19200, 38400 ], "Baudrate" ],
	         [ "ixon", "Y", "Set xon/xoff" ],
	         [ "ixany", "N", "Set xon/xoff with any character release" ],
	         [ "csize", [ 8, 5, 6, 7, 8], "Character size" ],
	         [ "stopbits", [1, 1, 2], "Stop bits" ],
	         [ "parenb", "N", "Parity enabled" ],
	         [ "parodd", "N", "Odd parity" ],
	         [ "clocal", "N", "No modem control" ],
	         [ "open", 30, "Timeout on open before giving up" ],
	         [ "offline", 300, "Timeout on write before regarding device as offline" ],
	         [ "canhang", "N", "Running processes attached to device hard to kill" ],
	         [ "outbuffer", 1024, "Size of output buffer in bytes" ],
	         [ "reopen", "N", "Close and reopen device after each job" ],
	         [ "onlcr", "N", "Insert CR before each newline" ] ],

    STDNET => [		# General network parameters
	       [ "open", 30, "Timeout on open before giving up" ],
	       [ "offline", 300, "Timeout on write before regarding device as offline" ],
	       [ "close", 10000, "Time to wait for close to complete" ],
	       [ "postclose", 1, "Time to wait after close" ],
	       [ "canhang", "N", "Running processes attached to device hard to kill" ],
	       [ "outbuffer", 1024, "Size of output buffer in bytes" ],
	       [ "reopen", "Y", "Restart server after each job" ],
	       [ "logerror", "Y", "Log error messages to system log" ],
	       [ "fberror", "Y", "Display error messages on screen" ] ],

    LPDNET => [		# Specific to LPD
	       [ "host", '!$SPOOLDEV', "Host address of server", 'H' ],
	       [ "ctrlfile", "!SDATADIR/xtlpc-ctrl", "Control file", 'f' ],
	       [ "outip", "!h", "Outgoing host name", 'S' ],
	       [ "lpdname", "!S", "Printer name for protocol", 'P' ],
	       [ "nonull", "Y", "Do not send null jobs", 'N' ],
	       [ "resp", "N", "Use reserved port", '!U' ],
	       [ "loops", 3, "Attempts to connect", 'l', 3 ],
	       [ "loopwait", 1, "Seconds to wait between connect attempts", 'L', 1 ],
	       [ "itimeout", 5, "Input timeout (for response packets", 'I', 5 ],
	       [ "otimeout", 5, "Output timeout (response receiving data", 'O', 5 ],
	       [ "retries", 0, "Number of retries after timeouts", 'R', 0 ],
	       [ "linger", 'f:0', "Linger time (may be fractional)", 's', 0 ] ],

    TELNET => [		# Specific to telnet
	       [ "host", '!$SPOOLDEV', "Host name of server", 'h' ],
	       [ "port", 'p:9100', "Output port", 'p', 9100 ],
	       [ "loops", 3, "Attempts to connect", 'l', 3 ],
	       [ "loopwait", 1, "Seconds to wait between connect attempts", 'L' ],
	       [ "endsleep", 0, "Time for process to sleep at end of each job", 't', 0 ],
	       [ "linger", 'f:0', "Linger time (may be fractional", 's', 0 ] ],

    FTP => [		# Specific to FTP
	       [ "host", '!$SPOOLDEV', "Host name of server", 'h' ],
	       [ "myhost", '!h', "IP to send from", 'A' ],
	       [ "port", 'p:ftp', "Control port", 'p', "ftp" ],
	       [ "username", "s:", "User name", 'u' ],
	       [ "password", "s:", "Password", 'w' ],
	       [ "directory", 's:', "Directory name on server", 'D' ],
	       [ "outfile", "s:", "Output file on server", 'o' ],
	       [ "textmode", "N", "Force text mode", 't' ],
	       [ "timeout", 750, "Timeout for select (ms)", 'T', 750 ],
	       [ "maintimeout", 30000, "Timeout for FTP (ms)", 'R', 30000 ] ],

    XTLHP => [		# Specific to SNMP
	      [ "host", '!$SPOOLDEV', "Host name of server", 'h' ],
	      [ "configfile", "!SDATADIR/xtsnmpdef", "Config file", 'f' ],
	      [ "ctrlfile", "!SDATADIR/xtlhp-ctrl", "Control file", 'c' ],
	      [ "port", 'p:9100', "Output port", 'p', 9100 ],
	      [ "myhost", '!h', "Outgoing host name (sometimes different)", 'H' ],
	      [ "commun", "s:public", "SNMP Community", 'C', "public"],
	      [ "timeout", "f:1", "UDP timeout", 'T', 1 ],
	      [ "snmpport", "p:snmp", "SNMP Port", 'S', "snmp" ],
	      [ "blksize", 10240, "Block size", 'b', 10240 ],
	      [ "next", "N", "Get next on SNMP var fetches", 'N' ] ],

    STDOPTS => [	# Spooler opts
	       [ "addcr", "N", "Add CR before each newline (text only!)" ],
	       [ "retain", "N", "Retain all jobs on queue after printing" ],
	       [ "norange", "N", "Ignore page ranges" ],
	       [ "inclpage1", "N", "Always print page 1 when printing ranges" ],
	       [ "single", "N", "Single-job mode" ],
	       [ "onecopy", "N", "Limit to one copy - handled elsewhere" ] ],

    LPDOPTS => [	# LPD variant
	       [ "addcr", "N", "Add CR before each newline (text only!)" ],
	       [ "retain", "N", "Retain all jobs on queue after printing" ],
	       [ "norange", "N", "Ignore page ranges" ],
	       [ "inclpage1", "N", "Always print page 1 when printing ranges" ],
	       [ "single", "N", "Single-job mode" ],
	       [ "onecopy", "N", "Limit to one copy - handled elsewhere" ] ] } ;

# Change previous way of recording port types

$Canonports = { LPD => "LPDNET", "REVERSE TELNET" => "TELNET", "TELNET-SNMP" => "XTLHP", "OTHER" => "OTHER" };

########################################################################
#
# Functions for formatting display
#
########################################################################

# Underline a message

sub underline {
    my $fh = shift;
    my $txt = shift;
    my $und = shift || '-';
    print $fh $txt,"\n", $und x length($txt),"\n\n";
}

# Nice formatted column

sub multicol {
    my $fh = shift;
    my $arr = shift;
    my @cw;
    for my $a (@$arr) {
	my $c = 0;
	for my $e (@$a) {
	    $cw[$c] = length($e) if $cw[$c] < length($e);
	    $c++;
	}
	
    }
    for my $a (@$arr) {
	my @e = @$a;
	my $c = 0;
	while  ($#e > 0) {
	    my $i = shift @e;
	    print $fh $i, ' ' x ($cw[$c] - length($i) + 1);
	    $c++;
	}
	my $i = shift @e;
	print $fh "$i\n";
    }
}

########################################################################
#
#	Get chars from standard input routines
#
########################################################################

# Function to get terminal stuff before we start

sub getekchars {

    # Extract terminal control characters from stty output into %Schar
    
    open(ST, "stty -a|");
    while (<ST>) {
	chop;
	s/\b(intr|quit|erase|kill)\s*=\s*([^;]*);/$Schar{$1}=$2/eg;
    }
    close ST;

    # Easier if we use "ord"

    for my $s (keys %Schar) {

	# Special case ^? for delete

	if ($Schar{$s} eq '^?') {
	    $Schar{$s} = 127;
	}
	else  {
	    $Schar{$s} = ord($1) & 31 if $Schar{$s} =~ /^\^(.)/;
	}
    }

    # Remember how to reset terminal

    $Resetty = `stty -g`;
    chop $Resetty;

    # Remember F1 key for help - but we may not have it available
    # Remember clear screen sequence

    $Func1 = `tput kf1`;
    $Clear = `tput clear`;
}

# Get a character from the terminal - using raw mode so we can recognise
# if a function key is pressed

sub getchar {
    system("stty raw -echo time 3");
    my $res;
    my $cnt;
    do  {
	$cnt = sysread STDIN, $res, 10;
    }  while $cnt == 0;
    system("stty $Resetty");
    $res;
}

sub splurgehelp {
    my $help = shift;
    my $hf = $Config{SDATADIR} . "/Psetups/pihelp/$help.txt";
    print $Clear;
    if (open(HF, $hf)) {
	print while <HF>;
	close HF;
    }
    else  {
	print "Sorry no help file for $help\n";
    }
    # Throw away char
    getchar;
}

# Get a line normally terminated by \r or \n
# Sets global $Hadfunc1

sub getline {
    my $help = shift;				# Name of help file
    my $prompt = shift;				# Prompt
    my $res = "";				# Result so far
    print $prompt;

    for  (;;)  {
	my $ch = getchar;

	if  ($ch eq "\r" || $ch eq "\n")  {	# End of input
	    print "\n";				# Echo it
	    return $res;
	}

	if  (length($ch) > 1)  {		# Function key
	    if  ($ch eq $Func1)  {		# Help key F1
		# Set we had function key one so ? doesn't get used for help any more
		$Hadfunc1 = 1;
		splurgehelp($help);
		# Clear screen again, give prompt and result so far
		print $Clear, $prompt, $res;
	    }
	    redo;
	}

	# Provide ? as a help key only if the guy hasn't managed
	# to press F1 sometime.

	unless  ($ch ne '?' || $Hadfunc1) {
	    splurgehelp($help);
	    print $Clear, $prompt, $res;
	    redo;
	}

	# Quit if interrupt or quit pressed

	my $och = ord($ch);
	if ($och == $Schar{'intr'} || $och == $Schar{'quit'})  {
	    print "\n";
	    exit 0;
	}

	# Emulate kill char

	if  ($och == $Schar{'kill'})  {
	    $res = "";
	    print "\n$prompt";
	    redo;
	}

	# Emulate erase char

	if  ($och == $Schar{'erase'})  {
	    $res = substr $res, 0, length($res)-1 unless length($res) == 0;
	    print "\b \b";
	    redo;
	}

	# Ignore non-printing chars

	redo if $och < 32 || $och > 126;

	$res .= $ch;
	print $ch;
    }
}

# Prompt for new printer name

sub getnewptrname {
    my $descr = shift;
    for  (;;)  {
	$ptr = getline('newptrname', "$descr: ");
	return $ptr if $ptr =~ /^[a-z]\w*$/;
	print "Invalid printer name $ptr please try again\n";
    }
}

# Generalised ask question routine
# Param 1 help file
# Param 2 prompt
# Param 3 default response or existing response may be omitted
# Param 4 Possibilities array may be omitted

sub askq {
    my $help = shift;
    my $prompt = shift;
    my $def = shift;
    my $poss = shift;

    # Manufacture full prompt

    my $Pr = "$prompt ";
    $Pr .= "(" . join('|', @$poss) . ") " if $poss;
    $Pr .= "[$def]" if length($def) != 0;
    $Pr .= ": ";

    my $resp;
    for  (;;)  {
	$resp = getline($help, $Pr);
	if  (length($resp) == 0)  {
	    return  $def if length($def) != 0;
	    print "Please give a response\n";
	    next;
	}
	return  $resp unless $poss;

	# If part response find first match

	for my $p (@$poss) {
	    return $p if length($resp) <= length($p) && substr(lc($p), 0, length($resp)) eq lc($resp);
	}
	print "Unknown response $resp\n";
    }
}

# Ask yes or no help, prompt, default

sub askyorn {
    my $help = shift;
    my $prompt = shift;
    my $def = shift;
    $def = $def ? 'y': 'n';
    my $ans = askq($help, $prompt, $def, [ 'y', 'n' ]);
    $ans eq 'y';
}

# Ask number help, prompt, default

sub asknum {
    my $help = shift;
    my $prompt = shift;
    my $def = shift;
    for (;;) {
	my $resp = getline($help, "$prompt [$def]: ");
	return $def if length($resp) == 0;
	return $resp if $resp =~ /^\d+$/;
	print "Please give a numeric value\n";
    }
}

# Ask and check IP address - give help and prompt

sub askip {
    my $help = shift;
    my $prompt = shift;
    for  (;;)  {
	my $dev = askq($help, $prompt);
	return $dev if  inet_aton($dev);
	print "Invalid host/device $dev please try again\n";
    }
}

# Ask port name or number

sub askport {
    my $help = shift;
    my $prompt = shift;
    my $def = shift;
    for  (;;)  {
	my $port = askq($help, $prompt, $def);
	return $port if $port =~ /^\d+$/;
	return $port if getservbyname($port,"tcp");
	print "Sorry unknown port $port\n";
    }
}

# Ask linger time might be fractional

sub askling {
    my $prompt = shift;
    my $def = shift;
    for (;;) {
	my $resp = getline("linger", "$prompt [$def]: ");
	return $def if length($resp) == 0;
	return $resp if $resp =~ /^\d+(\.\d+)?$/;
	print "Please give a numeric (possibly fractional)value\n";
    }
}

# Adjust parameters

sub adjparam {
    my ($res, $pname, $name, $def, $descr) = @_;
    my $field = $res->{$pname};

    # Second parameter gives argument type:default or ! for no questions
    # Special cases are integer for just an integer
    # Y or N for yes or no default that

    if (ref($def) eq 'ARRAY') {
	my @opts = @$def;
	my $dflt = shift @opts;
	if (defined($field->{$name}) && $field->{$name} ne $dflt)  {
	    $descr .= "(default $dflt)";
	    $dflt = $field->{$name};
	}
	$field->{$name} = askq("param", $descr, $dflt, \@opts);
	return;
    }

    return if $def =~ /!/;			# No questions

    # Yes or No case

    if ($def =~ /^[yn]$/i)  {
	$field->{$name} = askyorn("paramyorn", $descr, uc($field->{$name}) eq 'Y')? 'Y': 'N';
    }
    elsif ($def =~ /^\d+$/) {

	# Integer only case
	# If updating offer current value as default and also show default

	if (defined($field->{$name}) && $field->{$name} != $def)  {
	    $descr .= "(default $def)";
	    $def = $field->{$name};
	}

	$field->{$name} = asknum('numparam', $descr, $def);
    }
    else  {

	# Alternative types of codes of form type:default

	my ($code,$deflt) = split(':', $def);

	# When updating show default and give existing value instead of default

	if (length($deflt) != 0 && defined($field->{$name}) && $field->{$name} ne $deflt)  {
	    $descr .= "(default $deflt)";
	    $deflt = $field->{$name};
	}

	if  ($code eq 'p') {			# Port number
	    $field->{$name} = askport('portnum', $descr, $deflt);
	}
	elsif ($code eq 'h') {			# Host name
	    $field->{$name} = askip('ipaddr', $descr);
	}
	elsif ($code eq 'f') {			# Fractional (linger time)
	    $field->{$name} = askling($descr, $deflt);
	}
	elsif ($code eq 's') {			# String
	    $field->{$name} = askq("string", $descr, $deflt);
	}
    }
}

# Set up options we haven't got defined yet

sub init_def_options {
    my $res = shift;
    my $cls = shift;
    for my $o (@{$Options->{$cls}})  {
	my ($kw, $def) = @$o;
	next if defined($res->{$cls}->{$kw});
	next if $def =~ /!/;
	my ($code,$deflt) = split(':', $def);
	$res->{$cls}->{$kw} = length($deflt) > 0? $deflt: $code;
    }
}

# Run over option list and ask questions

sub ask_optionlist {
    my $res = shift;
    my $cls = shift;
    for my $o (@{$Options->{$cls}})  {
	my ($name, $val, $descr) = @$o;
	adjparam($res, $cls, $name, $val, $descr); # Need don't ask!!!!
    }
}

# Get port number or apply default

sub getportordefault {
    my $pname = shift;
    my $def = shift;
    my @plist = getservbyname($pname, 'tcp');
    return  $plist[2] if @plist;
    $def;
}

# Look for program on PATH variable

sub findonpath {
    my $prog = shift;
    for my $p (split(':', $ENV{PATH}))  {
	next unless $p =~ m|^/|;
	return "$p/$prog" if -x "$p/$prog";
    }
    undef;
}

########################################################################
#
#	Spooler manips
#
########################################################################

# Is spooler running

sub isrunning {
    system("$bindir/gspl-plist >/dev/null 2>&1") == 0;
}

# Parse master config file and set up %Config

sub parse_mconfig {

    # First set up defaults as per build

    $Config{SPOOLDIR} = eval "\"/var/spool/gnuspool\"";
    $Config{SPROGDIR} = eval "\"${exec_prefix}/lib/gnuspool\"";
    $Config{SDATADIR} = eval "\"${datarootdir}/gnuspool\"";
    $Config{SPOOLPT} = eval "\"/etc/gnuspool/ptrconf\"";

    # If there is a master config file relocating stuff read it in and
    # appropriately reset

    if (open(MC, "/etc/gnuspool/gnuspool.conf")) {
	while  (<MC>)  {
	    chop;
	    s/#.*//;
	    next unless /(\w+)[:=](\S+)/;
	    $Config{$1} = $2;
	}
	close MC;
    }
}

# Check user path set up.
# Otherwise add it to current PATH

sub check_userpath {
    die "Cannot find splist in $bindir is this set up correctly?\n" unless -f "$bindir/gspl-plist";
    for my $p (split(':', $ENV{'PATH'}))  {
	return if $p eq $bindir;
    }
    print "****Note: **** Adding $bindir to PATH\n";
    $ENV{PATH} = "$bindir:$ENV{PATH}";
}

# Set up defaults for device

sub gendevdef {
    my $def = shift;
    return $def->[0] if  ref($def) eq 'ARRAY';
    return 'N' if $def eq 'Y';
    return substr $def, 2 if $def =~ /^\w:/;
    $def;
}

# Apply options for device

sub applyopt {
    my $ptrres = shift;
    my $wh = shift;
    my $porttype = $ptrres->{PORT};
    my $opt = $Options->{$wh};
    my $ptopt = $ptrres->{$porttype};
    for my $o (@$opt) {
	my ($kw, $def, $expl, $sw) = @$o;
	next if defined $ptopt->{$kw} or $def =~ /^!/;
	$ptopt->{$kw} = $sw =~ /!/? 'N': gendevdef($def);
    }
}

# Rejig read .device entries

sub parse_devtype {
    my $ptrres = shift;
    my $porttype = $ptrres->{PORT};
    my $opt = $Options->{$porttype};
    my $ptopt = $ptrres->{$porttype};
    if ($porttype eq 'SERIAL') {
	for my $b (5 .. 8) {
	    if (defined $ptopt->{"cs%b"})  {
		$ptopt->{'csize'} = $b;
		last;
	    }
	}
	$ptopt->{'stopbits'} = 2 if defined $ptopt->{'twostop'};
    }
    applyopt($ptrres, $porttype);
    1;
}

# Parse network=command arguments in .device file to deduce options

sub parse_netwargs {
    my $ptrres = shift;
    my $nwcmd = shift;
    my $porttype = $ptrres->{PORT};

    # Canonicalise arguments to command
    # Currently assume no quotes

    my @rargs = split /\s+/, $nwcmd;
    shift @rargs;				# Get rid of program name
    my @args;
    while  (@rargs)  {
	my $a = shift @rargs;
	if  ($a =~ /^(-.)(.+)/)  {
	    push @args, $1, $2;
	}
	else  {
	    push @args, $a;
	}
    }

    my $ptopts = $ptrres->{$porttype};		# What we're trying to set

    # Get ourselves a lookup table of option flags

    my %fllu;
    for my $o (@{$Options->{$porttype}})  {
	my $fl = $o->[3];
	$fl = substr $fl, 1 if (substr $fl, 0) eq '!'; # Cover invert case ('resp' on LPDNET)
	$fllu{$fl} = $o;
    }

    while  (@args)  {
	my $arg = shift @args;
	next unless $arg =~ /^-([.])/;
	my $o = $fllu{$1};
	next unless defined $o;
	my ($name, $def, $expl, $fl) = @$o;
	# Y or N options don't take an argument and check for invert response
	$ptopts->{$name} = $def !~ /^[YN]$/? shift @args: $fl =~ /!/? 'N': 'Y';
    }
}

# Parse network=command in .device file

sub parse_netwcmd {
    my $ptrres = shift;
    my $nwcmd = shift;
    my $porttype = $ptrres->{PORT};
    applyopt($ptrres, 'STDNET');

    my %ckprog = (LPDNET => 'xtlpc', FTP => 'xtftp', XTLHP => 'xtlhp', TELNET => 'xtelnet');
    if  (defined $ckprog{$porttype})  {
	return 0 unless $nwcmd =~ /$ckprog{$porttype}/;
	parse_netwargs($ptrres, $nwcmd);
    }
    else  {
	$ptrres->{$porttype} = { COMMAND => $nwcmd };
    }
    # Cover things not defined
    applyopt($ptrres, $porttype) if defined $Options->{$porttype};
    1;
}

# Parse .device file

sub parse_device {
    my $ptrres = shift;
    my $printername = $ptrres->{PRINTER};
    my $file = shift;
    my $porttype;
    my $nwcmd;
    my %portopts;
    if  (open(DVF, $file))  {
	while  (<DVF>)  {
	    chop;
	    if  (/#\s*Porttype:\s*(\w+)/)  {
		 $porttype = uc $1;
		 $porttype = $Canonports->{$porttype} unless defined $Options->{$porttype};
		 $ptrres->{PORT} = $porttype;
	    }
	    elsif  (/^(\w+)(?:\s+(\w+))?\s*$/)  {
		$portopts{$1} = $2? $2: 'Y';
	    }
	    elsif  (/^network=(.*)/)  {
		$nwcmd = $1;
	    }
	}
	close DVF;
    }
    
    # If we didn't get a port type try to find out from keywords

    unless  ($porttype)  {

	if  ($nwcmd)  {
	    if  ($nwcmd =~ /xtlpc/)  {
		$porttype = 'LPDNET';
	    }
	    elsif ($nwcmd =~ /xtftp/)  {
		$porttype = 'FTP';
	    }
	    elsif ($nwcmd =~ /xtlhp/)  {
		$porttype = 'XTLHP';
	    }
	    elsif ($nwcmd =~ /xtelnet/)  {
		$porttype = 'TELNET';
	    }
	    else  {
		$porttype = 'OTHER';
	    }
	}
	else  {
	    if  (defined($portopts{'baud'}) || defined($portopts{'parenb'}))  {
		$porttype = 'SERIAL';
	    }
	    else  {
		$porttype = 'PARALLEL';
	    }
	}
    }

    return  0  if  $porttype =~ /Custom/i;

    $ptrres->{PORT} = $porttype;
    $ptrres->{$porttype} = \%portopts;
    
    if  ($porttype =~ /PARALLEL|SERIAL|USB/)  {
	if  ($nwcmd)  {
	    print "***Warning network print command for $printername\ndefined as $porttype - $file must have been edited\n";
	    return  0;
	}
	return 0 unless parse_devtype($ptrres);
    }
    else  {
	unless  ($nwcmd)  {
	    print "***Warning no network print command for $printername\n defined as $porttype - $file must have been edited\n";
	    return  0;
	}
	return 0 unless parse_netwcmd($ptrres, $nwcmd);
    }
    1;
}

# Parse default file

sub parse_default {
    my $ptrres = shift;
    my $printername = $ptrres->{PRINTER};
    my $file = shift;
    my ($emul, $model);
    if  (open(DFF, $file))  {
	while  (<DFF>)  {
	    chop;
	    if (/#\s*Ptrtype:\s*(.*)/)  {
		$emul = $1;
	    }
	    elsif (/#\s*Set up for\s*(.*)/)  {
	        $model = $2;
	    }
	    elsif (/#\s*Postscript emulation/) {
		$ptrres->{HASPS} = 'Y';
	    }
	    elsif (/#\s*Using ghostscript/ && findonpath('gs'))  {
		$ptrres->{GS} = 'Y';
	    }
	    elsif (/#\s*Paper:\s*(\w+)/)  {
		$ptrres->{GSSIZE} = $1;
	    }
	    elsif (/^(\w+)$/)  {
		$ptrres->{STDOPTS}->{$1} = 'Y';
	    }
	    elsif (/^-(\w+)$/)  {
		$ptrres->{STDOPTS}->{$1} = 'N';
	    }
	}
	close DFF;
    }
    return 0 if  $emul =~ /Custom/i;
    $ptrres->{TYPE} = $emul if $emul;
    $ptrres->{MODEL} = $model if $model;
    for my $o (@{$Options->{STDOPTS}})  {
	my ($kw, $def, $expl) = @$o;
	next if defined $ptrres->{STDOPTS}->{$kw};
	$ptrres->{STDOPTS}->{$kw} = gendevdef($def);
    }
    1;
}

# List defined printers

sub list_defptrs {
    my $ptrdir = $Config{SPOOLPT};
    my %plist;
    my %clist;
    if  (opendir(PTDIR, $ptrdir))  {
	while  (my $de = readdir(PTDIR))  {
	    my $sd = "$ptrdir/$de";
	    next if $de =~ /^[-.]/  ||  ! -d $sd;
	    if (-l $sd) {
		my $lc = readlink($sd);
		next if  $lc =~ m|/| || $lc eq $de;
		$clist{$de} = $lc;
	    }
	    else  {
		next unless -f "$sd/default";
		my $rp = { PRINTER => $de };
		if  (-f "$sd/.device")  {
		    next unless parse_device($rp, "$sd/.device");
		}
		else  {
		    next unless parse_device($rp, "$sd/default");
		}
		next unless  parse_default($rp, "$sd/default");
		$plist{$de} = $rp;
	    }
	}
	closedir(PTDIR);
    }
    for my $c (keys %clist) {
	my $ct = $clist{$c};
	while  (defined $clist{$ct})  {
	    $ct = $clist{$ct};
	}
	$plist{$c} = { TYPE => 'Clone', CLONEOF => $ct, PRINTER => $c };
    }
    %plist;
}

# Get printers if thing running

sub getptrs_online {
    my $tempfile = "tmppl$$";
    unless  (system("$bindir/gspl-plist -N -l -F '%p:%d:%e' >$tempfile") == 0  &&  open(TF, $tempfile))  {
	unlink $tempfile;
	return  undef;
    }
    my %result;
    while  (<TF>)  {
	chop;
	my ($ptr,$dev,$descr) = split('\s*:\s*');
	$result{$ptr} = { DESCR => $descr };
	if  ($dev =~ /<(.*)>/)  {
	    $dev = $1;
	    $result{$ptr}->{NETWORK} = 'Y';
	}
	$result{$ptr}->{DEV} = $dev;
    }
    close TF;
    unlink $tempfile;
    %result;
}

# Get printers if scheduler not running

sub getptrs_offline {
    my $spooldir = $Config{SPOOLDIR};
    my $tempfile = "tmppl$$";
    my $cplist = "$sbindir/gspl-cplist";
    my $ptrfile = "$spooldir/spshed_pfile";
    return  undef  unless -x $cplist && -r $ptrfile;
    return  undef  unless system("$cplist $ptrfile $tempfile") == 0;
    return  undef  unless  open(TF, $tempfile);
    my %result;
    while  (<TF>)  {
	chop;
	next unless my ($net, $dev, $descr, $ptr) = /^gspl-padd\s+-\w\s+-(\w)\s+-\w\s+[-A-Pa-p]+\s+-l\s+'(.*?)'\s+-D\s+'(.*?)'\s+(\w+)\s+'.*'/;
	$result{$ptr} = { DEV => $dev, DESCR => $descr };
	$result{$ptr}->{NETWORK} = 'Y' if $net eq 'N';
    }
    close  TF;
    unlink $tempfile;
    %result;
}

# Page through printers list

sub pagedisp_ptrs {

    open(OUT, "|$pager");

    underline(\*OUT, "Installed printers", "=");

    for my $p (sort keys %Ptrdeflist) {
	my $pd = $Ptrdeflist{$p};
	next unless $pd->{INSTALLED} eq 'Y';
	underline(\*OUT, $p, '-');
	my @ao;
	push @ao, [ "Description:", $pd->{DESCR} ];
	push @ao, [ "Printer emulation:", $pd->{TYPE} ];
	if  ($pd->{NETWORK})  {
	    push @ao, [ "Address/Host:", $pd->{DEV} ];
	    push @ao, [ "Protocol:", $pd->{PORT} ];
	}
	else  {
	    push @ao, [ "Port type:", $pd->{PORT} ];
	    push @ao, [ "Device:", $pd->{DEV} ];
	}
	multicol(\*OUT, \@ao);
	print OUT "\n\n";
    }

    my @dnoti;

    for my $p (sort keys %Ptrdeflist) {
	push @dnoti, $p unless $Ptrdeflist{$p}->{INSTALLED} eq 'Y';
    }

    if (@dnoti) {
	underline(\*OUT, "Defined but not Installed", "=");
	for my $p (@dnoti) {
	    my $pd = $Ptrdeflist{$p};
	    underline(\*OUT, $p, '-');
	    my @ao;
	    push @ao, [ "Printer emulation:", $pd->{TYPE} ];
	    push @ao, [ "Port type:", $pd->{PORT} ];
	    multicol(\*OUT, \@ao);
	    print OUT "\n\n";
	}
    }

    close OUT;
}

# List parallel ports.

sub list_parports {
    my $all = shift;
    my @lps = glob('/dev/lp[0-9]');
    my @res;
    for my $lp (@lps) {
	next unless -c $lp;
	my ($num) = $lp =~ m|/dev/lp(\d)|;
	my $pd = "/proc/sys/dev/parport/parport$num/autoprobe";
	unless (open(PD, $pd))  {
	    push @res, { DEV => $lp } if  $all;
	    next;
	}
	while (<PD>) {
	    next unless /MODEL:\s*(.*);/;
	    push @res, { DEV => $lp, MODEL => $1, NAME => $1 };
	}
	close PD;
    }
    \@res;
}

# Try to connect to a port

sub tryconnect {
    my $host = shift;
    my $port = shift;
    my $proto = getprotobyname('tcp');
    my $sin = sockaddr_in($port, inet_aton($host));
    socket(SOCKFD, PF_INET, SOCK_STREAM, $proto);
    my $ret = connect(SOCKFD, $sin);
    close SOCKFD;
    $ret;
}

# Get type of network connection

sub getnetworkconn {
    my $res = shift;
    my $ptr = $res->{PRINTER};
    $res->{NETWORK} = 'Y';
    
    $res->{DEV} = askip("ptrip", "Please give the host name or IP address of the $ptr");

    if  (askyorn("isconn", "Is $ptr connected, if so can I probe it", 1))  {

	# Case where we can probe the printer

	my @oports;
	for my $prt (["LPD", "LPD", 515], ["Telnet", "Reverse telnet", 9100], ["FTP", "FTP", 21]) {
	    if (tryconnect($res->{DEV}, $prt->[2])) {
		push @oports, $prt;
		$res->{TRYSNMP} = 1 if $prt->[2] == 9100;
	    }
	}
	
	if ($#oports >= 0)  {

	    # One or more ports active

	    $res->{ALIVE} = 'Y';

	    if ($#oports == 0)  {

		# Only one port available

		if  (askyorn("onlyconn", "$ptr seems to have $oports[0]->[1] connection available. Use that", 1))  {
		    my $p = uc $oports[0]->[0];
		    $p = $Canonports->{$p} unless defined $Options->{$p};
		    $res->{PORT} = $p;
		    return;
		}
		print "Sorry confused about this printer please try again\n";
		exit 0;
	    }
	    
	    # Two or more available

	    my @names;
	    map { push @names, $_->[1]; } @oports;
	    push @names, "None of those";
	    print "Your printer offers several protocols for sending data\n";
	    my $ans = askq("proto", "Which to use", $names[0], \@names);
	    for my $a (@oports) {
		if  ($ans eq $a->[1])  {
		    my $p = uc $a->[0];
		    $p = $Canonports->{$p} unless defined $Options->{$p};
		    $res->{PORT} = $p;
		    return;
		}
	    }
	    $res->{PORT} = "Other";
	    return;
	}
    }

    # Have to ask

    print <<EOT;
I need to ask you about the protocol for speaking to your printer.
I don't mean TCP/IP - that's the lower level "connection" protocol.

Protocols might be:

	LPD protocol - the most common
	Reverse Telnet - with and without "SNMP" including JetDirect
	FTP - available on some printers
	Some other protocol with a printer interface program which
	you must tell me about.

All of the above may have different options to select different
printers - this is especially true of multi-port devices.

Sorry but we cannot bypass this question!
EOT
    my $ptype = askq("proto", "Please give protocol type", "LPD", [ "LPD", "Reverse Telnet", "FTP", "Other" ]);
    $ptype = uc $ptype;
    $ptype = $Canonports->{$ptype} unless defined $Options->{$ptype};
    $res->{PORT} = $ptype;
}

# Get standard network params

sub getstdnetparam {
    my $res = shift;
    init_def_options($res, STDNET);
    ask_optionlist($res, STDNET) if askyorn("adjstd", "Do you want to adjust the standard network parameters", 0);
}

# Get LPD-specific network params

sub getlpdparam {
    my $res = shift;
    init_def_options($res, LPDNET);
    if (askyorn("adjlpd", "Do you want to adjust the LPD parameters", 0))  {
	$res->{LPDNET}->{outip} = askip("outiph", "Outgoing IP/host") if askyorn("outip", "Do you need to give a different outgoing IP address/host", 0);
	$res->{LPDNET}->{lpdname} = askq("destptr", "Destination printer name") if askyorn("diffptr", "Does your interface require a different printer name than $res->{PRINTER}");
	ask_optionlist($res, LPDNET);
    }
}

# Get telnet-specific network params

sub gettelnetparam {
    my $res = shift;
    my $type = askyorn("usnmp", "Use SNMP", 1)? "XTLHP": "TELNET";
    $res->{PORT} = $type;
    init_def_options($res, $type);
    $res->{$type}->{myhost} = askip('outiph', "Outgoing IP/host") if $type eq "XTLHP" && askyorn("outip", "Do you need to give a different outgoing IP address/host", 0);
    ask_optionlist($res, $type) if askyorn("adjtelnet", "Do you want to adjust the telnet parameters", 0);    
}

# Get FTP-specific network params

sub getftpparam {
    my $res = shift;
    init_def_options($res, FTP);
    ask_optionlist($res, FTP) if askyorn("adjftp", "Do you want to adjust the FTP parameters", 0);
}

# Get other network params

sub getotherparam {
    my $res = shift;
    my $list = $Config{SDATADIR} . "/Psetups/servers.list";
    my %servs;
    if (open(SLIST, $list))  {
	while (<SLIST>) {
	    chop;
	    s/#.*//;
	    next unless /^(\w+)\s*:\s*(.*)/;
	    my $descr = $1;
	    my $cmd = $2;
	    next if $cmd =~ /SPROGDIR/;
	    my $prog = $cmd;
	    $prog =~ s/\s+.*//;
	    next unless -x $prog;
	    $servs{$descr} = $cmd;
	}
	close SLIST;
	if  (%servs)  {
	    my @poss = sort keys %servs;
	    if  ($#poss == 0)  {
		if  (askyorn("possdriv", "You seem to have a $poss[0] driver - use this", 1))  {
		    $res->{PORT} = $poss[0];
		    $res->{$poss[0]} = {COMMAND => $servs{$poss[0]}};
		    return;
		}
	    }
	    else  {
		print "Possible network drivers: @poss\n";
		if  (askyorn("possdrivm", "Use one of those", 1))  {
		    my $drv = askq("driver", "Select driver", $poss[0], \@poss);
		    $res->{PORT} = $drv;
		    $res->{$drv} = {COMMAND => $servs{$drv} };
		}
	    }
	}
    }
    my $port = $res->{PORT};
    print <<EOM;
I shall have to ask you what command or driver is used to send data
to the network. It should be something that takes data on standard input
and sends it to the printer.

Please abort this and contact us if you have any queries.
EOM
    my $prog = askq("pprogram", "Program to send to $res->{PRINTER}");
    if  ($prog =~ m|^/|)  {
	exit 0 unless -x $prog || askyorn("noprogf", "$prog not found on path - are you sure", 0);
    }
    else  {
	exit 0 unless findonpath($prog) || askyorn("noprog", "$prog not found on path - are you sure", 0);
    }
    print "Please give the arguments for $prog - specify the host name with \$SPOOLDEV\n";
    my $args = askq("pprogargs", "Arguments for $prog");
    $res->{$port} = {COMMAND => "$prog $args"};
}

# Get network parameters according to type

sub getnetworkparam {
    my $res = shift;
    my $update = shift;
    $res->{EDITED} = 'Y';
    getnetworkconn($res) unless $update && !askyorn("chnet", "Change network connection details", 0);
    getstdnetparam($res) unless $update && !askyorn("chbasic", "Change basic network connection parameters", 0);
    my $port = $res->{PORT};
    if ($port eq 'LPDNET') {
	getlpdparam($res) unless $update && !askyorn("chlpd", "Change LPD-specific parameters", 0);
    }
    elsif ($port eq 'TELNET') {
	gettelnetparam($res) unless $update && !askyorn("chtelnet", "Change Telnet-specific paramters", 0);
    }
    elsif ($port eq 'FTP') {
	getftpparam($res) unless $update && !askyorn("chftp", "Change FTP-specific parameters", 0);
    }
    else  {
	getotherparam($res) unless $update && !askyorn("chnetcomm", "Change network command specific paramters", 0);
    }
}

# Get device parameters

sub getdevparam {
    my $res = shift;
    my $ptype = shift;
    my $update = shift;
    $ptype = uc $ptype;
    my $des = lc $ptype;
    $res->{PORT} = $ptype;
    $res->{EDITED} = 'Y';
    init_def_options($res, $ptype);
    ask_optionlist($res, $ptype) if askyorn("chport", "Do you want to adjust the $des port parameters", 0);
}

# Discover interface type and apply

sub getinterface {
    my $res = shift;
    my $update = shift;
    my $type;
    if  ($update)  {
	$type = $res->{PORT};
	if (askyorn("chinter", "Do you want to change the interface type, currently $type", 0)) {
	    undef $res->{$type};
	    undef $res->{NETWORK};
	    undef $res->{STDNET};
	    $res->{EDITED} = 'Y';
	    $type = askq("newconntype", "New connection type", "Network", [ "Serial", "Parallel", "USB", "Network"]);
	}
	elsif ($res->{NETWORK} eq 'Y')  {
	    getnetworkparam($res, 1);
	    return;
	}
	else {
	    getdevparam($res, $type, 1);
	    return;
	}
    }
    else  {
	$type = askq("connect", "How is $res->{PRINTER} connected", "Network", [ "Serial", "Parallel", "USB", "Network" ]);
    }
    if  ($type eq 'Network') {
	getnetworkparam($res, 0);
    }
    else  {
	getdevparam($res, $type, 0);
    }
}

# For linux installs where we notice a printer attached to parallel port early on

sub install_parallel {
    my ($ptr, $dev, $model) = @_;
    my $ptrdets = { PRINTER => $ptr, DEV => $dev, NAME => $model };
    getdevparam($ptrdets, 'PARALLEL', 0);
    askptremul($ptrdets) unless getptremul($ptrdets);
    getspoolopts($ptrdets);
    write_devfile($ptrdets);
    write_defaultfile($ptrdets);
    $Ptrdeflist{$ptr} = $ptrdets;
    proc_install($ptr) if isrunning;
}

# Display printer

sub dispptr {
    my $ptr = shift;
    return ( $ptr->{DEV}, $ptr->{NAME} )  if  $ptr->{NAME};
    ($ptr->{DEV}, "Unknown printer type");
}

# Get linux parallel port info

sub getlinuxparallel {
    my $res = shift;
    my $update = shift;
    my $pplist = list_parports(1);
    my @nilist;
    for my $p (@$pplist) {
	push @nilist, $p unless !$update && $Idevs{$p->{DEV}};
    }
    if ($#nilist < 0)  {
	print "There do not seem to be any parallel ports available\n";
	exit 0 unless askyorn("confpara", "Are you sure", 0);
    }
    elsif ($#nilist == 0)  {
	my $p = $nilist[0];
	my $j = join(' which is ', dispptr($p));
	if  (askyorn("usepara", "Use $j", 1))  {
	    $res->{DEV} = $p->{DEV};
	    $res->{NAME} = $p->{NAME} if $p->{NAME};
	}
    }
    else  {
	my @short;
	my %wh;
	print "Possible printers and types:\n\n";
	for my $s (@nilist) {
	    print join(' which is ', dispptr($s)), "\n";
	    my $sh = $s->{DEV};
	    $sh =~ s/\/dev\///;
	    push @short, $sh;
	    $wh{$sh} = $s;
	}
	my $dev = askq("ptrtype", "Please select device", $short[0], \@short);
	$dev = $wh{$dev};
	$res->{DEV} = $dev->{DEV};
	$res->{NAME} = $dev->{NAME} if $dev->{NAME};
    }
}

# Get printer type using SNMP

sub getsnmptype {
    my $res = shift;
    my $getsnmp = "$sbindir/gspl-getsnmp";
    return unless -x $getsnmp;
    my $nm = `$getsnmp -N -h $res->{DEV} 1.3`;
    return unless length($nm) > 0;
    chop $nm;
    print "Your printer appears to be a $nm\n";
    $res->{NAME} = $nm;
}

# Ask printer type

sub askptrtype {
    my $res = shift;
    my $list = $Config{SDATADIR} . "/Psetups/printers.list";
    if (-f $list  &&  $Pmenu)  {
	print "First please give the type of the printer.\nIt may be listed in the list we supply\n";
	if  (askyorn("trylist", "Try supplied list", 1))  {
	    open(LIST, $list);
	    my $tf = "pl$$";
	    open(TF, ">$tf");
	    while (<LIST>) {
		chop;
		s/#.*//;
		next unless /:/;
		my ($ptr,$emul,$ijs,$col) = split(/\s*:\s*/);
		print TF $ptr,"\n";
	    }
	    close LIST;
	    close TF;
	    $resline = `$Pmenu -f $tf -h'Please select printer type and press ENTER or Q to exit'`;
	    chomp $resline;
	    unlink $tf;
	    $res->{NAME} = $resline if length($resline) != 0;
	}
    }
    $res->{NAME} = askq("pmodel", "Please give printer name/model") unless  $res->{NAME};    
}

# Ask if OK to use Ghostscript

sub askusegs {
    my $res = shift;
    return  unless  $res->{TYPE} =~ /ljet|pcl/i;
    $res->{TYPE} = 'PCL';
    if  (findonpath('gs')  &&  askyorn('usegs', 'Use ghostscript for PS (even if printer supports it)', 1))  {
	unless (defined $res->{MODEL})  {
	    if (askyorn("cptr", "Does this printer print colour", 0))  {
		$res->{MODEL} = 'HP Color LaserJet';
		$res->{COLOUR} = 'Y';
	    }
	    else  {
		$res->{MODEL} = 'HP LaserJet 6';
	    }
	}
	$res->{GS} = 'Y';
	$res->{GSSIZE} = askq("psize", "Standard paper size", "a4", [ "a4", "11x7", "letter", "legal", "ledger", "note"]);
	$res->{DEFCOLOUR} = 'Y' if $res->{COLOUR} eq 'Y' && askyorn("defcolour", "Print colour by default", 0);
    }
}

# Get printer emulation

sub getptremul {
    my $res = shift;
    my $name = $res->{NAME};
    my $list = $Config{SDATADIR} . "/Psetups/printers.list";
    return 0 unless open(LIST, $list);
    my $ret = 0;
    while (<LIST>) {
	chop;
	s/#.*//;
	next unless /:/;
	my ($ptr,$emul,$ijs,$col) = split(/\s*:\s*/);
	if (lc $ptr eq lc $name)  {
	    $res->{TYPE} = $emul;
	    $res->{MODEL} = $ijs if $ijs;
	    $res->{HASPS} = 'Y' if  $emul =~ /ps/i;
	    $res->{COLOUR} = 'Y' if $col eq 'C';
	    $ret = 1;
	    last;
	}
    }
    close LIST;
    askusegs($res) if $ret;
    $ret;
}

# Ask printer emulation

sub askptremul {
    my $res = shift;
    $res->{NAME} = askq("pmodel", "Please give printer name/model") unless  $res->{NAME};
    $res->{TYPE} = askq("pemul", "Please give emulation", "PCL", [ "Epson", "PCL", "IBM", "Other" ]);
    if  ($res->{TYPE} eq 'PCL')  {
	$res->{HASPS} = 'Y' if askyorn('emps', "Does printer emulate PostScript also", 0);
	askusegs($res);
    }
}

# Get type of printer

sub getptrtype {
    my $res = shift;
    my $update = shift;
    $res->{EDITED} = 'Y';
    getlinuxparallel($res, $update) if $res->{PORT} eq 'PARALLEL'  &&  $Systemtype eq 'Linux';
    getsnmptype($res) if $res->{NETWORK} eq 'Y' &&  $res->{ALIVE} eq 'Y'  &&  $res->{TRYSNMP};
    askptrtype($res) unless $res->{NAME};
    askptremul($res) unless getptremul($res);
}

# Get header per copy parameter

sub sethdrpercopy {
    my $res = shift;
    my $cl = shift;
    $res->{$cl}->{hdrpercopy} = askyorn('banneach', 'Do you want banners on each copy of multiple copies', 0)? 'Y': 'N';
}

# Get the various header options

sub gethdropts {
    my $res = shift;
    my $islpd = shift;
    my $cl = $islpd? 'LPDOPTS': 'STDOPTS';
    if  (askyorn('userbann', 'Do you want users to set on/off banner pages themselves', !$islpd))  {
	sethdrpercopy($res, $cl);
    }
    elsif  (askyorn('nohdr', 'Do you want to force banner pages off', $islpd))  {
	$res->{$cl}->{hdrpercopy} = 'N';
	$res->{$cl}->{nohdr} = 'Y';
	$res->{$cl}->{forcehdr} = 'N';
    }
    else  {
	$res->{$cl}->{nohdr} = 'N';
	$res->{$cl}->{forcehdr} = 'Y';
	sethdrpercopy($res, $cl);
    }
}

# Copy the options on one name to another name
# This is used for shuffling between "STDOPTS" and "LPDOPTS"

sub copyopts {
    my $res = shift;
    my $old = shift;
    my $new = shift;
    for my $k (keys %{$res->{$old}})  {
	$res->{$new}->{$k} =  $res->{$old}->{$k};
    }
}

# Get spooler options

sub getspoolopts {
    my $res = shift;
    my $update = shift;
    if ($res->{PORT} eq 'LPDNET')  {
	copyopts($res, 'STDOPTS', 'LPDOPTS');
	init_def_options($res, 'LPDOPTS');
	init_def_options($res, 'LPDHDROPTS');
	gethdropts($res, 1) if askyorn('chbann', 'Adjust banner printing options', 0);
	ask_optionlist($res, 'LPDOPTS') if askyorn('chmisc', 'Adjust miscellaneous options', 0);
	copyopts($res, 'LPDOPTS', 'STDOPTS');
    }
    else  {
	init_def_options($res, 'STDOPTS');
	init_def_options($res, 'STDHDROPTS');
	gethdropts($res, 0) if askyorn('chbann', 'Adjust banner printing options', 0);
	ask_optionlist($res, 'STDOPTS') if askyorn('chmisc', 'Adjust miscellaneous options', 0);
    }
}

# Write out device file

sub out_device {
    my $file = shift;
    my $ptrdets = shift;
    my $porttype = $ptrdets->{PORT};
    my $optv = $Options->{$porttype};
    my $optp = $ptrdets->{$porttype};
    for my $o (@$optv) {
	my ($kw, $def, $expl) = @$o;
	if  (defined $optp->{$kw})  {		# Take as always defined
	    print $file "\n# $expl\n";
	    my $val = $optp->{$kw};
	    print $file "#" if $val eq 'N';
	    if ($val =~ /^[YN]$/) {
		print $file "$kw\n";
	    }
	    elsif ($kw eq 'csize') {
		print $file "cs$val\n";
	    }
	    elsif ($kw eq 'stopbits') {
		print $file '#' if $val != 2;
		print $file "twostop\n";
	    }
	    else {
		print $file "$kw $val\n";
	    }
	}
    }
}

# Write out network command

sub out_network {
    my $file = shift;
    my $ptrdets = shift;
    my $porttype = $ptrdets->{PORT};
    my $optv = $Options->{STDNET};
    my $optp = $ptrdets->{STDNET};
    for my $o (@$optv)  {
	my ($kw, $def, $expl) = @$o;
	if  (defined $optp->{$kw})  {		# Take as always defined
	    print $file "\n# $expl\n";
	    my $val = $optp->{$kw};
	    print $file "#" if $val eq 'N';
	    if ($val =~ /^[YN]$/) {
		print $file "$kw\n";
	    }
	    else {
		print $file "$kw $val\n";
	    }
	}
    }
    $optv = $Options->{$porttype};
    $optp = $ptrdets->{$porttype};
    if ($porttype eq 'OTHER')  {
	print $file "\n# Network command to print as specified\n";
	print $file "network=$optp->{COMMAND}\n";
    }
    else  {
	my $sprog = $Config{SPROGDIR};
	my $sdata = $Config{SDATADIR};
	print $file "\n# Network command for protocol type\n";
	my %ckprog = (LPDNET => 'xtlpc', FTP => 'xtftp', XTLHP => 'xtlhp', TELNET => 'xtelnet');
	print $file "network=\${SPROGDIR:-$sprog}/$ckprog{$porttype}";
	for my $o (@$optv)  {
	    my ($kw, $def, $expl, $arg, $progdef) = @$o;
	    my $val = $optp->{$kw};
	    if  (defined $val)  {
		if ($val eq 'N')  {
		    print $file " -$1" if $arg =~ /!(.)/;
		}
		elsif ($val eq 'Y') {
		    print $file " -$arg" unless $arg =~ /!/;
		}
		elsif (length($val) > 0)  {
		    next if $val =~ /^\d+$/ && $progdef =~ /^\d+$/ && $val == $progdef;
		    print $file " -$arg $val" if $val ne $progdef;
		}
	    }
	    elsif  (!ref($def) && $def =~ /^!(.*)/)  {
		my $str = $1;
		if (length($str) > 1)  {
		    $str =~ s/SPROGDIR/\${SPROGDIR:-$sprog}/;
		    $str =~ s/SDATADIR/\${SDATADIR:-$sdata}/;
		    print $file " -$arg $str";
		}
	    }
	}
	print $file "\n";
    }
}

# Write .device file

sub write_devfile {
    my $ptrdets = shift;
    my $printer = $ptrdets->{PRINTER};
    my $porttype = $ptrdets->{PORT};
    my $ptrdir = $Config{SPOOLPT};
    my $dirname = "$ptrdir/$printer";
    unless  (-d $dirname)  {
	unless  (mkdir $dirname, 0775)  {
	    print "Sorry cannot create directory $dirname for printer\n";
	    exit 1;
	}
	chown $Spooluid, $Spoolgid, $dirname;
    }
    my $filename = "$dirname/.device";
    unless  (open(DEVF, ">$filename"))  {
	print "Sorry cannot create $filename\n";
	exit 2;
    }
    chown $Spooluid, $Spoolgid, $filename;
    my @tbits = localtime;
    my $dat = sprintf "%.2d/%.2d/%.2d", $tbits[3], $tbits[4]+1, $tbits[5]%100;
    my $pt = ucfirst lc $porttype;
    print DEVF <<EOF;
# Device file created $dat
# Porttype: $pt
#
# This file contains parameters for the above interface.
# It is read in ahead of any "setup file" such as "default"
# and should contain interface-only features.
#
# Please do not edit this file directly without changing "Porttype" above
# to "custom".

EOF
    if ($porttype =~ /PARALLEL|SERIAL|USB/)  {
	out_device(\*DEVF, $ptrdets);
    }
    else  {
	out_network(\*DEVF, $ptrdets);
    }
    close DEVF;
}

# Output segment of file

sub out_splurge {
    my $fileout = shift;
    my $filein = shift;
    my $ptrdets = shift;
    my $sprog = $Config{SPROGDIR};
    my $sdata = $Config{SDATADIR};
    my $path = "$sdata/Psetups/$filein.pi";
    my $gssize = $ptrdets->{GSSIZE};
    my $model = $ptrdets->{MODEL};
    my $gs = findonpath('gs');
    my $ijs = findonpath('hpijs');

    if (open(EP, $path))  {
	while (<EP>)  {
	    s/SPROGDIR/\${SPROGDIR:-$sprog}/;
	    s/SDATADIR/\${SDATADIR:-$sdata}/;
	    s/\bGS\b/$gs/;
	    s/\bIJS\b/$ijs/;
	    s/\bGSSIZE\b/$gssize/;
	    s/\bMODEL\b/$model/;
	    print $fileout $_;
	}
	close EP;
    }
    else  {
	print $fileout "# Sorry didn't find $filein template\n";
    }
}

# Output stuff for epson

sub out_epson {
    my $file = shift;
    my $ptrdets = shift;
    out_splurge($file, "Epson", $ptrdets);
}

# Output stuff for PCL

sub out_pcl {
    my $file = shift;
    my $ptrdets = shift;
    out_splurge($file, "PCL1", $ptrdets);
    if ($ptrdets->{GS} eq 'Y') {
	my $pcl = "PCL2";
	if ($ptrdets->{COLOUR} eq 'Y') {
	    $pcl .= "dbw" unless $ptrdets-{DEFCOLOUR} eq 'Y';
	}
	else  {
	    $pcl .= "bw";
	}
	out_splurge($file, $pcl, $ptrdets);
    }
    elsif ($ptrdets->{HASPS} eq 'Y') {
	out_splurge($file, "PCLPS", $ptrdets);
    }
    else {
	out_splurge($file, "PCLnoPS", $ptrdets);
    }
}

# Output stuff for IBM

sub out_ibm {
    my $file = shift;
    my $ptrdets = shift;
    out_splurge($file, "IBM", $ptrdets);
}

# Output stuff for "Other"

sub out_other {
    my $file = shift;
    my $ptrdets = shift;
    print $file "# This is a null file for future adjustment\n";
}

# Create "default" file for form type.

sub write_defaultfile {
    my $ptrdets = shift;
    my $printer = $ptrdets->{PRINTER};
    my $ptrdir = $Config{SPOOLPT};
    my $ptrtype = $ptrdets->{TYPE};
    
    my $dirname = "$ptrdir/$printer";
    my $filename = "$dirname/default";
    unless  (open(DEFF, ">$filename"))  {
	print "Sorry cannot create $filename\n";
	exit 3;
    }
    chown $Spooluid, $Spoolgid, $filename;
    print DEFF <<EOF;
# Ptrtype: $ptrtype
# This is the "default" setup file for $printer.
# It is used to handle forms for which there isn't a specific setup file given
# with the name of the formtype (most of the time).
# If you make changes to the file other than with this program
# please change the printer type above to "Custom"
# so that your changes don't get wiped out.

EOF
    print DEFF "# Ptrname: $ptrdets->{NAME}\n" if $ptrdets->{NAME};
    print DEFF "# Set up for $ptrdets->{MODEL}\n" if $ptrdets->{MODEL};
    print DEFF "# Postscript emulation\n" if $ptrdets->{HASPS} eq 'Y';
    print DEFF "# Using ghostscript\n" if $ptrdets->{GS} eq 'Y';
    print DEFF "# Paper: $ptrdets->{GSSIZE}\n" if $ptrdets->{GSSIZE};

    print DEFF <<EOF;

# The following options relate to header pages - the default settings
# "nohdr" means that header (banner) pages are never printed whatever
# a user may set on his/her job.
# "forcehdr" means that headers are always printed whatever the user
# may set.
# Note that you can restore the defaults with either -nohdr or -forcehdr.
# You may want this for specific suffixes.
# "hdrpercopy" forces a header on each of multiple copies

EOF

    my $optp = $ptrdets->{STDOPTS};
    if ($optp->{nohdr} eq 'Y') {
	print DEFF "nohdr\n";
    }
    elsif ($optp->{forcehdr} eq 'Y') {
	print DEFF "forcehdr\n";
    }
    print DEFF "hdrpercopy\n" if $optp->{hdrpercopy} eq 'Y';

    my $optv = $Options->{STDOPTS};
    for my $o (@$optv) {
	my ($kw, $def, $expl) = @$o;
	print DEFF "\n# $expl\n";
	print DEFF "#" unless $optp->{$kw} eq 'Y';
	print DEFF "$kw\n";
    }
    
    if ($ptrtype eq 'Epson') {
	out_epson(\*DEFF, $ptrdets);
    }
    elsif ($ptrtype eq 'PCL') {
	out_pcl(\*DEFF, $ptrdets);
    }
    elsif ($ptrtype eq 'IBM') {
	out_ibm(\*DEFF, $ptrdets);
    }
    else  {
	out_other(\*DEFF, $ptrdets);
    }
    close DEFF;
}

sub makeclone {
    my $newptr = shift;
    my $oldptr = shift;
    my $ptrdir = $Config{SPOOLPT};
    symlink $oldptr, "$ptrdir/$newptr" or die "Cannot create link";
    $Ptrdeflist{$newptr} = { TYPE => 'Clone', CLONEOF => $oldptr, PRINTER => $newptr };
    proc_install($newptr) if askyorn('installptr', "Install $newptr", 1);
}

# Create printer def

sub proc_create {
    my $Insptr = shift;
    if (askyorn('makeclone', "Do you want $Insptr to be a clone of another printer", 0))  {
	my @possp;
	for my $p (sort keys %Ptrdeflist) {
	    push @possp, [ $p, $Ptrdeflist{$p}->{DEV} ] if $Ptrdeflist{$p}->{TYPE} ne 'Clone';
	}
	if ($#possp < 0)  {
	    print "Sorry no printers yet to clone\n";
	    exit 0;
	}
	if ($#possp == 0)  {
	    my $cl = $possp[0]->[0];
	    makeclone($Insptr, $cl) if askyorn('makecloneof', "Make clone of $cl", 1);
	    exit 0;
	}
	if ($#possp < 4 || !$Pmenu) {
	    my @pnames;
	    for my $p (@possp) {
		push @pnames, $p->[0];
	    }
	    makeclone($Insptr, askq("w2clone", "Which printer", $pnames[0], \@pnames));
	}
	else  {
	    my $tf = "pl";
	    open(TF, ">$tf");
	    for my $p (@possp) {
		print TF "$p->[0]:$p->[1]\n";
	    }
	    close TF;
	    my $resline = `$Pmenu -f $tf -d : -n -h 'Please select printer to clone'`;
	    chomp $resline;
	    unlink $tf;
	    makeclone($Insptr, $possp[$resline-1])  if  length($resline) != 0;
	}
	exit 0;
    }
    else  {
	my $ptrdets = { PRINTER => $Insptr };
	getinterface($ptrdets, 0);
	getptrtype($ptrdets, 0);
	getspoolopts($ptrdets, 0);
	write_devfile($ptrdets);
	write_defaultfile($ptrdets);
	$Ptrdeflist{$Insptr} = $ptrdets;
    }
}

# Modify printer def

sub proc_modify {
    my $Insptr = shift;
    my $spoolrunning = shift;
    my $isinst = shift;

    # Get the existing description

    my $ptrdets = $Ptrdeflist{$Insptr};
    if ($ptrdets->{TYPE} eq 'Clone')  {
	return unless askyorn('splitclone', "As this printer is a clone, do you want to split it", 1);
	my $ptrdir = $Config{SPOOLPT};
	my $cloned = $ptrdets->{CLONEOF};
	unlink "$ptrdir/$Insptr";
	system("chdir $ptrdir;cp -r -p $cloned $Insptr");
    }
    else  {
	getinterface($ptrdets, 1) if askyorn('chinter', "Adjust interface details", 0);
	getptrtype($ptrdets, 1) if askyorn('chtype', "Adjust type of printer", 0);
	getspoolopts($ptrdets, 1) if askyorn('chspool', "Adjust spool options", 0);
	return if $ptrdets->{EDITED} ne 'Y';
	write_devfile($ptrdets);
	write_defaultfile($ptrdets);
    }
}

sub setdefform {
    my $form = shift;
    return if length($form) == 0;
    system("$bindir/gspl-uchange -D -f $form -F $form -A");
    my $me = $ENV{'SUDO_USER'};
    system("$bindir/gspl-uchange -p ALL $me") if length($me) != 0;
}

# Install printer

sub proc_install {
    my $ptr = shift;
    my $ptrdets = $Ptrdeflist{$ptr};
    my $cloned = $ptrdets;
    $cloned = $Ptrdeflist{$ptrdets->{CLONEOF}} if $ptrdets->{TYPE} eq 'Clone';
    $descr = askq("pdescr", "Please give a description for this printer") unless $ptrdets->{DESCR};
    $descr =~ y/[a-z][A-Z] //cd;
    $ptrdets->{DESCR} = $descr;
    my $dev;
    if ($ptrdets->{DEV})  {
	$dev = $ptrdets->{DEV};
    }
    else  {
	if  ($cloned->{NETWORK} eq 'Y')  {
	    $ptrdets->{DEV} = askip('destip', "Please give the host name or IP for this printer");
	}
	else {
	    my $port = $cloned->{PORT};
	    my $lport = ucfirst lc $port;
	    for (;;)  {
		$dev = "/dev/" . getline("devname", "$lport device: /dev/");
		unless (-c $dev) {
		    print "$dev is not a suitable device\n";
		    redo;
		}
		if ($Idevs{$dev}) {
		    print "Sorry, already using $dev\n";
		    redo;
		}
		last;
	    }
	}
    }

    my @args;
    push @args, "$bindir/gspl-padd";

    if  ($cloned->{NETWORK} ne 'Y')  {
	my @sbits = stat $dev;
	if ($sbits[4] != $Spooluid) {
	    if (askyorn('notowned', "$dev is not owned by gnuspool - fix", 1))  {
		chown $Spooluid, $Spoolgid, $dev;
	    }
	    elsif ($sbits[5] == $Spoolgid)  {
		if  (($sbits[2] & 0020) == 0)  {
		    return  unless  askyorn('notgrpwrt', "$dev not group writable - fix", 1);
		    chmod (($sbits[2] & 07777) | 0020, $dev);
		}
	    }
	    else  {
		if  (($sbits[2] & 002) == 0)  {
		    return  unless  askyorn('notwrld', "$dev not world writable - fix", 1);
		    chmod (($sbits[2] & 07777) | 0002, $dev);
		}
	    }
	}
	$dev =~ s|/dev/||;
    }
    else  {
	push @args,"-N";
    }
    push @args, '-l';
    push @args, $dev;
    push @args, "-D";
    push @args, "'$ptrdets->{DESCR}'";
    push @args, $ptr;

    if ($cloned->{GSSIZE}) {
	push @args, $cloned->{GSSIZE};
    }
    else  {
	my $ftype = askq('ftype', 'Form type name', 'a4', [ 'a4', 'letter', 'legal', 'standard' ]);
	push @args, $ftype;
	# The first time we start up, the default form type is set to "standard"
	# If we are setting some other form type in a printer lets set the default
	# form type to that.
	my $defform = `$bindir/gspl-ulist -S -F %f`;
	chop $defform;
	setdefform($ftype) if $defform eq 'standard' || askyorn('defform', "set $ftype as default form type", 0);
    }
    if (system(join(' ', @args)) == 0)  {
	print "$ptr added successfully\n";
    }
    else  {
	print "Sorry - could not add $ptr\n";
    }
}

# Perform operation - return true if success

sub proc_ptrop  {
    my $ptrdef = shift;
    my $prog = shift;
    my $dev = $ptrdef->{DEV};
    $dev =~ s|/dev/||;
    my @args;
    push @args, "$bindir/$prog";
    push @args, "-l", $dev if $dev;
    push @args, $ptrdef->{PRINTER};
    system(join(' ', @args)) == 0;
}

# Is printer running?

sub isrunning_ptr {
    my $ptrdef = shift;
    proc_ptrop($ptrdef, "gspl-pstat");
}

# Stop printer

sub proc_ptrstop {
    my $ptrdef = shift;
    proc_ptrop($ptrdef, "gspl-pstop");
}

# Stop printer if running and return whether it was

sub proc_stopifrunning {
    my $ptr = shift;
    my $ptrdets = $Ptrdeflist{$ptr};
    return 0 if isrunning_ptr($ptrdets);
    proc_ptrstop($ptrdets);
    1;
}

# Restart printer

sub proc_restartprin {
    my $ptr = shift;
    my $ptrdets = $Ptrdeflist{$ptr};
    proc_ptrop($ptrdets, 'gspl-start');
}

# Uninstall printer

sub proc_uninstall {
    my $ptr = shift;				# FIXME for clones
    my $ptrdets = $Ptrdeflist{$ptr};
    if  (isrunning_ptr($ptrdets))  {
	exit 0 unless askyorn('ptrrun', "ptr (on $ptrdets->{DEV}) is running - are you sure", 0);
	die "Sorry could not stop $ptr\n" unless proc_ptrstop($ptrdets);
    }
    die "Sorry could not delete $ptr\n" unless proc_ptrop($ptrdets, "gspl-pdel");
    print "$ptr uninstalled OK\n";
}

# Remove printer def

sub proc_remove {
    my $ptr = shift;
    my $ptrdir = $Config{SPOOLPT};
    system("rm -rf $ptrdir/$ptr");
}

################################################################################
#									       #
#			Start here					       #
#									       #
################################################################################

# Optional argument giving printer name

die "You have to be super-user to run this" unless $> == 0;

$Systemtype = `uname -s`;
chop $Systemtype;

($Spoolu, $Spoolp, $Spooluid, $Spoolgid) = getpwnam('gnuspool') or die "Cannot find gnuspool id";
undef $Spoolu;
undef $Spoolp;

if ($#ARGV >= 0) {
    die "Usage: $0 [ptrname]\n" if $#ARGV > 0;
    $Insptr = shift @ARGV;
    die "Invalid printer name format $Insptr\n" unless $Insptr =~ /^[a-z]\w+$/;
}

# May need pager later

$prefix = "/usr";
$exec_prefix = "${prefix}";
$datarootdir = "/usr/share";
$bindir = "${exec_prefix}/bin";
$sbindir = "${exec_prefix}/sbin";

$Pmenu = "$sbindir/gspl-pmenu";
die "Cannot find pmenu program looking in $sbindir" unless -x $Pmenu;

# Need to check we've got PATH set up correctly with the binaries in

check_userpath;

# Parse config in case directories relocated
# (Need this before we go into python)

parse_mconfig;

if (findonpath('python')) {
    my $pyversion = `python --version 2>&1`;
    chop $pyversion;
    my ($maj,$min);
    if ((($maj,$min) = $pyversion =~ /(\d+)\.(\d+)/) && ($maj > 2 || ($maj >= 2 && $min >= 6)))  {
	$pyprog = $Config{SDATADIR} . "/ptrinstall/ptrinstall.py";
	$c = system("python $pyprog");
	exit 0 if $c == 0;
	$ec = $c >> 8;
	if ($ec == 20) {
	    print <<EOT;
You seem to have Python installed but not PyQt4.
If you install this you should be able to install printers using a GUI interface.
EOT
	}
	elsif ($ec == 21) {
	    print <<EOT;
You seem to have Python installed and PyQt4 but are missing the
auto-generated config.py.
If you install this you should be able to install printers using a GUI interface.
EOT
	}
	else {
	    print <<EOT;
Sorry but the Python interface failed.
Please try to install it or mend it if it is installed.
If you install this you should be able to install printers using a GUI interface.
EOT
	}
    }
}

getekchars;
$pager = findonpath('less') || findonpath('more') || findonpath('pg') || 'cat';

print <<EOT;
Welcome to the Printer Setup system.
Please answer questions - mostly y or n as required (suggested default given)
Press F1 if available for help otherwise ?
=============================================================================
EOT

# Get exiting printers - defined and installed

%Ptrdeflist = list_defptrs;
(%Ptrinslist = getptrs_online) || (%Ptrinslist = getptrs_offline) || print "Cannot find installed printers (may not be an error)\n";

# Note list of devices used by existing printers

for my $id (values %Ptrinslist)  {
    $Idevs{"/dev/$id->{DEV}"} = 1 unless $id->{NETWORK};
}

# Merge in installed printers

while (my ($p, $pi) = each %Ptrinslist)  {
    my $d = $Ptrdeflist{$p};
    unless  (defined $d)  {
	print "*** Confused about $p which is installed but not defined\n";
	next;
    }
    $d->{INSTALLED} = 'Y';
    if ($pi->{NETWORK} eq 'Y')  {
	$d->{NETWORK} = 'Y';
	$d->{DEV} = $pi->{DEV};
    }
    else  {
	$d->{DEV} = "/dev/" . $pi->{DEV};
    }
    $d->{DESCR} = $pi->{DESCR};
}

undef %Ptrinslist;

# Get printer name if needed

unless  ($Insptr)  {

    if ($Systemtype eq 'Linux')  {
	my $pplist = list_parports(0);
	for my $p (@$pplist) {
	    unless ($Idevs{$p->{DEV}})  {
		print "You appear to have $p->{MODEL} on $p->{DEV}\n";
		if  (askyorn('instpara', "Do you want to install that", 1))  {
		    $Insptr = getnewptrname("Please give a name for the printer");
		    install_parallel($Insptr, $p->{DEV}, $p->{MODEL});
		    exit 0;
		}
	    }
	}
    }

    pagedisp_ptrs if askyorn('displayexist', "Display existing printers", 1);
    $Insptr = getnewptrname("Printer to install or edit");
}

# See if it's a completely new printer

if ($Ptrdeflist{$Insptr})  {

    # Printer is defined

    if  ($Ptrdeflist{$Insptr}->{INSTALLED} eq 'Y')  {

	# Printer is defined and installed

	if  (isrunning)  {
	    my $ans = askq("modorrem", "Do you want to modify or remove $Insptr", "m", [ 'm', 'r' ]);
	    if ($ans eq 'm') {
		my $wasrunning = proc_stopifrunning($Insptr);
		proc_modify($Insptr, 1, 1);
		if  ($wasrunning)  {
		    proc_restartprin($Insptr) if askyorn('restartnow', "Restart $Insptr now", 1);
		}
		else  {
		    proc_restartprin($Insptr) if askyorn('startnow', "Start $Insptr now", 0);
		}
	    }
	    elsif (askyorn('justunist', "Do you just want to uninstall $Insptr", 1))  {
		proc_uninstall($Insptr);
	    }
	    else  {
		if  (askyorn('comprem', "This will completely remove $Insptr are you sure", 0))  {
		    proc_uninstall($Insptr);
		    proc_remove($Insptr);
		}
	    }
	}
	elsif (askyorn('modexist', "Do you want to modify $Insptr", 1))  {
	    proc_modify($Insptr, 0, 1);
 	}
    }
    else  {

	#  Not installed
	if (isrunning) {
	    if  (askyorn('modptr', "Do you want to modify $Insptr", 1))  {
		proc_modify($Insptr, 1, 0);
		proc_install($Insptr) if askyorn("instptr", "Do you want to install $Insptr", 1);
	    }
	    elsif (askyorn('instptr', "Do you want to install $Insptr", 1))  {
		proc_install($Insptr);
	    }
	    elsif (askyorn('deldef', "Delete definition of $Insptr", 0))  {
		proc_remove($Insptr);
	    }
	}
	else  {
	    if (askyorn('moddef', "Do you want to change definition of $Insptr", 1))  {
		proc_modify($Insptr, 0, 0);
	    }
	    elsif  (askyorn('deldef', "Do you want to remove the definition of $Insptr", 0))  {
		proc_remove($Insptr);
	    }
	}
    }
}
else  {
    proc_create($Insptr);
    proc_install($Insptr) if isrunning && askyorn('instnow', "Do you want to install $Insptr", 1);
}