more bulletproof workaround for mangled paths (updates changes#3345,3350);

provide Win32::GetLongPathName() to complement Win32::GetShortPathName()

p4raw-link: @3350 on //depot/perl: b5ce6607ab4b332cfeb9911174599b4208a0bc29
p4raw-link: @3345 on //depot/perl: 95140b9803ddf95b050f1d52936f19393a6b541c

p4raw-id: //depot/perl@3353

5 files changed, 130 insertions, 18 deletions

diff --git a/t/op/magic.t b/t/op/magic.t
index 9b819a8d7b..8486512b35 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -120,8 +120,9 @@ ok 18, $$ > 0, $$;
     $script = "$wd/show-shebang";
     if ($Is_MSWin32) {
 	chomp($wd = `cd`);
-	$perl = "$wd\\perl.exe";
-	$script = "$wd\\show-shebang.bat";
+	$wd =~ s|\\|/|g;
+	$perl = "$wd/perl.exe";
+	$script = "$wd/show-shebang.bat";
 	$headmaybe = <<EOH ;
 \@rem ='
 \@echo off
diff --git a/win32/makedef.pl b/win32/makedef.pl
index 0a753fbfe1..f13c1da0a7 100644
--- a/win32/makedef.pl
+++ b/win32/makedef.pl
@@ -462,6 +462,7 @@ win32_telldir
 win32_seekdir
 win32_rewinddir
 win32_closedir
+win32_longpath
 Perl_win32_init
 Perl_init_os_extras
 Perl_getTHR
diff --git a/win32/runperl.c b/win32/runperl.c
index 20423c7660..1b569d2557 100644
--- a/win32/runperl.c
+++ b/win32/runperl.c
@@ -44,8 +44,7 @@ main(int argc, char **argv, char **env)
     char *ptr;
 
     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
-    (void)GetFullPathName(szModuleName, sizeof(szModuleName),
-			  szModuleName, &ptr);
+    (void)win32_longpath(szModuleName);
     argv[0] = szModuleName;
 #endif
 
@@ -93,8 +92,7 @@ main(int argc, char **argv, char **env)
     char *ptr;
 
     GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
-    (void)GetFullPathName(szModuleName, sizeof(szModuleName),
-			  szModuleName, &ptr);
+    (void)win32_longpath(szModuleName);
     argv[0] = szModuleName;
 #endif
     return RunPerl(argc, argv, env, (void*)0);
diff --git a/win32/win32.c b/win32/win32.c
index 5e54571d78..1e4e4c53fa 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -100,6 +100,7 @@ static long		find_pid(int pid);
 static char *		qualified_path(const char *cmd);
 
 HANDLE	w32_perldll_handle = INVALID_HANDLE_VALUE;
+char	w32_module_name[MAX_PATH+1];
 static DWORD	w32_platform = (DWORD)-1;
 
 #ifdef USE_THREADS
@@ -192,19 +193,27 @@ get_emd_part(char *prev_path, char *trailing_path, ...)
     sprintf(base, "%5.3f",
 	    (double)PERL_REVISION + ((double)PERL_VERSION / (double)1000));
 
-    GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
-				? GetModuleHandle(NULL) : w32_perldll_handle),
-		      mod_name, sizeof(mod_name));
-    /* try to get full path to binary (which may be mangled when perl is
-     * run from a 16-bit app */
-    (void)GetFullPathName(mod_name, sizeof(mod_name), mod_name, &ptr);
-    ptr = mod_name;
-    /* normalize to forward slashes */
-    while (*ptr) {
-	if (*ptr == '\\')
-	    *ptr = '/';
-	++ptr;
+    if (!*w32_module_name) {
+	GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
+				    ? GetModuleHandle(NULL)
+				    : w32_perldll_handle),
+			  w32_module_name, sizeof(w32_module_name));
+
+	/* try to get full path to binary (which may be mangled when perl is
+	 * run from a 16-bit app) */
+	/*PerlIO_printf(PerlIO_stderr(), "Before %s\n", w32_module_name);*/
+	(void)win32_longpath(w32_module_name);
+	/*PerlIO_printf(PerlIO_stderr(), "After  %s\n", w32_module_name);*/
+
+	/* normalize to forward slashes */
+	ptr = w32_module_name;
+	while (*ptr) {
+	    if (*ptr == '\\')
+		*ptr = '/';
+	    ++ptr;
+	}
     }
+    strcpy(mod_name, w32_module_name);
     ptr = strrchr(mod_name, '/');
     while (ptr && strip) {
         /* look for directories to skip back */
@@ -979,6 +988,83 @@ win32_stat(const char *path, struct stat *buffer)
     return res;
 }
 
