| 1 | #!/import/archperf/ws/devtools/4/v9/bin/perl |
| 2 | eval 'exec /import/archperf/ws/devtools/4/v9/bin/perl -S $0 ${1+"$@"}' |
| 3 | if $running_under_some_shell; |
| 4 | #!/usr/bin/perl -w |
| 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 | ############################################################################### |