Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | #!/import/archperf/ws/devtools/4/v8plus/bin/perl |
2 | eval 'exec /import/archperf/ws/devtools/4/v8plus/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 | ############################################################################### |