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