local-lib5/lib/perl5/ExtUtils/Command/MM.pm

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