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