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