1N/A#!/usr/local/bin/perl -w
1N/A
1N/Ause strict;
1N/Ause IO::File;
1N/Ause ExtUtils::Packlist;
1N/Ause ExtUtils::Installed;
1N/A
1N/Ause vars qw($Inst @Modules);
1N/A
1N/A################################################################################
1N/A
1N/Asub do_module($)
1N/A{
1N/Amy ($module) = @_;
1N/Amy $help = <<EOF;
1N/AAvailable commands are:
1N/A f [all|prog|doc] - List installed files of a given type
1N/A d [all|prog|doc] - List the directories used by a module
1N/A v - Validate the .packlist - check for missing files
1N/A t <tarfile> - Create a tar archive of the module
1N/A q - Quit the module
1N/AEOF
1N/Aprint($help);
1N/Awhile (1)
1N/A {
1N/A print("$module cmd? ");
1N/A my $reply = <STDIN>; chomp($reply);
1N/A CASE:
1N/A {
1N/A $reply =~ /^f\s*/ and do
1N/A {
1N/A my $class = (split(' ', $reply))[1];
1N/A $class = 'all' if (! $class);
1N/A my @files;
1N/A if (eval { @files = $Inst->files($module, $class); })
1N/A {
1N/A print("$class files in $module are:\n ",
1N/A join("\n ", @files), "\n");
1N/A last CASE;
1N/A }
1N/A else
1N/A { print($@); }
1N/A };
1N/A $reply =~ /^d\s*/ and do
1N/A {
1N/A my $class = (split(' ', $reply))[1];
1N/A $class = 'all' if (! $class);
1N/A my @dirs;
1N/A if (eval { @dirs = $Inst->directories($module, $class); })
1N/A {
1N/A print("$class directories in $module are:\n ",
1N/A join("\n ", @dirs), "\n");
1N/A last CASE;
1N/A }
1N/A else
1N/A { print($@); }
1N/A };
1N/A $reply =~ /^t\s*/ and do
1N/A {
1N/A my $file = (split(' ', $reply))[1];
1N/A my $tmp = "/tmp/inst.$$";
1N/A if (my $fh = IO::File->new($tmp, "w"))
1N/A {
1N/A $fh->print(join("\n", $Inst->files($module)));
1N/A $fh->close();
1N/A system("tar cvf $file -I $tmp");
1N/A unlink($tmp);
1N/A last CASE;
1N/A }
1N/A else { print("Can't open $file: $!\n"); }
1N/A last CASE;
1N/A };
1N/A $reply eq 'v' and do
1N/A {
1N/A if (my @missing = $Inst->validate($module))
1N/A {
1N/A print("Files missing from $module are:\n ",
1N/A join("\n ", @missing), "\n");
1N/A }
1N/A else
1N/A {
1N/A print("$module has no missing files\n");
1N/A }
1N/A last CASE;
1N/A };
1N/A $reply eq 'q' and do
1N/A {
1N/A return;
1N/A };
1N/A # Default
1N/A print($help);
1N/A }
1N/A }
1N/A}
1N/A
1N/A################################################################################
1N/A
1N/Asub toplevel()
1N/A{
1N/Amy $help = <<EOF;
1N/AAvailable commands are:
1N/A l - List all installed modules
1N/A m <module> - Select a module
1N/A q - Quit the program
1N/AEOF
1N/Aprint($help);
1N/Awhile (1)
1N/A {
1N/A print("cmd? ");
1N/A my $reply = <STDIN>; chomp($reply);
1N/A CASE:
1N/A {
1N/A $reply eq 'l' and do
1N/A {
1N/A print("Installed modules are:\n ", join("\n ", @Modules), "\n");
1N/A last CASE;
1N/A };
1N/A $reply =~ /^m\s+/ and do
1N/A {
1N/A do_module((split(' ', $reply))[1]);
1N/A last CASE;
1N/A };
1N/A $reply eq 'q' and do
1N/A {
1N/A exit(0);
1N/A };
1N/A # Default
1N/A print($help);
1N/A }
1N/A }
1N/A}
1N/A
1N/A################################################################################
1N/A
1N/A$Inst = ExtUtils::Installed->new();
1N/A@Modules = $Inst->modules();
1N/Atoplevel();
1N/A
1N/A################################################################################