1package ExtUtils::Command::MM; 2 3require 5.006; 4 5use strict; 6use warnings; 7 8require Exporter; 9our @ISA = qw(Exporter); 10 11our @EXPORT = qw(test_harness pod2man perllocal_install uninstall 12 warn_if_old_packlist test_s cp_nonempty); 13our $VERSION = '7.10_02'; 14 15my $Is_VMS = $^O eq 'VMS'; 16 17eval { 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 24ExtUtils::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 33B<FOR INTERNAL USE ONLY!> The interface is not stable. 34 35ExtUtils::Command::MM encapsulates code which would otherwise have to 36be done with large "one" liners. 37 38Any $(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 46Runs the tests on @ARGV via Test::Harness passing through the $verbose 47flag. Any @test_libs will be unshifted onto the test's @INC. 48 49@test_libs are run in alphabetical order. 50 51=cut 52 53sub 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 81pod2man() is a function performing most of the duties of the pod2man 82program. Its arguments are exactly the same as pod2man as of 5.8.0 83with the addition of: 84 85 --perm_rw octal permission to set the resulting manpage to 86 87And the removal of: 88 89 --verbose/-v 90 --help/-h 91 92If no arguments are given to pod2man it will read from @ARGV. 93 94If Pod::Man is unavailable, this function will warn and return undef. 95 96=cut 97 98sub 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', 'utf8|u' 120 ); 121 delete $options{utf8} unless $Pod::Man::VERSION >= 2.17; 122 123 # If there's no files, don't bother going further. 124 return 0 unless @ARGV; 125 126 # Official sets --center, but don't override things explicitly set. 127 if ($options{official} && !defined $options{center}) { 128 $options{center} = q[Perl Programmer's Reference Guide]; 129 } 130 131 # This isn't a valid Pod::Man option and is only accepted for backwards 132 # compatibility. 133 delete $options{lax}; 134 my $count = scalar @ARGV / 2; 135 my $plural = $count == 1 ? 'document' : 'documents'; 136 print "Manifying $count pod $plural\n"; 137 138 do {{ # so 'next' works 139 my ($pod, $man) = splice(@ARGV, 0, 2); 140 141 next if ((-e $man) && 142 (mtime($man) > mtime($pod)) && 143 (mtime($man) > mtime("Makefile"))); 144 145 my $parser = Pod::Man->new(%options); 146 $parser->parse_from_file($pod, $man) 147 or do { warn("Could not install $man\n"); next }; 148 149 if (exists $options{perm_rw}) { 150 chmod(oct($options{perm_rw}), $man) 151 or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; 152 } 153 }} while @ARGV; 154 155 return 1; 156} 157 158 159=item B<warn_if_old_packlist> 160 161 perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile> 162 163Displays a warning that an old packlist file was found. Reads the 164filename from @ARGV. 165 166=cut 167 168sub warn_if_old_packlist { 169 my $packlist = $ARGV[0]; 170 171 return unless -f $packlist; 172 print <<"PACKLIST_WARNING"; 173WARNING: I have found an old package in 174 $packlist. 175Please make sure the two installations are not conflicting 176PACKLIST_WARNING 177 178} 179 180 181=item B<perllocal_install> 182 183 perl "-MExtUtils::Command::MM" -e perllocal_install 184 <type> <module name> <key> <value> ... 185 186 # VMS only, key|value pairs come on STDIN 187 perl "-MExtUtils::Command::MM" -e perllocal_install 188 <type> <module name> < <key>|<value> ... 189 190Prints a fragment of POD suitable for appending to perllocal.pod. 191Arguments are read from @ARGV. 192 193'type' is the type of what you're installing. Usually 'Module'. 194 195'module name' is simply the name of your module. (Foo::Bar) 196 197Key/value pairs are extra information about the module. Fields include: 198 199 installed into which directory your module was out into 200 LINKTYPE dynamic or static linking 201 VERSION module version number 202 EXE_FILES any executables installed in a space seperated 203 list 204 205=cut 206 207sub perllocal_install { 208 my($type, $name) = splice(@ARGV, 0, 2); 209 210 # VMS feeds args as a piped file on STDIN since it usually can't 211 # fit all the args on a single command line. 212 my @mod_info = $Is_VMS ? split /\|/, <STDIN> 213 : @ARGV; 214 215 my $pod; 216 $pod = sprintf <<POD, scalar localtime; 217 =head2 %s: C<$type> L<$name|$name> 218 219 =over 4 220 221POD 222 223 do { 224 my($key, $val) = splice(@mod_info, 0, 2); 225 226 $pod .= <<POD 227 =item * 228 229 C<$key: $val> 230 231POD 232 233 } while(@mod_info); 234 235 $pod .= "=back\n\n"; 236 $pod =~ s/^ //mg; 237 print $pod; 238 239 return 1; 240} 241 242=item B<uninstall> 243 244 perl "-MExtUtils::Command::MM" -e uninstall <packlist> 245 246A wrapper around ExtUtils::Install::uninstall(). Warns that 247uninstallation is deprecated and doesn't actually perform the 248uninstallation. 249 250=cut 251 252sub uninstall { 253 my($packlist) = shift @ARGV; 254 255 require ExtUtils::Install; 256 257 print <<'WARNING'; 258 259Uninstall is unsafe and deprecated, the uninstallation was not performed. 260We will show what would have been done. 261 262WARNING 263 264 ExtUtils::Install::uninstall($packlist, 1, 1); 265 266 print <<'WARNING'; 267 268Uninstall is unsafe and deprecated, the uninstallation was not performed. 269Please check the list above carefully, there may be errors. 270Remove the appropriate files manually. 271Sorry for the inconvenience. 272 273WARNING 274 275} 276 277=item B<test_s> 278 279 perl "-MExtUtils::Command::MM" -e test_s <file> 280 281Tests if a file exists and is not empty (size > 0). 282I<Exits> with 0 if it does, 1 if it does not. 283 284=cut 285 286sub test_s { 287 exit(-s $ARGV[0] ? 0 : 1); 288} 289 290=item B<cp_nonempty> 291 292 perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm> 293 294Tests if the source file exists and is not empty (size > 0). If it is not empty 295it copies it to the given destination with the given permissions. 296 297=back 298 299=cut 300 301sub cp_nonempty { 302 my @args = @ARGV; 303 return 0 unless -s $args[0]; 304 require ExtUtils::Command; 305 { 306 local @ARGV = @args[0,1]; 307 ExtUtils::Command::cp(@ARGV); 308 } 309 { 310 local @ARGV = @args[2,1]; 311 ExtUtils::Command::chmod(@ARGV); 312 } 313} 314 315 3161; 317