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

package CPANPLUS::Dist::Deb;

use strict;
use vars    qw[@ISA $VERSION];
@ISA =      qw[CPANPLUS::Dist];
$VERSION =  '0.12';

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Dist::Deb::Constants;

use FileHandle;
use File::Basename;
use File::Find;
use File::Path;
use Cwd;

use IPC::Cmd                    qw[run can_run];
use Params::Check               qw[check];
use File::Basename              qw[dirname];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Params::Check::VERBOSE = 1;


=pod

=head1 NAME

CPANPLUS::Dist::Deb

=head1 SYNOPSIS

    my $cb      = CPANPLUS::Backend->new;
    my $modobj  = $cb->module_tree('Some::Module');


    ### as an option to ->install()
    $modobj->install( format => 'CPANPLUS::Dist::Deb' );


    ### just to create the debs, don't install
    $modobj->install( format => 'CPANPLUS::Dist::Deb',
                      target => 'create',
                      prereq_target => 'create' );


    ### the long way around
    $mobobj->fetch;
    $modobj->extract;

    my $deb = CPANPLUS::Dist->new(
                                format  => 'CPANPLUS::Dist::Deb',
                                module  => $modobj,
                                %extra_opts,
                          );

    $bool   = $deb->create;     # create a .deb file
    $bool   = $deb->install;    # installs the .deb file

    $where  = $deb->status->dist;                   # from the dist obj
    $where  = $modobj->status->dist->status->dist;  # from the mod obj


    ### from the CPANPLUS Default shell
    CPAN Terminal> i --format=CPANPLUS::Dist::Deb Some::Module

    ### using the commandline tool
    cpan2dist --format CPANPLUS::Dist::Deb Some::Module

=head1 DESCRIPTION

C is a distribution class to create C
packages from C modules, and all it's dependencies. This allows
you to have the most recent copies of C modules installed,
using your package manager of choice, but without having to wait for
central repositories to be updated.

You can either install them using the API provided in this package,
or manually via C.

Some of the bleading edge C modules have already been turned
into debian packages for you, and you can make use of them by adding
the following line to your C file:

    deb http://debian.pkgs.cpan.org/debian unstable main

Note that these packages are built automatically from CPAN and are
assumed to have the same license as perl and come without support.
Please always refer to the original C package if you have
questions.

=cut


=head1 ACCESSORS

=over 4

=item parent()

Returns the C object that parented this object.

=item status()

Returns the C object that keeps the status for
this module.

Look at C for a list of standard accessors every
C object will have. Below is a list of those specific to
this package.

Note that these are mostly to ensure the inner workings of this
package.

=back

=head1 STATUS ACCESSORS

All accessors can be accessed as follows:
    $deb->status->ACCESSOR

=over 4

=item rules()

The location of the C file.

Will be removed after successful creation.

=item compat()

The location of the C file

Will be removed after successful creation.

=item changelog()

The location of the C file

Will be removed after successful creation.

=item copyright()

The location of the C file

Will be removed after successful creation.

=item control()

The location of the C file

Will be removed after successful creation.

=item distdir()

The directory where the C<.deb> file is placed.

Will be removed after successful creation.

=item package()

The location of the C<.deb> file.

Note this is equivalent to the C accessor already
standardly provided.

=item files()

List of all the generated files for this distribution.

=back

=cut


=head1 METHODS

=head2 $bool = CPANPLUS::Dist::Deb->format_available();

Returns a boolean indicating whether or not you can use this package
to create and install modules in your environment.

It will verify if you have all the necessary components avialable to
build your own debian packages. You will need at least these
dependencies installed:

=over 4

=item debhelper

=item dpkg

=item dpkg-dev

=item fakeroot

=item gcc

=item libc6-dev

=item findutils

=back

=cut

### XXX check if we're on debian? or perhaps we can do this cross-platform
sub format_available {
    my $flag;
    for my $prog (qw[gencat dpkg dh_perl gcc cp dpkg-buildpackage
                     fakeroot xargs find]) {
        unless( can_run($prog) ) {
            error(loc("'%1' is a required program to build debian packages",
                      $prog));
            $flag++;
        }
    }
    return $flag ? 0 : 1;
}

=head2 $bool = $deb->init

Sets up the C object for use.
Effectively creates all the needed status accessors.

Called automatically whenever you create a new C
object.

=cut

