#!/usr/bin/perl
    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
	if $running_under_some_shell;
#!/usr/bin/perl -w
use strict;
use CPANPLUS::Backend;
use CPANPLUS::Dist;
use CPANPLUS::Internals::Constants;
use Data::Dumper;
use Getopt::Long;
use File::Spec;
use File::Temp                  qw|tempfile|;
use File::Basename;
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Data::Dumper::Indent = 1;

use constant PREREQ_SKIP_CLASS  => 'CPANPLUS::To::Dist::PREREQ_SKIP';
use constant ALARM_CLASS        => 'CPANPLUS::To::Dist::ALARM';

### print when you can
$|++;

my $cb      = CPANPLUS::Backend->new
                or die loc("Could not create new CPANPLUS::Backend object");
my $conf    = $cb->configure_object;

my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types;

my $opts    = {};
GetOptions( $opts,
            'format=s',             'archive',
            'verbose!',             'force!',
            'skiptest!',            'keepsource!',
            'makefile!',            'buildprereq!',
            'help',                 'flushcache',
            'ban=s@',               'banlist=s@',
            'ignore=s@',            'ignorelist=s@',
            'defaults',             'modulelist=s@',
            'logfile=s',            'timeout=s',
            'dist-opts=s%',         'set-config=s%',
            'default-banlist!',     'set-program=s%',
            'default-ignorelist!',  'edit-metafile!',
            'install!'
        );
        
die usage() if exists $opts->{'help'};

### parse options
my $tarball     = $opts->{'archive'}    || 0;
my $keep        = $opts->{'keepsource'} ? 1 : 0;
my $prereqbuild = exists $opts->{'buildprereq'}
                    ? $opts->{'buildprereq'}
                    : 0;
my $timeout     = exists $opts->{'timeout'} 
                    ? $opts->{'timeout'} 
                    : 300;

### use default answers?
$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0;

my $format;
### if provided, we go with the command line option, fall back to conf setting
{   $format      = $opts->{'format'}         || $conf->get_conf('dist_type');
    $conf->set_conf( dist_type  => $format );

    ### is this a valid format??
    die loc("Invalid format: " . ($format || "[NONE]") ) . usage() 
        unless $formats{$format};

    ### any options to fix config entries
    {   my $set_conf = $opts->{'set-config'} || {};
        while( my($key,$val) = each %$set_conf ) {
            $conf->set_conf( $key => $val );
        }
    }        

    ### any options to fix program entries
    {   my $set_prog = $opts->{'set-program'} || {};
        while( my($key,$val) = each %$set_prog ) {
            $conf->set_program( $key => $val );
        }
    }        

    ### any other options passed
    {   my %map = ( verbose     => 'verbose',
                    force       => 'force',
                    skiptest    => 'skiptest',
                    makefile    => 'prefer_makefile'
                );
                
        ### set config options from arguments        
        while (my($key,$val) = each %map) {
            my $bool = exists $opts->{$key} 
                            ? $opts->{$key} 
                            : $conf->get_conf($val);
            $conf->set_conf( $val => $bool );
        }    
    }        
}

my @modules = @ARGV;
if( exists $opts->{'modulelist'} ) {
    push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} }; 
} 

die usage() unless @modules;

### set up munge callback if requested
{   if( $opts->{'edit-metafile'} ) {
        my $editor = $conf->get_program('editor');
        
        if( $editor ) {
    
            ### register install callback ###
            $cb->_register_callback(
                name    => 'munge_dist_metafile',
                code    => sub {
                                my $self = shift;
                                my $text = shift or return;
                            
                                my($fh,$file) = tempfile( UNLINK => 1 );
                                
                                unless( print $fh $text ) {
                                    warn "Could not print metafile information: $!";
                                    return;
                                }
                                
                                close $fh;
                                
                                system( $editor => $file );
                                
                                my $cont = $cb->_get_file_contents( file => $file );
                                
                                return $cont;
                            },
            );
            
        } else {
            warn "No editor configured. Can not edit metafiles!\n";
        }
    }
}

my $fh;
LOGFILE: {
    if( my $file = $opts->{logfile} ) {
        open $fh, ">$file" or ( 
            warn loc("Could not open '%1' for writing: %2", $file,$!),
            last LOGFILE
        );            
        
        warn "Logging to '$file'\n";
        
        *STDERR = $fh;
        *STDOUT = $fh;
    }
}

### reload indices if so desired
$cb->reload_indices() if $opts->{'flushcache'};

