local-lib5/bin/instmodsh

   1 #!/usr/bin/perl -w
   2
   3 eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
   4     if 0; # not running under some shell
   5
   6 use strict;
   7 use IO::File;
   8 use ExtUtils::Packlist;
   9 use ExtUtils::Installed;
  10
  11 use vars qw($Inst @Modules);
  12
  13
  14 =head1 NAME
  15
  16 instmodsh - A shell to examine installed modules
  17
  18 =head1 SYNOPSIS
  19
  20     instmodsh
  21
  22 =head1 DESCRIPTION
  23
  24 A little interface to ExtUtils::Installed to examine installed modules,
  25 validate your packlists and even create a tarball from an installed module.
  26
  27 =head1 SEE ALSO
  28
  29 ExtUtils::Installed
  30
  31 =cut
  32
  33
  34 my $Module_Help = <<EOF;
  35 Available commands are:
  36    f [all|prog|doc]   - List installed files of a given type
  37    d [all|prog|doc]   - List the directories used by a module
  38    v                  - Validate the .packlist - check for missing files
  39    t <tarfile>        - Create a tar archive of the module
  40    h                  - Display module help
  41    q                  - Quit the module
  42 EOF
  43
  44 my %Module_Commands = (
  45                        f => \&list_installed,
  46                        d => \&list_directories,
  47                        v => \&validate_packlist,
  48                        t => \&create_archive,
  49                        h => \&module_help,
  50                       );
  51
  52 sub do_module($) {
  53     my ($module) = @_;
  54
  55     print($Module_Help);
  56     MODULE_CMD: while (1) {
  57         print("$module cmd? ");
  58
  59         my $reply = <STDIN>; chomp($reply);
  60         my($cmd) = $reply =~ /^(\w)\b/;
  61
  62         last if $cmd eq 'q';
  63
  64         if( $Module_Commands{$cmd} ) {
  65             $Module_Commands{$cmd}->($reply, $module);
  66         }
  67         elsif( $cmd eq 'q' ) {
  68             last MODULE_CMD;
  69         }
  70         else {
  71             module_help();
  72         }
  73     }
  74 }
  75
  76
  77 sub list_installed {
  78     my($reply, $module) = @_;
  79
  80     my $class = (split(' ', $reply))[1];
  81     $class = 'all' unless $class;
  82
  83     my @files;
  84     if (eval { @files = $Inst->files($module, $class); }) {
  85         print("$class files in $module are:\n   ",
  86               join("\n   ", @files), "\n");
  87     }
  88     else {
  89         print($@);
  90     }
  91 };
  92
  93
  94 sub list_directories {
  95     my($reply, $module) = @_;
  96
  97     my $class = (split(' ', $reply))[1];
  98     $class = 'all' unless $class;
  99
 100     my @dirs;
 101     if (eval { @dirs = $Inst->directories($module, $class); }) {
 102         print("$class directories in $module are:\n   ",
 103               join("\n   ", @dirs), "\n");
 104     }
 105     else {
 106         print($@);
 107     }
 108 }
 109
 110
 111 sub create_archive {
 112     my($reply, $module) = @_;
 113
 114     my $file = (split(' ', $reply))[1];
 115
 116     if( !(defined $file and length $file) ) {
 117         print "No tar file specified\n";
 118     }
 119     elsif( eval { require Archive::Tar } ) {
 120         Archive::Tar->create_archive($file, 0, $Inst->files($module));
 121     }
 122     else {
 123         my($first, @rest) = $Inst->files($module);
 124         system('tar', 'cvf', $file, $first);
 125         for my $f (@rest) {
 126             system('tar', 'rvf', $file, $f);
 127         }
 128         print "Can't use tar\n" if $?;
 129     }
 130 }
 131
 132
 133 sub validate_packlist {
 134     my($reply, $module) = @_;
 135
 136     if (my @missing = $Inst->validate($module)) {
 137         print("Files missing from $module are:\n   ",
 138               join("\n   ", @missing), "\n");
 139     }
 140     else {
 141         print("$module has no missing files\n");
 142     }
 143 }
 144
 145 sub module_help {
 146     print $Module_Help;
 147 }
 148
 149
 150
 151 ##############################################################################
 152
 153 sub toplevel()
 154 {
 155 my $help = <<EOF;
 156 Available commands are:
 157    l            - List all installed modules
 158    m <module>   - Select a module
 159    q            - Quit the program
 160 EOF
 161 print($help);
 162 while (1)
 163    {
 164    print("cmd? ");
 165    my $reply = <STDIN>; chomp($reply);
 166    CASE:
 167       {
 168       $reply eq 'l' and do
 169          {
 170          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
 171          last CASE;
 172          };
 173       $reply =~ /^m\s+/ and do
 174          {
 175          do_module((split(' ', $reply))[1]);
 176          last CASE;
 177          };
 178       $reply eq 'q' and do
 179          {
 180          exit(0);
 181          };
 182       # Default
 183          print($help);
 184       }
 185    }
 186 }
 187
 188
 189 ###############################################################################
 190
 191 $Inst = ExtUtils::Installed->new();
 192 @Modules = $Inst->modules();
 193 toplevel();
 194
 195 ###############################################################################