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