Commit | Line | Data |
---|---|---|
03c94fc2 | 1 | #!/usr/bin/perl -w |
354f3b56 AB |
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 RGS |
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 RGS |
24 | =head1 SEE ALSO |
25 | ||
26 | ExtUtils::Installed | |
27 | ||
a7d1454b RGS |
28 | =cut |
29 | ||
354f3b56 | 30 | |
03c94fc2 | 31 | my $Module_Help = <<EOF; |
354f3b56 AB |
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 AB |
38 | q - Quit the module |
39 | EOF | |
03c94fc2 RGS |
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 AB |
105 | } |
106 | ||
03c94fc2 RGS |
107 | |
108 | sub create_archive { | |
109 | my($reply, $module) = @_; | |
110 | ||
111 | my $file = (split(' ', $reply))[1]; | |
03c94fc2 RGS |
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 AB |
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 RGS |
185 | |
186 | ############################################################################### | |
354f3b56 AB |
187 | |
188 | $Inst = ExtUtils::Installed->new(); | |
189 | @Modules = $Inst->modules(); | |
190 | toplevel(); | |
191 | ||
03c94fc2 | 192 | ############################################################################### |