line |
stmt |
bran |
cond |
sub |
time |
code |
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
|
2963
|
|
|
2963
|
29762
|
use strict; |
|
2963
|
|
|
|
9897
|
|
|
2963
|
|
|
|
176508
|
|
23
|
2963
|
|
|
2963
|
23489
|
use warnings; |
|
2963
|
|
|
|
8796
|
|
|
2963
|
|
|
|
230402
|
|
24
|
2963
|
|
|
2963
|
23333
|
use autodie; |
|
2963
|
|
|
|
9038
|
|
|
2963
|
|
|
|
34737
|
|
25
|
|
|
|
|
|
|
26
|
2963
|
|
|
2963
|
28112503
|
use Lintian::Relation; |
|
2963
|
|
|
|
9862
|
|
|
2963
|
|
|
|
271523
|
|
27
|
2963
|
|
|
2963
|
26630
|
use Lintian::Tags qw(tag); |
|
2963
|
|
|
|
8828
|
|
|
2963
|
|
|
|
225154
|
|
28
|
2963
|
|
|
2963
|
26723
|
use Lintian::Util qw(read_dpkg_control :constants $PKGNAME_REGEX); |
|
2963
|
|
|
|
8908
|
|
|
2963
|
|
|
|
21645937
|
|
29
|
|
|
|
|
|
|
30
|
|
|
|
|
|
# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf |
31
|
|
|
|
|
|
# version 1.5.24. Added indices for cdebconf (indicates sort order for |
32
|
|
|
|
|
|
# choices); debconf doesn't support it, but it ignores it, which is safe |
33
|
|
|
|
|
|
# behavior. Likewise, help is supported as of cdebconf 0.143 but is not yet |
34
|
|
|
|
|
|
# supported by debconf. |
35
|
|
|
|
|
|
my %template_fields |
36
|
|
|
|
|
|
= map { $_ => 1 } qw(template type choices indices default description help); |
37
|
|
|
|
|
|
|
38
|
|
|
|
|
|
# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf |
39
|
|
|
|
|
|
# version 1.5.24. |
40
|
|
|
|
|
|
my %valid_types = map { $_ => 1 } qw( |
41
|
|
|
|
|
|
string |
42
|
|
|
|
|
|
password |
43
|
|
|
|
|
|
boolean |
44
|
|
|
|
|
|
select |
45
|
|
|
|
|
|
multiselect |
46
|
|
|
|
|
|
note |
47
|
|
|
|
|
|
error |
48
|
|
|
|
|
|
title |
49
|
|
|
|
|
|
text); |
50
|
|
|
|
|
|
|
51
|
|
|
|
|
|
# From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to |
52
|
|
|
|
|
|
# date with debconf version 1.5.24. |
53
|
|
|
|
|
|
my %valid_priorities = map { $_ => 1 } qw(low medium high critical); |
54
|
|
|
|
|
|
|
55
|
|
|
|
|
|
# All the packages that provide debconf functionality. Anything using debconf |
56
|
|
|
|
|
|
# needs to have dependencies that satisfy one of these. |
57
|
|
|
|
|
|
my $ANY_DEBCONF = Lintian::Relation->new( |
58
|
|
|
|
|
|
join( |
59
|
|
|
|
|
|
' | ', qw(debconf debconf-2.0 cdebconf |
60
|
|
|
|
|
|
cdebconf-udeb libdebconfclient0 libdebconfclient0-udeb) |
61
|
|
|
|
|
|
)); |
62
|
|
|
|
|
|
|
63
|
|
|
|
|
|
sub run { |
64
|
8438
|
|
|
8438
|
67410
|
my ($pkg, $type, $info) = @_; |
65
|
8438
|
|
|
|
43273
|
my ($seenconfig, $seentemplates, $usespreinst); |
66
|
|
|
|
|
|
|
67
|
8438
|
100
|
|
|
55428
|
if ($type eq 'source') { |
68
|
2852
|
|
|
|
22115
|
my @binaries = $info->binaries; |
69
|
2852
|
|
|
|
14439
|
my @files = map { "$_.templates" } @binaries; |
|
5961
|
|
|
|
32129
|
|
70
|
2852
|
|
|
|
19102
|
push @files, 'templates'; |
71
|
|
|
|
|
|
|
72
|
2852
|
|
|
|
17663
|
foreach my $file (@files) { |
73
|
8813
|
|
|
|
32103
|
my $dfile = "debian/$file"; |
74
|
8813
|
|
|
|
41153
|
my $templates_file = $info->index_resolved_path($dfile); |
75
|
8813
|
|
|
|
35927
|
my $binary = $file; |
76
|
8813
|
|
|
|
79294
|
$binary =~ s/\.?templates$//; |
77
|
|
|
|
|
|
# Single binary package (so @files contains "templates" and |
78
|
|
|
|
|
|
# "binary.templates")? |
79
|
8813
|
100
|
100
|
|
83032
|
if (!$binary && @files == 2) { |
80
|
2155
|
|
|
|
10708
|
$binary = $binaries[0]; |
81
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
83
|
8813
|
100
|
66
|
|
47212
|
if ($templates_file and $templates_file->is_open_ok) { |
84
|
186
|
|
|
|
1992
|
my @templates; |
85
|
186
|
|
|
|
592
|
eval { |
86
|
|
|
|
|
|
@templates |
87
|
186
|
|
|
|
1155
|
= read_dpkg_control($templates_file->fs_path, |
88
|
|
|
|
|
|
DCTRL_DEBCONF_TEMPLATE); |
89
|
|
|
|
|
|
}; |
90
|
186
|
100
|
|
|
1186
|
if ($@) { |
91
|
8
|
|
|
|
24
|
chomp $@; |
92
|
8
|
|
|
|
48
|
$@ =~ s/^internal error: //; |
93
|
8
|
|
|
|
32
|
$@ =~ s/^syntax error in //; |
94
|
8
|
|
|
|
112
|
tag 'syntax-error-in-debconf-template', "$file: $@"; |
95
|
8
|
|
|
|
48
|
next; |
96
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
98
|
178
|
|
|
|
751
|
foreach my $template (@templates) { |
99
|
692
|
100
|
100
|
|
6386
|
if ( exists $template->{template} |
100
|
|
|
|
|
|
and exists $template->{_choices}) { |
101
|
27
|
|
|
|
432
|
tag 'template-uses-unsplit-choices', |
102
|
|
|
|
|
|
"$binary - $template->{template}"; |
103
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
108
|
|
|
|
|
|
# The remainder of the checks are for binary packages, so we exit now |
109
|
2852
|
|
|
|
18404
|
return; |
110
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
112
|
5586
|
|
|
|
98070
|
my $preinst = $info->control_index('preinst'); |
113
|
5586
|
|
|
|
44709
|
my $ctrl_config = $info->control_index('config'); |
114
|
5586
|
|
|
|
38510
|
my $ctrl_templates = $info->control_index('templates'); |
115
|
|
|
|
|
|
|
116
|
5586
|
50
|
66
|
|
49403
|
if ($preinst and $preinst->is_file and $preinst->is_open_ok) { |
|
|
|
66
|
|
|
|
117
|
165
|
|
|
|
2082
|
my $fd = $preinst->open; |
118
|
165
|
|
|
|
5177
|
while (<$fd>) { |
119
|
2473
|
|
|
|
9738
|
s/\#.*//; # Not perfect for Perl, but should be OK |
120
|
2473
|
100
|
66
|
|
26653
|
if ( m,/usr/share/debconf/confmodule, |
121
|
|
|
|
|
|
or m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) { |
122
|
25
|
|
|
|
77
|
$usespreinst=1; |
123
|
25
|
|
|
|
125
|
last; |
124
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
} |
126
|
165
|
|
|
|
1733
|
close($fd); |
127
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
129
|
5586
|
100
|
66
|
|
288879
|
$seenconfig = 1 if $ctrl_config and $ctrl_config->is_file; |
130
|
5586
|
100
|
66
|
|
39763
|
$seentemplates = 1 if $ctrl_templates and $ctrl_templates->is_file; |
131
|
|
|
|
|
|
|
132
|
|
|
|
|
|
# This still misses packages that use debconf only in the postrm. |
133
|
|
|
|
|
|
# Packages that ask debconf questions in the postrm should load |
134
|
|
|
|
|
|
# the confmodule in the postinst so that debconf can register |
135
|
|
|
|
|
|
# their templates. |
136
|
5586
|
100
|
100
|
|
130420
|
return unless $seenconfig or $seentemplates or $usespreinst; |
|
|
|
66
|
|
|
|
137
|
|
|
|
|
|
|
138
|
|
|
|
|
|
# parse depends info for later checks |
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
# Consider every package to depend on itself. |
141
|
162
|
|
|
|
767
|
my $selfrel; |
142
|
162
|
50
|
|
|
7089
|
if (defined $info->field('version')) { |
143
|
162
|
|
|
|
1083
|
$_ = $info->field('version'); |
144
|
162
|
|
|
|
1287
|
$selfrel = "$pkg (= $_)"; |
145
|
|
|
|
|
|
} else { |
146
|
0
|
|
|
|
0
|
$selfrel = "$pkg"; |
147
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
149
|
|
|
|
|
|
# Include self and provides as a package providing debconf presumably |
150
|
|
|
|
|
|
# satisfies its own use of debconf (if any). |
151
|
162
|
|
|
|
1804
|
my $selfrelation |
152
|
|
|
|
|
|
= Lintian::Relation->and($info->relation('provides'), $selfrel); |
153
|
162
|
|
|
|
1625
|
my $alldependencies |
154
|
|
|
|
|
|
= Lintian::Relation->and($info->relation('strong'), $selfrelation); |
155
|
|
|
|
|
|
|
156
|
|
|
|
|
|
# See if the package depends on dbconfig-common. Packages that do |
157
|
|
|
|
|
|
# are allowed to have a config file with no templates, since they |
158
|
|
|
|
|
|
# use the dbconfig-common templates. |
159
|
162
|
|
|
|
1750
|
my $usesdbconfig = $alldependencies->implies('dbconfig-common'); |
160
|
|
|
|
|
|
|
161
|
|
|
|
|
|
# Check that both debconf control area files are present. |
162
|
162
|
100
|
100
|
|
6038
|
if ($seenconfig and not $seentemplates and not $usesdbconfig) { |
|
|
100
|
66
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
163
|
17
|
|
|
|
194
|
tag 'no-debconf-templates'; |
164
|
|
|
|
|
|
} elsif ($seentemplates |
165
|
|
|
|
|
|
and not $seenconfig |
166
|
|
|
|
|
|
and not $usespreinst |
167
|
|
|
|
|
|
and $type ne 'udeb') { |
168
|
31
|
|
|
|
387
|
tag 'no-debconf-config'; |
169
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
171
|
162
|
100
|
100
|
|
2738
|
if ($seenconfig and not $ctrl_config->is_executable) { |
172
|
17
|
|
|
|
149
|
tag 'debconf-config-not-executable'; |
173
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
175
|
|
|
|
|
|
# Lots of template checks. |
176
|
|
|
|
|
|
|
177
|
162
|
|
|
|
968
|
my (@templates, %potential_db_abuse, @templates_seen); |
178
|
|
|
|
|
|
|
179
|
162
|
100
|
|
|
882
|
if ($seentemplates) { |
180
|
145
|
|
|
|
566
|
eval { |
181
|
|
|
|
|
|
# $seentemplates (above) will be false if $ctrl_templates is a |
182
|
|
|
|
|
|
# symlink or not a file, so this should be safe without |
183
|
|
|
|
|
|
# (re-checking) with -f/-l. |
184
|
|
|
|
|
|
@templates |
185
|
145
|
|
|
|
1368
|
= read_dpkg_control($ctrl_templates->fs_path, |
186
|
|
|
|
|
|
DCTRL_DEBCONF_TEMPLATE); |
187
|
|
|
|
|
|
}; |
188
|
145
|
100
|
|
|
1187
|
if ($@) { |
189
|
8
|
|
|
|
40
|
chomp $@; |
190
|
8
|
|
|
|
64
|
$@ =~ s/^internal error: //; |
191
|
8
|
|
|
|
48
|
$@ =~ s/^syntax error in //; |
192
|
8
|
|
|
|
128
|
tag 'syntax-error-in-debconf-template', "templates: $@"; |
193
|
8
|
|
|
|
40
|
@templates = (); |
194
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
197
|
162
|
|
|
|
1023
|
foreach my $template (@templates) { |
198
|
547
|
|
|
|
1628
|
my $isselect = ''; |
199
|
|
|
|
|
|
|
200
|
547
|
100
|
|
|
2004
|
if (not exists $template->{template}) { |
201
|
8
|
|
|
|
136
|
tag 'no-template-name'; |
202
|
8
|
|
|
|
72
|
$template->{template} = 'no-template-name'; |
203
|
|
|
|
|
|
} else { |
204
|
539
|
|
|
|
1755
|
push @templates_seen, $template->{template}; |
205
|
539
|
100
|
|
|
4317
|
if ($template->{template}!~m|[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])|) { |
206
|
8
|
|
|
|
72
|
tag 'malformed-template-name', "$template->{template}"; |
207
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
210
|
547
|
100
|
|
|
4770
|
if (not exists $template->{type}) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
211
|
22
|
|
|
|
140
|
tag 'no-template-type', "$template->{template}"; |
212
|
|
|
|
|
|
} elsif (not $valid_types{$template->{type}}) { |
213
|
8
|
|
|
|
64
|
tag 'unknown-template-type', "$template->{type}"; |
214
|
|
|
|
|
|
} elsif ($template->{type} eq 'select') { |
215
|
76
|
|
|
|
212
|
$isselect = 1; |
216
|
|
|
|
|
|
} elsif ($template->{type} eq 'multiselect') { |
217
|
28
|
|
|
|
140
|
$isselect = 1; |
218
|
|
|
|
|
|
} elsif ($template->{type} eq 'boolean') { |
219
|
|
|
|
|
|
tag 'boolean-template-has-bogus-default', |
220
|
|
|
|
|
|
"$template->{template} $template->{default}" |
221
|
|
|
|
|
|
if defined $template->{default} |
222
|
|
|
|
|
|
and $template->{default} ne 'true' |
223
|
120
|
100
|
66
|
|
1042
|
and $template->{default} ne 'false'; |
|
|
|
100
|
|
|
|
224
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
226
|
547
|
100
|
66
|
|
3029
|
if ($template->{choices} && ($template->{choices} !~ /^\s*$/)) { |
227
|
110
|
|
|
|
548
|
my $nrchoices = count_choices($template->{choices}); |
228
|
110
|
|
|
|
512
|
for my $key (keys %$template) { |
229
|
524
|
100
|
|
|
1476
|
if ($key =~ /^choices-/) { |
230
|
44
|
100
|
66
|
|
540
|
if (!$template->{$key} || ($template->{$key} =~ /^\s*$/o)){ |
231
|
8
|
|
|
|
64
|
tag 'empty-translated-choices', |
232
|
|
|
|
|
|
"$template->{template} $key"; |
233
|
|
|
|
|
|
} |
234
|
44
|
100
|
|
|
156
|
if (count_choices($template->{$key}) != $nrchoices) { |
235
|
22
|
|
|
|
302
|
tag 'mismatch-translated-choices', |
236
|
|
|
|
|
|
"$template->{template} $key"; |
237
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
} |
240
|
110
|
100
|
|
|
786
|
if ($template->{choices} =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i) |
241
|
|
|
|
|
|
{ |
242
|
22
|
|
|
|
174
|
tag 'select-with-boolean-choices', "$template->{template}"; |
243
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
246
|
547
|
100
|
100
|
|
2804
|
if ($isselect and not exists $template->{choices}) { |
247
|
8
|
|
|
|
64
|
tag 'select-without-choices', "$template->{template}"; |
248
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
250
|
547
|
100
|
|
|
4019
|
if (not exists $template->{description}) { |
|
|
100
|
|
|
|
|
251
|
22
|
|
|
|
120
|
tag 'no-template-description', "$template->{template}"; |
252
|
|
|
|
|
|
} elsif ($template->{description}=~m/^\s*(.*?)\s*?\n\s*\1\s*$/) { |
253
|
|
|
|
|
|
# Check for duplication. Should all this be folded into the |
254
|
|
|
|
|
|
# description checks? |
255
|
8
|
|
|
|
72
|
tag 'duplicate-long-description-in-template', |
256
|
|
|
|
|
|
"$template->{template}"; |
257
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
259
|
547
|
|
|
|
1316
|
my %languages; |
260
|
547
|
|
|
|
3737
|
foreach my $field (sort keys %$template) { |
261
|
|
|
|
|
|
# Tests on translations |
262
|
2097
|
|
|
|
7456
|
my ($mainfield, $lang) = split m/-/, $field, 2; |
263
|
2097
|
100
|
|
|
6094
|
if (defined $lang) { |
264
|
296
|
|
|
|
1714
|
$languages{$lang}{$mainfield}=1; |
265
|
|
|
|
|
|
} |
266
|
2097
|
100
|
|
|
9900
|
unless ($template_fields{$mainfield}){ # Ignore language codes here |
267
|
8
|
|
|
|
104
|
tag 'unknown-field-in-templates', |
268
|
|
|
|
|
|
"$template->{template} $field"; |
269
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
272
|
547
|
100
|
66
|
|
4822
|
if ($template->{template} && $template->{type}) { |
273
|
|
|
|
|
|
$potential_db_abuse{$template->{template}} = 1 |
274
|
|
|
|
|
|
if ( ($template->{type} eq 'note') |
275
|
525
|
100
|
100
|
|
5206
|
or ($template->{type} eq 'text')); |
276
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
278
|
|
|
|
|
|
# Check the description against the best practices in the |
279
|
|
|
|
|
|
# Developer's Reference, but skip all templates where the |
280
|
|
|
|
|
|
# short description contains the string "for internal use". |
281
|
547
|
|
|
|
1298
|
my ($short, $extended); |
282
|
547
|
100
|
|
|
1807
|
if (defined $template->{description}) { |
283
|
525
|
|
|
|
2359
|
($short, $extended) = split(/\n/, $template->{description}, 2); |
284
|
525
|
50
|
|
|
2079
|
unless (defined $short) { |
285
|
0
|
|
|
|
0
|
$short = $template->{description}; |
286
|
0
|
|
|
|
0
|
$extended = ''; |
287
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
} else { |
289
|
22
|
|
|
|
158
|
($short, $extended) = ('', ''); |
290
|
|
|
|
|
|
} |
291
|
547
|
|
100
|
|
2100
|
my $ttype = $template->{type} || ''; |
292
|
547
|
100
|
|
|
2351
|
unless ($short =~ /for internal use/i) { |
293
|
533
|
|
|
|
1364
|
my $isprompt = grep { $_ eq $ttype } qw(string password); |
|
1066
|
|
|
|
3472
|
|
294
|
533
|
100
|
|
|
1796
|
if ($isprompt) { |
295
|
111
|
100
|
100
|
|
1814
|
if ( |
|
|
|
100
|
|
|
|
296
|
|
|
|
|
|
$short |
297
|
|
|
|
|
|
&& ( $short !~ m/:$/ |
298
|
|
|
|
|
|
|| $short =~ m/^(what|who|when|where|which|how)/i) |
299
|
|
|
|
|
|
) { |
300
|
22
|
|
|
|
218
|
tag 'malformed-prompt-in-templates', $template->{template}; |
301
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
} |
303
|
533
|
100
|
|
|
1776
|
if ($isselect) { |
304
|
104
|
100
|
|
|
610
|
if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) { |
305
|
|
|
|
|
|
tag 'using-imperative-form-in-templates', |
306
|
36
|
|
|
|
168
|
$template->{template}; |
307
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
} |
309
|
533
|
100
|
|
|
1844
|
if ($ttype eq 'boolean') { |
310
|
106
|
100
|
|
|
614
|
if ($short !~ /\?/) { |
311
|
|
|
|
|
|
tag 'malformed-question-in-templates', |
312
|
36
|
|
|
|
216
|
$template->{template}; |
313
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
} |
315
|
533
|
100
|
100
|
|
3920
|
if (defined($extended) && $extended =~ /[^\?]\?(\s+|$)/) { |
316
|
|
|
|
|
|
tag 'using-question-in-extended-description-in-templates', |
317
|
22
|
|
|
|
176
|
$template->{template}; |
318
|
|
|
|
|
|
} |
319
|
533
|
100
|
|
|
1723
|
if ($ttype eq 'note') { |
320
|
30
|
100
|
|
|
222
|
if ($short =~ /[.?;:]$/) { |
321
|
22
|
|
|
|
162
|
tag 'malformed-title-in-templates', $template->{template}; |
322
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
} |
324
|
533
|
100
|
|
|
2214
|
if (length($short) > 75) { |
325
|
|
|
|
|
|
tag 'too-long-short-description-in-templates', |
326
|
|
|
|
|
|
$template->{template} |
327
|
22
|
50
|
33
|
|
332
|
unless $type eq 'udeb' && $ttype eq 'text'; |
328
|
|
|
|
|
|
} |
329
|
533
|
100
|
|
|
2158
|
if (defined $template->{description}) { |
330
|
511
|
100
|
|
|
9461
|
if ($template->{description} |
331
|
|
|
|
|
|
=~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us)(\Z|\s)/ |
332
|
|
|
|
|
|
) { |
333
|
|
|
|
|
|
tag 'using-first-person-in-templates', |
334
|
22
|
|
|
|
162
|
$template->{template}; |
335
|
|
|
|
|
|
} |
336
|
511
|
100
|
100
|
|
4109
|
if ( $template->{description} =~ /[ \'\"]yes[ \'\",;.]/i |
337
|
|
|
|
|
|
and $ttype eq 'boolean') { |
338
|
|
|
|
|
|
tag 'making-assumptions-about-interfaces-in-templates', |
339
|
22
|
|
|
|
132
|
$template->{template}; |
340
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
343
|
|
|
|
|
|
# Check whether the extended description is too long. |
344
|
533
|
100
|
|
|
2859
|
if ($extended) { |
345
|
174
|
|
|
|
376
|
my $lines = 0; |
346
|
174
|
|
|
|
856
|
for my $string (split("\n", $extended)) { |
347
|
680
|
|
|
|
1656
|
while (length($string) > 80) { |
348
|
0
|
|
|
|
0
|
my $pos = rindex($string, ' ', 80); |
349
|
0
|
0
|
|
|
0
|
if ($pos == -1) { |
350
|
0
|
|
|
|
0
|
$pos = index($string, ' '); |
351
|
|
|
|
|
|
} |
352
|
0
|
0
|
|
|
0
|
if ($pos == -1) { |
353
|
0
|
|
|
|
0
|
$string = ''; |
354
|
|
|
|
|
|
} else { |
355
|
0
|
|
|
|
0
|
$string = substr($string, $pos + 1); |
356
|
0
|
|
|
|
0
|
$lines++; |
357
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
} |
359
|
680
|
|
|
|
1070
|
$lines++; |
360
|
|
|
|
|
|
} |
361
|
174
|
100
|
|
|
866
|
if ($lines > 20) { |
362
|
|
|
|
|
|
tag 'too-long-extended-description-in-templates', |
363
|
22
|
|
|
|
140
|
$template->{template}; |
364
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
369
|
|
|
|
|
|
# Check the maintainer scripts. |
370
|
|
|
|
|
|
|
371
|
162
|
|
|
|
2457
|
my ($config_calls_db_input, $db_purge); |
372
|
162
|
|
|
|
0
|
my (%templates_used, %template_aliases); |
373
|
162
|
|
|
|
735
|
for my $file (qw(config prerm postrm preinst postinst)) { |
374
|
810
|
|
|
|
156610
|
my $potential_makedev = {}; |
375
|
810
|
|
|
|
3998
|
my $path = $info->control_index($file); |
376
|
810
|
100
|
66
|
|
5584
|
if ($path and $path->is_file and $path->is_open_ok) { |
|
|
100
|
66
|
|
|
|
|
|
100
|
|
|
|
|
377
|
414
|
|
|
|
3516
|
my ($usesconfmodule, $obsoleteconfmodule, $db_input, $isdefault); |
378
|
|
|
|
|
|
|
379
|
414
|
|
|
|
2857
|
my $fd = $path->open; |
380
|
|
|
|
|
|
# Only check scripts. |
381
|
414
|
|
|
|
6176
|
my $fl = <$fd>; |
382
|
414
|
50
|
33
|
|
9382
|
unless ($fl && $fl =~ /^\#!/) { |
383
|
0
|
|
|
|
0
|
close($fd); |
384
|
0
|
|
|
|
0
|
next; |
385
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
387
|
414
|
|
|
|
2564
|
while (<$fd>) { |
388
|
7433
|
|
|
|
17339
|
s/#.*//; # Not perfect for Perl, but should be OK |
389
|
7433
|
100
|
|
|
30058
|
next unless m/\S/; |
390
|
4469
|
|
|
|
13175
|
while (s%\\$%%) { |
391
|
77
|
|
|
|
242
|
my $next = <$fd>; |
392
|
77
|
50
|
|
|
210
|
last unless $next; |
393
|
77
|
|
|
|
309
|
$_ .= $next; |
394
|
|
|
|
|
|
} |
395
|
4469
|
100
|
66
|
|
27954
|
if ( m,(?:\.|source)\s+/usr/share/debconf/confmodule, |
396
|
|
|
|
|
|
|| m/(?:use|require)\s+Debconf::Client::ConfModule/) { |
397
|
368
|
|
|
|
1312
|
$usesconfmodule=1; |
398
|
|
|
|
|
|
} |
399
|
4469
|
100
|
100
|
|
25477
|
if ( |
400
|
|
|
|
|
|
not $obsoleteconfmodule |
401
|
|
|
|
|
|
and m,(/usr/share/debconf/confmodule\.sh| |
402
|
|
|
|
|
|
Debian::DebConf::Client::ConfModule),x |
403
|
|
|
|
|
|
) { |
404
|
25
|
|
|
|
268
|
my $cmod = $1; |
405
|
25
|
|
|
|
509
|
tag 'loads-obsolete-confmodule', "$file:$. $cmod"; |
406
|
25
|
|
|
|
109
|
$usesconfmodule = 1; |
407
|
25
|
|
|
|
82
|
$obsoleteconfmodule = 1; |
408
|
|
|
|
|
|
} |
409
|
4469
|
100
|
100
|
|
18330
|
if ($file eq 'config' and m/db_input/) { |
410
|
296
|
|
|
|
849
|
$config_calls_db_input = 1; |
411
|
|
|
|
|
|
} |
412
|
4469
|
100
|
100
|
|
19230
|
if ( $file eq 'postinst' |
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
413
|
|
|
|
|
|
and not $db_input |
414
|
|
|
|
|
|
and m/db_input/ |
415
|
|
|
|
|
|
and not $config_calls_db_input) { |
416
|
|
|
|
|
|
# TODO: Perl? |
417
|
20
|
50
|
|
|
217
|
tag 'postinst-uses-db-input' |
418
|
|
|
|
|
|
unless $type eq 'udeb'; |
419
|
20
|
|
|
|
73
|
$db_input=1; |
420
|
|
|
|
|
|
} |
421
|
4469
|
100
|
|
|
11734
|
if (m%/dev/%) { |
422
|
99
|
|
|
|
423
|
$potential_makedev->{$.} = 1; |
423
|
|
|
|
|
|
} |
424
|
4469
|
100
|
|
|
14121
|
if ( |
425
|
|
|
|
|
|
m/\A \s*(?:db_input|db_text)\s+ |
426
|
|
|
|
|
|
[\"\']? (\S+?) [\"\']? \s+ (\S+)\s/xsm |
427
|
|
|
|
|
|
) { |
428
|
374
|
|
|
|
1994
|
my ($priority, $template) = ($1, $2); |
429
|
374
|
|
|
|
1859
|
$templates_used{$template} = 1; |
430
|
374
|
100
|
|
|
1462
|
if ($priority !~ /^\$\S+$/) { |
431
|
|
|
|
|
|
tag 'unknown-debconf-priority', "$file:$. $1" |
432
|
346
|
100
|
|
|
1522
|
unless ($valid_priorities{$priority}); |
433
|
|
|
|
|
|
tag 'possible-debconf-note-abuse', |
434
|
|
|
|
|
|
"$file:$. $template" |
435
|
|
|
|
|
|
if ( |
436
|
|
|
|
|
|
$potential_db_abuse{$template} |
437
|
|
|
|
|
|
and ( |
438
|
346
|
100
|
33
|
|
4002
|
not($potential_makedev->{($. - 1)} |
|
|
|
66
|
|
|
|
|
|
|
100
|
|
|
|
439
|
|
|
|
|
|
and ($priority eq 'low'))) |
440
|
|
|
|
|
|
and ($priority =~ /^(low|medium)$/)); |
441
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
} |
443
|
4469
|
100
|
|
|
13698
|
if ( |
444
|
|
|
|
|
|
m/ \A \s* (?:db_get|db_set(?:title)?) \s+ |
445
|
|
|
|
|
|
[\"\']? (\S+?) [\"\']? (?:\s|\Z)/xsm |
446
|
|
|
|
|
|
) { |
447
|
64
|
|
|
|
590
|
$templates_used{$1} = 1; |
448
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
# Try to handle Perl somewhat. |
450
|
4469
|
50
|
33
|
|
30642
|
if ( m/^\s*(?:.*=\s*get|set)\s*\(\s*[\"\'](\S+?)[\"\']/ |
451
|
|
|
|
|
|
|| m/\b(?:metaget|settitle)\s*\(\s*[\"\'](\S+?)[\"\']/) { |
452
|
0
|
|
|
|
0
|
$templates_used{$1} = 1; |
453
|
|
|
|
|
|
} |
454
|
4469
|
100
|
|
|
11425
|
if (m/^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/) { |
455
|
14
|
|
|
|
98
|
my ($template, $question) = ($1, $2); |
456
|
14
|
|
|
|
28
|
push @{$template_aliases{$template}}, $question; |
|
14
|
|
|
|
126
|
|
457
|
|
|
|
|
|
} |
458
|
4469
|
100
|
100
|
|
22177
|
if (not $isdefault and m/db_fset.*isdefault/) { |
459
|
|
|
|
|
|
# TODO: Perl? |
460
|
8
|
|
|
|
72
|
tag 'isdefault-flag-is-deprecated', $file; |
461
|
8
|
|
|
|
16
|
$isdefault = 1; |
462
|
|
|
|
|
|
} |
463
|
4469
|
100
|
100
|
|
35352
|
if (not $db_purge and m/db_purge/) { # TODO: Perl? |
464
|
121
|
|
|
|
789
|
$db_purge = 1; |
465
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
468
|
414
|
100
|
100
|
|
3576
|
if ($file eq 'postinst' or $file eq 'config') { |
469
|
232
|
100
|
|
|
1047
|
unless ($usesconfmodule) { |
470
|
35
|
50
|
66
|
|
573
|
tag "$file-does-not-load-confmodule" |
|
|
|
33
|
|
|
|
471
|
|
|
|
|
|
unless ($type eq 'udeb' |
472
|
|
|
|
|
|
|| ($file eq 'postinst' && !$seenconfig)); |
473
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
476
|
414
|
100
|
|
|
1708
|
if ($file eq 'postrm') { |
477
|
|
|
|
|
|
# If we haven't seen db_purge we emit the tag unless the |
478
|
|
|
|
|
|
# package is a debconf provider (in which case db_purge |
479
|
|
|
|
|
|
# won't be available) |
480
|
139
|
100
|
66
|
|
1096
|
unless ($db_purge or $selfrelation->implies($ANY_DEBCONF)) { |
481
|
18
|
|
|
|
81
|
tag 'postrm-does-not-purge-debconf'; |
482
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
485
|
414
|
|
|
|
7457
|
close($fd); |
486
|
|
|
|
|
|
} elsif ($file eq 'postinst') { |
487
|
36
|
50
|
33
|
|
610
|
tag 'postinst-does-not-load-confmodule' |
488
|
|
|
|
|
|
unless ($type eq 'udeb' || !$seenconfig); |
489
|
|
|
|
|
|
} elsif ($file eq 'postrm') { |
490
|
|
|
|
|
|
# Make an exception for debconf providing packages as some of |
491
|
|
|
|
|
|
# them (incl. "debconf" itself) cleans up in prerm and have no |
492
|
|
|
|
|
|
# postrm script at all. |
493
|
23
|
100
|
66
|
|
337
|
tag 'postrm-does-not-purge-debconf' |
494
|
|
|
|
|
|
unless $type eq 'udeb' |
495
|
|
|
|
|
|
or $selfrelation->implies($ANY_DEBCONF); |
496
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
499
|
162
|
|
|
|
9916
|
foreach my $template (@templates_seen) { |
500
|
539
|
|
|
|
1756
|
$template =~ s/\s+\Z//; |
501
|
|
|
|
|
|
|
502
|
539
|
|
|
|
1020
|
my $used = 0; |
503
|
|
|
|
|
|
|
504
|
539
|
100
|
|
|
1802
|
if ($templates_used{$template}) { |
505
|
308
|
|
|
|
807
|
$used = 1; |
506
|
|
|
|
|
|
} else { |
507
|
231
|
|
|
|
425
|
foreach my $alias (@{$template_aliases{$template}}) { |
|
231
|
|
|
|
1293
|
|
508
|
14
|
50
|
|
|
126
|
if ($templates_used{$alias}) { |
509
|
14
|
|
|
|
70
|
$used = 1; |
510
|
14
|
|
|
|
42
|
last; |
511
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
515
|
539
|
100
|
66
|
|
3992
|
unless ($used or $pkg eq 'debconf' or $type eq 'udeb') { |
|
|
|
100
|
|
|
|
516
|
208
|
50
|
33
|
|
1564
|
tag 'unused-debconf-template', $template |
517
|
|
|
|
|
|
unless $template =~ m,^shared/packages-(wordlist|ispell)$, |
518
|
|
|
|
|
|
or $template =~ m,/languages$,; |
519
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
522
|
|
|
|
|
|
# Check that the right dependencies are in the control file. Accept any |
523
|
|
|
|
|
|
# package that might provide debconf functionality. |
524
|
|
|
|
|
|
|
525
|
162
|
100
|
|
|
838
|
if ($usespreinst) { |
526
|
25
|
50
|
|
|
282
|
unless ($info->relation('pre-depends')->implies($ANY_DEBCONF)) { |
527
|
25
|
50
|
|
|
108723
|
tag 'missing-debconf-dependency-for-preinst' |
528
|
|
|
|
|
|
unless $type eq 'udeb'; |
529
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
} else { |
531
|
137
|
100
|
66
|
|
11650
|
unless ($alldependencies->implies($ANY_DEBCONF) or $usesdbconfig) { |
532
|
26
|
|
|
|
5278
|
tag 'missing-debconf-dependency'; |
533
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
536
|
|
|
|
|
|
# Now make sure that no scripts are using debconf as a registry. |
537
|
|
|
|
|
|
# Unfortunately this requires us to unpack to level 2 and grep all the |
538
|
|
|
|
|
|
# scripts in the package. |
539
|
|
|
|
|
|
# the following checks is ignored if the package being checked is debconf |
540
|
|
|
|
|
|
# itself. |
541
|
|
|
|
|
|
|
542
|
162
|
100
|
66
|
|
2769
|
return if ($pkg eq 'debconf') || ($type eq 'udeb'); |
543
|
|
|
|
|
|
|
544
|
153
|
|
|
|
558
|
foreach my $filename (sort keys %{$info->scripts}) { |
|
153
|
|
|
|
1270
|
|
545
|
9
|
|
|
|
72
|
my $path = $info->index_resolved_path($filename); |
546
|
9
|
50
|
33
|
|
54
|
next if not $path or not $path->is_open_ok; |
547
|
9
|
|
|
|
81
|
my $fd = $path->open; |
548
|
9
|
|
|
|
162
|
while (<$fd>) { |
549
|
27
|
|
|
|
180
|
s/#.*//; # Not perfect for Perl, but should be OK |
550
|
27
|
100
|
66
|
|
1314
|
if ( m,/usr/share/debconf/confmodule, |
551
|
|
|
|
|
|
or m/(?:Debconf|Debian::DebConf)::Client::ConfModule/) { |
552
|
9
|
|
|
|
162
|
tag 'debconf-is-not-a-registry', $filename; |
553
|
9
|
|
|
|
27
|
last; |
554
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
} |
556
|
9
|
|
|
|
63
|
close($fd); |
557
|
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
559
|
153
|
|
|
|
3891
|
return; |
560
|
|
|
|
|
|
} # |
561
|
|
|
|
|
|
|
562
|
|
|
|
|
|
# ----------------------------------- |
563
|
|
|
|
|
|
|
564
|
|
|
|
|
|
# Count the number of choices. Splitting code copied from debconf 1.5.8 |
565
|
|
|
|
|
|
# (Debconf::Question). |
566
|
|
|
|
|
|
sub count_choices { |
567
|
154
|
|
|
154
|
436
|
my ($choices) = @_; |
568
|
154
|
|
|
|
300
|
my @items; |
569
|
154
|
|
|
|
348
|
my $item = ''; |
570
|
154
|
|
|
|
1596
|
for my $chunk (split /(\\[, ]|,\s+)/, $choices) { |
571
|
682
|
100
|
|
|
2228
|
if ($chunk =~ /^\\([, ])$/) { |
|
|
100
|
|
|
|
|
572
|
28
|
|
|
|
112
|
$item .= $1; |
573
|
|
|
|
|
|
} elsif ($chunk =~ /^,\s+$/) { |
574
|
240
|
|
|
|
618
|
push(@items, $item); |
575
|
240
|
|
|
|
546
|
$item = ''; |
576
|
|
|
|
|
|
} else { |
577
|
414
|
|
|
|
836
|
$item .= $chunk; |
578
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
} |
580
|
154
|
100
|
|
|
720
|
push(@items, $item) if $item ne ''; |
581
|
154
|
|
|
|
586
|
return scalar(@items); |
582
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
584
|
|
|
|
|
|
1; |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
# Local Variables: |
587
|
|
|
|
|
|
# indent-tabs-mode: nil |
588
|
|
|
|
|
|
# cperl-indent-level: 4 |
589
|
|
|
|
|
|
# End: |
590
|
|
|
|
|
|
# vim: syntax=perl sw=4 sts=4 sr et |