This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #15063] /tmp issues
[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
109     if( !(defined $file and length $file) ) {
110         print "No tar file specified\n";
111     }
112     elsif( eval { require Archive::Tar } ) {
113         Archive::Tar->create_archive($file, 0, $Inst->files($module));
114     }
115     else {
116         my($first, @rest) = $Inst->files($module);
117         system('tar', 'cvf', $file, $first);
118         for my $f (@rest) {
119             system('tar', 'rvf', $file, $f);
120         }
121         print "Can't use tar\n" if $?;
122     }
123 }
124
125
126 sub validate_packlist {
127     my($reply, $module) = @_;
128
129     if (my @missing = $Inst->validate($module)) {
130         print("Files missing from $module are:\n   ",
131               join("\n   ", @missing), "\n");
132     }
133     else {
134         print("$module has no missing files\n");
135     }
136 }
137
138 sub module_help {
139     print $Module_Help;
140 }
141
142
143
144 ##############################################################################
145
146 sub toplevel()
147 {
148 my $help = <<EOF;
149 Available commands are:
150    l            - List all installed modules
151    m <module>   - Select a module
152    q            - Quit the program
153 EOF
154 print($help);
155 while (1)
156    {
157    print("cmd? ");
158    my $reply = <STDIN>; chomp($reply);
159    CASE:
160       {
161       $reply eq 'l' and do
162          {
163          print("Installed modules are:\n   ", join("\n   ", @Modules), "\n");
164          last CASE;
165          };
166       $reply =~ /^m\s+/ and do
167          {
168          do_module((split(' ', $reply))[1]);
169          last CASE;
170          };
171       $reply eq 'q' and do
172          {
173          exit(0);
174          };
175       # Default
176          print($help);
177       }
178    }
179 }
180
181
182 ###############################################################################
183
184 $Inst = ExtUtils::Installed->new();
185 @Modules = $Inst->modules();
186 toplevel();
187
188 ###############################################################################