+/* Find the longname of a given path.  path is destructively modified.
+ * It should have space for at least MAX_PATH characters. */
+DllExport char *
+win32_longpath(char *path)
+{
+    WIN32_FIND_DATA fdata;
+    HANDLE fhand;
+    char tmpbuf[MAX_PATH+1];
+    char *tmpstart = tmpbuf;
+    char *start = path;
+    char sep;
+    if (!path)
+	return Nullch;
+
+    /* drive prefix */
+    if (isALPHA(path[0]) && path[1] == ':' &&
+	(path[2] == '/' || path[2] == '\\'))
+    {
+	start = path + 2;
+	*tmpstart++ = path[0];
+	*tmpstart++ = ':';
+    }
+    /* UNC prefix */
+    else if ((path[0] == '/' || path[0] == '\\') &&
+	     (path[1] == '/' || path[1] == '\\'))
+    {
+	start = path + 2;
+	*tmpstart++ = '/';
+	*tmpstart++ = '/';
+	/* copy machine name */
+	while (*start && *start != '/' && *start != '\\')
+	    *tmpstart++ = *start++;
+	if (*start) {
+	    *tmpstart++ = '/';
+	    start++;
+	    /* copy share name */
+	    while (*start && *start != '/' && *start != '\\')
+		*tmpstart++ = *start++;
+	}
+    }
+    sep = *start++;
+    if (sep == '/' || sep == '\\')
+	*tmpstart++ = '/';
+    *tmpstart = '\0';
+    while (sep) {
+	/* walk up to slash */
+	while (*start && *start != '/' && *start != '\\')
+	    ++start;
+
+	/* discard doubled slashes */
+	while (*start && (start[1] == '/' || start[1] == '\\'))
+	    ++start;
+	sep = *start;
+
+	/* stop and find full name of component */
+	*start = '\0';
+	fhand = FindFirstFile(path,&fdata);
+	if (fhand != INVALID_HANDLE_VALUE) {
+	    strcpy(tmpstart, fdata.cFileName);
+	    tmpstart += strlen(fdata.cFileName);
+	    if (sep)
+		*tmpstart++ = '/';
+	    *tmpstart = '\0';
+	    *start++ = sep;
+	    FindClose(fhand);
+	}
+	else {
+	    /* failed a step, just return without side effects */
+	    /*PerlIO_printf(PerlIO_stderr(), "Failed to find %s\n", path);*/
+	    *start = sep;
+	    return Nullch;
+	}
+    }
+    strcpy(path,tmpbuf);
+    return path;
+}
+
 #ifndef USE_WIN32_RTL_ENV
 
 DllExport char *
@@ -2843,6 +2929,29 @@ XS(w32_GetFullPathName)
 }
 
 static
+XS(w32_GetLongPathName)
+{
+    dXSARGS;
+    SV *path;
+    char tmpbuf[MAX_PATH+1];
+    char *pathstr;
+    STRLEN len;
+
+    if (items != 1)
+	croak("usage: Win32::GetLongPathName($pathname)");
+
+    path = ST(0);
+    pathstr = SvPV(path,len);
+    strcpy(tmpbuf, pathstr);
+    pathstr = win32_longpath(tmpbuf);
+    if (pathstr) {
+	ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
+	XSRETURN(1);
+    }
+    XSRETURN_EMPTY;
+}
+
+static
 XS(w32_Sleep)
 {
     dXSARGS;
@@ -2882,6 +2991,7 @@ Perl_init_os_extras()
     newXS("Win32::GetTickCount", w32_GetTickCount, file);
     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
     newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
+    newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
     newXS("Win32::Sleep", w32_Sleep, file);
 
     /* XXX Bloat Alert! The following Activeware preloads really
diff --git a/win32/win32iop.h b/win32/win32iop.h
index a0649b1623..bcdc304511 100644
--- a/win32/win32iop.h
+++ b/win32/win32iop.h
@@ -122,6 +122,7 @@ DllExport  unsigned 	win32_sleep(unsigned int);
 DllExport  int		win32_times(struct tms *timebuf);
 DllExport  unsigned 	win32_alarm(unsigned int sec);
 DllExport  int		win32_stat(const char *path, struct stat *buf);
+DllExport  char*	win32_longpath(char *path);
 DllExport  int		win32_ioctl(int i, unsigned int u, char *data);
 DllExport  int		win32_utime(const char *f, struct utimbuf *t);
 DllExport  int		win32_uname(struct utsname *n);
@@ -207,6 +208,7 @@ END_EXTERN_C
 #define abort()			win32_abort()
 #define fstat(fd,bufptr)   	win32_fstat(fd,bufptr)
 #define stat(pth,bufptr)   	win32_stat(pth,bufptr)
+#define longpath(pth)   	win32_longpath(pth)
 #define rename(old,new)		win32_rename(old,new)
 #define setmode(fd,mode)	win32_setmode(fd,mode)
 #define lseek(fd,offset,orig)	win32_lseek(fd,offset,orig)