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