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