This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Sync with the latest MakeMaker snapshot.
[perl5.git] / lib / ExtUtils / 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 =cut
25
26
27 my $Module_Help = <<EOF;
28 Available commands are:
29    f [all|prog|doc]   - List installed files of a given type
30    d [all|prog|doc]   - List the directories used by a module
31    v                  - Validate the .packlist - check for missing files
32    t <tarfile>        - Create a tar archive of the module
33    h                  - Display module help
34    q                  - Quit the module
35 EOF
36
37 my %Module_Commands = (
38                        f => \&list_installed,
39                        d => \&list_directories,
40                        v => \&validate_packlist,
41                        t => \&create_archive,
42                        h => \&module_help,
43                       );
44
45 sub do_module($) {
46     my ($module) = @_;
47
48     print($Module_Help);
49     MODULE_CMD: while (1) {
50         print("$module cmd? ");
51
52         my $reply = <STDIN>; chomp($reply);
53         my($cmd) = $reply =~ /^(\w)\b/;
54
55         last if $cmd eq 'q';
56
57         if( $Module_Commands{$cmd} ) {
58             $Module_Commands{$cmd}->($reply, $module);
59         }
60         elsif( $cmd eq 'q' ) {
61             last MODULE_CMD;
62         }
63         else {
64             module_help();
65         }
66     }
67 }
68
69
70 sub list_installed {
71     my($reply, $module) = @_;
72
73     my $class = (split(' ', $reply))[1];
74     $class = 'all' unless $class;
75
76     my @files;
77     if (eval { @files = $Inst->files($module, $class); }) {
78         print("$class files in $module are:\n   ",
79               join("\n   ", @files), "\n");
80     }
81     else { 
82         print($@); 
83     }
84 };
85
86
87 sub list_directories {
88     my($reply, $module) = @_;
89
90     my $class = (split(' ', $reply))[1];
91     $class = 'all' unless $class;
92
93     my @dirs;
94     if (eval { @dirs = $Inst->directories($module, $class); }) {
95         print("$class directories in $module are:\n   ",
96               join("\n   ", @dirs), "\n");
97     }
98     else { 
99         print($@); 
100     }
101 }
102
103
104 sub create_archive {
105     my($reply, $module) = @_;
106
107     my $file = (split(' ', $reply))[1];
108     my $tmp = "/tmp/inst.$$";
109
110     if( !(defined $file and length $file) ) {
111         print "No tar file specified\n";
112     }
113     elsif( eval { require Archive::Tar } ) {
114         Archive::Tar->create_archive($file, 0, $Inst->files($module));
115     }
116     else {
117         my($first, @rest) = $Inst->files($module);
118         system('tar', 'cvf', $file, $first);
119         for my $f (@rest) {
120             system('tar', 'rvf', $file, $f);
121         }
122         print "Can't use tar\n" if $?;
123     }
124 }
125
126
127 sub validate_packlist {
128     my($reply, $module) = @_;
129
130     if (my @missing = $Inst->validate($module)) {
131         print("Files missing from $module are:\n   ",
132               join("\n   ", @missing), "\n");
133     }
134     else {
135         print("$module has no missing files\n");
136     }
137 }
138
139 sub module_help {
140     print $Module_Help;
141 }
142
143
144
145 ##############################################################################
146
147 sub toplevel()
148 {
149 my $help = <<EOF;
150 Available commands are:
151    l            - List all installed modules
152    m <module>   - Select a module
153    q            - Quit the program
154 EOF
155 print($help);
156 while (1)
157    {
158    print("cmd? ");
159    my $reply = <STDIN>; chomp($reply);
160    CASE:
161       {
162       $reply eq 'l' and do
163          {
164          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
165          last CASE;
166          };
167       $reply =~ /^m\s+/ and do
168          {
169          do_module((split(' ', $reply))[1]);
170          last CASE;
171          };
172       $reply eq 'q' and do
173          {
174          exit(0);
175          };
176       # Default
177          print($help);
178       }
179    }
180 }
181
182
183 ###############################################################################
184
185 $Inst = ExtUtils::Installed->new();
186 @Modules = $Inst->modules();
187 toplevel();
188
189 ###############################################################################