CXUX_BROKEN_CONSTANT_CONVERT isn't used anymore.

[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / instmodsh

diff --git a/lib/ExtUtils/instmodsh b/lib/ExtUtils/instmodsh
index f568e88..0eab08f 100644 (file)
--- a/lib/ExtUtils/instmodsh
+++ b/lib/ExtUtils/instmodsh
@@ -1,4 +1,4 @@
-#!/usr/local/bin/perl -w
+#!/usr/bin/perl -w
 
 use strict;
 use IO::File;
@@ -24,91 +24,124 @@ validate your packlists and even create a tarball from an installed module.
 =cut
 
 
-sub do_module($)
-{
-my ($module) = @_;
-my $help = <<EOF;
+my $Module_Help = <<EOF;
 Available commands are:
    f [all|prog|doc]   - List installed files of a given type
    d [all|prog|doc]   - List the directories used by a module
    v                  - Validate the .packlist - check for missing files
    t <tarfile>        - Create a tar archive of the module
+   h                  - Display module help
    q                  - Quit the module
 EOF
-print($help);
-while (1)
-   {
-   print("$module cmd? ");
-   my $reply = <STDIN>; chomp($reply);
-   CASE:
-      {
-      $reply =~ /^f\s*/ and do
-         {
-         my $class = (split(' ', $reply))[1];
-         $class = 'all' if (! $class);
-         my @files;
-         if (eval { @files = $Inst->files($module, $class); })
-            {
-            print("$class files in $module are:\n   ",
-                  join("\n   ", @files), "\n");
-            last CASE;
-            }
-         else
-            { print($@); }
-         };
-      $reply =~ /^d\s*/ and do
-         {
-         my $class = (split(' ', $reply))[1];
-         $class = 'all' if (! $class);
-         my @dirs;
-         if (eval { @dirs = $Inst->directories($module, $class); })
-            {
-            print("$class directories in $module are:\n   ",
-                  join("\n   ", @dirs), "\n");
-            last CASE;
-            }
-         else
-            { print($@); }
-         };
-      $reply =~ /^t\s*/ and do
-         {
-         my $file = (split(' ', $reply))[1];
-         my $tmp = "/tmp/inst.$$";
-         if (my $fh = IO::File->new($tmp, "w"))
-            {
-            $fh->print(join("\n", $Inst->files($module)));
-            $fh->close();
-            system("tar cvf $file -I $tmp");
-            unlink($tmp);
-            last CASE;
-            }
-         else { print("Can't open $file: $!\n"); }
-         last CASE;
-         };
-      $reply eq 'v' and do
-         {
-         if (my @missing = $Inst->validate($module))
-            {
-            print("Files missing from $module are:\n   ",
-                  join("\n   ", @missing), "\n");
-            }
-         else
-            {
-            print("$module has no missing files\n");
-            }
-         last CASE;
-         };
-      $reply eq 'q' and do
-         {
-         return;
-         };
-      # Default
-         print($help);
-      }
-   }
+
+my %Module_Commands = (
+                       f => \&list_installed,
+                       d => \&list_directories,
+                       v => \&validate_packlist,
+                       t => \&create_archive,
+                       h => \&module_help,
+                      );
+
+sub do_module($) {
+    my ($module) = @_;
+
+    print($Module_Help);
+    MODULE_CMD: while (1) {
+        print("$module cmd? ");
+
+        my $reply = <STDIN>; chomp($reply);
+        my($cmd) = $reply =~ /^(\w)\b/;
+
+        last if $cmd eq 'q';
+
+        if( $Module_Commands{$cmd} ) {
+            $Module_Commands{$cmd}->($reply, $module);
+        }
+        elsif( $cmd eq 'q' ) {
+            last MODULE_CMD;
+        }
+        else {
+            module_help();
+        }
+    }
+}
+
+
+sub list_installed {
+    my($reply, $module) = @_;
+
+    my $class = (split(' ', $reply))[1];
+    $class = 'all' unless $class;
+
+    my @files;
+    if (eval { @files = $Inst->files($module, $class); }) {
+        print("$class files in $module are:\n   ",
+              join("\n   ", @files), "\n");
+    }
+    else { 
+        print($@); 
+    }
+};
+
+
+sub list_directories {
+    my($reply, $module) = @_;
+
+    my $class = (split(' ', $reply))[1];
+    $class = 'all' unless $class;
+
+    my @dirs;
+    if (eval { @dirs = $Inst->directories($module, $class); }) {
+        print("$class directories in $module are:\n   ",
+              join("\n   ", @dirs), "\n");
+    }
+    else { 
+        print($@); 
+    }
 }
 
-################################################################################
+
+sub create_archive {
+    my($reply, $module) = @_;
+
+    my $file = (split(' ', $reply))[1];
+
+    if( !(defined $file and length $file) ) {
+        print "No tar file specified\n";
+    }
+    elsif( eval { require Archive::Tar } ) {
+        Archive::Tar->create_archive($file, 0, $Inst->files($module));
+    }
+    else {
+        my($first, @rest) = $Inst->files($module);
+        system('tar', 'cvf', $file, $first);
+        for my $f (@rest) {
+            system('tar', 'rvf', $file, $f);
+        }
+        print "Can't use tar\n" if $?;
+    }
+}
+
+
+sub validate_packlist {
+    my($reply, $module) = @_;
+
+    if (my @missing = $Inst->validate($module)) {
+        print("Files missing from $module are:\n   ",
+              join("\n   ", @missing), "\n");
+    }
+    else {
+        print("$module has no missing files\n");
+    }
+}
+
+sub module_help {
+    print $Module_Help;
+}
+
+
+
+##############################################################################
 
 sub toplevel()
 {
@@ -145,10 +178,11 @@ while (1)
    }
 }
 
-################################################################################
+
+###############################################################################
 
 $Inst = ExtUtils::Installed->new();
 @Modules = $Inst->modules();
 toplevel();
 
-################################################################################
+###############################################################################