This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
change#4866 was flawed; revert and add better fix for warning
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745 1/* WIN32.C
2 *
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.
6 *
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.
9 */
0a753a76 10
11#define WIN32_LEAN_AND_MEAN
12#define WIN32IO_IS_STDIO
13#include <tchar.h>
a835ef8a
NIS
14#ifdef __GNUC__
15#define Win32_Winsock
16#endif
0a753a76 17#include <windows.h>
5db10396
GS
18#include <winnt.h>
19#include <io.h>
0a753a76 20
68dc0745 21/* #include "config.h" */
0a753a76 22
23#define PERLIO_NOT_STDIO 0
24#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
25#define PerlIO FILE
26#endif
27
7a9ec5a3 28#include <sys/stat.h>
0a753a76 29#include "EXTERN.h"
30#include "perl.h"
c69f6586
GS
31
32#define NO_XSLOCKS
c5be433b 33#define PERL_NO_GET_CONTEXT
ad2e33dc 34#include "XSUB.h"
c69f6586
GS
35
36#include "Win32iop.h"
0a753a76 37#include <fcntl.h>
5b0d9cbe
NIS
38#ifndef __GNUC__
39/* assert.h conflicts with #define of assert in perl.h */
0a753a76 40#include <assert.h>
5b0d9cbe 41#endif
0a753a76 42#include <string.h>
43#include <stdarg.h>
ad2e33dc 44#include <float.h>
ad0751ec 45#include <time.h>
3730b96e 46#if defined(_MSC_VER) || defined(__MINGW32__)
ad0751ec
GS
47#include <sys/utime.h>
48#else
49#include <utime.h>
50#endif
0a753a76 51
5b0d9cbe
NIS
52#ifdef __GNUC__
53/* Mingw32 defaults to globing command line
54 * So we turn it off like this:
55 */
56int _CRT_glob = 0;
57#endif
58
2b260de0
GS
59#if defined(__MINGW32__)
60# define _stat stat
61#endif
62
63#if defined(__BORLANDC__)
0b94c7bb
GS
64# define _stat stat
65# define _utimbuf utimbuf
66#endif
67
6890e559
GS
68#define EXECF_EXEC 1
69#define EXECF_SPAWN 2
70#define EXECF_SPAWN_NOWAIT 3
71
32e30700
GS
72#if defined(PERL_IMPLICIT_SYS)
73# undef win32_get_privlib
74# define win32_get_privlib g_win32_get_privlib
75# undef win32_get_sitelib
76# define win32_get_sitelib g_win32_get_sitelib
77# undef do_spawn
78# define do_spawn g_do_spawn
79# undef getlogin
80# define getlogin g_getlogin
81#endif
82
c69f6586 83#if defined(PERL_OBJECT)
32e30700
GS
84# undef do_aspawn
85# define do_aspawn g_do_aspawn
86# undef Perl_do_exec
87# define Perl_do_exec g_do_exec
c69f6586
GS
88#endif
89
ce1da67e 90static void get_shell(void);
dff6d3cd 91static long tokenize(const char *str, char **dest, char ***destv);
c5be433b 92 int do_spawn2(char *cmd, int exectype);
e200fe59 93static BOOL has_shell_metachars(char *ptr);
2d7a9237 94static long filetime_to_clock(PFILETIME ft);
ad0751ec 95static BOOL filetime_from_time(PFILETIME ft, time_t t);
c5be433b 96static char * get_emd_part(SV **leading, char *trailing, ...);
0aaad0ff
GS
97static void remove_dead_process(long deceased);
98static long find_pid(int pid);
99static char * qualified_path(const char *cmd);
7766f137
GS
100#ifdef USE_ITHREADS
101static void remove_dead_pseudo_process(long child);
102static long find_pseudo_pid(int pid);
103#endif
c69f6586 104
7766f137 105START_EXTERN_C
2d7a9237 106HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
8ac9c18d 107char w32_module_name[MAX_PATH+1];
7766f137
GS
108END_EXTERN_C
109
4b556e6c 110static DWORD w32_platform = (DWORD)-1;
50892819 111
7766f137
GS
112#define ONE_K_BUFSIZE 1024
113
3fe9a6f1 114int
ba106d47
GS
115IsWin95(void)
116{
0cb96387 117 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
3fe9a6f1 118}
119
120int
ba106d47
GS
121IsWinNT(void)
122{
0cb96387 123 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
3fe9a6f1 124}
0a753a76 125
c5be433b 126/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 127static char*
c5be433b 128get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
349ad1fe
GS
129{
130 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
00dc2f4f
GS
131 HKEY handle;
132 DWORD type;
133 const char *subkey = "Software\\Perl";
349ad1fe 134 char *str = Nullch;
00dc2f4f
GS
135 long retval;
136
137 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
349ad1fe 138 if (retval == ERROR_SUCCESS) {
51371543
GS
139 DWORD datalen;
140 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
ba3eb2af 141 if (retval == ERROR_SUCCESS && type == REG_SZ) {
c5be433b
GS
142 dTHXo;
143 if (!*svp)
144 *svp = sv_2mortal(newSVpvn("",0));
145 SvGROW(*svp, datalen);
51371543 146 retval = RegQueryValueEx(handle, valuename, 0, NULL,
c5be433b 147 (PBYTE)SvPVX(*svp), &datalen);
51371543 148 if (retval == ERROR_SUCCESS) {
c5be433b
GS
149 str = SvPVX(*svp);
150 SvCUR_set(*svp,datalen-1);
51371543 151 }
00dc2f4f
GS
152 }
153 RegCloseKey(handle);
154 }
349ad1fe 155 return str;
00dc2f4f
GS
156}
157
c5be433b 158/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 159static char*
c5be433b 160get_regstr(const char *valuename, SV **svp)
00dc2f4f 161{
c5be433b 162 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
349ad1fe 163 if (!str)
c5be433b 164 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
349ad1fe 165 return str;
00dc2f4f
GS
166}
167
c5be433b 168/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
e5a95ffb 169static char *
c5be433b 170get_emd_part(SV **prev_pathp, char *trailing_path, ...)
00dc2f4f 171{
dc9e4912 172 char base[10];
e5a95ffb 173 va_list ap;
e24c7c18 174 char mod_name[MAX_PATH+1];
00dc2f4f 175 char *ptr;
e5a95ffb
GS
176 char *optr;
177 char *strip;
178 int oldsize, newsize;
273cf8d1 179 STRLEN baselen;
e5a95ffb
GS
180
181 va_start(ap, trailing_path);
182 strip = va_arg(ap, char *);
183
273cf8d1
GS
184 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
185 baselen = strlen(base);
dc9e4912 186
8ac9c18d
GS
187 if (!*w32_module_name) {
188 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
189 ? GetModuleHandle(NULL)
190 : w32_perldll_handle),
191 w32_module_name, sizeof(w32_module_name));
192
193 /* try to get full path to binary (which may be mangled when perl is
194 * run from a 16-bit app) */
bf49b057 195 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
8ac9c18d 196 (void)win32_longpath(w32_module_name);
bf49b057 197 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
8ac9c18d
GS
198
199 /* normalize to forward slashes */
200 ptr = w32_module_name;
201 while (*ptr) {
202 if (*ptr == '\\')
203 *ptr = '/';
204 ++ptr;
205 }
95140b98 206 }
8ac9c18d 207 strcpy(mod_name, w32_module_name);
95140b98 208 ptr = strrchr(mod_name, '/');
e5a95ffb
GS
209 while (ptr && strip) {
210 /* look for directories to skip back */
211 optr = ptr;
00dc2f4f 212 *ptr = '\0';
95140b98 213 ptr = strrchr(mod_name, '/');
1c39adb2
GS
214 /* avoid stripping component if there is no slash,
215 * or it doesn't match ... */
e5a95ffb 216 if (!ptr || stricmp(ptr+1, strip) != 0) {
273cf8d1 217 /* ... but not if component matches m|5\.$patchlevel.*| */
1c39adb2 218 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
273cf8d1
GS
219 && strncmp(strip, base, baselen) == 0
220 && strncmp(ptr+1, base, baselen) == 0))
95140b98
GS
221 {
222 *optr = '/';
80252599
GS
223 ptr = optr;
224 }
00dc2f4f 225 }
e5a95ffb 226 strip = va_arg(ap, char *);
00dc2f4f 227 }
e5a95ffb
GS
228 if (!ptr) {
229 ptr = mod_name;
230 *ptr++ = '.';
95140b98 231 *ptr = '/';
00dc2f4f 232 }
e5a95ffb
GS
233 va_end(ap);
234 strcpy(++ptr, trailing_path);
235
dc9e4912 236 /* only add directory if it exists */
349ad1fe 237 if (GetFileAttributes(mod_name) != (DWORD) -1) {
dc9e4912 238 /* directory exists */
c5be433b
GS
239 dTHXo;
240 if (!*prev_pathp)
241 *prev_pathp = sv_2mortal(newSVpvn("",0));
242 sv_catpvn(*prev_pathp, ";", 1);
243 sv_catpv(*prev_pathp, mod_name);
244 return SvPVX(*prev_pathp);
00dc2f4f 245 }
00dc2f4f 246
cf11f4bf 247 return Nullch;
00dc2f4f
GS
248}
249
250char *
c5be433b 251win32_get_privlib(char *pl)
00dc2f4f 252{
c5be433b 253 dTHXo;
e5a95ffb
GS
254 char *stdlib = "lib";
255 char buffer[MAX_PATH+1];
51371543 256 SV *sv = Nullsv;
00dc2f4f 257
e5a95ffb
GS
258 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
259 sprintf(buffer, "%s-%s", stdlib, pl);
c5be433b
GS
260 if (!get_regstr(buffer, &sv))
261 (void)get_regstr(stdlib, &sv);
00dc2f4f 262
e5a95ffb 263 /* $stdlib .= ";$EMD/../../lib" */
c5be433b 264 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
00dc2f4f
GS
265}
266
68dc0745 267char *
c5be433b 268win32_get_sitelib(char *pl)
00dc2f4f 269{
c5be433b 270 dTHXo;
e5a95ffb
GS
271 char *sitelib = "sitelib";
272 char regstr[40];
e24c7c18 273 char pathstr[MAX_PATH+1];
e5a95ffb 274 DWORD datalen;
e5a95ffb 275 int len, newsize;
51371543
GS
276 SV *sv1 = Nullsv;
277 SV *sv2 = Nullsv;
00dc2f4f
GS
278
279 /* $HKCU{"sitelib-$]"} || $HKLM{"sitelib-$]"} . ---; */
e5a95ffb 280 sprintf(regstr, "%s-%s", sitelib, pl);
c5be433b 281 (void)get_regstr(regstr, &sv1);
e5a95ffb
GS
282
283 /* $sitelib .=
284 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/$]/lib"; */
95140b98 285 sprintf(pathstr, "site/%s/lib", pl);
c5be433b 286 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
00dc2f4f
GS
287
288 /* $HKCU{'sitelib'} || $HKLM{'sitelib'} . ---; */
c5be433b 289 (void)get_regstr(sitelib, &sv2);
00dc2f4f 290
e5a95ffb
GS
291 /* $sitelib .=
292 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/site/lib"; */
c5be433b 293 (void)get_emd_part(&sv2, "site/lib", ARCHNAME, "bin", pl, Nullch);
e5a95ffb 294
51371543
GS
295 if (!sv1 && !sv2)
296 return Nullch;
297 if (!sv1)
298 return SvPVX(sv2);
299 if (!sv2)
300 return SvPVX(sv1);
e5a95ffb 301
349ad1fe
GS
302 sv_catpvn(sv1, ";", 1);
303 sv_catsv(sv1, sv2);
e5a95ffb 304
349ad1fe 305 return SvPVX(sv1);
68dc0745 306}
0a753a76 307
b4793f7f 308
2d7a9237 309static BOOL
e200fe59 310has_shell_metachars(char *ptr)
68dc0745 311{
312 int inquote = 0;
313 char quote = '\0';
314
315 /*
316 * Scan string looking for redirection (< or >) or pipe
e200fe59
JD
317 * characters (|) that are not in a quoted string.
318 * Shell variable interpolation (%VAR%) can also happen inside strings.
68dc0745 319 */
9404a519 320 while (*ptr) {
68dc0745 321 switch(*ptr) {
e200fe59
JD
322 case '%':
323 return TRUE;
68dc0745 324 case '\'':
325 case '\"':
9404a519
GS
326 if (inquote) {
327 if (quote == *ptr) {
68dc0745 328 inquote = 0;
329 quote = '\0';
0a753a76 330 }
68dc0745 331 }
332 else {
333 quote = *ptr;
334 inquote++;
335 }
336 break;
337 case '>':
338 case '<':
339 case '|':
9404a519 340 if (!inquote)
68dc0745 341 return TRUE;
342 default:
343 break;
0a753a76 344 }
68dc0745 345 ++ptr;
346 }
347 return FALSE;
0a753a76 348}
349
32e30700 350#if !defined(PERL_IMPLICIT_SYS)
68dc0745 351/* since the current process environment is being updated in util.c
352 * the library functions will get the correct environment
353 */
354PerlIO *
4f63d024 355Perl_my_popen(pTHX_ char *cmd, char *mode)
0a753a76 356{
357#ifdef FIXCMD
7766f137
GS
358#define fixcmd(x) { \
359 char *pspace = strchr((x),' '); \
360 if (pspace) { \
361 char *p = (x); \
362 while (p < pspace) { \
363 if (*p == '/') \
364 *p = '\\'; \
365 p++; \
366 } \
367 } \
368 }
0a753a76 369#else
370#define fixcmd(x)
371#endif
68dc0745 372 fixcmd(cmd);
45bc9206 373 PERL_FLUSHALL_FOR_CHILD;
0a753a76 374 return win32_popen(cmd, mode);
0a753a76 375}
376
68dc0745 377long
4f63d024 378Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76 379{
380 return win32_pclose(fp);
381}
c69f6586 382#endif
0a753a76 383
0cb96387
GS
384DllExport unsigned long
385win32_os_id(void)
0a753a76 386{
8b10511d 387 static OSVERSIONINFO osver;
0a753a76 388
2d7a9237 389 if (osver.dwPlatformId != w32_platform) {
8b10511d
GS
390 memset(&osver, 0, sizeof(OSVERSIONINFO));
391 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
392 GetVersionEx(&osver);
2d7a9237 393 w32_platform = osver.dwPlatformId;
8b10511d 394 }
0cb96387 395 return (unsigned long)w32_platform;
0a753a76 396}
397
7766f137
GS
398DllExport int
399win32_getpid(void)
400{
401#ifdef USE_ITHREADS
402 dTHXo;
403 if (w32_pseudo_id)
404 return -((int)w32_pseudo_id);
405#endif
406 return _getpid();
407}
408
ce1da67e
GS
409/* Tokenize a string. Words are null-separated, and the list
410 * ends with a doubled null. Any character (except null and
411 * including backslash) may be escaped by preceding it with a
412 * backslash (the backslash will be stripped).
413 * Returns number of words in result buffer.
414 */
415static long
dff6d3cd 416tokenize(const char *str, char **dest, char ***destv)
ce1da67e
GS
417{
418 char *retstart = Nullch;
419 char **retvstart = 0;
420 int items = -1;
421 if (str) {
c5be433b 422 dTHXo;
ce1da67e
GS
423 int slen = strlen(str);
424 register char *ret;
425 register char **retv;
426 New(1307, ret, slen+2, char);
427 New(1308, retv, (slen+3)/2, char*);
428
429 retstart = ret;
430 retvstart = retv;
431 *retv = ret;
432 items = 0;
433 while (*str) {
434 *ret = *str++;
435 if (*ret == '\\' && *str)
436 *ret = *str++;
437 else if (*ret == ' ') {
438 while (*str == ' ')
439 str++;
440 if (ret == retstart)
441 ret--;
442 else {
443 *ret = '\0';
444 ++items;
445 if (*str)
446 *++retv = ret+1;
447 }
448 }
449 else if (!*str)
450 ++items;
451 ret++;
452 }
453 retvstart[items] = Nullch;
454 *ret++ = '\0';
455 *ret = '\0';
456 }
457 *dest = retstart;
458 *destv = retvstart;
459 return items;
460}
461
462static void
2d7a9237 463get_shell(void)
0a753a76 464{
c5be433b 465 dTHXo;
ce1da67e 466 if (!w32_perlshell_tokens) {
174c211a
GS
467 /* we don't use COMSPEC here for two reasons:
468 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
469 * uncontrolled unportability of the ensuing scripts.
470 * 2. PERL5SHELL could be set to a shell that may not be fit for
471 * interactive use (which is what most programs look in COMSPEC
472 * for).
473 */
dff6d3cd
GS
474 const char* defaultshell = (IsWinNT()
475 ? "cmd.exe /x/c" : "command.com /c");
476 const char *usershell = getenv("PERL5SHELL");
ce1da67e
GS
477 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
478 &w32_perlshell_tokens,
479 &w32_perlshell_vec);
68dc0745 480 }
0a753a76 481}
482
68dc0745 483int
c5be433b 484do_aspawn(void *vreally, void **vmark, void **vsp)
0a753a76 485{
c5be433b 486 dTHXo;
2d7a9237
GS
487 SV *really = (SV*)vreally;
488 SV **mark = (SV**)vmark;
489 SV **sp = (SV**)vsp;
68dc0745 490 char **argv;
2d7a9237 491 char *str;
68dc0745 492 int status;
2d7a9237 493 int flag = P_WAIT;
68dc0745 494 int index = 0;
68dc0745 495
2d7a9237
GS
496 if (sp <= mark)
497 return -1;
68dc0745 498
ce1da67e
GS
499 get_shell();
500 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
2d7a9237
GS
501
502 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
503 ++mark;
504 flag = SvIVx(*mark);
68dc0745 505 }
506
9404a519 507 while (++mark <= sp) {
bb897dfc 508 if (*mark && (str = SvPV_nolen(*mark)))
2d7a9237
GS
509 argv[index++] = str;
510 else
511 argv[index++] = "";
68dc0745 512 }
513 argv[index++] = 0;
514
2d7a9237 515 status = win32_spawnvp(flag,
bb897dfc 516 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
517 (const char* const*)argv);
518
80252599 519 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
2d7a9237 520 /* possible shell-builtin, invoke with shell */
ce1da67e
GS
521 int sh_items;
522 sh_items = w32_perlshell_items;
2d7a9237
GS
523 while (--index >= 0)
524 argv[index+sh_items] = argv[index];
ce1da67e
GS
525 while (--sh_items >= 0)
526 argv[sh_items] = w32_perlshell_vec[sh_items];
2d7a9237
GS
527
528 status = win32_spawnvp(flag,
bb897dfc 529 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS
530 (const char* const*)argv);
531 }
68dc0745 532
50892819
GS
533 if (flag != P_NOWAIT) {
534 if (status < 0) {
0453d815
PM
535 dTHR;
536 if (ckWARN(WARN_EXEC))
537 Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno));
50892819
GS
538 status = 255 * 256;
539 }
540 else
541 status *= 256;
b28d0864 542 PL_statusvalue = status;
5aabfad6 543 }
ce1da67e 544 Safefree(argv);
50892819 545 return (status);
68dc0745 546}
547
c69f6586 548int
c5be433b 549do_spawn2(char *cmd, int exectype)
68dc0745 550{
c5be433b 551 dTHXo;
68dc0745 552 char **a;
553 char *s;
554 char **argv;
555 int status = -1;
556 BOOL needToTry = TRUE;
2d7a9237 557 char *cmd2;
68dc0745 558
2d7a9237
GS
559 /* Save an extra exec if possible. See if there are shell
560 * metacharacters in it */
e200fe59 561 if (!has_shell_metachars(cmd)) {
fc36a67e 562 New(1301,argv, strlen(cmd) / 2 + 2, char*);
563 New(1302,cmd2, strlen(cmd) + 1, char);
68dc0745 564 strcpy(cmd2, cmd);
565 a = argv;
566 for (s = cmd2; *s;) {
de030af3 567 while (*s && isSPACE(*s))
68dc0745 568 s++;
569 if (*s)
570 *(a++) = s;
de030af3 571 while (*s && !isSPACE(*s))
68dc0745 572 s++;
9404a519 573 if (*s)
68dc0745 574 *s++ = '\0';
0a753a76 575 }
68dc0745 576 *a = Nullch;
ce1da67e 577 if (argv[0]) {
6890e559
GS
578 switch (exectype) {
579 case EXECF_SPAWN:
580 status = win32_spawnvp(P_WAIT, argv[0],
581 (const char* const*)argv);
582 break;
583 case EXECF_SPAWN_NOWAIT:
584 status = win32_spawnvp(P_NOWAIT, argv[0],
585 (const char* const*)argv);
586 break;
587 case EXECF_EXEC:
588 status = win32_execvp(argv[0], (const char* const*)argv);
589 break;
590 }
2d7a9237 591 if (status != -1 || errno == 0)
68dc0745 592 needToTry = FALSE;
0a753a76 593 }
0a753a76 594 Safefree(argv);
68dc0745 595 Safefree(cmd2);
596 }
2d7a9237 597 if (needToTry) {
ce1da67e
GS
598 char **argv;
599 int i = -1;
600 get_shell();
601 New(1306, argv, w32_perlshell_items + 2, char*);
602 while (++i < w32_perlshell_items)
603 argv[i] = w32_perlshell_vec[i];
2d7a9237
GS
604 argv[i++] = cmd;
605 argv[i] = Nullch;
6890e559
GS
606 switch (exectype) {
607 case EXECF_SPAWN:
608 status = win32_spawnvp(P_WAIT, argv[0],
609 (const char* const*)argv);
610 break;
611 case EXECF_SPAWN_NOWAIT:
612 status = win32_spawnvp(P_NOWAIT, argv[0],
613 (const char* const*)argv);
614 break;
615 case EXECF_EXEC:
616 status = win32_execvp(argv[0], (const char* const*)argv);
617 break;
618 }
ce1da67e
GS
619 cmd = argv[0];
620 Safefree(argv);
68dc0745 621 }
50892819
GS
622 if (exectype != EXECF_SPAWN_NOWAIT) {
623 if (status < 0) {
0453d815
PM
624 dTHR;
625 if (ckWARN(WARN_EXEC))
626 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
50892819
GS
627 (exectype == EXECF_EXEC ? "exec" : "spawn"),
628 cmd, strerror(errno));
629 status = 255 * 256;
630 }
631 else
632 status *= 256;
b28d0864 633 PL_statusvalue = status;
5aabfad6 634 }
50892819 635 return (status);
0a753a76 636}
637
6890e559 638int
c5be433b 639do_spawn(char *cmd)
6890e559 640{
c5be433b 641 return do_spawn2(cmd, EXECF_SPAWN);
6890e559
GS
642}
643
2d7a9237 644int
c5be433b 645do_spawn_nowait(char *cmd)
2d7a9237 646{
c5be433b 647 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
2d7a9237
GS
648}
649
6890e559 650bool
4f63d024 651Perl_do_exec(pTHX_ char *cmd)
6890e559 652{
c5be433b 653 do_spawn2(cmd, EXECF_EXEC);
6890e559
GS
654 return FALSE;
655}
656
68dc0745 657/* The idea here is to read all the directory names into a string table
658 * (separated by nulls) and when one of the other dir functions is called
659 * return the pointer to the current file name.
660 */
c5be433b 661DllExport DIR *
ce2e26e5 662win32_opendir(char *filename)
0a753a76 663{
c5be433b 664 dTHXo;
95136add 665 DIR *dirp;
9404a519
GS
666 long len;
667 long idx;
668 char scanname[MAX_PATH+3];
669 struct stat sbuf;
7fac1903
GS
670 WIN32_FIND_DATAA aFindData;
671 WIN32_FIND_DATAW wFindData;
9404a519 672 HANDLE fh;
7fac1903
GS
673 char buffer[MAX_PATH*2];
674 WCHAR wbuffer[MAX_PATH];
95136add 675 char* ptr;
9404a519
GS
676
677 len = strlen(filename);
678 if (len > MAX_PATH)
679 return NULL;
68dc0745 680
681 /* check to see if filename is a directory */
69d3ab13 682 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
24caa93f 683 return NULL;
68dc0745 684
68dc0745 685 /* Get us a DIR structure */
95136add 686 Newz(1303, dirp, 1, DIR);
68dc0745 687
688 /* Create the search pattern */
689 strcpy(scanname, filename);
23db2e2d
GS
690
691 /* bare drive name means look in cwd for drive */
692 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
693 scanname[len++] = '.';
694 scanname[len++] = '/';
695 }
696 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
9404a519 697 scanname[len++] = '/';
23db2e2d 698 }
9404a519
GS
699 scanname[len++] = '*';
700 scanname[len] = '\0';
68dc0745 701
702 /* do the FindFirstFile call */
7fac1903 703 if (USING_WIDE()) {
0cb96387 704 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
7766f137 705 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
7fac1903
GS
706 }
707 else {
7766f137 708 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
7fac1903 709 }
95136add 710 dirp->handle = fh;
9404a519 711 if (fh == INVALID_HANDLE_VALUE) {
95136add 712 DWORD err = GetLastError();
21e72512 713 /* FindFirstFile() fails on empty drives! */
95136add
GS
714 switch (err) {
715 case ERROR_FILE_NOT_FOUND:
716 return dirp;
717 case ERROR_NO_MORE_FILES:
718 case ERROR_PATH_NOT_FOUND:
719 errno = ENOENT;
720 break;
721 case ERROR_NOT_ENOUGH_MEMORY:
722 errno = ENOMEM;
723 break;
724 default:
725 errno = EINVAL;
726 break;
727 }
728 Safefree(dirp);
68dc0745 729 return NULL;
730 }
731
732 /* now allocate the first part of the string table for
733 * the filenames that we find.
734 */
7fac1903 735 if (USING_WIDE()) {
0cb96387 736 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
7fac1903
GS
737 ptr = buffer;
738 }
739 else {
740 ptr = aFindData.cFileName;
741 }
742 idx = strlen(ptr)+1;
95136add
GS
743 if (idx < 256)
744 dirp->size = 128;
745 else
746 dirp->size = idx;
747 New(1304, dirp->start, dirp->size, char);
748 strcpy(dirp->start, ptr);
749 dirp->nfiles++;
750 dirp->end = dirp->curr = dirp->start;
751 dirp->end += idx;
752 return dirp;
0a753a76 753}
754
755
68dc0745 756/* Readdir just returns the current string pointer and bumps the
757 * string pointer to the nDllExport entry.
758 */
c5be433b 759DllExport struct direct *
ce2e26e5 760win32_readdir(DIR *dirp)
0a753a76 761{
95136add 762 long len;
0a753a76 763
68dc0745 764 if (dirp->curr) {
765 /* first set up the structure to return */
766 len = strlen(dirp->curr);
0f38926b 767 strcpy(dirp->dirstr.d_name, dirp->curr);
68dc0745 768 dirp->dirstr.d_namlen = len;
0a753a76 769
68dc0745 770 /* Fake an inode */
0f38926b 771 dirp->dirstr.d_ino = dirp->curr - dirp->start;
0a753a76 772
95136add 773 /* Now set up for the next call to readdir */
68dc0745 774 dirp->curr += len + 1;
95136add
GS
775 if (dirp->curr >= dirp->end) {
776 dTHXo;
777 char* ptr;
778 BOOL res;
779 WIN32_FIND_DATAW wFindData;
780 WIN32_FIND_DATAA aFindData;
781 char buffer[MAX_PATH*2];
782
783 /* finding the next file that matches the wildcard
784 * (which should be all of them in this directory!).
95136add
GS
785 */
786 if (USING_WIDE()) {
787 res = FindNextFileW(dirp->handle, &wFindData);
788 if (res) {
789 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
790 ptr = buffer;
791 }
792 }
793 else {
794 res = FindNextFileA(dirp->handle, &aFindData);
795 if (res)
796 ptr = aFindData.cFileName;
797 }
798 if (res) {
0f38926b
GS
799 long endpos = dirp->end - dirp->start;
800 long newsize = endpos + strlen(ptr) + 1;
95136add
GS
801 /* bump the string table size by enough for the
802 * new name and it's null terminator */
0f38926b
GS
803 while (newsize > dirp->size) {
804 long curpos = dirp->curr - dirp->start;
95136add
GS
805 dirp->size *= 2;
806 Renew(dirp->start, dirp->size, char);
0f38926b 807 dirp->curr = dirp->start + curpos;
95136add 808 }
0f38926b
GS
809 strcpy(dirp->start + endpos, ptr);
810 dirp->end = dirp->start + newsize;
95136add
GS
811 dirp->nfiles++;
812 }
813 else
814 dirp->curr = NULL;
68dc0745 815 }
68dc0745 816 return &(dirp->dirstr);
817 }
818 else
819 return NULL;
0a753a76 820}
821
68dc0745 822/* Telldir returns the current string pointer position */
c5be433b 823DllExport long
ce2e26e5 824win32_telldir(DIR *dirp)
0a753a76 825{
95136add 826 return (dirp->curr - dirp->start);
0a753a76 827}
828
829
68dc0745 830/* Seekdir moves the string pointer to a previously saved position
95136add 831 * (returned by telldir).
68dc0745 832 */
c5be433b 833DllExport void
ce2e26e5 834win32_seekdir(DIR *dirp, long loc)
0a753a76 835{
95136add 836 dirp->curr = dirp->start + loc;
0a753a76 837}
838
68dc0745 839/* Rewinddir resets the string pointer to the start */
c5be433b 840DllExport void
ce2e26e5 841win32_rewinddir(DIR *dirp)
0a753a76 842{
843 dirp->curr = dirp->start;
844}
845
68dc0745 846/* free the memory allocated by opendir */
c5be433b 847DllExport int
ce2e26e5 848win32_closedir(DIR *dirp)
0a753a76 849{
c5be433b 850 dTHXo;
95136add 851 if (dirp->handle != INVALID_HANDLE_VALUE)
0f38926b 852 FindClose(dirp->handle);
0a753a76 853 Safefree(dirp->start);
854 Safefree(dirp);
68dc0745 855 return 1;
0a753a76 856}
857
858
68dc0745 859/*
860 * various stubs
861 */
0a753a76 862
863
68dc0745 864/* Ownership
865 *
866 * Just pretend that everyone is a superuser. NT will let us know if
867 * we don\'t really have permission to do something.
868 */
0a753a76 869
870#define ROOT_UID ((uid_t)0)
871#define ROOT_GID ((gid_t)0)
872
68dc0745 873uid_t
874getuid(void)
0a753a76 875{
68dc0745 876 return ROOT_UID;
0a753a76 877}
878
68dc0745 879uid_t
880geteuid(void)
0a753a76 881{
68dc0745 882 return ROOT_UID;
0a753a76 883}
884
68dc0745 885gid_t
886getgid(void)
0a753a76 887{
68dc0745 888 return ROOT_GID;
0a753a76 889}
890
68dc0745 891gid_t
892getegid(void)
0a753a76 893{
68dc0745 894 return ROOT_GID;
0a753a76 895}
896
68dc0745 897int
22239a37 898setuid(uid_t auid)
0a753a76 899{
22239a37 900 return (auid == ROOT_UID ? 0 : -1);
0a753a76 901}
902
68dc0745 903int
22239a37 904setgid(gid_t agid)
0a753a76 905{
22239a37 906 return (agid == ROOT_GID ? 0 : -1);
0a753a76 907}
908
e34ffe5a
GS
909char *
910getlogin(void)
911{
c5be433b 912 dTHXo;
3352bfcb
GS
913 char *buf = w32_getlogin_buffer;
914 DWORD size = sizeof(w32_getlogin_buffer);
e34ffe5a
GS
915 if (GetUserName(buf,&size))
916 return buf;
917 return (char*)NULL;
918}
919
b990f8c8
GS
920int
921chown(const char *path, uid_t owner, gid_t group)
922{
923 /* XXX noop */
1c1c7f20 924 return 0;
b990f8c8
GS
925}
926
0aaad0ff
GS
927static long
928find_pid(int pid)
0a753a76 929{
c5be433b 930 dTHXo;
7766f137
GS
931 long child = w32_num_children;
932 while (--child >= 0) {
0aaad0ff
GS
933 if (w32_child_pids[child] == pid)
934 return child;
935 }
936 return -1;
937}
938
939static void
940remove_dead_process(long child)
941{
942 if (child >= 0) {
c5be433b 943 dTHXo;
0aaad0ff
GS
944 CloseHandle(w32_child_handles[child]);
945 Copy(&w32_child_handles[child+1], &w32_child_handles[child],
946 (w32_num_children-child-1), HANDLE);
947 Copy(&w32_child_pids[child+1], &w32_child_pids[child],
948 (w32_num_children-child-1), DWORD);
949 w32_num_children--;
f55ee38a 950 }
f55ee38a
GS
951}
952
7766f137
GS
953#ifdef USE_ITHREADS
954static long
955find_pseudo_pid(int pid)
956{
957 dTHXo;
958 long child = w32_num_pseudo_children;
959 while (--child >= 0) {
960 if (w32_pseudo_child_pids[child] == pid)
961 return child;
962 }
963 return -1;
964}
965
966static void
967remove_dead_pseudo_process(long child)
968{
969 if (child >= 0) {
970 dTHXo;
971 CloseHandle(w32_pseudo_child_handles[child]);
972 Copy(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
973 (w32_num_pseudo_children-child-1), HANDLE);
974 Copy(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
975 (w32_num_pseudo_children-child-1), DWORD);
976 w32_num_pseudo_children--;
977 }
978}
979#endif
980
f55ee38a
GS
981DllExport int
982win32_kill(int pid, int sig)
983{
7766f137 984 dTHXo;
0aaad0ff 985 HANDLE hProcess;
7766f137
GS
986#ifdef USE_ITHREADS
987 if (pid < 0) {
988 /* it is a pseudo-forked child */
989 long child = find_pseudo_pid(-pid);
990 if (child >= 0) {
991 hProcess = w32_pseudo_child_handles[child];
992 if (TerminateThread(hProcess, sig)) {
993 remove_dead_pseudo_process(child);
994 return 0;
995 }
996 }
68dc0745 997 }
7766f137
GS
998 else
999#endif
1000 {
1001 long child = find_pid(pid);
1002 if (child >= 0) {
1003 hProcess = w32_child_handles[child];
1004 if (TerminateProcess(hProcess, sig)) {
1005 remove_dead_process(child);
1006 return 0;
1007 }
1008 }
1009 else {
1010 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
1011 if (hProcess && TerminateProcess(hProcess, sig)) {
1012 CloseHandle(hProcess);
1013 return 0;
1014 }
1015 }
1016 }
1017 errno = EINVAL;
1018 return -1;
0a753a76 1019}
fbbbcc48 1020
68dc0745 1021/*
1022 * File system stuff
1023 */
0a753a76 1024
f3986ebb
GS
1025DllExport unsigned int
1026win32_sleep(unsigned int t)
0a753a76 1027{
68dc0745 1028 Sleep(t*1000);
1029 return 0;
0a753a76 1030}
1031
68dc0745 1032DllExport int
1033win32_stat(const char *path, struct stat *buffer)
0a753a76 1034{
c5be433b 1035 dTHXo;
24caa93f 1036 char t[MAX_PATH+1];
68dc0745 1037 int l = strlen(path);
67fbe06e 1038 int res;
7fac1903 1039 WCHAR wbuffer[MAX_PATH];
6b980173
JD
1040 HANDLE handle;
1041 int nlink = 1;
0a753a76 1042
68dc0745 1043 if (l > 1) {
1044 switch(path[l - 1]) {
e1dbac94
GS
1045 /* FindFirstFile() and stat() are buggy with a trailing
1046 * backslash, so change it to a forward slash :-( */
68dc0745 1047 case '\\':
e1dbac94
GS
1048 strncpy(t, path, l-1);
1049 t[l - 1] = '/';
1050 t[l] = '\0';
1051 path = t;
1052 break;
23db2e2d 1053 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS
1054 case ':':
1055 if (l == 2 && isALPHA(path[0])) {
23db2e2d 1056 t[0] = path[0]; t[1] = ':'; t[2] = '.'; t[3] = '\0';
e1dbac94
GS
1057 l = 3;
1058 path = t;
1059 }
1060 break;
68dc0745 1061 }
1062 }
6b980173
JD
1063
1064 /* We *must* open & close the file once; otherwise file attribute changes */
1065 /* might not yet have propagated to "other" hard links of the same file. */
1066 /* This also gives us an opportunity to determine the number of links. */
7fac1903 1067 if (USING_WIDE()) {
0cb96387 1068 A2WHELPER(path, wbuffer, sizeof(wbuffer));
7766f137 1069 wcscpy(wbuffer, PerlDir_mapW(wbuffer));
6b980173 1070 handle = CreateFileW(wbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
7fac1903
GS
1071 }
1072 else {
7766f137 1073 path = PerlDir_mapA(path);
6b980173
JD
1074 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1075 }
1076 if (handle != INVALID_HANDLE_VALUE) {
1077 BY_HANDLE_FILE_INFORMATION bhi;
1078 if (GetFileInformationByHandle(handle, &bhi))
1079 nlink = bhi.nNumberOfLinks;
1080 CloseHandle(handle);
7fac1903 1081 }
6b980173 1082
7766f137
GS
1083 /* wbuffer or path will be mapped correctly above */
1084 if (USING_WIDE()) {
6b980173 1085 res = _wstat(wbuffer, (struct _stat *)buffer);
7766f137
GS
1086 }
1087 else {
6b980173 1088 res = stat(path, buffer);
7766f137 1089 }
6b980173
JD
1090 buffer->st_nlink = nlink;
1091
24caa93f
GS
1092 if (res < 0) {
1093 /* CRT is buggy on sharenames, so make sure it really isn't.
1094 * XXX using GetFileAttributesEx() will enable us to set
1095 * buffer->st_*time (but note that's not available on the
1096 * Windows of 1995) */
7fac1903
GS
1097 DWORD r;
1098 if (USING_WIDE()) {
1099 r = GetFileAttributesW(wbuffer);
1100 }
1101 else {
1102 r = GetFileAttributesA(path);
1103 }
24caa93f 1104 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
e1dbac94
GS
1105 /* buffer may still contain old garbage since stat() failed */
1106 Zero(buffer, 1, struct stat);
1107 buffer->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS
1108 errno = 0;
1109 if (!(r & FILE_ATTRIBUTE_READONLY))
1110 buffer->st_mode |= S_IWRITE | S_IEXEC;
1111 return 0;
1112 }
1113 }
24caa93f 1114 else {
e1dbac94
GS
1115 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1116 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB
1117 {
1118 /* The drive can be inaccessible, some _stat()s are buggy */
7fac1903
GS
1119 if (USING_WIDE()
1120 ? !GetVolumeInformationW(wbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1121 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB
1122 errno = ENOENT;
1123 return -1;
1124 }
1125 }
1126#ifdef __BORLANDC__
67fbe06e
GS
1127 if (S_ISDIR(buffer->st_mode))
1128 buffer->st_mode |= S_IWRITE | S_IEXEC;
1129 else if (S_ISREG(buffer->st_mode)) {
1130 if (l >= 4 && path[l-4] == '.') {
1131 const char *e = path + l - 3;
1132 if (strnicmp(e,"exe",3)
1133 && strnicmp(e,"bat",3)
1134 && strnicmp(e,"com",3)
1135 && (IsWin95() || strnicmp(e,"cmd",3)))
1136 buffer->st_mode &= ~S_IEXEC;
1137 else
1138 buffer->st_mode |= S_IEXEC;
1139 }
1140 else
1141 buffer->st_mode &= ~S_IEXEC;
1142 }
67fbe06e 1143#endif
2293b0e9 1144 }
67fbe06e 1145 return res;
0a753a76 1146}
1147
8ac9c18d
GS
1148/* Find the longname of a given path. path is destructively modified.
1149 * It should have space for at least MAX_PATH characters. */
1150DllExport char *
1151win32_longpath(char *path)
1152{
1153 WIN32_FIND_DATA fdata;
1154 HANDLE fhand;
1155 char tmpbuf[MAX_PATH+1];
1156 char *tmpstart = tmpbuf;
1157 char *start = path;
1158 char sep;
1159 if (!path)
1160 return Nullch;
1161
1162 /* drive prefix */
1163 if (isALPHA(path[0]) && path[1] == ':' &&
1164 (path[2] == '/' || path[2] == '\\'))
1165 {
1166 start = path + 2;
1167 *tmpstart++ = path[0];
1168 *tmpstart++ = ':';
1169 }
1170 /* UNC prefix */
1171 else if ((path[0] == '/' || path[0] == '\\') &&
1172 (path[1] == '/' || path[1] == '\\'))
1173 {
1174 start = path + 2;
52fcf7ee
GS
1175 *tmpstart++ = path[0];
1176 *tmpstart++ = path[1];
8ac9c18d
GS
1177 /* copy machine name */
1178 while (*start && *start != '/' && *start != '\\')
1179 *tmpstart++ = *start++;
1180 if (*start) {
52fcf7ee 1181 *tmpstart++ = *start;
8ac9c18d
GS
1182 start++;
1183 /* copy share name */
1184 while (*start && *start != '/' && *start != '\\')
1185 *tmpstart++ = *start++;
1186 }
1187 }
1188 sep = *start++;
1189 if (sep == '/' || sep == '\\')
52fcf7ee 1190 *tmpstart++ = sep;
8ac9c18d
GS
1191 *tmpstart = '\0';
1192 while (sep) {
1193 /* walk up to slash */
1194 while (*start && *start != '/' && *start != '\\')
1195 ++start;
1196
1197 /* discard doubled slashes */
1198 while (*start && (start[1] == '/' || start[1] == '\\'))
1199 ++start;
1200 sep = *start;
1201
1202 /* stop and find full name of component */
1203 *start = '\0';
1204 fhand = FindFirstFile(path,&fdata);
1205 if (fhand != INVALID_HANDLE_VALUE) {
1206 strcpy(tmpstart, fdata.cFileName);
1207 tmpstart += strlen(fdata.cFileName);
1208 if (sep)
52fcf7ee 1209 *tmpstart++ = sep;
8ac9c18d
GS
1210 *tmpstart = '\0';
1211 *start++ = sep;
1212 FindClose(fhand);
1213 }
1214 else {
1215 /* failed a step, just return without side effects */
bf49b057 1216 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
8ac9c18d
GS
1217 *start = sep;
1218 return Nullch;
1219 }
1220 }
1221 strcpy(path,tmpbuf);
1222 return path;
1223}
1224
0551aaa8
GS
1225#ifndef USE_WIN32_RTL_ENV
1226
1227DllExport char *
1228win32_getenv(const char *name)
1229{
c5be433b 1230 dTHXo;
7fac1903 1231 WCHAR wBuffer[MAX_PATH];
0551aaa8 1232 DWORD needlen;
51371543 1233 SV *curitem = Nullsv;
58a50f62 1234
7fac1903 1235 if (USING_WIDE()) {
0cb96387 1236 A2WHELPER(name, wBuffer, sizeof(wBuffer));
51371543 1237 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
7fac1903
GS
1238 }
1239 else
51371543 1240 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1241 if (needlen != 0) {
51371543 1242 curitem = sv_2mortal(newSVpvn("", 0));
7fac1903 1243 if (USING_WIDE()) {
51371543
GS
1244 SV *acuritem;
1245 do {
1246 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1247 needlen = GetEnvironmentVariableW(wBuffer,
1248 (WCHAR*)SvPVX(curitem),
1249 needlen);
1250 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
c5be433b 1251 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
51371543
GS
1252 acuritem = sv_2mortal(newSVsv(curitem));
1253 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
7fac1903
GS
1254 }
1255 else {
51371543
GS
1256 do {
1257 SvGROW(curitem, needlen+1);
1258 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1259 needlen);
1260 } while (needlen >= SvLEN(curitem));
1261 SvCUR_set(curitem, needlen);
58a50f62 1262 }
0551aaa8 1263 }
c934e9d4 1264 else {
7a5f8e82 1265 /* allow any environment variables that begin with 'PERL'
c934e9d4 1266 to be stored in the registry */
51371543 1267 if (strncmp(name, "PERL", 4) == 0)
c5be433b 1268 (void)get_regstr(name, &curitem);
c69f6586 1269 }
51371543
GS
1270 if (curitem && SvCUR(curitem))
1271 return SvPVX(curitem);
58a50f62 1272
51371543 1273 return Nullch;
0551aaa8
GS
1274}
1275
ac5c734f
GS
1276DllExport int
1277win32_putenv(const char *name)
1278{
c5be433b 1279 dTHXo;
ac5c734f
GS
1280 char* curitem;
1281 char* val;
7fac1903
GS
1282 WCHAR* wCuritem;
1283 WCHAR* wVal;
1284 int length, relval = -1;
51371543 1285
73c4f7a1 1286 if (name) {
7fac1903
GS
1287 if (USING_WIDE()) {
1288 length = strlen(name)+1;
1289 New(1309,wCuritem,length,WCHAR);
c5be433b 1290 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
7fac1903 1291 wVal = wcschr(wCuritem, '=');
7766f137 1292 if (wVal) {
7fac1903 1293 *wVal++ = '\0';
7766f137 1294 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
7fac1903
GS
1295 relval = 0;
1296 }
1297 Safefree(wCuritem);
1298 }
1299 else {
1300 New(1309,curitem,strlen(name)+1,char);
1301 strcpy(curitem, name);
1302 val = strchr(curitem, '=');
7766f137 1303 if (val) {
7fac1903
GS
1304 /* The sane way to deal with the environment.
1305 * Has these advantages over putenv() & co.:
1306 * * enables us to store a truly empty value in the
1307 * environment (like in UNIX).
1308 * * we don't have to deal with RTL globals, bugs and leaks.
1309 * * Much faster.
1310 * Why you may want to enable USE_WIN32_RTL_ENV:
1311 * * environ[] and RTL functions will not reflect changes,
1312 * which might be an issue if extensions want to access
1313 * the env. via RTL. This cuts both ways, since RTL will
1314 * not see changes made by extensions that call the Win32
1315 * functions directly, either.
1316 * GSAR 97-06-07
1317 */
1318 *val++ = '\0';
7766f137 1319 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
7fac1903
GS
1320 relval = 0;
1321 }
1322 Safefree(curitem);
ac5c734f 1323 }
ac5c734f
GS
1324 }
1325 return relval;
1326}
1327
0551aaa8
GS
1328#endif
1329
d55594ae 1330static long
2d7a9237 1331filetime_to_clock(PFILETIME ft)
d55594ae 1332{
7766f137
GS
1333 __int64 qw = ft->dwHighDateTime;
1334 qw <<= 32;
1335 qw |= ft->dwLowDateTime;
1336 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1337 return (long) qw;
d55594ae
GS
1338}
1339
f3986ebb
GS
1340DllExport int
1341win32_times(struct tms *timebuf)
0a753a76 1342{
d55594ae
GS
1343 FILETIME user;
1344 FILETIME kernel;
1345 FILETIME dummy;
1346 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1347 &kernel,&user)) {
2d7a9237
GS
1348 timebuf->tms_utime = filetime_to_clock(&user);
1349 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS
1350 timebuf->tms_cutime = 0;
1351 timebuf->tms_cstime = 0;
1352
1353 } else {
1354 /* That failed - e.g. Win95 fallback to clock() */
1355 clock_t t = clock();
1356 timebuf->tms_utime = t;
1357 timebuf->tms_stime = 0;
1358 timebuf->tms_cutime = 0;
1359 timebuf->tms_cstime = 0;
1360 }
68dc0745 1361 return 0;
0a753a76 1362}
1363
9c51cf4c 1364/* fix utime() so it works on directories in NT */
ad0751ec
GS
1365static BOOL
1366filetime_from_time(PFILETIME pFileTime, time_t Time)
1367{
9c51cf4c 1368 struct tm *pTM = localtime(&Time);
ad0751ec 1369 SYSTEMTIME SystemTime;
9c51cf4c 1370 FILETIME LocalTime;
ad0751ec
GS
1371
1372 if (pTM == NULL)
1373 return FALSE;
1374
1375 SystemTime.wYear = pTM->tm_year + 1900;
1376 SystemTime.wMonth = pTM->tm_mon + 1;
1377 SystemTime.wDay = pTM->tm_mday;
1378 SystemTime.wHour = pTM->tm_hour;
1379 SystemTime.wMinute = pTM->tm_min;
1380 SystemTime.wSecond = pTM->tm_sec;
1381 SystemTime.wMilliseconds = 0;
1382
9c51cf4c
GS
1383 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1384 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS
1385}
1386
1387DllExport int
7766f137
GS
1388win32_unlink(const char *filename)
1389{
1390 dTHXo;
1391 int ret;
1392 DWORD attrs;
1393
1394 if (USING_WIDE()) {
1395 WCHAR wBuffer[MAX_PATH];
1396
1397 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1398 wcscpy(wBuffer, PerlDir_mapW(wBuffer));
1399 attrs = GetFileAttributesW(wBuffer);
1400 if (attrs & FILE_ATTRIBUTE_READONLY) {
1401 (void)SetFileAttributesW(wBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1402 ret = _wunlink(wBuffer);
1403 if (ret == -1)
1404 (void)SetFileAttributesW(wBuffer, attrs);
1405 }
1406 else
1407 ret = _wunlink(wBuffer);
1408 }
1409 else {
1410 filename = PerlDir_mapA(filename);
1411 attrs = GetFileAttributesA(filename);
1412 if (attrs & FILE_ATTRIBUTE_READONLY) {
1413 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1414 ret = unlink(filename);
1415 if (ret == -1)
1416 (void)SetFileAttributesA(filename, attrs);
1417 }
1418 else
1419 ret = unlink(filename);
1420 }
1421 return ret;
1422}
1423
1424DllExport int
3b405fc5 1425win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1426{
c5be433b 1427 dTHXo;
ad0751ec
GS
1428 HANDLE handle;
1429 FILETIME ftCreate;
1430 FILETIME ftAccess;
1431 FILETIME ftWrite;
1432 struct utimbuf TimeBuffer;
7fac1903 1433 WCHAR wbuffer[MAX_PATH];
ad0751ec 1434
7fac1903
GS
1435 int rc;
1436 if (USING_WIDE()) {
0cb96387 1437 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
7766f137 1438 wcscpy(wbuffer, PerlDir_mapW(wbuffer));
7fac1903
GS
1439 rc = _wutime(wbuffer, (struct _utimbuf*)times);
1440 }
1441 else {
7766f137 1442 filename = PerlDir_mapA(filename);
7fac1903
GS
1443 rc = utime(filename, times);
1444 }
ad0751ec
GS
1445 /* EACCES: path specifies directory or readonly file */
1446 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1447 return rc;
1448
1449 if (times == NULL) {
1450 times = &TimeBuffer;
1451 time(&times->actime);
1452 times->modtime = times->actime;
1453 }
1454
1455 /* This will (and should) still fail on readonly files */
7fac1903
GS
1456 if (USING_WIDE()) {
1457 handle = CreateFileW(wbuffer, GENERIC_READ | GENERIC_WRITE,
1458 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1459 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1460 }
1461 else {
1462 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1463 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1464 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1465 }
ad0751ec
GS
1466 if (handle == INVALID_HANDLE_VALUE)
1467 return rc;
1468
1469 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1470 filetime_from_time(&ftAccess, times->actime) &&
1471 filetime_from_time(&ftWrite, times->modtime) &&
1472 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1473 {
1474 rc = 0;
1475 }
1476
1477 CloseHandle(handle);
1478 return rc;
1479}
1480
2d7a9237 1481DllExport int
b2af26b1
GS
1482win32_uname(struct utsname *name)
1483{
1484 struct hostent *hep;
1485 STRLEN nodemax = sizeof(name->nodename)-1;
1486 OSVERSIONINFO osver;
1487
1488 memset(&osver, 0, sizeof(OSVERSIONINFO));
1489 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1490 if (GetVersionEx(&osver)) {
1491 /* sysname */
1492 switch (osver.dwPlatformId) {
1493 case VER_PLATFORM_WIN32_WINDOWS:
1494 strcpy(name->sysname, "Windows");
1495 break;
1496 case VER_PLATFORM_WIN32_NT:
1497 strcpy(name->sysname, "Windows NT");
1498 break;
1499 case VER_PLATFORM_WIN32s:
1500 strcpy(name->sysname, "Win32s");
1501 break;
1502 default:
1503 strcpy(name->sysname, "Win32 Unknown");
1504 break;
1505 }
1506
cf6cacac
GS
1507 /* release */
1508 sprintf(name->release, "%d.%d",
b2af26b1
GS
1509 osver.dwMajorVersion, osver.dwMinorVersion);
1510
cf6cacac
GS
1511 /* version */
1512 sprintf(name->version, "Build %d",
b2af26b1
GS
1513 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1514 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1515 if (osver.szCSDVersion[0]) {
cf6cacac 1516 char *buf = name->version + strlen(name->version);
b2af26b1
GS
1517 sprintf(buf, " (%s)", osver.szCSDVersion);
1518 }
1519 }
1520 else {
1521 *name->sysname = '\0';
1522 *name->version = '\0';
1523 *name->release = '\0';
1524 }
1525
1526 /* nodename */
1527 hep = win32_gethostbyname("localhost");
1528 if (hep) {
1529 STRLEN len = strlen(hep->h_name);
1530 if (len <= nodemax) {
1531 strcpy(name->nodename, hep->h_name);
1532 }
1533 else {
1534 strncpy(name->nodename, hep->h_name, nodemax);
1535 name->nodename[nodemax] = '\0';
1536 }
1537 }
1538 else {
1539 DWORD sz = nodemax;
1540 if (!GetComputerName(name->nodename, &sz))
1541 *name->nodename = '\0';
1542 }
1543
1544 /* machine (architecture) */
1545 {
1546 SYSTEM_INFO info;
1547 char *arch;
1548 GetSystemInfo(&info);
a6c40364 1549
2d63fa08 1550#if defined(__BORLANDC__) || defined(__MINGW32__)
a6c40364
GS
1551 switch (info.u.s.wProcessorArchitecture) {
1552#else
b2af26b1 1553 switch (info.wProcessorArchitecture) {
a6c40364 1554#endif
b2af26b1
GS
1555 case PROCESSOR_ARCHITECTURE_INTEL:
1556 arch = "x86"; break;
1557 case PROCESSOR_ARCHITECTURE_MIPS:
1558 arch = "mips"; break;
1559 case PROCESSOR_ARCHITECTURE_ALPHA:
1560 arch = "alpha"; break;
1561 case PROCESSOR_ARCHITECTURE_PPC:
1562 arch = "ppc"; break;
1563 default:
1564 arch = "unknown"; break;
1565 }
1566 strcpy(name->machine, arch);
1567 }
1568 return 0;
1569}
1570
1571DllExport int
f55ee38a
GS
1572win32_waitpid(int pid, int *status, int flags)
1573{
c5be433b 1574 dTHXo;
0aaad0ff 1575 int retval = -1;
7766f137 1576 if (pid == -1) /* XXX threadid == 1 ? */
0aaad0ff 1577 return win32_wait(status);
7766f137
GS
1578#ifdef USE_ITHREADS
1579 else if (pid < 0) {
1580 long child = find_pseudo_pid(-pid);
1581 if (child >= 0) {
1582 HANDLE hThread = w32_pseudo_child_handles[child];
1583 DWORD waitcode = WaitForSingleObject(hThread, INFINITE);
1584 if (waitcode != WAIT_FAILED) {
1585 if (GetExitCodeThread(hThread, &waitcode)) {
1586 *status = (int)((waitcode & 0xff) << 8);
1587 retval = (int)w32_pseudo_child_pids[child];
1588 remove_dead_pseudo_process(child);
1589 return retval;
1590 }
1591 }
1592 else
1593 errno = ECHILD;
1594 }
1595 }
1596#endif
f55ee38a 1597 else {
0aaad0ff
GS
1598 long child = find_pid(pid);
1599 if (child >= 0) {
1600 HANDLE hProcess = w32_child_handles[child];
1601 DWORD waitcode = WaitForSingleObject(hProcess, INFINITE);
1602 if (waitcode != WAIT_FAILED) {
1603 if (GetExitCodeProcess(hProcess, &waitcode)) {
1604 *status = (int)((waitcode & 0xff) << 8);
1605 retval = (int)w32_child_pids[child];
1606 remove_dead_process(child);
1607 return retval;
1608 }
1609 }
1610 else
1611 errno = ECHILD;
1612 }
1613 else {
1614 retval = cwait(status, pid, WAIT_CHILD);
1615 /* cwait() returns "correctly" on Borland */
8f1e745d 1616#ifndef __BORLANDC__
0aaad0ff
GS
1617 if (status)
1618 *status *= 256;
f55ee38a 1619#endif
0aaad0ff 1620 }
f55ee38a 1621 }
0aaad0ff 1622 return retval >= 0 ? pid : retval;
f55ee38a
GS
1623}
1624
1625DllExport int
2d7a9237
GS
1626win32_wait(int *status)
1627{
2d7a9237
GS
1628 /* XXX this wait emulation only knows about processes
1629 * spawned via win32_spawnvp(P_NOWAIT, ...).
1630 */
c5be433b 1631 dTHXo;
2d7a9237
GS
1632 int i, retval;
1633 DWORD exitcode, waitcode;
1634
7766f137
GS
1635#ifdef USE_ITHREADS
1636 if (w32_num_pseudo_children) {
1637 waitcode = WaitForMultipleObjects(w32_num_pseudo_children,
1638 w32_pseudo_child_handles,
1639 FALSE,
1640 INFINITE);
1641 if (waitcode != WAIT_FAILED) {
1642 if (waitcode >= WAIT_ABANDONED_0
1643 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1644 i = waitcode - WAIT_ABANDONED_0;
1645 else
1646 i = waitcode - WAIT_OBJECT_0;
1647 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1648 *status = (int)((exitcode & 0xff) << 8);
1649 retval = (int)w32_pseudo_child_pids[i];
1650 remove_dead_pseudo_process(i);
1651 return retval;
1652 }
1653 }
1654 }
1655#endif
1656
2d7a9237
GS
1657 if (!w32_num_children) {
1658 errno = ECHILD;
1659 return -1;
1660 }
1661
1662 /* if a child exists, wait for it to die */
1663 waitcode = WaitForMultipleObjects(w32_num_children,
0aaad0ff 1664 w32_child_handles,
2d7a9237
GS
1665 FALSE,
1666 INFINITE);
1667 if (waitcode != WAIT_FAILED) {
1668 if (waitcode >= WAIT_ABANDONED_0
1669 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1670 i = waitcode - WAIT_ABANDONED_0;
1671 else
1672 i = waitcode - WAIT_OBJECT_0;
0aaad0ff 1673 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2d7a9237
GS
1674 *status = (int)((exitcode & 0xff) << 8);
1675 retval = (int)w32_child_pids[i];
0aaad0ff 1676 remove_dead_process(i);
2d7a9237
GS
1677 return retval;
1678 }
1679 }
1680
1681FAILED:
1682 errno = GetLastError();
1683 return -1;
2d7a9237 1684}
d55594ae 1685
2d7a9237 1686static UINT timerid = 0;
d55594ae
GS
1687
1688static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
1689{
c5be433b 1690 dTHXo;
0cb96387
GS
1691 KillTimer(NULL,timerid);
1692 timerid=0;
1693 sighandler(14);
d55594ae
GS
1694}
1695
f3986ebb
GS
1696DllExport unsigned int
1697win32_alarm(unsigned int sec)
0a753a76 1698{
d55594ae
GS
1699 /*
1700 * the 'obvious' implentation is SetTimer() with a callback
1701 * which does whatever receiving SIGALRM would do
1702 * we cannot use SIGALRM even via raise() as it is not
1703 * one of the supported codes in <signal.h>
1704 *
1705 * Snag is unless something is looking at the message queue
1706 * nothing happens :-(
1707 */
c5be433b 1708 dTHXo;
d55594ae
GS
1709 if (sec)
1710 {
1711 timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
1712 if (!timerid)
4f63d024 1713 Perl_croak_nocontext("Cannot set timer");
d55594ae
GS
1714 }
1715 else
1716 {
1717 if (timerid)
1718 {
1719 KillTimer(NULL,timerid);
1720 timerid=0;
1721 }
1722 }
68dc0745 1723 return 0;
0a753a76 1724}
1725
26618a56 1726#ifdef HAVE_DES_FCRYPT
2d77217b 1727extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
ff95b63e 1728#endif
26618a56
GS
1729
1730DllExport char *
1731win32_crypt(const char *txt, const char *salt)
1732{
0b94c7bb 1733 dTHXo;
ff95b63e 1734#ifdef HAVE_DES_FCRYPT
26618a56 1735 dTHR;
3352bfcb 1736 return des_fcrypt(txt, salt, w32_crypt_buffer);
ff95b63e 1737#else
25dbdbbc 1738 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
b8957cf1 1739 return Nullch;
ff95b63e 1740#endif
26618a56 1741}
26618a56 1742
f3986ebb 1743#ifdef USE_FIXED_OSFHANDLE
390b85e7
GS
1744
1745EXTERN_C int __cdecl _alloc_osfhnd(void);
1746EXTERN_C int __cdecl _set_osfhnd(int fh, long value);
1747EXTERN_C void __cdecl _lock_fhandle(int);
1748EXTERN_C void __cdecl _unlock_fhandle(int);
1749EXTERN_C void __cdecl _unlock(int);
1750
1751#if (_MSC_VER >= 1000)
1752typedef struct {
1753 long osfhnd; /* underlying OS file HANDLE */
1754 char osfile; /* attributes of file (e.g., open in text mode?) */
1755 char pipech; /* one char buffer for handles opened on pipes */
1756#if defined (_MT) && !defined (DLL_FOR_WIN32S)
1757 int lockinitflag;
1758 CRITICAL_SECTION lock;
1759#endif /* defined (_MT) && !defined (DLL_FOR_WIN32S) */
1760} ioinfo;
1761
1762EXTERN_C ioinfo * __pioinfo[];
1763
1764#define IOINFO_L2E 5
1765#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
1766#define _pioinfo(i) (__pioinfo[i >> IOINFO_L2E] + (i & (IOINFO_ARRAY_ELTS - 1)))
1767#define _osfile(i) (_pioinfo(i)->osfile)
1768
1769#else /* (_MSC_VER >= 1000) */
1770extern char _osfile[];
1771#endif /* (_MSC_VER >= 1000) */
1772
1773#define FOPEN 0x01 /* file handle open */
1774#define FAPPEND 0x20 /* file handle opened O_APPEND */
1775#define FDEV 0x40 /* file handle refers to device */
1776#define FTEXT 0x80 /* file handle is in text mode */
1777
1778#define _STREAM_LOCKS 26 /* Table of stream locks */
1779#define _LAST_STREAM_LOCK (_STREAM_LOCKS+_NSTREAM_-1) /* Last stream lock */
1780#define _FH_LOCKS (_LAST_STREAM_LOCK+1) /* Table of fh locks */
1781
1782/***
1783*int my_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
1784*
1785*Purpose:
1786* This function allocates a free C Runtime file handle and associates
1787* it with the Win32 HANDLE specified by the first parameter. This is a
1788* temperary fix for WIN95's brain damage GetFileType() error on socket
1789* we just bypass that call for socket
1790*
1791*Entry:
1792* long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
1793* int flags - flags to associate with C Runtime file handle.
1794*
1795*Exit:
1796* returns index of entry in fh, if successful
1797* return -1, if no free entry is found
1798*
1799*Exceptions:
1800*
1801*******************************************************************************/
1802
1803static int
1804my_open_osfhandle(long osfhandle, int flags)
1805{
1806 int fh;
1807 char fileflags; /* _osfile flags */
1808
1809 /* copy relevant flags from second parameter */
1810 fileflags = FDEV;
1811
9404a519 1812 if (flags & O_APPEND)
390b85e7
GS
1813 fileflags |= FAPPEND;
1814
9404a519 1815 if (flags & O_TEXT)
390b85e7
GS
1816 fileflags |= FTEXT;
1817
1818 /* attempt to allocate a C Runtime file handle */
9404a519 1819 if ((fh = _alloc_osfhnd()) == -1) {
390b85e7
GS
1820 errno = EMFILE; /* too many open files */
1821 _doserrno = 0L; /* not an OS error */
1822 return -1; /* return error to caller */
1823 }
1824
1825 /* the file is open. now, set the info in _osfhnd array */
1826 _set_osfhnd(fh, osfhandle);
1827
1828 fileflags |= FOPEN; /* mark as open */
1829
1830#if (_MSC_VER >= 1000)
1831 _osfile(fh) = fileflags; /* set osfile entry */
1832 _unlock_fhandle(fh);
1833#else
1834 _osfile[fh] = fileflags; /* set osfile entry */
1835 _unlock(fh+_FH_LOCKS); /* unlock handle */
1836#endif
1837
1838 return fh; /* return handle */
1839}
1840
1841#define _open_osfhandle my_open_osfhandle
f3986ebb 1842#endif /* USE_FIXED_OSFHANDLE */
390b85e7
GS
1843
1844/* simulate flock by locking a range on the file */
1845
1846#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
1847#define LK_LEN 0xffff0000
1848
f3986ebb
GS
1849DllExport int
1850win32_flock(int fd, int oper)
390b85e7
GS
1851{
1852 OVERLAPPED o;
1853 int i = -1;
1854 HANDLE fh;
1855
f3986ebb 1856 if (!IsWinNT()) {
c5be433b 1857 dTHXo;
4f63d024 1858 Perl_croak_nocontext("flock() unimplemented on this platform");
f3986ebb
GS
1859 return -1;
1860 }
390b85e7
GS
1861 fh = (HANDLE)_get_osfhandle(fd);
1862 memset(&o, 0, sizeof(o));
1863
1864 switch(oper) {
1865 case LOCK_SH: /* shared lock */
1866 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
1867 break;
1868 case LOCK_EX: /* exclusive lock */
1869 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
1870 break;
1871 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
1872 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
1873 break;
1874 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
1875 LK_ERR(LockFileEx(fh,
1876 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
1877 0, LK_LEN, 0, &o),i);
1878 break;
1879 case LOCK_UN: /* unlock lock */
1880 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
1881 break;
1882 default: /* unknown */
1883 errno = EINVAL;
1884 break;
1885 }
1886 return i;
1887}
1888
1889#undef LK_ERR
1890#undef LK_LEN
1891
68dc0745 1892/*
1893 * redirected io subsystem for all XS modules
1894 *
1895 */
0a753a76 1896
68dc0745 1897DllExport int *
1898win32_errno(void)
0a753a76 1899{
390b85e7 1900 return (&errno);
0a753a76 1901}
1902
dcb2879a
GS
1903DllExport char ***
1904win32_environ(void)
1905{
390b85e7 1906 return (&(_environ));
dcb2879a
GS
1907}
1908
68dc0745 1909/* the rest are the remapped stdio routines */
1910DllExport FILE *
1911win32_stderr(void)
0a753a76 1912{
390b85e7 1913 return (stderr);
0a753a76 1914}
1915
68dc0745 1916DllExport FILE *
1917win32_stdin(void)
0a753a76 1918{
390b85e7 1919 return (stdin);
0a753a76 1920}
1921
68dc0745 1922DllExport FILE *
1923win32_stdout()
0a753a76 1924{
390b85e7 1925 return (stdout);
0a753a76 1926}
1927
68dc0745 1928DllExport int
1929win32_ferror(FILE *fp)
0a753a76 1930{
390b85e7 1931 return (ferror(fp));
0a753a76 1932}
1933
1934
68dc0745 1935DllExport int
1936win32_feof(FILE *fp)
0a753a76 1937{
390b85e7 1938 return (feof(fp));
0a753a76 1939}
1940
68dc0745 1941/*
1942 * Since the errors returned by the socket error function
1943 * WSAGetLastError() are not known by the library routine strerror
1944 * we have to roll our own.
1945 */
0a753a76 1946
68dc0745 1947DllExport char *
1948win32_strerror(int e)
0a753a76 1949{
3e3baf6d 1950#ifndef __BORLANDC__ /* Borland intolerance */
68dc0745 1951 extern int sys_nerr;
3e3baf6d 1952#endif
68dc0745 1953 DWORD source = 0;
0a753a76 1954
9404a519 1955 if (e < 0 || e > sys_nerr) {
c5be433b 1956 dTHXo;
9404a519 1957 if (e < 0)
68dc0745 1958 e = GetLastError();
0a753a76 1959
9404a519 1960 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
3352bfcb
GS
1961 w32_strerror_buffer,
1962 sizeof(w32_strerror_buffer), NULL) == 0)
1963 strcpy(w32_strerror_buffer, "Unknown Error");
0a753a76 1964
3352bfcb 1965 return w32_strerror_buffer;
68dc0745 1966 }
390b85e7 1967 return strerror(e);
0a753a76 1968}
1969
22fae026 1970DllExport void
c5be433b 1971win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM
1972{
1973 DWORD dwLen;
1974 char *sMsg;
1975 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
1976 |FORMAT_MESSAGE_IGNORE_INSERTS
1977 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
1978 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 1979 /* strip trailing whitespace and period */
22fae026 1980 if (0 < dwLen) {
2ce77adf
GS
1981 do {
1982 --dwLen; /* dwLen doesn't include trailing null */
1983 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM
1984 if ('.' != sMsg[dwLen])
1985 dwLen++;
2ce77adf 1986 sMsg[dwLen] = '\0';
22fae026
TM
1987 }
1988 if (0 == dwLen) {
c69f6586 1989 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS
1990 if (sMsg)
1991 dwLen = sprintf(sMsg,
1992 "Unknown error #0x%lX (lookup 0x%lX)",
1993 dwErr, GetLastError());
1994 }
1995 if (sMsg) {
c5be433b 1996 dTHXo;
db7c17d7
GS
1997 sv_setpvn((SV*)sv, sMsg, dwLen);
1998 LocalFree(sMsg);
22fae026 1999 }
22fae026
TM
2000}
2001
2002
68dc0745 2003DllExport int
2004win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2005{
68dc0745 2006 va_list marker;
2007 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2008
390b85e7 2009 return (vfprintf(fp, format, marker));
0a753a76 2010}
2011
68dc0745 2012DllExport int
2013win32_printf(const char *format, ...)
0a753a76 2014{
68dc0745 2015 va_list marker;
2016 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2017
390b85e7 2018 return (vprintf(format, marker));
0a753a76 2019}
2020
68dc0745 2021DllExport int
2022win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2023{
390b85e7 2024 return (vfprintf(fp, format, args));
0a753a76 2025}
2026
96e4d5b1 2027DllExport int
2028win32_vprintf(const char *format, va_list args)
2029{
390b85e7 2030 return (vprintf(format, args));
96e4d5b1 2031}
2032
68dc0745 2033DllExport size_t
2034win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2035{
390b85e7 2036 return fread(buf, size, count, fp);
0a753a76 2037}
2038
68dc0745 2039DllExport size_t
2040win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2041{
390b85e7 2042 return fwrite(buf, size, count, fp);
0a753a76 2043}
2044
7fac1903
GS
2045#define MODE_SIZE 10
2046
68dc0745 2047DllExport FILE *
2048win32_fopen(const char *filename, const char *mode)
0a753a76 2049{
c5be433b 2050 dTHXo;
7fac1903 2051 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH];
c5be433b
GS
2052
2053 if (!*filename)
2054 return NULL;
2055
68dc0745 2056 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS
2057 filename = "NUL";
2058
2059 if (USING_WIDE()) {
0cb96387
GS
2060 A2WHELPER(mode, wMode, sizeof(wMode));
2061 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
7766f137 2062 return _wfopen(PerlDir_mapW(wBuffer), wMode);
7fac1903 2063 }
7766f137 2064 return fopen(PerlDir_mapA(filename), mode);
0a753a76 2065}
2066
f3986ebb
GS
2067#ifndef USE_SOCKETS_AS_HANDLES
2068#undef fdopen
2069#define fdopen my_fdopen
2070#endif
2071
68dc0745 2072DllExport FILE *
7fac1903 2073win32_fdopen(int handle, const char *mode)
0a753a76 2074{
c5be433b 2075 dTHXo;
51371543 2076 WCHAR wMode[MODE_SIZE];
7fac1903 2077 if (USING_WIDE()) {
0cb96387 2078 A2WHELPER(mode, wMode, sizeof(wMode));
7fac1903
GS
2079 return _wfdopen(handle, wMode);
2080 }
390b85e7 2081 return fdopen(handle, (char *) mode);
0a753a76 2082}
2083
68dc0745 2084DllExport FILE *
7fac1903 2085win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2086{
c5be433b 2087 dTHXo;
51371543 2088 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH];
68dc0745 2089 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
2090 path = "NUL";
2091
2092 if (USING_WIDE()) {
0cb96387
GS
2093 A2WHELPER(mode, wMode, sizeof(wMode));
2094 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2095 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
7fac1903 2096 }
7766f137 2097 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76 2098}
2099
68dc0745 2100DllExport int
2101win32_fclose(FILE *pf)
0a753a76 2102{
f3986ebb 2103 return my_fclose(pf); /* defined in win32sck.c */
0a753a76 2104}
2105
68dc0745 2106DllExport int
2107win32_fputs(const char *s,FILE *pf)
0a753a76 2108{
390b85e7 2109 return fputs(s, pf);
0a753a76 2110}
2111
68dc0745 2112DllExport int
2113win32_fputc(int c,FILE *pf)
0a753a76 2114{
390b85e7 2115 return fputc(c,pf);
0a753a76 2116}
2117
68dc0745 2118DllExport int
2119win32_ungetc(int c,FILE *pf)
0a753a76 2120{
390b85e7 2121 return ungetc(c,pf);
0a753a76 2122}
2123
68dc0745 2124DllExport int
2125win32_getc(FILE *pf)
0a753a76 2126{
390b85e7 2127 return getc(pf);
0a753a76 2128}
2129
68dc0745 2130DllExport int
2131win32_fileno(FILE *pf)
0a753a76 2132{
390b85e7 2133 return fileno(pf);
0a753a76 2134}
2135
68dc0745 2136DllExport void
2137win32_clearerr(FILE *pf)
0a753a76 2138{
390b85e7 2139 clearerr(pf);
68dc0745 2140 return;
0a753a76 2141}
2142
68dc0745 2143DllExport int
2144win32_fflush(FILE *pf)
0a753a76 2145{
390b85e7 2146 return fflush(pf);
0a753a76 2147}
2148
68dc0745 2149DllExport long
2150win32_ftell(FILE *pf)
0a753a76 2151{
390b85e7 2152 return ftell(pf);
0a753a76 2153}
2154
68dc0745 2155DllExport int
2156win32_fseek(FILE *pf,long offset,int origin)
0a753a76 2157{
390b85e7 2158 return fseek(pf, offset, origin);
0a753a76 2159}
2160
68dc0745 2161DllExport int
2162win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2163{
390b85e7 2164 return fgetpos(pf, p);
0a753a76 2165}
2166
68dc0745 2167DllExport int
2168win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2169{
390b85e7 2170 return fsetpos(pf, p);
0a753a76 2171}
2172
68dc0745 2173DllExport void
2174win32_rewind(FILE *pf)
0a753a76 2175{
390b85e7 2176 rewind(pf);
68dc0745 2177 return;
0a753a76 2178}
2179
68dc0745 2180DllExport FILE*
2181win32_tmpfile(void)
0a753a76 2182{
390b85e7 2183 return tmpfile();
0a753a76 2184}
2185
68dc0745 2186DllExport void
2187win32_abort(void)
0a753a76 2188{
390b85e7 2189 abort();
68dc0745 2190 return;
0a753a76 2191}
2192
68dc0745 2193DllExport int
22239a37 2194win32_fstat(int fd,struct stat *sbufptr)
0a753a76 2195{
22239a37 2196 return fstat(fd,sbufptr);
0a753a76 2197}
2198
68dc0745 2199DllExport int
2200win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2201{
390b85e7 2202 return _pipe(pfd, size, mode);
0a753a76 2203}
2204
50892819
GS
2205/*
2206 * a popen() clone that respects PERL5SHELL
2207 */
2208
68dc0745 2209DllExport FILE*
2210win32_popen(const char *command, const char *mode)
0a753a76 2211{
4b556e6c 2212#ifdef USE_RTL_POPEN
390b85e7 2213 return _popen(command, mode);
50892819
GS
2214#else
2215 int p[2];
2216 int parent, child;
2217 int stdfd, oldfd;
2218 int ourmode;
2219 int childpid;
2220
2221 /* establish which ends read and write */
2222 if (strchr(mode,'w')) {
2223 stdfd = 0; /* stdin */
2224 parent = 1;
2225 child = 0;
2226 }
2227 else if (strchr(mode,'r')) {
2228 stdfd = 1; /* stdout */
2229 parent = 0;
2230 child = 1;
2231 }
2232 else
2233 return NULL;
2234
2235 /* set the correct mode */
2236 if (strchr(mode,'b'))
2237 ourmode = O_BINARY;
2238 else if (strchr(mode,'t'))
2239 ourmode = O_TEXT;
2240 else
2241 ourmode = _fmode & (O_TEXT | O_BINARY);
2242
2243 /* the child doesn't inherit handles */
2244 ourmode |= O_NOINHERIT;
2245
2246 if (win32_pipe( p, 512, ourmode) == -1)
2247 return NULL;
2248
2249 /* save current stdfd */
2250 if ((oldfd = win32_dup(stdfd)) == -1)
2251 goto cleanup;
2252
2253 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2254 /* stdfd will be inherited by the child */
2255 if (win32_dup2(p[child], stdfd) == -1)
2256 goto cleanup;
2257
2258 /* close the child end in parent */
2259 win32_close(p[child]);
2260
2261 /* start the child */
4f63d024 2262 {
c5be433b
GS
2263 dTHXo;
2264 if ((childpid = do_spawn_nowait((char*)command)) == -1)
4f63d024 2265 goto cleanup;
50892819 2266
4f63d024
GS
2267 /* revert stdfd to whatever it was before */
2268 if (win32_dup2(oldfd, stdfd) == -1)
2269 goto cleanup;
50892819 2270
4f63d024
GS
2271 /* close saved handle */
2272 win32_close(oldfd);
50892819 2273
4f63d024 2274 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
d91d68c1
RS
2275
2276 /* set process id so that it can be returned by perl's open() */
2277 PL_forkprocess = childpid;
4f63d024 2278 }
50892819
GS
2279
2280 /* we have an fd, return a file stream */
2281 return (win32_fdopen(p[parent], (char *)mode));
2282
2283cleanup:
2284 /* we don't need to check for errors here */
2285 win32_close(p[0]);
2286 win32_close(p[1]);
2287 if (oldfd != -1) {
2288 win32_dup2(oldfd, stdfd);
2289 win32_close(oldfd);
2290 }
2291 return (NULL);
2292
4b556e6c 2293#endif /* USE_RTL_POPEN */
0a753a76 2294}
2295
50892819
GS
2296/*
2297 * pclose() clone
2298 */
2299
68dc0745 2300DllExport int
2301win32_pclose(FILE *pf)
0a753a76 2302{
4b556e6c 2303#ifdef USE_RTL_POPEN
390b85e7 2304 return _pclose(pf);
50892819 2305#else
c5be433b 2306 dTHXo;
e17cb2a9
JD
2307 int childpid, status;
2308 SV *sv;
2309
4b556e6c 2310 sv = *av_fetch(w32_fdpid, win32_fileno(pf), TRUE);
e17cb2a9
JD
2311 if (SvIOK(sv))
2312 childpid = SvIVX(sv);
2313 else
2314 childpid = 0;
50892819
GS
2315
2316 if (!childpid) {
2317 errno = EBADF;
2318 return -1;
2319 }
2320
2321 win32_fclose(pf);
e17cb2a9
JD
2322 SvIVX(sv) = 0;
2323
0aaad0ff
GS
2324 if (win32_waitpid(childpid, &status, 0) == -1)
2325 return -1;
50892819 2326
0aaad0ff 2327 return status;
50892819 2328
4b556e6c 2329#endif /* USE_RTL_POPEN */
0a753a76 2330}
6b980173
JD
2331
2332static BOOL WINAPI
2333Nt4CreateHardLinkW(
2334 LPCWSTR lpFileName,
2335 LPCWSTR lpExistingFileName,
2336 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2337{
2338 HANDLE handle;
2339 WCHAR wFullName[MAX_PATH+1];
2340 LPVOID lpContext = NULL;
2341 WIN32_STREAM_ID StreamId;
2342 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2343 DWORD dwWritten;
2344 DWORD dwLen;
2345 BOOL bSuccess;
2346
2347 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2348 BOOL, BOOL, LPVOID*) =
2349 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2350 BOOL, BOOL, LPVOID*))
2351 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2352 if (pfnBackupWrite == NULL)
2353 return 0;
2354
2355 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2356 if (dwLen == 0)
2357 return 0;
2358 dwLen = (dwLen+1)*sizeof(WCHAR);
2359
2360 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2361 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2362 NULL, OPEN_EXISTING, 0, NULL);
2363 if (handle == INVALID_HANDLE_VALUE)
2364 return 0;
2365
2366 StreamId.dwStreamId = BACKUP_LINK;
2367 StreamId.dwStreamAttributes = 0;
2368 StreamId.dwStreamNameSize = 0;
9eaf016b 2369#if defined(__BORLANDC__) || defined(__MINGW32__)
4ce4f76e
GS
2370 StreamId.Size.u.HighPart = 0;
2371 StreamId.Size.u.LowPart = dwLen;
2372#else
6b980173
JD
2373 StreamId.Size.HighPart = 0;
2374 StreamId.Size.LowPart = dwLen;
4ce4f76e 2375#endif
6b980173
JD
2376
2377 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2378 FALSE, FALSE, &lpContext);
2379 if (bSuccess) {
2380 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2381 FALSE, FALSE, &lpContext);
2382 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2383 }
2384
2385 CloseHandle(handle);
2386 return bSuccess;
2387}
2388
2389DllExport int
2390win32_link(const char *oldname, const char *newname)
2391{
2392 dTHXo;
2393 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
2394 WCHAR wOldName[MAX_PATH];
2395 WCHAR wNewName[MAX_PATH];
2396
2397 if (IsWin95())
2398 Perl_die(aTHX_ PL_no_func, "link");
2399
2400 pfnCreateHardLinkW =
2401 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2402 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2403 if (pfnCreateHardLinkW == NULL)
2404 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2405
2406 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2407 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
7766f137
GS
2408 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2409 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD
2410 {
2411 return 0;
2412 }
2413 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2414 return -1;
2415}
0a753a76 2416
68dc0745 2417DllExport int
8d9b2e3c 2418win32_rename(const char *oname, const char *newname)
e24c7c18 2419{
7fac1903
GS
2420 WCHAR wOldName[MAX_PATH];
2421 WCHAR wNewName[MAX_PATH];
7766f137 2422 char szOldName[MAX_PATH];
7fac1903 2423 BOOL bResult;
80252599
GS
2424 /* XXX despite what the documentation says about MoveFileEx(),
2425 * it doesn't work under Windows95!
2426 */
2427 if (IsWinNT()) {
c5be433b 2428 dTHXo;
7fac1903 2429 if (USING_WIDE()) {
0cb96387
GS
2430 A2WHELPER(oname, wOldName, sizeof(wOldName));
2431 A2WHELPER(newname, wNewName, sizeof(wNewName));
7766f137
GS
2432 wcscpy(wOldName, PerlDir_mapW(wOldName));
2433 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName),
7fac1903
GS
2434 MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
2435 }
2436 else {
7766f137
GS
2437 strcpy(szOldName, PerlDir_mapA(szOldName));
2438 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname),
7fac1903
GS
2439 MOVEFILE_COPY_ALLOWED|MOVEFILE_REPLACE_EXISTING);
2440 }
2441 if (!bResult) {
80252599
GS
2442 DWORD err = GetLastError();
2443 switch (err) {
2444 case ERROR_BAD_NET_NAME:
2445 case ERROR_BAD_NETPATH:
2446 case ERROR_BAD_PATHNAME:
2447 case ERROR_FILE_NOT_FOUND:
2448 case ERROR_FILENAME_EXCED_RANGE:
2449 case ERROR_INVALID_DRIVE:
2450 case ERROR_NO_MORE_FILES:
2451 case ERROR_PATH_NOT_FOUND:
2452 errno = ENOENT;
2453 break;
2454 default:
2455 errno = EACCES;
2456 break;
2457 }
2458 return -1;
2459 }
2460 return 0;
e24c7c18 2461 }
80252599
GS
2462 else {
2463 int retval = 0;
2464 char tmpname[MAX_PATH+1];
2465 char dname[MAX_PATH+1];
2466 char *endname = Nullch;
2467 STRLEN tmplen = 0;
2468 DWORD from_attr, to_attr;
2469
2470 /* if oname doesn't exist, do nothing */
2471 from_attr = GetFileAttributes(oname);
2472 if (from_attr == 0xFFFFFFFF) {
2473 errno = ENOENT;
2474 return -1;
2475 }
2476
2477 /* if newname exists, rename it to a temporary name so that we
2478 * don't delete it in case oname happens to be the same file
2479 * (but perhaps accessed via a different path)
2480 */
2481 to_attr = GetFileAttributes(newname);
2482 if (to_attr != 0xFFFFFFFF) {
2483 /* if newname is a directory, we fail
2484 * XXX could overcome this with yet more convoluted logic */
2485 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2486 errno = EACCES;
2487 return -1;
2488 }
2489 tmplen = strlen(newname);
2490 strcpy(tmpname,newname);
2491 endname = tmpname+tmplen;
2492 for (; endname > tmpname ; --endname) {
2493 if (*endname == '/' || *endname == '\\') {
2494 *endname = '\0';
2495 break;
2496 }
2497 }
2498 if (endname > tmpname)
2499 endname = strcpy(dname,tmpname);
e24c7c18 2500 else
80252599
GS
2501 endname = ".";
2502
2503 /* get a temporary filename in same directory
2504 * XXX is this really the best we can do? */
2505 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, tmpname)) {
2506 errno = ENOENT;
2507 return -1;
2508 }
2509 DeleteFile(tmpname);
2510
2511 retval = rename(newname, tmpname);
2512 if (retval != 0) {
2513 errno = EACCES;
2514 return retval;
e24c7c18
GS
2515 }
2516 }
80252599
GS
2517
2518 /* rename oname to newname */
2519 retval = rename(oname, newname);
2520
2521 /* if we created a temporary file before ... */
2522 if (endname != Nullch) {
2523 /* ...and rename succeeded, delete temporary file/directory */
2524 if (retval == 0)
2525 DeleteFile(tmpname);
2526 /* else restore it to what it was */
2527 else
2528 (void)rename(tmpname, newname);
2529 }
2530 return retval;
e24c7c18 2531 }
e24c7c18
GS
2532}
2533
2534DllExport int
68dc0745 2535win32_setmode(int fd, int mode)
0a753a76 2536{
390b85e7 2537 return setmode(fd, mode);
0a753a76 2538}
2539
96e4d5b1 2540DllExport long
2541win32_lseek(int fd, long offset, int origin)
2542{
390b85e7 2543 return lseek(fd, offset, origin);
96e4d5b1 2544}
2545
2546DllExport long
2547win32_tell(int fd)
2548{
390b85e7 2549 return tell(fd);
96e4d5b1 2550}
2551
68dc0745 2552DllExport int
2553win32_open(const char *path, int flag, ...)
0a753a76 2554{
c5be433b 2555 dTHXo;
68dc0745 2556 va_list ap;
2557 int pmode;
b9010385 2558 WCHAR wBuffer[MAX_PATH];
0a753a76 2559
2560 va_start(ap, flag);
2561 pmode = va_arg(ap, int);
2562 va_end(ap);
2563
68dc0745 2564 if (stricmp(path, "/dev/null")==0)
7fac1903
GS
2565 path = "NUL";
2566
2567 if (USING_WIDE()) {
0cb96387 2568 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2569 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
7fac1903 2570 }
7766f137 2571 return open(PerlDir_mapA(path), flag, pmode);
0a753a76 2572}
2573
68dc0745 2574DllExport int
2575win32_close(int fd)
0a753a76 2576{
390b85e7 2577 return close(fd);
0a753a76 2578}
2579
68dc0745 2580DllExport int
96e4d5b1 2581win32_eof(int fd)
2582{
390b85e7 2583 return eof(fd);
96e4d5b1 2584}
2585
2586DllExport int
68dc0745 2587win32_dup(int fd)
0a753a76 2588{
390b85e7 2589 return dup(fd);
0a753a76 2590}
2591
68dc0745 2592DllExport int
2593win32_dup2(int fd1,int fd2)
0a753a76 2594{
390b85e7 2595 return dup2(fd1,fd2);
0a753a76 2596}
2597
f7aeb604
GS
2598#ifdef PERL_MSVCRT_READFIX
2599
2600#define LF 10 /* line feed */
2601#define CR 13 /* carriage return */
2602#define CTRLZ 26 /* ctrl-z means eof for text */
2603#define FOPEN 0x01 /* file handle open */
2604#define FEOFLAG 0x02 /* end of file has been encountered */
2605#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
2606#define FPIPE 0x08 /* file handle refers to a pipe */
2607#define FAPPEND 0x20 /* file handle opened O_APPEND */
2608#define FDEV 0x40 /* file handle refers to device */
2609#define FTEXT 0x80 /* file handle is in text mode */
2610#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
2611
2612/*
2613 * Control structure for lowio file handles
2614 */
2615typedef struct {
2616 long osfhnd; /* underlying OS file HANDLE */
2617 char osfile; /* attributes of file (e.g., open in text mode?) */
2618 char pipech; /* one char buffer for handles opened on pipes */
2619 int lockinitflag;
2620 CRITICAL_SECTION lock;
2621} ioinfo;
2622
2623
2624/*
2625 * Array of arrays of control structures for lowio files.
2626 */
2627EXTERN_C _CRTIMP ioinfo* __pioinfo[];
2628
2629/*
2630 * Definition of IOINFO_L2E, the log base 2 of the number of elements in each
2631 * array of ioinfo structs.
2632 */
2633#define IOINFO_L2E 5
2634
2635/*
2636 * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array
2637 */
2638#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
2639
2640/*
2641 * Access macros for getting at an ioinfo struct and its fields from a
2642 * file handle
2643 */
2644#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1)))
2645#define _osfhnd(i) (_pioinfo(i)->osfhnd)
2646#define _osfile(i) (_pioinfo(i)->osfile)
2647#define _pipech(i) (_pioinfo(i)->pipech)
2648
2649int __cdecl _fixed_read(int fh, void *buf, unsigned cnt)
2650{
2651 int bytes_read; /* number of bytes read */
2652 char *buffer; /* buffer to read to */
2653 int os_read; /* bytes read on OS call */
2654 char *p, *q; /* pointers into buffer */
2655 char peekchr; /* peek-ahead character */
2656 ULONG filepos; /* file position after seek */
2657 ULONG dosretval; /* o.s. return value */
2658
2659 /* validate handle */
2660 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
2661 !(_osfile(fh) & FOPEN))
2662 {
2663 /* out of range -- return error */
2664 errno = EBADF;
2665 _doserrno = 0; /* not o.s. error */
2666 return -1;
2667 }
2668
2669 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
2670
2671 bytes_read = 0; /* nothing read yet */
2672 buffer = (char*)buf;
2673
2674 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
2675 /* nothing to read or at EOF, so return 0 read */
2676 goto functionexit;
2677 }
2678
2679 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
2680 /* a pipe/device and pipe lookahead non-empty: read the lookahead
2681 * char */
2682 *buffer++ = _pipech(fh);
2683 ++bytes_read;
2684 --cnt;
2685 _pipech(fh) = LF; /* mark as empty */
2686 }
2687
2688 /* read the data */
2689
2690 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
2691 {
2692 /* ReadFile has reported an error. recognize two special cases.
2693 *
2694 * 1. map ERROR_ACCESS_DENIED to EBADF
2695 *
2696 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
2697 * means the handle is a read-handle on a pipe for which
2698 * all write-handles have been closed and all data has been
2699 * read. */
2700
2701 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
2702 /* wrong read/write mode should return EBADF, not EACCES */
2703 errno = EBADF;
2704 _doserrno = dosretval;
2705 bytes_read = -1;
2706 goto functionexit;
2707 }
2708 else if (dosretval == ERROR_BROKEN_PIPE) {
2709 bytes_read = 0;
2710 goto functionexit;
2711 }
2712 else {
2713 bytes_read = -1;
2714 goto functionexit;
2715 }
2716 }
2717
2718 bytes_read += os_read; /* update bytes read */
2719
2720 if (_osfile(fh) & FTEXT) {
2721 /* now must translate CR-LFs to LFs in the buffer */
2722
2723 /* set CRLF flag to indicate LF at beginning of buffer */
2724 /* if ((os_read != 0) && (*(char *)buf == LF)) */
2725 /* _osfile(fh) |= FCRLF; */
2726 /* else */
2727 /* _osfile(fh) &= ~FCRLF; */
2728
2729 _osfile(fh) &= ~FCRLF;
2730
2731 /* convert chars in the buffer: p is src, q is dest */
2732 p = q = (char*)buf;
2733 while (p < (char *)buf + bytes_read) {
2734 if (*p == CTRLZ) {
2735 /* if fh is not a device, set ctrl-z flag */
2736 if (!(_osfile(fh) & FDEV))
2737 _osfile(fh) |= FEOFLAG;
2738 break; /* stop translating */
2739 }
2740 else if (*p != CR)
2741 *q++ = *p++;
2742 else {
2743 /* *p is CR, so must check next char for LF */
2744 if (p < (char *)buf + bytes_read - 1) {
2745 if (*(p+1) == LF) {
2746 p += 2;
2747 *q++ = LF; /* convert CR-LF to LF */
2748 }
2749 else
2750 *q++ = *p++; /* store char normally */
2751 }
2752 else {
2753 /* This is the hard part. We found a CR at end of
2754 buffer. We must peek ahead to see if next char
2755 is an LF. */
2756 ++p;
2757
2758 dosretval = 0;
2759 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
2760 (LPDWORD)&os_read, NULL))
2761 dosretval = GetLastError();
2762
2763 if (dosretval != 0 || os_read == 0) {
2764 /* couldn't read ahead, store CR */
2765 *q++ = CR;
2766 }
2767 else {
2768 /* peekchr now has the extra character -- we now
2769 have several possibilities:
2770 1. disk file and char is not LF; just seek back
2771 and copy CR
2772 2. disk file and char is LF; store LF, don't seek back
2773 3. pipe/device and char is LF; store LF.
2774 4. pipe/device and char isn't LF, store CR and
2775 put char in pipe lookahead buffer. */
2776 if (_osfile(fh) & (FDEV|FPIPE)) {
2777 /* non-seekable device */
2778 if (peekchr == LF)
2779 *q++ = LF;
2780 else {
2781 *q++ = CR;
2782 _pipech(fh) = peekchr;
2783 }
2784 }
2785 else {
2786 /* disk file */
2787 if (peekchr == LF) {
2788 /* nothing read yet; must make some
2789 progress */
2790 *q++ = LF;
2791 /* turn on this flag for tell routine */
2792 _osfile(fh) |= FCRLF;
2793 }
2794 else {
2795 HANDLE osHandle; /* o.s. handle value */
2796 /* seek back */
2797 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
2798 {
2799 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
2800 dosretval = GetLastError();
2801 }
2802 if (peekchr != LF)
2803 *q++ = CR;
2804 }
2805 }
2806 }
2807 }
2808 }
2809 }
2810
2811 /* we now change bytes_read to reflect the true number of chars
2812 in the buffer */
2813 bytes_read = q - (char *)buf;
2814 }
2815
2816functionexit:
2817 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
2818
2819 return bytes_read;
2820}
2821
2822#endif /* PERL_MSVCRT_READFIX */
2823
68dc0745 2824DllExport int
3e3baf6d 2825win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 2826{
f7aeb604
GS
2827#ifdef PERL_MSVCRT_READFIX
2828 return _fixed_read(fd, buf, cnt);
2829#else
390b85e7 2830 return read(fd, buf, cnt);
f7aeb604 2831#endif
0a753a76 2832}
2833
68dc0745 2834DllExport int
3e3baf6d 2835win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 2836{
390b85e7 2837 return write(fd, buf, cnt);
0a753a76 2838}
2839
68dc0745 2840DllExport int
5aabfad6 2841win32_mkdir(const char *dir, int mode)
2842{
7766f137
GS
2843 dTHXo;
2844 if (USING_WIDE()) {
2845 WCHAR wBuffer[MAX_PATH];
2846 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
2847 return _wmkdir(PerlDir_mapW(wBuffer));
2848 }
2849 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 2850}
96e4d5b1 2851
5aabfad6 2852DllExport int
2853win32_rmdir(const char *dir)
2854{
7766f137
GS
2855 dTHXo;
2856 if (USING_WIDE()) {
2857 WCHAR wBuffer[MAX_PATH];
2858 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
2859 return _wrmdir(PerlDir_mapW(wBuffer));
2860 }
2861 return rmdir(PerlDir_mapA(dir));
5aabfad6 2862}
96e4d5b1 2863
5aabfad6 2864DllExport int
2865win32_chdir(const char *dir)
2866{
7766f137
GS
2867 dTHXo;
2868 if (USING_WIDE()) {
2869 WCHAR wBuffer[MAX_PATH];
2870 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
2871 return _wchdir(wBuffer);
2872 }
390b85e7 2873 return chdir(dir);
5aabfad6 2874}
96e4d5b1 2875
7766f137
GS
2876DllExport int
2877win32_access(const char *path, int mode)
2878{
2879 dTHXo;
2880 if (USING_WIDE()) {
2881 WCHAR wBuffer[MAX_PATH];
2882 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2883 return _waccess(PerlDir_mapW(wBuffer), mode);
2884 }
2885 return access(PerlDir_mapA(path), mode);
2886}
2887
2888DllExport int
2889win32_chmod(const char *path, int mode)
2890{
2891 dTHXo;
2892 if (USING_WIDE()) {
2893 WCHAR wBuffer[MAX_PATH];
2894 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2895 return _wchmod(PerlDir_mapW(wBuffer), mode);
2896 }
2897 return chmod(PerlDir_mapA(path), mode);
2898}
2899
2900
0aaad0ff
GS
2901static char *
2902create_command_line(const char* command, const char * const *args)
2903{
c5be433b 2904 dTHXo;
0aaad0ff
GS
2905 int index;
2906 char *cmd, *ptr, *arg;
2907 STRLEN len = strlen(command) + 1;
2908
2909 for (index = 0; (ptr = (char*)args[index]) != NULL; ++index)
2910 len += strlen(ptr) + 1;
2911
2912 New(1310, cmd, len, char);
2913 ptr = cmd;
2914 strcpy(ptr, command);
0aaad0ff
GS
2915
2916 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
0aaad0ff 2917 ptr += strlen(ptr);
18a945d4
GS
2918 *ptr++ = ' ';
2919 strcpy(ptr, arg);
0aaad0ff
GS
2920 }
2921
2922 return cmd;
2923}
2924
2925static char *
2926qualified_path(const char *cmd)
2927{
c5be433b 2928 dTHXo;
0aaad0ff
GS
2929 char *pathstr;
2930 char *fullcmd, *curfullcmd;
2931 STRLEN cmdlen = 0;
2932 int has_slash = 0;
2933
2934 if (!cmd)
2935 return Nullch;
2936 fullcmd = (char*)cmd;
2937 while (*fullcmd) {
2938 if (*fullcmd == '/' || *fullcmd == '\\')
2939 has_slash++;
2940 fullcmd++;
2941 cmdlen++;
2942 }
2943
2944 /* look in PATH */
2945 pathstr = win32_getenv("PATH");
2946 New(0, fullcmd, MAX_PATH+1, char);
2947 curfullcmd = fullcmd;
2948
2949 while (1) {
2950 DWORD res;
2951
2952 /* start by appending the name to the current prefix */
2953 strcpy(curfullcmd, cmd);
2954 curfullcmd += cmdlen;
2955
2956 /* if it doesn't end with '.', or has no extension, try adding
2957 * a trailing .exe first */
2958 if (cmd[cmdlen-1] != '.'
2959 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
2960 {
2961 strcpy(curfullcmd, ".exe");
2962 res = GetFileAttributes(fullcmd);
2963 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
2964 return fullcmd;
2965 *curfullcmd = '\0';
2966 }
2967
2968 /* that failed, try the bare name */
2969 res = GetFileAttributes(fullcmd);
2970 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
2971 return fullcmd;
2972
2973 /* quit if no other path exists, or if cmd already has path */
2974 if (!pathstr || !*pathstr || has_slash)
2975 break;
2976
2977 /* skip leading semis */
2978 while (*pathstr == ';')
2979 pathstr++;
2980
2981 /* build a new prefix from scratch */
2982 curfullcmd = fullcmd;
2983 while (*pathstr && *pathstr != ';') {
2984 if (*pathstr == '"') { /* foo;"baz;etc";bar */
2985 pathstr++; /* skip initial '"' */
2986 while (*pathstr && *pathstr != '"') {
2987 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
2988 *curfullcmd++ = *pathstr;
2989 pathstr++;
2990 }
2991 if (*pathstr)
2992 pathstr++; /* skip trailing '"' */
2993 }
2994 else {
2995 if (curfullcmd-fullcmd < MAX_PATH-cmdlen-5)
2996 *curfullcmd++ = *pathstr;
2997 pathstr++;
2998 }
2999 }
3000 if (*pathstr)
3001 pathstr++; /* skip trailing semi */
3002 if (curfullcmd > fullcmd /* append a dir separator */
3003 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3004 {
3005 *curfullcmd++ = '\\';
3006 }
3007 }
3008GIVE_UP:
3009 Safefree(fullcmd);
3010 return Nullch;
3011}
3012
3075ddba
GS
3013/* The following are just place holders.
3014 * Some hosts may provide and environment that the OS is
3015 * not tracking, therefore, these host must provide that
3016 * environment and the current directory to CreateProcess
3017 */
3018
3019void*
3020get_childenv(void)
3021{
3022 return NULL;
3023}
3024
3025void
2dd19d29 3026free_childenv(void* d)
3075ddba
GS
3027{
3028}
3029
3030char*
3031get_childdir(void)
3032{
7766f137
GS
3033 dTHXo;
3034 char* ptr;
3035 char szfilename[(MAX_PATH+1)*2];
3036 if (USING_WIDE()) {
3037 WCHAR wfilename[MAX_PATH+1];
3038 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3039 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3040 }
3041 else {
3042 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3043 }
3044
3045 New(0, ptr, strlen(szfilename)+1, char);
3046 strcpy(ptr, szfilename);
3047 return ptr;
3075ddba
GS
3048}
3049
3050void
2dd19d29 3051free_childdir(char* d)
3075ddba 3052{
7766f137
GS
3053 dTHXo;
3054 Safefree(d);
3075ddba
GS
3055}
3056
3057
0aaad0ff
GS
3058/* XXX this needs to be made more compatible with the spawnvp()
3059 * provided by the various RTLs. In particular, searching for
3060 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3061 * This doesn't significantly affect perl itself, because we
3062 * always invoke things using PERL5SHELL if a direct attempt to
3063 * spawn the executable fails.
3064 *
3065 * XXX splitting and rejoining the commandline between do_aspawn()
3066 * and win32_spawnvp() could also be avoided.
3067 */
3068
5aabfad6 3069DllExport int
3e3baf6d 3070win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
0a753a76 3071{
0aaad0ff
GS
3072#ifdef USE_RTL_SPAWNVP
3073 return spawnvp(mode, cmdname, (char * const *)argv);
3074#else
c5be433b 3075 dTHXo;
2b260de0 3076 int ret;
3075ddba
GS
3077 void* env;
3078 char* dir;
0aaad0ff
GS
3079 STARTUPINFO StartupInfo;
3080 PROCESS_INFORMATION ProcessInformation;
3081 DWORD create = 0;
3082
3083 char *cmd = create_command_line(cmdname, strcmp(cmdname, argv[0]) == 0
3084 ? &argv[1] : argv);
3085 char *fullcmd = Nullch;
3086
3075ddba
GS
3087 env = PerlEnv_get_childenv();
3088 dir = PerlEnv_get_childdir();
3089
0aaad0ff
GS
3090 switch(mode) {
3091 case P_NOWAIT: /* asynch + remember result */
3092 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3093 errno = EAGAIN;
3094 ret = -1;
3095 goto RETVAL;
3096 }
3097 /* FALL THROUGH */
3098 case P_WAIT: /* synchronous execution */
3099 break;
3100 default: /* invalid mode */
3101 errno = EINVAL;
3102 ret = -1;
3103 goto RETVAL;
3104 }
3105 memset(&StartupInfo,0,sizeof(StartupInfo));
3106 StartupInfo.cb = sizeof(StartupInfo);
3ffaa937
GS
3107 StartupInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE);
3108 StartupInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
3109 StartupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE);
3110 if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
3111 StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
3112 StartupInfo.hStdError != INVALID_HANDLE_VALUE)
3113 {
3114 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3115 }
3116 else {
3117 create |= CREATE_NEW_CONSOLE;
3118 }
3119
0aaad0ff
GS
3120RETRY:
3121 if (!CreateProcess(cmdname, /* search PATH to find executable */
3122 cmd, /* executable, and its arguments */
3123 NULL, /* process attributes */
3124 NULL, /* thread attributes */
3125 TRUE, /* inherit handles */
3126 create, /* creation flags */
3075ddba
GS
3127 (LPVOID)env, /* inherit environment */
3128 dir, /* inherit cwd */
0aaad0ff
GS
3129 &StartupInfo,
3130 &ProcessInformation))
3131 {
3132 /* initial NULL argument to CreateProcess() does a PATH
3133 * search, but it always first looks in the directory
3134 * where the current process was started, which behavior
3135 * is undesirable for backward compatibility. So we
3136 * jump through our own hoops by picking out the path
3137 * we really want it to use. */
3138 if (!fullcmd) {
3139 fullcmd = qualified_path(cmdname);
3140 if (fullcmd) {
3141 cmdname = fullcmd;
3142 goto RETRY;
3143 }
3144 }
3145 errno = ENOENT;
3146 ret = -1;
3147 goto RETVAL;
3148 }
2d7a9237 3149
0aaad0ff
GS
3150 if (mode == P_NOWAIT) {
3151 /* asynchronous spawn -- store handle, return PID */
3152 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
2b260de0
GS
3153 w32_child_pids[w32_num_children] = ProcessInformation.dwProcessId;
3154 ret = (int)ProcessInformation.dwProcessId;
0aaad0ff
GS
3155 ++w32_num_children;
3156 }
3157 else {
2b260de0 3158 DWORD status;
0aaad0ff 3159 WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
2b260de0
GS
3160 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3161 ret = (int)status;
0aaad0ff
GS
3162 CloseHandle(ProcessInformation.hProcess);
3163 }
e17cb2a9 3164
0aaad0ff 3165 CloseHandle(ProcessInformation.hThread);
3075ddba 3166
0aaad0ff 3167RETVAL:
3075ddba
GS
3168 PerlEnv_free_childenv(env);
3169 PerlEnv_free_childdir(dir);
0aaad0ff
GS
3170 Safefree(cmd);
3171 Safefree(fullcmd);
2b260de0 3172 return ret;
2d7a9237 3173#endif
0a753a76 3174}
3175
6890e559 3176DllExport int
eb62e965
JD
3177win32_execv(const char *cmdname, const char *const *argv)
3178{
7766f137
GS
3179#ifdef USE_ITHREADS
3180 dTHXo;
3181 /* if this is a pseudo-forked child, we just want to spawn
3182 * the new program, and return */
3183 if (w32_pseudo_id)
3184 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3185#endif
eb62e965
JD
3186 return execv(cmdname, (char *const *)argv);
3187}
3188
3189DllExport int
6890e559
GS
3190win32_execvp(const char *cmdname, const char *const *argv)
3191{
7766f137
GS
3192#ifdef USE_ITHREADS
3193 dTHXo;
3194 /* if this is a pseudo-forked child, we just want to spawn
3195 * the new program, and return */
3196 if (w32_pseudo_id)
3197 return win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3198#endif
390b85e7 3199 return execvp(cmdname, (char *const *)argv);
6890e559
GS
3200}
3201
84902520
TB
3202DllExport void
3203win32_perror(const char *str)
3204{
390b85e7 3205 perror(str);
84902520
TB
3206}
3207
3208DllExport void
3209win32_setbuf(FILE *pf, char *buf)
3210{
390b85e7 3211 setbuf(pf, buf);
84902520
TB
3212}
3213
3214DllExport int
3215win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3216{
390b85e7 3217 return setvbuf(pf, buf, type, size);
84902520
TB
3218}
3219
3220DllExport int
3221win32_flushall(void)
3222{
390b85e7 3223 return flushall();
84902520
TB
3224}
3225
3226DllExport int
3227win32_fcloseall(void)
3228{
390b85e7 3229 return fcloseall();
84902520
TB
3230}
3231
3232DllExport char*
3233win32_fgets(char *s, int n, FILE *pf)
3234{
390b85e7 3235 return fgets(s, n, pf);
84902520
TB
3236}
3237
3238DllExport char*
3239win32_gets(char *s)
3240{
390b85e7 3241 return gets(s);
84902520
TB
3242}
3243
3244DllExport int
3245win32_fgetc(FILE *pf)
3246{
390b85e7 3247 return fgetc(pf);
84902520
TB
3248}
3249
3250DllExport int
3251win32_putc(int c, FILE *pf)
3252{
390b85e7 3253 return putc(c,pf);
84902520
TB
3254}
3255
3256DllExport int
3257win32_puts(const char *s)
3258{
390b85e7 3259 return puts(s);
84902520
TB
3260}
3261
3262DllExport int
3263win32_getchar(void)
3264{
390b85e7 3265 return getchar();
84902520
TB
3266}
3267
3268DllExport int
3269win32_putchar(int c)
3270{
390b85e7 3271 return putchar(c);
84902520
TB
3272}
3273
bbc8f9de
NIS
3274#ifdef MYMALLOC
3275
3276#ifndef USE_PERL_SBRK
3277
3278static char *committed = NULL;
3279static char *base = NULL;
3280static char *reserved = NULL;
3281static char *brk = NULL;
3282static DWORD pagesize = 0;
3283static DWORD allocsize = 0;
3284
3285void *
3286sbrk(int need)
3287{
3288 void *result;
3289 if (!pagesize)
3290 {SYSTEM_INFO info;
3291 GetSystemInfo(&info);
3292 /* Pretend page size is larger so we don't perpetually
3293 * call the OS to commit just one page ...
3294 */
3295 pagesize = info.dwPageSize << 3;
3296 allocsize = info.dwAllocationGranularity;
3297 }
3298 /* This scheme fails eventually if request for contiguous
3299 * block is denied so reserve big blocks - this is only
3300 * address space not memory ...
3301 */
3302 if (brk+need >= reserved)
3303 {
3304 DWORD size = 64*1024*1024;
3305 char *addr;
3306 if (committed && reserved && committed < reserved)
3307 {
3308 /* Commit last of previous chunk cannot span allocations */
161b471a 3309 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS
3310 if (addr)
3311 committed = reserved;
3312 }
3313 /* Reserve some (more) space
3314 * Note this is a little sneaky, 1st call passes NULL as reserved
3315 * so lets system choose where we start, subsequent calls pass
3316 * the old end address so ask for a contiguous block
3317 */
161b471a 3318 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
bbc8f9de
NIS
3319 if (addr)
3320 {
3321 reserved = addr+size;
3322 if (!base)
3323 base = addr;
3324 if (!committed)
3325 committed = base;
3326 if (!brk)
3327 brk = committed;
3328 }
3329 else
3330 {
3331 return (void *) -1;
3332 }
3333 }
3334 result = brk;
3335 brk += need;
3336 if (brk > committed)
3337 {
3338 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
161b471a 3339 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS
3340 if (addr)
3341 {
3342 committed += size;
3343 }
3344 else
3345 return (void *) -1;
3346 }
3347 return result;
3348}
3349
3350#endif
3351#endif
3352
84902520
TB
3353DllExport void*
3354win32_malloc(size_t size)
3355{
390b85e7 3356 return malloc(size);
84902520
TB
3357}
3358
3359DllExport void*
3360win32_calloc(size_t numitems, size_t size)
3361{
390b85e7 3362 return calloc(numitems,size);
84902520
TB
3363}
3364
3365DllExport void*
3366win32_realloc(void *block, size_t size)
3367{
390b85e7 3368 return realloc(block,size);
84902520
TB
3369}
3370
3371DllExport void
3372win32_free(void *block)
3373{
390b85e7 3374 free(block);
84902520
TB
3375}
3376
bbc8f9de 3377
68dc0745 3378int
65e48ea9 3379win32_open_osfhandle(long handle, int flags)
0a753a76 3380{
390b85e7 3381 return _open_osfhandle(handle, flags);
0a753a76 3382}
3383
68dc0745 3384long
65e48ea9 3385win32_get_osfhandle(int fd)
0a753a76 3386{
390b85e7 3387 return _get_osfhandle(fd);
0a753a76 3388}
7bac28a0 3389
0cb96387 3390DllExport void*
c5be433b 3391win32_dynaload(const char* filename)
0cb96387 3392{
c5be433b 3393 dTHXo;
51371543 3394 HMODULE hModule;
0cb96387
GS
3395 if (USING_WIDE()) {
3396 WCHAR wfilename[MAX_PATH];
3397 A2WHELPER(filename, wfilename, sizeof(wfilename));
7766f137 3398 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS
3399 }
3400 else {
7766f137 3401 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS
3402 }
3403 return hModule;
3404}
3405
7bac28a0 3406/*
3407 * Extras.
3408 */
3409
ad2e33dc
GS
3410static
3411XS(w32_GetCwd)
3412{
3413 dXSARGS;
7766f137
GS
3414 /* Make the host for current directory */
3415 char* ptr = PerlEnv_get_childdir();
ad2e33dc 3416 /*
7766f137 3417 * If ptr != Nullch
ad2e33dc 3418 * then it worked, set PV valid,
7766f137 3419 * else return 'undef'
ad2e33dc 3420 */
7766f137
GS
3421 if (ptr) {
3422 SV *sv = sv_newmortal();
3423 sv_setpv(sv, ptr);
3424 PerlEnv_free_childdir(ptr);
3425
3426 EXTEND(SP,1);
ad2e33dc 3427 SvPOK_on(sv);
bb897dfc
JD
3428 ST(0) = sv;
3429 XSRETURN(1);
3430 }
3467312b 3431 XSRETURN_UNDEF;
ad2e33dc
GS
3432}
3433
3434static
3435XS(w32_SetCwd)
3436{
3437 dXSARGS;
3438 if (items != 1)
4f63d024 3439 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
7766f137 3440 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
ad2e33dc
GS
3441 XSRETURN_YES;
3442
3443 XSRETURN_NO;
3444}
3445
3446static
3447XS(w32_GetNextAvailDrive)
3448{
3449 dXSARGS;
3450 char ix = 'C';
3451 char root[] = "_:\\";
3467312b
JD
3452
3453 EXTEND(SP,1);
ad2e33dc
GS
3454 while (ix <= 'Z') {
3455 root[0] = ix++;
3456 if (GetDriveType(root) == 1) {
3457 root[2] = '\0';
3458 XSRETURN_PV(root);
3459 }
3460 }
3467312b 3461 XSRETURN_UNDEF;
ad2e33dc
GS
3462}
3463
3464static
3465XS(w32_GetLastError)
3466{
3467 dXSARGS;
bb897dfc 3468 EXTEND(SP,1);
ad2e33dc
GS
3469 XSRETURN_IV(GetLastError());
3470}
3471
3472static
ca135624
JD
3473XS(w32_SetLastError)
3474{
3475 dXSARGS;
3476 if (items != 1)
4f63d024 3477 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
ca135624 3478 SetLastError(SvIV(ST(0)));
bb897dfc 3479 XSRETURN_EMPTY;
ca135624
JD
3480}
3481
3482static
ad2e33dc
GS
3483XS(w32_LoginName)
3484{
3485 dXSARGS;
3352bfcb
GS
3486 char *name = w32_getlogin_buffer;
3487 DWORD size = sizeof(w32_getlogin_buffer);
3467312b 3488 EXTEND(SP,1);
ad2e33dc
GS
3489 if (GetUserName(name,&size)) {
3490 /* size includes NULL */
79cb57f6 3491 ST(0) = sv_2mortal(newSVpvn(name,size-1));
ad2e33dc
GS
3492 XSRETURN(1);
3493 }
3467312b 3494 XSRETURN_UNDEF;
ad2e33dc
GS
3495}
3496
3497static
3498XS(w32_NodeName)
3499{
3500 dXSARGS;
3501 char name[MAX_COMPUTERNAME_LENGTH+1];
3502 DWORD size = sizeof(name);
3467312b 3503 EXTEND(SP,1);
ad2e33dc
GS
3504 if (GetComputerName(name,&size)) {
3505 /* size does NOT include NULL :-( */
79cb57f6 3506 ST(0) = sv_2mortal(newSVpvn(name,size));
ad2e33dc
GS
3507 XSRETURN(1);
3508 }
3467312b 3509 XSRETURN_UNDEF;
ad2e33dc
GS
3510}
3511
3512
3513static
3514XS(w32_DomainName)
3515{
3516 dXSARGS;
625a29bd
GS
3517 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
3518 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
3519 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
3520 void *bufptr);
3521
3522 if (hNetApi32) {
3523 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
3524 GetProcAddress(hNetApi32, "NetApiBufferFree");
3525 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
3526 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
3527 }
3467312b 3528 EXTEND(SP,1);
625a29bd
GS
3529 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
3530 /* this way is more reliable, in case user has a local account. */
ad2e33dc
GS
3531 char dname[256];
3532 DWORD dnamelen = sizeof(dname);
625a29bd
GS
3533 struct {
3534 DWORD wki100_platform_id;
3535 LPWSTR wki100_computername;
3536 LPWSTR wki100_langroup;
3537 DWORD wki100_ver_major;
3538 DWORD wki100_ver_minor;
3539 } *pwi;
3540 /* NERR_Success *is* 0*/
3541 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
3542 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
3543 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
3544 -1, (LPSTR)dname, dnamelen, NULL, NULL);
3545 }
3546 else {
3547 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
3548 -1, (LPSTR)dname, dnamelen, NULL, NULL);
3549 }
3550 pfnNetApiBufferFree(pwi);
3551 FreeLibrary(hNetApi32);
3552 XSRETURN_PV(dname);
ad2e33dc 3553 }
625a29bd 3554 FreeLibrary(hNetApi32);
ad2e33dc 3555 }
625a29bd
GS
3556 else {
3557 /* Win95 doesn't have NetWksta*(), so do it the old way */
3558 char name[256];
3559 DWORD size = sizeof(name);
3560 if (hNetApi32)
3561 FreeLibrary(hNetApi32);
3562 if (GetUserName(name,&size)) {
7766f137 3563 char sid[ONE_K_BUFSIZE];
625a29bd
GS
3564 DWORD sidlen = sizeof(sid);
3565 char dname[256];
3566 DWORD dnamelen = sizeof(dname);
3567 SID_NAME_USE snu;
3568 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
3569 dname, &dnamelen, &snu)) {
3570 XSRETURN_PV(dname); /* all that for this */
3571 }
0a2408cf 3572 }
9404a519 3573 }
3467312b 3574 XSRETURN_UNDEF;
ad2e33dc
GS
3575}
3576
3577static
3578XS(w32_FsType)
3579{
3580 dXSARGS;
3581 char fsname[256];
3582 DWORD flags, filecomplen;
3583 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
3584 &flags, fsname, sizeof(fsname))) {
bb897dfc 3585 if (GIMME_V == G_ARRAY) {
79cb57f6 3586 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
ad2e33dc
GS
3587 XPUSHs(sv_2mortal(newSViv(flags)));
3588 XPUSHs(sv_2mortal(newSViv(filecomplen)));
3589 PUTBACK;
3590 return;
3591 }
bb897dfc 3592 EXTEND(SP,1);
ad2e33dc
GS
3593 XSRETURN_PV(fsname);
3594 }
bb897dfc 3595 XSRETURN_EMPTY;
ad2e33dc
GS
3596}
3597
3598static
3599XS(w32_GetOSVersion)
3600{
3601 dXSARGS;
7766f137 3602 OSVERSIONINFOA osver;
ad2e33dc 3603
7766f137
GS
3604 if (USING_WIDE()) {
3605 OSVERSIONINFOW osverw;
3606 char szCSDVersion[sizeof(osverw.szCSDVersion)];
3607 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
3608 if (!GetVersionExW(&osverw)) {
3609 XSRETURN_EMPTY;
3610 }
3611 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
3612 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
3613 osver.dwMajorVersion = osverw.dwMajorVersion;
3614 osver.dwMinorVersion = osverw.dwMinorVersion;
3615 osver.dwBuildNumber = osverw.dwBuildNumber;
3616 osver.dwPlatformId = osverw.dwPlatformId;
3617 }
3618 else {
3619 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
3620 if (!GetVersionExA(&osver)) {
3621 XSRETURN_EMPTY;
3622 }
79cb57f6 3623 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
ad2e33dc 3624 }
7766f137
GS
3625 XPUSHs(newSViv(osver.dwMajorVersion));
3626 XPUSHs(newSViv(osver.dwMinorVersion));
3627 XPUSHs(newSViv(osver.dwBuildNumber));
3628 XPUSHs(newSViv(osver.dwPlatformId));
3629 PUTBACK;
ad2e33dc
GS
3630}
3631
3632static
3633XS(w32_IsWinNT)
3634{
3635 dXSARGS;
bb897dfc 3636 EXTEND(SP,1);
ad2e33dc
GS
3637 XSRETURN_IV(IsWinNT());
3638}
3639
3640static
3641XS(w32_IsWin95)
3642{
3643 dXSARGS;
bb897dfc 3644 EXTEND(SP,1);
ad2e33dc
GS
3645 XSRETURN_IV(IsWin95());
3646}
3647
3648static
3649XS(w32_FormatMessage)
3650{
3651 dXSARGS;
3652 DWORD source = 0;
7766f137 3653 char msgbuf[ONE_K_BUFSIZE];
ad2e33dc
GS
3654
3655 if (items != 1)
4f63d024 3656 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
ad2e33dc 3657
7766f137
GS
3658 if (USING_WIDE()) {
3659 WCHAR wmsgbuf[ONE_K_BUFSIZE];
3660 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
3661 &source, SvIV(ST(0)), 0,
3662 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
3663 {
3664 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
3665 XSRETURN_PV(msgbuf);
3666 }
3667 }
3668 else {
3669 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
3670 &source, SvIV(ST(0)), 0,
3671 msgbuf, sizeof(msgbuf)-1, NULL))
3672 XSRETURN_PV(msgbuf);
3673 }
ad2e33dc 3674
3467312b 3675 XSRETURN_UNDEF;
ad2e33dc
GS
3676}
3677
3678static
3679XS(w32_Spawn)
3680{
3681 dXSARGS;
3682 char *cmd, *args;
3683 PROCESS_INFORMATION stProcInfo;
3684 STARTUPINFO stStartInfo;
3685 BOOL bSuccess = FALSE;
3686
9404a519 3687 if (items != 3)
4f63d024 3688 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
ad2e33dc 3689
bb897dfc
JD
3690 cmd = SvPV_nolen(ST(0));
3691 args = SvPV_nolen(ST(1));
ad2e33dc
GS
3692
3693 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
3694 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
3695 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
3696 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
3697
9404a519 3698 if (CreateProcess(
ad2e33dc
GS
3699 cmd, /* Image path */
3700 args, /* Arguments for command line */
3701 NULL, /* Default process security */
3702 NULL, /* Default thread security */
3703 FALSE, /* Must be TRUE to use std handles */
3704 NORMAL_PRIORITY_CLASS, /* No special scheduling */
3705 NULL, /* Inherit our environment block */
3706 NULL, /* Inherit our currrent directory */
3707 &stStartInfo, /* -> Startup info */
3708 &stProcInfo)) /* <- Process info (if OK) */
3709 {
3710 CloseHandle(stProcInfo.hThread);/* library source code does this. */
3711 sv_setiv(ST(2), stProcInfo.dwProcessId);
3712 bSuccess = TRUE;
3713 }
3714 XSRETURN_IV(bSuccess);
3715}
3716
3717static
3718XS(w32_GetTickCount)
3719{
3720 dXSARGS;
fdb068fa 3721 DWORD msec = GetTickCount();
a6c40364 3722 EXTEND(SP,1);
fdb068fa
JD
3723 if ((IV)msec > 0)
3724 XSRETURN_IV(msec);
3725 XSRETURN_NV(msec);
ad2e33dc
GS
3726}
3727
3728static
3729XS(w32_GetShortPathName)
3730{
3731 dXSARGS;
3732 SV *shortpath;
e8bab181 3733 DWORD len;
ad2e33dc 3734
9404a519 3735 if (items != 1)
4f63d024 3736 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
ad2e33dc
GS
3737
3738 shortpath = sv_mortalcopy(ST(0));
3739 SvUPGRADE(shortpath, SVt_PV);
3740 /* src == target is allowed */
e8bab181
GS
3741 do {
3742 len = GetShortPathName(SvPVX(shortpath),
3743 SvPVX(shortpath),
3744 SvLEN(shortpath));
3745 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
3746 if (len) {
3747 SvCUR_set(shortpath,len);
ad2e33dc 3748 ST(0) = shortpath;
bb897dfc 3749 XSRETURN(1);
e8bab181 3750 }
3467312b 3751 XSRETURN_UNDEF;
ad2e33dc
GS
3752}
3753
ad0751ec 3754static
ca135624
JD
3755XS(w32_GetFullPathName)
3756{
3757 dXSARGS;
3758 SV *filename;
3759 SV *fullpath;
3760 char *filepart;
3761 DWORD len;
3762
3763 if (items != 1)
4f63d024 3764 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
ca135624
JD
3765
3766 filename = ST(0);
3767 fullpath = sv_mortalcopy(filename);
3768 SvUPGRADE(fullpath, SVt_PV);
3769 do {
3770 len = GetFullPathName(SvPVX(filename),
3771 SvLEN(fullpath),
3772 SvPVX(fullpath),
3773 &filepart);
3774 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
3775 if (len) {
3776 if (GIMME_V == G_ARRAY) {
3777 EXTEND(SP,1);
bb897dfc 3778 XST_mPV(1,filepart);