File Coverage

lib/CPANPLUS/Dist/Deb.pm
Criterion Covered Total %
statement 51 256 19.9
branch 3 98 3.0
condition 0 18 0.0
subroutine 16 22 72.7
pod 7 7 100.0
total 77 401 19.2


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__