sub init {
    my $self    = shift;
    my $status  = $self->status;

    $status->mk_accessors(qw[rules compat changelog copyright control distdir
                             debiandir package package_name package_filename
                             readme prefix builddir _tmp_output_dir files
                             _prepare_args _create_args _install_args]);
                             ### XXX we might not be using _args properly!
    return 1;
}

=pod

=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])

C preps a distribution for creation. This means it will create
all meta data files required by C to build a C<.deb>
file of hte module you specified.
This will also satisfy any prerequisites the module may have.

If you set C to true, it will skip the C stage.
If you set C to true, it will go over all the stages of the
creation process again, ignoring any previously cached results. It
will also ignore a bad return value from the C stage and still
allow the operation to return true.

Returns true on success and false on failure.

You may then call C<< $deb->create >> on the object to create the
C<.deb> from the metadata, and then C<< $deb->install >> on the object
to actually install it.

Returns the location of the builddir on success, and false on failure.

Note any extra options you pass along, will be passed to the underlying
installers verbatim. This enables you to, for example, specify extra
flags for the C stage.

=cut

sub prepare {
    ### just in case you already did a create call for this module object
    ### just via a different dist object
    my $dist        = shift;
    my $self        = $dist->parent;
    my $dist_cpan   = $self->status->dist_cpan;
    $dist           = $self->status->dist   if      $self->status->dist;
    $self->status->dist( $dist )            unless  $self->status->dist;

    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my $args;
    my( $verbose,$force,$perl,$prereq_target,$distdir,$copyright,$prefix,
        $keep_source,$distribution, $deb_version,$prereq_build);
    {   local $Params::Check::ALLOW_UNKNOWN = 1;
        my $tmpl = {
            verbose     => { default => $conf->get_conf('verbose'),
                                store => \$verbose },
            force       => { default => $conf->get_conf('force'),
                                store => \$force },
            perl        => { default => $^X, store => \$perl },
            ### XXX is this the right thing to do???
            prereq_target   => { default => 'install',
                                 store   => \$prereq_target },
            copyright       => { default => DEB_STANDARD_COPYRIGHT_PERL,
                                 store   => \$copyright },
            distdir         => { default => '', store => \$distdir },
            prefix          => { default => 'cpan-', store => \$prefix },
            distribution    => { default => DEB_DEFAULT_RELEASE,
                                  store => \$distribution },
            deb_version     => { default => DEB_DEFAULT_PACKAGE_VERSION,
                                  store => \$deb_version },
            #keep_source     => { default => 0, store => \$keep_source },
            prereq_build    => { default => 0, store => \$prereq_build },
        };

        $args = check( $tmpl, \%hash ) or return;
    }

    ### store the prefix for later use
    $dist->status->prefix( $prefix );
    $dist->status->package_name( DEB_PACKAGE_NAME->($self, $prefix) );

    ### the directory we're going to put the files in, which has either
    ### a custom root, or our standard base directory
    my $basedir = File::Spec->catdir(
                        ( $distdir || DEB_BASE_DIR->( $conf, $perl ) ),
                        DEB_DISTDIR->( $dist, $prefix )
                    );

    ### did we already create the package? if so, don't bother to rebuild
    ### unless we are forced to

    {   for my $has_xs (0,1) {
            my $pkg = DEB_DEB_FILE_NAME->(
                            $self, $basedir, $prefix, $has_xs, $deb_version
                        );

            if( -e $pkg && -s _ and not $force) {
                msg(loc("Already created package of '%1' at '%2' -- not doing"
                        ." so again unless you force", $self->module, $pkg ));

                $dist->status->prepared( 1 );
                $dist->status->created( 1 );
                $dist->status->package( $pkg );
                return $dist->status->dist( $pkg );
            }
        }
    }

    {   ### we must install in site or vendor dirs..which means we *must*
        ### tell this to the underlying make/build process!
        MAKE: {
            my $mmflags = $conf->get_conf('makemakerflags');
            my $mmadd   = DEB_MAKEMAKERFLAGS->( $dist->status->prefix );
            $conf->set_conf( makemakerflags => $mmflags . ' ' . $mmadd )
                unless $mmflags =~ /$mmadd/;

            my $buildflags  = $conf->get_conf('buildflags');
            my $buildadd    = DEB_BUILDFLAGS->( $dist->status->prefix );
            $conf->set_conf(  buildflags => $buildflags . ' ' . $buildadd )
                unless $buildflags =~ /$buildadd/;

            my $fail;
            $fail++ unless $dist_cpan->prepare( %hash );

            ### restore the flags
            $conf->set_conf( makemakerflags => $mmflags );
            $conf->set_conf( buildflags     => $buildflags );

            if( $fail ) {
                $dist->status->prepared(0);
                return;
            }
        }


        unless ( $dist_cpan->create( %hash, prereq_format => __PACKAGE__ ) ) {
            $dist->status->prepared(0);
            return;
        }



        my $debdir = DEB_DEBIAN_DIR->( $self->status->extract );
        ### store the dirs we build debs in, and where we put the current
        ### meta data files
        $dist->status->distdir( $basedir );                # final destination
        $dist->status->builddir( $self->status->extract ); # [EXTRACT]/
        $dist->status->debiandir( $debdir );               # [EXTRACT]/debian
        ### dir where the generated packages will end up after compiling them,
        ### before moving them to their final destination
        $dist->status->_tmp_output_dir(
            File::Spec->catdir( $dist->status->builddir, '..' ) );


        ### create final destination dir && debian subdir ###
        for ( $debdir, $basedir ) {
            unless( -d $_ ) {
                unless( $cb->_mkdir( dir => $_ ) ) {
                    error( loc("Could not create directory '%1'", $_ ) );
                    $dist->status->prepared(0);
                    return;
                }
            }
        }

        ### chdir to builddir ###
        unless( $cb->_chdir( dir => $dist->status->builddir ) ) {
            $dist->status->prepared(0);
            return;
        }
    }


    ### copy the original tarball over, in .orig format so it can
    ### be diffed against by the dh- tools
    {   my $file = $self->status->fetch;
        my $orig = File::Spec->catdir(
                        $dist->status->builddir,
                        '..',   # be sure to updir, so the diff is included
                        DEB_ORIG_PACKAGE_NAME->( $self, $prefix ) );

        unless( $cb->_copy( file => $file, to => $orig ) ) {
            error(loc("Couldn't copy original archive '%1' to '%2'",
                        $file, $orig ));
            $dist->status->prepared(0);
            return;
        }
    }

    ### let's figure out what this distribution will be called -- we'll need
    ### that later to see if it was actually created
    {   my $has_xs  = scalar GET_XS_FILES->( $self->status->extract ) ? 1 : 0;
        my $debfile = DEB_DEB_FILE_NAME->(
                            $self, '.', $prefix, $has_xs, $deb_version
                        );

        $dist->status->package_filename( $debfile );
    }


    ### find where prereqs landed, etc.. add them to our dependency list ###
    my @depends;
    {   my $prereqs = $self->status->prereqs;

        for my $prereq ( sort keys %$prereqs ) {
            my $obj = $cb->module_tree($prereq);

            unless( $obj ) {
                error( loc( "Couldn't find module object for prerequisite ".
                            "'%1' -- skipping", $prereq ) );
                next;
            }

            ### no point in listing prereqs that are IN the perl core
            ### themselves
            next if $obj->package_is_perl_core;

            ### if the prereq requires any specific version, we'll assume
            ### the one we can provide, otherwise, we'll set it to undef,
            ### marking 'any'
            ### make sure we pick the /lowest/ version available, in case
            ### of custom patches, core running ahead of cpan, etc

            ### XXX here's a problem:
            ### some distributions contain several modules, like PathTools
            ### use to;
            ### Cwd 1.0, File::Spec 2.0, both in PathTools-3.0.tgz
            ### if you already have Cwd or File::Spec installed at a,
            ### for this install, sufficient version, we can no longer
            ### determine what /package/ they came from (as that information
            ### does not exist). So, if this situation occurs, we check
            ### if the installed version is the same as the cpan version.
            ### In that case, and then we will depend on the cpan package
            ### version. if *not* we will depend on the *installed_version*
            ### which may *differ* from the cpan version, but there's not
            ### much we can do :(
            {   my $version = undef;

                ### we need a certain version
                if( $prereqs->{$prereq} ) {

                    ### 2 scenarios -- either you have a previously
                    ### installed version, or you don't
                    if( $obj->installed_version ) {

                        ### if the installed version is the same or higher
                        ### (wtf? custom patches?) than the cpan version,
                        ### use the cpan package version
                        if( $obj->installed_version >= $obj->version ) {
                            $version = $obj->package_version;

                        ### the version is *lower* than what's on cpan
                        ### now we need to find out what package that was
                        ### released. However, that is currenty impossible :(
                        ### so we assume that the installed version is magically
                        ### matching the package version.. pretty please, with
                        ### sugar on top...
                        ### this will only possibly hurt if it's wrong, if you
                        ### are making these modules available through an apt
                        ### repo, which will then point to the 'wrong' debian
                        ### dependency.. however, since the dependency has also
                        ### been built by us, the 'right' cpan-lib*perl will
                        ### be picked.
                        } else {
                            $version = $obj->installed_version
                        }

                    ### no version installed? depend on the cpan package version
                    } else {
                        $version = $obj->package_version;
                    }
                }

                push @depends, [$obj, $version];
            }
        }
    }

    ### write a standard debian readme file
    {   my $debreadme = DEB_README->( $dist->status->builddir );

        ### open the makefile for writing ###
        my $fh;
        unless( $fh = FileHandle->new( ">$debreadme" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                         $debreadme, $! ) );
            $dist->status->prepared(0);
            return;
        }

        print $fh DEB_README_CONTENTS;
        close $fh;

        $dist->status->readme( $debreadme );
    }

    ### get all the metadata to make the control file ###
    {   my $control = DEB_CONTROL->( $dist->status->builddir );

        ### open the makefile for writing ###
        my $fh;
        unless( $fh = FileHandle->new( ">$control" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                         $control, $! ) );
            $dist->status->prepared(0);
            return;
        }

        ### check if there are xs files in this distribution ###
        my $has_xs = scalar GET_XS_FILES->( $self->status->extract ) ? 1 : 0;

        my $maintainer      = $conf->get_conf('email');
        my $desc            = $self->description || $self->module;
        my $arch            = DEB_RULES_ARCH->($has_xs);

        my $pkg             = DEB_PACKAGE_NAME->($self, $prefix);
        my $std_version     = DEB_STANDARDS_VERSION;
        my $debhelper       = DEB_DEBHELPER;
        my $perl_depends    = DEB_PERL_DEPENDS;

        ### prereqs will be 'libfoo-perl' if we don't have a prefix and
        ### '${prefix}libfoo-perl' if we do have a prefix. We only add the
        ### >= VERSION if the prereqs were stated with requiring a certain
        ### version.. otherwise we leave it empty
        my %seen;
        my $prereqs         = join ', ', map {
                                ### do we need a specific version?
                                my $ver = $_->[1]
                                            ? ' (>= ' . $_->[1] . ')'
                                            : '';

                                ### standard lib
                                my $str = DEB_PACKAGE_NAME->($_->[0]) . $ver;

                                ### our lib, if it has a prefix
                                if( $prefix ) {
                                    $str .= ' | ' . DEB_PACKAGE_NAME->(
                                            $_->[0], $prefix) . $ver;
                                }

                                $str;
                            } grep {
                                ### shouldn't be a core module
                                ### and we shouldn't list the same
                                ### prereq twice. Note that 2 modules
                                ### may be in 1 package
                                !$_->[0]->package_is_perl_core and
                                !$seen{ DEB_PACKAGE_NAME->( $_->[0] ) }++
                            } @depends;

        ### always put debhelper in build-depends ###
        my $build_depends   =  $debhelper;

        ### always add prereqs to depends ###
        my $depends         = join ', ', $perl_depends, $prereqs;

        ### empty by default, only used if this module has xs parts ###
        my $build_indep; my $bdi_line = '';

        ### xs module, so all dependencies go in build-depend-indep
        if( $has_xs ) {
            $build_indep = $prereqs;

            ### the build-depends-indep line to add to the here-doc
            ### since it's not allowed to be empty in the rules file
            $bdi_line = "Build-Depends-Indep: $build_depends";

        ### no xs, so all dependencies get added to build-depend
        } else {
            $build_depends .= ', ' . $prereqs;
        }


        my $contents = << "EOF";
