home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / instmodsh.bat < prev    next >
Encoding:
DOS Batch File  |  2004-02-15  |  4.1 KB  |  171 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl
  12. @rem ';
  13. #!/usr/local/bin/perl -w
  14. #line 15
  15.  
  16. use strict;
  17. use IO::File;
  18. use ExtUtils::Packlist;
  19. use ExtUtils::Installed;
  20.  
  21. use vars qw($Inst @Modules);
  22.  
  23.  
  24. =head1 NAME
  25.  
  26. instmodsh - A shell to examine installed modules
  27.  
  28. =head1 SYNOPSIS
  29.  
  30.     instmodsh
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. A little interface to ExtUtils::Installed to examine installed modules,
  35. validate your packlists and even create a tarball from an installed module.
  36.  
  37. =cut
  38.  
  39.  
  40. sub do_module($)
  41. {
  42. my ($module) = @_;
  43. my $help = <<EOF;
  44. Available commands are:
  45.    f [all|prog|doc]   - List installed files of a given type
  46.    d [all|prog|doc]   - List the directories used by a module
  47.    v                  - Validate the .packlist - check for missing files
  48.    t <tarfile>        - Create a tar archive of the module
  49.    q                  - Quit the module
  50. EOF
  51. print($help);
  52. while (1)
  53.    {
  54.    print("$module cmd? ");
  55.    my $reply = <STDIN>; chomp($reply);
  56.    CASE:
  57.       {
  58.       $reply =~ /^f\s*/ and do
  59.          {
  60.          my $class = (split(' ', $reply))[1];
  61.          $class = 'all' if (! $class);
  62.          my @files;
  63.          if (eval { @files = $Inst->files($module, $class); })
  64.             {
  65.             print("$class files in $module are:\n   ",
  66.                   join("\n   ", @files), "\n");
  67.             last CASE;
  68.             }
  69.          else
  70.             { print($@); }
  71.          };
  72.       $reply =~ /^d\s*/ and do
  73.          {
  74.          my $class = (split(' ', $reply))[1];
  75.          $class = 'all' if (! $class);
  76.          my @dirs;
  77.          if (eval { @dirs = $Inst->directories($module, $class); })
  78.             {
  79.             print("$class directories in $module are:\n   ",
  80.                   join("\n   ", @dirs), "\n");
  81.             last CASE;
  82.             }
  83.          else
  84.             { print($@); }
  85.          };
  86.       $reply =~ /^t\s*/ and do
  87.          {
  88.          my $file = (split(' ', $reply))[1];
  89.          my $tmp = "/tmp/inst.$$";
  90.          if (my $fh = IO::File->new($tmp, "w"))
  91.             {
  92.             $fh->print(join("\n", $Inst->files($module)));
  93.             $fh->close();
  94.             system("tar cvf $file -I $tmp");
  95.             unlink($tmp);
  96.             last CASE;
  97.             }
  98.          else { print("Can't open $file: $!\n"); }
  99.          last CASE;
  100.          };
  101.       $reply eq 'v' and do
  102.          {
  103.          if (my @missing = $Inst->validate($module))
  104.             {
  105.             print("Files missing from $module are:\n   ",
  106.                   join("\n   ", @missing), "\n");
  107.             }
  108.          else
  109.             {
  110.             print("$module has no missing files\n");
  111.             }
  112.          last CASE;
  113.          };
  114.       $reply eq 'q' and do
  115.          {
  116.          return;
  117.          };
  118.       # Default
  119.          print($help);
  120.       }
  121.    }
  122. }
  123.  
  124. ################################################################################
  125.  
  126. sub toplevel()
  127. {
  128. my $help = <<EOF;
  129. Available commands are:
  130.    l            - List all installed modules
  131.    m <module>   - Select a module
  132.    q            - Quit the program
  133. EOF
  134. print($help);
  135. while (1)
  136.    {
  137.    print("cmd? ");
  138.    my $reply = <STDIN>; chomp($reply);
  139.    CASE:
  140.       {
  141.       $reply eq 'l' and do
  142.          {
  143.          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
  144.          last CASE;
  145.          };
  146.       $reply =~ /^m\s+/ and do
  147.          {
  148.          do_module((split(' ', $reply))[1]);
  149.          last CASE;
  150.          };
  151.       $reply eq 'q' and do
  152.          {
  153.          exit(0);
  154.          };
  155.       # Default
  156.          print($help);
  157.       }
  158.    }
  159. }
  160.  
  161. ################################################################################
  162.  
  163. $Inst = ExtUtils::Installed->new();
  164. @Modules = $Inst->modules();
  165. toplevel();
  166.  
  167. ################################################################################
  168.  
  169. __END__
  170. :endofperl
  171.