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