1 | @rem = '--*-Perl-*--
|
---|
2 | @echo off
|
---|
3 | if "%OS%" == "Windows_NT" goto WinNT
|
---|
4 | perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
|
---|
5 | goto endofperl
|
---|
6 | :WinNT
|
---|
7 | perl -x -S %0 %*
|
---|
8 | if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
|
---|
9 | if %errorlevel% == 9009 echo You do not have Perl in your PATH.
|
---|
10 | if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
|
---|
11 | goto endofperl
|
---|
12 | @rem ';
|
---|
13 | #!perl
|
---|
14 | #line 15
|
---|
15 | eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
|
---|
16 | if $running_under_some_shell;
|
---|
17 | #!/usr/bin/perl -w
|
---|
18 |
|
---|
19 | use strict;
|
---|
20 | use IO::File;
|
---|
21 | use ExtUtils::Packlist;
|
---|
22 | use ExtUtils::Installed;
|
---|
23 |
|
---|
24 | use vars qw($Inst @Modules);
|
---|
25 |
|
---|
26 |
|
---|
27 | =head1 NAME
|
---|
28 |
|
---|
29 | instmodsh - A shell to examine installed modules
|
---|
30 |
|
---|
31 | =head1 SYNOPSIS
|
---|
32 |
|
---|
33 | instmodsh
|
---|
34 |
|
---|
35 | =head1 DESCRIPTION
|
---|
36 |
|
---|
37 | A little interface to ExtUtils::Installed to examine installed modules,
|
---|
38 | validate your packlists and even create a tarball from an installed module.
|
---|
39 |
|
---|
40 | =head1 SEE ALSO
|
---|
41 |
|
---|
42 | ExtUtils::Installed
|
---|
43 |
|
---|
44 | =cut
|
---|
45 |
|
---|
46 |
|
---|
47 | my $Module_Help = <<EOF;
|
---|
48 | Available commands are:
|
---|
49 | f [all|prog|doc] - List installed files of a given type
|
---|
50 | d [all|prog|doc] - List the directories used by a module
|
---|
51 | v - Validate the .packlist - check for missing files
|
---|
52 | t <tarfile> - Create a tar archive of the module
|
---|
53 | h - Display module help
|
---|
54 | q - Quit the module
|
---|
55 | EOF
|
---|
56 |
|
---|
57 | my %Module_Commands = (
|
---|
58 | f => \&list_installed,
|
---|
59 | d => \&list_directories,
|
---|
60 | v => \&validate_packlist,
|
---|
61 | t => \&create_archive,
|
---|
62 | h => \&module_help,
|
---|
63 | );
|
---|
64 |
|
---|
65 | sub do_module($) {
|
---|
66 | my ($module) = @_;
|
---|
67 |
|
---|
68 | print($Module_Help);
|
---|
69 | MODULE_CMD: while (1) {
|
---|
70 | print("$module cmd? ");
|
---|
71 |
|
---|
72 | my $reply = <STDIN>; chomp($reply);
|
---|
73 | my($cmd) = $reply =~ /^(\w)\b/;
|
---|
74 |
|
---|
75 | last if $cmd eq 'q';
|
---|
76 |
|
---|
77 | if( $Module_Commands{$cmd} ) {
|
---|
78 | $Module_Commands{$cmd}->($reply, $module);
|
---|
79 | }
|
---|
80 | elsif( $cmd eq 'q' ) {
|
---|
81 | last MODULE_CMD;
|
---|
82 | }
|
---|
83 | else {
|
---|
84 | module_help();
|
---|
85 | }
|
---|
86 | }
|
---|
87 | }
|
---|
88 |
|
---|
89 |
|
---|
90 | sub list_installed {
|
---|
91 | my($reply, $module) = @_;
|
---|
92 |
|
---|
93 | my $class = (split(' ', $reply))[1];
|
---|
94 | $class = 'all' unless $class;
|
---|
95 |
|
---|
96 | my @files;
|
---|
97 | if (eval { @files = $Inst->files($module, $class); }) {
|
---|
98 | print("$class files in $module are:\n ",
|
---|
99 | join("\n ", @files), "\n");
|
---|
100 | }
|
---|
101 | else {
|
---|
102 | print($@);
|
---|
103 | }
|
---|
104 | };
|
---|
105 |
|
---|
106 |
|
---|
107 | sub list_directories {
|
---|
108 | my($reply, $module) = @_;
|
---|
109 |
|
---|
110 | my $class = (split(' ', $reply))[1];
|
---|
111 | $class = 'all' unless $class;
|
---|
112 |
|
---|
113 | my @dirs;
|
---|
114 | if (eval { @dirs = $Inst->directories($module, $class); }) {
|
---|
115 | print("$class directories in $module are:\n ",
|
---|
116 | join("\n ", @dirs), "\n");
|
---|
117 | }
|
---|
118 | else {
|
---|
119 | print($@);
|
---|
120 | }
|
---|
121 | }
|
---|
122 |
|
---|
123 |
|
---|
124 | sub create_archive {
|
---|
125 | my($reply, $module) = @_;
|
---|
126 |
|
---|
127 | my $file = (split(' ', $reply))[1];
|
---|
128 |
|
---|
129 | if( !(defined $file and length $file) ) {
|
---|
130 | print "No tar file specified\n";
|
---|
131 | }
|
---|
132 | elsif( eval { require Archive::Tar } ) {
|
---|
133 | Archive::Tar->create_archive($file, 0, $Inst->files($module));
|
---|
134 | }
|
---|
135 | else {
|
---|
136 | my($first, @rest) = $Inst->files($module);
|
---|
137 | system('tar', 'cvf', $file, $first);
|
---|
138 | for my $f (@rest) {
|
---|
139 | system('tar', 'rvf', $file, $f);
|
---|
140 | }
|
---|
141 | print "Can't use tar\n" if $?;
|
---|
142 | }
|
---|
143 | }
|
---|
144 |
|
---|
145 |
|
---|
146 | sub validate_packlist {
|
---|
147 | my($reply, $module) = @_;
|
---|
148 |
|
---|
149 | if (my @missing = $Inst->validate($module)) {
|
---|
150 | print("Files missing from $module are:\n ",
|
---|
151 | join("\n ", @missing), "\n");
|
---|
152 | }
|
---|
153 | else {
|
---|
154 | print("$module has no missing files\n");
|
---|
155 | }
|
---|
156 | }
|
---|
157 |
|
---|
158 | sub module_help {
|
---|
159 | print $Module_Help;
|
---|
160 | }
|
---|
161 |
|
---|
162 |
|
---|
163 |
|
---|
164 | ##############################################################################
|
---|
165 |
|
---|
166 | sub toplevel()
|
---|
167 | {
|
---|
168 | my $help = <<EOF;
|
---|
169 | Available commands are:
|
---|
170 | l - List all installed modules
|
---|
171 | m <module> - Select a module
|
---|
172 | q - Quit the program
|
---|
173 | EOF
|
---|
174 | print($help);
|
---|
175 | while (1)
|
---|
176 | {
|
---|
177 | print("cmd? ");
|
---|
178 | my $reply = <STDIN>; chomp($reply);
|
---|
179 | CASE:
|
---|
180 | {
|
---|
181 | $reply eq 'l' and do
|
---|
182 | {
|
---|
183 | print("Installed modules are:\n ", join("\n ", @Modules), "\n");
|
---|
184 | last CASE;
|
---|
185 | };
|
---|
186 | $reply =~ /^m\s+/ and do
|
---|
187 | {
|
---|
188 | do_module((split(' ', $reply))[1]);
|
---|
189 | last CASE;
|
---|
190 | };
|
---|
191 | $reply eq 'q' and do
|
---|
192 | {
|
---|
193 | exit(0);
|
---|
194 | };
|
---|
195 | # Default
|
---|
196 | print($help);
|
---|
197 | }
|
---|
198 | }
|
---|
199 | }
|
---|
200 |
|
---|
201 |
|
---|
202 | ###############################################################################
|
---|
203 |
|
---|
204 | $Inst = ExtUtils::Installed->new();
|
---|
205 | @Modules = $Inst->modules();
|
---|
206 | toplevel();
|
---|
207 |
|
---|
208 | ###############################################################################
|
---|
209 |
|
---|
210 | __END__
|
---|
211 | :endofperl
|
---|