line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package CPANPLUS::Dist::Deb; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
3249606
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
131
|
|
4
|
3
|
|
|
3
|
|
17
|
use vars qw[@ISA $VERSION]; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
314
|
|
5
|
|
|
|
|
|
|
@ISA = qw[CPANPLUS::Dist]; |
6
|
|
|
|
|
|
|
$VERSION = '0.12'; |
7
|
|
|
|
|
|
|
|
8
|
3
|
|
|
3
|
|
17
|
use CPANPLUS::Error; |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
400
|
|
9
|
3
|
|
|
3
|
|
18
|
use CPANPLUS::Internals::Constants; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
2664
|
|
10
|
3
|
|
|
3
|
|
1682
|
use CPANPLUS::Dist::Deb::Constants; |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
2110
|
|
11
|
|
|
|
|
|
|
|
12
|
3
|
|
|
3
|
|
28
|
use FileHandle; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
32
|
|
13
|
3
|
|
|
3
|
|
1798
|
use File::Basename; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
251
|
|
14
|
3
|
|
|
3
|
|
19
|
use File::Find; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
183
|
|
15
|
3
|
|
|
3
|
|
19
|
use File::Path; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
150
|
|
16
|
3
|
|
|
3
|
|
18
|
use Cwd; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
227
|
|
17
|
|
|
|
|
|
|
|
18
|
3
|
|
|
3
|
|
17
|
use IPC::Cmd qw[run can_run]; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
271
|
|
19
|
3
|
|
|
3
|
|
19
|
use Params::Check qw[check]; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
266
|
|
20
|
3
|
|
|
3
|
|
18
|
use File::Basename qw[dirname]; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
139
|
|
21
|
3
|
|
|
3
|
|
21
|
use Module::Load::Conditional qw[can_load check_install]; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
262
|
|
22
|
3
|
|
|
3
|
|
21
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
153
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
local $Params::Check::VERBOSE = 1; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=pod |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 NAME |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
CPANPLUS::Dist::Deb |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 SYNOPSIS |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my $cb = CPANPLUS::Backend->new; |
36
|
|
|
|
|
|
|
my $modobj = $cb->module_tree('Some::Module'); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
### as an option to ->install() |
40
|
|
|
|
|
|
|
$modobj->install( format => 'CPANPLUS::Dist::Deb' ); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
### just to create the debs, don't install |
44
|
|
|
|
|
|
|
$modobj->install( format => 'CPANPLUS::Dist::Deb', |
45
|
|
|
|
|
|
|
target => 'create', |
46
|
|
|
|
|
|
|
prereq_target => 'create' ); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
### the long way around |
50
|
|
|
|
|
|
|
$mobobj->fetch; |
51
|
|
|
|
|
|
|
$modobj->extract; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
my $deb = CPANPLUS::Dist->new( |
54
|
|
|
|
|
|
|
format => 'CPANPLUS::Dist::Deb', |
55
|
|
|
|
|
|
|
module => $modobj, |
56
|
|
|
|
|
|
|
%extra_opts, |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
$bool = $deb->create; # create a .deb file |
60
|
|
|
|
|
|
|
$bool = $deb->install; # installs the .deb file |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
$where = $deb->status->dist; # from the dist obj |
63
|
|
|
|
|
|
|
$where = $modobj->status->dist->status->dist; # from the mod obj |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
### from the CPANPLUS Default shell |
67
|
|
|
|
|
|
|
CPAN Terminal> i --format=CPANPLUS::Dist::Deb Some::Module |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
### using the commandline tool |
70
|
|
|
|
|
|
|
cpan2dist --format CPANPLUS::Dist::Deb Some::Module |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=head1 DESCRIPTION |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
C is a distribution class to create C |
75
|
|
|
|
|
|
|
packages from C modules, and all it's dependencies. This allows |
76
|
|
|
|
|
|
|
you to have the most recent copies of C modules installed, |
77
|
|
|
|
|
|
|
using your package manager of choice, but without having to wait for |
78
|
|
|
|
|
|
|
central repositories to be updated. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
You can either install them using the API provided in this package, |
81
|
|
|
|
|
|
|
or manually via C. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
Some of the bleading edge C modules have already been turned |
84
|
|
|
|
|
|
|
into debian packages for you, and you can make use of them by adding |
85
|
|
|
|
|
|
|
the following line to your C file: |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
deb http://debian.pkgs.cpan.org/debian unstable main |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Note that these packages are built automatically from CPAN and are |
90
|
|
|
|
|
|
|
assumed to have the same license as perl and come without support. |
91
|
|
|
|
|
|
|
Please always refer to the original C package if you have |
92
|
|
|
|
|
|
|
questions. |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=cut |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=head1 ACCESSORS |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=over 4 |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
=item parent() |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
Returns the C object that parented this object. |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=item status() |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Returns the C object that keeps the status for |
108
|
|
|
|
|
|
|
this module. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
Look at C for a list of standard accessors every |
111
|
|
|
|
|
|
|
C object will have. Below is a list of those specific to |
112
|
|
|
|
|
|
|
this package. |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
Note that these are mostly to ensure the inner workings of this |
115
|
|
|
|
|
|
|
package. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=back |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=head1 STATUS ACCESSORS |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
All accessors can be accessed as follows: |
122
|
|
|
|
|
|
|
$deb->status->ACCESSOR |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=over 4 |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=item rules() |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
The location of the C file. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Will be removed after successful creation. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item compat() |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
The location of the C file |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
Will be removed after successful creation. |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=item changelog() |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
The location of the C file |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Will be removed after successful creation. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=item copyright() |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
The location of the C file |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
Will be removed after successful creation. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
=item control() |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
The location of the C file |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
Will be removed after successful creation. |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=item distdir() |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
The directory where the C<.deb> file is placed. |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
Will be removed after successful creation. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=item package() |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
The location of the C<.deb> file. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
Note this is equivalent to the C accessor already |
167
|
|
|
|
|
|
|
standardly provided. |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=item files() |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
List of all the generated files for this distribution. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=back |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=cut |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=head1 METHODS |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=head2 $bool = CPANPLUS::Dist::Deb->format_available(); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
Returns a boolean indicating whether or not you can use this package |
183
|
|
|
|
|
|
|
to create and install modules in your environment. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
It will verify if you have all the necessary components avialable to |
186
|
|
|
|
|
|
|
build your own debian packages. You will need at least these |
187
|
|
|
|
|
|
|
dependencies installed: |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
=over 4 |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=item debhelper |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=item dpkg |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=item dpkg-dev |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
=item fakeroot |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
=item gcc |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
=item libc6-dev |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
=item findutils |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=back |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=cut |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
### XXX check if we're on debian? or perhaps we can do this cross-platform |
210
|
|
|
|
|
|
|
sub format_available { |
211
|
3
|
|
|
3
|
1
|
5004
|
my $flag; |
212
|
3
|
|
|
|
|
16
|
for my $prog (qw[gencat dpkg dh_perl gcc cp dpkg-buildpackage |
213
|
|
|
|
|
|
|
fakeroot xargs find]) { |
214
|
27
|
100
|
|
|
|
8625
|
unless( can_run($prog) ) { |
215
|
3
|
|
|
|
|
967
|
error(loc("'%1' is a required program to build debian packages", |
216
|
|
|
|
|
|
|
$prog)); |
217
|
3
|
|
|
|
|
7201
|
$flag++; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
} |
220
|
3
|
50
|
|
|
|
1078
|
return $flag ? 0 : 1; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
=head2 $bool = $deb->init |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
Sets up the C object for use. |
226
|
|
|
|
|
|
|
Effectively creates all the needed status accessors. |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
Called automatically whenever you create a new C |
229
|
|
|
|
|
|
|
object. |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=cut |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub init { |
234
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
235
|
0
|
|
|
|
|
|
my $status = $self->status; |
236
|
|
|
|
|
|
|
|
237
|
0
|
|
|
|
|
|
$status->mk_accessors(qw[rules compat changelog copyright control distdir |
238
|
|
|
|
|
|
|
debiandir package package_name package_filename |
239
|
|
|
|
|
|
|
readme prefix builddir _tmp_output_dir files |
240
|
|
|
|
|
|
|
_prepare_args _create_args _install_args]); |
241
|
|
|
|
|
|
|
### XXX we might not be using _args properly! |
242
|
0
|
|
|
|
|
|
return 1; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=pod |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
=head2 $loc = $dist->prepare([perl => '/path/to/perl', distdir => '/path/to/build/debs', copyright => 'copyright_text', prereq_target => TARGET, force => BOOL, verbose => BOOL, skiptest => BOOL, prefix => 'prefix-', distribution => 'disttype', deb_version => INT]) |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
C preps a distribution for creation. This means it will create |
250
|
|
|
|
|
|
|
all meta data files required by C to build a C<.deb> |
251
|
|
|
|
|
|
|
file of hte module you specified. |
252
|
|
|
|
|
|
|
This will also satisfy any prerequisites the module may have. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
If you set C to true, it will skip the C stage. |
255
|
|
|
|
|
|
|
If you set C to true, it will go over all the stages of the |
256
|
|
|
|
|
|
|
creation process again, ignoring any previously cached results. It |
257
|
|
|
|
|
|
|
will also ignore a bad return value from the C stage and still |
258
|
|
|
|
|
|
|
allow the operation to return true. |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
Returns true on success and false on failure. |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
You may then call C<< $deb->create >> on the object to create the |
263
|
|
|
|
|
|
|
C<.deb> from the metadata, and then C<< $deb->install >> on the object |
264
|
|
|
|
|
|
|
to actually install it. |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
Returns the location of the builddir on success, and false on failure. |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
Note any extra options you pass along, will be passed to the underlying |
269
|
|
|
|
|
|
|
installers verbatim. This enables you to, for example, specify extra |
270
|
|
|
|
|
|
|
flags for the C stage. |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
=cut |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub prepare { |
275
|
|
|
|
|
|
|
### just in case you already did a create call for this module object |
276
|
|
|
|
|
|
|
### just via a different dist object |
277
|
0
|
|
|
0
|
1
|
|
my $dist = shift; |
278
|
0
|
|
|
|
|
|
my $self = $dist->parent; |
279
|
0
|
|
|
|
|
|
my $dist_cpan = $self->status->dist_cpan; |
280
|
0
|
0
|
|
|
|
|
$dist = $self->status->dist if $self->status->dist; |
281
|
0
|
0
|
|
|
|
|
$self->status->dist( $dist ) unless $self->status->dist; |
282
|
|
|
|
|
|
|
|
283
|
0
|
|
|
|
|
|
my $cb = $self->parent; |
284
|
0
|
|
|
|
|
|
my $conf = $cb->configure_object; |
285
|
0
|
|
|
|
|
|
my %hash = @_; |
286
|
|
|
|
|
|
|
|
287
|
0
|
|
|
|
|
|
my $args; |
288
|
0
|
|
|
|
|
|
my( $verbose,$force,$perl,$prereq_target,$distdir,$copyright,$prefix, |
289
|
|
|
|
|
|
|
$keep_source,$distribution, $deb_version,$prereq_build); |
290
|
0
|
|
|
|
|
|
{ local $Params::Check::ALLOW_UNKNOWN = 1; |
|
0
|
|
|
|
|
|
|
291
|
0
|
|
|
|
|
|
my $tmpl = { |
292
|
|
|
|
|
|
|
verbose => { default => $conf->get_conf('verbose'), |
293
|
|
|
|
|
|
|
store => \$verbose }, |
294
|
|
|
|
|
|
|
force => { default => $conf->get_conf('force'), |
295
|
|
|
|
|
|
|
store => \$force }, |
296
|
|
|
|
|
|
|
perl => { default => $^X, store => \$perl }, |
297
|
|
|
|
|
|
|
### XXX is this the right thing to do??? |
298
|
|
|
|
|
|
|
prereq_target => { default => 'install', |
299
|
|
|
|
|
|
|
store => \$prereq_target }, |
300
|
|
|
|
|
|
|
copyright => { default => DEB_STANDARD_COPYRIGHT_PERL, |
301
|
|
|
|
|
|
|
store => \$copyright }, |
302
|
|
|
|
|
|
|
distdir => { default => '', store => \$distdir }, |
303
|
|
|
|
|
|
|
prefix => { default => 'cpan-', store => \$prefix }, |
304
|
|
|
|
|
|
|
distribution => { default => DEB_DEFAULT_RELEASE, |
305
|
|
|
|
|
|
|
store => \$distribution }, |
306
|
|
|
|
|
|
|
deb_version => { default => DEB_DEFAULT_PACKAGE_VERSION, |
307
|
|
|
|
|
|
|
store => \$deb_version }, |
308
|
|
|
|
|
|
|
#keep_source => { default => 0, store => \$keep_source }, |
309
|
|
|
|
|
|
|
prereq_build => { default => 0, store => \$prereq_build }, |
310
|
|
|
|
|
|
|
}; |
311
|
|
|
|
|
|
|
|
312
|
0
|
0
|
|
|
|
|
$args = check( $tmpl, \%hash ) or return; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
### store the prefix for later use |
316
|
0
|
|
|
|
|
|
$dist->status->prefix( $prefix ); |
317
|
0
|
|
|
|
|
|
$dist->status->package_name( DEB_PACKAGE_NAME->($self, $prefix) ); |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
### the directory we're going to put the files in, which has either |
320
|
|
|
|
|
|
|
### a custom root, or our standard base directory |
321
|
0
|
|
0
|
|
|
|
my $basedir = File::Spec->catdir( |
322
|
|
|
|
|
|
|
( $distdir || DEB_BASE_DIR->( $conf, $perl ) ), |
323
|
|
|
|
|
|
|
DEB_DISTDIR->( $dist, $prefix ) |
324
|
|
|
|
|
|
|
); |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
### did we already create the package? if so, don't bother to rebuild |
327
|
|
|
|
|
|
|
### unless we are forced to |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
|
{ for my $has_xs (0,1) { |
|
0
|
|
|
|
|
|
|
330
|
0
|
|
|
|
|
|
my $pkg = DEB_DEB_FILE_NAME->( |
331
|
|
|
|
|
|
|
$self, $basedir, $prefix, $has_xs, $deb_version |
332
|
|
|
|
|
|
|
); |
333
|
|
|
|
|
|
|
|
334
|
0
|
0
|
0
|
|
|
|
if( -e $pkg && -s _ and not $force) { |
|
|
|
0
|
|
|
|
|
335
|
0
|
|
|
|
|
|
msg(loc("Already created package of '%1' at '%2' -- not doing" |
336
|
|
|
|
|
|
|
." so again unless you force", $self->module, $pkg )); |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
|
$dist->status->prepared( 1 ); |
339
|
0
|
|
|
|
|
|
$dist->status->created( 1 ); |
340
|
0
|
|
|
|
|
|
$dist->status->package( $pkg ); |
341
|
0
|
|
|
|
|
|
return $dist->status->dist( $pkg ); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
{ ### we must install in site or vendor dirs..which means we *must* |
347
|
|
|
|
|
|
|
### tell this to the underlying make/build process! |
348
|
0
|
|
|
|
|
|
MAKE: { |
|
0
|
|
|
|
|
|
|
349
|
0
|
|
|
|
|
|
my $mmflags = $conf->get_conf('makemakerflags'); |
350
|
0
|
|
|
|
|
|
my $mmadd = DEB_MAKEMAKERFLAGS->( $dist->status->prefix ); |
351
|
0
|
0
|
|
|
|
|
$conf->set_conf( makemakerflags => $mmflags . ' ' . $mmadd ) |
352
|
|
|
|
|
|
|
unless $mmflags =~ /$mmadd/; |
353
|
|
|
|
|
|
|
|
354
|
0
|
|
|
|
|
|
my $buildflags = $conf->get_conf('buildflags'); |
355
|
0
|
|
|
|
|
|
my $buildadd = DEB_BUILDFLAGS->( $dist->status->prefix ); |
356
|
0
|
0
|
|
|
|
|
$conf->set_conf( buildflags => $buildflags . ' ' . $buildadd ) |
357
|
|
|
|
|
|
|
unless $buildflags =~ /$buildadd/; |
358
|
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
|
my $fail; |
360
|
0
|
0
|
|
|
|
|
$fail++ unless $dist_cpan->prepare( %hash ); |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
### restore the flags |
363
|
0
|
|
|
|
|
|
$conf->set_conf( makemakerflags => $mmflags ); |
364
|
0
|
|
|
|
|
|
$conf->set_conf( buildflags => $buildflags ); |
365
|
|
|
|
|
|
|
|
366
|
0
|
0
|
|
|
|
|
if( $fail ) { |
367
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
368
|
0
|
|
|
|
|
|
return; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
|
373
|
0
|
0
|
|
|
|
|
unless ( $dist_cpan->create( %hash, prereq_format => __PACKAGE__ ) ) { |
374
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
375
|
0
|
|
|
|
|
|
return; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
|
my $debdir = DEB_DEBIAN_DIR->( $self->status->extract ); |
381
|
|
|
|
|
|
|
### store the dirs we build debs in, and where we put the current |
382
|
|
|
|
|
|
|
### meta data files |
383
|
0
|
|
|
|
|
|
$dist->status->distdir( $basedir ); # final destination |
384
|
0
|
|
|
|
|
|
$dist->status->builddir( $self->status->extract ); # [EXTRACT]/ |
385
|
0
|
|
|
|
|
|
$dist->status->debiandir( $debdir ); # [EXTRACT]/debian |
386
|
|
|
|
|
|
|
### dir where the generated packages will end up after compiling them, |
387
|
|
|
|
|
|
|
### before moving them to their final destination |
388
|
0
|
|
|
|
|
|
$dist->status->_tmp_output_dir( |
389
|
|
|
|
|
|
|
File::Spec->catdir( $dist->status->builddir, '..' ) ); |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
### create final destination dir && debian subdir ### |
393
|
0
|
|
|
|
|
|
for ( $debdir, $basedir ) { |
394
|
0
|
0
|
|
|
|
|
unless( -d $_ ) { |
395
|
0
|
0
|
|
|
|
|
unless( $cb->_mkdir( dir => $_ ) ) { |
396
|
0
|
|
|
|
|
|
error( loc("Could not create directory '%1'", $_ ) ); |
397
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
398
|
0
|
|
|
|
|
|
return; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
### chdir to builddir ### |
404
|
0
|
0
|
|
|
|
|
unless( $cb->_chdir( dir => $dist->status->builddir ) ) { |
405
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
406
|
0
|
|
|
|
|
|
return; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
### copy the original tarball over, in .orig format so it can |
412
|
|
|
|
|
|
|
### be diffed against by the dh- tools |
413
|
0
|
|
|
|
|
|
{ my $file = $self->status->fetch; |
|
0
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
|
my $orig = File::Spec->catdir( |
415
|
|
|
|
|
|
|
$dist->status->builddir, |
416
|
|
|
|
|
|
|
'..', # be sure to updir, so the diff is included |
417
|
|
|
|
|
|
|
DEB_ORIG_PACKAGE_NAME->( $self, $prefix ) ); |
418
|
|
|
|
|
|
|
|
419
|
0
|
0
|
|
|
|
|
unless( $cb->_copy( file => $file, to => $orig ) ) { |
420
|
0
|
|
|
|
|
|
error(loc("Couldn't copy original archive '%1' to '%2'", |
421
|
|
|
|
|
|
|
$file, $orig )); |
422
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
423
|
0
|
|
|
|
|
|
return; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
### let's figure out what this distribution will be called -- we'll need |
428
|
|
|
|
|
|
|
### that later to see if it was actually created |
429
|
0
|
0
|
|
|
|
|
{ my $has_xs = scalar GET_XS_FILES->( $self->status->extract ) ? 1 : 0; |
|
0
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
|
my $debfile = DEB_DEB_FILE_NAME->( |
431
|
|
|
|
|
|
|
$self, '.', $prefix, $has_xs, $deb_version |
432
|
|
|
|
|
|
|
); |
433
|
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
|
$dist->status->package_filename( $debfile ); |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
### find where prereqs landed, etc.. add them to our dependency list ### |
439
|
0
|
|
|
|
|
|
my @depends; |
440
|
0
|
|
|
|
|
|
{ my $prereqs = $self->status->prereqs; |
|
0
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
|
442
|
0
|
|
|
|
|
|
for my $prereq ( sort keys %$prereqs ) { |
443
|
0
|
|
|
|
|
|
my $obj = $cb->module_tree($prereq); |
444
|
|
|
|
|
|
|
|
445
|
0
|
0
|
|
|
|
|
unless( $obj ) { |
446
|
0
|
|
|
|
|
|
error( loc( "Couldn't find module object for prerequisite ". |
447
|
|
|
|
|
|
|
"'%1' -- skipping", $prereq ) ); |
448
|
0
|
|
|
|
|
|
next; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
### no point in listing prereqs that are IN the perl core |
452
|
|
|
|
|
|
|
### themselves |
453
|
0
|
0
|
|
|
|
|
next if $obj->package_is_perl_core; |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
### if the prereq requires any specific version, we'll assume |
456
|
|
|
|
|
|
|
### the one we can provide, otherwise, we'll set it to undef, |
457
|
|
|
|
|
|
|
### marking 'any' |
458
|
|
|
|
|
|
|
### make sure we pick the /lowest/ version available, in case |
459
|
|
|
|
|
|
|
### of custom patches, core running ahead of cpan, etc |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
### XXX here's a problem: |
462
|
|
|
|
|
|
|
### some distributions contain several modules, like PathTools |
463
|
|
|
|
|
|
|
### use to; |
464
|
|
|
|
|
|
|
### Cwd 1.0, File::Spec 2.0, both in PathTools-3.0.tgz |
465
|
|
|
|
|
|
|
### if you already have Cwd or File::Spec installed at a, |
466
|
|
|
|
|
|
|
### for this install, sufficient version, we can no longer |
467
|
|
|
|
|
|
|
### determine what /package/ they came from (as that information |
468
|
|
|
|
|
|
|
### does not exist). So, if this situation occurs, we check |
469
|
|
|
|
|
|
|
### if the installed version is the same as the cpan version. |
470
|
|
|
|
|
|
|
### In that case, and then we will depend on the cpan package |
471
|
|
|
|
|
|
|
### version. if *not* we will depend on the *installed_version* |
472
|
|
|
|
|
|
|
### which may *differ* from the cpan version, but there's not |
473
|
|
|
|
|
|
|
### much we can do :( |
474
|
0
|
|
|
|
|
|
{ my $version = undef; |
|
0
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
### we need a certain version |
477
|
0
|
0
|
|
|
|
|
if( $prereqs->{$prereq} ) { |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
### 2 scenarios -- either you have a previously |
480
|
|
|
|
|
|
|
### installed version, or you don't |
481
|
0
|
0
|
|
|
|
|
if( $obj->installed_version ) { |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
### if the installed version is the same or higher |
484
|
|
|
|
|
|
|
### (wtf? custom patches?) than the cpan version, |
485
|
|
|
|
|
|
|
### use the cpan package version |
486
|
0
|
0
|
|
|
|
|
if( $obj->installed_version >= $obj->version ) { |
487
|
0
|
|
|
|
|
|
$version = $obj->package_version; |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
### the version is *lower* than what's on cpan |
490
|
|
|
|
|
|
|
### now we need to find out what package that was |
491
|
|
|
|
|
|
|
### released. However, that is currenty impossible :( |
492
|
|
|
|
|
|
|
### so we assume that the installed version is magically |
493
|
|
|
|
|
|
|
### matching the package version.. pretty please, with |
494
|
|
|
|
|
|
|
### sugar on top... |
495
|
|
|
|
|
|
|
### this will only possibly hurt if it's wrong, if you |
496
|
|
|
|
|
|
|
### are making these modules available through an apt |
497
|
|
|
|
|
|
|
### repo, which will then point to the 'wrong' debian |
498
|
|
|
|
|
|
|
### dependency.. however, since the dependency has also |
499
|
|
|
|
|
|
|
### been built by us, the 'right' cpan-lib*perl will |
500
|
|
|
|
|
|
|
### be picked. |
501
|
|
|
|
|
|
|
} else { |
502
|
0
|
|
|
|
|
|
$version = $obj->installed_version |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
### no version installed? depend on the cpan package version |
506
|
|
|
|
|
|
|
} else { |
507
|
0
|
|
|
|
|
|
$version = $obj->package_version; |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
0
|
|
|
|
|
|
push @depends, [$obj, $version]; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
### write a standard debian readme file |
517
|
0
|
|
|
|
|
|
{ my $debreadme = DEB_README->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
### open the makefile for writing ### |
520
|
0
|
|
|
|
|
|
my $fh; |
521
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$debreadme" ) ) { |
522
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
523
|
|
|
|
|
|
|
$debreadme, $! ) ); |
524
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
525
|
0
|
|
|
|
|
|
return; |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
0
|
|
|
|
|
|
print $fh DEB_README_CONTENTS; |
529
|
0
|
|
|
|
|
|
close $fh; |
530
|
|
|
|
|
|
|
|
531
|
0
|
|
|
|
|
|
$dist->status->readme( $debreadme ); |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
### get all the metadata to make the control file ### |
535
|
0
|
|
|
|
|
|
{ my $control = DEB_CONTROL->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
### open the makefile for writing ### |
538
|
0
|
|
|
|
|
|
my $fh; |
539
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$control" ) ) { |
540
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
541
|
|
|
|
|
|
|
$control, $! ) ); |
542
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
543
|
0
|
|
|
|
|
|
return; |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
### check if there are xs files in this distribution ### |
547
|
0
|
0
|
|
|
|
|
my $has_xs = scalar GET_XS_FILES->( $self->status->extract ) ? 1 : 0; |
548
|
|
|
|
|
|
|
|
549
|
0
|
|
|
|
|
|
my $maintainer = $conf->get_conf('email'); |
550
|
0
|
|
0
|
|
|
|
my $desc = $self->description || $self->module; |
551
|
0
|
|
|
|
|
|
my $arch = DEB_RULES_ARCH->($has_xs); |
552
|
|
|
|
|
|
|
|
553
|
0
|
|
|
|
|
|
my $pkg = DEB_PACKAGE_NAME->($self, $prefix); |
554
|
0
|
|
|
|
|
|
my $std_version = DEB_STANDARDS_VERSION; |
555
|
0
|
|
|
|
|
|
my $debhelper = DEB_DEBHELPER; |
556
|
0
|
|
|
|
|
|
my $perl_depends = DEB_PERL_DEPENDS; |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
### prereqs will be 'libfoo-perl' if we don't have a prefix and |
559
|
|
|
|
|
|
|
### '${prefix}libfoo-perl' if we do have a prefix. We only add the |
560
|
|
|
|
|
|
|
### >= VERSION if the prereqs were stated with requiring a certain |
561
|
|
|
|
|
|
|
### version.. otherwise we leave it empty |
562
|
0
|
|
|
|
|
|
my %seen; |
563
|
0
|
0
|
|
|
|
|
my $prereqs = join ', ', map { |
564
|
|
|
|
|
|
|
### do we need a specific version? |
565
|
0
|
|
0
|
|
|
|
my $ver = $_->[1] |
566
|
|
|
|
|
|
|
? ' (>= ' . $_->[1] . ')' |
567
|
|
|
|
|
|
|
: ''; |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
### standard lib |
570
|
0
|
|
|
|
|
|
my $str = DEB_PACKAGE_NAME->($_->[0]) . $ver; |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
### our lib, if it has a prefix |
573
|
0
|
0
|
|
|
|
|
if( $prefix ) { |
574
|
0
|
|
|
|
|
|
$str .= ' | ' . DEB_PACKAGE_NAME->( |
575
|
|
|
|
|
|
|
$_->[0], $prefix) . $ver; |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
|
578
|
0
|
|
|
|
|
|
$str; |
579
|
|
|
|
|
|
|
} grep { |
580
|
|
|
|
|
|
|
### shouldn't be a core module |
581
|
|
|
|
|
|
|
### and we shouldn't list the same |
582
|
|
|
|
|
|
|
### prereq twice. Note that 2 modules |
583
|
|
|
|
|
|
|
### may be in 1 package |
584
|
0
|
|
|
|
|
|
!$_->[0]->package_is_perl_core and |
585
|
|
|
|
|
|
|
!$seen{ DEB_PACKAGE_NAME->( $_->[0] ) }++ |
586
|
|
|
|
|
|
|
} @depends; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
### always put debhelper in build-depends ### |
589
|
0
|
|
|
|
|
|
my $build_depends = $debhelper; |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
### always add prereqs to depends ### |
592
|
0
|
|
|
|
|
|
my $depends = join ', ', $perl_depends, $prereqs; |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
### empty by default, only used if this module has xs parts ### |
595
|
0
|
|
|
|
|
|
my $build_indep; my $bdi_line = ''; |
|
0
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
### xs module, so all dependencies go in build-depend-indep |
598
|
0
|
0
|
|
|
|
|
if( $has_xs ) { |
599
|
0
|
|
|
|
|
|
$build_indep = $prereqs; |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
### the build-depends-indep line to add to the here-doc |
602
|
|
|
|
|
|
|
### since it's not allowed to be empty in the rules file |
603
|
0
|
|
|
|
|
|
$bdi_line = "Build-Depends-Indep: $build_depends"; |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
### no xs, so all dependencies get added to build-depend |
606
|
|
|
|
|
|
|
} else { |
607
|
0
|
|
|
|
|
|
$build_depends .= ', ' . $prereqs; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
|
611
|
0
|
|
|
|
|
|
my $contents = << "EOF"; |
612
|
|
|
|
|
|
|
Source: $pkg |
613
|
|
|
|
|
|
|
Section: perl |
614
|
|
|
|
|
|
|
Priority: optional |
615
|
|
|
|
|
|
|
Maintainer: $maintainer |
616
|
|
|
|
|
|
|
Standards-Version: $std_version |
617
|
|
|
|
|
|
|
Build-Depends: $build_depends |
618
|
|
|
|
|
|
|
$bdi_line |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
Architecture: $arch |
621
|
|
|
|
|
|
|
Package: $pkg |
622
|
|
|
|
|
|
|
EOF |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
### we might have to print some 'Replaces:' lines |
625
|
|
|
|
|
|
|
### - replace perl core if we were ever part of it |
626
|
|
|
|
|
|
|
### - replaces 'standard' debian module (that may or may not exist) |
627
|
|
|
|
|
|
|
### if we are built without a prefix |
628
|
|
|
|
|
|
|
### XXX OBSOLETE! since we install completely paralel to existing |
629
|
|
|
|
|
|
|
### moduels, and dont replace any files, Replaces: is no longer |
630
|
|
|
|
|
|
|
### required |
631
|
|
|
|
|
|
|
# if ( $self->module_is_supplied_with_perl_core or not $prefix ) { |
632
|
|
|
|
|
|
|
# my @printme; |
633
|
|
|
|
|
|
|
# |
634
|
|
|
|
|
|
|
# $fh->print('Replaces: '); |
635
|
|
|
|
|
|
|
# |
636
|
|
|
|
|
|
|
# ### so this module is also in perl core, add a rule telling the |
637
|
|
|
|
|
|
|
# ### .deb that it's ok to replace stuff from those packages. |
638
|
|
|
|
|
|
|
# push @printme, DEB_REPLACE_PERL_CORE |
639
|
|
|
|
|
|
|
# if $self->module_is_supplied_with_perl_core; |
640
|
|
|
|
|
|
|
# |
641
|
|
|
|
|
|
|
# push @printme, DEB_PACKAGE_NAME->($self) if $prefix; |
642
|
|
|
|
|
|
|
# |
643
|
|
|
|
|
|
|
# $fh->print( join(', ', @printme), "\n" ); |
644
|
|
|
|
|
|
|
# } |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
### so we have a prefix? best explain what package we are /actually/ |
647
|
|
|
|
|
|
|
### providing. Also note the Conflicts |
648
|
0
|
0
|
|
|
|
|
$contents .= "Provides: " . DEB_PACKAGE_NAME->($self) . "\n" if $prefix; |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
### XXX remove 'Conflicts:' -- versioned provides don't work |
651
|
|
|
|
|
|
|
### with dpkg :( so if someone wants 'libfoo-perl > 2.0' it |
652
|
|
|
|
|
|
|
### will be seen as not provided by our libfoo-perl, and |
653
|
|
|
|
|
|
|
### will propbably uninstall these things... bad bad :( |
654
|
|
|
|
|
|
|
# "Conflicts: ". DEB_PACKAGE_NAME->($self) . "\n") |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
### description should be mentioned twice: one long one, one |
657
|
|
|
|
|
|
|
### short one... format is as follows: |
658
|
|
|
|
|
|
|
### Description: short desc |
659
|
|
|
|
|
|
|
### long description |
660
|
|
|
|
|
|
|
|
661
|
0
|
|
|
|
|
|
$contents .= << "EOF"; |
662
|
|
|
|
|
|
|
Depends: $depends |
663
|
|
|
|
|
|
|
Description: $desc |
664
|
|
|
|
|
|
|
$desc |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
EOF |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
### run the contents through the callback for munging |
669
|
|
|
|
|
|
|
### make this conditional, as this was introduced in the |
670
|
|
|
|
|
|
|
### dev branch of 0.81_01, so not all may have it (automatically) |
671
|
|
|
|
|
|
|
### installed |
672
|
0
|
0
|
|
|
|
|
if( $cb->_callbacks->munge_dist_metafile ) { |
673
|
0
|
|
|
|
|
|
$contents = $cb->_callbacks->munge_dist_metafile->( |
674
|
|
|
|
|
|
|
$cb, $contents |
675
|
|
|
|
|
|
|
); |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
0
|
|
|
|
|
|
$fh->print( $contents ); |
679
|
|
|
|
|
|
|
|
680
|
0
|
|
|
|
|
|
$fh->close; |
681
|
0
|
|
|
|
|
|
$dist->status->control( $control ); |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
### get all the metadata for compat file and write it ### |
686
|
0
|
|
|
|
|
|
{ my $compat = DEB_COMPAT->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
|
688
|
0
|
|
|
|
|
|
my $fh; |
689
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$compat" ) ) { |
690
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
691
|
|
|
|
|
|
|
$compat, $! ) ); |
692
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
693
|
0
|
|
|
|
|
|
return; |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
### this is in the sample, but what the hell does it do? |
697
|
|
|
|
|
|
|
### -- it's just the version of the spec files we used |
698
|
0
|
|
|
|
|
|
$fh->print( DEB_SPEC_FILE_VERSION . "\n"); |
699
|
0
|
|
|
|
|
|
$fh->close; |
700
|
|
|
|
|
|
|
|
701
|
0
|
|
|
|
|
|
$dist->status->compat( $compat ); |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
### get all the metadata for changelog file and write it ### |
705
|
0
|
|
|
|
|
|
{ my $changelog = DEB_CHANGELOG->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
|
707
|
0
|
|
|
|
|
|
my $fh; |
708
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$changelog" ) ) { |
709
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
710
|
|
|
|
|
|
|
$changelog, $! ) ); |
711
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
712
|
0
|
|
|
|
|
|
return; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
### XXX this will cause parse errors if the first line doesn't match |
716
|
|
|
|
|
|
|
### if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) { |
717
|
|
|
|
|
|
|
### (taken from /usr/lib/dpkg/parsechangelog/debian ) which means that |
718
|
|
|
|
|
|
|
### we can not have _ in package names, but dots are fine. |
719
|
|
|
|
|
|
|
|
720
|
0
|
|
|
|
|
|
my $pkg = DEB_PACKAGE_NAME->($self, $prefix); |
721
|
0
|
|
|
|
|
|
my $version = DEB_VERSION->($self, $deb_version); |
722
|
0
|
|
|
|
|
|
my $urgency = DEB_URGENCY; |
723
|
0
|
|
|
|
|
|
my $email = $conf->get_conf('email'); |
724
|
0
|
|
|
|
|
|
my $who = __PACKAGE__; |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
### geez timestamps are a b*tch with debian changelogs.. |
727
|
|
|
|
|
|
|
### this is the only correct format: |
728
|
|
|
|
|
|
|
### Sun, 3 Jun 2001 20:36:41 +0200 |
729
|
|
|
|
|
|
|
### but scalar gmtime says: |
730
|
|
|
|
|
|
|
### Sat Jul 3 14:23:31 2004 |
731
|
0
|
|
|
|
|
|
my ($wday, $mon, $day, $time, $year) = split /\s+/, scalar gmtime; |
732
|
0
|
|
|
|
|
|
my $when = sprintf "%s, %2d %s %s %s +0100", |
733
|
|
|
|
|
|
|
$wday, $day, $mon, $year, $time; # crackfueled :( |
734
|
|
|
|
|
|
|
|
735
|
0
|
|
|
|
|
|
$fh->print(<< "EOF"); |
736
|
|
|
|
|
|
|
$pkg ($version) $distribution; $urgency |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
* Initial Release. |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
-- $who <$email> $when |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
EOF |
743
|
|
|
|
|
|
|
|
744
|
0
|
|
|
|
|
|
$fh->close; |
745
|
|
|
|
|
|
|
|
746
|
0
|
|
|
|
|
|
$dist->status->changelog( $changelog ); |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
### get all the metadata for changelog file and write it ### |
750
|
0
|
|
|
|
|
|
{ my $copyright_file = DEB_COPYRIGHT->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
|
752
|
0
|
|
|
|
|
|
my $fh; |
753
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$copyright_file" ) ) { |
754
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
755
|
|
|
|
|
|
|
$copyright_file, $! ) ); |
756
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
757
|
0
|
|
|
|
|
|
return; |
758
|
|
|
|
|
|
|
} |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
### XXX probe for possible license here rather than assume the |
761
|
|
|
|
|
|
|
### default |
762
|
0
|
|
|
|
|
|
my $pkg = $self->module; |
763
|
0
|
0
|
0
|
|
|
|
my $who = $ENV{DEBFULLMAIL} |
764
|
|
|
|
|
|
|
? $ENV{DEBFULLNAME} . ' <' . |
765
|
|
|
|
|
|
|
($ENV{DEBEMAIL} || $conf->get_conf('email')) . '>' |
766
|
|
|
|
|
|
|
: ($ENV{DEBEMAIL} || $conf->get_conf('email')); |
767
|
0
|
|
|
|
|
|
my $when = 1900 + (localtime)[5]; |
768
|
0
|
|
|
|
|
|
my $license = DEB_STANDARD_COPYRIGHT_PERL; |
769
|
0
|
|
|
|
|
|
my $author = $self->author->author; |
770
|
0
|
|
|
|
|
|
my $email = $self->author->email; |
771
|
|
|
|
|
|
|
|
772
|
0
|
|
|
|
|
|
$fh->print(<< "EOF"); |
773
|
|
|
|
|
|
|
This is the debian package for the $pkg module. |
774
|
|
|
|
|
|
|
It was created by $who. |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
The upstream author is $author <$email>. |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
Copyright (c) $when by $author |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
$license |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
EOF |
783
|
|
|
|
|
|
|
|
784
|
0
|
|
|
|
|
|
$fh->close; |
785
|
0
|
|
|
|
|
|
$dist->status->copyright($copyright_file); |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
{ ### add the debian rules file, which is mostly static ### |
789
|
0
|
|
|
|
|
|
my $rules_file = DEB_RULES->( $dist->status->builddir ); |
|
0
|
|
|
|
|
|
|
790
|
0
|
0
|
|
|
|
|
my $has_xs = scalar GET_XS_FILES->($self->status->extract) |
791
|
|
|
|
|
|
|
? 1 : 0; |
792
|
0
|
|
|
|
|
|
my $content = DEB_GET_RULES_CONTENT->( $self, $prefix, |
793
|
|
|
|
|
|
|
$has_xs, $verbose ); |
794
|
|
|
|
|
|
|
|
795
|
0
|
|
|
|
|
|
my $fh; |
796
|
0
|
0
|
|
|
|
|
unless( $fh = FileHandle->new( ">$rules_file" ) ) { |
797
|
0
|
|
|
|
|
|
error( loc( "Could not open '%1' for writing: %2", |
798
|
|
|
|
|
|
|
$rules_file, $! ) ); |
799
|
0
|
|
|
|
|
|
$dist->status->prepared(0); |
800
|
0
|
|
|
|
|
|
return; |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
|
803
|
0
|
|
|
|
|
|
$fh->print( $content ); |
804
|
0
|
|
|
|
|
|
$fh->close; |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
### make sure it's set as +x |
807
|
0
|
|
|
|
|
|
chmod 0755, $rules_file; |
808
|
|
|
|
|
|
|
|
809
|
0
|
|
|
|
|
|
$dist->status->rules( $rules_file ); |
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
|
812
|
0
|
|
|
|
|
|
$dist->status->prepared(1); |
813
|
0
|
|
|
|
|
|
return $dist->status->builddir; |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=pod |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=head2 $loc = $dist->create([force => BOOL, verbose => BOOL, keep_source => BOOL]) |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
C preps a distribution for installation. This means it will |
821
|
|
|
|
|
|
|
build a C<.deb> file of the module object you've specified from the |
822
|
|
|
|
|
|
|
meta data files that were generated during C. |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Returns true on success and false on failure. |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
You may then call C<< $deb->install >> on the object to actually |
827
|
|
|
|
|
|
|
install it. |
828
|
|
|
|
|
|
|
Returns the location of the C<.deb> file on success, and false on failure. |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
=cut |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
sub create { |
833
|
|
|
|
|
|
|
### just in case you already did a create call for this module object |
834
|
|
|
|
|
|
|
### just via a different dist object |
835
|
0
|
|
|
0
|
1
|
|
my $dist = shift; |
836
|
0
|
|
|
|
|
|
my $self = $dist->parent; |
837
|
0
|
0
|
|
|
|
|
$dist = $self->status->dist if $self->status->dist; |
838
|
0
|
0
|
|
|
|
|
$self->status->dist( $dist ) unless $self->status->dist; |
839
|
|
|
|
|
|
|
|
840
|
0
|
|
|
|
|
|
my $cb = $self->parent; |
841
|
0
|
|
|
|
|
|
my $conf = $cb->configure_object; |
842
|
0
|
|
|
|
|
|
my %hash = @_; |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
my $args; |
845
|
|
|
|
|
|
|
my( $verbose,$force,$keep_source); |
846
|
|
|
|
|
|
|
{ local $Params::Check::ALLOW_UNKNOWN = 1; |
847
|
|
|
|
|
|
|
my $tmpl = { |
848
|
|
|
|
|
|
|
verbose => { default => $conf->get_conf('verbose'), |
849
|
|
|
|
|
|
|
store => \$verbose }, |
850
|
|
|
|
|
|
|
force => { default => $conf->get_conf('force'), |
851
|
|
|
|
|
|
|
store => \$force }, |
852
|
|
|
|
|
|
|
keep_source => { default => undef, store => \$keep_source }, |
853
|
|
|
|
|
|
|
}; |
854
|
|
|
|
|
|
|
|
855
|
|
0
|
|
|
|
|
$args = check( $tmpl, \%hash ) or return; |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
### did you prepare it yet? |
859
|
|
0
|
|
|
|
|
unless( $dist->status->prepared ) { |
860
|
|
|
|
|
|
|
error( loc( "You have not successfully prepared a '%2' distribution ". |
861
|
|
|
|
|
|
|
"yet -- cannot create yet", __PACKAGE__ ) ); |
862
|
|
|
|
|
|
|
return; |
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
### already created? |
866
|
|
0
|
|
|
|
|
if( $dist->status->created and not $force ) { |
867
|
|
|
|
|
|
|
msg(loc("You have already created a '%1' distribution -- not doing ". |
868
|
|
|
|
|
|
|
"so again unless you force", __PACKAGE__ )); |
869
|
|
|
|
|
|
|
return 1; |
870
|
|
|
|
|
|
|
} |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
### chdir to it ### |
873
|
|
0
|
|
|
|
|
unless( $cb->_chdir( dir => $dist->status->builddir ) ) { |
874
|
|
|
|
|
|
|
$dist->status->created(0); |
875
|
|
|
|
|
|
|
return; |
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
{ ### all rules files done, time to build the .deb ### |
879
|
|
|
|
|
|
|
### need to run: dpkg-buildpackage -rfakeroot -uc -us |
880
|
|
|
|
|
|
|
my $prog; |
881
|
|
0
|
|
|
|
|
unless( $prog = DEB_BIN_BUILDPACKAGE->() ) { |
882
|
|
|
|
|
|
|
error(loc( "Cannot create debian package" )); |
883
|
|
|
|
|
|
|
return $dist->status->created(0); |
884
|
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
my $buffer; |
887
|
|
0
|
|
|
|
|
unless( scalar run( |
888
|
|
|
|
|
|
|
command => [$prog, qw|-rfakeroot -uc -us -d|, |
889
|
|
|
|
|
|
|
DEB_DPKG_SOURCE_IGNORE], |
890
|
|
|
|
|
|
|
verbose => $verbose, |
891
|
|
|
|
|
|
|
buffer => \$buffer ) |
892
|
|
|
|
|
|
|
) { |
893
|
|
|
|
|
|
|
error( loc( "Failed to create debian package for '%1': '%2'", |
894
|
|
|
|
|
|
|
$self->module, $buffer ) ); |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
return $dist->status->created(0); |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
### ok, now we have a package created in: |
900
|
|
|
|
|
|
|
### ../$NAME_$VERSION_$ARCH.deb |
901
|
|
|
|
|
|
|
### and we can't tell dpkg-buildpackage to output it anywhere else :( |
902
|
|
|
|
|
|
|
#my $has_xs = scalar GET_XS_FILES->($self->status->extract) ? 1 : 0; |
903
|
|
|
|
|
|
|
{ my $tmpfile = File::Spec->catfile( $dist->status->_tmp_output_dir, |
904
|
|
|
|
|
|
|
$dist->status->package_filename |
905
|
|
|
|
|
|
|
); |
906
|
|
|
|
|
|
|
|
907
|
|
0
|
|
|
|
|
unless( -e $tmpfile && -s _ ) { |
908
|
|
|
|
|
|
|
error( loc( "Debian package '%1' was supposed to be created ". |
909
|
|
|
|
|
|
|
"but was not", $tmpfile ) ); |
910
|
|
|
|
|
|
|
return $dist->status->created(0); |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
} |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
### XXX moves stuff here |
915
|
|
0
|
|
|
|
|
if( my @files = glob( File::Spec->catdir( |
916
|
|
|
|
|
|
|
$dist->status->_tmp_output_dir, |
917
|
|
|
|
|
|
|
$dist->status->package_name, |
918
|
|
|
|
|
|
|
) . '*' ) |
919
|
|
|
|
|
|
|
) { |
920
|
|
|
|
|
|
|
my @dest; |
921
|
|
|
|
|
|
|
for my $file (@files) { |
922
|
|
|
|
|
|
|
my $to = File::Spec->catdir( |
923
|
|
|
|
|
|
|
$dist->status->distdir, basename( $file ) ); |
924
|
|
|
|
|
|
|
|
925
|
|
0
|
|
|
|
|
unless( $cb->_move( file => $file, to => $to ) ) { |
926
|
|
|
|
|
|
|
error(loc("Failed to move '%1' to its final ". |
927
|
|
|
|
|
|
|
"destination '%2'", $file, $to )); |
928
|
|
|
|
|
|
|
$dist->status->prepared(0); |
929
|
|
|
|
|
|
|
return; |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
push @dest, $to; |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
### save what files we ended up moving |
935
|
|
|
|
|
|
|
$dist->status->files( \@dest ); |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
} else { |
938
|
|
|
|
|
|
|
error(loc("No files found matching pattern '%1' in temporary ". |
939
|
|
|
|
|
|
|
"directory '%2'", $dist->status->package_name, |
940
|
|
|
|
|
|
|
$dist->status->_tmp_output_dir )); |
941
|
|
|
|
|
|
|
$dist->status->prepared(0); |
942
|
|
|
|
|
|
|
return; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
### final location |
946
|
|
|
|
|
|
|
my $debfile = File::Spec->catfile( $dist->status->distdir, |
947
|
|
|
|
|
|
|
$dist->status->package_filename ); |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
### store where we wrote the dist to |
951
|
|
|
|
|
|
|
$dist->status->package( $debfile ); |
952
|
|
|
|
|
|
|
$dist->status->dist( $debfile ); |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
msg(loc("Wrote '%1' package for '%2' to '%3'", |
955
|
|
|
|
|
|
|
'debian', $self->module, $debfile), $verbose); |
956
|
|
|
|
|
|
|
|
957
|
|
0
|
|
|
|
|
unless( $cb->_chdir( dir => $conf->_get_build('startdir') ) ) { |
958
|
|
|
|
|
|
|
error(loc("Unable to '%1' back to startdir",'chdir')); |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
} |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
### if we're asked to clean up our sources, then they |
963
|
|
|
|
|
|
|
### live in $dist->status->debiandir. Rmtree the lot |
964
|
|
0
|
|
|
|
|
unless ( $keep_source ) { |
965
|
|
|
|
|
|
|
my $dir = $dist->status->debiandir; |
966
|
|
|
|
|
|
|
msg(loc("Cleaning up meta directory '%1'",$dir), $verbose); |
967
|
|
|
|
|
|
|
$cb->_rmdir( dir => $dir ); |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
$dist->status->created(1); |
971
|
|
|
|
|
|
|
return $dist->status->dist; |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=pod |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
=head2 $bool = $deb->install([verbose => BOOL, force => BOOL, dpkg => /path/to/dpkg, dpkg_flags => ["--extra", "--flags"]]); |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
Installs the C<.deb> using C. |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
Returns true on success and false on failure |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
=cut |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
sub install { |
985
|
|
|
|
|
|
|
### just in case you already did a create call for this module object |
986
|
|
|
|
|
|
|
### just via a different dist object |
987
|
|
|
|
0
|
1
|
|
my $dist = shift; |
988
|
|
|
|
|
|
|
my $self = $dist->parent; |
989
|
|
0
|
|
|
|
|
$dist = $self->status->dist if $self->status->dist; |
990
|
|
|
|
|
|
|
$self->status->dist( $dist ) unless $self->status->dist; |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
my $cb = $self->parent; |
993
|
|
|
|
|
|
|
my $conf = $cb->configure_object; |
994
|
|
|
|
|
|
|
my %hash = @_; |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
my ($dpkg,$verbose,$force,$flags); |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
{ local $Params::Check::ALLOW_UNKNOWN = 1; |
999
|
|
|
|
|
|
|
my $tmpl = { |
1000
|
|
|
|
|
|
|
dpkg => { default => can_run('dpkg'), store => \$dpkg }, |
1001
|
|
|
|
|
|
|
verbose => { default => $conf->get_conf('verbose'), |
1002
|
|
|
|
|
|
|
store => \$verbose }, |
1003
|
|
|
|
|
|
|
force => { default => $conf->get_conf('force'), |
1004
|
|
|
|
|
|
|
store => \$force }, |
1005
|
|
|
|
|
|
|
dpkg_flags => { default => [], strict_type => 1, |
1006
|
|
|
|
|
|
|
store => \$flags }, |
1007
|
|
|
|
|
|
|
}; |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
check( $tmpl, \%hash ) or return; |
1010
|
|
|
|
|
|
|
} |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
### build the command ### |
1013
|
|
|
|
|
|
|
my $sudo = $conf->get_program('sudo'); |
1014
|
|
|
|
|
|
|
my @cmd = ($dpkg, '-i', @$flags, $dist->status->package); |
1015
|
|
|
|
|
|
|
unshift @cmd, $sudo if $sudo; |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
my $buffer; |
1018
|
|
|
|
|
|
|
unless( scalar run( command => \@cmd, |
1019
|
|
|
|
|
|
|
verbose => $verbose, |
1020
|
|
|
|
|
|
|
buffer => \$buffer ) |
1021
|
|
|
|
|
|
|
) { |
1022
|
|
|
|
|
|
|
error( loc( "Unable to install '%1': %2", |
1023
|
|
|
|
|
|
|
$dist->status->package, $buffer ) ); |
1024
|
|
|
|
|
|
|
return $dist->status->installed(0); |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
return $dist->status->installed(1); |
1028
|
|
|
|
|
|
|
}; |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
=pod |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
=head2 $bool = $deb->uninstall([verbose => BOOL, force => BOOL, dpkg => /path/to/dpkg, dpkg_flags => ["--extra", "--flags"]]); |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
Uninstalls the C<.deb> using C. |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
Returns true on success and false on failure |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=cut |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
sub uninstall { |
1041
|
|
|
|
|
|
|
### just in case you already did a create call for this module object |
1042
|
|
|
|
|
|
|
### just via a different dist object |
1043
|
|
|
|
0
|
1
|
|
my $dist = shift; |
1044
|
|
|
|
|
|
|
my $self = $dist->parent; |
1045
|
|
|
|
|
|
|
$dist = $self->status->dist if $self->status->dist; |
1046
|
|
|
|
|
|
|
$self->status->dist( $dist ) unless $self->status->dist; |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
my $cb = $self->parent; |
1049
|
|
|
|
|
|
|
my $conf = $cb->configure_object; |
1050
|
|
|
|
|
|
|
my %hash = @_; |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
my ($dpkg,$verbose,$force,$flags); |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
{ local $Params::Check::ALLOW_UNKNOWN = 1; |
1055
|
|
|
|
|
|
|
my $tmpl = { |
1056
|
|
|
|
|
|
|
dpkg => { default => can_run('dpkg'), store => \$dpkg }, |
1057
|
|
|
|
|
|
|
verbose => { default => $conf->get_conf('verbose'), |
1058
|
|
|
|
|
|
|
store => \$verbose }, |
1059
|
|
|
|
|
|
|
force => { default => $conf->get_conf('force'), |
1060
|
|
|
|
|
|
|
store => \$force }, |
1061
|
|
|
|
|
|
|
dpkg_flags => { default => [], strict_type => 1, |
1062
|
|
|
|
|
|
|
store => \$flags }, |
1063
|
|
|
|
|
|
|
}; |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
check( $tmpl, \%hash ) or return; |
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
### build the command ### |
1069
|
|
|
|
|
|
|
my $sudo = $conf->get_program('sudo'); |
1070
|
|
|
|
|
|
|
my @cmd = ($dpkg, '-r', @$flags, $dist->status->package_name); |
1071
|
|
|
|
|
|
|
unshift @cmd, $sudo if $sudo; |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
my $buffer; |
1074
|
|
|
|
|
|
|
unless( scalar run( command => \@cmd, |
1075
|
|
|
|
|
|
|
verbose => $verbose, |
1076
|
|
|
|
|
|
|
buffer => \$buffer ) |
1077
|
|
|
|
|
|
|
) { |
1078
|
|
|
|
|
|
|
error( loc( "Unable to uninstall '%1': %2", |
1079
|
|
|
|
|
|
|
$dist->status->package, $buffer ) ); |
1080
|
|
|
|
|
|
|
return $dist->status->uninstalled(0); |
1081
|
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
return $dist->status->uninstalled(1); |
1084
|
|
|
|
|
|
|
}; |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
=head2 $loc = CPANPLUS::Dist::Deb->write_meta_files( type => sources|packages, [basedir => /path/to/base, perl => /path/to/perl, release => $releasename]); |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
This writes the metafiles needed to use this archive as a debian mirror. |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
It returns the location of the metafile on success, and false on failure. |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
=cut |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
{ my $prog; |
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
sub write_meta_files { |
1097
|
|
|
|
0
|
1
|
|
my $dist = shift; |
1098
|
|
|
|
|
|
|
my %hash = @_; |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
my($type, $basedir, $perl, $release); |
1101
|
|
|
|
|
|
|
my $tmpl = { |
1102
|
|
|
|
|
|
|
type => { required => 1, store => \$type, |
1103
|
|
|
|
|
|
|
allow => [ DEB_METAFILE_SOURCES, |
1104
|
|
|
|
|
|
|
DEB_METAFILE_PACKAGES] }, |
1105
|
|
|
|
|
|
|
basedir => { store => \$basedir }, |
1106
|
|
|
|
|
|
|
perl => { default => $^X, store => \$perl }, |
1107
|
|
|
|
|
|
|
release => { default => DEB_DEFAULT_RELEASE, store => \$release }, |
1108
|
|
|
|
|
|
|
}; |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
check( $tmpl, \%hash ) or return; |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
### check only once for it per running session if possible |
1113
|
|
|
|
|
|
|
$prog ||= DEB_METAFILE_PROGRAM->(); |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
### optional program, just can't run it. |
1116
|
|
|
|
|
|
|
unless( $prog ) { |
1117
|
|
|
|
|
|
|
error(loc("Could not find '%1' in your path -- please install it", |
1118
|
|
|
|
|
|
|
$prog)); |
1119
|
|
|
|
|
|
|
return; |
1120
|
|
|
|
|
|
|
} |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
### class or object method? |
1123
|
|
|
|
|
|
|
my $conf = ref $dist |
1124
|
|
|
|
|
|
|
? $dist->parent->parent->configure_object |
1125
|
|
|
|
|
|
|
: do { require CPANPLUS::Configure; |
1126
|
|
|
|
|
|
|
CPANPLUS::Configure->new }; |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
### store the old value if needed |
1129
|
|
|
|
|
|
|
my $oldbase; |
1130
|
|
|
|
|
|
|
if( $basedir ) { |
1131
|
|
|
|
|
|
|
$oldbase = $conf->get_conf('base'); |
1132
|
|
|
|
|
|
|
$conf->set_conf( base => $basedir ); |
1133
|
|
|
|
|
|
|
}; |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
### this is the base path under which we'll put the debian structure |
1136
|
|
|
|
|
|
|
### for source files |
1137
|
|
|
|
|
|
|
my $path = DEB_BASE_DIR->( $conf, $perl ); |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
### set back the old path |
1140
|
|
|
|
|
|
|
$conf->set_conf( base => $oldbase ) if $oldbase; |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
my $outputfile = DEB_OUTPUT_METAFILE->( $type, $path ); |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
### check if we need to make the dir for this output file |
1145
|
|
|
|
|
|
|
{ my $dir = dirname( $outputfile ); |
1146
|
|
|
|
|
|
|
unless( -d $dir ) { |
1147
|
|
|
|
|
|
|
CPANPLUS::Internals::Utils->_mkdir( dir => $dir ) or return; |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
} |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
my $oldcwd = cwd(); |
1152
|
|
|
|
|
|
|
chdir $path or return error(loc( "Could not chdir to '%1': %2", |
1153
|
|
|
|
|
|
|
$basedir, $! )); |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
my $buffer; |
1156
|
|
|
|
|
|
|
my $fail; |
1157
|
|
|
|
|
|
|
my $command = "$prog $type . | gzip -9 > $outputfile"; |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
### using IPC::Cmd here gives errors, probably due to pipes and > |
1160
|
|
|
|
|
|
|
if( system($command) ) { |
1161
|
|
|
|
|
|
|
error(loc("Could not run command '%1': %2", $command, $buffer )); |
1162
|
|
|
|
|
|
|
$fail++; |
1163
|
|
|
|
|
|
|
} |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
chdir $oldcwd or error(loc("Could not chdir back to '%1': %2", |
1166
|
|
|
|
|
|
|
$oldcwd, $! )); |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
return if $fail; |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
return $outputfile; |
1171
|
|
|
|
|
|
|
} |
1172
|
|
|
|
|
|
|
} |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
|
1175
|
|
|
|
|
|
|
1; |
1176
|
|
|
|
|
|
|
|
1177
|
|
|
|
|
|
|
=pod |
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
=head1 TODO |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
There are no TODOs of a technical nature currently, merely of an |
1182
|
|
|
|
|
|
|
administrative one; |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
=over 4 |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
=item Scan for proper license |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
Right now we assume that the license of every module is C
|
1189
|
|
|
|
|
|
|
as perl itself>. Although correct in almost all cases, it should |
1190
|
|
|
|
|
|
|
really be probed rather than assumed. |
1191
|
|
|
|
|
|
|
This forms a barrier before C<.debs> generated by this package can |
1192
|
|
|
|
|
|
|
be used by C itself in it's own repositories. |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
=item Long description |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
Right now we provided the description as given by the module in it's |
1197
|
|
|
|
|
|
|
meta data. However, not all modules provide this meta data and rather |
1198
|
|
|
|
|
|
|
than scanning the files in the package for it, we simply default to the |
1199
|
|
|
|
|
|
|
name of the module. |
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
=back |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
=head1 AUTHOR |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
This module by |
1206
|
|
|
|
|
|
|
Jos Boumans Ekane@cpan.orgE. |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
The CPAN++ interface (of which this module is a part of) is |
1211
|
|
|
|
|
|
|
copyright (c) 2005, Jos Boumans Ekane@cpan.orgE. |
1212
|
|
|
|
|
|
|
All rights reserved. |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
This library is free software; |
1215
|
|
|
|
|
|
|
you may redistribute and/or modify it under the same |
1216
|
|
|
|
|
|
|
terms as Perl itself. |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
=head1 SEE ALSO |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
L, L, L, |
1221
|
|
|
|
|
|
|
C, C, C |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
=cut |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
# Local variables: |
1228
|
|
|
|
|
|
|
# c-indentation-style: bsd |
1229
|
|
|
|
|
|
|
# c-basic-offset: 4 |
1230
|
|
|
|
|
|
|
# indent-tabs-mode: nil |
1231
|
|
|
|
|
|
|
# End: |
1232
|
|
|
|
|
|
|
# vim: expandtab shiftwidth=4: |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
__END__ |