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