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