Source: $pkg
Section: perl
Priority: optional
Maintainer: $maintainer
Standards-Version: $std_version
Build-Depends: $build_depends
$bdi_line

Architecture: $arch
Package: $pkg
EOF

        ### we might have to print some 'Replaces:' lines
        ### - replace perl core if we were ever part of it
        ### - replaces 'standard' debian module (that may or may not exist)
        ###     if we are built without a prefix
        ### XXX OBSOLETE! since we install completely paralel to existing
        ### moduels, and dont replace any files, Replaces: is no longer
        ### required
#         if ( $self->module_is_supplied_with_perl_core or not $prefix ) {
#             my @printme;
#
#             $fh->print('Replaces: ');
#
#             ### so this module is also in perl core, add a rule telling the
#             ### .deb that it's ok to replace stuff from those packages.
#             push @printme, DEB_REPLACE_PERL_CORE
#                 if $self->module_is_supplied_with_perl_core;
#
#             push @printme, DEB_PACKAGE_NAME->($self) if $prefix;
#
#             $fh->print( join(', ', @printme), "\n" );
#         }

        ### so we have a prefix? best explain what package we are /actually/
        ### providing. Also note the Conflicts
        $contents .= "Provides: " . DEB_PACKAGE_NAME->($self) . "\n" if $prefix;

        ### XXX remove 'Conflicts:' -- versioned provides don't work
        ### with dpkg :( so if someone wants 'libfoo-perl > 2.0' it
        ### will be seen as not provided by our libfoo-perl, and
        ### will propbably uninstall these things... bad bad :(
        #  "Conflicts: ". DEB_PACKAGE_NAME->($self) . "\n")

        ### description should be mentioned twice: one long one, one
        ### short one... format is as follows:
        ### Description: short desc
        ### long description

        $contents .= << "EOF";
