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