# debconf -- lintian check script -*- perl -*-

# Copyright (C) 2001 Colin Watson
#
# 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., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package Lintian::debconf;
use strict;
use Tags;

use Dep;
use Util;

sub run {

my $pkg = shift;
my $type = shift;

# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
# version 1.3.22.  Added indices for cdebconf (indicates sort order for
# choices); debconf doesn't support it, but it ignores it, which is safe
# behavior.
my %template_fields;
map { $template_fields{$_}=1 }
    qw(template type choices indices default description);

# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
# version 1.3.22
my %valid_types;
map { $valid_types{$_}=1 } qw(
	string
	password
	boolean
	select
	multiselect
	note
	text
	title
	error
	);
$valid_types{error} = 1 if $type eq 'udeb';

# From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to
# date with debconf version 1.5.3.
my %valid_priorities = map { $_ => 1 }
    qw(low medium high critical);

my $seenconfig='';
my $seentemplates='';
my $usespreinst='';
my $usesmultiselect='';

if (open(PREINST, "control/preinst")) {
    while (<PREINST>) {
	s/#.*//;    # Not perfect for Perl, but should be OK
	if (m,/usr/share/debconf/confmodule, or
	        m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) {
	    $usespreinst=1;
	    last;
	}
    }
    close PREINST;
}

if (-f "control/config") {
    $seenconfig=1;
}
if (-f "control/templates") {
    $seentemplates=1;
}

# This still misses packages that use debconf only in the postrm.  Packages
# that ask debconf questions in the postrm should load the confmodule in the
# postinst so that debconf can register their templates.
return unless $seenconfig or $seentemplates or $usespreinst;

# parse depends info for later checks

# Consider every package to depend on itself.
my $version;
if (-f "fields/version") {
    open(IN, "fields/version") or fail("Can't open fields/version: $!");
    chomp($_ = <IN>);
    $version = "$pkg (= $_)";
    close IN;
}

my (%dependencies, @alldeps);

for my $field (qw(depends pre-depends)) {
    if (-f "fields/$field") {
	open(IN, "fields/$field") or fail("Can't open fields/$field: $!");
	chomp($_ = <IN>);
	close IN;
	$_ .= ", $version" if defined $version;
	$_ =~ s/debconf-2\.0/debconf (>= 1.2.30)/go;
	$_ =~ s/cdebconf(-\w+)?(-udeb)?\s*(\(.+?\))?/debconf (>= 1.2.30)/g;
	$_ =~ s/libdebconfclient.?(-udeb)?\s*(\(.+?\))?/debconf (>= 1.2.30)/g;
        push @alldeps, $_;
	$dependencies{$field} = Dep::parse($_);
    } else {
	my $dep = $version;
	$dep =~ s/debconf-2\.0/debconf (>= 1.2.30)/go;
	$dep =~ s/cdebconf(-\w+)?(-udeb)?\s*(\(.+?\))?/debconf (>= 1.2.30)/g;
	$dep =~ s/libdebconfclient.?(-udeb)?\s*(\(.+?\))?/debconf (>= 1.2.30)/g;
	push @alldeps, $dep;
	$dependencies{$field} = Dep::parse($dep);
    }
}

my $alldependencies = Dep::parse(join ', ', @alldeps);

# See if the package depends on dbconfig-common.  Packages that do are allowed
# to have a config file with no templates, since they use the dbconfig-common
# templates.
my $usesdbconfig = Dep::implies($alldependencies, Dep::parse('dbconfig-common'));

# Check that both debconf control area files are present.
if ($seenconfig and not $seentemplates and not $usesdbconfig) {
    tag "no-debconf-templates", "";
} elsif ($seentemplates and not $seenconfig and not $usespreinst and $type ne 'udeb') {
    tag "no-debconf-config", "";
}

if ($seenconfig and not -x "control/config") {
    tag "debconf-config-not-executable", "";
}

# First check that templates look valid
if ($seentemplates) {
    open(TMPL, "control/templates") or fail("Can't open control/templates: $!");
    local $/ = "\n\n";
    while (<TMPL>) {
	chomp;
	my %fields = ();
	my $name = 'unknown';

	foreach my $line (split "\n", $_) {
	    if ($line =~ s/^([-_.A-Za-z0-9]+):\s*(.+)//) {
		$fields{$1}++;
		$name = $2 if ($1 eq 'Template');
	    }
	}

	foreach (keys %fields) {
	    if ($fields{$_} > 1) {
		tag "duplicate-fields-in-templates", "$name $_";
		#  Templates file is corrupted, no need to report
		#  further errors
		$seentemplates = '';
	    }
	}
    }
    close TMPL;
}

# Lots of template checks.

my @templates = $seentemplates ? read_dpkg_control("control/templates", "templates file") : ();
my %potential_db_abuse;

foreach my $template (@templates) {
    my $isselect='';

    if (not exists $template->{template}) {
	tag "no-template-name", "";
	$template->{template} = 'no-template-name';
    } elsif ($template->{template}!~m|[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])|) {
	tag "malformed-template-name", "$template->{template}";
    }

    if (not exists $template->{type}) {
	tag "no-template-type", "$template->{template}";
    } elsif (not $valid_types{$template->{type}}) {
	tag "unknown-template-type", "$template->{type}";
    } elsif ($template->{type} eq 'select') {
	$isselect=1;
    } elsif ($template->{type} eq 'multiselect') {
	$isselect=1;
	$usesmultiselect=1;
    } elsif ($template->{type} eq 'boolean') {
	tag "boolean-template-has-bogus-default",
	    "$template->{template} $template->{default}"
		if defined $template->{default}
		    and $template->{default} ne 'true'
		    and $template->{default} ne 'false';
    }

    if ($template->{choices} && ($template->{choices} !~ /^\s*$/)) {
	my $nrchoices = count_choices ($template->{choices});
	for my $key (keys %$template) {
	    if ($key =~ /^choices-/) {
		if (! $template->{$key} || ($template->{$key} =~ /^\s*$/)) {
		    tag "empty-translated-choices", "$template->{template} $key";
		}
		if (count_choices ($template->{$key}) != $nrchoices) {
		    tag "mismatch-translated-choices", "$template->{template} $key";
		}
	    }
	}
    }

    if ($isselect and not exists $template->{choices}) {
	tag "select-without-choices", "$template->{template}";
    }

    if (not exists $template->{description}) {
	tag "no-template-description", "$template->{template}";
    } elsif ($template->{description}=~m/^\s*(.*?)\s*?\n\s*\1\s*$/) {
	# Check for duplication. Should all this be folded into the
	# description checks?
	tag "duplicate-long-description-in-template",
	      "$template->{template}";
    }

    my %languages;
    foreach my $field (sort keys %$template) {
	# Tests on translations
	my ($mainfield, $lang) = split m/-/, $field, 2;
	if (defined $lang) {
	    $languages{$lang}{$mainfield}=1;
	}
	unless ($template_fields{$mainfield}) { # Ignore language codes here
	    tag "unknown-field-in-templates", "$template->{template} $field";
	}
    }
    if (exists $template->{choices}
	&& $template->{choices} !~ m/^\s*\$\{\w+\}\s*$/) {
	foreach my $lang (sort keys %languages) {
	    # Choices-C is special. Normally, when it is present, the only
	    # other Choices* field present will be Choices itself, and there
	    # is not necessarily a Description-C. This is used by code that
	    # wants to substitute into the untranslated choices and also
	    # into all translated choices at once.
	    # TODO: it's reasonable to have a full set of Choices-*, but
	    # only Description-C and Description, for pretty much the same
	    # reason as above. This shouldn't trigger this tag.
	    if ($lang ne 'c' and $languages{$lang}{choices} and not $languages{$lang}{description}) {
		tag "partially-translated-question", "$template->{template} $lang";
	    }
	}
    }

    if ($template->{template} && $template->{type}) {
        $potential_db_abuse{$template->{template}} = 1
            if (($template->{type} eq "note") or ($template->{type} eq "text"));
    }

    # Check the description against the best practices in the Developer's
    # Reference, but skip all templates where the short description contains
    # the string "for internal use".
    my ($short, $extended);
    if (defined $template->{description}) {
        $template->{description} =~ m/^([^\n]*)\n(.*)$/s;
        ($short, $extended) = ($1, $2);
        unless (defined $short) {
            $short = $template->{description};
        }
    } else {
        ($short, $extended) = ('', '');
    }
    my $type = $template->{type} || '';
    unless ($short =~ /for internal use/i) {
	my $isprompt = grep { $_ eq $type } qw(string select password multiselect);
	if ($isprompt) {
	    if ($short && $short !~ m/:$/) {
		tag "malformed-prompt-in-templates", $template->{template};
	    }
	    if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) {
		tag "using-imperative-form-in-templates", $template->{template};
	    }
	}
	if ($type eq 'boolean') {
	    if ($short !~ /\?/) {
		tag "malformed-question-in-templates", $template->{template};
	    }
	    if (defined ($extended) && $extended =~ /\?/) {
		tag "using-question-in-extended-description-in-templates", $template->{template};
	    }
	}
	if ($type eq 'note') {
	    if ($short =~ /[.?;:]$/) {
		tag "malformed-title-in-templates", $template->{template};
	    }
	}
	if (length ($short) > 75) {
	    tag "too-long-short-description-in-templates", $template->{template};
	}
        if (defined $template->{description}) {
            if ($template->{description} =~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us) /) {
                tag "using-first-person-in-templates", $template->{template};
            }
            if ($template->{description} =~ /[ \'\"]([Yy]es)[ \'\",.]/) {
                tag "making-assumptions-about-interfaces-in-templates", $template->{template};
            }
        }

	# Check whether the extended description is too long.
	if ($extended) {
	    my $lines = 0;
	    for my $string (split ("\n", $extended)) {
		while (length ($string) > 80) {
		    my $pos = rindex ($string, ' ', 80);
		    if ($pos == -1) {
			$pos = index ($string, ' ');
		    }
		    if ($pos == -1) {
			$string = '';
		    } else {
			$string = substr ($string, $pos + 1);
			$lines++;
		    }
		}
		$lines++;
	    }
	    if ($lines > 20) {
		tag "too-long-extended-description-in-templates", $template->{template};
	    }
	}
    }
}