Depends: $depends
Description: $desc
 $desc

EOF

        ### run the contents through the callback for munging
        ### make this conditional, as this was introduced in the
        ### dev branch of 0.81_01, so not all may have it (automatically)
        ### installed
        if( $cb->_callbacks->munge_dist_metafile ) {
            $contents = $cb->_callbacks->munge_dist_metafile->(
                            $cb, $contents
                        );
        }

        $fh->print( $contents );

        $fh->close;
        $dist->status->control( $control );
    }


    ### get all the metadata for compat file and write it ###
    {   my $compat    = DEB_COMPAT->( $dist->status->builddir );

        my $fh;
        unless( $fh = FileHandle->new( ">$compat" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                        $compat, $! ) );
            $dist->status->prepared(0);
            return;
        }

        ### this is in the sample, but what the hell does it do?
        ### -- it's just the version of the spec files we used
        $fh->print( DEB_SPEC_FILE_VERSION . "\n");
        $fh->close;

        $dist->status->compat( $compat );
    }

    ### get all the metadata for changelog file and write it ###
    {   my $changelog   = DEB_CHANGELOG->( $dist->status->builddir );

        my $fh;
        unless( $fh = FileHandle->new( ">$changelog" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                        $changelog, $! ) );
            $dist->status->prepared(0);
            return;
        }

        ### XXX this will cause parse errors if the first line doesn't match
        ### if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) {
        ### (taken from /usr/lib/dpkg/parsechangelog/debian ) which means that
        ### we can not have _ in package names, but dots are fine.

        my $pkg     = DEB_PACKAGE_NAME->($self, $prefix);
        my $version = DEB_VERSION->($self, $deb_version);
        my $urgency = DEB_URGENCY;
        my $email   = $conf->get_conf('email');
        my $who     = __PACKAGE__;

        ### geez timestamps are a b*tch with debian changelogs..
        ### this is the only correct format:
        ### Sun,  3 Jun 2001 20:36:41 +0200
        ### but scalar gmtime says:
        ### Sat Jul  3 14:23:31 2004
        my ($wday, $mon, $day, $time, $year) = split /\s+/, scalar gmtime;
        my $when = sprintf "%s, %2d %s %s %s +0100",
                    $wday, $day, $mon, $year, $time; # crackfueled :(

        $fh->print(<< "EOF");
