1# Copyright © 2008-2011 Raphaël Hertzog <hertzog@debian.org>
2# Copyright © 2008-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;
18
19=encoding utf8
20
21=head1 NAME
22
23Dpkg::Source::Package - manipulate Debian source packages
24
25=head1 DESCRIPTION
26
27This module provides an object that can manipulate Debian source
28packages. While it supports both the extraction and the creation
29of source packages, the only API that is officially supported
30is the one that supports the extraction of the source package.
31
32=cut
33
34use strict;
35use warnings;
36
37our $VERSION = '1.03';
38our @EXPORT_OK = qw(
39    get_default_diff_ignore_regex
40    set_default_diff_ignore_regex
41    get_default_tar_ignore_pattern
42);
43
44use Exporter qw(import);
45use POSIX qw(:errno_h :sys_wait_h);
46use Carp;
47use File::Basename;
48
49use Dpkg::Gettext;
50use Dpkg::ErrorHandling;
51use Dpkg::Control;
52use Dpkg::Checksums;
53use Dpkg::Version;
54use Dpkg::Compression;
55use Dpkg::Exit qw(run_exit_handlers);
56use Dpkg::Path qw(check_files_are_the_same find_command);
57use Dpkg::IPC;
58use Dpkg::Vendor qw(run_vendor_hook);
59use Dpkg::Source::Format;
60
61my $diff_ignore_default_regex = '
62# Ignore general backup files
63(?:^|/).*~$|
64# Ignore emacs recovery files
65(?:^|/)\.#.*$|
66# Ignore vi swap files
67(?:^|/)\..*\.sw.$|
68# Ignore baz-style junk files or directories
69(?:^|/),,.*(?:$|/.*$)|
70# File-names that should be ignored (never directories)
71(?:^|/)(?:DEADJOE|\.arch-inventory|\.(?:bzr|cvs|hg|git|mtn-)ignore)$|
72# File or directory names that should be ignored
73(?:^|/)(?:CVS|RCS|\.deps|\{arch\}|\.arch-ids|\.svn|
74\.hg(?:tags|sigs)?|_darcs|\.git(?:attributes|modules|review)?|
75\.mailmap|\.shelf|_MTN|\.be|\.bzr(?:\.backup|tags)?)(?:$|/.*$)
76';
77# Take out comments and newlines
78$diff_ignore_default_regex =~ s/^#.*$//mg;
79$diff_ignore_default_regex =~ s/\n//sg;
80
81# Public variables
82# XXX: Backwards compatibility, stop exporting on VERSION 2.00.
83## no critic (Variables::ProhibitPackageVars)
84our $diff_ignore_default_regexp;
85*diff_ignore_default_regexp = \$diff_ignore_default_regex;
86
87no warnings 'qw'; ## no critic (TestingAndDebugging::ProhibitNoWarnings)
88our @tar_ignore_default_pattern = qw(
89*.a
90*.la
91*.o
92*.so
93.*.sw?
94*/*~
95,,*
96.[#~]*
97.arch-ids
98.arch-inventory
99.be
100.bzr
101.bzr.backup
102.bzr.tags
103.bzrignore
104.cvsignore
105.deps
106.git
107.gitattributes
108.gitignore
109.gitmodules
110.gitreview
111.hg
112.hgignore
113.hgsigs
114.hgtags
115.mailmap
116.mtn-ignore
117.shelf
118.svn
119CVS
120DEADJOE
121RCS
122_MTN
123_darcs
124{arch}
125);
126## use critic
127
128=head1 FUNCTIONS
129
130=over 4
131
132=item $string = get_default_diff_ignore_regex()
133
134Returns the default diff ignore regex.
135
136=cut
137
138sub get_default_diff_ignore_regex {
139    return $diff_ignore_default_regex;
140}
141
142=item set_default_diff_ignore_regex($string)
143
144Set a regex as the new default diff ignore regex.
145
146=cut
147
148sub set_default_diff_ignore_regex {
149    my $regex = shift;
150
151    $diff_ignore_default_regex = $regex;
152}
153
154=item @array = get_default_tar_ignore_pattern()
155
156Returns the default tar ignore pattern, as an array.
157
158=cut
159
160sub get_default_tar_ignore_pattern {
161    return @tar_ignore_default_pattern;
162}
163
164=back
165
166=head1 METHODS
167
168=over 4
169
170=item $p = Dpkg::Source::Package->new(%opts, options => {})
171
172Creates a new object corresponding to a source package. When the key
173B<filename> is set to a F<.dsc> file, it will be used to initialize the
174source package with its description. Otherwise if the B<format> key is
175set to a valid value, the object will be initialized for that format
176(since dpkg 1.19.3).
177
178The B<options> key is a hash ref which supports the following options:
179
180=over 8
181
182=item skip_debianization
183
184If set to 1, do not apply Debian changes on the extracted source package.
185
186=item skip_patches
187
188If set to 1, do not apply Debian-specific patches. This options is
189specific for source packages using format "2.0" and "3.0 (quilt)".
190
191=item require_valid_signature
192
193If set to 1, the check_signature() method will be stricter and will error
194out if the signature can't be verified.
195
196=item require_strong_checksums
197
198If set to 1, the check_checksums() method will be stricter and will error
199out if there is no strong checksum.
200
201=item copy_orig_tarballs
202
203If set to 1, the extraction will copy the upstream tarballs next the
204target directory. This is useful if you want to be able to rebuild the
205source package after its extraction.
206
207=back
208
209=cut
210
211# Object methods
212sub new {
213    my ($this, %args) = @_;
214    my $class = ref($this) || $this;
215    my $self = {
216        fields => Dpkg::Control->new(type => CTRL_PKG_SRC),
217        format => Dpkg::Source::Format->new(),
218        options => {},
219        checksums => Dpkg::Checksums->new(),
220    };
221    bless $self, $class;
222    if (exists $args{options}) {
223        $self->{options} = $args{options};
224    }
225    if (exists $args{filename}) {
226        $self->initialize($args{filename});
227        $self->init_options();
228    } elsif ($args{format}) {
229        $self->{fields}{Format} = $args{format};
230        $self->upgrade_object_type(0);
231        $self->init_options();
232    }
233    return $self;
234}
235
236sub init_options {
237    my $self = shift;
238    # Use full ignore list by default
239    # note: this function is not called by V1 packages
240    $self->{options}{diff_ignore_regex} ||= $diff_ignore_default_regex;
241    $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/source/local-.*$';
242    $self->{options}{diff_ignore_regex} .= '|(?:^|/)debian/files(?:\.new)?$';
243    if (defined $self->{options}{tar_ignore}) {
244        $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ]
245            unless @{$self->{options}{tar_ignore}};
246    } else {
247        $self->{options}{tar_ignore} = [ @tar_ignore_default_pattern ];
248    }
249    push @{$self->{options}{tar_ignore}},
250         'debian/source/local-options',
251         'debian/source/local-patch-header',
252         'debian/files',
253         'debian/files.new';
254    # Skip debianization while specific to some formats has an impact
255    # on code common to all formats
256    $self->{options}{skip_debianization} //= 0;
257
258    # Set default compressor for new formats.
259    $self->{options}{compression} //= 'xz';
260    $self->{options}{comp_level} //= compression_get_property($self->{options}{compression},
261                                                              'default_level');
262    $self->{options}{comp_ext} //= compression_get_property($self->{options}{compression},
263                                                            'file_ext');
264}
265
266sub initialize {
267    my ($self, $filename) = @_;
268    my ($fn, $dir) = fileparse($filename);
269    error(g_('%s is not the name of a file'), $filename) unless $fn;
270    $self->{basedir} = $dir || './';
271    $self->{filename} = $fn;
272
273    # Read the fields
274    my $fields = $self->{fields};
275    $fields->load($filename);
276    $self->{is_signed} = $fields->get_option('is_pgp_signed');
277
278    foreach my $f (qw(Source Version Files)) {
279        unless (defined($fields->{$f})) {
280            error(g_('missing critical source control field %s'), $f);
281        }
282    }
283
284    $self->{checksums}->add_from_control($fields, use_files_for_md5 => 1);
285
286    $self->upgrade_object_type(0);
287}
288
289sub upgrade_object_type {
290    my ($self, $update_format) = @_;
291    $update_format //= 1;
292
293    my $format = $self->{fields}{'Format'} // '1.0';
294    my ($major, $minor, $variant) = $self->{format}->set($format);
295
296    my $module = "Dpkg::Source::Package::V$major";
297    $module .= '::' . ucfirst $variant if defined $variant;
298    eval qq{
299        pop \@INC if \$INC[-1] eq '.';
300        require $module;
301        \$minor = \$${module}::CURRENT_MINOR_VERSION;
302    };
303    if ($@) {
304        error(g_("source package format '%s' is not supported: %s"),
305              $format, $@);
306    }
307    if ($update_format) {
308        $self->{format}->set_from_parts($major, $minor, $variant);
309        $self->{fields}{'Format'} = $self->{format}->get();
310    }
311
312    $module->prerequisites() if $module->can('prerequisites');
313    bless $self, $module;
314}
315
316=item $p->get_filename()
317
318Returns the filename of the DSC file.
319
320=cut
321
322sub get_filename {
323    my $self = shift;
324    return $self->{basedir} . $self->{filename};
325}
326
327=item $p->get_files()
328
329Returns the list of files referenced by the source package. The filenames
330usually do not have any path information.
331
332=cut
333
334sub get_files {
335    my $self = shift;
336    return $self->{checksums}->get_files();
337}
338
339=item $p->check_checksums()
340
341Verify the checksums embedded in the DSC file. It requires the presence of
342the other files constituting the source package. If any inconsistency is
343discovered, it immediately errors out. It will make sure at least one strong
344checksum is present.
345
346If the object has been created with the "require_strong_checksums" option,
347then any problem will result in a fatal error.
348
349=cut
350
351sub check_checksums {
352    my $self = shift;
353    my $checksums = $self->{checksums};
354    my $warn_on_weak = 0;
355
356    # add_from_file verify the checksums if they are already existing
357    foreach my $file ($checksums->get_files()) {
358        if (not $checksums->has_strong_checksums($file)) {
359            if ($self->{options}{require_strong_checksums}) {
360                error(g_('source package uses only weak checksums'));
361            } else {
362                $warn_on_weak = 1;
363            }
364        }
365	$checksums->add_from_file($self->{basedir} . $file, key => $file);
366    }
367
368    warning(g_('source package uses only weak checksums')) if $warn_on_weak;
369}
370
371sub get_basename {
372    my ($self, $with_revision) = @_;
373    my $f = $self->{fields};
374    unless (exists $f->{'Source'} and exists $f->{'Version'}) {
375        error(g_('%s and %s fields are required to compute the source basename'),
376              'Source', 'Version');
377    }
378    my $v = Dpkg::Version->new($f->{'Version'});
379    my $vs = $v->as_string(omit_epoch => 1, omit_revision => !$with_revision);
380    return $f->{'Source'} . '_' . $vs;
381}
382
383sub find_original_tarballs {
384    my ($self, %opts) = @_;
385    $opts{extension} //= compression_get_file_extension_regex();
386    $opts{include_main} //= 1;
387    $opts{include_supplementary} //= 1;
388    my $basename = $self->get_basename();
389    my @tar;
390    foreach my $dir ('.', $self->{basedir}, $self->{options}{origtardir}) {
391        next unless defined($dir) and -d $dir;
392        opendir(my $dir_dh, $dir) or syserr(g_('cannot opendir %s'), $dir);
393        push @tar, map { "$dir/$_" } grep {
394		($opts{include_main} and
395		 /^\Q$basename\E\.orig\.tar\.$opts{extension}$/) or
396		($opts{include_supplementary} and
397		 /^\Q$basename\E\.orig-[[:alnum:]-]+\.tar\.$opts{extension}$/)
398	    } readdir($dir_dh);
399        closedir($dir_dh);
400    }
401    return @tar;
402}
403
404=item $bool = $p->is_signed()
405
406Returns 1 if the DSC files contains an embedded OpenPGP signature.
407Otherwise returns 0.
408
409=cut
410
411sub is_signed {
412    my $self = shift;
413    return $self->{is_signed};
414}
415
416=item $p->check_signature()
417
418Implement the same OpenPGP signature check that dpkg-source does.
419In case of problems, it prints a warning or errors out.
420
421If the object has been created with the "require_valid_signature" option,
422then any problem will result in a fatal error.
423
424=cut
425
426sub check_signature {
427    my $self = shift;
428    my $dsc = $self->get_filename();
429    my @exec;
430
431    if (find_command('gpgv2')) {
432        push @exec, 'gpgv2';
433    } elsif (find_command('gpgv')) {
434        push @exec, 'gpgv';
435    } elsif (find_command('gpg2')) {
436        push @exec, 'gpg2', '--no-default-keyring', '-q', '--verify';
437    } elsif (find_command('gpg')) {
438        push @exec, 'gpg', '--no-default-keyring', '-q', '--verify';
439    }
440    if (scalar(@exec)) {
441        if (length $ENV{HOME} and -r "$ENV{HOME}/.gnupg/trustedkeys.gpg") {
442            push @exec, '--keyring', "$ENV{HOME}/.gnupg/trustedkeys.gpg";
443        }
444        foreach my $vendor_keyring (run_vendor_hook('package-keyrings')) {
445            if (-r $vendor_keyring) {
446                push @exec, '--keyring', $vendor_keyring;
447            }
448        }
449        push @exec, $dsc;
450
451        my ($stdout, $stderr);
452        spawn(exec => \@exec, wait_child => 1, nocheck => 1,
453              to_string => \$stdout, error_to_string => \$stderr,
454              timeout => 10);
455        if (WIFEXITED($?)) {
456            my $gpg_status = WEXITSTATUS($?);
457            print { *STDERR } "$stdout$stderr" if $gpg_status;
458            if ($gpg_status == 1 or ($gpg_status &&
459                $self->{options}{require_valid_signature}))
460            {
461                error(g_('failed to verify signature on %s'), $dsc);
462            } elsif ($gpg_status) {
463                warning(g_('failed to verify signature on %s'), $dsc);
464            }
465        } else {
466            subprocerr("@exec");
467        }
468    } else {
469        if ($self->{options}{require_valid_signature}) {
470            error(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
471        } else {
472            warning(g_('cannot verify signature on %s since GnuPG is not installed'), $dsc);
473        }
474    }
475}
476
477sub describe_cmdline_options {
478    return;
479}
480
481sub parse_cmdline_options {
482    my ($self, @opts) = @_;
483    foreach my $option (@opts) {
484        if (not $self->parse_cmdline_option($option)) {
485            warning(g_('%s is not a valid option for %s'), $option, ref $self);
486        }
487    }
488}
489
490sub parse_cmdline_option {
491    return 0;
492}
493
494=item $p->extract($targetdir)
495
496Extracts the source package in the target directory $targetdir. Beware
497that if $targetdir already exists, it will be erased (as long as the
498no_overwrite_dir option is set).
499
500=cut
501
502sub extract {
503    my ($self, $newdirectory) = @_;
504
505    my ($ok, $error) = version_check($self->{fields}{'Version'});
506    if (not $ok) {
507        if ($self->{options}{ignore_bad_version}) {
508            warning($error);
509        } else {
510            error($error);
511        }
512    }
513
514    # Copy orig tarballs
515    if ($self->{options}{copy_orig_tarballs}) {
516        my $basename = $self->get_basename();
517        my ($dirname, $destdir) = fileparse($newdirectory);
518        $destdir ||= './';
519	my $ext = compression_get_file_extension_regex();
520        foreach my $orig (grep { /^\Q$basename\E\.orig(-[[:alnum:]-]+)?\.tar\.$ext$/ }
521                          $self->get_files())
522        {
523            my $src = File::Spec->catfile($self->{basedir}, $orig);
524            my $dst = File::Spec->catfile($destdir, $orig);
525            if (not check_files_are_the_same($src, $dst, 1)) {
526                system('cp', '--', $src, $dst);
527                subprocerr("cp $src to $dst") if $?;
528            }
529        }
530    }
531
532    # Try extract
533    eval { $self->do_extract($newdirectory) };
534    if ($@) {
535        run_exit_handlers();
536        die $@;
537    }
538
539    # Store format if non-standard so that next build keeps the same format
540    if ($self->{fields}{'Format'} and
541        $self->{fields}{'Format'} ne '1.0' and
542        not $self->{options}{skip_debianization})
543    {
544        my $srcdir = File::Spec->catdir($newdirectory, 'debian', 'source');
545        my $format_file = File::Spec->catfile($srcdir, 'format');
546	unless (-e $format_file) {
547	    mkdir($srcdir) unless -e $srcdir;
548            $self->{format}->save($format_file);
549	}
550    }
551
552    # Make sure debian/rules is executable
553    my $rules = File::Spec->catfile($newdirectory, 'debian', 'rules');
554    my @s = lstat($rules);
555    if (not scalar(@s)) {
556        unless ($! == ENOENT) {
557            syserr(g_('cannot stat %s'), $rules);
558        }
559        warning(g_('%s does not exist'), $rules)
560            unless $self->{options}{skip_debianization};
561    } elsif (-f _) {
562        chmod($s[2] | 0111, $rules)
563            or syserr(g_('cannot make %s executable'), $rules);
564    } else {
565        warning(g_('%s is not a plain file'), $rules);
566    }
567}
568
569sub do_extract {
570    croak 'Dpkg::Source::Package does not know how to unpack a ' .
571          'source package; use one of the subclasses';
572}
573
574# Function used specifically during creation of a source package
575
576sub before_build {
577    my ($self, $dir) = @_;
578}
579
580sub build {
581    my $self = shift;
582    eval { $self->do_build(@_) };
583    if ($@) {
584        run_exit_handlers();
585        die $@;
586    }
587}
588
589sub after_build {
590    my ($self, $dir) = @_;
591}
592
593sub do_build {
594    croak 'Dpkg::Source::Package does not know how to build a ' .
595          'source package; use one of the subclasses';
596}
597
598sub can_build {
599    my ($self, $dir) = @_;
600    return (0, 'can_build() has not been overridden');
601}
602
603sub add_file {
604    my ($self, $filename) = @_;
605    my ($fn, $dir) = fileparse($filename);
606    if ($self->{checksums}->has_file($fn)) {
607        croak "tried to add file '$fn' twice";
608    }
609    $self->{checksums}->add_from_file($filename, key => $fn);
610    $self->{checksums}->export_to_control($self->{fields},
611					    use_files_for_md5 => 1);
612}
613
614sub commit {
615    my $self = shift;
616    eval { $self->do_commit(@_) };
617    if ($@) {
618        run_exit_handlers();
619        die $@;
620    }
621}
622
623sub do_commit {
624    my ($self, $dir) = @_;
625    info(g_("'%s' is not supported by the source format '%s'"),
626         'dpkg-source --commit', $self->{fields}{'Format'});
627}
628
629sub write_dsc {
630    my ($self, %opts) = @_;
631    my $fields = $self->{fields};
632
633    foreach my $f (keys %{$opts{override}}) {
634	$fields->{$f} = $opts{override}{$f};
635    }
636
637    unless ($opts{nocheck}) {
638        foreach my $f (qw(Source Version Architecture)) {
639            unless (defined($fields->{$f})) {
640                error(g_('missing information for critical output field %s'), $f);
641            }
642        }
643        foreach my $f (qw(Maintainer Standards-Version)) {
644            unless (defined($fields->{$f})) {
645                warning(g_('missing information for output field %s'), $f);
646            }
647        }
648    }
649
650    foreach my $f (keys %{$opts{remove}}) {
651	delete $fields->{$f};
652    }
653
654    my $filename = $opts{filename};
655    $filename //= $self->get_basename(1) . '.dsc';
656    open(my $dsc_fh, '>', $filename)
657        or syserr(g_('cannot write %s'), $filename);
658    $fields->apply_substvars($opts{substvars});
659    $fields->output($dsc_fh);
660    close($dsc_fh);
661}
662
663=back
664
665=head1 CHANGES
666
667=head2 Version 1.03 (dpkg 1.19.3)
668
669New option: format in new().
670
671=head2 Version 1.02 (dpkg 1.18.7)
672
673New option: require_strong_checksums in check_checksums().
674
675=head2 Version 1.01 (dpkg 1.17.2)
676
677New functions: get_default_diff_ignore_regex(), set_default_diff_ignore_regex(),
678get_default_tar_ignore_pattern()
679
680Deprecated variables: $diff_ignore_default_regexp, @tar_ignore_default_pattern
681
682=head2 Version 1.00 (dpkg 1.16.1)
683
684Mark the module as public.
685
686=cut
687
6881;
689