-S flag fixes for DOSISH platforms

This patch supercedes the one posted here by Ilya
(Message-Id: <199707191651.MAA04897@monk.mps.ohio-state.edu>).

There are no changes for Unix platforms over Ilya's
version.  On DOSISH platforms, the initial check in
the current directory (or the actual path to the script,
if supplied) includes searching for valid extensions.

The fact that -S does not do a PATH search if the supplied
filename contains directory separators (on all platforms) is
documented.  This behavior is similar to Unix and DOS shells.

Note -S *does* have an effect on DOSISH platforms even if no
PATH search happens: valid extensions will be checked for if
the file name is not found.

p5p-msgid: 199707250043.UAA02385@aatma.engin.umich.edu

3 files changed, 113 insertions, 20 deletions

diff --git a/perl.c b/perl.c
index f757d11bed..04543294bf 100644
--- a/perl.c
+++ b/perl.c
@@ -1632,11 +1632,31 @@ SV *sv;
     /* additional extensions to try in each dir if scriptname not found */
 #ifdef SEARCH_EXTS
     char *ext[] = { SEARCH_EXTS };
-    int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
+    int extidx = 0, i = 0;
+    char *curext = Nullch;
 #else
 #  define MAX_EXT_LEN 0
 #endif
 
+    /*
+     * If dosearch is true and if scriptname does not contain path
+     * delimiters, search the PATH for scriptname.
+     *
+     * If SEARCH_EXTS is also defined, will look for each
+     * scriptname{SEARCH_EXTS} whenever scriptname is not found
+     * while searching the PATH.
+     *
+     * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
+     * proceeds as follows:
+     *   If DOSISH:
+     *     + look for ./scriptname{,.foo,.bar}
+     *     + search the PATH for scriptname{,.foo,.bar}
+     *
+     *   If !DOSISH:
+     *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
+     *       this will not look in '.' if it's not in the PATH)
+     */
+
 #ifdef VMS
     if (dosearch) {
 	int hasdir, idx = 0, deftypes = 1;
@@ -1656,42 +1676,78 @@ SV *sv;
 		continue;	/* don't search dir with too-long name */
 	    strcat(tokenbuf, scriptname);
 #else  /* !VMS */
+
+#ifdef DOSISH
+    if (strEQ(scriptname, "-"))
+	dosearch = 0;
+    if (dosearch) {		/* Look in '.' first. */
+	char *cur = scriptname;
+#ifdef SEARCH_EXTS
+	if ((curext = strrchr(scriptname,'.')))	/* possible current ext */
+	    while (ext[i])
+		if (strEQ(ext[i++],curext)) {
+		    extidx = -1;		/* already has an ext */
+		    break;
+		}
+	do {
+#endif
+	    DEBUG_p(PerlIO_printf(Perl_debug_log,
+				  "Looking for %s\n",cur));
+	    if (Stat(cur,&statbuf) >= 0) {
+		dosearch = 0;
+		scriptname = cur;
+		break;
+	    }
+#ifdef SEARCH_EXTS
+	    if (cur == scriptname) {
+		len = strlen(scriptname);
+		if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
+		    break;
+		cur = strcpy(tokenbuf, scriptname);
+	    }
+	} while (extidx >= 0 && ext[extidx]	/* try an extension? */
+		 && strcpy(tokenbuf+len, ext[extidx++]));
+#endif
+    }
+#endif
     if (dosearch && !strchr(scriptname, '/')
 #ifdef DOSISH
 		 && !strchr(scriptname, '\\')
 #endif
 		 && (s = getenv("PATH"))) {
+	bool seen_dot = 0;
+
 	bufend = s + strlen(s);
 	while (s < bufend) {
-#ifndef atarist
-	    s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
-#ifdef DOSISH
-			 ';',
-#else
-			 ':',
-#endif
-			 &len);
-#else  /* atarist */
-	    for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
+#if defined(atarist) || defined(DOSISH)
+	    for (len = 0; *s
+#  ifdef atarist
+		    && *s != ','
+#  endif
+		    && *s != ';'; len++, s++) {
 		if (len < sizeof tokenbuf)
 		    tokenbuf[len] = *s;
 	    }
 	    if (len < sizeof tokenbuf)
 		tokenbuf[len] = '\0';
-#endif /* atarist */
+#else	/* ! (atarist || DOSISH) */
+	    s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend
+			 ':',
+			 &len);
+#endif	/* ! (atarist || DOSISH) */
 	    if (s < bufend)
 		s++;
 	    if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
 		continue;	/* don't search dir with too-long name */
 	    if (len
-#if defined(atarist) && !defined(DOSISH)
-		&& tokenbuf[len - 1] != '/'
-#endif
 #if defined(atarist) || defined(DOSISH)
+		&& tokenbuf[len - 1] != '/'
 		&& tokenbuf[len - 1] != '\\'
 #endif
 	       )
 		tokenbuf[len++] = '/';
+	    if (len == 2 && tokenbuf[0] == '.') 
+		seen_dot = 1;
 	    (void)strcpy(tokenbuf + len, scriptname);
 #endif  /* !VMS */
 
@@ -1724,8 +1780,16 @@ SV *sv;
 	    if (!xfailed)
 		xfailed = savepv(tokenbuf);
 	}