$pkg ($version) $distribution; $urgency

  * Initial Release.

 -- $who <$email>  $when

EOF

        $fh->close;

        $dist->status->changelog( $changelog );
    }

    ### get all the metadata for changelog file and write it ###
    {   my $copyright_file = DEB_COPYRIGHT->( $dist->status->builddir );

        my $fh;
        unless( $fh = FileHandle->new( ">$copyright_file" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                        $copyright_file, $! ) );
            $dist->status->prepared(0);
            return;
        }

        ### XXX probe for possible license here rather than assume the
        ### default
        my $pkg     = $self->module;
        my $who     = $ENV{DEBFULLMAIL}
                        ? $ENV{DEBFULLNAME} . ' <' .
                          ($ENV{DEBEMAIL} || $conf->get_conf('email')) . '>'
                        : ($ENV{DEBEMAIL} || $conf->get_conf('email'));
        my $when    = 1900 + (localtime)[5];
        my $license = DEB_STANDARD_COPYRIGHT_PERL;
        my $author  = $self->author->author;
        my $email   = $self->author->email;

        $fh->print(<< "EOF");
This is the debian package for the $pkg module.
It was created by $who.

The upstream author is $author <$email>.

Copyright (c) $when by $author

$license

EOF

        $fh->close;
        $dist->status->copyright($copyright_file);
    }

    {   ### add the debian rules file, which is mostly static ###
        my $rules_file  = DEB_RULES->( $dist->status->builddir );
        my $has_xs      = scalar GET_XS_FILES->($self->status->extract)
                                ? 1 : 0;
        my $content     = DEB_GET_RULES_CONTENT->( $self, $prefix,
                                                    $has_xs, $verbose );

        my $fh;
        unless( $fh = FileHandle->new( ">$rules_file" ) ) {
            error( loc( "Could not open '%1' for writing: %2",
                        $rules_file, $! ) );
            $dist->status->prepared(0);
            return;
        }

        $fh->print( $content );
        $fh->close;

        ### make sure it's set as +x
        chmod 0755, $rules_file;

        $dist->status->rules( $rules_file );
    }

    $dist->status->prepared(1);
    return $dist->status->builddir;
}

