File Coverage

blib/lib/PAR/Dist.pm
Criterion Covered Total %
statement 76 526 14.4
branch 23 258 8.9
condition 12 160 7.5
subroutine 10 39 25.6
pod 11 11 100.0
total 132 994 13.2


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