« back to all changes in this revision
Viewing changes to lib/WannaBuild/Database.pm
- browse files at revision 42
- compare with another revision
- download diff
- download tarball
- view history from revision 42
- Committer: Bazaar Package Importer
- Author(s): Lorenzo De Liso
- Date: 2011-05-01 16:55:16 UTC
- mfrom: (8.1.19 upstream) (3.3.17 sid)
- Revision ID: james.westby@ubuntu.com-20110501165516-8g3uwrnhv2bzjt8y
Tags: 0.62.2-1ubuntu1
* Merge from debian unstable, remaining changes:
- debian/patches/do-not-install-debfoster-into-chroots.patch:
do not install debfoster into the chroots because it is in universe and
not needed for package building itself.
- debian/patches/run-pre-build-hooks-as-root.patch:
run pre-build hooks as root (Closes: #607228)
* Now that the package uses a patch system, don't modify the files directly;
instead, put the changes in the respective patches and add the DEP-3
patch tagging guidelines to them.
- debian/patches/do-not-install-debfoster-into-chroots.patch:
do not install debfoster into the chroots because it is in universe and
not needed for package building itself.
- debian/patches/run-pre-build-hooks-as-root.patch:
run pre-build hooks as root (Closes: #607228)
* Now that the package uses a patch system, don't modify the files directly;
instead, put the changes in the respective patches and add the DEP-3
patch tagging guidelines to them.
- files added:
- .pc
- .pc/do-not-install-debfoster-into-chroots.patch
- .pc/do-not-install-debfoster-into-chroots.patch/bin
- .pc/run-pre-build-hooks-as-root.patch
- .pc/run-pre-build-hooks-as-root.patch/lib
- .pc/run-pre-build-hooks-as-root.patch/lib/Sbuild
- debian/patches
- debian/source
- tools
- wrapper
- files removed:
- bin/wanna-build
- lib/Sbuild/DB
- lib/WannaBuild
- files modified:
- ChangeLog
added
removed
lib/WannaBuild/Database.pm
1
# Copyright © 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
2
# Copyright © 2005-2008 Ryan Murray <rmurray@debian.org>
3
# Copyright © 2008 Roger Leigh <rleigh@debian.org
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, but
11
# WITHOUT ANY WARRANTY; without even the implied warranty of
12
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13
# 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, see
17
# <http://www.gnu.org/licenses/>.
18
#
19
#######################################################################
20
21
package Wannabuild::Database;
22
23
use strict;
24
use warnings;
25
26
use POSIX;
27
use Dpkg::Arch;
28
use Sbuild qw(isin usage_error version_less version_lesseq version_eq version_compare);
29
use WannaBuild::Conf qw();
30
use Sbuild::Sysconfig;
31
use Sbuild::DB::Info;
32
use Sbuild::DB::MLDBM;
33
use Sbuild::DB::Postgres;
34
use WannaBuild::Options;
35
36
BEGIN {
37
use Exporter ();
38
our (@ISA, @EXPORT);
39
40
@ISA = qw(Exporter Sbuild::Base);
41
42
@EXPORT = qw();
43
}
44
45
sub new {
46
my $class = shift;
47
my $conf = shift;
48
49
my $self = $class->SUPER::new($conf);
50
bless($self, $class);
51
52
$self->set('Current Database', undef);
53
$self->set('Databases', {});
54
55
$self->set('Mail Logs', '');
56
57
my @curr_time = gmtime();
58
my $ctime = time();
59
60
$self->set('Current Date', strftime("%Y %b %d %H:%M:%S", @curr_time));
61
$self->set('Short Date', strftime("%m/%d/%y", @curr_time));
62
$self->set('Current Time', $ctime);
63
64
# Note: specific contents are only incremented, never initially set.
65
# This might be a bug.
66
$self->set('New Version', {});
67
68
$self->set('Merge Src Version', {});
69
$self->set('Merge Bin Src', {});
70
71
$self->set('Priority Values', {
72
required => -5,
73
important => -4,
74
standard => -3,
75
optional => -2,
76
extra => -1,
77
unknown => -1});
78
79
my $sectval = {
80
libs => -200,
81
'debian-installer' => -199,
82
base => -198,
83
devel => -197,
84
kernel => -196,
85
shells => -195,
86
perl => -194,
87
python => -193,
88
graphics => -192,
89
admin => -191,
90
utils => -190,
91
x11 => -189,
92
editors => -188,
93
net => -187,
94
httpd => -186,
95
mail => -185,
96
news => -184,
97
tex => -183,
98
text => -182,
99
web => -181,
100
vcs => -180,
101
doc => -179,
102
localizations => -178,
103
interpreters => -177,
104
ruby => -176,
105
java => -175,
106
ocaml => -174,
107
lisp => -173,
108
haskell => -172,
109
'cli-mono' => -171,
110
gnome => -170,
111
kde => -169,
112
xfce => -168,
113
gnustep => -167,
114
database => -166,
115
video => -165,
116
debug => -164,
117
games => -163,
118
misc => -162,
119
fonts => -161,
120
otherosfs => -160,
121
oldlibs => -159,
122
libdevel => -158,
123
sound => -157,
124
math => -156,
125
'gnu-r' => -155,
126
science => -154,
127
comm => -153,
128
electronics => -152,
129
hamradio => -151,
130
embedded => -150,
131
php => -149,
132
zope => -148,
133
};
134
foreach my $i (keys %{$sectval}) {
135
$sectval->{"contrib/$i"} = $sectval->{$i}+40;
136
$sectval->{"non-free/$i"} = $sectval->{$i}+80;
137
}
138
$sectval->{'unknown'} = -165;
139
$self->set('Section Values', $sectval);
140
141
$self->set('Category Values', {
142
"none" => -20,
143
"uploaded-fixed-pkg" => -19,
144
"fix-expected" => -18,
145
"reminder-sent" => -17,
146
"nmu-offered" => -16,
147
"easy" => -15,
148
"medium" => -14,
149
"hard" => -13,
150
"compiler-error" => -12});
151
152
return $self;
153
}
154
155
sub run {
156
my $self = shift;
157
158
$self->set_conf('DB_OPERATION', $self->get_conf('DB_CATEGORY') ? "set-failed" : "set-building")
159
if !$self->get_conf('DB_OPERATION'); # default operation
160
$self->set_conf('DB_LIST_ORDER', $self->get_conf('DB_LIST_STATE') eq "failed" ? 'fPcpasn' : 'PScpasn')
161
if (!$self->get_conf('DB_LIST_ORDER') &&
162
(defined($self->get_conf('DB_LIST_STATE')) && $self->get_conf('DB_LIST_STATE')));
163
$self->set_conf('DISTRIBUTION', 'unstable')
164
if !defined($self->get_conf('DISTRIBUTION'));
165
166
die "Bad distribution '" . $self->get_conf('DISTRIBUTION') . "'\n"
167
if !isin($self->get_conf('DISTRIBUTION'), keys %{$self->get_conf('DB_DISTRIBUTIONS')});
168
169
if ($self->get_conf('VERBOSE')) {
170
print "wanna-build (Debian sbuild) $Sbuild::Sysconfig::version ($Sbuild::Sysconfig::release_date) on " . $self->get_conf('HOSTNAME') . "\n";
171
print "Using database " . $self->get_conf('DB_BASE_NAME') . '/' . $self->get_conf('DISTRIBUTION') . "\n"
172
}
173
174
if (!@ARGV && !isin($self->get_conf('DB_OPERATION'),
175
qw(list merge-quinn merge-partial-quinn import
176
export merge-packages manual-edit
177
maintlock-create merge-sources
178
maintlock-remove clean-db))) {
179
usage_error("wanna-build", "No packages given.");
180
}
181
182
if (!$self->get_conf('DB_FAIL_REASON')) {
183
if ($self->get_conf('DB_OPERATION') eq "set-failed" && !$self->get_conf('DB_CATEGORY')) {
184
print "Enter reason for failing (end with '.' alone on ".
185
"its line):\n";
186
my $log = "";
187
my $line;
188
while(!eof(STDIN)) {
189
$line = <STDIN>;
190
last if $line eq ".\n";
191
$log .= $line;
192
}
193
chomp($log);
194
$self->set_conf('DB_FAIL_REASON', $log);
195
} elsif ($self->get_conf('DB_OPERATION') eq "set-dep-wait") {
196
print "Enter dependencies (one line):\n";
197
my $line;
198
while( !$line && !eof(STDIN) ) {
199
chomp( $line = <STDIN> );
200
}
201
die "No dependencies given\n" if !$line;
202
$self->set_conf('DB_FAIL_REASON'. $line);
203
} elsif ($self->get_conf('DB_OPERATION') eq "set-binary-nmu" and $self->get_conf('DB_BIN_NMU_VERSION') > 0) {
204
print "Enter changelog entry (one line):\n";
205
my $line;
206
while( !$line && !eof(STDIN) ) {
207
chomp( $line = <STDIN> );
208
}
209
die "No changelog entry given\n" if !$line;
210
$self->set_conf('DB_FAIL_REASON', $line);
211
}
212
}
213
if ($self->get_conf('DB_OPERATION') eq "maintlock-create") {
214
$self->create_maintlock();
215
exit 0;
216
}
217
if ($self->get_conf('DB_OPERATION') eq "maintlock-remove") {
218
$self->remove_maintlock();
219
exit 0;
220
}
221
$self->waitfor_maintlock() if $self->get_conf('DB_OPERATION') !~ /^(?:merge-|clean-db$)/;
222
223
if (!-f $self->db_filename( $self->get_conf('DISTRIBUTION') ) && !$self->get_conf('DB_CREATE')) {
224
die "Database for " . $self->get_conf('DISTRIBUTION') . " doesn't exist\n";
225
}
226
227
# TODO: Use 'Databases' only.
228
$self->set('Current Database',
229
$self->open_db($self->get_conf('DISTRIBUTION')));
230
231
$self->process();
232
233
if ($self->get('Mail Logs') &&
234
defined($self->get_conf('DB_LOG_MAIL')) && $self->get_conf('DB_LOG_MAIL')) {
235
$self->send_mail($self->get_conf('DB_LOG_MAIL'),
236
"wanna-build " . $self->get_conf('DISTRIBUTION') .
237
" state changes " . $self->get('Current Date'),
238
"State changes at " . $self->get('Current Date') .
239
" for distribution ".
240
$self->get_conf('DISTRIBUTION') . ":\n\n".
241
$self->get('Mail Logs') . "\n");
242
}
243
244
return 0;
245
}
246
247
sub process {
248
my $self = shift;
249
250
SWITCH: foreach ($self->get_conf('DB_OPERATION')) {
251
/^set-(.+)/ && do {
252
$self->add_packages( $1, @ARGV );
253
last SWITCH;
254
};
255
/^list/ && do {
256
$self->list_packages($self->get_conf('DB_LIST_STATE'));
257
last SWITCH;
258
};
259
/^info/ && do {
260
$self->info_packages( @ARGV );
261
last SWITCH;
262
};
263
/^forget-user/ && do {
264
die "This operation is restricted to admin users\n"
265
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
266
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
267
$self->forget_users( @ARGV );
268
last SWITCH;
269
};
270
/^forget/ && do {
271
$self->forget_packages( @ARGV );
272
last SWITCH;
273
};
274
/^merge-partial-quinn/ && do {
275
die "This operation is restricted to admin users\n"
276
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
277
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
278
$self->parse_quinn_diff(1);
279
last SWITCH;
280
};
281
/^merge-quinn/ && do {
282
die "This operation is restricted to admin users\n"
283
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
284
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
285
$self->parse_quinn_diff(0);
286
last SWITCH;
287
};
288
/^merge-packages/ && do {
289
die "This operation is restricted to admin users\n"
290
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
291
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
292
$self->parse_packages();
293
last SWITCH;
294
};
295
/^merge-sources/ && do {
296
die "This operation is restricted to admin users\n"
297
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
298
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
299
$self->parse_sources(0);
300
last SWITCH;
301
};
302
/^pretend-avail/ && do {
303
$self->pretend_avail( @ARGV );
304
last SWITCH;
305
};
306
/^merge-all/ && do {
307
die "This operation is restricted to admin users\n"
308
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
309
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
310
my @ARGS = @ARGV;
311
@ARGV = ( $ARGS[0] );
312
my $pkgs = $self->parse_packages();
313
@ARGV = ( $ARGS[1] );
314
$self->parse_quinn_diff(0);
315
@ARGV = ( $ARGS[2] );
316
my $build_deps = $self->parse_sources(1);
317
$self->auto_dep_wait( $build_deps, $pkgs );
318
$self->get('Current Database')->clean();
319
last SWITCH;
320
};
321
/^import/ && do {
322
die "This operation is restricted to admin users\n"
323
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
324
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
325
$self->get('Current Database')->clear(); # clear all current contents
326
$self->get('Current Database')->restore($self->get_conf('DB_IMPORT_FILE'));
327
last SWITCH;
328
};
329
/^export/ && do {
330
$self->get('Current Database')->dump($self->get_conf('DB_EXPORT_FILE'));
331
last SWITCH;
332
};
333
/^manual-edit/ && do {
334
die "This operation is restricted to admin users\n"
335
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
336
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
337
my $tmpfile_pattern = "/tmp/wanna-build-" . $self->get_conf('DISTRIBUTION') . ".$$-";
338
my ($tmpfile, $i);
339
for( $i = 0;; ++$i ) {
340
$tmpfile = $tmpfile_pattern . $i;
341
last if ! -e $tmpfile;
342
}
343
$self->get('Current Database')->dump($tmpfile);
344
my $editor = $ENV{'VISUAL'} ||
345
"/usr/bin/sensible-editor";
346
system "$editor $tmpfile";
347
$self->get('Current Database')->clear(); # clear all current contents
348
$self->get('Current Database')->restore($tmpfile);
349
unlink( $tmpfile );
350
last SWITCH;
351
};
352
/^clean-db/ && do {
353
die "This operation is restricted to admin users\n"
354
if (defined @{$self->get_conf('DB_ADMIN_USERS')} and
355
!isin( $self->get_conf('USERNAME'), @{$self->get_conf('DB_ADMIN_USERS')}));
356
$self->get('Current Database')->clean();
357
last SWITCH;
358
};
359
360
die "Unexpected operation mode " . $self->get_conf('DB_OPERATION') . "\n";
361
}
362
if (not -t and $self->get_conf('DB_USER') =~ /-/) {
363
my $ui = $self->get('Current Database')->get_user($self->get_conf('DB_USER'));
364
$ui = {} if (!defined($ui));
365
366
$ui->{'Last-Seen'} = $self->get('Current Date');
367
$ui->{'User'} = $self->get_conf('DB_USER');
368
369
$self->get('Current Database')->set_user($ui);
370
}
371
372
}
373
374
sub add_packages {
375
my $self = shift;
376
my $newstate = shift;
377
378
my( $package, $name, $version, $ok, $reason );
379
380
foreach $package (@_) {
381
$package =~ s,^.*/,,; # strip path
382
$package =~ s/\.(dsc|diff\.gz|tar\.gz|deb)$//; # strip extension
383
$package =~ s/_[a-zA-Z\d-]+\.changes$//; # strip extension
384
if ($package =~ /^([\w\d.+-]+)_([\w\d:.+~-]+)/) {
385
($name,$version) = ($1,$2);
386
}
387
else {
388
warn "$package: can't extract package name and version ".
389
"(bad format)\n";
390
next;
391
}
392
393
if ($self->get_conf('DB_OPERATION') eq "set-building") {
394
$self->add_one_building( $name, $version );
395
}
396
elsif ($self->get_conf('DB_OPERATION') eq "set-built") {
397
$self->add_one_built( $name, $version );
398
}
399
elsif ($self->get_conf('DB_OPERATION') eq "set-attempted") {
400
$self->add_one_attempted( $name, $version );
401
}
402
elsif ($self->get_conf('DB_OPERATION') eq "set-uploaded") {
403
$self->add_one_uploaded( $name, $version );
404
}
405
elsif ($self->get_conf('DB_OPERATION') eq "set-failed") {
406
$self->add_one_failed( $name, $version );
407
}
408
elsif ($self->get_conf('DB_OPERATION') eq "set-not-for-us") {
409
$self->add_one_notforus( $name, $version );
410
}
411
elsif ($self->get_conf('DB_OPERATION') eq "set-needs-build") {
412
$self->add_one_needsbuild( $name, $version );
413
}
414
elsif ($self->get_conf('DB_OPERATION') eq "set-dep-wait") {
415
$self->add_one_depwait( $name, $version );
416
}
417
elsif ($self->get_conf('DB_OPERATION') eq "set-build-priority") {
418
$self->set_one_buildpri( $name, $version, 'BuildPri' );
419
}
420
elsif ($self->get_conf('DB_OPERATION') eq "set-permanent-build-priority") {
421
$self->set_one_buildpri( $name, $version, 'PermBuildPri' );
422
}
423
elsif ($self->get_conf('DB_OPERATION') eq "set-binary-nmu") {
424
$self->set_one_binnmu( $name, $version );
425
}
426
}
427
}
428
429
sub add_one_building {
430
my $self = shift;
431
my $name = shift;
432
my $version = shift;
433
434
my( $ok, $reason );
435
436
$ok = 1;
437
my $pkg = $self->get('Current Database')->get_package($name);
438
if (defined($pkg)) {
439
if ($pkg->{'State'} eq "Not-For-Us") {
440
$ok = 0;
441
$reason = "not suitable for this architecture";
442
}
443
elsif ($pkg->{'State'} =~ /^Dep-Wait/) {
444
$ok = 0;
445
$reason = "not all source dependencies available yet";
446
}
447
elsif ($pkg->{'State'} eq "Uploaded" &&
448
(version_lesseq($version, $pkg->{'Version'}))) {
449
$ok = 0;
450
$reason = "already uploaded by $pkg->{'Builder'}";
451
$reason .= " (in newer version $pkg->{'Version'})"
452
if !version_eq($pkg, $version);
453
}
454
elsif ($pkg->{'State'} eq "Installed" &&
455
version_less($version,$pkg->{'Version'})) {
456
if ($self->get_conf('DB_OVERRIDE')) {
457
print "$name: Warning: newer version $pkg->{'Version'} ".
458
"already installed, but overridden.\n";
459
}
460
else {
461
$ok = 0;
462
$reason = "newer version $pkg->{'Version'} already in ".
463
"archive; doesn't need rebuilding";
464
print "$name: Note: If the following is due to an epoch ",
465
" change, use --override\n";
466
}
467
}
468
elsif ($pkg->{'State'} eq "Installed" &&
469
$self->pkg_version_eq($pkg,$version)) {
470
$ok = 0;
471
$reason = "is up-to-date in the archive; doesn't need rebuilding";
472
}
473
elsif ($pkg->{'State'} eq "Needs-Build" &&
474
version_less($version,$pkg->{'Version'})) {
475
if ($self->get_conf('DB_OVERRIDE')) {
476
print "$name: Warning: newer version $pkg->{'Version'} ".
477
"needs building, but overridden.";
478
}
479
else {
480
$ok = 0;
481
$reason = "newer version $pkg->{'Version'} needs building, ".
482
"not $version";
483
}
484
}
485
elsif (isin($pkg->{'State'},qw(Building Built Build-Attempted))) {
486
if (version_less($pkg->{'Version'},$version)) {
487
print "$name: Warning: Older version $pkg->{'Version'} ",
488
"is being built by $pkg->{'Builder'}\n";
489
if ($pkg->{'Builder'} ne $self->get_conf('DB_USER')) {
490
$self->send_mail(
491
$pkg->{'Builder'},
492
"package takeover in newer version",
493
"You are building package '$name' in ".
494
"version $version\n".
495
"(as far as I'm informed).\n".
496
$self->get_conf('DB_USER') . " now has taken the newer ".
497
"version $version for building.".
498
"You can abort the build if you like.\n");
499
}
500
}
501
else {
502
if ($self->get_conf('DB_OVERRIDE')) {
503
print "User $pkg->{'Builder'} had already ",
504
"taken the following package,\n",
505
"but overriding this as you request:\n";
506
$self->send_mail(
507
$pkg->{'Builder'}, "package takeover",
508
"The package '$name' (version $version) that ".
509
"was locked by you\n".
510
"has been taken over by " . $self->get_conf('DB_USER') . "\n");
511
}
512
elsif ($pkg->{'Builder'} eq $self->get_conf('DB_USER')) {
513
print "$name: Note: already taken by you.\n";
514
print "$name: ok\n" if $self->get_conf('VERBOSE');
515
return;
516
}
517
else {
518
$ok = 0;
519
$reason = "already taken by $pkg->{'Builder'}";
520
$reason .= " (in newer version $pkg->{'Version'})"
521
if !version_eq($pkg->{'Version'}, $version);
522
}
523
}
524
}
525
elsif ($pkg->{'State'} =~ /^Failed/ &&
526
$self->pkg_version_eq($pkg, $version)) {
527
if ($self->get_conf('DB_OVERRIDE')) {
528
print "The following package previously failed ",
529
"(by $pkg->{'Builder'})\n",
530
"but overriding this as you request:\n";
531
$self->send_mail(
532
$pkg->{'Builder'}, "failed package takeover",
533
"The package '$name' (version $version) that ".
534
"is locked by you\n".
535
"and has failed previously has been taken over ".
536
"by " . $self->get_conf('DB_USER') . "\n")
537
if $pkg->{'Builder'} ne $self->get_conf('DB_USER');
538
}
539
else {
540
$ok = 0;
541
$reason = "build of $version failed previously:\n ";
542
$reason .= join( "\n ", split( "\n", $pkg->{'Failed'} ));
543
$reason .= "\nalso the package doesn't need builing"
544
if $pkg->{'State'} eq 'Failed-Removed';
545
}
546
}
547
}
548
if ($ok) {
549
my $ok = 'ok';
550
if ($pkg->{'Binary-NMU-Version'}) {
551
print "$name: Warning: needs binary NMU $pkg->{'Binary-NMU-Version'}\n" .
552
"$pkg->{'Binary-NMU-Changelog'}\n";
553
$ok = 'aok';
554
} else {
555
print "$name: Warning: Previous version failed!\n"
556
if $pkg->{'Previous-State'} =~ /^Failed/ ||
557
$pkg->{'State'} =~ /^Failed/;
558
}
559
$self->change_state( $pkg, 'Building' );
560
$pkg->{'Package'} = $name;
561
$pkg->{'Version'} = $version;
562
$pkg->{'Builder'} = $self->get_conf('DB_USER');
563
$self->log_ta( $pkg, "--take" );
564
$self->get('Current Database')->set_package($pkg);
565
print "$name: $ok\n" if $self->get_conf('VERBOSE');
566
}
567
else {
568
print "$name: NOT OK!\n $reason\n";
569
}
570
}
571
572
sub add_one_attempted {
573
my $self = shift;
574
my $name = shift;
575
my $version = shift;
576
577
my $pkg = $self->get('Current Database')->get_package($name);
578
579
if (!defined($pkg)) {
580
print "$name: not registered yet.\n";
581
return;
582
}
583
584
if ($pkg->{'State'} ne "Building" ) {
585
print "$name: not taken for building (state is $pkg->{'State'}). ",
586
"Skipping.\n";
587
return;
588
}
589
if ($pkg->{'Builder'} ne $self->get_conf('USERNAME')) {
590
print "$name: not taken by you, but by $pkg->{'Builder'}. Skipping.\n";
591
return;
592
}
593
elsif ( !$self->pkg_version_eq($pkg, $version) ) {
594
print "$name: version mismatch ".
595
"$(pkg->{'Version'} ".
596
"by $pkg->{'Builder'})\n";
597
return;
598
}
599
600
$self->change_state( $pkg, 'Build-Attempted' );
601
$self->log_ta( $pkg, "--attempted" );
602
$self->get('Current Database')->set_package($pkg);
603
print "$name: registered as uploaded\n" if $self->get_conf('VERBOSE');
604
}
605
606
sub add_one_built {
607
my $self = shift;
608
my $name = shift;
609
my $version = shift;
610
611
my $pkg = $self->get('Current Database')->get_package($name);
612
613
if (!defined($pkg)) {
614
print "$name: not registered yet.\n";
615
return;
616
}
617
618
if ($pkg->{'State'} ne "Building" ) {
619
print "$name: not taken for building (state is $pkg->{'State'}). ",
620
"Skipping.\n";
621
return;
622
}
623
if ($pkg->{'Builder'} ne $self->get_conf('USERNAME')) {
624
print "$name: not taken by you, but by $pkg->{'Builder'}. Skipping.\n";
625
return;
626
}
627
elsif ( !$self->pkg_version_eq($pkg, $version) ) {
628
print "$name: version mismatch ".
629
"$(pkg->{'Version'} ".
630
"by $pkg->{'Builder'})\n";
631
return;
632
}
633
$self->change_state( $pkg, 'Built' );
634
$self->log_ta( $pkg, "--built" );
635
$self->get('Current Database')->set_package($pkg);
636
print "$name: registered as built\n" if $self->get_conf('VERBOSE');
637
}
638
639
sub add_one_uploaded {
640
my $self = shift;
641
my $name = shift;
642
my $version = shift;
643
644
my $pkg = $self->get('Current Database')->get_package($name);
645
646
if (!defined($pkg)) {
647
print "$name: not registered yet.\n";
648
return;
649
}
650
651
if ($pkg->{'State'} eq "Uploaded" &&
652
$self->pkg_version_eq($pkg,$version)) {
653
print "$name: already uploaded\n";
654
return;
655
}
656
if (!isin( $pkg->{'State'}, qw(Building Built Build-Attempted))) {
657
print "$name: not taken for building (state is $pkg->{'State'}). ",
658
"Skipping.\n";
659
return;
660
}
661
if ($pkg->{'Builder'} ne $self->get_conf('DB_USER')) {
662
print "$name: not taken by you, but by $pkg->{'Builder'}. Skipping.\n";
663
return;
664
}
665
# strip epoch -- buildd-uploader used to go based on the filename.
666
# (to remove at some point)
667
my $pkgver;
668
($pkgver = $pkg->{'Version'}) =~ s/^\d+://;
669
$version =~ s/^\d+://; # for command line use
670
if ($pkg->{'Binary-NMU-Version'} ) {
671
my $nmuver = binNMU_version($pkgver, $pkg->{'Binary-NMU-Version'});
672
if (!version_eq( $nmuver, $version )) {
673
print "$name: version mismatch ($nmuver registered). ",
674
"Skipping.\n";
675
return;
676
}
677
} elsif (!version_eq($pkgver, $version)) {
678
print "$name: version mismatch ($pkg->{'Version'} registered). ",
679
"Skipping.\n";
680
return;
681
}
682
683
$self->change_state( $pkg, 'Uploaded' );
684
$self->log_ta( $pkg, "--uploaded" );
685
$self->get('Current Database')->set_package($pkg);
686
print "$name: registered as uploaded\n" if $self->get_conf('VERBOSE');
687
}
688
689
sub add_one_failed {
690
my $self = shift;
691
my $name = shift;
692
my $version = shift;
693
694
my ($state, $cat);
695
my $pkg = $self->get('Current Database')->get_package($name);
696
697
if (!defined($pkg)) {
698
print "$name: not registered yet.\n";
699
return;
700
}
701
$state = $pkg->{'State'};
702
703
if ($state eq "Not-For-Us") {
704
print "$name: not suitable for this architecture anyway. Skipping.\n";
705
return;
706
}
707
elsif ($state eq "Failed-Removed") {
708
print "$name: failed previously and doesn't need building. Skipping.\n";
709
return;
710
}
711
elsif ($state eq "Installed") {
712
print "$name: Is already installed in archive. Skipping.\n";
713
return;
714
}
715
elsif ($pkg->{'Builder'} &&
716
(($self->get_conf('DB_USER') ne $pkg->{'Builder'}) &&
717
!($pkg->{'Builder'} =~ /^(\w+)-\w+/ && $1 eq $self->get_conf('DB_USER')))) {
718
print "$name: not taken by you, but by ".
719
"$pkg->{'Builder'}. Skipping.\n";
720
return;
721
}
722
elsif ( !$self->pkg_version_eq($pkg, $version) ) {
723
print "$name: version mismatch ".
724
"$(pkg->{'Version'} ".
725
"by $pkg->{'Builder'})\n";
726
return;
727
}
728
729
$cat = $self->get_conf('DB_CATEGORY');
730
if (!$cat && $self->get_conf('DB_FAIL_REASON') =~ /^\[([^\]]+)\]/) {
731
$cat = $1;
732
$cat = category($cat);
733
$cat = "" if !defined($cat);
734
my $fail_reason = $self->get_conf('DB_FAIL_REASON');
735
$fail_reason =~ s/^\[[^\]]+\][ \t]*\n*//;
736
$self->set_conf('DB_FAIL_REASON', $fail_reason);
737
}
738
739
if ($state eq "Needs-Build") {
740
print "$name: Warning: not registered for building previously, ".
741
"but processing anyway.\n";
742
}
743
elsif ($state eq "Uploaded") {
744
print "$name: Warning: marked as uploaded previously, ".
745
"but processing anyway.\n";
746
}
747
elsif ($state eq "Dep-Wait") {
748
print "$name: Warning: marked as waiting for dependencies, ".
749
"but processing anyway.\n";
750
}
751
elsif ($state eq "Failed") {
752
print "$name: already registered as failed; will append new message\n"
753
if $self->get_conf('DB_FAIL_REASON');
754
print "$name: already registered as failed; changing category\n"
755
if $cat;
756
}
757
758
if (($cat eq "reminder-sent" || $cat eq "nmu-offered") &&
759
exists $pkg->{'Failed-Category'} &&
760
$pkg->{'Failed-Category'} ne $cat) {
761
(my $action = $cat) =~ s/-/ /;
762
$self->set_conf('DB_FAIL_REASON',
763
$self->get_conf('DB_FAIL_REASON') . "\n" .
764
$self->get('Short Date') . ": $action");
765
}
766
767
$self->change_state( $pkg, 'Failed' );
768
$pkg->{'Builder'} = $self->get_conf('DB_USER');
769
$pkg->{'Failed'} .= "\n" if $pkg->{'Failed'};
770
$pkg->{'Failed'} .= $self->get_conf('DB_FAIL_REASON');
771
$pkg->{'Failed-Category'} = $cat if $cat;
772
if (defined $pkg->{'PermBuildPri'}) {
773
$pkg->{'BuildPri'} = $pkg->{'PermBuildPri'};
774
} else {
775
delete $pkg->{'BuildPri'};
776
}
777
$self->log_ta( $pkg, "--failed" );
778
$self->get('Current Database')->set_package($pkg);
779
print "$name: registered as failed\n" if $self->get_conf('VERBOSE');
780
}
781
782
sub add_one_notforus {
783
my $self = shift;
784
my $name = shift;
785
my $version = shift;
786
787
my $pkg = $self->get('Current Database')->get_package($name);
788
789
if ($pkg->{'State'} eq 'Not-For-Us') {
790
# reset Not-For-Us state in case it's called twice; this is
791
# the only way to get a package out of this state...
792
# There is no really good state in which such packages should
793
# be put :-( So use Failed for now.
794
$self->change_state( $pkg, 'Failed' );
795
$pkg->{'Package'} = $name;
796
$pkg->{'Failed'} = "Was Not-For-Us previously";
797
delete $pkg->{'Builder'};
798
delete $pkg->{'Depends'};
799
$self->log_ta( $pkg, "--no-build(rev)" );
800
print "$name: now not unsuitable anymore\n";
801
802
$self->send_mail(
803
$self->get_conf('DB_NOTFORUS_MAINTAINER_EMAIL'),
804
"$name moved out of Not-For-Us state",
805
"The package '$name' has been moved out of the Not-For-Us ".
806
"state by " . $self->get_conf('DB_USER') . ".\n".
807
"It should probably also be removed from ".
808
"Packages-arch-specific or\n".
809
"the action was wrong.\n")
810
if $self->get_conf('DB_NOTFORUS_MAINTAINER_EMAIL');
811
}
812
else {
813
$self->change_state( $pkg, 'Not-For-Us' );
814
$pkg->{'Package'} = $name;
815
delete $pkg->{'Builder'};
816
delete $pkg->{'Depends'};
817
delete $pkg->{'BuildPri'};
818
delete $pkg->{'Binary-NMU-Version'};
819
delete $pkg->{'Binary-NMU-Changelog'};
820
$self->log_ta( $pkg, "--no-build" );
821
print "$name: registered as unsuitable\n" if $self->get_conf('VERBOSE');
822
823
$self->send_mail(
824
$self->get_conf('DB_NOTFORUS_MAINTAINER_EMAIL'),
825
"$name set to Not-For-Us",
826
"The package '$name' has been set to state Not-For-Us ".
827
"by " . $self->get_conf('DB_USER') . ".\n".
828
"It should probably also be added to ".
829
"Packages-arch-specific or\n".
830
"the Not-For-Us state is wrong.\n")
831
if $self->get_conf('DB_NOTFORUS_MAINTAINER_EMAIL');
832
}
833
$self->get('Current Database')->set_package($pkg);
834
}
835
836
sub add_one_needsbuild {
837
my $self = shift;
838
my $name = shift;
839
my $version = shift;
840
841
my $state;
842
my $pkg = $self->get('Current Database')->get_package($name);
843
844
if (!defined($pkg)) {
845
print "$name: not registered; can't give back.\n";
846
return;
847
}
848
$state = $pkg->{'State'};
849
850
if ($state eq "Dep-Wait") {
851
if ($self->get_conf('DB_OVERRIDE')) {
852
print "$name: Forcing source dependency list to be cleared\n";
853
}
854
else {
855
print "$name: waiting for source dependencies. Skipping\n",
856
" (use --override to clear dependency list and ",
857
"give back anyway)\n";
858
return;
859
}
860
}
861
elsif (!isin( $state, qw(Building Built Build-Attempted))) {
862
print "$name: not taken for building (state is $state).";
863
if ($self->get_conf('DB_OVERRIDE')) {
864
print "\n$name: Forcing give-back\n";
865
}
866
else {
867
print " Skipping.\n";
868
return;
869
}
870
}
871
if (defined ($pkg->{'Builder'}) && $self->get_conf('DB_USER') ne $pkg->{'Builder'} &&
872
!($pkg->{'Builder'} =~ /^(\w+)-\w+/ && $1 eq $self->get_conf('DB_USER'))) {
873
print "$name: not taken by you, but by ".
874
"$pkg->{'Builder'}. Skipping.\n";
875
return;
876
}
877
if (!$self->pkg_version_eq($pkg, $version)) {
878
print "$name: version mismatch ($pkg->{'Version'} registered). ",
879
"Skipping.\n";
880
return;
881
}
882
$self->change_state( $pkg, 'Needs-Build' );
883
delete $pkg->{'Builder'};
884
delete $pkg->{'Depends'};
885
$self->log_ta( $pkg, "--give-back" );
886
$self->get('Current Database')->set_package($pkg);
887
print "$name: given back\n" if $self->get_conf('VERBOSE');
888
}
889
890
sub set_one_binnmu {
891
my $self = shift;
892
my $name = shift;
893
my $version = shift;
894
895
my $pkg = $self->get('Current Database')->get_package($name);
896
my $state;
897
898
if (!defined($pkg)) {
899
print "$name: not registered; can't register for binNMU.\n";
900
return;
901
}
902
my $db_ver = $pkg->{'Version'};
903
904
if (!version_eq($db_ver, $version)) {
905
print "$name: version mismatch ($db_ver registered). ",
906
"Skipping.\n";
907
return;
908
}
909
$state = $pkg->{'State'};
910
911
if (defined $pkg->{'Binary-NMU-Version'}) {
912
if ($self->get_conf('DB_BIN_NMU_VERSION') == 0) {
913
$self->change_state( $pkg, 'Installed' );
914
delete $pkg->{'Builder'};
915
delete $pkg->{'Depends'};
916
delete $pkg->{'Binary-NMU-Version'};
917
delete $pkg->{'Binary-NMU-Changelog'};
918
} elsif ($self->get_conf('DB_BIN_NMU_VERSION') <= $pkg->{'Binary-NMU-Version'}) {
919
print "$name: already building binNMU $pkg->{'Binary-NMU-Version'}\n";
920
return;
921
} else {
922
$pkg->{'Binary-NMU-Version'} = $self->get_conf('DB_BIN_NMU_VERSION');
923
$pkg->{'Binary-NMU-Changelog'} = $self->get_conf('DB_FAIL_REASON');
924
$pkg->{'Notes'} = 'out-of-date';
925
$pkg->{'BuildPri'} = $pkg->{'PermBuildPri'}
926
if (defined $pkg->{'PermBuildPri'});
927
}
928
$self->log_ta( $pkg, "--binNMU" );
929
$self->get('Current Database')->set_package($pkg);
930
return;
931
} elsif ($self->get_conf('DB_BIN_NMU_VERSION')) {
932
print "${name}_$version: no scheduled binNMU to cancel.\n";
933
return;
934
}
935
936
if ($state ne 'Installed') {
937
print "${name}_$version: not installed; can't register for binNMU.\n";
938
return;
939
}
940
941
my $fullver = binNMU_version($version,$self->get_conf('DB_BIN_NMU_VERSION'));
942
if (version_lesseq($fullver, $pkg->{'Installed-Version'})) {
943
print "$name: binNMU $fullver is not newer than current version $pkg->{'Installed-Version'}\n";
944
return;
945
}
946
947
$self->change_state( $pkg, 'Needs-Build' );
948
delete $pkg->{'Builder'};
949
delete $pkg->{'Depends'};
950
$pkg->{'Binary-NMU-Version'} = $self->get_conf('DB_BIN_NMU_VERSION');
951
$pkg->{'Binary-NMU-Changelog'} = $self->get_conf('DB_FAIL_REASON');
952
$pkg->{'Notes'} = 'out-of-date';
953
$self->log_ta( $pkg, "--binNMU" );
954
$self->get('Current Database')->set_package($pkg);
955
print "${name}: registered for binNMU $fullver\n" if $self->get_conf('VERBOSE');
956
}
957
958
sub set_one_buildpri {
959
my $self = shift;
960
my $name = shift;
961
my $version = shift;
962
my $key = shift;
963
my $pkg = $self->get('Current Database')->get_package($name);
964
my $state;
965
966
if (!defined($pkg)) {
967
print "$name: not registered; can't set priority.\n";
968
return;
969
}
970
$state = $pkg->{'State'};
971
972
if ($state eq "Not-For-Us") {
973
print "$name: not suitable for this architecture. Skipping.\n";
974
return;
975
} elsif ($state eq "Failed-Removed") {
976
print "$name: failed previously and doesn't need building. Skipping.\n";
977
return;
978
}
979
if (!$self->pkg_version_eq($pkg, $version)) {
980
print "$name: version mismatch ($pkg->{'Version'} registered). ",
981
"Skipping.\n";
982
return;
983
}
984
if ( $self->get_conf('DB_BUILD_PRIORITY') == 0 ) {
985
delete $pkg->{'BuildPri'}
986
if $key eq 'PermBuildPri' and defined $pkg->{'BuildPri'}
987
and $pkg->{'BuildPri'} == $pkg->{$key};
988
delete $pkg->{$key};
989
} else {
990
$pkg->{'BuildPri'} = $self->get_conf('DB_BUILD_PRIORITY')
991
if $key eq 'PermBuildPri';
992
$pkg->{$key} = $self->get_conf('DB_BUILD_PRIORITY');
993
}
994
$self->get('Current Database')->set_package($pkg);
995
print "$name: set to build priority " .
996
$self->get_conf('DB_BUILD_PRIORITY') . "\n" if $self->get_conf('VERBOSE');
997
}
998
999
sub add_one_depwait {
1000
my $self = shift;
1001
my $name = shift;
1002
my $version = shift;
1003
my $state;
1004
my $pkg = $self->get('Current Database')->get_package($name);
1005
1006
if (!defined($pkg)) {
1007
print "$name: not registered yet.\n";
1008
return;
1009
}
1010
$state = $pkg->{'State'};
1011
1012
if ($state eq "Dep-Wait") {
1013
print "$name: merging with previously registered dependencies\n";
1014
}
1015
1016
if (isin( $state, qw(Needs-Build Failed))) {
1017
print "$name: Warning: not registered for building previously, ".
1018
"but processing anyway.\n";
1019
}
1020
elsif ($state eq "Not-For-Us") {
1021
print "$name: not suitable for this architecture anyway. Skipping.\n";
1022
return;
1023
}
1024
elsif ($state eq "Failed-Removed") {
1025
print "$name: failed previously and doesn't need building. Skipping.\n";
1026
return;
1027
}
1028
elsif ($state eq "Installed") {
1029
print "$name: Is already installed in archive. Skipping.\n";
1030
return;
1031
}
1032
elsif ($state eq "Uploaded") {
1033
print "$name: Is already uploaded. Skipping.\n";
1034
return;
1035
}
1036
elsif ($pkg->{'Builder'} &&
1037
$self->get_conf('DB_USER') ne $pkg->{'Builder'}) {
1038
print "$name: not taken by you, but by ".
1039
"$pkg->{'Builder'}. Skipping.\n";
1040
return;
1041
}
1042
elsif ( !$self->pkg_version_eq($pkg,$version)) {
1043
print "$name: version mismatch ".
1044
"($pkg->{'Version'} ".
1045
"by $pkg->{'Builder'})\n";
1046
return;
1047
}
1048
elsif ($self->get_conf('DB_FAIL_REASON') =~ /^\s*$/ ||
1049
!$self->parse_deplist( $self->get_conf('DB_FAIL_REASON'), 1 )) {
1050
print "$name: Bad dependency list\n";
1051
return;
1052
}
1053
$self->change_state( $pkg, 'Dep-Wait' );
1054
$pkg->{'Builder'} = $self->get_conf('DB_USER');
1055
if (defined $pkg->{'PermBuildPri'}) {
1056
$pkg->{'BuildPri'} = $pkg->{'PermBuildPri'};
1057
} else {
1058
delete $pkg->{'BuildPri'};
1059
}
1060
my $deplist = $self->parse_deplist( $pkg->{'Depends'}, 0 );
1061
my $new_deplist = $self->parse_deplist( $self->get_conf('DB_FAIL_REASON'), 0 );
1062
# add new dependencies, maybe overwriting old entries
1063
foreach (keys %$new_deplist) {
1064
$deplist->{$_} = $new_deplist->{$_};
1065
}
1066
$pkg->{'Depends'} = $self->build_deplist($deplist);
1067
$self->log_ta( $pkg, "--dep-wait" );
1068
$self->get('Current Database')->set_package($pkg);
1069
print "$name: registered as waiting for dependencies\n" if $self->get_conf('VERBOSE');
1070
}
1071
1072
1073
sub parse_sources {
1074
my $self = shift;
1075
my $full = shift;
1076
1077
my %pkgs;
1078
my %srcver;
1079
my $name;
1080
1081
local($/) = ""; # read in paragraph mode
1082
while( <> ) {
1083
my( $version, $arch, $section, $priority, $builddep, $buildconf, $binaries );
1084
s/\s*$//m;
1085
/^Package:\s*(\S+)$/mi and $name = $1;
1086
/^Version:\s*(\S+)$/mi and $version = $1;
1087
/^Architecture:\s*(.+)$/mi and $arch = $1;
1088
/^Section:\s*(\S+)$/mi and $section = $1;
1089
/^Priority:\s*(\S+)$/mi and $priority = $1;
1090
/^Build-Depends:\s*(.*)$/mi and $builddep = $1;
1091
/^Build-Conflicts:\s*(.*)$/mi and $buildconf = $1;
1092
/^Binary:\s*(.*)$/mi and $binaries = $1;
1093
1094
next if (defined $srcver{$name} and version_less( $version, $srcver{$name} ));
1095
$srcver{$name} = $version;
1096
if ($buildconf) {
1097
$buildconf = join( ", ", map { "!$_" } split( /\s*,\s*/, $buildconf ));
1098
if ($builddep) {
1099
$builddep .= "," . $buildconf;
1100
} else {
1101
$builddep = $buildconf;
1102
}
1103
}
1104
1105
$pkgs{$name}{'dep'} = defined $builddep ? $builddep : "";
1106
$pkgs{$name}{'ver'} = $version;
1107
$pkgs{$name}{'bin'} = $binaries;
1108
my $pkg = $self->get('Current Database')->get_package($name);
1109
1110
if (defined $pkg) {
1111
my $change = 0;
1112
1113
if ($arch eq "all" && !version_less( $version, $pkg->{'Version'} )) {
1114
# package is now Arch: all, delete it from db
1115
$self->change_state( $pkg, 'deleted' );
1116
$self->log_ta( $pkg, "--merge-sources" );
1117
print "$name ($pkg->{'Version'}): deleted ".
1118
"from database, because now Arch: all\n"
1119
if $self->get_conf('VERBOSE');
1120
$self->get('Current Database')->del_package($pkg);
1121
next;
1122
}
1123
1124
# The "Version" should always be the source version --
1125
# not a possible binNMU version number.
1126
$pkg->{'Version'} = $version, $change++
1127
if ($pkg->{'State'} eq 'Installed' and
1128
!version_eq( $pkg->{'Version'}, $version));
1129
# Always update priority and section, if available
1130
$pkg->{'Priority'} = $priority, $change++
1131
if defined $priority && (!defined($pkg->{'Priority'}) ||
1132
$pkg->{'Priority'} ne $priority);
1133
$pkg->{'Section'} = $section, $change++
1134
if defined $section && (!defined($pkg->{'Section'}) ||
1135
$pkg->{'Section'} ne $section);
1136
$self->get('Current Database')->set_package($pkg) if $change;
1137
}
1138
}
1139
# Now that we only have the latest source version, build the list
1140
# of binary packages from the Sources point of view
1141
foreach $name (keys %pkgs) {
1142
foreach my $bin (split( /\s*,\s*/, $pkgs{$name}{'bin'} ) ) {
1143
$self->get('Merge Bin Src')->{$bin} = $name;
1144
}
1145
}
1146
# remove installed packages that no longer have source available
1147
# or binaries installed
1148
foreach $name ($self->get('Current Database')->list_packages()) {
1149
my $pkg = $self->get('Current Database')->get_package($name);
1150
if (not defined($pkgs{$name})) {
1151
$self->change_state( $pkg, 'deleted' );
1152
$self->log_ta( $pkg, "--merge-sources" );
1153
print "$name ($pkg->{'Version'}): ".
1154
"deleted from database, because ".
1155
"not in Sources anymore\n"
1156
if $self->get_conf('VERBOSE');
1157
$self->get('Current Database')->del_package($name);
1158
} else {
1159
next if !isin( $pkg->{'State'}, qw(Installed) );
1160
if ($full && not defined $self->get('Merge Src Version')->{$name}) {
1161
$self->change_state( $pkg, 'deleted' );
1162
$self->log_ta( $pkg, "--merge-sources" );
1163
print "$name ($pkg->{'Version'}): ".
1164
"deleted from database, because ".
1165
"binaries don't exist anymore\n"
1166
if $self->get_conf('VERBOSE');
1167
$self->get('Current Database')->del_package($name);
1168
} elsif ($full && version_less( $self->get('Merge Src Version')->{$name}, $pkg->{'Version'})) {
1169
print "$name ($pkg->{'Version'}): ".
1170
"package is Installed but binaries are from ".
1171
$self->get('Merge Src Version')->{$name}. "\n"
1172
if $self->get_conf('VERBOSE');
1173
}
1174
}
1175
}
1176
return \%pkgs;
1177
}
1178
1179
# This function looks through a Packages file and sets the state of
1180
# packages to 'Installed'
1181
sub parse_packages {
1182
my $self = shift;
1183
1184
my $installed;
1185
1186
local($/) = ""; # read in paragraph mode
1187
while( <> ) {
1188
my( $name, $version, $depends, $source, $sourcev, $architecture, $provides, $binaryv, $binnmu );
1189
s/\s*$//m;
1190
/^Package:\s*(\S+)$/mi and $name = $1;
1191
/^Version:\s*(\S+)$/mi and $version = $1;
1192
/^Depends:\s*(.*)$/mi and $depends = $1;
1193
/^Source:\s*(\S+)(\s*\((\S+)\))?$/mi and ($source,$sourcev) = ($1, $3);
1194
/^Architecture:\s*(\S+)$/mi and $architecture = $1;
1195
/^Provides:\s*(.*)$/mi and $provides = $1;
1196
1197
next if !$name || !$version;
1198
next if ($self->get_conf('ARCH') ne $architecture and $architecture ne "all");
1199
next if (defined ($installed->{$name}) and $installed->{$name}{'Version'} ne "" and
1200
version_lesseq( $version, $installed->{$name}{'Version'} ));
1201
$installed->{$name}{'Version'} = $version;
1202
$installed->{$name}{'Depends'} = $depends;
1203
$installed->{$name}{'all'} = 1 if $architecture eq "all";
1204
undef $installed->{$name}{'Provider'};
1205
$installed->{$name}{'Source'} = $source ? $source : $name;
1206
1207
if ($provides) {
1208
foreach (split( /\s*,\s*/, $provides )) {
1209
if (not defined ($installed->{$_})) {
1210
$installed->{$_}{'Version'} = "";
1211
$installed->{$_}{'Provider'} = $name;
1212
}
1213
}
1214
}
1215
if ( $version =~ /\+b(\d+)$/ ) {
1216
$binnmu = $1;
1217
}
1218
$version = $sourcev if $sourcev;
1219
$binaryv = $version;
1220
$binaryv =~ s/\+b\d+$//;
1221
$installed->{$name}{'Sourcev'} = $sourcev ? $sourcev : $binaryv;
1222
$binaryv .= "+b$binnmu" if defined($binnmu);
1223
1224
next if $architecture ne $self->get_conf('ARCH');
1225
$name = $source if $source;
1226
next if defined($self->get('Merge Src Version')->{$name}) and $self->get('Merge Src Version')->{$name} eq $version;
1227
1228
$self->get('Merge Src Version')->{$name} = $version;
1229
1230
my $pkg = $self->get('Current Database')->get_package($name);
1231
1232
if (defined $pkg) {
1233
if (isin( $pkg->{'State'}, qw(Not-For-Us)) ||
1234
(isin($pkg->{'State'}, qw(Installed)) &&
1235
version_lesseq($binaryv, $pkg->{'Installed-Version'}))) {
1236
print "Skipping $name because State == $pkg->{'State'}\n"
1237
if $self->get_conf('VERBOSE') >= 2;
1238
next;
1239
}
1240
if ($pkg->{'Binary-NMU-Version'} ) {
1241
my $nmuver = binNMU_version($pkg->{'Version'}, $pkg->{'Binary-NMU-Version'});
1242
if (version_less( $binaryv, $nmuver )) {
1243
print "Skipping $name ($version) because have newer ".
1244
"version ($nmuver) in db.\n"
1245
if $self->get_conf('VERBOSE') >= 2;
1246
next;
1247
}
1248
} elsif (version_less($version, $pkg->{'Version'})) {
1249
print "Skipping $name ($version) because have newer ".
1250
"version ($pkg->{'Version'}) in db.\n"
1251
if $self->get_conf('VERBOSE') >= 2;
1252
next;
1253
}
1254
1255
if (!$self->pkg_version_eq($pkg, $version) &&
1256
$pkg->{'State'} ne "Installed") {
1257
warn "Warning: $name: newer version than expected appeared ".
1258
"in archive ($version vs. $pkg->{'Version'})\n";
1259
delete $pkg->{'Builder'};
1260
}
1261
1262
if (!isin( $pkg->{'State'}, qw(Uploaded) )) {
1263
warn "Warning: Package $name was not in uploaded state ".
1264
"before (but in '$pkg->{'State'}').\n";
1265
delete $pkg->{'Builder'};
1266
delete $pkg->{'Depends'};
1267
}
1268
} else {
1269
$pkg = {};
1270
$pkg->{'Version'} = $version;
1271
}
1272
1273
$self->change_state( $pkg, 'Installed' );
1274
$pkg->{'Package'} = $name;
1275
$pkg->{'Installed-Version'} = $binaryv;
1276
if (defined $pkg->{'PermBuildPri'}) {
1277
$pkg->{'BuildPri'} = $pkg->{'PermBuildPri'};
1278
} else {
1279
delete $pkg->{'BuildPri'};
1280
}
1281
$pkg->{'Version'} = $version
1282
if version_less( $pkg->{'Version'}, $version);
1283
delete $pkg->{'Binary-NMU-Version'};
1284
delete $pkg->{'Binary-NMU-Changelog'};
1285
$self->log_ta( $pkg, "--merge-packages" );
1286
$self->get('Current Database')->set_package($pkg);
1287
print "$name ($version) is up-to-date now.\n" if $self->get_conf('VERBOSE');
1288
}
1289
1290
$self->check_dep_wait( "--merge-packages", $installed );
1291
return $installed;
1292
}
1293
1294
sub pretend_avail {
1295
my $self = shift;
1296
1297
my ($package, $name, $version, $installed);
1298
1299
foreach $package (@_) {
1300
$package =~ s,^.*/,,; # strip path
1301
$package =~ s/\.(dsc|diff\.gz|tar\.gz|deb)$//; # strip extension
1302
$package =~ s/_[\w\d]+\.changes$//; # strip extension
1303
if ($package =~ /^([\w\d.+-]+)_([\w\d:.+~-]+)/) {
1304
($name,$version) = ($1,$2);
1305
}
1306
else {
1307
warn "$package: can't extract package name and version ".
1308
"(bad format)\n";
1309
next;
1310
}
1311
$installed->{$name}{'Version'} = $version;
1312
}
1313
1314
$self->check_dep_wait( "--pretend-avail", $installed );
1315
}
1316
1317
sub check_dep_wait {
1318
my $self = shift;
1319
my $action = shift;
1320
my $installed = shift;
1321
1322
# check all packages in state Dep-Wait if dependencies are all
1323
# available now
1324
my $name;
1325
foreach $name ($self->get('Current Database')->list_packages()) {
1326
my $pkg = $self->get('Current Database')->get_package($name);
1327
next if $pkg->{'State'} ne "Dep-Wait";
1328
my $deps = $pkg->{'Depends'};
1329
if (!$deps) {
1330
print "$name: was in state Dep-Wait, but with empty ",
1331
"dependencies!\n";
1332
goto make_needs_build;
1333
}
1334
my $deplist = $self->parse_deplist($deps, 0);
1335
my $new_deplist;
1336
my $allok = 1;
1337
my @removed_deps;
1338
foreach (keys %$deplist) {
1339
if (!exists $installed->{$_} ||
1340
($deplist->{$_}->{'Rel'} && $deplist->{$_}->{'Version'} &&
1341
!version_compare( $installed->{$_}{'Version'},
1342
$deplist->{$_}->{'Rel'},
1343
$deplist->{$_}->{'Version'}))) {
1344
$allok = 0;
1345
$new_deplist->{$_} = $deplist->{$_};
1346
}
1347
else {
1348
push( @removed_deps, $_ );
1349
}
1350
}
1351
if ($allok) {
1352
make_needs_build:
1353
$self->change_state( $pkg, 'Needs-Build' );
1354
$self->log_ta( $pkg, $action );
1355
delete $pkg->{'Builder'};
1356
delete $pkg->{'Depends'};
1357
print "$name ($pkg->{'Version'}) has all ",
1358
"dependencies available now\n" if $self->get_conf('VERBOSE');
1359
$self->get('New Version')->{$name}++;
1360
$self->get('Current Database')->set_package($pkg);
1361
}
1362
elsif (@removed_deps) {
1363
$pkg->{'Depends'} = $self->build_deplist( $new_deplist );
1364
print "$name ($pkg->{'Version'}): some dependencies ",
1365
"(@removed_deps) available now, but not all yet\n"
1366
if $self->get_conf('VERBOSE');
1367
$self->get('Current Database')->set_package($pkg);
1368
}
1369
}
1370
}
1371
1372
# This function accepts quinn-diff output (either from a file named on
1373
# the command line, or on stdin) and sets the packages named there to
1374
# state 'Needs-Build'.
1375
sub parse_quinn_diff {
1376
my $self = shift;
1377
my $partial = shift;
1378
1379
my %quinn_pkgs;
1380
my $dubious = "";
1381
1382
while( <> ) {
1383
my $change = 0;
1384
next if !m,^([-\w\d/]*)/ # section
1385
([-\w\d.+]+)_ # package name
1386
([\w\d:.~+-]+)\.dsc\s* # version
1387
\[([^:]*): # priority
1388
([^]]+)\]\s*$,x; # rest of notes
1389
my($section,$name,$version,$priority,$notes) = ($1, $2, $3, $4, $5);
1390
$quinn_pkgs{$name}++;
1391
$section ||= "unknown";
1392
$priority ||= "unknown";
1393
$priority = "unknown" if $priority eq "-";
1394
$priority = "standard" if ($name eq "debian-installer");
1395
1396
my $pkg = $self->get('Current Database')->get_package($name);
1397
1398
# Always update section and priority.
1399
if (defined($pkg)) {
1400
1401
$pkg->{'Section'} = $section, $change++ if not defined
1402
$pkg->{'Section'} or $section ne "unknown";
1403
$pkg->{'Priority'} = $priority, $change++ if not defined
1404
$pkg->{'Priority'} or $priority ne "unknown";
1405
}
1406
1407
if (defined($pkg) &&
1408
$pkg->{'State'} =~ /^Dep-Wait/ &&
1409
version_less( $pkg->{'Version'}, $version )) {
1410
$self->change_state( $pkg, 'Dep-Wait' );
1411
$pkg->{'Version'} = $version;
1412
delete $pkg->{'Binary-NMU-Version'};
1413
delete $pkg->{'Binary-NMU-Changelog'};
1414
$self->log_ta( $pkg, "--merge-quinn" );
1415
$change++;
1416
print "$name ($version) still waiting for dependencies.\n"
1417
if $self->get_conf('VERBOSE');
1418
}
1419
elsif (defined($pkg) &&
1420
$pkg->{'State'} =~ /-Removed$/ &&
1421
version_eq($pkg->{'Version'}, $version)) {
1422
# reinstantiate a package that has been removed earlier
1423
# (probably due to a quinn-diff malfunction...)
1424
my $newstate = $pkg->{'State'};
1425
$newstate =~ s/-Removed$//;
1426
$self->change_state( $pkg, $newstate );
1427
$pkg->{'Version'} = $version;
1428
$pkg->{'Notes'} = $notes;
1429
$self->log_ta( $pkg, "--merge-quinn" );
1430
$change++;
1431
print "$name ($version) reinstantiated to $newstate.\n"
1432
if $self->get_conf('VERBOSE');
1433
}
1434
elsif (defined($pkg) &&
1435
$pkg->{'State'} eq "Not-For-Us" &&
1436
version_less( $pkg->{'Version'}, $version )) {
1437
# for Not-For-Us packages just update the version etc., but
1438
# keep the state
1439
$self->change_state( $pkg, "Not-For-Us" );
1440
$pkg->{'Package'} = $name;
1441
$pkg->{'Version'} = $version;
1442
$pkg->{'Notes'} = $notes;
1443
delete $pkg->{'Builder'};
1444
$self->log_ta( $pkg, "--merge-quinn" );
1445
$change++;
1446
print "$name ($version) still Not-For-Us.\n" if $self->get_conf('VERBOSE');
1447
}
1448
elsif (!defined($pkg) ||
1449
$pkg->{'State'} ne "Not-For-Us" &&
1450
(version_less( $pkg->{'Version'}, $version ) ||
1451
($pkg->{'State'} eq "Installed" && version_less($pkg->{'Installed-Version'}, $version)))) {
1452
if (defined( $pkg->{'State'} ) &&
1453
isin($pkg->{'State'}, qw(Building Built Build-Attempted))) {
1454
$self->send_mail(
1455
$pkg->{'Builder'},
1456
"new version of $name (dist=" . $self->get_conf('DISTRIBUTION') . ")",
1457
"As far as I'm informed, you're currently ".
1458
"building the package $name\n".
1459
"in version $pkg->{'Version'}.\n\n".
1460
"Now there's a new source version $version. ".
1461
"If you haven't finished\n".
1462
"compiling $name yet, you can stop it to ".
1463
"save some work.\n".
1464
"Just to inform you...\n".
1465
"(This is an automated message)\n");
1466
print "$name: new version ($version) while building ".
1467
"$pkg->{'Version'} -- sending mail ".
1468
"to builder ($pkg->{'Builder'})\n"
1469
if $self->get_conf('VERBOSE');
1470
}
1471
$self->change_state( $pkg, 'Needs-Build' );
1472
$pkg->{'Package'} = $name;
1473
$pkg->{'Version'} = $version;
1474
$pkg->{'Section'} = $section;
1475
$pkg->{'Priority'} = $priority;
1476
$pkg->{'Notes'} = $notes;
1477
delete $pkg->{'Builder'};
1478
delete $pkg->{'Binary-NMU-Version'};
1479
delete $pkg->{'Binary-NMU-Changelog'};
1480
$self->log_ta( $pkg, "--merge-quinn" );
1481
$self->get('New Version')->{$name}++;
1482
$change++;
1483
print "$name ($version) needs rebuilding now.\n" if $self->get_conf('VERBOSE');
1484
}
1485
elsif (defined($pkg) &&
1486
!version_eq( $pkg->{'Version'}, $version ) &&
1487
isin( $pkg->{'State'}, qw(Installed Not-For-Us) )) {
1488
print "$name: skipping because version in db ".
1489
"($pkg->{'Version'}) is >> than ".
1490
"what quinn-diff says ($version) ".
1491
"(state is $pkg->{'State'})\n"
1492
if $self->get_conf('VERBOSE');
1493
$dubious .= "$pkg->{'State'}: ".
1494
"db ${name}_$pkg->{'Version'} >> ".
1495
"quinn $version\n" if !$partial;
1496
}
1497
elsif ($self->get_conf('VERBOSE') >= 2) {
1498
if ($pkg->{'State'} eq "Not-For-Us") {
1499
print "Skipping $name because State == ".
1500
"$pkg->{'State'}\n";
1501
}
1502
elsif (!version_less($pkg->{'Version'}, $version)) {
1503
print "Skipping $name because version in db ".
1504
"($pkg->{'Version'}) is >= than ".
1505
"what quinn-diff says ($version)\n";
1506
}
1507
}
1508
$self->get('Current Database')->set_package($pkg) if $change;
1509
}
1510
1511
if ($dubious) {
1512
$self->send_mail(
1513
$self->get_conf('DB_MAINTAINER_EMAIL'),
1514
"Dubious versions in " . $self->get_conf('DISTRIBUTION') . " " .
1515
$self->get_conf('DB_BASE_NAME') . " database",
1516
"The following packages have a newer version in the ".
1517
"wanna-build database\n".
1518
"than what quinn-diff says, and this is strange for ".
1519
"their state\n".
1520
"It could be caused by a lame mirror, or the version ".
1521
"in the database\n".
1522
"is wrong.\n\n".
1523
$dubious);
1524
}
1525
1526
# Now re-check the DB for packages in states Needs-Build, Failed,
1527
# or Dep-Wait and remove them if they're not listed anymore by quinn-diff.
1528
if ( !$partial ) {
1529
my $name;
1530
foreach $name ($self->get('Current Database')->list_packages()) {
1531
my $pkg = $self->get('Current Database')->get_package($name);
1532
next if defined $pkg->{'Binary-NMU-Version'};
1533
next if !isin($pkg->{'State'},
1534
qw(Needs-Build Building Built
1535
Build-Attempted Uploaded Failed
1536
Dep-Wait));
1537
my $virtual_delete = $pkg->{'State'} eq 'Failed';
1538
1539
if (!$quinn_pkgs{$name}) {
1540
$self->change_state( $pkg, $virtual_delete ?
1541
$pkg->{'State'}."-Removed" :
1542
'deleted' );
1543
$self->log_ta( $pkg, "--merge-quinn" );
1544
print "$name ($pkg->{'Version'}): ".
1545
($virtual_delete ? "(virtually) " : "") . "deleted ".
1546
"from database, because not in quinn-diff anymore\n"
1547
if $self->get_conf('VERBOSE');
1548
if ($virtual_delete) {
1549
$self->get('Current Database')->set_package($pkg);
1550
} else {
1551
$self->get('Current Database')->set_package($name);
1552
}
1553
}
1554
}
1555
}
1556
}
1557
1558
# Unused?
1559
sub send_reupload_mail {
1560
my $self = shift;
1561
my $to = shift;
1562
my $pkg = shift;
1563
my $version = shift;
1564
my $dist = shift;
1565
my $other_dist = shift;
1566
1567
$self->send_mail(
1568
$to,
1569
"Please reupload ${pkg}_${'Version'} for $dist",
1570
"You have recently built (or are currently building)\n".
1571
"${pkg}_${'Version'} for $other_dist.\n".
1572
"This version is now also needed in the $dist distribution.\n".
1573
"Please reupload the files now present in the Debian archive\n".
1574
"(best with buildd-reupload).\n");
1575
}
1576
1577
sub sort_list_func {
1578
my $self = shift;
1579
1580
my $sortfunc = sub {
1581
my($letter, $x);
1582
1583
foreach $letter (split( "", $self->get_conf('DB_LIST_ORDER') )) {
1584
SWITCH: foreach ($letter) {
1585
/P/ && do {
1586
my $ap = $a->{'BuildPri'};
1587
my $bp = $b->{'BuildPri'};
1588
$ap = 0 if !defined($ap);
1589
$bp = 0 if !defined($bp);
1590
$x = $bp <=> $ap;
1591
return $x if $x != 0;
1592
last SWITCH;
1593
};
1594
/p/ && do {
1595
$x = $self->get('Priority Values')->{$a->{'Priority'}} <=> $self->get('Priority Values')->{$b->{'Priority'}};
1596
return $x if $x != 0;
1597
last SWITCH;
1598
};
1599
/s/ && do {
1600
$self->get('Section Values')->{$a->{'Section'}} = -125 if(!$self->get('Section Values')->{$a->{'Section'}});
1601
$self->get('Section Values')->{$b->{'Section'}} = -125 if(!$self->get('Section Values')->{$b->{'Section'}});
1602
$x = $self->get('Section Values')->{$a->{'Section'}} <=> $self->get('Section Values')->{$b->{'Section'}};
1603
return $x if $x != 0;
1604
last SWITCH;
1605
};
1606
/n/ && do {
1607
$x = $a->{'Package'} cmp $b->{'Package'};
1608
return $x if $x != 0;
1609
last SWITCH;
1610
};
1611
/b/ && do {
1612
my $ab = $a->{'Builder'};
1613
my $bb = $b->{'Builder'};
1614
$ab = "" if !defined($ab);
1615
$bb = "" if !defined($bb);
1616
$x = $ab cmp $bb;
1617
return $x if $x != 0;
1618
last SWITCH;
1619
};
1620
/c/ && do {
1621
my $ax = 0;
1622
my $bx = 0;
1623
if (defined($a->{'Notes'})) {
1624
$ax = ($a->{'Notes'} =~ /^(out-of-date|partial)/) ? 0 :
1625
($a->{'Notes'} =~ /^uncompiled/) ? 2 : 1;
1626
}
1627
if (defined($b->{'Notes'})) {
1628
$bx = ($b->{'Notes'} =~ /^(out-of-date|partial)/) ? 0 :
1629
($b->{'Notes'} =~ /^uncompiled/) ? 2 : 1;
1630
$x = $ax <=> $bx;
1631
}
1632
return $x if $x != 0;
1633
last SWITCH;
1634
};
1635
/f/ && do {
1636
my $ca = exists $a->{'Failed-Category'} ?
1637
$a->{'Failed-Category'} : "none";
1638
my $cb = exists $b->{'Failed-Category'} ?
1639
$b->{'Failed-Category'} : "none";
1640
$x = $self->get('Category Values')->{$ca} <=> $self->get('Category Values')->{$cb};
1641
return $x if $x != 0;
1642
last SWITCH;
1643
};
1644
/S/ && do {
1645
my $pa = $self->get('Priority Values')->{$a->{'Priority'}} >
1646
$self->get('Priority Values')->{'standard'};
1647
my $pb = $self->get('Priority Values')->{$b->{'Priority'}} >
1648
$self->get('Priority Values')->{'standard'};
1649
$x = $pa <=> $pb;
1650
return $x if $x != 0;
1651
last SWITCH;
1652
};
1653
/a/ && do {
1654
my $x = $self->get('Current Time') - $self->parse_date($a->{'State-Change'}) <=>
1655
$self->get('Current Time') - $self->parse_date($b->{'State-Change'});
1656
return $x if $x != 0;
1657
last SWITCH;
1658
};
1659
}
1660
}
1661
return 0;
1662
};
1663
1664
return $sortfunc;
1665
}
1666
1667
sub list_packages {
1668
my $self = shift;
1669
my $state = shift;
1670
1671
my( $name, $pkg, @list );
1672
my $cnt = 0;
1673
my %scnt;
1674
my $user = $self->get_conf('DB_USER');
1675
1676
foreach $name ($self->get('Current Database')->list_packages()) {
1677
$pkg = $self->get('Current Database')->get_package($name);
1678
next if $state ne "all" && $pkg->{'State'} !~ /^\Q$state\E$/i;
1679
next if $user && (lc($state) ne 'needs-build' &&
1680
defined($pkg->{'Builder'}) &&
1681
$pkg->{'Builder'} ne $self->get_conf('DB_USER'));
1682
next if $self->get_conf('DB_CATEGORY') && $pkg->{'State'} eq "Failed" &&
1683
$pkg->{'Failed-Category'} ne $self->get_conf('DB_CATEGORY');
1684
next if ($self->get_conf('DB_LIST_MIN_AGE') > 0 &&
1685
($self->get('Current Time') - $self->parse_date($pkg->{'State-Change'})) < $self->get_conf('DB_LIST_MIN_AGE'))||
1686
($self->get_conf('DB_LIST_MIN_AGE') < 0 &&
1687
($self->get('Current Time') - $self->parse_date($pkg->{'State-Change'})) > -$self->get_conf('DB_LIST_MIN_AGE'));
1688
push( @list, $pkg );
1689
}
1690
1691
my $sortfunc = $self->sort_list_func();
1692
foreach $pkg (sort $sortfunc @list) {
1693
print "$pkg->{'Section'}/$pkg->{'Package'}_$pkg->{'Version'}";
1694
print ": $pkg->{'State'}"
1695
if $state eq "all";
1696
print " by $pkg->{'Builder'}"
1697
if $pkg->{'State'} ne "Needs-Build" && $pkg->{'Builder'};
1698
print " [$pkg->{'Priority'}:";
1699
print "$pkg->{'Notes'}"
1700
if defined($pkg->{'Notes'});
1701
print ":PREV-FAILED"
1702
if defined($pkg->{'Previous-State'}) &&
1703
$pkg->{'Previous-State'} =~ /^Failed/;
1704
print ":bp{" . $pkg->{'BuildPri'} . "}"
1705
if exists $pkg->{'BuildPri'};
1706
print ":binNMU{" . $pkg->{'Binary-NMU-Version'} . "}"
1707
if exists $pkg->{'Binary-NMU-Version'};
1708
print "]\n";
1709
print " Reasons for failing:\n",
1710
" [Category: ",
1711
exists $pkg->{'Failed-Category'} ? $pkg->{'Failed-Category'} : "none",
1712
"]\n ",
1713
join("\n ",split("\n",$pkg->{'Failed'})), "\n"
1714
if $pkg->{'State'} =~ /^Failed/;
1715
print " Dependencies: $pkg->{'Depends'}\n"
1716
if $pkg->{'State'} eq "Dep-Wait" &&
1717
defined $pkg->{'Depends'};
1718
print " Previous state was $pkg->{'Previous-State'} until ",
1719
"$pkg->{'State-Change'}\n"
1720
if $self->get_conf('VERBOSE') && $pkg->{'Previous-State'};
1721
print " Previous failing reasons:\n ",
1722
join("\n ",split("\n",$pkg->{'Old-Failed'})), "\n"
1723
if $self->get_conf('VERBOSE') && $pkg->{'Old-Failed'};
1724
++$cnt;
1725
$scnt{$pkg->{'State'}}++ if $state eq "all";
1726
}
1727
if ($state eq "all") {
1728
foreach (sort keys %scnt) {
1729
print "Total $scnt{$_} package(s) in state $_.\n";
1730
}
1731
}
1732
print "Total $cnt package(s)\n";
1733
}
1734
1735
sub info_packages {
1736
my $self = shift;
1737
1738
my( $name, $pkg, $key, $dist );
1739
my @firstkeys = qw(Package Version Builder State Section Priority
1740
Installed-Version Previous-State State-Change);
1741
my @dists = $self->get_conf('DB_INFO_ALL_DISTS') ? keys %{$self->get_conf('DB_DISTRIBUTIONS')} : ($self->get_conf('DISTRIBUTION'));
1742
1743
foreach $dist (@dists) {
1744
if ($dist ne $self->get_conf('DISTRIBUTION')) {
1745
if (!$self->open_db($dist)) {
1746
warn "Cannot open database for $dist!\n";
1747
@dists = grep { $_ ne $dist } @dists;
1748
}
1749
}
1750
}
1751
1752
foreach $name (@_) {
1753
$name =~ s/_.*$//; # strip version
1754
foreach $dist (@dists) {
1755
$self->set('Current Database', $self->get('Databases')->{$dist});
1756
my $pname = "$name" . ($self->get_conf('DB_INFO_ALL_DISTS') ? "($dist)" : "");
1757
1758
$pkg = $self->get('Current Database')->get_package($name);
1759
if (!defined( $pkg )) {
1760
print "$pname: not registered\n";
1761
next;
1762
}
1763
1764
print "$pname:\n";
1765
foreach $key (@firstkeys) {
1766
next if !exists $pkg->{$key};
1767
my $val = $pkg->{$key};
1768
chomp( $val );
1769
$val = "\n$val" if isin( $key, qw(Failed Old-Failed));
1770
$val =~ s/\n/\n /g;
1771
printf " %-20s: %s\n", $key, $val;
1772
}
1773
foreach $key (sort keys %$pkg) {
1774
next if isin( $key, @firstkeys );
1775
my $val = $pkg->{$key};
1776
chomp( $val );
1777
$val = "\n$val" if isin( $key, qw(Failed Old-Failed));
1778
$val =~ s/\n/\n /g;
1779
printf " %-20s: %s\n", $key, $val;
1780
}
1781
}
1782
}
1783
}
1784
1785
sub forget_packages {
1786
my $self = shift;
1787
1788
my( $name, $pkg, $key, $data );
1789
1790
foreach $name (@_) {
1791
$name =~ s/_.*$//; # strip version
1792
$pkg = $self->get('Current Database')->get_package($name);
1793
if (!defined( $pkg )) {
1794
print "$name: not registered\n";
1795
next;
1796
}
1797
1798
$data = "";
1799
foreach $key (sort keys %$pkg) {
1800
my $val = $pkg->{$key};
1801
chomp( $val );
1802
$val =~ s/\n/\n /g;
1803
$data .= sprintf " %-20s: %s\n", $key, $val;
1804
}
1805
$self->send_mail(
1806
$self->get_conf('DB_MAINTAINER_EMAIL'),
1807
"$name deleted from DB " . $self->get_conf('DB_BASE_NAME'),
1808
"The package '$name' has been deleted from the database ".
1809
"by " . $self->get_conf('DB_USER') . ".\n\n".
1810
"Data registered about the deleted package:\n".
1811
"$data\n")
1812
if $self->get_conf('DB_MAINTAINER_EMAIL');
1813
$self->change_state( $pkg, 'deleted' );
1814
$self->log_ta( $pkg, "--forget" );
1815
$self->get('Current Database')->set_package($name);
1816
print "$name: deleted from database\n" if $self->get_conf('VERBOSE');
1817
}
1818
}
1819
1820
sub forget_users {
1821
my $self = shift;
1822
1823
my( $name, $ui );
1824
1825
foreach $name (@_) {
1826
if (!$self->get('Current Database')->del_user($name)) {
1827
print "$name: not registered\n";
1828
next;
1829
}
1830
1831
print "$name: deleted from database\n" if $self->get_conf('VERBOSE');
1832
}
1833
}
1834
1835
sub create_maintlock {
1836
my $self = shift;
1837
1838
my $lockfile = $self->db_filename("maintenance") . ".lock";
1839
my $try = 0;
1840
local( *F );
1841
1842
print "Creating maintenance lock\n" if $self->get_conf('VERBOSE') >= 2;
1843
repeat:
1844
if (!sysopen( F, $lockfile, O_WRONLY|O_CREAT|O_TRUNC|O_EXCL, 0644 )){
1845
if ($! == EEXIST) {
1846
# lock file exists, wait
1847
goto repeat if !open( F, "<$lockfile" );
1848
my $line = <F>;
1849
close( F );
1850
if ($line !~ /^(\d+)\s+([\w\d.-]+)$/) {
1851
warn "Bad maintenance lock file contents -- still trying\n";
1852
}
1853
else {
1854
my($pid, $usr) = ($1, $2);
1855
if (kill( 0, $pid ) == 0 && $! == ESRCH) {
1856
# process doesn't exist anymore, remove stale lock
1857
print "Removing stale lock file (pid $pid, user $usr)\n";
1858
unlink( $lockfile );
1859
goto repeat;
1860
}
1861
warn "Maintenance lock already exists by $usr -- ".
1862
"please wait\n" if $try == 0;
1863
}
1864
if (++$try > 120) {
1865
die "Lock still present after 120 * 60 seconds.\n";
1866
}
1867
sleep 60;
1868
goto repeat;
1869
}
1870
die "Can't create maintenance lock $lockfile: $!\n";
1871
}
1872
F->print(getppid(), " " . $self->get_conf('USERNAME') . "\n");
1873
F->close();
1874
}
1875
1876
sub remove_maintlock {
1877
my $self = shift;
1878
1879
my $lockfile = $self->db_filename("maintenance") . ".lock";
1880
1881
print "Removing maintenance lock\n" if $self->get_conf('VERBOSE') >= 2;
1882
unlink $lockfile;
1883
}
1884
1885
sub waitfor_maintlock {
1886
my $self = shift;
1887
1888
my $lockfile = $self->db_filename("maintenance") . ".lock";
1889
my $try = 0;
1890
local( *F );
1891
1892
print "Checking for maintenance lock\n" if $self->get_conf('VERBOSE') >= 2;
1893
repeat:
1894
if (open( F, "<$lockfile" )) {
1895
my $line = <F>;
1896
close( F );
1897
if ($line !~ /^(\d+)\s+([\w\d.-]+)$/) {
1898
warn "Bad maintenance lock file contents -- still trying\n";
1899
}
1900
else {
1901
my($pid, $usr) = ($1, $2);
1902
if (kill( 0, $pid ) == 0 && $! == ESRCH) {
1903
# process doesn't exist anymore, remove stale lock
1904
print "Removing stale maintenance lock (pid $pid, user $usr)\n";
1905
unlink( $lockfile );
1906
return;
1907
}
1908
warn "Databases locked for general maintenance by $usr -- ".
1909
"please wait\n" if $try == 0;
1910
}
1911
if (++$try > 120) {
1912
die "Lock still present after 120 * 60 seconds.\n";
1913
}
1914
sleep 60;
1915
goto repeat;
1916
}
1917
}
1918
1919
sub change_state {
1920
my $self = shift;
1921
my $pkg = shift;
1922
my $newstate = shift;
1923
1924
my $state = $pkg->{'State'};
1925
1926
return if defined($state) and $state eq $newstate;
1927
$pkg->{'Previous-State'} = $state if defined($state);
1928
1929
$pkg->{'State-Change'} = $self->get('Current Date');
1930
1931
if (defined($state) and $state eq 'Failed') {
1932
$pkg->{'Old-Failed'} =
1933
"-"x20 . " $pkg->{'Version'} " . "-"x20 . "\n" .
1934
$pkg->{'Failed'} . "\n" .
1935
$pkg->{'Old-Failed'};
1936
delete $pkg->{'Failed'};
1937
delete $pkg->{'Failed-Category'};
1938
}
1939
1940
$pkg->{'State'} = $newstate;
1941
}
1942
1943
sub open_db {
1944
my $self = shift;
1945
my $dist = shift;
1946
1947
my $newdb = $self->get('Databases')->{$dist};
1948
1949
if (!defined($newdb)) {
1950
if ($self->get_conf('DB_TYPE') eq 'mldbm') {
1951
$newdb = Sbuild::DB::MLDBM->new($self->get('Config'));
1952
} elsif ($self->get_conf('DB_TYPE') eq 'postgres') {
1953
$newdb = Sbuild::DB::Postgres->new($self->get('Config'));
1954
} else {
1955
die "Unsupported database type '" . $self->get_conf('DB_TYPE') . "'\n";
1956
}
1957
1958
$newdb->open($self->db_filename($dist));
1959
$newdb->lock();
1960
1961
$self->get('Databases')->{$dist} = $newdb;
1962
}
1963
1964
return $newdb;
1965
}
1966
1967
sub log_ta {
1968
my $self = shift;
1969
my $pkg = shift;
1970
my $action = shift;
1971
1972
my $dist = $self->get_conf('DISTRIBUTION');
1973
my $str;
1974
my $prevstate = 'Unknown';
1975
1976
$prevstate = $pkg->{'Previous-State'} if defined($pkg->{'Previous-State'});
1977
1978
$str = "$action($dist): $pkg->{'Package'}_$pkg->{'Version'} ".
1979
"changed from $prevstate to $pkg->{'State'} ".
1980
"by " . $self->get_conf('USERNAME'). " as " . $self->get_conf('DB_USER') . ".";
1981
1982
my $transactlog = $self->get_conf('DB_BASE_DIR') . "/$dist-" .
1983
$self->get_conf('DB_TRANSACTION_LOG');
1984
if (!open( LOG, ">>$transactlog" )) {
1985
warn "Can't open log file $transactlog: $!\n";
1986
return;
1987
}
1988
print LOG $self->get('Current Date') . ": $str\n";
1989
close( LOG );
1990
1991
if (!($prevstate eq 'Failed' && $pkg->{'State'} eq 'Failed')) {
1992
$str .= " (with --override)"
1993
if $self->get_conf('DB_OVERRIDE');
1994
$self->set('Mail Logs',
1995
$self->get('Mail Logs') . "$str\n");
1996
}
1997
}
1998
1999
# Unused?
2000
sub dist_cmp {
2001
my $self = shift;
2002
my $d1 = shift;
2003
my $d2 = shift;
2004
2005
my $dist_order = $self->get_conf('DB_DISTRIBUTIONS');
2006
2007
return $dist_order->{$d1}->{'priority'} <=> $dist_order->{$d2}->{'priority'};
2008
}
2009
2010
sub send_mail {
2011
my $self = shift;
2012
my $to = shift;
2013
my $subject = shift;
2014
my $text = shift;
2015
2016
my $from = $self->get_conf('DB_MAINTAINER_EMAIL');
2017
my $domain = $self->get_conf('DB_MAIL_DOMAIN');
2018
2019
if (defined($domain)) {
2020
$from .= "\@$domain" if $from !~ /\@/;
2021
$to .= '@$domain' if $to !~ /\@/;
2022
} else {
2023
$from .= "\@" . $self->get_conf('HOSTNAME') if $from !~ /\@/;
2024
$to .= '@' . $self->get_conf('HOSTNAME') if $to !~ /\@/;
2025
}
2026
2027
$text =~ s/^\.$/../mg;
2028
local $SIG{'PIPE'} = 'IGNORE';
2029
open( PIPE, "| " . $self->get_conf('MAILPROG') . " -oem $to" )
2030
or die "Can't open pipe to " . $self->get_conf('MAILPROG') . ": $!\n";
2031
chomp $text;
2032
print PIPE "From: $from\n";
2033
print PIPE "Subject: $subject\n\n";
2034
print PIPE "$text\n";
2035
close( PIPE );
2036
}
2037
2038
sub db_filename {
2039
my $self = shift;
2040
my $dist = shift;
2041
2042
return $self->get_conf('DB_BASE_DIR') . '/' . $self->get_conf('DB_BASE_NAME') . "-$dist";
2043
}
2044
2045
# for parsing input to dep-wait
2046
sub parse_deplist {
2047
my $self = shift;
2048
my $deps = shift;
2049
my $verify = shift;
2050
my %result;
2051
2052
foreach (split( /\s*,\s*/, $deps )) {
2053
if ($verify) {
2054
# verification requires > starting prompts, no | crap
2055
if (!/^(\S+)\s*(\(\s*(>(?:[>=])?)\s*(\S+)\s*\))?\s*$/) {
2056
return 0;
2057
}
2058
next;
2059
}
2060
my @alts = split( /\s*\|\s*/, $_ );
2061
# Anything with an | is ignored, as it can be configured on a
2062
# per-buildd basis what will be installed
2063
next if $#alts != 0;
2064
$_ = shift @alts;
2065
2066
if (!/^(\S+)\s*(\(\s*(>=|=|==|>|>>|<<|<=)\s*(\S+)\s*\))?\s*$/) {
2067
warn( "parse_deplist: bad dependency $_\n" );
2068
next;
2069
}
2070
my($dep, $rel, $relv) = ($1, $3, $4);
2071
$rel = ">>" if defined($rel) and $rel eq ">";
2072
$result{$dep}->{'Package'} = $dep;
2073
if ($rel && $relv) {
2074
$result{$dep}->{'Rel'} = $rel;
2075
$result{$dep}->{'Version'} = $relv;
2076
}
2077
}
2078
return 1 if $verify;
2079
return \%result;
2080
}
2081
2082
# for parsing Build-Depends from Sources
2083
sub parse_srcdeplist {
2084
my $self = shift;
2085
my $pkg = shift;
2086
my $deps = shift;
2087
my $arch = shift;
2088
2089
my $dep;
2090
my @results;
2091
2092
foreach $dep (split( /\s*,\s*/, $deps )) {
2093
my @alts = split( /\s*\|\s*/, $dep );
2094
# Anything with an | is ignored, as it can be configured on a
2095
# per-buildd basis what will be installed
2096
next if $#alts != 0;
2097
$_ = shift @alts;
2098
if (!/^([^\s([]+)\s*(\(\s*([<=>]+)\s*(\S+)\s*\))?(\s*\[([^]]+)\])?/) {
2099
warn( "parse_srcdeplist: bad dependency $_\n" );
2100
next;
2101
}
2102
my($dep, $rel, $relv, $archlist) = ($1, $3, $4, $6);
2103
if ($archlist) {
2104
$archlist =~ s/^\s*(.*)\s*$/$1/;
2105
my @archs = split( /\s+/, $archlist );
2106
my ($use_it, $ignore_it, $include) = (0, 0, 0);
2107
foreach (@archs) {
2108
# Use 'dpkg-architecture' to support architecture
2109
# wildcards.
2110
if (/^!/) {
2111
$ignore_it = 1 if Dpkg::Arch::debarch_is($arch, substr($_, 1));
2112
} else {
2113
$use_it = 1 if Dpkg::Arch::debarch_is($arch, $_);
2114
$include = 1;
2115
}
2116
}
2117
warn "Warning: inconsistent arch restriction on ",
2118
"$pkg: $dep depedency\n"
2119
if $ignore_it && $use_it;
2120
next if $ignore_it || ($include && !$use_it);
2121
}
2122
my $neg = 0;
2123
if ($dep =~ /^!/) {
2124
$dep =~ s/^!\s*//;
2125
$neg = 1;
2126
}
2127
my $result;
2128
$result->{'Package'} = $dep;
2129
$result->{'Neg'} = $neg;
2130
if ($rel && $relv) {
2131
$result->{'Rel'} = $rel;
2132
$result->{'Version'} = $relv;
2133
}
2134
push @results, $result;
2135
2136
}
2137
return \@results;
2138
}
2139
2140
sub build_deplist {
2141
my $self = shift;
2142
my $list = shift;
2143
2144
my($key, $result);
2145
2146
foreach $key (keys %$list) {
2147
$result .= ", " if $result;
2148
$result .= $key;
2149
$result .= " ($list->{$key}->{'Rel'} $list->{$key}->{'Version'})"
2150
if $list->{$key}->{'Rel'} && $list->{$key}->{'Version'};
2151
}
2152
return $result;
2153
}
2154
2155
sub get_unsatisfied_dep {
2156
my $self = shift;
2157
my $bd = shift;
2158
my $pkgs = shift;
2159
my $dep = shift;
2160
my $savedep = shift;
2161
2162
my $pkgname = $dep->{'Package'};
2163
2164
if (defined $pkgs->{$pkgname}{'Provider'}) {
2165
# provides. leave them for buildd/sbuild.
2166
return "";
2167
}
2168
2169
# check cache
2170
return $pkgs->{$pkgname}{'Unsatisfied'} if $savedep and defined($pkgs->{$pkgname}{'Unsatisfied'});
2171
2172
# Return unsatisfied deps to a higher caller to process
2173
if ((!defined($pkgs->{$pkgname})) or
2174
(defined($dep->{'Rel'}) and !version_compare( $pkgs->{$pkgname}{'Version'}, $dep->{'Rel'}, $dep->{'Version'} ) ) ) {
2175
my %deplist;
2176
$deplist{$pkgname} = $dep;
2177
my $deps = $self->build_deplist(\%deplist);
2178
$pkgs->{$pkgname}{'Unsatisfied'} = $deps if $savedep;
2179
return $deps;
2180
}
2181
2182
# set cache to "" to avoid infinite recursion
2183
$pkgs->{$pkgname}{'Unsatisfied'} = "" if $savedep;
2184
2185
if (defined $pkgs->{$dep->{'Package'}}{'Depends'}) {
2186
my $deps = $self->parse_deplist( $pkgs->{$dep->{'Package'}}{'Depends'} );
2187
foreach (keys %$deps) {
2188
$dep = $$deps{$_};
2189
# recur on dep.
2190
my $ret = $self->get_unsatisfied_dep($bd,$pkgs,$dep,1);
2191
if ($ret ne "") {
2192
my $retdep = $self->parse_deplist( $ret );
2193
foreach (keys %$retdep) {
2194
$dep = $$retdep{$_};
2195
2196
$dep->{'Rel'} = '>=' if defined($dep->{'Rel'}) and $dep->{'Rel'} =~ '^=';
2197
2198
if (defined($dep->{'Rel'}) and $dep->{'Rel'} =~ '^>' and defined ($pkgs->{$dep->{'Package'}}) and
2199
version_compare($bd->{$pkgs->{$dep->{'Package'}}{'Source'}}{'ver'},'>>',$pkgs->{$dep->{'Package'}}{'Sourcev'})) {
2200
if (not defined($self->get('Merge Bin Src')->{$dep->{'Package'}})) {
2201
# the uninstallable package doesn't exist in the new source; look for something else that does.
2202
delete $$retdep{$dep->{'Package'}};
2203
foreach (sort (split( /\s*,\s*/, $bd->{$pkgs->{$dep->{'Package'}}{'Source'}}{'bin'}))) {
2204
next if ($pkgs->{$_}{'all'} or not defined $pkgs->{$_}{'Version'});
2205
$dep->{'Package'} = $_;
2206
$dep->{'Rel'} = '>>';
2207
$dep->{'Version'} = $pkgs->{$_}{'Version'};
2208
$$retdep{$_} = $dep;
2209
last;
2210
}
2211
}
2212
} else {
2213
# sanity check to make sure the depending binary still exists, and the depended binary exists and dep-wait on a new version of it
2214
if ( defined($self->get('Merge Bin Src')->{$pkgname}) and defined($pkgs->{$dep->{'Package'}}{'Version'}) ) {
2215
delete $$retdep{$dep->{'Package'}};
2216
$dep->{'Package'} = $pkgname;
2217
$dep->{'Rel'} = '>>';
2218
$dep->{'Version'} = $pkgs->{$pkgname}{'Version'};
2219
$$retdep{$pkgname} = $dep;
2220
}
2221
delete $$retdep{$dep->{'Package'}} if (defined ($dep->{'Rel'}) and $dep->{'Rel'} =~ '^>');
2222
}
2223
}
2224
$ret = $self->build_deplist($retdep);
2225
$pkgs->{$pkgname}{'Unsatisfied'} = $ret if $savedep;
2226
return $ret;
2227
}
2228
}
2229
}
2230
return "";
2231
}
2232
2233
sub auto_dep_wait {
2234
my $self = shift;
2235
my $bd = shift;
2236
my $pkgs = shift;
2237
my $key;
2238
2239
my $distribution = $self->get_conf('DISTRIBUTION');
2240
2241
return if (defined ($self->get_conf('DB_DISTRIBUTIONS')->{'$distribution'}) &&
2242
defined ($self->get_conf('DB_DISTRIBUTIONS')->{'$distribution'}->{'noadw'}));
2243
2244
# We need to walk all of needs-build, as any new upload could make
2245
# something in needs-build have uninstallable deps
2246
foreach $key ($self->get('Current Database')->list_packages()) {
2247
my $pkg = $self->get('Current Database')->get_package($key);
2248
next
2249
if not defined $pkg or $pkg->{'State'} ne "Needs-Build";
2250
my $srcdeps = $self->parse_srcdeplist($key,$bd->{$key}{'dep'},
2251
$self->get_conf('ARCH'));
2252
foreach my $srcdep (@$srcdeps) {
2253
next if $srcdep->{'Neg'} != 0; # we ignore conflicts atm
2254
my $rc = $self->get_unsatisfied_dep($bd,$pkgs,$srcdep,0);
2255
if ($rc ne "") {
2256
# set dep-wait
2257
my $deplist = $self->parse_deplist( $pkg->{'Depends'} );
2258
my $newdeps = $self->parse_deplist( $rc );
2259
my $change = 0;
2260
foreach (%$newdeps) {
2261
my $dep = $$newdeps{$_};
2262
# ensure we're not waiting on ourselves, or a package that has been removed
2263
next if (not defined($self->get('Merge Bin Src')->{$dep->{'Package'}})) or ($self->get('Merge Bin Src')->{$dep->{'Package'}} eq $key);
2264
if ($dep->{'Rel'} =~ '^>') {
2265
$deplist->{$dep->{'Package'}} = $dep;
2266
$change++;
2267
}
2268
}
2269
if ($change) {
2270
$pkg->{'Depends'} = $self->build_deplist($deplist);
2271
$self->change_state( $pkg, 'Dep-Wait' );
2272
$self->log_ta( $pkg, "--merge-all" );
2273
$self->get('Current Database')->set_package($pkg);
2274
print "Auto-Dep-Waiting ${key}_$pkg->{'Version'} to $pkg->{'Depends'}\n" if $self->get_conf('VERBOSE');
2275
}
2276
last;
2277
}
2278
}
2279
}
2280
}
2281
2282
sub pkg_version_eq {
2283
my $self = shift;
2284
my $pkg = shift;
2285
my $version = shift;
2286
2287
return 1
2288
if (defined $pkg->{'Binary-NMU-Version'}) and
2289
version_compare(binNMU_version($pkg->{'Version'},
2290
$pkg->{'Binary-NMU-Version'}),'=', $version);
2291
return version_compare( $pkg->{'Version'}, "=", $version );
2292
}
2293
2294
1;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1