lib/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.47_02';
  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 =cut
  91
  92 sub pod2man {
  93     local @ARGV = @_ ? @_ : @ARGV;
  94
  95     require Pod::Man;
  96     require Getopt::Long;
  97
  98     # We will cheat and just use Getopt::Long.  We fool it by putting
  99     # our arguments into @ARGV.  Should be safe.
 100     my %options = ();
 101     Getopt::Long::config ('bundling_override');
 102     Getopt::Long::GetOptions (\%options,
 103                 'section|s=s', 'release|r=s', 'center|c=s',
 104                 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
 105                 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
 106                 'name|n=s', 'perm_rw:i'
 107     );
 108
 109     # If there's no files, don't bother going further.
 110     return 0 unless @ARGV;
 111
 112     # Official sets --center, but don't override things explicitly set.
 113     if ($options{official} && !defined $options{center}) {
 114         $options{center} = q[Perl Programmer's Reference Guide];
 115     }
 116
 117     # This isn't a valid Pod::Man option and is only accepted for backwards
 118     # compatibility.
 119     delete $options{lax};
 120
 121     do {{  # so 'next' works
 122         my ($pod, $man) = splice(@ARGV, 0, 2);
 123
 124         next if ((-e $man) &&
 125                  (-M $man < -M $pod) &&
 126                  (-M $man < -M "Makefile"));
 127
 128         print "Manifying $man\n";
 129
 130         my $parser = Pod::Man->new(%options);
 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     my @mod_info = $Is_VMS ? split /\|/, <STDIN>
 198                            : @ARGV;
 199
 200     my $pod;
 201     $pod = sprintf <<POD, scalar localtime;
 202  =head2 %s: C<$type> L<$name|$name>
 203
 204  =over 4
 205
 206 POD
 207
 208     do {
 209         my($key, $val) = splice(@mod_info, 0, 2);
 210
 211         $pod .= <<POD
 212  =item *
 213
 214  C<$key: $val>
 215
 216 POD
 217
 218     } while(@mod_info);
 219
 220     $pod .= "=back\n\n";
 221     $pod =~ s/^ //mg;
 222     print $pod;
 223
 224     return 1;
 225 }
 226
 227 =item B<uninstall>
 228
 229     perl "-MExtUtils::Command::MM" -e uninstall <packlist>
 230
 231 A wrapper around ExtUtils::Install::uninstall().  Warns that
 232 uninstallation is deprecated and doesn't actually perform the
 233 uninstallation.
 234
 235 =cut
 236
 237 sub uninstall {
 238     my($packlist) = shift @ARGV;
 239
 240     require ExtUtils::Install;
 241
 242     print <<'WARNING';
 243
 244 Uninstall is unsafe and deprecated, the uninstallation was not performed.
 245 We will show what would have been done.
 246
 247 WARNING
 248
 249     ExtUtils::Install::uninstall($packlist, 1, 1);
 250
 251     print <<'WARNING';
 252
 253 Uninstall is unsafe and deprecated, the uninstallation was not performed.
 254 Please check the list above carefully, there may be errors.
 255 Remove the appropriate files manually.
 256 Sorry for the inconvenience.
 257
 258 WARNING
 259
 260 }
 261
 262 =back
 263
 264 =cut
 265
 266 1;