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