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