path: root/perl-install/printer/main.pm

package printer::main;

# $Id$

use strict;

use common;
use run_program;
use printer::data;
use printer::services;
use printer::default;
use printer::cups;
use printer::detect;
use handle_configs;
use services;
use lang;

use vars qw(@ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(%printer_type %printer_type_inv);

#-Did we already read the subroutines of /usr/sbin/ptal-init?
my $ptalinitread = 0;

our %printer_type = (
    N("Local printer")                              => "LOCAL",
    N("Remote printer")                             => "REMOTE",
    N("Printer on remote CUPS server")              => "CUPS",
    N("Printer on remote lpd server")               => "LPD",
    N("Network printer (TCP/Socket)")               => "SOCKET",
    N("Printer on SMB/Windows 95/98/NT server")     => "SMB",
    N("Printer on NetWare server")                  => "NCP",
    N("Enter a printer device URI")                 => "URI",
    N("Pipe job into a command")                    => "POSTPIPE"
);

our %printer_type_inv = reverse %printer_type;

our %thedb;

our $hplipdevicesdb;

#------------------------------------------------------------------------------

sub spooler() {
    # LPD is taken from the menu for the moment because the classic LPD is
    # highly unsecure. Depending on how the GNU lpr development is going on
    # LPD support can be reactivated by uncommenting the following line.

    #return @spooler_inv{qw(cups lpd lprng pdq)};

    # LPRng is not officially supported any more since version 9.0 of
    # this distribution, so show it only in the spooler menu when it
    # was manually installed.

    # PDQ is not officially supported any more since version 9.1, so
    # show it only in the spooler menu when it was manually installed.

    return map { $spoolers{$_}{long_name} } ('cups', 'rcups' , 
    if_(files_exist(qw(/usr/bin/pdq)), 'pdq'),
    if_(files_exist(qw(/usr/lib/filters/lpf /usr/sbin/lpd)), 'lprng'));
}

sub printer_type($) {
    my ($printer) = @_;
    for ($printer->{SPOOLER}) {
	/cups/  and return @printer_type_inv{qw(LOCAL LPD SOCKET SMB), if_($printer->{expert}, qw(URI))};
	/lpd/   and return @printer_type_inv{qw(LOCAL LPD SOCKET SMB NCP), if_($printer->{expert}, qw(POSTPIPE URI))};
	/lprng/ and return @printer_type_inv{qw(LOCAL LPD SOCKET SMB NCP), if_($printer->{expert}, qw(POSTPIPE URI))};
	/pdq/   and return @printer_type_inv{qw(LOCAL LPD SOCKET), if_($printer->{expert}, qw(URI))};
	/rcups/ and return ();
    }
}

sub SIGHUP_daemon {
    my ($service) = @_;
    if ($service eq "cupsd") { $service = "cups" };
    # PDQ and remote CUPS have no daemons, exit.
    if (($service eq "pdq") || ($service eq "rcups")) { return 1 };
    # CUPS needs auto-correction for its configuration
    run_program::rooted($::prefix, "/usr/sbin/correctcupsconfig") if $service eq "cups";
    # Name of the daemon
    my %daemons = (
			    "lpr" => "lpd",
			    "lpd" => "lpd",
			    "lprng" => "lpd",
			    "cups" => "cupsd",
			    "devfs" => "devfsd",
			    );
    my $daemon = $daemons{$service};
    $daemon = $service unless defined $daemon;
#    if ($service eq "cups") {
#	# The current CUPS (1.1.13) dies on SIGHUP, do the normal restart.
#	printer::services::restart($service);
#	# CUPS needs some time to come up.
#	printer::services::wait_for_cups();
#    } else {

    # Send the SIGHUP
    run_program::rooted($::prefix, "/usr/bin/killall", "-HUP", $daemon);
    if ($service eq "cups") {
	# CUPS needs some time to come up.
	printer::services::wait_for_cups();
    }

    return 1;
}


sub assure_device_is_available_for_cups {
    # Checks whether CUPS already "knows" a certain port, it does not
    # know it usually when the appropriate kernel module is loaded
    # after CUPS was started or when the printer is turned on after
    # CUPS was started. CUPS 1.1.12 and newer refuses to set up queues
    # on devices which it does not know, it points these queues to
    # file:/dev/null instead. Restart CUPS if necessary to assure that
    # CUPS knows the device.
    my ($device) = @_;
    my $sdevice = handle_configs::searchstr($device);
    my ($result, $i);
    # USB printers get special model-dependent URLs in "lpinfo -v" here
    # checking is complicated, so we simply restart CUPS then and ready.
    if ($device =~ /usb/) {
	$result = printer::services::restart("cups");
	return 1;
    }
    my $maxattempts = 3;
    for ($i = 0; $i < $maxattempts; $i++) {
	open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") .
	    '/bin/sh -c "export LC_ALL=C; /usr/sbin/lpinfo -v" |') or
	    die 'Could not run "lpinfo"!';
	while (my $line = <$F>) {
	    if ($line =~ /$sdevice/) { # Found a line containing the device
		                       # name, so CUPS knows it.
		close $F;
		return 1;
	    }
	}
	close $F;
	$result = printer::services::restart("cups");
    }
    return $result;
}


sub spooler_in_security_level {
    # Was the current spooler already added to the current security level?
    my ($spooler, $level) = @_;
    my $sp;
    $sp = $spooler eq "lpr" || $spooler eq "lprng" ? "lpd" : $spooler;
    my $file = "$::prefix/etc/security/msec/server.$level";
    if (-f $file) {
	open(my $F, "< $file") or return 0;
	while (my $line = <$F>) {
	    if ($line =~ /^\s*$sp\s*$/) {
		close $F;
		return 1;
	    }
	}
	close $F;
    }
    return 0;
}

sub add_spooler_to_security_level {
    my ($spooler, $level) = @_;
    my $sp;
    $sp = $spooler eq "lpr" || $spooler eq "lprng" ? "lpd" : $spooler;
    my $file = "$::prefix/etc/security/msec/server.$level";
    if (-f $file) {
	   eval { append_to_file($file, "$sp\n") } or return 0;
    }
    return 1;
}

sub pdq_panic_button {
    my $setting = $_[0];
    if (-f "$::prefix/usr/sbin/pdqpanicbutton") {
        run_program::rooted($::prefix, "/usr/sbin/pdqpanicbutton", "--$setting")
	    or die "Could not $setting PDQ panic buttons!";
    }
}

sub copy_printer_params($$) {
    my ($from, $to) = @_;
    map { $to->{$_} = $from->{$_} } grep { $_ ne 'configured' } keys %$from; 
    #- avoid cycles-----------------^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
}

sub getinfo($) {
    my ($prefix) = @_;
    my $printer = {};

    $::prefix = $prefix;

    # Initialize $printer data structure
    resetinfo($printer);

    return $printer;
}

#------------------------------------------------------------------------------
sub resetinfo($) {
    my ($printer) = @_;
    $printer->{QUEUE} = "";
    $printer->{OLD_QUEUE} = "";
    $printer->{OLD_CHOICE} = "";
    $printer->{ARGS} = "";
    $printer->{DBENTRY} = "";
    $printer->{DEFAULT} = "";
    $printer->{currentqueue} = {};
    # -check which printing system was used previously and load the information
    # -about its queues
    read_configured_queues($printer);
}

sub read_configured_queues($) {
    my ($printer) = @_;
    my @QUEUES;
    # Get the default spooler choice from the config file
    $printer->{SPOOLER} ||= printer::default::get_spooler();
    if (!$printer->{SPOOLER}) {
	#- Find the first spooler where there are queues
	foreach my $spooler (qw(rcups cups pdq lprng lpd)) {
	    #- Is the spooler's daemon running?
	    my $service = $spooler;
	    if ($service eq "lprng") {
		$service = "lpd";
	    }
	    if (($service ne "pdq") && ($service ne "rcups")) {
		next unless services::is_service_running($service);
		# daemon is running, spooler found
		$printer->{SPOOLER} = $spooler;
	    }
	    #- poll queue info
	    if ($service ne "rcups") {
		open(my $F, ($::testing ? 
			     $::prefix : "chroot $::prefix/ ") .
		     "foomatic-configure -P -q -s $spooler |") or
		     die "Could not run foomatic-configure";
		eval join('', <$F>);
		close $F;
	    }
	    if ($service eq "pdq") {
		#- Have we found queues? PDQ has no damon, so we consider
		#- it in use when there are defined printer queues
		if ($#QUEUES != -1) {
		    $printer->{SPOOLER} = $spooler;
		    last;
		}
	    } elsif ($service eq "rcups") {
		#- In daemon-less CUPS mode there are no local queues,
		#- we can only recognize it by a server entry in
		#- /etc/cups/client.conf
		my ($daemonless_cups, $remote_cups_server) =
		    printer::main::read_client_conf();
		if ($daemonless_cups) {
		    $printer->{SPOOLER} = $spooler;
		    $printer->{remote_cups_server} = $remote_cups_server;
		    last;
		}
	    } else {
		#- For other spoolers we have already found a running
		#- daemon when we have arrived here
		last;
	    }
	}
    } else {
	if ($printer->{SPOOLER} ne "rcups") {
	    #- Poll the queues of the current default spooler
	    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") .
		 "foomatic-configure -P -q -s $printer->{SPOOLER} -r |") or
		 die "Could not run foomatic-configure";
	    eval join('', <$F>);
	    close $F;
	} else {
	    my ($_daemonless_cups, $remote_cups_server) =
		printer::main::read_client_conf();
	    $printer->{remote_cups_server} = $remote_cups_server;
	}
    }
    $printer->{configured} = {};
    my $i;
    my $N = $#QUEUES + 1;
    for ($i = 0;  $i < $N; $i++) {
	# Set the default printer
	$printer->{DEFAULT} = $QUEUES[$i]{queuedata}{queue} if
	    $QUEUES[$i]{queuedata}{default};
	# Advance to the next entry if the current is a remotely defined
	# printer
	next if $QUEUES[$i]{queuedata}{remote};
	# Add an entry for a locally defined queue
	$printer->{configured}{$QUEUES[$i]{queuedata}{queue}} = 
	    $QUEUES[$i];
	if (!$QUEUES[$i]{make} || !$QUEUES[$i]{model}) {
	    if ($printer->{SPOOLER} eq "cups") {
		$printer->{OLD_QUEUE} = $QUEUES[$i]{queuedata}{queue};
		my $descr = get_descr_from_ppd($printer);
		if ($descr =~ m/^([^\|]*)\|([^\|]*)(\|.*|)$/) {
		    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} ||= $1;
		    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} ||= $2;
	        }
		# Read out which PPD file was originally used to set up this
		# queue
		if (open(my $F, "< $::prefix/etc/cups/ppd/$QUEUES[$i]{queuedata}{queue}.ppd")) {
		    while (my $line = <$F>) {
			if ($line =~ /^\*%MDKMODELCHOICE:(.+)$/) {
			    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd} = $1;
			}
		    }
		    close $F;
		}
		# Mark that we have a CUPS queue but do not know the name
		# the PPD file in /usr/share/cups/model
		if ((!$printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd}) &&
		    (! -r $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd})) {
		    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{ppd} = '1';
		}
		$printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{driver} = 'PPD';
		$printer->{OLD_QUEUE} = "";
	    }
	    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} ||= "";
	    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} ||= N("Unknown model");
	} else {
	    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{make} = $QUEUES[$i]{make};
	    $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{model} = $QUEUES[$i]{model};
	}
	# Fill in "options" field
	if (my $args = $printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{args}) {
	    my @options;
	    foreach my $arg (@$args) {
		push(@options, "-o");
		my $optstr = $arg->{name} . "=" . $arg->{default};
		push(@options, $optstr);
	    }
	    @{$printer->{configured}{$QUEUES[$i]{queuedata}{queue}}{queuedata}{options}} = @options;
	}
	# Construct an entry line for tree view in main window of
	# printerdrake
	make_menuentry($printer, $QUEUES[$i]{queuedata}{queue});
    }
}

sub make_menuentry {
    my ($printer, $queue) = @_;
    my $spooler = $spoolers{$printer->{SPOOLER}}{short_name};
    my $connect = $printer->{configured}{$queue}{queuedata}{connect};
    my $localremote = N("Configured on this machine");
    my $make = $printer->{configured}{$queue}{queuedata}{make};
    my $model = $printer->{configured}{$queue}{queuedata}{model};
    my $connection;
    if ($connect =~ m!^(file|parallel):/dev/lp(\d+)$!) {
	my $number = $2;
	$connection = N(" on parallel port #%s", $number);
    } elsif ($connect =~ m!^(file|usb):/dev/usb/lp(\d+)$!) {
	my $number = $2;
	$connection = N(", USB printer #%s", $number);
    } elsif ($connect =~ m!^usb://!) {
	$connection = N(", USB printer");
    } elsif ($connect =~ m!^hp:/(.+?)$!) {
	my $hplipdevice = $1;
	if ($hplipdevice =~ m!^par/!) {
	    $connection = N(", HP printer on a parallel port");
	} elsif ($hplipdevice =~ m!^usb/!) {
	    $connection = N(", HP printer on USB");
	} elsif ($hplipdevice =~ m!^net/!) {
	    $connection = N(", HP printer on HP JetDirect");
	} else {
	    $connection = N(", HP printer");
	}
    } elsif ($connect =~ m!^ptal://?(.+?)$!) {
	my $ptaldevice = $1;
	if ($ptaldevice =~ /^mlc:par:(\d+)$/) {
	    my $number = $1;
	    $connection = N(", multi-function device on parallel port #%s",
			    $number);
	} elsif ($ptaldevice =~ /^mlc:par:/) {
	    $connection = N(", multi-function device on a parallel port");
	} elsif ($ptaldevice =~ /^mlc:usb:/) {
	    $connection = N(", multi-function device on USB");
	} elsif ($ptaldevice =~ /^hpjd:/) {
	    $connection = N(", multi-function device on HP JetDirect");
	} else {
	    $connection = N(", multi-function device");
	}
    } elsif ($connect =~ m!^file:(.+)$!) {
        my $file = $1;
	$connection = N(", printing to %s", $file);
    } elsif ($connect =~ m!^lpd://([^/]+)/([^/]+)/?$!) {
        my ($server, $printer) = ($1, $2);
	$connection = N(" on LPD server \"%s\", printer \"%s\"", $server, $printer);
    } elsif ($connect =~ m!^socket://([^/:]+):([^/:]+)/?$!) {
        my ($host, $port) = ($1, $2);
	$connection = N(", TCP/IP host \"%s\", port %s", $host, $port);
    } elsif ($connect =~ m!^smb://([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^smb://.*/([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^smb://.*\@([^/\@]+)/([^/\@]+)/?$!) {
        my ($server, $share) = ($1, $2);
	$connection = N(" on SMB/Windows server \"%s\", share \"%s\"", $server, $share);
    } elsif ($connect =~ m!^ncp://([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^ncp://.*/([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^ncp://.*\@([^/\@]+)/([^/\@]+)/?$!) {
        my ($server, $printer) = ($1, $2);
	$connection = N(" on Novell server \"%s\", printer \"%s\"", $server, $printer);
    } elsif ($connect =~ m!^postpipe:(.+)$!) {
        my $command = $1;
	$connection = N(", using command %s", $command);
    } else {
	$connection = ($printer->{expert} ? ", URI: $connect" : "");
    }
    my $sep = "!";
    $printer->{configured}{$queue}{queuedata}{menuentry} = 
	($printer->{expert} ? "$spooler$sep" : "") .
	"$localremote$sep$queue: $make $model$connection";
}

