3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
11 #define WIN32_LEAN_AND_MEAN
12 #define WIN32IO_IS_STDIO
22 /* ugliness to work around a buggy struct definition in lmwksta.h */
29 #endif /* __MINGW32__ */
31 /* #include "config.h" */
33 #define PERLIO_NOT_STDIO 0
34 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
43 #define PERL_NO_GET_CONTEXT
49 /* assert.h conflicts with #define of assert in perl.h */
56 #if defined(_MSC_VER) || defined(__MINGW32__)
57 #include <sys/utime.h>
63 /* Mingw32 defaults to globing command line
64 * So we turn it off like this:
71 #define EXECF_SPAWN_NOWAIT 3
73 #if defined(PERL_OBJECT)
74 #undef win32_get_privlib
75 #define win32_get_privlib g_win32_get_privlib
76 #undef win32_get_sitelib
77 #define win32_get_sitelib g_win32_get_sitelib
79 #define do_aspawn g_do_aspawn
81 #define do_spawn g_do_spawn
83 #define Perl_do_exec g_do_exec
85 #define getlogin g_getlogin
88 static void get_shell(void);
89 static long tokenize(char *str, char **dest, char ***destv);
90 int do_spawn2(char *cmd, int exectype);
91 static BOOL has_shell_metachars(char *ptr);
92 static long filetime_to_clock(PFILETIME ft);
93 static BOOL filetime_from_time(PFILETIME ft, time_t t);
94 static char * get_emd_part(SV **leading, char *trailing, ...);
95 static void remove_dead_process(long deceased);
96 static long find_pid(int pid);
97 static char * qualified_path(const char *cmd);
99 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
100 char w32_module_name[MAX_PATH+1];
101 static DWORD w32_platform = (DWORD)-1;
104 # ifdef USE_DECLSPEC_THREAD
105 __declspec(thread) char strerror_buffer[512];
106 __declspec(thread) char getlogin_buffer[128];
107 __declspec(thread) char w32_perllib_root[MAX_PATH+1];
108 # ifdef HAVE_DES_FCRYPT
109 __declspec(thread) char crypt_buffer[30];
112 # define strerror_buffer (thr->i.Wstrerror_buffer)
113 # define getlogin_buffer (thr->i.Wgetlogin_buffer)
114 # define w32_perllib_root (thr->i.Ww32_perllib_root)
115 # define crypt_buffer (thr->i.Wcrypt_buffer)
118 static char strerror_buffer[512];
119 static char getlogin_buffer[128];
120 static char w32_perllib_root[MAX_PATH+1];
121 # ifdef HAVE_DES_FCRYPT
122 static char crypt_buffer[30];
129 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
135 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
138 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
140 get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
142 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
145 const char *subkey = "Software\\Perl";
149 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
150 if (retval == ERROR_SUCCESS) {
152 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
153 if (retval == ERROR_SUCCESS && type == REG_SZ) {
156 *svp = sv_2mortal(newSVpvn("",0));
157 SvGROW(*svp, datalen);
158 retval = RegQueryValueEx(handle, valuename, 0, NULL,
159 (PBYTE)SvPVX(*svp), &datalen);
160 if (retval == ERROR_SUCCESS) {
162 SvCUR_set(*svp,datalen-1);
170 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
172 get_regstr(const char *valuename, SV **svp)
174 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
176 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
180 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
182 get_emd_part(SV **prev_pathp, char *trailing_path, ...)
186 char mod_name[MAX_PATH+1];
190 int oldsize, newsize;
192 va_start(ap, trailing_path);
193 strip = va_arg(ap, char *);
195 sprintf(base, "%5.3f",
196 (double)PERL_REVISION + ((double)PERL_VERSION / (double)1000));
198 if (!*w32_module_name) {
199 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
200 ? GetModuleHandle(NULL)
201 : w32_perldll_handle),
202 w32_module_name, sizeof(w32_module_name));
204 /* try to get full path to binary (which may be mangled when perl is
205 * run from a 16-bit app) */
206 /*PerlIO_printf(PerlIO_stderr(), "Before %s\n", w32_module_name);*/
207 (void)win32_longpath(w32_module_name);
208 /*PerlIO_printf(PerlIO_stderr(), "After %s\n", w32_module_name);*/
210 /* normalize to forward slashes */
211 ptr = w32_module_name;
218 strcpy(mod_name, w32_module_name);
219 ptr = strrchr(mod_name, '/');
220 while (ptr && strip) {
221 /* look for directories to skip back */
224 ptr = strrchr(mod_name, '/');
225 /* avoid stripping component if there is no slash,
226 * or it doesn't match ... */
227 if (!ptr || stricmp(ptr+1, strip) != 0) {
228 /* ... but not if component matches 5.00X* */
229 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
230 && strncmp(strip, base, 5) == 0
231 && strncmp(ptr+1, base, 5) == 0))
237 strip = va_arg(ap, char *);
245 strcpy(++ptr, trailing_path);
247 /* only add directory if it exists */
248 if (GetFileAttributes(mod_name) != (DWORD) -1) {
249 /* directory exists */
252 *prev_pathp = sv_2mortal(newSVpvn("",0));
253 sv_catpvn(*prev_pathp, ";", 1);
254 sv_catpv(*prev_pathp, mod_name);
255 return SvPVX(*prev_pathp);
262 win32_get_privlib(char *pl)
265 char *stdlib = "lib";
266 char buffer[MAX_PATH+1];
269 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
270 sprintf(buffer, "%s-%s", stdlib, pl);
271 if (!get_regstr(buffer, &sv))
272 (void)get_regstr(stdlib, &sv);
274 /* $stdlib .= ";$EMD/../../lib" */
275 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
279 win32_get_sitelib(char *pl)
282 char *sitelib = "sitelib";
284 char pathstr[MAX_PATH+1];
290 /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */
291 sprintf(regstr, "%s-%s", sitelib, pl);
292 (void)get_regstr(regstr, &sv1);
295 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib"; */
296 sprintf(pathstr, "site/%s/lib", pl);
297 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
298 if (!sv1 && strlen(pl) == 7) {
299 /* pl may have been SUBVERSION-specific; try again without
301 sprintf(pathstr, "site/%.5s/lib", pl);
302 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
305 /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */
306 (void)get_regstr(sitelib, &sv2);
309 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/lib"; */
310 (void)get_emd_part(&sv2, "site/lib", ARCHNAME, "bin", pl, Nullch);
319 sv_catpvn(sv1, ";", 1);
327 has_shell_metachars(char *ptr)
333 * Scan string looking for redirection (< or >) or pipe
334 * characters (|) that are not in a quoted string.
335 * Shell variable interpolation (%VAR%) can also happen inside strings.
367 #if !defined(PERL_OBJECT)
368 /* since the current process environment is being updated in util.c
369 * the library functions will get the correct environment
372 Perl_my_popen(pTHX_ char *cmd, char *mode)
375 #define fixcmd(x) { \
376 char *pspace = strchr((x),' '); \
379 while (p < pspace) { \
390 PERL_FLUSHALL_FOR_CHILD;
391 return win32_popen(cmd, mode);
395 Perl_my_pclose(pTHX_ PerlIO *fp)
397 return win32_pclose(fp);
401 DllExport unsigned long
404 static OSVERSIONINFO osver;
406 if (osver.dwPlatformId != w32_platform) {
407 memset(&osver, 0, sizeof(OSVERSIONINFO));
408 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
409 GetVersionEx(&osver);
410 w32_platform = osver.dwPlatformId;
412 return (unsigned long)w32_platform;
415 /* Tokenize a string. Words are null-separated, and the list
416 * ends with a doubled null. Any character (except null and
417 * including backslash) may be escaped by preceding it with a
418 * backslash (the backslash will be stripped).
419 * Returns number of words in result buffer.
422 tokenize(char *str, char **dest, char ***destv)
424 char *retstart = Nullch;
425 char **retvstart = 0;
429 int slen = strlen(str);
431 register char **retv;
432 New(1307, ret, slen+2, char);
433 New(1308, retv, (slen+3)/2, char*);
441 if (*ret == '\\' && *str)
443 else if (*ret == ' ') {
459 retvstart[items] = Nullch;
472 if (!w32_perlshell_tokens) {
473 /* we don't use COMSPEC here for two reasons:
474 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
475 * uncontrolled unportability of the ensuing scripts.
476 * 2. PERL5SHELL could be set to a shell that may not be fit for
477 * interactive use (which is what most programs look in COMSPEC
480 char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c");
481 char *usershell = getenv("PERL5SHELL");
482 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
483 &w32_perlshell_tokens,
489 do_aspawn(void *vreally, void **vmark, void **vsp)
492 SV *really = (SV*)vreally;
493 SV **mark = (SV**)vmark;
505 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
507 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
512 while (++mark <= sp) {
513 if (*mark && (str = SvPV_nolen(*mark)))
520 status = win32_spawnvp(flag,
521 (const char*)(really ? SvPV_nolen(really) : argv[0]),
522 (const char* const*)argv);
524 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
525 /* possible shell-builtin, invoke with shell */
527 sh_items = w32_perlshell_items;
529 argv[index+sh_items] = argv[index];
530 while (--sh_items >= 0)
531 argv[sh_items] = w32_perlshell_vec[sh_items];
533 status = win32_spawnvp(flag,
534 (const char*)(really ? SvPV_nolen(really) : argv[0]),
535 (const char* const*)argv);
538 if (flag != P_NOWAIT) {
541 if (ckWARN(WARN_EXEC))
542 Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
547 PL_statusvalue = status;
554 do_spawn2(char *cmd, int exectype)
561 BOOL needToTry = TRUE;
564 /* Save an extra exec if possible. See if there are shell
565 * metacharacters in it */
566 if (!has_shell_metachars(cmd)) {
567 New(1301,argv, strlen(cmd) / 2 + 2, char*);
568 New(1302,cmd2, strlen(cmd) + 1, char);
571 for (s = cmd2; *s;) {
572 while (*s && isSPACE(*s))
576 while (*s && !isSPACE(*s))
585 status = win32_spawnvp(P_WAIT, argv[0],
586 (const char* const*)argv);
588 case EXECF_SPAWN_NOWAIT:
589 status = win32_spawnvp(P_NOWAIT, argv[0],
590 (const char* const*)argv);
593 status = win32_execvp(argv[0], (const char* const*)argv);
596 if (status != -1 || errno == 0)
606 New(1306, argv, w32_perlshell_items + 2, char*);
607 while (++i < w32_perlshell_items)
608 argv[i] = w32_perlshell_vec[i];
613 status = win32_spawnvp(P_WAIT, argv[0],
614 (const char* const*)argv);
616 case EXECF_SPAWN_NOWAIT:
617 status = win32_spawnvp(P_NOWAIT, argv[0],
618 (const char* const*)argv);
621 status = win32_execvp(argv[0], (const char* const*)argv);
627 if (exectype != EXECF_SPAWN_NOWAIT) {
630 if (ckWARN(WARN_EXEC))
631 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
632 (exectype == EXECF_EXEC ? "exec" : "spawn"),
633 cmd, strerror(errno));
638 PL_statusvalue = status;
646 return do_spawn2(cmd, EXECF_SPAWN);
650 do_spawn_nowait(char *cmd)
652 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
656 Perl_do_exec(pTHX_ char *cmd)
658 do_spawn2(cmd, EXECF_EXEC);
662 /* The idea here is to read all the directory names into a string table
663 * (separated by nulls) and when one of the other dir functions is called
664 * return the pointer to the current file name.
667 win32_opendir(char *filename)
673 char scanname[MAX_PATH+3];
675 WIN32_FIND_DATAA aFindData;
676 WIN32_FIND_DATAW wFindData;
678 char buffer[MAX_PATH*2];
679 WCHAR wbuffer[MAX_PATH];
682 len = strlen(filename);
686 /* check to see if filename is a directory */
687 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
690 /* Get us a DIR structure */
691 Newz(1303, p, 1, DIR);
695 /* Create the search pattern */
696 strcpy(scanname, filename);
698 /* bare drive name means look in cwd for drive */
699 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
700 scanname[len++] = '.';
701 scanname[len++] = '/';
703 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
704 scanname[len++] = '/';
706 scanname[len++] = '*';
707 scanname[len] = '\0';
709 /* do the FindFirstFile call */
711 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
712 fh = FindFirstFileW(wbuffer, &wFindData);
715 fh = FindFirstFileA(scanname, &aFindData);
717 if (fh == INVALID_HANDLE_VALUE) {
718 /* FindFirstFile() fails on empty drives! */
719 if (GetLastError() == ERROR_FILE_NOT_FOUND)
725 /* now allocate the first part of the string table for
726 * the filenames that we find.
729 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
733 ptr = aFindData.cFileName;
736 New(1304, p->start, idx, char);
737 if (p->start == NULL)
738 Perl_croak_nocontext("opendir: malloc failed!\n");
739 strcpy(p->start, ptr);
742 /* loop finding all the files that match the wildcard
743 * (which should be all of them in this directory!).
744 * the variable idx should point one past the null terminator
745 * of the previous string found.
748 ? FindNextFileW(fh, &wFindData)
749 : FindNextFileA(fh, &aFindData)) {
751 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
753 /* ptr is set above to the correct area */
755 /* bump the string table size by enough for the
756 * new name and it's null terminator
758 Renew(p->start, idx+len+1, char);
759 if (p->start == NULL)
760 Perl_croak_nocontext("opendir: malloc failed!\n");
761 strcpy(&p->start[idx], ptr);
772 /* Readdir just returns the current string pointer and bumps the
773 * string pointer to the nDllExport entry.
775 DllExport struct direct *
776 win32_readdir(DIR *dirp)
779 static int dummy = 0;
782 /* first set up the structure to return */
783 len = strlen(dirp->curr);
784 strcpy(dirp->dirstr.d_name, dirp->curr);
785 dirp->dirstr.d_namlen = len;
788 dirp->dirstr.d_ino = dummy++;
790 /* Now set up for the nDllExport call to readdir */
791 dirp->curr += len + 1;
792 if (dirp->curr >= (dirp->start + dirp->size)) {
796 return &(dirp->dirstr);
802 /* Telldir returns the current string pointer position */
804 win32_telldir(DIR *dirp)
806 return (long) dirp->curr;
810 /* Seekdir moves the string pointer to a previously saved position
814 win32_seekdir(DIR *dirp, long loc)
816 dirp->curr = (char *)loc;
819 /* Rewinddir resets the string pointer to the start */
821 win32_rewinddir(DIR *dirp)
823 dirp->curr = dirp->start;
826 /* free the memory allocated by opendir */
828 win32_closedir(DIR *dirp)
831 Safefree(dirp->start);
844 * Just pretend that everyone is a superuser. NT will let us know if
845 * we don\'t really have permission to do something.
848 #define ROOT_UID ((uid_t)0)
849 #define ROOT_GID ((gid_t)0)
878 return (auid == ROOT_UID ? 0 : -1);
884 return (agid == ROOT_GID ? 0 : -1);
891 char *buf = getlogin_buffer;
892 DWORD size = sizeof(getlogin_buffer);
893 if (GetUserName(buf,&size))
899 chown(const char *path, uid_t owner, gid_t group)
910 for (child = 0 ; child < w32_num_children ; ++child) {
911 if (w32_child_pids[child] == pid)
918 remove_dead_process(long child)
922 CloseHandle(w32_child_handles[child]);
923 Copy(&w32_child_handles[child+1], &w32_child_handles[child],
924 (w32_num_children-child-1), HANDLE);
925 Copy(&w32_child_pids[child+1], &w32_child_pids[child],
926 (w32_num_children-child-1), DWORD);
932 win32_kill(int pid, int sig)
935 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
936 if (hProcess && TerminateProcess(hProcess, sig))
937 CloseHandle(hProcess);
949 DllExport unsigned int
950 win32_sleep(unsigned int t)
957 win32_stat(const char *path, struct stat *buffer)
961 int l = strlen(path);
963 WCHAR wbuffer[MAX_PATH];
966 switch(path[l - 1]) {
967 /* FindFirstFile() and stat() are buggy with a trailing
968 * backslash, so change it to a forward slash :-( */
970 strncpy(t, path, l-1);
975 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
977 if (l == 2 && isALPHA(path[0])) {
978 t[0] = path[0]; t[1] = ':'; t[2] = '.'; t[3] = '\0';
986 A2WHELPER(path, wbuffer, sizeof(wbuffer));
987 res = _wstat(wbuffer, (struct _stat *)buffer);
990 res = stat(path, buffer);
993 /* CRT is buggy on sharenames, so make sure it really isn't.
994 * XXX using GetFileAttributesEx() will enable us to set
995 * buffer->st_*time (but note that's not available on the
996 * Windows of 1995) */
999 r = GetFileAttributesW(wbuffer);
1002 r = GetFileAttributesA(path);
1004 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1005 /* buffer may still contain old garbage since stat() failed */
1006 Zero(buffer, 1, struct stat);
1007 buffer->st_mode = S_IFDIR | S_IREAD;
1009 if (!(r & FILE_ATTRIBUTE_READONLY))
1010 buffer->st_mode |= S_IWRITE | S_IEXEC;
1015 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1016 && (path[2] == '\\' || path[2] == '/'))
1018 /* The drive can be inaccessible, some _stat()s are buggy */
1020 ? !GetVolumeInformationW(wbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1021 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1027 if (S_ISDIR(buffer->st_mode))
1028 buffer->st_mode |= S_IWRITE | S_IEXEC;
1029 else if (S_ISREG(buffer->st_mode)) {
1030 if (l >= 4 && path[l-4] == '.') {
1031 const char *e = path + l - 3;
1032 if (strnicmp(e,"exe",3)
1033 && strnicmp(e,"bat",3)
1034 && strnicmp(e,"com",3)
1035 && (IsWin95() || strnicmp(e,"cmd",3)))
1036 buffer->st_mode &= ~S_IEXEC;
1038 buffer->st_mode |= S_IEXEC;
1041 buffer->st_mode &= ~S_IEXEC;
1048 /* Find the longname of a given path. path is destructively modified.
1049 * It should have space for at least MAX_PATH characters. */
1051 win32_longpath(char *path)
1053 WIN32_FIND_DATA fdata;
1055 char tmpbuf[MAX_PATH+1];
1056 char *tmpstart = tmpbuf;
1063 if (isALPHA(path[0]) && path[1] == ':' &&
1064 (path[2] == '/' || path[2] == '\\'))
1067 *tmpstart++ = path[0];
1071 else if ((path[0] == '/' || path[0] == '\\') &&
1072 (path[1] == '/' || path[1] == '\\'))
1075 *tmpstart++ = path[0];
1076 *tmpstart++ = path[1];
1077 /* copy machine name */
1078 while (*start && *start != '/' && *start != '\\')
1079 *tmpstart++ = *start++;
1081 *tmpstart++ = *start;
1083 /* copy share name */
1084 while (*start && *start != '/' && *start != '\\')
1085 *tmpstart++ = *start++;
1089 if (sep == '/' || sep == '\\')
1093 /* walk up to slash */
1094 while (*start && *start != '/' && *start != '\\')
1097 /* discard doubled slashes */
1098 while (*start && (start[1] == '/' || start[1] == '\\'))
1102 /* stop and find full name of component */
1104 fhand = FindFirstFile(path,&fdata);
1105 if (fhand != INVALID_HANDLE_VALUE) {
1106 strcpy(tmpstart, fdata.cFileName);
1107 tmpstart += strlen(fdata.cFileName);
1115 /* failed a step, just return without side effects */
1116 /*PerlIO_printf(PerlIO_stderr(), "Failed to find %s\n", path);*/
1121 strcpy(path,tmpbuf);
1125 #ifndef USE_WIN32_RTL_ENV
1128 win32_getenv(const char *name)
1131 WCHAR wBuffer[MAX_PATH];
1133 SV *curitem = Nullsv;
1136 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1137 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1140 needlen = GetEnvironmentVariableA(name,NULL,0);
1142 curitem = sv_2mortal(newSVpvn("", 0));
1146 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1147 needlen = GetEnvironmentVariableW(wBuffer,
1148 (WCHAR*)SvPVX(curitem),
1150 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1151 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1152 acuritem = sv_2mortal(newSVsv(curitem));
1153 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1157 SvGROW(curitem, needlen+1);
1158 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1160 } while (needlen >= SvLEN(curitem));
1161 SvCUR_set(curitem, needlen);
1165 /* allow any environment variables that begin with 'PERL'
1166 to be stored in the registry */
1167 if (strncmp(name, "PERL", 4) == 0)
1168 (void)get_regstr(name, &curitem);
1170 if (curitem && SvCUR(curitem))
1171 return SvPVX(curitem);
1177 win32_putenv(const char *name)
1184 int length, relval = -1;
1188 length = strlen(name)+1;
1189 New(1309,wCuritem,length,WCHAR);
1190 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1191 wVal = wcschr(wCuritem, '=');
1194 if(SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1200 New(1309,curitem,strlen(name)+1,char);
1201 strcpy(curitem, name);
1202 val = strchr(curitem, '=');
1204 /* The sane way to deal with the environment.
1205 * Has these advantages over putenv() & co.:
1206 * * enables us to store a truly empty value in the
1207 * environment (like in UNIX).
1208 * * we don't have to deal with RTL globals, bugs and leaks.
1210 * Why you may want to enable USE_WIN32_RTL_ENV:
1211 * * environ[] and RTL functions will not reflect changes,
1212 * which might be an issue if extensions want to access
1213 * the env. via RTL. This cuts both ways, since RTL will
1214 * not see changes made by extensions that call the Win32
1215 * functions directly, either.
1219 if(SetEnvironmentVariableA(curitem, *val ? val : NULL))
1231 filetime_to_clock(PFILETIME ft)
1233 __int64 qw = ft->dwHighDateTime;
1235 qw |= ft->dwLowDateTime;
1236 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1241 win32_times(struct tms *timebuf)
1246 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1248 timebuf->tms_utime = filetime_to_clock(&user);
1249 timebuf->tms_stime = filetime_to_clock(&kernel);
1250 timebuf->tms_cutime = 0;
1251 timebuf->tms_cstime = 0;
1254 /* That failed - e.g. Win95 fallback to clock() */
1255 clock_t t = clock();
1256 timebuf->tms_utime = t;
1257 timebuf->tms_stime = 0;
1258 timebuf->tms_cutime = 0;
1259 timebuf->tms_cstime = 0;
1264 /* fix utime() so it works on directories in NT
1265 * thanks to Jan Dubois <jan.dubois@ibm.net>
1268 filetime_from_time(PFILETIME pFileTime, time_t Time)
1270 struct tm *pTM = gmtime(&Time);
1271 SYSTEMTIME SystemTime;
1276 SystemTime.wYear = pTM->tm_year + 1900;
1277 SystemTime.wMonth = pTM->tm_mon + 1;
1278 SystemTime.wDay = pTM->tm_mday;
1279 SystemTime.wHour = pTM->tm_hour;
1280 SystemTime.wMinute = pTM->tm_min;
1281 SystemTime.wSecond = pTM->tm_sec;
1282 SystemTime.wMilliseconds = 0;
1284 return SystemTimeToFileTime(&SystemTime, pFileTime);
1288 win32_utime(const char *filename, struct utimbuf *times)
1295 struct utimbuf TimeBuffer;
1296 WCHAR wbuffer[MAX_PATH];
1300 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1301 rc = _wutime(wbuffer, (struct _utimbuf*)times);
1304 rc = utime(filename, times);
1306 /* EACCES: path specifies directory or readonly file */
1307 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1310 if (times == NULL) {
1311 times = &TimeBuffer;
1312 time(×->actime);
1313 times->modtime = times->actime;
1316 /* This will (and should) still fail on readonly files */
1318 handle = CreateFileW(wbuffer, GENERIC_READ | GENERIC_WRITE,
1319 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1320 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1323 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1324 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1325 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1327 if (handle == INVALID_HANDLE_VALUE)
1330 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1331 filetime_from_time(&ftAccess, times->actime) &&
1332 filetime_from_time(&ftWrite, times->modtime) &&
1333 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1338 CloseHandle(handle);
1343 win32_uname(struct utsname *name)
1345 struct hostent *hep;
1346 STRLEN nodemax = sizeof(name->nodename)-1;
1347 OSVERSIONINFO osver;
1349 memset(&osver, 0, sizeof(OSVERSIONINFO));
1350 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1351 if (GetVersionEx(&osver)) {
1353 switch (osver.dwPlatformId) {
1354 case VER_PLATFORM_WIN32_WINDOWS:
1355 strcpy(name->sysname, "Windows");
1357 case VER_PLATFORM_WIN32_NT:
1358 strcpy(name->sysname, "Windows NT");
1360 case VER_PLATFORM_WIN32s:
1361 strcpy(name->sysname, "Win32s");
1364 strcpy(name->sysname, "Win32 Unknown");
1369 sprintf(name->release, "%d.%d",
1370 osver.dwMajorVersion, osver.dwMinorVersion);
1373 sprintf(name->version, "Build %d",
1374 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1375 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1376 if (osver.szCSDVersion[0]) {
1377 char *buf = name->version + strlen(name->version);
1378 sprintf(buf, " (%s)", osver.szCSDVersion);
1382 *name->sysname = '\0';
1383 *name->version = '\0';
1384 *name->release = '\0';
1388 hep = win32_gethostbyname("localhost");
1390 STRLEN len = strlen(hep->h_name);
1391 if (len <= nodemax) {
1392 strcpy(name->nodename, hep->h_name);
1395 strncpy(name->nodename, hep->h_name, nodemax);
1396 name->nodename[nodemax] = '\0';
1401 if (!GetComputerName(name->nodename, &sz))
1402 *name->nodename = '\0';
1405 /* machine (architecture) */
1409 GetSystemInfo(&info);
1411 #if defined(__BORLANDC__) || defined(__MINGW32__)
1412 switch (info.u.s.wProcessorArchitecture) {
1414 switch (info.wProcessorArchitecture) {
1416 case PROCESSOR_ARCHITECTURE_INTEL:
1417 arch = "x86"; break;
1418 case PROCESSOR_ARCHITECTURE_MIPS:
1419 arch = "mips"; break;
1420 case PROCESSOR_ARCHITECTURE_ALPHA:
1421 arch = "alpha"; break;
1422 case PROCESSOR_ARCHITECTURE_PPC:
1423 arch = "ppc"; break;
1425 arch = "unknown"; break;
1427 strcpy(name->machine, arch);
1433 win32_waitpid(int pid, int *status, int flags)
1438 return win32_wait(status);
1440 long child = find_pid(pid);
1442 HANDLE hProcess = w32_child_handles[child];
1443 DWORD waitcode = WaitForSingleObject(hProcess, INFINITE);
1444 if (waitcode != WAIT_FAILED) {
1445 if (GetExitCodeProcess(hProcess, &waitcode)) {
1446 *status = (int)((waitcode & 0xff) << 8);
1447 retval = (int)w32_child_pids[child];
1448 remove_dead_process(child);
1456 retval = cwait(status, pid, WAIT_CHILD);
1457 /* cwait() returns "correctly" on Borland */
1458 #ifndef __BORLANDC__
1464 return retval >= 0 ? pid : retval;
1468 win32_wait(int *status)
1470 /* XXX this wait emulation only knows about processes
1471 * spawned via win32_spawnvp(P_NOWAIT, ...).
1475 DWORD exitcode, waitcode;
1477 if (!w32_num_children) {
1482 /* if a child exists, wait for it to die */
1483 waitcode = WaitForMultipleObjects(w32_num_children,
1487 if (waitcode != WAIT_FAILED) {
1488 if (waitcode >= WAIT_ABANDONED_0
1489 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1490 i = waitcode - WAIT_ABANDONED_0;
1492 i = waitcode - WAIT_OBJECT_0;
1493 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1494 *status = (int)((exitcode & 0xff) << 8);
1495 retval = (int)w32_child_pids[i];
1496 remove_dead_process(i);
1502 errno = GetLastError();
1506 static UINT timerid = 0;
1508 static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
1511 KillTimer(NULL,timerid);
1516 DllExport unsigned int
1517 win32_alarm(unsigned int sec)
1520 * the 'obvious' implentation is SetTimer() with a callback
1521 * which does whatever receiving SIGALRM would do
1522 * we cannot use SIGALRM even via raise() as it is not
1523 * one of the supported codes in <signal.h>
1525 * Snag is unless something is looking at the message queue
1526 * nothing happens :-(
1531 timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
1533 Perl_croak_nocontext("Cannot set timer");
1539 KillTimer(NULL,timerid);
1546 #if defined(HAVE_DES_FCRYPT) || defined(PERL_OBJECT)
1547 #ifdef HAVE_DES_FCRYPT
1548 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
1552 win32_crypt(const char *txt, const char *salt)
1554 #ifdef HAVE_DES_FCRYPT
1557 return des_fcrypt(txt, salt, crypt_buffer);
1559 die("The crypt() function is unimplemented due to excessive paranoia.");
1565 #ifdef USE_FIXED_OSFHANDLE
1567 EXTERN_C int __cdecl _alloc_osfhnd(void);
1568 EXTERN_C int __cdecl _set_osfhnd(int fh, long value);
1569 EXTERN_C void __cdecl _lock_fhandle(int);
1570 EXTERN_C void __cdecl _unlock_fhandle(int);
1571 EXTERN_C void __cdecl _unlock(int);
1573 #if (_MSC_VER >= 1000)
1575 long osfhnd; /* underlying OS file HANDLE */
1576 char osfile; /* attributes of file (e.g., open in text mode?) */
1577 char pipech; /* one char buffer for handles opened on pipes */
1578 #if defined (_MT) && !defined (DLL_FOR_WIN32S)
1580 CRITICAL_SECTION lock;
1581 #endif /* defined (_MT) && !defined (DLL_FOR_WIN32S) */
1584 EXTERN_C ioinfo * __pioinfo[];
1586 #define IOINFO_L2E 5
1587 #define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
1588 #define _pioinfo(i) (__pioinfo[i >> IOINFO_L2E] + (i & (IOINFO_ARRAY_ELTS - 1)))
1589 #define _osfile(i) (_pioinfo(i)->osfile)
1591 #else /* (_MSC_VER >= 1000) */
1592 extern char _osfile[];
1593 #endif /* (_MSC_VER >= 1000) */
1595 #define FOPEN 0x01 /* file handle open */
1596 #define FAPPEND 0x20 /* file handle opened O_APPEND */
1597 #define FDEV 0x40 /* file handle refers to device */
1598 #define FTEXT 0x80 /* file handle is in text mode */
1600 #define _STREAM_LOCKS 26 /* Table of stream locks */
1601 #define _LAST_STREAM_LOCK (_STREAM_LOCKS+_NSTREAM_-1) /* Last stream lock */
1602 #define _FH_LOCKS (_LAST_STREAM_LOCK+1) /* Table of fh locks */
1605 *int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
1608 * This function allocates a free C Runtime file handle and associates
1609 * it with the Win32 HANDLE specified by the first parameter. This is a
1610 * temperary fix for WIN95's brain damage GetFileType() error on socket
1611 * we just bypass that call for socket
1614 * long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
1615 * int flags - flags to associate with C Runtime file handle.
1618 * returns index of entry in fh, if successful
1619 * return -1, if no free entry is found
1623 *******************************************************************************/
1626 my_open_osfhandle(long osfhandle, int flags)
1629 char fileflags; /* _osfile flags */
1631 /* copy relevant flags from second parameter */
1634 if (flags & O_APPEND)
1635 fileflags |= FAPPEND;
1640 /* attempt to allocate a C Runtime file handle */
1641 if ((fh = _alloc_osfhnd()) == -1) {
1642 errno = EMFILE; /* too many open files */
1643 _doserrno = 0L; /* not an OS error */
1644 return -1; /* return error to caller */
1647 /* the file is open. now, set the info in _osfhnd array */
1648 _set_osfhnd(fh, osfhandle);
1650 fileflags |= FOPEN; /* mark as open */
1652 #if (_MSC_VER >= 1000)
1653 _osfile(fh) = fileflags; /* set osfile entry */
1654 _unlock_fhandle(fh);
1656 _osfile[fh] = fileflags; /* set osfile entry */
1657 _unlock(fh+_FH_LOCKS); /* unlock handle */
1660 return fh; /* return handle */
1663 #define _open_osfhandle my_open_osfhandle
1664 #endif /* USE_FIXED_OSFHANDLE */
1666 /* simulate flock by locking a range on the file */
1668 #define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
1669 #define LK_LEN 0xffff0000
1672 win32_flock(int fd, int oper)
1680 Perl_croak_nocontext("flock() unimplemented on this platform");
1683 fh = (HANDLE)_get_osfhandle(fd);
1684 memset(&o, 0, sizeof(o));
1687 case LOCK_SH: /* shared lock */
1688 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
1690 case LOCK_EX: /* exclusive lock */
1691 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
1693 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
1694 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
1696 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
1697 LK_ERR(LockFileEx(fh,
1698 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
1699 0, LK_LEN, 0, &o),i);
1701 case LOCK_UN: /* unlock lock */
1702 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
1704 default: /* unknown */
1715 * redirected io subsystem for all XS modules
1728 return (&(_environ));
1731 /* the rest are the remapped stdio routines */
1751 win32_ferror(FILE *fp)
1753 return (ferror(fp));
1758 win32_feof(FILE *fp)
1764 * Since the errors returned by the socket error function
1765 * WSAGetLastError() are not known by the library routine strerror
1766 * we have to roll our own.
1770 win32_strerror(int e)
1772 #ifndef __BORLANDC__ /* Borland intolerance */
1773 extern int sys_nerr;
1777 if (e < 0 || e > sys_nerr) {
1782 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
1783 strerror_buffer, sizeof(strerror_buffer), NULL) == 0)
1784 strcpy(strerror_buffer, "Unknown Error");
1786 return strerror_buffer;
1792 win32_str_os_error(void *sv, DWORD dwErr)
1796 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
1797 |FORMAT_MESSAGE_IGNORE_INSERTS
1798 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
1799 dwErr, 0, (char *)&sMsg, 1, NULL);
1801 while (0 < dwLen && isSPACE(sMsg[--dwLen]))
1803 if ('.' != sMsg[dwLen])
1808 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
1810 dwLen = sprintf(sMsg,
1811 "Unknown error #0x%lX (lookup 0x%lX)",
1812 dwErr, GetLastError());
1816 sv_setpvn((SV*)sv, sMsg, dwLen);
1823 win32_fprintf(FILE *fp, const char *format, ...)
1826 va_start(marker, format); /* Initialize variable arguments. */
1828 return (vfprintf(fp, format, marker));
1832 win32_printf(const char *format, ...)
1835 va_start(marker, format); /* Initialize variable arguments. */
1837 return (vprintf(format, marker));
1841 win32_vfprintf(FILE *fp, const char *format, va_list args)
1843 return (vfprintf(fp, format, args));
1847 win32_vprintf(const char *format, va_list args)
1849 return (vprintf(format, args));
1853 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
1855 return fread(buf, size, count, fp);
1859 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
1861 return fwrite(buf, size, count, fp);
1864 #define MODE_SIZE 10
1867 win32_fopen(const char *filename, const char *mode)
1870 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH];
1875 if (stricmp(filename, "/dev/null")==0)
1879 A2WHELPER(mode, wMode, sizeof(wMode));
1880 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1881 return _wfopen(wBuffer, wMode);
1883 return fopen(filename, mode);
1886 #ifndef USE_SOCKETS_AS_HANDLES
1888 #define fdopen my_fdopen
1892 win32_fdopen(int handle, const char *mode)
1895 WCHAR wMode[MODE_SIZE];
1897 A2WHELPER(mode, wMode, sizeof(wMode));
1898 return _wfdopen(handle, wMode);
1900 return fdopen(handle, (char *) mode);
1904 win32_freopen(const char *path, const char *mode, FILE *stream)
1907 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH];
1908 if (stricmp(path, "/dev/null")==0)
1912 A2WHELPER(mode, wMode, sizeof(wMode));
1913 A2WHELPER(path, wBuffer, sizeof(wBuffer));
1914 return _wfreopen(wBuffer, wMode, stream);
1916 return freopen(path, mode, stream);
1920 win32_fclose(FILE *pf)
1922 return my_fclose(pf); /* defined in win32sck.c */
1926 win32_fputs(const char *s,FILE *pf)
1928 return fputs(s, pf);
1932 win32_fputc(int c,FILE *pf)
1938 win32_ungetc(int c,FILE *pf)
1940 return ungetc(c,pf);
1944 win32_getc(FILE *pf)
1950 win32_fileno(FILE *pf)
1956 win32_clearerr(FILE *pf)
1963 win32_fflush(FILE *pf)
1969 win32_ftell(FILE *pf)
1975 win32_fseek(FILE *pf,long offset,int origin)
1977 return fseek(pf, offset, origin);
1981 win32_fgetpos(FILE *pf,fpos_t *p)
1983 return fgetpos(pf, p);
1987 win32_fsetpos(FILE *pf,const fpos_t *p)
1989 return fsetpos(pf, p);
1993 win32_rewind(FILE *pf)
2013 win32_fstat(int fd,struct stat *sbufptr)
2015 return fstat(fd,sbufptr);
2019 win32_pipe(int *pfd, unsigned int size, int mode)
2021 return _pipe(pfd, size, mode);
2025 * a popen() clone that respects PERL5SHELL
2029 win32_popen(const char *command, const char *mode)
2031 #ifdef USE_RTL_POPEN
2032 return _popen(command, mode);
2040 /* establish which ends read and write */
2041 if (strchr(mode,'w')) {
2042 stdfd = 0; /* stdin */
2046 else if (strchr(mode,'r')) {
2047 stdfd = 1; /* stdout */
2054 /* set the correct mode */
2055 if (strchr(mode,'b'))
2057 else if (strchr(mode,'t'))
2060 ourmode = _fmode & (O_TEXT | O_BINARY);
2062 /* the child doesn't inherit handles */
2063 ourmode |= O_NOINHERIT;
2065 if (win32_pipe( p, 512, ourmode) == -1)
2068 /* save current stdfd */
2069 if ((oldfd = win32_dup(stdfd)) == -1)
2072 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2073 /* stdfd will be inherited by the child */
2074 if (win32_dup2(p[child], stdfd) == -1)
2077 /* close the child end in parent */
2078 win32_close(p[child]);
2080 /* start the child */
2083 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2086 /* revert stdfd to whatever it was before */
2087 if (win32_dup2(oldfd, stdfd) == -1)
2090 /* close saved handle */
2093 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2095 /* set process id so that it can be returned by perl's open() */
2096 PL_forkprocess = childpid;
2099 /* we have an fd, return a file stream */
2100 return (win32_fdopen(p[parent], (char *)mode));
2103 /* we don't need to check for errors here */
2107 win32_dup2(oldfd, stdfd);
2112 #endif /* USE_RTL_POPEN */
2120 win32_pclose(FILE *pf)
2122 #ifdef USE_RTL_POPEN
2126 int childpid, status;
2129 sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE);
2131 childpid = SvIVX(sv);
2143 if (win32_waitpid(childpid, &status, 0) == -1)
2148 #endif /* USE_RTL_POPEN */
2152 win32_rename(const char *oname, const char *newname)
2154 WCHAR wOldName[MAX_PATH];
2155 WCHAR wNewName[MAX_PATH];
2157 /* XXX despite what the documentation says about MoveFileEx(),
2158 * it doesn't work under Windows95!
2163 A2WHELPER(oname, wOldName, sizeof(wOldName));
2164 A2WHELPER(newname, wNewName, sizeof(wNewName));
2165 bResult = MoveFileExW(wOldName,wNewName,
2166 MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
2169 bResult = MoveFileExA(oname,newname,
2170 MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
2173 DWORD err = GetLastError();
2175 case ERROR_BAD_NET_NAME:
2176 case ERROR_BAD_NETPATH:
2177 case ERROR_BAD_PATHNAME:
2178 case ERROR_FILE_NOT_FOUND:
2179 case ERROR_FILENAME_EXCED_RANGE:
2180 case ERROR_INVALID_DRIVE:
2181 case ERROR_NO_MORE_FILES:
2182 case ERROR_PATH_NOT_FOUND:
2195 char tmpname[MAX_PATH+1];
2196 char dname[MAX_PATH+1];
2197 char *endname = Nullch;
2199 DWORD from_attr, to_attr;
2201 /* if oname doesn't exist, do nothing */
2202 from_attr = GetFileAttributes(oname);
2203 if (from_attr == 0xFFFFFFFF) {
2208 /* if newname exists, rename it to a temporary name so that we
2209 * don't delete it in case oname happens to be the same file
2210 * (but perhaps accessed via a different path)
2212 to_attr = GetFileAttributes(newname);
2213 if (to_attr != 0xFFFFFFFF) {
2214 /* if newname is a directory, we fail
2215 * XXX could overcome this with yet more convoluted logic */
2216 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2220 tmplen = strlen(newname);
2221 strcpy(tmpname,newname);
2222 endname = tmpname+tmplen;
2223 for (; endname > tmpname ; --endname) {
2224 if (*endname == '/' || *endname == '\\') {
2229 if (endname > tmpname)
2230 endname = strcpy(dname,tmpname);
2234 /* get a temporary filename in same directory
2235 * XXX is this really the best we can do? */
2236 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, tmpname)) {
2240 DeleteFile(tmpname);
2242 retval = rename(newname, tmpname);
2249 /* rename oname to newname */
2250 retval = rename(oname, newname);
2252 /* if we created a temporary file before ... */
2253 if (endname != Nullch) {
2254 /* ...and rename succeeded, delete temporary file/directory */
2256 DeleteFile(tmpname);
2257 /* else restore it to what it was */
2259 (void)rename(tmpname, newname);
2266 win32_setmode(int fd, int mode)
2268 return setmode(fd, mode);
2272 win32_lseek(int fd, long offset, int origin)
2274 return lseek(fd, offset, origin);
2284 win32_open(const char *path, int flag, ...)
2289 WCHAR wBuffer[MAX_PATH];
2292 pmode = va_arg(ap, int);
2295 if (stricmp(path, "/dev/null")==0)
2299 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2300 return _wopen(wBuffer, flag, pmode);
2302 return open(path,flag,pmode);
2324 win32_dup2(int fd1,int fd2)
2326 return dup2(fd1,fd2);
2330 win32_read(int fd, void *buf, unsigned int cnt)
2332 return read(fd, buf, cnt);
2336 win32_write(int fd, const void *buf, unsigned int cnt)
2338 return write(fd, buf, cnt);
2342 win32_mkdir(const char *dir, int mode)
2344 return mkdir(dir); /* just ignore mode */
2348 win32_rmdir(const char *dir)
2354 win32_chdir(const char *dir)
2360 create_command_line(const char* command, const char * const *args)
2364 char *cmd, *ptr, *arg;
2365 STRLEN len = strlen(command) + 1;
2367 for (index = 0; (ptr = (char*)args[index]) != NULL; ++index)
2368 len += strlen(ptr) + 1;
2370 New(1310, cmd, len, char);
2372 strcpy(ptr, command);
2374 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
2384 qualified_path(const char *cmd)
2388 char *fullcmd, *curfullcmd;
2394 fullcmd = (char*)cmd;
2396 if (*fullcmd == '/' || *fullcmd == '\\')
2403 pathstr = win32_getenv("PATH");
2404 New(0, fullcmd, MAX_PATH+1, char);
2405 curfullcmd = fullcmd;
2410 /* start by appending the name to the current prefix */
2411 strcpy(curfullcmd, cmd);
2412 curfullcmd += cmdlen;
2414 /* if it doesn't end with '.', or has no extension, try adding
2415 * a trailing .exe first */
2416 if (cmd[cmdlen-1] != '.'
2417 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
2419 strcpy(curfullcmd, ".exe");
2420 res = GetFileAttributes(fullcmd);
2421 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
2426 /* that failed, try the bare name */
2427 res = GetFileAttributes(fullcmd);
2428 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
2431 /* quit if no other path exists, or if cmd already has path */
2432 if (!pathstr || !*pathstr || has_slash)
2435 /* skip leading semis */
2436 while (*pathstr == ';')
2439 /* build a new prefix from scratch */
2440 curfullcmd = fullcmd;
2441 while (*pathstr && *pathstr != ';') {
2442 if (*pathstr == '"') { /* foo;"baz;etc";bar */
2443 pathstr++; /* skip initial '"' */
2444 while (*pathstr && *pathstr != '"') {
2445 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
2446 *curfullcmd++ = *pathstr;
2450 pathstr++; /* skip trailing '"' */
2453 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
2454 *curfullcmd++ = *pathstr;
2459 pathstr++; /* skip trailing semi */
2460 if (curfullcmd > fullcmd /* append a dir separator */
2461 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
2463 *curfullcmd++ = '\\';
2471 /* XXX this needs to be made more compatible with the spawnvp()
2472 * provided by the various RTLs. In particular, searching for
2473 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
2474 * This doesn't significantly affect perl itself, because we
2475 * always invoke things using PERL5SHELL if a direct attempt to
2476 * spawn the executable fails.
2478 * XXX splitting and rejoining the commandline between do_aspawn()
2479 * and win32_spawnvp() could also be avoided.
2483 win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
2485 #ifdef USE_RTL_SPAWNVP
2486 return spawnvp(mode, cmdname, (char * const *)argv);
2490 STARTUPINFO StartupInfo;
2491 PROCESS_INFORMATION ProcessInformation;
2494 char *cmd = create_command_line(cmdname, strcmp(cmdname, argv[0]) == 0
2496 char *fullcmd = Nullch;
2499 case P_NOWAIT: /* asynch + remember result */
2500 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
2506 case P_WAIT: /* synchronous execution */
2508 default: /* invalid mode */
2513 memset(&StartupInfo,0,sizeof(StartupInfo));
2514 StartupInfo.cb = sizeof(StartupInfo);
2515 StartupInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE);
2516 StartupInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
2517 StartupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE);
2518 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
2519 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
2520 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
2522 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
2525 create |= CREATE_NEW_CONSOLE;
2529 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
2530 StartupInfo.wShowWindow = SW_HIDE;
2534 if (!CreateProcess(cmdname, /* search PATH to find executable */
2535 cmd, /* executable, and its arguments */
2536 NULL, /* process attributes */
2537 NULL, /* thread attributes */
2538 TRUE, /* inherit handles */
2539 create, /* creation flags */
2540 NULL, /* inherit environment */
2541 NULL, /* inherit cwd */
2543 &ProcessInformation))
2545 /* initial NULL argument to CreateProcess() does a PATH
2546 * search, but it always first looks in the directory
2547 * where the current process was started, which behavior
2548 * is undesirable for backward compatibility. So we
2549 * jump through our own hoops by picking out the path
2550 * we really want it to use. */
2552 fullcmd = qualified_path(cmdname);
2563 if (mode == P_NOWAIT) {
2564 /* asynchronous spawn -- store handle, return PID */
2565 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
2566 ret = w32_child_pids[w32_num_children] = ProcessInformation.dwProcessId;
2570 WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
2571 GetExitCodeProcess(ProcessInformation.hProcess, &ret);
2572 CloseHandle(ProcessInformation.hProcess);
2575 CloseHandle(ProcessInformation.hThread);
2584 win32_execv(const char *cmdname, const char *const *argv)
2586 return execv(cmdname, (char *const *)argv);
2590 win32_execvp(const char *cmdname, const char *const *argv)
2592 return execvp(cmdname, (char *const *)argv);
2596 win32_perror(const char *str)
2602 win32_setbuf(FILE *pf, char *buf)
2608 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
2610 return setvbuf(pf, buf, type, size);
2614 win32_flushall(void)
2620 win32_fcloseall(void)
2626 win32_fgets(char *s, int n, FILE *pf)
2628 return fgets(s, n, pf);
2638 win32_fgetc(FILE *pf)
2644 win32_putc(int c, FILE *pf)
2650 win32_puts(const char *s)
2662 win32_putchar(int c)
2669 #ifndef USE_PERL_SBRK
2671 static char *committed = NULL;
2672 static char *base = NULL;
2673 static char *reserved = NULL;
2674 static char *brk = NULL;
2675 static DWORD pagesize = 0;
2676 static DWORD allocsize = 0;
2684 GetSystemInfo(&info);
2685 /* Pretend page size is larger so we don't perpetually
2686 * call the OS to commit just one page ...
2688 pagesize = info.dwPageSize << 3;
2689 allocsize = info.dwAllocationGranularity;
2691 /* This scheme fails eventually if request for contiguous
2692 * block is denied so reserve big blocks - this is only
2693 * address space not memory ...
2695 if (brk+need >= reserved)
2697 DWORD size = 64*1024*1024;
2699 if (committed && reserved && committed < reserved)
2701 /* Commit last of previous chunk cannot span allocations */
2702 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
2704 committed = reserved;
2706 /* Reserve some (more) space
2707 * Note this is a little sneaky, 1st call passes NULL as reserved
2708 * so lets system choose where we start, subsequent calls pass
2709 * the old end address so ask for a contiguous block
2711 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
2714 reserved = addr+size;
2729 if (brk > committed)
2731 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
2732 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
2747 win32_malloc(size_t size)
2749 return malloc(size);
2753 win32_calloc(size_t numitems, size_t size)
2755 return calloc(numitems,size);
2759 win32_realloc(void *block, size_t size)
2761 return realloc(block,size);
2765 win32_free(void *block)
2772 win32_open_osfhandle(long handle, int flags)
2774 return _open_osfhandle(handle, flags);
2778 win32_get_osfhandle(int fd)
2780 return _get_osfhandle(fd);
2784 win32_dynaload(const char* filename)
2789 WCHAR wfilename[MAX_PATH];
2790 A2WHELPER(filename, wfilename, sizeof(wfilename));
2791 hModule = LoadLibraryExW(wfilename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
2794 hModule = LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
2800 win32_add_host(char *nameId, void *data)
2803 * This must be called before the script is parsed,
2804 * therefore no locking of threads is needed
2807 struct host_link *link;
2808 New(1314, link, 1, struct host_link);
2809 link->host_data = data;
2810 link->nameId = nameId;
2811 link->next = w32_host_link;
2812 w32_host_link = link;
2817 win32_get_host_data(char *nameId)
2820 struct host_link *link = w32_host_link;
2822 if(strEQ(link->nameId, nameId))
2823 return link->host_data;
2837 SV *sv = sv_newmortal();
2838 /* Make one call with zero size - return value is required size */
2839 DWORD len = GetCurrentDirectory((DWORD)0,NULL);
2840 SvUPGRADE(sv,SVt_PV);
2842 SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
2845 * then it worked, set PV valid,
2846 * else leave it 'undef'
2862 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
2863 if (SetCurrentDirectory(SvPV_nolen(ST(0))))
2870 XS(w32_GetNextAvailDrive)
2874 char root[] = "_:\\";
2879 if (GetDriveType(root) == 1) {
2888 XS(w32_GetLastError)
2892 XSRETURN_IV(GetLastError());
2896 XS(w32_SetLastError)
2900 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
2901 SetLastError(SvIV(ST(0)));
2909 char *name = getlogin_buffer;
2910 DWORD size = sizeof(getlogin_buffer);
2912 if (GetUserName(name,&size)) {
2913 /* size includes NULL */
2914 ST(0) = sv_2mortal(newSVpvn(name,size-1));
2924 char name[MAX_COMPUTERNAME_LENGTH+1];
2925 DWORD size = sizeof(name);
2927 if (GetComputerName(name,&size)) {
2928 /* size does NOT include NULL :-( */
2929 ST(0) = sv_2mortal(newSVpvn(name,size));
2940 #ifndef HAS_NETWKSTAGETINFO
2941 /* mingw32 (and Win95) don't have NetWksta*(), so do it the old way */
2943 DWORD size = sizeof(name);
2945 if (GetUserName(name,&size)) {
2947 DWORD sidlen = sizeof(sid);
2949 DWORD dnamelen = sizeof(dname);
2951 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
2952 dname, &dnamelen, &snu)) {
2953 XSRETURN_PV(dname); /* all that for this */
2957 /* this way is more reliable, in case user has a local account.
2958 * XXX need dynamic binding of netapi32.dll symbols or this will fail on
2959 * Win95. Probably makes more sense to move it into libwin32. */
2961 DWORD dnamelen = sizeof(dname);
2962 PWKSTA_INFO_100 pwi;
2964 if (NERR_Success == NetWkstaGetInfo(NULL, 100, (LPBYTE*)&pwi)) {
2965 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
2966 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
2967 -1, (LPSTR)dname, dnamelen, NULL, NULL);
2970 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
2971 -1, (LPSTR)dname, dnamelen, NULL, NULL);
2973 NetApiBufferFree(pwi);
2985 DWORD flags, filecomplen;
2986 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
2987 &flags, fsname, sizeof(fsname))) {
2988 if (GIMME_V == G_ARRAY) {
2989 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
2990 XPUSHs(sv_2mortal(newSViv(flags)));
2991 XPUSHs(sv_2mortal(newSViv(filecomplen)));
2996 XSRETURN_PV(fsname);
3002 XS(w32_GetOSVersion)
3005 OSVERSIONINFO osver;
3007 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
3008 if (GetVersionEx(&osver)) {
3009 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
3010 XPUSHs(newSViv(osver.dwMajorVersion));
3011 XPUSHs(newSViv(osver.dwMinorVersion));
3012 XPUSHs(newSViv(osver.dwBuildNumber));
3013 XPUSHs(newSViv(osver.dwPlatformId));
3025 XSRETURN_IV(IsWinNT());
3033 XSRETURN_IV(IsWin95());
3037 XS(w32_FormatMessage)
3044 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
3046 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
3047 &source, SvIV(ST(0)), 0,
3048 msgbuf, sizeof(msgbuf)-1, NULL))
3049 XSRETURN_PV(msgbuf);
3059 PROCESS_INFORMATION stProcInfo;
3060 STARTUPINFO stStartInfo;
3061 BOOL bSuccess = FALSE;
3064 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
3066 cmd = SvPV_nolen(ST(0));
3067 args = SvPV_nolen(ST(1));
3069 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
3070 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
3071 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
3072 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
3075 cmd, /* Image path */
3076 args, /* Arguments for command line */
3077 NULL, /* Default process security */
3078 NULL, /* Default thread security */
3079 FALSE, /* Must be TRUE to use std handles */
3080 NORMAL_PRIORITY_CLASS, /* No special scheduling */
3081 NULL, /* Inherit our environment block */
3082 NULL, /* Inherit our currrent directory */
3083 &stStartInfo, /* -> Startup info */
3084 &stProcInfo)) /* <- Process info (if OK) */
3086 CloseHandle(stProcInfo.hThread);/* library source code does this. */
3087 sv_setiv(ST(2), stProcInfo.dwProcessId);
3090 XSRETURN_IV(bSuccess);
3094 XS(w32_GetTickCount)
3097 DWORD msec = GetTickCount();
3105 XS(w32_GetShortPathName)
3112 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
3114 shortpath = sv_mortalcopy(ST(0));
3115 SvUPGRADE(shortpath, SVt_PV);
3116 /* src == target is allowed */
3118 len = GetShortPathName(SvPVX(shortpath),
3121 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
3123 SvCUR_set(shortpath,len);
3131 XS(w32_GetFullPathName)
3140 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
3143 fullpath = sv_mortalcopy(filename);
3144 SvUPGRADE(fullpath, SVt_PV);
3146 len = GetFullPathName(SvPVX(filename),
3150 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
3152 if (GIMME_V == G_ARRAY) {
3154 XST_mPV(1,filepart);
3155 len = filepart - SvPVX(fullpath);
3158 SvCUR_set(fullpath,len);
3166 XS(w32_GetLongPathName)
3170 char tmpbuf[MAX_PATH+1];
3175 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
3178 pathstr = SvPV(path,len);
3179 strcpy(tmpbuf, pathstr);
3180 pathstr = win32_longpath(tmpbuf);
3182 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
3193 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
3203 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
3204 if (CopyFile(SvPV_nolen(ST(0)), SvPV_nolen(ST(1)), !SvTRUE(ST(2))))
3210 Perl_init_os_extras(void)
3213 char *file = __FILE__;
3216 w32_perlshell_tokens = Nullch;
3217 w32_perlshell_items = -1;
3218 w32_fdpid = newAV(); /* XXX needs to be in Perl_win32_init()? */
3219 New(1313, w32_children, 1, child_tab);
3220 w32_num_children = 0;
3222 /* these names are Activeware compatible */
3223 newXS("Win32::GetCwd", w32_GetCwd, file);
3224 newXS("Win32::SetCwd", w32_SetCwd, file);
3225 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
3226 newXS("Win32::GetLastError", w32_GetLastError, file);
3227 newXS("Win32::SetLastError", w32_SetLastError, file);
3228 newXS("Win32::LoginName", w32_LoginName, file);
3229 newXS("Win32::NodeName", w32_NodeName, file);
3230 newXS("Win32::DomainName", w32_DomainName, file);
3231 newXS("Win32::FsType", w32_FsType, file);
3232 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
3233 newXS("Win32::IsWinNT", w32_IsWinNT, file);
3234 newXS("Win32::IsWin95", w32_IsWin95, file);
3235 newXS("Win32::FormatMessage", w32_FormatMessage, file);
3236 newXS("Win32::Spawn", w32_Spawn, file);
3237 newXS("Win32::GetTickCount", w32_GetTickCount, file);
3238 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
3239 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
3240 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
3241 newXS("Win32::CopyFile", w32_CopyFile, file);
3242 newXS("Win32::Sleep", w32_Sleep, file);
3244 /* XXX Bloat Alert! The following Activeware preloads really
3245 * ought to be part of Win32::Sys::*, so they're not included
3248 /* LookupAccountName
3250 * InitiateSystemShutdown
3251 * AbortSystemShutdown
3252 * ExpandEnvrironmentStrings
3257 Perl_win32_init(int *argcp, char ***argvp)
3259 /* Disable floating point errors, Perl will trap the ones we
3260 * care about. VC++ RTL defaults to switching these off
3261 * already, but the Borland RTL doesn't. Since we don't
3262 * want to be at the vendor's whim on the default, we set
3263 * it explicitly here.
3265 #if !defined(_ALPHA_) && !defined(__GNUC__)
3266 _control87(MCW_EM, MCW_EM);
3271 #ifdef USE_BINMODE_SCRIPTS
3274 win32_strip_return(SV *sv)
3276 char *s = SvPVX(sv);
3277 char *e = s+SvCUR(sv);
3281 if (*s == '\r' && s[1] == '\n')
3291 SvCUR_set(sv,d-SvPVX(sv));