source: trunk/essentials/dev-lang/perl/win32/win32.c@ 3299

Last change on this file since 3299 was 3181, checked in by bird, 19 years ago

perl 5.8.8
File size: 122.3 KB
Line 
1/* WIN32.C
2 *
3 * (c) 1995 Microsoft Corporation. All rights reserved.
4 * Developed by hip communications inc., http://info.hip.com/info/
5 * Portions (c) 1993 Intergraph Corporation. All rights reserved.
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 */
10#define PERLIO_NOT_STDIO 0
11#define WIN32_LEAN_AND_MEAN
12#define WIN32IO_IS_STDIO
13#include <tchar.h>
14#ifdef __GNUC__
15#define Win32_Winsock
16#endif
17#include <windows.h>
18/* GCC-2.95.2/Mingw32-1.1 forgot the WINAPI on CommandLineToArgvW() */
19#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
20# include <shellapi.h>
21#else
22 LPWSTR* WINAPI CommandLineToArgvW(LPCWSTR lpCommandLine, int * pNumArgs);
23#endif
24#include <winnt.h>
25#include <io.h>
26#include <signal.h>
27
28/* #include "config.h" */
29
30#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
31#define PerlIO FILE
32#endif
33
34#include <sys/stat.h>
35#include "EXTERN.h"
36#include "perl.h"
37
38#define NO_XSLOCKS
39#define PERL_NO_GET_CONTEXT
40#include "XSUB.h"
41
42#include "Win32iop.h"
43#include <fcntl.h>
44#ifndef __GNUC__
45/* assert.h conflicts with #define of assert in perl.h */
46#include <assert.h>
47#endif
48#include <string.h>
49#include <stdarg.h>
50#include <float.h>
51#include <time.h>
52#if defined(_MSC_VER) || defined(__MINGW32__)
53#include <sys/utime.h>
54#else
55#include <utime.h>
56#endif
57#ifdef __GNUC__
58/* Mingw32 defaults to globing command line
59 * So we turn it off like this:
60 */
61int _CRT_glob = 0;
62#endif
63
64#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1)
65/* Mingw32-1.1 is missing some prototypes */
66FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode);
67FILE * _wfdopen(int nFd, LPCWSTR wszMode);
68FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream);
69int _flushall();
70int _fcloseall();
71#endif
72
73#if defined(__BORLANDC__)
74# define _stat stat
75# define _utimbuf utimbuf
76#endif
77
78#define EXECF_EXEC 1
79#define EXECF_SPAWN 2
80#define EXECF_SPAWN_NOWAIT 3
81
82#if defined(PERL_IMPLICIT_SYS)
83# undef win32_get_privlib
84# define win32_get_privlib g_win32_get_privlib
85# undef win32_get_sitelib
86# define win32_get_sitelib g_win32_get_sitelib
87# undef win32_get_vendorlib
88# define win32_get_vendorlib g_win32_get_vendorlib
89# undef getlogin
90# define getlogin g_getlogin
91#endif
92
93static void get_shell(void);
94static long tokenize(const char *str, char **dest, char ***destv);
95static int do_spawn2(pTHX_ char *cmd, int exectype);
96static BOOL has_shell_metachars(char *ptr);
97static long filetime_to_clock(PFILETIME ft);
98static BOOL filetime_from_time(PFILETIME ft, time_t t);
99static char * get_emd_part(SV **leading, char *trailing, ...);
100static void remove_dead_process(long deceased);
101static long find_pid(int pid);
102static char * qualified_path(const char *cmd);
103static char * win32_get_xlib(const char *pl, const char *xlib,
104 const char *libname);
105
106#ifdef USE_ITHREADS
107static void remove_dead_pseudo_process(long child);
108static long find_pseudo_pid(int pid);
109#endif
110
111START_EXTERN_C
112HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE;
113char w32_module_name[MAX_PATH+1];
114END_EXTERN_C
115
116static DWORD w32_platform = (DWORD)-1;
117
118#define ONE_K_BUFSIZE 1024
119
120#ifdef __BORLANDC__
121/* Silence STDERR grumblings from Borland's math library. */
122DllExport int
123_matherr(struct _exception *a)
124{
125 PERL_UNUSED_VAR(a);
126 return 1;
127}
128#endif
129
130int
131IsWin95(void)
132{
133 return (win32_os_id() == VER_PLATFORM_WIN32_WINDOWS);
134}
135
136int
137IsWinNT(void)
138{
139 return (win32_os_id() == VER_PLATFORM_WIN32_NT);
140}
141
142EXTERN_C void
143set_w32_module_name(void)
144{
145 char* ptr;
146 GetModuleFileName((HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE)
147 ? GetModuleHandle(NULL)
148 : w32_perldll_handle),
149 w32_module_name, sizeof(w32_module_name));
150
151 /* remove \\?\ prefix */
152 if (memcmp(w32_module_name, "\\\\?\\", 4) == 0)
153 memmove(w32_module_name, w32_module_name+4, strlen(w32_module_name+4)+1);
154
155 /* try to get full path to binary (which may be mangled when perl is
156 * run from a 16-bit app) */
157 /*PerlIO_printf(Perl_debug_log, "Before %s\n", w32_module_name);*/
158 (void)win32_longpath(w32_module_name);
159 /*PerlIO_printf(Perl_debug_log, "After %s\n", w32_module_name);*/
160
161 /* normalize to forward slashes */
162 ptr = w32_module_name;
163 while (*ptr) {
164 if (*ptr == '\\')
165 *ptr = '/';
166 ++ptr;
167 }
168}
169
170/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
171static char*
172get_regstr_from(HKEY hkey, const char *valuename, SV **svp)
173{
174 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */
175 HKEY handle;
176 DWORD type;
177 const char *subkey = "Software\\Perl";
178 char *str = Nullch;
179 long retval;
180
181 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle);
182 if (retval == ERROR_SUCCESS) {
183 DWORD datalen;
184 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen);
185 if (retval == ERROR_SUCCESS
186 && (type == REG_SZ || type == REG_EXPAND_SZ))
187 {
188 dTHX;
189 if (!*svp)
190 *svp = sv_2mortal(newSVpvn("",0));
191 SvGROW(*svp, datalen);
192 retval = RegQueryValueEx(handle, valuename, 0, NULL,
193 (PBYTE)SvPVX(*svp), &datalen);
194 if (retval == ERROR_SUCCESS) {
195 str = SvPVX(*svp);
196 SvCUR_set(*svp,datalen-1);
197 }
198 }
199 RegCloseKey(handle);
200 }
201 return str;
202}
203
204/* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */
205static char*
206get_regstr(const char *valuename, SV **svp)
207{
208 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp);
209 if (!str)
210 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp);
211 return str;
212}
213
214/* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */
215static char *
216get_emd_part(SV **prev_pathp, char *trailing_path, ...)
217{
218 char base[10];
219 va_list ap;
220 char mod_name[MAX_PATH+1];
221 char *ptr;
222 char *optr;
223 char *strip;
224 STRLEN baselen;
225
226 va_start(ap, trailing_path);
227 strip = va_arg(ap, char *);
228
229 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION);
230 baselen = strlen(base);
231
232 if (!*w32_module_name) {
233 set_w32_module_name();
234 }
235 strcpy(mod_name, w32_module_name);
236 ptr = strrchr(mod_name, '/');
237 while (ptr && strip) {
238 /* look for directories to skip back */
239 optr = ptr;
240 *ptr = '\0';
241 ptr = strrchr(mod_name, '/');
242 /* avoid stripping component if there is no slash,
243 * or it doesn't match ... */
244 if (!ptr || stricmp(ptr+1, strip) != 0) {
245 /* ... but not if component matches m|5\.$patchlevel.*| */
246 if (!ptr || !(*strip == '5' && *(ptr+1) == '5'
247 && strncmp(strip, base, baselen) == 0
248 && strncmp(ptr+1, base, baselen) == 0))
249 {
250 *optr = '/';
251 ptr = optr;
252 }
253 }
254 strip = va_arg(ap, char *);
255 }
256 if (!ptr) {
257 ptr = mod_name;
258 *ptr++ = '.';
259 *ptr = '/';
260 }
261 va_end(ap);
262 strcpy(++ptr, trailing_path);
263
264 /* only add directory if it exists */
265 if (GetFileAttributes(mod_name) != (DWORD) -1) {
266 /* directory exists */
267 dTHX;
268 if (!*prev_pathp)
269 *prev_pathp = sv_2mortal(newSVpvn("",0));
270 else if (SvPVX(*prev_pathp))
271 sv_catpvn(*prev_pathp, ";", 1);
272 sv_catpv(*prev_pathp, mod_name);
273 return SvPVX(*prev_pathp);
274 }
275
276 return Nullch;
277}
278
279char *
280win32_get_privlib(const char *pl)
281{
282 dTHX;
283 char *stdlib = "lib";
284 char buffer[MAX_PATH+1];
285 SV *sv = Nullsv;
286
287 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */
288 sprintf(buffer, "%s-%s", stdlib, pl);
289 if (!get_regstr(buffer, &sv))
290 (void)get_regstr(stdlib, &sv);
291
292 /* $stdlib .= ";$EMD/../../lib" */
293 return get_emd_part(&sv, stdlib, ARCHNAME, "bin", Nullch);
294}
295
296static char *
297win32_get_xlib(const char *pl, const char *xlib, const char *libname)
298{
299 dTHX;
300 char regstr[40];
301 char pathstr[MAX_PATH+1];
302 SV *sv1 = Nullsv;
303 SV *sv2 = Nullsv;
304
305 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */
306 sprintf(regstr, "%s-%s", xlib, pl);
307 (void)get_regstr(regstr, &sv1);
308
309 /* $xlib .=
310 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */
311 sprintf(pathstr, "%s/%s/lib", libname, pl);
312 (void)get_emd_part(&sv1, pathstr, ARCHNAME, "bin", pl, Nullch);
313
314 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */
315 (void)get_regstr(xlib, &sv2);
316
317 /* $xlib .=
318 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */
319 sprintf(pathstr, "%s/lib", libname);
320 (void)get_emd_part(&sv2, pathstr, ARCHNAME, "bin", pl, Nullch);
321
322 if (!sv1 && !sv2)
323 return Nullch;
324 if (!sv1)
325 return SvPVX(sv2);
326 if (!sv2)
327 return SvPVX(sv1);
328
329 sv_catpvn(sv1, ";", 1);
330 sv_catsv(sv1, sv2);
331
332 return SvPVX(sv1);
333}
334
335char *
336win32_get_sitelib(const char *pl)
337{
338 return win32_get_xlib(pl, "sitelib", "site");
339}
340
341#ifndef PERL_VENDORLIB_NAME
342# define PERL_VENDORLIB_NAME "vendor"
343#endif
344
345char *
346win32_get_vendorlib(const char *pl)
347{
348 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME);
349}
350
351static BOOL
352has_shell_metachars(char *ptr)
353{
354 int inquote = 0;
355 char quote = '\0';
356
357 /*
358 * Scan string looking for redirection (< or >) or pipe
359 * characters (|) that are not in a quoted string.
360 * Shell variable interpolation (%VAR%) can also happen inside strings.
361 */
362 while (*ptr) {
363 switch(*ptr) {
364 case '%':
365 return TRUE;
366 case '\'':
367 case '\"':
368 if (inquote) {
369 if (quote == *ptr) {
370 inquote = 0;
371 quote = '\0';
372 }
373 }
374 else {
375 quote = *ptr;
376 inquote++;
377 }
378 break;
379 case '>':
380 case '<':
381 case '|':
382 if (!inquote)
383 return TRUE;
384 default:
385 break;
386 }
387 ++ptr;
388 }
389 return FALSE;
390}
391
392#if !defined(PERL_IMPLICIT_SYS)
393/* since the current process environment is being updated in util.c
394 * the library functions will get the correct environment
395 */
396PerlIO *
397Perl_my_popen(pTHX_ char *cmd, char *mode)
398{
399#ifdef FIXCMD
400#define fixcmd(x) { \
401 char *pspace = strchr((x),' '); \
402 if (pspace) { \
403 char *p = (x); \
404 while (p < pspace) { \
405 if (*p == '/') \
406 *p = '\\'; \
407 p++; \
408 } \
409 } \
410 }
411#else
412#define fixcmd(x)
413#endif
414 fixcmd(cmd);
415 PERL_FLUSHALL_FOR_CHILD;
416 return win32_popen(cmd, mode);
417}
418
419long
420Perl_my_pclose(pTHX_ PerlIO *fp)
421{
422 return win32_pclose(fp);
423}
424#endif
425
426DllExport unsigned long
427win32_os_id(void)
428{
429 static OSVERSIONINFO osver;
430
431 if (osver.dwPlatformId != w32_platform) {
432 memset(&osver, 0, sizeof(OSVERSIONINFO));
433 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
434 GetVersionEx(&osver);
435 w32_platform = osver.dwPlatformId;
436 }
437 return (unsigned long)w32_platform;
438}
439
440DllExport int
441win32_getpid(void)
442{
443 int pid;
444#ifdef USE_ITHREADS
445 dTHX;
446 if (w32_pseudo_id)
447 return -((int)w32_pseudo_id);
448#endif
449 pid = _getpid();
450 /* Windows 9x appears to always reports a pid for threads and processes
451 * that has the high bit set. So we treat the lower 31 bits as the
452 * "real" PID for Perl's purposes. */
453 if (IsWin95() && pid < 0)
454 pid = -pid;
455 return pid;
456}
457
458/* Tokenize a string. Words are null-separated, and the list
459 * ends with a doubled null. Any character (except null and
460 * including backslash) may be escaped by preceding it with a
461 * backslash (the backslash will be stripped).
462 * Returns number of words in result buffer.
463 */
464static long
465tokenize(const char *str, char **dest, char ***destv)
466{
467 char *retstart = Nullch;
468 char **retvstart = 0;
469 int items = -1;
470 if (str) {
471 dTHX;
472 int slen = strlen(str);
473 register char *ret;
474 register char **retv;
475 Newx(ret, slen+2, char);
476 Newx(retv, (slen+3)/2, char*);
477
478 retstart = ret;
479 retvstart = retv;
480 *retv = ret;
481 items = 0;
482 while (*str) {
483 *ret = *str++;
484 if (*ret == '\\' && *str)
485 *ret = *str++;
486 else if (*ret == ' ') {
487 while (*str == ' ')
488 str++;
489 if (ret == retstart)
490 ret--;
491 else {
492 *ret = '\0';
493 ++items;
494 if (*str)
495 *++retv = ret+1;
496 }
497 }
498 else if (!*str)
499 ++items;
500 ret++;
501 }
502 retvstart[items] = Nullch;
503 *ret++ = '\0';
504 *ret = '\0';
505 }
506 *dest = retstart;
507 *destv = retvstart;
508 return items;
509}
510
511static void
512get_shell(void)
513{
514 dTHX;
515 if (!w32_perlshell_tokens) {
516 /* we don't use COMSPEC here for two reasons:
517 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
518 * uncontrolled unportability of the ensuing scripts.
519 * 2. PERL5SHELL could be set to a shell that may not be fit for
520 * interactive use (which is what most programs look in COMSPEC
521 * for).
522 */
523 const char* defaultshell = (IsWinNT()
524 ? "cmd.exe /x/d/c" : "command.com /c");
525 const char *usershell = PerlEnv_getenv("PERL5SHELL");
526 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell,
527 &w32_perlshell_tokens,
528 &w32_perlshell_vec);
529 }
530}
531
532int
533Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
534{
535 char **argv;
536 char *str;
537 int status;
538 int flag = P_WAIT;
539 int index = 0;
540
541 if (sp <= mark)
542 return -1;
543
544 get_shell();
545 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*);
546
547 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
548 ++mark;
549 flag = SvIVx(*mark);
550 }
551
552 while (++mark <= sp) {
553 if (*mark && (str = SvPV_nolen(*mark)))
554 argv[index++] = str;
555 else
556 argv[index++] = "";
557 }
558 argv[index++] = 0;
559
560 status = win32_spawnvp(flag,
561 (const char*)(really ? SvPV_nolen(really) : argv[0]),
562 (const char* const*)argv);
563
564 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) {
565 /* possible shell-builtin, invoke with shell */
566 int sh_items;
567 sh_items = w32_perlshell_items;
568 while (--index >= 0)
569 argv[index+sh_items] = argv[index];
570 while (--sh_items >= 0)
571 argv[sh_items] = w32_perlshell_vec[sh_items];
572
573 status = win32_spawnvp(flag,
574 (const char*)(really ? SvPV_nolen(really) : argv[0]),
575 (const char* const*)argv);
576 }
577
578 if (flag == P_NOWAIT) {
579 if (IsWin95())
580 PL_statusvalue = -1; /* >16bits hint for pp_system() */
581 }
582 else {
583 if (status < 0) {
584 if (ckWARN(WARN_EXEC))
585 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno));
586 status = 255 * 256;
587 }
588 else
589 status *= 256;
590 PL_statusvalue = status;
591 }
592 Safefree(argv);
593 return (status);
594}
595
596/* returns pointer to the next unquoted space or the end of the string */
597static char*
598find_next_space(const char *s)
599{
600 bool in_quotes = FALSE;
601 while (*s) {
602 /* ignore doubled backslashes, or backslash+quote */
603 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
604 s += 2;
605 }
606 /* keep track of when we're within quotes */
607 else if (*s == '"') {
608 s++;
609 in_quotes = !in_quotes;
610 }
611 /* break it up only at spaces that aren't in quotes */
612 else if (!in_quotes && isSPACE(*s))
613 return (char*)s;
614 else
615 s++;
616 }
617 return (char*)s;
618}
619
620static int
621do_spawn2(pTHX_ char *cmd, int exectype)
622{
623 char **a;
624 char *s;
625 char **argv;
626 int status = -1;
627 BOOL needToTry = TRUE;
628 char *cmd2;
629
630 /* Save an extra exec if possible. See if there are shell
631 * metacharacters in it */
632 if (!has_shell_metachars(cmd)) {
633 Newx(argv, strlen(cmd) / 2 + 2, char*);
634 Newx(cmd2, strlen(cmd) + 1, char);
635 strcpy(cmd2, cmd);
636 a = argv;
637 for (s = cmd2; *s;) {
638 while (*s && isSPACE(*s))
639 s++;
640 if (*s)
641 *(a++) = s;
642 s = find_next_space(s);
643 if (*s)
644 *s++ = '\0';
645 }
646 *a = Nullch;
647 if (argv[0]) {
648 switch (exectype) {
649 case EXECF_SPAWN:
650 status = win32_spawnvp(P_WAIT, argv[0],
651 (const char* const*)argv);
652 break;
653 case EXECF_SPAWN_NOWAIT:
654 status = win32_spawnvp(P_NOWAIT, argv[0],
655 (const char* const*)argv);
656 break;
657 case EXECF_EXEC:
658 status = win32_execvp(argv[0], (const char* const*)argv);
659 break;
660 }
661 if (status != -1 || errno == 0)
662 needToTry = FALSE;
663 }
664 Safefree(argv);
665 Safefree(cmd2);
666 }
667 if (needToTry) {
668 char **argv;
669 int i = -1;
670 get_shell();
671 Newx(argv, w32_perlshell_items + 2, char*);
672 while (++i < w32_perlshell_items)
673 argv[i] = w32_perlshell_vec[i];
674 argv[i++] = cmd;
675 argv[i] = Nullch;
676 switch (exectype) {
677 case EXECF_SPAWN:
678 status = win32_spawnvp(P_WAIT, argv[0],
679 (const char* const*)argv);
680 break;
681 case EXECF_SPAWN_NOWAIT:
682 status = win32_spawnvp(P_NOWAIT, argv[0],
683 (const char* const*)argv);
684 break;
685 case EXECF_EXEC:
686 status = win32_execvp(argv[0], (const char* const*)argv);
687 break;
688 }
689 cmd = argv[0];
690 Safefree(argv);
691 }
692 if (exectype == EXECF_SPAWN_NOWAIT) {
693 if (IsWin95())
694 PL_statusvalue = -1; /* >16bits hint for pp_system() */
695 }
696 else {
697 if (status < 0) {
698 if (ckWARN(WARN_EXEC))
699 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
700 (exectype == EXECF_EXEC ? "exec" : "spawn"),
701 cmd, strerror(errno));
702 status = 255 * 256;
703 }
704 else
705 status *= 256;
706 PL_statusvalue = status;
707 }
708 return (status);
709}
710
711int
712Perl_do_spawn(pTHX_ char *cmd)
713{
714 return do_spawn2(aTHX_ cmd, EXECF_SPAWN);
715}
716
717int
718Perl_do_spawn_nowait(pTHX_ char *cmd)
719{
720 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT);
721}
722
723bool
724Perl_do_exec(pTHX_ char *cmd)
725{
726 do_spawn2(aTHX_ cmd, EXECF_EXEC);
727 return FALSE;
728}
729
730/* The idea here is to read all the directory names into a string table
731 * (separated by nulls) and when one of the other dir functions is called
732 * return the pointer to the current file name.
733 */
734DllExport DIR *
735win32_opendir(char *filename)
736{
737 dTHX;
738 DIR *dirp;
739 long len;
740 long idx;
741 char scanname[MAX_PATH+3];
742 Stat_t sbuf;
743 WIN32_FIND_DATAA aFindData;
744 WIN32_FIND_DATAW wFindData;
745 HANDLE fh;
746 char buffer[MAX_PATH*2];
747 WCHAR wbuffer[MAX_PATH+1];
748 char* ptr;
749
750 len = strlen(filename);
751 if (len > MAX_PATH)
752 return NULL;
753
754 /* check to see if filename is a directory */
755 if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode))
756 return NULL;
757
758 /* Get us a DIR structure */
759 Newxz(dirp, 1, DIR);
760
761 /* Create the search pattern */
762 strcpy(scanname, filename);
763
764 /* bare drive name means look in cwd for drive */
765 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') {
766 scanname[len++] = '.';
767 scanname[len++] = '/';
768 }
769 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') {
770 scanname[len++] = '/';
771 }
772 scanname[len++] = '*';
773 scanname[len] = '\0';
774
775 /* do the FindFirstFile call */
776 if (USING_WIDE()) {
777 A2WHELPER(scanname, wbuffer, sizeof(wbuffer));
778 fh = FindFirstFileW(PerlDir_mapW(wbuffer), &wFindData);
779 }
780 else {
781 fh = FindFirstFileA(PerlDir_mapA(scanname), &aFindData);
782 }
783 dirp->handle = fh;
784 if (fh == INVALID_HANDLE_VALUE) {
785 DWORD err = GetLastError();
786 /* FindFirstFile() fails on empty drives! */
787 switch (err) {
788 case ERROR_FILE_NOT_FOUND:
789 return dirp;
790 case ERROR_NO_MORE_FILES:
791 case ERROR_PATH_NOT_FOUND:
792 errno = ENOENT;
793 break;
794 case ERROR_NOT_ENOUGH_MEMORY:
795 errno = ENOMEM;
796 break;
797 default:
798 errno = EINVAL;
799 break;
800 }
801 Safefree(dirp);
802 return NULL;
803 }
804
805 /* now allocate the first part of the string table for
806 * the filenames that we find.
807 */
808 if (USING_WIDE()) {
809 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
810 ptr = buffer;
811 }
812 else {
813 ptr = aFindData.cFileName;
814 }
815 idx = strlen(ptr)+1;
816 if (idx < 256)
817 dirp->size = 128;
818 else
819 dirp->size = idx;
820 Newx(dirp->start, dirp->size, char);
821 strcpy(dirp->start, ptr);
822 dirp->nfiles++;
823 dirp->end = dirp->curr = dirp->start;
824 dirp->end += idx;
825 return dirp;
826}
827
828
829/* Readdir just returns the current string pointer and bumps the
830 * string pointer to the nDllExport entry.
831 */
832DllExport struct direct *
833win32_readdir(DIR *dirp)
834{
835 long len;
836
837 if (dirp->curr) {
838 /* first set up the structure to return */
839 len = strlen(dirp->curr);
840 strcpy(dirp->dirstr.d_name, dirp->curr);
841 dirp->dirstr.d_namlen = len;
842
843 /* Fake an inode */
844 dirp->dirstr.d_ino = dirp->curr - dirp->start;
845
846 /* Now set up for the next call to readdir */
847 dirp->curr += len + 1;
848 if (dirp->curr >= dirp->end) {
849 dTHX;
850 char* ptr;
851 BOOL res;
852 WIN32_FIND_DATAW wFindData;
853 WIN32_FIND_DATAA aFindData;
854 char buffer[MAX_PATH*2];
855
856 /* finding the next file that matches the wildcard
857 * (which should be all of them in this directory!).
858 */
859 if (USING_WIDE()) {
860 res = FindNextFileW(dirp->handle, &wFindData);
861 if (res) {
862 W2AHELPER(wFindData.cFileName, buffer, sizeof(buffer));
863 ptr = buffer;
864 }
865 }
866 else {
867 res = FindNextFileA(dirp->handle, &aFindData);
868 if (res)
869 ptr = aFindData.cFileName;
870 }
871 if (res) {
872 long endpos = dirp->end - dirp->start;
873 long newsize = endpos + strlen(ptr) + 1;
874 /* bump the string table size by enough for the
875 * new name and its null terminator */
876 while (newsize > dirp->size) {
877 long curpos = dirp->curr - dirp->start;
878 dirp->size *= 2;
879 Renew(dirp->start, dirp->size, char);
880 dirp->curr = dirp->start + curpos;
881 }
882 strcpy(dirp->start + endpos, ptr);
883 dirp->end = dirp->start + newsize;
884 dirp->nfiles++;
885 }
886 else
887 dirp->curr = NULL;
888 }
889 return &(dirp->dirstr);
890 }
891 else
892 return NULL;
893}
894
895/* Telldir returns the current string pointer position */
896DllExport long
897win32_telldir(DIR *dirp)
898{
899 return (dirp->curr - dirp->start);
900}
901
902
903/* Seekdir moves the string pointer to a previously saved position
904 * (returned by telldir).
905 */
906DllExport void
907win32_seekdir(DIR *dirp, long loc)
908{
909 dirp->curr = dirp->start + loc;
910}
911
912/* Rewinddir resets the string pointer to the start */
913DllExport void
914win32_rewinddir(DIR *dirp)
915{
916 dirp->curr = dirp->start;
917}
918
919/* free the memory allocated by opendir */
920DllExport int
921win32_closedir(DIR *dirp)
922{
923 dTHX;
924 if (dirp->handle != INVALID_HANDLE_VALUE)
925 FindClose(dirp->handle);
926 Safefree(dirp->start);
927 Safefree(dirp);
928 return 1;
929}
930
931
932/*
933 * various stubs
934 */
935
936
937/* Ownership
938 *
939 * Just pretend that everyone is a superuser. NT will let us know if
940 * we don\'t really have permission to do something.
941 */
942
943#define ROOT_UID ((uid_t)0)
944#define ROOT_GID ((gid_t)0)
945
946uid_t
947getuid(void)
948{
949 return ROOT_UID;
950}
951
952uid_t
953geteuid(void)
954{
955 return ROOT_UID;
956}
957
958gid_t
959getgid(void)
960{
961 return ROOT_GID;
962}
963
964gid_t
965getegid(void)
966{
967 return ROOT_GID;
968}
969
970int
971setuid(uid_t auid)
972{
973 return (auid == ROOT_UID ? 0 : -1);
974}
975
976int
977setgid(gid_t agid)
978{
979 return (agid == ROOT_GID ? 0 : -1);
980}
981
982char *
983getlogin(void)
984{
985 dTHX;
986 char *buf = w32_getlogin_buffer;
987 DWORD size = sizeof(w32_getlogin_buffer);
988 if (GetUserName(buf,&size))
989 return buf;
990 return (char*)NULL;
991}
992
993int
994chown(const char *path, uid_t owner, gid_t group)
995{
996 /* XXX noop */
997 return 0;
998}
999
1000/*
1001 * XXX this needs strengthening (for PerlIO)
1002 * -- BKS, 11-11-200
1003*/
1004int mkstemp(const char *path)
1005{
1006 dTHX;
1007 char buf[MAX_PATH+1];
1008 int i = 0, fd = -1;
1009
1010retry:
1011 if (i++ > 10) { /* give up */
1012 errno = ENOENT;
1013 return -1;
1014 }
1015 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) {
1016 errno = ENOENT;
1017 return -1;
1018 }
1019 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600);
1020 if (fd == -1)
1021 goto retry;
1022 return fd;
1023}
1024
1025static long
1026find_pid(int pid)
1027{
1028 dTHX;
1029 long child = w32_num_children;
1030 while (--child >= 0) {
1031 if ((int)w32_child_pids[child] == pid)
1032 return child;
1033 }
1034 return -1;
1035}
1036
1037static void
1038remove_dead_process(long child)
1039{
1040 if (child >= 0) {
1041 dTHX;
1042 CloseHandle(w32_child_handles[child]);
1043 Move(&w32_child_handles[child+1], &w32_child_handles[child],
1044 (w32_num_children-child-1), HANDLE);
1045 Move(&w32_child_pids[child+1], &w32_child_pids[child],
1046 (w32_num_children-child-1), DWORD);
1047 w32_num_children--;
1048 }
1049}
1050
1051#ifdef USE_ITHREADS
1052static long
1053find_pseudo_pid(int pid)
1054{
1055 dTHX;
1056 long child = w32_num_pseudo_children;
1057 while (--child >= 0) {
1058 if ((int)w32_pseudo_child_pids[child] == pid)
1059 return child;
1060 }
1061 return -1;
1062}
1063
1064static void
1065remove_dead_pseudo_process(long child)
1066{
1067 if (child >= 0) {
1068 dTHX;
1069 CloseHandle(w32_pseudo_child_handles[child]);
1070 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child],
1071 (w32_num_pseudo_children-child-1), HANDLE);
1072 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child],
1073 (w32_num_pseudo_children-child-1), DWORD);
1074 w32_num_pseudo_children--;
1075 }
1076}
1077#endif
1078
1079DllExport int
1080win32_kill(int pid, int sig)
1081{
1082 dTHX;
1083 HANDLE hProcess;
1084 long child;
1085 int retval;
1086#ifdef USE_ITHREADS
1087 if (pid < 0) {
1088 /* it is a pseudo-forked child */
1089 child = find_pseudo_pid(-pid);
1090 if (child >= 0) {
1091 hProcess = w32_pseudo_child_handles[child];
1092 switch (sig) {
1093 case 0:
1094 /* "Does process exist?" use of kill */
1095 return 0;
1096 case 9:
1097 /* kill -9 style un-graceful exit */
1098 if (TerminateThread(hProcess, sig)) {
1099 remove_dead_pseudo_process(child);
1100 return 0;
1101 }
1102 break;
1103 default:
1104 /* We fake signals to pseudo-processes using Win32
1105 * message queue. In Win9X the pids are negative already. */
1106 if (PostThreadMessage(IsWin95() ? pid : -pid,WM_USER,sig,0)) {
1107 /* It might be us ... */
1108 PERL_ASYNC_CHECK();
1109 return 0;
1110 }
1111 break;
1112 }
1113 }
1114 else if (IsWin95()) {
1115 pid = -pid;
1116 goto alien_process;
1117 }
1118 }
1119 else
1120#endif
1121 {
1122 child = find_pid(pid);
1123 if (child >= 0) {
1124 hProcess = w32_child_handles[child];
1125 switch(sig) {
1126 case 0:
1127 /* "Does process exist?" use of kill */
1128 return 0;
1129 case 2:
1130 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1131 return 0;
1132 break;
1133 case SIGBREAK:
1134 case SIGTERM:
1135 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1136 return 0;
1137 break;
1138 default: /* For now be backwards compatible with perl5.6 */
1139 case 9:
1140 if (TerminateProcess(hProcess, sig)) {
1141 remove_dead_process(child);
1142 return 0;
1143 }
1144 break;
1145 }
1146 }
1147 else {
1148alien_process:
1149 retval = -1;
1150 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
1151 (IsWin95() ? -pid : pid));
1152 if (hProcess) {
1153 switch(sig) {
1154 case 0:
1155 /* "Does process exist?" use of kill */
1156 retval = 0;
1157 break;
1158 case 2:
1159 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT,pid))
1160 retval = 0;
1161 break;
1162 case SIGBREAK:
1163 case SIGTERM:
1164 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT,pid))
1165 retval = 0;
1166 break;
1167 default: /* For now be backwards compatible with perl5.6 */
1168 case 9:
1169 if (TerminateProcess(hProcess, sig))
1170 retval = 0;
1171 break;
1172 }
1173 }
1174 CloseHandle(hProcess);
1175 if (retval == 0)
1176 return 0;
1177 }
1178 }
1179 errno = EINVAL;
1180 return -1;
1181}
1182
1183DllExport int
1184win32_stat(const char *path, Stat_t *sbuf)
1185{
1186 dTHX;
1187 char buffer[MAX_PATH+1];
1188 int l = strlen(path);
1189 int res;
1190 WCHAR wbuffer[MAX_PATH+1];
1191 WCHAR* pwbuffer;
1192 HANDLE handle;
1193 int nlink = 1;
1194
1195 if (l > 1) {
1196 switch(path[l - 1]) {
1197 /* FindFirstFile() and stat() are buggy with a trailing
1198 * backslash, so change it to a forward slash :-( */
1199 case '\\':
1200 if (l >= sizeof(buffer)) {
1201 errno = ENAMETOOLONG;
1202 return -1;
1203 }
1204 strncpy(buffer, path, l-1);
1205 buffer[l - 1] = '/';
1206 buffer[l] = '\0';
1207 path = buffer;
1208 break;
1209 /* FindFirstFile() is buggy with "x:", so add a dot :-( */
1210 case ':':
1211 if (l == 2 && isALPHA(path[0])) {
1212 buffer[0] = path[0];
1213 buffer[1] = ':';
1214 buffer[2] = '.';
1215 buffer[3] = '\0';
1216 l = 3;
1217 path = buffer;
1218 }
1219 break;
1220 }
1221 }
1222
1223 /* We *must* open & close the file once; otherwise file attribute changes */
1224 /* might not yet have propagated to "other" hard links of the same file. */
1225 /* This also gives us an opportunity to determine the number of links. */
1226 if (USING_WIDE()) {
1227 A2WHELPER(path, wbuffer, sizeof(wbuffer));
1228 pwbuffer = PerlDir_mapW(wbuffer);
1229 handle = CreateFileW(pwbuffer, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1230 }
1231 else {
1232 path = PerlDir_mapA(path);
1233 l = strlen(path);
1234 handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL);
1235 }
1236 if (handle != INVALID_HANDLE_VALUE) {
1237 BY_HANDLE_FILE_INFORMATION bhi;
1238 if (GetFileInformationByHandle(handle, &bhi))
1239 nlink = bhi.nNumberOfLinks;
1240 CloseHandle(handle);
1241 }
1242
1243 /* pwbuffer or path will be mapped correctly above */
1244 if (USING_WIDE()) {
1245#if defined(WIN64) || defined(USE_LARGE_FILES)
1246 res = _wstati64(pwbuffer, sbuf);
1247#else
1248 res = _wstat(pwbuffer, (struct _stat*)sbuf);
1249#endif
1250 }
1251 else {
1252#if defined(WIN64) || defined(USE_LARGE_FILES)
1253 res = _stati64(path, sbuf);
1254#else
1255 res = stat(path, sbuf);
1256#endif
1257 }
1258 sbuf->st_nlink = nlink;
1259
1260 if (res < 0) {
1261 /* CRT is buggy on sharenames, so make sure it really isn't.
1262 * XXX using GetFileAttributesEx() will enable us to set
1263 * sbuf->st_*time (but note that's not available on the
1264 * Windows of 1995) */
1265 DWORD r;
1266 if (USING_WIDE()) {
1267 r = GetFileAttributesW(pwbuffer);
1268 }
1269 else {
1270 r = GetFileAttributesA(path);
1271 }
1272 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) {
1273 /* sbuf may still contain old garbage since stat() failed */
1274 Zero(sbuf, 1, Stat_t);
1275 sbuf->st_mode = S_IFDIR | S_IREAD;
1276 errno = 0;
1277 if (!(r & FILE_ATTRIBUTE_READONLY))
1278 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1279 return 0;
1280 }
1281 }
1282 else {
1283 if (l == 3 && isALPHA(path[0]) && path[1] == ':'
1284 && (path[2] == '\\' || path[2] == '/'))
1285 {
1286 /* The drive can be inaccessible, some _stat()s are buggy */
1287 if (USING_WIDE()
1288 ? !GetVolumeInformationW(pwbuffer,NULL,0,NULL,NULL,NULL,NULL,0)
1289 : !GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) {
1290 errno = ENOENT;
1291 return -1;
1292 }
1293 }
1294#ifdef __BORLANDC__
1295 if (S_ISDIR(sbuf->st_mode))
1296 sbuf->st_mode |= S_IWRITE | S_IEXEC;
1297 else if (S_ISREG(sbuf->st_mode)) {
1298 int perms;
1299 if (l >= 4 && path[l-4] == '.') {
1300 const char *e = path + l - 3;
1301 if (strnicmp(e,"exe",3)
1302 && strnicmp(e,"bat",3)
1303 && strnicmp(e,"com",3)
1304 && (IsWin95() || strnicmp(e,"cmd",3)))
1305 sbuf->st_mode &= ~S_IEXEC;
1306 else
1307 sbuf->st_mode |= S_IEXEC;
1308 }
1309 else
1310 sbuf->st_mode &= ~S_IEXEC;
1311 /* Propagate permissions to _group_ and _others_ */
1312 perms = sbuf->st_mode & (S_IREAD|S_IWRITE|S_IEXEC);
1313 sbuf->st_mode |= (perms>>3) | (perms>>6);
1314 }
1315#endif
1316 }
1317 return res;
1318}
1319
1320#define isSLASH(c) ((c) == '/' || (c) == '\\')
1321#define SKIP_SLASHES(s) \
1322 STMT_START { \
1323 while (*(s) && isSLASH(*(s))) \
1324 ++(s); \
1325 } STMT_END
1326#define COPY_NONSLASHES(d,s) \
1327 STMT_START { \
1328 while (*(s) && !isSLASH(*(s))) \
1329 *(d)++ = *(s)++; \
1330 } STMT_END
1331
1332/* Find the longname of a given path. path is destructively modified.
1333 * It should have space for at least MAX_PATH characters. */
1334DllExport char *
1335win32_longpath(char *path)
1336{
1337 WIN32_FIND_DATA fdata;
1338 HANDLE fhand;
1339 char tmpbuf[MAX_PATH+1];
1340 char *tmpstart = tmpbuf;
1341 char *start = path;
1342 char sep;
1343 if (!path)
1344 return Nullch;
1345
1346 /* drive prefix */
1347 if (isALPHA(path[0]) && path[1] == ':') {
1348 start = path + 2;
1349 *tmpstart++ = path[0];
1350 *tmpstart++ = ':';
1351 }
1352 /* UNC prefix */
1353 else if (isSLASH(path[0]) && isSLASH(path[1])) {
1354 start = path + 2;
1355 *tmpstart++ = path[0];
1356 *tmpstart++ = path[1];
1357 SKIP_SLASHES(start);
1358 COPY_NONSLASHES(tmpstart,start); /* copy machine name */
1359 if (*start) {
1360 *tmpstart++ = *start++;
1361 SKIP_SLASHES(start);
1362 COPY_NONSLASHES(tmpstart,start); /* copy share name */
1363 }
1364 }
1365 *tmpstart = '\0';
1366 while (*start) {
1367 /* copy initial slash, if any */
1368 if (isSLASH(*start)) {
1369 *tmpstart++ = *start++;
1370 *tmpstart = '\0';
1371 SKIP_SLASHES(start);
1372 }
1373
1374 /* FindFirstFile() expands "." and "..", so we need to pass
1375 * those through unmolested */
1376 if (*start == '.'
1377 && (!start[1] || isSLASH(start[1])
1378 || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
1379 {
1380 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
1381 *tmpstart = '\0';
1382 continue;
1383 }
1384
1385 /* if this is the end, bust outta here */
1386 if (!*start)
1387 break;
1388
1389 /* now we're at a non-slash; walk up to next slash */
1390 while (*start && !isSLASH(*start))
1391 ++start;
1392
1393 /* stop and find full name of component */
1394 sep = *start;
1395 *start = '\0';
1396 fhand = FindFirstFile(path,&fdata);
1397 *start = sep;
1398 if (fhand != INVALID_HANDLE_VALUE) {
1399 STRLEN len = strlen(fdata.cFileName);
1400 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
1401 strcpy(tmpstart, fdata.cFileName);
1402 tmpstart += len;
1403 FindClose(fhand);
1404 }
1405 else {
1406 FindClose(fhand);
1407 errno = ERANGE;
1408 return Nullch;
1409 }
1410 }
1411 else {
1412 /* failed a step, just return without side effects */
1413 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
1414 errno = EINVAL;
1415 return Nullch;
1416 }
1417 }
1418 strcpy(path,tmpbuf);
1419 return path;
1420}
1421
1422DllExport char *
1423win32_getenv(const char *name)
1424{
1425 dTHX;
1426 WCHAR wBuffer[MAX_PATH+1];
1427 DWORD needlen;
1428 SV *curitem = Nullsv;
1429
1430 if (USING_WIDE()) {
1431 A2WHELPER(name, wBuffer, sizeof(wBuffer));
1432 needlen = GetEnvironmentVariableW(wBuffer, NULL, 0);
1433 }
1434 else
1435 needlen = GetEnvironmentVariableA(name,NULL,0);
1436 if (needlen != 0) {
1437 curitem = sv_2mortal(newSVpvn("", 0));
1438 if (USING_WIDE()) {
1439 SV *acuritem;
1440 do {
1441 SvGROW(curitem, (needlen+1)*sizeof(WCHAR));
1442 needlen = GetEnvironmentVariableW(wBuffer,
1443 (WCHAR*)SvPVX(curitem),
1444 needlen);
1445 } while (needlen >= SvLEN(curitem)/sizeof(WCHAR));
1446 SvCUR_set(curitem, (needlen*sizeof(WCHAR))+1);
1447 acuritem = sv_2mortal(newSVsv(curitem));
1448 W2AHELPER((WCHAR*)SvPVX(acuritem), SvPVX(curitem), SvCUR(curitem));
1449 }
1450 else {
1451 do {
1452 SvGROW(curitem, needlen+1);
1453 needlen = GetEnvironmentVariableA(name,SvPVX(curitem),
1454 needlen);
1455 } while (needlen >= SvLEN(curitem));
1456 SvCUR_set(curitem, needlen);
1457 }
1458 }
1459 else {
1460 /* allow any environment variables that begin with 'PERL'
1461 to be stored in the registry */
1462 if (strncmp(name, "PERL", 4) == 0)
1463 (void)get_regstr(name, &curitem);
1464 }
1465 if (curitem && SvCUR(curitem))
1466 return SvPVX(curitem);
1467
1468 return Nullch;
1469}
1470
1471DllExport int
1472win32_putenv(const char *name)
1473{
1474 dTHX;
1475 char* curitem;
1476 char* val;
1477 WCHAR* wCuritem;
1478 WCHAR* wVal;
1479 int length, relval = -1;
1480
1481 if (name) {
1482 if (USING_WIDE()) {
1483 length = strlen(name)+1;
1484 Newx(wCuritem,length,WCHAR);
1485 A2WHELPER(name, wCuritem, length*sizeof(WCHAR));
1486 wVal = wcschr(wCuritem, '=');
1487 if (wVal) {
1488 *wVal++ = '\0';
1489 if (SetEnvironmentVariableW(wCuritem, *wVal ? wVal : NULL))
1490 relval = 0;
1491 }
1492 Safefree(wCuritem);
1493 }
1494 else {
1495 Newx(curitem,strlen(name)+1,char);
1496 strcpy(curitem, name);
1497 val = strchr(curitem, '=');
1498 if (val) {
1499 /* The sane way to deal with the environment.
1500 * Has these advantages over putenv() & co.:
1501 * * enables us to store a truly empty value in the
1502 * environment (like in UNIX).
1503 * * we don't have to deal with RTL globals, bugs and leaks.
1504 * * Much faster.
1505 * Why you may want to enable USE_WIN32_RTL_ENV:
1506 * * environ[] and RTL functions will not reflect changes,
1507 * which might be an issue if extensions want to access
1508 * the env. via RTL. This cuts both ways, since RTL will
1509 * not see changes made by extensions that call the Win32
1510 * functions directly, either.
1511 * GSAR 97-06-07
1512 */
1513 *val++ = '\0';
1514 if (SetEnvironmentVariableA(curitem, *val ? val : NULL))
1515 relval = 0;
1516 }
1517 Safefree(curitem);
1518 }
1519 }
1520 return relval;
1521}
1522
1523static long
1524filetime_to_clock(PFILETIME ft)
1525{
1526 __int64 qw = ft->dwHighDateTime;
1527 qw <<= 32;
1528 qw |= ft->dwLowDateTime;
1529 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */
1530 return (long) qw;
1531}
1532
1533DllExport int
1534win32_times(struct tms *timebuf)
1535{
1536 FILETIME user;
1537 FILETIME kernel;
1538 FILETIME dummy;
1539 clock_t process_time_so_far = clock();
1540 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy,
1541 &kernel,&user)) {
1542 timebuf->tms_utime = filetime_to_clock(&user);
1543 timebuf->tms_stime = filetime_to_clock(&kernel);
1544 timebuf->tms_cutime = 0;
1545 timebuf->tms_cstime = 0;
1546 } else {
1547 /* That failed - e.g. Win95 fallback to clock() */
1548 timebuf->tms_utime = process_time_so_far;
1549 timebuf->tms_stime = 0;
1550 timebuf->tms_cutime = 0;
1551 timebuf->tms_cstime = 0;
1552 }
1553 return process_time_so_far;
1554}
1555
1556/* fix utime() so it works on directories in NT */
1557static BOOL
1558filetime_from_time(PFILETIME pFileTime, time_t Time)
1559{
1560 struct tm *pTM = localtime(&Time);
1561 SYSTEMTIME SystemTime;
1562 FILETIME LocalTime;
1563
1564 if (pTM == NULL)
1565 return FALSE;
1566
1567 SystemTime.wYear = pTM->tm_year + 1900;
1568 SystemTime.wMonth = pTM->tm_mon + 1;
1569 SystemTime.wDay = pTM->tm_mday;
1570 SystemTime.wHour = pTM->tm_hour;
1571 SystemTime.wMinute = pTM->tm_min;
1572 SystemTime.wSecond = pTM->tm_sec;
1573 SystemTime.wMilliseconds = 0;
1574
1575 return SystemTimeToFileTime(&SystemTime, &LocalTime) &&
1576 LocalFileTimeToFileTime(&LocalTime, pFileTime);
1577}
1578
1579DllExport int
1580win32_unlink(const char *filename)
1581{
1582 dTHX;
1583 int ret;
1584 DWORD attrs;
1585
1586 if (USING_WIDE()) {
1587 WCHAR wBuffer[MAX_PATH+1];
1588 WCHAR* pwBuffer;
1589
1590 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
1591 pwBuffer = PerlDir_mapW(wBuffer);
1592 attrs = GetFileAttributesW(pwBuffer);
1593 if (attrs == 0xFFFFFFFF)
1594 goto fail;
1595 if (attrs & FILE_ATTRIBUTE_READONLY) {
1596 (void)SetFileAttributesW(pwBuffer, attrs & ~FILE_ATTRIBUTE_READONLY);
1597 ret = _wunlink(pwBuffer);
1598 if (ret == -1)
1599 (void)SetFileAttributesW(pwBuffer, attrs);
1600 }
1601 else
1602 ret = _wunlink(pwBuffer);
1603 }
1604 else {
1605 filename = PerlDir_mapA(filename);
1606 attrs = GetFileAttributesA(filename);
1607 if (attrs == 0xFFFFFFFF)
1608 goto fail;
1609 if (attrs & FILE_ATTRIBUTE_READONLY) {
1610 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY);
1611 ret = unlink(filename);
1612 if (ret == -1)
1613 (void)SetFileAttributesA(filename, attrs);
1614 }
1615 else
1616 ret = unlink(filename);
1617 }
1618 return ret;
1619fail:
1620 errno = ENOENT;
1621 return -1;
1622}
1623
1624DllExport int
1625win32_utime(const char *filename, struct utimbuf *times)
1626{
1627 dTHX;
1628 HANDLE handle;
1629 FILETIME ftCreate;
1630 FILETIME ftAccess;
1631 FILETIME ftWrite;
1632 struct utimbuf TimeBuffer;
1633 WCHAR wbuffer[MAX_PATH+1];
1634 WCHAR* pwbuffer;
1635
1636 int rc;
1637 if (USING_WIDE()) {
1638 A2WHELPER(filename, wbuffer, sizeof(wbuffer));
1639 pwbuffer = PerlDir_mapW(wbuffer);
1640 rc = _wutime(pwbuffer, (struct _utimbuf*)times);
1641 }
1642 else {
1643 filename = PerlDir_mapA(filename);
1644 rc = utime(filename, times);
1645 }
1646 /* EACCES: path specifies directory or readonly file */
1647 if (rc == 0 || errno != EACCES /* || !IsWinNT() */)
1648 return rc;
1649
1650 if (times == NULL) {
1651 times = &TimeBuffer;
1652 time(&times->actime);
1653 times->modtime = times->actime;
1654 }
1655
1656 /* This will (and should) still fail on readonly files */
1657 if (USING_WIDE()) {
1658 handle = CreateFileW(pwbuffer, GENERIC_READ | GENERIC_WRITE,
1659 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1660 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1661 }
1662 else {
1663 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE,
1664 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL,
1665 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1666 }
1667 if (handle == INVALID_HANDLE_VALUE)
1668 return rc;
1669
1670 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) &&
1671 filetime_from_time(&ftAccess, times->actime) &&
1672 filetime_from_time(&ftWrite, times->modtime) &&
1673 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite))
1674 {
1675 rc = 0;
1676 }
1677
1678 CloseHandle(handle);
1679 return rc;
1680}
1681
1682typedef union {
1683 unsigned __int64 ft_i64;
1684 FILETIME ft_val;
1685} FT_t;
1686
1687#ifdef __GNUC__
1688#define Const64(x) x##LL
1689#else
1690#define Const64(x) x##i64
1691#endif
1692/* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */
1693#define EPOCH_BIAS Const64(116444736000000000)
1694
1695/* NOTE: This does not compute the timezone info (doing so can be expensive,
1696 * and appears to be unsupported even by glibc) */
1697DllExport int
1698win32_gettimeofday(struct timeval *tp, void *not_used)
1699{
1700 FT_t ft;
1701
1702 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */
1703 GetSystemTimeAsFileTime(&ft.ft_val);
1704
1705 /* seconds since epoch */
1706 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000));
1707
1708 /* microseconds remaining */
1709 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000));
1710
1711 return 0;
1712}
1713
1714DllExport int
1715win32_uname(struct utsname *name)
1716{
1717 struct hostent *hep;
1718 STRLEN nodemax = sizeof(name->nodename)-1;
1719 OSVERSIONINFO osver;
1720
1721 memset(&osver, 0, sizeof(OSVERSIONINFO));
1722 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1723 if (GetVersionEx(&osver)) {
1724 /* sysname */
1725 switch (osver.dwPlatformId) {
1726 case VER_PLATFORM_WIN32_WINDOWS:
1727 strcpy(name->sysname, "Windows");
1728 break;
1729 case VER_PLATFORM_WIN32_NT:
1730 strcpy(name->sysname, "Windows NT");
1731 break;
1732 case VER_PLATFORM_WIN32s:
1733 strcpy(name->sysname, "Win32s");
1734 break;
1735 default:
1736 strcpy(name->sysname, "Win32 Unknown");
1737 break;
1738 }
1739
1740 /* release */
1741 sprintf(name->release, "%d.%d",
1742 osver.dwMajorVersion, osver.dwMinorVersion);
1743
1744 /* version */
1745 sprintf(name->version, "Build %d",
1746 osver.dwPlatformId == VER_PLATFORM_WIN32_NT
1747 ? osver.dwBuildNumber : (osver.dwBuildNumber & 0xffff));
1748 if (osver.szCSDVersion[0]) {
1749 char *buf = name->version + strlen(name->version);
1750 sprintf(buf, " (%s)", osver.szCSDVersion);
1751 }
1752 }
1753 else {
1754 *name->sysname = '\0';
1755 *name->version = '\0';
1756 *name->release = '\0';
1757 }
1758
1759 /* nodename */
1760 hep = win32_gethostbyname("localhost");
1761 if (hep) {
1762 STRLEN len = strlen(hep->h_name);
1763 if (len <= nodemax) {
1764 strcpy(name->nodename, hep->h_name);
1765 }
1766 else {
1767 strncpy(name->nodename, hep->h_name, nodemax);
1768 name->nodename[nodemax] = '\0';
1769 }
1770 }
1771 else {
1772 DWORD sz = nodemax;
1773 if (!GetComputerName(name->nodename, &sz))
1774 *name->nodename = '\0';
1775 }
1776
1777 /* machine (architecture) */
1778 {
1779 SYSTEM_INFO info;
1780 DWORD procarch;
1781 char *arch;
1782 GetSystemInfo(&info);
1783
1784#if (defined(__BORLANDC__)&&(__BORLANDC__<=0x520)) \
1785 || (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
1786 procarch = info.u.s.wProcessorArchitecture;
1787#else
1788 procarch = info.wProcessorArchitecture;
1789#endif
1790 switch (procarch) {
1791 case PROCESSOR_ARCHITECTURE_INTEL:
1792 arch = "x86"; break;
1793 case PROCESSOR_ARCHITECTURE_MIPS:
1794 arch = "mips"; break;
1795 case PROCESSOR_ARCHITECTURE_ALPHA:
1796 arch = "alpha"; break;
1797 case PROCESSOR_ARCHITECTURE_PPC:
1798 arch = "ppc"; break;
1799#ifdef PROCESSOR_ARCHITECTURE_SHX
1800 case PROCESSOR_ARCHITECTURE_SHX:
1801 arch = "shx"; break;
1802#endif
1803#ifdef PROCESSOR_ARCHITECTURE_ARM
1804 case PROCESSOR_ARCHITECTURE_ARM:
1805 arch = "arm"; break;
1806#endif
1807#ifdef PROCESSOR_ARCHITECTURE_IA64
1808 case PROCESSOR_ARCHITECTURE_IA64:
1809 arch = "ia64"; break;
1810#endif
1811#ifdef PROCESSOR_ARCHITECTURE_ALPHA64
1812 case PROCESSOR_ARCHITECTURE_ALPHA64:
1813 arch = "alpha64"; break;
1814#endif
1815#ifdef PROCESSOR_ARCHITECTURE_MSIL
1816 case PROCESSOR_ARCHITECTURE_MSIL:
1817 arch = "msil"; break;
1818#endif
1819#ifdef PROCESSOR_ARCHITECTURE_AMD64
1820 case PROCESSOR_ARCHITECTURE_AMD64:
1821 arch = "amd64"; break;
1822#endif
1823#ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1824 case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
1825 arch = "ia32-64"; break;
1826#endif
1827#ifdef PROCESSOR_ARCHITECTURE_UNKNOWN
1828 case PROCESSOR_ARCHITECTURE_UNKNOWN:
1829 arch = "unknown"; break;
1830#endif
1831 default:
1832 sprintf(name->machine, "unknown(0x%x)", procarch);
1833 arch = name->machine;
1834 break;
1835 }
1836 if (name->machine != arch)
1837 strcpy(name->machine, arch);
1838 }
1839 return 0;
1840}
1841
1842/* Timing related stuff */
1843
1844int
1845do_raise(pTHX_ int sig)
1846{
1847 if (sig < SIG_SIZE) {
1848 Sighandler_t handler = w32_sighandler[sig];
1849 if (handler == SIG_IGN) {
1850 return 0;
1851 }
1852 else if (handler != SIG_DFL) {
1853 (*handler)(sig);
1854 return 0;
1855 }
1856 else {
1857 /* Choose correct default behaviour */
1858 switch (sig) {
1859#ifdef SIGCLD
1860 case SIGCLD:
1861#endif
1862#ifdef SIGCHLD
1863 case SIGCHLD:
1864#endif
1865 case 0:
1866 return 0;
1867 case SIGTERM:
1868 default:
1869 break;
1870 }
1871 }
1872 }
1873 /* Tell caller to exit thread/process as approriate */
1874 return 1;
1875}
1876
1877void
1878sig_terminate(pTHX_ int sig)
1879{
1880 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig);
1881 /* exit() seems to be safe, my_exit() or die() is a problem in ^C
1882 thread
1883 */
1884 exit(sig);
1885}
1886
1887DllExport int
1888win32_async_check(pTHX)
1889{
1890 MSG msg;
1891 int ours = 1;
1892 /* Passing PeekMessage -1 as HWND (2nd arg) only get PostThreadMessage() messages
1893 * and ignores window messages - should co-exist better with windows apps e.g. Tk
1894 */
1895 while (PeekMessage(&msg, (HWND)-1, 0, 0, PM_REMOVE|PM_NOYIELD)) {
1896 int sig;
1897 switch(msg.message) {
1898
1899#if 0
1900 /* Perhaps some other messages could map to signals ? ... */
1901 case WM_CLOSE:
1902 case WM_QUIT:
1903 /* Treat WM_QUIT like SIGHUP? */
1904 sig = SIGHUP;
1905 goto Raise;
1906 break;
1907#endif
1908
1909 /* We use WM_USER to fake kill() with other signals */
1910 case WM_USER: {
1911 sig = msg.wParam;
1912 Raise:
1913 if (do_raise(aTHX_ sig)) {
1914 sig_terminate(aTHX_ sig);
1915 }
1916 break;
1917 }
1918
1919 case WM_TIMER: {
1920 /* alarm() is a one-shot but SetTimer() repeats so kill it */
1921 if (w32_timerid && w32_timerid==msg.wParam) {
1922 KillTimer(NULL,w32_timerid);
1923 w32_timerid=0;
1924 }
1925 else
1926 goto FallThrough;
1927 /* Now fake a call to signal handler */
1928 if (do_raise(aTHX_ 14)) {
1929 sig_terminate(aTHX_ 14);
1930 }
1931 break;
1932 }
1933
1934 /* Otherwise do normal Win32 thing - in case it is useful */
1935 default:
1936 FallThrough:
1937 TranslateMessage(&msg);
1938 DispatchMessage(&msg);
1939 ours = 0;
1940 break;
1941 }
1942 }
1943 w32_poll_count = 0;
1944
1945 /* Above or other stuff may have set a signal flag */
1946 if (PL_sig_pending) {
1947 despatch_signals();
1948 }
1949 return ours;
1950}
1951
1952/* This function will not return until the timeout has elapsed, or until
1953 * one of the handles is ready. */
1954DllExport DWORD
1955win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp)
1956{
1957 /* We may need several goes at this - so compute when we stop */
1958 DWORD ticks = 0;
1959 if (timeout != INFINITE) {
1960 ticks = GetTickCount();
1961 timeout += ticks;
1962 }
1963 while (1) {
1964 DWORD result = MsgWaitForMultipleObjects(count,handles,FALSE,timeout-ticks, QS_ALLEVENTS);
1965 if (resultp)
1966 *resultp = result;
1967 if (result == WAIT_TIMEOUT) {
1968 /* Ran out of time - explicit return of zero to avoid -ve if we
1969 have scheduling issues
1970 */
1971 return 0;
1972 }
1973 if (timeout != INFINITE) {
1974 ticks = GetTickCount();
1975 }
1976 if (result == WAIT_OBJECT_0 + count) {
1977 /* Message has arrived - check it */
1978 (void)win32_async_check(aTHX);
1979 }
1980 else {
1981 /* Not timeout or message - one of handles is ready */
1982 break;
1983 }
1984 }
1985 /* compute time left to wait */
1986 ticks = timeout - ticks;
1987 /* If we are past the end say zero */
1988 return (ticks > 0) ? ticks : 0;
1989}
1990
1991int
1992win32_internal_wait(int *status, DWORD timeout)
1993{
1994 /* XXX this wait emulation only knows about processes
1995 * spawned via win32_spawnvp(P_NOWAIT, ...).
1996 */
1997 dTHX;
1998 int i, retval;
1999 DWORD exitcode, waitcode;
2000
2001#ifdef USE_ITHREADS
2002 if (w32_num_pseudo_children) {
2003 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles,
2004 timeout, &waitcode);
2005 /* Time out here if there are no other children to wait for. */
2006 if (waitcode == WAIT_TIMEOUT) {
2007 if (!w32_num_children) {
2008 return 0;
2009 }
2010 }
2011 else if (waitcode != WAIT_FAILED) {
2012 if (waitcode >= WAIT_ABANDONED_0
2013 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children)
2014 i = waitcode - WAIT_ABANDONED_0;
2015 else
2016 i = waitcode - WAIT_OBJECT_0;
2017 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) {
2018 *status = (int)((exitcode & 0xff) << 8);
2019 retval = (int)w32_pseudo_child_pids[i];
2020 remove_dead_pseudo_process(i);
2021 return -retval;
2022 }
2023 }
2024 }
2025#endif
2026
2027 if (!w32_num_children) {
2028 errno = ECHILD;
2029 return -1;
2030 }
2031
2032 /* if a child exists, wait for it to die */
2033 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode);
2034 if (waitcode == WAIT_TIMEOUT) {
2035 return 0;
2036 }
2037 if (waitcode != WAIT_FAILED) {
2038 if (waitcode >= WAIT_ABANDONED_0
2039 && waitcode < WAIT_ABANDONED_0 + w32_num_children)
2040 i = waitcode - WAIT_ABANDONED_0;
2041 else
2042 i = waitcode - WAIT_OBJECT_0;
2043 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) {
2044 *status = (int)((exitcode & 0xff) << 8);
2045 retval = (int)w32_child_pids[i];
2046 remove_dead_process(i);
2047 return retval;
2048 }
2049 }
2050
2051 errno = GetLastError();
2052 return -1;
2053}
2054
2055DllExport int
2056win32_waitpid(int pid, int *status, int flags)
2057{
2058 dTHX;
2059 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE;
2060 int retval = -1;
2061 long child;
2062 if (pid == -1) /* XXX threadid == 1 ? */
2063 return win32_internal_wait(status, timeout);
2064#ifdef USE_ITHREADS
2065 else if (pid < 0) {
2066 child = find_pseudo_pid(-pid);
2067 if (child >= 0) {
2068 HANDLE hThread = w32_pseudo_child_handles[child];
2069 DWORD waitcode;
2070 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode);
2071 if (waitcode == WAIT_TIMEOUT) {
2072 return 0;
2073 }
2074 else if (waitcode == WAIT_OBJECT_0) {
2075 if (GetExitCodeThread(hThread, &waitcode)) {
2076 *status = (int)((waitcode & 0xff) << 8);
2077 retval = (int)w32_pseudo_child_pids[child];
2078 remove_dead_pseudo_process(child);
2079 return -retval;
2080 }
2081 }
2082 else
2083 errno = ECHILD;
2084 }
2085 else if (IsWin95()) {
2086 pid = -pid;
2087 goto alien_process;
2088 }
2089 }
2090#endif
2091 else {
2092 HANDLE hProcess;
2093 DWORD waitcode;
2094 child = find_pid(pid);
2095 if (child >= 0) {
2096 hProcess = w32_child_handles[child];
2097 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2098 if (waitcode == WAIT_TIMEOUT) {
2099 return 0;
2100 }
2101 else if (waitcode == WAIT_OBJECT_0) {
2102 if (GetExitCodeProcess(hProcess, &waitcode)) {
2103 *status = (int)((waitcode & 0xff) << 8);
2104 retval = (int)w32_child_pids[child];
2105 remove_dead_process(child);
2106 return retval;
2107 }
2108 }
2109 else
2110 errno = ECHILD;
2111 }
2112 else {
2113alien_process:
2114 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE,
2115 (IsWin95() ? -pid : pid));
2116 if (hProcess) {
2117 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode);
2118 if (waitcode == WAIT_TIMEOUT) {
2119 CloseHandle(hProcess);
2120 return 0;
2121 }
2122 else if (waitcode == WAIT_OBJECT_0) {
2123 if (GetExitCodeProcess(hProcess, &waitcode)) {
2124 *status = (int)((waitcode & 0xff) << 8);
2125 CloseHandle(hProcess);
2126 return pid;
2127 }
2128 }
2129 CloseHandle(hProcess);
2130 }
2131 else
2132 errno = ECHILD;
2133 }
2134 }
2135 return retval >= 0 ? pid : retval;
2136}
2137
2138DllExport int
2139win32_wait(int *status)
2140{
2141 return win32_internal_wait(status, INFINITE);
2142}
2143
2144DllExport unsigned int
2145win32_sleep(unsigned int t)
2146{
2147 dTHX;
2148 /* Win32 times are in ms so *1000 in and /1000 out */
2149 return win32_msgwait(aTHX_ 0, NULL, t*1000, NULL)/1000;
2150}
2151
2152DllExport unsigned int
2153win32_alarm(unsigned int sec)
2154{
2155 /*
2156 * the 'obvious' implentation is SetTimer() with a callback
2157 * which does whatever receiving SIGALRM would do
2158 * we cannot use SIGALRM even via raise() as it is not
2159 * one of the supported codes in <signal.h>
2160 */
2161 dTHX;
2162 if (sec) {
2163 w32_timerid = SetTimer(NULL,w32_timerid,sec*1000,NULL);
2164 }
2165 else {
2166 if (w32_timerid) {
2167 KillTimer(NULL,w32_timerid);
2168 w32_timerid=0;
2169 }
2170 }
2171 return 0;
2172}
2173
2174#ifdef HAVE_DES_FCRYPT
2175extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf);
2176#endif
2177
2178DllExport char *
2179win32_crypt(const char *txt, const char *salt)
2180{
2181 dTHX;
2182#ifdef HAVE_DES_FCRYPT
2183 return des_fcrypt(txt, salt, w32_crypt_buffer);
2184#else
2185 Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia.");
2186 return Nullch;
2187#endif
2188}
2189
2190#ifdef USE_FIXED_OSFHANDLE
2191
2192#define FOPEN 0x01 /* file handle open */
2193#define FNOINHERIT 0x10 /* file handle opened O_NOINHERIT */
2194#define FAPPEND 0x20 /* file handle opened O_APPEND */
2195#define FDEV 0x40 /* file handle refers to device */
2196#define FTEXT 0x80 /* file handle is in text mode */
2197
2198/***
2199*int my_open_osfhandle(intptr_t osfhandle, int flags) - open C Runtime file handle
2200*
2201*Purpose:
2202* This function allocates a free C Runtime file handle and associates
2203* it with the Win32 HANDLE specified by the first parameter. This is a
2204* temperary fix for WIN95's brain damage GetFileType() error on socket
2205* we just bypass that call for socket
2206*
2207* This works with MSVC++ 4.0+ or GCC/Mingw32
2208*
2209*Entry:
2210* intptr_t osfhandle - Win32 HANDLE to associate with C Runtime file handle.
2211* int flags - flags to associate with C Runtime file handle.
2212*
2213*Exit:
2214* returns index of entry in fh, if successful
2215* return -1, if no free entry is found
2216*
2217*Exceptions:
2218*
2219*******************************************************************************/
2220
2221/*
2222 * we fake up some parts of the CRT that aren't exported by MSVCRT.dll
2223 * this lets sockets work on Win9X with GCC and should fix the problems
2224 * with perl95.exe
2225 * -- BKS, 1-23-2000
2226*/
2227
2228/* create an ioinfo entry, kill its handle, and steal the entry */
2229
2230static int
2231_alloc_osfhnd(void)
2232{
2233 HANDLE hF = CreateFile("NUL", 0, 0, NULL, OPEN_ALWAYS, 0, NULL);
2234 int fh = _open_osfhandle((intptr_t)hF, 0);
2235 CloseHandle(hF);
2236 if (fh == -1)
2237 return fh;
2238 EnterCriticalSection(&(_pioinfo(fh)->lock));
2239 return fh;
2240}
2241
2242static int
2243my_open_osfhandle(intptr_t osfhandle, int flags)
2244{
2245 int fh;
2246 char fileflags; /* _osfile flags */
2247
2248 /* copy relevant flags from second parameter */
2249 fileflags = FDEV;
2250
2251 if (flags & O_APPEND)
2252 fileflags |= FAPPEND;
2253
2254 if (flags & O_TEXT)
2255 fileflags |= FTEXT;
2256
2257 if (flags & O_NOINHERIT)
2258 fileflags |= FNOINHERIT;
2259
2260 /* attempt to allocate a C Runtime file handle */
2261 if ((fh = _alloc_osfhnd()) == -1) {
2262 errno = EMFILE; /* too many open files */
2263 _doserrno = 0L; /* not an OS error */
2264 return -1; /* return error to caller */
2265 }
2266
2267 /* the file is open. now, set the info in _osfhnd array */
2268 _set_osfhnd(fh, osfhandle);
2269
2270 fileflags |= FOPEN; /* mark as open */
2271
2272 _osfile(fh) = fileflags; /* set osfile entry */
2273 LeaveCriticalSection(&_pioinfo(fh)->lock);
2274
2275 return fh; /* return handle */
2276}
2277
2278#endif /* USE_FIXED_OSFHANDLE */
2279
2280/* simulate flock by locking a range on the file */
2281
2282#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
2283#define LK_LEN 0xffff0000
2284
2285DllExport int
2286win32_flock(int fd, int oper)
2287{
2288 OVERLAPPED o;
2289 int i = -1;
2290 HANDLE fh;
2291
2292 if (!IsWinNT()) {
2293 dTHX;
2294 Perl_croak_nocontext("flock() unimplemented on this platform");
2295 return -1;
2296 }
2297 fh = (HANDLE)_get_osfhandle(fd);
2298 memset(&o, 0, sizeof(o));
2299
2300 switch(oper) {
2301 case LOCK_SH: /* shared lock */
2302 LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
2303 break;
2304 case LOCK_EX: /* exclusive lock */
2305 LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
2306 break;
2307 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
2308 LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
2309 break;
2310 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
2311 LK_ERR(LockFileEx(fh,
2312 LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
2313 0, LK_LEN, 0, &o),i);
2314 break;
2315 case LOCK_UN: /* unlock lock */
2316 LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
2317 break;
2318 default: /* unknown */
2319 errno = EINVAL;
2320 break;
2321 }
2322 return i;
2323}
2324
2325#undef LK_ERR
2326#undef LK_LEN
2327
2328/*
2329 * redirected io subsystem for all XS modules
2330 *
2331 */
2332
2333DllExport int *
2334win32_errno(void)
2335{
2336 return (&errno);
2337}
2338
2339DllExport char ***
2340win32_environ(void)
2341{
2342 return (&(_environ));
2343}
2344
2345/* the rest are the remapped stdio routines */
2346DllExport FILE *
2347win32_stderr(void)
2348{
2349 return (stderr);
2350}
2351
2352DllExport FILE *
2353win32_stdin(void)
2354{
2355 return (stdin);
2356}
2357
2358DllExport FILE *
2359win32_stdout()
2360{
2361 return (stdout);
2362}
2363
2364DllExport int
2365win32_ferror(FILE *fp)
2366{
2367 return (ferror(fp));
2368}
2369
2370
2371DllExport int
2372win32_feof(FILE *fp)
2373{
2374 return (feof(fp));
2375}
2376
2377/*
2378 * Since the errors returned by the socket error function
2379 * WSAGetLastError() are not known by the library routine strerror
2380 * we have to roll our own.
2381 */
2382
2383DllExport char *
2384win32_strerror(int e)
2385{
2386#if !defined __BORLANDC__ && !defined __MINGW32__ /* compiler intolerance */
2387 extern int sys_nerr;
2388#endif
2389 DWORD source = 0;
2390
2391 if (e < 0 || e > sys_nerr) {
2392 dTHX;
2393 if (e < 0)
2394 e = GetLastError();
2395
2396 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
2397 w32_strerror_buffer,
2398 sizeof(w32_strerror_buffer), NULL) == 0)
2399 strcpy(w32_strerror_buffer, "Unknown Error");
2400
2401 return w32_strerror_buffer;
2402 }
2403 return strerror(e);
2404}
2405
2406DllExport void
2407win32_str_os_error(void *sv, DWORD dwErr)
2408{
2409 DWORD dwLen;