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