# Check the maintainer scripts.

for my $file (qw(config postinst)) {
    my $potential_makedev = {};
    if (open(IN, "control/$file")) {
	my $usesconfmodule='';
	my $obsoleteconfmodule='';
	my $db_input='';
	my $isdefault='';
	my $usesseen='';
	my $usessettitle='';

	# Only check scripts.
	my $fl = <IN>;
	unless ($fl && $fl =~ /^\#!/) {
	    close IN;
	    next;
	}

	while (<IN>) {
	    s/#.*//;    # Not perfect for Perl, but should be OK
	    next unless m/\S/;
	    while (s%\\$%%) {
		my $next = <IN>;
		last unless $next;
		$_ .= $next;
	    }
	    if (m#(?:\.|source)\s+/usr/share/debconf/confmodule# ||
	            m/use\s+Debconf::Client::ConfModule/) {
	        $usesconfmodule=1;
	    }
	    if (not $obsoleteconfmodule and
	        m#(/usr/share/debconf/confmodule\.sh|
	           Debian::DebConf::Client::ConfModule)#x) {
	        tag "$file-loads-obsolete-confmodule", "$1";
	        $usesconfmodule=1;
	        $obsoleteconfmodule=1;
	    }
	    if ($file eq 'postinst' and not $db_input and m/db_input/) {
	        # TODO: Perl?
	        tag "postinst-uses-db-input", ""
		    unless $type eq 'udeb';
	        $db_input=1;
	    }
	    if (m%/dev/%) {
	        $potential_makedev->{$.} = 1;
	    }
	    if (m/^\s*(?:db_input|db_text)\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) {
		my ($priority, $template) = ($1, $2);
		if ($priority !~ /^\$\S+$/) {
		    tag "unknown-debconf-priority", "$file:$. $1"
		        unless ($valid_priorities{$priority});
		    tag "possible-debconf-note-abuse", "$file:$. $template"
			if ($potential_db_abuse{$template}
			    and (not ($potential_makedev->{($. - 1)} and ($priority eq "low")))
			    and ($priority =~ /^(low|medium)$/));
		}
	    }
	    if (not $isdefault and m/db_fset.*isdefault/) {
	        # TODO: Perl?
	        tag "isdefault-flag-is-deprecated", "$file";
	        $isdefault=1;
	    }
	    if (not $usessettitle and m/db_settitle\s+/) {
		unless (Dep::implies($alldependencies,
				     Dep::parse('debconf (>= 1.3.22)'))) {
	           tag "settitle-requires-versioned-depends", "$file" 
		       unless $type eq 'udeb';
	       }
	        $usessettitle = 1;
	    }
	}

	unless ($usesconfmodule) {
	    tag "$file-does-not-load-confmodule", ""
		unless ($type eq 'udeb' || ($file eq 'postinst' && !$seenconfig));
	}

	close IN;
    } elsif ($file eq 'postinst') {
	tag "$file-does-not-load-confmodule", ""
	    unless ($type eq 'udeb' || !$seenconfig);
    }
}