sub connectionstr {
    my ($connect) = @_;
    my $connection;
    if ($connect =~ m!^(file|parallel):/dev/lp(\d+)$!) {
	my $number = $2;
	$connection = N("Parallel port #%s", $number);
    } elsif ($connect =~ m!^(file|usb):/dev/usb/lp(\d+)$!) {
	my $number = $2;
	$connection = N("USB printer #%s", $number);
    } elsif ($connect =~ m!^usb://!) {
	$connection = N("USB printer");
    } elsif ($connect =~ m!^hp:/(.+?)$!) {
	my $hplipdevice = $1;
	if ($hplipdevice =~ m!^par/!) {
	    $connection = N("HP printer on a parallel port");
	} elsif ($hplipdevice =~ m!^usb/!) {
	    $connection = N("HP printer on USB");
	} elsif ($hplipdevice =~ m!^net/!) {
	    $connection = N("HP printer on HP JetDirect");
	} else {
	    $connection = N("HP printer");
	}
    } elsif ($connect =~ m!^ptal://?(.+?)$!) {
	my $ptaldevice = $1;
	if ($ptaldevice =~ /^mlc:par:(\d+)$/) {
	    my $number = $1;
	    $connection = N("Multi-function device on parallel port #%s",
			    $number);
	} elsif ($ptaldevice =~ /^mlc:par:/) {
	    $connection = N("Multi-function device on a parallel port");
	} elsif ($ptaldevice =~ /^mlc:usb:/) {
	    $connection = N("Multi-function device on USB");
	} elsif ($ptaldevice =~ /^hpjd:/) {
	    $connection = N("Multi-function device on HP JetDirect");
	} else {
	    $connection = N("Multi-function device");
	}
    } elsif ($connect =~ m!^file:(.+)$!) {
        my $file = $1;
	$connection = N("Prints into %s", $file);
    } elsif ($connect =~ m!^lpd://([^/]+)/([^/]+)/?$!) {
        my ($server, $port) = ($1, $2);
	$connection = N("LPD server \"%s\", printer \"%s\"", $server, $port);
    } elsif ($connect =~ m!^socket://([^/:]+):([^/:]+)/?$!) {
        my ($host, $port) = ($1, $2);
        $connection = N("TCP/IP host \"%s\", port %s", $host, $port);
    } elsif ($connect =~ m!^smb://([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^smb://.*/([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^smb://.*\@([^/\@]+)/([^/\@]+)/?$!) {
        my ($server, $share) = ($1, $2);
	$connection = N("SMB/Windows server \"%s\", share \"%s\"", $server, $share);
    } elsif ($connect =~ m!^ncp://([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^ncp://.*/([^/\@]+)/([^/\@]+)/?$! ||
	     $connect =~ m!^ncp://.*\@([^/\@]+)/([^/\@]+)/?$!) {
        my ($server, $share) = ($1, $2);
	$connection = N("Novell server \"%s\", printer \"%s\"", $server, $share);
    } elsif ($connect =~ m!^postpipe:(.+)$!) {
        my $command = $1;
	$connection = N("Uses command %s", $command);
    } else {
	$connection = N("URI: %s", $connect);
    }
    return $connection;
}

sub read_printer_db {

    my ($printer, $spooler) = @_;

    # No local queues available in daemon-less CUPS mode
    return 1 if $spooler eq "rcups";

    my $DBPATH; #- do not have to do close ... and do not modify globals at least
    # Generate the Foomatic printer/driver overview, read it from the
    # appropriate file when it is already generated
    open($DBPATH, ($::testing ? $::prefix : "chroot $::prefix/ ") . #-#
	"foomatic-configure -O -q |") or
	die "Could not run foomatic-configure";

    my $entry = {};
    my $inentry = 0;
    my $indrivers = 0;
    my $inautodetect = 0;
    my $autodetecttype = "";
    local $_;
    while (<$DBPATH>) {
	chomp;
	if ($inentry) {
	    # We are inside a printer entry
	    if ($indrivers) {
		# We are inside the drivers block of a printers entry
		if (m!^\s*</drivers>\s*$!) {
		    # End of drivers block
		    $indrivers = 0;
		} elsif (m!^\s*<driver>(.+)</driver>\s*$!) {
		    push @{$entry->{drivers}}, $1;
		}
	    } elsif ($inautodetect) {
		# We are inside the autodetect block of a printers entry
		# All entries inside this block will be ignored
		if ($autodetecttype) {
		    if (m!^.*</$autodetecttype>\s*$!) {
			# End of general, parallel, USB, or SNMP section
			$autodetecttype = "";
		    } elsif (m!^\s*<manufacturer>\s*([^<>]+)\s*</manufacturer>\s*$!) {
			# Manufacturer
			$entry->{devidmake} = $1;
		    } elsif (m!^\s*<model>\s*([^<>]+)\s*</model>\s*$!) {
			# Model
			$entry->{devidmodel} = $1;
		    } elsif (m!^\s*<description>\s*([^<>]+)\s*</description>\s*$!) {
			# Description
			$entry->{deviddesc} = $1;
		    } elsif (m!^\s*<commandset>\s*([^<>]+)\s*</commandset>\s*$!) {
			# Command set
			$entry->{devidcmdset} = $1;
		    } elsif (m!^\s*<ieee1284>\s*([^<>]+)\s*</ieee1284>\s*$!) {
			# Full ID string
			my $idstr = $1;
			$idstr =~ m!(MFG|MANUFACTURER):([^;]+);!i
			    and $entry->{devidmake} = $2;
			$idstr =~ m!(MDL|MODEL):([^;]+);!i
			    and $entry->{devidmodel} = $2;
			$idstr =~ m!(DES|DESCRIPTION):([^;]+);!i
			    and $entry->{deviddesc} = $2;
			$idstr =~ m!(CMD|COMMAND\s*SET):([^;]+);!i
			    and $entry->{devidcmdset} = $2;
		    }
		} else {
		    if (m!^.*</autodetect>\s*$!) {
			# End of autodetect block
			$inautodetect = 0;
		    } elsif (m!^\s*<(general|parallel|usb|snmp)>\s*$!) {
			# Beginning of parallel, USB, or SNMP section
			$autodetecttype = $1;
		    }
		}
	    } else {
		if (m!^\s*</printer>\s*$!) {
		    # entry completed
		    $inentry = 0;
		    # Expert mode:
		    # Make one database entry per driver with the entry name
		    # manufacturer|model|driver
		    if ($printer->{expert}) {
			foreach my $driver (@{$entry->{drivers}}) {
			    my $driverstr;
			    if ($driver eq "Postscript") {
				$driverstr = "PostScript";
			    } else {
				$driverstr = "GhostScript + $driver";
			    }
			    if ($driver eq $entry->{defaultdriver}) {
				$driverstr .= " (recommended)";
			    }
			    $entry->{ENTRY} = "$entry->{make}|$entry->{model}|$driverstr";
			    $entry->{ENTRY} =~ s/^CITOH/C.ITOH/i;
			    $entry->{ENTRY} =~ 
				s/^KYOCERA[\s\-]*MITA/KYOCERA/i;
			    $entry->{driver} = $driver;
			    # Duplicate contents of $entry because it is multiply entered to the database
			    map { $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} } keys %$entry;
			}
		    } else {
			# Recommended mode
			# Make one entry per printer, with the recommended
			# driver (manufacturerer|model)
			$entry->{ENTRY} = "$entry->{make}|$entry->{model}";
			$entry->{ENTRY} =~ s/^CITOH/C.ITOH/i;
			$entry->{ENTRY} =~ 
			    s/^KYOCERA[\s\-]*MITA/KYOCERA/i;
			if ($entry->{defaultdriver}) {
			    $entry->{driver} = $entry->{defaultdriver};
			    map { $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} } keys %$entry;
			}
		    }
		    $entry = {};
		} elsif (m!^\s*<id>\s*([^\s<>]+)\s*</id>\s*$!) {
		    # Foomatic printer ID
		    $entry->{printer} = $1;
		} elsif (m!^\s*<make>(.+)</make>\s*$!) {
		    # Printer manufacturer
		    $entry->{make} = uc($1);
		} elsif (m!^\s*<model>(.+)</model>\s*$!) {
		    # Printer model
		    $entry->{model} = $1;
		} elsif (m!<driver>(.+)</driver>!) {
		    # Printer default driver
		    $entry->{defaultdriver} = $1;
		} elsif (m!^\s*<drivers>\s*$!) {
		    # Drivers block
		    $indrivers = 1;
		    @{$entry->{drivers}} = (); 
		} elsif (m!^\s*<autodetect>\s*$!) {
		    # Autodetect block
		    $inautodetect = 1;
		}
	    }
	} else {
	    if (m!^\s*<printer>\s*$!) {
		# new entry
		$inentry = 1;
	    }
	}
    }
    close $DBPATH;

    # Add raw queue
    $entry->{ENTRY} = N("Raw printer (No driver)");
    $entry->{driver} = "raw";
    $entry->{make} = "";
    $entry->{model} = N("Unknown model");
    $thedb{$entry->{ENTRY}}{$_} = $entry->{$_} foreach keys %$entry;

    #- Load CUPS driver database if CUPS is used as spooler
    if ($spooler && $spooler eq "cups") {
        poll_ppd_base($printer);
    }

    #my @entries_db_short     = sort keys %printer::thedb;
    #%descr_to_db          = map { $printer::thedb{$_}{DESCR}, $_ } @entries_db_short;
    #%descr_to_help        = map { $printer::thedb{$_}{DESCR}, $printer::thedb{$_}{ABOUT} } @entries_db_short;
    #@entry_db_description = keys %descr_to_db;
    #db_to_descr          = reverse %descr_to_db;

}

sub read_foomatic_options ($) {
    my ($printer) = @_;
    # Generate the option data for the chosen printer/driver combo
    my $COMBODATA;
    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . 
	"foomatic-configure -P -q -p $printer->{currentqueue}{printer}" .
	" -d $printer->{currentqueue}{driver}" . 
	($printer->{OLD_QUEUE} ?
	 " -s $printer->{SPOOLER} -n $printer->{OLD_QUEUE}" : "") .
	 ($printer->{SPECIAL_OPTIONS} ?
	  " $printer->{SPECIAL_OPTIONS}" : "") 
	 . " |") or
	 die "Could not run foomatic-configure";
    eval join('', (<$F>)); 
    close $F;
    # Return the arguments field
    return $COMBODATA->{args};
}

sub read_ppd_options ($) {
    my ($printer) = @_;
    # Generate the option data for a given PPD file
    my $COMBODATA;
    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . 
	"foomatic-configure -P -q" .
	 if_($printer->{currentqueue}{ppd} &&
	     ($printer->{currentqueue}{ppd} ne '1'),
	     " --ppd " . ($printer->{currentqueue}{ppd} !~ m!^/! ?
			    "/usr/share/cups/model/" : "") .
			   $printer->{currentqueue}{ppd}) .
	($printer->{OLD_QUEUE} ?
	 " -s $printer->{SPOOLER} -n $printer->{OLD_QUEUE}" : "") .
	 ($printer->{SPECIAL_OPTIONS} ?
	  " $printer->{SPECIAL_OPTIONS}" : "") 
		    . " |") or
	    die "Could not run foomatic-configure";
    eval join('', (<$F>));
    close $F;
    # Return the arguments field
    return $COMBODATA->{args};
}

my %sysconfig = getVarsFromSh("$::prefix/etc/sysconfig/printing");

sub set_cups_special_options {
    my ($queue) = @_;
    # Set some special CUPS options
    my @lpoptions = chomp_(cat_("$::prefix/etc/cups/lpoptions"));
    # If nothing is already configured, set text file borders of half an inch
    # and decrease the font size a little bit, so nothing of the text gets
    # cut off by unprintable borders.
    if (!any { /$queue.*\s(page-(top|bottom|left|right)|lpi|cpi)=/ } @lpoptions) {
	run_program::rooted($::prefix, "lpoptions",
			    "-p", $queue,
			    "-o", "page-top=36", "-o", "page-bottom=36",
			    "-o", "page-left=36", "-o page-right=36",
			    "-o", "cpi=12", "-o", "lpi=7", "-o", "wrap");
    }
    # Let images fill the whole page by default
    if (!any { /$queue.*\s(scaling|natural-scaling|ppi)=/ } @lpoptions) {
	run_program::rooted($::prefix, "lpoptions",
			    "-p", $queue,
			    "-o", "scaling=100");
    }
    return 1;
}

sub set_cups_autoconf {
    my ($autoconf) = @_;
    $sysconfig{CUPS_CONFIG} = $autoconf ? "automatic" : "manual";
    setVarsInSh("$::prefix/etc/sysconfig/printing", \%sysconfig);
    # Restart CUPS
    printer::services::restart("cups") if $autoconf;
    return 1;
}

sub get_cups_autoconf() { $sysconfig{CUPS_CONFIG} ne 'manual' ? 1 : 0 }

sub set_usermode {
    my ($usermode) = @_;
    $sysconfig{USER_MODE} = $usermode ? "expert" : "recommended";
    setVarsInSh("$::prefix/etc/sysconfig/printing", \%sysconfig) if !$::testing;
    return $usermode;
}

sub get_usermode() { $sysconfig{USER_MODE} eq 'expert' ? 1 : 0 }

sub set_jap_textmode {
    my $textmode = ($_[0] ? 'cjk' : '');
    # Do not write mime.convs if the file does not exist, as then
    # CUPS is not installed and the created mime.convs will be broken.
    # When installing CUPS later it will not work.
    return 1 if (! -r "$::prefix/etc/cups/mime.convs");
    substInFile {
        s!^(\s*text/plain\s+\S+\s+\d+\s+)\S+(\s*$)!$1${textmode}texttops$2!        
    } "$::prefix/etc/cups/mime.convs";
    return 1;
}

sub get_jap_textmode() {
    my @mimeconvs = cat_("$::prefix/etc/cups/mime.convs");
    (m!^\s*text/plain\s+\S+\s+\d+\s+(\S+)\s*$!m and
     $1 eq 'cjktexttops' and return 1) foreach @mimeconvs;
    return 0;
}

#----------------------------------------------------------------------
# Handling of /etc/cups/cupsd.conf

