File Coverage

blib/lib/Module/Install/PAR.pm
Criterion Covered Total %
statement 12 71 16.9
branch 0 46 0.0
condition 0 24 0.0
subroutine 4 8 50.0
pod 4 4 100.0
total 20 153 13.0


line stmt bran cond sub pod time code
1             package Module::Install::PAR;
2              
3 1     1   1645 use strict;
  1         2  
  1         29  
4 1     1   6 use Module::Install::Base ();
  1         2  
  1         20  
5              
6 1     1   4 use vars qw{$VERSION @ISA $ISCORE};
  1         2  
  1         68  
7             BEGIN {
8 1     1   2 $VERSION = '1.21';
9 1         23 @ISA = 'Module::Install::Base';
10 1         1089 $ISCORE = 1;
11             }
12              
13             =head1 NAME
14              
15             Module::Install::PAR - Module::Install Support for PAR::Dist packages
16              
17             =head1 SYNOPSIS
18              
19             To offer your users the possibility to install binaries if we cannot
20             compile an XS version of the module, you could use this simplistic stub:
21              
22             use inc::Module::Install;
23            
24             name 'Foo';
25             all_from 'lib/Foo.pm';
26            
27             # Which CPAN directory do we fetch binaries from?
28             par_base 'SMUELLER';
29            
30             unless ( can_xs ) {
31             my $okay = extract_par( fetch_par );
32             if (not $okay) {
33             die "No compiler and no binary package found. Aborting.\n";
34             }
35             }
36            
37             WriteAll;
38              
39             =head1 DESCRIPTION
40              
41             This module adds a couple of directives to Module::Install
42             related to installing and creating PAR::Dist distributions.
43              
44             =head2 par_base
45              
46             This directive sets the CPAN ID from whose CPAN directory to
47             fetch binaries from. For example, you can choose to download
48             binaries from http://www.cpan.org/authors/id/S/SM/SMUELLER/
49             or its ftp counterpart by writing:
50              
51             par_base 'SMUELLER';
52              
53             By default, the name of the file to fetch is generated from
54             the distribution name, its version, your platform name and your
55             perl version concatenated with dashes.
56              
57             The directive, however, takes an optional second
58             argument which specifies the name of the file to fetch.
59             (Though C<par_base> does not fetch files itself, see below.)
60              
61             par_base 'SMUELLER', 'foo';
62              
63             Once C<fetch_par> is called, the file 'foo' will be downloaded
64             from SMUELLER's CPAN directory. (It doesn't exist.)
65              
66             The second argument could be used to fetch platform-agnostic
67             binaries:
68              
69             par_base 'SMUELLER', "Some-Distribution-0.01.par";
70              
71             (Documentation TODO: Use the previously defined distribution
72             name and version in example.)
73              
74             =cut
75              
76             sub par_base {
77 0     0 1   my ($self, $base, $file) = @_;
78 0           my $class = ref($self);
79 0           my $inc_class = join('::', @{$self->_top}{qw(prefix name)});
  0            
80 0           my $ftp_base;
81              
82 0 0 0       if ( defined $base and length $base ) {
83 0 0         if ( $base =~ m!^(([A-Z])[A-Z])[-_A-Z]+\Z! ) {
    0          
84 0           $self->{mailto} = "$base\@cpan.org";
85 0           $ftp_base = "ftp://ftp.cpan.org/pub/CPAN/authors/id/$2/$1/$base";
86 0           $base = "http://www.cpan.org/authors/id/$2/$1/$base";
87             } elsif ( $base !~ m!^(\w+)://! ) {
88 0           die "Cannot recognize path '$base'; please specify an URL or CPAN ID";
89             }
90 0 0         $base .= '/' unless $base =~ m!/\Z!;
91 0 0         $ftp_base .= '/' unless $ftp_base =~ m!/\Z!;
92             }
93              
94 0           require Config;
95 0           my $suffix = "$Config::Config{archname}-$Config::Config{version}.par";
96              
97 0 0 0       unless ( $file ||= $self->{file} ) {
98 0 0         my $name = $self->name or return;
99 0 0         my $version = $self->version or return;
100 0           $name =~ s!::!-!g;
101 0           $self->{file} = $file = "$name-$version-$suffix";
102             }
103              
104 0           my $perl = $^X;
105 0 0 0       $perl = Win32::GetShortPathName($perl)
106             if $perl =~ / / and defined &Win32::GetShortPathName;
107              
108 0 0         $self->preamble(<<"END_MAKEFILE") if $base;
109             # --- $class section:
110              
111             all ::
112             \t\$(NOECHO) $perl "-M$inc_class" -e "extract_par(q($file))"
113              
114             END_MAKEFILE
115              
116 0           $self->postamble(<<"END_MAKEFILE");
117             # --- $class section:
118              
119             $file: all test
120             \t\$(NOECHO) \$(PERL) "-M$inc_class" -e "make_par(q($file))"
121              
122             par :: $file
123             \t\$(NOECHO) \$(NOOP)
124              
125             par-upload :: $file
126             \tcpan-upload -verbose $file
127              
128             END_MAKEFILE
129              
130 0           $self->{url} = $base;
131 0           $self->{ftp_url} = $ftp_base;
132 0           $self->{suffix} = $suffix;
133              
134 0           return $self;
135             }
136              
137             =head2 fetch_par
138              
139             Fetches the .par file previously referenced in the documentation
140             of the C<par_base> directive.
141              
142             C<fetch_par> can be used without arguments given the C<par_base>
143             directive was used before. It will return the name of the file it
144             fetched.
145              
146             If the first argument is an URL or a CPAN user ID, the file is
147             fetched from that directory unless an URL has been previously set.
148             (Read that again.)
149              
150             If the second argument is a file name
151             it is used as the name of the file to download.
152              
153             If the file could not be fetched, a suitable error message
154             about no package being available, yada yada yada, is printed.
155             You can turn this off by specifying a true third argument.
156              
157             # Try to fetch the package (see par_base) but
158             # don't be verbose about failures
159             my $file = fetch_par('', '', undef);
160              
161             =cut
162              
163             sub fetch_par {
164 0     0 1   my ($self, $url, $file, $quiet) = @_;
165 0 0         $url = '' if not defined $url;
166 0 0         $file = '' if not defined $file;
167            
168 0   0       $url = $self->{url} || $self->par_base($url)->{url};
169 0           my $ftp_url = $self->{ftp_url};
170 0   0       $file ||= $self->{file};
171              
172 0 0 0       return $file if -f $file or $self->get_file(
173             url => "$url$file",
174             ftp_url => "$ftp_url$file"
175             );
176              
177 0           require Config;
178 0 0 0       print <<"END_MESSAGE" if $self->{mailto} and ! $quiet;
179             *** No installation package available for your architecture.
180             However, you may wish to generate one with '$Config::Config{make} par' and send
181             it to <$self->{mailto}>, so other people on the same platform
182             can benefit from it.
183             *** Proceeding with normal installation...
184             END_MESSAGE
185 0           return;
186             }
187              
188             =head2 extract_par
189              
190             Takes the name of a PAR::Dist archive file as first argument. The 'blib/'
191             directory of this archive is extracted and the 'pm_to_blib' is created.
192              
193             Typical shorthand usage:
194              
195             extract_par( fetch_par ) or die "Could not install PAR::Dist archive.";
196              
197             =cut
198              
199             sub extract_par {
200 0     0 1   my ($self, $file) = @_;
201 0 0         return unless -f $file;
202              
203 0 0         if ( eval { require Archive::Zip; 1 } ) {
  0 0          
  0            
204 0           my $zip = Archive::Zip->new;
205 0 0 0       return unless $zip->read($file) == Archive::Zip::AZ_OK()
206             and $zip->extractTree('', 'blib/') == Archive::Zip::AZ_OK();
207             } elsif ( $self->can_run('unzip') ) {
208 0 0         return if system( unzip => $file, qw(-d blib) );
209             }
210             else {
211 0           die <<'HERE';
212             Could not extract .par archive because neither Archive::Zip nor a
213             working 'unzip' binary are available. Please consider installing
214             Archive::Zip.
215             HERE
216             }
217              
218 0           local *PM_TO_BLIB;
219 0 0         open PM_TO_BLIB, '> pm_to_blib' or die $!;
220 0 0         close PM_TO_BLIB or die $!;
221              
222 0           return 1;
223             }
224              
225             =head2 make_par
226              
227             This directive requires PAR::Dist (version 0.03 or up) on your system.
228             (And checks that it is available before continuing.)
229              
230             Creates a PAR::Dist archive from the 'blib/' subdirectory.
231              
232             First argument must be the name of the PAR::Dist archive to create.
233              
234             If your Makefile.PL has a C<par_base> directive, the C<make par>
235             make target will be available. It uses this C<make_par> directive
236             internally, so on your development system, you can do this to create
237             a .par binary archive for your platform:
238              
239             perl Makefile.PL
240             make
241             make par
242              
243             =cut
244              
245             sub make_par {
246 0     0 1   my ($self, $file) = @_;
247 0 0         unlink $file if -f $file;
248              
249 0 0         unless ( eval { require PAR::Dist; PAR::Dist->VERSION(0.03) } ) {
  0            
  0            
250 0           warn "Please install PAR::Dist 0.03 or above first.";
251 0           return;
252             }
253              
254 0           return PAR::Dist::blib_to_par( dist => $file );
255             }
256              
257             1;
258              
259             =head1 AUTHOR
260              
261             Audrey Tang <cpan@audreyt.org>
262              
263             With documentation from Steffen Mueller <smueller@cpan.org>
264              
265             =head1 COPYRIGHT
266              
267             Copyright (c) 2006. Audrey Tang.
268              
269             This program is free software; you can redistribute it and/or modify it
270             under the same terms as Perl itself.
271              
272             See L<http://www.perl.com/perl/misc/Artistic.html>
273              
274             =cut