=pod

=head2 $loc = $dist->create([force => BOOL, verbose => BOOL, keep_source => BOOL])

C preps a distribution for installation. This means it will
build a C<.deb> file of the module object you've specified from the
meta data files that were generated during C.

Returns true on success and false on failure.

You may then call C<< $deb->install >> on the object to actually
install it.
Returns the location of the C<.deb> file on success, and false on failure.

=cut

sub create {
    ### just in case you already did a create call for this module object
    ### just via a different dist object
    my $dist = shift;
    my $self = $dist->parent;
    $dist    = $self->status->dist   if      $self->status->dist;
    $self->status->dist( $dist )     unless  $self->status->dist;

    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my $args;
    my( $verbose,$force,$keep_source);
    {   local $Params::Check::ALLOW_UNKNOWN = 1;
        my $tmpl = {
            verbose     => { default => $conf->get_conf('verbose'),
                                store => \$verbose },
            force       => { default => $conf->get_conf('force'),
                                store => \$force },
            keep_source => { default => undef, store => \$keep_source },
        };

        $args = check( $tmpl, \%hash ) or return;
    }

    ### did you prepare it yet?
    unless( $dist->status->prepared ) {
        error( loc( "You have not successfully prepared a '%2' distribution ".
                    "yet -- cannot create yet", __PACKAGE__ ) );
        return;
    }

    ### already created?
    if( $dist->status->created and not $force ) {
        msg(loc("You have already created a '%1' distribution -- not doing ".
                "so again unless you force", __PACKAGE__ ));
        return 1;
    }

    ### chdir to it ###
    unless( $cb->_chdir( dir => $dist->status->builddir ) ) {
        $dist->status->created(0);
        return;
    }

    {   ### all rules files done, time to build the .deb ###
        ### need to run: dpkg-buildpackage -rfakeroot -uc -us
        my $prog;
        unless( $prog = DEB_BIN_BUILDPACKAGE->() ) {
            error(loc( "Cannot create debian package" ));
            return $dist->status->created(0);
        }

        my $buffer;
        unless( scalar run(
                    command => [$prog, qw|-rfakeroot -uc -us -d|,
                                DEB_DPKG_SOURCE_IGNORE],
                    verbose => $verbose,
                    buffer  => \$buffer )
        ) {
            error( loc( "Failed to create debian package for '%1': '%2'",
                        $self->module, $buffer ) );

            return $dist->status->created(0);
        }

        ### ok, now we have a package created in:
        ### ../$NAME_$VERSION_$ARCH.deb
        ### and we can't tell dpkg-buildpackage to output it anywhere else :(
        #my $has_xs  = scalar GET_XS_FILES->($self->status->extract) ? 1 : 0;
        {   my $tmpfile = File::Spec->catfile(  $dist->status->_tmp_output_dir,
                                                $dist->status->package_filename
                                            );

            unless( -e $tmpfile && -s _ ) {
                error( loc( "Debian package '%1' was supposed to be created ".
                            "but was not", $tmpfile ) );
                return $dist->status->created(0);
            }
        }

        ### XXX moves stuff here
        if( my @files = glob( File::Spec->catdir(
                                    $dist->status->_tmp_output_dir,
                                    $dist->status->package_name,
                                ) . '*' )
        ) {
            my @dest;
            for my $file (@files) {
                my $to = File::Spec->catdir(
                            $dist->status->distdir, basename( $file ) );

                unless( $cb->_move( file => $file, to => $to ) ) {
                    error(loc("Failed to move '%1' to its final ".
                                "destination '%2'", $file, $to ));
                    $dist->status->prepared(0);
                    return;
                }
                push @dest, $to;
            }

            ### save what files we ended up moving
            $dist->status->files( \@dest );

        } else {
            error(loc("No files found matching pattern '%1' in temporary ".
                        "directory '%2'", $dist->status->package_name,
                        $dist->status->_tmp_output_dir ));
            $dist->status->prepared(0);
            return;
        }

        ### final location
        my $debfile = File::Spec->catfile(  $dist->status->distdir,
                                            $dist->status->package_filename );


        ### store where we wrote the dist to
        $dist->status->package( $debfile );
        $dist->status->dist( $debfile );

        msg(loc("Wrote '%1' package for '%2' to '%3'",
                'debian', $self->module, $debfile), $verbose);

        unless( $cb->_chdir( dir => $conf->_get_build('startdir') ) ) {
            error(loc("Unable to '%1' back to startdir",'chdir'));
        }
    }

    ### if we're asked to clean up our sources, then they
    ### live in $dist->status->debiandir. Rmtree the lot
    unless ( $keep_source ) {
        my $dir = $dist->status->debiandir;
        msg(loc("Cleaning up meta directory '%1'",$dir), $verbose);
        $cb->_rmdir( dir => $dir );
    }

    $dist->status->created(1);
    return $dist->status->dist;
}

