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