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

Last change on this file was 3181, checked in by bird, 18 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;
2410 char *sMsg;
2411 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
2412 |FORMAT_MESSAGE_IGNORE_INSERTS
2413 |FORMAT_MESSAGE_FROM_SYSTEM, NULL,
2414 dwErr, 0, (char *)&sMsg, 1, NULL);
2415 /* strip trailing whitespace and period */
2416 if (0 < dwLen) {
2417 do {
2418 --dwLen; /* dwLen doesn't include trailing null */
2419 } while (0 < dwLen && isSPACE(sMsg[dwLen]));
2420 if ('.' != sMsg[dwLen])
2421 dwLen++;
2422 sMsg[dwLen] = '\0';
2423 }
2424 if (0 == dwLen) {
2425 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/);
2426 if (sMsg)
2427 dwLen = sprintf(sMsg,
2428 "Unknown error #0x%lX (lookup 0x%lX)",
2429 dwErr, GetLastError());
2430 }
2431 if (sMsg) {
2432 dTHX;
2433 sv_setpvn((SV*)sv, sMsg, dwLen);
2434 LocalFree(sMsg);
2435 }
2436}
2437
2438DllExport int
2439win32_fprintf(FILE *fp, const char *format, ...)
2440{
2441 va_list marker;
2442 va_start(marker, format); /* Initialize variable arguments. */
2443
2444 return (vfprintf(fp, format, marker));
2445}
2446
2447DllExport int
2448win32_printf(const char *format, ...)
2449{
2450 va_list marker;
2451 va_start(marker, format); /* Initialize variable arguments. */
2452
2453 return (vprintf(format, marker));
2454}
2455
2456DllExport int
2457win32_vfprintf(FILE *fp, const char *format, va_list args)
2458{
2459 return (vfprintf(fp, format, args));
2460}
2461
2462DllExport int
2463win32_vprintf(const char *format, va_list args)
2464{
2465 return (vprintf(format, args));
2466}
2467
2468DllExport size_t
2469win32_fread(void *buf, size_t size, size_t count, FILE *fp)
2470{
2471 return fread(buf, size, count, fp);
2472}
2473
2474DllExport size_t
2475win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
2476{
2477 return fwrite(buf, size, count, fp);
2478}
2479
2480#define MODE_SIZE 10
2481
2482DllExport FILE *
2483win32_fopen(const char *filename, const char *mode)
2484{
2485 dTHX;
2486 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2487 FILE *f;
2488
2489 if (!*filename)
2490 return NULL;
2491
2492 if (stricmp(filename, "/dev/null")==0)
2493 filename = "NUL";
2494
2495 if (USING_WIDE()) {
2496 A2WHELPER(mode, wMode, sizeof(wMode));
2497 A2WHELPER(filename, wBuffer, sizeof(wBuffer));
2498 f = _wfopen(PerlDir_mapW(wBuffer), wMode);
2499 }
2500 else
2501 f = fopen(PerlDir_mapA(filename), mode);
2502 /* avoid buffering headaches for child processes */
2503 if (f && *mode == 'a')
2504 win32_fseek(f, 0, SEEK_END);
2505 return f;
2506}
2507
2508#ifndef USE_SOCKETS_AS_HANDLES
2509#undef fdopen
2510#define fdopen my_fdopen
2511#endif
2512
2513DllExport FILE *
2514win32_fdopen(int handle, const char *mode)
2515{
2516 dTHX;
2517 WCHAR wMode[MODE_SIZE];
2518 FILE *f;
2519 if (USING_WIDE()) {
2520 A2WHELPER(mode, wMode, sizeof(wMode));
2521 f = _wfdopen(handle, wMode);
2522 }
2523 else
2524 f = fdopen(handle, (char *) mode);
2525 /* avoid buffering headaches for child processes */
2526 if (f && *mode == 'a')
2527 win32_fseek(f, 0, SEEK_END);
2528 return f;
2529}
2530
2531DllExport FILE *
2532win32_freopen(const char *path, const char *mode, FILE *stream)
2533{
2534 dTHX;
2535 WCHAR wMode[MODE_SIZE], wBuffer[MAX_PATH+1];
2536 if (stricmp(path, "/dev/null")==0)
2537 path = "NUL";
2538
2539 if (USING_WIDE()) {
2540 A2WHELPER(mode, wMode, sizeof(wMode));
2541 A2WHELPER(path, wBuffer, sizeof(wBuffer));
2542 return _wfreopen(PerlDir_mapW(wBuffer), wMode, stream);
2543 }
2544 return freopen(PerlDir_mapA(path), mode, stream);
2545}
2546
2547DllExport int
2548win32_fclose(FILE *pf)
2549{
2550 return my_fclose(pf); /* defined in win32sck.c */
2551}
2552
2553DllExport int
2554win32_fputs(const char *s,FILE *pf)
2555{
2556 return fputs(s, pf);
2557}
2558
2559DllExport int
2560win32_fputc(int c,FILE *pf)
2561{
2562 return fputc(c,pf);
2563}
2564
2565DllExport int
2566win32_ungetc(int c,FILE *pf)
2567{
2568 return ungetc(c,pf);
2569}
2570
2571DllExport int
2572win32_getc(FILE *pf)
2573{
2574 return getc(pf);
2575}
2576
2577DllExport int
2578win32_fileno(FILE *pf)
2579{
2580 return fileno(pf);
2581}
2582
2583DllExport void
2584win32_clearerr(FILE *pf)
2585{
2586 clearerr(pf);
2587 return;
2588}
2589
2590DllExport int
2591win32_fflush(FILE *pf)
2592{
2593 return fflush(pf);
2594}
2595
2596DllExport Off_t
2597win32_ftell(FILE *pf)
2598{
2599#if defined(WIN64) || defined(USE_LARGE_FILES)
2600#if defined(__BORLANDC__) /* buk */
2601 return win32_tell( fileno( pf ) );
2602#else
2603 fpos_t pos;
2604 if (fgetpos(pf, &pos))
2605 return -1;
2606 return (Off_t)pos;
2607#endif
2608#else
2609 return ftell(pf);
2610#endif
2611}
2612
2613DllExport int
2614win32_fseek(FILE *pf, Off_t offset,int origin)
2615{
2616#if defined(WIN64) || defined(USE_LARGE_FILES)
2617#if defined(__BORLANDC__) /* buk */
2618 return win32_lseek(
2619 fileno(pf),
2620 offset,
2621 origin
2622 );
2623#else
2624 fpos_t pos;
2625 switch (origin) {
2626 case SEEK_CUR:
2627 if (fgetpos(pf, &pos))
2628 return -1;
2629 offset += pos;
2630 break;
2631 case SEEK_END:
2632 fseek(pf, 0, SEEK_END);
2633 pos = _telli64(fileno(pf));
2634 offset += pos;
2635 break;
2636 case SEEK_SET:
2637 break;
2638 default:
2639 errno = EINVAL;
2640 return -1;
2641 }
2642 return fsetpos(pf, &offset);
2643#endif
2644#else
2645 return fseek(pf, (long)offset, origin);
2646#endif
2647}
2648
2649DllExport int
2650win32_fgetpos(FILE *pf,fpos_t *p)
2651{
2652#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2653 if( win32_tell(fileno(pf)) == -1L ) {
2654 errno = EBADF;
2655 return -1;
2656 }
2657 return 0;
2658#else
2659 return fgetpos(pf, p);
2660#endif
2661}
2662
2663DllExport int
2664win32_fsetpos(FILE *pf,const fpos_t *p)
2665{
2666#if defined(__BORLANDC__) && defined(USE_LARGE_FILES) /* buk */
2667 return win32_lseek(fileno(pf), *p, SEEK_CUR);
2668#else
2669 return fsetpos(pf, p);
2670#endif
2671}
2672
2673DllExport void
2674win32_rewind(FILE *pf)
2675{
2676 rewind(pf);
2677 return;
2678}
2679
2680DllExport int
2681win32_tmpfd(void)
2682{
2683 dTHX;
2684 char prefix[MAX_PATH+1];
2685 char filename[MAX_PATH+1];
2686 DWORD len = GetTempPath(MAX_PATH, prefix);
2687 if (len && len < MAX_PATH) {
2688 if (GetTempFileName(prefix, "plx", 0, filename)) {
2689 HANDLE fh = CreateFile(filename,
2690 DELETE | GENERIC_READ | GENERIC_WRITE,
2691 0,
2692 NULL,
2693 CREATE_ALWAYS,
2694 FILE_ATTRIBUTE_NORMAL
2695 | FILE_FLAG_DELETE_ON_CLOSE,
2696 NULL);
2697 if (fh != INVALID_HANDLE_VALUE) {
2698 int fd = win32_open_osfhandle((intptr_t)fh, 0);
2699 if (fd >= 0) {
2700#if defined(__BORLANDC__)
2701 setmode(fd,O_BINARY);
2702#endif
2703 DEBUG_p(PerlIO_printf(Perl_debug_log,
2704 "Created tmpfile=%s\n",filename));
2705 return fd;
2706 }
2707 }
2708 }
2709 }
2710 return -1;
2711}
2712
2713DllExport FILE*
2714win32_tmpfile(void)
2715{
2716 int fd = win32_tmpfd();
2717 if (fd >= 0)
2718 return win32_fdopen(fd, "w+b");
2719 return NULL;
2720}
2721
2722DllExport void
2723win32_abort(void)
2724{
2725 abort();
2726 return;
2727}
2728
2729DllExport int
2730win32_fstat(int fd, Stat_t *sbufptr)
2731{
2732#ifdef __BORLANDC__
2733 /* A file designated by filehandle is not shown as accessible
2734 * for write operations, probably because it is opened for reading.
2735 * --Vadim Konovalov
2736 */
2737 BY_HANDLE_FILE_INFORMATION bhfi;
2738#if defined(WIN64) || defined(USE_LARGE_FILES)
2739 /* Borland 5.5.1 has a 64-bit stat, but only a 32-bit fstat */
2740 struct stat tmp;
2741 int rc = fstat(fd,&tmp);
2742
2743 sbufptr->st_dev = tmp.st_dev;
2744 sbufptr->st_ino = tmp.st_ino;
2745 sbufptr->st_mode = tmp.st_mode;
2746 sbufptr->st_nlink = tmp.st_nlink;
2747 sbufptr->st_uid = tmp.st_uid;
2748 sbufptr->st_gid = tmp.st_gid;
2749 sbufptr->st_rdev = tmp.st_rdev;
2750 sbufptr->st_size = tmp.st_size;
2751 sbufptr->st_atime = tmp.st_atime;
2752 sbufptr->st_mtime = tmp.st_mtime;
2753 sbufptr->st_ctime = tmp.st_ctime;
2754#else
2755 int rc = fstat(fd,sbufptr);
2756#endif
2757
2758 if (GetFileInformationByHandle((HANDLE)_get_osfhandle(fd), &bhfi)) {
2759#if defined(WIN64) || defined(USE_LARGE_FILES)
2760 sbufptr->st_size = (bhfi.nFileSizeHigh << 32) + bhfi.nFileSizeLow ;
2761#endif
2762 sbufptr->st_mode &= 0xFE00;
2763 if (bhfi.dwFileAttributes & FILE_ATTRIBUTE_READONLY)
2764 sbufptr->st_mode |= (S_IREAD + (S_IREAD >> 3) + (S_IREAD >> 6));
2765 else
2766 sbufptr->st_mode |= ((S_IREAD|S_IWRITE) + ((S_IREAD|S_IWRITE) >> 3)
2767 + ((S_IREAD|S_IWRITE) >> 6));
2768 }
2769 return rc;
2770#else
2771 return my_fstat(fd,sbufptr);
2772#endif
2773}
2774
2775DllExport int
2776win32_pipe(int *pfd, unsigned int size, int mode)
2777{
2778 return _pipe(pfd, size, mode);
2779}
2780
2781DllExport PerlIO*
2782win32_popenlist(const char *mode, IV narg, SV **args)
2783{
2784 dTHX;
2785 Perl_croak(aTHX_ "List form of pipe open not implemented");
2786 return NULL;
2787}
2788
2789/*
2790 * a popen() clone that respects PERL5SHELL
2791 *
2792 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
2793 */
2794
2795DllExport PerlIO*
2796win32_popen(const char *command, const char *mode)
2797{
2798#ifdef USE_RTL_POPEN
2799 return _popen(command, mode);
2800#else
2801 dTHX;
2802 int p[2];
2803 int parent, child;
2804 int stdfd, oldfd;
2805 int ourmode;
2806 int childpid;
2807 DWORD nhandle;
2808 HANDLE old_h;
2809 int lock_held = 0;
2810
2811 /* establish which ends read and write */
2812 if (strchr(mode,'w')) {
2813 stdfd = 0; /* stdin */
2814 parent = 1;
2815 child = 0;
2816 nhandle = STD_INPUT_HANDLE;
2817 }
2818 else if (strchr(mode,'r')) {
2819 stdfd = 1; /* stdout */
2820 parent = 0;
2821 child = 1;
2822 nhandle = STD_OUTPUT_HANDLE;
2823 }
2824 else
2825 return NULL;
2826
2827 /* set the correct mode */
2828 if (strchr(mode,'b'))
2829 ourmode = O_BINARY;
2830 else if (strchr(mode,'t'))
2831 ourmode = O_TEXT;
2832 else
2833 ourmode = _fmode & (O_TEXT | O_BINARY);
2834
2835 /* the child doesn't inherit handles */
2836 ourmode |= O_NOINHERIT;
2837
2838 if (win32_pipe(p, 512, ourmode) == -1)
2839 return NULL;
2840
2841 /* save current stdfd */
2842 if ((oldfd = win32_dup(stdfd)) == -1)
2843 goto cleanup;
2844
2845 /* save the old std handle (this needs to happen before the
2846 * dup2(), since that might call SetStdHandle() too) */
2847 OP_REFCNT_LOCK;
2848 lock_held = 1;
2849 old_h = GetStdHandle(nhandle);
2850
2851 /* make stdfd go to child end of pipe (implicitly closes stdfd) */
2852 /* stdfd will be inherited by the child */
2853 if (win32_dup2(p[child], stdfd) == -1)
2854 goto cleanup;
2855
2856 /* close the child end in parent */
2857 win32_close(p[child]);
2858
2859 /* set the new std handle (in case dup2() above didn't) */
2860 SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
2861
2862 /* start the child */
2863 {
2864 dTHX;
2865 if ((childpid = do_spawn_nowait((char*)command)) == -1)
2866 goto cleanup;
2867
2868 /* revert stdfd to whatever it was before */
2869 if (win32_dup2(oldfd, stdfd) == -1)
2870 goto cleanup;
2871
2872 /* restore the old std handle (this needs to happen after the
2873 * dup2(), since that might call SetStdHandle() too */
2874 if (lock_held) {
2875 SetStdHandle(nhandle, old_h);
2876 OP_REFCNT_UNLOCK;
2877 lock_held = 0;
2878 }
2879
2880 /* close saved handle */
2881 win32_close(oldfd);
2882
2883 LOCK_FDPID_MUTEX;
2884 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid);
2885 UNLOCK_FDPID_MUTEX;
2886
2887 /* set process id so that it can be returned by perl's open() */
2888 PL_forkprocess = childpid;
2889 }
2890
2891 /* we have an fd, return a file stream */
2892 return (PerlIO_fdopen(p[parent], (char *)mode));
2893
2894cleanup:
2895 /* we don't need to check for errors here */
2896 win32_close(p[0]);
2897 win32_close(p[1]);
2898 if (lock_held) {
2899 SetStdHandle(nhandle, old_h);
2900 OP_REFCNT_UNLOCK;
2901 lock_held = 0;
2902 }
2903 if (oldfd != -1) {
2904 win32_dup2(oldfd, stdfd);
2905 win32_close(oldfd);
2906 }
2907 return (NULL);
2908
2909#endif /* USE_RTL_POPEN */
2910}
2911
2912/*
2913 * pclose() clone
2914 */
2915
2916DllExport int
2917win32_pclose(PerlIO *pf)
2918{
2919#ifdef USE_RTL_POPEN
2920 return _pclose(pf);
2921#else
2922 dTHX;
2923 int childpid, status;
2924 SV *sv;
2925
2926 LOCK_FDPID_MUTEX;
2927 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE);
2928
2929 if (SvIOK(sv))
2930 childpid = SvIVX(sv);
2931 else
2932 childpid = 0;
2933
2934 if (!childpid) {
2935 errno = EBADF;
2936 return -1;
2937 }
2938
2939#ifdef USE_PERLIO
2940 PerlIO_close(pf);
2941#else
2942 fclose(pf);
2943#endif
2944 SvIVX(sv) = 0;
2945 UNLOCK_FDPID_MUTEX;
2946
2947 if (win32_waitpid(childpid, &status, 0) == -1)
2948 return -1;
2949
2950 return status;
2951
2952#endif /* USE_RTL_POPEN */
2953}
2954
2955static BOOL WINAPI
2956Nt4CreateHardLinkW(
2957 LPCWSTR lpFileName,
2958 LPCWSTR lpExistingFileName,
2959 LPSECURITY_ATTRIBUTES lpSecurityAttributes)
2960{
2961 HANDLE handle;
2962 WCHAR wFullName[MAX_PATH+1];
2963 LPVOID lpContext = NULL;
2964 WIN32_STREAM_ID StreamId;
2965 DWORD dwSize = (char*)&StreamId.cStreamName - (char*)&StreamId;
2966 DWORD dwWritten;
2967 DWORD dwLen;
2968 BOOL bSuccess;
2969
2970 BOOL (__stdcall *pfnBackupWrite)(HANDLE, LPBYTE, DWORD, LPDWORD,
2971 BOOL, BOOL, LPVOID*) =
2972 (BOOL (__stdcall *)(HANDLE, LPBYTE, DWORD, LPDWORD,
2973 BOOL, BOOL, LPVOID*))
2974 GetProcAddress(GetModuleHandle("kernel32.dll"), "BackupWrite");
2975 if (pfnBackupWrite == NULL)
2976 return 0;
2977
2978 dwLen = GetFullPathNameW(lpFileName, MAX_PATH, wFullName, NULL);
2979 if (dwLen == 0)
2980 return 0;
2981 dwLen = (dwLen+1)*sizeof(WCHAR);
2982
2983 handle = CreateFileW(lpExistingFileName, FILE_WRITE_ATTRIBUTES,
2984 FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
2985 NULL, OPEN_EXISTING, 0, NULL);
2986 if (handle == INVALID_HANDLE_VALUE)
2987 return 0;
2988
2989 StreamId.dwStreamId = BACKUP_LINK;
2990 StreamId.dwStreamAttributes = 0;
2991 StreamId.dwStreamNameSize = 0;
2992#if defined(__BORLANDC__) \
2993 ||(defined(__MINGW32__) && !defined(_ANONYMOUS_UNION))
2994 StreamId.Size.u.HighPart = 0;
2995 StreamId.Size.u.LowPart = dwLen;
2996#else
2997 StreamId.Size.HighPart = 0;
2998 StreamId.Size.LowPart = dwLen;
2999#endif
3000
3001 bSuccess = pfnBackupWrite(handle, (LPBYTE)&StreamId, dwSize, &dwWritten,
3002 FALSE, FALSE, &lpContext);
3003 if (bSuccess) {
3004 bSuccess = pfnBackupWrite(handle, (LPBYTE)wFullName, dwLen, &dwWritten,
3005 FALSE, FALSE, &lpContext);
3006 pfnBackupWrite(handle, NULL, 0, &dwWritten, TRUE, FALSE, &lpContext);
3007 }
3008
3009 CloseHandle(handle);
3010 return bSuccess;
3011}
3012
3013DllExport int
3014win32_link(const char *oldname, const char *newname)
3015{
3016 dTHX;
3017 BOOL (__stdcall *pfnCreateHardLinkW)(LPCWSTR,LPCWSTR,LPSECURITY_ATTRIBUTES);
3018 WCHAR wOldName[MAX_PATH+1];
3019 WCHAR wNewName[MAX_PATH+1];
3020
3021 if (IsWin95())
3022 Perl_croak(aTHX_ PL_no_func, "link");
3023
3024 pfnCreateHardLinkW =
3025 (BOOL (__stdcall *)(LPCWSTR, LPCWSTR, LPSECURITY_ATTRIBUTES))
3026 GetProcAddress(GetModuleHandle("kernel32.dll"), "CreateHardLinkW");
3027 if (pfnCreateHardLinkW == NULL)
3028 pfnCreateHardLinkW = Nt4CreateHardLinkW;
3029
3030 if ((A2WHELPER(oldname, wOldName, sizeof(wOldName))) &&
3031 (A2WHELPER(newname, wNewName, sizeof(wNewName))) &&
3032 (wcscpy(wOldName, PerlDir_mapW(wOldName)),
3033 pfnCreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL)))
3034 {
3035 return 0;
3036 }
3037 errno = (GetLastError() == ERROR_FILE_NOT_FOUND) ? ENOENT : EINVAL;
3038 return -1;
3039}
3040
3041DllExport int
3042win32_rename(const char *oname, const char *newname)
3043{
3044 WCHAR wOldName[MAX_PATH+1];
3045 WCHAR wNewName[MAX_PATH+1];
3046 char szOldName[MAX_PATH+1];
3047 char szNewName[MAX_PATH+1];
3048 BOOL bResult;
3049 dTHX;
3050
3051 /* XXX despite what the documentation says about MoveFileEx(),
3052 * it doesn't work under Windows95!
3053 */
3054 if (IsWinNT()) {
3055 DWORD dwFlags = MOVEFILE_COPY_ALLOWED;
3056 if (USING_WIDE()) {
3057 A2WHELPER(oname, wOldName, sizeof(wOldName));
3058 A2WHELPER(newname, wNewName, sizeof(wNewName));
3059 if (wcsicmp(wNewName, wOldName))
3060 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3061 wcscpy(wOldName, PerlDir_mapW(wOldName));
3062 bResult = MoveFileExW(wOldName,PerlDir_mapW(wNewName), dwFlags);
3063 }
3064 else {
3065 if (stricmp(newname, oname))
3066 dwFlags |= MOVEFILE_REPLACE_EXISTING;
3067 strcpy(szOldName, PerlDir_mapA(oname));
3068 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags);
3069 }
3070 if (!bResult) {
3071 DWORD err = GetLastError();
3072 switch (err) {
3073 case ERROR_BAD_NET_NAME:
3074 case ERROR_BAD_NETPATH:
3075 case ERROR_BAD_PATHNAME:
3076 case ERROR_FILE_NOT_FOUND:
3077 case ERROR_FILENAME_EXCED_RANGE:
3078 case ERROR_INVALID_DRIVE:
3079 case ERROR_NO_MORE_FILES:
3080 case ERROR_PATH_NOT_FOUND:
3081 errno = ENOENT;
3082 break;
3083 default:
3084 errno = EACCES;
3085 break;
3086 }
3087 return -1;
3088 }
3089 return 0;
3090 }
3091 else {
3092 int retval = 0;
3093 char szTmpName[MAX_PATH+1];
3094 char dname[MAX_PATH+1];
3095 char *endname = Nullch;
3096 STRLEN tmplen = 0;
3097 DWORD from_attr, to_attr;
3098
3099 strcpy(szOldName, PerlDir_mapA(oname));
3100 strcpy(szNewName, PerlDir_mapA(newname));
3101
3102 /* if oname doesn't exist, do nothing */
3103 from_attr = GetFileAttributes(szOldName);
3104 if (from_attr == 0xFFFFFFFF) {
3105 errno = ENOENT;
3106 return -1;
3107 }
3108
3109 /* if newname exists, rename it to a temporary name so that we
3110 * don't delete it in case oname happens to be the same file
3111 * (but perhaps accessed via a different path)
3112 */
3113 to_attr = GetFileAttributes(szNewName);
3114 if (to_attr != 0xFFFFFFFF) {
3115 /* if newname is a directory, we fail
3116 * XXX could overcome this with yet more convoluted logic */
3117 if (to_attr & FILE_ATTRIBUTE_DIRECTORY) {
3118 errno = EACCES;
3119 return -1;
3120 }
3121 tmplen = strlen(szNewName);
3122 strcpy(szTmpName,szNewName);
3123 endname = szTmpName+tmplen;
3124 for (; endname > szTmpName ; --endname) {
3125 if (*endname == '/' || *endname == '\\') {
3126 *endname = '\0';
3127 break;
3128 }
3129 }
3130 if (endname > szTmpName)
3131 endname = strcpy(dname,szTmpName);
3132 else
3133 endname = ".";
3134
3135 /* get a temporary filename in same directory
3136 * XXX is this really the best we can do? */
3137 if (!GetTempFileName((LPCTSTR)endname, "plr", 0, szTmpName)) {
3138 errno = ENOENT;
3139 return -1;
3140 }
3141 DeleteFile(szTmpName);
3142
3143 retval = rename(szNewName, szTmpName);
3144 if (retval != 0) {
3145 errno = EACCES;
3146 return retval;
3147 }
3148 }
3149
3150 /* rename oname to newname */
3151 retval = rename(szOldName, szNewName);
3152
3153 /* if we created a temporary file before ... */
3154 if (endname != Nullch) {
3155 /* ...and rename succeeded, delete temporary file/directory */
3156 if (retval == 0)
3157 DeleteFile(szTmpName);
3158 /* else restore it to what it was */
3159 else
3160 (void)rename(szTmpName, szNewName);
3161 }
3162 return retval;
3163 }
3164}
3165
3166DllExport int
3167win32_setmode(int fd, int mode)
3168{
3169 return setmode(fd, mode);
3170}
3171
3172DllExport int
3173win32_chsize(int fd, Off_t size)
3174{
3175#if defined(WIN64) || defined(USE_LARGE_FILES)
3176 int retval = 0;
3177 Off_t cur, end, extend;
3178
3179 cur = win32_tell(fd);
3180 if (cur < 0)
3181 return -1;
3182 end = win32_lseek(fd, 0, SEEK_END);
3183 if (end < 0)
3184 return -1;
3185 extend = size - end;
3186 if (extend == 0) {
3187 /* do nothing */
3188 }
3189 else if (extend > 0) {
3190 /* must grow the file, padding with nulls */
3191 char b[4096];
3192 int oldmode = win32_setmode(fd, O_BINARY);
3193 size_t count;
3194 memset(b, '\0', sizeof(b));
3195 do {
3196 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend;
3197 count = win32_write(fd, b, count);
3198 if ((int)count < 0) {
3199 retval = -1;
3200 break;
3201 }
3202 } while ((extend -= count) > 0);
3203 win32_setmode(fd, oldmode);
3204 }
3205 else {
3206 /* shrink the file */
3207 win32_lseek(fd, size, SEEK_SET);
3208 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) {
3209 errno = EACCES;
3210 retval = -1;
3211 }
3212 }
3213finish:
3214 win32_lseek(fd, cur, SEEK_SET);
3215 return retval;
3216#else
3217 return chsize(fd, (long)size);
3218#endif
3219}
3220
3221DllExport Off_t
3222win32_lseek(int fd, Off_t offset, int origin)
3223{
3224#if defined(WIN64) || defined(USE_LARGE_FILES)
3225#if defined(__BORLANDC__) /* buk */
3226 LARGE_INTEGER pos;
3227 pos.QuadPart = offset;
3228 pos.LowPart = SetFilePointer(
3229 (HANDLE)_get_osfhandle(fd),
3230 pos.LowPart,
3231 &pos.HighPart,
3232 origin
3233 );
3234 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3235 pos.QuadPart = -1;
3236 }
3237
3238 return pos.QuadPart;
3239#else
3240 return _lseeki64(fd, offset, origin);
3241#endif
3242#else
3243 return lseek(fd, (long)offset, origin);
3244#endif
3245}
3246
3247DllExport Off_t
3248win32_tell(int fd)
3249{
3250#if defined(WIN64) || defined(USE_LARGE_FILES)
3251#if defined(__BORLANDC__) /* buk */
3252 LARGE_INTEGER pos;
3253 pos.QuadPart = 0;
3254 pos.LowPart = SetFilePointer(
3255 (HANDLE)_get_osfhandle(fd),
3256 pos.LowPart,
3257 &pos.HighPart,
3258 FILE_CURRENT
3259 );
3260 if (pos.LowPart == INVALID_SET_FILE_POINTER && GetLastError() != NO_ERROR) {
3261 pos.QuadPart = -1;
3262 }
3263
3264 return pos.QuadPart;
3265 /* return tell(fd); */
3266#else
3267 return _telli64(fd);
3268#endif
3269#else
3270 return tell(fd);
3271#endif
3272}
3273
3274DllExport int
3275win32_open(const char *path, int flag, ...)
3276{
3277 dTHX;
3278 va_list ap;
3279 int pmode;
3280 WCHAR wBuffer[MAX_PATH+1];
3281
3282 va_start(ap, flag);
3283 pmode = va_arg(ap, int);
3284 va_end(ap);
3285
3286 if (stricmp(path, "/dev/null")==0)
3287 path = "NUL";
3288
3289 if (USING_WIDE()) {
3290 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3291 return _wopen(PerlDir_mapW(wBuffer), flag, pmode);
3292 }
3293 return open(PerlDir_mapA(path), flag, pmode);
3294}
3295
3296/* close() that understands socket */
3297extern int my_close(int); /* in win32sck.c */
3298
3299DllExport int
3300win32_close(int fd)
3301{
3302 return my_close(fd);
3303}
3304
3305DllExport int
3306win32_eof(int fd)
3307{
3308 return eof(fd);
3309}
3310
3311DllExport int
3312win32_dup(int fd)
3313{
3314 return dup(fd);
3315}
3316
3317DllExport int
3318win32_dup2(int fd1,int fd2)
3319{
3320 return dup2(fd1,fd2);
3321}
3322
3323#ifdef PERL_MSVCRT_READFIX
3324
3325#define LF 10 /* line feed */
3326#define CR 13 /* carriage return */
3327#define CTRLZ 26 /* ctrl-z means eof for text */
3328#define FOPEN 0x01 /* file handle open */
3329#define FEOFLAG 0x02 /* end of file has been encountered */
3330#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */
3331#define FPIPE 0x08 /* file handle refers to a pipe */
3332#define FAPPEND 0x20 /* file handle opened O_APPEND */
3333#define FDEV 0x40 /* file handle refers to device */
3334#define FTEXT 0x80 /* file handle is in text mode */
3335#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */
3336
3337int __cdecl
3338_fixed_read(int fh, void *buf, unsigned cnt)
3339{
3340 int bytes_read; /* number of bytes read */
3341 char *buffer; /* buffer to read to */
3342 int os_read; /* bytes read on OS call */
3343 char *p, *q; /* pointers into buffer */
3344 char peekchr; /* peek-ahead character */
3345 ULONG filepos; /* file position after seek */
3346 ULONG dosretval; /* o.s. return value */
3347
3348 /* validate handle */
3349 if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) ||
3350 !(_osfile(fh) & FOPEN))
3351 {
3352 /* out of range -- return error */
3353 errno = EBADF;
3354 _doserrno = 0; /* not o.s. error */
3355 return -1;
3356 }
3357
3358 /*
3359 * If lockinitflag is FALSE, assume fd is device
3360 * lockinitflag is set to TRUE by open.
3361 */
3362 if (_pioinfo(fh)->lockinitflag)
3363 EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */
3364
3365 bytes_read = 0; /* nothing read yet */
3366 buffer = (char*)buf;
3367
3368 if (cnt == 0 || (_osfile(fh) & FEOFLAG)) {
3369 /* nothing to read or at EOF, so return 0 read */
3370 goto functionexit;
3371 }
3372
3373 if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) {
3374 /* a pipe/device and pipe lookahead non-empty: read the lookahead
3375 * char */
3376 *buffer++ = _pipech(fh);
3377 ++bytes_read;
3378 --cnt;
3379 _pipech(fh) = LF; /* mark as empty */
3380 }
3381
3382 /* read the data */
3383
3384 if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL))
3385 {
3386 /* ReadFile has reported an error. recognize two special cases.
3387 *
3388 * 1. map ERROR_ACCESS_DENIED to EBADF
3389 *
3390 * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it
3391 * means the handle is a read-handle on a pipe for which
3392 * all write-handles have been closed and all data has been
3393 * read. */
3394
3395 if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) {
3396 /* wrong read/write mode should return EBADF, not EACCES */
3397 errno = EBADF;
3398 _doserrno = dosretval;
3399 bytes_read = -1;
3400 goto functionexit;
3401 }
3402 else if (dosretval == ERROR_BROKEN_PIPE) {
3403 bytes_read = 0;
3404 goto functionexit;
3405 }
3406 else {
3407 bytes_read = -1;
3408 goto functionexit;
3409 }
3410 }
3411
3412 bytes_read += os_read; /* update bytes read */
3413
3414 if (_osfile(fh) & FTEXT) {
3415 /* now must translate CR-LFs to LFs in the buffer */
3416
3417 /* set CRLF flag to indicate LF at beginning of buffer */
3418 /* if ((os_read != 0) && (*(char *)buf == LF)) */
3419 /* _osfile(fh) |= FCRLF; */
3420 /* else */
3421 /* _osfile(fh) &= ~FCRLF; */
3422
3423 _osfile(fh) &= ~FCRLF;
3424
3425 /* convert chars in the buffer: p is src, q is dest */
3426 p = q = (char*)buf;
3427 while (p < (char *)buf + bytes_read) {
3428 if (*p == CTRLZ) {
3429 /* if fh is not a device, set ctrl-z flag */
3430 if (!(_osfile(fh) & FDEV))
3431 _osfile(fh) |= FEOFLAG;
3432 break; /* stop translating */
3433 }
3434 else if (*p != CR)
3435 *q++ = *p++;
3436 else {
3437 /* *p is CR, so must check next char for LF */
3438 if (p < (char *)buf + bytes_read - 1) {
3439 if (*(p+1) == LF) {
3440 p += 2;
3441 *q++ = LF; /* convert CR-LF to LF */
3442 }
3443 else
3444 *q++ = *p++; /* store char normally */
3445 }
3446 else {
3447 /* This is the hard part. We found a CR at end of
3448 buffer. We must peek ahead to see if next char
3449 is an LF. */
3450 ++p;
3451
3452 dosretval = 0;
3453 if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1,
3454 (LPDWORD)&os_read, NULL))
3455 dosretval = GetLastError();
3456
3457 if (dosretval != 0 || os_read == 0) {
3458 /* couldn't read ahead, store CR */
3459 *q++ = CR;
3460 }
3461 else {
3462 /* peekchr now has the extra character -- we now
3463 have several possibilities:
3464 1. disk file and char is not LF; just seek back
3465 and copy CR
3466 2. disk file and char is LF; store LF, don't seek back
3467 3. pipe/device and char is LF; store LF.
3468 4. pipe/device and char isn't LF, store CR and
3469 put char in pipe lookahead buffer. */
3470 if (_osfile(fh) & (FDEV|FPIPE)) {
3471 /* non-seekable device */
3472 if (peekchr == LF)
3473 *q++ = LF;
3474 else {
3475 *q++ = CR;
3476 _pipech(fh) = peekchr;
3477 }
3478 }
3479 else {
3480 /* disk file */
3481 if (peekchr == LF) {
3482 /* nothing read yet; must make some
3483 progress */
3484 *q++ = LF;
3485 /* turn on this flag for tell routine */
3486 _osfile(fh) |= FCRLF;
3487 }
3488 else {
3489 HANDLE osHandle; /* o.s. handle value */
3490 /* seek back */
3491 if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1)
3492 {
3493 if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1)
3494 dosretval = GetLastError();
3495 }
3496 if (peekchr != LF)
3497 *q++ = CR;
3498 }
3499 }
3500 }
3501 }
3502 }
3503 }
3504
3505 /* we now change bytes_read to reflect the true number of chars
3506 in the buffer */
3507 bytes_read = q - (char *)buf;
3508 }
3509
3510functionexit:
3511 if (_pioinfo(fh)->lockinitflag)
3512 LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */
3513
3514 return bytes_read;
3515}
3516
3517#endif /* PERL_MSVCRT_READFIX */
3518
3519DllExport int
3520win32_read(int fd, void *buf, unsigned int cnt)
3521{
3522#ifdef PERL_MSVCRT_READFIX
3523 return _fixed_read(fd, buf, cnt);
3524#else
3525 return read(fd, buf, cnt);
3526#endif
3527}
3528
3529DllExport int
3530win32_write(int fd, const void *buf, unsigned int cnt)
3531{
3532 return write(fd, buf, cnt);
3533}
3534
3535DllExport int
3536win32_mkdir(const char *dir, int mode)
3537{
3538 dTHX;
3539 if (USING_WIDE()) {
3540 WCHAR wBuffer[MAX_PATH+1];
3541 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3542 return _wmkdir(PerlDir_mapW(wBuffer));
3543 }
3544 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */
3545}
3546
3547DllExport int
3548win32_rmdir(const char *dir)
3549{
3550 dTHX;
3551 if (USING_WIDE()) {
3552 WCHAR wBuffer[MAX_PATH+1];
3553 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3554 return _wrmdir(PerlDir_mapW(wBuffer));
3555 }
3556 return rmdir(PerlDir_mapA(dir));
3557}
3558
3559DllExport int
3560win32_chdir(const char *dir)
3561{
3562 dTHX;
3563 if (!dir) {
3564 errno = ENOENT;
3565 return -1;
3566 }
3567 if (USING_WIDE()) {
3568 WCHAR wBuffer[MAX_PATH+1];
3569 A2WHELPER(dir, wBuffer, sizeof(wBuffer));
3570 return _wchdir(wBuffer);
3571 }
3572 return chdir(dir);
3573}
3574
3575DllExport int
3576win32_access(const char *path, int mode)
3577{
3578 dTHX;
3579 if (USING_WIDE()) {
3580 WCHAR wBuffer[MAX_PATH+1];
3581 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3582 return _waccess(PerlDir_mapW(wBuffer), mode);
3583 }
3584 return access(PerlDir_mapA(path), mode);
3585}
3586
3587DllExport int
3588win32_chmod(const char *path, int mode)
3589{
3590 dTHX;
3591 if (USING_WIDE()) {
3592 WCHAR wBuffer[MAX_PATH+1];
3593 A2WHELPER(path, wBuffer, sizeof(wBuffer));
3594 return _wchmod(PerlDir_mapW(wBuffer), mode);
3595 }
3596 return chmod(PerlDir_mapA(path), mode);
3597}
3598
3599
3600static char *
3601create_command_line(char *cname, STRLEN clen, const char * const *args)
3602{
3603 dTHX;
3604 int index, argc;
3605 char *cmd, *ptr;
3606 const char *arg;
3607 STRLEN len = 0;
3608 bool bat_file = FALSE;
3609 bool cmd_shell = FALSE;
3610 bool dumb_shell = FALSE;
3611 bool extra_quotes = FALSE;
3612 bool quote_next = FALSE;
3613
3614 if (!cname)
3615 cname = (char*)args[0];
3616
3617 /* The NT cmd.exe shell has the following peculiarity that needs to be
3618 * worked around. It strips a leading and trailing dquote when any
3619 * of the following is true:
3620 * 1. the /S switch was used
3621 * 2. there are more than two dquotes
3622 * 3. there is a special character from this set: &<>()@^|
3623 * 4. no whitespace characters within the two dquotes
3624 * 5. string between two dquotes isn't an executable file
3625 * To work around this, we always add a leading and trailing dquote
3626 * to the string, if the first argument is either "cmd.exe" or "cmd",
3627 * and there were at least two or more arguments passed to cmd.exe
3628 * (not including switches).
3629 * XXX the above rules (from "cmd /?") don't seem to be applied
3630 * always, making for the convolutions below :-(
3631 */
3632 if (cname) {
3633 if (!clen)
3634 clen = strlen(cname);
3635
3636 if (clen > 4
3637 && (stricmp(&cname[clen-4], ".bat") == 0
3638 || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
3639 {
3640 bat_file = TRUE;
3641 if (!IsWin95())
3642 len += 3;
3643 }
3644 else {
3645 char *exe = strrchr(cname, '/');
3646 char *exe2 = strrchr(cname, '\\');
3647 if (exe2 > exe)
3648 exe = exe2;
3649 if (exe)
3650 ++exe;
3651 else
3652 exe = cname;
3653 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
3654 cmd_shell = TRUE;
3655 len += 3;
3656 }
3657 else if (stricmp(exe, "command.com") == 0
3658 || stricmp(exe, "command") == 0)
3659 {
3660 dumb_shell = TRUE;
3661 }
3662 }
3663 }
3664
3665 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
3666 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3667 STRLEN curlen = strlen(arg);
3668 if (!(arg[0] == '"' && arg[curlen-1] == '"'))
3669 len += 2; /* assume quoting needed (worst case) */
3670 len += curlen + 1;
3671 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg));
3672 }
3673 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n"));
3674
3675 argc = index;
3676 Newx(cmd, len, char);
3677 ptr = cmd;
3678
3679 if (bat_file && !IsWin95()) {
3680 *ptr++ = '"';
3681 extra_quotes = TRUE;
3682 }
3683
3684 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
3685 bool do_quote = 0;
3686 STRLEN curlen = strlen(arg);
3687
3688 /* we want to protect empty arguments and ones with spaces with
3689 * dquotes, but only if they aren't already there */
3690 if (!dumb_shell) {
3691 if (!curlen) {
3692 do_quote = 1;
3693 }
3694 else if (quote_next) {
3695 /* see if it really is multiple arguments pretending to
3696 * be one and force a set of quotes around it */
3697 if (*find_next_space(arg))
3698 do_quote = 1;
3699 }
3700 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
3701 STRLEN i = 0;
3702 while (i < curlen) {
3703 if (isSPACE(arg[i])) {
3704 do_quote = 1;
3705 }
3706 else if (arg[i] == '"') {
3707 do_quote = 0;
3708 break;
3709 }
3710 i++;
3711 }
3712 }
3713 }
3714
3715 if (do_quote)
3716 *ptr++ = '"';
3717
3718 strcpy(ptr, arg);
3719 ptr += curlen;
3720
3721 if (do_quote)
3722 *ptr++ = '"';
3723
3724 if (args[index+1])
3725 *ptr++ = ' ';
3726
3727 if (!extra_quotes
3728 && cmd_shell
3729 && curlen >= 2
3730 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */
3731 && stricmp(arg+curlen-2, "/c") == 0)
3732 {
3733 /* is there a next argument? */
3734 if (args[index+1]) {
3735 /* are there two or more next arguments? */
3736 if (args[index+2]) {
3737 *ptr++ = '"';
3738 extra_quotes = TRUE;
3739 }
3740 else {
3741 /* single argument, force quoting if it has spaces */
3742 quote_next = TRUE;
3743 }
3744 }
3745 }
3746 }
3747
3748 if (extra_quotes)
3749 *ptr++ = '"';
3750
3751 *ptr = '\0';
3752
3753 return cmd;
3754}
3755
3756static char *
3757qualified_path(const char *cmd)
3758{
3759 dTHX;
3760 char *pathstr;
3761 char *fullcmd, *curfullcmd;
3762 STRLEN cmdlen = 0;
3763 int has_slash = 0;
3764
3765 if (!cmd)
3766 return Nullch;
3767 fullcmd = (char*)cmd;
3768 while (*fullcmd) {
3769 if (*fullcmd == '/' || *fullcmd == '\\')
3770 has_slash++;
3771 fullcmd++;
3772 cmdlen++;
3773 }
3774
3775 /* look in PATH */
3776 pathstr = PerlEnv_getenv("PATH");
3777
3778 /* worst case: PATH is a single directory; we need additional space
3779 * to append "/", ".exe" and trailing "\0" */
3780 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char);
3781 curfullcmd = fullcmd;
3782
3783 while (1) {
3784 DWORD res;
3785
3786 /* start by appending the name to the current prefix */
3787 strcpy(curfullcmd, cmd);
3788 curfullcmd += cmdlen;
3789
3790 /* if it doesn't end with '.', or has no extension, try adding
3791 * a trailing .exe first */
3792 if (cmd[cmdlen-1] != '.'
3793 && (cmdlen < 4 || cmd[cmdlen-4] != '.'))
3794 {
3795 strcpy(curfullcmd, ".exe");
3796 res = GetFileAttributes(fullcmd);
3797 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3798 return fullcmd;
3799 *curfullcmd = '\0';
3800 }
3801
3802 /* that failed, try the bare name */
3803 res = GetFileAttributes(fullcmd);
3804 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY))
3805 return fullcmd;
3806
3807 /* quit if no other path exists, or if cmd already has path */
3808 if (!pathstr || !*pathstr || has_slash)
3809 break;
3810
3811 /* skip leading semis */
3812 while (*pathstr == ';')
3813 pathstr++;
3814
3815 /* build a new prefix from scratch */
3816 curfullcmd = fullcmd;
3817 while (*pathstr && *pathstr != ';') {
3818 if (*pathstr == '"') { /* foo;"baz;etc";bar */
3819 pathstr++; /* skip initial '"' */
3820 while (*pathstr && *pathstr != '"') {
3821 *curfullcmd++ = *pathstr++;
3822 }
3823 if (*pathstr)
3824 pathstr++; /* skip trailing '"' */
3825 }
3826 else {
3827 *curfullcmd++ = *pathstr++;
3828 }
3829 }
3830 if (*pathstr)
3831 pathstr++; /* skip trailing semi */
3832 if (curfullcmd > fullcmd /* append a dir separator */
3833 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\')
3834 {
3835 *curfullcmd++ = '\\';
3836 }
3837 }
3838
3839 Safefree(fullcmd);
3840 return Nullch;
3841}
3842
3843/* The following are just place holders.
3844 * Some hosts may provide and environment that the OS is
3845 * not tracking, therefore, these host must provide that
3846 * environment and the current directory to CreateProcess
3847 */
3848
3849DllExport void*
3850win32_get_childenv(void)
3851{
3852 return NULL;
3853}
3854
3855DllExport void
3856win32_free_childenv(void* d)
3857{
3858}
3859
3860DllExport void
3861win32_clearenv(void)
3862{
3863 char *envv = GetEnvironmentStrings();
3864 char *cur = envv;
3865 STRLEN len;
3866 while (*cur) {
3867 char *end = strchr(cur,'=');
3868 if (end && end != cur) {
3869 *end = '\0';
3870 SetEnvironmentVariable(cur, NULL);
3871 *end = '=';
3872 cur = end + strlen(end+1)+2;
3873 }
3874 else if ((len = strlen(cur)))
3875 cur += len+1;
3876 }
3877 FreeEnvironmentStrings(envv);
3878}
3879
3880DllExport char*
3881win32_get_childdir(void)
3882{
3883 dTHX;
3884 char* ptr;
3885 char szfilename[(MAX_PATH+1)*2];
3886 if (USING_WIDE()) {
3887 WCHAR wfilename[MAX_PATH+1];
3888 GetCurrentDirectoryW(MAX_PATH+1, wfilename);
3889 W2AHELPER(wfilename, szfilename, sizeof(szfilename));
3890 }
3891 else {
3892 GetCurrentDirectoryA(MAX_PATH+1, szfilename);
3893 }
3894
3895 Newx(ptr, strlen(szfilename)+1, char);
3896 strcpy(ptr, szfilename);
3897 return ptr;
3898}
3899
3900DllExport void
3901win32_free_childdir(char* d)
3902{
3903 dTHX;
3904 Safefree(d);
3905}
3906
3907
3908/* XXX this needs to be made more compatible with the spawnvp()
3909 * provided by the various RTLs. In particular, searching for
3910 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented.
3911 * This doesn't significantly affect perl itself, because we
3912 * always invoke things using PERL5SHELL if a direct attempt to
3913 * spawn the executable fails.
3914 *
3915 * XXX splitting and rejoining the commandline between do_aspawn()
3916 * and win32_spawnvp() could also be avoided.
3917 */
3918
3919DllExport int
3920win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
3921{
3922#ifdef USE_RTL_SPAWNVP
3923 return spawnvp(mode, cmdname, (char * const *)argv);
3924#else
3925 dTHX;
3926 int ret;
3927 void* env;
3928 char* dir;
3929 child_IO_table tbl;
3930 STARTUPINFO StartupInfo;
3931 PROCESS_INFORMATION ProcessInformation;
3932 DWORD create = 0;
3933 char *cmd;
3934 char *fullcmd = Nullch;
3935 char *cname = (char *)cmdname;
3936 STRLEN clen = 0;
3937
3938 if (cname) {
3939 clen = strlen(cname);
3940 /* if command name contains dquotes, must remove them */
3941 if (strchr(cname, '"')) {
3942 cmd = cname;
3943 Newx(cname,clen+1,char);
3944 clen = 0;
3945 while (*cmd) {
3946 if (*cmd != '"') {
3947 cname[clen] = *cmd;
3948 ++clen;
3949 }
3950 ++cmd;
3951 }
3952 cname[clen] = '\0';
3953 }
3954 }
3955
3956 cmd = create_command_line(cname, clen, argv);
3957
3958 env = PerlEnv_get_childenv();
3959 dir = PerlEnv_get_childdir();
3960
3961 switch(mode) {
3962 case P_NOWAIT: /* asynch + remember result */
3963 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) {
3964 errno = EAGAIN;
3965 ret = -1;
3966 goto RETVAL;
3967 }
3968 /* Create a new process group so we can use GenerateConsoleCtrlEvent()
3969 * in win32_kill()
3970 */
3971 create |= CREATE_NEW_PROCESS_GROUP;
3972 /* FALL THROUGH */
3973
3974 case P_WAIT: /* synchronous execution */
3975 break;
3976 default: /* invalid mode */
3977 errno = EINVAL;
3978 ret = -1;
3979 goto RETVAL;
3980 }
3981 memset(&StartupInfo,0,sizeof(StartupInfo));
3982 StartupInfo.cb = sizeof(StartupInfo);
3983 memset(&tbl,0,sizeof(tbl));
3984 PerlEnv_get_child_IO(&tbl);
3985 StartupInfo.dwFlags = tbl.dwFlags;
3986 StartupInfo.dwX = tbl.dwX;
3987 StartupInfo.dwY = tbl.dwY;
3988 StartupInfo.dwXSize = tbl.dwXSize;
3989 StartupInfo.dwYSize = tbl.dwYSize;
3990 StartupInfo.dwXCountChars = tbl.dwXCountChars;
3991 StartupInfo.dwYCountChars = tbl.dwYCountChars;
3992 StartupInfo.dwFillAttribute = tbl.dwFillAttribute;
3993 StartupInfo.wShowWindow = tbl.wShowWindow;
3994 StartupInfo.hStdInput = tbl.childStdIn;
3995 StartupInfo.hStdOutput = tbl.childStdOut;
3996 StartupInfo.hStdError = tbl.childStdErr;
3997 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
3998 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
3999 StartupInfo.hStdError == INVALID_HANDLE_VALUE)
4000 {
4001 create |= CREATE_NEW_CONSOLE;
4002 }
4003 else {
4004 StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
4005 }
4006 if (w32_use_showwindow) {
4007 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
4008 StartupInfo.wShowWindow = w32_showwindow;
4009 }
4010
4011 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
4012 cname,cmd));
4013RETRY:
4014 if (!CreateProcess(cname, /* search PATH to find executable */
4015 cmd, /* executable, and its arguments */
4016 NULL, /* process attributes */
4017 NULL, /* thread attributes */
4018 TRUE, /* inherit handles */
4019 create, /* creation flags */
4020 (LPVOID)env, /* inherit environment */
4021 dir, /* inherit cwd */
4022 &StartupInfo,
4023 &ProcessInformation))
4024 {
4025 /* initial NULL argument to CreateProcess() does a PATH
4026 * search, but it always first looks in the directory
4027 * where the current process was started, which behavior
4028 * is undesirable for backward compatibility. So we
4029 * jump through our own hoops by picking out the path
4030 * we really want it to use. */
4031 if (!fullcmd) {
4032 fullcmd = qualified_path(cname);
4033 if (fullcmd) {
4034 if (cname != cmdname)
4035 Safefree(cname);
4036 cname = fullcmd;
4037 DEBUG_p(PerlIO_printf(Perl_debug_log,
4038 "Retrying [%s] with same args\n",
4039 cname));
4040 goto RETRY;
4041 }
4042 }
4043 errno = ENOENT;
4044 ret = -1;
4045 goto RETVAL;
4046 }
4047
4048 if (mode == P_NOWAIT) {
4049 /* asynchronous spawn -- store handle, return PID */
4050 ret = (int)ProcessInformation.dwProcessId;
4051 if (IsWin95() && ret < 0)
4052 ret = -ret;
4053
4054 w32_child_handles[w32_num_children] = ProcessInformation.hProcess;
4055 w32_child_pids[w32_num_children] = (DWORD)ret;
4056 ++w32_num_children;
4057 }
4058 else {
4059 DWORD status;
4060 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL);
4061 /* FIXME: if msgwait returned due to message perhaps forward the
4062 "signal" to the process
4063 */
4064 GetExitCodeProcess(ProcessInformation.hProcess, &status);
4065 ret = (int)status;
4066 CloseHandle(ProcessInformation.hProcess);
4067 }
4068
4069 CloseHandle(ProcessInformation.hThread);
4070
4071RETVAL:
4072 PerlEnv_free_childenv(env);
4073 PerlEnv_free_childdir(dir);
4074 Safefree(cmd);
4075 if (cname != cmdname)
4076 Safefree(cname);
4077 return ret;
4078#endif
4079}
4080
4081DllExport int
4082win32_execv(const char *cmdname, const char *const *argv)
4083{
4084#ifdef USE_ITHREADS
4085 dTHX;
4086 /* if this is a pseudo-forked child, we just want to spawn
4087 * the new program, and return */
4088 if (w32_pseudo_id)
4089# ifdef __BORLANDC__
4090 return spawnv(P_WAIT, cmdname, (char *const *)argv);
4091# else
4092 return spawnv(P_WAIT, cmdname, argv);
4093# endif
4094#endif
4095#ifdef __BORLANDC__
4096 return execv(cmdname, (char *const *)argv);
4097#else
4098 return execv(cmdname, argv);
4099#endif
4100}
4101
4102DllExport int
4103win32_execvp(const char *cmdname, const char *const *argv)
4104{
4105#ifdef USE_ITHREADS
4106 dTHX;
4107 /* if this is a pseudo-forked child, we just want to spawn
4108 * the new program, and return */
4109 if (w32_pseudo_id) {
4110 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv);
4111 if (status != -1) {
4112 my_exit(status);
4113 return 0;
4114 }
4115 else
4116 return status;
4117 }
4118#endif
4119#ifdef __BORLANDC__
4120 return execvp(cmdname, (char *const *)argv);
4121#else
4122 return execvp(cmdname, argv);
4123#endif
4124}
4125
4126DllExport void
4127win32_perror(const char *str)
4128{
4129 perror(str);
4130}
4131
4132DllExport void
4133win32_setbuf(FILE *pf, char *buf)
4134{
4135 setbuf(pf, buf);
4136}
4137
4138DllExport int
4139win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
4140{
4141 return setvbuf(pf, buf, type, size);
4142}
4143
4144DllExport int
4145win32_flushall(void)
4146{
4147 return flushall();
4148}
4149
4150DllExport int
4151win32_fcloseall(void)
4152{
4153 return fcloseall();
4154}
4155
4156DllExport char*
4157win32_fgets(char *s, int n, FILE *pf)
4158{
4159 return fgets(s, n, pf);
4160}
4161
4162DllExport char*
4163win32_gets(char *s)
4164{
4165 return gets(s);
4166}
4167
4168DllExport int
4169win32_fgetc(FILE *pf)
4170{
4171 return fgetc(pf);
4172}
4173
4174DllExport int
4175win32_putc(int c, FILE *pf)
4176{
4177 return putc(c,pf);
4178}
4179
4180DllExport int
4181win32_puts(const char *s)
4182{
4183 return puts(s);
4184}
4185
4186DllExport int
4187win32_getchar(void)
4188{
4189 return getchar();
4190}
4191
4192DllExport int
4193win32_putchar(int c)
4194{
4195 return putchar(c);
4196}
4197
4198#ifdef MYMALLOC
4199
4200#ifndef USE_PERL_SBRK
4201
4202static char *committed = NULL; /* XXX threadead */
4203static char *base = NULL; /* XXX threadead */
4204static char *reserved = NULL; /* XXX threadead */
4205static char *brk = NULL; /* XXX threadead */
4206static DWORD pagesize = 0; /* XXX threadead */
4207
4208void *
4209sbrk(ptrdiff_t need)
4210{
4211 void *result;
4212 if (!pagesize)
4213 {SYSTEM_INFO info;
4214 GetSystemInfo(&info);
4215 /* Pretend page size is larger so we don't perpetually
4216 * call the OS to commit just one page ...
4217 */
4218 pagesize = info.dwPageSize << 3;
4219 }
4220 if (brk+need >= reserved)
4221 {
4222 DWORD size = brk+need-reserved;
4223 char *addr;
4224 char *prev_committed = NULL;
4225 if (committed && reserved && committed < reserved)
4226 {
4227 /* Commit last of previous chunk cannot span allocations */
4228 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE);
4229 if (addr)
4230 {
4231 /* Remember where we committed from in case we want to decommit later */
4232 prev_committed = committed;
4233 committed = reserved;
4234 }
4235 }
4236 /* Reserve some (more) space
4237 * Contiguous blocks give us greater efficiency, so reserve big blocks -
4238 * this is only address space not memory...
4239 * Note this is a little sneaky, 1st call passes NULL as reserved
4240 * so lets system choose where we start, subsequent calls pass
4241 * the old end address so ask for a contiguous block
4242 */
4243sbrk_reserve:
4244 if (size < 64*1024*1024)
4245 size = 64*1024*1024;
4246 size = ((size + pagesize - 1) / pagesize) * pagesize;
4247 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS);
4248 if (addr)
4249 {
4250 reserved = addr+size;
4251 if (!base)
4252 base = addr;
4253 if (!committed)
4254 committed = base;
4255 if (!brk)
4256 brk = committed;
4257 }
4258 else if (reserved)
4259 {
4260 /* The existing block could not be extended far enough, so decommit
4261 * anything that was just committed above and start anew */
4262 if (prev_committed)
4263 {
4264 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT))
4265 return (void *) -1;
4266 }
4267 reserved = base = committed = brk = NULL;
4268 size = need;
4269 goto sbrk_reserve;
4270 }
4271 else
4272 {
4273 return (void *) -1;
4274 }
4275 }
4276 result = brk;
4277 brk += need;
4278 if (brk > committed)
4279 {
4280 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize;
4281 char *addr;
4282 if (committed+size > reserved)
4283 size = reserved-committed;
4284 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE);
4285 if (addr)
4286 committed += size;
4287 else
4288 return (void *) -1;
4289 }
4290 return result;
4291}
4292
4293#endif
4294#endif
4295
4296DllExport void*
4297win32_malloc(size_t size)
4298{
4299 return malloc(size);
4300}
4301
4302DllExport void*
4303win32_calloc(size_t numitems, size_t size)
4304{
4305 return calloc(numitems,size);
4306}
4307
4308DllExport void*
4309win32_realloc(void *block, size_t size)
4310{
4311 return realloc(block,size);
4312}
4313
4314DllExport void
4315win32_free(void *block)
4316{
4317 free(block);
4318}
4319
4320
4321DllExport int
4322win32_open_osfhandle(intptr_t handle, int flags)
4323{
4324#ifdef USE_FIXED_OSFHANDLE
4325 if (IsWin95())
4326 return my_open_osfhandle(handle, flags);
4327#endif
4328 return _open_osfhandle(handle, flags);
4329}
4330
4331DllExport intptr_t
4332win32_get_osfhandle(int fd)
4333{
4334 return (intptr_t)_get_osfhandle(fd);
4335}
4336
4337DllExport FILE *
4338win32_fdupopen(FILE *pf)
4339{
4340 FILE* pfdup;
4341 fpos_t pos;
4342 char mode[3];
4343 int fileno = win32_dup(win32_fileno(pf));
4344
4345 /* open the file in the same mode */
4346#ifdef __BORLANDC__
4347 if((pf)->flags & _F_READ) {
4348 mode[0] = 'r';
4349 mode[1] = 0;
4350 }
4351 else if((pf)->flags & _F_WRIT) {
4352 mode[0] = 'a';
4353 mode[1] = 0;
4354 }
4355 else if((pf)->flags & _F_RDWR) {
4356 mode[0] = 'r';
4357 mode[1] = '+';
4358 mode[2] = 0;
4359 }
4360#else
4361 if((pf)->_flag & _IOREAD) {
4362 mode[0] = 'r';
4363 mode[1] = 0;
4364 }
4365 else if((pf)->_flag & _IOWRT) {
4366 mode[0] = 'a';
4367 mode[1] = 0;
4368 }
4369 else if((pf)->_flag & _IORW) {
4370 mode[0] = 'r';
4371 mode[1] = '+';
4372 mode[2] = 0;
4373 }
4374#endif
4375
4376 /* it appears that the binmode is attached to the
4377 * file descriptor so binmode files will be handled
4378 * correctly
4379 */
4380 pfdup = win32_fdopen(fileno, mode);
4381
4382 /* move the file pointer to the same position */
4383 if (!fgetpos(pf, &pos)) {
4384 fsetpos(pfdup, &pos);
4385 }
4386 return pfdup;
4387}
4388
4389DllExport void*
4390win32_dynaload(const char* filename)
4391{
4392 dTHX;
4393 HMODULE hModule;
4394 char buf[MAX_PATH+1];
4395 char *first;
4396
4397 /* LoadLibrary() doesn't recognize forward slashes correctly,
4398 * so turn 'em back. */
4399 first = strchr(filename, '/');
4400 if (first) {
4401 STRLEN len = strlen(filename);
4402 if (len <= MAX_PATH) {
4403 strcpy(buf, filename);
4404 filename = &buf[first - filename];
4405 while (*filename) {
4406 if (*filename == '/')
4407 *(char*)filename = '\\';
4408 ++filename;
4409 }
4410 filename = buf;
4411 }
4412 }
4413 if (USING_WIDE()) {
4414 WCHAR wfilename[MAX_PATH+1];
4415 A2WHELPER(filename, wfilename, sizeof(wfilename));
4416 hModule = LoadLibraryExW(PerlDir_mapW(wfilename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4417 }
4418 else {
4419 hModule = LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH);
4420 }
4421 return hModule;
4422}
4423
4424/*
4425 * Extras.
4426 */
4427
4428static
4429XS(w32_SetChildShowWindow)
4430{
4431 dXSARGS;
4432 BOOL use_showwindow = w32_use_showwindow;
4433 /* use "unsigned short" because Perl has redefined "WORD" */
4434 unsigned short showwindow = w32_showwindow;
4435
4436 if (items > 1)
4437 Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
4438
4439 if (items == 0 || !SvOK(ST(0)))
4440 w32_use_showwindow = FALSE;
4441 else {
4442 w32_use_showwindow = TRUE;
4443 w32_showwindow = (unsigned short)SvIV(ST(0));
4444 }
4445
4446 EXTEND(SP, 1);
4447 if (use_showwindow)
4448 ST(0) = sv_2mortal(newSViv(showwindow));
4449 else
4450 ST(0) = &PL_sv_undef;
4451 XSRETURN(1);
4452}
4453
4454static
4455XS(w32_GetCwd)
4456{
4457 dXSARGS;
4458 /* Make the host for current directory */
4459 char* ptr = PerlEnv_get_childdir();
4460 /*
4461 * If ptr != Nullch
4462 * then it worked, set PV valid,
4463 * else return 'undef'
4464 */
4465 if (ptr) {
4466 SV *sv = sv_newmortal();
4467 sv_setpv(sv, ptr);
4468 PerlEnv_free_childdir(ptr);
4469
4470#ifndef INCOMPLETE_TAINTS
4471 SvTAINTED_on(sv);
4472#endif
4473
4474 EXTEND(SP,1);
4475 SvPOK_on(sv);
4476 ST(0) = sv;
4477 XSRETURN(1);
4478 }
4479 XSRETURN_UNDEF;
4480}
4481
4482static
4483XS(w32_SetCwd)
4484{
4485 dXSARGS;
4486 if (items != 1)
4487 Perl_croak(aTHX_ "usage: Win32::SetCurrentDirectory($cwd)");
4488 if (!PerlDir_chdir(SvPV_nolen(ST(0))))
4489 XSRETURN_YES;
4490
4491 XSRETURN_NO;
4492}
4493
4494static
4495XS(w32_GetNextAvailDrive)
4496{
4497 dXSARGS;
4498 char ix = 'C';
4499 char root[] = "_:\\";
4500
4501 EXTEND(SP,1);
4502 while (ix <= 'Z') {
4503 root[0] = ix++;
4504 if (GetDriveType(root) == 1) {
4505 root[2] = '\0';
4506 XSRETURN_PV(root);
4507 }
4508 }
4509 XSRETURN_UNDEF;
4510}
4511
4512static
4513XS(w32_GetLastError)
4514{
4515 dXSARGS;
4516 EXTEND(SP,1);
4517 XSRETURN_IV(GetLastError());
4518}
4519
4520static
4521XS(w32_SetLastError)
4522{
4523 dXSARGS;
4524 if (items != 1)
4525 Perl_croak(aTHX_ "usage: Win32::SetLastError($error)");
4526 SetLastError(SvIV(ST(0)));
4527 XSRETURN_EMPTY;
4528}
4529
4530static
4531XS(w32_LoginName)
4532{
4533 dXSARGS;
4534 char *name = w32_getlogin_buffer;
4535 DWORD size = sizeof(w32_getlogin_buffer);
4536 EXTEND(SP,1);
4537 if (GetUserName(name,&size)) {
4538 /* size includes NULL */
4539 ST(0) = sv_2mortal(newSVpvn(name,size-1));
4540 XSRETURN(1);
4541 }
4542 XSRETURN_UNDEF;
4543}
4544
4545static
4546XS(w32_NodeName)
4547{
4548 dXSARGS;
4549 char name[MAX_COMPUTERNAME_LENGTH+1];
4550 DWORD size = sizeof(name);
4551 EXTEND(SP,1);
4552 if (GetComputerName(name,&size)) {
4553 /* size does NOT include NULL :-( */
4554 ST(0) = sv_2mortal(newSVpvn(name,size));
4555 XSRETURN(1);
4556 }
4557 XSRETURN_UNDEF;
4558}
4559
4560
4561static
4562XS(w32_DomainName)
4563{
4564 dXSARGS;
4565 HINSTANCE hNetApi32 = LoadLibrary("netapi32.dll");
4566 DWORD (__stdcall *pfnNetApiBufferFree)(LPVOID Buffer);
4567 DWORD (__stdcall *pfnNetWkstaGetInfo)(LPWSTR servername, DWORD level,
4568 void *bufptr);
4569
4570 if (hNetApi32) {
4571 pfnNetApiBufferFree = (DWORD (__stdcall *)(void *))
4572 GetProcAddress(hNetApi32, "NetApiBufferFree");
4573 pfnNetWkstaGetInfo = (DWORD (__stdcall *)(LPWSTR, DWORD, void *))
4574 GetProcAddress(hNetApi32, "NetWkstaGetInfo");
4575 }
4576 EXTEND(SP,1);
4577 if (hNetApi32 && pfnNetWkstaGetInfo && pfnNetApiBufferFree) {
4578 /* this way is more reliable, in case user has a local account. */
4579 char dname[256];
4580 DWORD dnamelen = sizeof(dname);
4581 struct {
4582 DWORD wki100_platform_id;
4583 LPWSTR wki100_computername;
4584 LPWSTR wki100_langroup;
4585 DWORD wki100_ver_major;
4586 DWORD wki100_ver_minor;
4587 } *pwi;
4588 /* NERR_Success *is* 0*/
4589 if (0 == pfnNetWkstaGetInfo(NULL, 100, &pwi)) {
4590 if (pwi->wki100_langroup && *(pwi->wki100_langroup)) {
4591 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup,
4592 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4593 }
4594 else {
4595 WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername,
4596 -1, (LPSTR)dname, dnamelen, NULL, NULL);
4597 }
4598 pfnNetApiBufferFree(pwi);
4599 FreeLibrary(hNetApi32);
4600 XSRETURN_PV(dname);
4601 }
4602 FreeLibrary(hNetApi32);
4603 }
4604 else {
4605 /* Win95 doesn't have NetWksta*(), so do it the old way */
4606 char name[256];
4607 DWORD size = sizeof(name);
4608 if (hNetApi32)
4609 FreeLibrary(hNetApi32);
4610 if (GetUserName(name,&size)) {
4611 char sid[ONE_K_BUFSIZE];
4612 DWORD sidlen = sizeof(sid);
4613 char dname[256];
4614 DWORD dnamelen = sizeof(dname);
4615 SID_NAME_USE snu;
4616 if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen,
4617 dname, &dnamelen, &snu)) {
4618 XSRETURN_PV(dname); /* all that for this */
4619 }
4620 }
4621 }
4622 XSRETURN_UNDEF;
4623}
4624
4625static
4626XS(w32_FsType)
4627{
4628 dXSARGS;
4629 char fsname[256];
4630 DWORD flags, filecomplen;
4631 if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
4632 &flags, fsname, sizeof(fsname))) {
4633 if (GIMME_V == G_ARRAY) {
4634 XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname))));
4635 XPUSHs(sv_2mortal(newSViv(flags)));
4636 XPUSHs(sv_2mortal(newSViv(filecomplen)));
4637 PUTBACK;
4638 return;
4639 }
4640 EXTEND(SP,1);
4641 XSRETURN_PV(fsname);
4642 }
4643 XSRETURN_EMPTY;
4644}
4645
4646static
4647XS(w32_GetOSVersion)
4648{
4649 dXSARGS;
4650 /* Use explicit struct definition because wSuiteMask and
4651 * wProductType are not defined in the VC++ 6.0 headers.
4652 * WORD type has been replaced by unsigned short because
4653 * WORD is already used by Perl itself.
4654 */
4655 struct {
4656 DWORD dwOSVersionInfoSize;
4657 DWORD dwMajorVersion;
4658 DWORD dwMinorVersion;
4659 DWORD dwBuildNumber;
4660 DWORD dwPlatformId;
4661 CHAR szCSDVersion[128];
4662 unsigned short wServicePackMajor;
4663 unsigned short wServicePackMinor;
4664 unsigned short wSuiteMask;
4665 BYTE wProductType;
4666 BYTE wReserved;
4667 } osver;
4668 BOOL bEx = TRUE;
4669
4670 if (USING_WIDE()) {
4671 struct {
4672 DWORD dwOSVersionInfoSize;
4673 DWORD dwMajorVersion;
4674 DWORD dwMinorVersion;
4675 DWORD dwBuildNumber;
4676 DWORD dwPlatformId;
4677 WCHAR szCSDVersion[128];
4678 unsigned short wServicePackMajor;
4679 unsigned short wServicePackMinor;
4680 unsigned short wSuiteMask;
4681 BYTE wProductType;
4682 BYTE wReserved;
4683 } osverw;
4684 char szCSDVersion[sizeof(osverw.szCSDVersion)];
4685 osverw.dwOSVersionInfoSize = sizeof(osverw);
4686 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4687 bEx = FALSE;
4688 osverw.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
4689 if (!GetVersionExW((OSVERSIONINFOW*)&osverw)) {
4690 XSRETURN_EMPTY;
4691 }
4692 }
4693 if (GIMME_V == G_SCALAR) {
4694 XSRETURN_IV(osverw.dwPlatformId);
4695 }
4696 W2AHELPER(osverw.szCSDVersion, szCSDVersion, sizeof(szCSDVersion));
4697 XPUSHs(newSVpvn(szCSDVersion, strlen(szCSDVersion)));
4698 osver.dwMajorVersion = osverw.dwMajorVersion;
4699 osver.dwMinorVersion = osverw.dwMinorVersion;
4700 osver.dwBuildNumber = osverw.dwBuildNumber;
4701 osver.dwPlatformId = osverw.dwPlatformId;
4702 osver.wServicePackMajor = osverw.wServicePackMajor;
4703 osver.wServicePackMinor = osverw.wServicePackMinor;
4704 osver.wSuiteMask = osverw.wSuiteMask;
4705 osver.wProductType = osverw.wProductType;
4706 }
4707 else {
4708 osver.dwOSVersionInfoSize = sizeof(osver);
4709 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4710 bEx = FALSE;
4711 osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
4712 if (!GetVersionExA((OSVERSIONINFOA*)&osver)) {
4713 XSRETURN_EMPTY;
4714 }
4715 }
4716 if (GIMME_V == G_SCALAR) {
4717 XSRETURN_IV(osver.dwPlatformId);
4718 }
4719 XPUSHs(newSVpvn(osver.szCSDVersion, strlen(osver.szCSDVersion)));
4720 }
4721 XPUSHs(newSViv(osver.dwMajorVersion));
4722 XPUSHs(newSViv(osver.dwMinorVersion));
4723 XPUSHs(newSViv(osver.dwBuildNumber));
4724 XPUSHs(newSViv(osver.dwPlatformId));
4725 if (bEx) {
4726 XPUSHs(newSViv(osver.wServicePackMajor));
4727 XPUSHs(newSViv(osver.wServicePackMinor));
4728 XPUSHs(newSViv(osver.wSuiteMask));
4729 XPUSHs(newSViv(osver.wProductType));
4730 }
4731 PUTBACK;
4732}
4733
4734static
4735XS(w32_IsWinNT)
4736{
4737 dXSARGS;
4738 EXTEND(SP,1);
4739 XSRETURN_IV(IsWinNT());
4740}
4741
4742static
4743XS(w32_IsWin95)
4744{
4745 dXSARGS;
4746 EXTEND(SP,1);
4747 XSRETURN_IV(IsWin95());
4748}
4749
4750static
4751XS(w32_FormatMessage)
4752{
4753 dXSARGS;
4754 DWORD source = 0;
4755 char msgbuf[ONE_K_BUFSIZE];
4756
4757 if (items != 1)
4758 Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)");
4759
4760 if (USING_WIDE()) {
4761 WCHAR wmsgbuf[ONE_K_BUFSIZE];
4762 if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
4763 &source, SvIV(ST(0)), 0,
4764 wmsgbuf, ONE_K_BUFSIZE-1, NULL))
4765 {
4766 W2AHELPER(wmsgbuf, msgbuf, sizeof(msgbuf));
4767 XSRETURN_PV(msgbuf);
4768 }
4769 }
4770 else {
4771 if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
4772 &source, SvIV(ST(0)), 0,
4773 msgbuf, sizeof(msgbuf)-1, NULL))
4774 XSRETURN_PV(msgbuf);
4775 }
4776
4777 XSRETURN_UNDEF;
4778}
4779
4780static
4781XS(w32_Spawn)
4782{
4783 dXSARGS;
4784 char *cmd, *args;
4785 void *env;
4786 char *dir;
4787 PROCESS_INFORMATION stProcInfo;
4788 STARTUPINFO stStartInfo;
4789 BOOL bSuccess = FALSE;
4790
4791 if (items != 3)
4792 Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)");
4793
4794 cmd = SvPV_nolen(ST(0));
4795 args = SvPV_nolen(ST(1));
4796
4797 env = PerlEnv_get_childenv();
4798 dir = PerlEnv_get_childdir();
4799
4800 memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
4801 stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
4802 stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
4803 stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
4804
4805 if (CreateProcess(
4806 cmd, /* Image path */
4807 args, /* Arguments for command line */
4808 NULL, /* Default process security */
4809 NULL, /* Default thread security */
4810 FALSE, /* Must be TRUE to use std handles */
4811 NORMAL_PRIORITY_CLASS, /* No special scheduling */
4812 env, /* Inherit our environment block */
4813 dir, /* Inherit our currrent directory */
4814 &stStartInfo, /* -> Startup info */
4815 &stProcInfo)) /* <- Process info (if OK) */
4816 {
4817 int pid = (int)stProcInfo.dwProcessId;
4818 if (IsWin95() && pid < 0)
4819 pid = -pid;
4820 sv_setiv(ST(2), pid);
4821 CloseHandle(stProcInfo.hThread);/* library source code does this. */
4822 bSuccess = TRUE;
4823 }
4824 PerlEnv_free_childenv(env);
4825 PerlEnv_free_childdir(dir);
4826 XSRETURN_IV(bSuccess);
4827}
4828
4829static
4830XS(w32_GetTickCount)
4831{
4832 dXSARGS;
4833 DWORD msec = GetTickCount();
4834 EXTEND(SP,1);
4835 if ((IV)msec > 0)
4836 XSRETURN_IV(msec);
4837 XSRETURN_NV(msec);
4838}
4839
4840static
4841XS(w32_GetShortPathName)
4842{
4843 dXSARGS;
4844 SV *shortpath;
4845 DWORD len;
4846
4847 if (items != 1)
4848 Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)");
4849
4850 shortpath = sv_mortalcopy(ST(0));
4851 SvUPGRADE(shortpath, SVt_PV);
4852 if (!SvPVX(shortpath) || !SvLEN(shortpath))
4853 XSRETURN_UNDEF;
4854
4855 /* src == target is allowed */
4856 do {
4857 len = GetShortPathName(SvPVX(shortpath),
4858 SvPVX(shortpath),
4859 SvLEN(shortpath));
4860 } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
4861 if (len) {
4862 SvCUR_set(shortpath,len);
4863 *SvEND(shortpath) = '\0';
4864 ST(0) = shortpath;
4865 XSRETURN(1);
4866 }
4867 XSRETURN_UNDEF;
4868}
4869
4870static
4871XS(w32_GetFullPathName)
4872{
4873 dXSARGS;
4874 SV *filename;
4875 SV *fullpath;
4876 char *filepart;
4877 DWORD len;
4878 STRLEN filename_len;
4879 char *filename_p;
4880
4881 if (items != 1)
4882 Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)");
4883
4884 filename = ST(0);
4885 filename_p = SvPV(filename, filename_len);
4886 fullpath = sv_2mortal(newSVpvn(filename_p, filename_len));
4887 if (!SvPVX(fullpath) || !SvLEN(fullpath))
4888 XSRETURN_UNDEF;
4889
4890 do {
4891 len = GetFullPathName(SvPVX(filename),
4892 SvLEN(fullpath),
4893 SvPVX(fullpath),
4894 &filepart);
4895 } while (len >= SvLEN(fullpath) && sv_grow(fullpath,len+1));
4896 if (len) {
4897 if (GIMME_V == G_ARRAY) {
4898 EXTEND(SP,1);
4899 if (filepart) {
4900 XST_mPV(1,filepart);
4901 len = filepart - SvPVX(fullpath);
4902 }
4903 else {
4904 XST_mPVN(1,"",0);
4905 }
4906 items = 2;
4907 }
4908 SvCUR_set(fullpath,len);
4909 *SvEND(fullpath) = '\0';
4910 ST(0) = fullpath;
4911 XSRETURN(items);
4912 }
4913 XSRETURN_EMPTY;
4914}
4915
4916static
4917XS(w32_GetLongPathName)
4918{
4919 dXSARGS;
4920 SV *path;
4921 char tmpbuf[MAX_PATH+1];
4922 char *pathstr;
4923 STRLEN len;
4924
4925 if (items != 1)
4926 Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)");
4927
4928 path = ST(0);
4929 pathstr = SvPV(path,len);
4930 strcpy(tmpbuf, pathstr);
4931 pathstr = win32_longpath(tmpbuf);
4932 if (pathstr) {
4933 ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr)));
4934 XSRETURN(1);
4935 }
4936 XSRETURN_EMPTY;
4937}
4938
4939static
4940XS(w32_Sleep)
4941{
4942 dXSARGS;
4943 if (items != 1)
4944 Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)");
4945 Sleep(SvIV(ST(0)));
4946 XSRETURN_YES;
4947}
4948
4949static
4950XS(w32_CopyFile)
4951{
4952 dXSARGS;
4953 BOOL bResult;
4954 if (items != 3)
4955 Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)");
4956 if (USING_WIDE()) {
4957 WCHAR wSourceFile[MAX_PATH+1];
4958 WCHAR wDestFile[MAX_PATH+1];
4959 A2WHELPER(SvPV_nolen(ST(0)), wSourceFile, sizeof(wSourceFile));
4960 wcscpy(wSourceFile, PerlDir_mapW(wSourceFile));
4961 A2WHELPER(SvPV_nolen(ST(1)), wDestFile, sizeof(wDestFile));
4962 bResult = CopyFileW(wSourceFile, PerlDir_mapW(wDestFile), !SvTRUE(ST(2)));
4963 }
4964 else {
4965 char szSourceFile[MAX_PATH+1];
4966 strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0))));
4967 bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2)));
4968 }
4969
4970 if (bResult)
4971 XSRETURN_YES;
4972 XSRETURN_NO;
4973}
4974
4975void
4976Perl_init_os_extras(void)
4977{
4978 dTHX;
4979 char *file = __FILE__;
4980 dXSUB_SYS;
4981
4982 /* these names are Activeware compatible */
4983 newXS("Win32::GetCwd", w32_GetCwd, file);
4984 newXS("Win32::SetCwd", w32_SetCwd, file);
4985 newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
4986 newXS("Win32::GetLastError", w32_GetLastError, file);
4987 newXS("Win32::SetLastError", w32_SetLastError, file);
4988 newXS("Win32::LoginName", w32_LoginName, file);
4989 newXS("Win32::NodeName", w32_NodeName, file);
4990 newXS("Win32::DomainName", w32_DomainName, file);
4991 newXS("Win32::FsType", w32_FsType, file);
4992 newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
4993 newXS("Win32::IsWinNT", w32_IsWinNT, file);
4994 newXS("Win32::IsWin95", w32_IsWin95, file);
4995 newXS("Win32::FormatMessage", w32_FormatMessage, file);
4996 newXS("Win32::Spawn", w32_Spawn, file);
4997 newXS("Win32::GetTickCount", w32_GetTickCount, file);
4998 newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
4999 newXS("Win32::GetFullPathName", w32_GetFullPathName, file);
5000 newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
5001 newXS("Win32::CopyFile", w32_CopyFile, file);
5002 newXS("Win32::Sleep", w32_Sleep, file);
5003 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
5004
5005 /* XXX Bloat Alert! The following Activeware preloads really
5006 * ought to be part of Win32::Sys::*, so they're not included
5007 * here.
5008 */
5009 /* LookupAccountName
5010 * LookupAccountSID
5011 * InitiateSystemShutdown
5012 * AbortSystemShutdown
5013 * ExpandEnvrironmentStrings
5014 */
5015}
5016
5017void *
5018win32_signal_context(void)
5019{
5020 dTHX;
5021#ifdef MULTIPLICITY
5022 if (!my_perl) {
5023 my_perl = PL_curinterp;
5024 PERL_SET_THX(my_perl);
5025 }
5026 return my_perl;
5027#else
5028#ifdef USE_5005THREADS
5029 return aTHX;
5030#else
5031 return PL_curinterp;
5032#endif
5033#endif
5034}
5035
5036
5037BOOL WINAPI
5038win32_ctrlhandler(DWORD dwCtrlType)
5039{
5040#ifdef MULTIPLICITY
5041 dTHXa(PERL_GET_SIG_CONTEXT);
5042
5043 if (!my_perl)
5044 return FALSE;
5045#else
5046#ifdef USE_5005THREADS
5047 dTHX;
5048#endif
5049#endif
5050
5051 switch(dwCtrlType) {
5052 case CTRL_CLOSE_EVENT:
5053 /* A signal that the system sends to all processes attached to a console when
5054 the user closes the console (either by choosing the Close command from the
5055 console window's System menu, or by choosing the End Task command from the
5056 Task List
5057 */
5058 if (do_raise(aTHX_ 1)) /* SIGHUP */
5059 sig_terminate(aTHX_ 1);
5060 return TRUE;
5061
5062 case CTRL_C_EVENT:
5063 /* A CTRL+c signal was received */
5064 if (do_raise(aTHX_ SIGINT))
5065 sig_terminate(aTHX_ SIGINT);
5066 return TRUE;
5067
5068 case CTRL_BREAK_EVENT:
5069 /* A CTRL+BREAK signal was received */
5070 if (do_raise(aTHX_ SIGBREAK))
5071 sig_terminate(aTHX_ SIGBREAK);
5072 return TRUE;
5073
5074 case CTRL_LOGOFF_EVENT:
5075 /* A signal that the system sends to all console processes when a user is logging
5076 off. This signal does not indicate which user is logging off, so no
5077 assumptions can be made.
5078 */
5079 break;
5080 case CTRL_SHUTDOWN_EVENT:
5081 /* A signal that the system sends to all console processes when the system is
5082 shutting down.
5083 */
5084 if (do_raise(aTHX_ SIGTERM))
5085 sig_terminate(aTHX_ SIGTERM);
5086 return TRUE;
5087 default:
5088 break;
5089 }
5090 return FALSE;
5091}
5092
5093
5094void
5095Perl_win32_init(int *argcp, char ***argvp)
5096{
5097 /* Disable floating point errors, Perl will trap the ones we
5098 * care about. VC++ RTL defaults to switching these off
5099 * already, but the Borland RTL doesn't. Since we don't
5100 * want to be at the vendor's whim on the default, we set
5101 * it explicitly here.
5102 */
5103#if !defined(_ALPHA_) && !defined(__GNUC__)
5104 _control87(MCW_EM, MCW_EM);
5105#endif
5106 MALLOC_INIT;
5107}
5108
5109void
5110Perl_win32_term(void)
5111{
5112 OP_REFCNT_TERM;
5113 MALLOC_TERM;
5114}
5115
5116void
5117win32_get_child_IO(child_IO_table* ptbl)
5118{
5119 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE);
5120 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE);
5121 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE);
5122}
5123
5124Sighandler_t
5125win32_signal(int sig, Sighandler_t subcode)
5126{
5127 dTHX;
5128 if (sig < SIG_SIZE) {
5129 int save_errno = errno;
5130 Sighandler_t result = signal(sig, subcode);
5131 if (result == SIG_ERR) {
5132 result = w32_sighandler[sig];
5133 errno = save_errno;
5134 }
5135 w32_sighandler[sig] = subcode;
5136 return result;
5137 }
5138 else {
5139 errno = EINVAL;
5140 return SIG_ERR;
5141 }
5142}
5143
5144
5145#ifdef HAVE_INTERP_INTERN
5146
5147
5148static void
5149win32_csighandler(int sig)
5150{
5151#if 0
5152 dTHXa(PERL_GET_SIG_CONTEXT);
5153 Perl_warn(aTHX_ "Got signal %d",sig);
5154#endif
5155 /* Does nothing */
5156}
5157
5158void
5159Perl_sys_intern_init(pTHX)
5160{
5161 int i;
5162 w32_perlshell_tokens = Nullch;
5163 w32_perlshell_vec = (char**)NULL;
5164 w32_perlshell_items = 0;
5165 w32_fdpid = newAV();
5166 Newx(w32_children, 1, child_tab);
5167 w32_num_children = 0;
5168# ifdef USE_ITHREADS
5169 w32_pseudo_id = 0;
5170 Newx(w32_pseudo_children, 1, child_tab);
5171 w32_num_pseudo_children = 0;
5172# endif
5173 w32_init_socktype = 0;
5174 w32_timerid = 0;
5175 w32_poll_count = 0;
5176 for (i=0; i < SIG_SIZE; i++) {
5177 w32_sighandler[i] = SIG_DFL;
5178 }
5179# ifdef MULTIPLICTY
5180 if (my_perl == PL_curinterp) {
5181# else
5182 {
5183# endif
5184 /* Force C runtime signal stuff to set its console handler */
5185 signal(SIGINT,win32_csighandler);
5186 signal(SIGBREAK,win32_csighandler);
5187 /* Push our handler on top */
5188 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE);
5189 }
5190}
5191
5192void
5193Perl_sys_intern_clear(pTHX)
5194{
5195 Safefree(w32_perlshell_tokens);
5196 Safefree(w32_perlshell_vec);
5197 /* NOTE: w32_fdpid is freed by sv_clean_all() */
5198 Safefree(w32_children);
5199 if (w32_timerid) {
5200 KillTimer(NULL,w32_timerid);
5201 w32_timerid=0;
5202 }
5203# ifdef MULTIPLICITY
5204 if (my_perl == PL_curinterp) {
5205# else
5206 {
5207# endif
5208 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE);
5209 }
5210# ifdef USE_ITHREADS
5211 Safefree(w32_pseudo_children);
5212# endif
5213}
5214
5215# ifdef USE_ITHREADS
5216
5217void
5218Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst)
5219{
5220 dst->perlshell_tokens = Nullch;
5221 dst->perlshell_vec = (char**)NULL;
5222 dst->perlshell_items = 0;
5223 dst->fdpid = newAV();
5224 Newxz(dst->children, 1, child_tab);
5225 dst->pseudo_id = 0;
5226 Newxz(dst->pseudo_children, 1, child_tab);
5227 dst->thr_intern.Winit_socktype = 0;
5228 dst->timerid = 0;
5229 dst->poll_count = 0;
5230 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t);
5231}
5232# endif /* USE_ITHREADS */
5233#endif /* HAVE_INTERP_INTERN */
5234
5235static void
5236win32_free_argvw(pTHX_ void *ptr)
5237{
5238 char** argv = (char**)ptr;
5239 while(*argv) {
5240 Safefree(*argv);
5241 *argv++ = Nullch;
5242 }
5243}
5244
5245void
5246win32_argv2utf8(int argc, char** argv)
5247{
5248 dTHX;
5249 char* psz;
5250 int length, wargc;
5251 LPWSTR* lpwStr = CommandLineToArgvW(GetCommandLineW(), &wargc);
5252 if (lpwStr && argc) {
5253 while (argc--) {
5254 length = WideCharToMultiByte(CP_UTF8, 0, lpwStr[--wargc], -1, NULL, 0, NULL, NULL);
5255 Newxz(psz, length, char);
5256 WideCharToMultiByte(CP_UTF8, 0, lpwStr[wargc], -1, psz, length, NULL, NULL);
5257 argv[argc] = psz;
5258 }
5259 call_atexit(win32_free_argvw, argv);
5260 }
5261 GlobalFree((HGLOBAL)lpwStr);
5262}
Note: See TracBrowser for help on using the repository browser.