=pod

=head2 $bool = $deb->install([verbose => BOOL, force => BOOL, dpkg => /path/to/dpkg, dpkg_flags => ["--extra", "--flags"]]);

Installs the C<.deb> using C.

Returns true on success and false on failure

=cut

sub install {
    ### just in case you already did a create call for this module object
    ### just via a different dist object
    my $dist = shift;
    my $self = $dist->parent;
    $dist    = $self->status->dist   if      $self->status->dist;
    $self->status->dist( $dist )     unless  $self->status->dist;

    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my ($dpkg,$verbose,$force,$flags);

    {   local $Params::Check::ALLOW_UNKNOWN = 1;
        my $tmpl = {
            dpkg        => { default => can_run('dpkg'), store => \$dpkg },
            verbose     => { default => $conf->get_conf('verbose'),
                            store => \$verbose },
            force       => { default => $conf->get_conf('force'),
                                store => \$force },
            dpkg_flags  => { default => [], strict_type => 1,
                                store => \$flags },
        };

        check( $tmpl, \%hash ) or return;
    }

    ### build the command ###
    my $sudo = $conf->get_program('sudo');
    my @cmd  = ($dpkg, '-i', @$flags, $dist->status->package);
    unshift @cmd, $sudo if $sudo;

    my $buffer;
    unless( scalar run( command => \@cmd,
                        verbose => $verbose,
                        buffer  => \$buffer )
    ) {
        error( loc( "Unable to install '%1': %2",
                    $dist->status->package, $buffer ) );
        return $dist->status->installed(0);
    }

    return $dist->status->installed(1);
};

=pod

=head2 $bool = $deb->uninstall([verbose => BOOL, force => BOOL, dpkg => /path/to/dpkg, dpkg_flags => ["--extra", "--flags"]]);

Uninstalls the C<.deb> using C.

Returns true on success and false on failure

=cut

