source: trunk/third/perl/wince/wince.c @ 20075

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