git.maemo.org Git - dh-make-perl/blob - dev/arm/libpar-dist-perl/libpar-dist-perl-0.31/debian/libpar-dist-perl/usr/share/perl5/PAR/Dist.pm

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