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