Accept globs for directory name responses

git-svn-id: http://svn.code.sf.net/p/netpbm/code/trunk@2981 9d0c8265-081b-0410-96cb-a4ca84ce46f8

2 files changed, 85 insertions, 14 deletions

diff --git a/buildtools/installnetpbm.pl b/buildtools/installnetpbm.pl
index c4a30d17..e9bcd231 100755
--- a/buildtools/installnetpbm.pl
+++ b/buildtools/installnetpbm.pl
@@ -46,6 +46,37 @@ sub prompt($$) {
 
 
 
+sub fsObjPrompt($$) {
+    my ($prompt, $default) = @_;
+#-----------------------------------------------------------------------------
+#  Prompt for a filesystem object name and accept glob pattern such as
+#  ~/mydir and /usr/lib/net* .
+#
+#  If there are zero or multiple filesystem object names that match the
+#  pattern the user gave, ask again.  If there is only one possible name
+#  consistent with the user's response, return that even if no filesystem
+#  object by that name exists.
+#-----------------------------------------------------------------------------
+    my $globbedResponse;
+
+    while (!$globbedResponse) {
+        my $response = prompt($prompt, $default);
+
+        my @matchList = glob($response);
+
+        if (@matchList == 0) {
+            print("No filesystem object matches that pattern\n");
+        } elsif (@matchList > 1) {
+            print("Multiple filesystem objects match that pattern\n");
+        } else {
+            $globbedResponse = $matchList[0];
+        }
+    }
+    return $globbedResponse;
+}
+
+
+
 sub getPkgdir() {
 #-----------------------------------------------------------------------------
 #  Find out from the user where the Netpbm package is (i.e. where
@@ -53,6 +84,17 @@ sub getPkgdir() {
 #-----------------------------------------------------------------------------
     my $pkgdir;
 
+    # We allow the user to respond with a shell filename pattern.  This seems
+    # like a lot of complexity for a barely useful feature, but we actually
+    # saw a problem where a user typed ~/mypackage without realizing that ~ is
+    # a globbing thing and was stumped when we said no such file exists, while
+    # shell commands said it does.
+
+    # Note that glob() of something that has no wildcard/substitution
+    # characters just returns its argument, whether a filesystem object by
+    # that name exists or not.  But for a wildcard pattern that doesn't match
+    # any existing files, glob() returns an empty list.
+
     while (!$pkgdir) {
     
         print("Where is the install package you created with " .
@@ -61,13 +103,32 @@ sub getPkgdir() {
         
         my $response = prompt("package directory", $default);
 
-        if (!-f("$response/pkginfo")) {
-            print("This does not appear to be a Netpbm install package. \n");
-            print("A file named $response/pkginfo does not exist.\n");
-            print("\n");
+        my @matchList = glob($response);
+
+        if (@matchList == 0) {
+            print("No filesystem object matches that pattern\n");
+        } elsif (@matchList > 1) {
+            print("Multiple filesystem objects match that pattern\n");
         } else {
-            $pkgdir = $response;
+            my $fsObjNm = $matchList[0];
+            
+            if (!-e($fsObjNm)) {
+                print("No filesystem object named '$fsObjNm' exists.\n");
+            } else {
+                if (!-d($fsObjNm)) {
+                    print("'$fsObjNm' is not a directory\n");
+                } else {
+                    if (!-f("$fsObjNm/pkginfo")) {
+                        print("Directory '$fsObjNm' does not appear to be " .
+                              "a Netpbm install package. \n");
+                        print("It does not contain a file named 'pkginfo'.\n");
+                    } else {
+                        $pkgdir = $fsObjNm;
+                    }
+                }
+            }
         }
+        print("\n");
     }
     print("\n");
     return $pkgdir;
@@ -80,8 +141,8 @@ sub makePrefixDirectory($) {
     my ($prefixDir) = @_;
 
     if ($prefixDir ne "" and !-d($prefixDir)) {
-        print("No directory named '$prefixDir' exists.  Do you want " .
-              "to create it?\n");
+        print("No directory named '$prefixDir' exists.  " .
+              "Do you want to create it?\n");
 
         my $done;
         while (!$done) {
@@ -97,6 +158,7 @@ sub makePrefixDirectory($) {
                 $done = $TRUE;
             } 
         }
+        print("\n");
     }
 }
 
@@ -123,7 +185,7 @@ sub getPrefix() {
         $default = "/usr/local/netpbm";
     }
 
-    my $response = prompt("install prefix", $default);
+    my $response = fsObjPrompt("install prefix", $default);
 
     my $prefix;
 
@@ -185,7 +247,7 @@ sub getBinDir($) {
     while (!$binDir) {
         my $default = "$prefix/bin";
 
-        my $response = prompt("program directory", $default);
+        my $response = fsObjPrompt("program directory", $default);
         
         if (-d($response)) {
             $binDir = $response;
@@ -243,7 +305,7 @@ sub getLibDir($) {
     while (!$libDir) {
         my $default = "$prefix/lib";
 
-        my $response = prompt("shared library directory", $default);
+        my $response = fsObjPrompt("shared library directory", $default);
         
         if (-d($response)) {
             $libDir = $response;
@@ -574,7 +636,7 @@ sub getLinkDir($) {
     while (!$linkDir) {
         my $default = "$prefix/lib";
 
-        my $response = prompt("static library directory", $default);
+        my $response = fsObjPrompt("static library directory", $default);
         
         if (-d($response)) {
             $linkDir = $response;
@@ -637,7 +699,7 @@ sub getDataDir($) {
     while (!$dataDir) {
         my $default = "$prefix/lib";
 
-        my $response = prompt("data file directory", $default);
+        my $response = fsObjPrompt("data file directory", $default);
         
         if (-d($response)) {
             $dataDir = $response;
@@ -674,7 +736,7 @@ sub getHdrDir($) {
     while (!$hdrDir) {
         my $default = "$prefix/include";
 
-        my $response = prompt("header directory", $default);
+        my $response = fsObjPrompt("header directory", $default);
         
         if (-d($response)) {
             $hdrDir = $response;
@@ -877,7 +939,7 @@ sub getPkgconfigDir($) {
     while (!$pkgconfigDir) {
         my $default = "$prefix/lib/pkgconfig";
 
-        my $response = prompt("Pkg-config directory", $default);
+        my $response = fsObjPrompt("Pkg-config directory", $default);
         
         if (-d($response)) {
             $pkgconfigDir = $response;
@@ -959,8 +1021,14 @@ print("\n");
 
 my $pkgdir = getPkgdir();
 
+print("Installing from package directory '$pkgdir'\n");
+print("\n");
+
 my $prefix = getPrefix();
 
+print("Using prefix '$prefix'\n");
+print("\n");
+
 $cpCommand = getCpCommand();
 
 installProgram($pkgdir, $prefix, \my $bindir);
diff --git a/doc/HISTORY b/doc/HISTORY
index 89d42711..5e72167b 100644
--- a/doc/HISTORY
+++ b/doc/HISTORY
@@ -45,6 +45,9 @@ not yet  BJH  Release 10.79.00
               (September 2007), but wouldn't even compile until Netpbm 10.42
               (March 2008)).
 
+              Installnetpbm: Accept globs for directory name responses
+              (notably, ~/DIR).
+
               Build: don't try to build standardppmdfont.c if it already
               exists (so don't require ppmdcfont to exist).  Broken around
               Netpbm 10.35 (2006).