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 | |
5dca256e |
24 | =head1 SEE ALSO |
25 | |
26 | ExtUtils::Installed |
27 | |
a7d1454b |
28 | =cut |
29 | |
354f3b56 |
30 | |
03c94fc2 |
31 | my $Module_Help = <<EOF; |
354f3b56 |
32 | Available 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 |
03c94fc2 |
37 | h - Display module help |
354f3b56 |
38 | q - Quit the module |
39 | EOF |
03c94fc2 |
40 | |
41 | my %Module_Commands = ( |
42 | f => \&list_installed, |
43 | d => \&list_directories, |
44 | v => \&validate_packlist, |
45 | t => \&create_archive, |
46 | h => \&module_help, |
47 | ); |
48 | |
49 | sub 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 | |
74 | sub 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 | |
91 | sub 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 | } |
354f3b56 |
105 | } |
106 | |
03c94fc2 |
107 | |
108 | sub create_archive { |
109 | my($reply, $module) = @_; |
110 | |
111 | my $file = (split(' ', $reply))[1]; |
03c94fc2 |
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 | |
130 | sub 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 | |
142 | sub module_help { |
143 | print $Module_Help; |
144 | } |
145 | |
146 | |
147 | |
148 | ############################################################################## |
354f3b56 |
149 | |
150 | sub toplevel() |
151 | { |
152 | my $help = <<EOF; |
153 | Available commands are: |
154 | l - List all installed modules |
155 | m <module> - Select a module |
156 | q - Quit the program |
157 | EOF |
158 | print($help); |
159 | while (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 | |
03c94fc2 |
185 | |
186 | ############################################################################### |
354f3b56 |
187 | |
188 | $Inst = ExtUtils::Installed->new(); |
189 | @Modules = $Inst->modules(); |
190 | toplevel(); |
191 | |
03c94fc2 |
192 | ############################################################################### |