{   my @ban      = exists $opts->{'ban'}  
                            ? map { qr/$_/ } @{ $opts->{'ban'} }
                            : ();


    if( exists $opts->{'banlist'} ) {
        push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} };
    }
    
    push @ban,  map  { s/\s+//; $_ }
                map  { [split /\s*#\s*/]->[0] }
                grep { /#/ }
                map  { split /\n/ } _default_ban_list() 
        if $opts->{'default-banlist'};
    
    ### use our prereq install callback 
    $conf->set_conf( prereqs => PREREQ_ASK );
    
    ### register install callback ###
    $cb->_register_callback(
            name    => 'install_prerequisite',
            code    => \&__ask_about_install,
    );

    
    ### check for ban patterns when handling prereqs
    sub __ask_about_install {
  
        my $mod     = shift or return;
        my $prereq  = shift or return;
    
    
        ### die with an error object, so we can verify that
        ### the die came from this location, and that it's an
        ### 'acceptable' death
        my $pat = ban_me( $prereq );
        die bless sub { loc("Module '%1' requires '%2' to be installed " .
                        "but found in your ban list (%3) -- skipping",
                        $mod->module, $prereq->module, $pat ) 
                  }, PREREQ_SKIP_CLASS if $pat;
        return 1;
    }    
    
    ### should we skip this module?
    sub ban_me {
        my $mod = shift;
        
        for my $pat ( @ban ) {
            return $pat if $mod->module =~ /$pat/i;
        }
        return;
    }
}    

### patterns to strip from prereq lists
{   my @ignore      = exists $opts->{'ignore'}  
                        ? map { qr/$_/ } @{ $opts->{'ignore'} }
                        : ();

    if( exists $opts->{'ignorelist'} ) {
        push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} };
    }

    push @ignore, map  { s/\s+//; $_ }
                  map  { [split /\s*#\s*/]->[0] }
                  grep { /#/ }
                  map  { split /\n/ } _default_ignore_list() 
        if $opts->{'default-ignorelist'};

    
    ### register install callback ###
    $cb->_register_callback(
            name    => 'filter_prereqs',
            code    => \&__filter_prereqs,
    );

    sub __filter_prereqs {
        my $cb      = shift;
        my $href    = shift;
        
        for my $name ( keys %$href ) {
            my $obj = $cb->parse_module( module => $name ) or (
                warn "Cannot make a module object out of ".
                        "'$name' -- skipping\n",
                next );

            if( my $pat = ignore_me( $obj ) ) {
                warn loc("'%1' found in your ignore list (%2) ".
                         "-- filtering it out\n", $name, $pat);

                delete $href->{ $name };                         
            }
        }

        return $href;
    }
    
    ### should we skip this module?
    sub ignore_me {
        my $mod = shift;
        
        for my $pat ( @ignore ) {
            return $pat if $mod->module =~ /$pat/i;
            return $pat if $mod->package_name =~ /$pat/i;
        }
        return;
    }   
}     


my %done;
for my $name (@modules) {

    my $obj;
    
    ### is it a tarball? then we get it locally and transform it
    ### and it's dependencies into .debs
    if( $tarball ) {
        ### make sure we use an absolute path, so chdirs() dont
        ### mess things up
        $name = File::Spec->rel2abs( $name ); 

        ### ENOTARBALL?
        unless( -e $name ) {
            warn loc("Archive '$name' does not exist");
            next;
        }
        
        $obj = CPANPLUS::Module::Fake->new(
                        module  => basename($name),
                        path    => dirname($name),
                        package => basename($name),
                    );

        ### if it's a traditional CPAN package, we can tidy
        ### up the module name some
        $obj->module( $obj->package_name ) if $obj->package_name;

        ### get the version from the package name
        $obj->version( $obj->package_version || 0 );

        ### set the location of the tarball
        $obj->status->fetch($name);

    ### plain old cpan module?    
    } else {

        ### find the corresponding module object ###
        $obj = $cb->parse_module( module => $name ) or (
                warn "Cannot make a module object out of ".
                        "'$name' -- skipping\n",
                next );
    }

    ### you banned it?
    if( my $pat = ban_me( $obj ) ) {
        warn loc("'%1' found in your ban list (%2) -- skipping\n",
                    $obj->module, $pat );
        next;
    }        
    
    ### or just ignored it? 
    if( my $pat = ignore_me( $obj ) ) {
        warn loc("'%1' found in your ignore list (%2) -- skipping\n",
                    $obj->module, $pat );
        next;
    }        
    

    my $target  = $opts->{'install'} ? 'install' : 'create';
    my $dist    = eval { 
                    local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS }
                        if $timeout;
                        
                    alarm $timeout || 0;

                    my $dist_opts = $opts->{'dist-opts'} || {};

                    my $rv = $obj->install(   
                            prereq_target   => $target,
                            target          => $target,
                            keep_source     => $keep,
                            prereq_build    => $prereqbuild,

                            ### any passed arbitrary options
                            %$dist_opts,
                    );
                    
                    alarm 0; 

                    $rv;
                }; 
                
    ### set here again, in case the install dies
    alarm 0;

    ### install failed due to a 'die' in our prereq skipper?
    if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) {
        warn loc("Dist creation of '%1' skipped: '%2'", 
                    $obj->module, $@->() );
        next;

    } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
        warn loc("\nDist creation of '%1' skipped, build time exceeded: ".
                 "%2 seconds\n", $obj->module, $timeout );
        next;                    

    ### died for some other reason? just report and skip
    } elsif ( $@ ) {
        warn loc("Dist creation of '%1' failed: '%2'",
                    $obj->module, $@ );
        next;
    }        

    ### we didn't get a dist object back?
    unless ($dist and $obj->status->dist) {
        warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module);
        next
    }

    print "Created '$format' distribution for ", $obj->module,
                " to:\n\t", $obj->status->dist->status->dist, "\n";
}


sub parse_file {
    my $file    = shift or return;
    my $qr      = shift() ? 1 : 0;

    my $fh = OPEN_FILE->( $file ) or return;

    my @rv;
    while( <$fh> ) {
        chomp;
        next if /^#/;                   # skip comments
        next unless /\S/;               # skip empty lines
        s/^(\S+).*/$1/;                 # skip extra info
        push @rv, $qr ? qr/$_/ : $_;    # add pattern to the list
    }
   
    return @rv;
}

=head1 NAME

cpan2dist - The CPANPLUS distribution creator

=head1 DESCRIPTION

This script will create distributions of C<CPAN> modules of the format
you specify, including its prerequisites. These packages can then be
installed using the corresponding package manager for the format.

Note, you can also do this interactively from the default shell,
C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation,
as well as the documentation of your format of choice for any format
specific documentation.

=head1 USAGE

=cut

sub usage {
    my $me      = basename($0);
    my $formats = join "\n", map { "\t\t$_" } sort keys %formats;

    my $usage = << '=cut';
=pod

 Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...]
        cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list
        cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2] 

    Will create a distribution of type FMT of the modules
    specified on the command line, and all their prerequisites.
    
    Can also create a distribution of type FMT from a local
    archive and all it's prerequisites

