Final move from meta-3.0 to meta-3.5
[p5sagit/p5-mst-13.2.git] / win32 / wince.c
1 /*  WINCE.C - stuff for Windows CE
2  *
3  *  Time-stamp: <26/10/01 15:25:20 keuchel@keuchelnt>
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>
12 #include <signal.h>
13
14 #define PERLIO_NOT_STDIO 0
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>
35 #include <process.h>
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
44 #define GetCurrentDirectoryW XCEGetCurrentDirectoryW
45
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
67 static void             get_shell(void);
68 static long             tokenize(const char *str, char **dest, char ***destv);
69 static int              do_spawn2(pTHX_ char *cmd, int exectype);
70 static BOOL             has_shell_metachars(char *ptr);
71 static long             filetime_to_clock(PFILETIME ft);
72 static BOOL             filetime_from_time(PFILETIME ft, time_t t);
73 static char *           get_emd_part(SV **leading, char *trailing, ...);
74 static void             remove_dead_process(long deceased);
75 static long             find_pid(int pid);
76 static char *           qualified_path(const char *cmd);
77 static char *           win32_get_xlib(const char *pl, const char *xlib,
78                                        const char *libname);
79
80 #ifdef USE_ITHREADS
81 static void             remove_dead_pseudo_process(long child);
82 static long             find_pseudo_pid(int pid);
83 #endif
84
85 int _fmode = O_TEXT; /* celib do not provide _fmode, so we define it here */
86
87 START_EXTERN_C
88 HANDLE  w32_perldll_handle = INVALID_HANDLE_VALUE;
89 char    w32_module_name[MAX_PATH+1];
90 END_EXTERN_C
91
92 static DWORD    w32_platform = (DWORD)-1;
93
94 int
95 IsWin95(void)
96 {
97   return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
98 }
99
100 int
101 IsWinNT(void)
102 {
103   return (win32_os_id() == VER_PLATFORM_WIN32_NT);
104 }
105
106 int
107 IsWinCE(void)
108 {
109   return (win32_os_id() == VER_PLATFORM_WIN32_CE);
110 }
111
112 EXTERN_C void
113 set_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)) */
131 static char*
132 get_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";
138     char *str = NULL;
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) {
146             dTHX;
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)) */
163 static char*
164 get_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)) */
173 static char *
174 get_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 */
226         dTHX;
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
234     return NULL;
235 }
236
237 char *
238 win32_get_privlib(const char *pl)
239 {
240     dTHX;
241     char *stdlib = "lib";
242     char buffer[MAX_PATH+1];
243     SV *sv = NULL;
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" */
251     return get_emd_part(&sv, stdlib, ARCHNAME, "bin", NULL);
252 }
253
254 static char *
255 win32_get_xlib(const char *pl, const char *xlib, const char *libname)
256 {
257     dTHX;
258     char regstr[40];
259     char pathstr[MAX_PATH+1];
260     DWORD datalen;
261     int len, newsize;
262     SV *sv1 = NULL;
263     SV *sv2 = NULL;
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);
272     (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, NULL);
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);
280     (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, NULL);
281
282     if (!sv1 && !sv2)
283         return NULL;
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
295 char *
296 win32_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
305 char *
306 win32_get_vendorlib(const char *pl)
307 {
308     return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
309 }
310
311 static BOOL
312 has_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
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  */
356 PerlIO *
357 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
358 {
359   printf("popen(%s)\n", cmd);
360
361   Perl_croak(aTHX_ PL_no_func, "popen");
362   return NULL;
363 }
364
365 long
366 Perl_my_pclose(pTHX_ PerlIO *fp)
367 {
368   Perl_croak(aTHX_ PL_no_func, "pclose");
369   return -1;
370 }
371 #endif
372
373 DllExport unsigned long
374 win32_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
387 DllExport int
388 win32_getpid(void)
389 {
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;
398 }
399
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  */
406 static long
407 tokenize(const char *str, char **dest, char ***destv)
408 {
409     char *retstart = NULL;
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;
417         Newx(ret, slen+2, char);
418         Newx(retv, (slen+3)/2, char*);
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         }
444         retvstart[items] = NULL;
445         *ret++ = '\0';
446         *ret = '\0';
447     }
448     *dest = retstart;
449     *destv = retvstart;
450     return items;
451 }
452
453 DllExport int
454 win32_pipe(int *pfd, unsigned int size, int mode)
455 {
456   dTHX;
457   Perl_croak(aTHX_ PL_no_func, "pipe");
458   return -1;
459 }
460
461 DllExport int
462 win32_times(struct tms *timebuf)
463 {
464   dTHX;
465   Perl_croak(aTHX_ PL_no_func, "times");
466   return -1;
467 }
468
469 Sighandler_t
470 win32_signal(int sig, Sighandler_t subcode)
471 {
472   return xcesignal(sig, subcode);
473 }
474
475 static void
476 get_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
496 int
497 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
498 {
499   PERL_ARGS_ASSERT_DO_ASPAWN;
500
501   Perl_croak(aTHX_ PL_no_func, "aspawn");
502   return -1;
503 }
504
505 /* returns pointer to the next unquoted space or the end of the string */
506 static char*
507 find_next_space(const char *s)
508 {
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
530 static int
531 do_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)) {
543         Newx(argv, strlen(cmd) / 2 + 2, char*);
544         Newx(cmd2, strlen(cmd) + 1, char);
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         }
556         *a = NULL;
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();
581         Newx(argv, w32_perlshell_items + 2, char*);
582         while (++i < w32_perlshell_items)
583             argv[i] = w32_perlshell_vec[i];
584         argv[i++] = cmd;
585         argv[i] = NULL;
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
621 int
622 Perl_do_spawn(pTHX_ char *cmd)
623 {
624     PERL_ARGS_ASSERT_DO_SPAWN;
625
626     return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
627 }
628
629 int
630 Perl_do_spawn_nowait(pTHX_ char *cmd)
631 {
632     PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
633
634     return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
635 }
636
637 bool
638 Perl_do_exec(pTHX_ const char *cmd)
639 {
640     PERL_ARGS_ASSERT_DO_EXEC;
641
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  */
650 DllExport DIR *
651 win32_opendir(const char *filename)
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 */
675     Newxz(dirp, 1, DIR);
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;
724     Newx(dirp->start, dirp->size, char);
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  */
736 DllExport struct direct *
737 win32_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 */
791 DllExport long
792 win32_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  */
801 DllExport void
802 win32_seekdir(DIR *dirp, long loc)
803 {
804     dirp->curr = dirp->start + loc;
805 }
806
807 /* Rewinddir resets the string pointer to the start */
808 DllExport void
809 win32_rewinddir(DIR *dirp)
810 {
811     dirp->curr = dirp->start;
812 }
813
814 /* free the memory allocated by opendir */
815 DllExport int
816 win32_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;
824 }
825
826 #else
827 /////!!!!!!!!!!! return here and do right stuff!!!!
828
829 DllExport DIR *
830 win32_opendir(const char *filename)
831 {
832   return opendir(filename);
833 }
834
835 DllExport struct direct *
836 win32_readdir(DIR *dirp)
837 {
838   return readdir(dirp);
839 }
840
841 DllExport long
842 win32_telldir(DIR *dirp)
843 {
844   dTHX;
845   Perl_croak(aTHX_ PL_no_func, "telldir");
846   return -1;
847 }
848
849 DllExport void
850 win32_seekdir(DIR *dirp, long loc)
851 {
852   dTHX;
853   Perl_croak(aTHX_ PL_no_func, "seekdir");
854 }
855
856 DllExport void
857 win32_rewinddir(DIR *dirp)
858 {
859   dTHX;
860   Perl_croak(aTHX_ PL_no_func, "rewinddir");
861 }
862
863 DllExport int
864 win32_closedir(DIR *dirp)
865 {
866   closedir(dirp);
867   return 0;
868 }
869 #endif   // 1
870
871 DllExport int
872 win32_kill(int pid, int sig)
873 {
874   dTHX;
875   Perl_croak(aTHX_ PL_no_func, "kill");
876   return -1;
877 }
878
879 DllExport int
880 win32_stat(const char *path, struct stat *sbuf)
881 {
882   return xcestat(path, sbuf);
883 }
884
885 DllExport char *
886 win32_longpath(char *path)
887 {
888   return path;
889 }
890
891 #ifndef USE_WIN32_RTL_ENV
892
893 DllExport char *
894 win32_getenv(const char *name)
895 {
896   return xcegetenv(name);
897 }
898
899 DllExport int
900 win32_putenv(const char *name)
901 {
902   return xceputenv(name);
903 }
904
905 #endif
906
907 static long
908 filetime_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 */
918 static BOOL
919 filetime_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
940 DllExport int
941 win32_unlink(const char *filename)
942 {
943   return xceunlink(filename);
944 }
945
946 DllExport int
947 win32_utime(const char *filename, struct utimbuf *times)
948 {
949   return xceutime(filename, (struct _utimbuf *) times);
950 }
951
952 DllExport int
953 win32_gettimeofday(struct timeval *tp, void *not_used)
954 {
955     return xcegettimeofday(tp,not_used);
956 }
957
958 DllExport int
959 win32_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
1030         switch (info.wProcessorArchitecture) {
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
1054 /* Timing related stuff */
1055
1056 int
1057 do_raise(pTHX_ int sig)
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
1089 void
1090 sig_terminate(pTHX_ int sig)
1091 {
1092     Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1093     /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1094        thread
1095      */
1096     exit(sig);
1097 }
1098
1099 DllExport int
1100 win32_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
1120
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. */
1163 DllExport DWORD
1164 win32_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
1200 static UINT timerid = 0;
1201
1202 static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
1203 {
1204     dTHX;
1205     KillTimer(NULL,timerid);
1206     timerid=0;
1207     sighandler(14);
1208 }
1209
1210 DllExport unsigned int
1211 win32_sleep(unsigned int t)
1212 {
1213   return xcesleep(t);
1214 }
1215
1216 DllExport unsigned int
1217 win32_alarm(unsigned int sec)
1218 {
1219     /*
1220      * the 'obvious' implentation is SetTimer() with a callback
1221      * which does whatever receiving SIGALRM would do
1222      * we cannot use SIGALRM even via raise() as it is not
1223      * one of the supported codes in <signal.h>
1224      *
1225      * Snag is unless something is looking at the message queue
1226      * nothing happens :-(
1227      */
1228     dTHX;
1229     if (sec)
1230      {
1231       timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
1232       if (!timerid)
1233        Perl_croak_nocontext("Cannot set timer");
1234      }
1235     else
1236      {
1237       if (timerid)
1238        {
1239         KillTimer(NULL,timerid);
1240         timerid=0;
1241        }
1242      }
1243     return 0;
1244 }
1245
1246 #ifdef HAVE_DES_FCRYPT
1247 extern char *   des_fcrypt(const char *txt, const char *salt, char *cbuf);
1248 #endif
1249
1250 DllExport char *
1251 win32_crypt(const char *txt, const char *salt)
1252 {
1253     dTHX;
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.");
1259     return NULL;
1260 #endif
1261 }
1262
1263
1264 /*
1265  *  redirected io subsystem for all XS modules
1266  *
1267  */
1268
1269 DllExport int *
1270 win32_errno(void)
1271 {
1272     return (&errno);
1273 }
1274
1275 DllExport char ***
1276 win32_environ(void)
1277 {
1278   return (&(environ));
1279 }
1280
1281 /* the rest are the remapped stdio routines */
1282 DllExport FILE *
1283 win32_stderr(void)
1284 {
1285     return (stderr);
1286 }
1287
1288 char *g_getlogin() {
1289     return "no-getlogin";
1290 }
1291
1292 DllExport FILE *
1293 win32_stdin(void)
1294 {
1295     return (stdin);
1296 }
1297
1298 DllExport FILE *
1299 win32_stdout()
1300 {
1301     return (stdout);
1302 }
1303
1304 DllExport int
1305 win32_ferror(FILE *fp)
1306 {
1307     return (ferror(fp));
1308 }
1309
1310
1311 DllExport int
1312 win32_feof(FILE *fp)
1313 {
1314     return (feof(fp));
1315 }
1316
1317 /*
1318  * Since the errors returned by the socket error function
1319  * WSAGetLastError() are not known by the library routine strerror
1320  * we have to roll our own.
1321  */
1322
1323 DllExport char *
1324 win32_strerror(int e)
1325 {
1326   return xcestrerror(e);
1327 }
1328
1329 DllExport void
1330 win32_str_os_error(void *sv, DWORD dwErr)
1331 {
1332   dTHX;
1333
1334   sv_setpvn((SV*)sv, "Error", 5);
1335 }
1336
1337
1338 DllExport int
1339 win32_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
1347 DllExport int
1348 win32_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
1356 DllExport int
1357 win32_vfprintf(FILE *fp, const char *format, va_list args)
1358 {
1359     return (vfprintf(fp, format, args));
1360 }
1361
1362 DllExport int
1363 win32_vprintf(const char *format, va_list args)
1364 {
1365     return (vprintf(format, args));
1366 }
1367
1368 DllExport size_t
1369 win32_fread(void *buf, size_t size, size_t count, FILE *fp)
1370 {
1371   return fread(buf, size, count, fp);
1372 }
1373
1374 DllExport size_t
1375 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
1376 {
1377   return fwrite(buf, size, count, fp);
1378 }
1379
1380 DllExport FILE *
1381 win32_fopen(const char *filename, const char *mode)
1382 {
1383   return xcefopen(filename, mode);
1384 }
1385
1386 DllExport FILE *
1387 win32_fdopen(int handle, const char *mode)
1388 {
1389   return palm_fdopen(handle, mode);
1390 }
1391
1392 DllExport FILE *
1393 win32_freopen(const char *path, const char *mode, FILE *stream)
1394 {
1395   return xcefreopen(path, mode, stream);
1396 }
1397
1398 DllExport int
1399 win32_fclose(FILE *pf)
1400 {
1401   return xcefclose(pf);
1402 }
1403
1404 DllExport int
1405 win32_fputs(const char *s,FILE *pf)
1406 {
1407   return fputs(s, pf);
1408 }
1409
1410 DllExport int
1411 win32_fputc(int c,FILE *pf)
1412 {
1413   return fputc(c,pf);
1414 }
1415
1416 DllExport int
1417 win32_ungetc(int c,FILE *pf)
1418 {
1419   return ungetc(c,pf);
1420 }
1421
1422 DllExport int
1423 win32_getc(FILE *pf)
1424 {
1425   return getc(pf);
1426 }
1427
1428 DllExport int
1429 win32_fileno(FILE *pf)
1430 {
1431   return palm_fileno(pf);
1432 }
1433
1434 DllExport void
1435 win32_clearerr(FILE *pf)
1436 {
1437   clearerr(pf);
1438   return;
1439 }
1440
1441 DllExport int
1442 win32_fflush(FILE *pf)
1443 {
1444   return fflush(pf);
1445 }
1446
1447 DllExport long
1448 win32_ftell(FILE *pf)
1449 {
1450   return ftell(pf);
1451 }
1452
1453 DllExport int
1454 win32_fseek(FILE *pf, Off_t offset,int origin)
1455 {
1456   return fseek(pf, offset, origin);
1457 }
1458
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... */
1461 DllExport int
1462 win32_fgetpos(FILE *pf, fpos_t *p)
1463 {
1464   return fgetpos(pf, p);
1465 }
1466
1467 DllExport int
1468 win32_fsetpos(FILE *pf, const fpos_t *p)
1469 {
1470   return fsetpos(pf, p);
1471 }
1472
1473 DllExport void
1474 win32_rewind(FILE *pf)
1475 {
1476   fseek(pf, 0, SEEK_SET);
1477   return;
1478 }
1479
1480 DllExport int
1481 win32_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
1513 DllExport FILE*
1514 win32_tmpfile(void)
1515 {
1516     int fd = win32_tmpfd();
1517     if (fd >= 0)
1518         return win32_fdopen(fd, "w+b");
1519     return NULL;
1520 }
1521
1522 DllExport void
1523 win32_abort(void)
1524 {
1525   xceabort();
1526
1527   return;
1528 }
1529
1530 DllExport int
1531 win32_fstat(int fd, struct stat *sbufptr)
1532 {
1533   return xcefstat(fd, sbufptr);
1534 }
1535
1536 DllExport int
1537 win32_link(const char *oldname, const char *newname)
1538 {
1539   dTHX;
1540   Perl_croak(aTHX_ PL_no_func, "link");
1541
1542   return -1;
1543 }
1544
1545 DllExport int
1546 win32_rename(const char *oname, const char *newname)
1547 {
1548   return xcerename(oname, newname);
1549 }
1550
1551 DllExport int
1552 win32_setmode(int fd, int mode)
1553 {
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;
1559 }
1560
1561 DllExport int
1562 win32_chsize(int fd, Off_t size)
1563 {
1564     return chsize(fd, size);
1565 }
1566
1567 DllExport long
1568 win32_lseek(int fd, Off_t offset, int origin)
1569 {
1570   return xcelseek(fd, offset, origin);
1571 }
1572
1573 DllExport long
1574 win32_tell(int fd)
1575 {
1576   return xcelseek(fd, 0, SEEK_CUR);
1577 }
1578
1579 DllExport int
1580 win32_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
1592 DllExport int
1593 win32_close(int fd)
1594 {
1595   return xceclose(fd);
1596 }
1597
1598 DllExport int
1599 win32_eof(int fd)
1600 {
1601   dTHX;
1602   Perl_croak(aTHX_ PL_no_func, "eof");
1603   return -1;
1604 }
1605
1606 DllExport int
1607 win32_dup(int fd)
1608 {
1609   return xcedup(fd); /* from celib/ceio.c; requires some more work on it */
1610 }
1611
1612 DllExport int
1613 win32_dup2(int fd1,int fd2)
1614 {
1615   return xcedup2(fd1,fd2);
1616 }
1617
1618 DllExport int
1619 win32_read(int fd, void *buf, unsigned int cnt)
1620 {
1621   return xceread(fd, buf, cnt);
1622 }
1623
1624 DllExport int
1625 win32_write(int fd, const void *buf, unsigned int cnt)
1626 {
1627   return xcewrite(fd, (void *) buf, cnt);
1628 }
1629
1630 DllExport int
1631 win32_mkdir(const char *dir, int mode)
1632 {
1633   return xcemkdir(dir);
1634 }
1635
1636 DllExport int
1637 win32_rmdir(const char *dir)
1638 {
1639   return xcermdir(dir);
1640 }
1641
1642 DllExport int
1643 win32_chdir(const char *dir)
1644 {
1645   return xcechdir(dir);
1646 }
1647
1648 DllExport  int
1649 win32_access(const char *path, int mode)
1650 {
1651   return xceaccess(path, mode);
1652 }
1653
1654 DllExport  int
1655 win32_chmod(const char *path, int mode)
1656 {
1657   return xcechmod(path, mode);
1658 }
1659
1660 static char *
1661 create_command_line(char *cname, STRLEN clen, const char * const *args)
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;
1735     Newx(cmd, len, char);
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
1815 static char *
1816 qualified_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)
1825         return NULL;
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");
1836     Newx(fullcmd, MAX_PATH+1, char);
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);
1900     return NULL;
1901 }
1902
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
1909 DllExport void*
1910 win32_get_childenv(void)
1911 {
1912     return NULL;
1913 }
1914
1915 DllExport void
1916 win32_free_childenv(void* d)
1917 {
1918 }
1919
1920 DllExport void
1921 win32_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
1940 DllExport char*
1941 win32_get_childdir(void)
1942 {
1943     dTHX;
1944     char* ptr;
1945     char szfilename[MAX_PATH+1];
1946     GetCurrentDirectoryA(MAX_PATH+1, szfilename);
1947
1948     Newx(ptr, strlen(szfilename)+1, char);
1949     strcpy(ptr, szfilename);
1950     return ptr;
1951 }
1952
1953 DllExport void
1954 win32_free_childdir(char* d)
1955 {
1956     dTHX;
1957     Safefree(d);
1958 }
1959
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
1971 DllExport int
1972 win32_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;
1986     char *fullcmd = NULL;
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;
1995             Newx(cname,clen+1,char);
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));
2065 RETRY:
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
2123 RETVAL:
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
2133 DllExport int
2134 win32_execv(const char *cmdname, const char *const *argv)
2135 {
2136   dTHX;
2137   Perl_croak(aTHX_ PL_no_func, "execv");
2138   return -1;
2139 }
2140
2141 DllExport int
2142 win32_execvp(const char *cmdname, const char *const *argv)
2143 {
2144   dTHX;
2145   Perl_croak(aTHX_ PL_no_func, "execvp");
2146   return -1;
2147 }
2148
2149 DllExport void
2150 win32_perror(const char *str)
2151 {
2152   xceperror(str);
2153 }
2154
2155 DllExport void
2156 win32_setbuf(FILE *pf, char *buf)
2157 {
2158   dTHX;
2159   Perl_croak(aTHX_ PL_no_func, "setbuf");
2160 }
2161
2162 DllExport int
2163 win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
2164 {
2165   return setvbuf(pf, buf, type, size);
2166 }
2167
2168 DllExport int
2169 win32_flushall(void)
2170 {
2171   return flushall();
2172 }
2173
2174 DllExport int
2175 win32_fcloseall(void)
2176 {
2177   return fcloseall();
2178 }
2179
2180 DllExport char*
2181 win32_fgets(char *s, int n, FILE *pf)
2182 {
2183   return fgets(s, n, pf);
2184 }
2185
2186 DllExport char*
2187 win32_gets(char *s)
2188 {
2189   return gets(s);
2190 }
2191
2192 DllExport int
2193 win32_fgetc(FILE *pf)
2194 {
2195   return fgetc(pf);
2196 }
2197
2198 DllExport int
2199 win32_putc(int c, FILE *pf)
2200 {
2201   return putc(c,pf);
2202 }
2203
2204 DllExport int
2205 win32_puts(const char *s)
2206 {
2207   return puts(s);
2208 }
2209
2210 DllExport int
2211 win32_getchar(void)
2212 {
2213   return getchar();
2214 }
2215
2216 DllExport int
2217 win32_putchar(int c)
2218 {
2219   return putchar(c);
2220 }
2221
2222 #ifdef MYMALLOC
2223
2224 #ifndef USE_PERL_SBRK
2225
2226 static char *committed = NULL;
2227 static char *base      = NULL;
2228 static char *reserved  = NULL;
2229 static char *brk       = NULL;
2230 static DWORD pagesize  = 0;
2231 static DWORD allocsize = 0;
2232
2233 void *
2234 sbrk(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
2247   * block is denied so reserve big blocks - this is only
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     }
2261    /* Reserve some (more) space
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
2301 DllExport void*
2302 win32_malloc(size_t size)
2303 {
2304     return malloc(size);
2305 }
2306
2307 DllExport void*
2308 win32_calloc(size_t numitems, size_t size)
2309 {
2310     return calloc(numitems,size);
2311 }
2312
2313 DllExport void*
2314 win32_realloc(void *block, size_t size)
2315 {
2316     return realloc(block,size);
2317 }
2318
2319 DllExport void
2320 win32_free(void *block)
2321 {
2322     free(block);
2323 }
2324
2325 int
2326 win32_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
2335 int
2336 win32_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
2345 FILE *
2346 win32_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
2384 DllExport void*
2385 win32_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
2397 static
2398 XS(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
2416 static
2417 XS(w32_SetCwd)
2418 {
2419   dXSARGS;
2420
2421   if (items != 1)
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
2430 static
2431 XS(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
2441 static
2442 XS(w32_GetOSVersion)
2443 {
2444     dXSARGS;
2445     OSVERSIONINFOA osver;
2446
2447     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
2448     if (!XCEGetVersionExA(&osver)) {
2449       XSRETURN_EMPTY;
2450     }
2451     mXPUSHp(osver.szCSDVersion, strlen(osver.szCSDVersion));
2452     mXPUSHi(osver.dwMajorVersion);
2453     mXPUSHi(osver.dwMinorVersion);
2454     mXPUSHi(osver.dwBuildNumber);
2455     /* WINCE = 3 */
2456     mXPUSHi(osver.dwPlatformId);
2457     PUTBACK;
2458 }
2459
2460 static
2461 XS(w32_IsWinNT)
2462 {
2463     dXSARGS;
2464     EXTEND(SP,1);
2465     XSRETURN_IV(IsWinNT());
2466 }
2467
2468 static
2469 XS(w32_IsWin95)
2470 {
2471     dXSARGS;
2472     EXTEND(SP,1);
2473     XSRETURN_IV(IsWin95());
2474 }
2475
2476 static
2477 XS(w32_IsWinCE)
2478 {
2479     dXSARGS;
2480     EXTEND(SP,1);
2481     XSRETURN_IV(IsWinCE());
2482 }
2483
2484 static
2485 XS(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
2500 static
2501 XS(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
2510 static
2511 XS(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))));
2521       bResult = XCECopyFileA(szSourceFile, SvPV_nolen(ST(1)),
2522                              !SvTRUE(ST(2)));
2523     }
2524
2525     if (bResult)
2526         XSRETURN_YES;
2527
2528     XSRETURN_NO;
2529 }
2530
2531 static
2532 XS(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));
2541
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
2553 static
2554 XS(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
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);
2574
2575   PUTBACK;
2576 }
2577
2578 #if UNDER_CE > 200
2579 static
2580 XS(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
2600   MultiByteToWideChar(CP_ACP, 0, verb, -1,
2601                       wverb, sizeof(wverb)/2);
2602   si.lpVerb = (TCHAR *)wverb;
2603
2604   MultiByteToWideChar(CP_ACP, 0, file, -1,
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
2616 void
2617 Perl_init_os_extras(void)
2618 {
2619     dTHX;
2620     char *file = __FILE__;
2621     dXSUB_SYS;
2622
2623     w32_perlshell_tokens = NULL;
2624     w32_perlshell_items = -1;
2625     w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */
2626     Newx(w32_children, 1, child_tab);
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
2646 void
2647 myexit(void)
2648 {
2649   char buf[126];
2650
2651   puts("Hit return");
2652   fgets(buf, sizeof(buf), stdin);
2653 }
2654
2655 void
2656 Perl_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
2668 DllExport void
2669 Perl_win32_term(void)
2670 {
2671     dTHX;
2672     HINTS_REFCNT_TERM;
2673     OP_REFCNT_TERM;
2674     PERLIO_TERM;
2675     MALLOC_TERM;
2676 }
2677
2678 void
2679 win32_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
2686 win32_flock(int fd, int oper)
2687 {
2688   dTHX;
2689   Perl_croak(aTHX_ PL_no_func, "flock");
2690   return -1;
2691 }
2692
2693 DllExport int
2694 win32_waitpid(int pid, int *status, int flags)
2695 {
2696   dTHX;
2697   Perl_croak(aTHX_ PL_no_func, "waitpid");
2698   return -1;
2699 }
2700
2701 DllExport int
2702 win32_wait(int *status)
2703 {
2704   dTHX;
2705   Perl_croak(aTHX_ PL_no_func, "wait");
2706   return -1;
2707 }
2708
2709 int
2710 wce_reopen_stdout(char *fname)
2711 {
2712   if(xcefreopen(fname, "w", stdout) == NULL)
2713     return -1;
2714
2715   return 0;
2716 }
2717
2718 void
2719 wce_hitreturn()
2720 {
2721   char buf[126];
2722
2723   printf("Hit RETURN");
2724   fflush(stdout);
2725   fgets(buf, sizeof(buf), stdin);
2726   return;
2727 }
2728
2729 /* //////////////////////////////////////////////////////////////////// */
2730
2731 #undef getcwd
2732
2733 char *
2734 getcwd(char *buf, size_t size)
2735 {
2736   return xcegetcwd(buf, size);
2737 }
2738
2739 int
2740 isnan(double d)
2741 {
2742   return _isnan(d);
2743 }
2744
2745
2746 DllExport PerlIO*
2747 win32_popenlist(const char *mode, IV narg, SV **args)
2748 {
2749  dTHX;
2750  Perl_croak(aTHX_ "List form of pipe open not implemented");
2751  return NULL;
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
2760 DllExport PerlIO*
2761 win32_popen(const char *command, const char *mode)
2762 {
2763     return _popen(command, mode);
2764 }
2765
2766 /*
2767  * pclose() clone
2768  */
2769
2770 DllExport int
2771 win32_pclose(PerlIO *pf)
2772 {
2773     return _pclose(pf);
2774 }
2775
2776 #ifdef HAVE_INTERP_INTERN
2777
2778
2779 static void
2780 win32_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
2789 void
2790 Perl_sys_intern_init(pTHX)
2791 {
2792     int i;
2793     w32_perlshell_tokens        = NULL;
2794     w32_perlshell_vec           = (char**)NULL;
2795     w32_perlshell_items         = 0;
2796     w32_fdpid                   = newAV();
2797     Newx(w32_children, 1, child_tab);
2798     w32_num_children            = 0;
2799 #  ifdef USE_ITHREADS
2800     w32_pseudo_id               = 0;
2801     Newx(w32_pseudo_children, 1, child_tab);
2802     w32_num_pseudo_children     = 0;
2803 #  endif
2804     w32_init_socktype           = 0;
2805     w32_timerid                 = 0;
2806     w32_poll_count              = 0;
2807 }
2808
2809 void
2810 Perl_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
2827 void
2828 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
2829 {
2830     dst->perlshell_tokens       = NULL;
2831     dst->perlshell_vec          = (char**)NULL;
2832     dst->perlshell_items        = 0;
2833     dst->fdpid                  = newAV();
2834     Newxz(dst->children, 1, child_tab);
2835     dst->pseudo_id              = 0;
2836     Newxz(dst->pseudo_children, 1, child_tab);
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
2845 // added to remove undefied symbol error in CodeWarrior compilation
2846 int
2847 Perl_Ireentrant_buffer_ptr(aTHX)
2848 {
2849         return 0;
2850 }