sub uninstall {
    ### just in case you already did a create call for this module object
    ### just via a different dist object
    my $dist = shift;
    my $self = $dist->parent;
    $dist    = $self->status->dist   if      $self->status->dist;
    $self->status->dist( $dist )     unless  $self->status->dist;

    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my ($dpkg,$verbose,$force,$flags);

    {   local $Params::Check::ALLOW_UNKNOWN = 1;
        my $tmpl = {
            dpkg        => { default => can_run('dpkg'), store => \$dpkg },
            verbose     => { default => $conf->get_conf('verbose'),
                            store => \$verbose },
            force       => { default => $conf->get_conf('force'),
                                store => \$force },
            dpkg_flags  => { default => [], strict_type => 1,
                                store => \$flags },
        };

        check( $tmpl, \%hash ) or return;
    }

    ### build the command ###
    my $sudo = $conf->get_program('sudo');
    my @cmd  = ($dpkg, '-r', @$flags, $dist->status->package_name);
    unshift @cmd, $sudo if $sudo;

    my $buffer;
    unless( scalar run( command => \@cmd,
                        verbose => $verbose,
                        buffer  => \$buffer )
    ) {
        error( loc( "Unable to uninstall '%1': %2",
                    $dist->status->package, $buffer ) );
        return $dist->status->uninstalled(0);
    }

    return $dist->status->uninstalled(1);
};

=head2 $loc = CPANPLUS::Dist::Deb->write_meta_files( type => sources|packages, [basedir => /path/to/base, perl => /path/to/perl, release => $releasename]);

This writes the metafiles needed to use this archive as a debian mirror.

It returns the location of the metafile on success, and false on failure.

=cut

{   my $prog;

    sub write_meta_files {
        my $dist = shift;
        my %hash  = @_;

        my($type, $basedir, $perl, $release);
        my $tmpl = {
            type    => { required => 1, store => \$type,
                            allow => [  DEB_METAFILE_SOURCES,
                                        DEB_METAFILE_PACKAGES] },
            basedir => { store => \$basedir },
            perl    => { default => $^X, store => \$perl },
            release => { default => DEB_DEFAULT_RELEASE, store => \$release },
        };

        check( $tmpl, \%hash ) or return;

        ### check only once for it per running session if possible
        $prog ||= DEB_METAFILE_PROGRAM->();

        ### optional program, just can't run it.
        unless( $prog ) {
            error(loc("Could not find '%1' in your path -- please install it",
                      $prog));
            return;
        }

        ### class or object method?
        my $conf = ref $dist
                        ? $dist->parent->parent->configure_object
                        : do {  require CPANPLUS::Configure;
                                CPANPLUS::Configure->new };

        ### store the old value if needed
        my $oldbase;
        if( $basedir ) {
            $oldbase = $conf->get_conf('base');
            $conf->set_conf( base => $basedir );
        };

        ### this is the base path under which we'll put the debian structure
        ### for source files
        my $path = DEB_BASE_DIR->( $conf, $perl );

        ### set back the old path
        $conf->set_conf( base => $oldbase ) if $oldbase;

        my $outputfile = DEB_OUTPUT_METAFILE->( $type, $path );

        ### check if we need to make the dir for this output file
        {   my $dir = dirname( $outputfile );
            unless( -d $dir ) {
                CPANPLUS::Internals::Utils->_mkdir( dir => $dir ) or return;
            }
        }

        my $oldcwd = cwd();
        chdir $path or return error(loc( "Could not chdir to '%1': %2",
                                            $basedir, $! ));

        my $buffer;
        my $fail;
        my $command = "$prog $type . | gzip -9 > $outputfile";

        ### using IPC::Cmd here gives errors, probably due to pipes and >
        if( system($command) ) {
            error(loc("Could not run command '%1': %2", $command, $buffer ));
            $fail++;
        }

        chdir $oldcwd or error(loc("Could not chdir back to '%1': %2",
                                    $oldcwd, $! ));

        return if $fail;

        return $outputfile;
    }
}


1;

=pod

=head1 TODO

There are no TODOs of a technical nature currently, merely of an
administrative one;

=over 4

=item Scan for proper license

Right now we assume that the license of every module is C
as perl itself>. Although correct in almost all cases, it should
really be probed rather than assumed.
This forms a barrier before C<.debs> generated by this package can
be used by C itself in it's own repositories.

=item Long description

Right now we provided the description as given by the module in it's
meta data. However, not all modules provide this meta data and rather
than scanning the files in the package for it, we simply default to the
name of the module.

=back

=head1 AUTHOR

This module by
Jos Boumans [e-mail].

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is
copyright (c) 2005, Jos Boumans [e-mail].
All rights reserved.

This library is free software;
you may redistribute and/or modify it under the same
terms as Perl itself.

=head1 SEE ALSO

L, L, L,
C, C, C

=cut



# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:


__END__