info dir cleaning script - test please, even on OK dir files

[Ian Jackson <ian@chiark.chu.cam.ac.uk>]

Kim-Minh Kaplan has very kindly written the script below for use in
dpkg, to tidy up the duplicate section headings left by some earlier
versions of install-info.

I intend to run it in dpkg's postinst script if the versions match up,
but before I do that I'd like to give it a bit of a field test - this
is a codefreeze, after all.

So: whether or not you have a messed-up dir file, please try the
script and let me know whether it works for you.

Kim-Minh: if it doesn't break anyone's file I'll ship it in the next
dpkg.  Please confirm that you're happy to have it distributed under
the GPL (I'm not asking, of course, that you assign the copyright to
anyone); if so I'll add the appropriate notices to the top of the
script.  I have to ask this because without that I may be on shaky
legal ground distributing it - in fact, just posting it is dodgy, but
I could probably claim implicit permission ...

Thanks,
Ian.

#!/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 learned Perl today for this program using
# the man pages, and hashes of lists are a bit tricky.  Hopefully this
# is a short enough program to debug.

sub version {
    print STDERR <<END;
Debian GNU/Linux cleanup-info 1.0.  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";
}

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

while ($#ARGV >= 0 && $ARGV[0] =~ m/^--/) {
    $_ = shift(@ARGV);
    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 (@ARGV) {
    $infodir = shift(@ARGV);
    if (@ARGV) {
	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") || &ulquit("$name: can't open $infodir/dir: $!\n");
open(OUT, ">$infodir/dir.new")
    || &ulquit("$name can't create $infodir/dir.new: $!\n");

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

$section="Miscellaneous\n";	# default section

foreach (<OLD>) {		# collect sections
    next if (m/^\s*$/);
    if (m/^[^\*\s]/) {		# change of section
	$section = $_;
    } else {			# add to section
	if ($#{ $sections{$section} } == -1) { # create section header
	    push @section_list, $section;
	    push @{ $sections{$section} }, "\n$section";
	}
	push @{ $sections{$section} }, $_;
    }
}

eof(OLD) || &ulquit("$name: read $infodir/dir: $!\n");
close(OLD) || &ulquit("$name: close $infodir/dir after read: $!\n");

# dump all that has been collected.
foreach (@section_list) {
    (print OUT @{ $sections{$_} })
	|| &ulquit("$name: error writing $infodir/dir.new: $!\n");
}
close(OUT) || &ulquit("$name: error closing $infodir/dir.new: $!\n");

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

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

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

exit 0;