summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/bin/cpan2dist
blob: 5ba4556c529e38698f1bfb77c75b73fd45b0ef65 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
#!/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 its 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 of its prerequisites.

=cut

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

    You can install more formats from CPAN!
    \n];
    
    $usage .= << '=cut';
=pod
    
Options:

    ### take no argument:
    --help          Show this help message
    --install       Install this package (and any prerequisites you built)
                    after building it. 
    --skiptest      Skip tests. Can be negated using --noskiptest
    --force         Force operation. Can be negated using --noforce
    --verbose       Be verbose. Can be negated using --noverbose
    --keepsource    Keep sources after building distribution. Can be
                    negated by --nokeepsource. May not be supported 
                    by all formats
    --makefile      Prefer Makefile.PL over Build.PL. Can be negated
                    using --nomakefile. Defaults to your config setting
    --buildprereq   Build packages of any prerequisites, even if they are
                    already uptodate on the local system. Can be negated
                    using --nobuildprereq. Defaults to false.
    --archive       Indicate that all modules listed are actually archives
    --flushcache    Update CPANPLUS' cache before commencing any operation
    --defaults      Instruct ExtUtils::MakeMaker and Module::Build to use
                    default answers during 'perl Makefile.PL' or 'perl
                    Build.PL' calls where possible
    --edit-metafile Edit the distributions metafile(s) before the distribution
                    is built. Requires a configured editor.

    ### take argument:
    --format      Installer format to use (defaults to config setting)
    --ban         Patterns of module names to skip during installation,
                  case-insensitive (affects prerequisites too)
                  May be given multiple times
    --banlist     File containing patterns that could be given to --ban
                  Are appended to the ban list built up by --ban
                  May be given multiple times.
    --ignore      Patterns of modules to exclude from prereq list. Useful
                  for when a prereq listed by a CPAN module is resolved 
                  in another way than from its corresponding CPAN package
                  (Match is done on both module name, and package name of
                  the package the module is in, case-insensitive)
    --ignorelist  File containing patterns that may be given to --ignore.
                  Are appended to the ban list built up by --ignore.
                  May be given multiple times.
    --modulelist  File containing a list of modules that should be built.
                  Are appended to the list of command line modules.
                  May be given multiple times.
    --logfile     File to log all output to. By default, all output goes
                  to the console.
    --timeout     The allowed time for buliding a distribution before
                  aborting. This is useful to terminate any build that 
                  hang or happen to be interactive despite being told not 
                  to be. Defaults to 300 seconds. To turn off, you can 
                  set it to 0.
    --set-config  Change any options as specified in your config for this
                  invocation only. See CPANPLUS::Config for a list of 
                  supported options.
    --set-program Change any programs as specified in your config for this
                  invocation only. See CPANPLUS::Config for a list of 
                  supported programs.
    --dist-opts   Arbitrary options passed along to the chosen installer
                  format's prepare()/create() routine. Please see the
                  documentation of the installer of your choice for 
                  options it accepts.

    ### builtin lists
    --default-banlist    Use our builtin banlist. Works just like --ban
                         and --banlist, but with pre-set lists. See the
                         "Builtin Lists" section for details.
    --default-ignorelist Use our builtin ignorelist. Works just like 
                         --ignore and --ignorelist but with pre-set lists. 
                         See the "Builtin Lists" section for details.

Examples:

    ### build a debian package of DBI and its prerequisites, 
    ### don't bother running tests
    cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI
    
    ### build a debian package of DBI and its prerequisites and install them
    cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI
    
    ### Build a package, whose format is determined by your config, of 
    ### the local tarball, reloading cpanplus' indices first and using
    ### the tarballs Makefile.PL if it has one.
    cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz
    
    ### build a package from Net::FTP, but dont build any packages or
    ### dependencies whose name match 'Foo', 'Bar' or any of the 
    ### patterns mentioned in /tmp/ban
    cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP
    
    ### build a package from Net::FTP, but ignore its listed dependency
    ### on IO::Socket, as it's shipped per default with the OS we're on
    cpan2dist --ignore IO::Socket Net::FTP
    
    ### building all modules listed, plus their prerequisites
    cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban 
      --modulelist /tmp/modules.list --buildprereq --flushcache 
      --makefile --defaults
    
    ### pass arbitrary options to the format's prepare()/create() routine
    cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp

=cut
    
    $usage .= qq[
Builtin Lists:

    Ignore list:] . _default_ignore_list() . qq[
    Ban list:] .    _default_ban_list();
    
    ### strip the pod directives
    $usage =~ s/=pod\n//g;
    
    return $usage;
}

=pod

=head1 Built-In Filter Lists

Some modules you'd rather not package. Some because they
are part of core-perl and you dont want a new package.
Some because they won't build on your system. Some because
your package manager of choice already packages them for you.

There may be a myriad of reasons. You can use the C<--ignore>
and C<--ban> options for this, but we provide some built-in
lists that catch common cases. You can use these built-in lists
if you like, or supply your own if need be.

=head2 Built-In Ignore List

=pod 

You can use this list of regexes to ignore modules matching
to be listed as prerequisites of a package. Particulaly useful
if they are bundled with core-perl anyway and they have known
issues building.

Toggle it by supplying the C<--default-ignorelist> option.

=cut

sub _default_ignore_list {

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

    ^IO$                    # Provided with core anyway
    ^Cwd$                   # Provided with core anyway
    ^File::Spec             # Provided with core anyway
    ^Config$                # Perl's own config, not shipped separately
    ^ExtUtils::MakeMaker$   # Shipped with perl, recent versions 
                            # have bug 14721 (see rt.cpan.org)
    ^ExtUtils::Install$     # Part of of EU::MM, same reason    

=cut

    return $list;
}

=head2 Built-In Ban list

You can use this list of regexes to disable building of these
modules altogether.

Toggle it by supplying the C<--default-banlist> option.

=cut

sub _default_ban_list {

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

    ^GD$                # Needs c libaries
    ^Berk.*DB           # DB packages require specific options & linking
    ^DBD::              # DBD drives require database files/headers
    ^XML::              # XML modules usually require expat libraries
    Apache              # These usually require apache libraries
    SSL                 # These usually require SSL certificates & libs
    Image::Magick       # Needs ImageMagick C libraries
    Mail::ClamAV        # Needs ClamAV C Libraries
    ^Verilog            # Needs Verilog C Libraries
    ^Authen::PAM$       # Needs PAM C libraries & Headers

=cut

    return $list;
}

__END__

=head1 SEE ALSO

L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>,
C<cpanp>

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.

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

=cut

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