pldcpan.pl

   1 #!/usr/bin/perl -w
   2 # Requirements:
   3 # perl-Pod-Tree perl-Archive-Any perl-Template-Toolkit perl-YAML perl-IO-String
   4 # perl-File-Find-Rule perl-Module-CoreList
   5
   6 =head1 NAME
   7
   8 pldcpan - A Perl module packager
   9
  10 =head1 SYNOPSIS
  11
  12     pldcpan.pl [ OPTIONS ] DIST [ DIST2 DIST3 ... ]
  13
  14 =head1 DESCRIPTION
  15
  16 This program uncompresses given archives in the current directory and -- more
  17 or less successfully -- attempts to write corresponding perl-*.spec files.
  18
  19 DIST can be a directory, a compressed archive, URL to fetch or module name
  20 (Foo::Bar) to be found on search.cpan.org.
  21
  22 =head1 TODO
  23
  24 Some things we're working on/thinking about:
  25
  26 =over
  27
  28 =item 1.
  29
  30 use poldek to search whether dir should be packaged:
  31
  32      $ poldek -q --cmd search -f /usr/share/perl5/vendor_perl/Text
  33      perl-base-5.8.7-4
  34
  35 =item 2.
  36
  37 first could be checked if the dir is contained by perl-base (will be faster than querying poldek)
  38
  39 =item 3.
  40
  41 Detect Module::AutoInstall and add --skipdeps to Makefile.PL.
  42
  43 =back
  44
  45 =head1 BUGS
  46
  47 Every software has bugs, if you find one and it's really annoying for you, try
  48 opening bugreport at: F<http://bugs.pld-linux.org>
  49
  50 =head1 AUTHOR
  51
  52 Radoslaw Zielinski <radek@pld-linux.org>.
  53 This manual page was composed by Elan Ruusamae <glen@pld-linux.org>
  54
  55 =head1 LICENSE AND COPYRIGHT
  56
  57 Copyright (c) 2004-2008 PLD Linux Distribution
  58
  59 This product is free and distributed under the Gnu Public License (GPL).
  60
  61 =cut
  62
  63
  64 use strict;
  65
  66 use Cwd qw( getcwd );
  67 use Getopt::Long qw( GetOptions );
  68 use IPC::Run qw( run timeout );
  69 use Pod::Select qw( podselect );
  70 use YAML::Any qw(LoadFile);
  71
  72 use Pod::Tree        ();
  73 use Archive::Any     ();
  74 use Template         ();
  75 use Digest::MD5      ();
  76 use IO::String       ();
  77 use File::Find::Rule ();
  78 use Module::CoreList ();
  79 use LWP::Simple      ();
  80
  81 our $VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\d+)/g;
  82 our %opts;
  83 GetOptions(\%opts, 'verbose|v', 'modulebuild|B', 'makemaker|M', 'force');
  84 eval "use Data::Dump qw(pp);" if $opts{verbose};
  85 die $@                        if $@;
  86
  87 unless (@ARGV) {
  88         die <<'EOF';
  89 usage:
  90         pldcpan.pl [ OPTIONS ] DIST [ DIST2 DIST3 ... ]
  91
  92 options:
  93         -v|--verbose      shout, and shout loud
  94         -B|--modulebuild  prefer Module::Build (default)
  95         -M|--makemaker    prefer ExtUtils::MakeMaker
  96            --force        overwrite existing *.spec files
  97
  98 This program uncompresses given archives in the current directory
  99 and -- more or less successfully -- attempts to write corresponding
 100 perl-*.spec files.
 101
 102 DIST can be a directory, a compressed archive, URL to fetch or module
 103 name (Foo::Bar) to be found on search.cpan.org.
 104
 105 $Id$
 106 EOF
 107 }
 108
 109 # get maximum information from directory name
 110 sub test_directory {
 111         my $fooball = shift;
 112         my $info    = shift;
 113         return $info->{_tests}->{directory}
 114           if defined $info->{_tests}->{directory};
 115
 116         #       FIXME: use -v  (hmm, what did I meant?)
 117         unless (
 118                 $fooball =~ m#^
 119                 (?:.*/)?
 120                 (
 121                   [a-z][a-z\d]*
 122                   (?:
 123                         ([-_])[a-z][a-z\d]*
 124                         (?: \2[a-z][a-z\d]*)*
 125                   )?
 126                 )
 127                 -
 128                 v?(\d[\d._-]*[a-z]?\d*)
 129                 /*$ #ix
 130           )
 131         {
 132                 warn " -- cannot resolve name and version: '$fooball'\n";
 133                 return $info->{_tests}->{directory} = 0;
 134         }
 135
 136         $info->{ballname} = $1;
 137         $info->{namme}    = $1;
 138         $info->{version}  = $3;
 139         {
 140                 my $separ = $2;
 141                 @{$info}{qw(pdir pnam)} = $separ
 142                   ? (split /$separ/, $info->{ballname}, 2)
 143                   : ($info->{ballname}, undef);
 144                 $info->{parts} =
 145                   [$separ ? (split /$separ/, $info->{ballname}) : ($info->{ballname})];
 146         }
 147         $info->{parts_joined} = join '::', @{ $info->{parts} };
 148         $info->{_tests}->{directory} = 1;
 149 }
 150
 151 sub test_archive_name {
 152         my (undef, $info) = @_;
 153         return $info->{_tests}->{archive_name}
 154           if defined $info->{_tests}->{archive_name};
 155         (my $d = shift) =~
 156           s/\.(?:(?:tar\.)?(?:gz|bz2|Z)|tar|tgz|zip|rar|arj|lha)$//;
 157         $info->{_tests}->{archive_name} = test_directory($d, @_);
 158 }
 159
 160 sub test_has_tests {
 161         my $info = shift;
 162         return $info->{_tests}->{has_tests}
 163           if defined $info->{_tests}->{has_tests};
 164         die "not a directory ($info->{dir})!" unless -d $info->{dir};
 165
 166         if (-d "$info->{dir}/t" || -f "$info->{dir}/test.pl") {
 167                 $info->{tests}++;
 168                 return $info->{_tests}->{has_tests} = 1;
 169         }
 170         $info->{_tests}->{has_tests} = 0;
 171 }
 172
 173 sub test_has_examples {
 174         my $info = shift;
 175         return $info->{_tests}->{has_examples}
 176           if defined $info->{_tests}->{has_examples};
 177         die "not a directory ($info->{dir})!" unless -d $info->{dir};
 178
 179         $info->{examples} =
 180           [grep -e,
 181                 map { $_, lc $_, uc $_ } qw(Example Examples Eg Sample Samples)];
 182         $info->{_tests}->{has_examples} = @{ $info->{examples} } ? 1 : 0;
 183 }
 184
 185 sub test_has_doc_files {
 186         my $info = shift;
 187         return $info->{_tests}->{has_doc_files}
 188           if defined $info->{_tests}->{has_doc_files};
 189         die "not a directory ($info->{dir})!" unless -d $info->{dir};
 190         my %tmp;
 191         $info->{doc_files} = [
 192                 grep -e,
 193                 grep !$tmp{$_}++,
 194                 map { $_, "$_.txt", "$_.TXT" }
 195                 map { $_, lc $_, uc $_ }
 196                   qw(AUTHORS BUGS ChangeLog Changes CREDITS doc docs documentation EXTRAS
 197                   GOALS HACKING HISTORY INSTALL NEW NEWS NOTES PATCHING README DISCLAIMER
 198                   ToDo)
 199         ];
 200         $info->{_tests}->{has_doc_files} = @{ $info->{doc_files} } ? 1 : 0;
 201 }
 202
 203 sub test_license {
 204         my $info = shift;
 205         return $info->{_tests}->{license}
 206           if defined $info->{_tests}->{license};
 207         if (load_META_yml($info) && $info->{META_yml}->{license}) {
 208                 $info->{license} =
 209                   $info->{META_yml}->{license} =~ /^l?gpl$/
 210                   ? uc $info->{META_yml}->{license}
 211                   : $info->{META_yml}->{license};
 212         # This depends on test_find_summ_descr2
 213         } elsif (my $license = $info->{pod_license}) {
 214                 $info->{license} = 'perl' if $license =~ /same terms as perl/i;
 215         }
 216         $info->{_tests}->{license} = $info->{license} ? 1 : 0;
 217 }
 218
 219 sub load_META_yml {
 220         my $info = shift;
 221         return $info->{_tests}->{license}
 222           if defined $info->{_tests}->{license};
 223         if (-f 'META.yml') {
 224                 $info->{META_yml} = LoadFile('META.yml');
 225         }
 226
 227         _remove_core_meta_requires($info, 'requires');
 228         _remove_core_meta_requires($info, 'build_requires');
 229
 230         $info->{_tests}->{license} = $info->{META_yml} ? 1 : 0;
 231 }
 232
 233 sub _remove_core_meta_requires {
 234         my ($info, $key) = @_;
 235
 236         return if ref($info->{META_yml}->{$key}) ne 'HASH';
 237
 238         # avoid perl(perl) >= 5.6... requires
 239         delete $info->{META_yml}->{$key}->{perl};
 240
 241         while (my ($module, $version) = each %{ $info->{META_yml}->{$key} }) {
 242                 my $result;
 243                 print "Checking dependency: $module $version\n" if $opts{verbose};
 244                 if ($version) {
 245                         $result = Module::CoreList->first_release($module, $version);
 246                 } else {
 247                         $result = Module::CoreList->first_release($module);
 248                 }
 249                 # $] - perl version
 250                 if ( $result and $result < $] ) {
 251                         if ($opts{verbose}) {
 252                                 print "Module $module availablie in core since $result, skipping\n"
 253                         }
 254                         delete $info->{META_yml}->{$key}->{$module};
 255                 }
 256         }
 257 }
 258
 259 sub test_find_pod_file {
 260         my $info = shift;
 261         return $info->{_tests}->{find_pod_file}
 262           if defined $info->{_tests}->{find_pod_file};
 263         die "not a directory ($info->{dir})!" unless -d $info->{dir};
 264
 265         my $pod_file;
 266
 267         my $mfile = @{ $info->{parts} }[-1];
 268         if (!defined $mfile) {
 269                 warn " .. unable to search for \$pod_file without parts\n";
 270                 return $info->{_tests}->{find_pod_file} = 0;
 271         }
 272
 273         my ($pm, $pod);
 274         for my $f ( grep !m#/t/#, File::Find::Rule->file->name( "$mfile.pod", "$mfile.pm", )->in( $info->{dir} ) ) {
 275                 $pod = $f if $f =~ /\.pod$/;
 276                 $pm  = $f if $f =~ /\.pm$/;
 277         }
 278         $pod_file = $pod ? $pod : $pm;
 279         if (   !$pod_file
 280                 && load_META_yml($info)
 281                 && exists $info->{META_yml}->{version_from})
 282         {
 283                 $pod_file = $info->{META_yml}->{version_from};
 284         }
 285
 286         unless ($pod_file) {
 287                 warn " -- no \$pod_file <@{$info->{parts}}>\n";
 288                 return $info->{_tests}->{find_pod_file} = 0;
 289         }
 290
 291         my $tree = new Pod::Tree;
 292         $tree->load_file($pod_file);
 293         unless ($tree->has_pod) {
 294                 warn " ,, no POD in $pod_file\n";
 295                 return $info->{_tests}->{find_pod_file} = 0;
 296         }
 297
 298         $info->{_podtree}                = $tree;
 299         $info->{pod_file}                = $pod_file;
 300         $info->{_tests}->{find_pod_file} = 1;
 301 }
 302
 303 # workaround for Pod::Parser not supporting "\r\n" line endings
 304 {
 305         no warnings 'redefine';
 306
 307         sub Pod::Parser::preprocess_line {
 308                 (my $text = $_[1]) =~ y/\r//d;
 309                 $text;
 310         }
 311 }
 312
 313 sub test_find_summ_descr2 {
 314         my $info = shift;
 315
 316         return $info->{_tests}->{find_summ_descr} = 0
 317           unless test_find_pod_file($info);
 318
 319         my $tree = $info->{_podtree};
 320         my $handler = _get_node_handler();
 321         $tree->walk( $handler );
 322         ($info->{summary}, $info->{descr}, $info->{pod_license}) = $handler->('data');
 323 }
 324
 325 # This subroutine return closure to be used as a node handler in Pod::Tree walk() method
 326 sub _get_node_handler {
 327         # state informaion
 328         my $next_is_summary;
 329         my $we_are_in_license;
 330         my $we_are_in_description;
 331         my $nodes_since_description_start;
 332         # data we will return
 333         my ($summary, $description, $license);
 334
 335         return sub {
 336                 my $node = shift;
 337
 338                 # If not called with a node, then return collected data
 339                 if (!ref $node) {
 340                         $summary =~ s/^ \s* (.*?) \s* $/$1/gxm;
 341                         return ($summary, $description, $license);
 342                 }
 343
 344                 # We want to dive into root node. Note that this is the only
 345                 # place we ever descend into tree
 346                 return 1 if $node->is_root;
 347
 348                 # If we have encountered any head command then abort collecting
 349                 # summary and description
 350                 my $command = $node->get_command;
 351                 if ($node->is_command and $command =~ /head/) {
 352                         if ($command eq 'head1' or $nodes_since_description_start > 3) {
 353                                 $we_are_in_description  = 0;
 354                         }
 355                         $next_is_summary = 0;
 356                         $we_are_in_license = 0;
 357                 }
 358
 359                 # If previous element started an summary section, then treat
 360                 # this one as summary text.
 361                 if ($next_is_summary) {
 362                         ($summary = $node->get_deep_text) =~ y/\r//d;
 363                         $summary =~ s/^\s+(.*?)\s+$/$1/;
 364                         $next_is_summary = 0;
 365                         return;
 366                 }
 367                 if ($we_are_in_license) {
 368                         ($license .= $node->get_text) =~ y/\r//d;
 369                         return;
 370                 }
 371
 372                 # If we started collecting description then add any ordinary
 373                 # node to collected description
 374                 if ($we_are_in_description) {
 375                         if ($nodes_since_description_start > 5) {
 376                                 $we_are_in_description = 0;
 377                         }
 378                         elsif ($node->is_ordinary or $node->is_verbatim) {
 379                                 ($description .= $node->get_deep_text) =~ y/\r//d;
 380                                 $nodes_since_description_start++;
 381                         }
 382                         else {
 383                                 return;
 384                         }
 385                 }
 386
 387                 # OK, next will be sumary text
 388                 if ($node->is_c_head1 and $node->get_text =~ /^\s*NAME\s*$/) {
 389                         $next_is_summary = 1;
 390                 }
 391                 # OK, description nodes will proceeed (until another head command)
 392                 if ($node->is_c_head1 and $node->get_text =~ /DESCRIPTION/) {
 393                         $we_are_in_description = 1;
 394                         $nodes_since_description_start = 1;
 395                 }
 396                 if ($node->is_c_head1 and $node->get_text =~ /LICENSE|COPYRIGHT/) {
 397                         $we_are_in_license = 1;
 398                 }
 399                 return;
 400         }
 401 }
 402
 403 sub test_find_summ_descr {
 404         my $info = shift;
 405         return $info->{_tests}->{find_summ_descr}
 406           if defined $info->{_tests}->{find_summ_descr};
 407         return $info->{_tests}->{find_summ_descr} = 0
 408           unless test_find_pod_file($info);
 409
 410         #       my $parser = new Pod::Select;
 411         #       $parser->parse_from_file($info->{pod_file});
 412         for my $sec ({ h => 'summary', s => 'NAME' },
 413                 { h => 'descr', s => 'DESCRIPTION' })
 414         {
 415                 my $H = new IO::String \$info->{ $sec->{h} };
 416                 podselect({ -output => $H, -sections => [$sec->{s}] },
 417                         $info->{pod_file});
 418                 $H->close;
 419                 $info->{ $sec->{h} } =~ s/^\s*=head.*//;
 420         }
 421
 422 =begin comment
 423
 424         my $tree = new Pod::Tree;
 425         $tree->load_file($info->{pod_file});
 426         unless ($tree->has_pod) {
 427                 warn " ,, no POD in $info->{pod_file}\n";
 428                 return $info->{_tests}->{find_summ_descr} = 0;
 429         }
 430
 431         my $root = $tree->get_root;
 432         $info->{$_} = '' for qw/summary descr/;
 433
 434         my $state;
 435         for my $n (@{ $root->get_children }) {
 436                 if ($n->is_c_head1) {
 437                         undef $state;
 438                         $state = 'summary'
 439                           if $n->get_text =~ /^\s*NAME\b/ && !$info->{summary};
 440                         $state = 'descr'
 441                           if $n->get_text =~ /^\s*DESCRIPTION\b/ && !$info->{descr};
 442                         next;
 443                 }
 444                 $info->{$state} .= $n->get_text if $state;
 445         }
 446
 447 =cut
 448
 449         $info->{summary} =~ y/\r\n\t /    /s;
 450         $info->{$_} =~ s/^\s+|\s+$//g for qw/summary descr/;
 451
 452         warn " ,, no summary in $info->{pod_file}\n"     unless $info->{summary};
 453         warn " ,, no description in $info->{pod_file}\n" unless $info->{descr};
 454
 455 =begin comment
 456
 457         my $file < io($info->{pod_file});
 458         $file =~ y/\r//d;
 459         if ($file =~ /(?:^|\n)=head\d\s+NAME[\t ]*\n\s*(.+)\n+(?:=|$)/) {
 460                 $info->{summary} = $1;
 461                 $info->{summary} =~ s/\s+$//g;
 462         }
 463         else {
 464                 warn " ,, no summary: $_\n";
 465                 $info->{summary} = '';
 466         }
 467         if ($file =~ /\n=head\d DESCRIPTION\s*\n\s*((?:(?<!=head).+\n){1,15})/) {
 468                 $info->{descr} = $1;
 469                 my $tmp;
 470                 run ['fmt'], \$info->{descr}, \$tmp;
 471                 $info->{descr} = $tmp if length $tmp;
 472                 $info->{descr} =~ s/\s+$//g;
 473         }
 474         else {
 475                 warn " ,, no description: $_\n";
 476                 $info->{descr} = '';
 477         }
 478
 479 =cut
 480
 481         $info->{_tests}->{find_summ_descr} =
 482           ($info->{summary} || $info->{descr}) ? 1 : 0;
 483 }
 484
 485 sub test_build_style {
 486         my $info = shift;
 487         return $info->{_tests}->{build_style}
 488           if defined $info->{_tests}->{build_style};
 489         $info->{uses_makemaker}    = -e 'Makefile.PL';
 490         $info->{uses_module_build} = -e 'Build.PL';
 491         $info->{uses_makemaker}    = 0
 492           if $opts{modulebuild} && $info->{uses_module_build};
 493         $info->{uses_module_build} = 0
 494           if $opts{makemaker} && $info->{uses_makemaker};
 495         $info->{_tests}->{build_style} =
 496           ($info->{uses_module_build} || $info->{uses_makemaker}) ? 1 : 0;
 497 }
 498
 499 sub gen_tarname_unexp {
 500         my $info = shift;
 501         return
 502           unless exists $info->{tarname} && test_directory($info->{dir}, $info);
 503         (my $tmp = $info->{tarname}) =~ s#.*/##;
 504         $info->{tarname_unexp} = unexpand_macros($info, $tmp);
 505 }
 506
 507 sub unexpand_macros {
 508         my $info  = shift;
 509         my $value = shift;
 510         $value =~ s/\Q$info->{pdir}\E/%{pdir}/;
 511         $value =~ s/\Q$info->{pnam}\E/%{pnam}/ if $info->{pnam};
 512         $value =~ s/\Q$info->{version}\E/%{version}/;
 513         $value;
 514 }
 515
 516 sub test_is_xs {
 517         my $info = shift;
 518         return $info->{_tests}->{is_xs}
 519           if defined $info->{_tests}->{is_xs};
 520
 521         # Ugly bitch.
 522         $info->{_tests}->{is_xs} = ( <*.c> || <*.xs> || <*/*.c> || <*/*.xs> || <*/*/*.c> || <*/*/*.xs> ) ? 1 : 0;
 523 }
 524
 525 sub run_configure {
 526         my $info = shift;
 527         test_build_style($info);
 528         return $info->{_tests}->{run_configure}
 529           if defined $info->{_tests}->{run_configure};
 530
 531         $info->{tmp_destdir} = getcwd() . "/pldcpan_destdir_$$";
 532         system(qw(rm -rf), $info->{tmp_destdir}) if -e $info->{tmp_destdir};
 533         my @cmd;
 534         if ($info->{_tests}->{build_style}) {
 535                 @cmd =
 536                   $info->{uses_makemaker}
 537                   ? qw(perl Makefile.PL INSTALLDIRS=vendor)
 538                   : (
 539                         qw(perl Build.PL installdirs=vendor config="optimize='%{rpmcflags}'"),
 540                         qw(destdir='$info->{tmp_destdir}')
 541                   );
 542         }
 543         else {
 544                 @cmd = (
 545                         qw(perl -MExtUtils::MakeMaker -wle),
 546                         qq#WriteMakefile(NAME=>"$info->{parts_joined}")#,
 547                         qw(INSTALLDIRS=>vendor)
 548                 );
 549         }
 550         $info->{_tests}->{run_configure} = run \@cmd, \undef, \my $out, \my $err,
 551           timeout(20);
 552 }
 553
 554 sub run_build {
 555         my $info = shift;
 556         return $info->{_tests}->{run_build} if defined $info->{_tests}->{run_build};
 557         return $info->{_tests}->{run_build} = 0 unless run_configure($info);
 558
 559         my @cmd;
 560         if ($info->{_tests}->{build_style}) {
 561                 @cmd =
 562                   $info->{uses_makemaker}
 563                   ? qw(make)
 564                   : qw(perl ./Build);
 565         }
 566         else {
 567                 @cmd = qw(make);
 568         }
 569         $info->{_tests}->{run_build} = run \@cmd, \undef, \my $out, \my $err,
 570           timeout(60);
 571 }
 572
 573 sub run_test {
 574         my $info = shift;
 575         return $info->{_tests}->{run_test} if defined $info->{_tests}->{run_test};
 576         return $info->{_tests}->{run_test} = 0 unless run_build($info);
 577
 578         my @cmd;
 579         if ($info->{_tests}->{build_style}) {
 580                 @cmd =
 581                   $info->{uses_makemaker}
 582                   ? qw(make test)
 583                   : qw(perl ./Build test);
 584         }
 585         else {
 586                 @cmd = qw(make test);
 587         }
 588         $info->{_tests}->{run_test} = run \@cmd, \undef, \my $out, \my $err,
 589           timeout(360);
 590 }
 591
 592 sub run_install {
 593         my $info = shift;
 594         return $info->{_tests}->{run_install}
 595           if defined $info->{_tests}->{run_install};
 596         return $info->{_tests}->{run_install} = 0 unless run_build($info);
 597
 598         my @cmd;
 599         if ($info->{_tests}->{build_style}) {
 600                 @cmd =
 601                   $info->{uses_makemaker}
 602                   ? (qw(make install), "DESTDIR='$info->{tmp_destdir}'")
 603                   : qw(perl ./Build install);
 604         }
 605         else {
 606                 @cmd = (qw(make install), "DESTDIR='$info->{tmp_destdir}'");
 607         }
 608         die "nfy";
 609 }
 610
 611 sub find_files {
 612         my $info = shift;
 613         return $info->{_tests}->{find_files}
 614           if defined $info->{_tests}->{find_files};
 615         return $info->{_tests}->{find_files} = 0 unless run_install($info);
 616         die "nfy";
 617 }
 618
 619 sub build_reqs_list {
 620         my $info = shift;
 621         my $rr   = $info->{META_yml}->{requires};
 622         my $br   = $info->{META_yml}->{build_requires};
 623         my %RR   = map format_r_or_br( $_, $rr->{$_} ), keys %$rr;
 624         my %BR   = map format_r_or_br( $_, $br->{$_} ), keys %$br;
 625         $info->{requires}       = \%RR;
 626         $info->{build_requires} = \%BR;
 627 }
 628
 629 sub format_r_or_br {
 630         my ( $package, $version ) = @_;
 631         my $rpmreq = "perl($package)";
 632         ( my $possible = "perl-$package" ) =~ s/::/-/g;
 633         if (   run( [ 'rpm', '-q', $possible ], \my ( undef, $out, $err ) )
 634                 or run( [ 'rpm', '-q', '--whatprovides', $possible ], \my ( undef, $out2, $err2 ) ) )
 635         {
 636                 return $possible => $version;    # we have this package or it is provided by something else
 637         }
 638         elsif ( run( [ 'rpm', '-q', '--qf', '%{NAME}\n', '--whatprovides', $rpmreq ], \my ( undef, $out3, $err3 ) ) ) {
 639                 my @providers = grep !/^perl-(?:base|modules|devel)$/, split /\s+/, $out3;    # might be more than one
 640                 return unless @providers;                                                     # core, ignore
 641                 return $providers[0] => $version if @providers == 1;
 642         }
 643         return $rpmreq => $version;                                                       # fallback
 644 }
 645
 646 for my $arg (@ARGV) {
 647         my $info = { _tests => {} };
 648
 649         if (-e $arg) {
 650                 ## local file; otherwise... hackish trash code :-]
 651                 ## TODO: %pdir / %pnam in %URL
 652         }
 653         elsif (my ($tarname) =
 654                 $arg =~ m# ^ (?:https?|ftp):// [^/]+/ (?:[^/]+/)* ([^/]+) $ #x)
 655         {
 656                 $info->{url} = $arg;
 657                 warn " -- fetching '$tarname'\n";
 658                 my $response = LWP::Simple::mirror($info->{url}, $tarname);
 659                 if (HTTP::Status::is_error($response)) {
 660                         warn " !! fetching '$tarname' failed: code $response. omiting.\n";
 661                         next;
 662                 }
 663                 $arg = $tarname;
 664         }
 665         elsif ($arg =~ /^[a-z\d_]+(?:(?:::|-)[a-z\d_]+)*$/i) {
 666                 (my $dist = $arg) =~ s/::/-/g;
 667                 warn " -- searching for '$dist' on search.cpan.org\n";
 668                 my $scpan = LWP::Simple::get("http://search.cpan.org/dist/$dist/");
 669                 if (   !defined $scpan
 670                         || $scpan =~ /cannot be found, did you mean one of these/
 671                         || $scpan !~ m#<a href="/CPAN/authors/id/([^"]+/([^/"]+))">Download</a>#)
 672                 {
 673                         warn " !! searching for '$dist' on search.cpan.org failed\n";
 674                         next;
 675                 }
 676                 $info->{url} = "http://www.cpan.org/modules/by-authors/id/$1";
 677                 my ($tarname) = $2;
 678                 warn " .. found $info->{url}\n";
 679                 my $response = LWP::Simple::mirror($info->{url}, $tarname);
 680                 if (HTTP::Status::is_error($response)) {
 681                         warn " !! fetching '$tarname' failed: code $response. omiting.\n";
 682                         next;
 683                 }
 684                 $arg = $tarname;
 685         }
 686         else {
 687                 warn " !! omiting '$arg': !-e or bad URL\n";
 688                 next;
 689         }
 690
 691         if (-d $arg) {
 692                 $info->{dir} = $arg =~ m#^/# ? $arg : getcwd() . "/$arg";
 693                 test_directory($arg, $info);
 694         }
 695         else {
 696                 open my $fh, $arg or die "can't open <$arg>: $!";
 697                 $info->{source0md5} = Digest::MD5->new->addfile($fh)->hexdigest;
 698                 close $fh or die "close <$arg>: $!";
 699
 700                 $info->{tarname} = $arg;
 701                 my $arch = Archive::Any->new($arg);
 702                 unless ($arch) {
 703                         warn " -- unpacking failed, omiting $arg";
 704                         next;
 705                 }
 706                 if ($arch->is_naughty) {
 707                         warn " !! Archive::Any says, that $arg is_naughty. omiting.\n";
 708                         next;
 709                 }
 710                 test_archive_name($arg, $info);
 711                 if ($info->{is_impolite} = $arch->is_impolite) {
 712                         if (!$info->{_tests}->{archive_name}) {
 713                                 warn
 714                                   "test_archive_name failed and $arg is_impolite; giving up\n";
 715                                 next;
 716                         }
 717                         $info->{dir} = getcwd() . "/$info->{ballname}-$info->{version}";
 718                         mkdir $info->{dir} or die "can't mkdir <$info->{dir}>, $arg!";
 719                         $arch->extract($info->{dir}) or die "Ni! $arg\n";
 720                 }
 721                 else {
 722                         ($arch->files)[0] =~ m#^(?:\.?/)?([^/]+)(?:/|$)#
 723                           or die "can't resolve dir from content of $arg";
 724                         $info->{dir} = getcwd() . "/$1";
 725                         $arch->extract or die "Nii! $arg\n";
 726                 }
 727         }
 728
 729         test_find_pod_file($info);
 730
 731         my $basedir = getcwd;
 732
 733         $info->{dir} =~ s{/*$}{};
 734         die " !! not a directory: $info->{dir}" unless -d $info->{dir};
 735         warn " .. processing $info->{dir}\n";
 736         chdir $info->{dir};
 737
 738 #       test_find_summ_descr($info);
 739         test_find_summ_descr2($info);
 740         test_license($info);
 741         test_is_xs($info);
 742         test_has_tests($info);
 743         test_has_examples($info);
 744         test_has_doc_files($info);
 745         test_build_style($info);
 746         gen_tarname_unexp($info);
 747         build_reqs_list($info);
 748
 749         $info->{dir} =~ s#.*/##;
 750         $info->{dir_unexp} = unexpand_macros($info, $info->{dir});
 751
 752         # try to fixup the URL
 753         if ($info->{url} && $info->{url} =~ m,/by-authors/id/, && $info->{pdir}) {
 754                 my $base_url = "http://www.cpan.org/modules/by-module/$info->{pdir}/";
 755                 if (LWP::Simple::head($base_url . $info->{tarname})) {
 756                         $info->{url} = $base_url . unexpand_macros($info, $info->{tarname});
 757                 }
 758         }
 759
 760         chdir $basedir;
 761
 762         # hack for TT
 763         $info = {
 764                 %$info,
 765                 map { ; "test_$_" => $info->{_tests}->{$_} }
 766                   keys %{ $info->{_tests} }
 767         };
 768
 769         pp($info) if $opts{verbose};
 770
 771         die " !! I find the idea of overwriting perl.spec disgusting."
 772           unless @{ $info->{parts} };
 773         my $spec = join('-', "$basedir/perl", @{ $info->{parts} }) . '.spec';
 774         warn " .. writing to '$spec'" . (-e $spec ? " ... which exists...\n" : "\n");
 775         die " !! I'm not to overwriting '$spec' without --force\n"
 776           if -e $spec && !$opts{force};
 777
 778         my $rotfl = tell DATA;
 779         my $tmpl  =
 780           Template->new(
 781                 { INTERPOLATE => 0, POST_CHOMP => 0, EVAL_PERL => 1, ABSOLUTE => 1 });
 782         $tmpl->process(\*DATA, $info, $spec)
 783           || warn "error parsing $info->{dir}: "
 784           . $tmpl->error->type . "\n"
 785           . $tmpl->error->info . "\n"
 786           . $tmpl->error . "\n";
 787         seek DATA, $rotfl, 0;
 788 }
 789
 790 # vim: ts=4 sw=4 noet noai nosi cin
 791 __DATA__
 792 #
 793 # Conditional build:
 794 %bcond_without  tests           # do not perform "make test"
 795 #
 796 %define         pdir    [% pdir %]
 797 [% IF pnam -%]
 798 %define         pnam    [% pnam %]
 799 [% END -%]
 800 %include        /usr/lib/rpm/macros.perl
 801 Summary:        [% summary.replace('[\r\n\t ]+', ' ') |trim %]
 802 #Summary(pl.UTF-8):
 803 Name:           perl-[% pdir %][% IF pnam %]-[% pnam %][% END %]
 804 Version:        [% version %]
 805 Release:        1
 806 [% IF test_license && license == 'perl' -%]
 807 # same as perl
 808 License:        GPL v1+ or Artistic
 809 [% ELSIF test_license -%]
 810 License:        [% license %]
 811 [% ELSE -%]
 812 # same as perl (REMOVE THIS LINE IF NOT TRUE)
 813 #License:       GPL v1+ or Artistic
 814 [% END -%]
 815 Group:          Development/Languages/Perl
 816 [% IF url -%]
 817 Source0:        [% url %]
 818 [% ELSIF tarname -%]
 819 Source0:        http://www.cpan.org/modules/by-module/[% pdir %]/[% tarname_unexp %]
 820 [% ELSIF pnam -%]
 821 Source0:        http://www.cpan.org/modules/by-module/[% pdir %]/%{pdir}-%{pnam}-%{version}.tar.gz
 822 [% ELSE -%]
 823 Source0:        http://www.cpan.org/modules/by-module/[% pdir %]/%{pdir}-%{version}.tar.gz
 824 [% END -%]
 825 [% IF source0md5 -%]
 826 # Source0-md5:  [% source0md5 %]
 827 [% END -%]
 828 # generic URL, check or change before uncommenting
 829 [% IF pnam -%]
 830 #URL:           http://search.cpan.org/dist/[% pdir %]-[% pnam %]/
 831 [% ELSE -%]
 832 #URL:           http://search.cpan.org/dist/[% pdir %]/
 833 [% END -%]
 834 [% IF uses_module_build -%]
 835 [% req = 'perl-Module-Build' -%]
 836 BuildRequires:  perl-Module-Build[% ' >= ' _ build_requires.$req IF build_requires.$req %]
 837 [% build_requires.delete('perl-Module-Build') -%]
 838 [% END -%]
 839 BuildRequires:  perl-devel >= 1:5.8.0
 840 BuildRequires:  rpm-perlprov >= 4.1-13
 841 [% IF test_has_tests -%]
 842 %if %{with tests}
 843 [% FOREACH req IN requires.keys.sort -%]
 844 BuildRequires:  [% req %][% ' >= ' _ requires.$req IF requires.$req %]
 845 [% END -%]
 846 [% FOREACH req IN build_requires.keys.sort -%]
 847 [% NEXT IF requires.exists(req) -%]
 848 BuildRequires:  [% req %][% ' >= ' _ build_requires.$req IF build_requires.$req %]
 849 [% END -%]
 850 %endif
 851 [% END -%]
 852 [% IF !test_is_xs -%]
 853 BuildArch:      noarch
 854 [% END -%]
 855 BuildRoot:      %{tmpdir}/%{name}-%{version}-root-%(id -u -n)
 856
 857 %description
 858 [% descr %]
 859
 860 # %description -l pl.UTF-8
 861 # TODO
 862
 863 %prep
 864 %setup -q -n [% dir_unexp %][% IF is_impolite %]-c[% END %]
 865
 866 %build
 867 [%- IF uses_module_build %]
 868 %{__perl} Build.PL \
 869 [%- IF test_is_xs %]
 870         config="optimize='%{rpmcflags}'" \
 871 [%- END %]
 872         destdir=$RPM_BUILD_ROOT \
 873         installdirs=vendor
 874 ./Build
 875
 876 %{?with_tests:./Build test}
 877 [%- ELSIF uses_makemaker %]
 878 %{__perl} Makefile.PL \
 879         INSTALLDIRS=vendor
 880 %{__make}[% IF test_is_xs -%] \
 881         CC="%{__cc}" \
 882         OPTIMIZE="%{rpmcflags}"[% END %]
 883
 884 %{?with_tests:%{__make} test}
 885 [%- ELSE %]
 886 %{__perl} -MExtUtils::MakeMaker -wle 'WriteMakefile(NAME=>"[% parts_joined %]")' \
 887         INSTALLDIRS=vendor
 888 %{__make}[% IF test_is_xs -%] \
 889         CC="%{__cc}" \
 890         OPTIMIZE="%{rpmcflags}"[% END %]
 891
 892 %{?with_tests:%{__make} test}
 893 [%- END %]
 894
 895 %install
 896 rm -rf $RPM_BUILD_ROOT
 897
 898 [% IF uses_module_build || !uses_makemaker -%]
 899 ./Build install
 900 [% ELSE -%]
 901 %{__make} pure_install \
 902         DESTDIR=$RPM_BUILD_ROOT
 903 [% END -%]
 904 [% IF test_has_examples -%]
 905
 906 install -d $RPM_BUILD_ROOT%{_examplesdir}/%{name}-%{version}
 907 [% FOREACH eg = examples -%]
 908 cp -a [% eg %] $RPM_BUILD_ROOT%{_examplesdir}/%{name}-%{version}
 909 [% END -%]
 910 [% END -%]
 911
 912 %clean
 913 rm -rf $RPM_BUILD_ROOT
 914
 915 %files
 916 %defattr(644,root,root,755)
 917 [% IF test_has_doc_files -%]
 918 %doc[% FOREACH doc = doc_files %] [% doc %][% END %]
 919 [% END -%]
 920 [% IF test_is_xs -%]
 921 %{perl_vendorarch}/[% pdir %]/*.pm
 922 %dir %{perl_vendorarch}/auto/[% pdir %]/[% pnam %]
 923 %{perl_vendorarch}/auto/[% pdir %]/[% pnam %]/*.bs
 924 %attr(755,root,root) %{perl_vendorarch}/auto/[% pdir %]/[% pnam %]/*.so
 925 [% ELSE -%]
 926 [%- number = parts.size - 1 -%]
 927 %{perl_vendorlib}/[% parts.first(number).join('/') %]/*.pm
 928 %{perl_vendorlib}/[% pdir %]/[% parts.last(number).join('/') %]
 929 [% END -%]
 930 %{_mandir}/man3/*
 931 [% IF test_has_examples -%]
 932 %{_examplesdir}/%{name}-%{version}
 933 [% END -%]