#!/usr/bin/perl
# perlmods -- lintian collection script
# grep all perl scripts for 'use' and 'require' directives.

# Copyright (C) 1998 by Richard Braakman
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

open(PERLMODS, ">perlmods") or fail("unable to write perlmods file: $!");

my %checkfiles;

open(SCRIPTS, "scripts") or fail("unable to read scripts file: $!");
while (<SCRIPTS>) {
    chop;
    /^(\S*) (.*)$/;
    next unless substr($1, -5) eq '/perl';
    $checkfiles{$2} = 1;
}
close(SCRIPTS) or fail("reading scripts file: $!");

open(INDEX, "index") or fail("unable to read index file: $!");
while (<INDEX>) {
    next if not m/^-/;
    chop;
    my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
    $file =~ s/ link to .*//;

    if ($file =~ m/\.p[lmh]$/) {
	$checkfiles{$file} = 1;
    }
}
close(INDEX) or fail("reading index file: $!");

for $file (keys %checkfiles) {
    open(PERL, "unpacked/$file") or fail("unable to read unpacked/$2: $!");
    $/ = "";
    my ($pod, $skip, $autoloader);
    while (<PERL>) {
	$pod = ($pod or /^=/) and not /^=cut\b/;
	next if $pod or /^=/;

	if ($skip) {
	    # Prepend the newline because $skip looks for a string at the
	    # start of a line.
	    $_ = "\n" . $_;
	    my $i = index($_, $skip);
	    if ($i >= 0) {
		$_ = substr($_, $i);
		undef $skip;
	    } else {
		next;
	    }
	}

	# This regexp has grown to monstrous proportions to deal with all
	# the perverse perl code out there... it tries to recognize "here
	# documents" without misparsing the use of << as leftshift.
	# Problem cases are in mrtg and mysql-base.
	while (m/
	       (?:
		^\s* (?:print|die) .*
		|
		=\s*
		)
	       <<
	       ['"]?(\S*)["']?
               \s*
               (?:unless\s.*)?
	       ;
	       \s*$/gmx) {
	    $skip = "\n$1";
	    my $i = index($_, $skip, pos);
	    my $cutoff = pos() - length($&);
	    if ($i >= 0) {
		$_ = substr($_, 0, $cutoff) . substr($_, $i);
		undef $skip;
	    } else {
		$_ = substr($_, 0, $cutoff);
	    }
	}

	$autoloader = 1 if /\bAutoLoader\b/m;

	# This is not quite correct, since if the paragraph contains text
	# before the end marker, that text is not scanned.
	last if /^\s*__DATA__\s*$/m;
	# There will be subroutine definitions after the __END__ if
	# AutoLoader is used, so do not check for __END__ in that case.
	last if not $autoloader and /^\s*__END__\s*$/m;

	while (m/^[ \t]*(require|use)\s.*$/gm) {
	    print PERLMODS "$file: $&\n";
	}
    }
    $/ = "\n";
}
close(PERLMODS) or fail("writing perlmods file: $!");

exit 0;

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

sub fail {
    if ($_[0]) {
        print STDERR "error: $_[0]\n";
    } elsif ($!) {
        print STDERR "error: $!\n";
    } else {
        print STDERR "error.\n";
    }
    exit 1;
}