sub read_cupsd_conf() {
    # If /etc/cups/cupsd.conf a default cupsd.conf will be put out to avoid
    # writing of a broken cupsd.conf file when we write it back later.
    my @cupsd_conf = cat_("$::prefix/etc/cups/cupsd.conf");
    if (!@cupsd_conf) {
	@cupsd_conf = map { /\n$/s or "$_\n" } split('\n',
'LogLevel info
TempDir /var/spool/cups/tmp
Port 631
Browsing On
BrowseAddress @LOCAL
BrowseDeny All
BrowseAllow 127.0.0.1
BrowseAllow @LOCAL
BrowseOrder deny,allow
<Location />
Order Deny,Allow
Deny From All
Allow From 127.0.0.1
Allow From @LOCAL
</Location>
<Location /admin>
AuthType Basic
AuthClass System
Order Deny,Allow
Deny From All
Allow From 127.0.0.1
</Location>
');
    }
    return @cupsd_conf;
}

sub write_cupsd_conf {
    my (@cupsd_conf) = @_;
    # Do not write cupsd.conf if the file does not exist, as then
    # CUPS is not installed and the created cupsd.conf will be broken.
    # When installing CUPS later it will not start.
    return 1 if (! -r "$::prefix/etc/cups/cupsd.conf");
    output("$::prefix/etc/cups/cupsd.conf", @cupsd_conf);
}

sub read_location {

    # Return the lines inside the [path] location block
    #
    #   <Location [path]>
    #   ...
    #   </Location>

    my ($cupsd_conf_ptr, $path) = @_;

    my @result;
    if (any { m!^\s*<Location\s+$path\s*>! } @$cupsd_conf_ptr) {
	my $location_start = -1;
	my $location_end = -1;
	# Go through all the lines, bail out when start and end line found
	for (my $i = 0; 
	     $i <= $#{$cupsd_conf_ptr} && $location_end == -1;
	     $i++) {
	    if ($cupsd_conf_ptr->[$i] =~ m!^\s*<\s*Location\s+$path\s*>!) {
		# Start line of block
		$location_start = $i;
	    } elsif ($cupsd_conf_ptr->[$i] =~ 
		      m!^\s*<\s*/Location\s*>! &&
		     $location_start != -1) {
		# End line of block
		$location_end = $i;
		last;
	    } elsif ($location_start >= 0 && $location_end < 0) {
		# Inside the location block
		push(@result, $cupsd_conf_ptr->[$i]);
	    }
	}
    } else {
	# If there is no root location block, set the result array to
	# "undef"
	@result = undef;
    }
    return @result;
}

sub rip_location {

    # Cut out the [path]  location block
    #
    #   <Location [path]>
    #   ...
    #   </Location>
    #
    # so that it can be treated seperately without affecting the
    # rest of the file

    my ($cupsd_conf_ptr, $path) = @_;

    my @location;
    my $location_start = -1;
    my $location_end = -1;
    if (any { m!^\s*<Location\s+$path\s*>! } @$cupsd_conf_ptr) {
	# Go through all the lines, bail out when start and end line found
	for (my $i = 0; 
	     $i <= $#{$cupsd_conf_ptr} && $location_end == -1;
	     $i++) {
	    if ($cupsd_conf_ptr->[$i] =~ m!^\s*<\s*Location\s+$path\s*>!) {
		# Start line of block
		$location_start = $i;
	    } elsif ($cupsd_conf_ptr->[$i] =~ 
		      m!^\s*<\s*/Location\s*>! &&
		     $location_start != -1) {
		# End line of block
		$location_end = $i;
		last;
	    }
	}
	# Rip out the block and store it seperately
	@location = 
	    splice(@$cupsd_conf_ptr, $location_start,
		   $location_end - $location_start + 1);
    } else {
	# If there is no location block, create one
	$location_start = $#{$cupsd_conf_ptr} + 1;
	@location = ("<Location $path>\n", "</Location>\n");
    }

    return $location_start, @location;
}

sub insert_location {

    # Re-insert a location block ripped with "rip_location"

    my ($cupsd_conf_ptr, $location_start, @location) = @_;

    splice(@$cupsd_conf_ptr, $location_start,0,@location);
}

sub add_to_location {

    # Add a directive to a given location (only if it is not already there)

    my ($cupsd_conf_ptr, $path, $directive) = @_;

    my ($location_start, @location) = rip_location($cupsd_conf_ptr, $path);
    my $success = handle_configs::insert_directive(\@location, $directive);
    insert_location($cupsd_conf_ptr, $location_start, @location);
    return $success;
}

sub remove_from_location {

    # Remove a directive from a given location

    my ($cupsd_conf_ptr, $path, $directive) = @_;

    my ($location_start, @location) = rip_location($cupsd_conf_ptr, $path);
    my $success = handle_configs::remove_directive(\@location, $directive);
    insert_location($cupsd_conf_ptr, $location_start, @location);
    return $success;
}

sub replace_in_location {

    # Replace a directive in a given location

    my ($cupsd_conf_ptr, $path, $olddirective, $newdirective) = @_;

    my ($location_start, @location) = rip_location($cupsd_conf_ptr, $path);
    my $success = handle_configs::replace_directive(\@location, 
						    $olddirective, 
						    $newdirective);
    insert_location($cupsd_conf_ptr, $location_start, @location);
    return $success;
}

sub add_allowed_host {

    # Add a host or network which should get access to the local printer(s)
    my ($cupsd_conf_ptr, $host) = @_;
    
    return (handle_configs::insert_directive($cupsd_conf_ptr, 
					     "BrowseAddress $host") and
	    add_to_location($cupsd_conf_ptr, "/", "Allow From $host"));
}

sub remove_allowed_host {

    # Remove a host or network which should get access to the local 
    # printer(s)
    my ($cupsd_conf_ptr, $host) = @_;
    
    return (handle_configs::remove_directive($cupsd_conf_ptr, "BrowseAddress $host") and
	    remove_from_location($cupsd_conf_ptr, "/",
				 "Allow From $host"));
}

sub replace_allowed_host {

    # Remove a host or network which should get access to the local 
    # printer(s)
    my ($cupsd_conf_ptr, $oldhost, $newhost) = @_;
    
    return (handle_configs::replace_directive($cupsd_conf_ptr,
					      "BrowseAddress $oldhost",
					      "BrowseAddress $newhost") and
	    replace_in_location($cupsd_conf_ptr, "/", "Allow From $newhost",
				"Allow From $newhost"));
}

sub broadcastaddress {
    
    # Determines the broadcast address (for "BrowseAddress" line) for
    # a given network IP

    my ($address) = @_;

    if ($address =~ /^\d+\.\*$/) {
	$address =~ s/\*$/255.255.255/;
    } elsif ($address =~ /^\d+\.\d+\.\*$/) {
	$address =~ s/\*$/255.255/;
    } elsif ($address =~ /^\d+\.\d+\.\d+\.\*$/) {
	$address =~ s/\*$/255/;
    } elsif ($address =~ m!^(\d+)\.(\d+)\.(\d+)\.(\d+)/(\d+)$!) {
	my $numadr = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4;
	my $mask = ((1 << $5) - 1) << (32 - $5);
	my $broadcast = $numadr | (~$mask);
	$address =
	    (($broadcast & (255 << 24)) >> 24) . '.' .
	    (($broadcast & (255 << 16)) >> 16) . '.' .
	    (($broadcast & (255 << 8)) >> 8) . '.' .
	    ($broadcast & 255);
    } elsif ($address =~
	     m!^(\d+)\.(\d+)\.(\d+)\.(\d+)/(\d+)\.(\d+)\.(\d+)\.(\d+)$!) {
	my $numadr = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4;
	my $mask = ($5 << 24) + ($6 << 16) + ($7 << 8) + $8;
	my $broadcast = $numadr | (~$mask);
	$address =
	    (($broadcast & (255 << 24)) >> 24) . '.' .
	    (($broadcast & (255 << 16)) >> 16) . '.' .
	    (($broadcast & (255 << 8)) >> 8) . '.' .
	    ($broadcast & 255);
    }
    
    return $address;
}

sub networkaddress {
    
    # Guesses a network address for a given broadcast address
    
    my ($address) = @_;

    if ($address =~ /\.255$/) {
	while ($address =~ s/\.255$//) {};
	$address .= ".*";
    }
 
    return $address;
}

sub localprintersshared {

    # Do we broadcast our local printers

    my ($printer) = @_;

    return ($printer->{cupsconfig}{keys}{Browsing} !~ /off/i &&
	    $printer->{cupsconfig}{keys}{BrowseInterval} != 0 &&
	    $#{$printer->{cupsconfig}{keys}{BrowseAddress}} >= 0);
}

sub remotebroadcastsaccepted {
    
    # Do we accept broadcasts from remote CUPS servers?

    my ($printer) = @_;

    # Is browsing not turned on at all?
    if ($printer->{cupsconfig}{keys}{Browsing} =~ /off/i) {
	return 0;
    }

    # No "BrowseDeny" lines at all
    if ($#{$printer->{cupsconfig}{keys}{BrowseDeny}} < 0) {
	return 1;
    }

    my $havedenyall = 
	join('', @{$printer->{cupsconfig}{keys}{BrowseDeny}}) =~
	 /All/im;
    my $havedenylocal = 
	join('', @{$printer->{cupsconfig}{keys}{BrowseDeny}}) =~
	 /\@LOCAL/im;
    my $orderallowdeny =
	$printer->{cupsconfig}{keys}{BrowseOrder} =~
	 /allow\s*,\s*deny/i;
    my $haveallowremote = 0;
    foreach my $allowline (@{$printer->{cupsconfig}{keys}{BrowseAllow}}) {
	next if 
	    $allowline =~ /^\s*(localhost|0*127\.0+\.0+\.0*1|none)\s*$/i;
	$haveallowremote = 1;
    }

    # A line denying all (or at least the all LANs) together with the order
    # "allow,deny" or without "BrowseAllow" lines (which allow the
    # broadcasts of at least one remote resource).
    if (($havedenyall || $havedenylocal) &&
	($orderallowdeny || !$haveallowremote)) {
	return 0;
    }

    return 1;
}

sub clientnetworks {

    # Determine the client networks to which the printers will be
    # shared If the configuration is supported by our simplified
    # interface ("Deny From All", "Order Deny,Allow", "Allow From ..."
    # lines in "<location /> ... </location>", a "BrowseAddress ..."
    # line for each "Allow From ..." line), return the list of allowed
    # client networks ("Allow"/"BrowseAddress" lines), if not, return
    # the list of all items which are at least one of the
    # "BrowseAddresse"s or one of the "Allow From" addresses together
    # with a flag that the setup is not supported.

    my ($printer) = @_;

    # Check for a "Deny From All" line
    my $havedenyfromall =
	(join('', @{$printer->{cupsconfig}{root}{DenyFrom}}) =~
	 /All/im ? 1 : 0);

    # Check for "Deny From XXX" with XXX != All
    my $havedenyfromnotall =
	($#{$printer->{cupsconfig}{root}{DenyFrom}} - $havedenyfromall < 0 ?
	 0 : 1);
    
    # Check for a "BrowseDeny All" line
    my $havebrowsedenyall =
	(join('', @{$printer->{cupsconfig}{keys}{BrowseDeny}}) =~
	 /All/im ? 1 : 0);

    # Check for "BrowseDeny XXX" with XXX != All
    my $havebrowsedenynotall =
	($#{$printer->{cupsconfig}{keys}{BrowseDeny}} - 
	 $havebrowsedenyall < 0 ? 0 : 1);
    
    my @sharehosts;
    my $haveallowfromlocalhost = 0;
    my $haveallowedhostwithoutbrowseaddress = 0;
    my $haveallowedhostwithoutbrowseallow = 0;
    # Go through all "Allow From" lines
    foreach my $line (@{$printer->{cupsconfig}{root}{AllowFrom}}) {
	if ($line =~ /^\s*(localhost|0*127\.0+\.0+\.0*1)\s*$/i) {
	    # Line pointing to localhost
	    $haveallowfromlocalhost = 1;
	} elsif ($line =~ /^\s*(none)\s*$/i) {
	    # Skip "Allow From None" lines
	} elsif (!member($line, @sharehosts)) {
	    # Line pointing to remote server
	    push(@sharehosts, $line);
	    if (!member(broadcastaddress($line),
			@{$printer->{cupsconfig}{keys}{BrowseAddress}})) {
		$haveallowedhostwithoutbrowseaddress = 1;
	    }
	    if (!member($line,
			@{$printer->{cupsconfig}{keys}{BrowseAllow}})) {
		$haveallowedhostwithoutbrowseallow = 1;
	    }
	}
    }
    my $havebrowseaddresswithoutallowedhost = 0;
    # Go through all "BrowseAdress" lines
    foreach my $line (@{$printer->{cupsconfig}{keys}{BrowseAddress}}) {
	if ($line =~ /^\s*(localhost|0*127\.0+\.0+\.0*1)\s*$/i) {
	    # Skip lines pointing to localhost
	} elsif ($line =~ /^\s*(none)\s*$/i) {
	    # Skip "Allow From None" lines
	} elsif (!member($line, map { broadcastaddress($_) } @sharehosts)) {
	    # Line pointing to remote server
	    push(@sharehosts, networkaddress($line));
	    if ($printer->{cupsconfig}{localprintersshared}) {
		$havebrowseaddresswithoutallowedhost = 1;
	    }
	}
    }
    my $havebrowseallowwithoutallowedhost = 0;
    # Go through all "BrowseAllow" lines
    foreach my $line (@{$printer->{cupsconfig}{keys}{BrowseAllow}}) {
	if ($line =~ /^\s*(localhost|0*127\.0+\.0+\.0*1)\s*$/i) {
	    # Skip lines pointing to localhost
	} elsif ($line =~ /^\s*(none)\s*$/i) {
	    # Skip "BrowseAllow None" lines
	} elsif (!member($line, @sharehosts)) {
	    # Line pointing to remote server
	    push(@sharehosts, $line);
	    #$havebrowseallowwithoutallowedhost = 1;
	}
    }

    my $configunsupported = (!$havedenyfromall || $havedenyfromnotall ||
			     !$havebrowsedenyall || $havebrowsedenynotall ||
			     !$haveallowfromlocalhost ||
			     $haveallowedhostwithoutbrowseaddress ||
			     $havebrowseaddresswithoutallowedhost ||
			     $haveallowedhostwithoutbrowseallow ||
			     $havebrowseallowwithoutallowedhost);

    return $configunsupported, @sharehosts;
}

sub makesharehostlist {

    # Human-readable strings for hosts onto which the local printers
    # are shared

    my ($printer) = @_;

    my @sharehostlist; 
    my %sharehosthash;
    foreach my $host (@{$printer->{cupsconfig}{clientnetworks}}) {
	if ($host =~ /\@LOCAL/i) {
	    $sharehosthash{$host} = N("Local network(s)");
	} elsif ($host =~ /\@IF\((.*)\)/i) {
	    $sharehosthash{$host} = N("Interface \"%s\"", $1);
	} elsif ($host =~ m!(/|^\*|\*$|^\.)!) {
	    $sharehosthash{$host} = N("Network %s", $host);
	} else {
	    $sharehosthash{$host} = N("Host %s", $host);
	}
	push(@sharehostlist, $sharehosthash{$host});
    }
    my %sharehosthash_inv = reverse %sharehosthash;

    return { list => \@sharehostlist, 
	     hash => \%sharehosthash, 
	     invhash => \%sharehosthash_inv };
}

sub makebrowsepolllist {

    # Human-readable strings for hosts from which the print queues are
    # polled

    my ($printer) = @_;

    my @browsepolllist; 
    my %browsepollhash;
    foreach my $host (@{$printer->{cupsconfig}{BrowsePoll}}) {
	my ($ip, $port);
	if ($host =~ /^([^:]+):([^:]+)$/) {
	    $ip = $1;
	    $port = $2;
	} else {
	    $ip = $host;
	    $port = '631';
	}
	$browsepollhash{$host} = N("%s (Port %s)", $ip, $port);
	push(@browsepolllist, $browsepollhash{$host});
    }
    my %browsepollhash_inv = reverse %browsepollhash;

    return { list => \@browsepolllist, 
	     hash => \%browsepollhash, 
	     invhash => \%browsepollhash_inv };
}

sub is_network_ip {

    # Determine whwther the given string is a valid network IP

    my ($address) = @_;

    $address =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ ||
	$address =~ /^(\d+\.){1,3}\*$/ ||
	$address =~ m!^(\d+)\.(\d+)\.(\d+)\.(\d+)/(\d+)$! ||
	$address =~
	 m!^(\d+)\.(\d+)\.(\d+)\.(\d+)/(\d+)\.(\d+)\.(\d+)\.(\d+)$!;

}

sub read_cups_config {
    
    # Read the information relevant to the printer sharing dialog from
    # the CUPS configuration

    my ($printer) = @_;

    # From /etc/cups/cupsd.conf

    # Keyword "Browsing" 
    $printer->{cupsconfig}{keys}{Browsing} =
	handle_configs::read_unique_directive($printer->{cupsconfig}{cupsd_conf},
					      'Browsing', 'On');

    # Keyword "BrowseInterval"
    $printer->{cupsconfig}{keys}{BrowseInterval} =
	handle_configs::read_unique_directive($printer->{cupsconfig}{cupsd_conf},
					      'BrowseInterval', '30');

    # Keyword "BrowseAddress" 
    @{$printer->{cupsconfig}{keys}{BrowseAddress}} =
	handle_configs::read_directives($printer->{cupsconfig}{cupsd_conf},
					'BrowseAddress');

    # Keyword "BrowseAllow" 
    @{$printer->{cupsconfig}{keys}{BrowseAllow}} =
	handle_configs::read_directives($printer->{cupsconfig}{cupsd_conf},
					'BrowseAllow');

    # Keyword "BrowseDeny" 
    @{$printer->{cupsconfig}{keys}{BrowseDeny}} =
	handle_configs::read_directives($printer->{cupsconfig}{cupsd_conf},
					'BrowseDeny');

    # Keyword "BrowseOrder" 
    $printer->{cupsconfig}{keys}{BrowseOrder} =
	handle_configs::read_unique_directive($printer->{cupsconfig}{cupsd_conf},
					      'BrowseOrder', 'deny,allow');

    # Keyword "BrowsePoll" (needs "Browsing On")
    if ($printer->{cupsconfig}{keys}{Browsing} !~ /off/i) {
	@{$printer->{cupsconfig}{BrowsePoll}} =
	    handle_configs::read_directives($printer->{cupsconfig}{cupsd_conf},
					    'BrowsePoll');
    }

    # Root location
    @{$printer->{cupsconfig}{rootlocation}} =
	read_location($printer->{cupsconfig}{cupsd_conf}, '/');

    # Keyword "Allow from" 
    @{$printer->{cupsconfig}{root}{AllowFrom}} =
	handle_configs::read_directives($printer->{cupsconfig}{rootlocation},
					'Allow From');
    # Remove the IPs pointing to the local machine
    my @localips = printer::detect::getIPsOfLocalMachine();
    @{$printer->{cupsconfig}{root}{AllowFrom}} =
	grep {
	    !member($_, @localips)
	} @{$printer->{cupsconfig}{root}{AllowFrom}};

    # Keyword "Deny from" 
    @{$printer->{cupsconfig}{root}{DenyFrom}} =
	handle_configs::read_directives($printer->{cupsconfig}{rootlocation},
					'Deny From');

    # Keyword "Order" 
    $printer->{cupsconfig}{root}{Order} =
	handle_configs::read_unique_directive($printer->{cupsconfig}{rootlocation},
					      'Order', 'Deny,Allow');

    # Widget settings

    # Local printers available to other machines?
    $printer->{cupsconfig}{localprintersshared} = 
	localprintersshared($printer);

    # This machine is accepting printers shared by remote machines?
    $printer->{cupsconfig}{remotebroadcastsaccepted} =
	remotebroadcastsaccepted($printer);

    # To which machines are the local printers available?
    ($printer->{cupsconfig}{customsharingsetup},
     @{$printer->{cupsconfig}{clientnetworks}}) =
	 clientnetworks($printer);

}

sub write_cups_config {
    
    # Write the information edited via the printer sharing dialog into
    # the CUPS configuration

    my ($printer) = @_;

    # Local printers available to other machines?
    if ($printer->{cupsconfig}{localprintersshared}) {
	handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
				      'Browsing On');
	if ($printer->{cupsconfig}{keys}{BrowseInterval} == 0) {
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseInterval 30');
	}  
    } else {
	handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
				      'BrowseInterval 0');
    }

    # This machine is accepting printers shared by remote machines?
    if ($printer->{cupsconfig}{remotebroadcastsaccepted}) {
	handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
				      'Browsing On');
	if (!$printer->{cupsconfig}{customsharingsetup}) {
	    # If we broadcast our printers, let's accept the broadcasts
	    # from the machines to which we broadcast
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseDeny All');
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseOrder Deny,Allow');
	}
    } else {
	if ($printer->{cupsconfig}{localprintersshared} ||
	    $#{$printer->{cupsconfig}{BrowsePoll}} >= 0) {
	    # Deny all broadcasts, but leave all "BrowseAllow" lines
	    # untouched
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseDeny All');
	      handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					    'BrowseOrder Allow,Deny');
	} else {
	    # We also do not share printers, if we also do not
	    # "BrowsePoll", we turn browsing off to do not need to deal 
	    # with any addresses
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'Browsing Off');
	}
    }

    # To which machines are the local printers available?
    if (!$printer->{cupsconfig}{customsharingsetup}) {
	my @localips = printer::detect::getIPsOfLocalMachine();
	# root location block
	@{$printer->{cupsconfig}{rootlocation}} =
	    "<Location />\n" .
	    "Order Deny,Allow\n" .
	    "Deny From All\n" .
	    "Allow From 127.0.0.1\n" .
	    (@localips ?
	     "Allow From " .
	     join("\nAllow From ", @localips) .
	     "\n" : "") .
	    ($printer->{cupsconfig}{localprintersshared} &&
	     $#{$printer->{cupsconfig}{clientnetworks}} >= 0 ?
	     "Allow From " .
	     join("\nAllow From ", 
		  grep {
		      !member($_, @localips)
		  } @{$printer->{cupsconfig}{clientnetworks}}) .
	     "\n" : "") .
	    "</Location>\n";
	my ($location_start, @_location) = 
	    rip_location($printer->{cupsconfig}{cupsd_conf}, "/");
	insert_location($printer->{cupsconfig}{cupsd_conf}, $location_start,
			@{$printer->{cupsconfig}{rootlocation}});
	# "BrowseAddress" lines
	if ($#{$printer->{cupsconfig}{clientnetworks}} >= 0) {
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseAddress ' .
					  join("\nBrowseAddress ",
						map { broadcastaddress($_) }
						@{$printer->{cupsconfig}{clientnetworks}}));
	} else {
	    handle_configs::comment_directive($printer->{cupsconfig}{cupsd_conf},
					      'BrowseAddress')
	}
	# Set "BrowseAllow" lines
	if ($#{$printer->{cupsconfig}{clientnetworks}} >= 0) {
	    handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowseAllow ' .
					  join("\nBrowseAllow ", 
						@{$printer->{cupsconfig}{clientnetworks}}));
	} else {
	    handle_configs::comment_directive($printer->{cupsconfig}{cupsd_conf},
					      'BrowseAllow');
	}
    }

    # Set "BrowsePoll" lines
    if ($#{$printer->{cupsconfig}{BrowsePoll}} >= 0) {
	handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
				      'BrowsePoll ' .
				      join("\nBrowsePoll ", 
					    @{$printer->{cupsconfig}{BrowsePoll}}));
	# "Browsing" must be on for "BrowsePoll" to work
	handle_configs::set_directive($printer->{cupsconfig}{cupsd_conf},
				      'Browsing On');
    } else {
	handle_configs::comment_directive($printer->{cupsconfig}{cupsd_conf},
					  'BrowsePoll');
    }

}

