--- /dev/null
+# 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
+ );
+
+# 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);
+
+# All the packages that provide debconf functionality. Anything using debconf
+# needs to have dependencies that satisfy one of these.
+my @debconfs = qw(debconf debconf-2.0 cdebconf cdebconf-udeb libdebconfclient0
+ libdebconfclient0-udeb);
+
+my $seenconfig='';
+my $seentemplates='';
+my $usespreinst='';
+my $usesmultiselect='';
+
+if ($type eq 'source') {
+ open(BINARY, '<', "fields/binary") or fail("Can't open fields/binary: $!");
+ my $binaries = <BINARY>;
+ close BINARY;
+ chomp $binaries;
+ my @files = map { "$_.templates" } split /,\s+/, $binaries;
+ push @files, "templates";
+
+ foreach my $file (@files) {
+ my $templates_file = "debfiles/$file";
+ my $binary = $file;
+ $binary =~ s/\.?templates$//;
+ # Single binary package (so @files contains "templates" and
+ # "binary.templates")?
+ if (!$binary and $#files == 1) {
+ $binary = $binaries;
+ }
+
+ if (-f $templates_file) {
+ my @templates = read_dpkg_control($templates_file, "templates file");
+
+ foreach my $template (@templates) {
+ if (exists $template->{template} and exists $template->{_choices}) {
+ tag "template-uses-unsplit-choices",
+ "$binary - $template->{template}";
+ }
+ }
+ }
+ }
+
+ # The remainder of the checks are for binary packages, so we exit now
+ return 0;
+}
+
+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;
+ push @alldeps, $_;
+ $dependencies{$field} = Dep::parse($_);
+ } else {
+ my $dep = $version;
+ 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;
+my @templates_seen;
+
+foreach my $template (@templates) {
+ my $isselect='';
+
+ if (not exists $template->{template}) {
+ tag "no-template-name", "";
+ $template->{template} = 'no-template-name';
+ } else {
+ push @templates_seen, $template->{template};
+ if ($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 'error') {
+ unless (Dep::implies($alldependencies, Dep::parse('debconf (>= 1.4.69) | cdebconf'))) {
+ tag "debconf-error-requires-versioned-depends", "$template->{template}"
+ unless $type eq 'udeb';
+ }
+ } 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 ($template->{choices} =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i) {
+ tag "select-with-boolean-choices", "$template->{template}";
+ }
+ }
+
+ 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 ($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 password);
+ my $isselect = grep { $_ eq $type } qw(select multiselect);
+ if ($isprompt) {
+ if ($short && ($short !~ m/:$/ || $short =~ m/^(what|who|when|where|which|how)/i)) {
+ tag "malformed-prompt-in-templates", $template->{template};
+ }
+ }
+ if ($isselect) {
+ 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)(\Z|\s)/) {
+ tag "using-first-person-in-templates", $template->{template};
+ }
+ if ($template->{description} =~ /[ \'\"]yes[ \'\",;.]/i and $type eq 'boolean') {
+ 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.
+
+my $config_calls_db_input;
+my $db_purge;
+my %templates_used;
+my %template_aliases;
+for my $file (qw(config prerm postrm preinst postinst)) {
+ my $potential_makedev = {};
+ if (open(IN, '<', "control/$file")) {
+ my $usesconfmodule='';
+ my $obsoleteconfmodule='';
+ my $db_input='';
+ my $isdefault='';
+ my $usesseen='';
+
+ # 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|require)\s+Debconf::Client::ConfModule/) {
+ $usesconfmodule=1;
+ }
+ if (not $obsoleteconfmodule and
+ m,(/usr/share/debconf/confmodule\.sh|
+ Debian::DebConf::Client::ConfModule),x) {
+ tag "loads-obsolete-confmodule", "$file:$. $1";
+ $usesconfmodule=1;
+ $obsoleteconfmodule=1;
+ }
+ if ($file eq 'config' and m/db_input/) {
+ $config_calls_db_input = 1;
+ }
+ if ($file eq 'postinst' and not $db_input and m/db_input/
+ and not $config_calls_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);
+ $templates_used{$template} = 1;
+ 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 (m/^\s*(?:db_get|db_set(?:title)?)\s+[\"\']?(\S+?)[\"\']?(\s|\Z)/) {
+ $templates_used{$1} = 1;
+ }
+ if (m/^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) {
+ my ($template, $question) = ($1, $2);
+ push @{$template_aliases{$template}}, $question;
+ }
+ if (not $isdefault and m/db_fset.*isdefault/) {
+ # TODO: Perl?
+ tag "isdefault-flag-is-deprecated", "$file";
+ $isdefault=1;
+ }
+ if (not $db_purge and m/db_purge/) { # TODO: Perl?
+ $db_purge=1;
+ }
+ }
+
+ if ($file eq 'postinst' or $file eq 'config') {
+ unless ($usesconfmodule) {
+ tag "$file-does-not-load-confmodule", ""
+ unless ($type eq 'udeb' || ($file eq 'postinst' && !$seenconfig));
+ }
+ }
+
+ if ($file eq 'postrm') {
+ unless ($db_purge) {
+ tag "postrm-does-not-purge-debconf", "";
+ }
+ }
+
+ close IN;
+ } elsif ($file eq 'postinst') {
+ tag "$file-does-not-load-confmodule", ""
+ unless ($type eq 'udeb' || !$seenconfig);
+ } elsif ($file eq 'postrm') {
+ tag "postrm-does-not-purge-debconf", ""
+ unless ($type eq 'udeb');
+ }
+}
+
+foreach my $template (@templates_seen) {
+ my $used = 0;
+
+ if ($templates_used{$template}) {
+ $used = 1;
+ } else {
+ foreach my $alias (@{$template_aliases{$template}}) {
+ if ($templates_used{$alias}) {
+ $used = 1;
+ last;
+ }
+ }
+ }
+ tag "unused-debconf-template", $template
+ unless $used or $pkg eq "debconf";
+}
+
+# Check that the right dependencies are in the control file. Accept any
+# package that might provide debconf functionality.
+
+my $anydebconf = Dep::parse(join (' | ', @debconfs));
+if ($usespreinst) {
+ unless (Dep::implies($dependencies{'pre-depends'}, $anydebconf)) {
+ tag "missing-debconf-dependency-for-preinst", ""
+ unless $type eq 'udeb';
+ }
+} else {
+ unless (Dep::implies($alldependencies, $anydebconf) 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;
+
+# Local Variables:
+# indent-tabs-mode: t
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl ts=8
projects / maemian / blobdiff