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