Commit | Line | Data |
---|---|---|
354f3b56 AB |
1 | #!/usr/local/bin/perl -w |
2 | ||
3 | use strict; | |
4 | use IO::File; | |
5 | use ExtUtils::Packlist; | |
6 | use ExtUtils::Installed; | |
7 | ||
8 | use vars qw($Inst @Modules); | |
9 | ||
10 | ################################################################################ | |
11 | ||
12 | sub do_module($) | |
13 | { | |
14 | my ($module) = @_; | |
15 | my $help = <<EOF; | |
16 | Available commands are: | |
17 | f [all|prog|doc] - List installed files of a given type | |
18 | d [all|prog|doc] - List the directories used by a module | |
19 | v - Validate the .packlist - check for missing files | |
20 | t <tarfile> - Create a tar archive of the module | |
21 | q - Quit the module | |
22 | EOF | |
23 | print($help); | |
24 | while (1) | |
25 | { | |
26 | print("$module cmd? "); | |
27 | my $reply = <STDIN>; chomp($reply); | |
28 | CASE: | |
29 | { | |
30 | $reply =~ /^f\s*/ and do | |
31 | { | |
32 | my $class = (split(' ', $reply))[1]; | |
33 | $class = 'all' if (! $class); | |
34 | my @files; | |
35 | if (eval { @files = $Inst->files($module, $class); }) | |
36 | { | |
37 | print("$class files in $module are:\n ", | |
38 | join("\n ", @files), "\n"); | |
39 | last CASE; | |
40 | } | |
41 | else | |
42 | { print($@); } | |
43 | }; | |
44 | $reply =~ /^d\s*/ and do | |
45 | { | |
46 | my $class = (split(' ', $reply))[1]; | |
47 | $class = 'all' if (! $class); | |
48 | my @dirs; | |
49 | if (eval { @dirs = $Inst->directories($module, $class); }) | |
50 | { | |
51 | print("$class directories in $module are:\n ", | |
52 | join("\n ", @dirs), "\n"); | |
53 | last CASE; | |
54 | } | |
55 | else | |
56 | { print($@); } | |
57 | }; | |
58 | $reply =~ /^t\s*/ and do | |
59 | { | |
60 | my $file = (split(' ', $reply))[1]; | |
61 | my $tmp = "/tmp/inst.$$"; | |
62 | if (my $fh = IO::File->new($tmp, "w")) | |
63 | { | |
64 | $fh->print(join("\n", $Inst->files($module))); | |
65 | $fh->close(); | |
66 | system("tar cvf $file -I $tmp"); | |
67 | unlink($tmp); | |
68 | last CASE; | |
69 | } | |
70 | else { print("Can't open $file: $!\n"); } | |
71 | last CASE; | |
72 | }; | |
73 | $reply eq 'v' and do | |
74 | { | |
75 | if (my @missing = $Inst->validate($module)) | |
76 | { | |
77 | print("Files missing from $module are:\n ", | |
78 | join("\n ", @missing), "\n"); | |
79 | } | |
80 | else | |
81 | { | |
82 | print("$module has no missing files\n"); | |
83 | } | |
84 | last CASE; | |
85 | }; | |
86 | $reply eq 'q' and do | |
87 | { | |
88 | return; | |
89 | }; | |
90 | # Default | |
91 | print($help); | |
92 | } | |
93 | } | |
94 | } | |
95 | ||
96 | ################################################################################ | |
97 | ||
98 | sub toplevel() | |
99 | { | |
100 | my $help = <<EOF; | |
101 | Available commands are: | |
102 | l - List all installed modules | |
103 | m <module> - Select a module | |
104 | q - Quit the program | |
105 | EOF | |
106 | print($help); | |
107 | while (1) | |
108 | { | |
109 | print("cmd? "); | |
110 | my $reply = <STDIN>; chomp($reply); | |
111 | CASE: | |
112 | { | |
113 | $reply eq 'l' and do | |
114 | { | |
115 | print("Installed modules are:\n ", join("\n ", @Modules), "\n"); | |
116 | last CASE; | |
117 | }; | |
118 | $reply =~ /^m\s+/ and do | |
119 | { | |
120 | do_module((split(' ', $reply))[1]); | |
121 | last CASE; | |
122 | }; | |
123 | $reply eq 'q' and do | |
124 | { | |
125 | exit(0); | |
126 | }; | |
127 | # Default | |
128 | print($help); | |
129 | } | |
130 | } | |
131 | } | |
132 | ||
133 | ################################################################################ | |
134 | ||
135 | $Inst = ExtUtils::Installed->new(); | |
136 | @Modules = $Inst->modules(); | |
137 | toplevel(); | |
138 | ||
139 | ################################################################################ |