| 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 | ################################################################################ |