This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate the PerlCE (WinCE Perl) port;
[perl5.git] / wince / wince.c
CommitLineData
e1caacb4
JH
1/* WINCE.C - stuff for Windows CE
2 *
3 * Time-stamp: <01/08/01 19:29:57 keuchel@w2k>
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
13#define PERLIO_NOT_STDIO 0
14
15#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
16#define PerlIO FILE
17#endif
18
19#define wince_private
20#include "errno.h"
21
22#include "EXTERN.h"
23#include "perl.h"
24
25#define NO_XSLOCKS
26#define PERL_NO_GET_CONTEXT
27#include "XSUB.h"
28
29#include "win32iop.h"
30#include <string.h>
31#include <stdarg.h>
32#include <float.h>
33#include <shellapi.h>
34
35#define perl
36#include "celib_defs.h"
37#include "cewin32.h"
38#include "cecrt.h"
39#include "cewin32_defs.h"
40#include "cecrt_defs.h"
41
42#ifdef PALM_SIZE
43#include "stdio-palmsize.h"
44#endif
45
46#define EXECF_EXEC 1
47#define EXECF_SPAWN 2
48#define EXECF_SPAWN_NOWAIT 3
49
50#if defined(PERL_IMPLICIT_SYS)
51# undef win32_get_privlib
52# define win32_get_privlib g_win32_get_privlib
53# undef win32_get_sitelib
54# define win32_get_sitelib g_win32_get_sitelib
55# undef win32_get_vendorlib
56# define win32_get_vendorlib g_win32_get_vendorlib
57# undef do_spawn
58# define do_spawn g_do_spawn
59# undef getlogin
60# define getlogin g_getlogin
61#endif
62
63#if defined(PERL_OBJECT)
64# undef do_aspawn
65# define do_aspawn g_do_aspawn
66# undef Perl_do_exec
67# define Perl_do_exec g_do_exec
68#endif
69
70static long filetime_to_clock(PFILETIME ft);
71static BOOL filetime_from_time(PFILETIME ft, time_t t);
72static char * get_emd_part(SV **leading, char *trailing, ...);
73static char * win32_get_xlib(const char *pl, const char *xlib,
74 const char *libname);
75
76START_EXTERN_C
77HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
78char w32_module_name[MAX_PATH+1];
79END_EXTERN_C
80
81static DWORD w32_platform = (DWORD)-1;
82
83int
84IsWin95(void)
85{
86 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
87}
88
89int
90IsWinNT(void)
91{
92 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
93}
94
95int
96IsWinCE(void)
97{
98 return (win32_os_id() == VER_PLATFORM_WIN32_CE);
99}
100
101EXTERN_C void
102set_w32_module_name(void)
103{
104 char* ptr;
105 XCEGetModuleFileNameA((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
106 ? XCEGetModuleHandleA(NULL)
107 : w32_perldll_handle),
108 w32_module_name, sizeof(w32_module_name));
109
110 /* normalize to forward slashes */
111 ptr = w32_module_name;
112 while (*ptr) {
113 if (*ptr == '\\')
114 *ptr = '/';
115 ++ptr;
116 }
117}
118
119/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
120static char*
121get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
122{
123 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
124 HKEY handle;
125 DWORD type;
126 const char *subkey = "Software\\Perl";
127 char *str = Nullch;
128 long retval;
129
130 retval = XCERegOpenKeyExA(hkey, subkey, 0, KEY_READ, &handle);
131 if (retval == ERROR_SUCCESS) {
132 DWORD datalen;
133 retval = XCERegQueryValueExA(handle, valuename, 0, &type, NULL, &datalen);
134 if (retval == ERROR_SUCCESS && type == REG_SZ) {
135 dTHXo;
136 if (!*svp)
137 *svp = sv_2mortal(newSVpvn("",0));
138 SvGROW(*svp, datalen);
139 retval = XCERegQueryValueExA(handle, valuename, 0, NULL,
140 (PBYTE)SvPVX(*svp), &datalen);
141 if (retval == ERROR_SUCCESS) {
142 str = SvPVX(*svp);
143 SvCUR_set(*svp,datalen-1);
144 }
145 }
146 RegCloseKey(handle);
147 }
148 return str;
149}
150
151/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
152static char*
153get_regstr(const char *valuename, SV **svp)
154{
155 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
156 if (!str)
157 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
158 return str;
159}
160
161/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
162static char *
163get_emd_part(SV **prev_pathp, char *trailing_path, ...)
164{
165 char base[10];
166 va_list ap;
167 char mod_name[MAX_PATH+1];
168 char *ptr;
169 char *optr;
170 char *strip;
171 int oldsize, newsize;
172 STRLEN baselen;
173
174 va_start(ap, trailing_path);
175 strip = va_arg(ap, char *);
176
177 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
178 baselen = strlen(base);
179
180 if (!*w32_module_name) {
181 set_w32_module_name();
182 }
183 strcpy(mod_name, w32_module_name);
184 ptr = strrchr(mod_name, '/');
185 while (ptr && strip) {
186 /* look for directories to skip back */
187 optr = ptr;
188 *ptr = '\0';
189 ptr = strrchr(mod_name, '/');
190 /* avoid stripping component if there is no slash,
191 * or it doesn't match ... */
192 if (!ptr || stricmp(ptr+1, strip) != 0) {
193 /* ... but not if component matches m|5\.$patchlevel.*| */
194 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
195 && strncmp(strip, base, baselen) == 0
196 && strncmp(ptr+1, base, baselen) == 0))
197 {
198 *optr = '/';
199 ptr = optr;
200 }
201 }
202 strip = va_arg(ap, char *);
203 }
204 if (!ptr) {
205 ptr = mod_name;
206 *ptr++ = '.';
207 *ptr = '/';
208 }
209 va_end(ap);
210 strcpy(++ptr, trailing_path);
211
212 /* only add directory if it exists */
213 if (XCEGetFileAttributesA(mod_name) != (DWORD) -1) {
214 /* directory exists */
215 dTHXo;
216 if (!*prev_pathp)
217 *prev_pathp = sv_2mortal(newSVpvn("",0));
218 sv_catpvn(*prev_pathp, ";", 1);
219 sv_catpv(*prev_pathp, mod_name);
220 return SvPVX(*prev_pathp);
221 }
222
223 return Nullch;
224}
225
226char *
227win32_get_privlib(const char *pl)
228{
229 dTHXo;
230 char *stdlib = "lib";
231 char buffer[MAX_PATH+1];
232 SV *sv = Nullsv;
233
234 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
235 sprintf(buffer, "%s-%s", stdlib, pl);
236 if (!get_regstr(buffer, &sv))
237 (void)get_regstr(stdlib, &sv);
238
239 /* $stdlib .= ";$EMD/../../lib" */
240 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
241}
242
243static char *
244win32_get_xlib(const char *pl, const char *xlib, const char *libname)
245{
246 dTHXo;
247 char regstr[40];
248 char pathstr[MAX_PATH+1];
249 DWORD datalen;
250 int len, newsize;
251 SV *sv1 = Nullsv;
252 SV *sv2 = Nullsv;
253
254 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
255 sprintf(regstr, "%s-%s", xlib, pl);
256 (void)get_regstr(regstr, &sv1);
257
258 /* $xlib .=
259 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
260 sprintf(pathstr, "%s/%s/lib", libname, pl);
261 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
262
263 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
264 (void)get_regstr(xlib, &sv2);
265
266 /* $xlib .=
267 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
268 sprintf(pathstr, "%s/lib", libname);
269 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
270
271 if (!sv1 && !sv2)
272 return Nullch;
273 if (!sv1)
274 return SvPVX(sv2);
275 if (!sv2)
276 return SvPVX(sv1);
277
278 sv_catpvn(sv1, ";", 1);
279 sv_catsv(sv1, sv2);
280
281 return SvPVX(sv1);
282}
283
284char *
285win32_get_sitelib(const char *pl)
286{
287 return win32_get_xlib(pl, "sitelib", "site");
288}
289
290#ifndef PERL_VENDORLIB_NAME
291# define PERL_VENDORLIB_NAME "vendor"
292#endif
293
294char *
295win32_get_vendorlib(const char *pl)
296{
297 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
298}
299
300#if !defined(PERL_IMPLICIT_SYS)
301/* since the current process environment is being updated in util.c
302 * the library functions will get the correct environment
303 */
304PerlIO *
305Perl_my_popen(pTHX_ char *cmd, char *mode)
306{
307 printf("popen(%s)\n", cmd);
308
309 Perl_croak(aTHX_ PL_no_func, "popen");
310 return NULL;
311}
312
313long
314Perl_my_pclose(pTHX_ PerlIO *fp)
315{
316 Perl_croak(aTHX_ PL_no_func, "pclose");
317 return -1;
318}
319#endif
320
321DllExport unsigned long
322win32_os_id(void)
323{
324 static OSVERSIONINFOA osver;
325
326 if (osver.dwPlatformId != w32_platform) {
327 memset(&osver, 0, sizeof(OSVERSIONINFOA));
328 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
329 XCEGetVersionExA(&osver);
330 w32_platform = osver.dwPlatformId;
331 }
332 return (unsigned long)w32_platform;
333}
334
335DllExport int
336win32_getpid(void)
337{
338 return xcegetpid();
339}
340
341bool
342Perl_do_exec(pTHX_ char *cmd)
343{
344 Perl_croak_nocontext("exec() unimplemented on this platform");
345 return FALSE;
346}
347
348DllExport int
349win32_pipe(int *pfd, unsigned int size, int mode)
350{
351 Perl_croak(aTHX_ PL_no_func, "pipe");
352 return -1;
353}
354
355DllExport int
356win32_times(struct tms *timebuf)
357{
358 Perl_croak(aTHX_ PL_no_func, "times");
359 return -1;
360}
361
362DllExport char ***
363win32_environ(void)
364{
365 return (&(environ));
366}
367
368DllExport DIR *
369win32_opendir(char *filename)
370{
371 return opendir(filename);
372}
373
374DllExport struct direct *
375win32_readdir(DIR *dirp)
376{
377 return readdir(dirp);
378}
379
380DllExport long
381win32_telldir(DIR *dirp)
382{
383 Perl_croak(aTHX_ PL_no_func, "telldir");
384 return -1;
385}
386
387DllExport void
388win32_seekdir(DIR *dirp, long loc)
389{
390 Perl_croak(aTHX_ PL_no_func, "seekdir");
391}
392
393DllExport void
394win32_rewinddir(DIR *dirp)
395{
396 Perl_croak(aTHX_ PL_no_func, "rewinddir");
397}
398
399DllExport int
400win32_closedir(DIR *dirp)
401{
402 closedir(dirp);
403 return 0;
404}
405
406DllExport int
407win32_kill(int pid, int sig)
408{
409 Perl_croak(aTHX_ PL_no_func, "kill");
410 return -1;
411}
412
413DllExport unsigned int
414win32_sleep(unsigned int t)
415{
416 return xcesleep(t);
417}
418
419DllExport int
420win32_stat(const char *path, struct stat *sbuf)
421{
422 return xcestat(path, sbuf);
423}
424
425DllExport char *
426win32_longpath(char *path)
427{
428 return path;
429}
430
431#ifndef USE_WIN32_RTL_ENV
432
433DllExport char *
434win32_getenv(const char *name)
435{
436 return xcegetenv(name);
437}
438
439DllExport int
440win32_putenv(const char *name)
441{
442 return xceputenv(name);
443}
444
445#endif
446
447static long
448filetime_to_clock(PFILETIME ft)
449{
450 __int64 qw = ft->dwHighDateTime;
451 qw <<= 32;
452 qw |= ft->dwLowDateTime;
453 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
454 return (long) qw;
455}
456
457/* fix utime() so it works on directories in NT */
458static BOOL
459filetime_from_time(PFILETIME pFileTime, time_t Time)
460{
461 struct tm *pTM = localtime(&Time);
462 SYSTEMTIME SystemTime;
463 FILETIME LocalTime;
464
465 if (pTM == NULL)
466 return FALSE;
467
468 SystemTime.wYear = pTM->tm_year + 1900;
469 SystemTime.wMonth = pTM->tm_mon + 1;
470 SystemTime.wDay = pTM->tm_mday;
471 SystemTime.wHour = pTM->tm_hour;
472 SystemTime.wMinute = pTM->tm_min;
473 SystemTime.wSecond = pTM->tm_sec;
474 SystemTime.wMilliseconds = 0;
475
476 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
477 LocalFileTimeToFileTime(&LocalTime, pFileTime);
478}
479
480DllExport int
481win32_unlink(const char *filename)
482{
483 return xceunlink(filename);
484}
485
486DllExport int
487win32_utime(const char *filename, struct utimbuf *times)
488{
489 return xceutime(filename, (struct _utimbuf *) times);
490}
491
492DllExport int
493win32_uname(struct utsname *name)
494{
495 struct hostent *hep;
496 STRLEN nodemax = sizeof(name->nodename)-1;
497 OSVERSIONINFOA osver;
498
499 memset(&osver, 0, sizeof(OSVERSIONINFOA));
500 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
501 if (XCEGetVersionExA(&osver)) {
502 /* sysname */
503 switch (osver.dwPlatformId) {
504 case VER_PLATFORM_WIN32_CE:
505 strcpy(name->sysname, "Windows CE");
506 break;
507 case VER_PLATFORM_WIN32_WINDOWS:
508 strcpy(name->sysname, "Windows");
509 break;
510 case VER_PLATFORM_WIN32_NT:
511 strcpy(name->sysname, "Windows NT");
512 break;
513 case VER_PLATFORM_WIN32s:
514 strcpy(name->sysname, "Win32s");
515 break;
516 default:
517 strcpy(name->sysname, "Win32 Unknown");
518 break;
519 }
520
521 /* release */
522 sprintf(name->release, "%d.%d",
523 osver.dwMajorVersion, osver.dwMinorVersion);
524
525 /* version */
526 sprintf(name->version, "Build %d",
527 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
528 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
529 if (osver.szCSDVersion[0]) {
530 char *buf = name->version + strlen(name->version);
531 sprintf(buf, " (%s)", osver.szCSDVersion);
532 }
533 }
534 else {
535 *name->sysname = '\0';
536 *name->version = '\0';
537 *name->release = '\0';
538 }
539
540 /* nodename */
541 hep = win32_gethostbyname("localhost");
542 if (hep) {
543 STRLEN len = strlen(hep->h_name);
544 if (len <= nodemax) {
545 strcpy(name->nodename, hep->h_name);
546 }
547 else {
548 strncpy(name->nodename, hep->h_name, nodemax);
549 name->nodename[nodemax] = '\0';
550 }
551 }
552 else {
553 DWORD sz = nodemax;
554 if (!XCEGetComputerNameA(name->nodename, &sz))
555 *name->nodename = '\0';
556 }
557
558 /* machine (architecture) */
559 {
560 SYSTEM_INFO info;
561 char *arch;
562 GetSystemInfo(&info);
563
564#if defined(__BORLANDC__) || defined(__MINGW32__)
565 switch (info.u.s.wProcessorArchitecture) {
566#else
567 switch (info.wProcessorArchitecture) {
568#endif
569 case PROCESSOR_ARCHITECTURE_INTEL:
570 arch = "x86"; break;
571 case PROCESSOR_ARCHITECTURE_MIPS:
572 arch = "mips"; break;
573 case PROCESSOR_ARCHITECTURE_ALPHA:
574 arch = "alpha"; break;
575 case PROCESSOR_ARCHITECTURE_PPC:
576 arch = "ppc"; break;
577 case PROCESSOR_ARCHITECTURE_ARM:
578 arch = "arm"; break;
579 case PROCESSOR_HITACHI_SH3:
580 arch = "sh3"; break;
581 case PROCESSOR_SHx_SH3:
582 arch = "sh3"; break;
583
584 default:
585 arch = "unknown"; break;
586 }
587 strcpy(name->machine, arch);
588 }
589 return 0;
590}
591
592#ifndef PERL_OBJECT
593
594static UINT timerid = 0;
595
596static VOID CALLBACK TimerProc(HWND win, UINT msg, UINT id, DWORD time)
597{
598 dTHXo;
599 KillTimer(NULL,timerid);
600 timerid=0;
601 sighandler(14);
602}
603#endif /* !PERL_OBJECT */
604
605DllExport unsigned int
606win32_alarm(unsigned int sec)
607{
608#ifndef PERL_OBJECT
609 /*
610 * the 'obvious' implentation is SetTimer() with a callback
611 * which does whatever receiving SIGALRM would do
612 * we cannot use SIGALRM even via raise() as it is not
613 * one of the supported codes in <signal.h>
614 *
615 * Snag is unless something is looking at the message queue
616 * nothing happens :-(
617 */
618 dTHXo;
619 if (sec)
620 {
621 timerid = SetTimer(NULL,timerid,sec*1000,(TIMERPROC)TimerProc);
622 if (!timerid)
623 Perl_croak_nocontext("Cannot set timer");
624 }
625 else
626 {
627 if (timerid)
628 {
629 KillTimer(NULL,timerid);
630 timerid=0;
631 }
632 }
633#endif /* !PERL_OBJECT */
634 return 0;
635}
636
637#ifdef HAVE_DES_FCRYPT
638extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
639#endif
640
641DllExport char *
642win32_crypt(const char *txt, const char *salt)
643{
644 dTHXo;
645#ifdef HAVE_DES_FCRYPT
646 dTHR;
647 return des_fcrypt(txt, salt, w32_crypt_buffer);
648#else
649 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
650 return Nullch;
651#endif
652}
653
654/* C doesn't like repeat struct definitions */
655
656#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX)
657
658#ifndef _CRTIMP
659#define _CRTIMP __declspec(dllimport)
660#endif
661
662/*
663 * Control structure for lowio file handles
664 */
665typedef struct {
666 long osfhnd; /* underlying OS file HANDLE */
667 char osfile; /* attributes of file (e.g., open in text mode?) */
668 char pipech; /* one char buffer for handles opened on pipes */
669 int lockinitflag;
670 CRITICAL_SECTION lock;
671} ioinfo;
672
673
674/*
675 * Array of arrays of control structures for lowio files.
676 */
677EXTERN_C _CRTIMP ioinfo* __pioinfo[];
678
679/*
680 * Definition of IOINFO_L2E, the log base 2 of the number of elements in each
681 * array of ioinfo structs.
682 */
683#define IOINFO_L2E 5
684
685/*
686 * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array
687 */
688#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
689
690/*
691 * Access macros for getting at an ioinfo struct and its fields from a
692 * file handle
693 */
694#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1)))
695#define _osfhnd(i) (_pioinfo(i)->osfhnd)
696#define _osfile(i) (_pioinfo(i)->osfile)
697#define _pipech(i) (_pioinfo(i)->pipech)
698
699#endif
700
701/*
702 * redirected io subsystem for all XS modules
703 *
704 */
705
706DllExport int *
707win32_errno(void)
708{
709 return (&errno);
710}
711
712/* the rest are the remapped stdio routines */
713DllExport FILE *
714win32_stderr(void)
715{
716 return (stderr);
717}
718
719DllExport FILE *
720win32_stdin(void)
721{
722 return (stdin);
723}
724
725DllExport FILE *
726win32_stdout()
727{
728 return (stdout);
729}
730
731DllExport int
732win32_ferror(FILE *fp)
733{
734 return (ferror(fp));
735}
736
737
738DllExport int
739win32_feof(FILE *fp)
740{
741 return (feof(fp));
742}
743
744/*
745 * Since the errors returned by the socket error function
746 * WSAGetLastError() are not known by the library routine strerror
747 * we have to roll our own.
748 */
749
750DllExport char *
751win32_strerror(int e)
752{
753 return xcestrerror(e);
754}
755
756DllExport void
757win32_str_os_error(void *sv, DWORD dwErr)
758{
759 dTHXo;
760
761 sv_setpvn((SV*)sv, "Error", 5);
762}
763
764
765DllExport int
766win32_fprintf(FILE *fp, const char *format, ...)
767{
768 va_list marker;
769 va_start(marker, format); /* Initialize variable arguments. */
770
771 return (vfprintf(fp, format, marker));
772}
773
774DllExport int
775win32_printf(const char *format, ...)
776{
777 va_list marker;
778 va_start(marker, format); /* Initialize variable arguments. */
779
780 return (vprintf(format, marker));
781}
782
783DllExport int
784win32_vfprintf(FILE *fp, const char *format, va_list args)
785{
786 return (vfprintf(fp, format, args));
787}
788
789DllExport int
790win32_vprintf(const char *format, va_list args)
791{
792 return (vprintf(format, args));
793}
794
795DllExport size_t
796win32_fread(void *buf, size_t size, size_t count, FILE *fp)
797{
798 return fread(buf, size, count, fp);
799}
800
801DllExport size_t
802win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
803{
804 return fwrite(buf, size, count, fp);
805}
806
807DllExport FILE *
808win32_fopen(const char *filename, const char *mode)
809{
810 return xcefopen(filename, mode);
811}
812
813DllExport FILE *
814win32_fdopen(int handle, const char *mode)
815{
816 return palm_fdopen(handle, mode);
817}
818
819DllExport FILE *
820win32_freopen(const char *path, const char *mode, FILE *stream)
821{
822 return xcefreopen(path, mode, stream);
823}
824
825DllExport int
826win32_fclose(FILE *pf)
827{
828 return xcefclose(pf);
829}
830
831DllExport int
832win32_fputs(const char *s,FILE *pf)
833{
834 return fputs(s, pf);
835}
836
837DllExport int
838win32_fputc(int c,FILE *pf)
839{
840 return fputc(c,pf);
841}
842
843DllExport int
844win32_ungetc(int c,FILE *pf)
845{
846 return ungetc(c,pf);
847}
848
849DllExport int
850win32_getc(FILE *pf)
851{
852 return getc(pf);
853}
854
855DllExport int
856win32_fileno(FILE *pf)
857{
858 return palm_fileno(pf);
859}
860
861DllExport void
862win32_clearerr(FILE *pf)
863{
864 clearerr(pf);
865 return;
866}
867
868DllExport int
869win32_fflush(FILE *pf)
870{
871 return fflush(pf);
872}
873
874DllExport long
875win32_ftell(FILE *pf)
876{
877 return ftell(pf);
878}
879
880DllExport int
881win32_fseek(FILE *pf,long offset,int origin)
882{
883 return fseek(pf, offset, origin);
884}
885
886// fpos_t seems to be int64 on hpc pro! Really stupid.
887// But maybe someday there will be such large disks in a hpc...
888DllExport int
889win32_fgetpos(FILE *pf, fpos_t *p)
890{
891 return fgetpos(pf, p);
892}
893
894DllExport int
895win32_fsetpos(FILE *pf, const fpos_t *p)
896{
897 return fsetpos(pf, p);
898}
899
900DllExport void
901win32_rewind(FILE *pf)
902{
903 fseek(pf, 0, SEEK_SET);
904 return;
905}
906
907DllExport FILE*
908win32_tmpfile(void)
909{
910 Perl_croak(aTHX_ PL_no_func, "tmpfile");
911
912 return NULL;
913}
914
915DllExport void
916win32_abort(void)
917{
918 xceabort();
919
920 return;
921}
922
923DllExport int
924win32_fstat(int fd, struct stat *sbufptr)
925{
926 return xcefstat(fd, sbufptr);
927}
928
929DllExport int
930win32_link(const char *oldname, const char *newname)
931{
932 Perl_croak(aTHX_ PL_no_func, "link");
933
934 return -1;
935}
936
937DllExport int
938win32_rename(const char *oname, const char *newname)
939{
940 return xcerename(oname, newname);
941}
942
943DllExport int
944win32_setmode(int fd, int mode)
945{
946 if(mode != O_BINARY)
947 {
948 Perl_croak(aTHX_ PL_no_func, "setmode");
949 return -1;
950 }
951 return 0;
952}
953
954DllExport long
955win32_lseek(int fd, long offset, int origin)
956{
957 return xcelseek(fd, offset, origin);
958}
959
960DllExport long
961win32_tell(int fd)
962{
963 return xcelseek(fd, 0, SEEK_CUR);
964}
965
966DllExport int
967win32_open(const char *path, int flag, ...)
968{
969 int pmode;
970 va_list ap;
971
972 va_start(ap, flag);
973 pmode = va_arg(ap, int);
974 va_end(ap);
975
976 return xceopen(path, flag, pmode);
977}
978
979DllExport int
980win32_close(int fd)
981{
982 return xceclose(fd);
983}
984
985DllExport int
986win32_eof(int fd)
987{
988 Perl_croak(aTHX_ PL_no_func, "eof");
989 return -1;
990}
991
992DllExport int
993win32_dup(int fd)
994{
995 Perl_croak(aTHX_ PL_no_func, "dup");
996 return -1;
997}
998
999DllExport int
1000win32_dup2(int fd1,int fd2)
1001{
1002 Perl_croak(aTHX_ PL_no_func, "dup2");
1003 return -1;
1004}
1005
1006DllExport int
1007win32_read(int fd, void *buf, unsigned int cnt)
1008{
1009 return xceread(fd, buf, cnt);
1010}
1011
1012DllExport int
1013win32_write(int fd, const void *buf, unsigned int cnt)
1014{
1015 return xcewrite(fd, (void *) buf, cnt);
1016}
1017
1018DllExport int
1019win32_mkdir(const char *dir, int mode)
1020{
1021 return xcemkdir(dir);
1022}
1023
1024DllExport int
1025win32_rmdir(const char *dir)
1026{
1027 return xcermdir(dir);
1028}
1029
1030DllExport int
1031win32_chdir(const char *dir)
1032{
1033 return xcechdir(dir);
1034}
1035
1036DllExport int
1037win32_access(const char *path, int mode)
1038{
1039 return xceaccess(path, mode);
1040}
1041
1042DllExport int
1043win32_chmod(const char *path, int mode)
1044{
1045 return xcechmod(path, mode);
1046}
1047
1048DllExport void
1049win32_perror(const char *str)
1050{
1051 xceperror(str);
1052}
1053
1054DllExport void
1055win32_setbuf(FILE *pf, char *buf)
1056{
1057 Perl_croak(aTHX_ PL_no_func, "setbuf");
1058}
1059
1060DllExport int
1061win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
1062{
1063 return setvbuf(pf, buf, type, size);
1064}
1065
1066DllExport int
1067win32_flushall(void)
1068{
1069 return flushall();
1070}
1071
1072DllExport int
1073win32_fcloseall(void)
1074{
1075 return fcloseall();
1076}
1077
1078DllExport char*
1079win32_fgets(char *s, int n, FILE *pf)
1080{
1081 return fgets(s, n, pf);
1082}
1083
1084DllExport char*
1085win32_gets(char *s)
1086{
1087 return gets(s);
1088}
1089
1090DllExport int
1091win32_fgetc(FILE *pf)
1092{
1093 return fgetc(pf);
1094}
1095
1096DllExport int
1097win32_putc(int c, FILE *pf)
1098{
1099 return putc(c,pf);
1100}
1101
1102DllExport int
1103win32_puts(const char *s)
1104{
1105 return puts(s);
1106}
1107
1108DllExport int
1109win32_getchar(void)
1110{
1111 return getchar();
1112}
1113
1114DllExport int
1115win32_putchar(int c)
1116{
1117 return putchar(c);
1118}
1119
1120#ifdef MYMALLOC
1121
1122#ifndef USE_PERL_SBRK
1123
1124static char *committed = NULL;
1125static char *base = NULL;
1126static char *reserved = NULL;
1127static char *brk = NULL;
1128static DWORD pagesize = 0;
1129static DWORD allocsize = 0;
1130
1131void *
1132sbrk(int need)
1133{
1134 void *result;
1135 if (!pagesize)
1136 {SYSTEM_INFO info;
1137 GetSystemInfo(&info);
1138 /* Pretend page size is larger so we don't perpetually
1139 * call the OS to commit just one page ...
1140 */
1141 pagesize = info.dwPageSize << 3;
1142 allocsize = info.dwAllocationGranularity;
1143 }
1144 /* This scheme fails eventually if request for contiguous
1145 * block is denied so reserve big blocks - this is only
1146 * address space not memory ...
1147 */
1148 if (brk+need >= reserved)
1149 {
1150 DWORD size = 64*1024*1024;
1151 char *addr;
1152 if (committed && reserved && committed < reserved)
1153 {
1154 /* Commit last of previous chunk cannot span allocations */
1155 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
1156 if (addr)
1157 committed = reserved;
1158 }
1159 /* Reserve some (more) space
1160 * Note this is a little sneaky, 1st call passes NULL as reserved
1161 * so lets system choose where we start, subsequent calls pass
1162 * the old end address so ask for a contiguous block
1163 */
1164 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
1165 if (addr)
1166 {
1167 reserved = addr+size;
1168 if (!base)
1169 base = addr;
1170 if (!committed)
1171 committed = base;
1172 if (!brk)
1173 brk = committed;
1174 }
1175 else
1176 {
1177 return (void *) -1;
1178 }
1179 }
1180 result = brk;
1181 brk += need;
1182 if (brk > committed)
1183 {
1184 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
1185 char *addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
1186 if (addr)
1187 {
1188 committed += size;
1189 }
1190 else
1191 return (void *) -1;
1192 }
1193 return result;
1194}
1195
1196#endif
1197#endif
1198
1199DllExport void*
1200win32_malloc(size_t size)
1201{
1202 return malloc(size);
1203}
1204
1205DllExport void*
1206win32_calloc(size_t numitems, size_t size)
1207{
1208 return calloc(numitems,size);
1209}
1210
1211DllExport void*
1212win32_realloc(void *block, size_t size)
1213{
1214 return realloc(block,size);
1215}
1216
1217DllExport void
1218win32_free(void *block)
1219{
1220 free(block);
1221}
1222
1223DllExport int
1224win32_execv(const char *cmdname, const char *const *argv)
1225{
1226 Perl_croak(aTHX_ PL_no_func, "execv");
1227 return -1;
1228}
1229
1230DllExport int
1231win32_execvp(const char *cmdname, const char *const *argv)
1232{
1233 Perl_croak(aTHX_ PL_no_func, "execvp");
1234 return -1;
1235}
1236
1237DllExport void*
1238win32_dynaload(const char* filename)
1239{
1240 dTHXo;
1241 HMODULE hModule;
1242
1243 hModule = XCELoadLibraryA(filename);
1244
1245 return hModule;
1246}
1247
1248// this is needed by Cwd.pm...
1249
1250static
1251XS(w32_GetCwd)
1252{
1253 dXSARGS;
1254 char buf[MAX_PATH];
1255 SV *sv = sv_newmortal();
1256
1257 xcegetcwd(buf, sizeof(buf));
1258
1259 sv_setpv(sv, xcestrdup(buf));
1260 EXTEND(SP,1);
1261 SvPOK_on(sv);
1262 ST(0) = sv;
1263 XSRETURN(1);
1264}
1265
1266static
1267XS(w32_SetCwd)
1268{
1269 dXSARGS;
1270
1271 if (items != 1)
1272 Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)");
1273
1274 if (!xcechdir(SvPV_nolen(ST(0))))
1275 XSRETURN_YES;
1276
1277 XSRETURN_NO;
1278}
1279
1280static
1281XS(w32_GetTickCount)
1282{
1283 dXSARGS;
1284 DWORD msec = GetTickCount();
1285 EXTEND(SP,1);
1286 if ((IV)msec > 0)
1287 XSRETURN_IV(msec);
1288 XSRETURN_NV(msec);
1289}
1290
1291static
1292XS(w32_GetOSVersion)
1293{
1294 dXSARGS;
1295 OSVERSIONINFOA osver;
1296
1297 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
1298 if (!XCEGetVersionExA(&osver)) {
1299 XSRETURN_EMPTY;
1300 }
1301 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
1302 XPUSHs(newSViv(osver.dwMajorVersion));
1303 XPUSHs(newSViv(osver.dwMinorVersion));
1304 XPUSHs(newSViv(osver.dwBuildNumber));
1305 // WINCE = 3
1306 XPUSHs(newSViv(osver.dwPlatformId));
1307 PUTBACK;
1308}
1309
1310static
1311XS(w32_IsWinNT)
1312{
1313 dXSARGS;
1314 EXTEND(SP,1);
1315 XSRETURN_IV(IsWinNT());
1316}
1317
1318static
1319XS(w32_IsWin95)
1320{
1321 dXSARGS;
1322 EXTEND(SP,1);
1323 XSRETURN_IV(IsWin95());
1324}
1325
1326static
1327XS(w32_IsWinCE)
1328{
1329 dXSARGS;
1330 EXTEND(SP,1);
1331 XSRETURN_IV(IsWinCE());
1332}
1333
1334static
1335XS(w32_GetOemInfo)
1336{
1337 dXSARGS;
1338 wchar_t wbuf[126];
1339 char buf[126];
1340
1341 if(SystemParametersInfoW(SPI_GETOEMINFO, sizeof(wbuf), wbuf, FALSE))
1342 WideCharToMultiByte(CP_ACP, 0, wbuf, -1, buf, sizeof(buf), 0, 0);
1343 else
1344 sprintf(buf, "SystemParametersInfo failed: %d", GetLastError());
1345
1346 EXTEND(SP,1);
1347 XSRETURN_PV(buf);
1348}
1349
1350static
1351XS(w32_Sleep)
1352{
1353 dXSARGS;
1354 if (items != 1)
1355 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
1356 Sleep(SvIV(ST(0)));
1357 XSRETURN_YES;
1358}
1359
1360static
1361XS(w32_CopyFile)
1362{
1363 dXSARGS;
1364 BOOL bResult;
1365 if (items != 3)
1366 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
1367
1368 {
1369 char szSourceFile[MAX_PATH+1];
1370 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
1371 bResult = XCECopyFileA(szSourceFile, SvPV_nolen(ST(1)),
1372 !SvTRUE(ST(2)));
1373 }
1374
1375 if (bResult)
1376 XSRETURN_YES;
1377
1378 XSRETURN_NO;
1379}
1380
1381static
1382XS(w32_MessageBox)
1383{
1384 dXSARGS;
1385
1386 char *txt;
1387 unsigned int res;
1388 unsigned int flags = MB_OK;
1389
1390 txt = SvPV_nolen(ST(0));
1391
1392 if (items < 1 || items > 2)
1393 Perl_croak(aTHX_ "usage: Win32::MessageBox($txt, [$flags])");
1394
1395 if(items == 2)
1396 flags = SvIV(ST(1));
1397
1398 res = XCEMessageBoxA(NULL, txt, "Perl", flags);
1399
1400 XSRETURN_IV(res);
1401}
1402
1403static
1404XS(w32_GetPowerStatus)
1405{
1406 dXSARGS;
1407
1408 SYSTEM_POWER_STATUS_EX sps;
1409
1410 if(GetSystemPowerStatusEx(&sps, TRUE) == FALSE)
1411 {
1412 XSRETURN_EMPTY;
1413 }
1414
1415 XPUSHs(newSViv(sps.ACLineStatus));
1416 XPUSHs(newSViv(sps.BatteryFlag));
1417 XPUSHs(newSViv(sps.BatteryLifePercent));
1418 XPUSHs(newSViv(sps.BatteryLifeTime));
1419 XPUSHs(newSViv(sps.BatteryFullLifeTime));
1420 XPUSHs(newSViv(sps.BackupBatteryFlag));
1421 XPUSHs(newSViv(sps.BackupBatteryLifePercent));
1422 XPUSHs(newSViv(sps.BackupBatteryLifeTime));
1423 XPUSHs(newSViv(sps.BackupBatteryFullLifeTime));
1424
1425 PUTBACK;
1426}
1427
1428#if UNDER_CE > 200
1429static
1430XS(w32_ShellEx)
1431{
1432 dXSARGS;
1433
1434 char buf[126];
1435 SHELLEXECUTEINFO si;
1436 char *file, *verb;
1437 wchar_t wfile[MAX_PATH];
1438 wchar_t wverb[20];
1439
1440 if (items != 2)
1441 Perl_croak(aTHX_ "usage: Win32::ShellEx($file, $verb)");
1442
1443 file = SvPV_nolen(ST(0));
1444 verb = SvPV_nolen(ST(1));
1445
1446 memset(&si, 0, sizeof(si));
1447 si.cbSize = sizeof(si);
1448 si.fMask = SEE_MASK_FLAG_NO_UI;
1449
1450 MultiByteToWideChar(CP_ACP, 0, verb, -1,
1451 wverb, sizeof(wverb)/2);
1452 si.lpVerb = (TCHAR *)wverb;
1453
1454 MultiByteToWideChar(CP_ACP, 0, file, -1,
1455 wfile, sizeof(wfile)/2);
1456 si.lpFile = (TCHAR *)wfile;
1457
1458 if(ShellExecuteEx(&si) == FALSE)
1459 {
1460 XSRETURN_NO;
1461 }
1462 XSRETURN_YES;
1463}
1464#endif
1465
1466void
1467Perl_init_os_extras(void)
1468{
1469 dTHXo;
1470 char *file = __FILE__;
1471 dXSUB_SYS;
1472
1473 w32_perlshell_tokens = Nullch;
1474 w32_perlshell_items = -1;
1475 w32_fdpid = newAV(); /* XX needs to be in Perl_win32_init()? */
1476 New(1313, w32_children, 1, child_tab);
1477 w32_num_children = 0;
1478
1479 newXS("Win32::GetCwd", w32_GetCwd, file);
1480 newXS("Win32::SetCwd", w32_SetCwd, file);
1481 newXS("Win32::GetTickCount", w32_GetTickCount, file);
1482 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
1483#if UNDER_CE > 200
1484 newXS("Win32::ShellEx", w32_ShellEx, file);
1485#endif
1486 newXS("Win32::IsWinNT", w32_IsWinNT, file);
1487 newXS("Win32::IsWin95", w32_IsWin95, file);
1488 newXS("Win32::IsWinCE", w32_IsWinCE, file);
1489 newXS("Win32::CopyFile", w32_CopyFile, file);
1490 newXS("Win32::Sleep", w32_Sleep, file);
1491 newXS("Win32::MessageBox", w32_MessageBox, file);
1492 newXS("Win32::GetPowerStatus", w32_GetPowerStatus, file);
1493 newXS("Win32::GetOemInfo", w32_GetOemInfo, file);
1494}
1495
1496void
1497myexit(void)
1498{
1499 char buf[126];
1500
1501 puts("Hit return");
1502 fgets(buf, sizeof(buf), stdin);
1503}
1504
1505void
1506Perl_win32_init(int *argcp, char ***argvp)
1507{
1508#ifdef UNDER_CE
1509 char *p;
1510
1511 if((p = xcegetenv("PERLDEBUG")) && (p[0] == 'y' || p[0] == 'Y'))
1512 atexit(myexit);
1513#endif
1514
1515 MALLOC_INIT;
1516}
1517
1518DllExport int
1519win32_flock(int fd, int oper)
1520{
1521 Perl_croak(aTHX_ PL_no_func, "flock");
1522 return -1;
1523}
1524
1525DllExport int
1526win32_waitpid(int pid, int *status, int flags)
1527{
1528 Perl_croak(aTHX_ PL_no_func, "waitpid");
1529 return -1;
1530}
1531
1532DllExport int
1533win32_wait(int *status)
1534{
1535 Perl_croak(aTHX_ PL_no_func, "wait");
1536 return -1;
1537}
1538
1539int
1540do_spawn(char *cmd)
1541{
1542 return xcesystem(cmd);
1543}
1544
1545int
1546do_aspawn(void *vreally, void **vmark, void **vsp)
1547{
1548 Perl_croak(aTHX_ PL_no_func, "aspawn");
1549 return -1;
1550}
1551
1552int
1553wce_reopen_stdout(char *fname)
1554{
1555 if(xcefreopen(fname, "w", stdout) == NULL)
1556 return -1;
1557
1558 return 0;
1559}
1560
1561void
1562wce_hitreturn()
1563{
1564 char buf[126];
1565
1566 printf("Hit RETURN");
1567 fflush(stdout);
1568 fgets(buf, sizeof(buf), stdin);
1569 return;
1570}
1571
1572//////////////////////////////////////////////////////////////////////
1573
1574#ifdef PERL_OBJECT
1575# undef this
1576# define this pPerl
1577#endif
1578
1579void
1580win32_argv2utf8(int argc, char** argv)
1581{
1582 // do nothing...
1583}
1584
1585void
1586Perl_sys_intern_init(pTHX)
1587{
1588 w32_perlshell_tokens = Nullch;
1589 w32_perlshell_vec = (char**)NULL;
1590 w32_perlshell_items = 0;
1591 w32_fdpid = newAV();
1592 New(1313, w32_children, 1, child_tab);
1593 w32_num_children = 0;
1594# ifdef USE_ITHREADS
1595 w32_pseudo_id = 0;
1596 New(1313, w32_pseudo_children, 1, child_tab);
1597 w32_num_pseudo_children = 0;
1598# endif
1599
1600#ifndef UNDER_CE
1601 w32_init_socktype = 0;
1602#endif
1603}
1604
1605void
1606Perl_sys_intern_clear(pTHX)
1607{
1608 Safefree(w32_perlshell_tokens);
1609 Safefree(w32_perlshell_vec);
1610 /* NOTE: w32_fdpid is freed by sv_clean_all() */
1611 Safefree(w32_children);
1612# ifdef USE_ITHREADS
1613 Safefree(w32_pseudo_children);
1614# endif
1615}
1616