=cut

    $usage .= qq[
    Possible formats are:
$formats

    You can install more formats from CPAN!
    \n]ake a modul
Optionally, it can take a single-letter switch and one or more argument,
to perform the associated action on each arguments.  A summary of the
available commands is listed below; C<cpanp -h> provides a detailed list.

    h                   # help information
    v                   # version information

    a AUTHOR ...        # search by author(s)
    m MODULE ...        # search by module(s)
    f MODULE ...        # list all releases of a module

    i MODULE ...        # install module(s)
    t MODULE ...        # test module(s)
    u MODULE ...        # uninstall module(s)
    d MODULE ...        # download module(s)
    l MODULE ...        # display detailed information about module(s)
    r MODULE ...        # display README files of module(s)
    c MODULE ...        # check for module report(s) from cpan-testers
    z MODULE ...        # extract module(s) and open command prompt in it

    x                   # reload CPAN indices

    o [ MODULE ... ]    # list installed module(s) that aren't up to date
    b                   # write a bundle file for your configuration

Each command may be followed by one or more I<options>.  If preceded by C<no>,
the corresponding option will be set to C<0>, otherwise it's set to C<1>.

Example: To skip a module's tests,

    cpanp -i --skiptest MODULE ...

Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>,
C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the
'd' command also accepts C<fetchdir>.  Please consult L<CPANPLUS::Configure>
for an explanation to their meanings.

Example: To download a module's tarball to the current directory,

    cpanp -d --fetchdir=. MODULE ...

=cut

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
                                                                                                                                                                                                                                                     ./usr/bin/cpan2dist                                                                                 0000755 0000000 0000000 00000053612 11603212250 013106  0                                                                                                    ustar   root                            root                                                                                                                                                                                                                   #!/usr/bin/perl
    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
	if $running_under_some_shell;
#!/usr/bin/perl -w
use strict;
use CPANPLUS::Backend;
use CPANPLUS::Dist;
use CPANPLUS::Internals::Constants;
use Data::Dumper;
use Getopt::Long;
use File::Spec;
use File::Temp                  qw|tempfile|;
use File::Basename;
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

local $Data::Dumper::Indent = 1;

use constant PREREQ_SKIP_CLASS  => 'CPANPLUS::To::Dist::PREREQ_SKIP';
use constant ALARM_CLASS        => 'CPANPLUS::To::Dist::ALARM';

