libxml-sax-perl 0.99+dfsg-2 / usr / bin / update-perl-sax-parsers

#!/usr/bin/perl
## ----------------------------------------------------------------------
## Debian update-perl-sax-parsers version 0.3
## ----------------------------------------------------------------------
## Copyright (C) 2001-2003 Ardo van Rangelrooij
## Copyright (C) 2007      Niko Tyni
##
## This is free software; see the GNU General Public Licence version 2
## or later for copying conditions.  There is NO warranty.
## ----------------------------------------------------------------------

## ----------------------------------------------------------------------
use strict;

## ----------------------------------------------------------------------
use File::Spec;
use Getopt::Long;
use XML::SAX;
use XML::SAX::Debian;
use File::Temp qw(tempfile);

## ----------------------------------------------------------------------
$0  =~ m|[^/]+$|;

## ----------------------------------------------------------------------
my $name = $&;

## ----------------------------------------------------------------------
my $add       = '';
my @directory = ();
my $file      = '';
my $help      = '';
my $quiet     = '';
my $remove    = '';
my $test      = '';
my $update    = '';
my $version   = '';
my $ucf;
my $priority;

## ----------------------------------------------------------------------
if ( ! GetOptions(
		  'add=s'       => \$add,
		  'directory=s' => \@directory,
		  'file=s'      => \$file,
		  'help'        => \$help,
		  'quiet'       => \$quiet,
		  'remove=s'    => \$remove,
		  'test'        => \$test,
		  'update'      => \$update,
		  'version'     => \$version,
		  'priority=i'  => \$priority,
		  'ucf=i'       => \$ucf,
		  )
     )
{
    &usage;
    exit 1;
}


## ----------------------------------------------------------------------
if ( $version )
{
    &version;
    exit 0;
}

## ----------------------------------------------------------------------
if ( $help )
{
    &usage;
    exit 0;
}

## ----------------------------------------------------------------------
print STDERR "$name: test mode - Perl SAX parsers file will not be updated\n"
    if $test && ! $quiet;

## ----------------------------------------------------------------------
# default priority is 50 unless --directory was specified
# with --directory, default to 0 (no priority in the filenames)
$priority = (@directory ? 0 : 50) if not defined $priority;

## ----------------------------------------------------------------------
my $PARSER_DETAILS_DIR  = "/var/lib/libxml-sax-perl/ParserDetails.d";
push( @directory, $PARSER_DETAILS_DIR) if ! @directory;

## ----------------------------------------------------------------------
# use ucf by default if --file is not specified
$ucf  = ($file ? 0 : 1) if not defined $ucf;

## ----------------------------------------------------------------------
my $PARSER_DETAILS_FILE = "/etc/perl/XML/SAX/ParserDetails.ini";
$file = $PARSER_DETAILS_FILE if ! $file;

## ----------------------------------------------------------------------
unless (XML::SAX->can("_is_vendor_supplied")) {
    print STDERR "$name: Non-vendor version of XML::SAX is installed.\n";
    print STDERR "$name: Automatic registration of SAX parsers might not work.\n";
}

if ( $add )
{
    print "$name: Registering Perl SAX parser $add with priority $priority...\n"
        unless $quiet;
    
    XML::SAX::Debian->save_parsers_debian( $add, $directory[0], $priority );
}
elsif ( $remove )
{
    print "$name: Unregistering Perl SAX parser $remove with priority $priority...\n"
        unless $quiet;
    
    my $parser_file = $remove;
    $parser_file = "${priority}-$parser_file" if $priority != 0;
    $parser_file = File::Spec->catfile( $directory[0], $parser_file );
    unlink( $parser_file );
}
elsif ( $update )
{
    print "$name: Updating overall Perl SAX parser modules info file...\n"
        unless $quiet;

    my ($handle, $tmpfile);

    if ($ucf) {
        ($handle, $tmpfile) = tempfile();
        chmod 0644, $tmpfile or die("chmod $tmpfile: $!");
    } else {
        open( $handle, ">$file" )
	        || die "Cannot write to $file: $!";
    }
    foreach my $directory ( @directory)
    {
	opendir( PARSER_DETAILS_DIR, $directory )
	    || die "Cannot access $directory: $!";
	my @files = sort readdir ( PARSER_DETAILS_DIR );
	for my $parser_details ( @files )
	{
	    next if $parser_details =~ /^\.\.?$/; # skip . and ..
	    open( PARSER_DETAILS, "$directory/$parser_details" )
		|| die "Cannot read from $parser_details: $!";
	    while ( <PARSER_DETAILS> ) { print $handle $_; }
	    close( PARSER_DETAILS );
	}
	closedir( PARSER_DETAILS_DIR );
    }
    close( $handle );
    if ($ucf) {
        system("ucf", "--debconf-ok", "--sum-file",  "/var/lib/libxml-sax-perl/ParserDetails.ini.md5sum", $tmpfile, $file);
        unlink $tmpfile or die("unlink $tmpfile: $!");
    }
}

## ----------------------------------------------------------------------
exit 0;

## ----------------------------------------------------------------------
sub usage
{
    print STDERR <<END;
Usage:
    $name <options> --add <parser_module>
    $name <options> --remove <parser_module>
    $name <options> --update

Options:
    --directory     Perl SAX parser module info file directory to be used
                    as target for 'add'/'remove' or as sources for 'update'
                    (default = '/var/lib/libxml-sax-perl/ParserDetails.d')
    --priority      The priority of the parser to add. The parser with the
                    highest priority is the default parser.
    --file          Perl SAX parser module info file to be updated
                    (default = '/etc/perl/XML/SAX/ParserDetails.ini')
    --ucf X         Forcibly disable (X == 0) or enable (X != 0) the use
                    of ucf with '--update'.
    --help          display this help text (usage)
    --quiet         be quiet
    --test          do not modify any files, enable debugging mode
    --version       display version number
END
}

## ----------------------------------------------------------------------
sub version
{
    print "Debian $name version 0.4\n";
}

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