lib/ExtUtils/instmodsh

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