X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fwin32.c;h=8ffffd53720d2a505be08ad130fac938d2a6ceba;hb=8bb8fffa0cd55f5ec6c1b52236f8c5baff79c3c6;hp=9cc714f13f12558d3e6c6ed964848516c3413b74;hpb=177a48aa5ce07de6b25a612090ebf912f817adcc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/win32.c b/win32/win32.c index 9cc714f..8ffffd5 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -7,7 +7,7 @@ * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. */ - +#define PERLIO_NOT_STDIO 0 #define WIN32_LEAN_AND_MEAN #define WIN32IO_IS_STDIO #include @@ -25,7 +25,6 @@ /* #include "config.h" */ -#define PERLIO_NOT_STDIO 0 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) #define PerlIO FILE #endif @@ -91,13 +90,6 @@ int _fcloseall(); # define getlogin g_getlogin #endif -#if defined(PERL_OBJECT) -# undef do_aspawn -# define do_aspawn g_do_aspawn -# undef Perl_do_exec -# define Perl_do_exec g_do_exec -#endif - static void get_shell(void); static long tokenize(const char *str, char **dest, char ***destv); int do_spawn2(char *cmd, int exectype); @@ -179,7 +171,7 @@ get_regstr_from(HKEY hkey, const char *valuename, SV **svp) if (retval == ERROR_SUCCESS && (type == REG_SZ || type == REG_EXPAND_SZ)) { - dTHXo; + dTHX; if (!*svp) *svp = sv_2mortal(newSVpvn("",0)); SvGROW(*svp, datalen); @@ -259,7 +251,7 @@ get_emd_part(SV **prev_pathp, char *trailing_path, ...) /* only add directory if it exists */ if (GetFileAttributes(mod_name) != (DWORD) -1) { /* directory exists */ - dTHXo; + dTHX; if (!*prev_pathp) *prev_pathp = sv_2mortal(newSVpvn("",0)); sv_catpvn(*prev_pathp, ";", 1); @@ -273,7 +265,7 @@ get_emd_part(SV **prev_pathp, char *trailing_path, ...) char * win32_get_privlib(const char *pl) { - dTHXo; + dTHX; char *stdlib = "lib"; char buffer[MAX_PATH+1]; SV *sv = Nullsv; @@ -290,7 +282,7 @@ win32_get_privlib(const char *pl) static char * win32_get_xlib(const char *pl, const char *xlib, const char *libname) { - dTHXo; + dTHX; char regstr[40]; char pathstr[MAX_PATH+1]; DWORD datalen; @@ -438,7 +430,7 @@ win32_getpid(void) { int pid; #ifdef USE_ITHREADS - dTHXo; + dTHX; if (w32_pseudo_id) return -((int)w32_pseudo_id); #endif @@ -464,7 +456,7 @@ tokenize(const char *str, char **dest, char ***destv) char **retvstart = 0; int items = -1; if (str) { - dTHXo; + dTHX; int slen = strlen(str); register char *ret; register char **retv; @@ -507,7 +499,7 @@ tokenize(const char *str, char **dest, char ***destv) static void get_shell(void) { - dTHXo; + dTHX; 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 @@ -518,7 +510,7 @@ get_shell(void) */ const char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c"); - const char *usershell = getenv("PERL5SHELL"); + const char *usershell = PerlEnv_getenv("PERL5SHELL"); w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, &w32_perlshell_tokens, &w32_perlshell_vec); @@ -528,7 +520,7 @@ get_shell(void) int do_aspawn(void *vreally, void **vmark, void **vsp) { - dTHXo; + dTHX; SV *really = (SV*)vreally; SV **mark = (SV**)vmark; SV **sp = (SV**)vsp; @@ -581,7 +573,6 @@ do_aspawn(void *vreally, void **vmark, void **vsp) } else { if (status < 0) { - dTHR; if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; @@ -594,10 +585,34 @@ do_aspawn(void *vreally, void **vmark, void **vsp) return (status); } +/* returns pointer to the next unquoted space or the end of the string */ +static char* +find_next_space(const char *s) +{ + bool in_quotes = FALSE; + while (*s) { + /* ignore doubled backslashes, or backslash+quote */ + if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) { + s += 2; + } + /* keep track of when we're within quotes */ + else if (*s == '"') { + s++; + in_quotes = !in_quotes; + } + /* break it up only at spaces that aren't in quotes */ + else if (!in_quotes && isSPACE(*s)) + return (char*)s; + else + s++; + } + return (char*)s; +} + int do_spawn2(char *cmd, int exectype) { - dTHXo; + dTHX; char **a; char *s; char **argv; @@ -617,8 +632,7 @@ do_spawn2(char *cmd, int exectype) s++; if (*s) *(a++) = s; - while (*s && !isSPACE(*s)) - s++; + s = find_next_space(s); if (*s) *s++ = '\0'; } @@ -674,7 +688,6 @@ do_spawn2(char *cmd, int exectype) } else { if (status < 0) { - dTHR; if (ckWARN(WARN_EXEC)) Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (exectype == EXECF_EXEC ? "exec" : "spawn"), @@ -714,7 +727,7 @@ Perl_do_exec(pTHX_ char *cmd) DllExport DIR * win32_opendir(char *filename) { - dTHXo; + dTHX; DIR *dirp; long len; long idx; @@ -826,7 +839,7 @@ win32_readdir(DIR *dirp) /* Now set up for the next call to readdir */ dirp->curr += len + 1; if (dirp->curr >= dirp->end) { - dTHXo; + dTHX; char* ptr; BOOL res; WIN32_FIND_DATAW wFindData; @@ -852,7 +865,7 @@ win32_readdir(DIR *dirp) long endpos = dirp->end - dirp->start; long newsize = endpos + strlen(ptr) + 1; /* bump the string table size by enough for the - * new name and it's null terminator */ + * new name and its null terminator */ while (newsize > dirp->size) { long curpos = dirp->curr - dirp->start; dirp->size *= 2; @@ -900,7 +913,7 @@ win32_rewinddir(DIR *dirp) DllExport int win32_closedir(DIR *dirp) { - dTHXo; + dTHX; if (dirp->handle != INVALID_HANDLE_VALUE) FindClose(dirp->handle); Safefree(dirp->start); @@ -962,7 +975,7 @@ setgid(gid_t agid) char * getlogin(void) { - dTHXo; + dTHX; char *buf = w32_getlogin_buffer; DWORD size = sizeof(w32_getlogin_buffer); if (GetUserName(buf,&size)) @@ -977,10 +990,35 @@ chown(const char *path, uid_t owner, gid_t group) return 0; } +/* + * XXX this needs strengthening (for PerlIO) + * -- BKS, 11-11-200 +*/ +int mkstemp(const char *path) +{ + dTHX; + char buf[MAX_PATH+1]; + int i = 0, fd = -1; + +retry: + if (i++ > 10) { /* give up */ + errno = ENOENT; + return -1; + } + if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) { + errno = ENOENT; + return -1; + } + fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600); + if (fd == -1) + goto retry; + return fd; +} + static long find_pid(int pid) { - dTHXo; + dTHX; long child = w32_num_children; while (--child >= 0) { if (w32_child_pids[child] == pid) @@ -993,7 +1031,7 @@ static void remove_dead_process(long child) { if (child >= 0) { - dTHXo; + dTHX; CloseHandle(w32_child_handles[child]); Move(&w32_child_handles[child+1], &w32_child_handles[child], (w32_num_children-child-1), HANDLE); @@ -1007,7 +1045,7 @@ remove_dead_process(long child) static long find_pseudo_pid(int pid) { - dTHXo; + dTHX; long child = w32_num_pseudo_children; while (--child >= 0) { if (w32_pseudo_child_pids[child] == pid) @@ -1020,7 +1058,7 @@ static void remove_dead_pseudo_process(long child) { if (child >= 0) { - dTHXo; + dTHX; CloseHandle(w32_pseudo_child_handles[child]); Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child], (w32_num_pseudo_children-child-1), HANDLE); @@ -1034,7 +1072,7 @@ remove_dead_pseudo_process(long child) DllExport int win32_kill(int pid, int sig) { - dTHXo; + dTHX; HANDLE hProcess; long child; #ifdef USE_ITHREADS @@ -1100,7 +1138,7 @@ win32_sleep(unsigned int t) DllExport int win32_stat(const char *path, struct stat *sbuf) { - dTHXo; + dTHX; char buffer[MAX_PATH+1]; int l = strlen(path); int res; @@ -1299,12 +1337,10 @@ win32_longpath(char *path) return path; } -#ifndef USE_WIN32_RTL_ENV - DllExport char * win32_getenv(const char *name) { - dTHXo; + dTHX; WCHAR wBuffer[MAX_PATH+1]; DWORD needlen; SV *curitem = Nullsv; @@ -1353,7 +1389,7 @@ win32_getenv(const char *name) DllExport int win32_putenv(const char *name) { - dTHXo; + dTHX; char* curitem; char* val; WCHAR* wCuritem; @@ -1402,8 +1438,6 @@ win32_putenv(const char *name) return relval; } -#endif - static long filetime_to_clock(PFILETIME ft) { @@ -1464,7 +1498,7 @@ filetime_from_time(PFILETIME pFileTime, time_t Time) DllExport int win32_unlink(const char *filename) { - dTHXo; + dTHX; int ret; DWORD attrs; @@ -1509,7 +1543,7 @@ fail: DllExport int win32_utime(const char *filename, struct utimbuf *times) { - dTHXo; + dTHX; HANDLE handle; FILETIME ftCreate; FILETIME ftAccess; @@ -1633,7 +1667,8 @@ win32_uname(struct utsname *name) char *arch; GetSystemInfo(&info); -#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) || defined(__MINGW32__) +#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \ + || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION)) switch (info.u.s.wProcessorArchitecture) { #else switch (info.wProcessorArchitecture) { @@ -1654,15 +1689,85 @@ win32_uname(struct utsname *name) return 0; } +int +win32_internal_wait(int *status, DWORD timeout) +{ + /* XXX this wait emulation only knows about processes + * spawned via win32_spawnvp(P_NOWAIT, ...). + */ + dTHX; + int i, retval; + DWORD exitcode, waitcode; + +#ifdef USE_ITHREADS + if (w32_num_pseudo_children) { + waitcode = WaitForMultipleObjects(w32_num_pseudo_children, + w32_pseudo_child_handles, + FALSE, + timeout); + /* Time out here if there are no other children to wait for. */ + if (waitcode == WAIT_TIMEOUT) { + if (!w32_num_children) { + return 0; + } + } + else if (waitcode != WAIT_FAILED) { + if (waitcode >= WAIT_ABANDONED_0 + && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) + i = waitcode - WAIT_ABANDONED_0; + else + i = waitcode - WAIT_OBJECT_0; + if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { + *status = (int)((exitcode & 0xff) << 8); + retval = (int)w32_pseudo_child_pids[i]; + remove_dead_pseudo_process(i); + return -retval; + } + } + } +#endif + + if (!w32_num_children) { + errno = ECHILD; + return -1; + } + + /* if a child exists, wait for it to die */ + waitcode = WaitForMultipleObjects(w32_num_children, + w32_child_handles, + FALSE, + timeout); + if (waitcode == WAIT_TIMEOUT) { + return 0; + } + 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_handles[i], &exitcode) ) { + *status = (int)((exitcode & 0xff) << 8); + retval = (int)w32_child_pids[i]; + remove_dead_process(i); + return retval; + } + } + +FAILED: + errno = GetLastError(); + return -1; +} + DllExport int win32_waitpid(int pid, int *status, int flags) { - dTHXo; + dTHX; DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE; int retval = -1; long child; if (pid == -1) /* XXX threadid == 1 ? */ - return win32_wait(status); + return win32_internal_wait(status, timeout); #ifdef USE_ITHREADS else if (pid < 0) { child = find_pseudo_pid(-pid); @@ -1738,81 +1843,27 @@ alien_process: DllExport int win32_wait(int *status) { - /* XXX this wait emulation only knows about processes - * spawned via win32_spawnvp(P_NOWAIT, ...). - */ - dTHXo; - int i, retval; - DWORD exitcode, waitcode; - -#ifdef USE_ITHREADS - if (w32_num_pseudo_children) { - waitcode = WaitForMultipleObjects(w32_num_pseudo_children, - w32_pseudo_child_handles, - FALSE, - INFINITE); - if (waitcode != WAIT_FAILED) { - if (waitcode >= WAIT_ABANDONED_0 - && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) - i = waitcode - WAIT_ABANDONED_0; - else - i = waitcode - WAIT_OBJECT_0; - if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { - *status = (int)((exitcode & 0xff) << 8); - retval = (int)w32_pseudo_child_pids[i]; - remove_dead_pseudo_process(i); - return -retval; - } - } - } -#endif - - if (!w32_num_children) { - errno = ECHILD; - return -1; - } - - /* if a child exists, wait for it to die */ - waitcode = WaitForMultipleObjects(w32_num_children, - w32_child_handles, - 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_handles[i], &exitcode) ) { - *status = (int)((exitcode & 0xff) << 8); - retval = (int)w32_child_pids[i]; - remove_dead_process(i); - return retval; - } - } - -FAILED: - errno = GetLastError(); - return -1; + return win32_internal_wait(status, INFINITE); } -#ifndef PERL_OBJECT +#ifndef PERL_IMPLICIT_CONTEXT static UINT timerid = 0; static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time) { - dTHXo; + dTHX; KillTimer(NULL,timerid); timerid=0; CALL_FPTR(PL_sighandlerp)(14); } -#endif /* !PERL_OBJECT */ + +#endif /* !PERL_IMPLICIT_CONTEXT */ DllExport unsigned int win32_alarm(unsigned int sec) { -#ifndef PERL_OBJECT +#ifndef PERL_IMPLICIT_CONTEXT /* * the 'obvious' implentation is SetTimer() with a callback * which does whatever receiving SIGALRM would do @@ -1822,7 +1873,7 @@ win32_alarm(unsigned int sec) * Snag is unless something is looking at the message queue * nothing happens :-( */ - dTHXo; + dTHX; if (sec) { timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc); @@ -1837,7 +1888,7 @@ win32_alarm(unsigned int sec) timerid=0; } } -#endif /* !PERL_OBJECT */ +#endif /* !PERL_IMPLICIT_CONTEXT */ return 0; } @@ -1848,9 +1899,8 @@ extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); DllExport char * win32_crypt(const char *txt, const char *salt) { - dTHXo; + dTHX; #ifdef HAVE_DES_FCRYPT - dTHR; return des_fcrypt(txt, salt, w32_crypt_buffer); #else Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); @@ -1858,53 +1908,6 @@ win32_crypt(const char *txt, const char *salt) #endif } -/* C doesn't like repeat struct definitions */ - -#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) - -#ifndef _CRTIMP -#define _CRTIMP __declspec(dllimport) -#endif - -/* - * Control structure for lowio file handles - */ -typedef struct { - long osfhnd; /* underlying OS file HANDLE */ - char osfile; /* attributes of file (e.g., open in text mode?) */ - char pipech; /* one char buffer for handles opened on pipes */ - int lockinitflag; - CRITICAL_SECTION lock; -} ioinfo; - - -/* - * Array of arrays of control structures for lowio files. - */ -EXTERN_C _CRTIMP ioinfo* __pioinfo[]; - -/* - * Definition of IOINFO_L2E, the log base 2 of the number of elements in each - * array of ioinfo structs. - */ -#define IOINFO_L2E 5 - -/* - * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array - */ -#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E) - -/* - * Access macros for getting at an ioinfo struct and its fields from a - * file handle - */ -#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1))) -#define _osfhnd(i) (_pioinfo(i)->osfhnd) -#define _osfile(i) (_pioinfo(i)->osfile) -#define _pipech(i) (_pioinfo(i)->pipech) - -#endif - #ifdef USE_FIXED_OSFHANDLE #define FOPEN 0x01 /* file handle open */ @@ -1943,10 +1946,6 @@ EXTERN_C _CRTIMP ioinfo* __pioinfo[]; * -- BKS, 1-23-2000 */ -/* since we are not doing a dup2(), this works fine */ - -#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = osfh) - /* create an ioinfo entry, kill its handle, and steal the entry */ static int @@ -2012,7 +2011,7 @@ win32_flock(int fd, int oper) HANDLE fh; if (!IsWinNT()) { - dTHXo; + dTHX; Perl_croak_nocontext("flock() unimplemented on this platform"); return -1; } @@ -2105,13 +2104,13 @@ win32_feof(FILE *fp) DllExport char * win32_strerror(int e) { -#ifndef __BORLANDC__ /* Borland intolerance */ +#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */ extern int sys_nerr; #endif DWORD source = 0; if (e < 0 || e > sys_nerr) { - dTHXo; + dTHX; if (e < 0) e = GetLastError(); @@ -2151,13 +2150,12 @@ win32_str_os_error(void *sv, DWORD dwErr) dwErr, GetLastError()); } if (sMsg) { - dTHXo; + dTHX; sv_setpvn((SV*)sv, sMsg, dwLen); LocalFree(sMsg); } } - DllExport int win32_fprintf(FILE *fp, const char *format, ...) { @@ -2205,7 +2203,7 @@ win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) DllExport FILE * win32_fopen(const char *filename, const char *mode) { - dTHXo; + dTHX; WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1]; FILE *f; @@ -2236,7 +2234,7 @@ win32_fopen(const char *filename, const char *mode) DllExport FILE * win32_fdopen(int handle, const char *mode) { - dTHXo; + dTHX; WCHAR wMode[MODE_SIZE]; FILE *f; if (USING_WIDE()) { @@ -2254,7 +2252,7 @@ win32_fdopen(int handle, const char *mode) DllExport FILE * win32_freopen(const char *path, const char *mode, FILE *stream) { - dTHXo; + dTHX; WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1]; if (stricmp(path, "/dev/null")==0) path = "NUL"; @@ -2350,7 +2348,31 @@ win32_rewind(FILE *pf) DllExport FILE* win32_tmpfile(void) { - return tmpfile(); + dTHX; + char prefix[MAX_PATH+1]; + char filename[MAX_PATH+1]; + DWORD len = GetTempPath(MAX_PATH, prefix); + if (len && len < MAX_PATH) { + if (GetTempFileName(prefix, "plx", 0, filename)) { + HANDLE fh = CreateFile(filename, + DELETE | GENERIC_READ | GENERIC_WRITE, + 0, + NULL, + CREATE_ALWAYS, + FILE_ATTRIBUTE_NORMAL + | FILE_FLAG_DELETE_ON_CLOSE, + NULL); + if (fh != INVALID_HANDLE_VALUE) { + int fd = win32_open_osfhandle((long)fh, 0); + if (fd >= 0) { + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Created tmpfile=%s\n",filename)); + return fdopen(fd, "w+b"); + } + } + } + } + return NULL; } DllExport void @@ -2363,7 +2385,25 @@ win32_abort(void) DllExport int win32_fstat(int fd,struct stat *sbufptr) { - return fstat(fd,sbufptr); +#ifdef __BORLANDC__ + /* A file designated by filehandle is not shown as accessible + * for write operations, probably because it is opened for reading. + * --Vadim Konovalov + */ + int rc = fstat(fd,sbufptr); + BY_HANDLE_FILE_INFORMATION bhfi; + if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) { + sbufptr->st_mode &= 0xFE00; + if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY) + sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6)); + else + sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3) + + ((S_IREAD|S_IWRITE) >> 6)); + } + return rc; +#else + return my_fstat(fd,sbufptr); +#endif } DllExport int @@ -2372,11 +2412,21 @@ win32_pipe(int *pfd, unsigned int size, int mode) return _pipe(pfd, size, mode); } +DllExport PerlIO* +win32_popenlist(const char *mode, IV narg, SV **args) +{ + dTHX; + Perl_croak(aTHX_ "List form of pipe open not implemented"); + return NULL; +} + /* * a popen() clone that respects PERL5SHELL + * + * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000 */ -DllExport FILE* +DllExport PerlIO* win32_popen(const char *command, const char *mode) { #ifdef USE_RTL_POPEN @@ -2430,7 +2480,7 @@ win32_popen(const char *command, const char *mode) /* start the child */ { - dTHXo; + dTHX; if ((childpid = do_spawn_nowait((char*)command)) == -1) goto cleanup; @@ -2450,7 +2500,7 @@ win32_popen(const char *command, const char *mode) } /* we have an fd, return a file stream */ - return (win32_fdopen(p[parent], (char *)mode)); + return (PerlIO_fdopen(p[parent], (char *)mode)); cleanup: /* we don't need to check for errors here */ @@ -2470,17 +2520,17 @@ cleanup: */ DllExport int -win32_pclose(FILE *pf) +win32_pclose(PerlIO *pf) { #ifdef USE_RTL_POPEN return _pclose(pf); #else - dTHXo; + dTHX; int childpid, status; SV *sv; LOCK_FDPID_MUTEX; - sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE); + sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE); if (SvIOK(sv)) childpid = SvIVX(sv); @@ -2492,7 +2542,11 @@ win32_pclose(FILE *pf) return -1; } - win32_fclose(pf); +#ifdef USE_PERLIO + PerlIO_close(pf); +#else + fclose(pf); +#endif SvIVX(sv) = 0; UNLOCK_FDPID_MUTEX; @@ -2541,7 +2595,8 @@ Nt4CreateHardLinkW( StreamId.dwStreamId = BACKUP_LINK; StreamId.dwStreamAttributes = 0; StreamId.dwStreamNameSize = 0; -#if defined(__BORLANDC__) || defined(__MINGW32__) +#if defined(__BORLANDC__) \ + ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION)) StreamId.Size.u.HighPart = 0; StreamId.Size.u.LowPart = dwLen; #else @@ -2564,7 +2619,7 @@ Nt4CreateHardLinkW( DllExport int win32_link(const char *oldname, const char *newname) { - dTHXo; + dTHX; BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES); WCHAR wOldName[MAX_PATH+1]; WCHAR wNewName[MAX_PATH+1]; @@ -2597,7 +2652,7 @@ win32_rename(const char *oname, const char *newname) char szOldName[MAX_PATH+1]; char szNewName[MAX_PATH+1]; BOOL bResult; - dTHXo; + dTHX; /* XXX despite what the documentation says about MoveFileEx(), * it doesn't work under Windows95! @@ -2735,7 +2790,7 @@ win32_tell(int fd) DllExport int win32_open(const char *path, int flag, ...) { - dTHXo; + dTHX; va_list ap; int pmode; WCHAR wBuffer[MAX_PATH+1]; @@ -2754,10 +2809,13 @@ win32_open(const char *path, int flag, ...) return open(PerlDir_mapA(path), flag, pmode); } +/* close() that understands socket */ +extern int my_close(int); /* in win32sck.c */ + DllExport int win32_close(int fd) { - return close(fd); + return my_close(fd); } DllExport int @@ -2993,7 +3051,7 @@ win32_write(int fd, const void *buf, unsigned int cnt) DllExport int win32_mkdir(const char *dir, int mode) { - dTHXo; + dTHX; if (USING_WIDE()) { WCHAR wBuffer[MAX_PATH+1]; A2WHELPER(dir, wBuffer, sizeof(wBuffer)); @@ -3005,7 +3063,7 @@ win32_mkdir(const char *dir, int mode) DllExport int win32_rmdir(const char *dir) { - dTHXo; + dTHX; if (USING_WIDE()) { WCHAR wBuffer[MAX_PATH+1]; A2WHELPER(dir, wBuffer, sizeof(wBuffer)); @@ -3017,7 +3075,11 @@ win32_rmdir(const char *dir) DllExport int win32_chdir(const char *dir) { - dTHXo; + dTHX; + if (!dir) { + errno = ENOENT; + return -1; + } if (USING_WIDE()) { WCHAR wBuffer[MAX_PATH+1]; A2WHELPER(dir, wBuffer, sizeof(wBuffer)); @@ -3029,7 +3091,7 @@ win32_chdir(const char *dir) DllExport int win32_access(const char *path, int mode) { - dTHXo; + dTHX; if (USING_WIDE()) { WCHAR wBuffer[MAX_PATH+1]; A2WHELPER(path, wBuffer, sizeof(wBuffer)); @@ -3041,7 +3103,7 @@ win32_access(const char *path, int mode) DllExport int win32_chmod(const char *path, int mode) { - dTHXo; + dTHX; if (USING_WIDE()) { WCHAR wBuffer[MAX_PATH+1]; A2WHELPER(path, wBuffer, sizeof(wBuffer)); @@ -3052,33 +3114,162 @@ win32_chmod(const char *path, int mode) static char * -create_command_line(const char* command, const char * const *args) -{ - dTHXo; - int index; - char *cmd, *ptr, *arg; - STRLEN len = strlen(command) + 1; +create_command_line(char *cname, STRLEN clen, const char * const *args) +{ + dTHX; + int index, argc; + char *cmd, *ptr; + const char *arg; + STRLEN len = 0; + bool bat_file = FALSE; + bool cmd_shell = FALSE; + bool dumb_shell = FALSE; + bool extra_quotes = FALSE; + bool quote_next = FALSE; + + if (!cname) + cname = (char*)args[0]; + + /* The NT cmd.exe shell has the following peculiarity that needs to be + * worked around. It strips a leading and trailing dquote when any + * of the following is true: + * 1. the /S switch was used + * 2. there are more than two dquotes + * 3. there is a special character from this set: &<>()@^| + * 4. no whitespace characters within the two dquotes + * 5. string between two dquotes isn't an executable file + * To work around this, we always add a leading and trailing dquote + * to the string, if the first argument is either "cmd.exe" or "cmd", + * and there were at least two or more arguments passed to cmd.exe + * (not including switches). + * XXX the above rules (from "cmd /?") don't seem to be applied + * always, making for the convolutions below :-( + */ + if (cname) { + if (!clen) + clen = strlen(cname); + + if (clen > 4 + && (stricmp(&cname[clen-4], ".bat") == 0 + || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0))) + { + bat_file = TRUE; + len += 3; + } + else { + char *exe = strrchr(cname, '/'); + char *exe2 = strrchr(cname, '\\'); + if (exe2 > exe) + exe = exe2; + if (exe) + ++exe; + else + exe = cname; + if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) { + cmd_shell = TRUE; + len += 3; + } + else if (stricmp(exe, "command.com") == 0 + || stricmp(exe, "command") == 0) + { + dumb_shell = TRUE; + } + } + } - for (index = 0; (ptr = (char*)args[index]) != NULL; ++index) - len += strlen(ptr) + 1; + DEBUG_p(PerlIO_printf(Perl_debug_log, "Args ")); + for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { + STRLEN curlen = strlen(arg); + if (!(arg[0] == '"' && arg[curlen-1] == '"')) + len += 2; /* assume quoting needed (worst case) */ + len += curlen + 1; + DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg)); + } + DEBUG_p(PerlIO_printf(Perl_debug_log, "\n")); + argc = index; New(1310, cmd, len, char); ptr = cmd; - strcpy(ptr, command); + + if (bat_file) { + *ptr++ = '"'; + extra_quotes = TRUE; + } for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { - ptr += strlen(ptr); - *ptr++ = ' '; + bool do_quote = 0; + STRLEN curlen = strlen(arg); + + /* we want to protect empty arguments and ones with spaces with + * dquotes, but only if they aren't already there */ + if (!dumb_shell) { + if (!curlen) { + do_quote = 1; + } + else if (quote_next) { + /* see if it really is multiple arguments pretending to + * be one and force a set of quotes around it */ + if (*find_next_space(arg)) + do_quote = 1; + } + else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) { + STRLEN i = 0; + while (i < curlen) { + if (isSPACE(arg[i])) { + do_quote = 1; + } + else if (arg[i] == '"') { + do_quote = 0; + break; + } + i++; + } + } + } + + if (do_quote) + *ptr++ = '"'; + strcpy(ptr, arg); + ptr += curlen; + + if (do_quote) + *ptr++ = '"'; + + if (args[index+1]) + *ptr++ = ' '; + + if (!extra_quotes + && cmd_shell + && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0)) + { + /* is there a next argument? */ + if (args[index+1]) { + /* are there two or more next arguments? */ + if (args[index+2]) { + *ptr++ = '"'; + extra_quotes = TRUE; + } + else { + /* single argument, force quoting if it has spaces */ + quote_next = TRUE; + } + } + } } + if (extra_quotes) + *ptr++ = '"'; + + *ptr = '\0'; + return cmd; } static char * qualified_path(const char *cmd) { - dTHXo; + dTHX; char *pathstr; char *fullcmd, *curfullcmd; STRLEN cmdlen = 0; @@ -3095,7 +3286,7 @@ qualified_path(const char *cmd) } /* look in PATH */ - pathstr = win32_getenv("PATH"); + pathstr = PerlEnv_getenv("PATH"); New(0, fullcmd, MAX_PATH+1, char); curfullcmd = fullcmd; @@ -3169,21 +3360,41 @@ GIVE_UP: * environment and the current directory to CreateProcess */ -void* -get_childenv(void) +DllExport void* +win32_get_childenv(void) { return NULL; } -void -free_childenv(void* d) +DllExport void +win32_free_childenv(void* d) +{ +} + +DllExport void +win32_clearenv(void) { + char *envv = GetEnvironmentStrings(); + char *cur = envv; + STRLEN len; + while (*cur) { + char *end = strchr(cur,'='); + if (end && end != cur) { + *end = '\0'; + SetEnvironmentVariable(cur, NULL); + *end = '='; + cur = end + strlen(end+1)+2; + } + else if ((len = strlen(cur))) + cur += len+1; + } + FreeEnvironmentStrings(envv); } -char* -get_childdir(void) +DllExport char* +win32_get_childdir(void) { - dTHXo; + dTHX; char* ptr; char szfilename[(MAX_PATH+1)*2]; if (USING_WIDE()) { @@ -3200,10 +3411,10 @@ get_childdir(void) return ptr; } -void -free_childdir(char* d) +DllExport void +win32_free_childdir(char* d) { - dTHXo; + dTHX; Safefree(d); } @@ -3225,7 +3436,7 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) #ifdef USE_RTL_SPAWNVP return spawnvp(mode, cmdname, (char * const *)argv); #else - dTHXo; + dTHX; int ret; void* env; char* dir; @@ -3233,10 +3444,30 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) STARTUPINFO StartupInfo; PROCESS_INFORMATION ProcessInformation; DWORD create = 0; - - char *cmd = create_command_line(cmdname, strcmp(cmdname, argv[0]) == 0 - ? &argv[1] : argv); + char *cmd; char *fullcmd = Nullch; + char *cname = (char *)cmdname; + STRLEN clen = 0; + + if (cname) { + clen = strlen(cname); + /* if command name contains dquotes, must remove them */ + if (strchr(cname, '"')) { + cmd = cname; + New(0,cname,clen+1,char); + clen = 0; + while (*cmd) { + if (*cmd != '"') { + cname[clen] = *cmd; + ++clen; + } + ++cmd; + } + cname[clen] = '\0'; + } + } + + cmd = create_command_line(cname, clen, argv); env = PerlEnv_get_childenv(); dir = PerlEnv_get_childdir(); @@ -3282,8 +3513,10 @@ win32_spawnvp(int mode, const char *cmdname, const char *const *argv) create |= CREATE_NEW_CONSOLE; } + DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n", + cname,cmd)); RETRY: - if (!CreateProcess(cmdname, /* search PATH to find executable */ + if (!CreateProcess(cname, /* search PATH to find executable */ cmd, /* executable, and its arguments */ NULL, /* process attributes */ NULL, /* thread attributes */ @@ -3301,9 +3534,14 @@ RETRY: * jump through our own hoops by picking out the path * we really want it to use. */ if (!fullcmd) { - fullcmd = qualified_path(cmdname); + fullcmd = qualified_path(cname); if (fullcmd) { - cmdname = fullcmd; + if (cname != cmdname) + Safefree(cname); + cname = fullcmd; + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Retrying [%s] with same args\n", + cname)); goto RETRY; } } @@ -3336,7 +3574,8 @@ RETVAL: PerlEnv_free_childenv(env); PerlEnv_free_childdir(dir); Safefree(cmd); - Safefree(fullcmd); + if (cname != cmdname) + Safefree(cname); return ret; #endif } @@ -3345,7 +3584,7 @@ DllExport int win32_execv(const char *cmdname, const char *const *argv) { #ifdef USE_ITHREADS - dTHXo; + dTHX; /* if this is a pseudo-forked child, we just want to spawn * the new program, and return */ if (w32_pseudo_id) @@ -3358,11 +3597,18 @@ DllExport int win32_execvp(const char *cmdname, const char *const *argv) { #ifdef USE_ITHREADS - dTHXo; + dTHX; /* if this is a pseudo-forked child, we just want to spawn * the new program, and return */ - if (w32_pseudo_id) - return win32_spawnvp(P_WAIT, cmdname, (char *const *)argv); + if (w32_pseudo_id) { + int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv); + if (status != -1) { + my_exit(status); + return 0; + } + else + return status; + } #endif return execvp(cmdname, (char *const *)argv); } @@ -3443,12 +3689,12 @@ win32_putchar(int c) #ifndef USE_PERL_SBRK -static char *committed = NULL; -static char *base = NULL; -static char *reserved = NULL; -static char *brk = NULL; -static DWORD pagesize = 0; -static DWORD allocsize = 0; +static char *committed = NULL; /* XXX threadead */ +static char *base = NULL; /* XXX threadead */ +static char *reserved = NULL; /* XXX threadead */ +static char *brk = NULL; /* XXX threadead */ +static DWORD pagesize = 0; /* XXX threadead */ +static DWORD allocsize = 0; /* XXX threadead */ void * sbrk(int need) @@ -3562,8 +3808,27 @@ win32_get_osfhandle(int fd) DllExport void* win32_dynaload(const char* filename) { - dTHXo; + dTHX; HMODULE hModule; + char buf[MAX_PATH+1]; + char *first; + + /* LoadLibrary() doesn't recognize forward slashes correctly, + * so turn 'em back. */ + first = strchr(filename, '/'); + if (first) { + STRLEN len = strlen(filename); + if (len <= MAX_PATH) { + strcpy(buf, filename); + filename = &buf[first - filename]; + while (*filename) { + if (*filename == '/') + *(char*)filename = '\\'; + ++filename; + } + filename = buf; + } + } if (USING_WIDE()) { WCHAR wfilename[MAX_PATH+1]; A2WHELPER(filename, wfilename, sizeof(wfilename)); @@ -3595,6 +3860,10 @@ XS(w32_GetCwd) sv_setpv(sv, ptr); PerlEnv_free_childdir(ptr); +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + EXTEND(SP,1); SvPOK_on(sv); ST(0) = sv; @@ -3852,6 +4121,8 @@ XS(w32_Spawn) { dXSARGS; char *cmd, *args; + void *env; + char *dir; PROCESS_INFORMATION stProcInfo; STARTUPINFO stStartInfo; BOOL bSuccess = FALSE; @@ -3862,6 +4133,9 @@ XS(w32_Spawn) cmd = SvPV_nolen(ST(0)); args = SvPV_nolen(ST(1)); + env = PerlEnv_get_childenv(); + dir = PerlEnv_get_childdir(); + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ @@ -3874,8 +4148,8 @@ XS(w32_Spawn) NULL, /* Default thread security */ FALSE, /* Must be TRUE to use std handles */ NORMAL_PRIORITY_CLASS, /* No special scheduling */ - NULL, /* Inherit our environment block */ - NULL, /* Inherit our currrent directory */ + env, /* Inherit our environment block */ + dir, /* Inherit our currrent directory */ &stStartInfo, /* -> Startup info */ &stProcInfo)) /* <- Process info (if OK) */ { @@ -3886,6 +4160,8 @@ XS(w32_Spawn) CloseHandle(stProcInfo.hThread);/* library source code does this. */ bSuccess = TRUE; } + PerlEnv_free_childenv(env); + PerlEnv_free_childdir(dir); XSRETURN_IV(bSuccess); } @@ -4029,7 +4305,7 @@ XS(w32_CopyFile) void Perl_init_os_extras(void) { - dTHXo; + dTHX; char *file = __FILE__; dXSUB_SYS; @@ -4092,16 +4368,6 @@ win32_get_child_IO(child_IO_table* ptbl) #ifdef HAVE_INTERP_INTERN -# ifdef PERL_OBJECT -# undef Perl_sys_intern_init -# define Perl_sys_intern_init CPerlObj::Perl_sys_intern_init -# undef Perl_sys_intern_dup -# define Perl_sys_intern_dup CPerlObj::Perl_sys_intern_dup -# undef Perl_sys_intern_clear -# define Perl_sys_intern_clear CPerlObj::Perl_sys_intern_clear -# define pPerl this -# endif - void Perl_sys_intern_init(pTHX) { @@ -4143,18 +4409,13 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) Newz(1313, dst->children, 1, child_tab); dst->pseudo_id = 0; Newz(1313, dst->pseudo_children, 1, child_tab); - dst->thr_intern.Winit_socktype = src->thr_intern.Winit_socktype; + dst->thr_intern.Winit_socktype = 0; } # endif /* USE_ITHREADS */ #endif /* HAVE_INTERP_INTERN */ -#ifdef PERL_OBJECT -# undef this -# define this pPerl -#endif - static void -win32_free_argvw(pTHXo_ void *ptr) +win32_free_argvw(pTHX_ void *ptr) { char** argv = (char**)ptr; while(*argv) { @@ -4166,7 +4427,7 @@ win32_free_argvw(pTHXo_ void *ptr) void win32_argv2utf8(int argc, char** argv) { - dTHXo; + dTHX; char* psz; int length, wargc; LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);