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   23 use strict;
  6         7  
  6         147  
3 6     6   20 use warnings;
  6         7  
  6         130  
4 6     6   19 use base qw(Exporter);
  6         7  
  6         543  
5 6     6   26 use File::Basename;
  6         9  
  6         374  
6 6     6   454 use Safe;
  6         26049  
  6         175  
7 6     6   5942 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             use HTML::Entities;
15              
16             =head1 NAME
17              
18             PPM::Make::Util - Utility functions for PPM::Make
19              
20             =head1 SYNOPSIS
21              
22             use PPM::Make::Util qw(:all);
23              
24             =head1 DESCRIPTION
25              
26             This module contains a number of utility functions used by PPM::Make.
27              
28             =over 2
29              
30             =cut
31              
32             our $VERSION = '0.9904';
33              
34             our (@EXPORT_OK, %EXPORT_TAGS, $protocol, $ext, $src_dir, $build_dir,
35             @url_list, $ERROR);
36             $protocol = qr{^(http|ftp)://};
37             $ext = qr{\.(tar\.gz|tar\.bz2|tgz|tar\.Z|zip)};
38             @url_list = url_list();
39              
40             my @exports = qw(load_cs verifyMD5 verifySHA256 parse_version $ERROR
41             is_core is_ap_core url_list
42             parse_ppd parse_abstract
43             ppd2cpan_version cpan2ppd_version
44             file_to_dist cpan_file fix_path
45             mirror encode_non_ascii_chars
46             $src_dir $build_dir @url_list);
47              
48             %EXPORT_TAGS = (all => [@exports]);
49             @EXPORT_OK = (@exports);
50              
51             my %ap_core = map {$_ => 1} qw(
52             Archive-Tar
53             Archive-Zip
54             Compress-Zlib
55             Data-Dump
56             Digest-HMAC
57             Digest-MD2
58             Digest-MD4
59             Digest-SHA1
60             File-CounterFile
61             Font-AFM
62             HTML-Parser
63             HTML-Tagset
64             HTML-Tree
65             IO-String
66             IO-Zlib
67             libwin32
68             libwww-perl
69             MD5
70             MIME-Base64-Scripts
71             SOAP-Lite
72             Term-ReadLine-Perl
73             TermReadKey
74             Text-Autoformat
75             Text-Reform
76             Tk
77             Unicode-String
78             URI
79             XML-Parser
80             XML-Simple );
81              
82             if (WIN32 and ACTIVEPERL and eval { Win32::BuildNumber() > 818 }) {
83             $ap_core{'DBI'}++; $ap_core{'DBD-SQLite'}++;
84             }
85             src_and_build();
86              
87             my %dists;
88              
89             =item fix_path
90              
91             Ensures a path is a Unix-type path, with no spaces.
92              
93             my $path = 'C:\Program Files\';
94             my $unix_version = fix_path($path);
95              
96             =cut
97              
98             sub fix_path {
99             my $path = shift;
100             $path = Win32::GetShortPathName($path);
101             $path =~ s!\\!/!g;
102             $path =~ s!/$!!;
103             return $path;
104             }
105              
106             =item load_cs
107              
108             Loads a CHECKSUMS file into $cksum
109             (adapted from the MD5 check of CPAN.pm)
110              
111             my $cksum = load_cs('CHECKSUMS');
112              
113             =cut
114              
115             sub load_cs {
116             my $cs = shift;
117             open(my $fh, '<', $cs);
118             unless ($fh) {
119             $ERROR = qq{Could not open "$cs": $!};
120             return;
121             }
122             local($/);
123             my $eval = <$fh>;
124             close $fh;
125             $eval =~ s/\015?\012/\n/g;
126             my $comp = Safe->new();
127             my $cksum = $comp->reval($eval);
128             if ($@) {
129             $ERROR = qq{eval of "$cs" failed: $@};
130             return;
131             }
132             return $cksum;
133             }
134              
135             =item verifyMD5
136              
137             Verify a CHECKSUM for a $file
138              
139             my $ok = verifyMD5($cksum, $file);
140             print "$file checked out OK" if $ok;
141              
142             =cut
143              
144             sub verifyMD5 {
145             my ($cksum, $file) = @_;
146             my ($is, $should);
147             open (my $fh, '<', $file);
148             unless ($fh) {
149             $ERROR = qq{Cannot open "$file": $!};
150             return;
151             }
152             binmode($fh);
153             unless ($is = Digest::MD5->new->addfile($fh)->hexdigest) {
154             $ERROR = qq{Could not compute checksum for "$file": $!};
155             close $fh;
156             return;
157             }
158             close $fh;
159             if ($should = $cksum->{$file}->{md5}) {
160             my $test = ($is eq $should);
161             if (!$test && ($should = $cksum->{$file}->{'md5-ungz'})) {
162             $test = ($is eq $should);
163             }
164             printf qq{ Checksum for "$file" is %s\n},
165             ($test) ? 'OK.' : 'NOT OK.';
166             return $test;
167             }
168             else {
169             $ERROR = qq{Checksum data for "$file" not present.};
170             return;
171             }
172             }
173              
174             =item verifySHA256
175              
176             Verify a CHECKSUM for a $file
177              
178             my $ok = verifySHA256($cksum, $file);
179             print "$file checked out OK" if $ok;
180              
181             =cut
182              
183             sub verifySHA256 {
184             my ($cksum, $file) = @_;
185             my ($is, $should);
186             open (my $fh, '<', $file);
187             unless ($fh) {
188             $ERROR = qq{Cannot open "$file": $!};
189             return;
190             }
191             require Digest::SHA;
192             binmode($fh);
193             unless ($is = Digest::SHA->new(256)->addfile($fh)->hexdigest) {
194             $ERROR = qq{Could not compute checksum for "$file": $!};
195             close $fh;
196             return;
197             }
198             close $fh;
199             if ($should = $cksum->{$file}->{sha256}) {
200             my $test = ($is eq $should);
201             if (!$test && ($should = $cksum->{$file}->{'sha256-ungz'})) {
202             $test = ($is eq $should);
203             }
204             printf qq{ SHA256-Checksum for "$file" is %s\n},
205             ($test) ? 'OK.' : 'NOT OK.';
206             return $test;
207             }
208             else {
209             $ERROR = qq{Checksum data for "$file" not present.};
210             return;
211             }
212             }
213              
214             =item is_core
215              
216             Tests to see if a module is part of the core, based on
217             whether or not the file is found within a I type
218             of directory.
219              
220             my $is_core = is_core('Net::FTP');
221             print "Net::FTP is a core module" if $is_core;
222              
223             =cut
224              
225             sub is_core {
226             my $m = shift;
227             return unless $m;
228             $m =~ s!::|-!/!g;
229             $m .= '.pm';
230             my $is_core = (-e File::Spec->catfile($Config{privlibexp}, $m)) ? 1 : 0;
231             return $is_core;
232             }
233              
234             =item is_ap_core
235              
236             Tests to see if a package is part of the ActivePerl core (at
237             least for recent ActivePerl versions).
238              
239             my $is_ap_core = is_ap_core('libwin32');
240             print "libwin32 is a core package" if $is_ap_core;
241              
242             =cut
243              
244             sub is_ap_core {
245             my $p = shift;
246             return unless defined $p;
247             return defined $ap_core{$p} ? 1 : 0;
248             }
249              
250             =item file_to_dist
251              
252             In scalar context, returns a CPAN distribution name I based
253             on an input file I:
254              
255             my $file = 'A/AB/ABC/defg-1.23.tar.gz';
256             my $dist = file_to_dist($file);
257              
258             In a list context, returns both the distribution name I
259             and the version number I<1.23>:
260              
261             my $file = 'A/AB/ABC/defg-1.23.tar.gz';
262             my ($dist, $version) = file_to_dist($cpan_file);
263              
264              
265             =cut
266              
267             sub file_to_dist {
268             my $cpan_file = shift;
269             return unless $cpan_file;
270             my $d = CPAN::DistnameInfo->new($cpan_file);
271             my ($dist, $version) = ($d->dist, $d->version);
272             unless ($dist and $version) {
273             $ERROR = qq{Could not find distribution name from $cpan_file.};
274             return;
275             }
276             return wantarray? ($dist, $version) : $dist;
277             }
278              
279             =item ppd2cpan_version
280              
281             Converts a ppd-type of version string (eg, I<1,23,0,0>) into a ppd one
282             of the form I<1.23>:
283              
284             my $s = "1,23,0,0";
285             my $v = ppd2cpan_version($v);
286              
287             =cut
288              
289             sub ppd2cpan_version {
290             local $_ = shift;
291             s/(,0)*$//;
292             tr/,/./;
293             return $_;
294             }
295              
296             =item cpan2ppd_version
297              
298             Converts a cpan-type of version string (eg, I<1.23>) into a ppd one
299             of the form I<1,23,0,0>:
300              
301             my $v = 1.23;
302             my $s = cpan2ppd_version($v);
303              
304             =cut
305              
306             sub cpan2ppd_version {
307             local $_ = shift;
308             return join ',', (split (/\./, $_), (0)x4)[0..3];
309             }
310              
311              
312             =item parse_ppd
313              
314             Parse a I file or a string.
315              
316             my $ppd = 'package.ppd';
317             my $d = parse_ppd($ppd);
318             print $d->{ABSTRACT};
319             print $d->{OS}->{NAME};
320              
321             my $e = parse_ppd($ppd, 'MSWin32-x86-multi-thread');
322             print $e->{ABSTRACT};
323              
324             This routine takes a required argument of a I file containing
325             a I<.ppd> extension or a string and,
326             optionally, an ARCHITECTURE name to restrict the results to.
327             It returns a data structure containing the information of
328             the ppd file or string:
329              
330             $d->{SOFTPKG}->{NAME}
331             $d->{SOFTPKG}->{VERSION}
332             $d->{TITLE}
333             $d->{AUTHOR}
334             $d->{ABSTRACT}
335             $d->{PROVIDE}
336             $d->{DEPENDENCY}
337             $d->{REQUIRE}
338             $d->{OS}->{NAME}
339             $d->{ARCHITECTURE}->{NAME}
340             $d->{CODEBASE}->{HREF}
341             $d->{INSTALL}->{EXEC}
342             $d->{INSTALL}->{SCRIPT}
343             $d->{INSTALL}->{HREF}
344              
345             The I, I and I tags are array references
346             containing lists of, respectively, the prerequisites required and
347             the modules supplied by the package, with keys of I and
348             I.
349              
350             If there is more than one I section in the
351             ppd file, all the results except for the I elements and
352             I, I<AUTHOR>, and I<ABSTRACT> will be placed in </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"> a I<$d-E<gt>{IMPLENTATION}> array </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"> reference. If an optional second argument is passed to </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"> I<parse_ppd($file, $arch)>, this will filter out all implementation </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"> sections except for the specified I<ARCHITECTURE> given by I<$arch>. </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">   </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"> =cut </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">   </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"> my $i; </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">   </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"> sub parse_ppd { </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 $file = 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 $arch = shift; </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"> my $is_a_file = ($file =~ /\.ppd/); </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"> if ($is_a_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"> unless (-e $file) { </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"> $ERROR = qq{$file not found.}; </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"> return; </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"> } </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"> my $p = XML::Parser->new(Style => 'Subs', </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"> Handlers => {Char => \&ppd_char, </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"> Start => \&ppd_start, </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"> End => \&ppd_end, </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"> Init => \&ppd_init, </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"> Final => \&ppd_final, </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"> ); </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 $d = $is_a_file ? $p->parsefile($file) : $p->parse($file); </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 $implem = $d->{IMPLEMENTATION}; </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"> my $size = scalar @$implem; </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"> if ($size == 1) { </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->{PROVIDE} = $implem->[0]->{PROVIDE} || []; </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->{DEPENDENCY} = $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->{REQUIRE} = $implem->[0]->{DEPENDENCY} || []; </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->{OS}->{NAME} = $implem->[0]->{OS}->{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->{ARCHITECTURE}->{NAME} = $implem->[0]->{ARCHITECTURE}->{NAME} || ''; </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->{CODEBASE}->{HREF} = $implem->[0]->{CODEBASE}->{HREF}; </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}->{EXEC} = $implem->[0]->{INSTALL}->{EXEC}; </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}->{SCRIPT} = $implem->[0]->{INSTALL}->{SCRIPT}; </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"> $d->{INSTALL}->{HREF} = $implem->[0]->{INSTALL}->{HREF}; </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"> } </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"> elsif (defined $arch) { </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 $flag = 0; </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"> my $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"> for ($i=0; $i<$size; $i++) { </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"> if ($implem->[$i]->{ARCHITECTURE}->{NAME} eq $arch) { </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"> $flag++; </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"> last; </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"> } </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"> return unless $flag; </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->{PROVIDE} = $implem->[$i]->{PROVIDE} || []; </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->{DEPENDENCY} = $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->{REQUIRE} = $implem->[$i]->{DEPENDENCY} || []; </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->{OS}->{NAME} = $implem->[$i]->{OS}->{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->{ARCHITECTURE}->{NAME} = $implem->[$i]->{ARCHITECTURE}->{NAME} || ''; </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->{CODEBASE}->{HREF} = $implem->[$i]->{CODEBASE}->{HREF}; </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}->{EXEC} = $implem->[$i]->{INSTALL}->{EXEC}; </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}->{SCRIPT} = $implem->[$i]->{INSTALL}->{SCRIPT}; </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"> $d->{INSTALL}->{HREF} = $implem->[$i]->{INSTALL}->{HREF}; </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"> } </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"> return $d; </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">   </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"> sub ppd_init { </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"> my $self = shift; </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"> $i = 0; </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"> $self->{_mydata} = { </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"> SOFTPKG => {NAME => '', VERSION => ''}, </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"> TITLE => '', </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"> AUTHOR => '', </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"> ABSTRACT => '', </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"> PROVIDE => [], </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"> IMPLEMENTATION => [], </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"> OS => {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"> ARCHITECTURE => {NAME => ''}, </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"> CODEBASE => {HREF => ''}, </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"> DEPENDENCY => [], </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"> REQUIRE => [], </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"> INSTALL => {EXEC => '', SCRIPT => '', HREF => ''}, </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"> wanted => {TITLE => 1, ABSTRACT => 1, AUTHOR => 1}, </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"> _current => '', </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">   </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"> sub ppd_start { </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 ($self, $tag, %attrs) = @_; </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"> my $internal = $self->{_mydata}; </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"> $internal->{_current} = $tag; </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"> SWITCH: { </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"> ($tag eq 'SOFTPKG') and do { </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}->{NAME} = $attrs{NAME}; </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"> $internal->{SOFTPKG}->{VERSION} = $attrs{VERSION}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'PROVIDE') and do { </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 $name = $attrs{NAME}; </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"> my $version = $attrs{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"> if ($version) { </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"> push @{$internal->{IMPLEMENTATION}->[$i]->{PROVIDE}}, </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"> {NAME => $name, VERSION => $version}; </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"> } </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"> else { </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"> push @{$internal->{IMPLEMENTATION}->[$i]->{PROVIDE}}, </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"> {NAME => $name}; </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"> } </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"> last SWITCH; </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"> }; </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"> ($tag eq 'CODEBASE') and do { </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"> $internal->{IMPLEMENTATION}->[$i]->{CODEBASE}->{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"> $attrs{HREF}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'OS') and do { </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"> $internal->{IMPLEMENTATION}->[$i]->{OS}->{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"> $attrs{NAME}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'ARCHITECTURE') and do { </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"> $internal->{IMPLEMENTATION}->[$i]->{ARCHITECTURE}->{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"> $attrs{NAME}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'INSTALL') and do { </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"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{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"> $attrs{EXEC}; </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"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{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"> $attrs{HREF}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'DEPENDENCY') and do { </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"> push @{$internal->{IMPLEMENTATION}->[$i]->{DEPENDENCY}}, </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"> {NAME => $attrs{NAME}, VERSION => $attrs{VERSION}}; </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"> last SWITCH; </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"> }; </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"> ($tag eq 'REQUIRE') and do { </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"> push @{$internal->{IMPLEMENTATION}->[$i]->{REQUIRE}}, </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"> {NAME => $attrs{NAME}, VERSION => $attrs{VERSION}}; </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"> last SWITCH; </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">   </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"> sub ppd_char { </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 ($self, $string) = @_; </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 $internal = $self->{_mydata}; </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"> my $tag = $internal->{_current}; </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"> if ($tag and $internal->{wanted}->{$tag}) { </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"> $internal->{$tag} .= $string; </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"> } </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"> elsif ($tag and $tag eq 'INSTALL') { </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"> $internal->{IMPLEMENTATION}->[$i]->{INSTALL}->{SCRIPT} .= $string; </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"> } </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"> else { </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">   </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"> sub ppd_end { </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"> my ($self, $tag) = @_; </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"> $i++ if ($tag eq 'IMPLEMENTATION'); </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"> delete $self->{_mydata}->{_current}; </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">   </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"> sub ppd_final { </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"> my $self = shift; </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"> return $self->{_mydata}; </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">   </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"> =item src_and_build </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">   </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"> Returns the source and build directories used with </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"> CPAN.pm, if present. If not, returns those used with PPM, </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"> if those are present. If neither of these are available, </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"> returns the system temp directory. </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">   </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"> my ($src_dir, $build_dir)= src_and_build; </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">   </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"> =cut </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">   </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"> sub src_and_build { </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"> return if ($src_dir and $build_dir); </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"> SWITCH: { </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"> HAS_CPAN and do { </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"> $src_dir = $CPAN::Config->{keep_source_where}; </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"> $build_dir = $CPAN::Config->{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"> last SWITCH if ($src_dir and $build_dir); </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"> }; </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"> $src_dir = File::Spec->tmpdir() || '.'; </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"> $build_dir = $src_dir; </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">   </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"> =item parse_version </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">   </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"> Extracts a version string from a module file. </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">   </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"> my $version = parse_version('C:/Perl/lib/CPAN.pm'); </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">   </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"> =cut </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">   </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"> # from ExtUtils::MM_Unix </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"> sub parse_version { </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"> my $parsefile = shift; </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"> return unless -e $parsefile; </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"> my $version; </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"> local $/ = "\n"; </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"> my $fh; </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"> unless (open($fh, '<', $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"> $ERROR = "Could not open '$parsefile': $!"; </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"> return; </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"> } </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"> my $inpod = 0; </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"> while (<$fh>) { </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"> $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; </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"> next if $inpod || /^\s*\#/; </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"> chop; </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"> next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; </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"> my $eval = qq{ </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"> package # hide from PAUSE </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"> ExtUtils::MakeMaker::_version; </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"> no strict; </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"> </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"> local $1$2; </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"> \$$2=undef; do { </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"> $_; </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"> return \$$2; </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"> }; </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"> local $^W = 0; </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"> $version = eval($eval); </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"> warn "Could not eval '$eval' in $parsefile: $@" if $@; </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"> last; </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"> } </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"> close $fh; </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"> return $version; </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">   </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"> =item parse_abstract </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">   </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"> Attempt to obtain an abstract from a module file. </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">   </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 $package = 'CPAN'; </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 $file = 'C:/Perl/lib/CPAN.pm'; </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"> my $abstract = parse_abstract($package, $file); </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">   </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"> =cut </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">   </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"> sub parse_abstract { </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 ($package, $file) = @_; </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 $basename = basename($file, qr/\.\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 $stripped = $basename) =~ s!\.\w+$!!; </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 $trans = $package) =~ s!-!::!g; </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 $result; </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"> my $inpod = 0; </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"> open(my $fh, '<', $file) or die "Couldn't open $file: $!"; </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"> while (<$fh>) { </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"> $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $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"> next if !$inpod; </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"> chop; </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"> next unless /^\s*($package|$basename|$stripped|$trans)\s+--*\s+(.*)/; </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"> $result = $2; </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"> last; </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"> } </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"> close($fh); </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"> return unless $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"> chomp($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"> return $result; </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">   </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"> =item cpan_file { </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">   </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"> Given a file of the form C<file.tar.gz> and a CPAN id </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"> of the form <ABCDEFG>, will return the CPAN file </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"> C<A/AB/ABCDEFG/file.tar.gz>. </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">   </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 $cpanid = 'GBARR'; </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 $file = 'libnet-1.23.tar.gz'; </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"> my $cpan_file = cpan_file($cpanid, $file); </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">   </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"> =cut </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">   </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"> sub cpan_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"> my ($cpanid, $file) = @_; </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"> return $file if $file =~ m!/!; </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"> (my $cpan_loc = $cpanid) =~ s{^(\w)(\w)(.*)}{$1/$1$2/$1$2$3}; </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"> return qq{$cpan_loc/$file}; </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">   </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"> =item url_list </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">   </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"> Gets a list of CPAN mirrors, incorporating any from CPAN.pm. </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">   </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"> my @list = url_list(); </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">   </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"> =cut </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">   </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"> sub url_list { </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"> my @urls; </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"> if (HAS_CPAN and defined $CPAN::Config->{urllist} and </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"> ref($CPAN::Config->{urllist}) eq 'ARRAY') { </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"> push @urls, @{$CPAN::Config->{urllist}}; </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"> } </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"> push @urls, 'ftp://ftp.cpan.org', 'http://www.cpan.org'; </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"> return @urls; </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">   </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"> =item mirror </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">   </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"> Gets a file from a remote source and store it to a local file. </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">   </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"> my $success = getstore($url, $file); </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">   </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"> =cut </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">   </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"> sub mirror { </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 ($url, $file) = @_; </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 $ua = HTTP::Tiny->new(agent => "PPM-Make/$VERSION"); </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"> my $res = $ua->mirror($url, $file); </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"> $res->{success} ? 1 : 0; </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">   </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"> =item encode_non_ascii_chars </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">   </td> </tr> <tr> <td class="h" > <a name="677">677</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> Encodes non-ascii characters. </td> </tr> <tr> <td class="h" > <a name="678">678</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="679">679</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $encoded = encode_non_ascii_chars($non_ascii_string); </td> </tr> <tr> <td class="h" > <a name="680">680</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="681">681</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="682">682</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="683">683</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub encode_non_ascii_chars { </td> </tr> <tr> <td class="h" > <a name="684">684</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $string = shift; </td> </tr> <tr> <td class="h" > <a name="685">685</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> HTML::Entities::encode_entities_numeric($string, '^\n\x20-\x25\x26-\x7e'); </td> </tr> <tr> <td class="h" > <a name="686">686</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="687">687</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="688">688</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="689">689</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="690">690</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> __END__ </td> </tr> </table> </body> </html>