sub clean_cups_config {
    
    # Clean $printer data structure from all settings not related to
    # the CUPS printer sharing dialog

    my ($printer) = @_;

    delete $printer->{cupsconfig}{keys};
    delete $printer->{cupsconfig}{root};
    delete $printer->{cupsconfig}{cupsd_conf};
    delete $printer->{cupsconfig}{rootlocation};
}

#----------------------------------------------------------------------
# Handling of /etc/cups/client.conf

sub read_client_conf() {
    return (0, undef) if (! -r "$::prefix/etc/cups/client.conf");
    my @client_conf = cat_("$::prefix/etc/cups/client.conf");
    my @servers = handle_configs::read_directives(\@client_conf, 
						  "ServerName");
    return (@servers > 0, 
	    $servers[0]); # If there is more than one entry in client.conf,
                          # the first one counts.
}

sub write_client_conf {
    my ($daemonless_cups, $remote_cups_server) = @_;
    # Create the directory for client.conf if needed
    (-d "$::prefix/etc/cups/" ) || mkdir("$::prefix/etc/cups/") || return 1;
    my (@client_conf) = cat_("$::prefix/etc/cups/client.conf");
    if ($daemonless_cups) {
	handle_configs::set_directive(\@client_conf, 
				      "ServerName $remote_cups_server");
    } else {
	handle_configs::comment_directive(\@client_conf, "ServerName");
    }
    output("$::prefix/etc/cups/client.conf", @client_conf);
}



#----------------------------------------------------------------------
sub read_printers_conf {
    my ($printer) = @_;
    my $current;

    #- read /etc/cups/printers.conf file.
    #- according to this code, we are now using the following keys for each queues.
    #-    DeviceURI > lpd://printer6/lp
    #-    Info      > Info Text
    #-    Location  > Location Text
    #-    State     > Idle|Stopped
    #-    Accepting > Yes|No
    open(my $PRINTERS, "$::prefix/etc/cups/printers.conf") or return;
    local $_;
    while (<$PRINTERS>) {
	chomp;
	/^\s*#/ and next;
	if (/^\s*<(?:DefaultPrinter|Printer)\s+([^>]*)>/) { $current = { mode => 'cups', QUEUE => $1, } }
	elsif (m!\s*</Printer>!) { $current->{QUEUE} && $current->{DeviceURI} or next; #- minimal check of synthax.
				   add2hash($printer->{configured}{$current->{QUEUE}} ||= {}, $current); $current = undef }
	elsif (/\s*(\S*)\s+(.*)/) { $current->{$1} = $2 }
    }
    close $PRINTERS;

    #- assume this printing system.
    $printer->{SPOOLER} ||= 'cups';
}

sub get_direct_uri() {
    #- get the local printer to access via a Device URI.
    my @direct_uri;
    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . "/usr/sbin/lpinfo -v |");
    local $_;
    while (<$F>) {
	/^(direct|usb|serial)\s+(\S*)/ and push @direct_uri, $2;
    }
    close $F;
    @direct_uri;
}

sub checkppd {
    # Check whether the PPD file is valid
    my ($printer, $ppdfile) = @_;
    return 1 if $printer->{SPOOLER} ne "cups";
    return run_program::rooted($::prefix, "cupstestppd", "-q",
			       $ppdfile);
}

sub installppd {
    # Install the PPD file in /usr/share/cups/model/printerdrake/
    my ($printer, $ppdfile) = @_;
    return "" if !$ppdfile;
    # Install PPD file
    mkdir_p("$::prefix/usr/share/cups/model/printerdrake");
    # "cp_f()" is broken, it hangs infinitely
    # cp_f($ppdfile, "$::prefix/usr/share/cups/model/printerdrake");
    run_program::rooted($::prefix, "cp", "-f", $ppdfile,
			"$::prefix/usr/share/cups/model/printerdrake");
    $ppdfile =~ s!^(.*)(/[^/]+)$!/usr/share/cups/model/printerdrake$2!;
    chmod 0644, "$::prefix$ppdfile";
    # Restart CUPS to register new PPD file
    printer::services::restart("cups") if $printer->{SPOOLER} eq "cups";
    # Re-read printer database
    %thedb = ();
    read_printer_db($printer, $printer->{SPOOLER});
    # Return description string of the PPD file
    my $ppdentry = get_descr_from_ppdfile($printer, $ppdfile);
    return $ppdentry;
}

sub clean_manufacturer_name {
    my ($make) = @_;
    # Clean some manufacturer's names so that every manufacturer has only
    # one entry in the tree list
    $make =~ s/^CANON\W.*$/CANON/i;
    $make =~ s/^LEXMARK.*$/LEXMARK/i;
    $make =~ s/^HEWLETT?[\s\-]*PACKARD/HP/i;
    $make =~ s/^SEIKO[\s\-]*EPSON/EPSON/i;
    $make =~ s/^KYOCERA[\s\-]*MITA/KYOCERA/i;
    $make =~ s/^CITOH/C.ITOH/i;
    $make =~ s/^OKI(|[\s\-]*DATA)\s*$/OKIDATA/i;
    $make =~ s/^(SILENTWRITER2?|COLORMATE)/NEC/i;
    $make =~ s/^(XPRINT|MAJESTIX)/XEROX/i;
    $make =~ s/^QMS-PS/QMS/i;
    $make =~ s/^(PERSONAL|LASERWRITER)/APPLE/i;
    $make =~ s/^DIGITAL/DEC/i;
    $make =~ s/\s+Inc\.//i;
    $make =~ s/\s+Corp\.//i;
    $make =~ s/\s+SA\.//i;
    $make =~ s/\s+S\.\s*A\.//i;
    $make =~ s/\s+Ltd\.//i;
    $make =~ s/\s+International//i;
    $make =~ s/\s+Int\.//i;
    return uc($make);
}    

