This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Extutils-MakeMaker to CPAN version 6.80
[perl5.git] / cpan / ExtUtils-MakeMaker / lib / ExtUtils / Command / MM.pm
1 package ExtUtils::Command::MM;
2
3 require 5.006;
4
5 use strict;
6 use warnings;
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 test_s cp_nonempty);
13 our $VERSION = '6.80';
14
15 my $Is_VMS = $^O eq 'VMS';
16
17 eval {  require Time::HiRes; die unless Time::HiRes->can("stat"); };
18 *mtime = $@ ?
19  sub { [             stat($_[0])]->[9] } :
20  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<FOR INTERNAL USE ONLY!>  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<test_harness>
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     require Test::Harness;
55     require File::Spec;
56
57     $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     require ExtUtils::Command;
62     my @argv = ExtUtils::Command::expand_wildcards(@ARGV);
63
64     local @INC = @INC;
65     unshift @INC, map { File::Spec->rel2abs($_) } @_;
66     Test::Harness::runtests(sort { lc $a cmp lc $b } @argv);
67 }
68
69
70
71 =item B<pod2man>
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     local @ARGV = @_ ? @_ : @ARGV;
100
101     {
102         local $@;
103         if( !eval { require Pod::Man } ) {
104             warn "Pod::Man is not available: $@".
105                  "Man pages will not be generated during this install.\n";
106             return 0;
107         }
108     }
109     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     my %options = ();
114     Getopt::Long::config ('bundling_override');
115     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     return 0 unless @ARGV;
124
125     # Official sets --center, but don't override things explicitly set.
126     if ($options{official} && !defined $options{center}) {
127         $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     delete $options{lax};
133
134     do {{  # so 'next' works
135         my ($pod, $man) = splice(@ARGV, 0, 2);
136
137         next if ((-e $man) &&
138                  (mtime($man) > mtime($pod)) &&
139                  (mtime($man) > mtime("Makefile")));
140
141         print "Manifying $man\n";
142
143         my $parser = Pod::Man->new(%options);
144         $parser->parse_from_file($pod, $man)
145           or do { warn("Could not install $man\n");  next };
146
147         if (exists $options{perm_rw}) {
148             chmod(oct($options{perm_rw}), $man)
149               or do { warn("chmod $options{perm_rw} $man: $!\n"); next };
150         }
151     }} while @ARGV;
152
153     return 1;
154 }
155
156
157 =item B<warn_if_old_packlist>
158
159   perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile>
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     my $packlist = $ARGV[0];
168
169     return unless -f $packlist;
170     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<perllocal_install>
180
181     perl "-MExtUtils::Command::MM" -e perllocal_install
182         <type> <module name> <key> <value> ...
183
184     # VMS only, key|value pairs come on STDIN
185     perl "-MExtUtils::Command::MM" -e perllocal_install
186         <type> <module name> < <key>|<value> ...
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     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     my @mod_info = $Is_VMS ? split /\|/, <STDIN>
211                            : @ARGV;
212
213     my $pod;
214     $pod = sprintf <<POD, scalar localtime;
215  =head2 %s: C<$type> L<$name|$name>
216
217  =over 4
218
219 POD
220
221     do {
222         my($key, $val) = splice(@mod_info, 0, 2);
223
224         $pod .= <<POD
225  =item *
226
227  C<$key: $val>
228
229 POD
230
231     } while(@mod_info);
232
233     $pod .= "=back\n\n";
234     $pod =~ s/^ //mg;
235     print $pod;
236
237     return 1;
238 }
239
240 =item B<uninstall>
241
242     perl "-MExtUtils::Command::MM" -e uninstall <packlist>
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     my($packlist) = shift @ARGV;
252
253     require ExtUtils::Install;
254
255     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     ExtUtils::Install::uninstall($packlist, 1, 1);
263
264     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 =item B<test_s>
276
277    perl "-MExtUtils::Command::MM" -e test_s <file>
278
279 Tests if a file exists and is not empty (size > 0).
280 I<Exits> with 0 if it does, 1 if it does not.
281
282 =cut
283
284 sub test_s {
285   exit(-s $ARGV[0] ? 0 : 1);
286 }
287
288 =item B<cp_nonempty>
289
290   perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm>
291
292 Tests if the source file exists and is not empty (size > 0). If it is not empty
293 it copies it to the given destination with the given permissions.
294
295 =back
296
297 =cut
298
299 sub cp_nonempty {
300   my @args = @ARGV;
301   return 0 unless -s $args[0];
302   require ExtUtils::Command;
303   {
304     local @ARGV = @args[0,1];
305     ExtUtils::Command::cp(@ARGV);
306   }
307   {
308     local @ARGV = @args[2,1];
309     ExtUtils::Command::chmod(@ARGV);
310   }
311 }
312
313
314 1;