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
Run Porting/new-perldelta.pl for v5.23.2
[perl5.git] / win32 / wince.c
CommitLineData
e1caacb4
JH		 1/* WINCE.C - stuff for Windows CE
2 *
ca6c63e1 3 * Time-stamp: <26/10/01 15:25:20 keuchel@keuchelnt>
e1caacb4
JH		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 */
8
9#define WIN32_LEAN_AND_MEAN
10#define WIN32IO_IS_STDIO
11#include <windows.h>
216db7ee 12#include <signal.h>
e1caacb4 13
f4257e4d 14#define PERLIO_NOT_STDIO 0
e1caacb4 15
97cb92d6 16#if !defined(PERLIO_IS_STDIO)
e1caacb4
JH		 17#define PerlIO FILE
18#endif
19
20#define wince_private
21#include "errno.h"
22
23#include "EXTERN.h"
24#include "perl.h"
25
26#define NO_XSLOCKS
27#define PERL_NO_GET_CONTEXT
28#include "XSUB.h"
29
30#include "win32iop.h"
31#include <string.h>
32#include <stdarg.h>
33#include <float.h>
34#include <shellapi.h>
814ffeea 35#include <process.h>
e1caacb4
JH		 36
37#define perl
38#include "celib_defs.h"
39#include "cewin32.h"
40#include "cecrt.h"
41#include "cewin32_defs.h"
42#include "cecrt_defs.h"
43
94081db1
VK		 44#define GetCurrentDirectoryW XCEGetCurrentDirectoryW
45
e1caacb4
JH		 46#ifdef PALM_SIZE
47#include "stdio-palmsize.h"
48#endif
49
50#define EXECF_EXEC 1
51#define EXECF_SPAWN 2
52#define EXECF_SPAWN_NOWAIT 3
53
54#if defined(PERL_IMPLICIT_SYS)
e1caacb4
JH		 55# undef do_spawn
56# define do_spawn g_do_spawn
57# undef getlogin
58# define getlogin g_getlogin
59#endif
60
814ffeea
VK		 61static void get_shell(void);
62static long tokenize(const char *str, char **dest, char ***destv);
63static int do_spawn2(pTHX_ char *cmd, int exectype);
64static BOOL has_shell_metachars(char *ptr);
e1caacb4
JH		 65static long filetime_to_clock(PFILETIME ft);
66static BOOL filetime_from_time(PFILETIME ft, time_t t);
e6a0bbf8
NC		 67static char * get_emd_part(SV **leading, STRLEN *const len,
68 char *trailing, ...);
814ffeea 69static void remove_dead_process(long deceased);
04a2c3d9 70static long find_pid(pTHX_ int pid);
814ffeea 71static char * qualified_path(const char *cmd);
e1caacb4 72static char * win32_get_xlib(const char *pl, const char *xlib,
e6a0bbf8 73 const char *libname, STRLEN *const len);
e1caacb4 74
814ffeea
VK		 75#ifdef USE_ITHREADS
76static void remove_dead_pseudo_process(long child);
04a2c3d9 77static long find_pseudo_pid(pTHX_ int pid);
814ffeea
VK		 78#endif
79
80int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */
81
e1caacb4
JH		 82START_EXTERN_C
83HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
84char w32_module_name[MAX_PATH+1];
85END_EXTERN_C
86
87static DWORD w32_platform = (DWORD)-1;
88
f4257e4d 89int
e1caacb4
JH		 90IsWin95(void)
91{
92 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
93}
94
95int
96IsWinNT(void)
97{
98 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
99}
100
101int
102IsWinCE(void)
103{
104 return (win32_os_id() == VER_PLATFORM_WIN32_CE);
105}
106
107EXTERN_C void
108set_w32_module_name(void)
109{
110 char* ptr;
111 XCEGetModuleFileNameA((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
112 ? XCEGetModuleHandleA(NULL)
113 : w32_perldll_handle),
114 w32_module_name, sizeof(w32_module_name));
115
116 /* normalize to forward slashes */
117 ptr = w32_module_name;
118 while (*ptr) {
119 if (*ptr == '\\')
120 *ptr = '/';
121 ++ptr;
122 }
123}
124
125/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
126static char*
127get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
128{
129 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
130 HKEY handle;
131 DWORD type;
132 const char *subkey = "Software\\Perl";
4e205ed6 133 char *str = NULL;
e1caacb4
JH		 134 long retval;
135
136 retval = XCERegOpenKeyExA(hkey, subkey, 0, KEY_READ, &handle);
137 if (retval == ERROR_SUCCESS) {
138 DWORD datalen;
139 retval = XCERegQueryValueExA(handle, valuename, 0, &type, NULL, &datalen);
140 if (retval == ERROR_SUCCESS && type == REG_SZ) {
acfe0abc 141 dTHX;
e1caacb4 142 if (!*svp)
c2b90b61 143 *svp = sv_2mortal(newSVpvs(""));
e1caacb4
JH		 144 SvGROW(*svp, datalen);
145 retval = XCERegQueryValueExA(handle, valuename, 0, NULL,
146 (PBYTE)SvPVX(*svp), &datalen);
147 if (retval == ERROR_SUCCESS) {
148 str = SvPVX(*svp);
149 SvCUR_set(*svp,datalen-1);
150 }
151 }
152 RegCloseKey(handle);
153 }
154 return str;
155}
156
157/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
158static char*
159get_regstr(const char *valuename, SV **svp)
160{
161 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
162 if (!str)
163 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
164 return str;
165}
166
167/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
168static char *
e6a0bbf8 169get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...)
e1caacb4
JH		 170{
171 char base[10];
172 va_list ap;
173 char mod_name[MAX_PATH+1];
174 char *ptr;
175 char *optr;
176 char *strip;
177 int oldsize, newsize;
178 STRLEN baselen;
179
180 va_start(ap, trailing_path);
181 strip = va_arg(ap, char *);
182
183 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
184 baselen = strlen(base);
185
186 if (!*w32_module_name) {
187 set_w32_module_name();
188 }
189 strcpy(mod_name, w32_module_name);
190 ptr = strrchr(mod_name, '/');
191 while (ptr && strip) {
192 /* look for directories to skip back */
193 optr = ptr;
194 *ptr = '\0';
195 ptr = strrchr(mod_name, '/');
196 /* avoid stripping component if there is no slash,
197 * or it doesn't match ... */
198 if (!ptr || stricmp(ptr+1, strip) != 0) {
199 /* ... but not if component matches m|5\.$patchlevel.*| */
200 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
201 && strncmp(strip, base, baselen) == 0
202 && strncmp(ptr+1, base, baselen) == 0))
203 {
204 *optr = '/';
205 ptr = optr;
206 }
207 }
208 strip = va_arg(ap, char *);
209 }
210 if (!ptr) {
211 ptr = mod_name;
212 *ptr++ = '.';
213 *ptr = '/';
214 }
215 va_end(ap);
216 strcpy(++ptr, trailing_path);
217
218 /* only add directory if it exists */
219 if (XCEGetFileAttributesA(mod_name) != (DWORD) -1) {
220 /* directory exists */
acfe0abc 221 dTHX;
e1caacb4 222 if (!*prev_pathp)
c2b90b61 223 *prev_pathp = sv_2mortal(newSVpvs(""));
46e2868e 224 sv_catpvs(*prev_pathp, ";");
e1caacb4 225 sv_catpv(*prev_pathp, mod_name);
e6a0bbf8
NC		 226 if(len)
227 *len = SvCUR(*prev_pathp);
e1caacb4
JH		 228 return SvPVX(*prev_pathp);
229 }
230
4e205ed6 231 return NULL;
e1caacb4
JH		 232}
233
234char *
e6a0bbf8 235win32_get_privlib(const char *pl, STRLEN *const len)
e1caacb4 236{
acfe0abc 237 dTHX;
e1caacb4
JH		 238 char *stdlib = "lib";
239 char buffer[MAX_PATH+1];
4e205ed6 240 SV *sv = NULL;
e1caacb4
JH		 241
242 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
243 sprintf(buffer, "%s-%s", stdlib, pl);
244 if (!get_regstr(buffer, &sv))
245 (void)get_regstr(stdlib, &sv);
246
247 /* $stdlib .= ";$EMD/../../lib" */
e6a0bbf8 248 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL);
e1caacb4
JH		 249}
250
251static char *
e6a0bbf8
NC		 252win32_get_xlib(const char *pl, const char *xlib, const char *libname,
253 STRLEN *const len)
e1caacb4 254{
acfe0abc 255 dTHX;
e1caacb4
JH		 256 char regstr[40];
257 char pathstr[MAX_PATH+1];
4e205ed6
SP		 258 SV *sv1 = NULL;
259 SV *sv2 = NULL;
e1caacb4
JH		 260
261 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
262 sprintf(regstr, "%s-%s", xlib, pl);
263 (void)get_regstr(regstr, &sv1);
264
265 /* $xlib .=
266 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
267 sprintf(pathstr, "%s/%s/lib", libname, pl);
e6a0bbf8 268 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
e1caacb4
JH		 269
270 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
271 (void)get_regstr(xlib, &sv2);
272
273 /* $xlib .=
274 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
275 sprintf(pathstr, "%s/lib", libname);
e6a0bbf8 276 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL);
e1caacb4
JH		 277
278 if (!sv1 && !sv2)
4e205ed6 279 return NULL;
e6a0bbf8
NC		 280 if (!sv1) {
281 sv1 = sv2;
282 } else if (sv2) {
46e2868e 283 sv_catpvs(sv1, ";");
e6a0bbf8
NC		 284 sv_catsv(sv1, sv2);
285 }
e1caacb4 286
e6a0bbf8
NC		 287 if (len)
288 *len = SvCUR(sv1);
e1caacb4
JH		 289 return SvPVX(sv1);
290}
291
292char *
e6a0bbf8 293win32_get_sitelib(const char *pl, STRLEN *const len)
e1caacb4 294{
e6a0bbf8 295 return win32_get_xlib(pl, "sitelib", "site", len);
e1caacb4
JH		 296}
297
298#ifndef PERL_VENDORLIB_NAME
299# define PERL_VENDORLIB_NAME "vendor"
300#endif
301
302char *
e6a0bbf8 303win32_get_vendorlib(const char *pl, STRLEN *const len)
e1caacb4 304{
e6a0bbf8 305 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len);
e1caacb4
JH		 306}
307
814ffeea
VK		 308static BOOL
309has_shell_metachars(char *ptr)
310{
311 int inquote = 0;
312 char quote = '\0';
313
314 /*
315 * Scan string looking for redirection (< or >) or pipe
316 * characters (|) that are not in a quoted string.
317 * Shell variable interpolation (%VAR%) can also happen inside strings.
318 */
319 while (*ptr) {
320 switch(*ptr) {
321 case '%':
322 return TRUE;
323 case '\'':
324 case '\"':
325 if (inquote) {
326 if (quote == *ptr) {
327 inquote = 0;
328 quote = '\0';
329 }
330 }
331 else {
332 quote = *ptr;
333 inquote++;
334 }
335 break;
336 case '>':
337 case '<':
338 case '|':
339 if (!inquote)
340 return TRUE;
341 default:
342 break;
343 }
344 ++ptr;
345 }
346 return FALSE;
347}
348
e1caacb4
JH		 349#if !defined(PERL_IMPLICIT_SYS)
350/* since the current process environment is being updated in util.c
351 * the library functions will get the correct environment
352 */
353PerlIO *
751e07d2 354Perl_my_popen(pTHX_ const char *cmd, const char *mode)
e1caacb4
JH		 355{
356 printf("popen(%s)\n", cmd);
357
358 Perl_croak(aTHX_ PL_no_func, "popen");
359 return NULL;
360}
361
362long
363Perl_my_pclose(pTHX_ PerlIO *fp)
364{
365 Perl_croak(aTHX_ PL_no_func, "pclose");
366 return -1;
367}
368#endif
369
370DllExport unsigned long
371win32_os_id(void)
372{
373 static OSVERSIONINFOA osver;
374
375 if (osver.dwPlatformId != w32_platform) {
376 memset(&osver, 0, sizeof(OSVERSIONINFOA));
377 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
378 XCEGetVersionExA(&osver);
379 w32_platform = osver.dwPlatformId;
380 }
381 return (unsigned long)w32_platform;
382}
383
384DllExport int
385win32_getpid(void)
386{
814ffeea
VK		 387 int pid;
388#ifdef USE_ITHREADS
389 dTHX;
390 if (w32_pseudo_id)
391 return -((int)w32_pseudo_id);
392#endif
393 pid = xcegetpid();
394 return pid;
e1caacb4
JH		 395}
396
814ffeea
VK		 397/* Tokenize a string. Words are null-separated, and the list
398 * ends with a doubled null. Any character (except null and
399 * including backslash) may be escaped by preceding it with a
400 * backslash (the backslash will be stripped).
401 * Returns number of words in result buffer.
402 */
403static long
404tokenize(const char *str, char **dest, char ***destv)
e1caacb4 405{
4e205ed6 406 char *retstart = NULL;
814ffeea
VK		 407 char **retvstart = 0;
408 int items = -1;
409 if (str) {
410 dTHX;
411 int slen = strlen(str);
eb578fdb
KW		 412 char *ret;
413 char **retv;
a02a5408
JC		 414 Newx(ret, slen+2, char);
415 Newx(retv, (slen+3)/2, char*);
814ffeea
VK		 416
417 retstart = ret;
418 retvstart = retv;
419 *retv = ret;
420 items = 0;
421 while (*str) {
422 *ret = *str++;
423 if (*ret == '\\' && *str)
424 *ret = *str++;
425 else if (*ret == ' ') {
426 while (*str == ' ')
427 str++;
428 if (ret == retstart)
429 ret--;
430 else {
431 *ret = '\0';
432 ++items;
433 if (*str)
434 *++retv = ret+1;
435 }
436 }
437 else if (!*str)
438 ++items;
439 ret++;
440 }
4e205ed6 441 retvstart[items] = NULL;
814ffeea
VK		 442 *ret++ = '\0';
443 *ret = '\0';
444 }
445 *dest = retstart;
446 *destv = retvstart;
447 return items;
e1caacb4
JH		 448}
449
450DllExport int
451win32_pipe(int *pfd, unsigned int size, int mode)
452{
216db7ee 453 dTHX;
e1caacb4
JH		 454 Perl_croak(aTHX_ PL_no_func, "pipe");
455 return -1;
456}
457
458DllExport int
459win32_times(struct tms *timebuf)
460{
216db7ee 461 dTHX;
e1caacb4
JH		 462 Perl_croak(aTHX_ PL_no_func, "times");
463 return -1;
464}
465
216db7ee
VK		 466Sighandler_t
467win32_signal(int sig, Sighandler_t subcode)
42165d27 468{
1829b0dc 469 return xcesignal(sig, subcode);
42165d27 470}
216db7ee 471
814ffeea
VK		 472static void
473get_shell(void)
474{
475 dTHX;
476 if (!w32_perlshell_tokens) {
477 /* we don't use COMSPEC here for two reasons:
478 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
479 * uncontrolled unportability of the ensuing scripts.
480 * 2. PERL5SHELL could be set to a shell that may not be fit for
481 * interactive use (which is what most programs look in COMSPEC
482 * for).
483 */
484 const char* defaultshell = (IsWinNT()
485 ? "cmd.exe /x/d/c" : "command.com /c");
486 const char *usershell = PerlEnv_getenv("PERL5SHELL");
487 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
488 &w32_perlshell_tokens,
489 &w32_perlshell_vec);
490 }
491}
492
493int
494Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
495{
7918f24d
NC		 496 PERL_ARGS_ASSERT_DO_ASPAWN;
497
814ffeea
VK		 498 Perl_croak(aTHX_ PL_no_func, "aspawn");
499 return -1;
500}
42165d27 501
814ffeea
VK		 502/* returns pointer to the next unquoted space or the end of the string */
503static char*
504find_next_space(const char *s)
e1caacb4 505{
814ffeea
VK		 506 bool in_quotes = FALSE;
507 while (*s) {
508 /* ignore doubled backslashes, or backslash+quote */
509 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
510 s += 2;
511 }
512 /* keep track of when we're within quotes */
513 else if (*s == '"') {
514 s++;
515 in_quotes = !in_quotes;
516 }
517 /* break it up only at spaces that aren't in quotes */
518 else if (!in_quotes && isSPACE(*s))
519 return (char*)s;
520 else
521 s++;
522 }
523 return (char*)s;
524}
525
526#if 1
527static int
528do_spawn2(pTHX_ char *cmd, int exectype)
529{
530 char **a;
531 char *s;
532 char **argv;
533 int status = -1;
534 BOOL needToTry = TRUE;
535 char *cmd2;
536
537 /* Save an extra exec if possible. See if there are shell
538 * metacharacters in it */
539 if (!has_shell_metachars(cmd)) {
a02a5408
JC		 540 Newx(argv, strlen(cmd) / 2 + 2, char*);
541 Newx(cmd2, strlen(cmd) + 1, char);
814ffeea
VK		 542 strcpy(cmd2, cmd);
543 a = argv;
544 for (s = cmd2; *s;) {
545 while (*s && isSPACE(*s))
546 s++;
547 if (*s)
548 *(a++) = s;
549 s = find_next_space(s);
550 if (*s)
551 *s++ = '\0';
552 }
4e205ed6 553 *a = NULL;
814ffeea
VK		 554 if (argv[0]) {
555 switch (exectype) {
556 case EXECF_SPAWN:
557 status = win32_spawnvp(P_WAIT, argv[0],
558 (const char* const*)argv);
559 break;
560 case EXECF_SPAWN_NOWAIT:
561 status = win32_spawnvp(P_NOWAIT, argv[0],
562 (const char* const*)argv);
563 break;
564 case EXECF_EXEC:
565 status = win32_execvp(argv[0], (const char* const*)argv);
566 break;
567 }
568 if (status != -1 || errno == 0)
569 needToTry = FALSE;
570 }
571 Safefree(argv);
572 Safefree(cmd2);
573 }
574 if (needToTry) {
575 char **argv;
576 int i = -1;
577 get_shell();
a02a5408 578 Newx(argv, w32_perlshell_items + 2, char*);
814ffeea
VK		 579 while (++i < w32_perlshell_items)
580 argv[i] = w32_perlshell_vec[i];
581 argv[i++] = cmd;
4e205ed6 582 argv[i] = NULL;
814ffeea
VK		 583 switch (exectype) {
584 case EXECF_SPAWN:
585 status = win32_spawnvp(P_WAIT, argv[0],
586 (const char* const*)argv);
587 break;
588 case EXECF_SPAWN_NOWAIT:
589 status = win32_spawnvp(P_NOWAIT, argv[0],
590 (const char* const*)argv);
591 break;
592 case EXECF_EXEC:
593 status = win32_execvp(argv[0], (const char* const*)argv);
594 break;
595 }
596 cmd = argv[0];
597 Safefree(argv);
598 }
599 if (exectype == EXECF_SPAWN_NOWAIT) {
600 if (IsWin95())
601 PL_statusvalue = -1; /* >16bits hint for pp_system() */
602 }
603 else {
604 if (status < 0) {
605 if (ckWARN(WARN_EXEC))
606 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
607 (exectype == EXECF_EXEC ? "exec" : "spawn"),
608 cmd, strerror(errno));
609 status = 255 * 256;
610 }
611 else
612 status *= 256;
613 PL_statusvalue = status;
614 }
615 return (status);
616}
617
618int
619Perl_do_spawn(pTHX_ char *cmd)
620{
7918f24d
NC		 621 PERL_ARGS_ASSERT_DO_SPAWN;
622
814ffeea
VK		 623 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
624}
625
626int
627Perl_do_spawn_nowait(pTHX_ char *cmd)
628{
7918f24d
NC		 629 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
630
814ffeea
VK		 631 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
632}
633
634bool
751e07d2 635Perl_do_exec(pTHX_ const char *cmd)
814ffeea 636{
7918f24d
NC		 637 PERL_ARGS_ASSERT_DO_EXEC;
638
814ffeea
VK		 639 do_spawn2(aTHX_ cmd, EXECF_EXEC);
640 return FALSE;
641}
642
643/* The idea here is to read all the directory names into a string table
644 * (separated by nulls) and when one of the other dir functions is called
645 * return the pointer to the current file name.
646 */
647DllExport DIR *
0e06f75d 648win32_opendir(const char *filename)
814ffeea
VK		 649{
650 dTHX;
651 DIR *dirp;
652 long len;
653 long idx;
654 char scanname[MAX_PATH+3];
655 Stat_t sbuf;
656 WIN32_FIND_DATAA aFindData;
657 WIN32_FIND_DATAW wFindData;
658 HANDLE fh;
659 char buffer[MAX_PATH*2];
660 WCHAR wbuffer[MAX_PATH+1];
661 char* ptr;
662
663 len = strlen(filename);
664 if (len > MAX_PATH)
665 return NULL;
666
667 /* check to see if filename is a directory */
668 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
669 return NULL;
670
671 /* Get us a DIR structure */
a02a5408 672 Newxz(dirp, 1, DIR);
814ffeea
VK		 673
674 /* Create the search pattern */
675 strcpy(scanname, filename);
676
677 /* bare drive name means look in cwd for drive */
678 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
679 scanname[len++] = '.';
680 scanname[len++] = '/';
681 }
682 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
683 scanname[len++] = '/';
684 }
685 scanname[len++] = '*';
686 scanname[len] = '\0';
687
688 /* do the FindFirstFile call */
689 fh = FindFirstFile(PerlDir_mapA(scanname), &aFindData);
690 dirp->handle = fh;
691 if (fh == INVALID_HANDLE_VALUE) {
692 DWORD err = GetLastError();
693 /* FindFirstFile() fails on empty drives! */
694 switch (err) {
695 case ERROR_FILE_NOT_FOUND:
696 return dirp;
697 case ERROR_NO_MORE_FILES:
698 case ERROR_PATH_NOT_FOUND:
699 errno = ENOENT;
700 break;
701 case ERROR_NOT_ENOUGH_MEMORY:
702 errno = ENOMEM;
703 break;
704 default:
705 errno = EINVAL;
706 break;
707 }
708 Safefree(dirp);
709 return NULL;
710 }
711
712 /* now allocate the first part of the string table for
713 * the filenames that we find.
714 */
715 ptr = aFindData.cFileName;
716 idx = strlen(ptr)+1;
717 if (idx < 256)
718 dirp->size = 128;
719 else
720 dirp->size = idx;
a02a5408 721 Newx(dirp->start, dirp->size, char);
814ffeea
VK		 722 strcpy(dirp->start, ptr);
723 dirp->nfiles++;
724 dirp->end = dirp->curr = dirp->start;
725 dirp->end += idx;
726 return dirp;
727}
728
729
730/* Readdir just returns the current string pointer and bumps the
731 * string pointer to the nDllExport entry.
732 */
733DllExport struct direct *
734win32_readdir(DIR *dirp)
735{
736 long len;
737
738 if (dirp->curr) {
739 /* first set up the structure to return */
740 len = strlen(dirp->curr);
741 strcpy(dirp->dirstr.d_name, dirp->curr);
742 dirp->dirstr.d_namlen = len;
743
744 /* Fake an inode */
745 dirp->dirstr.d_ino = dirp->curr - dirp->start;
746
747 /* Now set up for the next call to readdir */
748 dirp->curr += len + 1;
749 if (dirp->curr >= dirp->end) {
750 dTHX;
751 char* ptr;
752 BOOL res;
753 WIN32_FIND_DATAW wFindData;
754 WIN32_FIND_DATAA aFindData;
755 char buffer[MAX_PATH*2];
756
757 /* finding the next file that matches the wildcard
758 * (which should be all of them in this directory!).
759 */
760 res = FindNextFile(dirp->handle, &aFindData);
761 if (res)
762 ptr = aFindData.cFileName;
763 if (res) {
764 long endpos = dirp->end - dirp->start;
765 long newsize = endpos + strlen(ptr) + 1;
766 /* bump the string table size by enough for the
767 * new name and its null terminator */
768 while (newsize > dirp->size) {
769 long curpos = dirp->curr - dirp->start;
770 dirp->size *= 2;
771 Renew(dirp->start, dirp->size, char);
772 dirp->curr = dirp->start + curpos;
773 }
774 strcpy(dirp->start + endpos, ptr);
775 dirp->end = dirp->start + newsize;
776 dirp->nfiles++;
777 }
778 else
779 dirp->curr = NULL;
780 }
781 return &(dirp->dirstr);
782 }
783 else
784 return NULL;
785}
786
787/* Telldir returns the current string pointer position */
788DllExport long
789win32_telldir(DIR *dirp)
790{
791 return (dirp->curr - dirp->start);
792}
793
794
795/* Seekdir moves the string pointer to a previously saved position
796 * (returned by telldir).
797 */
798DllExport void
799win32_seekdir(DIR *dirp, long loc)
800{
801 dirp->curr = dirp->start + loc;
802}
803
804/* Rewinddir resets the string pointer to the start */
805DllExport void
806win32_rewinddir(DIR *dirp)
807{
808 dirp->curr = dirp->start;
809}
810
811/* free the memory allocated by opendir */
812DllExport int
813win32_closedir(DIR *dirp)
814{
815 dTHX;
816 if (dirp->handle != INVALID_HANDLE_VALUE)
817 FindClose(dirp->handle);
818 Safefree(dirp->start);
819 Safefree(dirp);
820 return 1;
e1caacb4
JH		 821}
822
814ffeea
VK		 823#else
824/////!!!!!!!!!!! return here and do right stuff!!!!
825
e1caacb4 826DllExport DIR *
0e06f75d 827win32_opendir(const char *filename)
e1caacb4
JH		 828{
829 return opendir(filename);
830}
831
832DllExport struct direct *
833win32_readdir(DIR *dirp)
834{
835 return readdir(dirp);
836}
837
838DllExport long
839win32_telldir(DIR *dirp)
840{
216db7ee 841 dTHX;
e1caacb4
JH		 842 Perl_croak(aTHX_ PL_no_func, "telldir");
843 return -1;
844}
845
846DllExport void
847win32_seekdir(DIR *dirp, long loc)
848{
216db7ee 849 dTHX;
e1caacb4
JH		 850 Perl_croak(aTHX_ PL_no_func, "seekdir");
851}
852
853DllExport void
854win32_rewinddir(DIR *dirp)
855{
216db7ee 856 dTHX;
e1caacb4
JH		 857 Perl_croak(aTHX_ PL_no_func, "rewinddir");
858}
859
860DllExport int
861win32_closedir(DIR *dirp)
862{
863 closedir(dirp);
864 return 0;
865}
814ffeea 866#endif // 1
e1caacb4
JH		 867
868DllExport int
869win32_kill(int pid, int sig)
870{
216db7ee 871 dTHX;
e1caacb4
JH		 872 Perl_croak(aTHX_ PL_no_func, "kill");
873 return -1;
874}
875
e1caacb4
JH		 876DllExport int
877win32_stat(const char *path, struct stat *sbuf)
878{
879 return xcestat(path, sbuf);
880}
881
882DllExport char *
883win32_longpath(char *path)
884{
885 return path;
886}
887
517bb5c6
VK		 888static void
889out_of_memory(void)
890{
891 if (PL_curinterp) {
892 dTHX;
893 /* Can't use PerlIO to write as it allocates memory */
894 PerlLIO_write(PerlIO_fileno(Perl_error_log),
895 PL_no_mem, strlen(PL_no_mem));
896 my_exit(1);
897 }
898 exit(1);
899}
900
901/* The win32_ansipath() function takes a Unicode filename and converts it
902 * into the current Windows codepage. If some characters cannot be mapped,
903 * then it will convert the short name instead.
904 *
905 * The buffer to the ansi pathname must be freed with win32_free() when it
906 * it no longer needed.
907 *
908 * The argument to win32_ansipath() must exist before this function is
909 * called; otherwise there is no way to determine the short path name.
910 *
911 * Ideas for future refinement:
912 * - Only convert those segments of the path that are not in the current
913 * codepage, but leave the other segments in their long form.
914 * - If the resulting name is longer than MAX_PATH, start converting
915 * additional path segments into short names until the full name
916 * is shorter than MAX_PATH. Shorten the filename part last!
917 */
918DllExport char *
919win32_ansipath(const WCHAR *widename)
920{
921 char *name;
922 size_t widelen = wcslen(widename)+1;
923 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
924 NULL, 0, NULL, NULL);
925 name = win32_malloc(len);
926 if (!name)
927 out_of_memory();
928
929 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen,
930 name, len, NULL, NULL);
931 return name;
932}
933
e1caacb4
JH		 934DllExport char *
935win32_getenv(const char *name)
936{
937 return xcegetenv(name);
938}
939
940DllExport int
941win32_putenv(const char *name)
942{
943 return xceputenv(name);
944}
945
e1caacb4
JH		 946static long
947filetime_to_clock(PFILETIME ft)
948{
949 __int64 qw = ft->dwHighDateTime;
950 qw <<= 32;
951 qw |= ft->dwLowDateTime;
952 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
953 return (long) qw;
954}
955
956/* fix utime() so it works on directories in NT */
957static BOOL
958filetime_from_time(PFILETIME pFileTime, time_t Time)
959{
960 struct tm *pTM = localtime(&Time);
961 SYSTEMTIME SystemTime;
962 FILETIME LocalTime;
963
964 if (pTM == NULL)
965 return FALSE;
966
967 SystemTime.wYear = pTM->tm_year + 1900;
968 SystemTime.wMonth = pTM->tm_mon + 1;
969 SystemTime.wDay = pTM->tm_mday;
970 SystemTime.wHour = pTM->tm_hour;
971 SystemTime.wMinute = pTM->tm_min;
972 SystemTime.wSecond = pTM->tm_sec;
973 SystemTime.wMilliseconds = 0;
974
975 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
976 LocalFileTimeToFileTime(&LocalTime, pFileTime);
977}
978
979DllExport int
980win32_unlink(const char *filename)
981{
982 return xceunlink(filename);
983}
984
985DllExport int
986win32_utime(const char *filename, struct utimbuf *times)
987{
988 return xceutime(filename, (struct _utimbuf *) times);
989}
990
991DllExport int
e2a02c1e
VK		 992win32_gettimeofday(struct timeval *tp, void *not_used)
993{
994 return xcegettimeofday(tp,not_used);
995}
996
997DllExport int
e1caacb4
JH		 998win32_uname(struct utsname *name)
999{
1000 struct hostent *hep;
1001 STRLEN nodemax = sizeof(name->nodename)-1;
1002 OSVERSIONINFOA osver;
1003
1004 memset(&osver, 0, sizeof(OSVERSIONINFOA));
1005 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
1006 if (XCEGetVersionExA(&osver)) {
1007 /* sysname */
1008 switch (osver.dwPlatformId) {
1009 case VER_PLATFORM_WIN32_CE:
1010 strcpy(name->sysname, "Windows CE");
1011 break;
1012 case VER_PLATFORM_WIN32_WINDOWS:
1013 strcpy(name->sysname, "Windows");
1014 break;
1015 case VER_PLATFORM_WIN32_NT:
1016 strcpy(name->sysname, "Windows NT");
1017 break;
1018 case VER_PLATFORM_WIN32s:
1019 strcpy(name->sysname, "Win32s");
1020 break;
1021 default:
1022 strcpy(name->sysname, "Win32 Unknown");
1023 break;
1024 }
1025
1026 /* release */
1027 sprintf(name->release, "%d.%d",
1028 osver.dwMajorVersion, osver.dwMinorVersion);
1029
1030 /* version */
1031 sprintf(name->version, "Build %d",
1032 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1033 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1034 if (osver.szCSDVersion[0]) {
1035 char *buf = name->version + strlen(name->version);
1036 sprintf(buf, " (%s)", osver.szCSDVersion);
1037 }
1038 }
1039 else {
1040 *name->sysname = '\0';
1041 *name->version = '\0';
1042 *name->release = '\0';
1043 }
1044
1045 /* nodename */
1046 hep = win32_gethostbyname("localhost");
1047 if (hep) {
1048 STRLEN len = strlen(hep->h_name);
1049 if (len <= nodemax) {
1050 strcpy(name->nodename, hep->h_name);
1051 }
1052 else {
1053 strncpy(name->nodename, hep->h_name, nodemax);
1054 name->nodename[nodemax] = '\0';
1055 }
1056 }
1057 else {
1058 DWORD sz = nodemax;
1059 if (!XCEGetComputerNameA(name->nodename, &sz))
1060 *name->nodename = '\0';
1061 }
1062
1063 /* machine (architecture) */
1064 {
1065 SYSTEM_INFO info;
1066 char *arch;
1067 GetSystemInfo(&info);
1068
e1caacb4 1069 switch (info.wProcessorArchitecture) {
e1caacb4
JH		 1070 case PROCESSOR_ARCHITECTURE_INTEL:
1071 arch = "x86"; break;
1072 case PROCESSOR_ARCHITECTURE_MIPS:
1073 arch = "mips"; break;
1074 case PROCESSOR_ARCHITECTURE_ALPHA:
1075 arch = "alpha"; break;
1076 case PROCESSOR_ARCHITECTURE_PPC:
1077 arch = "ppc"; break;
1078 case PROCESSOR_ARCHITECTURE_ARM:
1079 arch = "arm"; break;
1080 case PROCESSOR_HITACHI_SH3:
1081 arch = "sh3"; break;
1082 case PROCESSOR_SHx_SH3:
1083 arch = "sh3"; break;
1084
1085 default:
1086 arch = "unknown"; break;
1087 }
1088 strcpy(name->machine, arch);
1089 }
1090 return 0;
1091}
1092
814ffeea
VK		 1093/* Timing related stuff */
1094
1095int
f4257e4d 1096do_raise(pTHX_ int sig)
814ffeea
VK		 1097{
1098 if (sig < SIG_SIZE) {
1099 Sighandler_t handler = w32_sighandler[sig];
1100 if (handler == SIG_IGN) {
1101 return 0;
1102 }
1103 else if (handler != SIG_DFL) {
1104 (*handler)(sig);
1105 return 0;
1106 }
1107 else {
1108 /* Choose correct default behaviour */
1109 switch (sig) {
1110#ifdef SIGCLD
1111 case SIGCLD:
1112#endif
1113#ifdef SIGCHLD
1114 case SIGCHLD:
1115#endif
1116 case 0:
1117 return 0;
1118 case SIGTERM:
1119 default:
1120 break;
1121 }
1122 }
1123 }
bb0f0a6a 1124 /* Tell caller to exit thread/process as appropriate */
814ffeea
VK		 1125 return 1;
1126}
1127
216db7ee
VK		 1128void
1129sig_terminate(pTHX_ int sig)
1130{
2e332e71 1131 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
f4257e4d
YO		 1132 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1133 thread
216db7ee
VK		 1134 */
1135 exit(sig);
1136}
1137
1138DllExport int
1139win32_async_check(pTHX)
1140{
1141 MSG msg;
1142 int ours = 1;
1143 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1144 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1145 */
1146 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1147 int sig;
1148 switch(msg.message) {
1149
1150#if 0
1151 /* Perhaps some other messages could map to signals ? ... */
1152 case WM_CLOSE:
1153 case WM_QUIT:
1154 /* Treat WM_QUIT like SIGHUP? */
1155 sig = SIGHUP;
1156 goto Raise;
1157 break;
1158#endif
2e332e71 1159
216db7ee
VK		 1160 /* We use WM_USER to fake kill() with other signals */
1161 case WM_USER: {
1162 sig = msg.wParam;
1163 Raise:
1164 if (do_raise(aTHX_ sig)) {
1165 sig_terminate(aTHX_ sig);
1166 }
1167 break;
1168 }
1169
1170 case WM_TIMER: {
1171 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1172 if (w32_timerid) {
1173 KillTimer(NULL,w32_timerid);
1174 w32_timerid=0;
1175 }
1176 /* Now fake a call to signal handler */
1177 if (do_raise(aTHX_ 14)) {
1178 sig_terminate(aTHX_ 14);
1179 }
1180 break;
1181 }
1182
1183 /* Otherwise do normal Win32 thing - in case it is useful */
1184 default:
1185 TranslateMessage(&msg);
1186 DispatchMessage(&msg);
1187 ours = 0;
1188 break;
1189 }
1190 }
1191 w32_poll_count = 0;
1192
1193 /* Above or other stuff may have set a signal flag */
1194 if (PL_sig_pending) {
1195 despatch_signals();
1196 }
1197 return ours;
1198}
1199
1200/* This function will not return until the timeout has elapsed, or until
1201 * one of the handles is ready. */
1202DllExport DWORD
1203win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1204{
1205 /* We may need several goes at this - so compute when we stop */
1206 DWORD ticks = 0;
1207 if (timeout != INFINITE) {
1208 ticks = GetTickCount();
1209 timeout += ticks;
1210 }
1211 while (1) {
1212 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1213 if (resultp)
1214 *resultp = result;
1215 if (result == WAIT_TIMEOUT) {
1216 /* Ran out of time - explicit return of zero to avoid -ve if we
1217 have scheduling issues
1218 */
1219 return 0;
1220 }
1221 if (timeout != INFINITE) {
1222 ticks = GetTickCount();
1223 }
1224 if (result == WAIT_OBJECT_0 + count) {
1225 /* Message has arrived - check it */
1226 (void)win32_async_check(aTHX);
1227 }
1228 else {
1229 /* Not timeout or message - one of handles is ready */
1230 break;
1231 }
1232 }
1233 /* compute time left to wait */
1234 ticks = timeout - ticks;
1235 /* If we are past the end say zero */
1236 return (ticks > 0) ? ticks : 0;
1237}
1238
e1caacb4
JH		 1239static UINT timerid = 0;
1240
1241static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
1242{
acfe0abc 1243 dTHX;
e1caacb4 1244 KillTimer(NULL,timerid);
f4257e4d 1245 timerid=0;
e1caacb4
JH		 1246 sighandler(14);
1247}
e1caacb4
JH		 1248
1249DllExport unsigned int
814ffeea
VK		 1250win32_sleep(unsigned int t)
1251{
1252 return xcesleep(t);
1253}
1254
1255DllExport unsigned int
e1caacb4
JH		 1256win32_alarm(unsigned int sec)
1257{
f4257e4d 1258 /*
e1caacb4 1259 * the 'obvious' implentation is SetTimer() with a callback
f4257e4d
YO		 1260 * which does whatever receiving SIGALRM would do
1261 * we cannot use SIGALRM even via raise() as it is not
e1caacb4
JH		 1262 * one of the supported codes in <signal.h>
1263 *
1264 * Snag is unless something is looking at the message queue
1265 * nothing happens :-(
f4257e4d 1266 */
acfe0abc 1267 dTHX;
e1caacb4
JH		 1268 if (sec)
1269 {
1270 timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
1271 if (!timerid)
1272 Perl_croak_nocontext("Cannot set timer");
f4257e4d 1273 }
e1caacb4
JH		 1274 else
1275 {
1276 if (timerid)
1277 {
1278 KillTimer(NULL,timerid);
f4257e4d 1279 timerid=0;
e1caacb4
JH		 1280 }
1281 }
e1caacb4
JH		 1282 return 0;
1283}
1284
1285#ifdef HAVE_DES_FCRYPT
1286extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
1287#endif
1288
1289DllExport char *
1290win32_crypt(const char *txt, const char *salt)
1291{
acfe0abc 1292 dTHX;
e1caacb4
JH		 1293#ifdef HAVE_DES_FCRYPT
1294 dTHR;
1295 return des_fcrypt(txt, salt, w32_crypt_buffer);
1296#else
1297 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
4e205ed6 1298 return NULL;
e1caacb4
JH		 1299#endif
1300}
1301
e1caacb4
JH		 1302
1303/*
1304 * redirected io subsystem for all XS modules
1305 *
1306 */
1307
1308DllExport int *
1309win32_errno(void)
1310{
1311 return (&errno);
1312}
1313
814ffeea
VK		 1314DllExport char ***
1315win32_environ(void)
1316{
1317 return (&(environ));
1318}
1319
e1caacb4
JH		 1320/* the rest are the remapped stdio routines */
1321DllExport FILE *
1322win32_stderr(void)
1323{
1324 return (stderr);
1325}
1326
216db7ee
VK		 1327char *g_getlogin() {
1328 return "no-getlogin";
1329}
1330
e1caacb4
JH		 1331DllExport FILE *
1332win32_stdin(void)
1333{
1334 return (stdin);
1335}
1336
1337DllExport FILE *
1338win32_stdout()
1339{
1340 return (stdout);
1341}
1342
1343DllExport int
1344win32_ferror(FILE *fp)
1345{
1346 return (ferror(fp));
1347}
1348
1349
1350DllExport int
1351win32_feof(FILE *fp)
1352{
1353 return (feof(fp));
1354}
1355
1356/*
f4257e4d 1357 * Since the errors returned by the socket error function
e1caacb4
JH		 1358 * WSAGetLastError() are not known by the library routine strerror
1359 * we have to roll our own.
1360 */
1361
1362DllExport char *
814ffeea 1363win32_strerror(int e)
e1caacb4
JH		 1364{
1365 return xcestrerror(e);
1366}
1367
1368DllExport void
1369win32_str_os_error(void *sv, DWORD dwErr)
1370{
acfe0abc 1371 dTHX;
e1caacb4
JH		 1372
1373 sv_setpvn((SV*)sv, "Error", 5);
1374}
1375
1376
1377DllExport int
1378win32_fprintf(FILE *fp, const char *format, ...)
1379{
1380 va_list marker;
1381 va_start(marker, format); /* Initialize variable arguments. */
1382
1383 return (vfprintf(fp, format, marker));
1384}
1385
1386DllExport int
1387win32_printf(const char *format, ...)
1388{
1389 va_list marker;
1390 va_start(marker, format); /* Initialize variable arguments. */
1391
1392 return (vprintf(format, marker));
1393}
1394
1395DllExport int
1396win32_vfprintf(FILE *fp, const char *format, va_list args)
1397{
1398 return (vfprintf(fp, format, args));
1399}
1400
1401DllExport int
1402win32_vprintf(const char *format, va_list args)
1403{
1404 return (vprintf(format, args));
1405}
1406
1407DllExport size_t
1408win32_fread(void *buf, size_t size, size_t count, FILE *fp)
1409{
1410 return fread(buf, size, count, fp);
1411}
1412
1413DllExport size_t
1414win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
1415{
1416 return fwrite(buf, size, count, fp);
1417}
1418
1419DllExport FILE *
1420win32_fopen(const char *filename, const char *mode)
1421{
1422 return xcefopen(filename, mode);
1423}
1424
1425DllExport FILE *
1426win32_fdopen(int handle, const char *mode)
1427{
1428 return palm_fdopen(handle, mode);
1429}
1430
1431DllExport FILE *
1432win32_freopen(const char *path, const char *mode, FILE *stream)
1433{
1434 return xcefreopen(path, mode, stream);
1435}
1436
1437DllExport int
1438win32_fclose(FILE *pf)
1439{
1440 return xcefclose(pf);
1441}
1442
1443DllExport int
1444win32_fputs(const char *s,FILE *pf)
1445{
1446 return fputs(s, pf);
1447}
1448
1449DllExport int
1450win32_fputc(int c,FILE *pf)
1451{
1452 return fputc(c,pf);
1453}
1454
1455DllExport int
1456win32_ungetc(int c,FILE *pf)
1457{
1458 return ungetc(c,pf);
1459}
1460
1461DllExport int
1462win32_getc(FILE *pf)
1463{
1464 return getc(pf);
1465}
1466
1467DllExport int
1468win32_fileno(FILE *pf)
1469{
1470 return palm_fileno(pf);
1471}
1472
1473DllExport void
1474win32_clearerr(FILE *pf)
1475{
1476 clearerr(pf);
1477 return;
1478}
1479
1480DllExport int
1481win32_fflush(FILE *pf)
1482{
1483 return fflush(pf);
1484}
1485
1486DllExport long
1487win32_ftell(FILE *pf)
1488{
1489 return ftell(pf);
1490}
1491
1492DllExport int
814ffeea 1493win32_fseek(FILE *pf, Off_t offset,int origin)
e1caacb4
JH		 1494{
1495 return fseek(pf, offset, origin);
1496}
1497
cb69f87a
MB		 1498/* fpos_t seems to be int64 on hpc pro! Really stupid. */
1499/* But maybe someday there will be such large disks in a hpc... */
e1caacb4
JH		 1500DllExport int
1501win32_fgetpos(FILE *pf, fpos_t *p)
1502{
1503 return fgetpos(pf, p);
1504}
1505
1506DllExport int
1507win32_fsetpos(FILE *pf, const fpos_t *p)
1508{
1509 return fsetpos(pf, p);
1510}
1511
1512DllExport void
1513win32_rewind(FILE *pf)
1514{
1515 fseek(pf, 0, SEEK_SET);
1516 return;
1517}
1518
81003058
VK		 1519DllExport int
1520win32_tmpfd(void)
1521{
1522 dTHX;
1523 char prefix[MAX_PATH+1];
1524 char filename[MAX_PATH+1];
1525 DWORD len = GetTempPath(MAX_PATH, prefix);
1526 if (len && len < MAX_PATH) {
1527 if (GetTempFileName(prefix, "plx", 0, filename)) {
1528 HANDLE fh = CreateFile(filename,
1529 DELETE | GENERIC_READ | GENERIC_WRITE,
1530 0,
1531 NULL,
1532 CREATE_ALWAYS,
1533 FILE_ATTRIBUTE_NORMAL
1534 | FILE_FLAG_DELETE_ON_CLOSE,
1535 NULL);
1536 if (fh != INVALID_HANDLE_VALUE) {
1537 int fd = win32_open_osfhandle((intptr_t)fh, 0);
1538 if (fd >= 0) {
81003058
VK		 1539 DEBUG_p(PerlIO_printf(Perl_debug_log,
1540 "Created tmpfile=%s\n",filename));
1541 return fd;
1542 }
1543 }
1544 }
1545 }
1546 return -1;
1547}
1548
e1caacb4
JH		 1549DllExport FILE*
1550win32_tmpfile(void)
1551{
81003058
VK		 1552 int fd = win32_tmpfd();
1553 if (fd >= 0)
1554 return win32_fdopen(fd, "w+b");
1555 return NULL;
e1caacb4
JH		 1556}
1557
1558DllExport void
1559win32_abort(void)
1560{
1561 xceabort();
1562
1563 return;
1564}
1565
1566DllExport int
1567win32_fstat(int fd, struct stat *sbufptr)
1568{
1569 return xcefstat(fd, sbufptr);
1570}
1571
1572DllExport int
1573win32_link(const char *oldname, const char *newname)
1574{
216db7ee 1575 dTHX;
e1caacb4
JH		 1576 Perl_croak(aTHX_ PL_no_func, "link");
1577
1578 return -1;
1579}
1580
1581DllExport int
1582win32_rename(const char *oname, const char *newname)
1583{
1584 return xcerename(oname, newname);
1585}
1586
1587DllExport int
1588win32_setmode(int fd, int mode)
1589{
bcdf844e
VK		 1590 /* currently 'celib' seem to have this function in src, but not
1591 * exported. When it will be, we'll uncomment following line.
1592 */
1593 /* return xcesetmode(fd, mode); */
1594 return 0;
e1caacb4
JH		 1595}
1596
216db7ee
VK		 1597DllExport int
1598win32_chsize(int fd, Off_t size)
1599{
1600 return chsize(fd, size);
1601}
1602
e1caacb4 1603DllExport long
814ffeea 1604win32_lseek(int fd, Off_t offset, int origin)
e1caacb4
JH		 1605{
1606 return xcelseek(fd, offset, origin);
1607}
1608
1609DllExport long
1610win32_tell(int fd)
1611{
1612 return xcelseek(fd, 0, SEEK_CUR);
1613}
1614
1615DllExport int
1616win32_open(const char *path, int flag, ...)
1617{
1618 int pmode;
1619 va_list ap;
1620
1621 va_start(ap, flag);
1622 pmode = va_arg(ap, int);
1623 va_end(ap);
1624
1625 return xceopen(path, flag, pmode);
1626}
1627
1628DllExport int
1629win32_close(int fd)
1630{
1631 return xceclose(fd);
1632}
1633
1634DllExport int
1635win32_eof(int fd)
1636{
216db7ee 1637 dTHX;
e1caacb4
JH		 1638 Perl_croak(aTHX_ PL_no_func, "eof");
1639 return -1;
1640}
1641
1642DllExport int
1643win32_dup(int fd)
1644{
216db7ee 1645 return xcedup(fd); /* from celib/ceio.c; requires some more work on it */
e1caacb4
JH		 1646}
1647
1648DllExport int
1649win32_dup2(int fd1,int fd2)
1650{
aebd5ec7 1651 return xcedup2(fd1,fd2);
e1caacb4
JH		 1652}
1653
1654DllExport int
1655win32_read(int fd, void *buf, unsigned int cnt)
1656{
1657 return xceread(fd, buf, cnt);
1658}
1659
1660DllExport int
1661win32_write(int fd, const void *buf, unsigned int cnt)
1662{
1663 return xcewrite(fd, (void *) buf, cnt);
1664}
1665
1666DllExport int
1667win32_mkdir(const char *dir, int mode)
1668{
1669 return xcemkdir(dir);
1670}
1671
1672DllExport int
1673win32_rmdir(const char *dir)
1674{
1675 return xcermdir(dir);
1676}
1677
1678DllExport int
1679win32_chdir(const char *dir)
1680{
1681 return xcechdir(dir);
1682}
1683
1684DllExport int
1685win32_access(const char *path, int mode)
1686{
1687 return xceaccess(path, mode);
1688}
1689
1690DllExport int
1691win32_chmod(const char *path, int mode)
1692{
1693 return xcechmod(path, mode);
1694}
1695
814ffeea
VK		 1696static char *
1697create_command_line(char *cname, STRLEN clen, const char * const *args)
216db7ee
VK		 1698{
1699 dTHX;
1700 int index, argc;
1701 char *cmd, *ptr;
1702 const char *arg;
1703 STRLEN len = 0;
1704 bool bat_file = FALSE;
1705 bool cmd_shell = FALSE;
1706 bool dumb_shell = FALSE;
1707 bool extra_quotes = FALSE;
1708 bool quote_next = FALSE;
1709
1710 if (!cname)
1711 cname = (char*)args[0];
1712
1713 /* The NT cmd.exe shell has the following peculiarity that needs to be
1714 * worked around. It strips a leading and trailing dquote when any
1715 * of the following is true:
1716 * 1. the /S switch was used
1717 * 2. there are more than two dquotes
1718 * 3. there is a special character from this set: &<>()@^|
1719 * 4. no whitespace characters within the two dquotes
1720 * 5. string between two dquotes isn't an executable file
1721 * To work around this, we always add a leading and trailing dquote
1722 * to the string, if the first argument is either "cmd.exe" or "cmd",
1723 * and there were at least two or more arguments passed to cmd.exe
1724 * (not including switches).
1725 * XXX the above rules (from "cmd /?") don't seem to be applied
1726 * always, making for the convolutions below :-(
1727 */
1728 if (cname) {
1729 if (!clen)
1730 clen = strlen(cname);
1731
1732 if (clen > 4
1733 && (stricmp(&cname[clen-4], ".bat") == 0
1734 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
1735 {
1736 bat_file = TRUE;
1737 len += 3;
1738 }
1739 else {
1740 char *exe = strrchr(cname, '/');
1741 char *exe2 = strrchr(cname, '\\');
1742 if (exe2 > exe)
1743 exe = exe2;
1744 if (exe)
1745 ++exe;
1746 else
1747 exe = cname;
1748 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
1749 cmd_shell = TRUE;
1750 len += 3;
1751 }
1752 else if (stricmp(exe, "command.com") == 0
1753 || stricmp(exe, "command") == 0)
1754 {
1755 dumb_shell = TRUE;
1756 }
1757 }
1758 }
1759
1760 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
1761 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
1762 STRLEN curlen = strlen(arg);
1763 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
1764 len += 2; /* assume quoting needed (worst case) */
1765 len += curlen + 1;
1766 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
1767 }
1768 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
1769
1770 argc = index;
a02a5408 1771 Newx(cmd, len, char);
216db7ee
VK		 1772 ptr = cmd;
1773
1774 if (bat_file) {
1775 *ptr++ = '"';
1776 extra_quotes = TRUE;
1777 }
1778
1779 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
1780 bool do_quote = 0;
1781 STRLEN curlen = strlen(arg);
1782
1783 /* we want to protect empty arguments and ones with spaces with
1784 * dquotes, but only if they aren't already there */
1785 if (!dumb_shell) {
1786 if (!curlen) {
1787 do_quote = 1;
1788 }
1789 else if (quote_next) {
1790 /* see if it really is multiple arguments pretending to
1791 * be one and force a set of quotes around it */
1792 if (*find_next_space(arg))
1793 do_quote = 1;
1794 }
1795 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
1796 STRLEN i = 0;
1797 while (i < curlen) {
1798 if (isSPACE(arg[i])) {
1799 do_quote = 1;
1800 }
1801 else if (arg[i] == '"') {
1802 do_quote = 0;
1803 break;
1804 }
1805 i++;
1806 }
1807 }
1808 }
1809
1810 if (do_quote)
1811 *ptr++ = '"';
1812
1813 strcpy(ptr, arg);
1814 ptr += curlen;
1815
1816 if (do_quote)
1817 *ptr++ = '"';
1818
1819 if (args[index+1])
1820 *ptr++ = ' ';
1821
1822 if (!extra_quotes
1823 && cmd_shell
1824 && curlen >= 2
1825 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
1826 && stricmp(arg+curlen-2, "/c") == 0)
1827 {
1828 /* is there a next argument? */
1829 if (args[index+1]) {
1830 /* are there two or more next arguments? */
1831 if (args[index+2]) {
1832 *ptr++ = '"';
1833 extra_quotes = TRUE;
1834 }
1835 else {
1836 /* single argument, force quoting if it has spaces */
1837 quote_next = TRUE;
1838 }
1839 }
1840 }
1841 }
1842
1843 if (extra_quotes)
1844 *ptr++ = '"';
1845
1846 *ptr = '\0';
1847
1848 return cmd;
1849}
1850
1851static char *
1852qualified_path(const char *cmd)
1853{
1854 dTHX;
1855 char *pathstr;
1856 char *fullcmd, *curfullcmd;
1857 STRLEN cmdlen = 0;
1858 int has_slash = 0;
1859
1860 if (!cmd)
4e205ed6 1861 return NULL;
216db7ee
VK		 1862 fullcmd = (char*)cmd;
1863 while (*fullcmd) {
1864 if (*fullcmd == '/' || *fullcmd == '\\')
1865 has_slash++;
1866 fullcmd++;
1867 cmdlen++;
1868 }
1869
1870 /* look in PATH */
1871 pathstr = PerlEnv_getenv("PATH");
a02a5408 1872 Newx(fullcmd, MAX_PATH+1, char);
216db7ee
VK		 1873 curfullcmd = fullcmd;
1874
1875 while (1) {
1876 DWORD res;
1877
1878 /* start by appending the name to the current prefix */
1879 strcpy(curfullcmd, cmd);
1880 curfullcmd += cmdlen;
1881
1882 /* if it doesn't end with '.', or has no extension, try adding
1883 * a trailing .exe first */
1884 if (cmd[cmdlen-1] != '.'
1885 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
1886 {
1887 strcpy(curfullcmd, ".exe");
1888 res = GetFileAttributes(fullcmd);
1889 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
1890 return fullcmd;
1891 *curfullcmd = '\0';
1892 }
1893
1894 /* that failed, try the bare name */
1895 res = GetFileAttributes(fullcmd);
1896 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
1897 return fullcmd;
1898
1899 /* quit if no other path exists, or if cmd already has path */
1900 if (!pathstr || !*pathstr || has_slash)
1901 break;
1902
1903 /* skip leading semis */
1904 while (*pathstr == ';')
1905 pathstr++;
1906
1907 /* build a new prefix from scratch */
1908 curfullcmd = fullcmd;
1909 while (*pathstr && *pathstr != ';') {
1910 if (*pathstr == '"') { /* foo;"baz;etc";bar */
1911 pathstr++; /* skip initial '"' */
1912 while (*pathstr && *pathstr != '"') {
1913 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
1914 *curfullcmd++ = *pathstr;
1915 pathstr++;
1916 }
1917 if (*pathstr)
1918 pathstr++; /* skip trailing '"' */
1919 }
1920 else {
1921 if ((STRLEN)(curfullcmd-fullcmd) < MAX_PATH-cmdlen-5)
1922 *curfullcmd++ = *pathstr;
1923 pathstr++;
1924 }
1925 }
1926 if (*pathstr)
1927 pathstr++; /* skip trailing semi */
1928 if (curfullcmd > fullcmd /* append a dir separator */
1929 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
1930 {
1931 *curfullcmd++ = '\\';
1932 }
1933 }
1934
1935 Safefree(fullcmd);
4e205ed6 1936 return NULL;
216db7ee
VK		 1937}
1938
8f33b42a
VK		 1939/* The following are just place holders.
1940 * Some hosts may provide and environment that the OS is
1941 * not tracking, therefore, these host must provide that
1942 * environment and the current directory to CreateProcess
1943 */
1944
1945DllExport void*
1946win32_get_childenv(void)
1947{
1948 return NULL;
1949}
1950
1951DllExport void
1952win32_free_childenv(void* d)
1953{
1954}
1955
1956DllExport void
1957win32_clearenv(void)
1958{
1959 char *envv = GetEnvironmentStrings();
1960 char *cur = envv;
1961 STRLEN len;
1962 while (*cur) {
1963 char *end = strchr(cur,'=');
1964 if (end && end != cur) {
1965 *end = '\0';
1966 xcesetenv(cur, "", 0);
1967 *end = '=';
1968 cur = end + strlen(end+1)+2;
1969 }
1970 else if ((len = strlen(cur)))
1971 cur += len+1;
1972 }
1973 FreeEnvironmentStrings(envv);
1974}
1975
1976DllExport char*
1977win32_get_childdir(void)
1978{
1979 dTHX;
1980 char* ptr;
8c56068e
JD		 1981 char szfilename[MAX_PATH+1];
1982 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
8f33b42a 1983
a02a5408 1984 Newx(ptr, strlen(szfilename)+1, char);
8f33b42a
VK		 1985 strcpy(ptr, szfilename);
1986 return ptr;
1987}
1988
1989DllExport void
1990win32_free_childdir(char* d)
1991{
1992 dTHX;
1993 Safefree(d);
1994}
1995
216db7ee
VK		 1996/* XXX this needs to be made more compatible with the spawnvp()
1997 * provided by the various RTLs. In particular, searching for
1998 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
1999 * This doesn't significantly affect perl itself, because we
2000 * always invoke things using PERL5SHELL if a direct attempt to
2001 * spawn the executable fails.
2002 *
2003 * XXX splitting and rejoining the commandline between do_aspawn()
2004 * and win32_spawnvp() could also be avoided.
2005 */
2006
216db7ee
VK		 2007DllExport int
2008win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
2009{
2010#ifdef USE_RTL_SPAWNVP
2011 return spawnvp(mode, cmdname, (char * const *)argv);
2012#else
2013 dTHX;
2014 int ret;
2015 void* env;
2016 char* dir;
2017 child_IO_table tbl;
2018 STARTUPINFO StartupInfo;
2019 PROCESS_INFORMATION ProcessInformation;
2020 DWORD create = 0;
2021 char *cmd;
4e205ed6 2022 char *fullcmd = NULL;
216db7ee
VK		 2023 char *cname = (char *)cmdname;
2024 STRLEN clen = 0;
2025
2026 if (cname) {
2027 clen = strlen(cname);
2028 /* if command name contains dquotes, must remove them */
2029 if (strchr(cname, '"')) {
2030 cmd = cname;
a02a5408 2031 Newx(cname,clen+1,char);
216db7ee
VK		 2032 clen = 0;
2033 while (*cmd) {
2034 if (*cmd != '"') {
2035 cname[clen] = *cmd;
2036 ++clen;
2037 }
2038 ++cmd;
2039 }
2040 cname[clen] = '\0';
2041 }
2042 }
2043
2044 cmd = create_command_line(cname, clen, argv);
2045
2046 env = PerlEnv_get_childenv();
2047 dir = PerlEnv_get_childdir();
2048
2049 switch(mode) {
2050 case P_NOWAIT: /* asynch + remember result */
2051 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
2052 errno = EAGAIN;
2053 ret = -1;
2054 goto RETVAL;
2055 }
2056 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
2057 * in win32_kill()
2058 */
2059 /* not supported on CE create |= CREATE_NEW_PROCESS_GROUP; */
2060 /* FALL THROUGH */
2061
2062 case P_WAIT: /* synchronous execution */
2063 break;
2064 default: /* invalid mode */
2065 errno = EINVAL;
2066 ret = -1;
2067 goto RETVAL;
2068 }
2069 memset(&StartupInfo,0,sizeof(StartupInfo));
2070 StartupInfo.cb = sizeof(StartupInfo);
2071 memset(&tbl,0,sizeof(tbl));
2072 PerlEnv_get_child_IO(&tbl);
2073 StartupInfo.dwFlags = tbl.dwFlags;
2074 StartupInfo.dwX = tbl.dwX;
2075 StartupInfo.dwY = tbl.dwY;
2076 StartupInfo.dwXSize = tbl.dwXSize;
2077 StartupInfo.dwYSize = tbl.dwYSize;
2078 StartupInfo.dwXCountChars = tbl.dwXCountChars;
2079 StartupInfo.dwYCountChars = tbl.dwYCountChars;
2080 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
2081 StartupInfo.wShowWindow = tbl.wShowWindow;
2082 StartupInfo.hStdInput = tbl.childStdIn;
2083 StartupInfo.hStdOutput = tbl.childStdOut;
2084 StartupInfo.hStdError = tbl.childStdErr;
2085 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
2086 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
2087 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
2088 {
2089 create |= CREATE_NEW_CONSOLE;
2090 }
2091 else {
2092 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
2093 }
2094 if (w32_use_showwindow) {
2095 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
2096 StartupInfo.wShowWindow = w32_showwindow;
2097 }
2098
2099 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
2100 cname,cmd));
2101RETRY:
2102 if (!CreateProcess(cname, /* search PATH to find executable */
2103 cmd, /* executable, and its arguments */
2104 NULL, /* process attributes */
2105 NULL, /* thread attributes */
2106 TRUE, /* inherit handles */
2107 create, /* creation flags */
2108 (LPVOID)env, /* inherit environment */
2109 dir, /* inherit cwd */
2110 &StartupInfo,
2111 &ProcessInformation))
2112 {
2113 /* initial NULL argument to CreateProcess() does a PATH
2114 * search, but it always first looks in the directory
2115 * where the current process was started, which behavior
2116 * is undesirable for backward compatibility. So we
2117 * jump through our own hoops by picking out the path
2118 * we really want it to use. */
2119 if (!fullcmd) {
2120 fullcmd = qualified_path(cname);
2121 if (fullcmd) {
2122 if (cname != cmdname)
2123 Safefree(cname);
2124 cname = fullcmd;
2125 DEBUG_p(PerlIO_printf(Perl_debug_log,
2126 "Retrying [%s] with same args\n",
2127 cname));
2128 goto RETRY;
2129 }
2130 }
2131 errno = ENOENT;
2132 ret = -1;
2133 goto RETVAL;
2134 }
2135
2136 if (mode == P_NOWAIT) {
2137 /* asynchronous spawn -- store handle, return PID */
2138 ret = (int)ProcessInformation.dwProcessId;
2139 if (IsWin95() && ret < 0)
2140 ret = -ret;
2141
2142 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
2143 w32_child_pids[w32_num_children] = (DWORD)ret;
2144 ++w32_num_children;
2145 }
2146 else {
2147 DWORD status;
2148 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
2149 /* FIXME: if msgwait returned due to message perhaps forward the
2150 "signal" to the process
2151 */
2152 GetExitCodeProcess(ProcessInformation.hProcess, &status);
2153 ret = (int)status;
2154 CloseHandle(ProcessInformation.hProcess);
2155 }
2156
2157 CloseHandle(ProcessInformation.hThread);
2158
2159RETVAL:
2160 PerlEnv_free_childenv(env);
2161 PerlEnv_free_childdir(dir);
2162 Safefree(cmd);
2163 if (cname != cmdname)
2164 Safefree(cname);
2165 return ret;
2166#endif
2167}
2168
e1caacb4
JH		 2169DllExport int
2170win32_execv(const char *cmdname, const char *const *argv)
2171{
216db7ee 2172 dTHX;
e1caacb4
JH		 2173 Perl_croak(aTHX_ PL_no_func, "execv");
2174 return -1;
2175}
2176
2177DllExport int
2178win32_execvp(const char *cmdname, const char *const *argv)
2179{
216db7ee 2180 dTHX;
e1caacb4
JH		 2181 Perl_croak(aTHX_ PL_no_func, "execvp");
2182 return -1;
2183}
2184
814ffeea
VK		 2185DllExport void
2186win32_perror(const char *str)
e1caacb4 2187{
814ffeea
VK		 2188 xceperror(str);
2189}
e1caacb4 2190
814ffeea
VK		 2191DllExport void
2192win32_setbuf(FILE *pf, char *buf)
2193{
2194 dTHX;
2195 Perl_croak(aTHX_ PL_no_func, "setbuf");
2196}
e1caacb4 2197
814ffeea
VK		 2198DllExport int
2199win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
2200{
2201 return setvbuf(pf, buf, type, size);
e1caacb4
JH		 2202}
2203
814ffeea
VK		 2204DllExport int
2205win32_flushall(void)
2206{
2207 return flushall();
2208}
e1caacb4 2209
814ffeea
VK		 2210DllExport int
2211win32_fcloseall(void)
e1caacb4 2212{
814ffeea
VK		 2213 return fcloseall();
2214}
e1caacb4 2215
814ffeea
VK		 2216DllExport char*
2217win32_fgets(char *s, int n, FILE *pf)
2218{
2219 return fgets(s, n, pf);
2220}
e1caacb4 2221
814ffeea
VK		 2222DllExport char*
2223win32_gets(char *s)
2224{
2225 return gets(s);
e1caacb4
JH		 2226}
2227
814ffeea
VK		 2228DllExport int
2229win32_fgetc(FILE *pf)
e1caacb4 2230{
814ffeea
VK		 2231 return fgetc(pf);
2232}
e1caacb4 2233
814ffeea
VK		 2234DllExport int
2235win32_putc(int c, FILE *pf)
2236{
2237 return putc(c,pf);
2238}
2239
2240DllExport int
2241win32_puts(const char *s)
2242{
2243 return puts(s);
2244}
2245
2246DllExport int
2247win32_getchar(void)
2248{
2249 return getchar();
2250}
2251
2252DllExport int
2253win32_putchar(int c)
2254{
2255 return putchar(c);
2256}
2257
2258#ifdef MYMALLOC
2259
2260#ifndef USE_PERL_SBRK
2261
2262static char *committed = NULL;
2263static char *base = NULL;
2264static char *reserved = NULL;
2265static char *brk = NULL;
2266static DWORD pagesize = 0;
2267static DWORD allocsize = 0;
2268
2269void *
2270sbrk(int need)
2271{
2272 void *result;
2273 if (!pagesize)
2274 {SYSTEM_INFO info;
2275 GetSystemInfo(&info);
2276 /* Pretend page size is larger so we don't perpetually
2277 * call the OS to commit just one page ...
2278 */
2279 pagesize = info.dwPageSize << 3;
2280 allocsize = info.dwAllocationGranularity;
2281 }
2282 /* This scheme fails eventually if request for contiguous
f4257e4d 2283 * block is denied so reserve big blocks - this is only
814ffeea
VK		 2284 * address space not memory ...
2285 */
2286 if (brk+need >= reserved)
2287 {
2288 DWORD size = 64*1024*1024;
2289 char *addr;
2290 if (committed && reserved && committed < reserved)
2291 {
2292 /* Commit last of previous chunk cannot span allocations */
2293 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
2294 if (addr)
2295 committed = reserved;
2296 }
f4257e4d 2297 /* Reserve some (more) space
814ffeea
VK		 2298 * Note this is a little sneaky, 1st call passes NULL as reserved
2299 * so lets system choose where we start, subsequent calls pass
2300 * the old end address so ask for a contiguous block
2301 */
2302 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
2303 if (addr)
2304 {
2305 reserved = addr+size;
2306 if (!base)
2307 base = addr;
2308 if (!committed)
2309 committed = base;
2310 if (!brk)
2311 brk = committed;
2312 }
2313 else
2314 {
2315 return (void *) -1;
2316 }
2317 }
2318 result = brk;
2319 brk += need;
2320 if (brk > committed)
2321 {
2322 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
2323 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
2324 if (addr)
2325 {
2326 committed += size;
2327 }
2328 else
2329 return (void *) -1;
2330 }
2331 return result;
2332}
2333
2334#endif
2335#endif
2336
2337DllExport void*
2338win32_malloc(size_t size)
2339{
2340 return malloc(size);
2341}
2342
2343DllExport void*
2344win32_calloc(size_t numitems, size_t size)
2345{
2346 return calloc(numitems,size);
2347}
2348
2349DllExport void*
2350win32_realloc(void *block, size_t size)
2351{
2352 return realloc(block,size);
2353}
2354
2355DllExport void
2356win32_free(void *block)
2357{
2358 free(block);
2359}
2360
2361int
2362win32_open_osfhandle(intptr_t osfhandle, int flags)
2363{
2364 int fh;
2365 char fileflags=0; /* _osfile flags */
2366
2367 Perl_croak_nocontext("win32_open_osfhandle() TBD on this platform");
2368 return 0;
2369}
2370
2371int
2372win32_get_osfhandle(int fd)
2373{
2374 int fh;
2375 char fileflags=0; /* _osfile flags */
2376
2377 Perl_croak_nocontext("win32_get_osfhandle() TBD on this platform");
2378 return 0;
2379}
2380
2381FILE *
2382win32_fdupopen(FILE *pf)
2383{
2384 FILE* pfdup;
2385 fpos_t pos;
2386 char mode[3];
2387 int fileno = win32_dup(win32_fileno(pf));
2388 int fmode = palm_fgetmode(pfdup);
2389
2390 fprintf(stderr,"DEBUG for win32_fdupopen()\n");
2391
2392 /* open the file in the same mode */
2393 if(fmode & O_RDONLY) {
2394 mode[0] = 'r';
2395 mode[1] = 0;
2396 }
2397 else if(fmode & O_APPEND) {
2398 mode[0] = 'a';
2399 mode[1] = 0;
2400 }
2401 else if(fmode & O_RDWR) {
2402 mode[0] = 'r';
2403 mode[1] = '+';
2404 mode[2] = 0;
2405 }
2406
2407 /* it appears that the binmode is attached to the
2408 * file descriptor so binmode files will be handled
2409 * correctly
2410 */
2411 pfdup = win32_fdopen(fileno, mode);
2412
2413 /* move the file pointer to the same position */
2414 if (!fgetpos(pf, &pos)) {
2415 fsetpos(pfdup, &pos);
2416 }
2417 return pfdup;
2418}
2419
2420DllExport void*
2421win32_dynaload(const char* filename)
2422{
2423 dTHX;
2424 HMODULE hModule;
2425
2426 hModule = XCELoadLibraryA(filename);
2427
2428 return hModule;
2429}
2430
2431/* this is needed by Cwd.pm... */
2432
2433static
2434XS(w32_GetCwd)
2435{
2436 dXSARGS;
2437 char buf[MAX_PATH];
2438 SV *sv = sv_newmortal();
2439
2440 xcegetcwd(buf, sizeof(buf));
2441
2442 sv_setpv(sv, xcestrdup(buf));
2443 EXTEND(SP,1);
2444 SvPOK_on(sv);
2445 ST(0) = sv;
814ffeea 2446 SvTAINTED_on(ST(0));
814ffeea
VK		 2447 XSRETURN(1);
2448}
2449
2450static
2451XS(w32_SetCwd)
2452{
2453 dXSARGS;
2454
2455 if (items != 1)
e1caacb4
JH		 2456 Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
2457
2458 if (!xcechdir(SvPV_nolen(ST(0))))
2459 XSRETURN_YES;
2460
2461 XSRETURN_NO;
2462}
2463
2464static
2465XS(w32_GetTickCount)
2466{
2467 dXSARGS;
2468 DWORD msec = GetTickCount();
2469 EXTEND(SP,1);
2470 if ((IV)msec > 0)
2471 XSRETURN_IV(msec);
2472 XSRETURN_NV(msec);
2473}
2474
2475static
2476XS(w32_GetOSVersion)
2477{
2478 dXSARGS;
2479 OSVERSIONINFOA osver;
2480
2481 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
2482 if (!XCEGetVersionExA(&osver)) {
2483 XSRETURN_EMPTY;
2484 }
22f1178f
VP		 2485 mXPUSHp(osver.szCSDVersion, strlen(osver.szCSDVersion));
2486 mXPUSHi(osver.dwMajorVersion);
2487 mXPUSHi(osver.dwMinorVersion);
2488 mXPUSHi(osver.dwBuildNumber);
cb69f87a 2489 /* WINCE = 3 */
22f1178f 2490 mXPUSHi(osver.dwPlatformId);
e1caacb4
JH		 2491 PUTBACK;
2492}
2493
2494static
2495XS(w32_IsWinNT)
2496{
2497 dXSARGS;
2498 EXTEND(SP,1);
2499 XSRETURN_IV(IsWinNT());
2500}
2501
2502static
2503XS(w32_IsWin95)
2504{
2505 dXSARGS;
2506 EXTEND(SP,1);
2507 XSRETURN_IV(IsWin95());
2508}
2509
2510static
2511XS(w32_IsWinCE)
2512{
2513 dXSARGS;
2514 EXTEND(SP,1);
2515 XSRETURN_IV(IsWinCE());
2516}
2517
2518static
2519XS(w32_GetOemInfo)
2520{
2521 dXSARGS;
2522 wchar_t wbuf[126];
2523 char buf[126];
2524
2525 if(SystemParametersInfoW(SPI_GETOEMINFO, sizeof(wbuf), wbuf, FALSE))
2526 WideCharToMultiByte(CP_ACP, 0, wbuf, -1, buf, sizeof(buf), 0, 0);
2527 else
2528 sprintf(buf, "SystemParametersInfo failed: %d", GetLastError());
2529
2530 EXTEND(SP,1);
2531 XSRETURN_PV(buf);
2532}
2533
2534static
2535XS(w32_Sleep)
2536{
2537 dXSARGS;
2538 if (items != 1)
2539 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
2540 Sleep(SvIV(ST(0)));
2541 XSRETURN_YES;
2542}
2543
2544static
2545XS(w32_CopyFile)
2546{
2547 dXSARGS;
2548 BOOL bResult;
2549 if (items != 3)
2550 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
2551
2552 {
2553 char szSourceFile[MAX_PATH+1];
2554 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
f4257e4d 2555 bResult = XCECopyFileA(szSourceFile, SvPV_nolen(ST(1)),
e1caacb4
JH		 2556 !SvTRUE(ST(2)));
2557 }
2558
2559 if (bResult)
2560 XSRETURN_YES;
2561
2562 XSRETURN_NO;
2563}
2564
2565static
2566XS(w32_MessageBox)
2567{
2568 dXSARGS;
2569
2570 char *txt;
2571 unsigned int res;
2572 unsigned int flags = MB_OK;
2573
2574 txt = SvPV_nolen(ST(0));
f4257e4d 2575
e1caacb4
JH		 2576 if (items < 1 || items > 2)
2577 Perl_croak(aTHX_ "usage: Win32::MessageBox($txt, [$flags])");
2578
2579 if(items == 2)
2580 flags = SvIV(ST(1));
2581
2582 res = XCEMessageBoxA(NULL, txt, "Perl", flags);
2583
2584 XSRETURN_IV(res);
2585}
2586
2587static
2588XS(w32_GetPowerStatus)
2589{
2590 dXSARGS;
2591
2592 SYSTEM_POWER_STATUS_EX sps;
2593
2594 if(GetSystemPowerStatusEx(&sps, TRUE) == FALSE)
2595 {
2596 XSRETURN_EMPTY;
2597 }
2598
22f1178f
VP		 2599 mXPUSHi(sps.ACLineStatus);
2600 mXPUSHi(sps.BatteryFlag);
2601 mXPUSHi(sps.BatteryLifePercent);
2602 mXPUSHi(sps.BatteryLifeTime);
2603 mXPUSHi(sps.BatteryFullLifeTime);
2604 mXPUSHi(sps.BackupBatteryFlag);
2605 mXPUSHi(sps.BackupBatteryLifePercent);
2606 mXPUSHi(sps.BackupBatteryLifeTime);
2607 mXPUSHi(sps.BackupBatteryFullLifeTime);
e1caacb4
JH		 2608
2609 PUTBACK;
2610}
2611
2612#if UNDER_CE > 200
2613static
2614XS(w32_ShellEx)
2615{
2616 dXSARGS;
2617
2618 char buf[126];
2619 SHELLEXECUTEINFO si;
2620 char *file, *verb;
2621 wchar_t wfile[MAX_PATH];
2622 wchar_t wverb[20];
2623
2624 if (items != 2)
2625 Perl_croak(aTHX_ "usage: Win32::ShellEx($file, $verb)");
2626
2627 file = SvPV_nolen(ST(0));
2628 verb = SvPV_nolen(ST(1));
2629
2630 memset(&si, 0, sizeof(si));
2631 si.cbSize = sizeof(si);
2632 si.fMask = SEE_MASK_FLAG_NO_UI;
2633
f4257e4d 2634 MultiByteToWideChar(CP_ACP, 0, verb, -1,
e1caacb4
JH		 2635 wverb, sizeof(wverb)/2);
2636 si.lpVerb = (TCHAR *)wverb;
2637
f4257e4d 2638 MultiByteToWideChar(CP_ACP, 0, file, -1,
e1caacb4
JH		 2639 wfile, sizeof(wfile)/2);
2640 si.lpFile = (TCHAR *)wfile;
2641
2642 if(ShellExecuteEx(&si) == FALSE)
2643 {
2644 XSRETURN_NO;
2645 }
2646 XSRETURN_YES;
2647}
2648#endif
2649
2650void
2651Perl_init_os_extras(void)
2652{
acfe0abc 2653 dTHX;
e1caacb4
JH		 2654 char *file = __FILE__;
2655 dXSUB_SYS;
2656
4e205ed6 2657 w32_perlshell_tokens = NULL;
e1caacb4
JH		 2658 w32_perlshell_items = -1;
2659 w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */
a02a5408 2660 Newx(w32_children, 1, child_tab);
e1caacb4
JH		 2661 w32_num_children = 0;
2662
2663 newXS("Win32::GetCwd", w32_GetCwd, file);
2664 newXS("Win32::SetCwd", w32_SetCwd, file);
2665 newXS("Win32::GetTickCount", w32_GetTickCount, file);
2666 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
2667#if UNDER_CE > 200
2668 newXS("Win32::ShellEx", w32_ShellEx, file);
2669#endif
2670 newXS("Win32::IsWinNT", w32_IsWinNT, file);
2671 newXS("Win32::IsWin95", w32_IsWin95, file);
2672 newXS("Win32::IsWinCE", w32_IsWinCE, file);
2673 newXS("Win32::CopyFile", w32_CopyFile, file);
2674 newXS("Win32::Sleep", w32_Sleep, file);
2675 newXS("Win32::MessageBox", w32_MessageBox, file);
2676 newXS("Win32::GetPowerStatus", w32_GetPowerStatus, file);
2677 newXS("Win32::GetOemInfo", w32_GetOemInfo, file);
2678}
2679
2680void
2681myexit(void)
2682{
2683 char buf[126];
2684
2685 puts("Hit return");
2686 fgets(buf, sizeof(buf), stdin);
2687}
2688
2689void
2690Perl_win32_init(int *argcp, char ***argvp)
2691{
2692#ifdef UNDER_CE
2693 char *p;
2694
2695 if((p = xcegetenv("PERLDEBUG")) && (p[0] == 'y' || p[0] == 'Y'))
2696 atexit(myexit);
2697#endif
2698
2699 MALLOC_INIT;
2700}
2701
216db7ee
VK		 2702DllExport void
2703Perl_win32_term(void)
2704{
3890ecea 2705 dTHX;
71ad1b0c 2706 HINTS_REFCNT_TERM;
216db7ee 2707 OP_REFCNT_TERM;
3890ecea 2708 PERLIO_TERM;
216db7ee
VK		 2709 MALLOC_TERM;
2710}
2711
2712void
2713win32_get_child_IO(child_IO_table* ptbl)
2714{
2715 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
2716 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
2717 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
2718}
2719
e1caacb4
JH		 2720win32_flock(int fd, int oper)
2721{
216db7ee 2722 dTHX;
e1caacb4
JH		 2723 Perl_croak(aTHX_ PL_no_func, "flock");
2724 return -1;
2725}
2726
2727DllExport int
2728win32_waitpid(int pid, int *status, int flags)
2729{
216db7ee 2730 dTHX;
e1caacb4
JH		 2731 Perl_croak(aTHX_ PL_no_func, "waitpid");
2732 return -1;
2733}
2734
2735DllExport int
2736win32_wait(int *status)
2737{
216db7ee 2738 dTHX;
e1caacb4
JH		 2739 Perl_croak(aTHX_ PL_no_func, "wait");
2740 return -1;
2741}
2742
2743int
e1caacb4 2744wce_reopen_stdout(char *fname)
f4257e4d 2745{
e1caacb4
JH		 2746 if(xcefreopen(fname, "w", stdout) == NULL)
2747 return -1;
2748
2749 return 0;
2750}
2751
2752void
2753wce_hitreturn()
2754{
2755 char buf[126];
2756
2757 printf("Hit RETURN");
2758 fflush(stdout);
2759 fgets(buf, sizeof(buf), stdin);
2760 return;
2761}
2762
cb69f87a 2763/* //////////////////////////////////////////////////////////////////// */
e1caacb4 2764
ca6c63e1
JH		 2765#undef getcwd
2766
2767char *
2768getcwd(char *buf, size_t size)
2769{
2770 return xcegetcwd(buf, size);
2771}
2772
18f68570 2773
814ffeea
VK		 2774DllExport PerlIO*
2775win32_popenlist(const char *mode, IV narg, SV **args)
18f68570 2776{
814ffeea
VK		 2777 dTHX;
2778 Perl_croak(aTHX_ "List form of pipe open not implemented");
2779 return NULL;
18f68570
VK		 2780}
2781
2782/*
2783 * a popen() clone that respects PERL5SHELL
2784 *
2785 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2786 */
2787
2788DllExport PerlIO*
2789win32_popen(const char *command, const char *mode)
2790{
814ffeea 2791 return _popen(command, mode);
216db7ee
VK		 2792}
2793
18f68570
VK		 2794/*
2795 * pclose() clone
2796 */
2797
2798DllExport int
2799win32_pclose(PerlIO *pf)
2800{
18f68570 2801 return _pclose(pf);
18f68570
VK		 2802}
2803
216db7ee
VK		 2804#ifdef HAVE_INTERP_INTERN
2805
2806
2807static void
2808win32_csighandler(int sig)
2809{
2810#if 0
2811 dTHXa(PERL_GET_SIG_CONTEXT);
2812 Perl_warn(aTHX_ "Got signal %d",sig);
2813#endif
2814 /* Does nothing */
2815}
2816
2817void
2818Perl_sys_intern_init(pTHX)
2819{
2820 int i;
4e205ed6 2821 w32_perlshell_tokens = NULL;
216db7ee
VK		 2822 w32_perlshell_vec = (char**)NULL;
2823 w32_perlshell_items = 0;
2824 w32_fdpid = newAV();
a02a5408 2825 Newx(w32_children, 1, child_tab);
216db7ee
VK		 2826 w32_num_children = 0;
2827# ifdef USE_ITHREADS
2828 w32_pseudo_id = 0;
a02a5408 2829 Newx(w32_pseudo_children, 1, child_tab);
216db7ee
VK		 2830 w32_num_pseudo_children = 0;
2831# endif
2832 w32_init_socktype = 0;
2833 w32_timerid = 0;
2834 w32_poll_count = 0;
2835}
2836
2837void
2838Perl_sys_intern_clear(pTHX)
2839{
2840 Safefree(w32_perlshell_tokens);
2841 Safefree(w32_perlshell_vec);
2842 /* NOTE: w32_fdpid is freed by sv_clean_all() */
2843 Safefree(w32_children);
2844 if (w32_timerid) {
2845 KillTimer(NULL,w32_timerid);
2846 w32_timerid=0;
2847 }
2848# ifdef USE_ITHREADS
2849 Safefree(w32_pseudo_children);
2850# endif
2851}
2852
2853# ifdef USE_ITHREADS
2854
2855void
2856Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
2857{
4e205ed6 2858 dst->perlshell_tokens = NULL;
216db7ee
VK		 2859 dst->perlshell_vec = (char**)NULL;
2860 dst->perlshell_items = 0;
2861 dst->fdpid = newAV();
a02a5408 2862 Newxz(dst->children, 1, child_tab);
216db7ee 2863 dst->pseudo_id = 0;
a02a5408 2864 Newxz(dst->pseudo_children, 1, child_tab);
216db7ee
VK		 2865 dst->thr_intern.Winit_socktype = 0;
2866 dst->timerid = 0;
2867 dst->poll_count = 0;
2868 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
2869}
2870# endif /* USE_ITHREADS */
2871#endif /* HAVE_INTERP_INTERN */
2872
216db7ee
VK		 2873// added to remove undefied symbol error in CodeWarrior compilation
2874int
2875Perl_Ireentrant_buffer_ptr(aTHX)
2876{
2877 return 0;
2878}
Unnamed repository; edit this file 'description' to name the repository.