sub ppd_entry_str {
    my ($mf, $descr, $lang) = @_;
    my ($model, $driver);
    if ($descr) {
	# Apply the beautifying rules of poll_ppd_base
	if ($descr =~ /Foomatic \+ Postscript/) {
	    $descr =~ s/Foomatic \+ Postscript/PostScript/;
	} elsif ($descr =~ /Foomatic/i) {
	    $descr =~ s/Foomatic/GhostScript/i;
	} elsif ($descr =~ /CUPS\+Gimp-Print/i) {
	    $descr =~ s/CUPS\+Gimp-Print/CUPS + Gimp-Print/i;
	} elsif ($descr =~ /Series CUPS/i) {
	    $descr =~ s/Series CUPS/Series, CUPS/i;
	} elsif ($descr !~ /(PostScript|GhostScript|CUPS|Foomatic)/i) {
	    $descr .= ", PostScript";
	}
	# Split model and driver
	$descr =~ s/\s*Series//i;
	$descr =~ s/\((.*?(PostScript|PS.*).*?)\)/$1/i;
	if ($descr =~
	     /^\s*(Generic\s*PostScript\s*Printer)\s*,?\s*(.*)$/i ||
	    $descr =~
	     /^\s*(PostScript\s*Printer)\s*,?\s*(.*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s*(Foomatic.*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s*(GhostScript.*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s*(CUPS.*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s+(PS.*)$/i ||
	    $descr =~
	     /^([^,]+[^,\s])\s*,?\s*(\(v?\.?\s*\d\d\d\d\.\d\d\d\).*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s*(v\d+\.\d+.*)$/i ||
	    $descr =~ /^([^,]+[^,\s])\s*,?\s*(PostScript.*)$/i ||
	    $descr =~ /^([^,]+)\s*,?\s*(.+)$/) {
	    $model = $1;
	    $driver = $2;
	    $model =~ s/[\-\s,]+$//;
	    $driver =~ s/\b(PS|PostScript\b)/PostScript/gi;
	    $driver =~ s/(PostScript)(.*)(PostScript)/$1$2/i;
	    $driver =~ 
	      s/^\s*(\(?v?\.?\s*\d\d\d\d\.\d\d\d\)?|v\d+\.\d+)([,\s]*)(.*?)\s*$/$3$2$1/i;
	    $driver =~ s/,\s*\(/ (/g;
	    $driver =~ s/[\-\s,]+$//;
	    $driver =~ s/^[\-\s,]+//;
	    $driver =~ s/\s+/ /g;
	    if ($driver !~ /[a-z]/i) {
		$driver = "PostScript " . $driver;
		$driver =~ s/ $//;
	    }
	} else {
	    # Some PPDs do not have the ", <driver>" part.
	    $model = $descr;
	    $driver = "PostScript";
	}
    }
    # Remove manufacturer's name from the beginning of the model
    # name (do not do this with manufacturer names which contain
    # odd characters)
    $model =~ s/^$mf[\s\-]+//i 
	if $mf && $mf !~ m![\\/\(\)\[\]\|\.\$\@\%\*\?]!;
    # Clean some manufacturer's names
    $mf = clean_manufacturer_name($mf);
    # Rename Canon "BJC XXXX" models into "BJC-XXXX" so that the 
    # models do not appear twice
    if ($mf eq "CANON") {
	$model =~ s/BJC\s+/BJC-/;
    }
    # New MF devices from Epson have mis-spelled name in PPD files for
    # native CUPS drivers of Gimp-Print
    if ($mf eq "EPSON") {
	$model =~ s/Stylus CX\-/Stylus CX/;
    }
    # Remove the "Oki" from the beginning of the model names of Okidata
    # printers
    if ($mf eq "OKIDATA") {
	$model =~ s/Oki\s+//i;
    }
    # Try again to remove manufacturer's name from the beginning of the 
    # model name, this with the cleaned manufacturer name
    $model =~ s/^$mf[\s\-]+//i 
	if $mf && $mf !~ m![\\/\(\)\[\]\|\.\$\@\%\*\?]!;
    # Put out the resulting description string
    uc($mf) . '|' . $model . '|' . $driver .
      ($lang && " (" . lang::locale_to_main_locale($lang) . ")");
}

sub get_descr_from_ppd {
    my ($printer) = @_;
    #- if there is no ppd, this means this is a raw queue.
    if (! -r "$::prefix/etc/cups/ppd/$printer->{OLD_QUEUE}.ppd") {
	return "|" . N("Unknown model");
    }
    return get_descr_from_ppdfile($printer, "/etc/cups/ppd/$printer->{OLD_QUEUE}.ppd");
}

sub get_descr_from_ppdfile {
    my ($printer, $ppdfile) = @_;
    my %ppd;

    # Remove ".gz" from end of file name, so that "catMaybeCompressed" works
    $ppdfile =~ s/\.gz$//;

    eval {
	local $_;
	foreach (catMaybeCompressed("$::prefix$ppdfile")) {
	    # "OTHERS|Generic PostScript printer|PostScript (en)";
	    /^\*([^\s:]*)\s*:\s*"([^"]*)"/ and
		do { $ppd{$1} = $2; next };
	    /^\*([^\s:]*)\s*:\s*([^\s"]*)/   and
		do { $ppd{$1} = $2; next };
	}
    };
    my $descr = ($ppd{NickName} || $ppd{ShortNickName} || $ppd{ModelName});
    my $make = $ppd{Manufacturer};
    my $lang = $ppd{LanguageVersion};
    my $entry = ppd_entry_str($make, $descr, $lang);
    if (!$printer->{expert}) {
	# Remove driver from printer list entry when in recommended mode
	$entry =~ s/^([^\|]+\|[^\|]+)\|.*$/$1/;
    }
    return $entry;
}

sub ppd_devid_data {
    my ($ppd) = @_;
    $ppd = "$::prefix/usr/share/cups/model/$ppd";
    my @content;
    if ($ppd =~ /\.gz$/i) {
	@content = cat_("$::prefix/bin/zcat $ppd |") or return "", "";
    } else {
	@content = cat_($ppd) or return "", "";
    }
    my ($devidmake, $devidmodel);
    /^\*Manufacturer:\s*"(.*)"\s*$/ and $devidmake = $1
	foreach @content;
    /^\*Product:\s*"\(?(.*?)\)?"\s*$/ and $devidmodel = $1 
	foreach @content;
    return $devidmake, $devidmodel;
}

sub poll_ppd_base {
    my ($printer) = @_;
    #- Before trying to poll the ppd database available to cups, we have 
    #- to make sure the file /etc/cups/ppds.dat is no more modified.
    #- If cups continue to modify it (because it reads the ppd files 
    #- available), the poll_ppd_base program simply cores :-)
    # else cups will not be happy! and ifup lo do not run ?
    run_program::rooted($::prefix, 'ifconfig', 'lo', '127.0.0.1');
    printer::services::start_not_running_service("cups");
    my $driversthere = scalar(keys %thedb);
    foreach (1..60) {
	open(my $PPDS, ($::testing ? $::prefix :
				 "chroot $::prefix/ ") .
				 "/usr/bin/poll_ppd_base -a |");
	local $_;
	while (<$PPDS>) {
	    chomp;
	    my ($ppd, $mf, $descr, $lang) = split /\|/;
	    if ($ppd eq "raw") { next }
	    $ppd && $mf && $descr and do {
		my $key = ppd_entry_str($mf, $descr, $lang);
		my ($model, $driver) = ($1, $2) if $key =~ /^[^\|]+\|([^\|]+)\|(.*)$/;
		# Clean some manufacturer's names
		$mf = clean_manufacturer_name($mf);
		# Remove language tag
		$driver =~ s/\s*\([a-z]{2}(|_[A-Z]{2})\)\s*$//;
		# Recommended Foomatic PPD? Extract "(recommended)"
		my $isrecommended = 
		    $driver =~ s/\s+\(recommended\)\s*$//i;
		# Remove trailing white space
		$driver =~ s/\s+$//;
		# For Foomatic: Driver with "GhostScript + "
		my $fullfoomaticdriver = $driver;
		# Foomatic PPD? Extract driver name
		my $isfoomatic = 
		    $driver =~ s!^\s*(GhostScript|Foomatic)(\s*\+\s*|/)!!i;
		# Foomatic PostScript driver?
		$isfoomatic ||= $descr =~ /Foomatic/i;
		# Native CUPS?
		my $isnativecups = $driver =~ /CUPS/i;
		# Native PostScript
		my $isnativeps = !$isfoomatic && !$isnativecups;
		# Key without language tag (key as it was produced for the
		# entries from the Foomatic XML database)
		my $keynolang = $key;
		$keynolang =~ s/\s*\([a-z]{2}(|_[A-Z]{2})\)\s*$//;
		if (!$isfoomatic) {
		    # Driver is PPD when the PPD is a non-Foomatic one
		    $driver = "PPD";
		} else {
		    # Remove language tag in menu entry when PPD is from
		    # Foomatic
		    $key = $keynolang;
		}
	        my ($devidmake, $devidmodel, $deviddesc, $devidcmdset);
		if (!$printer->{expert}) {
		    # Remove driver from printer list entry when in
		    # recommended mode
		    $key =~ s/^([^\|]+\|[^\|]+)\|.*$/$1/;
		    # Only replace an existing printer entry if
		    #  - its driver is not the same as the driver of the
		    #    new one
		    # AND if one of the following items is true
		    #  - The existing entry uses a "Foomatic + Postscript" 
		    #    driver and the new one is native PostScript
		    #  - The existing entry is a Foomatic entry and the new 
		    #    one is "recommended"
		    #  - The existing entry is a native PostScript entry
		    #    and the new entry is a "recommended" driver other
		    #    then "Foomatic + Postscript"
		    if (defined($thedb{$key})) {
			next if lc($thedb{$key}{driver}) eq
				     lc($driver);
			if ($isnativeps &&
                            $thedb{$key}{driver} =~ /^PostScript$/i ||
                            $thedb{$key}{driver} ne "PPD" && $isrecommended ||
                            $thedb{$key}{driver} eq "PPD" && $isrecommended && $driver ne "PostScript") {
			    # Save the autodetection data
			    $devidmake = $thedb{$key}{devidmake};
			    $devidmodel = $thedb{$key}{devidmodel};
			    $deviddesc = $thedb{$key}{deviddesc};
			    $devidcmdset = $thedb{$key}{devidcmdset};
                            # Remove the old entry
                            delete $thedb{$key};
                        } else {
                            next;
                        }
		    }
		} elsif ((defined 
			   $thedb{"$mf|$model|$fullfoomaticdriver"} ||
			  defined 
			   $thedb{"$mf|$model|$fullfoomaticdriver (recommended)"}) && 
			 $isfoomatic) {
		    # Expert mode: There is already an entry for the
		    # same printer/driver combo produced by the
		    # Foomatic XML database, so do not make a second
		    # entry
		    next;
		} elsif (defined
			 $thedb{"$mf|$model|PostScript (recommended)"} &&
			 $isnativeps) {
		    # Expert mode: "Foomatic + Postscript" driver is
		    # recommended and this is a PostScript PPD? Make
		    # this PPD the recommended one
		    foreach (keys 
		         %{$thedb{"$mf|$model|PostScript (recommended)"}}) {
			$thedb{"$mf|$model|PostScript"}{$_} =
			  $thedb{"$mf|$model|PostScript (recommended)"}{$_};
		    }
		    delete
			$thedb{"$mf|$model|PostScript (recommended)"};
		    if (!$isrecommended) {
			$key .= " (recommended)";
		    }
		} elsif ($driver =~ /PostScript/i &&
			 $isrecommended && $isfoomatic &&
			 (my @foundkeys = grep {
			     /^$mf\|$model\|/ && !/CUPS/i &&
			     $thedb{$_}{driver} eq "PPD" 
			 } keys %thedb)) {
		    # Expert mode: "Foomatic + Postscript" driver is
		    # recommended and there was a PostScript PPD? Make
		    # the PostScript PPD the recommended one
		    my $firstfound = $foundkeys[0];
		    if (!(any { /\(recommended\)/ } @foundkeys)) {
			# Do it only if none of the native PostScript
			# PPDs for this printer is already "recommended"
			foreach (keys %{$thedb{$firstfound}}) {
			    $thedb{"$firstfound (recommended)"}{$_} =
				$thedb{$firstfound}{$_};
			}
			delete $thedb{$firstfound};
		    }
		    $key =~ s/\s*\(recommended\)//;
		} elsif ($driver !~ /PostScript/i &&
			 $isrecommended && $isfoomatic &&
			 (@foundkeys = grep {
			     /^$mf\|$model\|.*\(recommended\)/ && 
			     !/CUPS/i && $thedb{$_}{driver} eq "PPD" 
			 } keys %thedb)) {
		    # Expert mode: Foomatic driver other than "Foomatic +
		    # Postscript" is recommended and there was a PostScript 
		    # PPD which was recommended? Make The Foomatic driver
		    # the recommended one
		    foreach my $sourcekey (@foundkeys) {
			# Remove the "recommended" tag
			my $destkey = $sourcekey;
			$destkey =~ s/\s+\(recommended\)\s*$//i;
			foreach (keys %{$thedb{$sourcekey}}) {
			    $thedb{$destkey}{$_} = $thedb{$sourcekey}{$_};
			}
			delete $thedb{$sourcekey};
		    }
		}
	        $thedb{$key}{ppd} = $ppd;
		$thedb{$key}{make} = $mf;
		$thedb{$key}{model} = $model;
		$thedb{$key}{driver} = $driver;
		# Recover saved autodetection data
		$thedb{$key}{devidmake} = $devidmake if $devidmake;
		$thedb{$key}{devidmodel} = $devidmodel if $devidmodel;
		$thedb{$key}{deviddesc} = $deviddesc if $deviddesc;
		$thedb{$key}{devidcmdset} = $devidcmdset if $devidcmdset;
		# Get autodetection data
		#my ($devidmake, $devidmodel) = ppd_devid_data($ppd);
		#$thedb{$key}{devidmake} = $devidmake;
		#$thedb{$key}{devidmodel} = $devidmodel;
	    }
	}
	close $PPDS;
	scalar(keys %thedb) - $driversthere > 5 and last;
	#- we have to try again running the program, wait here a little 
	#- before.
	sleep 1;
    }
    #scalar(keys %descr_to_ppd) > 5 or 
    #  die "unable to connect to cups server";

}



#-******************************************************************************
#- write functions
#-******************************************************************************

sub configure_queue($) {
    my ($printer) = @_;

    #- Create the queue with "foomatic-configure", in case of queue
    #- renaming copy the old queue
    my $quotedconnect = $printer->{currentqueue}{connect};
    $quotedconnect =~ s/\$/\\\$/g; # Quote '$' in URI
    run_program::rooted($::prefix, "foomatic-configure", "-q",
			"-s", $printer->{currentqueue}{spooler},
			"-n", $printer->{currentqueue}{queue},
			($printer->{currentqueue}{queue} ne 
			 $printer->{OLD_QUEUE} &&
			 $printer->{configured}{$printer->{OLD_QUEUE}} ?
			 ("-C", $printer->{OLD_QUEUE}) : ()),
			"-c", $quotedconnect,
			($printer->{currentqueue}{foomatic} ?
			 ("-p", $printer->{currentqueue}{printer},
			  "-d", $printer->{currentqueue}{driver}) :
			 ($printer->{currentqueue}{ppd} ?
			  ($printer->{currentqueue}{ppd} ne '1' ?
			   ("--ppd",
			    ($printer->{currentqueue}{ppd} !~ m!^/! ?
			     "/usr/share/cups/model/" : "") .
			    $printer->{currentqueue}{ppd}) : "") :
			  ("-d", "raw"))),
			"-N", $printer->{currentqueue}{desc},
			"-L", $printer->{currentqueue}{loc},
			@{$printer->{currentqueue}{options}}
			) or return 0;;
    if ($printer->{currentqueue}{ppd} &&
	($printer->{currentqueue}{ppd} ne '1')) {
	# Add a comment line containing the path of the used PPD file to the
	# end of the PPD file
	if ($printer->{currentqueue}{ppd} ne '1') {
	    append_to_file("$::prefix/etc/cups/ppd/$printer->{currentqueue}{queue}.ppd", "*%MDKMODELCHOICE:$printer->{currentqueue}{ppd}\n");
	}
    }	  

    # Make sure that queue is active
    if ($printer->{NEW} && ($printer->{SPOOLER} ne "pdq")) {
        run_program::rooted($::prefix, "foomatic-printjob",
			    "-s", $printer->{currentqueue}{spooler},
			    "-C", "up", $printer->{currentqueue}{queue});
    }

    # In case of CUPS set some more useful defaults for text and image 
    # printing
    if ($printer->{SPOOLER} eq "cups") {
	set_cups_special_options($printer->{currentqueue}{queue});
    }

    # Check whether a USB printer is configured and activate USB printing if so
    my $useUSB = 0;
    foreach (values %{$printer->{configured}}) {
	$useUSB ||= $_->{queuedata}{connect} =~ /usb/i || 
	    $_->{DeviceURI} =~ /usb/i;
    }
    $useUSB ||= $printer->{currentqueue}{connect} =~ /usb/i;
    if ($useUSB) {
	my $f = "$::prefix/etc/sysconfig/usb";
	my %usb = getVarsFromSh($f);
	$usb{PRINTER} = "yes";
	setVarsInSh($f, \%usb);
    }

    # Open permissions for device file when PDQ is chosen as spooler
    # so normal users can print.
    if ($printer->{SPOOLER} eq 'pdq') {
	if ($printer->{currentqueue}{connect} =~ 
	    m!^\s*(file|parallel|usb|serial):(\S*)\s*$!) {
	    set_permissions($1, "666");
	}
    }

    # Make a new printer entry in the $printer structure
    $printer->{configured}{$printer->{currentqueue}{queue}}{queuedata} =
        {};
    copy_printer_params($printer->{currentqueue},
      $printer->{configured}{$printer->{currentqueue}{queue}}{queuedata});
    # Construct an entry line for tree view in main window of
    # printerdrake
    make_menuentry($printer, $printer->{currentqueue}{queue});

    # Store the default option settings
    $printer->{configured}{$printer->{currentqueue}{queue}}{args} = {};
    $printer->{configured}{$printer->{currentqueue}{queue}}{args} =
	$printer->{ARGS};
    # Clean up
    delete($printer->{ARGS});
    $printer->{OLD_CHOICE} = "";
    $printer->{ARGS} = {};
    $printer->{DBENTRY} = "";
    $printer->{currentqueue} = {};

    return 1;
}

sub enable_disable_queue {
    my ($printer, $queue, $state) = @_;
    
    if (($printer->{SPOOLER} ne "pdq") &&
	($printer->{SPOOLER} ne "rcups")) {
        run_program::rooted($::prefix, "foomatic-printjob",
			    "-s", $printer->{SPOOLER},
			    "-C", ($state ? "start" : "stop"), $queue);
    }
}

sub remove_queue($$) {
    my ($printer, $queue) = @_;
    run_program::rooted($::prefix, "foomatic-configure", "-R", "-q",
			"-s", $printer->{SPOOLER},
			"-n", $queue);
    # Delete old stuff from data structure
    delete $printer->{configured}{$queue};
    delete($printer->{currentqueue});
    delete($printer->{ARGS});
    $printer->{OLD_CHOICE} = "";
    $printer->{ARGS} = {};
    $printer->{DBENTRY} = "";
    $printer->{currentqueue} = {};
}

sub restart_queue($) {
    my ($printer) = @_;
    my $queue = $printer->{QUEUE};

    # Restart the daemon(s)
    for ($printer->{SPOOLER}) {
	/cups/ and do {
	    #- restart cups.
	    printer::services::restart("cups");
	    last };
	/lpr|lprng/ and do {
	    #- restart lpd.
	    foreach ("/var/spool/lpd/$queue/lock", "/var/spool/lpd/lpd.lock") {
		my $pidlpd = (cat_("$::prefix$_"))[0];
		kill 'TERM', $pidlpd if $pidlpd;
		unlink "$::prefix$_";
	    }
	    printer::services::restart("lpd"); sleep 1;
	    last };
    }
    # Kill the jobs
    run_program::rooted($::prefix, "foomatic-printjob", "-R",
			"-s", $printer->{SPOOLER},
			"-P", $queue, "-");

}

sub print_pages($@) {
    my ($printer, @pages) = @_;
    my $queue = $printer->{QUEUE};
    my $lpr = "/usr/bin/foomatic-printjob";
    my $lpq = "$lpr -Q";
    my $spooler = $printer->{SPOOLER};
    $spooler = "cups" if $spooler eq "rcups";

    # Print the pages
    foreach (@pages) {
	my $page = $_;
	# Only text and PostScript can be printed directly with all
	# spoolers, images must be treated seperately
	if ($page =~ /\.jpg$/) {
	    if ($spooler ne "cups") {
		# Use "convert" from ImageMagick for non-CUPS spoolers
		system(($::testing ? $::prefix : "chroot $::prefix/ ") .
		       "/usr/bin/convert $page -page 427x654+100+65 PS:- | " .
		       ($::testing ? $::prefix : "chroot $::prefix/ ") .
		       "$lpr -s $spooler -P $queue");
	    } else {
		# Use CUPS's internal image converter with CUPS, tell it
		# to let the image occupy 90% of the page size (so nothing
		# gets cut off by unprintable borders)
		run_program::rooted($::prefix, $lpr, "-s", $spooler,
				    "-P", $queue, "-o", "scaling=90", $page);
	    }		
	} else {
	    run_program::rooted($::prefix, $lpr, "-s", $spooler,
				"-P", $queue, $page);
	}
    }
    sleep 5; #- allow lpr to send pages.
    # Check whether the job is queued
    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . "$lpq -s $spooler -P $queue |");
    my @lpq_output =
	grep { !/^no entries/ && !(/^Rank\s+Owner/ .. /^\s*$/) } <$F>;
    close $F;
    @lpq_output;
}

sub help_output {
    my ($printer, $spooler) = @_;
    my $queue = $printer->{QUEUE};

    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . sprintf($spoolers{$spooler}{help}, $queue));
    my $helptext = join("", <$F>);
    close $F;
    $helptext ||= "Option list not available!\n";
    return $helptext;
}

sub print_optionlist {
    my ($printer) = @_;
    my $queue = $printer->{QUEUE};
    my $lpr = "/usr/bin/foomatic-printjob";

    # Print the option list pages
    if ($printer->{configured}{$queue}{queuedata}{foomatic}) {
        run_program::rooted($::prefix, $lpr, "-s", $printer->{SPOOLER},
			    "-P", $queue, "-o", "docs",
			    "/etc/bashrc");
    } elsif ($printer->{configured}{$queue}{queuedata}{ppd}) {
	system(($::testing ? $::prefix : "chroot $::prefix/ ") .
	       "/usr/bin/lphelp $queue | " .
	       ($::testing ? $::prefix : "chroot $::prefix/ ") .
	       "$lpr -s $printer->{SPOOLER} -P $queue");
    }
}

# ---------------------------------------------------------------
#
# Spooler config stuff
#
# ---------------------------------------------------------------

sub get_copiable_queues {
    my ($oldspooler, $newspooler) = @_;

    # No local queues available in daemon-less CUPS mode
    return () if ($oldspooler eq "rcups") or ($newspooler eq "rcups");

    my @queuelist;      #- here we will list all Foomatic-generated queues
    # Get queue list with foomatic-configure
    open(my $QUEUEOUTPUT, ($::testing ? $::prefix : "chroot $::prefix/ ") .
	    "foomatic-configure -Q -q -s $oldspooler |") or
		die "Could not run foomatic-configure";

    my $entry = {};
    my $inentry = 0;
    local $_;
    while (<$QUEUEOUTPUT>) {
	chomp;
	if ($inentry) {
	    # We are inside a queue entry
	    if (m!^\s*</queue>\s*$!) {
		# entry completed
		$inentry = 0;
		if ($entry->{foomatic} && $entry->{spooler} eq $oldspooler) {
		    # Is the connection type supported by the new
		    # spooler?
		    if ($newspooler eq "cups" && $entry->{connect} =~ /^(file|hp|ptal|lpd|socket|smb|ipp):/ ||
                  $newspooler =~ /^(lpd|lprng)$/ && $entry->{connect} =~ /^(file|ptal|lpd|socket|smb|ncp|postpipe):/ ||
                  $newspooler eq "pdq" && $entry->{connect} =~ /^(file|ptal|lpd|socket):/) {
                  push(@queuelist, $entry->{name});
		    }
		}
		$entry = {};
	    } elsif (m!^\s*<name>(.+)</name>\s*$!) {
		    # queue name
		    $entry->{name} = $1;
	    } elsif (m!^\s*<connect>(.+)</connect>\s*$!) {
		    # connection type (URI)
		    $entry->{connect} = $1;
	    }
	} else {
	    if (m!^\s*<queue\s+foomatic\s*=\s*"?(\d+)"?\s*spooler\s*=\s*"?(\w+)"?\s*>\s*$!) {
		# new entry
		$inentry = 1;
		$entry->{foomatic} = $1;
		$entry->{spooler} = $2;
	    }
	}
    }
    close $QUEUEOUTPUT;

    return @queuelist;
}

sub copy_foomatic_queue {
    my ($printer, $oldqueue, $oldspooler, $newqueue) = @_;
    run_program::rooted($::prefix, "foomatic-configure", "-q",
			"-s", $printer->{SPOOLER},
			"-n", $newqueue,
			"-C", $oldspooler, $oldqueue);
    # In case of CUPS set some more useful defaults for text and image printing
    if ($printer->{SPOOLER} eq "cups") {
	set_cups_special_options($newqueue);
    }
}

# ------------------------------------------------------------------
#
# Stuff for non-interactive printer configuration
#
# ------------------------------------------------------------------

# Check whether a given URI (for example of an existing queue matches
# one of the auto-detected printers

sub autodetectionentry_for_uri {
    my ($uri, @autodetected) = @_;

    if ($uri =~ m!^usb://([^/]+)/([^/\?]+)(|\?serial=(\S+))$!) {
	# USB device with URI referring to printer model
	my $make = $1;
	my $model = $2;
	my $serial = $4;
	if ($make && $model) {
	    $make =~ s/\%20/ /g;
	    $model =~ s/\%20/ /g;
	    $serial =~ s/\%20/ /g;
	    $make =~ s/Hewlett[-\s_]Packard/HP/;
	    $make =~ s/HEWLETT[-\s_]PACKARD/HP/;
	    my $smake = handle_configs::searchstr($make);
	    my $smodel = handle_configs::searchstr($model);
	    foreach my $p (@autodetected) {
		next if $p->{port} !~ /usb/i;
		next if ((!$p->{val}{MANUFACTURER} ||
                    $p->{val}{MANUFACTURER} ne $make) &&
                   (!$p->{val}{DESCRIPTION} ||
                    $p->{val}{DESCRIPTION} !~ /^\s*$smake\s+/));
		next if ((!$p->{val}{MODEL} ||
			  $p->{val}{MODEL} ne $model) &&
			 (!$p->{val}{DESCRIPTION} ||
			  $p->{val}{DESCRIPTION} !~ /\s+$smodel\s*$/));
		next if ($serial &&
			 (!$p->{val}{SERIALNUMBER} ||
			  $p->{val}{SERIALNUMBER} ne $serial));
		return $p;
	    }
	}
    } elsif ($uri =~ m!^hp:/(usb|par|net)/!) {
	# HP printer (controlled by HPLIP)
	my $hplipdevice = $uri;
	$hplipdevice =~ m!^hp:/(usb|par|net)/(\S+?)(\?serial=(\S+)|)$!;
	my $model = $2;
	my $serial = $4;
	$model =~ s/_/ /g;
	foreach my $p (@autodetected) {
	    next if !$p->{val}{MODEL};
	    if (uc($p->{val}{MODEL}) ne uc($model)) {
		my $entry = hplip_device_entry($p->{port}, @autodetected);
		next if !$entry;
		my $m = $entry->{model};
		$m =~ s/_/ /g;
		next if uc($m) ne uc($model);
	    }
	    next if ($serial && !$p->{val}{SERIALNUMBER}) ||
		(!$serial && $p->{val}{SERIALNUMBER}) ||
		(uc($serial) ne uc($p->{val}{SERIALNUMBER}));
	    return $p;
	}
    } elsif ($uri =~ m!^ptal://?mlc:!) {
	# HP multi-function device (controlled by HPOJ)
	my $ptaldevice = $uri;
	$ptaldevice =~ s!^ptal://?mlc:!!;
	if ($ptaldevice =~ /^par:(\d+)$/) {
	    my $device = "/dev/lp$1";
	    foreach my $p (@autodetected) {
		next if !$p->{port} ||
			 $p->{port} ne $device;
		return $p;
	    }
	} else {
	    my $model = $2 if $ptaldevice =~ /^(usb|par):(.*)$/;
	    $model =~ s/_/ /g;
	    foreach my $p (@autodetected) {
		next if !$p->{val}{MODEL} ||
			 $p->{val}{MODEL} ne $model;
		return $p;
	    }
	}
    } elsif ($uri =~ m!^(socket|smb|file|parallel|usb|serial):/!) {
	# Local print-only device, Ethernet-(TCP/Socket)-connected printer, 
	# or printer on Windows server
	my $device = $uri;
	$device =~ s/^(file|parallel|usb|serial)://;
	foreach my $p (@autodetected) {
	    next if !$p->{port} ||
		     $p->{port} ne $device;
	    return $p;
	}
    }
    return undef;
}

# ------------------------------------------------------------------
#
# Configuration of HP multi-function devices
#
# ------------------------------------------------------------------

sub read_hplip_db {

    # Read the device database XML file which comes with the HPLIP
    # package
    open(my $F, "< $::prefix/usr/share/hplip/data/xml/models.xml") or
	die "Could not read /usr/share/hplip/data/xml/models.xml\n";

    my $entry = {};
    my $inentry = 0;
    my $inrX = 0;
    my $incomment = 0;
    my %hplipdevices;
    local $_;
    while (<$F>) {
	chomp;
	if ($incomment) {
	    # In a comment block, skip all except the end of the comment
	    if (m!^(.*?)-->(.*)$!) {
		# End of comment, keep rest of line
		$_ = $2;
		$incomment = 0;
	    } else {
		# Skip line
		$_ = '';
	    }
	} else {
	    while (m/^(.*?)<!--(.*?)-->(.*)$/) {
		# Remove one-line comments
		$_ = $1 . $3;
	    }
	    if (m/^(.*?)<!--(.*)$/) {
		# Start of comment, keep the beginning of the line
		$_ = $1;
		$incomment = 1;
	    }
	}
	# Is there some non-comment part left in the line
	if (m!\S!) {
	    if ($inentry) {
		# We are inside a device entry
		if ($inrX) {
		    # We are in one of the the device's <rX> sections,
		    # skip the section
		    if (m!^\s*</r\d+>\s*$!) {
			# End of <rX> section
			$inrX = 0;
		    }
		} else {
		    if (m!^\s*<r\d+>\s*$!) {
			# Start of <rX> section
			$inrX = 1;
		    } elsif (m!^\s*</model>\s*$!) {
			# End of device entry
			$inentry = 0;
			my $devidmodel;
			if ($entry->{$devidmodel}) {
			    $devidmodel = $entry->{devidmodel};
			    $devidmodel =~ s/ /_/g;
			} else {
			    $devidmodel = $entry->{model};
			}
			$hplipdevices{$devidmodel} = $entry;
			$entry = {};
		    } elsif (m!^\s*<id>\s*([^<>]+)\s*</id>\s*$!) {
			# Full ID string
			my $idstr = $1;
			$idstr =~ m!(MFG|MANUFACTURER):([^;]+);!i
			    and $entry->{devidmake} = $2;
			$idstr =~ m!(MDL|MODEL):([^;]+);!i
			    and $entry->{devidmodel} = $2;
			$idstr =~ m!(DES|DESCRIPTION):([^;]+);!i
			    and $entry->{deviddesc} = $2;
			$idstr =~ m!(CMD|COMMAND\s*SET):([^;]+);!i
			    and $entry->{devidcmdset} = $2;
		    } elsif (m!^\s*<tech type="(\d+)"/>\s*$!) {
			# Printing technology
			$entry->{tech} = $1;
		    } elsif (m!^\s*<align type="(\d+)"/>\s*$!) {
			# Head alignment type
			$entry->{align} = $1;
		    } elsif (m!^\s*<clean type="(\d+)"/>\s*$!) {
			# Head cleaning type
			$entry->{clean} = $1;
		    } elsif (m!^\s*<color-cal type="(\d+)"/>\s*$!) {
			# Color calibration type
			$entry->{colorcal} = $1;
		    } elsif (m!^\s*<status type="(\d+)"/>\s*$!) {
			# Status request type
			$entry->{status} = $1;
		    } elsif (m!^\s*<scan type="(\d+)"/>\s*$!) {
			# Scanner access type
			$entry->{scan} = $1;
		    } elsif (m!^\s*<fax type="(\d+)"/>\s*$!) {
			# Fax access type
			$entry->{fax} = $1;
		    } elsif (m!^\s*<pcard type="(\d+)"/>\s*$!) {
			# Memory card access type
			$entry->{card} = $1;
		    } elsif (m!^\s*<copy type="(\d+)"/>\s*$!) {
			# Copier access type
			$entry->{copy} = $1;
		    }
		}
	    } else {
		# We are not in a printer entry
		if (m!^\s*<\s*model\s+name=\"(\S+)\"\a*>\s*$!) {
		    $inentry = 1;
		    # HPLIP model ID
		    $entry->{model} = $1;
		}
	    }
	}
    }
    close $F;
    return \%hplipdevices;
}

sub hplip_simple_model {
    my ($model) = @_;
    my $simplemodel = $model;
    $simplemodel =~ s/[^A-Za-z0-9]//g;
    $simplemodel =~ s/(DeskJet\d+C?)([a-z]*?)/$1/gi;
    $simplemodel =~ s/((LaserJet|OfficeJet|PhotoSmart|PSC)\d+)([a-z]*?)/$1/gi;
    $simplemodel =~ s/DeskJet/DJ/gi;
    $simplemodel =~ s/PhotoSmartP/PhotoSmart/gi;
    $simplemodel =~ s/LaserJet/LJ/gi;
    $simplemodel =~ s/OfficeJet/OJ/gi;
    $simplemodel =~ s/Series//gi;
    $simplemodel = uc($simplemodel);
    return $simplemodel;
}

sub hplip_device_entry {
    my ($device, @autodetected) = @_;

    # Currently, only devices on USB work
    return undef if $device !~ /usb/i;

    if (!$hplipdevicesdb) {
	# Read the HPLIP device database if not done already
	$hplipdevicesdb = read_hplip_db();
    }

    my $entry;
    foreach my $a (@autodetected) {
	$device eq $a->{port} or next;
	# Only HP devices supported
	return undef if $a->{val}{MANUFACTURER} !~ /^\s*HP\s*$/i;
	my $modelstr = $a->{val}{MODEL};
	$modelstr =~ s/ /_/g;
	if ($entry = $hplipdevicesdb->{$modelstr}) {
	    # Exact match
	    return $entry;
	}
	# More 'fuzzy' matching
	my $simplemodel = hplip_simple_model($modelstr);
	foreach my $key (keys %{$hplipdevicesdb}) {
	    my $simplekey = hplip_simple_model($key);
	    return $hplipdevicesdb->{$key} if $simplemodel eq $simplekey;
	}
	foreach my $key (keys %{$hplipdevicesdb}) {
	    my $simplekey = hplip_simple_model($key);
	    $simplekey =~ s/(\d\d)00(C?)$/$1\\d\\d$2/;
	    $simplekey =~ s/(\d\d\d)0(C?)$/$1\\d$2/;
	    $simplekey =~ s/(\d\d)0(\dC?)$/$1\\d$2/;
	    return $hplipdevicesdb->{$key} if 
		$simplemodel =~ m/^$simplekey$/;
	}
	# Device not supported
	return undef;
    }
    # $device not in @autodetected
    return undef;
}

sub hplip_device_entry_from_uri {
    my ($deviceuri) = @_;

    return undef if $deviceuri !~ m!^hp:/!;
    
    if (!$hplipdevicesdb) {
	# Read the HPLIP device database if not done already
	$hplipdevicesdb = read_hplip_db();
    }

    $deviceuri =~ m!^hp:/(usb|par|net)/(\S+?)(\?\S+|)$!;
    my $model = $2;
    return undef if !$model;

    my $entry;
    if ($entry = $hplipdevicesdb->{$model}) {
	return $entry;
    }
    return undef;
}

sub start_hplip {
    my ($device, $hplipentry, @autodetected) = @_;

    # Determine connection type
    my $bus;
    if ($device =~ /usb/) {
	$bus = "usb";
    } elsif ($device =~ /par/ ||
	     $device =~ m!/dev/lp! ||
	     $device =~ /printers/) {
	$bus = "par";
    } else {
	return undef;
    }

    # Start HPLIP daemons
    printer::services::start_not_running_service("hplip");

    # Determine HPLIP device URI for the CUPS queue
    foreach my $a (@autodetected) {
	$device eq $a->{port} or next;
	open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") .
	     '/bin/sh -c "export LC_ALL=C; /usr/lib/cups/backend/hp" |') or
	     die 'Could not run "/usr/lib/cups/backend/hp"!';
	while (my $line = <$F>) {
	    if (($line =~ m!^direct\s+(hp:/$bus/(\S+)\?serial=(\S+))\s+!) ||
		($line =~ m!^direct\s+(hp:/$bus/(\S+))\s+!)) {
		my $uri = $1;
		my $modelstr = $2;
		my $serial = $3;
		if ((uc($modelstr) eq uc($hplipentry->{model})) &&
		    (!$serial ||
		     (uc($serial) eq uc($a->{val}{SERIALNUMBER})))) {
		    close $F;
		    return $uri;
		}
	    }
	}
	close $F;
	last;
    }
    # HPLIP URI not found
    return undef;
}

sub start_hplip_manual {

    # Start HPLIP daemons
    printer::services::start_not_running_service("hplip");

    # Return all possible device URIs
    open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") .
	 '/bin/sh -c "export LC_ALL=C; /usr/lib/cups/backend/hp" |') or
	 die 'Could not run "/usr/lib/cups/backend/hp"!';
    my @uris;
    while (<$F>) {
        m!^direct\s+(hp:\S+)\s+!;
	push(@uris, $1);
    }
    return @uris;
}

sub remove_hpoj_config {
    my ($device, @autodetected) = @_;

    for my $d (@autodetected) {
	$device eq $d->{port} or next;
	my $bus;
	if ($device =~ /usb/) {
	    $bus = "usb";
	} elsif ($device =~ /par/ ||
		 $device =~ m!/dev/lp! ||
		 $device =~ /printers/) {
	    $bus = "par";
	} elsif ($device =~ /socket/) {
	    $bus = "hpjd";
	}
	my $path = "$::prefix/etc/ptal";
	opendir PTALDIR, "$path";
	while (my $file = readdir(PTALDIR)) {
	    next if $file !~ /^(mlc:|)$bus:/;
	    $file = "$path/$file";
	    if ($bus eq "hpjd") {
		$device =~ m!^socket://(\S+?)(:\d+|)$!;
		my $host = $1;
		if ($file =~ /$host/) {
		    closedir PTALDIR;
		    unlink ($file) or return $file;
		    printer::services::restart("hpoj");
		    return undef;
		} 
	    } else {
		if ((grep { /$d->{val}{MODEL}/ } chomp_(cat_($file))) &&
		    ((!$d->{val}{SERIALNUMBER}) ||
		     (grep { /$d->{val}{SERIALNUMBER}/ } 
		      chomp_(cat_($file))))) {
		    closedir PTALDIR;
		    unlink ($file) or return $file;
		    printer::services::restart("hpoj");
		    return undef;
		}
	    }
	}
	last;
    }
    closedir PTALDIR;
    return undef;
}    

sub configure_hpoj {
    my ($device, @autodetected) = @_;

    # Make the subroutines of /usr/sbin/ptal-init available
    # It's only necessary to read it at the first call of this subroutine,
    # the subroutine definitions stay valid after leaving this subroutine.
    if (!$ptalinitread) {
	open(my $PTALINIT, "$::prefix/usr/sbin/ptal-init") or do {
	    die "unable to open $::prefix/usr/sbin/ptal-init";
	};
	my @ptalinitfunctions; # subroutine definitions in /usr/sbin/ptal-init
	local $_;
	while (<$PTALINIT>) {
	    if (m!sub main!) {
		last;
	    } elsif (m!^[^#]! && !(m!^\s*exec\b!)) {
		# Comment lines and the "exec" line (probably obsolete
		# Red Hat workaround) are skipped.

		# Make the subroutines also working during installation
		if ($::isInstall) {
		    s!\$::prefix!\$hpoj_prefix!g;
		    s!prefix="/usr"!prefix="$::prefix/usr"!g;
		    s!etcPtal="/etc/ptal"!etcPtal="$::prefix/etc/ptal"!g;
		    s!varLock="/var/lock"!varLock="$::prefix/var/lock"!g;
		    s!varRunPrefix="/var/run"!varRunPrefix="$::prefix/var/run"!g;
		    s!/sbin/lsmod!/usr/bin/lsmod!g;
		    s!/sbin/modprobe!/usr/bin/modprobe!g;
		    s!/sbin/rmmod!/usr/bin/rmmod!g;
		    s!(my\s*\$osPlatform\s*=\s*).*?$!$1"Linux";!g;
		    s!chomp\s*\$osPlatform\s*;\s*$!!g;
		    s!(my\s*\$linuxVersion\s*=\s*).*?$!$1"$kernelversion";!g;
		    s!^\s*\$linuxVersion\s*=~\s*s.*$!!g;
		    s!chomp\s*\$linuxVersion\s*;\s*$!!g;
		    s!(my\s*\$usbprintermodule\s*=\s*).*?$!$1"$usbprintermodule";!g;
		}
		push @ptalinitfunctions, $_;
	    }
	}
	close $PTALINIT;

	eval "package printer::hpoj;
        @ptalinitfunctions
        sub getDevnames {
	    return (%devnames)
	}
        sub getConfigInfo {
            return (%configInfo)
        }";

	if ($::isInstall) {
	    # Needed for photo card reader detection during installation
	    system("ln -s $::prefix/var/run/ptal-mlcd /var/run/ptal-mlcd");
	    system("ln -s $::prefix/etc/ptal /etc/ptal");
	}
	$ptalinitread = 1;
    }

    # Read the HPOJ config file and check whether this device is already
    # configured
    printer::hpoj::setupVariables();
    printer::hpoj::readDeviceInfo();

    $device =~ m!^/dev/\S*lp(\d+)$! or
	$device =~ m!^/dev/printers/(\d+)$! or
	$device =~ m!^socket://([^:]+)$! or
	$device =~ m!^socket://([^:]+):(\d+)$!;
    my $model = $1;
    my ($model_long, $serialnumber, $serialnumber_long) = ("", "", "");
    my $cardreader = 0;
    my $device_ok = 1;
    my $bus;
    my $address_arg = "";
    my $base_address = "";
    my $hostname = "";
    my $port = $2;
    if ($device =~ /usb/) {
	$bus = "usb";
    } elsif ($device =~ /par/ ||
	     $device =~ m!/dev/lp! ||
	     $device =~ /printers/) {
	$bus = "par";
	$address_arg = printer::detect::parport_addr($device);
	eval "$base_address = $1" if $address_arg =~ /^\s*-base\s+(\S+)/;
    } elsif ($device =~ /socket/) {
	$bus = "hpjd";
	$hostname = $model;
	return "" if $port && ($port < 9100 || $port > 9103);
	if ($port && $port != 9100) {
	    $port -= 9100;
	    $hostname .= ":$port";
	}
    } else {
	return "";
    }
    if ($#autodetected < 0) {
	# Make a pseudo structure for the auto-detected data if there is
	# no auto-detected data (for example when configuring manually)
	$autodetected[0] = {
	    'port' => $device,
	    'val' => {
		'MODEL' => N("Unknown model")
	    }
	};
    }
    foreach (@autodetected) {
	$device eq $_->{port} or next;
	# $model is for the PTAL device name, so make sure that it is unique
	# so in the case of the model name auto-detection having failed leave
	# the port number or the host name as model name.
	my $searchunknown = N("Unknown model");
	if ($_->{val}{MODEL} &&
	    $_->{val}{MODEL} !~ /$searchunknown/i &&
	    $_->{val}{MODEL} !~ /^\s*$/) {
	    $model = $_->{val}{MODEL};
	}
	$serialnumber = $_->{val}{SERIALNUMBER};
	services::stop("hpoj") if $bus ne "hpjd";
	# Check if the device is really an HP multi-function device
	#my $libusb = 0;
	foreach my $libusb (0, 1) {
	    # Do access via libusb/user mode only if we have a USB device
	    next if $libusb && $bus ne "usb";
	    # Preliminary workaround to make the user-mode USB devices
	    # (LIDIL devices) installable as verification of the HPOJ
	    # settings of these devices does not work yet. The workaround
	    # will probably removed after version 9.2 of this distribution.
	    # Note: This workaround leaves out the checking for a photo
	    # memory card reader, but to my knowledge there are no LIDIL
	    # devices with card reader yet.
	    if ($libusb) {
		$device_ok = 1;
		next;
	    }
	    my $printermoduleunloaded = 0;
	    if ($bus ne "hpjd") {
		if (!$libusb) {
		    # Start ptal-mlcd daemon for locally connected devices
		    # (kernel mode with "printer"/"usblp" module for USB).
		    run_program::rooted($::prefix, 
					"ptal-mlcd", "$bus:probe",
					(($bus ne "par") ||
					 (!$address_arg) ?
					 ("-device", $device) : ()), 
					split(' ',$address_arg));
		} else {
		    # Start ptal-mlcd daemon for user-mode USB devices
		    # (all LIDIL MF devices as HP PSC 1xxx and OfficeJet 
		    #  4xxx)
		    my $usbdev = usbdevice($_->{val});
		    if (defined($usbdev)) {
			# Unload kernel module "printer"/"usblp"
			if (modules::any_conf->read->get_probeall("usb-interface")) {
			    eval(modules::unload($usbprintermodule));
			    $printermoduleunloaded = 1;
			}
			# Start ptal-mlcd
			run_program::rooted($::prefix, 
					    "ptal-mlcd", "$bus:probe",
					    "-device", $usbdev);
		    } else {
			# We could not determine the USB device number,
			# so we cannot check this device in user mode
			next;
		    }
		}
	    }
	    $device_ok = 0;
	    my $ptalprobedevice = $bus eq "hpjd" ? "hpjd:$hostname" : "mlc:$bus:probe";
	    if (open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . "/usr/bin/ptal-devid $ptalprobedevice |")) {
		my $devid = join("", <$F>);
		close $F;
		if ($devid) {
		    $device_ok = 1;
		    if (open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . "/usr/bin/ptal-devid $ptalprobedevice -long -mdl 2>/dev/null |")) {
			$model_long = join("", <$F>);
			close $F;
			chomp $model_long;
			# If SNMP or local port auto-detection failed but 
			# HPOJ auto-detection succeeded, fill in model name 
			# here.
			if (!$_->{val}{MODEL} ||
			    $_->{val}{MODEL} =~ /$searchunknown/i ||
			    $_->{val}{MODEL} =~ /^\s*$/) {
			    if ($model_long =~ /:([^:;]+);/) {
				$_->{val}{MODEL} = $1;
				$model = $_->{val}{MODEL};
				$model =~ s/ /_/g;
			    }
			}
		    }
		    if (open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . "/usr/bin/ptal-devid $ptalprobedevice -long -sern 2>/dev/null |")) { #-#
			$serialnumber_long = join("", <$F>);
			close $F;
			chomp $serialnumber_long;
		    }
		    $cardreader = 1 if printer::hpoj::cardReaderDetected($ptalprobedevice);
		}
	    }
	    if ($bus ne "hpjd") {
		# Stop ptal-mlcd daemon for locally connected devices
		if (open(my $F, ($::testing ? $::prefix : "chroot $::prefix/ ") . qq(ps auxwww | grep "ptal-mlcd $bus:probe" | grep -v grep | ))) {
		    my $line = <$F>;
		    if ($line =~ /^\s*\S+\s+(\d+)\s+/) {
			my $pid = $1;
			kill 15, $pid;
		    }
		    close $F;
		}
		$printermoduleunloaded &&
		    eval(modules::load($usbprintermodule));
	    }
	    last if $device_ok;
	}
	printer::services::start("hpoj") if $bus ne "hpjd";
	last;
    }
    # No, it is not an HP multi-function device.
    return "" if !$device_ok;
	
    # If $model_long and $serialnumber_long stay empty, fill them with
    # $model and $serialnumber
    $model_long ||= $model;
    $serialnumber_long ||= $serialnumber;

    # Determine the ptal device name from already existing config files
    my $ptalprefix =
	($bus eq "hpjd" ? "hpjd:" : "mlc:$bus:");
    my $ptaldevice = printer::hpoj::lookupDevname($ptalprefix, $model_long, 
				    $serialnumber_long, $base_address);

    # It's all done for us, the device is already configured
    return $ptaldevice if defined($ptaldevice);

    # Determine the ptal name for a new device
    if ($bus eq "hpjd") {
	$ptaldevice = "hpjd:$hostname";
    } else {
	$ptaldevice = $model;
	$ptaldevice =~ s![\s/]+!_!g;
	$ptaldevice = "mlc:$bus:$ptaldevice";
    }

    # Delete any old/conflicting devices
    printer::hpoj::deleteDevice($ptaldevice);
    if ($bus eq "par") {
	while (1) {
	    my $oldDevname = printer::hpoj::lookupDevname("mlc:par:",undef,undef,$base_address);
	    last unless defined($oldDevname);
	    printer::hpoj::deleteDevice($oldDevname);
	}
    }

    # Configure the device

    # Open configuration file
    open(my $CONFIG, "> $::prefix/etc/ptal/$ptaldevice") or
	die "Could not open /etc/ptal/$ptaldevice for writing!\n";

    # Write file header.
    my $date = chomp_(`date`);
    print $CONFIG
qq(
# Added $date by "printerdrake"

# The basic format for this file is "key[+]=value".
# If you say "+=" instead of "=", then the value is appended to any
# value already defined for this key, rather than replacing it.

# Comments must start at the beginning of the line.  Otherwise, they may
# be interpreted as being part of the value.

# If you have multiple devices and want to define options that apply to
# all of them, then put them in the file /etc/ptal/defaults, which is read
# in before this file.

# The format version of this file:
#   ptal-init ignores devices with incorrect/missing versions.
init.version=2
);

    # Write model string.
    if ($model_long !~ /\S/) {
	print $CONFIG
	    "\n" .
	    qq(# "printerdrake" couldn't read the model but added this device anyway:\n) .
	    "# ";
    } else {
	print $CONFIG
	    "\n" .
	    "# The device model that was originally detected on this port:\n" .
	    qq(#   If this ever changes, then you should re-run "printerdrake"\n) .
	    "#   to delete and re-configure this device.\n";
	if ($bus eq "par") {
	    print $CONFIG
		"#   Comment out if you do not care what model is really connected to this\n" .
		"#   parallel port.\n";
	}
    }
    print $CONFIG
	qq(init.mlcd.append+=-devidmatch "$model_long"\n);

    # Write serial-number string.
    if ($serialnumber_long !~ /\S/) {
	print $CONFIG
	    "\n" .
	    "# The device's serial number is unknown.\n" .
	    "# ";
    } else {
	print $CONFIG
	    "\n" .
	    "# The serial number of the device that was originally detected on this port:\n";
	if ($bus =~ /^[pu]/) {
	    print $CONFIG
		"#   Comment out if you want to disable serial-number matching.\n";
	}
    }
    print $CONFIG
	qq(init.mlcd.append+=-devidmatch "$serialnumber_long"\n);

    if ($bus =~ /^[pu]/) {
	print $CONFIG
	    "\n" .
	    "# Standard options passed to ptal-mlcd:\n" .
	    "init.mlcd.append+=";
	if ($bus eq "usb") {
	    # Important: do not put more quotes around /dev/usb/lp[0-9]*,
	    # because ptal-mlcd currently does no globbing:
	    print $CONFIG "-device /dev/usb/lp0 /dev/usb/lp1 /dev/usb/lp2 /dev/usb/lp3 /dev/usb/lp4 /dev/usb/lp5 /dev/usb/lp6 /dev/usb/lp7 /dev/usb/lp8 /dev/usb/lp9 /dev/usb/lp10 /dev/usb/lp11 /dev/usb/lp12 /dev/usb/lp13 /dev/usb/lp14 /dev/usb/lp15";
	} elsif ($bus eq "par") {
	    print $CONFIG "$address_arg" .
		(!$address_arg ? " -device $device" : "");
	}
	print $CONFIG "\n" .
	    "\n" .
	    "# ptal-mlcd's remote console can be useful for debugging, but may be a\n" .
	    "# security/DoS risk otherwise.  In any case, it's accessible with the\n" .
	    qq(# command "ptal-connect mlc:<XXX>:<YYY> -service PTAL-MLCD-CONSOLE".\n) .
	    "# Uncomment the following line if you want to enable this feature for\n" .
	    "# this device:\n" .
	    "# init.mlcd.append+=-remconsole\n" .
	    "\n" .
	    "# If you need to pass any other command-line options to ptal-mlcd, then\n" .
	    "# add them to the following line and uncomment the line:\n" .
	    "# init.mlcd.append+=\n" .
	    "\n" .
	    "# By default ptal-printd is started for mlc: devices.  If you use CUPS,\n" .
	    "# then you may not be able to use ptal-printd, and you can uncomment the\n" .
	    "# following line to disable ptal-printd for this device:\n" .
	    "# init.printd.start=0\n";
    } else {
	print $CONFIG
	    "\n" .
	    "# By default ptal-printd is not started for hpjd: devices.\n" .
	    "# If for some reason you want to start it for this device, then\n" .
	    "# uncomment the following line:\n" .
	    "init.printd.start=1\n";
    }

    print $CONFIG
	"\n" .
	"# If you need to pass any additional command-line options to ptal-printd,\n" .
	"# then add them to the following line and uncomment the line:\n" .
	"# init.printd.append+=\n";
    if ($cardreader) {
	print $CONFIG
	    "\n" .
	    "# Uncomment the following line to enable ptal-photod for this device:\n" .
	    "init.photod.start=1\n" .
	    "\n" .
	    "# If you have more than one photo-card-capable peripheral and you want to\n" .
	    "# assign particular TCP port numbers and mtools drive letters to each one,\n" .
	    qq(# then change the line below to use the "-portoffset <n>" option.\n) .
	    "init.photod.append+=-maxaltports 26\n";
    }
    close($CONFIG);
    printer::hpoj::readOneDevice($ptaldevice);

    # Restart HPOJ
    printer::services::restart("hpoj");

    # Return HPOJ device name to form the URI
    return $ptaldevice;
}

sub devicefound {
    my ($usbid, $model, $serial) = @_;
    # Compare the output of "lsusb -vv" with the elements of the device 
    # ID string
    if ($serial && $usbid->{SERIALNUMBER} eq $serial) {
	# Match of serial number has absolute priority
	return 1;
    } elsif ($model && $usbid->{MODEL} eq $model) {
	# Try to match the model name otherwise
	return 1;
    }
    return 0;
}

sub usbdevice {
    my ($usbid) = @_;
    # Run "lsusb -vv� and search the given device to get its USB bus and
    # device numbers
    open(my $F, ($::testing ? "" : "chroot $::prefix/ ") .
	'/bin/sh -c "export LC_ALL=C; lsusb -vv 2> /dev/null" |')
	or return undef;
    my ($bus, $device, $model, $serial) = ("", "", "", "");
    my $found = 0;
    while (my $line = <$F>) {
	chomp $line;
	if ($line =~ m/^\s*Bus\s+(\d+)\s+Device\s+(\d+)\s*:/i) {
	    # head line of a new device
	    my ($newbus, $newdevice) = ($1, $2);
	    last if (($model || $serial) && 
		     ($found = devicefound($usbid, $model, $serial)));
	    ($bus, $device) = ($newbus, $newdevice);
	} elsif ($line =~ m/^\s*iProduct\s+\d+\s+(.+)$/i) {
	    # model line
	    next if $device eq "";
	    $model = $1;
	} elsif ($line =~ m/^\s*iSerial\s+\d+\s+(.+)$/i) {
	    # model line
	    next if $device eq "";
	    $serial = $1;
	}
    }
    close $F;
    # Check last entry
    $found = devicefound($usbid, $model, $serial);

    return 0 if !$found;
    return sprintf("%%%03d%%%03d", $bus, $device);
}

sub config_sane {
    my ($backend) = $_;

    # Add HPOJ/HPLIP backend to /etc/sane.d/dll.conf if needed (no
    # individual config file /etc/sane.d/hplip.conf or
    # /etc/sane.d/hpoj.conf necessary, the HPLIP and HPOJ drivers find
    # the scanner automatically)

    return if (! -f "$::prefix/etc/sane.d/dll.conf");
    return if member($backend,
		     chomp_(cat_("$::prefix/etc/sane.d/dll.conf")));
    eval { append_to_file("$::prefix/etc/sane.d/dll.conf",
			  "$backend\n") } or
	   die "can not write SANE config in /etc/sane.d/dll.conf: $!";
}

sub config_photocard() {

    # Add definitions for the drives p:. q:, r:, and s: to /etc/mtools.conf
    cat_("$::prefix/etc/mtools.conf") !~ m/^\s*drive\s+p:/m or return;

    append_to_file("$::prefix/etc/mtools.conf", <<'EOF');
# Drive definitions added for the photo card readers in HP multi-function
# devices driven by HPOJ
drive p: file=":0" remote
drive q: file=":1" remote
drive r: file=":2" remote
drive s: file=":3" remote
# This turns off some file system integrity checks of mtools, it is needed
# for some photo cards.
mtools_skip_check=1
EOF

    # Generate a config file for the graphical mtools frontend MToolsFM or
    # modify the existing one
    my $mtoolsfmconf;
    if (-f "$::prefix/etc/mtoolsfm.conf") {
	$mtoolsfmconf = cat_("$::prefix/etc/mtoolsfm.conf") or die "can not read MToolsFM config in $::prefix/etc/mtoolsfm.conf: $!";
	my $alloweddrives = lc($1) if $mtoolsfmconf =~ m/^\s*DRIVES\s*=\s*"([A-Za-z ]*)"/m;
	foreach my $letter ("p", "q", "r", "s") {
         $alloweddrives .= $letter if $alloweddrives !~ /$letter/;
	}
	$mtoolsfmconf =~ s/^\s*DRIVES\s*=\s*"[A-Za-z ]*"/DRIVES="$alloweddrives"/m;
	$mtoolsfmconf =~ s/^\s*LEFTDRIVE\s*=\s*"[^"]*"/LEFTDRIVE="p"/m;
        #"# Fix emacs syntax highlighting
    } else {
	$mtoolsfmconf = <<'EOF';
# MToolsFM config file. comments start with a hash sign.
#
# This variable sets the allowed driveletters (all lowercase). Example:
# DRIVES="ab"
DRIVES="apqrs"
#
# This variable sets the driveletter upon startup in the left window.
# An empty string or space is for the hardisk. Example:
# LEFTDRIVE="a"
LEFTDRIVE="p"
#
# This variable sets the driveletter upon startup in the right window.
# An empty string or space is for the hardisk. Example:
# RIGHTDRIVE="a"
RIGHTDRIVE=" "
EOF
    }
    output("$::prefix/etc/mtoolsfm.conf", $mtoolsfmconf);
}

sub setcupslink {
    my ($printer) = @_;
    return 1 if !$::isInstall || $printer->{SPOOLER} ne "cups" || -d "/etc/cups/ppd";
    system("ln -sf $::prefix/etc/cups /etc/cups");
    return 1;
}


1;