if (open(POSTRM, "control/postrm")) {
    my $db_purge='';

    while (<POSTRM>) {
	s/#.*//;    # Not perfect for Perl, but should be OK
	if (not $db_purge and m/db_purge/) {    # TODO: Perl?
	    $db_purge=1;
	    last;
	}
    }

    unless ($db_purge) {
	tag "postrm-does-not-purge-debconf", "";
    }
} elsif ($type ne 'udeb') {
    tag "postrm-does-not-purge-debconf", "";
}

# Check that the right dependencies are in the control file.

if ($usespreinst) {
    unless (Dep::implies($dependencies{'pre-depends'}, Dep::parse('debconf'))) {
	tag "missing-debconf-dependency-for-preinst", ""
	    unless $type eq 'udeb';
    }
} else {
    unless (Dep::implies($alldependencies, Dep::parse('debconf')) or $usesdbconfig) {
	tag "missing-debconf-dependency", "";
    }
}

# Now make sure that no scripts are using debconf as a registry.
# Unfortunately this requires us to unpack to level 2 and grep all the
# scripts in the package.
# the following checks is ignored if the package being checked is debconf
# itself.

return 0 if ($pkg eq "debconf") || ($type eq 'udeb');

open(SCRIPTS, "scripts") or fail("cannot open lintian scripts file: $!");
while (<SCRIPTS>) {
    chomp;

    # From checks/scripts.
    my ($calls_env, $interpreter, $filename) = m/^(env )?(\S*) (.*)$/
	or fail("bad line in scripts file: $_");

    open(IN, "< unpacked/$filename") or fail("cannot open $filename: $!");
    while (<IN>) {
	s/#.*//;    # Not perfect for Perl, but should be OK
	if (m,/usr/share/debconf/confmodule, or
	        m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) {
	    tag "debconf-is-not-a-registry", "$filename";
	    last;
	}
    }
    close IN;
}
close SCRIPTS;

} # </run>

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

# Count the number of choices.	Splitting code copied from debconf 1.5.8
# (Debconf::Question).
sub count_choices {
    my ($choices) = @_;
    my @items;
    my $item = '';
    for my $chunk (split /(\\[, ]|,\s+)/, $choices) {
	if ($chunk =~ /^\\([, ])$/) {
	    $item .= $1;
	} elsif ($chunk =~ /^,\s+$/) {
	    push (@items, $item);
	    $item = '';
	} else {
	    $item .= $chunk;
	}
    }
    push (@items, $item) if $item ne '';
    return scalar (@items);
}

1;

# vim: syntax=perl ts=8
