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 = '6.98_01'; 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' 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 161Displays a warning that an old packlist file was found. Reads the 162filename from @ARGV. 163 164=cut 165 166sub warn_if_old_packlist { 167 my $packlist = $ARGV[0]; 168 169 return unless -f $packlist; 170 print <<"PACKLIST_WARNING"; 171WARNING: I have found an old package in 172 $packlist. 173Please make sure the two installations are not conflicting 174PACKLIST_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 188Prints a fragment of POD suitable for appending to perllocal.pod. 189Arguments 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 195Key/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 205sub 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 219POD 220 221 do { 222 my($key, $val) = splice(@mod_info, 0, 2); 223 224 $pod .= <<POD 225 =item * 226 227 C<$key: $val> 228 229POD 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 244A wrapper around ExtUtils::Install::uninstall(). Warns that 245uninstallation is deprecated and doesn't actually perform the 246uninstallation. 247 248=cut 249 250sub uninstall { 251 my($packlist) = shift @ARGV; 252 253 require ExtUtils::Install; 254 255 print <<'WARNING'; 256 257Uninstall is unsafe and deprecated, the uninstallation was not performed. 258We will show what would have been done. 259 260WARNING 261 262 ExtUtils::Install::uninstall($packlist, 1, 1); 263 264 print <<'WARNING'; 265 266Uninstall is unsafe and deprecated, the uninstallation was not performed. 267Please check the list above carefully, there may be errors. 268Remove the appropriate files manually. 269Sorry for the inconvenience. 270 271WARNING 272 273} 274 275=item B<test_s> 276 277 perl "-MExtUtils::Command::MM" -e test_s <file> 278 279Tests if a file exists and is not empty (size > 0). 280I<Exits> with 0 if it does, 1 if it does not. 281 282=cut 283 284sub 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 292Tests if the source file exists and is not empty (size > 0). If it is not empty 293it copies it to the given destination with the given permissions. 294 295=back 296 297=cut 298 299sub 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 3141; 315