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