Re: lib, ext, cpan and dist [PATCH] (take 2)
[perl.git] / ext / ExtUtils-MakeMaker / bin / instmodsh
1 #!/usr/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 =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
24 =head1 SEE ALSO
25
26 ExtUtils::Installed
27
28 =cut
29
30
31 my $Module_Help = <<EOF;
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
37    h                  - Display module help
38    q                  - Quit the module
39 EOF
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     }
105 }
106
107
108 sub create_archive {
109     my($reply, $module) = @_;
110
111     my $file = (split(' ', $reply))[1];
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 ##############################################################################
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
185
186 ###############################################################################
187
188 $Inst = ExtUtils::Installed->new();
189 @Modules = $Inst->modules();
190 toplevel();
191
192 ###############################################################################