File Coverage

blib/lib/PPM/Make/Util.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package PPM::Make::Util;
2 6     6   22 use strict;
  6         8  
  6         144  
3 6     6   19 use warnings;
  6         6  
  6         124  
4 6     6   20 use base qw(Exporter);
  6         8  
  6         609  
5 6     6   27 use File::Basename;
  6         6  
  6         345  
6 6     6   439 use Safe;
  6         29885  
  6         178  
7 6     6   6276 use XML::Parser;
  0            
  0            
8             use Digest::MD5;
9             use Config;
10             use CPAN::DistnameInfo;
11             use File::Spec;
12             use PPM::Make::Config qw(WIN32 HAS_CPAN ACTIVEPERL);
13             use HTTP::Tiny;
14              
15             =head1 NAME
16              
17             PPM::Make::Util - Utility functions for PPM::Make
18              
19             =head1 SYNOPSIS
20              
21             use PPM::Make::Util qw(:all);
22              
23             =head1 DESCRIPTION
24              
25             This module contains a number of utility functions used by PPM::Make.
26              
27             =over 2
28              
29             =cut
30              
31             our $VERSION = '0.9903';
32              
33             our (@EXPORT_OK, %EXPORT_TAGS, $protocol, $ext, $src_dir, $build_dir,
34             @url_list, $ERROR);
35             $protocol = qr{^(http|ftp)://};
36             $ext = qr{\.(tar\.gz|tgz|tar\.Z|zip)};
37             @url_list = url_list();
38              
39             my @exports = qw(load_cs verifyMD5 verifySHA256 parse_version $ERROR
40             is_core is_ap_core url_list
41             parse_ppd parse_abstract
42             ppd2cpan_version cpan2ppd_version
43             file_to_dist cpan_file fix_path
44             mirror
45             $src_dir $build_dir @url_list);
46              
47             %EXPORT_TAGS = (all => [@exports]);
48             @EXPORT_OK = (@exports);
49              
50             my %ap_core = map {$_ => 1} qw(
51             Archive-Tar
52             Archive-Zip
53             Compress-Zlib
54             Data-Dump
55             Digest-HMAC
56             Digest-MD2
57             Digest-MD4
58             Digest-SHA1
59             File-CounterFile
60             Font-AFM
61             HTML-Parser
62             HTML-Tagset
63             HTML-Tree
64             IO-String
65             IO-Zlib
66             libwin32
67             libwww-perl
68             MD5
69             MIME-Base64-Scripts
70             SOAP-Lite
71             Term-ReadLine-Perl
72             TermReadKey
73             Text-Autoformat
74             Text-Reform
75             Tk
76             Unicode-String
77             URI
78             XML-Parser
79             XML-Simple );
80              
81             if (WIN32 and ACTIVEPERL and eval { Win32::BuildNumber() > 818 }) {
82             $ap_core{'DBI'}++; $ap_core{'DBD-SQLite'}++;
83             }
84             src_and_build();
85              
86             my %dists;
87              
88             =item fix_path
89              
90             Ensures a path is a Unix-type path, with no spaces.
91              
92             my $path = 'C:\Program Files\';
93             my $unix_version = fix_path($path);
94              
95             =cut
96              
97             sub fix_path {
98             my $path = shift;
99             $path = Win32::GetShortPathName($path);
100             $path =~ s!\\!/!g;
101             $path =~ s!/$!!;
102             return $path;
103             }
104              
105             =item load_cs
106              
107             Loads a CHECKSUMS file into $cksum
108             (adapted from the MD5 check of CPAN.pm)
109              
110             my $cksum = load_cs('CHECKSUMS');
111              
112             =cut
113              
114             sub load_cs {
115             my $cs = shift;
116             open(my $fh, '<', $cs);
117             unless ($fh) {
118             $ERROR = qq{Could not open "$cs": $!};
119             return;
120             }
121             local($/);
122             my $eval = <$fh>;
123             close $fh;
124             $eval =~ s/\015?\012/\n/g;
125             my $comp = Safe->new();
126             my $cksum = $comp->reval($eval);
127             if ($@) {
128             $ERROR = qq{eval of "$cs" failed: $@};
129             return;
130             }
131             return $cksum;
132             }
133              
134             =item verifyMD5
135              
136             Verify a CHECKSUM for a $file
137              
138             my $ok = verifyMD5($cksum, $file);
139             print "$file checked out OK" if $ok;
140              
141             =cut
142              
143             sub verifyMD5 {
144             my ($cksum, $file) = @_;
145             my ($is, $should);
146             open (my $fh, '<', $file);
147             unless ($fh) {
148             $ERROR = qq{Cannot open "$file": $!};
149             return;
150             }
151             binmode($fh);
152             unless ($is = Digest::MD5->new->addfile($fh)->hexdigest) {
153             $ERROR = qq{Could not compute checksum for "$file": $!};
154             close $fh;
155             return;
156             }
157             close $fh;
158             if ($should = $cksum->{$file}->{md5}) {
159             my $test = ($is eq $should);
160             if (!$test && ($should = $cksum->{$file}->{'md5-ungz'})) {
161             $test = ($is eq $should);
162             }
163             printf qq{ Checksum for "$file" is %s\n},
164             ($test) ? 'OK.' : 'NOT OK.';
165             return $test;
166             }
167             else {
168             $ERROR = qq{Checksum data for "$file" not present.};
169             return;
170             }
171             }
172              
173             =item verifySHA256
174              
175             Verify a CHECKSUM for a $file
176              
177             my $ok = verifySHA256($cksum, $file);
178             print "$file checked out OK" if $ok;
179              
180             =cut
181              
182             sub verifySHA256 {
183             my ($cksum, $file) = @_;
184             my ($is, $should);
185             open (my $fh, '<', $file);
186             unless ($fh) {
187             $ERROR = qq{Cannot open "$file": $!};
188             return;
189             }
190             require Digest::SHA;
191             binmode($fh);
192             unless ($is = Digest::SHA->new(256)->addfile($fh)->hexdigest) {
193             $ERROR = qq{Could not compute checksum for "$file": $!};
194             close $fh;
195             return;
196             }
197             close $fh;
198             if ($should = $cksum->{$file}->{sha256}) {
199             my $test = ($is eq $should);
200             if (!$test && ($should = $cksum->{$file}->{'sha256-ungz'})) {
201             $test = ($is eq $should);
202             }
203             printf qq{ SHA256-Checksum for "$file" is %s\n},
204             ($test) ? 'OK.' : 'NOT OK.';
205             return $test;
206             }
207             else {
208             $ERROR = qq{Checksum data for "$file" not present.};
209             return;
210             }
211             }
212              
213             =item is_core
214              
215             Tests to see if a module is part of the core, based on
216             whether or not the file is found within a I type
217             of directory.
218              
219             my $is_core = is_core('Net::FTP');
220             print "Net::FTP is a core module" if $is_core;
221              
222             =cut
223              
224             sub is_core {
225             my $m = shift;
226             return unless $m;
227             $m =~ s!::|-!/!g;
228             $m .= '.pm';
229             my $is_core = (-e File::Spec->catfile($Config{privlibexp}, $m)) ? 1 : 0;
230             return $is_core;
231             }
232              
233             =item is_ap_core
234              
235             Tests to see if a package is part of the ActivePerl core (at
236             least for recent ActivePerl versions).
237              
238             my $is_ap_core = is_ap_core('libwin32');
239             print "libwin32 is a core package" if $is_ap_core;
240              
241             =cut
242              
243             sub is_ap_core {
244             my $p = shift;
245             return unless defined $p;
246             return defined $ap_core{$p} ? 1 : 0;
247             }
248              
249             =item file_to_dist
250              
251             In scalar context, returns a CPAN distribution name I based
252             on an input file I:
253              
254             my $file = 'A/AB/ABC/defg-1.23.tar.gz';
255             my $dist = file_to_dist($file);
256              
257             In a list context, returns both the distribution name I
258             and the version number I<1.23>:
259              
260             my $file = 'A/AB/ABC/defg-1.23.tar.gz';
261             my ($dist, $version) = file_to_dist($cpan_file);
262              
263              
264             =cut
265              
266             sub file_to_dist {
267             my $cpan_file = shift;
268             return unless $cpan_file;
269             my $d = CPAN::DistnameInfo->new($cpan_file);
270             my ($dist, $version) = ($d->dist, $d->version);
271             unless ($dist and $version) {
272             $ERROR = qq{Could not find distribution name from $cpan_file.};
273             return;
274             }
275             return wantarray? ($dist, $version) : $dist;
276             }
277              
278             =item ppd2cpan_version
279              
280             Converts a ppd-type of version string (eg, I<1,23,0,0>) into a ppd one
281             of the form I<1.23>:
282              
283             my $s = "1,23,0,0";
284             my $v = ppd2cpan_version($v);
285              
286             =cut
287              
288             sub ppd2cpan_version {
289             local $_ = shift;
290             s/(,0)*$//;
291             tr/,/./;
292             return $_;
293             }
294              
295             =item cpan2ppd_version
296              
297             Converts a cpan-type of version string (eg, I<1.23>) into a ppd one
298             of the form I<1,23,0,0>:
299              
300             my $v = 1.23;
301             my $s = cpan2ppd_version($v);
302              
303             =cut
304              
305             sub cpan2ppd_version {
306             local $_ = shift;
307             return join ',', (split (/\./, $_), (0)x4)[0..3];
308             }
309              
310              
311             =item parse_ppd
312              
313             Parse a I file or a string.
314              
315             my $ppd = 'package.ppd';
316             my $d = parse_ppd($ppd);
317             print $d->{ABSTRACT};
318             print $d->{OS}->{NAME};
319              
320             my $e = parse_ppd($ppd, 'MSWin32-x86-multi-thread');
321             print $e->{ABSTRACT};
322              
323             This routine takes a required argument of a I file containing
324             a I<.ppd> extension or a string and,
325             optionally, an ARCHITECTURE name to restrict the results to.
326             It returns a data structure containing the information of
327             the ppd file or string:
328              
329             $d->{SOFTPKG}->{NAME}
330             $d->{SOFTPKG}->{VERSION}
331             $d->{TITLE}
332             $d->{AUTHOR}
333             $d->{ABSTRACT}
334             $d->{PROVIDE}
335             $d->{DEPENDENCY}
336             $d->{REQUIRE}
337             $d->{OS}->{NAME}
338             $d->{ARCHITECTURE}->{NAME}
339             $d->{CODEBASE}->{HREF}
340             $d->{INSTALL}->{EXEC}
341             $d->{INSTALL}->{SCRIPT}
342             $d->{INSTALL}->{HREF}
343              
344             The I, I and I tags are array references
345             containing lists of, respectively, the prerequisites required and
346             the modules supplied by the package, with keys of I and
347             I.
348              
349             If there is more than one I section in the
350             ppd file, all the results except for the I elements and
351             I, I<AUTHOR>, and I<ABSTRACT> will be placed in </td> </tr> <tr> <td class="h" > <a name="352">352</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> a I<$d-E<gt>{IMPLENTATION}> array </td> </tr> <tr> <td class="h" > <a name="353">353</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> reference. If an optional second argument is passed to </td> </tr> <tr> <td class="h" > <a name="354">354</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> I<parse_ppd($file, $arch)>, this will filter out all implementation </td> </tr> <tr> <td class="h" > <a name="355">355</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sections except for the specified I<ARCHITECTURE> given by I<$arch>. </td> </tr> <tr> <td class="h" > <a name="356">356</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="357">357</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="358">358</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="359">359</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $i; </td> </tr> <tr> <td class="h" > <a name="360">360</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="361">361</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub parse_ppd { </td> </tr> <tr> <td class="h" > <a name="362">362</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $file = shift; </td> </tr> <tr> <td class="h" > <a name="363">363</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $arch = shift; </td> </tr> <tr> <td class="h" > <a name="364">364</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $is_a_file = ($file =~ /\.ppd/); </td> </tr> <tr> <td class="h" > <a name="365">365</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if ($is_a_file) { </td> </tr> <tr> <td class="h" > <a name="366">366</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> unless (-e $file) { </td> </tr> <tr> <td class="h" > <a name="367">367</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $ERROR = qq{$file not found.}; </td> </tr> <tr> <td class="h" > <a name="368">368</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return; </td> </tr> <tr> <td class="h" > <a name="369">369</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="370">370</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="371">371</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $p = XML::Parser->new(Style => 'Subs', </td> </tr> <tr> <td class="h" > <a name="372">372</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Handlers => {Char => \&ppd_char, </td> </tr> <tr> <td class="h" > <a name="373">373</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Start => \&ppd_start, </td> </tr> <tr> <td class="h" > <a name="374">374</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> End => \&ppd_end, </td> </tr> <tr> <td class="h" > <a name="375">375</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Init => \&ppd_init, </td> </tr> <tr> <td class="h" > <a name="376">376</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Final => \&ppd_final, </td> </tr> <tr> <td class="h" > <a name="377">377</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }, </td> </tr> <tr> <td class="h" > <a name="378">378</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ); </td> </tr> <tr> <td class="h" > <a name="379">379</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $d = $is_a_file ? $p->parsefile($file) : $p->parse($file); </td> </tr> <tr> <td class="h" > <a name="380">380</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $implem = $d->{IMPLEMENTATION}; </td> </tr> <tr> <td class="h" > <a name="381">381</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $size = scalar @$implem; </td> </tr> <tr> <td class="h" > <a name="382">382</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if ($size == 1) { </td> </tr> <tr> <td class="h" > <a name="383">383</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{PROVIDE} = $implem->[0]->{PROVIDE} || []; </td> </tr> <tr> <td class="h" > <a name="384">384</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{DEPENDENCY} = $implem->[0]->{DEPENDENCY} || []; </td> </tr> <tr> <td class="h" > <a name="385">385</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{REQUIRE} = $implem->[0]->{DEPENDENCY} || []; </td> </tr> <tr> <td class="h" > <a name="386">386</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{OS}->{NAME} = $implem->[0]->{OS}->{NAME} || ''; </td> </tr> <tr> <td class="h" > <a name="387">387</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{ARCHITECTURE}->{NAME} = $implem->[0]->{ARCHITECTURE}->{NAME} || ''; </td> </tr> <tr> <td class="h" > <a name="388">388</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{CODEBASE}->{HREF} = $implem->[0]->{CODEBASE}->{HREF}; </td> </tr> <tr> <td class="h" > <a name="389">389</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{EXEC} = $implem->[0]->{INSTALL}->{EXEC}; </td> </tr> <tr> <td class="h" > <a name="390">390</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{SCRIPT} = $implem->[0]->{INSTALL}->{SCRIPT}; </td> </tr> <tr> <td class="h" > <a name="391">391</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{HREF} = $implem->[0]->{INSTALL}->{HREF}; </td> </tr> <tr> <td class="h" > <a name="392">392</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="393">393</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> elsif (defined $arch) { </td> </tr> <tr> <td class="h" > <a name="394">394</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $flag = 0; </td> </tr> <tr> <td class="h" > <a name="395">395</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $i; </td> </tr> <tr> <td class="h" > <a name="396">396</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> for ($i=0; $i<$size; $i++) { </td> </tr> <tr> <td class="h" > <a name="397">397</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if ($implem->[$i]->{ARCHITECTURE}->{NAME} eq $arch) { </td> </tr> <tr> <td class="h" > <a name="398">398</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $flag++; </td> </tr> <tr> <td class="h" > <a name="399">399</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last; </td> </tr> <tr> <td class="h" > <a name="400">400</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="401">401</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="402">402</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return unless $flag; </td> </tr> <tr> <td class="h" > <a name="403">403</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{PROVIDE} = $implem->[$i]->{PROVIDE} || []; </td> </tr> <tr> <td class="h" > <a name="404">404</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{DEPENDENCY} = $implem->[$i]->{DEPENDENCY} || []; </td> </tr> <tr> <td class="h" > <a name="405">405</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{REQUIRE} = $implem->[$i]->{DEPENDENCY} || []; </td> </tr> <tr> <td class="h" > <a name="406">406</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{OS}->{NAME} = $implem->[$i]->{OS}->{NAME} || ''; </td> </tr> <tr> <td class="h" > <a name="407">407</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{ARCHITECTURE}->{NAME} = $implem->[$i]->{ARCHITECTURE}->{NAME} || ''; </td> </tr> <tr> <td class="h" > <a name="408">408</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{CODEBASE}->{HREF} = $implem->[$i]->{CODEBASE}->{HREF}; </td> </tr> <tr> <td class="h" > <a name="409">409</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{EXEC} = $implem->[$i]->{INSTALL}->{EXEC}; </td> </tr> <tr> <td class="h" > <a name="410">410</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{SCRIPT} = $implem->[$i]->{INSTALL}->{SCRIPT}; </td> </tr> <tr> <td class="h" > <a name="411">411</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $d->{INSTALL}->{HREF} = $implem->[$i]->{INSTALL}->{HREF}; </td> </tr> <tr> <td class="h" > <a name="412">412</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="413">413</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return $d; </td> </tr> <tr> <td class="h" > <a name="414">414</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="415">415</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="416">416</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub ppd_init { </td> </tr> <tr> <td class="h" > <a name="417">417</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $self = shift; </td> </tr> <tr> <td class="h" > <a name="418">418</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $i = 0; </td> </tr> <tr> <td class="h" > <a name="419">419</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $self->{_mydata} = { </td> </tr> <tr> <td class="h" > <a name="420">420</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> SOFTPKG => {NAME => '', VERSION => ''}, </td> </tr> <tr> <td class="h" > <a name="421">421</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> TITLE => '', </td> </tr> <tr> <td class="h" > <a name="422">422</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> AUTHOR => '', </td> </tr> <tr> <td class="h" > <a name="423">423</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ABSTRACT => '', </td> </tr> <tr> <td class="h" > <a name="424">424</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> PROVIDE => [], </td> </tr> <tr> <td class="h" > <a name="425">425</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> IMPLEMENTATION => [], </td> </tr> <tr> <td class="h" > <a name="426">426</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> OS => {NAME => ''}, </td> </tr> <tr> <td class="h" > <a name="427">427</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ARCHITECTURE => {NAME => ''}, </td> </tr> <tr> <td class="h" > <a name="428">428</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> CODEBASE => {HREF => ''}, </td> </tr> <tr> <td class="h" > <a name="429">429</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> DEPENDENCY => [], </td> </tr> <tr> <td class="h" > <a name="430">430</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> REQUIRE => [], </td> </tr> <tr> <td class="h" > <a name="431">431</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> INSTALL => {EXEC => '', SCRIPT => '', HREF => ''}, </td> </tr> <tr> <td class="h" > <a name="432">432</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> wanted => {TITLE => 1, ABSTRACT => 1, AUTHOR => 1}, </td> </tr> <tr> <td class="h" > <a name="433">433</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> _current => '', </td> </tr> <tr> <td class="h" > <a name="434">434</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="435">435</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="436">436</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="437">437</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub ppd_start { </td> </tr> <tr> <td class="h" > <a name="438">438</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($self, $tag, %attrs) = @_; </td> </tr> <tr> <td class="h" > <a name="439">439</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $internal = $self->{_mydata}; </td> </tr> <tr> <td class="h" > <a name="440">440</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{_current} = $tag; </td> </tr> <tr> <td class="h" > <a name="441">441</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> SWITCH: { </td> </tr> <tr> <td class="h" > <a name="442">442</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'SOFTPKG') and do { </td> </tr> <tr> <td class="h" > <a name="443">443</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{SOFTPKG}->{NAME} = $attrs{NAME}; </td> </tr> <tr> <td class="h" > <a name="444">444</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{SOFTPKG}->{VERSION} = $attrs{VERSION}; </td> </tr> <tr> <td class="h" > <a name="445">445</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="446">446</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="447">447</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'PROVIDE') and do { </td> </tr> <tr> <td class="h" > <a name="448">448</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $name = $attrs{NAME}; </td> </tr> <tr> <td class="h" > <a name="449">449</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $version = $attrs{VERSION}; </td> </tr> <tr> <td class="h" > <a name="450">450</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if ($version) { </td> </tr> <tr> <td class="h" > <a name="451">451</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @{$internal->{IMPLEMENTATION}->[$i]->{PROVIDE}}, </td> </tr> <tr> <td class="h" > <a name="452">452</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> {NAME => $name, VERSION => $version}; </td> </tr> <tr> <td class="h" > <a name="453">453</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="454">454</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> else { </td> </tr> <tr> <td class="h" > <a name="455">455</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @{$internal->{IMPLEMENTATION}->[$i]->{PROVIDE}}, </td> </tr> <tr> <td class="h" > <a name="456">456</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> {NAME => $name}; </td> </tr> <tr> <td class="h" > <a name="457">457</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="458">458</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="459">459</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="460">460</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'CODEBASE') and do { </td> </tr> <tr> <td class="h" > <a name="461">461</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{CODEBASE}->{HREF} = </td> </tr> <tr> <td class="h" > <a name="462">462</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $attrs{HREF}; </td> </tr> <tr> <td class="h" > <a name="463">463</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="464">464</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="465">465</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'OS') and do { </td> </tr> <tr> <td class="h" > <a name="466">466</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{OS}->{NAME} = </td> </tr> <tr> <td class="h" > <a name="467">467</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $attrs{NAME}; </td> </tr> <tr> <td class="h" > <a name="468">468</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="469">469</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="470">470</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'ARCHITECTURE') and do { </td> </tr> <tr> <td class="h" > <a name="471">471</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{ARCHITECTURE}->{NAME} = </td> </tr> <tr> <td class="h" > <a name="472">472</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $attrs{NAME}; </td> </tr> <tr> <td class="h" > <a name="473">473</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="474">474</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="475">475</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'INSTALL') and do { </td> </tr> <tr> <td class="h" > <a name="476">476</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{EXEC} = </td> </tr> <tr> <td class="h" > <a name="477">477</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $attrs{EXEC}; </td> </tr> <tr> <td class="h" > <a name="478">478</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{HREF} = </td> </tr> <tr> <td class="h" > <a name="479">479</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $attrs{HREF}; </td> </tr> <tr> <td class="h" > <a name="480">480</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="481">481</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="482">482</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'DEPENDENCY') and do { </td> </tr> <tr> <td class="h" > <a name="483">483</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @{$internal->{IMPLEMENTATION}->[$i]->{DEPENDENCY}}, </td> </tr> <tr> <td class="h" > <a name="484">484</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> {NAME => $attrs{NAME}, VERSION => $attrs{VERSION}}; </td> </tr> <tr> <td class="h" > <a name="485">485</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="486">486</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="487">487</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ($tag eq 'REQUIRE') and do { </td> </tr> <tr> <td class="h" > <a name="488">488</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @{$internal->{IMPLEMENTATION}->[$i]->{REQUIRE}}, </td> </tr> <tr> <td class="h" > <a name="489">489</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> {NAME => $attrs{NAME}, VERSION => $attrs{VERSION}}; </td> </tr> <tr> <td class="h" > <a name="490">490</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH; </td> </tr> <tr> <td class="h" > <a name="491">491</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="492">492</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="493">493</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="494">494</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="495">495</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub ppd_char { </td> </tr> <tr> <td class="h" > <a name="496">496</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($self, $string) = @_; </td> </tr> <tr> <td class="h" > <a name="497">497</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $internal = $self->{_mydata}; </td> </tr> <tr> <td class="h" > <a name="498">498</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $tag = $internal->{_current}; </td> </tr> <tr> <td class="h" > <a name="499">499</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if ($tag and $internal->{wanted}->{$tag}) { </td> </tr> <tr> <td class="h" > <a name="500">500</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{$tag} .= $string; </td> </tr> <tr> <td class="h" > <a name="501">501</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="502">502</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> elsif ($tag and $tag eq 'INSTALL') { </td> </tr> <tr> <td class="h" > <a name="503">503</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{SCRIPT} .= $string; </td> </tr> <tr> <td class="h" > <a name="504">504</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="505">505</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> else { </td> </tr> <tr> <td class="h" > <a name="506">506</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="507">507</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="508">508</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="509">509</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub ppd_end { </td> </tr> <tr> <td class="h" > <a name="510">510</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($self, $tag) = @_; </td> </tr> <tr> <td class="h" > <a name="511">511</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $i++ if ($tag eq 'IMPLEMENTATION'); </td> </tr> <tr> <td class="h" > <a name="512">512</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> delete $self->{_mydata}->{_current}; </td> </tr> <tr> <td class="h" > <a name="513">513</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="514">514</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="515">515</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub ppd_final { </td> </tr> <tr> <td class="h" > <a name="516">516</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $self = shift; </td> </tr> <tr> <td class="h" > <a name="517">517</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return $self->{_mydata}; </td> </tr> <tr> <td class="h" > <a name="518">518</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="519">519</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="520">520</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item src_and_build </td> </tr> <tr> <td class="h" > <a name="521">521</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="522">522</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Returns the source and build directories used with </td> </tr> <tr> <td class="h" > <a name="523">523</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> CPAN.pm, if present. If not, returns those used with PPM, </td> </tr> <tr> <td class="h" > <a name="524">524</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if those are present. If neither of these are available, </td> </tr> <tr> <td class="h" > <a name="525">525</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> returns the system temp directory. </td> </tr> <tr> <td class="h" > <a name="526">526</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="527">527</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($src_dir, $build_dir)= src_and_build; </td> </tr> <tr> <td class="h" > <a name="528">528</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="529">529</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="530">530</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="531">531</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub src_and_build { </td> </tr> <tr> <td class="h" > <a name="532">532</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return if ($src_dir and $build_dir); </td> </tr> <tr> <td class="h" > <a name="533">533</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> SWITCH: { </td> </tr> <tr> <td class="h" > <a name="534">534</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> HAS_CPAN and do { </td> </tr> <tr> <td class="h" > <a name="535">535</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $src_dir = $CPAN::Config->{keep_source_where}; </td> </tr> <tr> <td class="h" > <a name="536">536</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $build_dir = $CPAN::Config->{build_dir}; </td> </tr> <tr> <td class="h" > <a name="537">537</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last SWITCH if ($src_dir and $build_dir); </td> </tr> <tr> <td class="h" > <a name="538">538</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="539">539</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $src_dir = File::Spec->tmpdir() || '.'; </td> </tr> <tr> <td class="h" > <a name="540">540</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $build_dir = $src_dir; </td> </tr> <tr> <td class="h" > <a name="541">541</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="542">542</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="543">543</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="544">544</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item parse_version </td> </tr> <tr> <td class="h" > <a name="545">545</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="546">546</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Extracts a version string from a module file. </td> </tr> <tr> <td class="h" > <a name="547">547</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="548">548</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $version = parse_version('C:/Perl/lib/CPAN.pm'); </td> </tr> <tr> <td class="h" > <a name="549">549</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="550">550</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="551">551</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="552">552</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # from ExtUtils::MM_Unix </td> </tr> <tr> <td class="h" > <a name="553">553</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub parse_version { </td> </tr> <tr> <td class="h" > <a name="554">554</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $parsefile = shift; </td> </tr> <tr> <td class="h" > <a name="555">555</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return unless -e $parsefile; </td> </tr> <tr> <td class="h" > <a name="556">556</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $version; </td> </tr> <tr> <td class="h" > <a name="557">557</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> local $/ = "\n"; </td> </tr> <tr> <td class="h" > <a name="558">558</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $fh; </td> </tr> <tr> <td class="h" > <a name="559">559</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> unless (open($fh, '<', $parsefile)) { </td> </tr> <tr> <td class="h" > <a name="560">560</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $ERROR = "Could not open '$parsefile': $!"; </td> </tr> <tr> <td class="h" > <a name="561">561</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return; </td> </tr> <tr> <td class="h" > <a name="562">562</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="563">563</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $inpod = 0; </td> </tr> <tr> <td class="h" > <a name="564">564</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> while (<$fh>) { </td> </tr> <tr> <td class="h" > <a name="565">565</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; </td> </tr> <tr> <td class="h" > <a name="566">566</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next if $inpod || /^\s*\#/; </td> </tr> <tr> <td class="h" > <a name="567">567</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> chop; </td> </tr> <tr> <td class="h" > <a name="568">568</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; </td> </tr> <tr> <td class="h" > <a name="569">569</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; </td> </tr> <tr> <td class="h" > <a name="570">570</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $eval = qq{ </td> </tr> <tr> <td class="h" > <a name="571">571</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> package # hide from PAUSE </td> </tr> <tr> <td class="h" > <a name="572">572</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ExtUtils::MakeMaker::_version; </td> </tr> <tr> <td class="h" > <a name="573">573</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> no strict; </td> </tr> <tr> <td class="h" > <a name="574">574</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> </td> </tr> <tr> <td class="h" > <a name="575">575</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> local $1$2; </td> </tr> <tr> <td class="h" > <a name="576">576</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> \$$2=undef; do { </td> </tr> <tr> <td class="h" > <a name="577">577</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $_; </td> </tr> <tr> <td class="h" > <a name="578">578</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return \$$2; </td> </tr> <tr> <td class="h" > <a name="579">579</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="580">580</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="581">581</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> local $^W = 0; </td> </tr> <tr> <td class="h" > <a name="582">582</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $version = eval($eval); </td> </tr> <tr> <td class="h" > <a name="583">583</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> warn "Could not eval '$eval' in $parsefile: $@" if $@; </td> </tr> <tr> <td class="h" > <a name="584">584</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last; </td> </tr> <tr> <td class="h" > <a name="585">585</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="586">586</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> close $fh; </td> </tr> <tr> <td class="h" > <a name="587">587</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return $version; </td> </tr> <tr> <td class="h" > <a name="588">588</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="589">589</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="590">590</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item parse_abstract </td> </tr> <tr> <td class="h" > <a name="591">591</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="592">592</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Attempt to obtain an abstract from a module file. </td> </tr> <tr> <td class="h" > <a name="593">593</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="594">594</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $package = 'CPAN'; </td> </tr> <tr> <td class="h" > <a name="595">595</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $file = 'C:/Perl/lib/CPAN.pm'; </td> </tr> <tr> <td class="h" > <a name="596">596</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $abstract = parse_abstract($package, $file); </td> </tr> <tr> <td class="h" > <a name="597">597</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="598">598</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="599">599</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="600">600</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub parse_abstract { </td> </tr> <tr> <td class="h" > <a name="601">601</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($package, $file) = @_; </td> </tr> <tr> <td class="h" > <a name="602">602</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $basename = basename($file, qr/\.\w+$/); </td> </tr> <tr> <td class="h" > <a name="603">603</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> (my $stripped = $basename) =~ s!\.\w+$!!; </td> </tr> <tr> <td class="h" > <a name="604">604</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> (my $trans = $package) =~ s!-!::!g; </td> </tr> <tr> <td class="h" > <a name="605">605</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $result; </td> </tr> <tr> <td class="h" > <a name="606">606</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $inpod = 0; </td> </tr> <tr> <td class="h" > <a name="607">607</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> open(my $fh, '<', $file) or die "Couldn't open $file: $!"; </td> </tr> <tr> <td class="h" > <a name="608">608</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> while (<$fh>) { </td> </tr> <tr> <td class="h" > <a name="609">609</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; </td> </tr> <tr> <td class="h" > <a name="610">610</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next if !$inpod; </td> </tr> <tr> <td class="h" > <a name="611">611</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> chop; </td> </tr> <tr> <td class="h" > <a name="612">612</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> next unless /^\s*($package|$basename|$stripped|$trans)\s+--*\s+(.*)/; </td> </tr> <tr> <td class="h" > <a name="613">613</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $result = $2; </td> </tr> <tr> <td class="h" > <a name="614">614</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> last; </td> </tr> <tr> <td class="h" > <a name="615">615</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="616">616</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> close($fh); </td> </tr> <tr> <td class="h" > <a name="617">617</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return unless $result; </td> </tr> <tr> <td class="h" > <a name="618">618</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> chomp($result); </td> </tr> <tr> <td class="h" > <a name="619">619</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return $result; </td> </tr> <tr> <td class="h" > <a name="620">620</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="621">621</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="622">622</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item cpan_file { </td> </tr> <tr> <td class="h" > <a name="623">623</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="624">624</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Given a file of the form C<file.tar.gz> and a CPAN id </td> </tr> <tr> <td class="h" > <a name="625">625</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> of the form <ABCDEFG>, will return the CPAN file </td> </tr> <tr> <td class="h" > <a name="626">626</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> C<A/AB/ABCDEFG/file.tar.gz>. </td> </tr> <tr> <td class="h" > <a name="627">627</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="628">628</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $cpanid = 'GBARR'; </td> </tr> <tr> <td class="h" > <a name="629">629</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $file = 'libnet-1.23.tar.gz'; </td> </tr> <tr> <td class="h" > <a name="630">630</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $cpan_file = cpan_file($cpanid, $file); </td> </tr> <tr> <td class="h" > <a name="631">631</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="632">632</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="633">633</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="634">634</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub cpan_file { </td> </tr> <tr> <td class="h" > <a name="635">635</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($cpanid, $file) = @_; </td> </tr> <tr> <td class="h" > <a name="636">636</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return $file if $file =~ m!/!; </td> </tr> <tr> <td class="h" > <a name="637">637</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> (my $cpan_loc = $cpanid) =~ s{^(\w)(\w)(.*)}{$1/$1$2/$1$2$3}; </td> </tr> <tr> <td class="h" > <a name="638">638</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return qq{$cpan_loc/$file}; </td> </tr> <tr> <td class="h" > <a name="639">639</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="640">640</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="641">641</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item url_list </td> </tr> <tr> <td class="h" > <a name="642">642</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="643">643</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Gets a list of CPAN mirrors, incorporating any from CPAN.pm. </td> </tr> <tr> <td class="h" > <a name="644">644</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="645">645</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @list = url_list(); </td> </tr> <tr> <td class="h" > <a name="646">646</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="647">647</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="648">648</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="649">649</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub url_list { </td> </tr> <tr> <td class="h" > <a name="650">650</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my @urls; </td> </tr> <tr> <td class="h" > <a name="651">651</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if (HAS_CPAN and defined $CPAN::Config->{urllist} and </td> </tr> <tr> <td class="h" > <a name="652">652</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> ref($CPAN::Config->{urllist}) eq 'ARRAY') { </td> </tr> <tr> <td class="h" > <a name="653">653</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @urls, @{$CPAN::Config->{urllist}}; </td> </tr> <tr> <td class="h" > <a name="654">654</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="655">655</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @urls, 'ftp://ftp.cpan.org', 'http://www.cpan.org'; </td> </tr> <tr> <td class="h" > <a name="656">656</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> return @urls; </td> </tr> <tr> <td class="h" > <a name="657">657</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="658">658</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="659">659</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =item mirror </td> </tr> <tr> <td class="h" > <a name="660">660</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="661">661</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Gets a file from a remote source and store it to a local file. </td> </tr> <tr> <td class="h" > <a name="662">662</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="663">663</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $success = getstore($url, $file); </td> </tr> <tr> <td class="h" > <a name="664">664</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="665">665</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> =cut </td> </tr> <tr> <td class="h" > <a name="666">666</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="667">667</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub mirror { </td> </tr> <tr> <td class="h" > <a name="668">668</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my ($url, $file) = @_; </td> </tr> <tr> <td class="h" > <a name="669">669</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $ua = HTTP::Tiny->new(agent => "PPM-Make/$VERSION"); </td> </tr> <tr> <td class="h" > <a name="670">670</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $res = $ua->mirror($url, $file); </td> </tr> <tr> <td class="h" > <a name="671">671</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $res->{success} ? 1 : 0; </td> </tr> <tr> <td class="h" > <a name="672">672</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="673">673</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="674">674</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> 1; </td> </tr> <tr> <td class="h" > <a name="675">675</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="676">676</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> __END__ </td> </tr> </table> </body> </html>