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