Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org> |
2 | # Copyright © 2008, 2012-2015 Guillem Jover <guillem@debian.org> | |
3 | # | |
4 | # This program is free software; you can redistribute it and/or modify | |
5 | # it under the terms of the GNU General Public License as published by | |
6 | # the Free Software Foundation; either version 2 of the License, or | |
7 | # (at your option) any later version. | |
8 | # | |
9 | # This program is distributed in the hope that it will be useful, | |
10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | # GNU General Public License for more details. | |
13 | # | |
14 | # You should have received a copy of the GNU General Public License | |
15 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
16 | ||
17 | package Dpkg::Source::Package::V1; | |
18 | ||
19 | use strict; | |
20 | use warnings; | |
21 | ||
22 | our $VERSION = '0.01'; | |
23 | ||
24 | use POSIX qw(:errno_h); | |
25 | use Cwd; | |
26 | use File::Basename; | |
27 | use File::Temp qw(tempfile); | |
28 | use File::Spec; | |
29 | ||
30 | use Dpkg (); | |
31 | use Dpkg::Gettext; | |
32 | use Dpkg::ErrorHandling; | |
33 | use Dpkg::Compression; | |
34 | use Dpkg::Source::Archive; | |
35 | use Dpkg::Source::Patch; | |
36 | use Dpkg::Exit qw(push_exit_handler pop_exit_handler); | |
37 | use Dpkg::Source::Functions qw(erasedir); | |
38 | use Dpkg::Source::Package::V3::Native; | |
39 | ||
40 | use parent qw(Dpkg::Source::Package); | |
41 | ||
42 | our $CURRENT_MINOR_VERSION = '0'; | |
43 | ||
44 | sub init_options { | |
45 | my $self = shift; | |
46 | ||
47 | # Don't call $self->SUPER::init_options() on purpose, V1.0 has no | |
48 | # ignore by default | |
49 | if ($self->{options}{diff_ignore_regex}) { | |
50 | $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$'; | |
51 | } else { | |
52 | $self->{options}{diff_ignore_regex} = '(?:^|/)debian/source/local-.*$'; | |
53 | } | |
54 | $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$'; | |
55 | push @{$self->{options}{tar_ignore}}, | |
56 | 'debian/source/local-options', | |
57 | 'debian/source/local-patch-header', | |
58 | 'debian/files', | |
59 | 'debian/files.new'; | |
60 | $self->{options}{sourcestyle} //= 'X'; | |
61 | $self->{options}{skip_debianization} //= 0; | |
62 | $self->{options}{ignore_bad_version} //= 0; | |
63 | $self->{options}{abort_on_upstream_changes} //= 0; | |
64 | ||
65 | # V1.0 only supports gzip compression. | |
66 | $self->{options}{compression} //= 'gzip'; | |
67 | $self->{options}{comp_level} //= compression_get_property('gzip', 'default_level'); | |
68 | $self->{options}{comp_ext} //= compression_get_property('gzip', 'file_ext'); | |
69 | } | |
70 | ||
71 | my @module_cmdline = ( | |
72 | { | |
73 | name => '-sa', | |
74 | help => N_('auto select original source'), | |
75 | when => 'build', | |
76 | }, { | |
77 | name => '-sk', | |
78 | help => N_('use packed original source (unpack and keep)'), | |
79 | when => 'build', | |
80 | }, { | |
81 | name => '-sp', | |
82 | help => N_('use packed original source (unpack and remove)'), | |
83 | when => 'build', | |
84 | }, { | |
85 | name => '-su', | |
86 | help => N_('use unpacked original source (pack and keep)'), | |
87 | when => 'build', | |
88 | }, { | |
89 | name => '-sr', | |
90 | help => N_('use unpacked original source (pack and remove)'), | |
91 | when => 'build', | |
92 | }, { | |
93 | name => '-ss', | |
94 | help => N_('trust packed and unpacked original sources are same'), | |
95 | when => 'build', | |
96 | }, { | |
97 | name => '-sn', | |
98 | help => N_('there is no diff, do main tarfile only'), | |
99 | when => 'build', | |
100 | }, { | |
101 | name => '-sA, -sK, -sP, -sU, -sR', | |
102 | help => N_('like -sa, -sk, -sp, -su, -sr but may overwrite'), | |
103 | when => 'build', | |
104 | }, { | |
105 | name => '--abort-on-upstream-changes', | |
106 | help => N_('abort if generated diff has upstream files changes'), | |
107 | when => 'build', | |
108 | }, { | |
109 | name => '-sp', | |
110 | help => N_('leave original source packed in current directory'), | |
111 | when => 'extract', | |
112 | }, { | |
113 | name => '-su', | |
114 | help => N_('do not copy original source to current directory'), | |
115 | when => 'extract', | |
116 | }, { | |
117 | name => '-sn', | |
118 | help => N_('unpack original source tree too'), | |
119 | when => 'extract', | |
120 | }, { | |
121 | name => '--skip-debianization', | |
122 | help => N_('do not apply debian diff to upstream sources'), | |
123 | when => 'extract', | |
124 | }, | |
125 | ); | |
126 | ||
127 | sub describe_cmdline_options { | |
128 | return @module_cmdline; | |
129 | } | |
130 | ||
131 | sub parse_cmdline_option { | |
132 | my ($self, $opt) = @_; | |
133 | my $o = $self->{options}; | |
134 | if ($opt =~ m/^-s([akpursnAKPUR])$/) { | |
135 | warning(g_('-s%s option overrides earlier -s%s option'), $1, | |
136 | $o->{sourcestyle}) if $o->{sourcestyle} ne 'X'; | |
137 | $o->{sourcestyle} = $1; | |
138 | $o->{copy_orig_tarballs} = 0 if $1 eq 'n'; # Extract option -sn | |
139 | return 1; | |
140 | } elsif ($opt eq '--skip-debianization') { | |
141 | $o->{skip_debianization} = 1; | |
142 | return 1; | |
143 | } elsif ($opt eq '--ignore-bad-version') { | |
144 | $o->{ignore_bad_version} = 1; | |
145 | return 1; | |
146 | } elsif ($opt eq '--abort-on-upstream-changes') { | |
147 | $o->{abort_on_upstream_changes} = 1; | |
148 | return 1; | |
149 | } | |
150 | return 0; | |
151 | } | |
152 | ||
153 | sub do_extract { | |
154 | my ($self, $newdirectory) = @_; | |
155 | my $sourcestyle = $self->{options}{sourcestyle}; | |
156 | my $fields = $self->{fields}; | |
157 | ||
158 | $sourcestyle =~ y/X/p/; | |
159 | unless ($sourcestyle =~ m/[pun]/) { | |
160 | usageerr(g_('source handling style -s%s not allowed with -x'), | |
161 | $sourcestyle); | |
162 | } | |
163 | ||
164 | my $dscdir = $self->{basedir}; | |
165 | ||
166 | my $basename = $self->get_basename(); | |
167 | my $basenamerev = $self->get_basename(1); | |
168 | ||
169 | # V1.0 only supports gzip compression | |
170 | my ($tarfile, $difffile); | |
171 | my $tarsign; | |
172 | foreach my $file ($self->get_files()) { | |
173 | if ($file =~ /^(?:\Q$basename\E\.orig|\Q$basenamerev\E)\.tar\.gz$/) { | |
174 | error(g_('multiple tarfiles in v1.0 source package')) if $tarfile; | |
175 | $tarfile = $file; | |
176 | } elsif ($file =~ /^\Q$basename\E\.orig\.tar\.gz\.asc$/) { | |
177 | $tarsign = $file; | |
178 | } elsif ($file =~ /^\Q$basenamerev\E\.diff\.gz$/) { | |
179 | $difffile = $file; | |
180 | } else { | |
181 | error(g_('unrecognized file for a %s source package: %s'), | |
182 | 'v1.0', $file); | |
183 | } | |
184 | } | |
185 | ||
186 | error(g_('no tarfile in Files field')) unless $tarfile; | |
187 | my $native = $difffile ? 0 : 1; | |
188 | if ($native and ($tarfile =~ /\.orig\.tar\.gz$/)) { | |
189 | warning(g_('native package with .orig.tar')); | |
190 | $native = 0; # V3::Native doesn't handle orig.tar | |
191 | } | |
192 | ||
193 | if ($native) { | |
194 | Dpkg::Source::Package::V3::Native::do_extract($self, $newdirectory); | |
195 | } else { | |
196 | my $expectprefix = $newdirectory; | |
197 | $expectprefix .= '.orig'; | |
198 | ||
199 | if ($self->{options}{no_overwrite_dir} and -e $newdirectory) { | |
200 | error(g_('unpack target exists: %s'), $newdirectory); | |
201 | } else { | |
202 | erasedir($newdirectory); | |
203 | } | |
204 | if (-e $expectprefix) { | |
205 | rename($expectprefix, "$newdirectory.tmp-keep") | |
206 | or syserr(g_("unable to rename '%s' to '%s'"), $expectprefix, | |
207 | "$newdirectory.tmp-keep"); | |
208 | } | |
209 | ||
210 | info(g_('unpacking %s'), $tarfile); | |
211 | my $tar = Dpkg::Source::Archive->new(filename => "$dscdir$tarfile"); | |
212 | $tar->extract($expectprefix); | |
213 | ||
214 | if ($sourcestyle =~ /u/) { | |
215 | # -su: keep .orig directory unpacked | |
216 | if (-e "$newdirectory.tmp-keep") { | |
217 | error(g_('unable to keep orig directory (already exists)')); | |
218 | } | |
219 | system('cp', '-ar', '--', $expectprefix, "$newdirectory.tmp-keep"); | |
220 | subprocerr("cp $expectprefix to $newdirectory.tmp-keep") if $?; | |
221 | } | |
222 | ||
223 | rename($expectprefix, $newdirectory) | |
224 | or syserr(g_('failed to rename newly-extracted %s to %s'), | |
225 | $expectprefix, $newdirectory); | |
226 | ||
227 | # rename the copied .orig directory | |
228 | if (-e "$newdirectory.tmp-keep") { | |
229 | rename("$newdirectory.tmp-keep", $expectprefix) | |
230 | or syserr(g_('failed to rename saved %s to %s'), | |
231 | "$newdirectory.tmp-keep", $expectprefix); | |
232 | } | |
233 | } | |
234 | ||
235 | if ($difffile and not $self->{options}{skip_debianization}) { | |
236 | my $patch = "$dscdir$difffile"; | |
237 | info(g_('applying %s'), $difffile); | |
238 | my $patch_obj = Dpkg::Source::Patch->new(filename => $patch); | |
239 | my $analysis = $patch_obj->apply($newdirectory, force_timestamp => 1); | |
240 | my @files = grep { ! m{^\Q$newdirectory\E/debian/} } | |
241 | sort keys %{$analysis->{filepatched}}; | |
242 | info(g_('upstream files that have been modified: %s'), | |
243 | "\n " . join("\n ", @files)) if scalar @files; | |
244 | } | |
245 | } | |
246 | ||
247 | sub can_build { | |
248 | my ($self, $dir) = @_; | |
249 | ||
250 | # As long as we can use gzip, we can do it as we have | |
251 | # native packages as fallback | |
252 | return (0, g_('only supports gzip compression')) | |
253 | unless $self->{options}{compression} eq 'gzip'; | |
254 | return 1; | |
255 | } | |
256 | ||
257 | sub do_build { | |
258 | my ($self, $dir) = @_; | |
259 | my $sourcestyle = $self->{options}{sourcestyle}; | |
260 | my @argv = @{$self->{options}{ARGV}}; | |
261 | my @tar_ignore = map { "--exclude=$_" } @{$self->{options}{tar_ignore}}; | |
262 | my $diff_ignore_regex = $self->{options}{diff_ignore_regex}; | |
263 | ||
264 | if (scalar(@argv) > 1) { | |
265 | usageerr(g_('-b takes at most a directory and an orig source ' . | |
266 | 'argument (with v1.0 source package)')); | |
267 | } | |
268 | ||
269 | $sourcestyle =~ y/X/A/; | |
270 | unless ($sourcestyle =~ m/[akpursnAKPUR]/) { | |
271 | usageerr(g_('source handling style -s%s not allowed with -b'), | |
272 | $sourcestyle); | |
273 | } | |
274 | ||
275 | my $sourcepackage = $self->{fields}{'Source'}; | |
276 | my $basenamerev = $self->get_basename(1); | |
277 | my $basename = $self->get_basename(); | |
278 | my $basedirname = $basename; | |
279 | $basedirname =~ s/_/-/; | |
280 | ||
281 | # Try to find a .orig tarball for the package | |
282 | my $origdir = "$dir.orig"; | |
283 | my $origtargz = $self->get_basename() . '.orig.tar.gz'; | |
284 | if (-e $origtargz) { | |
285 | unless (-f $origtargz) { | |
286 | error(g_("packed orig '%s' exists but is not a plain file"), $origtargz); | |
287 | } | |
288 | } else { | |
289 | $origtargz = undef; | |
290 | } | |
291 | ||
292 | if (@argv) { | |
293 | # We have a second-argument <orig-dir> or <orig-targz>, check what it | |
294 | # is to decide the mode to use | |
295 | my $origarg = shift(@argv); | |
296 | if (length($origarg)) { | |
297 | stat($origarg) | |
298 | or syserr(g_('cannot stat orig argument %s'), $origarg); | |
299 | if (-d _) { | |
300 | $origdir = File::Spec->catdir($origarg); | |
301 | ||
302 | $sourcestyle =~ y/aA/rR/; | |
303 | unless ($sourcestyle =~ m/[ursURS]/) { | |
304 | error(g_('orig argument is unpacked but source handling ' . | |
305 | 'style -s%s calls for packed (.orig.tar.<ext>)'), | |
306 | $sourcestyle); | |
307 | } | |
308 | } elsif (-f _) { | |
309 | $origtargz = $origarg; | |
310 | $sourcestyle =~ y/aA/pP/; | |
311 | unless ($sourcestyle =~ m/[kpsKPS]/) { | |
312 | error(g_('orig argument is packed but source handling ' . | |
313 | 'style -s%s calls for unpacked (.orig/)'), | |
314 | $sourcestyle); | |
315 | } | |
316 | } else { | |
317 | error(g_('orig argument %s is not a plain file or directory'), | |
318 | $origarg); | |
319 | } | |
320 | } else { | |
321 | $sourcestyle =~ y/aA/nn/; | |
322 | unless ($sourcestyle =~ m/n/) { | |
323 | error(g_('orig argument is empty (means no orig, no diff) ' . | |
324 | 'but source handling style -s%s wants something'), | |
325 | $sourcestyle); | |
326 | } | |
327 | } | |
328 | } elsif ($sourcestyle =~ m/[aA]/) { | |
329 | # We have no explicit <orig-dir> or <orig-targz>, try to use | |
330 | # a .orig tarball first, then a .orig directory and fall back to | |
331 | # creating a native .tar.gz | |
332 | if ($origtargz) { | |
333 | $sourcestyle =~ y/aA/pP/; # .orig.tar.<ext> | |
334 | } else { | |
335 | if (stat($origdir)) { | |
336 | unless (-d _) { | |
337 | error(g_("unpacked orig '%s' exists but is not a directory"), | |
338 | $origdir); | |
339 | } | |
340 | $sourcestyle =~ y/aA/rR/; # .orig directory | |
341 | } elsif ($! != ENOENT) { | |
342 | syserr(g_("unable to stat putative unpacked orig '%s'"), $origdir); | |
343 | } else { | |
344 | $sourcestyle =~ y/aA/nn/; # Native tar.gz | |
345 | } | |
346 | } | |
347 | } | |
348 | ||
349 | my ($dirname, $dirbase) = fileparse($dir); | |
350 | if ($dirname ne $basedirname) { | |
351 | warning(g_("source directory '%s' is not <sourcepackage>" . | |
352 | "-<upstreamversion> '%s'"), $dir, $basedirname); | |
353 | } | |
354 | ||
355 | my ($tarname, $tardirname, $tardirbase); | |
356 | my $tarsign; | |
357 | if ($sourcestyle ne 'n') { | |
358 | my ($origdirname, $origdirbase) = fileparse($origdir); | |
359 | ||
360 | if ($origdirname ne "$basedirname.orig") { | |
361 | warning(g_('.orig directory name %s is not <package>' . | |
362 | '-<upstreamversion> (wanted %s)'), | |
363 | $origdirname, "$basedirname.orig"); | |
364 | } | |
365 | $tardirbase = $origdirbase; | |
366 | $tardirname = $origdirname; | |
367 | ||
368 | $tarname = $origtargz || "$basename.orig.tar.gz"; | |
369 | $tarsign = "$tarname.asc"; | |
370 | unless ($tarname =~ /\Q$basename\E\.orig\.tar\.gz/) { | |
371 | warning(g_('.orig.tar name %s is not <package>_<upstreamversion>' . | |
372 | '.orig.tar (wanted %s)'), | |
373 | $tarname, "$basename.orig.tar.gz"); | |
374 | } | |
375 | } | |
376 | ||
377 | if ($sourcestyle eq 'n') { | |
378 | $self->{options}{ARGV} = []; # ensure we have no error | |
379 | Dpkg::Source::Package::V3::Native::do_build($self, $dir); | |
380 | } elsif ($sourcestyle =~ m/[urUR]/) { | |
381 | if (stat($tarname)) { | |
382 | unless ($sourcestyle =~ m/[UR]/) { | |
383 | error(g_("tarfile '%s' already exists, not overwriting, " . | |
384 | 'giving up; use -sU or -sR to override'), $tarname); | |
385 | } | |
386 | } elsif ($! != ENOENT) { | |
387 | syserr(g_("unable to check for existence of '%s'"), $tarname); | |
388 | } | |
389 | ||
390 | info(g_('building %s in %s'), | |
391 | $sourcepackage, $tarname); | |
392 | ||
393 | my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX", | |
394 | DIR => getcwd(), UNLINK => 0); | |
395 | my $tar = Dpkg::Source::Archive->new(filename => $newtar, | |
396 | compression => compression_guess_from_filename($tarname), | |
397 | compression_level => $self->{options}{comp_level}); | |
398 | $tar->create(options => \@tar_ignore, chdir => $tardirbase); | |
399 | $tar->add_directory($tardirname); | |
400 | $tar->finish(); | |
401 | rename($newtar, $tarname) | |
402 | or syserr(g_("unable to rename '%s' (newly created) to '%s'"), | |
403 | $newtar, $tarname); | |
404 | chmod(0666 &~ umask(), $tarname) | |
405 | or syserr(g_("unable to change permission of '%s'"), $tarname); | |
406 | } else { | |
407 | info(g_('building %s using existing %s'), | |
408 | $sourcepackage, $tarname); | |
409 | } | |
410 | ||
411 | $self->add_file($tarname) if $tarname; | |
412 | # XXX: Re-enable once a stable dpkg supports extracting upstream signatures | |
413 | # for source 1.0 format, either in 1.17.x or 1.18.x. | |
414 | #$self->add_file($tarsign) if $tarsign and -e $tarsign; | |
415 | ||
416 | if ($sourcestyle =~ m/[kpKP]/) { | |
417 | if (stat($origdir)) { | |
418 | unless ($sourcestyle =~ m/[KP]/) { | |
419 | error(g_("orig directory '%s' already exists, not overwriting, ". | |
420 | 'giving up; use -sA, -sK or -sP to override'), | |
421 | $origdir); | |
422 | } | |
423 | push_exit_handler(sub { erasedir($origdir) }); | |
424 | erasedir($origdir); | |
425 | pop_exit_handler(); | |
426 | } elsif ($! != ENOENT) { | |
427 | syserr(g_("unable to check for existence of orig directory '%s'"), | |
428 | $origdir); | |
429 | } | |
430 | ||
431 | my $tar = Dpkg::Source::Archive->new(filename => $origtargz); | |
432 | $tar->extract($origdir); | |
433 | } | |
434 | ||
435 | my $ur; # Unrepresentable changes | |
436 | if ($sourcestyle =~ m/[kpursKPUR]/) { | |
437 | my $diffname = "$basenamerev.diff.gz"; | |
438 | info(g_('building %s in %s'), | |
439 | $sourcepackage, $diffname); | |
440 | my ($ndfh, $newdiffgz) = tempfile("$diffname.new.XXXXXX", | |
441 | DIR => getcwd(), UNLINK => 0); | |
442 | push_exit_handler(sub { unlink($newdiffgz) }); | |
443 | my $diff = Dpkg::Source::Patch->new(filename => $newdiffgz, | |
444 | compression => 'gzip', | |
445 | compression_level => $self->{options}{comp_level}); | |
446 | $diff->create(); | |
447 | $diff->add_diff_directory($origdir, $dir, | |
448 | basedirname => $basedirname, | |
449 | diff_ignore_regex => $diff_ignore_regex, | |
450 | options => []); # Force empty set of options to drop the | |
451 | # default -p option | |
452 | $diff->finish() || $ur++; | |
453 | pop_exit_handler(); | |
454 | ||
455 | my $analysis = $diff->analyze($origdir); | |
456 | my @files = grep { ! m{^debian/} } | |
457 | map { s{^[^/]+/+}{}r } | |
458 | sort keys %{$analysis->{filepatched}}; | |
459 | if (scalar @files) { | |
460 | warning(g_('the diff modifies the following upstream files: %s'), | |
461 | "\n " . join("\n ", @files)); | |
462 | info(g_("use the '3.0 (quilt)' format to have separate and " . | |
463 | 'documented changes to upstream files, see dpkg-source(1)')); | |
464 | error(g_('aborting due to --abort-on-upstream-changes')) | |
465 | if $self->{options}{abort_on_upstream_changes}; | |
466 | } | |
467 | ||
468 | rename($newdiffgz, $diffname) | |
469 | or syserr(g_("unable to rename '%s' (newly created) to '%s'"), | |
470 | $newdiffgz, $diffname); | |
471 | chmod(0666 &~ umask(), $diffname) | |
472 | or syserr(g_("unable to change permission of '%s'"), $diffname); | |
473 | ||
474 | $self->add_file($diffname); | |
475 | } | |
476 | ||
477 | if ($sourcestyle =~ m/[prPR]/) { | |
478 | erasedir($origdir); | |
479 | } | |
480 | ||
481 | if ($ur) { | |
482 | errormsg(g_('unrepresentable changes to source')); | |
483 | exit(1); | |
484 | } | |
485 | } | |
486 | ||
487 | 1; |