#!/usr/bin/perl -w
# perl -- lintian check script

# 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.

require "$ENV{'LINTIAN_ROOT'}/lib/deplib.pl";

# autouse is treated specially.
%known_pragmas = map { $_ => 1 }
  qw(blib diagnostics integer less lib locale ops overload
     sigtrap strict subs vmsish vars);

($#ARGV == 1) or fail("syntax: field <pkg> <type>");
$pkg = shift;
$type = shift;

open(MODS, "perlmods") or fail("cannot open perlmods file: $!");
while (<MODS>) {
    chop;
    
    /^(.*?):\s+((use|require)\s+[^;\#]*)/
	or fail("syntax error in perlmods file: $_");
    my ($file,$orig_use) = ($1,$2);

    next if $file =~ m,^usr/doc/,;

    $orig_use =~ s/\s+$//;

    # Keep $orig_use for reporting
    my $use = $orig_use;

    # Treat use and require as equivalent
    $use =~ s/^(use|require)\s+//;

    my ($first) = $use =~ /^(\S+)/;

    # Is it a pragma?
    next if (exists $known_pragmas{$first});

    # Is it a perl version number?
    # It seems that, contrary to the docs, version numbers do not have
    # to be numeric can can be extended with patchlevels as "_01".
    if ($use =~ /^\d+(\.\d+(_\d+)?)?$/) {
	# Then the package should depend on the right perl version.
	# Versions older than the one 5.004 are too ancient to worry about,
	# mainly because the perl-base / perl split wasn't properly done
	# until that version.

	# Deal with the patchlevel thing
	my ($ver, $dep) = ($use, $use);
	$ver =~ s/_//;
	$dep =~ s/_/./;

	if ($ver > 5.004 and not
	    depends_on("perl (>= $dep) | perl-base (>= $dep)")) {
	    tag_error("script-needs-perl-version", $file, $use);
	}
	next;
    }

    # 'autouse' is a pragma that precedes a module name, so discard it
    # and process the rest normally.
    $use =~ s/^autouse\s+//;

    # Some scripts do "require blah || die"
    $use =~ s/\|\|\s*(die|warn)\b.*//;
    
    # Now try to process the directive as a filename.

    # Is it a bareword?
    if ($use =~ /^([A-Za-z0-9_:]+)/) {
	$use = $1;
	# Replace :: with / and add .pm
	$use =~ s,::,/,g;
	$use .= '.pm';
    }
    # Is it a simple quoted string?
    elsif ($use =~ /^"([^\$\\\"]*)"/ or
           $use =~ /^'([^\\\']*)'/) {
	$use = $1;
    }
    # Is it a quoted string with a single variable substitution at the start?
    elsif ($use =~ /^"\$[^\$\/\\\"]+\/([^\$\\\"]+)"/) {
	$use = $1;
    }
    # Too complicated -- give up.
    else {
	tag_info("cannot-parse-perl-directive", $file, $orig_use);
	next;
    }

    # Is the filename relative to the current directory? 
    # Then we have to assume the script knows what it's doing.
    next if $use =~ /^\./;

    # Is the required file supplied by the package itself?
    next if (package_installs_file($use));

    # No.  Find out which perl package(s) provide it.
    my $p = module_provided_by($use);

    # Do we know this module?
    if (not defined $p) {
	# Ignore anything called "config", since that probably indicates
	# the use of the perl-script-as-config-file trick.
	next if ($use =~ m,(^|/)config(.p[lm])?,);
	tag_warn("perl-script-uses-unknown-module", $file, $orig_use);
	next;
    }

    # Does the package have the appropriate dependencies?
    next if depends_on($p);
    
    # No.  Emit a warning.
    tag_warn("perl-script-needs-dependency", "\"$p\"", $file, $orig_use);
}
close(MODS);

exit 0;

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

my @package_installs_filelist;
sub package_installs_file {
    my $wantfile = shift;
    $wantfile =~ s,^\./,,;
    $wantfile =~ tr,/,/,s; # eliminate duplicate slashes
    if (not defined @package_installs_filelist) {
	open(IN,"index") or fail("cannot open index file index: $!");
	while (<IN>) {
	    chop;
	    my $file = (split (' ', $_, 6))[5];
	    $file =~ s/ link to .*//;
	    $file =~ s/ -> .*//;
	    push @package_installs_filelist, $file;
	}
	close(IN);
    }
    if ($wantfile =~ s,^/,,) {    # absolute
        return grep { $_ eq $wantfile } @package_installs_filelist;
    } else {                     # relative / pathsearch
	my $len = length($wantfile);
	for $file (@package_installs_filelist) {
	    return 1 if substr($file, -$len) eq $wantfile;
	}
	return 0;
    }
}

my $cached_pkg_dependencies;
sub package_dependencies {
    my $field;
    my @lines;

    return $cached_pkg_dependencies if defined $cached_pkg_dependencies;

    # Added 'recommends' and 'suggests' to the list, because if a perl
    # script needs a module that is provided by something on the
    # 'recommends' or 'suggests' lines, then that's probably no accident.
    for $field ('depends', 'pre-depends', 'recommends', 'suggests') {
	if (-f "fields/$field") {
	    open(I, "fields/$field") or fail("cannot open fields/$field: $!");
	    chomp($_ = <I>);
	    push @lines, $_;
	    close(I);
	}
    }

    # Consider every package to depend on itself
    if (-f "fields/version") {
	open(I, "fields/version") or fail("cannot open fields/version: $!");
	chomp($_ = <I>);
	push @lines, "$pkg (= $_)";
	close(I);
    }

    return $cached_pkg_dependencies = Dep::parse(join(', ', @lines));
}

sub depends_on {
    return 1 if length($_[0]) == 0;
    return Dep::implies(package_dependencies, Dep::parse($_[0]));
}

my %perl_modules_cache;
sub module_provided_by {
    my $fname = $_[0];

    if (not defined %perl_modules_cache) {
	my $modfile = "$ENV{'LINTIAN_ROOT'}/info/perl-modules";
	open(I, $modfile) or fail("could not open $modfile: $!");
	while (<I>) {
	    chop;
	    /^(\S+)\s*(.*)/;
	    $2 = '' if not defined $2;
	    $perl_modules_cache{$1} = $2;
	}
	close(I);
    }

    while (length $fname) {
	return $perl_modules_cache{$fname}
	    if exists $perl_modules_cache{$fname};
	$fname =~ s,^[^/]*/?,,;
    }

    return undef;
}
	

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

sub tag_error {
    my $tag = shift;
    if ($#_ >= 0) {
        # We can't have newlines in a tag message, so turn them into \n
        map { s,\n,\\n, } @_;
        my $args = join(' ', @_);
        print "E: $pkg $type: $tag $args\n";
    } else {
        print "E: $pkg $type: $tag\n";
    }
}

sub tag_warn {
    my $tag = shift;
    if ($#_ >= 0) {
        # We can't have newlines in a tag message, so turn them into \n
        map { s,\n,\\n, } @_;
        my $args = join(' ', @_);
        print "W: $pkg $type: $tag $args\n";
    } else {
        print "W: $pkg $type: $tag\n";
    }
}

sub tag_info {
    my $tag = shift;
    if ($#_ >= 0) {
        # We can't have newlines in a tag message, so turn them into \n
        map { s,\n,\\n, } @_;
        my $args = join(' ', @_);
        print "I: $pkg $type: $tag $args\n";
    } else {
        print "I: $pkg $type: $tag\n";
    }
}

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