### print when you can
$|++;

my $cb      = CPANPLUS::Backend->new
                or die loc("Could not create new CPANPLUS::Backend object");
my $conf    = $cb->configure_object;

my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types;

my $opts    = {};
GetOptions( $opts,
            'format=s',             'archive',
            'verbose!',             'force!',
            'skiptest!',            'keepsource!',
            'makefile!',            'buildprereq!',
            'help',                 'flushcache',
            'ban=s@',               'banlist=s@',
            'ignore=s@',            'ignorelist=s@',
            'defaults',             'modulelist=s@',
            'logfile=s',            'timeout=s',
            'dist-opts=s%',         'set-config=s%',
            'default-banlist!',     'set-program=s%',
            'default-ignorelist!',  'edit-metafile!',
            'install!'
        );
        
die usage() if exists $opts->{'help'};

### parse options
my $tarball     = $opts->{'archive'}    || 0;
my $keep        = $opts->{'keepsource'} ? 1 : 0;
my $prereqbuild = exists $opts->{'buildprereq'}
                    ? $opts->{'buildprereq'}
                    : 0;
my $timeout     = exists $opts->{'timeout'} 
                    ? $opts->{'timeout'} 
                    : 300;

### use default answers?
$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0;

my $format;
### if provided, we go with the command line option, fall back to conf setting
{   $format      = $opts->{'format'}         || $conf->get_conf('dist_type');
    $conf->set_conf( dist_type  => $format );

    ### is this a valid format??
    die loc("Invalid format: " . ($format || "[NONE]") ) . usage() 
        unless $formats{$format};

    ### any options to fix config entries
    {   my $set_conf = $opts->{'set-config'} || {};
        while( my($key,$val) = each %$set_conf ) {
            $conf->set_conf( $key => $val );
        }
    }        

    ### any options to fix program entries
    {   my $set_prog = $opts->{'set-program'} || {};
        while( my($key,$val) = each %$set_prog ) {
            $conf->set_program( $key => $val );
        }
    }        

    ### any other options passed
    {   my %map = ( verbose     => 'verbose',
                    force       => 'force',
                    skiptest    => 'skiptest',
                    makefile    => 'prefer_makefile'
                );
                
        ### set config options from arguments        
        while (my($key,$val) = each %map) {
            my $bool = exists $opts->{$key} 
                            ? $opts->{$key} 
                            : $conf->get_conf($val);
            $conf->set_conf( $val => $bool );
        }    
    }        
}

my @modules = @ARGV;
if( exists $opts->{'modulelist'} ) {
    push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} }; 
} 

die usage() unless @modules;

### set up munge callback if requested
{   if( $opts->{'edit-metafile'} ) {
        my $editor = $conf->get_program('editor');
        
        if( $editor ) {
    
            ### register install callback ###
            $cb->_register_callback(
                name    => 'munge_dist_metafile',
                code    => sub {
                                my $self = shift;
                                my $text = shift or return;
                            
                                my($fh,$file) = tempfile( UNLINK => 1 );
                                
                                unless( print $fh $text ) {
                                    warn "Could not print metafile information: $!";
                                    return;
                                }
                                
                                close $fh;
                                
                                system( $editor => $file );
                                
                                my $cont = $cb->_get_file_contents( file => $file );
                                
                                return $cont;
                            },
            );
            
        } else {
            warn "No editor configured. Can not edit metafiles!\n";
        }
    }
}

my $fh;
LOGFILE: {
    if( my $file = $opts->{logfile} ) {
        open $fh, ">$file" or ( 
            warn loc("Could not open '%1' for writing: %2", $file,$!),
            last LOGFILE
        );            
        
        warn "Logging to '$file'\n";
        
        *STDERR = $fh;
        *STDOUT = $fh;
    }
}

### reload indices if so desired
$cb->reload_indices() if $opts->{'flushcache'};

{   my @ban      = exists $opts->{'ban'}  
                            ? map { qr/$_/ } @{ $opts->{'ban'} }
                            : ();


    if( exists $opts->{'banlist'} ) {
        push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} };
    }
    
    push @ban,  map  { s/\s+//; $_ }
                map  { [split /\s*#\s*/]->[0] }
                grep { /#/ }
                map  { split /\n/ } _default_ban_list() 
        if $opts->{'default-banlist'};
    
    ### use our prereq install callback 
    $conf->set_conf( prereqs => PREREQ_ASK );
    
    ### register install callback ###
    $cb->_register_callback(
            name    => 'install_prerequisite',
            code    => \&__ask_about_install,
    );

    
    ### check for ban patterns when handling prereq