X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=win32%2Fwin32.c;h=924ee92a7ea90aede7b87899c5648b94680add22;hb=16b7a9a47be196cb33bf757faad24e73ceffc2fc;hp=ead206b0423febfff8c5d7f3ef2f9f1789979717;hpb=19c81aacf4756efdf4567e39db89e8c0ffbd1b19;p=p5sagit%2Fp5-mst-13.2.git diff --git a/win32/win32.c b/win32/win32.c index ead206b0..924ee92 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -581,7 +581,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; @@ -674,7 +673,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"), @@ -977,6 +975,31 @@ 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) { @@ -1633,7 +1656,7 @@ win32_uname(struct utsname *name) char *arch; GetSystemInfo(&info); -#if defined(__BORLANDC__) || defined(__MINGW32__) +#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) || defined(__MINGW32__) switch (info.u.s.wProcessorArchitecture) { #else switch (info.wProcessorArchitecture) { @@ -1850,7 +1873,6 @@ win32_crypt(const char *txt, const char *salt) { dTHXo; #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 +1880,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 +1918,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 @@ -2157,7 +2128,6 @@ win32_str_os_error(void *sv, DWORD dwErr) } } - DllExport int win32_fprintf(FILE *fp, const char *format, ...) { @@ -2363,7 +2333,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 @@ -2374,9 +2362,11 @@ win32_pipe(int *pfd, unsigned int size, int mode) /* * 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 @@ -2450,7 +2440,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,7 +2460,7 @@ cleanup: */ DllExport int -win32_pclose(FILE *pf) +win32_pclose(PerlIO *pf) { #ifdef USE_RTL_POPEN return _pclose(pf); @@ -2480,7 +2470,7 @@ win32_pclose(FILE *pf) 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 +2482,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; @@ -2754,10 +2748,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 @@ -3564,6 +3561,25 @@ win32_dynaload(const char* filename) { dTHXo; 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)); @@ -3685,79 +3701,65 @@ XS(w32_NodeName) static XS(w32_DomainName) { - /* - * HOWTO: Retrieve Current User and Domain Names on Windows NT - * http://support.microsoft.com/support/kb/articles/Q111/5/44.ASP - * - * This information is unfortunately unavailable from 32 bit code on - * Win9X. If anyone wants to write a thunking DLL to make the 16 bit - * Lan Manager APIs available to Perl, here are some relevant KB articles: - * - * HOWTO: Retrieve Current User and Domain Names on Windows 95 and Windows 98 - * http://support.microsoft.com/support/kb/articles/Q155/6/98.ASP - * - * HOWTO: Call 16-bit Code from 32-bit Code Under Windows 95 - * http://support.microsoft.com/support/kb/articles/Q155/7/63.ASP - */ - dXSARGS; + HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll"); + DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer); + DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level, + void *bufptr); - char szUser[256]; - DWORD cchUser = sizeof(szUser); - char szDomain[256]; - DWORD cchDomain = sizeof(szDomain); - - HANDLE hToken = NULL; - PTOKEN_USER ptiUser = NULL; - DWORD cbti = 0; - SID_NAME_USE snu; - - EXTEND(SP,1); - ST(0) = &PL_sv_undef; - - /* Get the calling thread's access token. */ - if (!OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, TRUE, &hToken)) { - if (GetLastError() != ERROR_NO_TOKEN) - goto leave; - /* Retry against process token if no thread token exists. */ - if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hToken)) - goto leave; + if (hNetApi32) { + pfnNetApiBufferFree = (DWORD (__stdcall *)(void *)) + GetProcAddress(hNetApi32, "NetApiBufferFree"); + pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *)) + GetProcAddress(hNetApi32, "NetWkstaGetInfo"); } - - /* Obtain the size of the user information in the token. */ - if (GetTokenInformation(hToken, TokenUser, NULL, 0, &cbti)) { - /* Call should have failed due to zero-length buffer. */ - goto leave; + EXTEND(SP,1); + if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) { + /* this way is more reliable, in case user has a local account. */ + char dname[256]; + DWORD dnamelen = sizeof(dname); + struct { + DWORD wki100_platform_id; + LPWSTR wki100_computername; + LPWSTR wki100_langroup; + DWORD wki100_ver_major; + DWORD wki100_ver_minor; + } *pwi; + /* NERR_Success *is* 0*/ + if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) { + if (pwi->wki100_langroup && *(pwi->wki100_langroup)) { + WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + else { + WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + pfnNetApiBufferFree(pwi); + FreeLibrary(hNetApi32); + XSRETURN_PV(dname); + } + FreeLibrary(hNetApi32); } else { - /* Call should have failed due to zero-length buffer. */ - if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) - goto leave; + /* Win95 doesn't have NetWksta*(), so do it the old way */ + char name[256]; + DWORD size = sizeof(name); + if (hNetApi32) + FreeLibrary(hNetApi32); + if (GetUserName(name,&size)) { + char sid[ONE_K_BUFSIZE]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } } - - /* Allocate buffer for user information in the token. */ - Newc(0, ptiUser, cbti, char, TOKEN_USER); - if (!ptiUser) - goto leave; - - /* Retrieve the user information from the token. */ - if (!GetTokenInformation(hToken, TokenUser, ptiUser, cbti, &cbti)) - goto leave; - - /* Retrieve user name and domain name based on user's SID. */ - if (!LookupAccountSid(NULL, ptiUser->User.Sid, szUser, &cchUser, - szDomain, &cchDomain, &snu)) - goto leave; - - ST(0) = sv_2mortal(newSVpvn(szDomain, cchDomain)); - - leave: - if (hToken) - CloseHandle(hToken); - - Safefree(ptiUser); - - XSRETURN(1); + XSRETURN_UNDEF; } static @@ -4157,7 +4159,7 @@ 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 */