X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fwin32.c;h=9ae2a7d70fe25cbd44c2836dca056f1dbaf7822b;hb=377729033bd4c3e2f6c0ac6b0d2bde9a83c5da6d;hp=613d9815ca3a672a48e95d5ca02a94866d6c4bb6;hpb=5b0d9cbecfd90628c0e955ee142f05f9b60bcf43;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/win32/win32.c b/win32/win32.c
index 613d981..9ae2a7d 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -47,38 +47,66 @@ int _CRT_glob = 0;
 #define EXECF_SPAWN 2
 #define EXECF_SPAWN_NOWAIT 3
 
-static DWORD IdOS(void);
-
-BOOL  ProbeEnv = FALSE;
-DWORD Win32System = (DWORD)-1;
-char  szShellPath[MAX_PATH+1];
-char  szPerlLibRoot[MAX_PATH+1];
-HANDLE PerlDllHandle = INVALID_HANDLE_VALUE;
+static DWORD		os_id(void);
+static void		get_shell(void);
+static long		tokenize(char *str, char **dest, char ***destv);
+static int		do_spawn2(char *cmd, int exectype);
+static BOOL		has_redirection(char *ptr);
+static long		filetime_to_clock(PFILETIME ft);
+
+char *	w32_perlshell_tokens = Nullch;
+char **	w32_perlshell_vec;
+long	w32_perlshell_items = -1;
+DWORD	w32_platform = (DWORD)-1;
+char	w32_perllib_root[MAX_PATH+1];
+HANDLE	w32_perldll_handle = INVALID_HANDLE_VALUE;
+#ifndef __BORLANDC__
+long	w32_num_children = 0;
+HANDLE	w32_child_pids[MAXIMUM_WAIT_OBJECTS];
+#endif
 
-static int do_spawn2(char *cmd, int exectype);
+#ifdef USE_THREADS
+#  ifdef USE_DECLSPEC_THREAD
+__declspec(thread) char	strerror_buffer[512];
+__declspec(thread) char	getlogin_buffer[128];
+#    ifdef HAVE_DES_FCRYPT
+__declspec(thread) char	crypt_buffer[30];
+#    endif
+#  else
+#    define strerror_buffer	(thr->i.Wstrerror_buffer)
+#    define getlogin_buffer	(thr->i.Wgetlogin_buffer)
+#    define crypt_buffer	(thr->i.Wcrypt_buffer)
+#  endif
+#else
+char	strerror_buffer[512];
+char	getlogin_buffer[128];
+#  ifdef HAVE_DES_FCRYPT
+char	crypt_buffer[30];
+#  endif
+#endif
 
 int 
 IsWin95(void) {
-    return (IdOS() == VER_PLATFORM_WIN32_WINDOWS);
+    return (os_id() == VER_PLATFORM_WIN32_WINDOWS);
 }
 
 int
 IsWinNT(void) {
-    return (IdOS() == VER_PLATFORM_WIN32_NT);
+    return (os_id() == VER_PLATFORM_WIN32_NT);
 }
 
 char *
-win32PerlLibPath(char *sfx,...)
+win32_perllib_path(char *sfx,...)
 {
     va_list ap;
     char *end;
     va_start(ap,sfx);
-    GetModuleFileName((PerlDllHandle == INVALID_HANDLE_VALUE) 
+    GetModuleFileName((w32_perldll_handle == INVALID_HANDLE_VALUE) 
 		      ? GetModuleHandle(NULL)
-		      : PerlDllHandle,
-		      szPerlLibRoot, 
-		      sizeof(szPerlLibRoot));
-    *(end = strrchr(szPerlLibRoot, '\\')) = '\0';
+		      : w32_perldll_handle,
+		      w32_perllib_root, 
+		      sizeof(w32_perllib_root));
+    *(end = strrchr(w32_perllib_root, '\\')) = '\0';
     if (stricmp(end-4,"\\bin") == 0)
      end -= 4;
     strcpy(end,"\\lib");
@@ -89,12 +117,12 @@ win32PerlLibPath(char *sfx,...)
       sfx = va_arg(ap,char *);
      }
     va_end(ap); 
-    return (szPerlLibRoot);
+    return (w32_perllib_root);
 }
 
 
