diff options
Diffstat (limited to 'lib/Devscripts/MkOrigtargz')
| -rw-r--r-- | lib/Devscripts/MkOrigtargz/Config.pm | 241 |
1 files changed, 241 insertions, 0 deletions
diff --git a/lib/Devscripts/MkOrigtargz/Config.pm b/lib/Devscripts/MkOrigtargz/Config.pm new file mode 100644 index 0000000..28be19f --- /dev/null +++ b/lib/Devscripts/MkOrigtargz/Config.pm @@ -0,0 +1,241 @@ +package Devscripts::MkOrigtargz::Config; + +use strict; + +use Devscripts::Compression qw'compression_is_supported + compression_guess_from_file + compression_get_property'; +use Devscripts::Uscan::Output; +use Exporter 'import'; +use File::Which; +use Moo; + +use constant default_compression => 'xz'; + +# regexp-assemble << END +# tar\.gz +# tgz +# tar\.bz2 +# tbz2? +# tar\.lzma +# tlz(?:ma?)? +# tar\.xz +# txz +# tar\.Z +# tar +# END +use constant tar_regex => + qr/t(?:ar(?:\.(?:[gx]z|lzma|bz2|Z))?|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 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 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]"); + } + 1; + + } + ], + ['directory|C=s'], + ['exclude-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'); + $prog = 'xpi-unpack'; + $pkg = 'mozilla-devscripts'; + } 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_type + . " upstream archives.\n") + unless (which $prog); + } elsif ($self->upstream =~ tar_regex) { + $self->upstream_type('tar'); + if ($self->upstream =~ /\.tar$/) { + $self->upstream_comp(''); + } else { + unless ( + $self->upstream_comp( + compression_guess_from_file($self->upstream)) + ) { + return (0, + "Unknown compression used in $self->{upstream}"); + } + } + } else { + # TODO: Should we ignore the name and only look at what file knows? + return (0, + 'Parameter ' + . $self->upstream + . ' does not look like a tar archive or a zip file.'); + } + 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; |