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