Rev 13 | Details | Compare with Previous | Last modification | View Log | RSS feed
Rev | Author | Line No. | Line |
---|---|---|---|
1 | magnus | 1 | #! /usr/bin/perl -w |
2 | |||
3 | ##### |
||
4 | # |
||
5 | # Copyright 2003-2004 Joel Baker. All rights reserved. |
||
6 | # |
||
7 | # Redistribution and use in source and binary forms, with or without |
||
8 | # modification, are permitted provided that the following conditions |
||
9 | # are met: |
||
10 | # 1. Redistributions of source code must retain the above copyright |
||
11 | # notice, this list of conditions and the following disclaimer. |
||
12 | # 2. Redistributions in binary form must reproduce the above copyright |
||
13 | # notice, this list of conditions and the following disclaimer in the |
||
14 | # documentation and/or other materials provided with the distribution. |
||
15 | # 3. Neither the name of the Author nor the names of any contributors |
||
16 | # may be used to endorse or promote products derived from this software |
||
17 | # without specific prior written permission. |
||
18 | # |
||
19 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND |
||
20 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
||
21 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
||
22 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE |
||
23 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
||
24 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS |
||
25 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) |
||
26 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
||
27 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
||
28 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF |
||
29 | # SUCH DAMAGE. |
||
30 | # |
||
31 | # $Id: debpool 54 2005-02-21 21:48:29Z joel $ |
||
32 | # |
||
33 | ##### |
||
34 | |||
35 | # Put our private support module area into the search path |
||
36 | |||
37 | use lib '/usr/share/debpool/perl5'; |
||
38 | |||
39 | # We always want to be careful about things... |
||
40 | |||
41 | use strict; |
||
42 | use warnings; |
||
43 | |||
44 | use POSIX; # This gets us strftime. |
||
45 | |||
46 | # First things first - figure out how we need to be configured. |
||
47 | |||
48 | use Getopt::Long qw(:config pass_through); |
||
49 | use DebPool::Config qw(:functions :vars); |
||
50 | |||
13 | magnus | 51 | my($help); |
15 | magnus | 52 | GetOptions('help' => \$help); |
13 | magnus | 53 | if (defined($help)) { |
54 | #23456789 123456789 123456789 123456789 123456789 123456789 123456789 123456789 | |
||
55 | print "Usage: debpool [Options] |
||
56 | Pool-based Debian package archive manager |
||
57 | |||
58 | --config=configfile May be issued multiple times; each time it is used, it will |
||
59 | add the named config file to the list which DebPool will |
||
60 | load (later config files override earlier ones, in case of |
||
61 | any conflicts). |
||
62 | --daemon Run debpool as a daemon. |
||
63 | --debug Run debpool in debug mode. Identical to daemon mode but |
||
64 | remains in foreground. |
||
65 | --help Displays this help text. |
||
66 | --dumpdb Dumps the debpool database. |
||
67 | --log_file=filename Send logging output to the specified filename. |
||
68 | --rebuild-files Forces all of the distribution files (Packages and Sources) |
||
69 | to be rebuilt. |
||
70 | --rebuild-dbs Forces all of the metadata files to be rebuilt from scratch. |
||
71 | WARNING: This feature is not yet implemented |
||
72 | --rebuild-all Turn on all other rebuild options (currently --rebuild-files |
||
73 | and --rebuild-dbs). |
||
74 | WARNING: This feature depends on rebuild-dbs, which is not |
||
75 | yet implemented; only the --rebuild-files section will be |
||
76 | triggered. |
||
77 | |||
78 | "; |
||
79 | |||
80 | exit(0); |
||
81 | } |
||
82 | |||
1 | magnus | 83 | # First, grab --config and --nodefault options if they exist. We |
84 | # don't want these in the %Options hash, and they affect what we do when |
||
85 | # loading it. |
||
86 | |||
87 | my(@config_files); |
||
88 | my($default); |
||
89 | |||
90 | GetOptions('config=s' => \@config_files, 'default!' => \$default); |
||
91 | |||
92 | # Call Load_Default_Configs if we're loading default values, or |
||
93 | # Load_Minimal_Configs if we're not (we still need the OptionDefs hash to |
||
94 | # be populated). |
||
95 | |||
96 | if (!defined($default) || $default) { |
||
97 | Load_Default_Configs(); |
||
98 | } else { |
||
99 | Load_Minimal_Configs(); |
||
100 | } |
||
101 | |||
102 | # Load any config files we were given. |
||
103 | |||
104 | my($config); |
||
105 | |||
106 | foreach $config (@config_files) { |
||
107 | Load_File_Configs($config); |
||
108 | } |
||
109 | |||
110 | # And finally, pull in any other command line options. |
||
111 | |||
112 | GetOptions(\%Options, values(%OptionDefs)); |
||
113 | |||
114 | # Run the cleanup stuff on %Options. |
||
115 | |||
116 | Clean_Options(); |
||
117 | |||
118 | # Okay. We're more or less ready to go. First, load some modules that we |
||
119 | # know we'll be calling. |
||
120 | |||
121 | use DebPool::Dirs qw(:functions :vars); # Directory management |
||
122 | use DebPool::DB qw(:functions :vars); # Various databases |
||
123 | use DebPool::GnuPG qw(:functions :vars); # GnuPG interaction routines |
||
124 | use DebPool::Gzip qw(:functions :vars); # Gzip interaction routines |
||
125 | use DebPool::Logging qw(:functions :facility :level); # Logging routines |
||
126 | use DebPool::Packages qw(:functions :vars); # Distribution databases |
||
127 | use DebPool::Signal qw(:functions :vars); # Handle signals |
||
128 | |||
129 | # Before we do anything else, let's find out if we need to act as a daemon, |
||
130 | # and if so, whether we can manage to pull it off. |
||
131 | |||
132 | if ($Options{'daemon'}) { |
||
133 | Log_Message("Trying to enter daemon mode.", LOG_GENERAL, LOG_DEBUG); |
||
134 | |||
135 | require Proc::Daemon; |
||
136 | Proc::Daemon::Init(); |
||
137 | |||
138 | Log_Message("Now running as a daemon.", LOG_GENERAL, LOG_DEBUG); |
||
139 | } |
||
140 | |||
141 | # Create the directory tree. This is clean even it it already exists, |
||
142 | # so we can do it every time we start up. I believe the fancy word is |
||
143 | # 'idempotent'. We do this before grabbing a lockfile because it should |
||
144 | # never screw anything up, even if run multiple times at once, and our |
||
145 | # lockfile may be (probably is, in fact) in one of these places. |
||
146 | |||
147 | if (!Create_Tree()) { |
||
148 | my($msg) = "Couldn't create directory tree: $DebPool::Dirs::Error"; |
||
149 | Log_Message($msg, LOG_GENERAL, LOG_FATAL); |
||
150 | die "$msg\n"; |
||
151 | } |
||
152 | |||
153 | # Obtain a lockfile. We should never run more than one occurance; it's too |
||
154 | # likely that we'd step on our own toes. |
||
155 | |||
156 | if (!sysopen(LOCK_FILE, $Options{'lock_file'}, O_WRONLY|O_CREAT|O_EXCL, 0644)) { |
||
157 | my($msg) = "Couldn't obtain lockfile '$Options{'lock_file'}'; "; |
||
158 | |||
159 | if (open(LOCK_FILE, '<', $Options{'lock_file'}) && |
||
160 | (my($pid) = <LOCK_FILE>)) { |
||
161 | chomp($pid); |
||
162 | $msg .= "(PID $pid)\n"; |
||
163 | } else { |
||
164 | $msg .= "(unable to read PID)\n"; |
||
165 | } |
||
166 | |||
167 | die $msg; |
||
168 | } else { # Do something useful - like put our PID into the file. |
||
169 | print LOCK_FILE "$$\n"; |
||
170 | close(LOCK_FILE); |
||
171 | } |
||
172 | |||
173 | # Start the main loop. We use a do/until loop so that we always fire off at |
||
174 | # least once. |
||
175 | |||
176 | MAIN_LOOP: do { |
||
177 | |||
178 | Log_Message("Starting processing run", LOG_GENERAL, LOG_DEBUG); |
||
179 | |||
180 | # First off, open up our databases. We do this each time through the loop, |
||
181 | # so that they get flushed periodically if we're in daemon mode. |
||
182 | |||
183 | Open_Databases(); |
||
184 | |||
185 | # This keeps track of what distributions need to have their Packages and |
||
186 | # Sources files rebuilt. We force it to be 'everything' if the user has |
||
187 | # requested a rebuild (normally from the command line). |
||
188 | |||
189 | my(%rebuild) = (); |
||
190 | |||
191 | if ($Options{'rebuild-files'}) { |
||
192 | my($dist); |
||
193 | foreach $dist (@{$Options{'realdists'}}) { |
||
194 | $rebuild{$dist} = 1; |
||
195 | } |
||
196 | } |
||
197 | |||
198 | # Check for any changes files in the incoming directory. |
||
199 | |||
200 | my(@changefiles) = Scan_Changes($Options{'incoming_dir'}); |
||
201 | |||
202 | # Go through each of the changes files we found, and process it. This is the |
||
203 | # heart of things. |
||
204 | |||
205 | my($changefile); |
||
206 | |||
207 | foreach $changefile (@changefiles) { |
||
208 | Log_Message("Processing changefile '$changefile'", LOG_GENERAL, LOG_INFO); |
||
209 | |||
210 | # .dsc = .changes, minus the part after the last _, plus .dsc |
||
211 | |||
212 | my(@parts) = split(/_/, $changefile); |
||
213 | pop(@parts); |
||
214 | my($dscfile) = join('_', @parts) . '.dsc'; |
||
215 | |||
216 | my($changes_data) = Parse_Changes("$Options{'incoming_dir'}/$changefile"); |
||
217 | if (!defined($changes_data)) { |
||
218 | Log_Message("Failure parsing changes file '$changefile': " . |
||
219 | $DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR); |
||
220 | next; |
||
221 | } |
||
222 | |||
223 | my($with_source) = undef; # Upload with or without source? |
||
224 | my($temp); |
||
225 | |||
226 | for $temp (@{$changes_data->{'Architecture'}}) { |
||
227 | if ('source' eq $temp) { |
||
228 | $with_source = 1; |
||
229 | } |
||
230 | } |
||
231 | |||
232 | my($has_orig) = undef; # Has an orig tarball? |
||
233 | my($filehr); |
||
234 | |||
235 | foreach $filehr (@{$changes_data->{'Files'}}) { |
||
236 | if ($filehr->{'Filename'} =~ /orig\.tar\.gz/) { |
||
237 | $has_orig = 1; |
||
238 | } |
||
239 | } |
||
240 | |||
241 | my($dsc_data) = Parse_DSC("$Options{'incoming_dir'}/$dscfile"); |
||
242 | if ($with_source && !defined($dsc_data)) { |
||
243 | Log_Message("Failure parsing dsc file '$dscfile': " . |
||
244 | $DebPool::Packages::Error, LOG_GENERAL, LOG_ERROR); |
||
245 | next; |
||
246 | } |
||
247 | |||
248 | my($package) = $changes_data->{'Source'}; |
||
249 | my($version) = $changes_data->{'Version'}; |
||
250 | |||
6 | magnus | 251 | if ($Options{'require_sigs_meta'}) { |
1 | magnus | 252 | # First, check the changefile signature |
253 | |||
254 | if (!Check_Signature("$Options{'incoming_dir'}/$changefile")) { |
||
255 | Reject_Package($changefile, $changes_data); |
||
256 | Log_Message("GPG signature failure in changes file '$changefile'", |
||
257 | LOG_REJECT, LOG_ERROR); |
||
258 | next; |
||
259 | } else { |
||
260 | Log_Message("Successful changes signature: '$changefile'", |
||
261 | LOG_GPG, LOG_DEBUG); |
||
262 | } |
||
263 | |||
264 | # Now check the dscfile signature |
||
265 | |||
266 | if ($with_source && !Check_Signature("$Options{'incoming_dir'}/$dscfile")) { |
||
267 | Reject_Package($changefile, $changes_data); |
||
268 | Log_Message("GPG signature failure in dsc file '$dscfile'", |
||
269 | LOG_REJECT, LOG_ERROR); |
||
270 | next; |
||
271 | } else { |
||
272 | Log_Message("Successful dsc signature: '$dscfile'", |
||
273 | LOG_GPG, LOG_DEBUG); |
||
274 | } |
||
275 | } |
||
276 | |||
277 | # Verify MD5 checksums on all files. |
||
278 | |||
279 | my($valid) = 1; |
||
280 | |||
281 | foreach $filehr (@{$changes_data->{'Files'}}) { |
||
282 | if (!(Verify_MD5("$Options{'incoming_dir'}/$filehr->{'Filename'}", |
||
283 | $filehr->{'MD5Sum'}))) { |
||
284 | $valid = undef; |
||
285 | } |
||
286 | } |
||
287 | |||
288 | if (!$valid) { |
||
289 | Reject_Package($changefile, $changes_data); |
||
290 | |||
291 | my($msg) = "MD5 checksum failure in changes file '$changefile'"; |
||
292 | Log_Message($msg, LOG_REJECT, LOG_ERROR); |
||
293 | next; |
||
294 | } |
||
295 | |||
296 | $valid = 1; |
||
297 | my($rejected) = undef; |
||
298 | |||
299 | if ($with_source) { |
||
300 | foreach $filehr (@{$dsc_data->{'Files'}}) { |
||
301 | # A bit of a special case here; if the Changes file lists an |
||
302 | # orig tarball, we must *not* have one for that version in the |
||
303 | # pool. If it doesn't, then we *must* have one. In either case, |
||
304 | # as long as it's in the right place we use that file for the |
||
305 | # MD5Sum check when the file is listed in the DSC. |
||
306 | |||
307 | my($file) = $filehr->{'Filename'}; |
||
308 | |||
309 | if ($file =~ /orig\.tar\.gz/) { |
||
310 | my($section) = Guess_Section($changes_data); |
||
311 | my($pkg_pooldir) = join('/', |
||
312 | ($Options{'pool_dir'}, PoolDir($package, $section), |
||
313 | $package)); |
||
314 | |||
315 | if ($has_orig) { # Orig tarball uploaded |
||
316 | if (-e "$pkg_pooldir/$file") { |
||
317 | Reject_Package($changefile, $changes_data); |
||
318 | |||
319 | my($msg) = "Duplicate orig tarball '$file'"; |
||
320 | Log_Message($msg, LOG_REJECT, LOG_ERROR); |
||
321 | |||
322 | $rejected = 1; |
||
323 | last; # Don't check other files, we just rejected |
||
324 | } elsif (!(-e "$Options{'incoming_dir'}/$file")) { |
||
325 | Reject_Package($changefile, $changes_data); |
||
326 | |||
327 | my($msg) = "Missing orig tarball '$file'"; |
||
328 | Log_Message($msg, LOG_REJECT, LOG_ERROR); |
||
329 | |||
330 | $rejected = 1; |
||
331 | last; # Don't check other files, we just rejected |
||
332 | } else { |
||
333 | $file = "$Options{'incoming_dir'}/$file"; |
||
334 | } |
||
335 | } else { # Orig tarball in pool - we hope |
||
336 | if (!(-e "$pkg_pooldir/$file")) { |
||
337 | Reject_Package($changefile, $changes_data); |
||
338 | |||
339 | my($msg) = "Missing orig tarball '$file'"; |
||
340 | Log_Message($msg, LOG_REJECT, LOG_ERROR); |
||
341 | |||
342 | $rejected = 1; |
||
343 | last; # Don't check other files, we just rejected |
||
344 | } else { |
||
345 | $file = "$pkg_pooldir/$file"; |
||
346 | } |
||
347 | } |
||
348 | } else { # Not an orig tarball - must be in upload |
||
349 | $file = "$Options{'incoming_dir'}/$file"; |
||
350 | } |
||
351 | |||
352 | # Whatever it is, it must also pass the MD5 checksum test. |
||
353 | |||
354 | if (!(Verify_MD5($file, $filehr->{'MD5Sum'}))) { |
||
355 | $valid = undef; |
||
356 | last; # Don't check other files, we already failed |
||
357 | } |
||
358 | } |
||
359 | } |
||
360 | |||
361 | next if ($rejected); # Reject message already logged, go to next package. |
||
362 | |||
363 | if (!$valid) { |
||
364 | Reject_Package($changefile, $changes_data); |
||
365 | |||
366 | my($msg) = "MD5 checksum failure in dsc file '$dscfile'"; |
||
367 | Log_Message($msg, LOG_REJECT, LOG_ERROR); |
||
368 | next; |
||
369 | } |
||
370 | |||
371 | # Go through each distribution in the changes file, and decide whether |
||
372 | # the package is valid for that distribution. |
||
373 | |||
374 | my($distribution, $realdist); |
||
375 | my(@valid_dists); |
||
376 | |||
377 | foreach $distribution (@{$changes_data->{'Distribution'}}) { |
||
378 | $realdist = $distribution; |
||
379 | |||
380 | if (defined($Options{'virtual_dists'}->{$realdist})) { |
||
381 | $realdist = $Options{'virtual_dists'}->{$realdist}; |
||
382 | } |
||
383 | |||
384 | if (defined($Options{'dists'}->{$realdist})) { |
||
385 | $realdist = $Options{'dists'}->{$realdist}; |
||
386 | } |
||
387 | |||
388 | if (!defined($realdist)) { |
||
389 | Log_Message("Distribution $distribution does not exist", |
||
390 | LOG_INSTALL, LOG_ERROR); |
||
391 | next; |
||
392 | } |
||
393 | |||
394 | my($allow) = Allow_Version($package, $version, $realdist); |
||
395 | |||
396 | if (!defined($allow)) { |
||
397 | Log_Message("Version check for $version failed: " . |
||
398 | $DebPool::Packages::Error, LOG_INSTALL, LOG_ERROR); |
||
399 | next; |
||
400 | } |
||
401 | |||
402 | if (!$allow) { |
||
403 | Log_Message("Cannot install version $version of $package to " . |
||
404 | "$realdist", LOG_INSTALL, LOG_WARNING); |
||
405 | next; |
||
406 | } |
||
407 | |||
408 | # It's valid. Put it in the list. |
||
409 | |||
410 | push(@valid_dists, $realdist); |
||
411 | } |
||
412 | |||
413 | if (-1 == $#valid_dists) { |
||
414 | Reject_Package($changefile, $changes_data); |
||
415 | Log_Message("No valid distributions for version $version of $package", |
||
416 | LOG_REJECT, LOG_ERROR); |
||
417 | next; |
||
418 | } |
||
419 | |||
420 | # Install the package |
||
421 | |||
422 | if (Install_Package($changefile, $changes_data, $dscfile, $dsc_data, \@valid_dists)) { |
||
423 | my($dist); |
||
424 | foreach $dist (@valid_dists) { |
||
425 | $rebuild{$dist} = 1; |
||
426 | } |
||
427 | |||
428 | my($msg) = "Installed $package ($version) to "; |
||
429 | $msg .= "distribution(s): " . join(', ', @valid_dists); |
||
430 | Log_Message($msg, LOG_INSTALL, LOG_INFO); |
||
431 | } else { |
||
432 | # Something is very, very wrong. |
||
433 | Log_Message("Couldn't install package '$package': " . |
||
434 | $DebPool::Packages::Error, LOG_INSTALL, LOG_FATAL); |
||
435 | Close_Databases(); |
||
436 | unlink($Options{'lock_file'}); # Release our lock |
||
437 | die "Couldn't install package '$package'\n"; |
||
438 | } |
||
439 | |||
440 | # And, now that that's done, audit the package area in the pool to get |
||
441 | # rid of crufty, obsolete versions. |
||
442 | |||
443 | Audit_Package($package, $changes_data); |
||
444 | } |
||
445 | |||
446 | # Regenerate {Packages,Sources}{,.gz} for distributions which need it. Also |
||
447 | # rebuild Release files that need it, if we're doing them. |
||
448 | |||
449 | my($dist, $section); |
||
450 | |||
451 | foreach $dist (keys(%rebuild)) { |
||
452 | my(@rel_filelist) = (); |
||
453 | foreach $section (@{$Options{'sections'}}) { |
||
454 | my(@archs) = @{$Options{'archs'}}; |
||
455 | @archs = grep(!/^all$/, @archs); # We don't build binary-all files. |
||
456 | |||
457 | my($arch); |
||
458 | |||
459 | ARCH_LOOP: |
||
460 | foreach $arch (@{$Options{'archs'}}) { |
||
461 | # We cheat, and use @triple for dist/section/arch inputs. |
||
462 | # Perl lets us get away with this. I'd care, except that Perl |
||
463 | # prototyping isn't, so it's useless to not do this. |
||
464 | |||
465 | my(@triple) = ($dist, $section, $arch); |
||
466 | |||
467 | # Generate a Packages/Sources file. |
||
468 | |||
469 | my($file) = Generate_List(@triple); |
||
470 | |||
471 | if (!defined($file)) { |
||
472 | my($msg) = "Couldn't create list for $dist/$section/${arch}: "; |
||
473 | $msg .= $DebPool::Packages::Error; |
||
474 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
475 | |||
476 | next; |
||
477 | } |
||
478 | |||
479 | # If we're compressing distribution files, do that here. |
||
480 | |||
481 | my($gzfile); |
||
482 | if ($Options{'compress_dists'}) { |
||
483 | $gzfile = Gzip_File($file); |
||
484 | |||
485 | if (!defined($gzfile)) { |
||
486 | my($msg) = "Couldn't create compressed file: "; |
||
487 | $msg .= $DebPool::Gzip::Error; |
||
488 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
489 | |||
490 | unlink($file); |
||
491 | next; |
||
492 | } |
||
493 | } |
||
494 | |||
495 | # If we're doing Release files, now is the time for triples. |
||
496 | |||
497 | my($relfile); |
||
498 | my($sigfile); |
||
499 | |||
500 | if ($Options{'do_release'}) { |
||
501 | require DebPool::Release; |
||
502 | |||
503 | # Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default. |
||
504 | |||
505 | my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime()); |
||
506 | $relfile = DebPool::Release::Generate_Release_Triple( |
||
507 | @triple, $release_version); |
||
508 | |||
509 | if (!defined($relfile)) { |
||
510 | my($msg) = "Couldn't create Release file: "; |
||
511 | $msg .= $DebPool::Release::Error; |
||
512 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
513 | |||
514 | unlink($file); |
||
515 | if (defined($gzfile)) { |
||
516 | unlink($gzfile); |
||
517 | } |
||
518 | next; |
||
519 | } |
||
520 | |||
521 | if ($Options{'sign_release'}) { |
||
522 | $sigfile = Sign_Release($relfile); |
||
523 | |||
524 | if (!defined($sigfile)) { |
||
525 | my($msg) = "Couldn't create Release signature file: "; |
||
526 | $msg .= $DebPool::GnuPG::Error; |
||
527 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
528 | |||
529 | unlink($file); |
||
530 | |||
531 | if (defined($gzfile)) { |
||
532 | unlink($gzfile); |
||
533 | } |
||
534 | |||
535 | if (defined($relfile)) { |
||
536 | unlink($relfile); |
||
537 | } |
||
538 | |||
539 | next; |
||
540 | } |
||
541 | } |
||
542 | } |
||
543 | |||
544 | # Install {Packages,Sources}{,.gz} |
||
545 | |||
546 | if (!Install_List(@triple, $file, $gzfile)) { |
||
547 | |||
548 | my($msg) = "Couldn't install distribution files for "; |
||
549 | $msg .= "$dist/$section/${arch}: " . $DebPool::Packages::Error; |
||
550 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
551 | |||
552 | if (-e $file) { |
||
553 | unlink($file); |
||
554 | } |
||
555 | |||
556 | if (defined($gzfile) && -e $gzfile) { |
||
557 | unlink($gzfile); |
||
558 | } |
||
559 | |||
560 | if (defined($relfile) && -e $relfile) { |
||
561 | unlink($relfile); |
||
562 | } |
||
563 | |||
564 | if (defined($sigfile) && -e $sigfile) { |
||
565 | unlink($sigfile); |
||
566 | } |
||
567 | |||
568 | next; |
||
569 | } |
||
570 | |||
571 | # Install Release{,.gpg} |
||
572 | |||
573 | if (defined($relfile) && |
||
574 | !DebPool::Release::Install_Release(@triple, $relfile, $sigfile)) { |
||
575 | |||
576 | my($msg) = "Couldn't install release files for "; |
||
577 | $msg .= "$dist/$section/${arch}: " . $DebPool::Release::Error; |
||
578 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
579 | |||
580 | if (-e $relfile) { |
||
581 | unlink($relfile); |
||
582 | } |
||
583 | |||
584 | if (defined($sigfile) && -e $sigfile) { |
||
585 | unlink($sigfile); |
||
586 | } |
||
587 | |||
588 | next; |
||
589 | } |
||
590 | |||
591 | my($pushfile) = Archfile(@triple, 0); |
||
592 | $pushfile =~ s/${dist}\///; |
||
593 | push(@rel_filelist, $pushfile); |
||
594 | |||
595 | if (defined($gzfile)) { |
||
596 | push(@rel_filelist, $pushfile . '.gz'); |
||
597 | } |
||
598 | |||
599 | if (defined($relfile)) { |
||
600 | $pushfile = Archfile(@triple, 1); |
||
601 | $pushfile =~ s/${dist}\///; |
||
602 | $pushfile .= '/Release'; |
||
603 | push(@rel_filelist, $pushfile); |
||
604 | |||
605 | if (defined($sigfile)) { |
||
606 | push(@rel_filelist, $pushfile . '.gpg'); |
||
607 | } |
||
608 | } |
||
609 | } |
||
610 | } |
||
611 | |||
612 | # If we're doing Release files, now is the time for the general dist one. |
||
613 | |||
614 | my($relfile); |
||
615 | my($sigfile); |
||
616 | |||
617 | if ($Options{'do_release'}) { |
||
618 | require DebPool::Release; |
||
619 | |||
620 | # Release versions are YYYY.MM.DD.HH.MM.SS (GMT) by default. |
||
621 | |||
622 | my($release_version) = strftime('%Y.%m.%d.%H.%M.%S', gmtime()); |
||
623 | $relfile = DebPool::Release::Generate_Release_Dist( |
||
624 | $dist, $release_version, @rel_filelist); |
||
625 | |||
626 | if (!defined($relfile)) { |
||
627 | my($msg) = "Couldn't create Release file: "; |
||
628 | $msg .= $DebPool::Release::Error; |
||
629 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
630 | } else { |
||
631 | if ($Options{'sign_release'}) { |
||
632 | $sigfile = Sign_Release($relfile); |
||
633 | |||
634 | if (!defined($sigfile)) { |
||
635 | my($msg) = "Couldn't create Release signature file: "; |
||
636 | $msg .= $DebPool::GnuPG::Error; |
||
637 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
638 | unlink($relfile); |
||
639 | $relfile = undef; |
||
640 | } |
||
641 | } |
||
642 | } |
||
643 | } |
||
644 | |||
645 | # Install Release{,.gpg} |
||
646 | |||
647 | if (defined($relfile) && |
||
648 | !DebPool::Release::Install_Release($dist, undef, undef, |
||
649 | $relfile, $sigfile)) { |
||
650 | my($msg) = "Couldn't install release files for "; |
||
651 | $msg .= "${dist}: " . $DebPool::Release::Error; |
||
652 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
653 | |||
654 | if (-e $relfile) { |
||
655 | unlink($relfile); |
||
656 | } |
||
657 | |||
658 | if (defined($sigfile) && -e $sigfile) { |
||
659 | unlink($sigfile); |
||
660 | } |
||
661 | } |
||
662 | } |
||
663 | |||
664 | # Close out the databases, ensuring that they're flushed to disk. We'll |
||
665 | # just reopen them in a moment, if we're in daemon mode; it's still good to |
||
666 | # write them out. |
||
667 | |||
668 | Close_Databases(); |
||
669 | |||
670 | # This will short-circuit if we catch a signal while sleeping. |
||
671 | |||
672 | if ($Options{'daemon'}) { |
||
673 | Log_Message("Waiting on changes to incoming dir.", LOG_GENERAL, LOG_DEBUG); |
||
674 | |||
675 | if (!Monitor_Incoming()) { |
||
676 | my($msg) = "Error in Monitor_Incoming: " . $DebPool::Dirs::Error; |
||
677 | Log_Message($msg, LOG_GENERAL, LOG_ERROR); |
||
678 | } |
||
679 | } |
||
680 | |||
681 | # End of MAIN_LOOP; we loop back until either we're not in daemon mode |
||
682 | # (that is, we've been told to single-pass), or until we catch a signal. |
||
683 | |||
684 | } until ((!$Options{'daemon'}) || $Signal_Caught); |
||
685 | |||
686 | # Release our lock |
||
687 | |||
688 | unlink($Options{'lock_file'}); |
||
689 | |||
690 | Log_Message("Exiting.", LOG_GENERAL, LOG_DEBUG); |
||
691 | |||
692 | exit(0); |
||
693 | |||
694 | __END__ |
||
695 | |||
696 | # vim:set tabstop=4 expandtab: |