1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
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;
|
