1package ExtUtils::Command::MM;
2
3use strict;
4
5require 5.005_03;
6require Exporter;
7use 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
14my $Is_VMS = $^O eq 'VMS';
15
16
17=head1 NAME
18
19ExtUtils::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
28B<FOR INTERNAL USE ONLY!>  The interface is not stable.
29
30ExtUtils::Command::MM encapsulates code which would otherwise have to
31be done with large "one" liners.
32
33Any $(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
41Runs the tests on @ARGV via Test::Harness passing through the $verbose
42flag.  Any @test_libs will be unshifted onto the test's @INC.
43
44@test_libs are run in alphabetical order.
45
46=cut
47
48sub 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
76pod2man() is a function performing most of the duties of the pod2man
77program.  Its arguments are exactly the same as pod2man as of 5.8.0
78with the addition of:
79
80    --perm_rw   octal permission to set the resulting manpage to
81
82And the removal of:
83
84    --verbose/-v
85    --help/-h
86
87If no arguments are given to pod2man it will read from @ARGV.
88
89=cut
90
91sub 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
148Displays a warning that an old packlist file was found.  Reads the
149filename from @ARGV.
150
151=cut
152
153sub warn_if_old_packlist {
154    my $packlist = $ARGV[0];
155
156    return unless -f $packlist;
157    print <<"PACKLIST_WARNING";
158WARNING: I have found an old package in
159    $packlist.
160Please make sure the two installations are not conflicting
161PACKLIST_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
175Prints a fragment of POD suitable for appending to perllocal.pod.
176Arguments 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
182Key/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
192sub 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
205POD
206
207    do {
208        my($key, $val) = splice(@ARGV, 0, 2);
209
210        $pod .= <<POD
211 =item *
212
213 C<$key: $val>
214
215POD
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
230A wrapper around ExtUtils::Install::uninstall().  Warns that
231uninstallation is deprecated and doesn't actually perform the
232uninstallation.
233
234=cut
235
236sub uninstall {
237    my($packlist) = shift @ARGV;
238
239    require ExtUtils::Install;
240
241    print <<'WARNING';
242
243Uninstall is unsafe and deprecated, the uninstallation was not performed.
244We will show what would have been done.
245
246WARNING
247
248    ExtUtils::Install::uninstall($packlist, 1, 1);
249
250    print <<'WARNING';
251
252Uninstall is unsafe and deprecated, the uninstallation was not performed.
253Please check the list above carefully, there may be errors.
254Remove the appropriate files manually.
255Sorry for the inconvenience.
256
257WARNING
258
259}
260
261=back
262
263=cut
264
2651;
266