lib/ExtUtils/Command/MM.pm

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