Commit | Line | Data |
---|---|---|
920dae64 AT |
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'; | |
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 | my $parser = Pod::Man->new(%options); | |
121 | ||
122 | do {{ # so 'next' works | |
123 | my ($pod, $man) = splice(@ARGV, 0, 2); | |
124 | ||
125 | next if ((-e $man) && | |
126 | (-M $man < -M $pod) && | |
127 | (-M $man < -M "Makefile")); | |
128 | ||
129 | print "Manifying $man\n"; | |
130 | ||
131 | $parser->parse_from_file($pod, $man) | |
132 | or do { warn("Could not install $man\n"); next }; | |
133 | ||
134 | if (length $options{perm_rw}) { | |
135 | chmod(oct($options{perm_rw}), $man) | |
136 | or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; | |
137 | } | |
138 | }} while @ARGV; | |
139 | ||
140 | return 1; | |
141 | } | |
142 | ||
143 | ||
144 | =item B<warn_if_old_packlist> | |
145 | ||
146 | perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile> | |
147 | ||
148 | Displays a warning that an old packlist file was found. Reads the | |
149 | filename from @ARGV. | |
150 | ||
151 | =cut | |
152 | ||
153 | sub warn_if_old_packlist { | |
154 | my $packlist = $ARGV[0]; | |
155 | ||
156 | return unless -f $packlist; | |
157 | print <<"PACKLIST_WARNING"; | |
158 | WARNING: I have found an old package in | |
159 | $packlist. | |
160 | Please make sure the two installations are not conflicting | |
161 | PACKLIST_WARNING | |
162 | ||
163 | } | |
164 | ||
165 | ||
166 | =item B<perllocal_install> | |
167 | ||
168 | perl "-MExtUtils::Command::MM" -e perllocal_install | |
169 | <type> <module name> <key> <value> ... | |
170 | ||
171 | # VMS only, key|value pairs come on STDIN | |
172 | perl "-MExtUtils::Command::MM" -e perllocal_install | |
173 | <type> <module name> < <key>|<value> ... | |
174 | ||
175 | Prints a fragment of POD suitable for appending to perllocal.pod. | |
176 | Arguments are read from @ARGV. | |
177 | ||
178 | 'type' is the type of what you're installing. Usually 'Module'. | |
179 | ||
180 | 'module name' is simply the name of your module. (Foo::Bar) | |
181 | ||
182 | Key/value pairs are extra information about the module. Fields include: | |
183 | ||
184 | installed into which directory your module was out into | |
185 | LINKTYPE dynamic or static linking | |
186 | VERSION module version number | |
187 | EXE_FILES any executables installed in a space seperated | |
188 | list | |
189 | ||
190 | =cut | |
191 | ||
192 | sub perllocal_install { | |
193 | my($type, $name) = splice(@ARGV, 0, 2); | |
194 | ||
195 | # VMS feeds args as a piped file on STDIN since it usually can't | |
196 | # fit all the args on a single command line. | |
197 | @ARGV = split /\|/, <STDIN> if $Is_VMS; | |
198 | ||
199 | my $pod; | |
200 | $pod = sprintf <<POD, scalar localtime; | |
201 | =head2 %s: C<$type> L<$name|$name> | |
202 | ||
203 | =over 4 | |
204 | ||
205 | POD | |
206 | ||
207 | do { | |
208 | my($key, $val) = splice(@ARGV, 0, 2); | |
209 | ||
210 | $pod .= <<POD | |
211 | =item * | |
212 | ||
213 | C<$key: $val> | |
214 | ||
215 | POD | |
216 | ||
217 | } while(@ARGV); | |
218 | ||
219 | $pod .= "=back\n\n"; | |
220 | $pod =~ s/^ //mg; | |
221 | print $pod; | |
222 | ||
223 | return 1; | |
224 | } | |
225 | ||
226 | =item B<uninstall> | |
227 | ||
228 | perl "-MExtUtils::Command::MM" -e uninstall <packlist> | |
229 | ||
230 | A wrapper around ExtUtils::Install::uninstall(). Warns that | |
231 | uninstallation is deprecated and doesn't actually perform the | |
232 | uninstallation. | |
233 | ||
234 | =cut | |
235 | ||
236 | sub uninstall { | |
237 | my($packlist) = shift @ARGV; | |
238 | ||
239 | require ExtUtils::Install; | |
240 | ||
241 | print <<'WARNING'; | |
242 | ||
243 | Uninstall is unsafe and deprecated, the uninstallation was not performed. | |
244 | We will show what would have been done. | |
245 | ||
246 | WARNING | |
247 | ||
248 | ExtUtils::Install::uninstall($packlist, 1, 1); | |
249 | ||
250 | print <<'WARNING'; | |
251 | ||
252 | Uninstall is unsafe and deprecated, the uninstallation was not performed. | |
253 | Please check the list above carefully, there may be errors. | |
254 | Remove the appropriate files manually. | |
255 | Sorry for the inconvenience. | |
256 | ||
257 | WARNING | |
258 | ||
259 | } | |
260 | ||
261 | =back | |
262 | ||
263 | =cut | |
264 | ||
265 | 1; |