vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/debconf

   1 # debconf -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 2001 Colin Watson
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Lintian::debconf;
  22 use strict;
  23 use Tags;
  24
  25 use Dep;
  26 use Util;
  27
  28 sub run {
  29
  30 my $pkg = shift;
  31 my $type = shift;
  32
  33 # From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
  34 # version 1.3.22.  Added indices for cdebconf (indicates sort order for
  35 # choices); debconf doesn't support it, but it ignores it, which is safe
  36 # behavior.
  37 my %template_fields;
  38 map { $template_fields{$_}=1 }
  39     qw(template type choices indices default description);
  40
  41 # From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
  42 # version 1.3.22
  43 my %valid_types;
  44 map { $valid_types{$_}=1 } qw(
  45         string
  46         password
  47         boolean
  48         select
  49         multiselect
  50         note
  51         text
  52         title
  53         error
  54         );
  55
  56 # From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to
  57 # date with debconf version 1.5.3.
  58 my %valid_priorities = map { $_ => 1 }
  59     qw(low medium high critical);
  60
  61 # All the packages that provide debconf functionality.  Anything using debconf
  62 # needs to have dependencies that satisfy one of these.
  63 my @debconfs = qw(debconf debconf-2.0 cdebconf cdebconf-udeb libdebconfclient0
  64                   libdebconfclient0-udeb);
  65
  66 my $seenconfig='';
  67 my $seentemplates='';
  68 my $usespreinst='';
  69 my $usesmultiselect='';
  70
  71 if ($type eq 'source') {
  72     open(BINARY, '<', "fields/binary") or fail("Can't open fields/binary: $!");
  73     my $binaries = <BINARY>;
  74     close BINARY;
  75     chomp $binaries;
  76     my @files = map { "$_.templates" } split /,\s+/, $binaries;
  77     push @files, "templates";
  78
  79     foreach my $file (@files) {
  80         my $templates_file = "debfiles/$file";
  81         my $binary = $file;
  82         $binary =~ s/\.?templates$//;
  83         # Single binary package (so @files contains "templates" and
  84         # "binary.templates")?
  85         if (!$binary and $#files == 1) {
  86             $binary = $binaries;
  87         }
  88
  89         if (-f $templates_file) {
  90             my @templates = read_dpkg_control($templates_file, "templates file");
  91
  92             foreach my $template (@templates) {
  93                 if (exists $template->{template} and exists $template->{_choices}) {
  94                     tag "template-uses-unsplit-choices",
  95                         "$binary - $template->{template}";
  96                 }
  97             }
  98         }
  99     }
 100
 101     # The remainder of the checks are for binary packages, so we exit now
 102     return 0;
 103 }
 104
 105 if (open(PREINST, '<', "control/preinst")) {
 106     while (<PREINST>) {
 107         s/#.*//;    # Not perfect for Perl, but should be OK
 108         if (m,/usr/share/debconf/confmodule, or
 109                 m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) {
 110             $usespreinst=1;
 111             last;
 112         }
 113     }
 114     close PREINST;
 115 }
 116
 117 if (-f "control/config") {
 118     $seenconfig=1;
 119 }
 120 if (-f "control/templates") {
 121     $seentemplates=1;
 122 }
 123
 124 # This still misses packages that use debconf only in the postrm.  Packages
 125 # that ask debconf questions in the postrm should load the confmodule in the
 126 # postinst so that debconf can register their templates.
 127 return unless $seenconfig or $seentemplates or $usespreinst;
 128
 129 # parse depends info for later checks
 130
 131 # Consider every package to depend on itself.
 132 my $version;
 133 if (-f "fields/version") {
 134     open(IN, '<', "fields/version") or fail("Can't open fields/version: $!");
 135     chomp($_ = <IN>);
 136     $version = "$pkg (= $_)";
 137     close IN;
 138 }
 139
 140 my (%dependencies, @alldeps);
 141
 142 for my $field (qw(depends pre-depends)) {
 143     if (-f "fields/$field") {
 144         open(IN, '<', "fields/$field") or fail("Can't open fields/$field: $!");
 145         chomp($_ = <IN>);
 146         close IN;
 147         $_ .= ", $version" if defined $version;
 148         push @alldeps, $_;
 149         $dependencies{$field} = Dep::parse($_);
 150     } else {
 151         my $dep = $version;
 152         push @alldeps, $dep;
 153         $dependencies{$field} = Dep::parse($dep);
 154     }
 155 }
 156
 157 my $alldependencies = Dep::parse(join ', ', @alldeps);
 158
 159 # See if the package depends on dbconfig-common.  Packages that do are allowed
 160 # to have a config file with no templates, since they use the dbconfig-common
 161 # templates.
 162 my $usesdbconfig = Dep::implies($alldependencies, Dep::parse('dbconfig-common'));
 163
 164 # Check that both debconf control area files are present.
 165 if ($seenconfig and not $seentemplates and not $usesdbconfig) {
 166     tag "no-debconf-templates", "";
 167 } elsif ($seentemplates and not $seenconfig and not $usespreinst and $type ne 'udeb') {
 168     tag "no-debconf-config", "";
 169 }
 170
 171 if ($seenconfig and not -x "control/config") {
 172     tag "debconf-config-not-executable", "";
 173 }
 174
 175 # First check that templates look valid
 176 if ($seentemplates) {
 177     open(TMPL, '<', "control/templates")
 178         or fail("Can't open control/templates: $!");
 179     local $/ = "\n\n";
 180     while (<TMPL>) {
 181         chomp;
 182         my %fields = ();
 183         my $name = 'unknown';
 184
 185         foreach my $line (split "\n", $_) {
 186             if ($line =~ s/^([-_.A-Za-z0-9]+):\s*(.+)//) {
 187                 $fields{$1}++;
 188                 $name = $2 if ($1 eq 'Template');
 189             }
 190         }
 191
 192         foreach (keys %fields) {
 193             if ($fields{$_} > 1) {
 194                 tag "duplicate-fields-in-templates", "$name $_";
 195                 #  Templates file is corrupted, no need to report
 196                 #  further errors
 197                 $seentemplates = '';
 198             }
 199         }
 200     }
 201     close TMPL;
 202 }
 203
 204 # Lots of template checks.
 205
 206 my @templates = $seentemplates ? read_dpkg_control("control/templates", "templates file") : ();
 207 my %potential_db_abuse;
 208 my @templates_seen;
 209
 210 foreach my $template (@templates) {
 211     my $isselect='';
 212
 213     if (not exists $template->{template}) {
 214         tag "no-template-name", "";
 215         $template->{template} = 'no-template-name';
 216     } else {
 217         push @templates_seen, $template->{template};
 218         if ($template->{template}!~m|[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])|) {
 219             tag "malformed-template-name", "$template->{template}";
 220         }
 221     }
 222
 223     if (not exists $template->{type}) {
 224         tag "no-template-type", "$template->{template}";
 225     } elsif (not $valid_types{$template->{type}}) {
 226         tag "unknown-template-type", "$template->{type}";
 227     } elsif ($template->{type} eq 'select') {
 228         $isselect=1;
 229     } elsif ($template->{type} eq 'multiselect') {
 230         $isselect=1;
 231         $usesmultiselect=1;
 232     } elsif ($template->{type} eq 'error') {
 233         unless (Dep::implies($alldependencies, Dep::parse('debconf (>= 1.4.69) | cdebconf'))) {
 234             tag "debconf-error-requires-versioned-depends", "$template->{template}"
 235                 unless $type eq 'udeb';
 236         }
 237     } elsif ($template->{type} eq 'boolean') {
 238         tag "boolean-template-has-bogus-default",
 239             "$template->{template} $template->{default}"
 240                 if defined $template->{default}
 241                     and $template->{default} ne 'true'
 242                     and $template->{default} ne 'false';
 243     }
 244
 245     if ($template->{choices} && ($template->{choices} !~ /^\s*$/)) {
 246         my $nrchoices = count_choices ($template->{choices});
 247         for my $key (keys %$template) {
 248             if ($key =~ /^choices-/) {
 249                 if (! $template->{$key} || ($template->{$key} =~ /^\s*$/)) {
 250                     tag "empty-translated-choices", "$template->{template} $key";
 251                 }
 252                 if (count_choices ($template->{$key}) != $nrchoices) {
 253                     tag "mismatch-translated-choices", "$template->{template} $key";
 254                 }
 255             }
 256         }
 257         if ($template->{choices} =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i) {
 258             tag "select-with-boolean-choices", "$template->{template}";
 259         }
 260     }
 261
 262     if ($isselect and not exists $template->{choices}) {
 263         tag "select-without-choices", "$template->{template}";
 264     }
 265
 266     if (not exists $template->{description}) {
 267         tag "no-template-description", "$template->{template}";
 268     } elsif ($template->{description}=~m/^\s*(.*?)\s*?\n\s*\1\s*$/) {
 269         # Check for duplication. Should all this be folded into the
 270         # description checks?
 271         tag "duplicate-long-description-in-template",
 272               "$template->{template}";
 273     }
 274
 275     my %languages;
 276     foreach my $field (sort keys %$template) {
 277         # Tests on translations
 278         my ($mainfield, $lang) = split m/-/, $field, 2;
 279         if (defined $lang) {
 280             $languages{$lang}{$mainfield}=1;
 281         }
 282         unless ($template_fields{$mainfield}) { # Ignore language codes here
 283             tag "unknown-field-in-templates", "$template->{template} $field";
 284         }
 285     }
 286
 287     if ($template->{template} && $template->{type}) {
 288         $potential_db_abuse{$template->{template}} = 1
 289             if (($template->{type} eq "note") or ($template->{type} eq "text"));
 290     }
 291
 292     # Check the description against the best practices in the Developer's
 293     # Reference, but skip all templates where the short description contains
 294     # the string "for internal use".
 295     my ($short, $extended);
 296     if (defined $template->{description}) {
 297         $template->{description} =~ m/^([^\n]*)\n(.*)$/s;
 298         ($short, $extended) = ($1, $2);
 299         unless (defined $short) {
 300             $short = $template->{description};
 301         }
 302     } else {
 303         ($short, $extended) = ('', '');
 304     }
 305     my $type = $template->{type} || '';
 306     unless ($short =~ /for internal use/i) {
 307         my $isprompt = grep { $_ eq $type } qw(string password);
 308         my $isselect = grep { $_ eq $type } qw(select multiselect);
 309         if ($isprompt) {
 310             if ($short && ($short !~ m/:$/ || $short =~ m/^(what|who|when|where|which|how)/i)) {
 311                 tag "malformed-prompt-in-templates", $template->{template};
 312             }
 313         }
 314         if ($isselect) {
 315             if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) {
 316                 tag "using-imperative-form-in-templates", $template->{template};
 317             }
 318         }
 319         if ($type eq 'boolean') {
 320             if ($short !~ /\?/) {
 321                 tag "malformed-question-in-templates", $template->{template};
 322             }
 323         }
 324         if (defined ($extended) && $extended =~ /\?/) {
 325             tag "using-question-in-extended-description-in-templates", $template->{template};
 326         }
 327         if ($type eq 'note') {
 328             if ($short =~ /[.?;:]$/) {
 329                 tag "malformed-title-in-templates", $template->{template};
 330             }
 331         }
 332         if (length ($short) > 75) {
 333             tag "too-long-short-description-in-templates", $template->{template};
 334         }
 335         if (defined $template->{description}) {
 336             if ($template->{description} =~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us)(\Z|\s)/) {
 337                 tag "using-first-person-in-templates", $template->{template};
 338             }
 339             if ($template->{description} =~ /[ \'\"]yes[ \'\",;.]/i and $type eq 'boolean') {
 340                 tag "making-assumptions-about-interfaces-in-templates", $template->{template};
 341             }
 342         }
 343
 344         # Check whether the extended description is too long.
 345         if ($extended) {
 346             my $lines = 0;
 347             for my $string (split ("\n", $extended)) {
 348                 while (length ($string) > 80) {
 349                     my $pos = rindex ($string, ' ', 80);
 350                     if ($pos == -1) {
 351                         $pos = index ($string, ' ');
 352                     }
 353                     if ($pos == -1) {
 354                         $string = '';
 355                     } else {
 356                         $string = substr ($string, $pos + 1);
 357                         $lines++;
 358                     }
 359                 }
 360                 $lines++;
 361             }
 362             if ($lines > 20) {
 363                 tag "too-long-extended-description-in-templates", $template->{template};
 364             }
 365         }
 366     }
 367 }
 368
 369 # Check the maintainer scripts.
 370
 371 my $config_calls_db_input;
 372 my $db_purge;
 373 my %templates_used;
 374 my %template_aliases;
 375 for my $file (qw(config prerm postrm preinst postinst)) {
 376     my $potential_makedev = {};
 377     if (open(IN, '<', "control/$file")) {
 378         my $usesconfmodule='';
 379         my $obsoleteconfmodule='';
 380         my $db_input='';
 381         my $isdefault='';
 382         my $usesseen='';
 383
 384         # Only check scripts.
 385         my $fl = <IN>;
 386         unless ($fl && $fl =~ /^\#!/) {
 387             close IN;
 388             next;
 389         }
 390
 391         while (<IN>) {
 392             s/#.*//;    # Not perfect for Perl, but should be OK
 393             next unless m/\S/;
 394             while (s%\\$%%) {
 395                 my $next = <IN>;
 396                 last unless $next;
 397                 $_ .= $next;
 398             }
 399             if (m,(?:\.|source)\s+/usr/share/debconf/confmodule, ||
 400                     m/(use|require)\s+Debconf::Client::ConfModule/) {
 401                 $usesconfmodule=1;
 402             }
 403             if (not $obsoleteconfmodule and
 404                 m,(/usr/share/debconf/confmodule\.sh|
 405                    Debian::DebConf::Client::ConfModule),x) {
 406                 tag "loads-obsolete-confmodule", "$file:$. $1";
 407                 $usesconfmodule=1;
 408                 $obsoleteconfmodule=1;
 409             }
 410             if ($file eq 'config' and m/db_input/) {
 411                 $config_calls_db_input = 1;
 412             }
 413             if ($file eq 'postinst' and not $db_input and m/db_input/
 414                 and not $config_calls_db_input) {
 415                 # TODO: Perl?
 416                 tag "postinst-uses-db-input", ""
 417                     unless $type eq 'udeb';
 418                 $db_input=1;
 419             }
 420             if (m%/dev/%) {
 421                 $potential_makedev->{$.} = 1;
 422             }
 423             if (m/^\s*(?:db_input|db_text)\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) {
 424                 my ($priority, $template) = ($1, $2);
 425                 $templates_used{$template} = 1;
 426                 if ($priority !~ /^\$\S+$/) {
 427                     tag "unknown-debconf-priority", "$file:$. $1"
 428                         unless ($valid_priorities{$priority});
 429                     tag "possible-debconf-note-abuse", "$file:$. $template"
 430                         if ($potential_db_abuse{$template}
 431                             and (not ($potential_makedev->{($. - 1)} and ($priority eq "low")))
 432                             and ($priority =~ /^(low|medium)$/));
 433                 }
 434             }
 435             if (m/^\s*(?:db_get|db_set(?:title)?)\s+[\"\']?(\S+?)[\"\']?(\s|\Z)/) {
 436                 $templates_used{$1} = 1;
 437             }
 438             if (m/^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) {
 439                 my ($template, $question) = ($1, $2);
 440                 push @{$template_aliases{$template}}, $question;
 441             }
 442             if (not $isdefault and m/db_fset.*isdefault/) {
 443                 # TODO: Perl?
 444                 tag "isdefault-flag-is-deprecated", "$file";
 445                 $isdefault=1;
 446             }
 447             if (not $db_purge and m/db_purge/) {    # TODO: Perl?
 448                 $db_purge=1;
 449             }
 450         }
 451
 452         if ($file eq 'postinst' or $file eq 'config') {
 453             unless ($usesconfmodule) {
 454                 tag "$file-does-not-load-confmodule", ""
 455                     unless ($type eq 'udeb' || ($file eq 'postinst' && !$seenconfig));
 456             }
 457         }
 458
 459         if ($file eq 'postrm') {
 460             unless ($db_purge) {
 461                 tag "postrm-does-not-purge-debconf", "";
 462             }
 463         }
 464
 465         close IN;
 466     } elsif ($file eq 'postinst') {
 467         tag "$file-does-not-load-confmodule", ""
 468             unless ($type eq 'udeb' || !$seenconfig);
 469     } elsif ($file eq 'postrm') {
 470         tag "postrm-does-not-purge-debconf", ""
 471             unless ($type eq 'udeb');
 472     }
 473 }
 474
 475 foreach my $template (@templates_seen) {
 476     my $used = 0;
 477
 478     if ($templates_used{$template}) {
 479         $used = 1;
 480     } else {
 481         foreach my $alias (@{$template_aliases{$template}}) {
 482             if ($templates_used{$alias}) {
 483                 $used = 1;
 484                 last;
 485             }
 486         }
 487     }
 488     tag "unused-debconf-template", $template
 489         unless $used or $pkg eq "debconf";
 490 }
 491
 492 # Check that the right dependencies are in the control file.  Accept any
 493 # package that might provide debconf functionality.
 494
 495 my $anydebconf = Dep::parse(join (' | ', @debconfs));
 496 if ($usespreinst) {
 497     unless (Dep::implies($dependencies{'pre-depends'}, $anydebconf)) {
 498         tag "missing-debconf-dependency-for-preinst", ""
 499             unless $type eq 'udeb';
 500     }
 501 } else {
 502     unless (Dep::implies($alldependencies, $anydebconf) or $usesdbconfig) {
 503         tag "missing-debconf-dependency", "";
 504     }
 505 }
 506
 507 # Now make sure that no scripts are using debconf as a registry.
 508 # Unfortunately this requires us to unpack to level 2 and grep all the
 509 # scripts in the package.
 510 # the following checks is ignored if the package being checked is debconf
 511 # itself.
 512
 513 return 0 if ($pkg eq "debconf") || ($type eq 'udeb');
 514
 515 open(SCRIPTS, '<', "scripts") or fail("cannot open lintian scripts file: $!");
 516 while (<SCRIPTS>) {
 517     chomp;
 518
 519     # From checks/scripts.
 520     my ($calls_env, $interpreter, $filename) = m/^(env )?(\S*) (.*)$/
 521         or fail("bad line in scripts file: $_");
 522
 523     open(IN, '<', "unpacked/$filename") or fail("cannot open $filename: $!");
 524     while (<IN>) {
 525         s/#.*//;    # Not perfect for Perl, but should be OK
 526         if (m,/usr/share/debconf/confmodule, or
 527                 m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) {
 528             tag "debconf-is-not-a-registry", "$filename";
 529             last;
 530         }
 531     }
 532     close IN;
 533 }
 534 close SCRIPTS;
 535
 536 } # </run>
 537
 538 # -----------------------------------
 539
 540 # Count the number of choices.  Splitting code copied from debconf 1.5.8
 541 # (Debconf::Question).
 542 sub count_choices {
 543     my ($choices) = @_;
 544     my @items;
 545     my $item = '';
 546     for my $chunk (split /(\\[, ]|,\s+)/, $choices) {
 547         if ($chunk =~ /^\\([, ])$/) {
 548             $item .= $1;
 549         } elsif ($chunk =~ /^,\s+$/) {
 550             push (@items, $item);
 551             $item = '';
 552         } else {
 553             $item .= $chunk;
 554         }
 555     }
 556     push (@items, $item) if $item ne '';
 557     return scalar (@items);
 558 }
 559
 560 1;
 561
 562 # Local Variables:
 563 # indent-tabs-mode: t
 564 # cperl-indent-level: 4
 565 # End:
 566 # vim: syntax=perl ts=8