This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
EBCDIC: retract #16557, it ran into a weird tokenizer(?) bug.
[perl5.git] / win32 / win32.c
CommitLineData
68dc0745 1/* WIN32.C
2 *
3fadfdf1 3 * (c) 1995 Microsoft Corporation. All rights reserved.
68dc0745 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 */
3fadfdf1 10#define PERLIO_NOT_STDIO 0
0a753a76 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>
f8fb7c90
GS		 18#ifndef __MINGW32__ /* GCC/Mingw32-2.95.2 forgot the WINAPI on CommandLineToArgvW() */
19# include <shellapi.h>
20#else
21 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
22#endif
5db10396
GS		 23#include <winnt.h>
24#include <io.h>
c843839f 25#include <signal.h>
0a753a76 26
68dc0745 27/* #include "config.h" */
0a753a76 28
0a753a76 29#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
30#define PerlIO FILE
31#endif
32
7a9ec5a3 33#include <sys/stat.h>
0a753a76 34#include "EXTERN.h"
35#include "perl.h"
c69f6586
GS		 36
37#define NO_XSLOCKS
c5be433b 38#define PERL_NO_GET_CONTEXT
ad2e33dc 39#include "XSUB.h"
c69f6586
GS		 40
41#include "Win32iop.h"
0a753a76 42#include <fcntl.h>
5b0d9cbe
NIS		 43#ifndef __GNUC__
44/* assert.h conflicts with #define of assert in perl.h */
0a753a76 45#include <assert.h>
5b0d9cbe 46#endif
0a753a76 47#include <string.h>
48#include <stdarg.h>
ad2e33dc 49#include <float.h>
ad0751ec 50#include <time.h>
3730b96e 51#if defined(_MSC_VER) || defined(__MINGW32__)
ad0751ec
GS		 52#include <sys/utime.h>
53#else
54#include <utime.h>
55#endif
5b0d9cbe 56#ifdef __GNUC__
3fadfdf1 57/* Mingw32 defaults to globing command line
5b0d9cbe
NIS		 58 * So we turn it off like this:
59 */
60int _CRT_glob = 0;
61#endif
62
2b260de0 63#if defined(__MINGW32__)
f8fb7c90
GS		 64/* Mingw32 is missing some prototypes */
65FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
66FILE * _wfdopen(int nFd, LPCWSTR wszMode);
67FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
68int _flushall();
69int _fcloseall();
2b260de0
GS		 70#endif
71
72#if defined(__BORLANDC__)
0b94c7bb
GS		 73# define _stat stat
74# define _utimbuf utimbuf
75#endif
76
6890e559
GS		 77#define EXECF_EXEC 1
78#define EXECF_SPAWN 2
79#define EXECF_SPAWN_NOWAIT 3
80
32e30700
GS		 81#if defined(PERL_IMPLICIT_SYS)
82# undef win32_get_privlib
83# define win32_get_privlib g_win32_get_privlib
84# undef win32_get_sitelib
85# define win32_get_sitelib g_win32_get_sitelib
4ea817c6
GS		 86# undef win32_get_vendorlib
87# define win32_get_vendorlib g_win32_get_vendorlib
32e30700
GS		 88# undef do_spawn
89# define do_spawn g_do_spawn
90# undef getlogin
91# define getlogin g_getlogin
92#endif
93
ce1da67e 94static void get_shell(void);
dff6d3cd 95static long tokenize(const char *str, char **dest, char ***destv);
c5be433b 96 int do_spawn2(char *cmd, int exectype);
e200fe59 97static BOOL has_shell_metachars(char *ptr);
2d7a9237 98static long filetime_to_clock(PFILETIME ft);
ad0751ec 99static BOOL filetime_from_time(PFILETIME ft, time_t t);
c5be433b 100static char * get_emd_part(SV **leading, char *trailing, ...);
0aaad0ff
GS		 101static void remove_dead_process(long deceased);
102static long find_pid(int pid);
103static char * qualified_path(const char *cmd);
4ea817c6
GS		 104static char * win32_get_xlib(const char *pl, const char *xlib,
105 const char *libname);
106
7766f137
GS		 107#ifdef USE_ITHREADS
108static void remove_dead_pseudo_process(long child);
109static long find_pseudo_pid(int pid);
110#endif
c69f6586 111
7766f137 112START_EXTERN_C
2d7a9237 113HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
8ac9c18d 114char w32_module_name[MAX_PATH+1];
7766f137
GS		 115END_EXTERN_C
116
4b556e6c 117static DWORD w32_platform = (DWORD)-1;
50892819 118
7766f137
GS		 119#define ONE_K_BUFSIZE 1024
120
3fadfdf1 121int
ba106d47
GS		 122IsWin95(void)
123{
0cb96387 124 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
3fe9a6f1 125}
126
127int
ba106d47
GS		 128IsWinNT(void)
129{
0cb96387 130 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
3fe9a6f1 131}
0a753a76 132
2fa86c13
GS		 133EXTERN_C void
134set_w32_module_name(void)
135{
136 char* ptr;
137 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
138 ? GetModuleHandle(NULL)
139 : w32_perldll_handle),
140 w32_module_name, sizeof(w32_module_name));
141
142 /* try to get full path to binary (which may be mangled when perl is
143 * run from a 16-bit app) */
144 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
145 (void)win32_longpath(w32_module_name);
146 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
147
148 /* normalize to forward slashes */
149 ptr = w32_module_name;
150 while (*ptr) {
151 if (*ptr == '\\')
152 *ptr = '/';
153 ++ptr;
154 }
155}
156
c5be433b 157/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 158static char*
c5be433b 159get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
349ad1fe
GS		 160{
161 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
00dc2f4f
GS		 162 HKEY handle;
163 DWORD type;
164 const char *subkey = "Software\\Perl";
349ad1fe 165 char *str = Nullch;
00dc2f4f
GS		 166 long retval;
167
168 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
349ad1fe 169 if (retval == ERROR_SUCCESS) {
51371543
GS		 170 DWORD datalen;
171 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
1c94caf4
GS		 172 if (retval == ERROR_SUCCESS
173 && (type == REG_SZ || type == REG_EXPAND_SZ))
174 {
acfe0abc 175 dTHX;
c5be433b
GS		 176 if (!*svp)
177 *svp = sv_2mortal(newSVpvn("",0));
178 SvGROW(*svp, datalen);
51371543 179 retval = RegQueryValueEx(handle, valuename, 0, NULL,
c5be433b 180 (PBYTE)SvPVX(*svp), &datalen);
51371543 181 if (retval == ERROR_SUCCESS) {
c5be433b
GS		 182 str = SvPVX(*svp);
183 SvCUR_set(*svp,datalen-1);
51371543 184 }
00dc2f4f
GS		 185 }
186 RegCloseKey(handle);
187 }
349ad1fe 188 return str;
00dc2f4f
GS		 189}
190
c5be433b 191/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
51371543 192static char*
c5be433b 193get_regstr(const char *valuename, SV **svp)
00dc2f4f 194{
c5be433b 195 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
349ad1fe 196 if (!str)
c5be433b 197 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
349ad1fe 198 return str;
00dc2f4f
GS		 199}
200
c5be433b 201/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
e5a95ffb 202static char *
c5be433b 203get_emd_part(SV **prev_pathp, char *trailing_path, ...)
00dc2f4f 204{
dc9e4912 205 char base[10];
e5a95ffb 206 va_list ap;
e24c7c18 207 char mod_name[MAX_PATH+1];
00dc2f4f 208 char *ptr;
e5a95ffb
GS		 209 char *optr;
210 char *strip;
273cf8d1 211 STRLEN baselen;
e5a95ffb
GS		 212
213 va_start(ap, trailing_path);
214 strip = va_arg(ap, char *);
215
273cf8d1
GS		 216 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
217 baselen = strlen(base);
dc9e4912 218
8ac9c18d 219 if (!*w32_module_name) {
2fa86c13 220 set_w32_module_name();
95140b98 221 }
8ac9c18d 222 strcpy(mod_name, w32_module_name);
95140b98 223 ptr = strrchr(mod_name, '/');
e5a95ffb
GS		 224 while (ptr && strip) {
225 /* look for directories to skip back */
226 optr = ptr;
00dc2f4f 227 *ptr = '\0';
95140b98 228 ptr = strrchr(mod_name, '/');
1c39adb2
GS		 229 /* avoid stripping component if there is no slash,
230 * or it doesn't match ... */
e5a95ffb 231 if (!ptr || stricmp(ptr+1, strip) != 0) {
273cf8d1 232 /* ... but not if component matches m|5\.$patchlevel.*| */
1c39adb2 233 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
273cf8d1
GS		 234 && strncmp(strip, base, baselen) == 0
235 && strncmp(ptr+1, base, baselen) == 0))
95140b98
GS		 236 {
237 *optr = '/';
80252599
GS		 238 ptr = optr;
239 }
00dc2f4f 240 }
e5a95ffb 241 strip = va_arg(ap, char *);
00dc2f4f 242 }
e5a95ffb
GS		 243 if (!ptr) {
244 ptr = mod_name;
245 *ptr++ = '.';
95140b98 246 *ptr = '/';
00dc2f4f 247 }
e5a95ffb
GS		 248 va_end(ap);
249 strcpy(++ptr, trailing_path);
250
dc9e4912 251 /* only add directory if it exists */
349ad1fe 252 if (GetFileAttributes(mod_name) != (DWORD) -1) {
dc9e4912 253 /* directory exists */
acfe0abc 254 dTHX;
c5be433b
GS		 255 if (!*prev_pathp)
256 *prev_pathp = sv_2mortal(newSVpvn("",0));
257 sv_catpvn(*prev_pathp, ";", 1);
258 sv_catpv(*prev_pathp, mod_name);
259 return SvPVX(*prev_pathp);
00dc2f4f 260 }
00dc2f4f 261
cf11f4bf 262 return Nullch;
00dc2f4f
GS		 263}
264
265char *
4ea817c6 266win32_get_privlib(const char *pl)
00dc2f4f 267{
acfe0abc 268 dTHX;
e5a95ffb
GS		 269 char *stdlib = "lib";
270 char buffer[MAX_PATH+1];
51371543 271 SV *sv = Nullsv;
00dc2f4f 272
e5a95ffb
GS		 273 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
274 sprintf(buffer, "%s-%s", stdlib, pl);
c5be433b
GS		 275 if (!get_regstr(buffer, &sv))
276 (void)get_regstr(stdlib, &sv);
00dc2f4f 277
e5a95ffb 278 /* $stdlib .= ";$EMD/../../lib" */
c5be433b 279 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
00dc2f4f
GS		 280}
281
4ea817c6
GS		 282static char *
283win32_get_xlib(const char *pl, const char *xlib, const char *libname)
00dc2f4f 284{
acfe0abc 285 dTHX;
e5a95ffb 286 char regstr[40];
e24c7c18 287 char pathstr[MAX_PATH+1];
51371543
GS		 288 SV *sv1 = Nullsv;
289 SV *sv2 = Nullsv;
00dc2f4f 290
4ea817c6
GS		 291 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
292 sprintf(regstr, "%s-%s", xlib, pl);
c5be433b 293 (void)get_regstr(regstr, &sv1);
e5a95ffb 294
4ea817c6
GS		 295 /* $xlib .=
296 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
297 sprintf(pathstr, "%s/%s/lib", libname, pl);
c5be433b 298 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
00dc2f4f 299
4ea817c6
GS		 300 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
301 (void)get_regstr(xlib, &sv2);
00dc2f4f 302
4ea817c6
GS		 303 /* $xlib .=
304 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
305 sprintf(pathstr, "%s/lib", libname);
306 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
e5a95ffb 307
51371543
GS		 308 if (!sv1 && !sv2)
309 return Nullch;
310 if (!sv1)
311 return SvPVX(sv2);
312 if (!sv2)
313 return SvPVX(sv1);
e5a95ffb 314
349ad1fe
GS		 315 sv_catpvn(sv1, ";", 1);
316 sv_catsv(sv1, sv2);
e5a95ffb 317
349ad1fe 318 return SvPVX(sv1);
68dc0745 319}
0a753a76 320
4ea817c6
GS		 321char *
322win32_get_sitelib(const char *pl)
323{
324 return win32_get_xlib(pl, "sitelib", "site");
325}
326
327#ifndef PERL_VENDORLIB_NAME
328# define PERL_VENDORLIB_NAME "vendor"
329#endif
330
331char *
332win32_get_vendorlib(const char *pl)
333{
334 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
335}
b4793f7f 336
2d7a9237 337static BOOL
e200fe59 338has_shell_metachars(char *ptr)
68dc0745 339{
340 int inquote = 0;
341 char quote = '\0';
342
343 /*
344 * Scan string looking for redirection (< or >) or pipe
e200fe59
JD		 345 * characters (|) that are not in a quoted string.
346 * Shell variable interpolation (%VAR%) can also happen inside strings.
68dc0745 347 */
9404a519 348 while (*ptr) {
68dc0745 349 switch(*ptr) {
e200fe59
JD		 350 case '%':
351 return TRUE;
68dc0745 352 case '\'':
353 case '\"':
9404a519
GS		 354 if (inquote) {
355 if (quote == *ptr) {
68dc0745 356 inquote = 0;
357 quote = '\0';
0a753a76 358 }
68dc0745 359 }
360 else {
361 quote = *ptr;
362 inquote++;
363 }
364 break;
365 case '>':
366 case '<':
367 case '|':
9404a519 368 if (!inquote)
68dc0745 369 return TRUE;
370 default:
371 break;
0a753a76 372 }
68dc0745 373 ++ptr;
374 }
375 return FALSE;
0a753a76 376}
377
32e30700 378#if !defined(PERL_IMPLICIT_SYS)
68dc0745 379/* since the current process environment is being updated in util.c
380 * the library functions will get the correct environment
381 */
382PerlIO *
4f63d024 383Perl_my_popen(pTHX_ char *cmd, char *mode)
0a753a76 384{
385#ifdef FIXCMD
7766f137
GS		 386#define fixcmd(x) { \
387 char *pspace = strchr((x),' '); \
388 if (pspace) { \
389 char *p = (x); \
390 while (p < pspace) { \
391 if (*p == '/') \
392 *p = '\\'; \
393 p++; \
394 } \
395 } \
396 }
0a753a76 397#else
398#define fixcmd(x)
399#endif
68dc0745 400 fixcmd(cmd);
45bc9206 401 PERL_FLUSHALL_FOR_CHILD;
0a753a76 402 return win32_popen(cmd, mode);
0a753a76 403}
404
68dc0745 405long
4f63d024 406Perl_my_pclose(pTHX_ PerlIO *fp)
0a753a76 407{
408 return win32_pclose(fp);
409}
c69f6586 410#endif
0a753a76 411
0cb96387
GS		 412DllExport unsigned long
413win32_os_id(void)
0a753a76 414{
8b10511d 415 static OSVERSIONINFO osver;
0a753a76 416
2d7a9237 417 if (osver.dwPlatformId != w32_platform) {
8b10511d
GS		 418 memset(&osver, 0, sizeof(OSVERSIONINFO));
419 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
420 GetVersionEx(&osver);
2d7a9237 421 w32_platform = osver.dwPlatformId;
8b10511d 422 }
0cb96387 423 return (unsigned long)w32_platform;
0a753a76 424}
425
7766f137
GS		 426DllExport int
427win32_getpid(void)
428{
922b1888 429 int pid;
7766f137 430#ifdef USE_ITHREADS
acfe0abc 431 dTHX;
7766f137
GS		 432 if (w32_pseudo_id)
433 return -((int)w32_pseudo_id);
434#endif
922b1888
GS		 435 pid = _getpid();
436 /* Windows 9x appears to always reports a pid for threads and processes
437 * that has the high bit set. So we treat the lower 31 bits as the
438 * "real" PID for Perl's purposes. */
439 if (IsWin95() && pid < 0)
440 pid = -pid;
441 return pid;
7766f137
GS		 442}
443
ce1da67e
GS		 444/* Tokenize a string. Words are null-separated, and the list
445 * ends with a doubled null. Any character (except null and
446 * including backslash) may be escaped by preceding it with a
447 * backslash (the backslash will be stripped).
448 * Returns number of words in result buffer.
449 */
450static long
dff6d3cd 451tokenize(const char *str, char **dest, char ***destv)
ce1da67e
GS		 452{
453 char *retstart = Nullch;
454 char **retvstart = 0;
455 int items = -1;
456 if (str) {
acfe0abc 457 dTHX;
ce1da67e
GS		 458 int slen = strlen(str);
459 register char *ret;
460 register char **retv;
461 New(1307, ret, slen+2, char);
462 New(1308, retv, (slen+3)/2, char*);
463
464 retstart = ret;
465 retvstart = retv;
466 *retv = ret;
467 items = 0;
468 while (*str) {
469 *ret = *str++;
470 if (*ret == '\\' && *str)
471 *ret = *str++;
472 else if (*ret == ' ') {
473 while (*str == ' ')
474 str++;
475 if (ret == retstart)
476 ret--;
477 else {
478 *ret = '\0';
479 ++items;
480 if (*str)
481 *++retv = ret+1;
482 }
483 }
484 else if (!*str)
485 ++items;
486 ret++;
487 }
488 retvstart[items] = Nullch;
489 *ret++ = '\0';
490 *ret = '\0';
491 }
492 *dest = retstart;
493 *destv = retvstart;
494 return items;
495}
496
497static void
2d7a9237 498get_shell(void)
0a753a76 499{
acfe0abc 500 dTHX;
ce1da67e 501 if (!w32_perlshell_tokens) {
174c211a
GS		 502 /* we don't use COMSPEC here for two reasons:
503 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
504 * uncontrolled unportability of the ensuing scripts.
505 * 2. PERL5SHELL could be set to a shell that may not be fit for
506 * interactive use (which is what most programs look in COMSPEC
507 * for).
508 */
dff6d3cd
GS		 509 const char* defaultshell = (IsWinNT()
510 ? "cmd.exe /x/c" : "command.com /c");
2fb9ab56 511 const char *usershell = PerlEnv_getenv("PERL5SHELL");
ce1da67e
GS		 512 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
513 &w32_perlshell_tokens,
514 &w32_perlshell_vec);
68dc0745 515 }
0a753a76 516}
517
68dc0745 518int
c5be433b 519do_aspawn(void *vreally, void **vmark, void **vsp)
0a753a76 520{
acfe0abc 521 dTHX;
2d7a9237
GS		 522 SV *really = (SV*)vreally;
523 SV **mark = (SV**)vmark;
524 SV **sp = (SV**)vsp;
68dc0745 525 char **argv;
2d7a9237 526 char *str;
68dc0745 527 int status;
2d7a9237 528 int flag = P_WAIT;
68dc0745 529 int index = 0;
68dc0745 530
2d7a9237
GS		 531 if (sp <= mark)
532 return -1;
68dc0745 533
ce1da67e
GS		 534 get_shell();
535 New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*);
2d7a9237
GS		 536
537 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
538 ++mark;
539 flag = SvIVx(*mark);
68dc0745 540 }
541
9404a519 542 while (++mark <= sp) {
bb897dfc 543 if (*mark && (str = SvPV_nolen(*mark)))
2d7a9237
GS		 544 argv[index++] = str;
545 else
546 argv[index++] = "";
68dc0745 547 }
548 argv[index++] = 0;
3fadfdf1 549
2d7a9237 550 status = win32_spawnvp(flag,
bb897dfc 551 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS		 552 (const char* const*)argv);
553
80252599 554 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
2d7a9237 555 /* possible shell-builtin, invoke with shell */
ce1da67e
GS		 556 int sh_items;
557 sh_items = w32_perlshell_items;
2d7a9237
GS		 558 while (--index >= 0)
559 argv[index+sh_items] = argv[index];
ce1da67e
GS		 560 while (--sh_items >= 0)
561 argv[sh_items] = w32_perlshell_vec[sh_items];
3fadfdf1 562
2d7a9237 563 status = win32_spawnvp(flag,
bb897dfc 564 (const char*)(really ? SvPV_nolen(really) : argv[0]),
2d7a9237
GS		 565 (const char* const*)argv);
566 }
68dc0745 567
922b1888
GS		 568 if (flag == P_NOWAIT) {
569 if (IsWin95())
570 PL_statusvalue = -1; /* >16bits hint for pp_system() */
571 }
572 else {
50892819 573 if (status < 0) {
0453d815 574 if (ckWARN(WARN_EXEC))
f98bc0c6 575 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
50892819
GS		 576 status = 255 * 256;
577 }
578 else
579 status *= 256;
b28d0864 580 PL_statusvalue = status;
5aabfad6 581 }
ce1da67e 582 Safefree(argv);
50892819 583 return (status);
68dc0745 584}
585
dd7038b3
JH		 586/* returns pointer to the next unquoted space or the end of the string */
587static char*
588find_next_space(const char *s)
589{
590 bool in_quotes = FALSE;
591 while (*s) {
592 /* ignore doubled backslashes, or backslash+quote */
593 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
594 s += 2;
595 }
596 /* keep track of when we're within quotes */
597 else if (*s == '"') {
598 s++;
599 in_quotes = !in_quotes;
600 }
601 /* break it up only at spaces that aren't in quotes */
602 else if (!in_quotes && isSPACE(*s))
603 return (char*)s;
604 else
605 s++;
606 }
607 return (char*)s;
608}
609
c69f6586 610int
c5be433b 611do_spawn2(char *cmd, int exectype)
68dc0745 612{
acfe0abc 613 dTHX;
68dc0745 614 char **a;
615 char *s;
616 char **argv;
617 int status = -1;
618 BOOL needToTry = TRUE;
2d7a9237 619 char *cmd2;
68dc0745 620
2d7a9237
GS		 621 /* Save an extra exec if possible. See if there are shell
622 * metacharacters in it */
e200fe59 623 if (!has_shell_metachars(cmd)) {
fc36a67e 624 New(1301,argv, strlen(cmd) / 2 + 2, char*);
625 New(1302,cmd2, strlen(cmd) + 1, char);
68dc0745 626 strcpy(cmd2, cmd);
627 a = argv;
628 for (s = cmd2; *s;) {
de030af3 629 while (*s && isSPACE(*s))
68dc0745 630 s++;
631 if (*s)
632 *(a++) = s;
dd7038b3 633 s = find_next_space(s);
9404a519 634 if (*s)
68dc0745 635 *s++ = '\0';
0a753a76 636 }
68dc0745 637 *a = Nullch;
ce1da67e 638 if (argv[0]) {
6890e559
GS		 639 switch (exectype) {
640 case EXECF_SPAWN:
641 status = win32_spawnvp(P_WAIT, argv[0],
642 (const char* const*)argv);
643 break;
644 case EXECF_SPAWN_NOWAIT:
645 status = win32_spawnvp(P_NOWAIT, argv[0],
646 (const char* const*)argv);
647 break;
648 case EXECF_EXEC:
649 status = win32_execvp(argv[0], (const char* const*)argv);
650 break;
651 }
2d7a9237 652 if (status != -1 || errno == 0)
68dc0745 653 needToTry = FALSE;
0a753a76 654 }
0a753a76 655 Safefree(argv);
68dc0745 656 Safefree(cmd2);
657 }
2d7a9237 658 if (needToTry) {
ce1da67e
GS		 659 char **argv;
660 int i = -1;
661 get_shell();
662 New(1306, argv, w32_perlshell_items + 2, char*);
663 while (++i < w32_perlshell_items)
664 argv[i] = w32_perlshell_vec[i];
2d7a9237
GS		 665 argv[i++] = cmd;
666 argv[i] = Nullch;
6890e559
GS		 667 switch (exectype) {
668 case EXECF_SPAWN:
669 status = win32_spawnvp(P_WAIT, argv[0],
670 (const char* const*)argv);
671 break;
672 case EXECF_SPAWN_NOWAIT:
673 status = win32_spawnvp(P_NOWAIT, argv[0],
674 (const char* const*)argv);
675 break;
676 case EXECF_EXEC:
677 status = win32_execvp(argv[0], (const char* const*)argv);
678 break;
679 }
ce1da67e
GS		 680 cmd = argv[0];
681 Safefree(argv);
68dc0745 682 }
922b1888
GS		 683 if (exectype == EXECF_SPAWN_NOWAIT) {
684 if (IsWin95())
685 PL_statusvalue = -1; /* >16bits hint for pp_system() */
686 }
687 else {
50892819 688 if (status < 0) {
0453d815 689 if (ckWARN(WARN_EXEC))
f98bc0c6 690 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
50892819
GS		 691 (exectype == EXECF_EXEC ? "exec" : "spawn"),
692 cmd, strerror(errno));
693 status = 255 * 256;
694 }
695 else
696 status *= 256;
b28d0864 697 PL_statusvalue = status;
5aabfad6 698 }
50892819 699 return (status);
0a753a76 700}
701
6890e559 702int
c5be433b 703do_spawn(char *cmd)
6890e559 704{
c5be433b 705 return do_spawn2(cmd, EXECF_SPAWN);
6890e559
GS		 706}
707
2d7a9237 708int
c5be433b 709do_spawn_nowait(char *cmd)
2d7a9237 710{
c5be433b 711 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
2d7a9237
GS		 712}
713
6890e559 714bool
4f63d024 715Perl_do_exec(pTHX_ char *cmd)
6890e559 716{
c5be433b 717 do_spawn2(cmd, EXECF_EXEC);
6890e559
GS		 718 return FALSE;
719}
720
68dc0745 721/* The idea here is to read all the directory names into a string table
722 * (separated by nulls) and when one of the other dir functions is called
723 * return the pointer to the current file name.
724 */
c5be433b 725DllExport DIR *
ce2e26e5 726win32_opendir(char *filename)
0a753a76 727{
acfe0abc 728 dTHX;
95136add 729 DIR *dirp;
9404a519
GS		 730 long len;
731 long idx;
732 char scanname[MAX_PATH+3];
c623ac67 733 Stat_t sbuf;
7fac1903
GS		 734 WIN32_FIND_DATAA aFindData;
735 WIN32_FIND_DATAW wFindData;
9404a519 736 HANDLE fh;
7fac1903 737 char buffer[MAX_PATH*2];
82867ecf 738 WCHAR wbuffer[MAX_PATH+1];
95136add 739 char* ptr;
9404a519
GS		 740
741 len = strlen(filename);
742 if (len > MAX_PATH)
743 return NULL;
68dc0745 744
745 /* check to see if filename is a directory */
69d3ab13 746 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
24caa93f 747 return NULL;
68dc0745 748
68dc0745 749 /* Get us a DIR structure */
95136add 750 Newz(1303, dirp, 1, DIR);
68dc0745 751
752 /* Create the search pattern */
753 strcpy(scanname, filename);
23db2e2d
GS		 754
755 /* bare drive name means look in cwd for drive */
756 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
757 scanname[len++] = '.';
758 scanname[len++] = '/';
759 }
760 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
9404a519 761 scanname[len++] = '/';
23db2e2d 762 }
9404a519
GS		 763 scanname[len++] = '*';
764 scanname[len] = '\0';
68dc0745 765
766 /* do the FindFirstFile call */
7fac1903 767 if (USING_WIDE()) {
0cb96387 768 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
7766f137 769 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
7fac1903
GS		 770 }
771 else {
7766f137 772 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
7fac1903 773 }
95136add 774 dirp->handle = fh;
9404a519 775 if (fh == INVALID_HANDLE_VALUE) {
95136add 776 DWORD err = GetLastError();
21e72512 777 /* FindFirstFile() fails on empty drives! */
95136add
GS		 778 switch (err) {
779 case ERROR_FILE_NOT_FOUND:
780 return dirp;
781 case ERROR_NO_MORE_FILES:
782 case ERROR_PATH_NOT_FOUND:
783 errno = ENOENT;
784 break;
785 case ERROR_NOT_ENOUGH_MEMORY:
786 errno = ENOMEM;
787 break;
788 default:
789 errno = EINVAL;
790 break;
791 }
792 Safefree(dirp);
68dc0745 793 return NULL;
794 }
795
796 /* now allocate the first part of the string table for
797 * the filenames that we find.
798 */
7fac1903 799 if (USING_WIDE()) {
0cb96387 800 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
7fac1903
GS		 801 ptr = buffer;
802 }
803 else {
804 ptr = aFindData.cFileName;
805 }
806 idx = strlen(ptr)+1;
95136add
GS		 807 if (idx < 256)
808 dirp->size = 128;
809 else
810 dirp->size = idx;
811 New(1304, dirp->start, dirp->size, char);
812 strcpy(dirp->start, ptr);
813 dirp->nfiles++;
814 dirp->end = dirp->curr = dirp->start;
815 dirp->end += idx;
816 return dirp;
0a753a76 817}
818
819
68dc0745 820/* Readdir just returns the current string pointer and bumps the
821 * string pointer to the nDllExport entry.
822 */
c5be433b 823DllExport struct direct *
ce2e26e5 824win32_readdir(DIR *dirp)
0a753a76 825{
95136add 826 long len;
0a753a76 827
68dc0745 828 if (dirp->curr) {
829 /* first set up the structure to return */
830 len = strlen(dirp->curr);
0f38926b 831 strcpy(dirp->dirstr.d_name, dirp->curr);
68dc0745 832 dirp->dirstr.d_namlen = len;
0a753a76 833
68dc0745 834 /* Fake an inode */
0f38926b 835 dirp->dirstr.d_ino = dirp->curr - dirp->start;
0a753a76 836
95136add 837 /* Now set up for the next call to readdir */
68dc0745 838 dirp->curr += len + 1;
95136add 839 if (dirp->curr >= dirp->end) {
acfe0abc 840 dTHX;
95136add
GS		 841 char* ptr;
842 BOOL res;
843 WIN32_FIND_DATAW wFindData;
844 WIN32_FIND_DATAA aFindData;
845 char buffer[MAX_PATH*2];
846
847 /* finding the next file that matches the wildcard
848 * (which should be all of them in this directory!).
95136add
GS		 849 */
850 if (USING_WIDE()) {
851 res = FindNextFileW(dirp->handle, &wFindData);
852 if (res) {
853 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
854 ptr = buffer;
855 }
856 }
857 else {
858 res = FindNextFileA(dirp->handle, &aFindData);
859 if (res)
860 ptr = aFindData.cFileName;
861 }
862 if (res) {
0f38926b
GS		 863 long endpos = dirp->end - dirp->start;
864 long newsize = endpos + strlen(ptr) + 1;
95136add 865 /* bump the string table size by enough for the
022735b4 866 * new name and its null terminator */
0f38926b
GS		 867 while (newsize > dirp->size) {
868 long curpos = dirp->curr - dirp->start;
95136add
GS		 869 dirp->size *= 2;
870 Renew(dirp->start, dirp->size, char);
0f38926b 871 dirp->curr = dirp->start + curpos;
95136add 872 }
0f38926b
GS		 873 strcpy(dirp->start + endpos, ptr);
874 dirp->end = dirp->start + newsize;
95136add
GS		 875 dirp->nfiles++;
876 }
877 else
878 dirp->curr = NULL;
68dc0745 879 }
68dc0745 880 return &(dirp->dirstr);
3fadfdf1 881 }
68dc0745 882 else
883 return NULL;
0a753a76 884}
885
68dc0745 886/* Telldir returns the current string pointer position */
c5be433b 887DllExport long
ce2e26e5 888win32_telldir(DIR *dirp)
0a753a76 889{
95136add 890 return (dirp->curr - dirp->start);
0a753a76 891}
892
893
68dc0745 894/* Seekdir moves the string pointer to a previously saved position
95136add 895 * (returned by telldir).
68dc0745 896 */
c5be433b 897DllExport void
ce2e26e5 898win32_seekdir(DIR *dirp, long loc)
0a753a76 899{
95136add 900 dirp->curr = dirp->start + loc;
0a753a76 901}
902
68dc0745 903/* Rewinddir resets the string pointer to the start */
c5be433b 904DllExport void
ce2e26e5 905win32_rewinddir(DIR *dirp)
0a753a76 906{
907 dirp->curr = dirp->start;
908}
909
68dc0745 910/* free the memory allocated by opendir */
c5be433b 911DllExport int
ce2e26e5 912win32_closedir(DIR *dirp)
0a753a76 913{
acfe0abc 914 dTHX;
95136add 915 if (dirp->handle != INVALID_HANDLE_VALUE)
0f38926b 916 FindClose(dirp->handle);
0a753a76 917 Safefree(dirp->start);
918 Safefree(dirp);
68dc0745 919 return 1;
0a753a76 920}
921
922
68dc0745 923/*
924 * various stubs
925 */
0a753a76 926
927
68dc0745 928/* Ownership
929 *
930 * Just pretend that everyone is a superuser. NT will let us know if
931 * we don\'t really have permission to do something.
932 */
0a753a76 933
934#define ROOT_UID ((uid_t)0)
935#define ROOT_GID ((gid_t)0)
936
68dc0745 937uid_t
938getuid(void)
0a753a76 939{
68dc0745 940 return ROOT_UID;
0a753a76 941}
942
68dc0745 943uid_t
944geteuid(void)
0a753a76 945{
68dc0745 946 return ROOT_UID;
0a753a76 947}
948
68dc0745 949gid_t
950getgid(void)
0a753a76 951{
68dc0745 952 return ROOT_GID;
0a753a76 953}
954
68dc0745 955gid_t
956getegid(void)
0a753a76 957{
68dc0745 958 return ROOT_GID;
0a753a76 959}
960
68dc0745 961int
22239a37 962setuid(uid_t auid)
3fadfdf1 963{
22239a37 964 return (auid == ROOT_UID ? 0 : -1);
0a753a76 965}
966
68dc0745 967int
22239a37 968setgid(gid_t agid)
0a753a76 969{
22239a37 970 return (agid == ROOT_GID ? 0 : -1);
0a753a76 971}
972
e34ffe5a
GS		 973char *
974getlogin(void)
975{
acfe0abc 976 dTHX;
3352bfcb
GS		 977 char *buf = w32_getlogin_buffer;
978 DWORD size = sizeof(w32_getlogin_buffer);
e34ffe5a
GS		 979 if (GetUserName(buf,&size))
980 return buf;
981 return (char*)NULL;
982}
983
b990f8c8
GS		 984int
985chown(const char *path, uid_t owner, gid_t group)
986{
987 /* XXX noop */
1c1c7f20 988 return 0;
b990f8c8
GS		 989}
990
00b02797
JH		 991/*
992 * XXX this needs strengthening (for PerlIO)
993 * -- BKS, 11-11-200
994*/
995int mkstemp(const char *path)
996{
997 dTHX;
998 char buf[MAX_PATH+1];
999 int i = 0, fd = -1;
1000
1001retry:
1002 if (i++ > 10) { /* give up */
1003 errno = ENOENT;
1004 return -1;
1005 }
1006 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1007 errno = ENOENT;
1008 return -1;
1009 }
1010 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1011 if (fd == -1)
1012 goto retry;
1013 return fd;
1014}
1015
0aaad0ff
GS		 1016static long
1017find_pid(int pid)
0a753a76 1018{
acfe0abc 1019 dTHX;
7766f137
GS		 1020 long child = w32_num_children;
1021 while (--child >= 0) {
eb160463 1022 if ((int)w32_child_pids[child] == pid)
0aaad0ff
GS		 1023 return child;
1024 }
1025 return -1;
1026}
1027
1028static void
1029remove_dead_process(long child)
1030{
1031 if (child >= 0) {
acfe0abc 1032 dTHX;
0aaad0ff 1033 CloseHandle(w32_child_handles[child]);
c00206c8 1034 Move(&w32_child_handles[child+1], &w32_child_handles[child],
0aaad0ff 1035 (w32_num_children-child-1), HANDLE);
c00206c8 1036 Move(&w32_child_pids[child+1], &w32_child_pids[child],
0aaad0ff
GS		 1037 (w32_num_children-child-1), DWORD);
1038 w32_num_children--;
f55ee38a 1039 }
f55ee38a
GS		 1040}
1041
7766f137
GS		 1042#ifdef USE_ITHREADS
1043static long
1044find_pseudo_pid(int pid)
1045{
acfe0abc 1046 dTHX;
7766f137
GS		 1047 long child = w32_num_pseudo_children;
1048 while (--child >= 0) {
eb160463 1049 if ((int)w32_pseudo_child_pids[child] == pid)
7766f137
GS		 1050 return child;
1051 }
1052 return -1;
1053}
1054
1055static void
1056remove_dead_pseudo_process(long child)
1057{
1058 if (child >= 0) {
acfe0abc 1059 dTHX;
7766f137 1060 CloseHandle(w32_pseudo_child_handles[child]);
c00206c8 1061 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
7766f137 1062 (w32_num_pseudo_children-child-1), HANDLE);
c00206c8 1063 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
7766f137
GS		 1064 (w32_num_pseudo_children-child-1), DWORD);
1065 w32_num_pseudo_children--;
1066 }
1067}
1068#endif
1069
f55ee38a
GS		 1070DllExport int
1071win32_kill(int pid, int sig)
1072{
acfe0abc 1073 dTHX;
0aaad0ff 1074 HANDLE hProcess;
c66b022d 1075 long child;
7766f137
GS		 1076#ifdef USE_ITHREADS
1077 if (pid < 0) {
1078 /* it is a pseudo-forked child */
c66b022d 1079 child = find_pseudo_pid(-pid);
7766f137
GS		 1080 if (child >= 0) {
1081 hProcess = w32_pseudo_child_handles[child];
7e5f34c0
NIS		 1082 switch (sig) {
1083 case 0:
c843839f 1084 /* "Does process exist?" use of kill */
7766f137 1085 return 0;
7e5f34c0
NIS		 1086 case 9:
1087 /* kill -9 style un-graceful exit */
1088 if (TerminateThread(hProcess, sig)) {
1089 remove_dead_pseudo_process(child);
1090 return 0;
1091 }
1092 break;
1093 default:
fb6be350
NK		 1094 /* We fake signals to pseudo-processes using Win32
1095 * message queue. In Win9X the pids are negative already. */
1096 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
3fadfdf1 1097 /* It might be us ... */
7e5f34c0
NIS		 1098 PERL_ASYNC_CHECK();
1099 return 0;
1100 }
1101 break;
1102 }
7766f137 1103 }
922b1888
GS		 1104 else if (IsWin95()) {
1105 pid = -pid;
1106 goto alien_process;
1107 }
68dc0745 1108 }
7766f137
GS		 1109 else
1110#endif
1111 {
c66b022d 1112 child = find_pid(pid);
7766f137 1113 if (child >= 0) {
7e5f34c0
NIS		 1114 hProcess = w32_child_handles[child];
1115 switch(sig) {
1116 case 0:
c843839f 1117 /* "Does process exist?" use of kill */
7766f137 1118 return 0;
7e5f34c0
NIS		 1119 case 2:
1120 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1121 return 0;
1122 break;
c843839f 1123 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS		 1124 case 9:
1125 if (TerminateProcess(hProcess, sig)) {
1126 remove_dead_process(child);
1127 return 0;
1128 }
1129 break;
1130 }
7766f137
GS		 1131 }
1132 else {
922b1888
GS		 1133alien_process:
1134 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1135 (IsWin95() ? -pid : pid));
42b8b86c 1136 if (hProcess) {
7e5f34c0
NIS		 1137 switch(sig) {
1138 case 0:
c843839f 1139 /* "Does process exist?" use of kill */
42b8b86c 1140 return 0;
7e5f34c0
NIS		 1141 case 2:
1142 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1143 return 0;
1144 break;
c843839f 1145 default: /* For now be backwards compatible with perl5.6 */
7e5f34c0
NIS		 1146 case 9:
1147 if (TerminateProcess(hProcess, sig)) {
1148 CloseHandle(hProcess);
1149 return 0;
1150 }
42b8b86c 1151 }
7766f137
GS		 1152 }
1153 }
1154 }
1155 errno = EINVAL;
1156 return -1;
0a753a76 1157}
fbbbcc48 1158
68dc0745 1159DllExport int
c623ac67 1160win32_stat(const char *path, Stat_t *sbuf)
0a753a76 1161{
acfe0abc 1162 dTHX;
3fadfdf1 1163 char buffer[MAX_PATH+1];
68dc0745 1164 int l = strlen(path);
67fbe06e 1165 int res;
82867ecf 1166 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1167 WCHAR* pwbuffer;
6b980173
JD		 1168 HANDLE handle;
1169 int nlink = 1;
0a753a76 1170
68dc0745 1171 if (l > 1) {
1172 switch(path[l - 1]) {
e1dbac94
GS		 1173 /* FindFirstFile() and stat() are buggy with a trailing
1174 * backslash, so change it to a forward slash :-( */
68dc0745 1175 case '\\':
426c1a18
GS		 1176 strncpy(buffer, path, l-1);
1177 buffer[l - 1] = '/';
1178 buffer[l] = '\0';
1179 path = buffer;
e1dbac94 1180 break;
23db2e2d 1181 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
e1dbac94
GS		 1182 case ':':
1183 if (l == 2 && isALPHA(path[0])) {
426c1a18
GS		 1184 buffer[0] = path[0];
1185 buffer[1] = ':';
1186 buffer[2] = '.';
1187 buffer[3] = '\0';
e1dbac94 1188 l = 3;
426c1a18 1189 path = buffer;
e1dbac94
GS		 1190 }
1191 break;
68dc0745 1192 }
1193 }
6b980173
JD		 1194
1195 /* We *must* open & close the file once; otherwise file attribute changes */
1196 /* might not yet have propagated to "other" hard links of the same file. */
1197 /* This also gives us an opportunity to determine the number of links. */
7fac1903 1198 if (USING_WIDE()) {
0cb96387 1199 A2WHELPER(path, wbuffer, sizeof(wbuffer));
e9ff6d27
GS		 1200 pwbuffer = PerlDir_mapW(wbuffer);
1201 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
7fac1903
GS		 1202 }
1203 else {
e9ff6d27
GS		 1204 path = PerlDir_mapA(path);
1205 l = strlen(path);
1206 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
6b980173
JD		 1207 }
1208 if (handle != INVALID_HANDLE_VALUE) {
1209 BY_HANDLE_FILE_INFORMATION bhi;
1210 if (GetFileInformationByHandle(handle, &bhi))
1211 nlink = bhi.nNumberOfLinks;
1212 CloseHandle(handle);
7fac1903 1213 }
6b980173 1214
e9ff6d27 1215 /* pwbuffer or path will be mapped correctly above */
7766f137 1216 if (USING_WIDE()) {
c623ac67
GS		 1217#if defined(WIN64) || defined(USE_LARGE_FILES)
1218 res = _wstati64(pwbuffer, sbuf);
1219#else
eb160463 1220 res = _wstat(pwbuffer, (struct _stat*)sbuf);
c623ac67 1221#endif
7766f137
GS		 1222 }
1223 else {
c623ac67
GS		 1224#if defined(WIN64) || defined(USE_LARGE_FILES)
1225 res = _stati64(path, sbuf);
1226#else
e9ff6d27 1227 res = stat(path, sbuf);
c623ac67 1228#endif
7766f137 1229 }
426c1a18 1230 sbuf->st_nlink = nlink;
6b980173 1231
24caa93f
GS		 1232 if (res < 0) {
1233 /* CRT is buggy on sharenames, so make sure it really isn't.
1234 * XXX using GetFileAttributesEx() will enable us to set
426c1a18 1235 * sbuf->st_*time (but note that's not available on the
24caa93f 1236 * Windows of 1995) */
7fac1903
GS		 1237 DWORD r;
1238 if (USING_WIDE()) {
e9ff6d27 1239 r = GetFileAttributesW(pwbuffer);
7fac1903
GS		 1240 }
1241 else {
e9ff6d27 1242 r = GetFileAttributesA(path);
7fac1903 1243 }
24caa93f 1244 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
426c1a18 1245 /* sbuf may still contain old garbage since stat() failed */
c623ac67 1246 Zero(sbuf, 1, Stat_t);
426c1a18 1247 sbuf->st_mode = S_IFDIR | S_IREAD;
24caa93f
GS		 1248 errno = 0;
1249 if (!(r & FILE_ATTRIBUTE_READONLY))
426c1a18 1250 sbuf->st_mode |= S_IWRITE | S_IEXEC;
24caa93f
GS		 1251 return 0;
1252 }
1253 }
24caa93f 1254 else {
e1dbac94
GS		 1255 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1256 && (path[2] == '\\' || path[2] == '/'))
2293b0e9
AB		 1257 {
1258 /* The drive can be inaccessible, some _stat()s are buggy */
7fac1903 1259 if (USING_WIDE()
e9ff6d27
GS		 1260 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1261 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
2293b0e9
AB		 1262 errno = ENOENT;
1263 return -1;
1264 }
1265 }
1266#ifdef __BORLANDC__
426c1a18
GS		 1267 if (S_ISDIR(sbuf->st_mode))
1268 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1269 else if (S_ISREG(sbuf->st_mode)) {
d0650a05 1270 int perms;
67fbe06e
GS		 1271 if (l >= 4 && path[l-4] == '.') {
1272 const char *e = path + l - 3;
1273 if (strnicmp(e,"exe",3)
1274 && strnicmp(e,"bat",3)
1275 && strnicmp(e,"com",3)
1276 && (IsWin95() || strnicmp(e,"cmd",3)))
426c1a18 1277 sbuf->st_mode &= ~S_IEXEC;
67fbe06e 1278 else
426c1a18 1279 sbuf->st_mode |= S_IEXEC;
67fbe06e
GS		 1280 }
1281 else
426c1a18 1282 sbuf->st_mode &= ~S_IEXEC;
d0650a05
GS		 1283 /* Propagate permissions to _group_ and _others_ */
1284 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1285 sbuf->st_mode |= (perms>>3) | (perms>>6);
67fbe06e 1286 }
67fbe06e 1287#endif
2293b0e9 1288 }
67fbe06e 1289 return res;
0a753a76 1290}
1291
bb27e7b6
JH		 1292#define isSLASH(c) ((c) == '/' || (c) == '\\')
1293#define SKIP_SLASHES(s) \
1294 STMT_START { \
1295 while (*(s) && isSLASH(*(s))) \
1296 ++(s); \
1297 } STMT_END
1298#define COPY_NONSLASHES(d,s) \
1299 STMT_START { \
1300 while (*(s) && !isSLASH(*(s))) \
1301 *(d)++ = *(s)++; \
1302 } STMT_END
1303
8ac9c18d
GS		 1304/* Find the longname of a given path. path is destructively modified.
1305 * It should have space for at least MAX_PATH characters. */
1306DllExport char *
1307win32_longpath(char *path)
1308{
1309 WIN32_FIND_DATA fdata;
1310 HANDLE fhand;
1311 char tmpbuf[MAX_PATH+1];
1312 char *tmpstart = tmpbuf;
1313 char *start = path;
1314 char sep;
1315 if (!path)
1316 return Nullch;
1317
1318 /* drive prefix */
bb27e7b6 1319 if (isALPHA(path[0]) && path[1] == ':') {
8ac9c18d
GS		 1320 start = path + 2;
1321 *tmpstart++ = path[0];
1322 *tmpstart++ = ':';
1323 }
1324 /* UNC prefix */
bb27e7b6 1325 else if (isSLASH(path[0]) && isSLASH(path[1])) {
8ac9c18d 1326 start = path + 2;
52fcf7ee
GS		 1327 *tmpstart++ = path[0];
1328 *tmpstart++ = path[1];
bb27e7b6
JH		 1329 SKIP_SLASHES(start);
1330 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
8ac9c18d 1331 if (*start) {
bb27e7b6
JH		 1332 *tmpstart++ = *start++;
1333 SKIP_SLASHES(start);
1334 COPY_NONSLASHES(tmpstart,start); /* copy share name */
8ac9c18d
GS		 1335 }
1336 }
8ac9c18d 1337 *tmpstart = '\0';
bb27e7b6
JH		 1338 while (*start) {
1339 /* copy initial slash, if any */
1340 if (isSLASH(*start)) {
1341 *tmpstart++ = *start++;
1342 *tmpstart = '\0';
1343 SKIP_SLASHES(start);
1344 }
1345
1346 /* FindFirstFile() expands "." and "..", so we need to pass
1347 * those through unmolested */
1348 if (*start == '.'
1349 && (!start[1] || isSLASH(start[1])
1350 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1351 {
1352 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1353 *tmpstart = '\0';
1354 continue;
1355 }
1356
1357 /* if this is the end, bust outta here */
1358 if (!*start)
1359 break;
8ac9c18d 1360
bb27e7b6
JH		 1361 /* now we're at a non-slash; walk up to next slash */
1362 while (*start && !isSLASH(*start))
8ac9c18d 1363 ++start;
8ac9c18d
GS		 1364
1365 /* stop and find full name of component */
bb27e7b6 1366 sep = *start;
8ac9c18d
GS		 1367 *start = '\0';
1368 fhand = FindFirstFile(path,&fdata);
bb27e7b6 1369 *start = sep;
8ac9c18d 1370 if (fhand != INVALID_HANDLE_VALUE) {
bb27e7b6
JH		 1371 STRLEN len = strlen(fdata.cFileName);
1372 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1373 strcpy(tmpstart, fdata.cFileName);
1374 tmpstart += len;
1375 FindClose(fhand);
1376 }
1377 else {
1378 FindClose(fhand);
1379 errno = ERANGE;
1380 return Nullch;
1381 }
8ac9c18d
GS		 1382 }
1383 else {
1384 /* failed a step, just return without side effects */
bf49b057 1385 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
bb27e7b6 1386 errno = EINVAL;
8ac9c18d
GS		 1387 return Nullch;
1388 }
1389 }
1390 strcpy(path,tmpbuf);
1391 return path;
1392}
1393
0551aaa8
GS		 1394DllExport char *
1395win32_getenv(const char *name)
1396{
acfe0abc 1397 dTHX;
82867ecf 1398 WCHAR wBuffer[MAX_PATH+1];
0551aaa8 1399 DWORD needlen;
51371543 1400 SV *curitem = Nullsv;
58a50f62 1401
7fac1903 1402 if (USING_WIDE()) {
0cb96387 1403 A2WHELPER(name, wBuffer, sizeof(wBuffer));
51371543 1404 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
7fac1903
GS		 1405 }
1406 else
51371543 1407 needlen = GetEnvironmentVariableA(name,NULL,0);
58a50f62 1408 if (needlen != 0) {
51371543 1409 curitem = sv_2mortal(newSVpvn("", 0));
7fac1903 1410 if (USING_WIDE()) {
51371543
GS		 1411 SV *acuritem;
1412 do {
1413 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1414 needlen = GetEnvironmentVariableW(wBuffer,
1415 (WCHAR*)SvPVX(curitem),
1416 needlen);
1417 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
c5be433b 1418 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
51371543
GS		 1419 acuritem = sv_2mortal(newSVsv(curitem));
1420 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
7fac1903
GS		 1421 }
1422 else {
51371543
GS		 1423 do {
1424 SvGROW(curitem, needlen+1);
1425 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1426 needlen);
1427 } while (needlen >= SvLEN(curitem));
1428 SvCUR_set(curitem, needlen);
58a50f62 1429 }
0551aaa8 1430 }
c934e9d4 1431 else {
7a5f8e82 1432 /* allow any environment variables that begin with 'PERL'
c934e9d4 1433 to be stored in the registry */
51371543 1434 if (strncmp(name, "PERL", 4) == 0)
c5be433b 1435 (void)get_regstr(name, &curitem);
c69f6586 1436 }
51371543
GS		 1437 if (curitem && SvCUR(curitem))
1438 return SvPVX(curitem);
58a50f62 1439
51371543 1440 return Nullch;
0551aaa8
GS		 1441}
1442
ac5c734f
GS		 1443DllExport int
1444win32_putenv(const char *name)
1445{
acfe0abc 1446 dTHX;
ac5c734f
GS		 1447 char* curitem;
1448 char* val;
7fac1903
GS		 1449 WCHAR* wCuritem;
1450 WCHAR* wVal;
1451 int length, relval = -1;
51371543 1452
73c4f7a1 1453 if (name) {
7fac1903
GS		 1454 if (USING_WIDE()) {
1455 length = strlen(name)+1;
1456 New(1309,wCuritem,length,WCHAR);
c5be433b 1457 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
7fac1903 1458 wVal = wcschr(wCuritem, '=');
7766f137 1459 if (wVal) {
7fac1903 1460 *wVal++ = '\0';
7766f137 1461 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
7fac1903
GS		 1462 relval = 0;
1463 }
1464 Safefree(wCuritem);
1465 }
1466 else {
1467 New(1309,curitem,strlen(name)+1,char);
1468 strcpy(curitem, name);
1469 val = strchr(curitem, '=');
7766f137 1470 if (val) {
7fac1903
GS		 1471 /* The sane way to deal with the environment.
1472 * Has these advantages over putenv() & co.:
1473 * * enables us to store a truly empty value in the
1474 * environment (like in UNIX).
1475 * * we don't have to deal with RTL globals, bugs and leaks.
1476 * * Much faster.
1477 * Why you may want to enable USE_WIN32_RTL_ENV:
1478 * * environ[] and RTL functions will not reflect changes,
1479 * which might be an issue if extensions want to access
1480 * the env. via RTL. This cuts both ways, since RTL will
1481 * not see changes made by extensions that call the Win32
1482 * functions directly, either.
1483 * GSAR 97-06-07
1484 */
1485 *val++ = '\0';
7766f137 1486 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
7fac1903
GS		 1487 relval = 0;
1488 }
1489 Safefree(curitem);
ac5c734f 1490 }
ac5c734f
GS		 1491 }
1492 return relval;
1493}
1494
d55594ae 1495static long
2d7a9237 1496filetime_to_clock(PFILETIME ft)
d55594ae 1497{
7766f137
GS		 1498 __int64 qw = ft->dwHighDateTime;
1499 qw <<= 32;
1500 qw |= ft->dwLowDateTime;
1501 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1502 return (long) qw;
d55594ae
GS		 1503}
1504
f3986ebb
GS		 1505DllExport int
1506win32_times(struct tms *timebuf)
0a753a76 1507{
d55594ae
GS		 1508 FILETIME user;
1509 FILETIME kernel;
1510 FILETIME dummy;
50ee8e5e 1511 clock_t process_time_so_far = clock();
3fadfdf1 1512 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
d55594ae 1513 &kernel,&user)) {
2d7a9237
GS		 1514 timebuf->tms_utime = filetime_to_clock(&user);
1515 timebuf->tms_stime = filetime_to_clock(&kernel);
d55594ae
GS		 1516 timebuf->tms_cutime = 0;
1517 timebuf->tms_cstime = 0;
3fadfdf1 1518 } else {
d55594ae 1519 /* That failed - e.g. Win95 fallback to clock() */
50ee8e5e 1520 timebuf->tms_utime = process_time_so_far;
d55594ae
GS		 1521 timebuf->tms_stime = 0;
1522 timebuf->tms_cutime = 0;
1523 timebuf->tms_cstime = 0;
1524 }
50ee8e5e 1525 return process_time_so_far;
0a753a76 1526}
1527
9c51cf4c 1528/* fix utime() so it works on directories in NT */
ad0751ec
GS		 1529static BOOL
1530filetime_from_time(PFILETIME pFileTime, time_t Time)
1531{
9c51cf4c 1532 struct tm *pTM = localtime(&Time);
ad0751ec 1533 SYSTEMTIME SystemTime;
9c51cf4c 1534 FILETIME LocalTime;
ad0751ec
GS		 1535
1536 if (pTM == NULL)
1537 return FALSE;
1538
1539 SystemTime.wYear = pTM->tm_year + 1900;
1540 SystemTime.wMonth = pTM->tm_mon + 1;
1541 SystemTime.wDay = pTM->tm_mday;
1542 SystemTime.wHour = pTM->tm_hour;
1543 SystemTime.wMinute = pTM->tm_min;
1544 SystemTime.wSecond = pTM->tm_sec;
1545 SystemTime.wMilliseconds = 0;
1546
9c51cf4c
GS		 1547 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1548 LocalFileTimeToFileTime(&LocalTime, pFileTime);
ad0751ec
GS		 1549}
1550
1551DllExport int
7766f137
GS		 1552win32_unlink(const char *filename)
1553{
acfe0abc 1554 dTHX;
7766f137
GS		 1555 int ret;
1556 DWORD attrs;
1557
1558 if (USING_WIDE()) {
82867ecf 1559 WCHAR wBuffer[MAX_PATH+1];
e9ff6d27 1560 WCHAR* pwBuffer;
7766f137
GS		 1561
1562 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
e9ff6d27
GS		 1563 pwBuffer = PerlDir_mapW(wBuffer);
1564 attrs = GetFileAttributesW(pwBuffer);
c00206c8
GS		 1565 if (attrs == 0xFFFFFFFF)
1566 goto fail;
7766f137 1567 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS		 1568 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1569 ret = _wunlink(pwBuffer);
7766f137 1570 if (ret == -1)
e9ff6d27 1571 (void)SetFileAttributesW(pwBuffer, attrs);
7766f137
GS		 1572 }
1573 else
e9ff6d27 1574 ret = _wunlink(pwBuffer);
7766f137
GS		 1575 }
1576 else {
e9ff6d27
GS		 1577 filename = PerlDir_mapA(filename);
1578 attrs = GetFileAttributesA(filename);
c00206c8
GS		 1579 if (attrs == 0xFFFFFFFF)
1580 goto fail;
7766f137 1581 if (attrs & FILE_ATTRIBUTE_READONLY) {
e9ff6d27
GS		 1582 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1583 ret = unlink(filename);
7766f137 1584 if (ret == -1)
e9ff6d27 1585 (void)SetFileAttributesA(filename, attrs);
7766f137
GS		 1586 }
1587 else
e9ff6d27 1588 ret = unlink(filename);
7766f137
GS		 1589 }
1590 return ret;
c00206c8
GS		 1591fail:
1592 errno = ENOENT;
1593 return -1;
7766f137
GS		 1594}
1595
1596DllExport int
3b405fc5 1597win32_utime(const char *filename, struct utimbuf *times)
ad0751ec 1598{
acfe0abc 1599 dTHX;
ad0751ec
GS		 1600 HANDLE handle;
1601 FILETIME ftCreate;
1602 FILETIME ftAccess;
1603 FILETIME ftWrite;
1604 struct utimbuf TimeBuffer;
82867ecf 1605 WCHAR wbuffer[MAX_PATH+1];
e9ff6d27 1606 WCHAR* pwbuffer;
ad0751ec 1607
7fac1903
GS		 1608 int rc;
1609 if (USING_WIDE()) {
0cb96387 1610 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
e9ff6d27
GS		 1611 pwbuffer = PerlDir_mapW(wbuffer);
1612 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
7fac1903
GS		 1613 }
1614 else {
e9ff6d27
GS		 1615 filename = PerlDir_mapA(filename);
1616 rc = utime(filename, times);
7fac1903 1617 }
ad0751ec
GS		 1618 /* EACCES: path specifies directory or readonly file */
1619 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1620 return rc;
1621
1622 if (times == NULL) {
1623 times = &TimeBuffer;
1624 time(&times->actime);
1625 times->modtime = times->actime;
1626 }
1627
1628 /* This will (and should) still fail on readonly files */
7fac1903 1629 if (USING_WIDE()) {
e9ff6d27 1630 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS		 1631 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1632 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1633 }
1634 else {
e9ff6d27 1635 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
7fac1903
GS		 1636 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1637 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1638 }
ad0751ec
GS		 1639 if (handle == INVALID_HANDLE_VALUE)
1640 return rc;
1641
1642 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1643 filetime_from_time(&ftAccess, times->actime) &&
1644 filetime_from_time(&ftWrite, times->modtime) &&
1645 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1646 {
1647 rc = 0;
1648 }
1649
1650 CloseHandle(handle);
1651 return rc;
1652}
1653
6e3b076d
JH		 1654typedef union {
1655 unsigned __int64 ft_i64;
1656 FILETIME ft_val;
1657} FT_t;
1658
1659#ifdef __GNUC__
1660#define Const64(x) x##LL
1661#else
1662#define Const64(x) x##i64
1663#endif
1664/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1665#define EPOCH_BIAS Const64(116444736000000000)
1666
57ab3dfe
GS		 1667/* NOTE: This does not compute the timezone info (doing so can be expensive,
1668 * and appears to be unsupported even by glibc) */
1669DllExport int
1670win32_gettimeofday(struct timeval *tp, void *not_used)
1671{
6e3b076d
JH		 1672 FT_t ft;
1673
1674 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1675 GetSystemTimeAsFileTime(&ft.ft_val);
1676
1677 /* seconds since epoch */
1678 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1679
1680 /* microseconds remaining */
1681 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1682
1683 return 0;
57ab3dfe
GS		 1684}
1685
2d7a9237 1686DllExport int
b2af26b1
GS		 1687win32_uname(struct utsname *name)
1688{
1689 struct hostent *hep;
1690 STRLEN nodemax = sizeof(name->nodename)-1;
1691 OSVERSIONINFO osver;
1692
1693 memset(&osver, 0, sizeof(OSVERSIONINFO));
1694 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1695 if (GetVersionEx(&osver)) {
1696 /* sysname */
1697 switch (osver.dwPlatformId) {
1698 case VER_PLATFORM_WIN32_WINDOWS:
1699 strcpy(name->sysname, "Windows");
1700 break;
1701 case VER_PLATFORM_WIN32_NT:
1702 strcpy(name->sysname, "Windows NT");
1703 break;
1704 case VER_PLATFORM_WIN32s:
1705 strcpy(name->sysname, "Win32s");
1706 break;
1707 default:
1708 strcpy(name->sysname, "Win32 Unknown");
1709 break;
1710 }
1711
cf6cacac
GS		 1712 /* release */
1713 sprintf(name->release, "%d.%d",
b2af26b1
GS		 1714 osver.dwMajorVersion, osver.dwMinorVersion);
1715
cf6cacac
GS		 1716 /* version */
1717 sprintf(name->version, "Build %d",
b2af26b1
GS		 1718 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1719 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1720 if (osver.szCSDVersion[0]) {
cf6cacac 1721 char *buf = name->version + strlen(name->version);
b2af26b1
GS		 1722 sprintf(buf, " (%s)", osver.szCSDVersion);
1723 }
1724 }
1725 else {
1726 *name->sysname = '\0';
1727 *name->version = '\0';
1728 *name->release = '\0';
1729 }
1730
1731 /* nodename */
1732 hep = win32_gethostbyname("localhost");
1733 if (hep) {
1734 STRLEN len = strlen(hep->h_name);
1735 if (len <= nodemax) {
1736 strcpy(name->nodename, hep->h_name);
1737 }
1738 else {
1739 strncpy(name->nodename, hep->h_name, nodemax);
1740 name->nodename[nodemax] = '\0';
1741 }
1742 }
1743 else {
1744 DWORD sz = nodemax;
1745 if (!GetComputerName(name->nodename, &sz))
1746 *name->nodename = '\0';
1747 }
1748
1749 /* machine (architecture) */
1750 {
1751 SYSTEM_INFO info;
1752 char *arch;
1753 GetSystemInfo(&info);
a6c40364 1754
6f24f39d
JK		 1755#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1756 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
a6c40364
GS		 1757 switch (info.u.s.wProcessorArchitecture) {
1758#else
b2af26b1 1759 switch (info.wProcessorArchitecture) {
a6c40364 1760#endif
b2af26b1
GS		 1761 case PROCESSOR_ARCHITECTURE_INTEL:
1762 arch = "x86"; break;
1763 case PROCESSOR_ARCHITECTURE_MIPS:
1764 arch = "mips"; break;
1765 case PROCESSOR_ARCHITECTURE_ALPHA:
1766 arch = "alpha"; break;
1767 case PROCESSOR_ARCHITECTURE_PPC:
1768 arch = "ppc"; break;
1769 default:
1770 arch = "unknown"; break;
1771 }
1772 strcpy(name->machine, arch);
1773 }
1774 return 0;
1775}
1776
8fb3fcfb
NIS		 1777/* Timing related stuff */
1778
3fadfdf1
NIS		 1779int
1780do_raise(pTHX_ int sig)
1781{
1782 if (sig < SIG_SIZE) {
1783 Sighandler_t handler = w32_sighandler[sig];
1784 if (handler == SIG_IGN) {
1785 return 0;
1786 }
1787 else if (handler != SIG_DFL) {
1788 (*handler)(sig);
1789 return 0;
1790 }
1791 else {
1792 /* Choose correct default behaviour */
1793 switch (sig) {
1794#ifdef SIGCLD
1795 case SIGCLD:
1796#endif
1797#ifdef SIGCHLD
1798 case SIGCHLD:
1799#endif
1800 case 0:
1801 return 0;
1802 case SIGTERM:
1803 default:
1804 break;
1805 }
1806 }
1807 }
1808 /* Tell caller to exit thread/process as approriate */
1809 return 1;
1810}
1811
1812void
1813sig_terminate(pTHX_ int sig)
1814{
1815 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1816 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1817 thread
1818 */
1819 exit(sig);
1820}
1821
8fb3fcfb
NIS		 1822DllExport int
1823win32_async_check(pTHX)
1824{
1825 MSG msg;
1826 int ours = 1;
7e5f34c0
NIS		 1827 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1828 * and ignores window messages - should co-exist better with windows apps e.g. Tk
3fadfdf1 1829 */
222c300a 1830 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
3fadfdf1 1831 int sig;
8fb3fcfb
NIS		 1832 switch(msg.message) {
1833
7e5f34c0
NIS		 1834#if 0
1835 /* Perhaps some other messages could map to signals ? ... */
1836 case WM_CLOSE:
3fadfdf1 1837 case WM_QUIT:
7e5f34c0 1838 /* Treat WM_QUIT like SIGHUP? */
3fadfdf1
NIS		 1839 sig = SIGHUP;
1840 goto Raise;
7e5f34c0
NIS		 1841 break;
1842#endif
1843
c843839f 1844 /* We use WM_USER to fake kill() with other signals */
8fb3fcfb 1845 case WM_USER: {
3fadfdf1
NIS		 1846 sig = msg.wParam;
1847 Raise:
1848 if (do_raise(aTHX_ sig)) {
1849 sig_terminate(aTHX_ sig);
1850 }
8fb3fcfb
NIS		 1851 break;
1852 }
3fadfdf1 1853
8fb3fcfb
NIS		 1854 case WM_TIMER: {
1855 /* alarm() is a one-shot but SetTimer() repeats so kill it */
222c300a
NIS		 1856 if (w32_timerid) {
1857 KillTimer(NULL,w32_timerid);
3fadfdf1
NIS		 1858 w32_timerid=0;
1859 }
8fb3fcfb 1860 /* Now fake a call to signal handler */
3fadfdf1
NIS		 1861 if (do_raise(aTHX_ 14)) {
1862 sig_terminate(aTHX_ 14);
1863 }
8fb3fcfb
NIS		 1864 break;
1865 }
1866
1867 /* Otherwise do normal Win32 thing - in case it is useful */
1868 default:
1869 TranslateMessage(&msg);
1870 DispatchMessage(&msg);
1871 ours = 0;
1872 break;
1873 }
1874 }
05ec9bb3 1875 w32_poll_count = 0;
8fb3fcfb 1876
7e5f34c0 1877 /* Above or other stuff may have set a signal flag */
8fb3fcfb
NIS		 1878 if (PL_sig_pending) {
1879 despatch_signals();
1880 }
3fadfdf1 1881 return ours;
8fb3fcfb
NIS		 1882}
1883
1884DllExport DWORD
1885win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1886{
1887 /* We may need several goes at this - so compute when we stop */
1888 DWORD ticks = 0;
1889 if (timeout != INFINITE) {
1890 ticks = GetTickCount();
1891 timeout += ticks;
1892 }
1893 while (1) {
1894 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1895 if (resultp)
1896 *resultp = result;
1897 if (result == WAIT_TIMEOUT) {
3fadfdf1
NIS		 1898 /* Ran out of time - explicit return of zero to avoid -ve if we
1899 have scheduling issues
1900 */
8fb3fcfb
NIS		 1901 return 0;
1902 }
1903 if (timeout != INFINITE) {
1904 ticks = GetTickCount();
1905 }
1906 if (result == WAIT_OBJECT_0 + count) {
1907 /* Message has arrived - check it */
1908 if (win32_async_check(aTHX)) {
1909 /* was one of ours */
1910 break;
1911 }
1912 }
1913 else {
1914 /* Not timeout or message - one of handles is ready */
1915 break;
1916 }
1917 }
1918 /* compute time left to wait */
1919 ticks = timeout - ticks;
1920 /* If we are past the end say zero */
1921 return (ticks > 0) ? ticks : 0;
1922}
1923
932b7487
RC		 1924int
1925win32_internal_wait(int *status, DWORD timeout)
1926{
1927 /* XXX this wait emulation only knows about processes
1928 * spawned via win32_spawnvp(P_NOWAIT, ...).
1929 */
1930 dTHX;
1931 int i, retval;
1932 DWORD exitcode, waitcode;
1933
1934#ifdef USE_ITHREADS
1935 if (w32_num_pseudo_children) {
8fb3fcfb
NIS		 1936 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
1937 timeout, &waitcode);
932b7487
RC		 1938 /* Time out here if there are no other children to wait for. */
1939 if (waitcode == WAIT_TIMEOUT) {
1940 if (!w32_num_children) {
1941 return 0;
1942 }
1943 }
1944 else if (waitcode != WAIT_FAILED) {
1945 if (waitcode >= WAIT_ABANDONED_0
1946 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
1947 i = waitcode - WAIT_ABANDONED_0;
1948 else
1949 i = waitcode - WAIT_OBJECT_0;
1950 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
1951 *status = (int)((exitcode & 0xff) << 8);
1952 retval = (int)w32_pseudo_child_pids[i];
1953 remove_dead_pseudo_process(i);
1954 return -retval;
1955 }
1956 }
1957 }
1958#endif
1959
1960 if (!w32_num_children) {
1961 errno = ECHILD;
1962 return -1;
1963 }
1964
1965 /* if a child exists, wait for it to die */
8fb3fcfb 1966 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
932b7487
RC		 1967 if (waitcode == WAIT_TIMEOUT) {
1968 return 0;
1969 }
1970 if (waitcode != WAIT_FAILED) {
1971 if (waitcode >= WAIT_ABANDONED_0
1972 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
1973 i = waitcode - WAIT_ABANDONED_0;
1974 else
1975 i = waitcode - WAIT_OBJECT_0;
1976 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
1977 *status = (int)((exitcode & 0xff) << 8);
1978 retval = (int)w32_child_pids[i];
1979 remove_dead_process(i);
1980 return retval;
1981 }
1982 }
1983
932b7487
RC		 1984 errno = GetLastError();
1985 return -1;
1986}
1987
b2af26b1 1988DllExport int
f55ee38a
GS		 1989win32_waitpid(int pid, int *status, int flags)
1990{
acfe0abc 1991 dTHX;
922b1888 1992 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
0aaad0ff 1993 int retval = -1;
c66b022d 1994 long child;
7766f137 1995 if (pid == -1) /* XXX threadid == 1 ? */
932b7487 1996 return win32_internal_wait(status, timeout);
7766f137
GS		 1997#ifdef USE_ITHREADS
1998 else if (pid < 0) {
c66b022d 1999 child = find_pseudo_pid(-pid);
7766f137
GS		 2000 if (child >= 0) {
2001 HANDLE hThread = w32_pseudo_child_handles[child];
8fb3fcfb
NIS		 2002 DWORD waitcode;
2003 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2f67576d
BC		 2004 if (waitcode == WAIT_TIMEOUT) {
2005 return 0;
2006 }
8fb3fcfb 2007 else if (waitcode == WAIT_OBJECT_0) {
7766f137
GS		 2008 if (GetExitCodeThread(hThread, &waitcode)) {
2009 *status = (int)((waitcode & 0xff) << 8);
2010 retval = (int)w32_pseudo_child_pids[child];
2011 remove_dead_pseudo_process(child);
68a29c53 2012 return -retval;
7766f137
GS		 2013 }
2014 }
2015 else
2016 errno = ECHILD;
2017 }
922b1888
GS		 2018 else if (IsWin95()) {
2019 pid = -pid;
2020 goto alien_process;
2021 }
7766f137
GS		 2022 }
2023#endif
f55ee38a 2024 else {
922b1888
GS		 2025 HANDLE hProcess;
2026 DWORD waitcode;
c66b022d 2027 child = find_pid(pid);
0aaad0ff 2028 if (child >= 0) {
922b1888 2029 hProcess = w32_child_handles[child];
8fb3fcfb 2030 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
a7867d0a
GS		 2031 if (waitcode == WAIT_TIMEOUT) {
2032 return 0;
2033 }
8fb3fcfb 2034 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 2035 if (GetExitCodeProcess(hProcess, &waitcode)) {
2036 *status = (int)((waitcode & 0xff) << 8);
2037 retval = (int)w32_child_pids[child];
2038 remove_dead_process(child);
2039 return retval;
2040 }
a7867d0a 2041 }
0aaad0ff
GS		 2042 else
2043 errno = ECHILD;
2044 }
2045 else {
922b1888
GS		 2046alien_process:
2047 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2048 (IsWin95() ? -pid : pid));
2049 if (hProcess) {
8fb3fcfb 2050 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
922b1888
GS		 2051 if (waitcode == WAIT_TIMEOUT) {
2052 return 0;
2053 }
8fb3fcfb 2054 else if (waitcode == WAIT_OBJECT_0) {
922b1888
GS		 2055 if (GetExitCodeProcess(hProcess, &waitcode)) {
2056 *status = (int)((waitcode & 0xff) << 8);
2057 CloseHandle(hProcess);
2058 return pid;
2059 }
2060 }
2061 CloseHandle(hProcess);
2062 }
2063 else
2064 errno = ECHILD;
0aaad0ff 2065 }
f55ee38a 2066 }
3fadfdf1 2067 return retval >= 0 ? pid : retval;
f55ee38a
GS		 2068}
2069
2070DllExport int
2d7a9237
GS		 2071win32_wait(int *status)
2072{
932b7487 2073 return win32_internal_wait(status, INFINITE);
2d7a9237 2074}
d55594ae 2075
8fb3fcfb
NIS		 2076DllExport unsigned int
2077win32_sleep(unsigned int t)
d55594ae 2078{
acfe0abc 2079 dTHX;
8fb3fcfb
NIS		 2080 /* Win32 times are in ms so *1000 in and /1000 out */
2081 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
d55594ae
GS		 2082}
2083
f3986ebb
GS		 2084DllExport unsigned int
2085win32_alarm(unsigned int sec)
0a753a76 2086{
3fadfdf1 2087 /*
d55594ae 2088 * the 'obvious' implentation is SetTimer() with a callback
3fadfdf1
NIS		 2089 * which does whatever receiving SIGALRM would do
2090 * we cannot use SIGALRM even via raise() as it is not
d55594ae 2091 * one of the supported codes in <signal.h>
3fadfdf1 2092 */
acfe0abc 2093 dTHX;
8fb3fcfb
NIS		 2094 if (sec) {
2095 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2096 }
2097 else {
2098 if (w32_timerid) {
2099 KillTimer(NULL,w32_timerid);
3fadfdf1 2100 w32_timerid=0;
8fb3fcfb 2101 }
3fadfdf1 2102 }
afe91769 2103 return 0;
0a753a76 2104}
2105
26618a56 2106#ifdef HAVE_DES_FCRYPT
2d77217b 2107extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
ff95b63e 2108#endif
26618a56
GS		 2109
2110DllExport char *
2111win32_crypt(const char *txt, const char *salt)
2112{
acfe0abc 2113 dTHX;
ff95b63e 2114#ifdef HAVE_DES_FCRYPT
3352bfcb 2115 return des_fcrypt(txt, salt, w32_crypt_buffer);
ff95b63e 2116#else
25dbdbbc 2117 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
b8957cf1 2118 return Nullch;
ff95b63e 2119#endif
26618a56 2120}
26618a56 2121
9e5f57de 2122#ifdef USE_FIXED_OSFHANDLE
390b85e7
GS		 2123
2124#define FOPEN 0x01 /* file handle open */
b181b6fb 2125#define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
390b85e7
GS		 2126#define FAPPEND 0x20 /* file handle opened O_APPEND */
2127#define FDEV 0x40 /* file handle refers to device */
2128#define FTEXT 0x80 /* file handle is in text mode */
2129
390b85e7 2130/***
c623ac67 2131*int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
390b85e7
GS		 2132*
2133*Purpose:
2134* This function allocates a free C Runtime file handle and associates
2135* it with the Win32 HANDLE specified by the first parameter. This is a
9e5f57de
GS		 2136* temperary fix for WIN95's brain damage GetFileType() error on socket
2137* we just bypass that call for socket
2138*
2139* This works with MSVC++ 4.0+ or GCC/Mingw32
390b85e7
GS		 2140*
2141*Entry:
c623ac67 2142* intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
390b85e7
GS		 2143* int flags - flags to associate with C Runtime file handle.
2144*
2145*Exit:
2146* returns index of entry in fh, if successful
2147* return -1, if no free entry is found
2148*
2149*Exceptions:
2150*
2151*******************************************************************************/
2152
9e5f57de
GS		 2153/*
2154 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2155 * this lets sockets work on Win9X with GCC and should fix the problems
2156 * with perl95.exe
2157 * -- BKS, 1-23-2000
2158*/
2159
9e5f57de
GS		 2160/* create an ioinfo entry, kill its handle, and steal the entry */
2161
b181b6fb
GS		 2162static int
2163_alloc_osfhnd(void)
9e5f57de
GS		 2164{
2165 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
c623ac67 2166 int fh = _open_osfhandle((intptr_t)hF, 0);
9e5f57de
GS		 2167 CloseHandle(hF);
2168 if (fh == -1)
2169 return fh;
2170 EnterCriticalSection(&(_pioinfo(fh)->lock));
2171 return fh;
2172}
2173
390b85e7 2174static int
c623ac67 2175my_open_osfhandle(intptr_t osfhandle, int flags)
390b85e7
GS		 2176{
2177 int fh;
2178 char fileflags; /* _osfile flags */
2179
2180 /* copy relevant flags from second parameter */
2181 fileflags = FDEV;
2182
9404a519 2183 if (flags & O_APPEND)
390b85e7
GS		 2184 fileflags |= FAPPEND;
2185
9404a519 2186 if (flags & O_TEXT)
390b85e7
GS		 2187 fileflags |= FTEXT;
2188
b181b6fb
GS		 2189 if (flags & O_NOINHERIT)
2190 fileflags |= FNOINHERIT;
2191
390b85e7 2192 /* attempt to allocate a C Runtime file handle */
9404a519 2193 if ((fh = _alloc_osfhnd()) == -1) {
390b85e7
GS		 2194 errno = EMFILE; /* too many open files */
2195 _doserrno = 0L; /* not an OS error */
2196 return -1; /* return error to caller */
2197 }
2198
2199 /* the file is open. now, set the info in _osfhnd array */
2200 _set_osfhnd(fh, osfhandle);
2201
2202 fileflags |= FOPEN; /* mark as open */
2203
390b85e7 2204 _osfile(fh) = fileflags; /* set osfile entry */
dd8f4818 2205 LeaveCriticalSection(&_pioinfo(fh)->lock);
390b85e7
GS		 2206
2207 return fh; /* return handle */
2208}
2209
f3986ebb 2210#endif /* USE_FIXED_OSFHANDLE */
390b85e7
GS		 2211
2212/* simulate flock by locking a range on the file */
2213
2214#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2215#define LK_LEN 0xffff0000
2216
f3986ebb
GS		 2217DllExport int
2218win32_flock(int fd, int oper)
390b85e7
GS		 2219{
2220 OVERLAPPED o;
2221 int i = -1;
2222 HANDLE fh;
2223
f3986ebb 2224 if (!IsWinNT()) {
acfe0abc 2225 dTHX;
4f63d024 2226 Perl_croak_nocontext("flock() unimplemented on this platform");
f3986ebb
GS		 2227 return -1;
2228 }
390b85e7
GS		 2229 fh = (HANDLE)_get_osfhandle(fd);
2230 memset(&o, 0, sizeof(o));
2231
2232 switch(oper) {
2233 case LOCK_SH: /* shared lock */
2234 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2235 break;
2236 case LOCK_EX: /* exclusive lock */
2237 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2238 break;
2239 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2240 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2241 break;
2242 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2243 LK_ERR(LockFileEx(fh,
2244 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2245 0, LK_LEN, 0, &o),i);
2246 break;
2247 case LOCK_UN: /* unlock lock */
2248 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2249 break;
2250 default: /* unknown */
2251 errno = EINVAL;
2252 break;
2253 }
2254 return i;
2255}
2256
2257#undef LK_ERR
2258#undef LK_LEN
2259
68dc0745 2260/*
2261 * redirected io subsystem for all XS modules
2262 *
2263 */
0a753a76 2264
68dc0745 2265DllExport int *
2266win32_errno(void)
0a753a76 2267{
390b85e7 2268 return (&errno);
0a753a76 2269}
2270
dcb2879a
GS		 2271DllExport char ***
2272win32_environ(void)
2273{
390b85e7 2274 return (&(_environ));
dcb2879a
GS		 2275}
2276
68dc0745 2277/* the rest are the remapped stdio routines */
2278DllExport FILE *
2279win32_stderr(void)
0a753a76 2280{
390b85e7 2281 return (stderr);
0a753a76 2282}
2283
68dc0745 2284DllExport FILE *
2285win32_stdin(void)
0a753a76 2286{
390b85e7 2287 return (stdin);
0a753a76 2288}
2289
68dc0745 2290DllExport FILE *
2291win32_stdout()
0a753a76 2292{
390b85e7 2293 return (stdout);
0a753a76 2294}
2295
68dc0745 2296DllExport int
2297win32_ferror(FILE *fp)
0a753a76 2298{
390b85e7 2299 return (ferror(fp));
0a753a76 2300}
2301
2302
68dc0745 2303DllExport int
2304win32_feof(FILE *fp)
0a753a76 2305{
390b85e7 2306 return (feof(fp));
0a753a76 2307}
2308
68dc0745 2309/*
3fadfdf1 2310 * Since the errors returned by the socket error function
68dc0745 2311 * WSAGetLastError() are not known by the library routine strerror
2312 * we have to roll our own.
2313 */
0a753a76 2314
68dc0745 2315DllExport char *
3fadfdf1 2316win32_strerror(int e)
0a753a76 2317{
6f24f39d 2318#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
68dc0745 2319 extern int sys_nerr;
3e3baf6d 2320#endif
68dc0745 2321 DWORD source = 0;
0a753a76 2322
9404a519 2323 if (e < 0 || e > sys_nerr) {
acfe0abc 2324 dTHX;
9404a519 2325 if (e < 0)
68dc0745 2326 e = GetLastError();
0a753a76 2327
9404a519 2328 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
3352bfcb 2329 w32_strerror_buffer,
3fadfdf1 2330 sizeof(w32_strerror_buffer), NULL) == 0)
3352bfcb 2331 strcpy(w32_strerror_buffer, "Unknown Error");
0a753a76 2332
3352bfcb 2333 return w32_strerror_buffer;
68dc0745 2334 }
390b85e7 2335 return strerror(e);
0a753a76 2336}
2337
22fae026 2338DllExport void
c5be433b 2339win32_str_os_error(void *sv, DWORD dwErr)
22fae026
TM		 2340{
2341 DWORD dwLen;
2342 char *sMsg;
2343 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2344 |FORMAT_MESSAGE_IGNORE_INSERTS
2345 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2346 dwErr, 0, (char *)&sMsg, 1, NULL);
2ce77adf 2347 /* strip trailing whitespace and period */
22fae026 2348 if (0 < dwLen) {
2ce77adf
GS		 2349 do {
2350 --dwLen; /* dwLen doesn't include trailing null */
2351 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
22fae026
TM		 2352 if ('.' != sMsg[dwLen])
2353 dwLen++;
2ce77adf 2354 sMsg[dwLen] = '\0';
22fae026
TM		 2355 }
2356 if (0 == dwLen) {
c69f6586 2357 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
db7c17d7
GS		 2358 if (sMsg)
2359 dwLen = sprintf(sMsg,
2360 "Unknown error #0x%lX (lookup 0x%lX)",
2361 dwErr, GetLastError());
2362 }
2363 if (sMsg) {
acfe0abc 2364 dTHX;
db7c17d7
GS		 2365 sv_setpvn((SV*)sv, sMsg, dwLen);
2366 LocalFree(sMsg);
22fae026 2367 }
22fae026
TM		 2368}
2369
68dc0745 2370DllExport int
2371win32_fprintf(FILE *fp, const char *format, ...)
0a753a76 2372{
68dc0745 2373 va_list marker;
2374 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2375
390b85e7 2376 return (vfprintf(fp, format, marker));
0a753a76 2377}
2378
68dc0745 2379DllExport int
2380win32_printf(const char *format, ...)
0a753a76 2381{
68dc0745 2382 va_list marker;
2383 va_start(marker, format); /* Initialize variable arguments. */
0a753a76 2384
390b85e7 2385 return (vprintf(format, marker));
0a753a76 2386}
2387
68dc0745 2388DllExport int
2389win32_vfprintf(FILE *fp, const char *format, va_list args)
0a753a76 2390{
390b85e7 2391 return (vfprintf(fp, format, args));
0a753a76 2392}
2393
96e4d5b1 2394DllExport int
2395win32_vprintf(const char *format, va_list args)
2396{
390b85e7 2397 return (vprintf(format, args));
96e4d5b1 2398}
2399
68dc0745 2400DllExport size_t
2401win32_fread(void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2402{
390b85e7 2403 return fread(buf, size, count, fp);
0a753a76 2404}
2405
68dc0745 2406DllExport size_t
2407win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
0a753a76 2408{
390b85e7 2409 return fwrite(buf, size, count, fp);
0a753a76 2410}
2411
7fac1903
GS		 2412#define MODE_SIZE 10
2413
68dc0745 2414DllExport FILE *
2415win32_fopen(const char *filename, const char *mode)
0a753a76 2416{
acfe0abc 2417 dTHX;
82867ecf 2418 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
1c5905c2 2419 FILE *f;
3fadfdf1 2420
c5be433b
GS		 2421 if (!*filename)
2422 return NULL;
2423
68dc0745 2424 if (stricmp(filename, "/dev/null")==0)
7fac1903
GS		 2425 filename = "NUL";
2426
2427 if (USING_WIDE()) {
0cb96387
GS		 2428 A2WHELPER(mode, wMode, sizeof(wMode));
2429 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1c5905c2 2430 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
7fac1903 2431 }
1c5905c2
GS		 2432 else
2433 f = fopen(PerlDir_mapA(filename), mode);
2434 /* avoid buffering headaches for child processes */
2435 if (f && *mode == 'a')
2436 win32_fseek(f, 0, SEEK_END);
2437 return f;
0a753a76 2438}
2439
f3986ebb
GS		 2440#ifndef USE_SOCKETS_AS_HANDLES
2441#undef fdopen
2442#define fdopen my_fdopen
2443#endif
2444
68dc0745 2445DllExport FILE *
7fac1903 2446win32_fdopen(int handle, const char *mode)
0a753a76 2447{
acfe0abc 2448 dTHX;
51371543 2449 WCHAR wMode[MODE_SIZE];
1c5905c2 2450 FILE *f;
7fac1903 2451 if (USING_WIDE()) {
0cb96387 2452 A2WHELPER(mode, wMode, sizeof(wMode));
1c5905c2 2453 f = _wfdopen(handle, wMode);
7fac1903 2454 }
1c5905c2
GS		 2455 else
2456 f = fdopen(handle, (char *) mode);
2457 /* avoid buffering headaches for child processes */
2458 if (f && *mode == 'a')
2459 win32_fseek(f, 0, SEEK_END);
2460 return f;
0a753a76 2461}
2462
68dc0745 2463DllExport FILE *
7fac1903 2464win32_freopen(const char *path, const char *mode, FILE *stream)
0a753a76 2465{
acfe0abc 2466 dTHX;
82867ecf 2467 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
68dc0745 2468 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 2469 path = "NUL";
2470
2471 if (USING_WIDE()) {
0cb96387
GS		 2472 A2WHELPER(mode, wMode, sizeof(wMode));
2473 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 2474 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
7fac1903 2475 }
7766f137 2476 return freopen(PerlDir_mapA(path), mode, stream);
0a753a76 2477}
2478
68dc0745 2479DllExport int
2480win32_fclose(FILE *pf)
0a753a76 2481{
f3986ebb 2482 return my_fclose(pf); /* defined in win32sck.c */
0a753a76 2483}
2484
68dc0745 2485DllExport int
2486win32_fputs(const char *s,FILE *pf)
0a753a76 2487{
390b85e7 2488 return fputs(s, pf);
0a753a76 2489}
2490
68dc0745 2491DllExport int
2492win32_fputc(int c,FILE *pf)
0a753a76 2493{
390b85e7 2494 return fputc(c,pf);
0a753a76 2495}
2496
68dc0745 2497DllExport int
2498win32_ungetc(int c,FILE *pf)
0a753a76 2499{
390b85e7 2500 return ungetc(c,pf);
0a753a76 2501}
2502
68dc0745 2503DllExport int
2504win32_getc(FILE *pf)
0a753a76 2505{
390b85e7 2506 return getc(pf);
0a753a76 2507}
2508
68dc0745 2509DllExport int
2510win32_fileno(FILE *pf)
0a753a76 2511{
390b85e7 2512 return fileno(pf);
0a753a76 2513}
2514
68dc0745 2515DllExport void
2516win32_clearerr(FILE *pf)
0a753a76 2517{
390b85e7 2518 clearerr(pf);
68dc0745 2519 return;
0a753a76 2520}
2521
68dc0745 2522DllExport int
2523win32_fflush(FILE *pf)
0a753a76 2524{
390b85e7 2525 return fflush(pf);
0a753a76 2526}
2527
c623ac67 2528DllExport Off_t
68dc0745 2529win32_ftell(FILE *pf)
0a753a76 2530{
c623ac67
GS		 2531#if defined(WIN64) || defined(USE_LARGE_FILES)
2532 fpos_t pos;
2533 if (fgetpos(pf, &pos))
2534 return -1;
2535 return (Off_t)pos;
2536#else
390b85e7 2537 return ftell(pf);
c623ac67 2538#endif
0a753a76 2539}
2540
68dc0745 2541DllExport int
c623ac67 2542win32_fseek(FILE *pf, Off_t offset,int origin)
0a753a76 2543{
c623ac67
GS		 2544#if defined(WIN64) || defined(USE_LARGE_FILES)
2545 fpos_t pos;
2546 switch (origin) {
2547 case SEEK_CUR:
2548 if (fgetpos(pf, &pos))
2549 return -1;
2550 offset += pos;
2551 break;
2552 case SEEK_END:
2553 fseek(pf, 0, SEEK_END);
2554 pos = _telli64(fileno(pf));
2555 offset += pos;
2556 break;
2557 case SEEK_SET:
2558 break;
2559 default:
2560 errno = EINVAL;
2561 return -1;
2562 }
2563 return fsetpos(pf, &offset);
2564#else
390b85e7 2565 return fseek(pf, offset, origin);
c623ac67 2566#endif
0a753a76 2567}
2568
68dc0745 2569DllExport int
2570win32_fgetpos(FILE *pf,fpos_t *p)
0a753a76 2571{
390b85e7 2572 return fgetpos(pf, p);
0a753a76 2573}
2574
68dc0745 2575DllExport int
2576win32_fsetpos(FILE *pf,const fpos_t *p)
0a753a76 2577{
390b85e7 2578 return fsetpos(pf, p);
0a753a76 2579}
2580
68dc0745 2581DllExport void
2582win32_rewind(FILE *pf)
0a753a76 2583{
390b85e7 2584 rewind(pf);
68dc0745 2585 return;
0a753a76 2586}
2587
68dc0745 2588DllExport FILE*
2589win32_tmpfile(void)
0a753a76 2590{
b3122bc4
JH		 2591 dTHX;
2592 char prefix[MAX_PATH+1];
2593 char filename[MAX_PATH+1];
2594 DWORD len = GetTempPath(MAX_PATH, prefix);
2595 if (len && len < MAX_PATH) {
2596 if (GetTempFileName(prefix, "plx", 0, filename)) {
2597 HANDLE fh = CreateFile(filename,
2598 DELETE | GENERIC_READ | GENERIC_WRITE,
2599 0,
2600 NULL,
2601 CREATE_ALWAYS,
2602 FILE_ATTRIBUTE_NORMAL
2603 | FILE_FLAG_DELETE_ON_CLOSE,
2604 NULL);
2605 if (fh != INVALID_HANDLE_VALUE) {
c623ac67 2606 int fd = win32_open_osfhandle((intptr_t)fh, 0);
b3122bc4 2607 if (fd >= 0) {
a051bdb4
VK		 2608#if defined(__BORLANDC__)
2609 setmode(fd,O_BINARY);
2610#endif
b3122bc4
JH		 2611 DEBUG_p(PerlIO_printf(Perl_debug_log,
2612 "Created tmpfile=%s\n",filename));
2613 return fdopen(fd, "w+b");
2614 }
2615 }
2616 }
2617 }
2618 return NULL;
0a753a76 2619}
2620
68dc0745 2621DllExport void
2622win32_abort(void)
0a753a76 2623{
390b85e7 2624 abort();
68dc0745 2625 return;
0a753a76 2626}
2627
68dc0745 2628DllExport int
c623ac67 2629win32_fstat(int fd, Stat_t *sbufptr)
0a753a76 2630{
2a07f407
VK		 2631#ifdef __BORLANDC__
2632 /* A file designated by filehandle is not shown as accessible
2633 * for write operations, probably because it is opened for reading.
2634 * --Vadim Konovalov
3fadfdf1 2635 */
2a07f407
VK		 2636 int rc = fstat(fd,sbufptr);
2637 BY_HANDLE_FILE_INFORMATION bhfi;
2638 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2639 sbufptr->st_mode &= 0xFE00;
2640 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2641 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2642 else
2643 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2644 + ((S_IREAD|S_IWRITE) >> 6));
2645 }
2646 return rc;
2647#else
ed59ec62 2648 return my_fstat(fd,sbufptr);
2a07f407 2649#endif
0a753a76 2650}
2651
68dc0745 2652DllExport int
2653win32_pipe(int *pfd, unsigned int size, int mode)
0a753a76 2654{
390b85e7 2655 return _pipe(pfd, size, mode);
0a753a76 2656}
2657
8c0134a8
NIS		 2658DllExport PerlIO*
2659win32_popenlist(const char *mode, IV narg, SV **args)
2660{
2661 dTHX;
2662 Perl_croak(aTHX_ "List form of pipe open not implemented");
2663 return NULL;
2664}
2665
50892819
GS		 2666/*
2667 * a popen() clone that respects PERL5SHELL
00b02797
JH		 2668 *
2669 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
50892819
GS		 2670 */
2671
00b02797 2672DllExport PerlIO*
68dc0745 2673win32_popen(const char *command, const char *mode)
0a753a76 2674{
4b556e6c 2675#ifdef USE_RTL_POPEN
390b85e7 2676 return _popen(command, mode);
50892819 2677#else
2cbbe5a1 2678 dTHX;
50892819
GS		 2679 int p[2];
2680 int parent, child;
2681 int stdfd, oldfd;
2682 int ourmode;
2683 int childpid;
2684
2685 /* establish which ends read and write */
2686 if (strchr(mode,'w')) {
2687 stdfd = 0; /* stdin */
2688 parent = 1;
2689 child = 0;
2690 }
2691 else if (strchr(mode,'r')) {
2692 stdfd = 1; /* stdout */
2693 parent = 0;
2694 child = 1;
2695 }
2696 else
2697 return NULL;
2698
2699 /* set the correct mode */
2700 if (strchr(mode,'b'))
2701 ourmode = O_BINARY;
2702 else if (strchr(mode,'t'))
2703 ourmode = O_TEXT;
2704 else
2705 ourmode = _fmode & (O_TEXT | O_BINARY);
2706
2707 /* the child doesn't inherit handles */
2708 ourmode |= O_NOINHERIT;
2709
2710 if (win32_pipe( p, 512, ourmode) == -1)
2711 return NULL;
2712
2713 /* save current stdfd */
2714 if ((oldfd = win32_dup(stdfd)) == -1)
2715 goto cleanup;
2716
2717 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2718 /* stdfd will be inherited by the child */
2719 if (win32_dup2(p[child], stdfd) == -1)
2720 goto cleanup;
2721
2722 /* close the child end in parent */
2723 win32_close(p[child]);
2724
2725 /* start the child */
4f63d024 2726 {
acfe0abc 2727 dTHX;
c5be433b 2728 if ((childpid = do_spawn_nowait((char*)command)) == -1)
4f63d024 2729 goto cleanup;
50892819 2730
4f63d024
GS		 2731 /* revert stdfd to whatever it was before */
2732 if (win32_dup2(oldfd, stdfd) == -1)
2733 goto cleanup;
50892819 2734
4f63d024
GS		 2735 /* close saved handle */
2736 win32_close(oldfd);
50892819 2737
4755096e 2738 LOCK_FDPID_MUTEX;
4f63d024 2739 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
4755096e 2740 UNLOCK_FDPID_MUTEX;
d91d68c1
RS		 2741
2742 /* set process id so that it can be returned by perl's open() */
2743 PL_forkprocess = childpid;
4f63d024 2744 }
50892819
GS		 2745
2746 /* we have an fd, return a file stream */
00b02797 2747 return (PerlIO_fdopen(p[parent], (char *)mode));
50892819
GS		 2748
2749cleanup:
2750 /* we don't need to check for errors here */
2751 win32_close(p[0]);
2752 win32_close(p[1]);
2753 if (oldfd != -1) {
2754 win32_dup2(oldfd, stdfd);
2755 win32_close(oldfd);
2756 }
2757 return (NULL);
2758
4b556e6c 2759#endif /* USE_RTL_POPEN */
0a753a76 2760}
2761
50892819
GS		 2762/*
2763 * pclose() clone
2764 */
2765
68dc0745 2766DllExport int
00b02797 2767win32_pclose(PerlIO *pf)
0a753a76 2768{
4b556e6c 2769#ifdef USE_RTL_POPEN
390b85e7 2770 return _pclose(pf);
50892819 2771#else
acfe0abc 2772 dTHX;
e17cb2a9
JD		 2773 int childpid, status;
2774 SV *sv;
2775
4755096e 2776 LOCK_FDPID_MUTEX;
00b02797 2777 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
4755096e 2778
e17cb2a9
JD		 2779 if (SvIOK(sv))
2780 childpid = SvIVX(sv);
2781 else
2782 childpid = 0;
50892819
GS		 2783
2784 if (!childpid) {
2785 errno = EBADF;
2786 return -1;
2787 }
2788
00b02797
JH		 2789#ifdef USE_PERLIO
2790 PerlIO_close(pf);
2791#else
2792 fclose(pf);
2793#endif
e17cb2a9 2794 SvIVX(sv) = 0;
4755096e 2795 UNLOCK_FDPID_MUTEX;
e17cb2a9 2796
0aaad0ff
GS		 2797 if (win32_waitpid(childpid, &status, 0) == -1)
2798 return -1;
50892819 2799
0aaad0ff 2800 return status;
50892819 2801
4b556e6c 2802#endif /* USE_RTL_POPEN */
0a753a76 2803}
6b980173
JD		 2804
2805static BOOL WINAPI
2806Nt4CreateHardLinkW(
2807 LPCWSTR lpFileName,
2808 LPCWSTR lpExistingFileName,
2809 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2810{
2811 HANDLE handle;
2812 WCHAR wFullName[MAX_PATH+1];
2813 LPVOID lpContext = NULL;
2814 WIN32_STREAM_ID StreamId;
2815 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2816 DWORD dwWritten;
2817 DWORD dwLen;
2818 BOOL bSuccess;
2819
2820 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2821 BOOL, BOOL, LPVOID*) =
2822 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2823 BOOL, BOOL, LPVOID*))
2824 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2825 if (pfnBackupWrite == NULL)
2826 return 0;
2827
2828 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2829 if (dwLen == 0)
2830 return 0;
2831 dwLen = (dwLen+1)*sizeof(WCHAR);
2832
2833 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2834 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2835 NULL, OPEN_EXISTING, 0, NULL);
2836 if (handle == INVALID_HANDLE_VALUE)
2837 return 0;
2838
2839 StreamId.dwStreamId = BACKUP_LINK;
2840 StreamId.dwStreamAttributes = 0;
2841 StreamId.dwStreamNameSize = 0;
6f24f39d
JK		 2842#if defined(__BORLANDC__) \
2843 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
4ce4f76e
GS		 2844 StreamId.Size.u.HighPart = 0;
2845 StreamId.Size.u.LowPart = dwLen;
2846#else
6b980173
JD		 2847 StreamId.Size.HighPart = 0;
2848 StreamId.Size.LowPart = dwLen;
4ce4f76e 2849#endif
6b980173
JD		 2850
2851 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
2852 FALSE, FALSE, &lpContext);
2853 if (bSuccess) {
2854 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
2855 FALSE, FALSE, &lpContext);
2856 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
2857 }
2858
2859 CloseHandle(handle);
2860 return bSuccess;
2861}
2862
2863DllExport int
2864win32_link(const char *oldname, const char *newname)
2865{
acfe0abc 2866 dTHX;
6b980173 2867 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
82867ecf
GS		 2868 WCHAR wOldName[MAX_PATH+1];
2869 WCHAR wNewName[MAX_PATH+1];
6b980173
JD		 2870
2871 if (IsWin95())
1be9d9c6 2872 Perl_croak(aTHX_ PL_no_func, "link");
6b980173
JD		 2873
2874 pfnCreateHardLinkW =
2875 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
2876 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
2877 if (pfnCreateHardLinkW == NULL)
2878 pfnCreateHardLinkW = Nt4CreateHardLinkW;
2879
2880 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
2881 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
7766f137
GS		 2882 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
2883 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
6b980173
JD		 2884 {
2885 return 0;
2886 }
2887 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
2888 return -1;
2889}
0a753a76 2890
68dc0745 2891DllExport int
8d9b2e3c 2892win32_rename(const char *oname, const char *newname)
e24c7c18 2893{
65cb15a1
GS		 2894 WCHAR wOldName[MAX_PATH+1];
2895 WCHAR wNewName[MAX_PATH+1];
2896 char szOldName[MAX_PATH+1];
2897 char szNewName[MAX_PATH+1];
7fac1903 2898 BOOL bResult;
acfe0abc 2899 dTHX;
65cb15a1 2900
80252599
GS		 2901 /* XXX despite what the documentation says about MoveFileEx(),
2902 * it doesn't work under Windows95!
2903 */
2904 if (IsWinNT()) {
65cb15a1 2905 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
7fac1903 2906 if (USING_WIDE()) {
0cb96387
GS		 2907 A2WHELPER(oname, wOldName, sizeof(wOldName));
2908 A2WHELPER(newname, wNewName, sizeof(wNewName));
65cb15a1
GS		 2909 if (wcsicmp(wNewName, wOldName))
2910 dwFlags |= MOVEFILE_REPLACE_EXISTING;
7766f137 2911 wcscpy(wOldName, PerlDir_mapW(wOldName));
65cb15a1 2912 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
7fac1903
GS		 2913 }
2914 else {
65cb15a1
GS		 2915 if (stricmp(newname, oname))
2916 dwFlags |= MOVEFILE_REPLACE_EXISTING;
2917 strcpy(szOldName, PerlDir_mapA(oname));
2918 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
7fac1903
GS		 2919 }
2920 if (!bResult) {
80252599
GS		 2921 DWORD err = GetLastError();
2922 switch (err) {
2923 case ERROR_BAD_NET_NAME:
2924 case ERROR_BAD_NETPATH:
2925 case ERROR_BAD_PATHNAME:
2926 case ERROR_FILE_NOT_FOUND:
2927 case ERROR_FILENAME_EXCED_RANGE:
2928 case ERROR_INVALID_DRIVE:
2929 case ERROR_NO_MORE_FILES:
2930 case ERROR_PATH_NOT_FOUND:
2931 errno = ENOENT;
2932 break;
2933 default:
2934 errno = EACCES;
2935 break;
2936 }
2937 return -1;
2938 }
2939 return 0;
e24c7c18 2940 }
80252599
GS		 2941 else {
2942 int retval = 0;
65cb15a1 2943 char szTmpName[MAX_PATH+1];
80252599
GS		 2944 char dname[MAX_PATH+1];
2945 char *endname = Nullch;
2946 STRLEN tmplen = 0;
2947 DWORD from_attr, to_attr;
2948
65cb15a1
GS		 2949 strcpy(szOldName, PerlDir_mapA(oname));
2950 strcpy(szNewName, PerlDir_mapA(newname));
2951
80252599 2952 /* if oname doesn't exist, do nothing */
65cb15a1 2953 from_attr = GetFileAttributes(szOldName);
80252599
GS		 2954 if (from_attr == 0xFFFFFFFF) {
2955 errno = ENOENT;
2956 return -1;
2957 }
2958
2959 /* if newname exists, rename it to a temporary name so that we
2960 * don't delete it in case oname happens to be the same file
2961 * (but perhaps accessed via a different path)
2962 */
65cb15a1 2963 to_attr = GetFileAttributes(szNewName);
80252599
GS		 2964 if (to_attr != 0xFFFFFFFF) {
2965 /* if newname is a directory, we fail
2966 * XXX could overcome this with yet more convoluted logic */
2967 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
2968 errno = EACCES;
2969 return -1;
2970 }
65cb15a1
GS		 2971 tmplen = strlen(szNewName);
2972 strcpy(szTmpName,szNewName);
2973 endname = szTmpName+tmplen;
2974 for (; endname > szTmpName ; --endname) {
80252599
GS		 2975 if (*endname == '/' || *endname == '\\') {
2976 *endname = '\0';
2977 break;
2978 }
2979 }
65cb15a1
GS		 2980 if (endname > szTmpName)
2981 endname = strcpy(dname,szTmpName);
e24c7c18 2982 else
80252599
GS		 2983 endname = ".";
2984
2985 /* get a temporary filename in same directory
2986 * XXX is this really the best we can do? */
65cb15a1 2987 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
80252599
GS		 2988 errno = ENOENT;
2989 return -1;
2990 }
65cb15a1 2991 DeleteFile(szTmpName);
80252599 2992
65cb15a1 2993 retval = rename(szNewName, szTmpName);
80252599
GS		 2994 if (retval != 0) {
2995 errno = EACCES;
2996 return retval;
e24c7c18
GS		 2997 }
2998 }
80252599
GS		 2999
3000 /* rename oname to newname */
65cb15a1 3001 retval = rename(szOldName, szNewName);
80252599
GS		 3002
3003 /* if we created a temporary file before ... */
3004 if (endname != Nullch) {
3005 /* ...and rename succeeded, delete temporary file/directory */
3006 if (retval == 0)
65cb15a1 3007 DeleteFile(szTmpName);
80252599
GS		 3008 /* else restore it to what it was */
3009 else
65cb15a1 3010 (void)rename(szTmpName, szNewName);
80252599
GS		 3011 }
3012 return retval;
e24c7c18 3013 }
e24c7c18
GS		 3014}
3015
3016DllExport int
68dc0745 3017win32_setmode(int fd, int mode)
0a753a76 3018{
390b85e7 3019 return setmode(fd, mode);
0a753a76 3020}
3021
c623ac67
GS		 3022DllExport Off_t
3023win32_lseek(int fd, Off_t offset, int origin)
96e4d5b1 3024{
c623ac67
GS		 3025#if defined(WIN64) || defined(USE_LARGE_FILES)
3026 return _lseeki64(fd, offset, origin);
3027#else
390b85e7 3028 return lseek(fd, offset, origin);
c623ac67 3029#endif
96e4d5b1 3030}
3031
c623ac67 3032DllExport Off_t
96e4d5b1 3033win32_tell(int fd)
3034{
c623ac67
GS		 3035#if defined(WIN64) || defined(USE_LARGE_FILES)
3036 return _telli64(fd);
3037#else
390b85e7 3038 return tell(fd);
c623ac67 3039#endif
96e4d5b1 3040}
3041
68dc0745 3042DllExport int
3043win32_open(const char *path, int flag, ...)
0a753a76 3044{
acfe0abc 3045 dTHX;
68dc0745 3046 va_list ap;
3047 int pmode;
82867ecf 3048 WCHAR wBuffer[MAX_PATH+1];
0a753a76 3049
3050 va_start(ap, flag);
3051 pmode = va_arg(ap, int);
3052 va_end(ap);
3053
68dc0745 3054 if (stricmp(path, "/dev/null")==0)
7fac1903
GS		 3055 path = "NUL";
3056
3057 if (USING_WIDE()) {
0cb96387 3058 A2WHELPER(path, wBuffer, sizeof(wBuffer));
7766f137 3059 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
7fac1903 3060 }
7766f137 3061 return open(PerlDir_mapA(path), flag, pmode);
0a753a76 3062}
3063
00b02797
JH		 3064/* close() that understands socket */
3065extern int my_close(int); /* in win32sck.c */
3066
68dc0745 3067DllExport int
3068win32_close(int fd)
0a753a76 3069{
00b02797 3070 return my_close(fd);
0a753a76 3071}
3072
68dc0745 3073DllExport int
96e4d5b1 3074win32_eof(int fd)
3075{
390b85e7 3076 return eof(fd);
96e4d5b1 3077}
3078
3079DllExport int
68dc0745 3080win32_dup(int fd)
0a753a76 3081{
390b85e7 3082 return dup(fd);
0a753a76 3083}
3084
68dc0745 3085DllExport int
3086win32_dup2(int fd1,int fd2)
0a753a76 3087{
390b85e7 3088 return dup2(fd1,fd2);
0a753a76 3089}
3090
f7aeb604
GS		 3091#ifdef PERL_MSVCRT_READFIX
3092
3093#define LF 10 /* line feed */
3094#define CR 13 /* carriage return */
3095#define CTRLZ 26 /* ctrl-z means eof for text */
3096#define FOPEN 0x01 /* file handle open */
3097#define FEOFLAG 0x02 /* end of file has been encountered */
3098#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3099#define FPIPE 0x08 /* file handle refers to a pipe */
3100#define FAPPEND 0x20 /* file handle opened O_APPEND */
3101#define FDEV 0x40 /* file handle refers to device */
3102#define FTEXT 0x80 /* file handle is in text mode */
3103#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3104
b181b6fb
GS		 3105int __cdecl
3106_fixed_read(int fh, void *buf, unsigned cnt)
f7aeb604
GS		 3107{
3108 int bytes_read; /* number of bytes read */
3109 char *buffer; /* buffer to read to */
3110 int os_read; /* bytes read on OS call */
3111 char *p, *q; /* pointers into buffer */
3112 char peekchr; /* peek-ahead character */
3113 ULONG filepos; /* file position after seek */
3114 ULONG dosretval; /* o.s. return value */
3115
3116 /* validate handle */
3117 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3118 !(_osfile(fh) & FOPEN))
3119 {
3120 /* out of range -- return error */
3121 errno = EBADF;
3122 _doserrno = 0; /* not o.s. error */
3123 return -1;
3124 }
3125
635bbe87
GS		 3126 /*
3127 * If lockinitflag is FALSE, assume fd is device
3128 * lockinitflag is set to TRUE by open.
3129 */
3130 if (_pioinfo(fh)->lockinitflag)
3131 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
f7aeb604
GS		 3132
3133 bytes_read = 0; /* nothing read yet */
3134 buffer = (char*)buf;
3135
3136 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3137 /* nothing to read or at EOF, so return 0 read */
3138 goto functionexit;
3139 }
3140
3141 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3142 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3143 * char */
3144 *buffer++ = _pipech(fh);
3145 ++bytes_read;
3146 --cnt;
3147 _pipech(fh) = LF; /* mark as empty */
3148 }
3149
3150 /* read the data */
3151
3152 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3153 {
3154 /* ReadFile has reported an error. recognize two special cases.
3155 *
3156 * 1. map ERROR_ACCESS_DENIED to EBADF
3157 *
3158 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3159 * means the handle is a read-handle on a pipe for which
3160 * all write-handles have been closed and all data has been
3161 * read. */
3162
3163 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3164 /* wrong read/write mode should return EBADF, not EACCES */
3165 errno = EBADF;
3166 _doserrno = dosretval;
3167 bytes_read = -1;
3168 goto functionexit;
3169 }
3170 else if (dosretval == ERROR_BROKEN_PIPE) {
3171 bytes_read = 0;
3172 goto functionexit;
3173 }
3174 else {
3175 bytes_read = -1;
3176 goto functionexit;
3177 }
3178 }
3179
3180 bytes_read += os_read; /* update bytes read */
3181
3182 if (_osfile(fh) & FTEXT) {
3183 /* now must translate CR-LFs to LFs in the buffer */
3184
3185 /* set CRLF flag to indicate LF at beginning of buffer */
3186 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3187 /* _osfile(fh) |= FCRLF; */
3188 /* else */
3189 /* _osfile(fh) &= ~FCRLF; */
3190
3191 _osfile(fh) &= ~FCRLF;
3192
3193 /* convert chars in the buffer: p is src, q is dest */
3194 p = q = (char*)buf;
3195 while (p < (char *)buf + bytes_read) {
3196 if (*p == CTRLZ) {
3197 /* if fh is not a device, set ctrl-z flag */
3198 if (!(_osfile(fh) & FDEV))
3199 _osfile(fh) |= FEOFLAG;
3200 break; /* stop translating */
3201 }
3202 else if (*p != CR)
3203 *q++ = *p++;
3204 else {
3205 /* *p is CR, so must check next char for LF */
3206 if (p < (char *)buf + bytes_read - 1) {
3207 if (*(p+1) == LF) {
3208 p += 2;
3209 *q++ = LF; /* convert CR-LF to LF */
3210 }
3211 else
3212 *q++ = *p++; /* store char normally */
3213 }
3214 else {
3215 /* This is the hard part. We found a CR at end of
3216 buffer. We must peek ahead to see if next char
3217 is an LF. */
3218 ++p;
3219
3220 dosretval = 0;
3221 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3222 (LPDWORD)&os_read, NULL))
3223 dosretval = GetLastError();
3224
3225 if (dosretval != 0 || os_read == 0) {
3226 /* couldn't read ahead, store CR */
3227 *q++ = CR;
3228 }
3229 else {
3230 /* peekchr now has the extra character -- we now
3231 have several possibilities:
3232 1. disk file and char is not LF; just seek back
3233 and copy CR
3234 2. disk file and char is LF; store LF, don't seek back
3235 3. pipe/device and char is LF; store LF.
3236 4. pipe/device and char isn't LF, store CR and
3237 put char in pipe lookahead buffer. */
3238 if (_osfile(fh) & (FDEV|FPIPE)) {
3239 /* non-seekable device */
3240 if (peekchr == LF)
3241 *q++ = LF;
3242 else {
3243 *q++ = CR;
3244 _pipech(fh) = peekchr;
3245 }
3246 }
3247 else {
3248 /* disk file */
3249 if (peekchr == LF) {
3250 /* nothing read yet; must make some
3251 progress */
3252 *q++ = LF;
3253 /* turn on this flag for tell routine */
3254 _osfile(fh) |= FCRLF;
3255 }
3256 else {
3257 HANDLE osHandle; /* o.s. handle value */
3258 /* seek back */
3259 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3260 {
3261 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3262 dosretval = GetLastError();
3263 }
3264 if (peekchr != LF)
3265 *q++ = CR;
3266 }
3267 }
3268 }
3269 }
3270 }
3271 }
3272
3273 /* we now change bytes_read to reflect the true number of chars
3274 in the buffer */
3275 bytes_read = q - (char *)buf;
3276 }
3277
3fadfdf1 3278functionexit:
635bbe87
GS		 3279 if (_pioinfo(fh)->lockinitflag)
3280 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
f7aeb604
GS		 3281
3282 return bytes_read;
3283}
3284
3285#endif /* PERL_MSVCRT_READFIX */
3286
68dc0745 3287DllExport int
3e3baf6d 3288win32_read(int fd, void *buf, unsigned int cnt)
0a753a76 3289{
f7aeb604
GS		 3290#ifdef PERL_MSVCRT_READFIX
3291 return _fixed_read(fd, buf, cnt);
3292#else
390b85e7 3293 return read(fd, buf, cnt);
f7aeb604 3294#endif
0a753a76 3295}
3296
68dc0745 3297DllExport int
3e3baf6d 3298win32_write(int fd, const void *buf, unsigned int cnt)
0a753a76 3299{
390b85e7 3300 return write(fd, buf, cnt);
0a753a76 3301}
3302
68dc0745 3303DllExport int
5aabfad6 3304win32_mkdir(const char *dir, int mode)
3305{
acfe0abc 3306 dTHX;
7766f137 3307 if (USING_WIDE()) {
82867ecf 3308 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3309 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3310 return _wmkdir(PerlDir_mapW(wBuffer));
3311 }
3312 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
5aabfad6 3313}
96e4d5b1 3314
5aabfad6 3315DllExport int
3316win32_rmdir(const char *dir)
3317{
acfe0abc 3318 dTHX;
7766f137 3319 if (USING_WIDE()) {
82867ecf 3320 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3321 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3322 return _wrmdir(PerlDir_mapW(wBuffer));
3323 }
3324 return rmdir(PerlDir_mapA(dir));
5aabfad6 3325}
96e4d5b1 3326
5aabfad6 3327DllExport int
3328win32_chdir(const char *dir)
3329{
4ae93879 3330 dTHX;
9ec3348a
JH		 3331 if (!dir) {
3332 errno = ENOENT;
3333 return -1;
3334 }
7766f137 3335 if (USING_WIDE()) {
82867ecf 3336 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3337 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3338 return _wchdir(wBuffer);
3339 }
390b85e7 3340 return chdir(dir);
5aabfad6 3341}
96e4d5b1 3342
7766f137
GS		 3343DllExport int
3344win32_access(const char *path, int mode)
3345{
acfe0abc 3346 dTHX;
7766f137 3347 if (USING_WIDE()) {
82867ecf 3348 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3349 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3350 return _waccess(PerlDir_mapW(wBuffer), mode);
3351 }
3352 return access(PerlDir_mapA(path), mode);
3353}
3354
3355DllExport int
3356win32_chmod(const char *path, int mode)
3357{
acfe0abc 3358 dTHX;
7766f137 3359 if (USING_WIDE()) {
82867ecf 3360 WCHAR wBuffer[MAX_PATH+1];
7766f137
GS		 3361 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3362 return _wchmod(PerlDir_mapW(wBuffer), mode);
3363 }
3364 return chmod(PerlDir_mapA(path), mode);
3365}
3366
3367
0aaad0ff 3368static char *
dd7038b3 3369create_command_line(char *cname, STRLEN clen, const char * const *args)
0aaad0ff 3370{
acfe0abc 3371 dTHX;
b309b8ae
JH		 3372 int index, argc;
3373 char *cmd, *ptr;
3374 const char *arg;
3375 STRLEN len = 0;
81bc1258 3376 bool bat_file = FALSE;
b309b8ae 3377 bool cmd_shell = FALSE;
7b11e424 3378 bool dumb_shell = FALSE;
b309b8ae 3379 bool extra_quotes = FALSE;
dd7038b3 3380 bool quote_next = FALSE;
81bc1258
JH		 3381
3382 if (!cname)
3383 cname = (char*)args[0];
b309b8ae
JH		 3384
3385 /* The NT cmd.exe shell has the following peculiarity that needs to be
3386 * worked around. It strips a leading and trailing dquote when any
3387 * of the following is true:
3388 * 1. the /S switch was used
3389 * 2. there are more than two dquotes
3390 * 3. there is a special character from this set: &<>()@^|
3391 * 4. no whitespace characters within the two dquotes
3392 * 5. string between two dquotes isn't an executable file
3393 * To work around this, we always add a leading and trailing dquote
3394 * to the string, if the first argument is either "cmd.exe" or "cmd",
3395 * and there were at least two or more arguments passed to cmd.exe
3396 * (not including switches).
dd7038b3
JH		 3397 * XXX the above rules (from "cmd /?") don't seem to be applied
3398 * always, making for the convolutions below :-(
b309b8ae 3399 */
81bc1258 3400 if (cname) {
dd7038b3
JH		 3401 if (!clen)
3402 clen = strlen(cname);
3403
81bc1258
JH		 3404 if (clen > 4
3405 && (stricmp(&cname[clen-4], ".bat") == 0
3406 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3407 {
3408 bat_file = TRUE;
3409 len += 3;
3410 }
dd7038b3
JH		 3411 else {
3412 char *exe = strrchr(cname, '/');
3413 char *exe2 = strrchr(cname, '\\');
3414 if (exe2 > exe)
3415 exe = exe2;
3416 if (exe)
3417 ++exe;
3418 else
3419 exe = cname;
3420 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3421 cmd_shell = TRUE;
3422 len += 3;
3423 }
7b11e424
JH		 3424 else if (stricmp(exe, "command.com") == 0
3425 || stricmp(exe, "command") == 0)
3426 {
3427 dumb_shell = TRUE;
3428 }
81bc1258 3429 }
b309b8ae 3430 }
0aaad0ff 3431
b309b8ae
JH		 3432 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3433 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3434 STRLEN curlen = strlen(arg);
3435 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3436 len += 2; /* assume quoting needed (worst case) */
3437 len += curlen + 1;
3438 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3439 }
3440 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
0aaad0ff 3441
b309b8ae 3442 argc = index;
0aaad0ff
GS		 3443 New(1310, cmd, len, char);
3444 ptr = cmd;
0aaad0ff 3445
81bc1258
JH		 3446 if (bat_file) {
3447 *ptr++ = '"';
3448 extra_quotes = TRUE;
3449 }
3450
0aaad0ff 3451 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
b309b8ae
JH		 3452 bool do_quote = 0;
3453 STRLEN curlen = strlen(arg);
3454
81bc1258
JH		 3455 /* we want to protect empty arguments and ones with spaces with
3456 * dquotes, but only if they aren't already there */
7b11e424
JH		 3457 if (!dumb_shell) {
3458 if (!curlen) {
3459 do_quote = 1;
3460 }
02ef22d5
JH		 3461 else if (quote_next) {
3462 /* see if it really is multiple arguments pretending to
3463 * be one and force a set of quotes around it */
3464 if (*find_next_space(arg))
3465 do_quote = 1;
3466 }
7b11e424
JH		 3467 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3468 STRLEN i = 0;
3469 while (i < curlen) {
3470 if (isSPACE(arg[i])) {
3471 do_quote = 1;
02ef22d5
JH		 3472 }
3473 else if (arg[i] == '"') {
3474 do_quote = 0;
7b11e424
JH		 3475 break;
3476 }
3477 i++;
b309b8ae 3478 }
b309b8ae 3479 }
dd7038b3 3480 }
b309b8ae
JH		 3481
3482 if (do_quote)
3483 *ptr++ = '"';
3484
18a945d4 3485 strcpy(ptr, arg);
b309b8ae
JH		 3486 ptr += curlen;
3487
3488 if (do_quote)
3489 *ptr++ = '"';
3490
3491 if (args[index+1])
3492 *ptr++ = ' ';
3493
81bc1258
JH		 3494 if (!extra_quotes
3495 && cmd_shell
dd7038b3 3496 && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
b309b8ae 3497 {
dd7038b3
JH		 3498 /* is there a next argument? */
3499 if (args[index+1]) {
3500 /* are there two or more next arguments? */
3501 if (args[index+2]) {
3502 *ptr++ = '"';
3503 extra_quotes = TRUE;
3504 }
3505 else {
02ef22d5 3506 /* single argument, force quoting if it has spaces */
dd7038b3
JH		 3507 quote_next = TRUE;
3508 }
3509 }
b309b8ae 3510 }
0aaad0ff
GS		 3511 }
3512
b309b8ae
JH		 3513 if (extra_quotes)
3514 *ptr++ = '"';
3515
3516 *ptr = '\0';
3517
0aaad0ff
GS		 3518 return cmd;
3519}
3520
3521static char *
3522qualified_path(const char *cmd)
3523{
acfe0abc 3524 dTHX;
0aaad0ff
GS		 3525 char *pathstr;
3526 char *fullcmd, *curfullcmd;
3527 STRLEN cmdlen = 0;
3528 int has_slash = 0;
3529
3530 if (!cmd)
3531 return Nullch;
3532 fullcmd = (char*)cmd;
3533 while (*fullcmd) {
3534 if (*fullcmd == '/' || *fullcmd == '\\')
3535 has_slash++;
3536 fullcmd++;
3537 cmdlen++;
3538 }
3539
3540 /* look in PATH */
2fb9ab56 3541 pathstr = PerlEnv_getenv("PATH");
0aaad0ff
GS		 3542 New(0, fullcmd, MAX_PATH+1, char);
3543 curfullcmd = fullcmd;
3544
3545 while (1) {
3546 DWORD res;
3547
3548 /* start by appending the name to the current prefix */
3549 strcpy(curfullcmd, cmd);
3550 curfullcmd += cmdlen;
3551
3552 /* if it doesn't end with '.', or has no extension, try adding
3553 * a trailing .exe first */
3554 if (cmd[cmdlen-1] != '.'
3555 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3556 {
3557 strcpy(curfullcmd, ".exe");
3558 res = GetFileAttributes(fullcmd);
3559 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3560 return fullcmd;
3561 *curfullcmd = '\0';
3562 }
3563
3564 /* that failed, try the bare name */
3565 res = GetFileAttributes(fullcmd);
3566 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3567 return fullcmd;
3568
3569 /* quit if no other path exists, or if cmd already has path */
3570 if (!pathstr || !*pathstr || has_slash)
3571 break;
3572
3573 /* skip leading semis */
3574 while (*pathstr == ';')
3575 pathstr++;
3576
3577 /* build a new prefix from scratch */
3578 curfullcmd = fullcmd;
3579 while (*pathstr && *pathstr != ';') {
3580 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3581 pathstr++; /* skip initial '"' */
3582 while (*pathstr && *pathstr != '"') {
eb160463 3583 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
0aaad0ff
GS		 3584 *curfullcmd++ = *pathstr;
3585 pathstr++;
3586 }
3587 if (*pathstr)
3588 pathstr++; /* skip trailing '"' */
3589 }
3590 else {
eb160463 3591 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
0aaad0ff
GS		 3592 *curfullcmd++ = *pathstr;
3593 pathstr++;
3594 }
3595 }
3596 if (*pathstr)
3597 pathstr++; /* skip trailing semi */
3598 if (curfullcmd > fullcmd /* append a dir separator */
3599 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3600 {
3601 *curfullcmd++ = '\\';
3602 }
3603 }
eb160463 3604
0aaad0ff
GS		 3605 Safefree(fullcmd);
3606 return Nullch;
3607}
3608
3075ddba
GS		 3609/* The following are just place holders.
3610 * Some hosts may provide and environment that the OS is
3611 * not tracking, therefore, these host must provide that
3612 * environment and the current directory to CreateProcess
3613 */
3614
df3728a2
JH		 3615DllExport void*
3616win32_get_childenv(void)
3075ddba
GS		 3617{
3618 return NULL;
3619}
3620
df3728a2
JH		 3621DllExport void
3622win32_free_childenv(void* d)
3075ddba
GS		 3623{
3624}
3625
df3728a2
JH		 3626DllExport void
3627win32_clearenv(void)
3628{
3629 char *envv = GetEnvironmentStrings();
3630 char *cur = envv;
3631 STRLEN len;
3632 while (*cur) {
3633 char *end = strchr(cur,'=');
3634 if (end && end != cur) {
3635 *end = '\0';
3636 SetEnvironmentVariable(cur, NULL);
3637 *end = '=';
3638 cur = end + strlen(end+1)+2;
3639 }
3640 else if ((len = strlen(cur)))
3641 cur += len+1;
3642 }
3643 FreeEnvironmentStrings(envv);
3644}
3645
3646DllExport char*
3647win32_get_childdir(void)
3075ddba 3648{
acfe0abc 3649 dTHX;
7766f137
GS		 3650 char* ptr;
3651 char szfilename[(MAX_PATH+1)*2];
3652 if (USING_WIDE()) {
3653 WCHAR wfilename[MAX_PATH+1];
3654 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3655 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3656 }
3657 else {
3658 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3659 }
3660
3661 New(0, ptr, strlen(szfilename)+1, char);
3662 strcpy(ptr, szfilename);
3663 return ptr;
3075ddba
GS		 3664}
3665
df3728a2
JH		 3666DllExport void
3667win32_free_childdir(char* d)
3075ddba 3668{
acfe0abc 3669 dTHX;
7766f137 3670 Safefree(d);
3075ddba
GS		 3671}
3672
3673
0aaad0ff
GS		 3674/* XXX this needs to be made more compatible with the spawnvp()
3675 * provided by the various RTLs. In particular, searching for
3676 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3677 * This doesn't significantly affect perl itself, because we
3678 * always invoke things using PERL5SHELL if a direct attempt to
3679 * spawn the executable fails.
3fadfdf1 3680 *
0aaad0ff
GS		 3681 * XXX splitting and rejoining the commandline between do_aspawn()
3682 * and win32_spawnvp() could also be avoided.
3683 */
3684
5aabfad6 3685DllExport int
3e3baf6d 3686win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
0a753a76 3687{
0aaad0ff
GS		 3688#ifdef USE_RTL_SPAWNVP
3689 return spawnvp(mode, cmdname, (char * const *)argv);
3690#else
acfe0abc 3691 dTHX;
2b260de0 3692 int ret;
3075ddba
GS		 3693 void* env;
3694 char* dir;
635bbe87 3695 child_IO_table tbl;
0aaad0ff
GS		 3696 STARTUPINFO StartupInfo;
3697 PROCESS_INFORMATION ProcessInformation;
3698 DWORD create = 0;
dd7038b3 3699 char *cmd;
0aaad0ff 3700 char *fullcmd = Nullch;
dd7038b3
JH		 3701 char *cname = (char *)cmdname;
3702 STRLEN clen = 0;
3703
3704 if (cname) {
3705 clen = strlen(cname);
3706 /* if command name contains dquotes, must remove them */
3707 if (strchr(cname, '"')) {
3708 cmd = cname;
3709 New(0,cname,clen+1,char);
3710 clen = 0;
3711 while (*cmd) {
3712 if (*cmd != '"') {
3713 cname[clen] = *cmd;
3714 ++clen;
3715 }
3716 ++cmd;
3717 }
3718 cname[clen] = '\0';
3719 }
3720 }
3721
3722 cmd = create_command_line(cname, clen, argv);
0aaad0ff 3723
3075ddba
GS		 3724 env = PerlEnv_get_childenv();
3725 dir = PerlEnv_get_childdir();
3726
0aaad0ff
GS		 3727 switch(mode) {
3728 case P_NOWAIT: /* asynch + remember result */
3729 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3730 errno = EAGAIN;
3731 ret = -1;
3732 goto RETVAL;
3733 }
3fadfdf1 3734 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
7e5f34c0
NIS		 3735 * in win32_kill()
3736 */
3fadfdf1 3737 create |= CREATE_NEW_PROCESS_GROUP;
0aaad0ff 3738 /* FALL THROUGH */
7e5f34c0 3739
0aaad0ff
GS		 3740 case P_WAIT: /* synchronous execution */
3741 break;
3742 default: /* invalid mode */
3743 errno = EINVAL;
3744 ret = -1;
3745 goto RETVAL;
3746 }
3747 memset(&StartupInfo,0,sizeof(StartupInfo));
3748 StartupInfo.cb = sizeof(StartupInfo);
f83751a7 3749 memset(&tbl,0,sizeof(tbl));
635bbe87 3750 PerlEnv_get_child_IO(&tbl);
f83751a7 3751 StartupInfo.dwFlags = tbl.dwFlags;
3fadfdf1
NIS		 3752 StartupInfo.dwX = tbl.dwX;
3753 StartupInfo.dwY = tbl.dwY;
3754 StartupInfo.dwXSize = tbl.dwXSize;
3755 StartupInfo.dwYSize = tbl.dwYSize;
3756 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3757 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3758 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3759 StartupInfo.wShowWindow = tbl.wShowWindow;
f83751a7
GS		 3760 StartupInfo.hStdInput = tbl.childStdIn;
3761 StartupInfo.hStdOutput = tbl.childStdOut;
3762 StartupInfo.hStdError = tbl.childStdErr;
139cf11b
GS		 3763 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3764 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3765 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
3ffaa937 3766 {
139cf11b 3767 create |= CREATE_NEW_CONSOLE;
3ffaa937
GS		 3768 }
3769 else {
139cf11b 3770 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
3ffaa937 3771 }
02637f4c
JD		 3772 if (w32_use_showwindow) {
3773 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
3774 StartupInfo.wShowWindow = w32_showwindow;
3775 }
3ffaa937 3776
b309b8ae 3777 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
dd7038b3 3778 cname,cmd));
0aaad0ff 3779RETRY:
dd7038b3 3780 if (!CreateProcess(cname, /* search PATH to find executable */
0aaad0ff
GS		 3781 cmd, /* executable, and its arguments */
3782 NULL, /* process attributes */
3783 NULL, /* thread attributes */
3784 TRUE, /* inherit handles */
3785 create, /* creation flags */
3075ddba
GS		 3786 (LPVOID)env, /* inherit environment */
3787 dir, /* inherit cwd */
0aaad0ff
GS		 3788 &StartupInfo,
3789 &ProcessInformation))
3790 {
3791 /* initial NULL argument to CreateProcess() does a PATH
3792 * search, but it always first looks in the directory
3793 * where the current process was started, which behavior
3794 * is undesirable for backward compatibility. So we
3795 * jump through our own hoops by picking out the path
3796 * we really want it to use. */
3797 if (!fullcmd) {
dd7038b3 3798 fullcmd = qualified_path(cname);
0aaad0ff 3799 if (fullcmd) {
dd7038b3
JH		 3800 if (cname != cmdname)
3801 Safefree(cname);
3802 cname = fullcmd;
b309b8ae
JH		 3803 DEBUG_p(PerlIO_printf(Perl_debug_log,
3804 "Retrying [%s] with same args\n",
dd7038b3 3805 cname));
0aaad0ff
GS		 3806 goto RETRY;
3807 }
3808 }
3809 errno = ENOENT;
3810 ret = -1;
3811 goto RETVAL;
3812 }
2d7a9237 3813
0aaad0ff
GS		 3814 if (mode == P_NOWAIT) {
3815 /* asynchronous spawn -- store handle, return PID */
2b260de0 3816 ret = (int)ProcessInformation.dwProcessId;
922b1888
GS		 3817 if (IsWin95() && ret < 0)
3818 ret = -ret;
3819
3820 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
3821 w32_child_pids[w32_num_children] = (DWORD)ret;
0aaad0ff
GS		 3822 ++w32_num_children;
3823 }
3824 else {
2b260de0 3825 DWORD status;
8fb3fcfb 3826 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
7e5f34c0
NIS		 3827 /* FIXME: if msgwait returned due to message perhaps forward the
3828 "signal" to the process
3829 */
2b260de0
GS		 3830 GetExitCodeProcess(ProcessInformation.hProcess, &status);
3831 ret = (int)status;
0aaad0ff
GS		 3832 CloseHandle(ProcessInformation.hProcess);
3833 }
e17cb2a9 3834
0aaad0ff 3835 CloseHandle(ProcessInformation.hThread);
3075ddba 3836
0aaad0ff 3837RETVAL:
3075ddba
GS		 3838 PerlEnv_free_childenv(env);
3839 PerlEnv_free_childdir(dir);
0aaad0ff 3840 Safefree(cmd);
dd7038b3
JH		 3841 if (cname != cmdname)
3842 Safefree(cname);
2b260de0 3843 return ret;
2d7a9237 3844#endif
0a753a76 3845}
3846
6890e559 3847DllExport int
eb62e965
JD		 3848win32_execv(const char *cmdname, const char *const *argv)
3849{
7766f137 3850#ifdef USE_ITHREADS
acfe0abc 3851 dTHX;
7766f137
GS		 3852 /* if this is a pseudo-forked child, we just want to spawn
3853 * the new program, and return */
3854 if (w32_pseudo_id)
3855 return spawnv(P_WAIT, cmdname, (char *const *)argv);
3856#endif
eb62e965
JD		 3857 return execv(cmdname, (char *const *)argv);
3858}
3859
3860DllExport int
6890e559
GS		 3861win32_execvp(const char *cmdname, const char *const *argv)
3862{
7766f137 3863#ifdef USE_ITHREADS
acfe0abc 3864 dTHX;
7766f137
GS		 3865 /* if this is a pseudo-forked child, we just want to spawn
3866 * the new program, and return */
190e4ad0 3867 if (w32_pseudo_id) {
ba6ce41c
GS		 3868 int status = win32_spawnvp(P_WAIT, cmdname, (char *const *)argv);
3869 if (status != -1) {
3870 my_exit(status);
3871 return 0;
3872 }
3873 else
3874 return status;
190e4ad0 3875 }
7766f137 3876#endif
390b85e7 3877 return execvp(cmdname, (char *const *)argv);
6890e559
GS		 3878}
3879
84902520
TB		 3880DllExport void
3881win32_perror(const char *str)
3882{
390b85e7 3883 perror(str);
84902520
TB		 3884}
3885
3886DllExport void
3887win32_setbuf(FILE *pf, char *buf)
3888{
390b85e7 3889 setbuf(pf, buf);
84902520
TB		 3890}
3891
3892DllExport int
3893win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
3894{
390b85e7 3895 return setvbuf(pf, buf, type, size);
84902520
TB		 3896}
3897
3898DllExport int
3899win32_flushall(void)
3900{
390b85e7 3901 return flushall();
84902520
TB		 3902}
3903
3904DllExport int
3905win32_fcloseall(void)
3906{
390b85e7 3907 return fcloseall();
84902520
TB		 3908}
3909
3910DllExport char*
3911win32_fgets(char *s, int n, FILE *pf)
3912{
390b85e7 3913 return fgets(s, n, pf);
84902520
TB		 3914}
3915
3916DllExport char*
3917win32_gets(char *s)
3918{
390b85e7 3919 return gets(s);
84902520
TB		 3920}
3921
3922DllExport int
3923win32_fgetc(FILE *pf)
3924{
390b85e7 3925 return fgetc(pf);
84902520
TB		 3926}
3927
3928DllExport int
3929win32_putc(int c, FILE *pf)
3930{
390b85e7 3931 return putc(c,pf);
84902520
TB		 3932}
3933
3934DllExport int
3935win32_puts(const char *s)
3936{
390b85e7 3937 return puts(s);
84902520
TB		 3938}
3939
3940DllExport int
3941win32_getchar(void)
3942{
390b85e7 3943 return getchar();
84902520
TB		 3944}
3945
3946DllExport int
3947win32_putchar(int c)
3948{
390b85e7 3949 return putchar(c);
84902520
TB		 3950}
3951
bbc8f9de
NIS		 3952#ifdef MYMALLOC
3953
3954#ifndef USE_PERL_SBRK
3955
df3728a2
JH		 3956static char *committed = NULL; /* XXX threadead */
3957static char *base = NULL; /* XXX threadead */
3958static char *reserved = NULL; /* XXX threadead */
3959static char *brk = NULL; /* XXX threadead */
3960static DWORD pagesize = 0; /* XXX threadead */
3961static DWORD allocsize = 0; /* XXX threadead */
bbc8f9de
NIS		 3962
3963void *
c623ac67 3964sbrk(ptrdiff_t need)
bbc8f9de
NIS		 3965{
3966 void *result;
3967 if (!pagesize)
3968 {SYSTEM_INFO info;
3969 GetSystemInfo(&info);
3970 /* Pretend page size is larger so we don't perpetually
3971 * call the OS to commit just one page ...
3972 */
3973 pagesize = info.dwPageSize << 3;
3974 allocsize = info.dwAllocationGranularity;
3975 }
3976 /* This scheme fails eventually if request for contiguous
3fadfdf1 3977 * block is denied so reserve big blocks - this is only
bbc8f9de
NIS		 3978 * address space not memory ...
3979 */
3980 if (brk+need >= reserved)
3981 {
3982 DWORD size = 64*1024*1024;
3983 char *addr;
3984 if (committed && reserved && committed < reserved)
3985 {
3986 /* Commit last of previous chunk cannot span allocations */
161b471a 3987 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS		 3988 if (addr)
3989 committed = reserved;
3990 }
3fadfdf1 3991 /* Reserve some (more) space
bbc8f9de
NIS		 3992 * Note this is a little sneaky, 1st call passes NULL as reserved
3993 * so lets system choose where we start, subsequent calls pass
3994 * the old end address so ask for a contiguous block
3995 */
161b471a 3996 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
bbc8f9de
NIS		 3997 if (addr)
3998 {
3999 reserved = addr+size;
4000 if (!base)
4001 base = addr;
4002 if (!committed)
4003 committed = base;
4004 if (!brk)
4005 brk = committed;
4006 }
4007 else
4008 {
4009 return (void *) -1;
4010 }
4011 }
4012 result = brk;
4013 brk += need;
4014 if (brk > committed)
4015 {
4016 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
161b471a 4017 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
bbc8f9de
NIS		 4018 if (addr)
4019 {
4020 committed += size;
4021 }
4022 else
4023 return (void *) -1;
4024 }
4025 return result;
4026}
4027
4028#endif
4029#endif
4030
84902520
TB		 4031DllExport void*
4032win32_malloc(size_t size)
4033{
390b85e7 4034 return malloc(size);
84902520
TB		 4035}
4036
4037DllExport void*
4038win32_calloc(size_t numitems, size_t size)
4039{
390b85e7 4040 return calloc(numitems,size);
84902520
TB		 4041}
4042
4043DllExport void*
4044win32_realloc(void *block, size_t size)
4045{
390b85e7 4046 return realloc(block,size);
84902520
TB		 4047}
4048
4049DllExport void
4050win32_free(void *block)
4051{
390b85e7 4052 free(block);
84902520
TB		 4053}
4054
bbc8f9de 4055
6e21dc91 4056DllExport int
c623ac67 4057win32_open_osfhandle(intptr_t handle, int flags)
0a753a76 4058{
9e5f57de
GS		 4059#ifdef USE_FIXED_OSFHANDLE
4060 if (IsWin95())
4061 return my_open_osfhandle(handle, flags);
4062#endif
390b85e7 4063 return _open_osfhandle(handle, flags);
0a753a76 4064}
4065
6e21dc91 4066DllExport intptr_t
65e48ea9 4067win32_get_osfhandle(int fd)
0a753a76 4068{
c623ac67 4069 return (intptr_t)_get_osfhandle(fd);
0a753a76 4070}
7bac28a0 4071
6e21dc91 4072DllExport FILE *
30753f56
NIS		 4073win32_fdupopen(FILE *pf)
4074{
4075 FILE* pfdup;
4076 fpos_t pos;
4077 char mode[3];
4078 int fileno = win32_dup(win32_fileno(pf));
4079
4080 /* open the file in the same mode */
4081#ifdef __BORLANDC__
4082 if((pf)->flags & _F_READ) {
4083 mode[0] = 'r';
4084 mode[1] = 0;
4085 }
4086 else if((pf)->flags & _F_WRIT) {
4087 mode[0] = 'a';
4088 mode[1] = 0;
4089 }
4090 else if((pf)->flags & _F_RDWR) {
4091 mode[0] = 'r';
4092 mode[1] = '+';
4093 mode[2] = 0;
4094 }
4095#else
4096 if((pf)->_flag & _IOREAD) {
4097 mode[0] = 'r';
4098 mode[1] = 0;
4099 }
4100 else if((pf)->_flag & _IOWRT) {
4101 mode[0] = 'a';
4102 mode[1] = 0;
4103 }
4104 else if((pf)->_flag & _IORW) {
4105 mode[0] = 'r';
4106 mode[1] = '+';
4107 mode[2] = 0;
4108 }
4109#endif
4110
4111 /* it appears that the binmode is attached to the
4112 * file descriptor so binmode files will be handled
4113 * correctly
4114 */
4115 pfdup = win32_fdopen(fileno, mode);
4116
4117 /* move the file pointer to the same position */
4118 if (!fgetpos(pf, &pos)) {
4119 fsetpos(pfdup, &pos);
4120 }
4121 return pfdup;
4122}
4123
0cb96387 4124DllExport void*
c5be433b 4125win32_dynaload(const char* filename)
0cb96387 4126{
acfe0abc 4127 dTHX;
51371543 4128 HMODULE hModule;
32f99636
GS		 4129 char buf[MAX_PATH+1];
4130 char *first;
4131
4132 /* LoadLibrary() doesn't recognize forward slashes correctly,
4133 * so turn 'em back. */
4134 first = strchr(filename, '/');
4135 if (first) {
4136 STRLEN len = strlen(filename);
4137 if (len <= MAX_PATH) {
4138 strcpy(buf, filename);
4139 filename = &buf[first - filename];
4140 while (*filename) {
4141 if (*filename == '/')
4142 *(char*)filename = '\\';
4143 ++filename;
4144 }
4145 filename = buf;
4146 }
4147 }
0cb96387 4148 if (USING_WIDE()) {
82867ecf 4149 WCHAR wfilename[MAX_PATH+1];
0cb96387 4150 A2WHELPER(filename, wfilename, sizeof(wfilename));
7766f137 4151 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS		 4152 }
4153 else {
7766f137 4154 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
0cb96387
GS		 4155 }
4156 return hModule;
4157}
4158
7bac28a0 4159/*
4160 * Extras.
4161 */
4162
ad2e33dc 4163static
02637f4c
JD		 4164XS(w32_SetChildShowWindow)
4165{
4166 dXSARGS;
4167 BOOL use_showwindow = w32_use_showwindow;
4168 /* use "unsigned short" because Perl has redefined "WORD" */
4169 unsigned short showwindow = w32_showwindow;
4170
4171 if (items > 1)
4172 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4173
4174 if (items == 0 || !SvOK(ST(0)))
4175 w32_use_showwindow = FALSE;
4176 else {
4177 w32_use_showwindow = TRUE;
4178 w32_showwindow = (unsigned short)SvIV(ST(0));
4179 }
4180
4181 EXTEND(SP, 1);
4182 if (use_showwindow)
4183 ST(0) = sv_2mortal(newSViv(showwindow));
4184 else
4185 ST(0) = &PL_sv_undef;
4186 XSRETURN(1);
4187}
4188
4189static
ad2e33dc
GS		 4190XS(w32_GetCwd)
4191{
4192 dXSARGS;
7766f137
GS		 4193 /* Make the host for current directory */
4194 char* ptr = PerlEnv_get_childdir();
3fadfdf1
NIS		 4195 /*
4196 * If ptr != Nullch
4197 * then it worked, set PV valid,
4198 * else return 'undef'
ad2e33dc 4199 */
7766f137
GS		 4200 if (ptr) {
4201 SV *sv = sv_newmortal();
4202 sv_setpv(sv, ptr);
4203 PerlEnv_free_childdir(ptr);
4204
617e632e
NK		 4205#ifndef INCOMPLETE_TAINTS
4206 SvTAINTED_on(sv);
4207#endif
4208
7766f137 4209 EXTEND(SP,1);
ad2e33dc 4210 SvPOK_on(sv);
bb897dfc
JD		 4211 ST(0) = sv;
4212 XSRETURN(1);
4213 }
3467312b 4214 XSRETURN_UNDEF;
ad2e33dc
GS		 4215}
4216
4217static
4218XS(w32_SetCwd)
4219{
4220 dXSARGS;
4221 if (items != 1)
4f63d024 4222 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
7766f137 4223 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
ad2e33dc
GS		 4224 XSRETURN_YES;
4225
4226 XSRETURN_NO;
4227}
4228
4229static
4230XS(w32_GetNextAvailDrive)
4231{
4232 dXSARGS;
4233 char ix = 'C';
4234 char root[] = "_:\\";
3467312b
JD		 4235
4236 EXTEND(SP,1);
ad2e33dc
GS		 4237 while (ix <= 'Z') {
4238 root[0] = ix++;
4239 if (GetDriveType(root) == 1) {
4240 root[2] = '\0';
4241 XSRETURN_PV(root);
4242 }
4243 }
3467312b 4244 XSRETURN_UNDEF;
ad2e33dc
GS		 4245}
4246
4247static
4248XS(w32_GetLastError)
4249{
4250 dXSARGS;
bb897dfc 4251 EXTEND(SP,1);
ad2e33dc
GS		 4252 XSRETURN_IV(GetLastError());
4253}
4254
4255static
ca135624
JD		 4256XS(w32_SetLastError)
4257{
4258 dXSARGS;
4259 if (items != 1)
4f63d024 4260 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
ca135624 4261 SetLastError(SvIV(ST(0)));
bb897dfc 4262 XSRETURN_EMPTY;
ca135624
JD		 4263}
4264
4265static
ad2e33dc
GS		 4266XS(w32_LoginName)
4267{
4268 dXSARGS;
3352bfcb
GS		 4269 char *name = w32_getlogin_buffer;
4270 DWORD size = sizeof(w32_getlogin_buffer);
3467312b 4271 EXTEND(SP,1);
ad2e33dc
GS		 4272 if (GetUserName(name,&size)) {
4273 /* size includes NULL */
79cb57f6 4274 ST(0) = sv_2mortal(newSVpvn(name,size-1));
ad2e33dc
GS		 4275 XSRETURN(1);
4276 }
3467312b 4277 XSRETURN_UNDEF;
ad2e33dc
GS		 4278}
4279
4280static
4281XS(w32_NodeName)
4282{
4283 dXSARGS;
4284 char name[MAX_COMPUTERNAME_LENGTH+1];
4285 DWORD size = sizeof(name);
3467312b 4286 EXTEND(SP,1);
ad2e33dc
GS		 4287 if (GetComputerName(name,&size)) {
4288 /* size does NOT include NULL :-( */
79cb57f6 4289 ST(0) = sv_2mortal(newSVpvn(name,size));
ad2e33dc
GS		 4290 XSRETURN(1);
4291 }
3467312b 4292 XSRETURN_UNDEF;
ad2e33dc
GS		 4293}
4294
4295
4296static
4297XS(w32_DomainName)
4298{
4299 dXSARGS;
da147683
JD		 4300 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4301 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4302 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4303 void *bufptr);
625a29bd 4304
da147683
JD		 4305 if (hNetApi32) {
4306 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4307 GetProcAddress(hNetApi32, "NetApiBufferFree");
4308 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4309 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
d12db45c 4310 }
da147683
JD		 4311 EXTEND(SP,1);
4312 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4313 /* this way is more reliable, in case user has a local account. */
4314 char dname[256];
4315 DWORD dnamelen = sizeof(dname);
4316 struct {
4317 DWORD wki100_platform_id;
4318 LPWSTR wki100_computername;
4319 LPWSTR wki100_langroup;
4320 DWORD wki100_ver_major;
4321 DWORD wki100_ver_minor;
4322 } *pwi;
4323 /* NERR_Success *is* 0*/
4324 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4325 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4326 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_langroup,
4327 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4328 }
4329 else {
4330 WideCharToMultiByte(CP_ACP, NULL, pwi->wki100_computername,
4331 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4332 }
4333 pfnNetApiBufferFree(pwi);
4334 FreeLibrary(hNetApi32);
4335 XSRETURN_PV(dname);
4336 }
4337 FreeLibrary(hNetApi32);
ad2e33dc 4338 }
625a29bd 4339 else {
da147683
JD		 4340 /* Win95 doesn't have NetWksta*(), so do it the old way */
4341 char name[256];
4342 DWORD size = sizeof(name);
4343 if (hNetApi32)
4344 FreeLibrary(hNetApi32);
4345 if (GetUserName(name,&size)) {
4346 char sid[ONE_K_BUFSIZE];
4347 DWORD sidlen = sizeof(sid);
4348 char dname[256];
4349 DWORD dnamelen = sizeof(dname);
4350 SID_NAME_USE snu;
4351 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4352 dname, &dnamelen, &snu)) {
4353 XSRETURN_PV(dname); /* all that for this */
4354 }
4355 }
9404a519 4356 }
da147683 4357 XSRETURN_UNDEF;
ad2e33dc
GS		 4358}
4359
4360static
4361XS(w32_FsType)
4362{
4363 dXSARGS;
4364 char fsname[256];
4365 DWORD flags, filecomplen;
4366 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4367 &flags, fsname, sizeof(fsname))) {
bb897dfc 4368 if (GIMME_V == G_ARRAY) {
79cb57f6 4369 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
ad2e33dc
GS		 4370 XPUSHs(sv_2mortal(newSViv(flags)));
4371 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4372 PUTBACK;
4373 return;
4374 }
bb897dfc 4375 EXTEND(SP,1);
ad2e33dc
GS		 4376 XSRETURN_PV(fsname);
4377 }
bb897dfc 4378 XSRETURN_EMPTY;
ad2e33dc
GS		 4379}
4380
4381static
4382XS(w32_GetOSVersion)
4383{
4384 dXSARGS;
7766f137 4385 OSVERSIONINFOA osver;
ad2e33dc 4386
7766f137
GS		 4387 if (USING_WIDE()) {
4388 OSVERSIONINFOW osverw;
4389 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4390 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4391 if (!GetVersionExW(&osverw)) {
4392 XSRETURN_EMPTY;
4393 }
4394 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4395 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4396 osver.dwMajorVersion = osverw.dwMajorVersion;
4397 osver.dwMinorVersion = osverw.dwMinorVersion;
4398 osver.dwBuildNumber = osverw.dwBuildNumber;
4399 osver.dwPlatformId = osverw.dwPlatformId;
4400 }
4401 else {
4402 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4403 if (!GetVersionExA(&osver)) {
4404 XSRETURN_EMPTY;
4405 }
79cb57f6 4406 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
ad2e33dc 4407 }
7766f137
GS		 4408 XPUSHs(newSViv(osver.dwMajorVersion));
4409 XPUSHs(newSViv(osver.dwMinorVersion));
4410 XPUSHs(newSViv(osver.dwBuildNumber));
4411 XPUSHs(newSViv(osver.dwPlatformId));
4412 PUTBACK;
ad2e33dc
GS		 4413}
4414
4415static
4416XS(w32_IsWinNT)
4417{
4418 dXSARGS;
bb897dfc 4419 EXTEND(SP,1);
ad2e33dc
GS		 4420 XSRETURN_IV(IsWinNT());
4421}
4422
4423static
4424XS(w32_IsWin95)
4425{
4426 dXSARGS;
bb897dfc 4427 EXTEND(SP,1);
ad2e33dc
GS		 4428 XSRETURN_IV(IsWin95());
4429}
4430
4431static
4432XS(w32_FormatMessage)
4433{
4434 dXSARGS;
4435 DWORD source = 0;
7766f137 4436 char msgbuf[ONE_K_BUFSIZE];
ad2e33dc
GS		 4437
4438 if (items != 1)
4f63d024 4439 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
ad2e33dc 4440
7766f137
GS		 4441 if (USING_WIDE()) {
4442 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4443 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4444 &source, SvIV(ST(0)), 0,
4445 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4446 {
4447 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4448 XSRETURN_PV(msgbuf);
4449 }
4450 }
4451 else {
4452 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4453 &source, SvIV(ST(0)), 0,
4454 msgbuf, sizeof(msgbuf)-1, NULL))
4455 XSRETURN_PV(msgbuf);
4456 }
ad2e33dc 4457
3467312b 4458 XSRETURN_UNDEF;
ad2e33dc
GS		 4459}
4460
4461static
4462XS(w32_Spawn)
4463{
4464 dXSARGS;
4465 char *cmd, *args;
33005217
JD		 4466 void *env;
4467 char *dir;
ad2e33dc
GS		 4468 PROCESS_INFORMATION stProcInfo;
4469 STARTUPINFO stStartInfo;
4470 BOOL bSuccess = FALSE;
4471
9404a519 4472 if (items != 3)
4f63d024 4473 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
ad2e33dc 4474
bb897dfc
JD		 4475 cmd = SvPV_nolen(ST(0));
4476 args = SvPV_nolen(ST(1));
ad2e33dc 4477
33005217
JD		 4478 env = PerlEnv_get_childenv();
4479 dir = PerlEnv_get_childdir();
4480
ad2e33dc
GS		 4481 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4482 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4483 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4484 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4485
9404a519 4486 if (CreateProcess(
ad2e33dc
GS		 4487 cmd, /* Image path */
4488 args, /* Arguments for command line */
4489 NULL, /* Default process security */
4490 NULL, /* Default thread security */
4491 FALSE, /* Must be TRUE to use std handles */
4492 NORMAL_PRIORITY_CLASS, /* No special scheduling */
33005217
JD		 4493 env, /* Inherit our environment block */
4494 dir, /* Inherit our currrent directory */
ad2e33dc
GS		 4495 &stStartInfo, /* -> Startup info */
4496 &stProcInfo)) /* <- Process info (if OK) */
4497 {
922b1888
GS		 4498 int pid = (int)stProcInfo.dwProcessId;
4499 if (IsWin95() && pid < 0)
4500 pid = -pid;
4501 sv_setiv(ST(2), pid);
ad2e33dc 4502 CloseHandle(stProcInfo.hThread);/* library source code does this. */
ad2e33dc
GS		 4503 bSuccess = TRUE;
4504 }
33005217
JD		 4505 PerlEnv_free_childenv(env);
4506 PerlEnv_free_childdir(dir);
ad2e33dc
GS		 4507 XSRETURN_IV(bSuccess);
4508}
4509
4510static
4511XS(w32_GetTickCount)
4512{
4513 dXSARGS;
fdb068fa 4514 DWORD msec = GetTickCount();
a6c40364 4515 EXTEND(SP,1);
fdb068fa
JD		 4516 if ((IV)msec > 0)
4517 XSRETURN_IV(msec);
4518 XSRETURN_NV(msec);
ad2e33dc
GS		 4519}
4520
4521static
4522XS(w32_GetShortPathName)
4523{
4524 dXSARGS;
4525 SV *shortpath;
e8bab181 4526 DWORD len;
ad2e33dc 4527
9404a519 4528 if (items != 1)
4f63d024 4529 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
ad2e33dc
GS		 4530
4531 shortpath = sv_mortalcopy(ST(0));
4532 SvUPGRADE(shortpath, SVt_PV);
631c0b04
GS		 4533 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4534 XSRETURN_UNDEF;
4535
ad2e33dc 4536 /* src == target is allowed */
e8bab181
GS		 4537 do {
4538 len = GetShortPathName(SvPVX(shortpath),
4539 SvPVX(shortpath),
4540 SvLEN(shortpath));
4541 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4542 if (len) {
4543 SvCUR_set(shortpath,len);
ad2e33dc 4544 ST(0) = shortpath;
bb897dfc 4545 XSRETURN(1);
e8bab181 4546 }
3467312b 4547 XSRETURN_UNDEF;
ad2e33dc
GS		 4548}
4549
ad0751ec 4550static
ca135624
JD		 4551XS(w32_GetFullPathName)
4552{
4553 dXSARGS;
4554 SV *filename;
4555 SV *fullpath;
4556 char *filepart;
4557 DWORD len;
4558
4559 if (items != 1)
4f63d024 4560 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
ca135624
JD		 4561
4562 filename = ST(0);
4563 fullpath = sv_mortalcopy(filename);
4564 SvUPGRADE(fullpath, SVt_PV);
631c0b04
GS		 4565 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4566 XSRETURN_UNDEF;
4567
ca135624
JD		 4568 do {
4569 len = GetFullPathName(SvPVX(filename),
4570 SvLEN(fullpath),
4571 SvPVX(fullpath),
4572 &filepart);
4573 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4574 if (len) {
4575 if (GIMME_V == G_ARRAY) {
4576 EXTEND(SP,1);
bb897dfc 4577 XST_mPV(1,filepart);
ca135624
JD		 4578 len = filepart - SvPVX(fullpath);
4579 items = 2;
4580 }
4581 SvCUR_set(fullpath,len);
4582 ST(0) = fullpath;
bb897dfc 4583 XSRETURN(items);
ca135624 4584 }
bb897dfc 4585 XSRETURN_EMPTY;
ca135624
JD		 4586}
4587
4588static
8ac9c18d
GS		 4589XS(w32_GetLongPathName)
4590{
4591 dXSARGS;
4592 SV *path;
4593 char tmpbuf[MAX_PATH+1];
4594 char *pathstr;
4595 STRLEN len;
4596
4597 if (items != 1)
4f63d024 4598 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
8ac9c18d
GS		 4599
4600 path = ST(0);
4601 pathstr = SvPV(path,len);
4602 strcpy(tmpbuf, pathstr);
4603 pathstr = win32_longpath(tmpbuf);
4604 if (pathstr) {
4605 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4606 XSRETURN(1);
4607 }
4608 XSRETURN_EMPTY;
4609}
4610
4611static
ad0751ec
GS		 4612XS(w32_Sleep)
4613{
4614 dXSARGS;
4615 if (items != 1)
4f63d024 4616 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
ad0751ec
GS		 4617 Sleep(SvIV(ST(0)));
4618 XSRETURN_YES;
4619}
4620
7509b657
GS		 4621static
4622XS(w32_CopyFile)
4623{
4624 dXSARGS;
7766f137 4625 BOOL bResult;
7509b657 4626 if (items != 3)
4f63d024 4627 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
7766f137 4628 if (USING_WIDE()) {
82867ecf
GS		 4629 WCHAR wSourceFile[MAX_PATH+1];
4630 WCHAR wDestFile[MAX_PATH+1];
7766f137
GS		 4631 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4632 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4633 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4634 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4635 }
4636 else {
82867ecf 4637 char szSourceFile[MAX_PATH+1];
7766f137
GS		 4638 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4639 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4640 }
4641
4642 if (bResult)
7509b657
GS		 4643 XSRETURN_YES;
4644 XSRETURN_NO;
4645}
4646
ad2e33dc 4647void
c5be433b 4648Perl_init_os_extras(void)
ad2e33dc 4649{
acfe0abc 4650 dTHX;
ad2e33dc
GS		 4651 char *file = __FILE__;
4652 dXSUB_SYS;
4653
ad2e33dc
GS		 4654 /* these names are Activeware compatible */
4655 newXS("Win32::GetCwd", w32_GetCwd, file);
4656 newXS("Win32::SetCwd", w32_SetCwd, file);
4657 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4658 newXS("Win32::GetLastError", w32_GetLastError, file);
ca135624 4659 newXS("Win32::SetLastError", w32_SetLastError, file);
ad2e33dc
GS		 4660 newXS("Win32::LoginName", w32_LoginName, file);
4661 newXS("Win32::NodeName", w32_NodeName, file);
4662 newXS("Win32::DomainName", w32_DomainName, file);
4663 newXS("Win32::FsType", w32_FsType, file);
4664 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4665 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4666 newXS("Win32::IsWin95", w32_IsWin95, file);
4667 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4668 newXS("Win32::Spawn", w32_Spawn, file);
4669 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4670 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
ca135624 4671 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
8ac9c18d 4672 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
7509b657 4673 newXS("Win32::CopyFile", w32_CopyFile, file);
ad0751ec 4674 newXS("Win32::Sleep", w32_Sleep, file);
02637f4c 4675 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
ad2e33dc
GS		 4676
4677 /* XXX Bloat Alert! The following Activeware preloads really
4678 * ought to be part of Win32::Sys::*, so they're not included
4679 * here.
4680 */
4681 /* LookupAccountName
4682 * LookupAccountSID
4683 * InitiateSystemShutdown
4684 * AbortSystemShutdown
4685 * ExpandEnvrironmentStrings
4686 */
4687}
4688
f4958739 4689void *
1018e26f 4690win32_signal_context(void)
c843839f
NIS		 4691{
4692 dTHX;
f4958739 4693#ifdef MULTIPLICITY
c843839f 4694 if (!my_perl) {
1018e26f 4695 my_perl = PL_curinterp;
c843839f 4696 PERL_SET_THX(my_perl);
3fadfdf1 4697 }
1018e26f 4698 return my_perl;
f4958739 4699#else
d9a047f6 4700#ifdef USE_5005THREADS
f4958739 4701 return aTHX;
d9a047f6
GS		 4702#else
4703 return PL_curinterp;
4704#endif
f4958739 4705#endif
1018e26f
NIS		 4706}
4707
96116d93 4708
3fadfdf1 4709BOOL WINAPI
1018e26f
NIS		 4710win32_ctrlhandler(DWORD dwCtrlType)
4711{
96116d93 4712#ifdef MULTIPLICITY
1018e26f
NIS		 4713 dTHXa(PERL_GET_SIG_CONTEXT);
4714
4715 if (!my_perl)
4716 return FALSE;
f4958739
GS		 4717#else
4718#ifdef USE_5005THREADS
4719 dTHX;
4720#endif
96116d93 4721#endif
c843839f
NIS		 4722
4723 switch(dwCtrlType) {
4724 case CTRL_CLOSE_EVENT:
3fadfdf1
NIS		 4725 /* A signal that the system sends to all processes attached to a console when
4726 the user closes the console (either by choosing the Close command from the
4727 console window's System menu, or by choosing the End Task command from the
c843839f
NIS		 4728 Task List
4729 */
3fadfdf1
NIS		 4730 if (do_raise(aTHX_ 1)) /* SIGHUP */
4731 sig_terminate(aTHX_ 1);
4732 return TRUE;
c843839f
NIS		 4733
4734 case CTRL_C_EVENT:
4735 /* A CTRL+c signal was received */
3fadfdf1
NIS		 4736 if (do_raise(aTHX_ SIGINT))
4737 sig_terminate(aTHX_ SIGINT);
4738 return TRUE;
c843839f
NIS		 4739
4740 case CTRL_BREAK_EVENT:
4741 /* A CTRL+BREAK signal was received */
3fadfdf1
NIS		 4742 if (do_raise(aTHX_ SIGBREAK))
4743 sig_terminate(aTHX_ SIGBREAK);
4744 return TRUE;
c843839f
NIS		 4745
4746 case CTRL_LOGOFF_EVENT:
3fadfdf1
NIS		 4747 /* A signal that the system sends to all console processes when a user is logging
4748 off. This signal does not indicate which user is logging off, so no
4749 assumptions can be made.
c843839f 4750 */
3fadfdf1 4751 break;
c843839f 4752 case CTRL_SHUTDOWN_EVENT:
3fadfdf1
NIS		 4753 /* A signal that the system sends to all console processes when the system is
4754 shutting down.
c843839f 4755 */
3fadfdf1
NIS		 4756 if (do_raise(aTHX_ SIGTERM))
4757 sig_terminate(aTHX_ SIGTERM);
4758 return TRUE;
c843839f 4759 default:
3fadfdf1 4760 break;
c843839f
NIS		 4761 }
4762 return FALSE;
4763}
c843839f
NIS		 4764
4765
ad2e33dc
GS		 4766void
4767Perl_win32_init(int *argcp, char ***argvp)
4768{
4769 /* Disable floating point errors, Perl will trap the ones we
4770 * care about. VC++ RTL defaults to switching these off
4771 * already, but the Borland RTL doesn't. Since we don't
4772 * want to be at the vendor's whim on the default, we set
4773 * it explicitly here.
4774 */
a835ef8a 4775#if !defined(_ALPHA_) && !defined(__GNUC__)
ad2e33dc 4776 _control87(MCW_EM, MCW_EM);
3dc9191e 4777#endif
4b556e6c 4778 MALLOC_INIT;
ad2e33dc 4779}
d55594ae 4780
635bbe87
GS		 4781void
4782win32_get_child_IO(child_IO_table* ptbl)
4783{
4784 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
4785 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
4786 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
4787}
4788
3fadfdf1
NIS		 4789Sighandler_t
4790win32_signal(int sig, Sighandler_t subcode)
4791{
4792 dTHX;
4793 if (sig < SIG_SIZE) {
4794 int save_errno = errno;
4795 Sighandler_t result = signal(sig, subcode);
4796 if (result == SIG_ERR) {
4797 result = w32_sighandler[sig];
4798 errno = save_errno;
4799 }
4800 w32_sighandler[sig] = subcode;
4801 return result;
4802 }
4803 else {
4804 errno = EINVAL;
4805 return SIG_ERR;
4806 }
4807}
4808
4809
52853b95 4810#ifdef HAVE_INTERP_INTERN
7766f137 4811
c843839f 4812
f646a69a
NIS		 4813static void
4814win32_csighandler(int sig)
4815{
4816#if 0
4817 dTHXa(PERL_GET_SIG_CONTEXT);
4818 Perl_warn(aTHX_ "Got signal %d",sig);
4819#endif
4820 /* Does nothing */
4821}
c843839f 4822
7766f137 4823void
52853b95
GS		 4824Perl_sys_intern_init(pTHX)
4825{
3fadfdf1 4826 int i;
52853b95
GS		 4827 w32_perlshell_tokens = Nullch;
4828 w32_perlshell_vec = (char**)NULL;
4829 w32_perlshell_items = 0;
4830 w32_fdpid = newAV();
4831 New(1313, w32_children, 1, child_tab);
4832 w32_num_children = 0;
4833# ifdef USE_ITHREADS
4834 w32_pseudo_id = 0;
4835 New(1313, w32_pseudo_children, 1, child_tab);
4836 w32_num_pseudo_children = 0;
4837# endif
4838 w32_init_socktype = 0;
222c300a 4839 w32_timerid = 0;
05ec9bb3 4840 w32_poll_count = 0;
3fadfdf1
NIS		 4841 for (i=0; i < SIG_SIZE; i++) {
4842 w32_sighandler[i] = SIG_DFL;
4843 }
96116d93 4844# ifdef MULTIPLICTY
1018e26f 4845 if (my_perl == PL_curinterp) {
96116d93
MB		 4846# else
4847 {
4848# endif
3fadfdf1 4849 /* Force C runtime signal stuff to set its console handler */
f646a69a
NIS		 4850 signal(SIGINT,&win32_csighandler);
4851 signal(SIGBREAK,&win32_csighandler);
3fadfdf1 4852 /* Push our handler on top */
c843839f
NIS		 4853 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
4854 }
52853b95
GS		 4855}
4856
3dbbd0f5
GS		 4857void
4858Perl_sys_intern_clear(pTHX)
4859{
4860 Safefree(w32_perlshell_tokens);
4861 Safefree(w32_perlshell_vec);
4862 /* NOTE: w32_fdpid is freed by sv_clean_all() */
4863 Safefree(w32_children);
222c300a
NIS		 4864 if (w32_timerid) {
4865 KillTimer(NULL,w32_timerid);
3fadfdf1 4866 w32_timerid=0;
222c300a 4867 }
96116d93 4868# ifdef MULTIPLICITY
1018e26f 4869 if (my_perl == PL_curinterp) {
96116d93
MB		 4870# else
4871 {
4872# endif
c843839f 4873 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
c843839f 4874 }
3dbbd0f5
GS		 4875# ifdef USE_ITHREADS
4876 Safefree(w32_pseudo_children);
4877# endif
4878}
4879
52853b95
GS		 4880# ifdef USE_ITHREADS
4881
4882void
7766f137
GS		 4883Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
4884{
4885 dst->perlshell_tokens = Nullch;
4886 dst->perlshell_vec = (char**)NULL;
4887 dst->perlshell_items = 0;
4888 dst->fdpid = newAV();
4889 Newz(1313, dst->children, 1, child_tab);
7766f137 4890 dst->pseudo_id = 0;
52853b95 4891 Newz(1313, dst->pseudo_children, 1, child_tab);
862f1e8c 4892 dst->thr_intern.Winit_socktype = 0;
222c300a 4893 dst->timerid = 0;
05ec9bb3 4894 dst->poll_count = 0;
3fadfdf1 4895 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
7766f137 4896}
52853b95
GS		 4897# endif /* USE_ITHREADS */
4898#endif /* HAVE_INTERP_INTERN */
7766f137 4899
729a02f2 4900static void
acfe0abc 4901win32_free_argvw(pTHX_ void *ptr)
729a02f2
GS		 4902{
4903 char** argv = (char**)ptr;
4904 while(*argv) {
4905 Safefree(*argv);
4906 *argv++ = Nullch;
4907 }
4908}
4909
4910void
c0932edc 4911win32_argv2utf8(int argc, char** argv)
729a02f2 4912{
acfe0abc 4913 dTHX;
729a02f2
GS		 4914 char* psz;
4915 int length, wargc;
4916 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
4917 if (lpwStr && argc) {
4918 while (argc--) {
4919 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
4920 Newz(0, psz, length, char);
4921 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
4922 argv[argc] = psz;
4923 }
4924 call_atexit(win32_free_argvw, argv);
4925 }
4926 GlobalFree((HGLOBAL)lpwStr);
4927}
Unnamed repository; edit this file 'description' to name the repository.