File Coverage

lib/ExtUtils/Command/MM.pm
Criterion Covered Total %
statement 18 65 27.7
branch 5 20 25.0
condition 0 9 0.0
subroutine 3 8 37.5
total 26 102 25.5


line stmt bran cond sub time code
1           package ExtUtils::Command::MM;
2            
3           require 5.006;
4            
5 2     2 145543 use strict;
  2       7  
  2       87  
6 2     2 11 use warnings;
  2       4  
  2       2877  
7            
8           require Exporter;
9           our @ISA = qw(Exporter);
10            
11           our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
12           warn_if_old_packlist);
13           our $VERSION = '6.74';
14            
15           my $Is_VMS = $^O eq 'VMS';
16            
17           eval "require Time::HiRes";
18           *mtime = $@ ?
19           sub { [ stat($_[0])]->[9] } :
20 0     0 0 sub { [Time::HiRes::stat($_[0])]->[9] } ;
21            
22           =head1 NAME
23            
24           ExtUtils::Command::MM - Commands for the MM's to use in Makefiles
25            
26           =head1 SYNOPSIS
27            
28           perl "-MExtUtils::Command::MM" -e "function" "--" arguments...
29            
30            
31           =head1 DESCRIPTION
32            
33           B The interface is not stable.
34            
35           ExtUtils::Command::MM encapsulates code which would otherwise have to
36           be done with large "one" liners.
37            
38           Any $(FOO) used in the examples are make variables, not Perl.
39            
40           =over 4
41            
42           =item B
43            
44           test_harness($verbose, @test_libs);
45            
46           Runs the tests on @ARGV via Test::Harness passing through the $verbose
47           flag. Any @test_libs will be unshifted onto the test's @INC.
48            
49           @test_libs are run in alphabetical order.
50            
51           =cut
52            
53           sub test_harness {
54 0     0 0 require Test::Harness;
55 0       0 require File::Spec;
56            
57 0       0 $Test::Harness::verbose = shift;
58            
59           # Because Windows doesn't do this for us and listing all the *.t files
60           # out on the command line can blow over its exec limit.
61 0       0 require ExtUtils::Command;
62 0       0 my @argv = ExtUtils::Command::expand_wildcards(@ARGV);
63            
64 0       0 local @INC = @INC;
65 0       0 unshift @INC, map { File::Spec->rel2abs($_) } @_;
  0       0  
66 0       0 Test::Harness::runtests(sort { lc $a cmp lc $b } @argv);
  0       0  
67           }
68            
69            
70            
71           =item B
72            
73           pod2man( '--option=value',
74           $podfile1 => $manpage1,
75           $podfile2 => $manpage2,
76           ...
77           );
78            
79           # or args on @ARGV
80            
81           pod2man() is a function performing most of the duties of the pod2man
82           program. Its arguments are exactly the same as pod2man as of 5.8.0
83           with the addition of:
84            
85           --perm_rw octal permission to set the resulting manpage to
86            
87           And the removal of:
88            
89           --verbose/-v
90           --help/-h
91            
92           If no arguments are given to pod2man it will read from @ARGV.
93            
94           If Pod::Man is unavailable, this function will warn and return undef.
95            
96           =cut
97            
98           sub pod2man {
99 2 100   2 143552 local @ARGV = @_ ? @_ : @ARGV;
100            
101           {
102 2       6 local $@;
  2       5  
103 2 100     6 if( !eval { require Pod::Man } ) {
  2       767  
104 1       24 warn "Pod::Man is not available: $@".
105           "Man pages will not be generated during this install.\n";
106 1       14 return 0;
107           }
108           }
109 1       64237 require Getopt::Long;
110            
111           # We will cheat and just use Getopt::Long. We fool it by putting
112           # our arguments into @ARGV. Should be safe.
113 1       15770 my %options = ();
114 1       5 Getopt::Long::config ('bundling_override');
115 1       39 Getopt::Long::GetOptions (\%options,
116           'section|s=s', 'release|r=s', 'center|c=s',
117           'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
118           'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
119           'name|n=s', 'perm_rw=i'
120           );
121            
122           # If there's no files, don't bother going further.
123 1 50     1252 return 0 unless @ARGV;
124            
125           # Official sets --center, but don't override things explicitly set.
126 0 0 0     if ($options{official} && !defined $options{center}) {
127 0         $options{center} = q[Perl Programmer's Reference Guide];
128           }
129            
130           # This isn't a valid Pod::Man option and is only accepted for backwards
131           # compatibility.
132 0         delete $options{lax};
133            
134 0         do {{ # so 'next' works
135 0         my ($pod, $man) = splice(@ARGV, 0, 2);
  0          
136            
137 0 0 0     next if ((-e $man) &&
      0      
138           (mtime($man) > mtime($pod)) &&
139           (mtime($man) > mtime("Makefile")));
140            
141 0         print "Manifying $man\n";
142            
143 0         my $parser = Pod::Man->new(%options);
144           $parser->parse_from_file($pod, $man)
145 0 0       or do { warn("Could not install $man\n"); next };
  0          
  0          
146            
147 0 0       if (exists $options{perm_rw}) {
148           chmod(oct($options{perm_rw}), $man)
149 0 0       or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
  0          
  0          
150           }
151           }} while @ARGV;
152            
153 0         return 1;
154           }
155            
156            
157           =item B
158            
159           perl "-MExtUtils::Command::MM" -e warn_if_old_packlist
160            
161           Displays a warning that an old packlist file was found. Reads the
162           filename from @ARGV.
163            
164           =cut
165            
166           sub warn_if_old_packlist {
167 0     0   my $packlist = $ARGV[0];
168            
169 0 0       return unless -f $packlist;
170 0         print <<"PACKLIST_WARNING";
171           WARNING: I have found an old package in
172           $packlist.
173           Please make sure the two installations are not conflicting
174           PACKLIST_WARNING
175            
176           }
177            
178            
179           =item B
180            
181           perl "-MExtUtils::Command::MM" -e perllocal_install
182           ...
183            
184           # VMS only, key|value pairs come on STDIN
185           perl "-MExtUtils::Command::MM" -e perllocal_install
186           < | ...
187            
188           Prints a fragment of POD suitable for appending to perllocal.pod.
189           Arguments are read from @ARGV.
190            
191           'type' is the type of what you're installing. Usually 'Module'.
192            
193           'module name' is simply the name of your module. (Foo::Bar)
194            
195           Key/value pairs are extra information about the module. Fields include:
196            
197           installed into which directory your module was out into
198           LINKTYPE dynamic or static linking
199           VERSION module version number
200           EXE_FILES any executables installed in a space seperated
201           list
202            
203           =cut
204            
205           sub perllocal_install {
206 0     0   my($type, $name) = splice(@ARGV, 0, 2);
207            
208           # VMS feeds args as a piped file on STDIN since it usually can't
209           # fit all the args on a single command line.
210 0 0       my @mod_info = $Is_VMS ? split /\|/,
211           : @ARGV;
212            
213 0         my $pod;
214 0         $pod = sprintf <
215           =head2 %s: C<$type> L<$name|$name>
216            
217           =over 4
218            
219           POD
220            
221 0         do {
222 0         my($key, $val) = splice(@mod_info, 0, 2);
223            
224 0         $pod .= <
225           =item *
226            
227           C<$key: $val>
228            
229           POD
230            
231           } while(@mod_info);
232            
233 0         $pod .= "=back\n\n";
234 0         $pod =~ s/^ //mg;
235 0         print $pod;
236            
237 0         return 1;
238           }
239            
240           =item B
241            
242           perl "-MExtUtils::Command::MM" -e uninstall
243            
244           A wrapper around ExtUtils::Install::uninstall(). Warns that
245           uninstallation is deprecated and doesn't actually perform the
246           uninstallation.
247            
248           =cut
249            
250           sub uninstall {
251 0     0   my($packlist) = shift @ARGV;
252            
253 0         require ExtUtils::Install;
254            
255 0         print <<'WARNING';
256            
257           Uninstall is unsafe and deprecated, the uninstallation was not performed.
258           We will show what would have been done.
259            
260           WARNING
261            
262 0         ExtUtils::Install::uninstall($packlist, 1, 1);
263            
264 0         print <<'WARNING';
265            
266           Uninstall is unsafe and deprecated, the uninstallation was not performed.
267           Please check the list above carefully, there may be errors.
268           Remove the appropriate files manually.
269           Sorry for the inconvenience.
270            
271           WARNING
272            
273           }
274            
275           =back
276            
277           =cut
278            
279           1;