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