+#ifndef DOSISH
+	if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+#endif 
+	    seen_dot = 1;		/* Disable message. */
 	if (!xfound)
-	    croak("Can't execute %s", xfailed ? xfailed : scriptname );
+	    croak("Can't %s %s%s%s", 
+		  (xfailed ? "execute" : "find"),
+		  (xfailed ? xfailed : scriptname),
+		  (xfailed ? "" : " on PATH"),
+		  (xfailed || seen_dot) ? "" : ", '.' not in PATH");
 	if (xfailed)
 	    Safefree(xfailed);
 	scriptname = xfound;
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index ab40fd122d..409aa21ec0 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -549,8 +549,19 @@ mention "perl" on the #! line somewhere.
 
 =item Can't execute %s
 
+(F) You used the B<-S> switch, but the copies of the script to execute found
+in the PATH did not have correct permissions.
+
+=item Can't find %s on PATH, '.' not in PATH
+
+(F) You used the B<-S> switch, but the script to execute could not be found
+in the PATH, or at least not with the correct permissions.  The script
+exists in the current directory, but PATH prohibits running it.
+
+=item Can't find %s on PATH
+
 (F) You used the B<-S> switch, but the script to execute could not be found
-in the PATH, or at least not with the correct permissions.
+in the PATH.
 
 =item Can't find label %s
 
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 61e40f88a0..19aa0a2a9e 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -431,9 +431,27 @@ prints "true" if and only if the script is invoked with a B<-xyz> switch.
 =item B<-S>
 
 makes Perl use the PATH environment variable to search for the
-script (unless the name of the script starts with a slash).  Typically
-this is used to emulate #! startup on machines that don't support #!,
-in the following manner:
+script (unless the name of the script contains directory separators).
+On some platforms, this also makes Perl append suffixes to the
+filename while searching for it.  For example, on Win32 platforms,
+the ".bat" and ".cmd" suffixes are appended if a lookup for the
+original name fails, and if the name does not already end in one
+of those suffixes.  If your Perl was compiled with DEBUGGING turned
+on, using the -Dp switch to Perl shows how the search progresses.
+
+If the file supplied contains directory separators (i.e. it is an
+absolute or relative pathname), and if the file is not found,
+platforms that append file extensions will do so and try to look
+for the file with those extensions added, one by one.
+
+On DOS-like platforms, if the script does not contain directory
+separators, it will first be searched for in the current directory
+before being searched for on the PATH.  On Unix platforms, the
+script will be searched for strictly on the PATH.
+
+Typically this is used to emulate #! startup on platforms that
+don't support #!.  This example works on many platforms that
+have a shell compatible with Bourne shell:
 
     #!/usr/bin/perl
     eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'