File Coverage

blib/lib/Module/Build/PPMMaker.pm
Criterion Covered Total %
statement 55 65 84.6
branch 8 20 40.0
condition 1 3 33.3
subroutine 8 8 100.0
pod 0 2 0.0
total 72 98 73.4


line stmt bran cond sub pod time code
1             package Module::Build::PPMMaker;
2              
3 2     2   16 use strict;
  2         14  
  2         114  
4 2     2   24 use warnings;
  2         6  
  2         168  
5 2     2   24 use Config;
  2         16  
  2         2282  
6              
7             our $VERSION = '0.42_35';
8             $VERSION = eval $VERSION;
9              
10             # This code is mostly borrowed from ExtUtils::MM_Unix 6.10_03, with a
11             # few tweaks based on the PPD spec at
12             # http://www.xav.com/perl/site/lib/XML/PPD.html
13              
14             # The PPD spec is based on
15              
16             sub new {
17 5     5 0 19 my $package = shift;
18 5         38 return bless {@_}, $package;
19             }
20              
21             sub make_ppd {
22 5     5 0 59 my ($self, %args) = @_;
23 5         19 my $build = delete $args{build};
24              
25 5         14 my @codebase;
26 5 100       36 if (exists $args{codebase}) {
27 2 50       28 @codebase = ref $args{codebase} ? @{$args{codebase}} : ($args{codebase});
  0         0  
28             } else {
29 3         36 my $distfile = $build->ppm_name . '.tar.gz';
30 3         937 print "Using default codebase '$distfile'\n";
31 3         43 @codebase = ($distfile);
32             }
33              
34 5         19 my %dist;
35 5         31 foreach my $info (qw(name author abstract version)) {
36 20         79 my $method = "dist_$info";
37 20 50       186 $dist{$info} = $build->$method() or die "Can't determine distribution's $info\n";
38             }
39              
40 5         21 $self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}};
  5         70  
41              
42             # TODO: could add tag if we knew what the URLs were for
43             # various licenses
44 5         42 my $ppd = <<"PPD";
45            
46             $dist{abstract}
47 5         15 @{[ join "\n", map " $_", @{$dist{author}} ]}
  5         47  
48            
49             PPD
50              
51             # We don't include recommended dependencies because PPD has no way
52             # to distinguish them from normal dependencies. We don't include
53             # build_requires dependencies because the PPM installer doesn't
54             # build or test before installing. And obviously we don't include
55             # conflicts either.
56              
57 5         20 foreach my $type (qw(requires)) {
58 5         94 my $prereq = $build->$type();
59 5         34 foreach my $modname (sort keys %$prereq) {
60 0 0       0 next if $modname eq 'perl';
61              
62 0         0 my $min_version = '0.0';
63 0         0 foreach my $c ($build->_parse_conditions($prereq->{$modname})) {
64 0         0 my ($op, $version) = $c =~ /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x;
65              
66             # This is a nasty hack because it fails if there is no >= op
67 0 0       0 if ($op eq '>=') {
68 0         0 $min_version = $version;
69 0         0 last;
70             }
71             }
72              
73             # PPM4 spec requires a '::' for top level modules
74 0 0       0 $modname .= '::' unless $modname =~ /::/;
75              
76 0         0 $ppd .= qq! \n!;
77             }
78             }
79              
80             # We only include these tags if this module involves XS, on the
81             # assumption that pure Perl modules will work on any OS.
82 5 50       9 if (keys %{$build->find_xs_files}) {
  5         78  
83 5         65 my $perl_version = $self->_ppd_version($build->perl_version);
84 5         57 $ppd .= sprintf(<<'EOF', $self->_varchname($build->config) );
85            
86             EOF
87             }
88              
89 5         616 foreach my $codebase (@codebase) {
90 5         34 $self->_simple_xml_escape($codebase);
91 5         32 $ppd .= sprintf(<<'EOF', $codebase);
92            
93             EOF
94             }
95              
96 5         27 $ppd .= <<'EOF';
97            
98            
99             EOF
100              
101 5         24 my $ppd_file = "$dist{name}.ppd";
102 5 50       525 open(my $fh, '>', $ppd_file)
103             or die "Cannot write to $ppd_file: $!";
104              
105             binmode($fh, ":utf8")
106 5 50 33     179 if $] >= 5.008 && $Config{useperlio};
107 5         436 print $fh $ppd;
108 5         393 close $fh;
109              
110 5         73 return $ppd_file;
111             }
112              
113             sub _ppd_version {
114 7     7   35 my ($self, $version) = @_;
115              
116             # generates something like "0,18,0,0"
117 7         60 return join ',', (split(/\./, $version), (0)x4)[0..3];
118             }
119              
120             sub _varchname { # Copied from PPM.pm
121 7     7   61 my ($self, $config) = @_;
122 7         21 my $varchname = $config->{archname};
123             # Append "-5.8" to architecture name for Perl 5.8 and later
124 7 50       33 if ($] >= 5.008) {
125 7         76 my $vstring = sprintf "%vd", $^V;
126 7         58 $vstring =~ s/\.\d+$//;
127 7         27 $varchname .= "-$vstring";
128             }
129 7         33 return $varchname;
130             }
131              
132             {
133             my %escapes = (
134             "\n" => "\\n",
135             '"' => '"',
136             '&' => '&',
137             '>' => '>',
138             '<' => '<',
139             );
140             my $rx = join '|', keys %escapes;
141              
142             sub _simple_xml_escape {
143 15     15   141 $_[1] =~ s/($rx)/$escapes{$1}/go;
144             }
145             }
146              
147             1;
148             __END__