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

From: Kim-Minh Kaplan <[email-masked]>
Date: Tue, 4 Jun 1996 05:11:34 +0200

OK, here's a little improved one, it should correct the other
strange things that have been reported.  Here are the changes :

  - Insensitive case matching on section title.  Also the trailing
colon is ignored during the comparision.

  - Should cleanup the '* Menu' line when it's in limbo.  But it will
go nuts if there's a line in the header part that starts with a star.
I have a problem here : if the dir file is wrong enough as to have
lost it's '* Menu' line, I don't really see how to reliably
reconstruct it.  The current behavior will correct most of those cases
but at the price that a completly legal (but rare) dir file can get it
to hell.  Sounds bad :-( Which should be kept ?

  P.S: I really don't feel like doing the sorting stuff someone talked
about.  So this is up to you all...

--- START OF 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.
#	Tries to be smart about cases and trailing colon/spaces.
#
#   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.2.  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";

my (%sections, @section_list, $lastline);
my $section="Miscellaneous";	# default section
my $section_canonic="miscellaneous";

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

if (! /^\*\s*Menu\s*:?/i) {
    $lastline =~ s/\s*$//;
    if ($lastline =~ /^([^\*\s].*)/) {	# there was a section title
	$section = $1;
	$lastline =~ s/$*:$//;
	$section_canonic = lc $lastline;
    }
    push @section_list, $section_canonic;
    s/\s*$//;
    $sections{$section_canonic} = "\n$section\n$_\n";
}

foreach (<OLD>) {		# collect sections
    next if (m/^\s*$/ or m/^\*\s*Menu/i);
    s/\s*$//;
    if (/^([^\*\s].*)/) {		# change of section
	$section = $1;
	s/\s*:$//;
	$section_canonic = lc $_;
    } else {			# add to section
	if (! exists $sections{$section_canonic}) { # create section header
	    push @section_list, $section_canonic;
	    $sections{$section_canonic} = "\n$section\n";
	}
	$sections{$section_canonic} .= "$_\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;
--- END OF cleanup-info.pl ---
---
<[email-masked]> <[email-masked]>
FAX : +33-1-45 80 08 02

Linux Is Not UniX.  What's lignux ?