Bug#3125: bug (and correction) in dpkg-1.1.6 scripts/install-info.pl

[Kim-Minh Kaplan <kkaplan@cdf.in2p3.fr>]

  It looks like my previous mail didn't make it to the bug list; so
much the better : after a little more study on Perl, I have simplified
the code.  Still, inspect carefully begore using.

  Another word of warning if you plan on calling it in dpkg.postinst :
it backups the dir file to dir.old, so the install-info command that
would be found with it would make the real original file disappear.

  BTW, what/where is dpkg-1.2.3 ?  And dpkg now defaults to
--force-overwrite (bad IMHO), but --force-help doesn't say so.

+++ THIS IS cleanup-info.pl +++
#!/usr/bin/perl --
#
#   Clean up the mess that bogus install-info may have done :
#
#	- gather all sections with the same heading into a single one.
#
#   Other clean ups :
#
#	- remove empty sections,
#	- squeeze blank lines (in entries part only).
#
#   Order of sections is preserved (the first encountered section
# counts).
#
#   Order of entries within a section is preserved.
#
# BUGS:
#
#   Probably many : I just recently learned Perl for this program
# using the man pages.  Hopefully this is a short enough program to
# debug.

use strict;

sub version {
    print STDERR <<END;
Debian GNU/Linux cleanup-info 1.1.  Copyright (C) 1994,1995 Kim-Minh
Kaplan. This is free software; see the GNU General Public Licence
version 2 or later for copying conditions.  There is NO warranty.
END
}

sub usage {
    print STDERR "usage: cleanup-info [--version] [--help] [--] [<dirname>]\n";
}

my $infodir = '/usr/info';
$0 =~ m|[^/]+$|;
my $name= $&;

sub ulquit {
    unlink "$infodir/dir.lock"
	or warn "$name: warning - unable to unlock $infodir/dir: $!\n";
    die $_[0];
}

while (scalar @ARGV > 0 && $ARGV[0] =~ m/^--/) {
    $_ = shift;
    if ($_ eq '--') {
	last;
    } elsif ($_ eq "--version") {
	version;
	exit 0;
    } elsif ($_ eq "--help") {
	usage;
	exit 0;
    } else {
	print STDERR "$name: unknown option \`$_'\n";
	usage;
	exit 1;
    }
}

if (scalar @ARGV > 0) {
    $infodir = shift;
    if (scalar @ARGV > 0) {
	print STDERR "$name: too many arguments\n";
	usage;
	exit 1;
    }
}

if (!link "$infodir/dir", "$infodir/dir.lock") {
    die "$name: failed to lock dir for editing! $!\n".
        ($! =~ m/exist/i ? "try deleting $infodir/dir.lock\n" : '');
}
open OLD, "$infodir/dir"  or ulquit "$name: can't open $infodir/dir: $!\n";
open OUT, ">$infodir/dir.new"
    or ulquit "$name can't create $infodir/dir.new: $!\n";

do {				# dump the non entries part
    $_ = <OLD>;
    last if !$_;
    print OUT $_ or ulquit "$name: error writing $infodir/dir.new: $!\n";
} until (m/^\*\s*Menu:/i);

my (%sections, @section_list);
my $section="Miscellaneous";	# default section
foreach (<OLD>) {		# collect sections
    next if (m/^\s*$/);		# squeeze blank lines
    s/\s*$//;
    if (m/^[^\*\s]/) {		# change of section
	$section = $_;
    } else {			# add to section
	if (! exists $sections{$section}) { # create section header
	    push @section_list, $section;
	    $sections{$section} = "\n$section\n";
	}
	$sections{$section} .= "$_\n";
    }
}

eof OLD or ulquit "$name: read $infodir/dir: $!\n";
close OLD or ulquit "$name: close $infodir/dir after read: $!\n";

print OUT @sections{@section_list};
close OUT or ulquit "$name: error closing $infodir/dir.new: $!\n";

# install clean version
unlink "$infodir/dir.old";
link "$infodir/dir", "$infodir/dir.old"
    or ulquit "$name: can't backup old $infodir/dir, giving up: $!\n";
rename "$infodir/dir.new", "$infodir/dir"
    or ulquit "$name: failed to install $infodir/dir; I'll leave it as $infodir/dir.new: $!\n";

unlink "$infodir/dir.lock"
    or die "$name: failed to unlock $infodir/dir: $!\n";

exit 0;
+++ THIS IS NO MORE cleanup-info.pl +++
--
FAX : +33-1-45 80 08 02
<Kim-Minh.Kaplan@cdf.in2p3.fr> <kaplan@afflynn.frmug.fr.net>

Linux Is Not UniX.  What's lignux ?