1#!/usr/bin/perl -w
2
3use strict;
4use IO::File;
5use ExtUtils::Packlist;
6use ExtUtils::Installed;
7
8use vars qw($Inst @Modules);
9
10
11=head1 NAME
12
13instmodsh - A shell to examine installed modules
14
15=head1 SYNOPSIS
16
17    instmodsh
18
19=head1 DESCRIPTION
20
21A little interface to ExtUtils::Installed to examine installed modules,
22validate your packlists and even create a tarball from an installed module.
23
24=head1 SEE ALSO
25
26ExtUtils::Installed
27
28=cut
29
30
31my $Module_Help = <<EOF;
32Available 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
39EOF
40
41my %Module_Commands = (
42                       f => \&list_installed,
43                       d => \&list_directories,
44                       v => \&validate_packlist,
45                       t => \&create_archive,
46                       h => \&module_help,
47                      );
48
49sub 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
74sub 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
91sub 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
108sub 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
130sub 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
142sub module_help {
143    print $Module_Help;
144}
145
146
147
148##############################################################################
149
150sub toplevel()
151{
152my $help = <<EOF;
153Available commands are:
154   l            - List all installed modules
155   m <module>   - Select a module
156   q            - Quit the program
157EOF
158print($help);
159while (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();
190toplevel();
191
192###############################################################################
193