home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _4948f9b3ad03ddc6dfcb8f8ed4dbf6b9 < prev    next >
Text File  |  2000-03-15  |  4KB  |  140 lines
  1. #!/usr/local/bin/perl -w
  2.  
  3. use strict;
  4. use IO::File;
  5. use ExtUtils::Packlist;
  6. use ExtUtils::Installed;
  7.  
  8. use vars qw($Inst @Modules);
  9.  
  10. ################################################################################
  11.  
  12. sub do_module($)
  13. {
  14. my ($module) = @_;
  15. my $help = <<EOF;
  16. Available commands are:
  17.    f [all|prog|doc]   - List installed files of a given type
  18.    d [all|prog|doc]   - List the directories used by a module
  19.    v                  - Validate the .packlist - check for missing files
  20.    t <tarfile>        - Create a tar archive of the module
  21.    q                  - Quit the module
  22. EOF
  23. print($help);
  24. while (1)
  25.    {
  26.    print("$module cmd? ");
  27.    my $reply = <STDIN>; chomp($reply);
  28.    CASE:
  29.       {
  30.       $reply =~ /^f\s*/ and do
  31.          {
  32.          my $class = (split(' ', $reply))[1];
  33.          $class = 'all' if (! $class);
  34.          my @files;
  35.          if (eval { @files = $Inst->files($module, $class); })
  36.             {
  37.             print("$class files in $module are:\n   ",
  38.                   join("\n   ", @files), "\n");
  39.             last CASE;
  40.             }
  41.          else
  42.             { print($@); }
  43.          };
  44.       $reply =~ /^d\s*/ and do
  45.          {
  46.          my $class = (split(' ', $reply))[1];
  47.          $class = 'all' if (! $class);
  48.          my @dirs;
  49.          if (eval { @dirs = $Inst->directories($module, $class); })
  50.             {
  51.             print("$class directories in $module are:\n   ",
  52.                   join("\n   ", @dirs), "\n");
  53.             last CASE;
  54.             }
  55.          else
  56.             { print($@); }
  57.          };
  58.       $reply =~ /^t\s*/ and do
  59.          {
  60.          my $file = (split(' ', $reply))[1];
  61.          my $tmp = "/tmp/inst.$$";
  62.          if (my $fh = IO::File->new($tmp, "w"))
  63.             {
  64.             $fh->print(join("\n", $Inst->files($module)));
  65.             $fh->close();
  66.             system("tar cvf $file -I $tmp");
  67.             unlink($tmp);
  68.             last CASE;
  69.             }
  70.          else { print("Can't open $file: $!\n"); }
  71.          last CASE;
  72.          };
  73.       $reply eq 'v' and do
  74.          {
  75.          if (my @missing = $Inst->validate($module))
  76.             {
  77.             print("Files missing from $module are:\n   ",
  78.                   join("\n   ", @missing), "\n");
  79.             }
  80.          else
  81.             {
  82.             print("$module has no missing files\n");
  83.             }
  84.          last CASE;
  85.          };
  86.       $reply eq 'q' and do
  87.          {
  88.          return;
  89.          };
  90.       # Default
  91.          print($help);
  92.       }
  93.    }
  94. }
  95.  
  96. ################################################################################
  97.  
  98. sub toplevel()
  99. {
  100. my $help = <<EOF;
  101. Available commands are:
  102.    l            - List all installed modules
  103.    m <module>   - Select a module
  104.    q            - Quit the program
  105. EOF
  106. print($help);
  107. while (1)
  108.    {
  109.    print("cmd? ");
  110.    my $reply = <STDIN>; chomp($reply);
  111.    CASE:
  112.       {
  113.       $reply eq 'l' and do
  114.          {
  115.          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
  116.          last CASE;
  117.          };
  118.       $reply =~ /^m\s+/ and do
  119.          {
  120.          do_module((split(' ', $reply))[1]);
  121.          last CASE;
  122.          };
  123.       $reply eq 'q' and do
  124.          {
  125.          exit(0);
  126.          };
  127.       # Default
  128.          print($help);
  129.       }
  130.    }
  131. }
  132.  
  133. ################################################################################
  134.  
  135. $Inst = ExtUtils::Installed->new();
  136. @Modules = $Inst->modules();
  137. toplevel();
  138.  
  139. ################################################################################
  140.