git.oblomov.eu Git - ohcount/blob - test/expected_dir/perl_module.pm

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