Commit | Line | Data |
03c94fc2 |
1 | #!/usr/bin/perl -w |
354f3b56 |
2 | |
3 | use strict; |
4 | use IO::File; |
5 | use ExtUtils::Packlist; |
6 | use ExtUtils::Installed; |
7 | |
8 | use vars qw($Inst @Modules); |
9 | |
a7d1454b |
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 | |
354f3b56 |
26 | |
03c94fc2 |
27 | my $Module_Help = <<EOF; |
354f3b56 |
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 |
03c94fc2 |
33 | h - Display module help |
354f3b56 |
34 | q - Quit the module |
35 | EOF |
03c94fc2 |
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 | } |
354f3b56 |
101 | } |
102 | |
03c94fc2 |
103 | |
104 | sub create_archive { |
105 | my($reply, $module) = @_; |
106 | |
107 | my $file = (split(' ', $reply))[1]; |
108 | my $tmp = "/tmp/inst.$$"; |
109 | |
110 | if( !(defined $file and length $file) ) { |
111 | print "No tar file specified\n"; |
112 | } |
113 | elsif( eval { require Archive::Tar } ) { |
114 | Archive::Tar->create_archive($file, 0, $Inst->files($module)); |
115 | } |
116 | else { |
117 | my($first, @rest) = $Inst->files($module); |
118 | system('tar', 'cvf', $file, $first); |
119 | for my $f (@rest) { |
120 | system('tar', 'rvf', $file, $f); |
121 | } |
122 | print "Can't use tar\n" if $?; |
123 | } |
124 | } |
125 | |
126 | |
127 | sub validate_packlist { |
128 | my($reply, $module) = @_; |
129 | |
130 | if (my @missing = $Inst->validate($module)) { |
131 | print("Files missing from $module are:\n ", |
132 | join("\n ", @missing), "\n"); |
133 | } |
134 | else { |
135 | print("$module has no missing files\n"); |
136 | } |
137 | } |
138 | |
139 | sub module_help { |
140 | print $Module_Help; |
141 | } |
142 | |
143 | |
144 | |
145 | ############################################################################## |
354f3b56 |
146 | |
147 | sub toplevel() |
148 | { |
149 | my $help = <<EOF; |
150 | Available commands are: |
151 | l - List all installed modules |
152 | m <module> - Select a module |
153 | q - Quit the program |
154 | EOF |
155 | print($help); |
156 | while (1) |
157 | { |
158 | print("cmd? "); |
159 | my $reply = <STDIN>; chomp($reply); |
160 | CASE: |
161 | { |
162 | $reply eq 'l' and do |
163 | { |
164 | print("Installed modules are:\n ", join("\n ", @Modules), "\n"); |
165 | last CASE; |
166 | }; |
167 | $reply =~ /^m\s+/ and do |
168 | { |
169 | do_module((split(' ', $reply))[1]); |
170 | last CASE; |
171 | }; |
172 | $reply eq 'q' and do |
173 | { |
174 | exit(0); |
175 | }; |
176 | # Default |
177 | print($help); |
178 | } |
179 | } |
180 | } |
181 | |
03c94fc2 |
182 | |
183 | ############################################################################### |
354f3b56 |
184 | |
185 | $Inst = ExtUtils::Installed->new(); |
186 | @Modules = $Inst->modules(); |
187 | toplevel(); |
188 | |
03c94fc2 |
189 | ############################################################################### |