-BOOL
-HasRedirection(char *ptr)
+static BOOL
+has_redirection(char *ptr)
 {
     int inquote = 0;
     char quote = '\0';
@@ -167,24 +195,75 @@ my_pclose(PerlIO *fp)
 }
 
 static DWORD
-IdOS(void)
+os_id(void)
 {
     static OSVERSIONINFO osver;
 
-    if (osver.dwPlatformId != Win32System) {
+    if (osver.dwPlatformId != w32_platform) {
 	memset(&osver, 0, sizeof(OSVERSIONINFO));
 	osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
 	GetVersionEx(&osver);
-	Win32System = osver.dwPlatformId;
+	w32_platform = osver.dwPlatformId;
+    }
+    return (w32_platform);
+}
+
+/* Tokenize a string.  Words are null-separated, and the list
+ * ends with a doubled null.  Any character (except null and
+ * including backslash) may be escaped by preceding it with a
+ * backslash (the backslash will be stripped).
+ * Returns number of words in result buffer.
+ */
+static long
+tokenize(char *str, char **dest, char ***destv)
+{
+    char *retstart = Nullch;
+    char **retvstart = 0;
+    int items = -1;
+    if (str) {
+	int slen = strlen(str);
+	register char *ret;
+	register char **retv;
+	New(1307, ret, slen+2, char);
+	New(1308, retv, (slen+3)/2, char*);
+
+	retstart = ret;
+	retvstart = retv;
+	*retv = ret;
+	items = 0;
+	while (*str) {
+	    *ret = *str++;
+	    if (*ret == '\\' && *str)
+		*ret = *str++;
+	    else if (*ret == ' ') {
+		while (*str == ' ')
+		    str++;
+		if (ret == retstart)
+		    ret--;
+		else {
+		    *ret = '\0';
+		    ++items;
+		    if (*str)
+			*++retv = ret+1;
+		}
+	    }
+	    else if (!*str)
+		++items;
+	    ret++;
+	}
+	retvstart[items] = Nullch;
+	*ret++ = '\0';
+	*ret = '\0';
     }
-    return (Win32System);
+    *dest = retstart;
+    *destv = retvstart;
+    return items;
 }
 
-static char *
-GetShell(void)
+static void
+get_shell(void)
 {
-    if (!ProbeEnv) {
-	char* defaultshell = (IsWinNT() ? "cmd.exe" : "command.com");
+    if (!w32_perlshell_tokens) {
 	/* we don't use COMSPEC here for two reasons:
 	 *  1. the same reason perl on UNIX doesn't use SHELL--rampant and
 	 *     uncontrolled unportability of the ensuing scripts.
@@ -192,59 +271,75 @@ GetShell(void)
 	 *     interactive use (which is what most programs look in COMSPEC
 	 *     for).
 	 */
-	char *usershell = getenv("PERL5SHELL");  
-
-	ProbeEnv = TRUE;
-	strcpy(szShellPath, usershell ? usershell : defaultshell);
+	char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c");
+	char *usershell = getenv("PERL5SHELL");
+	w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
+				       &w32_perlshell_tokens,
+				       &w32_perlshell_vec);
     }
-    return szShellPath;
 }
 
 int
-do_aspawn(void* really, void ** mark, void ** arglast)
+do_aspawn(void *vreally, void **vmark, void **vsp)
 {
+    SV *really = (SV*)vreally;
+    SV **mark = (SV**)vmark;
+    SV **sp = (SV**)vsp;
     char **argv;
-    char *strPtr;
-    char *cmd;
+    char *str;
     int status;
-    unsigned int length;
+    int flag = P_WAIT;
     int index = 0;
-    SV *sv = (SV*)really;
-    SV** pSv = (SV**)mark;
 
-    New(1310, argv, (arglast - mark) + 4, char*);
+    if (sp <= mark)
+	return -1;
+
+    get_shell();
+    New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
 
-    if(sv != Nullsv) {
-	cmd = SvPV(sv, length);
-    }
-    else {
-	argv[index++] = cmd = GetShell();
-	if (IsWinNT())
-	    argv[index++] = "/x";   /* always enable command extensions */
-	argv[index++] = "/c";
+    if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
+	++mark;
+	flag = SvIVx(*mark);
     }
 
-    while(++pSv <= (SV**)arglast) {
-	sv = *pSv;
-	strPtr = SvPV(sv, length);
-	if(strPtr != NULL && *strPtr != '\0')
-	    argv[index++] = strPtr;
+    while(++mark <= sp) {
+	if (*mark && (str = SvPV(*mark, na)))
+	    argv[index++] = str;
+	else
+	    argv[index++] = "";
     }
     argv[index++] = 0;
    
-    status = win32_spawnvp(P_WAIT, cmd, (const char* const*)argv);
-
-    Safefree(argv);
+    status = win32_spawnvp(flag,
+			   (really ? SvPV(really,na) : argv[0]),
+			   (const char* const*)argv);
+
+    if (status < 0 && errno == ENOEXEC) {
+	/* possible shell-builtin, invoke with shell */
+	int sh_items;
+	sh_items = w32_perlshell_items;
+	while (--index >= 0)
+	    argv[index+sh_items] = argv[index];
+	while (--sh_items >= 0)
+	    argv[sh_items] = w32_perlshell_vec[sh_items];
+   
+	status = win32_spawnvp(flag,
+			       (really ? SvPV(really,na) : argv[0]),
+			       (const char* const*)argv);
+    }
 
     if (status < 0) {
 	if (dowarn)
-	    warn("Can't spawn \"%s\": %s", cmd, strerror(errno));
-	status = 255 << 8;
+	    warn("Can't spawn \"%s\": %s", argv[0], strerror(errno));
+	status = 255 * 256;
     }
-    return (status);
+    else if (flag != P_NOWAIT)
+	status *= 256;
+    Safefree(argv);
+    return (statusvalue = status);
 }
 
-int
+static int
 do_spawn2(char *cmd, int exectype)
 {
     char **a;
@@ -252,13 +347,11 @@ do_spawn2(char *cmd, int exectype)
     char **argv;
     int status = -1;
     BOOL needToTry = TRUE;
-    char *shell, *cmd2;
+    char *cmd2;
 
-    /* save an extra exec if possible */
-    shell = GetShell();
-
-    /* see if there are shell metacharacters in it */
-    if(!HasRedirection(cmd)) {
+    /* Save an extra exec if possible. See if there are shell
+     * metacharacters in it */
+    if(!has_redirection(cmd)) {
 	New(1301,argv, strlen(cmd) / 2 + 2, char*);
 	New(1302,cmd2, strlen(cmd) + 1, char);
 	strcpy(cmd2, cmd);
@@ -274,7 +367,7 @@ do_spawn2(char *cmd, int exectype)
 		*s++ = '\0';
 	}
 	*a = Nullch;
-	if(argv[0]) {
+	if (argv[0]) {
 	    switch (exectype) {
 	    case EXECF_SPAWN:
 		status = win32_spawnvp(P_WAIT, argv[0],
@@ -288,19 +381,21 @@ do_spawn2(char *cmd, int exectype)
 		status = win32_execvp(argv[0], (const char* const*)argv);
 		break;
 	    }
-	    if(status != -1 || errno == 0)
+	    if (status != -1 || errno == 0)
 		needToTry = FALSE;
 	}
 	Safefree(argv);
 	Safefree(cmd2);
     }
-    if(needToTry) {
-	char *argv[5];
-	int i = 0;
-	argv[i++] = shell;
-	if (IsWinNT())
-	    argv[i++] = "/x";
-	argv[i++] = "/c"; argv[i++] = cmd; argv[i] = Nullch;
+    if (needToTry) {
+	char **argv;
+	int i = -1;
+	get_shell();
+	New(1306, argv, w32_perlshell_items + 2, char*);
+	while (++i < w32_perlshell_items)
+	    argv[i] = w32_perlshell_vec[i];
+	argv[i++] = cmd;
+	argv[i] = Nullch;
 	switch (exectype) {
 	case EXECF_SPAWN:
 	    status = win32_spawnvp(P_WAIT, argv[0],
@@ -314,16 +409,19 @@ do_spawn2(char *cmd, int exectype)
 	    status = win32_execvp(argv[0], (const char* const*)argv);
 	    break;
 	}
+	cmd = argv[0];
+	Safefree(argv);
     }
     if (status < 0) {
 	if (dowarn)
 	    warn("Can't %s \"%s\": %s",
 		 (exectype == EXECF_EXEC ? "exec" : "spawn"),
-		 needToTry ? shell : argv[0],
-		 strerror(errno));
-	status = 255 << 8;
+		 cmd, strerror(errno));
+	status = 255 * 256;
     }
-    return (status);
+    else if (exectype != EXECF_SPAWN_NOWAIT)
+	status *= 256;
+    return (statusvalue = status);
 }
 
 int
@@ -332,6 +430,12 @@ do_spawn(char *cmd)
     return do_spawn2(cmd, EXECF_SPAWN);
 }
 
+int
+do_spawn_nowait(char *cmd)
+{
+    return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+}
+
 bool
 do_exec(char *cmd)
 {
@@ -545,15 +649,26 @@ getegid(void)
 }
 
 int
-setuid(uid_t uid)
+setuid(uid_t auid)
 { 
-    return (uid == ROOT_UID ? 0 : -1);
+    return (auid == ROOT_UID ? 0 : -1);
 }
 
 int
-setgid(gid_t gid)
+setgid(gid_t agid)
+{
+    return (agid == ROOT_GID ? 0 : -1);
+}
+
+char *
+getlogin(void)
 {
-    return (gid == ROOT_GID ? 0 : -1);
+    dTHR;
+    char *buf = getlogin_buffer;
+    DWORD size = sizeof(getlogin_buffer);
+    if (GetUserName(buf,&size))
+	return buf;
+    return (char*)NULL;
 }
 
 /*
@@ -579,15 +694,6 @@ kill(int pid, int sig)
  * File system stuff
  */
 
-#if 0
-int
-ioctl(int i, unsigned int u, char *data)
-{
-    croak("ioctl not implemented!\n");
-    return -1;
-}
-#endif
-
 DllExport unsigned int
 win32_sleep(unsigned int t)
 {
@@ -661,7 +767,7 @@ win32_getenv(const char *name)
 #endif
 
 static long
-FileTimeToClock(PFILETIME ft)
+filetime_to_clock(PFILETIME ft)
 {
  __int64 qw = ft->dwHighDateTime;
  qw <<= 32;
@@ -678,8 +784,8 @@ win32_times(struct tms *timebuf)
     FILETIME dummy;
     if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, 
                         &kernel,&user)) {
-	timebuf->tms_utime = FileTimeToClock(&user);
-	timebuf->tms_stime = FileTimeToClock(&kernel);
+	timebuf->tms_utime = filetime_to_clock(&user);
+	timebuf->tms_stime = filetime_to_clock(&kernel);
 	timebuf->tms_cutime = 0;
 	timebuf->tms_cstime = 0;
         
@@ -694,8 +800,53 @@ win32_times(struct tms *timebuf)
     return 0;
 }
 
-static UINT timerid = 0;
+DllExport int
+win32_wait(int *status)
+{
+#ifdef __BORLANDC__
+    return wait(status);
+#else
+    /* XXX this wait emulation only knows about processes
+     * spawned via win32_spawnvp(P_NOWAIT, ...).
+     */
+    int i, retval;
+    DWORD exitcode, waitcode;
+
+    if (!w32_num_children) {
+	errno = ECHILD;
+	return -1;
+    }
 
+    /* if a child exists, wait for it to die */
+    waitcode = WaitForMultipleObjects(w32_num_children,
+				      w32_child_pids,
+				      FALSE,
+				      INFINITE);
+    if (waitcode != WAIT_FAILED) {
+	if (waitcode >= WAIT_ABANDONED_0
+	    && waitcode < WAIT_ABANDONED_0 + w32_num_children)
+	    i = waitcode - WAIT_ABANDONED_0;
+	else
+	    i = waitcode - WAIT_OBJECT_0;
+	if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) {
+	    CloseHandle(w32_child_pids[i]);
+	    *status = (int)((exitcode & 0xff) << 8);
+	    retval = (int)w32_child_pids[i];
+	    Copy(&w32_child_pids[i+1], &w32_child_pids[i],
+		 (w32_num_children-i-1), HANDLE);
+	    w32_num_children--;
+	    return retval;
+	}
+    }
+
+FAILED:
+    errno = GetLastError();
+    return -1;
+
+#endif
+}
+
+static UINT timerid = 0;
 
 static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
 {
@@ -733,6 +884,17 @@ win32_alarm(unsigned int sec)
     return 0;
 }
 
+#ifdef HAVE_DES_FCRYPT
+extern char *	des_fcrypt(char *cbuf, const char *txt, const char *salt);
+
+DllExport char *
+win32_crypt(const char *txt, const char *salt)
+{
+    dTHR;
+    return des_fcrypt(crypt_buffer, txt, salt);
+}
+#endif
+
 #ifdef USE_FIXED_OSFHANDLE
 
 EXTERN_C int __cdecl _alloc_osfhnd(void);
@@ -936,8 +1098,6 @@ win32_feof(FILE *fp)
  * we have to roll our own.
  */
 
-__declspec(thread) char	strerror_buffer[512];
-
 DllExport char *
 win32_strerror(int e) 
 {
@@ -947,6 +1107,7 @@ win32_strerror(int e)
     DWORD source = 0;
 
     if(e < 0 || e > sys_nerr) {
+        dTHR;
 	if(e < 0)
 	    e = GetLastError();
 
@@ -959,6 +1120,33 @@ win32_strerror(int e)
     return strerror(e);
 }
 
+DllExport void
+win32_str_os_error(SV *sv, unsigned long dwErr)
+{
+    DWORD dwLen;
+    char *sMsg;
+    dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
+			  |FORMAT_MESSAGE_IGNORE_INSERTS
+			  |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
+			   dwErr, 0, (char *)&sMsg, 1, NULL);
+    if (0 < dwLen) {
+	while (0 < dwLen  &&  isspace(sMsg[--dwLen]))
+	    ;
+	if ('.' != sMsg[dwLen])
+	    dwLen++;
+	sMsg[dwLen]= '\0';
+    }
+    if (0 == dwLen) {
+	sMsg = LocalAlloc(0, 64/**sizeof(TCHAR)*/);
+	dwLen = sprintf(sMsg,
+			"Unknown error #0x%lX (lookup 0x%lX)",
+			dwErr, GetLastError());
+    }
+    sv_setpvn(sv, sMsg, dwLen);
+    LocalFree(sMsg);
+}
+
+
 DllExport int
 win32_fprintf(FILE *fp, const char *format, ...)
 {
@@ -1122,9 +1310,9 @@ win32_abort(void)
 }
 
 DllExport int
-win32_fstat(int fd,struct stat *bufptr)
+win32_fstat(int fd,struct stat *sbufptr)
 {
-    return fstat(fd,bufptr);
+    return fstat(fd,sbufptr);
 }
 
 DllExport int
@@ -1235,7 +1423,18 @@ win32_chdir(const char *dir)
 DllExport int
 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
 {
-    return spawnvp(mode, cmdname, (char * const *) argv);
+    int status;
+
+    status = spawnvp(mode, cmdname, (char * const *) argv);
+#ifndef __BORLANDC__
+    /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId
+     * while VC RTL returns pinfo.hProcess. For purposes of the custom
+     * implementation of win32_wait(), we assume the latter.
+     */
+    if (mode == P_NOWAIT && status >= 0)
+	w32_child_pids[w32_num_children++] = (HANDLE)status;
+#endif
+    return status;
 }
 
 DllExport int
@@ -1497,8 +1696,8 @@ static
 XS(w32_LoginName)
 {
     dXSARGS;
-    char name[256];
-    DWORD size = sizeof(name);
+    char *name = getlogin_buffer;
+    DWORD size = sizeof(getlogin_buffer);
     if (GetUserName(name,&size)) {
 	/* size includes NULL */
 	ST(0) = sv_2mortal(newSVpv(name,size-1));
@@ -1736,6 +1935,7 @@ Perl_win32_init(int *argcp, char ***argvp)
 #if !defined(_ALPHA_) && !defined(__GNUC__)
     _control87(MCW_EM, MCW_EM);
 #endif
+    MALLOC_INIT; 
 }
 
 #ifdef USE_BINMODE_SCRIPTS
@@ -1769,3 +1969,4 @@ win32_strip_return(SV *sv)
 
 
 
+