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.05';
  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     my $parser = Pod::Man->new(%options);
 121
 122     do {{  # so 'next' works
 123         my ($pod, $man) = splice(@ARGV, 0, 2);
 124
 125         next if ((-e $man) &&
 126                  (-M $man < -M $pod) &&
 127                  (-M $man < -M "Makefile"));
 128
 129         print "Manifying $man\n";
 130
 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     @ARGV = split /\|/, <STDIN> if $Is_VMS;
 198
 199     my $pod;
 200     $pod = sprintf <<POD, scalar localtime;
 201  =head2 %s: C<$type> L<$name|$name>
 202
 203  =over 4
 204
 205 POD
 206
 207     do {
 208         my($key, $val) = splice(@ARGV, 0, 2);
 209
 210         $pod .= <<POD
 211  =item *
 212
 213  C<$key: $val>
 214
 215 POD
 216
 217     } while(@ARGV);
 218
 219     $pod .= "=back\n\n";
 220     $pod =~ s/^ //mg;
 221     print $pod;
 222
 223     return 1;
 224 }
 225
 226 =item B<uninstall>
 227
 228     perl "-MExtUtils::Command::MM" -e uninstall <packlist>
 229
 230 A wrapper around ExtUtils::Install::uninstall().  Warns that
 231 uninstallation is deprecated and doesn't actually perform the
 232 uninstallation.
 233
 234 =cut
 235
 236 sub uninstall {
 237     my($packlist) = shift @ARGV;
 238
 239     require ExtUtils::Install;
 240
 241     print <<'WARNING';
 242
 243 Uninstall is unsafe and deprecated, the uninstallation was not performed.
 244 We will show what would have been done.
 245
 246 WARNING
 247
 248     ExtUtils::Install::uninstall($packlist, 1, 1);
 249
 250     print <<'WARNING';
 251
 252 Uninstall is unsafe and deprecated, the uninstallation was not performed.
 253 Please check the list above carefully, there may be errors.
 254 Remove the appropriate files manually.
 255 Sorry for the inconvenience.
 256
 257 WARNING
 258
 259 }
 260
 261 =back
 262
 263 =cut
 264
 265 1;