devscripts/lib/Devscripts/MkOrigtargz/Config.pm

package Devscripts::MkOrigtargz::Config;

use strict;

use Devscripts::Compression qw'compression_is_supported
  compression_guess_from_file';
use Devscripts::Uscan::Output;
use Dpkg::Path qw(find_command);
use Exporter 'import';
use Moo;

use constant default_compression => 'xz';

# regexp-assemble << END
# tar\.gz
# tgz
# tar\.bz2
# tbz2?
# tar\.lz(?:ma)?
# tlz(?:ma?)?
# tar\.xz
# txz
# tar\.Z
# tar
# tar.zst
# tar.zstd
# END
use constant tar_regex =>
  qr/t(?:ar(?:\.(?:lz(?:ma)?|[gx]z|bz2|Z)|.zstd?)?|lz(?:ma?)?|[gx]z|bz2?)$/;

extends 'Devscripts::Config';

# Command-line parameters
has component      => (is => 'rw');
has compression    => (is => 'rw');
has copyright_file => (is => 'rw');
has directory      => (is => 'rw');
has exclude_file   => (is => 'rw');
has include_file   => (is => 'rw');
has force_repack   => (is => 'rw');
has package        => (is => 'rw');
has signature      => (is => 'rw');
has signature_file => (is => 'rw');
has repack         => (is => 'rw');
has repack_suffix  => (is => 'rw');
has unzipopt       => (is => 'rw');
has version        => (is => 'rw');

# Internal accessors
has mode          => (is => 'rw');
has orig          => (is => 'rw', default => sub { 'orig' });
has excludestanza => (is => 'rw', default => sub { 'Files-Excluded' });
has includestanza => (is => 'rw', default => sub { 'Files-Included' });
has upstream      => (is => 'rw');
has upstream_type => (is => 'rw');
has upstream_comp => (is => 'rw');

use constant keys => [
    ['package=s'],
    ['version|v=s'],
    [
        'component|c=s',
        undef,
        sub {
            if ($_[1]) {
                $_[0]->orig("orig-$_[1]");
                $_[0]->excludestanza("Files-Excluded-$_[1]");
                $_[0]->includestanza("Files-Included-$_[1]");
            }
            1;

        }
    ],
    ['directory|C=s'],
    ['exclude-file=s', undef, undef, sub { [] }],
    ['include-file=s', undef, undef, sub { [] }],
    ['force-repack'],
    ['copyright-file=s', undef, undef, sub { [] }],
    ['signature=i',      undef, undef, 0],
    ['signature-file=s', undef, undef, ''],
    [
        'compression=s',
        undef,
        sub {
            return (0, "Unknown compression scheme $_[1]")
              unless ($_[1] eq 'default' or compression_is_supported($_[1]));
            $_[0]->compression($_[1]);
        },
    ],
    ['symlink', undef, \&setmode],
    ['rename',  undef, \&setmode],
    ['copy',    undef, \&setmode],
    ['repack'],
    ['repack-suffix|S=s', undef, undef, ''],
    ['unzipopt=s'],
];

use constant rules => [
    # Check --package if --version is used
    sub {
        return (
              (defined $_[0]->{package} and not defined $_[0]->{version})
            ? (0, 'If you use --package, you also have to specify --version')
            : (1));
    },
    # Check that a tarball has been given and store it in $self->upstream
    sub {
        return (0, 'Please specify original tarball') unless (@ARGV == 1);
        $_[0]->upstream($ARGV[0]);
        return (
            -r $_[0]->upstream
            ? (1)
            : (0, "Could not read $_[0]->{upstream}: $!"));
    },
    # Get Debian package name an version unless given
    sub {
        my ($self) = @_;
        unless (defined $self->package) {

            # get package name
            my $c = Dpkg::Changelog::Debian->new(range => { count => 1 });
            $c->load('debian/changelog');
            if (my $msg = $c->get_parse_errors()) {
                return (0, "could not parse debian/changelog:\n$msg");
            }
            my ($entry) = @{$c};
            $self->package($entry->get_source());

            # get version number
            unless (defined $self->version) {
                my $debversion = Dpkg::Version->new($entry->get_version());
                if ($debversion->is_native()) {
                    return (0,
                            "Package with native version number $debversion; "
                          . "mk-origtargz makes no sense for native packages."
                    );
                }
                $self->version($debversion->version());
            }

            unshift @{ $self->copyright_file }, "debian/copyright"
              if -r "debian/copyright";

            # set destination directory
            unless (defined $self->directory) {
                $self->directory('..');
            }
        } else {
            unless (defined $self->directory) {
                $self->directory('.');
            }
        }
        return 1;
    },
    # Get upstream type and compression
    sub {
        my ($self) = @_;
        my $mime = compression_guess_from_file($self->upstream);

        if (defined $mime and $mime eq 'zip') {
            $self->upstream_type('zip');
            my ($prog, $pkg);
            if ($self->upstream =~ /\.xpi$/i) {
                $self->upstream_comp('xpi');
            } else {
                $self->upstream_comp('zip');
            }
            $prog = $pkg = 'unzip';
            return (0,
                    "$prog binary not found."
                  . " You need to install the package $pkg"
                  . " to be able to repack "
                  . $self->upstream_comp
                  . " upstream archives.\n")
              unless (find_command($prog));
        } else {
            if ($self->upstream =~ /\.tar$/ and $mime eq 'tar') {
                $self->upstream_type('tar');
                $self->upstream_comp('');
            } elsif ($mime) {
                $self->upstream_type('tar');
                $self->upstream_comp($mime);
                unless ($self->upstream =~ tar_regex) {
                    return (1,
                            'Parameter '
                          . $self->upstream
                          . ' does not have a file extension, guessed a tarball compressed with '
                          . $self->upstream_comp
                          . '.');
                }
            } else {
                return (0, "Unknown compression used in $self->{upstream}");
            }
        }
        return 1;
    },
    # Default compression
    sub {
        my ($self) = @_;

        # Case 1: format is 1.0
        if (-r 'debian/source/format') {
            open F, 'debian/source/format';
            my $str = <F>;
            unless ($str =~ /^([\d\.]+)/ and $1 >= 2.0) {
                ds_warn
"Source format is earlier than 2.0, switch compression to gzip";
                $self->compression('gzip');
                $self->repack(1) unless ($self->upstream_comp eq 'gzip');
            }
            close F;
        } elsif (-d 'debian') {
            ds_warn "Missing debian/source/format, switch compression to gzip";
            $self->compression('gzip');
            $self->repack(1) unless ($self->upstream_comp eq 'gzip');
        } elsif ($self->upstream_type eq 'tar') {

            # Uncompressed tar
            if (!$self->upstream_comp) {
                $self->repack(1);
            }
        }
        # Set to default. Will be changed after setting do_repack
        $self->compression('default')
          unless ($self->compression);
        return 1;
    },
    sub {
        my ($self) = @_;
        $self->{mode} ||= 'symlink';
    },
];

sub setmode {
    my ($self, $nv, $kname) = @_;
    return unless ($nv);
    if (defined $self->mode and $self->mode ne $kname) {
        return (0, "--$self->{mode} and --$kname are mutually exclusive");
    }
    $self->mode($kname);
}

1;