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