local-lib5/lib/perl5/PAR/Dist.pm

   1 package PAR::Dist;
   2 use 5.006;
   3 use strict;
   4 require Exporter;
   5 use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK $DEBUG/;
   6
   7 $VERSION    = '0.47'; # Change version in POD, too!
   8 @ISA        = 'Exporter';
   9 @EXPORT     = qw/
  10   blib_to_par
  11   install_par
  12   uninstall_par
  13   sign_par
  14   verify_par
  15   merge_par
  16   remove_man
  17   get_meta
  18   generate_blib_stub
  19 /;
  20
  21 @EXPORT_OK = qw/
  22   parse_dist_name
  23   contains_binaries
  24 /;
  25
  26 $DEBUG = 0;
  27
  28 use Carp qw/carp croak/;
  29 use File::Spec;
  30
  31 =head1 NAME
  32
  33 PAR::Dist - Create and manipulate PAR distributions
  34
  35 =head1 VERSION
  36
  37 This document describes version 0.47 of PAR::Dist, released November 29, 2009.
  38
  39 =head1 SYNOPSIS
  40
  41 As a shell command:
  42
  43     % perl -MPAR::Dist -eblib_to_par
  44
  45 In programs:
  46
  47     use PAR::Dist;
  48
  49     my $dist = blib_to_par();   # make a PAR file using ./blib/
  50     install_par($dist);         # install it into the system
  51     uninstall_par($dist);       # uninstall it from the system
  52     sign_par($dist);            # sign it using Module::Signature
  53     verify_par($dist);          # verify it using Module::Signature
  54
  55     install_par("http://foo.com/DBI-1.37-MSWin32-5.8.0.par"); # works too
  56     install_par("http://foo.com/DBI-1.37"); # auto-appends archname + perlver
  57     install_par("cpan://SMUELLER/PAR-Packer-0.975"); # uses CPAN author directory
  58
  59 =head1 DESCRIPTION
  60
  61 This module creates and manipulates I<PAR distributions>.  They are
  62 architecture-specific B<PAR> files, containing everything under F<blib/>
  63 of CPAN distributions after their C<make> or C<Build> stage, a
  64 F<META.yml> describing metadata of the original CPAN distribution,
  65 and a F<MANIFEST> detailing all files within it.  Digitally signed PAR
  66 distributions will also contain a F<SIGNATURE> file.
  67
  68 The naming convention for such distributions is:
  69
  70     $NAME-$VERSION-$ARCH-$PERL_VERSION.par
  71
  72 For example, C<PAR-Dist-0.01-i386-freebsd-5.8.0.par> corresponds to the
  73 0.01 release of C<PAR-Dist> on CPAN, built for perl 5.8.0 running on
  74 C<i386-freebsd>.
  75
  76 =head1 FUNCTIONS
  77
  78 Several functions are exported by default.  Unless otherwise noted,
  79 they can take either a hash of
  80 named arguments, a single argument (taken as C<$path> by C<blib_to_par>
  81 and C<$dist> by other functions), or no arguments (in which case
  82 the first PAR file in the current directory is used).
  83
  84 Therefore, under a directory containing only a single F<test.par>, all
  85 invocations below are equivalent:
  86
  87     % perl -MPAR::Dist -e"install_par( dist => 'test.par' )"
  88     % perl -MPAR::Dist -e"install_par( 'test.par' )"
  89     % perl -MPAR::Dist -einstall_par;
  90
  91 If C<$dist> resembles a URL, C<LWP::Simple::mirror> is called to mirror it
  92 locally under C<$ENV{PAR_TEMP}> (or C<$TEMP/par/> if unspecified), and the
  93 function will act on the fetched local file instead.  If the URL begins
  94 with C<cpan://AUTHOR/>, it will be expanded automatically to the author's CPAN
  95 directory (e.g. C<http://www.cpan.org/modules/by-authors/id/A/AU/AUTHOR/>).
  96
  97 If C<$dist> does not have a file extension beginning with a letter or
  98 underscore, a dash and C<$suffix> ($ARCH-$PERL_VERSION.par by default)
  99 will be appended to it.
 100
 101 =head2 blib_to_par
 102
 103 Takes key/value pairs as parameters or a single parameter indicating the
 104 path that contains the F<blib/> subdirectory.
 105
 106 Builds a PAR distribution from the F<blib/> subdirectory under C<path>, or
 107 under the current directory if unspecified.  If F<blib/> does not exist,
 108 it automatically runs F<Build>, F<make>, F<Build.PL> or F<Makefile.PL> to
 109 create it.
 110
 111 Returns the filename of the generated PAR distribution.
 112
 113 Valid parameters are:
 114
 115 =over 2
 116
 117 =item path
 118
 119 Sets the path which contains the F<blib/> subdirectory from which the PAR
 120 distribution will be generated.
 121
 122 =item name, version, suffix
 123
 124 These attributes set the name, version and platform specific suffix
 125 of the distribution. Name and version can be automatically
 126 determined from the distributions F<META.yml> or F<Makefile.PL> files.
 127
 128 The suffix is generated from your architecture name and your version of
 129 perl by default.
 130
 131 =item dist
 132
 133 The output filename for the PAR distribution.
 134
 135 =item quiet
 136
 137 Set to true to suppress as much output as possible.
 138
 139 =back
 140
 141 =cut
 142
 143 sub blib_to_par {
 144     @_ = (path => @_) if @_ == 1;
 145
 146     my %args = @_;
 147     require Config;
 148
 149
 150     # don't use 'my $foo ... if ...' it creates a static variable!
 151     my $quiet = $args{quiet} || 0;
 152     my $dist;
 153     my $path    = $args{path};
 154     $dist       = File::Spec->rel2abs($args{dist}) if $args{dist};
 155     my $name    = $args{name};
 156     my $version = $args{version};
 157     my $suffix  = $args{suffix} || "$Config::Config{archname}-$Config::Config{version}.par";
 158     my $cwd;
 159
 160     if (defined $path) {
 161         require Cwd;
 162         $cwd = Cwd::cwd();
 163         chdir $path;
 164     }
 165
 166     _build_blib() unless -d "blib";
 167
 168     my @files;
 169     open MANIFEST, ">", File::Spec->catfile("blib", "MANIFEST") or die $!;
 170     open META, ">", File::Spec->catfile("blib", "META.yml") or die $!;
 171
 172     require File::Find;
 173     File::Find::find( sub {
 174         next unless $File::Find::name;
 175         (-r && !-d) and push ( @files, substr($File::Find::name, 5) );
 176     } , 'blib' );
 177
 178     print MANIFEST join(
 179         "\n",
 180         '    <!-- accessible as jar:file:///NAME.par!/MANIFEST in compliant browsers -->',
 181         (sort @files),
 182         q(    # <html><body onload="var X=document.body.innerHTML.split(/\n/);var Y='<iframe src=&quot;META.yml&quot; style=&quot;float:right;height:40%;width:40%&quot;></iframe><ul>';for(var x in X){if(!X[x].match(/^\s*#/)&&X[x].length)Y+='<li><a href=&quot;'+X[x]+'&quot;>'+X[x]+'</a>'}document.body.innerHTML=Y">)
 183     );
 184     close MANIFEST;
 185
 186     if (open(OLD_META, "META.yml")) {
 187         while (<OLD_META>) {
 188             if (/^distribution_type:/) {
 189                 print META "distribution_type: par\n";
 190             }
 191             else {
 192                 print META $_;
 193             }
 194
 195             if (/^name:\s+(.*)/) {
 196                 $name ||= $1;
 197                 $name =~ s/::/-/g;
 198             }
 199             elsif (/^version:\s+.*Module::Build::Version/) {
 200                 while (<OLD_META>) {
 201                     /^\s+original:\s+(.*)/ or next;
 202                     $version ||= $1;
 203                     last;
 204                 }
 205             }
 206             elsif (/^version:\s+(.*)/) {
 207                 $version ||= $1;
 208             }
 209         }
 210         close OLD_META;
 211         close META;
 212     }
 213
 214     if ((!$name or !$version) and open(MAKEFILE, "Makefile")) {
 215         while (<MAKEFILE>) {
 216             if (/^DISTNAME\s+=\s+(.*)$/) {
 217                 $name ||= $1;
 218             }
 219             elsif (/^VERSION\s+=\s+(.*)$/) {
 220                 $version ||= $1;
 221             }
 222         }
 223     }
 224
 225     if (not defined($name) or not defined($version)) {
 226         # could not determine name or version. Error.
 227         my $what;
 228         if (not defined $name) {
 229             $what = 'name';
 230             $what .= ' and version' if not defined $version;
 231         }
 232         elsif (not defined $version) {
 233             $what = 'version';
 234         }
 235
 236         carp("I was unable to determine the $what of the PAR distribution. Please create a Makefile or META.yml file from which we can infer the information or just specify the missing information as an option to blib_to_par.");
 237         return();
 238     }
 239
 240     $name =~ s/\s+$//;
 241     $version =~ s/\s+$//;
 242
 243     my $file = "$name-$version-$suffix";
 244     unlink $file if -f $file;
 245
 246     print META << "YAML" if fileno(META);
 247 name: $name
 248 version: $version
 249 build_requires: {}
 250 conflicts: {}
 251 dist_name: $file
 252 distribution_type: par
 253 dynamic_config: 0
 254 generated_by: 'PAR::Dist version $PAR::Dist::VERSION'
 255 license: unknown
 256 YAML
 257     close META;
 258
 259     mkdir('blib', 0777);
 260     chdir('blib');
 261     require Cwd;
 262     my $zipoutfile = File::Spec->catfile(File::Spec->updir, $file);
 263     _zip(dist => $zipoutfile);
 264     chdir(File::Spec->updir);
 265
 266     unlink File::Spec->catfile("blib", "MANIFEST");
 267     unlink File::Spec->catfile("blib", "META.yml");
 268
 269     $dist ||= File::Spec->catfile($cwd, $file) if $cwd;
 270
 271     if ($dist and $file ne $dist) {
 272         if ( File::Copy::copy($file, $dist) ) {
 273           unlink $file;
 274         } else {
 275           die "Cannot copy $file: $!";
 276         }
 277
 278         $file = $dist;
 279     }
 280
 281     my $pathname = File::Spec->rel2abs($file);
 282     if ($^O eq 'MSWin32') {
 283         $pathname =~ s!\\!/!g;
 284         $pathname =~ s!:!|!g;
 285     };
 286     print << "." if !$quiet;
 287 Successfully created binary distribution '$file'.
 288 Its contents are accessible in compliant browsers as:
 289     jar:file://$pathname!/MANIFEST
 290 .
 291
 292     chdir $cwd if $cwd;
 293     return $file;
 294 }
 295
 296 sub _build_blib {
 297     if (-e 'Build') {
 298         _system_wrapper($^X, "Build");
 299     }
 300     elsif (-e 'Makefile') {
 301         _system_wrapper($Config::Config{make});
 302     }
 303     elsif (-e 'Build.PL') {
 304         _system_wrapper($^X, "Build.PL");
 305         _system_wrapper($^X, "Build");
 306     }
 307     elsif (-e 'Makefile.PL') {
 308         _system_wrapper($^X, "Makefile.PL");
 309         _system_wrapper($Config::Config{make});
 310     }
 311 }
 312
 313 =head2 install_par
 314
 315 Installs a PAR distribution into the system, using
 316 C<ExtUtils::Install::install_default>.
 317
 318 If only a single parameter is given, it is treated as the value for the
 319 C<dist> parameter.
 320
 321 Valid named parameters are:
 322
 323 =over 2
 324
 325 =item dist
 326
 327 The .par file to install. The heuristics outlined in the B<FUNCTIONS>
 328 section above apply.
 329
 330 =item prefix
 331
 332 This string will be prepended to all installation paths.
 333 If it isn't specified, the environment variable
 334 C<PERL_INSTALL_ROOT> is used as a prefix.
 335
 336 =item uninstall_shadows
 337
 338 This corresponds to the C<uninstall_shadows> option of L<ExtUtils::Install>. Quoting its manual:
 339 If C<uninstall_shadows> is set to true, any differing versions throughout C<@INC>
 340 will be uninstalled. This is C<make install UNINST=1>.
 341
 342 =item verbose
 343
 344 This corresponds to the C<verbose> option of L<ExtUtils::Install>. According to its manual:
 345 If C<verbose> is true, will print out each file removed. This is C<make install VERBINST=1>.
 346 C<verbose> values going up to 5 show increasingly more diagnostics output.
 347
 348 Default verbosity for PAR::Dist is 1.
 349
 350 =back
 351
 352 If you're just going to install into the running perl like everything else,
 353 you can stop reading the rest of this section now.
 354
 355 Additionally, you can use several parameters to change the default
 356 installation destinations. You don't usually have to worry about this
 357 unless you are installing into a user-local directory.
 358 The following section outlines the parameter names and default settings:
 359
 360   Parameter         From          To
 361   inst_lib          blib/lib      $Config{installsitelib} (*)
 362   inst_archlib      blib/arch     $Config{installsitearch}
 363   inst_script       blib/script   $Config{installscript}
 364   inst_bin          blib/bin      $Config{installbin}
 365   inst_man1dir      blib/man1     $Config{installman1dir}
 366   inst_man3dir      blib/man3     $Config{installman3dir}
 367   packlist_read                   $Config{sitearchexp}/auto/$name/.packlist
 368   packlist_write                  $Config{installsitearch}/auto/$name/.packlist
 369
 370 The C<packlist_write> parameter is used to control where the F<.packlist>
 371 file is written to. (Necessary for uninstallation.)
 372 The C<packlist_read> parameter specifies a .packlist file to merge in if
 373 it exists. By setting any of the above installation targets to C<undef>,
 374 you can remove that target altogether. For example, passing
 375 C<< inst_man1dir => undef, inst_man3dir => undef >> means that the contained
 376 manual pages won't be installed. This is not available for the packlists.
 377
 378 Again, the defaults will be the normal I<site> paths from C<%Config>.
 379
 380 (*) If the C<.par>'s I<inst_archlib> section (normally C<blib/arch>)
 381 isn't empty, the code in I<inst_lib> (normally C<blib/lib>) is also installed
 382 into the I<inst_archlib> path. This makes sense for XS modules.
 383 If, however, you override C<inst_lib>, this automatic conversion is
 384 also overridden! You can use the named parameter
 385 C<auto_inst_lib_conversion =E<gt> 1> to re-enable the conversion
 386 for custom I<inst_lib>'s.
 387
 388 Finally, you may specify a C<custom_targets> parameter. Its value should be
 389 a reference to a hash of custom installation targets such as
 390
 391   custom_targets => { 'blib/my_data' => '/some/path/my_data' }
 392
 393 You can use this to install the F<.par> archives contents to arbitrary
 394 locations.
 395
 396 =cut
 397
 398 sub install_par {
 399     my %args = &_args;
 400     _install_or_uninstall(%args, action => 'install');
 401 }
 402
 403 =head2 uninstall_par
 404
 405 Uninstalls all previously installed contents of a PAR distribution,
 406 using C<ExtUtils::Install::uninstall>.
 407
 408 Takes almost the same parameters as C<install_par>, but naturally,
 409 the installation target parameters do not apply. The only exception
 410 to this is the C<packlist_read> parameter which specifies the
 411 F<.packlist> file to read the list of installed files from.
 412 It defaults to C<$Config::Config{installsitearch}/auto/$name/.packlist>.
 413
 414 Additionally, the C<uninstall_shadows> parameter of C<install_par>
 415 isn't available.
 416
 417 =cut
 418
 419 sub uninstall_par {
 420     my %args = &_args;
 421     _install_or_uninstall(%args, action => 'uninstall');
 422 }
 423
 424 sub _install_or_uninstall {
 425     my %args = &_args;
 426     my $name = $args{name};
 427     my $action = $args{action};
 428
 429     my %ENV_copy = %ENV;
 430     $ENV{PERL_INSTALL_ROOT} = $args{prefix} if defined $args{prefix};
 431
 432     require Cwd;
 433     my $old_dir = Cwd::cwd();
 434
 435     my ($dist, $tmpdir) = _unzip_to_tmpdir( dist => $args{dist}, subdir => 'blib' );
 436
 437     if ( open (META, File::Spec->catfile('blib', 'META.yml')) ) {
 438         while (<META>) {
 439             next unless /^name:\s+(.*)/;
 440             $name = $1;
 441             $name =~ s/\s+$//;
 442             last;
 443         }
 444         close META;
 445     }
 446     return if not defined $name or $name eq '';
 447
 448     if (-d 'script') {
 449         require ExtUtils::MY;
 450         foreach my $file (glob("script/*")) {
 451             next unless -T $file;
 452             ExtUtils::MY->fixin($file);
 453             chmod(0555, $file);
 454         }
 455     }
 456
 457     $name =~ s{::|-}{/}g;
 458     require ExtUtils::Install;
 459
 460     if ($action eq 'install') {
 461         my $target = _installation_target( File::Spec->curdir, $name, \%args );
 462         my $custom_targets = $args{custom_targets} || {};
 463         $target->{$_} = $custom_targets->{$_} foreach keys %{$custom_targets};
 464
 465         my $uninstall_shadows = $args{uninstall_shadows};
 466         my $verbose = $args{verbose};
 467         ExtUtils::Install::install($target, $verbose, 0, $uninstall_shadows);
 468     }
 469     elsif ($action eq 'uninstall') {
 470         require Config;
 471         my $verbose = $args{verbose};
 472         ExtUtils::Install::uninstall(
 473             $args{packlist_read}||"$Config::Config{installsitearch}/auto/$name/.packlist",
 474             $verbose
 475         );
 476     }
 477
 478     %ENV = %ENV_copy;
 479
 480     chdir($old_dir);
 481     File::Path::rmtree([$tmpdir]);
 482
 483     return 1;
 484 }
 485
 486 # Returns the default installation target as used by
 487 # ExtUtils::Install::install(). First parameter should be the base
 488 # directory containing the blib/ we're installing from.
 489 # Second parameter should be the name of the distribution for the packlist
 490 # paths. Third parameter may be a hash reference with user defined keys for
 491 # the target hash. In fact, any contents that do not start with 'inst_' are
 492 # skipped.
 493 sub _installation_target {
 494     require Config;
 495     my $dir = shift;
 496     my $name = shift;
 497     my $user = shift || {};
 498
 499     # accepted sources (and user overrides)
 500     my %sources = (
 501       inst_lib => File::Spec->catdir($dir,"blib","lib"),
 502       inst_archlib => File::Spec->catdir($dir,"blib","arch"),
 503       inst_bin => File::Spec->catdir($dir,'blib','bin'),
 504       inst_script => File::Spec->catdir($dir,'blib','script'),
 505       inst_man1dir => File::Spec->catdir($dir,'blib','man1'),
 506       inst_man3dir => File::Spec->catdir($dir,'blib','man3'),
 507       packlist_read => 'read',
 508       packlist_write => 'write',
 509     );
 510
 511
 512     my $par_has_archlib = _directory_not_empty( $sources{inst_archlib} );
 513
 514     # default targets
 515     my $target = {
 516        read => $Config::Config{sitearchexp}."/auto/$name/.packlist",
 517        write => $Config::Config{installsitearch}."/auto/$name/.packlist",
 518        $sources{inst_lib} =>
 519             ($par_has_archlib
 520              ? $Config::Config{installsitearch}
 521              : $Config::Config{installsitelib}),
 522        $sources{inst_archlib}   => $Config::Config{installsitearch},
 523        $sources{inst_bin}       => $Config::Config{installbin} ,
 524        $sources{inst_script}    => $Config::Config{installscript},
 525        $sources{inst_man1dir}   => $Config::Config{installman1dir},
 526        $sources{inst_man3dir}   => $Config::Config{installman3dir},
 527     };
 528
 529     # Included for future support for ${flavour}perl external lib installation
 530 #    if ($Config::Config{flavour_perl}) {
 531 #        my $ext = File::Spec->catdir($dir, 'blib', 'ext');
 532 #        # from => to
 533 #        $sources{inst_external_lib}    = File::Spec->catdir($ext, 'lib');
 534 #        $sources{inst_external_bin}    = File::Spec->catdir($ext, 'bin');
 535 #        $sources{inst_external_include} = File::Spec->catdir($ext, 'include');
 536 #        $sources{inst_external_src}    = File::Spec->catdir($ext, 'src');
 537 #        $target->{ $sources{inst_external_lib} }     = $Config::Config{flavour_install_lib};
 538 #        $target->{ $sources{inst_external_bin} }     = $Config::Config{flavour_install_bin};
 539 #        $target->{ $sources{inst_external_include} } = $Config::Config{flavour_install_include};
 540 #        $target->{ $sources{inst_external_src} }     = $Config::Config{flavour_install_src};
 541 #    }
 542
 543     # insert user overrides
 544     foreach my $key (keys %$user) {
 545         my $value = $user->{$key};
 546         if (not defined $value and $key ne 'packlist_read' and $key ne 'packlist_write') {
 547           # undef means "remove"
 548           delete $target->{ $sources{$key} };
 549         }
 550         elsif (exists $sources{$key}) {
 551           # overwrite stuff, don't let the user create new entries
 552           $target->{ $sources{$key} } = $value;
 553         }
 554     }
 555
 556     # apply the automatic inst_lib => inst_archlib conversion again
 557     # if the user asks for it and there is an archlib in the .par
 558     if ($user->{auto_inst_lib_conversion} and $par_has_archlib) {
 559       $target->{inst_lib} = $target->{inst_archlib};
 560     }
 561
 562     return $target;
 563 }
 564
 565 sub _directory_not_empty {
 566     require File::Find;
 567     my($dir) = @_;
 568     my $files = 0;
 569     File::Find::find(sub {
 570             return if $_ eq ".exists";
 571         if (-f) {
 572             $File::Find::prune++;
 573             $files = 1;
 574             }
 575     }, $dir);
 576     return $files;
 577 }
 578
 579 =head2 sign_par
 580
 581 Digitally sign a PAR distribution using C<gpg> or B<Crypt::OpenPGP>,
 582 via B<Module::Signature>.
 583
 584 =cut
 585
 586 sub sign_par {
 587     my %args = &_args;
 588     _verify_or_sign(%args, action => 'sign');
 589 }
 590
 591 =head2 verify_par
 592
 593 Verify the digital signature of a PAR distribution using C<gpg> or
 594 B<Crypt::OpenPGP>, via B<Module::Signature>.
 595
 596 Returns a boolean value indicating whether verification passed; C<$!>
 597 is set to the return code of C<Module::Signature::verify>.
 598
 599 =cut
 600
 601 sub verify_par {
 602     my %args = &_args;
 603     $! = _verify_or_sign(%args, action => 'verify');
 604     return ( $! == Module::Signature::SIGNATURE_OK() );
 605 }
 606
 607 =head2 merge_par
 608
 609 I<Note:> Since version 0.32 of PAR::Dist, this function requires a YAML
 610 reader. The order of precedence is:
 611
 612   YAML YAML::Syck YAML::Tiny YAML::XS
 613
 614 Merges two or more PAR distributions into one. First argument must
 615 be the name of the distribution you want to merge all others into.
 616 Any following arguments will be interpreted as the file names of
 617 further PAR distributions to merge into the first one.
 618
 619   merge_par('foo.par', 'bar.par', 'baz.par')
 620
 621 This will merge the distributions C<foo.par>, C<bar.par> and C<baz.par>
 622 into the distribution C<foo.par>. C<foo.par> will be overwritten!
 623
 624 The original META.yml of C<foo.par> is retained, but augmented with any
 625 C<provides>, C<requires>, C<recommends>, C<build_requires>, and
 626 C<configure_requires> sections from the other C<.par> files.
 627
 628 =cut
 629
 630 sub merge_par {
 631     my $base_par = shift;
 632     my @additional_pars = @_;
 633     require Cwd;
 634     require File::Copy;
 635     require File::Path;
 636     require File::Find;
 637
 638     # parameter checking
 639     if (not defined $base_par) {
 640         croak "First argument to merge_par() must be the .par archive to modify.";
 641     }
 642
 643     if (not -f $base_par or not -r _ or not -w _) {
 644         croak "'$base_par' is not a file or you do not have enough permissions to read and modify it.";
 645     }
 646
 647     foreach (@additional_pars) {
 648         if (not -f $_ or not -r _) {
 649             croak "'$_' is not a file or you do not have enough permissions to read it.";
 650         }
 651     }
 652
 653     # The unzipping will change directories. Remember old dir.
 654     my $old_cwd = Cwd::cwd();
 655
 656     # Unzip the base par to a temp. dir.
 657     (undef, my $base_dir) = _unzip_to_tmpdir(
 658         dist => $base_par, subdir => 'blib'
 659     );
 660     my $blibdir = File::Spec->catdir($base_dir, 'blib');
 661
 662     # move the META.yml to the (main) temp. dir.
 663     my $main_meta_file = File::Spec->catfile($base_dir, 'META.yml');
 664     File::Copy::move(
 665         File::Spec->catfile($blibdir, 'META.yml'),
 666         $main_meta_file
 667     );
 668     # delete (incorrect) MANIFEST
 669     unlink File::Spec->catfile($blibdir, 'MANIFEST');
 670
 671     # extract additional pars and merge
 672     foreach my $par (@additional_pars) {
 673         # restore original directory because the par path
 674         # might have been relative!
 675         chdir($old_cwd);
 676         (undef, my $add_dir) = _unzip_to_tmpdir(
 677             dist => $par
 678         );
 679
 680         # merge the meta (at least the provides info) into the main meta.yml
 681         my $meta_file = File::Spec->catfile($add_dir, 'META.yml');
 682         if (-f $meta_file) {
 683           _merge_meta($main_meta_file, $meta_file);
 684         }
 685
 686         my @files;
 687         my @dirs;
 688         # I hate File::Find
 689         # And I hate writing portable code, too.
 690         File::Find::find(
 691             {wanted =>sub {
 692                 my $file = $File::Find::name;
 693                 push @files, $file if -f $file;
 694                 push @dirs, $file if -d _;
 695             }},
 696             $add_dir
 697         );
 698         my ($vol, $subdir, undef) = File::Spec->splitpath( $add_dir, 1);
 699         my @dir = File::Spec->splitdir( $subdir );
 700
 701         # merge directory structure
 702         foreach my $dir (@dirs) {
 703             my ($v, $d, undef) = File::Spec->splitpath( $dir, 1 );
 704             my @d = File::Spec->splitdir( $d );
 705             shift @d foreach @dir; # remove tmp dir from path
 706             my $target = File::Spec->catdir( $blibdir, @d );
 707             mkdir($target);
 708         }
 709
 710         # merge files
 711         foreach my $file (@files) {
 712             my ($v, $d, $f) = File::Spec->splitpath( $file );
 713             my @d = File::Spec->splitdir( $d );
 714             shift @d foreach @dir; # remove tmp dir from path
 715             my $target = File::Spec->catfile(
 716                 File::Spec->catdir( $blibdir, @d ),
 717                 $f
 718             );
 719             File::Copy::copy($file, $target)
 720               or die "Could not copy '$file' to '$target': $!";
 721
 722         }
 723         chdir($old_cwd);
 724         File::Path::rmtree([$add_dir]);
 725     }
 726
 727     # delete (copied) MANIFEST and META.yml
 728     unlink File::Spec->catfile($blibdir, 'MANIFEST');
 729     unlink File::Spec->catfile($blibdir, 'META.yml');
 730
 731     chdir($base_dir);
 732     my $resulting_par_file = Cwd::abs_path(blib_to_par(quiet => 1));
 733     chdir($old_cwd);
 734     File::Copy::move($resulting_par_file, $base_par);
 735
 736     File::Path::rmtree([$base_dir]);
 737 }
 738
 739
 740 sub _merge_meta {
 741   my $meta_orig_file = shift;
 742   my $meta_extra_file = shift;
 743   return() if not defined $meta_orig_file or not -f $meta_orig_file;
 744   return 1 if not defined $meta_extra_file or not -f $meta_extra_file;
 745
 746   my $yaml_functions = _get_yaml_functions();
 747
 748   die "Cannot merge META.yml files without a YAML reader/writer"
 749     if !exists $yaml_functions->{LoadFile}
 750     or !exists $yaml_functions->{DumpFile};
 751
 752   my $orig_meta  = $yaml_functions->{LoadFile}->($meta_orig_file);
 753   my $extra_meta = $yaml_functions->{LoadFile}->($meta_extra_file);
 754
 755   # I seem to remember there was this incompatibility between the different
 756   # YAML implementations with regards to "document" handling:
 757   my $orig_tree  = (ref($orig_meta) eq 'ARRAY' ? $orig_meta->[0] : $orig_meta);
 758   my $extra_tree = (ref($extra_meta) eq 'ARRAY' ? $extra_meta->[0] : $extra_meta);
 759
 760   _merge_provides($orig_tree, $extra_tree);
 761   _merge_requires($orig_tree, $extra_tree);
 762
 763   $yaml_functions->{DumpFile}->($meta_orig_file, $orig_meta);
 764
 765   return 1;
 766 }
 767
 768 # merge the two-level provides sections of META.yml
 769 sub _merge_provides {
 770   my $orig_hash  = shift;
 771   my $extra_hash = shift;
 772
 773   return() if not exists $extra_hash->{provides};
 774   $orig_hash->{provides} ||= {};
 775
 776   my $orig_provides  = $orig_hash->{provides};
 777   my $extra_provides = $extra_hash->{provides};
 778
 779   # two level clone is enough wrt META spec 1.4
 780   # overwrite the original provides since we're also overwriting the files.
 781   foreach my $module (keys %$extra_provides) {
 782     my $extra_mod_hash = $extra_provides->{$module};
 783     my %mod_hash;
 784     $mod_hash{$_} = $extra_mod_hash->{$_} for keys %$extra_mod_hash;
 785     $orig_provides->{$module} = \%mod_hash;
 786   }
 787 }
 788
 789 # merge the single-level requires-like sections of META.yml
 790 sub _merge_requires {
 791   my $orig_hash  = shift;
 792   my $extra_hash = shift;
 793
 794   foreach my $type (qw(requires build_requires configure_requires recommends)) {
 795     next if not exists $extra_hash->{$type};
 796     $orig_hash->{$type} ||= {};
 797
 798     # one level clone is enough wrt META spec 1.4
 799     foreach my $module (keys %{ $extra_hash->{$type} }) {
 800       # FIXME there should be a version comparison here, BUT how are we going to do that without a guaranteed version.pm?
 801       $orig_hash->{$type}{$module} = $extra_hash->{$type}{$module}; # assign version and module name
 802     }
 803   }
 804 }
 805
 806 =head2 remove_man
 807
 808 Remove the man pages from a PAR distribution. Takes one named
 809 parameter: I<dist> which should be the name (and path) of the
 810 PAR distribution file. The calling conventions outlined in
 811 the C<FUNCTIONS> section above apply.
 812
 813 The PAR archive will be
 814 extracted, stripped of all C<man\d?> and C<html> subdirectories
 815 and then repackaged into the original file.
 816
 817 =cut
 818
 819 sub remove_man {
 820     my %args = &_args;
 821     my $par = $args{dist};
 822     require Cwd;
 823     require File::Copy;
 824     require File::Path;
 825     require File::Find;
 826
 827     # parameter checking
 828     if (not defined $par) {
 829         croak "First argument to remove_man() must be the .par archive to modify.";
 830     }
 831
 832     if (not -f $par or not -r _ or not -w _) {
 833         croak "'$par' is not a file or you do not have enough permissions to read and modify it.";
 834     }
 835
 836     # The unzipping will change directories. Remember old dir.
 837     my $old_cwd = Cwd::cwd();
 838
 839     # Unzip the base par to a temp. dir.
 840     (undef, my $base_dir) = _unzip_to_tmpdir(
 841         dist => $par, subdir => 'blib'
 842     );
 843     my $blibdir = File::Spec->catdir($base_dir, 'blib');
 844
 845     # move the META.yml to the (main) temp. dir.
 846     File::Copy::move(
 847         File::Spec->catfile($blibdir, 'META.yml'),
 848         File::Spec->catfile($base_dir, 'META.yml')
 849     );
 850     # delete (incorrect) MANIFEST
 851     unlink File::Spec->catfile($blibdir, 'MANIFEST');
 852
 853     opendir DIRECTORY, 'blib' or die $!;
 854     my @dirs = grep { /^blib\/(?:man\d*|html)$/ }
 855                grep { -d $_ }
 856                map  { File::Spec->catfile('blib', $_) }
 857                readdir DIRECTORY;
 858     close DIRECTORY;
 859
 860     File::Path::rmtree(\@dirs);
 861
 862     chdir($base_dir);
 863     my $resulting_par_file = Cwd::abs_path(blib_to_par());
 864     chdir($old_cwd);
 865     File::Copy::move($resulting_par_file, $par);
 866
 867     File::Path::rmtree([$base_dir]);
 868 }
 869
 870
 871 =head2 get_meta
 872
 873 Opens a PAR archive and extracts the contained META.yml file.
 874 Returns the META.yml file as a string.
 875
 876 Takes one named parameter: I<dist>. If only one parameter is
 877 passed, it is treated as the I<dist> parameter. (Have a look
 878 at the description in the C<FUNCTIONS> section above.)
 879
 880 Returns undef if no PAR archive or no META.yml within the
 881 archive were found.
 882
 883 =cut
 884
 885 sub get_meta {
 886     my %args = &_args;
 887     my $dist = $args{dist};
 888     return undef if not defined $dist or not -r $dist;
 889     require Cwd;
 890     require File::Path;
 891
 892     # The unzipping will change directories. Remember old dir.
 893     my $old_cwd = Cwd::cwd();
 894
 895     # Unzip the base par to a temp. dir.
 896     (undef, my $base_dir) = _unzip_to_tmpdir(
 897         dist => $dist, subdir => 'blib'
 898     );
 899     my $blibdir = File::Spec->catdir($base_dir, 'blib');
 900
 901     my $meta = File::Spec->catfile($blibdir, 'META.yml');
 902
 903     if (not -r $meta) {
 904         return undef;
 905     }
 906
 907     open FH, '<', $meta
 908       or die "Could not open file '$meta' for reading: $!";
 909
 910     local $/ = undef;
 911     my $meta_text = <FH>;
 912     close FH;
 913
 914     chdir($old_cwd);
 915
 916     File::Path::rmtree([$base_dir]);
 917
 918     return $meta_text;
 919 }
 920
 921
 922
 923 sub _unzip {
 924     my %args = &_args;
 925     my $dist = $args{dist};
 926     my $path = $args{path} || File::Spec->curdir;
 927     return unless -f $dist;
 928
 929     # Try fast unzipping first
 930     if (eval { require Archive::Unzip::Burst; 1 }) {
 931         my $return = !Archive::Unzip::Burst::unzip($dist, $path);
 932         return if $return; # true return value == error (a la system call)
 933     }
 934     # Then slow unzipping
 935     if (eval { require Archive::Zip; 1 }) {
 936         my $zip = Archive::Zip->new;
 937         local %SIG;
 938         $SIG{__WARN__} = sub { print STDERR $_[0] unless $_[0] =~ /\bstat\b/ };
 939         return unless $zip->read($dist) == Archive::Zip::AZ_OK()
 940                   and $zip->extractTree('', "$path/") == Archive::Zip::AZ_OK();
 941     }
 942     # Then fall back to the system
 943     else {
 944         undef $!;
 945         if (_system_wrapper(unzip => $dist, '-d', $path)) {
 946             die "Failed to unzip '$dist' to path '$path': Could neither load "
 947                 . "Archive::Zip nor (successfully) run the system 'unzip' (unzip said: $!)";
 948         }
 949     }
 950
 951     return 1;
 952 }
 953
 954 sub _zip {
 955     my %args = &_args;
 956     my $dist = $args{dist};
 957
 958     if (eval { require Archive::Zip; 1 }) {
 959         my $zip = Archive::Zip->new;
 960         $zip->addTree( File::Spec->curdir, '' );
 961         $zip->writeToFileNamed( $dist ) == Archive::Zip::AZ_OK() or die $!;
 962     }
 963     else {
 964         undef $!;
 965         if (_system_wrapper(qw(zip -r), $dist, File::Spec->curdir)) {
 966             die "Failed to zip '" .File::Spec->curdir(). "' to '$dist': Could neither load "
 967                 . "Archive::Zip nor (successfully) run the system 'zip' (zip said: $!)";
 968         }
 969     }
 970     return 1;
 971 }
 972
 973
 974 # This sub munges the arguments to most of the PAR::Dist functions
 975 # into a hash. On the way, it downloads PAR archives as necessary, etc.
 976 sub _args {
 977     # default to the first .par in the CWD
 978     if (not @_) {
 979         @_ = (glob('*.par'))[0];
 980     }
 981
 982     # single argument => it's a distribution file name or URL
 983     @_ = (dist => @_) if @_ == 1;
 984
 985     my %args = @_;
 986     $args{name} ||= $args{dist};
 987
 988     # If we are installing from an URL, we want to munge the
 989     # distribution name so that it is in form "Module-Name"
 990     if (defined $args{name}) {
 991         $args{name} =~ s/^\w+:\/\///;
 992         my @elems = parse_dist_name($args{name});
 993         # @elems is name, version, arch, perlversion
 994         if (defined $elems[0]) {
 995             $args{name} = $elems[0];
 996         }
 997         else {
 998             $args{name} =~ s/^.*\/([^\/]+)$/$1/;
 999             $args{name} =~ s/^([0-9A-Za-z_-]+)-\d+\..+$/$1/;
1000         }
1001     }
1002
1003     # append suffix if there is none
1004     if ($args{dist} and not $args{dist} =~ /\.[a-zA-Z_][^.]*$/) {
1005         require Config;
1006         my $suffix = $args{suffix};
1007         $suffix ||= "$Config::Config{archname}-$Config::Config{version}.par";
1008         $args{dist} .= "-$suffix";
1009     }
1010
1011     # download if it's an URL
1012     if ($args{dist} and $args{dist} =~ m!^\w+://!) {
1013         $args{dist} = _fetch(dist => $args{dist})
1014     }
1015
1016     return %args;
1017 }
1018
1019
1020 # Download PAR archive, but only if necessary (mirror!)
1021 my %escapes;
1022 sub _fetch {
1023     my %args = @_;
1024
1025     if ($args{dist} =~ s/^file:\/\///) {
1026       return $args{dist} if -e $args{dist};
1027       return;
1028     }
1029     require LWP::Simple;
1030
1031     $ENV{PAR_TEMP} ||= File::Spec->catdir(File::Spec->tmpdir, 'par');
1032     mkdir $ENV{PAR_TEMP}, 0777;
1033     %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255 unless %escapes;
1034
1035     $args{dist} =~ s{^cpan://((([a-zA-Z])[a-zA-Z])[-_a-zA-Z]+)/}
1036                     {http://www.cpan.org/modules/by-authors/id/\U$3/$2/$1\E/};
1037
1038     my $file = $args{dist};
1039     $file =~ s/([^\w\.])/$escapes{$1}/g;
1040     $file = File::Spec->catfile( $ENV{PAR_TEMP}, $file);
1041     my $rc = LWP::Simple::mirror( $args{dist}, $file );
1042
1043     if (!LWP::Simple::is_success($rc) and $rc != 304) {
1044         die "Error $rc: ", LWP::Simple::status_message($rc), " ($args{dist})\n";
1045     }
1046
1047     return $file if -e $file;
1048     return;
1049 }
1050
1051 sub _verify_or_sign {
1052     my %args = &_args;
1053
1054     require File::Path;
1055     require Module::Signature;
1056     die "Module::Signature version 0.25 required"
1057       unless Module::Signature->VERSION >= 0.25;
1058
1059     require Cwd;
1060     my $cwd = Cwd::cwd();
1061     my $action = $args{action};
1062     my ($dist, $tmpdir) = _unzip_to_tmpdir($args{dist});
1063     $action ||= (-e 'SIGNATURE' ? 'verify' : 'sign');
1064
1065     if ($action eq 'sign') {
1066         open FH, '>SIGNATURE' unless -e 'SIGNATURE';
1067         open FH, 'MANIFEST' or die $!;
1068
1069         local $/;
1070         my $out = <FH>;
1071         if ($out !~ /^SIGNATURE(?:\s|$)/m) {
1072             $out =~ s/^(?!\s)/SIGNATURE\n/m;
1073             open FH, '>MANIFEST' or die $!;
1074             print FH $out;
1075         }
1076         close FH;
1077
1078         $args{overwrite} = 1 unless exists $args{overwrite};
1079         $args{skip}      = 0 unless exists $args{skip};
1080     }
1081
1082     my $rv = Module::Signature->can($action)->(%args);
1083     _zip(dist => $dist) if $action eq 'sign';
1084     File::Path::rmtree([$tmpdir]);
1085
1086     chdir($cwd);
1087     return $rv;
1088 }
1089
1090 sub _unzip_to_tmpdir {
1091     my %args = &_args;
1092
1093     require File::Temp;
1094
1095     my $dist   = File::Spec->rel2abs($args{dist});
1096     my $tmpdirname = File::Spec->catdir(File::Spec->tmpdir, "parXXXXX");
1097     my $tmpdir = File::Temp::mkdtemp($tmpdirname)
1098       or die "Could not create temporary directory from template '$tmpdirname': $!";
1099     my $path = $tmpdir;
1100     $path = File::Spec->catdir($tmpdir, $args{subdir}) if defined $args{subdir};
1101     _unzip(dist => $dist, path => $path);
1102
1103     chdir $tmpdir;
1104     return ($dist, $tmpdir);
1105 }
1106
1107
1108
1109 =head2 parse_dist_name
1110
1111 First argument must be a distribution file name. The file name
1112 is parsed into I<distribution name>, I<distribution version>,
1113 I<architecture name>, and I<perl version>.
1114
1115 Returns the results as a list in the above order.
1116 If any or all of the above cannot be determined, returns undef instead
1117 of the undetermined elements.
1118
1119 Supported formats are:
1120
1121 Math-Symbolic-0.502-x86_64-linux-gnu-thread-multi-5.8.7
1122
1123 Math-Symbolic-0.502
1124
1125 The ".tar.gz" or ".par" extensions as well as any
1126 preceding paths are stripped before parsing. Starting with C<PAR::Dist>
1127 0.22, versions containing a preceding C<v> are parsed correctly.
1128
1129 This function is not exported by default.
1130
1131 =cut
1132
1133 sub parse_dist_name {
1134         my $file = shift;
1135         return(undef, undef, undef, undef) if not defined $file;
1136
1137         (undef, undef, $file) = File::Spec->splitpath($file);
1138
1139         my $version = qr/v?(?:\d+(?:_\d+)?|\d*(?:\.\d+(?:_\d+)?)+)/;
1140         $file =~ s/\.(?:par|tar\.gz|tar)$//i;
1141         my @elem = split /-/, $file;
1142         my (@dn, $dv, @arch, $pv);
1143         while (@elem) {
1144                 my $e = shift @elem;
1145                 if (
1146             $e =~ /^$version$/o
1147             and not(# if not next token also a version
1148                     # (assumes an arch string doesnt start with a version...)
1149                 @elem and $elem[0] =~ /^$version$/o
1150             )
1151         ) {
1152
1153                         $dv = $e;
1154                         last;
1155                 }
1156                 push @dn, $e;
1157         }
1158
1159         my $dn;
1160         $dn = join('-', @dn) if @dn;
1161
1162         if (not @elem) {
1163                 return( $dn, $dv, undef, undef);
1164         }
1165
1166         while (@elem) {
1167                 my $e = shift @elem;
1168                 if ($e =~ /^$version|any_version$/) {
1169                         $pv = $e;
1170                         last;
1171                 }
1172                 push @arch, $e;
1173         }
1174
1175         my $arch;
1176         $arch = join('-', @arch) if @arch;
1177
1178         return($dn, $dv, $arch, $pv);
1179 }
1180
1181 =head2 generate_blib_stub
1182
1183 Creates a F<blib/lib> subdirectory in the current directory
1184 and prepares a F<META.yml> with meta information for a
1185 new PAR distribution. First argument should be the name of the
1186 PAR distribution in a format understood by C<parse_dist_name()>.
1187 Alternatively, named arguments resembling those of
1188 C<blib_to_par> are accepted.
1189
1190 After running C<generate_blib_stub> and injecting files into
1191 the F<blib> directory, you can create a PAR distribution
1192 using C<blib_to_par>.
1193 This function is useful for creating custom PAR distributions
1194 from scratch. (I.e. not from an unpacked CPAN distribution)
1195 Example:
1196
1197   use PAR::Dist;
1198   use File::Copy 'copy';
1199
1200   generate_blib_stub(
1201     name => 'MyApp', version => '1.00'
1202   );
1203   copy('MyApp.pm', 'blib/lib/MyApp.pm');
1204   blib_to_par(); # generates the .par file!
1205
1206 C<generate_blib_stub> will not overwrite existing files.
1207
1208 =cut
1209
1210 sub generate_blib_stub {
1211     my %args = &_args;
1212     my $dist = $args{dist};
1213     require Config;
1214
1215     my $name    = $args{name};
1216     my $version = $args{version};
1217     my $suffix  = $args{suffix};
1218
1219     my ($parse_name, $parse_version, $archname, $perlversion)
1220       = parse_dist_name($dist);
1221
1222     $name ||= $parse_name;
1223     $version ||= $parse_version;
1224     $suffix = "$archname-$perlversion"
1225       if (not defined $suffix or $suffix eq '')
1226          and $archname and $perlversion;
1227
1228     $suffix ||= "$Config::Config{archname}-$Config::Config{version}";
1229     if ( grep { not defined $_ } ($name, $version, $suffix) ) {
1230         warn "Could not determine distribution meta information from distribution name '$dist'";
1231         return();
1232     }
1233     $suffix =~ s/\.par$//;
1234
1235     if (not -f 'META.yml') {
1236         open META, '>', 'META.yml'
1237           or die "Could not open META.yml file for writing: $!";
1238         print META << "YAML" if fileno(META);
1239 name: $name
1240 version: $version
1241 build_requires: {}
1242 conflicts: {}
1243 dist_name: $name-$version-$suffix.par
1244 distribution_type: par
1245 dynamic_config: 0
1246 generated_by: 'PAR::Dist version $PAR::Dist::VERSION'
1247 license: unknown
1248 YAML
1249         close META;
1250     }
1251
1252     mkdir('blib');
1253     mkdir(File::Spec->catdir('blib', 'lib'));
1254     mkdir(File::Spec->catdir('blib', 'script'));
1255
1256     return 1;
1257 }
1258
1259
1260 =head2 contains_binaries
1261
1262 This function is not exported by default.
1263
1264 Opens a PAR archive tries to determine whether that archive
1265 contains platform-specific binary code.
1266
1267 Takes one named parameter: I<dist>. If only one parameter is
1268 passed, it is treated as the I<dist> parameter. (Have a look
1269 at the description in the C<FUNCTIONS> section above.)
1270
1271 Throws a fatal error if the PAR archive could not be found.
1272
1273 Returns one if the PAR was found to contain binary code
1274 and zero otherwise.
1275
1276 =cut
1277
1278 sub contains_binaries {
1279     require File::Find;
1280     my %args = &_args;
1281     my $dist = $args{dist};
1282     return undef if not defined $dist or not -r $dist;
1283     require Cwd;
1284     require File::Path;
1285
1286     # The unzipping will change directories. Remember old dir.
1287     my $old_cwd = Cwd::cwd();
1288
1289     # Unzip the base par to a temp. dir.
1290     (undef, my $base_dir) = _unzip_to_tmpdir(
1291         dist => $dist, subdir => 'blib'
1292     );
1293     my $blibdir = File::Spec->catdir($base_dir, 'blib');
1294     my $archdir = File::Spec->catdir($blibdir, 'arch');
1295
1296     my $found = 0;
1297
1298     File::Find::find(
1299       sub {
1300         $found++ if -f $_ and not /^\.exists$/;
1301       },
1302       $archdir
1303     );
1304
1305     chdir($old_cwd);
1306
1307     File::Path::rmtree([$base_dir]);
1308
1309     return $found ? 1 : 0;
1310 }
1311
1312 sub _system_wrapper {
1313   if ($DEBUG) {
1314     Carp::cluck("Running system call '@_' from:");
1315   }
1316   return system(@_);
1317 }
1318
1319 # stolen from Module::Install::Can
1320 # very much internal and subject to change or removal
1321 sub _MI_can_run {
1322   require ExtUtils::MakeMaker;
1323   my ($cmd) = @_;
1324
1325   my $_cmd = $cmd;
1326   return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
1327
1328   for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
1329     my $abs = File::Spec->catfile($dir, $cmd);
1330     return $abs if (-x $abs or $abs = MM->maybe_command($abs));
1331   }
1332
1333   return;
1334 }
1335
1336
1337 # Tries to load any YAML reader writer I know of
1338 # returns nothing on failure or hash reference containing
1339 # a subset of Load, Dump, LoadFile, DumpFile
1340 # entries with sub references on success.
1341 sub _get_yaml_functions {
1342   # reasoning for the ranking here:
1343   # - syck is fast and reasonably complete
1344   # - YAML.pm is slow and aging
1345   # - Tiny is only a very small subset
1346   # - XS is very new and I'm not sure it's ready for prime-time yet
1347   # - Parse... is only a reader and only deals with the same subset as ::Tiny
1348   my @modules = qw(YAML::Syck YAML YAML::Tiny YAML::XS Parse::CPAN::Meta);
1349
1350   my %yaml_functions;
1351   foreach my $module (@modules) {
1352     eval "require $module;";
1353     if (!$@) {
1354       warn "PAR::Dist testers/debug info: Using '$module' as YAML implementation" if $DEBUG;
1355       foreach my $sub (qw(Load Dump LoadFile DumpFile)) {
1356         no strict 'refs';
1357         my $subref = *{"${module}::$sub"}{CODE};
1358         if (defined $subref and ref($subref) eq 'CODE') {
1359           $yaml_functions{$sub} = $subref;
1360         }
1361       }
1362       $yaml_functions{yaml_provider} = $module;
1363       last;
1364     }
1365   } # end foreach module candidates
1366   if (not keys %yaml_functions) {
1367     warn "Cannot find a working YAML reader/writer implementation. Tried to load all of '@modules'";
1368   }
1369   return(\%yaml_functions);
1370 }
1371
1372 sub _check_tools {
1373   my $tools = _get_yaml_functions();
1374   if ($DEBUG) {
1375     foreach (qw/Load Dump LoadFile DumpFile/) {
1376       warn "No YAML support for $_ found.\n" if not defined $tools->{$_};
1377     }
1378   }
1379
1380   $tools->{zip} = undef;
1381   # A::Zip 1.28 was a broken release...
1382   if (eval {require Archive::Zip; 1;} and $Archive::Zip::VERSION ne '1.28') {
1383     warn "Using Archive::Zip as ZIP tool.\n" if $DEBUG;
1384     $tools->{zip} = 'Archive::Zip';
1385   }
1386   elsif (_MI_can_run("zip") and _MI_can_run("unzip")) {
1387     warn "Using zip/unzip as ZIP tool.\n" if $DEBUG;
1388     $tools->{zip} = 'zip';
1389   }
1390   else {
1391     warn "Found neither Archive::Zip (version != 1.28) nor ZIP/UNZIP as valid ZIP tools.\n" if $DEBUG;
1392     $tools->{zip} = undef;
1393   }
1394
1395   return $tools;
1396 }
1397
1398 1;
1399
1400 =head1 SEE ALSO
1401
1402 L<PAR>, L<ExtUtils::Install>, L<Module::Signature>, L<LWP::Simple>
1403
1404 =head1 AUTHORS
1405
1406 Audrey Tang E<lt>cpan@audreyt.orgE<gt> 2003-2007
1407
1408 Steffen Mueller E<lt>smueller@cpan.orgE<gt> 2005-2009
1409
1410 PAR has a mailing list, E<lt>par@perl.orgE<gt>, that you can write to;
1411 send an empty mail to E<lt>par-subscribe@perl.orgE<gt> to join the list
1412 and participate in the discussion.
1413
1414 Please send bug reports to E<lt>bug-par@rt.cpan.orgE<gt>.
1415
1416 =head1 COPYRIGHT
1417
1418 Copyright 2003-2009 by Audrey Tang E<lt>autrijus@autrijus.orgE<gt>.
1419
1420 This program is free software; you can redistribute it and/or modify it
1421 under the same terms as Perl itself.
1422
1423 See L<http://www.perl.com/perl/misc/Artistic.html>
1424
1425 =cut