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