Mercurial > repo
comparison perl-5.22.2/win32/win32.c @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
1 /* WIN32.C | |
2 * | |
3 * (c) 1995 Microsoft Corporation. All rights reserved. | |
4 * Developed by hip communications inc. | |
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 | |
15 #ifdef __GNUC__ | |
16 # define Win32_Winsock | |
17 #endif | |
18 | |
19 #ifndef _WIN32_WINNT | |
20 # define _WIN32_WINNT 0x0500 /* needed for CreateHardlink() etc. */ | |
21 #endif | |
22 | |
23 #include <windows.h> | |
24 | |
25 #ifndef HWND_MESSAGE | |
26 # define HWND_MESSAGE ((HWND)-3) | |
27 #endif | |
28 | |
29 #ifndef PROCESSOR_ARCHITECTURE_AMD64 | |
30 # define PROCESSOR_ARCHITECTURE_AMD64 9 | |
31 #endif | |
32 | |
33 #ifndef WC_NO_BEST_FIT_CHARS | |
34 # define WC_NO_BEST_FIT_CHARS 0x00000400 | |
35 #endif | |
36 | |
37 #include <winnt.h> | |
38 #include <commctrl.h> | |
39 #include <tlhelp32.h> | |
40 #include <io.h> | |
41 #include <signal.h> | |
42 | |
43 /* #include "config.h" */ | |
44 | |
45 #if !defined(PERLIO_IS_STDIO) | |
46 # define PerlIO FILE | |
47 #endif | |
48 | |
49 #include <sys/stat.h> | |
50 #include "EXTERN.h" | |
51 #include "perl.h" | |
52 | |
53 #define NO_XSLOCKS | |
54 #define PERL_NO_GET_CONTEXT | |
55 #include "XSUB.h" | |
56 | |
57 #include <fcntl.h> | |
58 #ifndef __GNUC__ | |
59 /* assert.h conflicts with #define of assert in perl.h */ | |
60 # include <assert.h> | |
61 #endif | |
62 | |
63 #include <string.h> | |
64 #include <stdarg.h> | |
65 #include <float.h> | |
66 #include <time.h> | |
67 #include <sys/utime.h> | |
68 | |
69 #ifdef __GNUC__ | |
70 /* Mingw32 defaults to globing command line | |
71 * So we turn it off like this: | |
72 */ | |
73 int _CRT_glob = 0; | |
74 #endif | |
75 | |
76 #if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION==1) | |
77 /* Mingw32-1.1 is missing some prototypes */ | |
78 START_EXTERN_C | |
79 FILE * _wfopen(LPCWSTR wszFileName, LPCWSTR wszMode); | |
80 FILE * _wfdopen(int nFd, LPCWSTR wszMode); | |
81 FILE * _freopen(LPCWSTR wszFileName, LPCWSTR wszMode, FILE * pOldStream); | |
82 int _flushall(); | |
83 int _fcloseall(); | |
84 END_EXTERN_C | |
85 #endif | |
86 | |
87 #define EXECF_EXEC 1 | |
88 #define EXECF_SPAWN 2 | |
89 #define EXECF_SPAWN_NOWAIT 3 | |
90 | |
91 #if defined(PERL_IMPLICIT_SYS) | |
92 # undef win32_get_privlib | |
93 # define win32_get_privlib g_win32_get_privlib | |
94 # undef win32_get_sitelib | |
95 # define win32_get_sitelib g_win32_get_sitelib | |
96 # undef win32_get_vendorlib | |
97 # define win32_get_vendorlib g_win32_get_vendorlib | |
98 # undef getlogin | |
99 # define getlogin g_getlogin | |
100 #endif | |
101 | |
102 /* VS2005 (MSC version 14) provides a mechanism to set an invalid | |
103 * parameter handler. This functionality is not available in the | |
104 * 64-bit compiler from the Platform SDK, which unfortunately also | |
105 * believes itself to be MSC version 14. | |
106 * | |
107 * There is no #define related to _set_invalid_parameter_handler(), | |
108 * but we can check for one of the constants defined for | |
109 * _set_abort_behavior(), which was introduced into stdlib.h at | |
110 * the same time. | |
111 */ | |
112 | |
113 #if _MSC_VER >= 1400 && defined(_WRITE_ABORT_MSG) | |
114 # define SET_INVALID_PARAMETER_HANDLER | |
115 #endif | |
116 | |
117 #ifdef SET_INVALID_PARAMETER_HANDLER | |
118 static BOOL set_silent_invalid_parameter_handler(BOOL newvalue); | |
119 static void my_invalid_parameter_handler(const wchar_t* expression, | |
120 const wchar_t* function, const wchar_t* file, | |
121 unsigned int line, uintptr_t pReserved); | |
122 #endif | |
123 | |
124 static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp); | |
125 static char* get_regstr(const char *valuename, SV **svp); | |
126 static char* get_emd_part(SV **prev_pathp, STRLEN *const len, | |
127 char *trailing, ...); | |
128 static char* win32_get_xlib(const char *pl, const char *xlib, | |
129 const char *libname, STRLEN *const len); | |
130 static BOOL has_shell_metachars(const char *ptr); | |
131 static long tokenize(const char *str, char **dest, char ***destv); | |
132 static void get_shell(void); | |
133 static char* find_next_space(const char *s); | |
134 static int do_spawn2(pTHX_ const char *cmd, int exectype); | |
135 static int do_spawn2_handles(pTHX_ const char *cmd, int exectype, | |
136 const int *handles); | |
137 static int do_spawnvp_handles(int mode, const char *cmdname, | |
138 const char * const *argv, const int *handles); | |
139 static PerlIO * do_popen(const char *mode, const char *command, IV narg, | |
140 SV **args); | |
141 static long find_pid(pTHX_ int pid); | |
142 static void remove_dead_process(long child); | |
143 static int terminate_process(DWORD pid, HANDLE process_handle, int sig); | |
144 static int my_killpg(int pid, int sig); | |
145 static int my_kill(int pid, int sig); | |
146 static void out_of_memory(void); | |
147 static char* wstr_to_str(const wchar_t* wstr); | |
148 static long filetime_to_clock(PFILETIME ft); | |
149 static BOOL filetime_from_time(PFILETIME ft, time_t t); | |
150 static char* create_command_line(char *cname, STRLEN clen, | |
151 const char * const *args); | |
152 static char* qualified_path(const char *cmd, bool other_exts); | |
153 static void ansify_path(void); | |
154 static LRESULT win32_process_message(HWND hwnd, UINT msg, | |
155 WPARAM wParam, LPARAM lParam); | |
156 | |
157 #ifdef USE_ITHREADS | |
158 static long find_pseudo_pid(pTHX_ int pid); | |
159 static void remove_dead_pseudo_process(long child); | |
160 static HWND get_hwnd_delay(pTHX, long child, DWORD tries); | |
161 #endif | |
162 | |
163 #ifdef HAVE_INTERP_INTERN | |
164 static void win32_csighandler(int sig); | |
165 #endif | |
166 | |
167 START_EXTERN_C | |
168 HANDLE w32_perldll_handle = INVALID_HANDLE_VALUE; | |
169 char w32_module_name[MAX_PATH+1]; | |
170 #ifdef WIN32_DYN_IOINFO_SIZE | |
171 Size_t w32_ioinfo_size;/* avoid 0 extend op b4 mul, otherwise could be a U8 */ | |
172 #endif | |
173 END_EXTERN_C | |
174 | |
175 static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""}; | |
176 | |
177 #ifdef SET_INVALID_PARAMETER_HANDLER | |
178 static BOOL silent_invalid_parameter_handler = FALSE; | |
179 | |
180 static BOOL | |
181 set_silent_invalid_parameter_handler(BOOL newvalue) | |
182 { | |
183 BOOL oldvalue = silent_invalid_parameter_handler; | |
184 # ifdef _DEBUG | |
185 silent_invalid_parameter_handler = newvalue; | |
186 # endif | |
187 return oldvalue; | |
188 } | |
189 | |
190 static void | |
191 my_invalid_parameter_handler(const wchar_t* expression, | |
192 const wchar_t* function, | |
193 const wchar_t* file, | |
194 unsigned int line, | |
195 uintptr_t pReserved) | |
196 { | |
197 # ifdef _DEBUG | |
198 char* ansi_expression; | |
199 char* ansi_function; | |
200 char* ansi_file; | |
201 if (silent_invalid_parameter_handler) | |
202 return; | |
203 ansi_expression = wstr_to_str(expression); | |
204 ansi_function = wstr_to_str(function); | |
205 ansi_file = wstr_to_str(file); | |
206 fprintf(stderr, "Invalid parameter detected in function %s. " | |
207 "File: %s, line: %d\n", ansi_function, ansi_file, line); | |
208 fprintf(stderr, "Expression: %s\n", ansi_expression); | |
209 free(ansi_expression); | |
210 free(ansi_function); | |
211 free(ansi_file); | |
212 # endif | |
213 } | |
214 #endif | |
215 | |
216 EXTERN_C void | |
217 set_w32_module_name(void) | |
218 { | |
219 /* this function may be called at DLL_PROCESS_ATTACH time */ | |
220 char* ptr; | |
221 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) | |
222 ? GetModuleHandle(NULL) | |
223 : w32_perldll_handle); | |
224 | |
225 WCHAR modulename[MAX_PATH]; | |
226 WCHAR fullname[MAX_PATH]; | |
227 char *ansi; | |
228 | |
229 DWORD (__stdcall *pfnGetLongPathNameW)(LPCWSTR, LPWSTR, DWORD) = | |
230 (DWORD (__stdcall *)(LPCWSTR, LPWSTR, DWORD)) | |
231 GetProcAddress(GetModuleHandle("kernel32.dll"), "GetLongPathNameW"); | |
232 | |
233 GetModuleFileNameW(module, modulename, sizeof(modulename)/sizeof(WCHAR)); | |
234 | |
235 /* Make sure we get an absolute pathname in case the module was loaded | |
236 * explicitly by LoadLibrary() with a relative path. */ | |
237 GetFullPathNameW(modulename, sizeof(fullname)/sizeof(WCHAR), fullname, NULL); | |
238 | |
239 /* Make sure we start with the long path name of the module because we | |
240 * later scan for pathname components to match "5.xx" to locate | |
241 * compatible sitelib directories, and the short pathname might mangle | |
242 * this path segment (e.g. by removing the dot on NTFS to something | |
243 * like "5xx~1.yy") */ | |
244 if (pfnGetLongPathNameW) | |
245 pfnGetLongPathNameW(fullname, fullname, sizeof(fullname)/sizeof(WCHAR)); | |
246 | |
247 /* remove \\?\ prefix */ | |
248 if (memcmp(fullname, L"\\\\?\\", 4*sizeof(WCHAR)) == 0) | |
249 memmove(fullname, fullname+4, (wcslen(fullname+4)+1)*sizeof(WCHAR)); | |
250 | |
251 ansi = win32_ansipath(fullname); | |
252 my_strlcpy(w32_module_name, ansi, sizeof(w32_module_name)); | |
253 win32_free(ansi); | |
254 | |
255 /* normalize to forward slashes */ | |
256 ptr = w32_module_name; | |
257 while (*ptr) { | |
258 if (*ptr == '\\') | |
259 *ptr = '/'; | |
260 ++ptr; | |
261 } | |
262 } | |
263 | |
264 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ | |
265 static char* | |
266 get_regstr_from(HKEY hkey, const char *valuename, SV **svp) | |
267 { | |
268 /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ | |
269 HKEY handle; | |
270 DWORD type; | |
271 const char *subkey = "Software\\Perl"; | |
272 char *str = NULL; | |
273 long retval; | |
274 | |
275 retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); | |
276 if (retval == ERROR_SUCCESS) { | |
277 DWORD datalen; | |
278 retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); | |
279 if (retval == ERROR_SUCCESS | |
280 && (type == REG_SZ || type == REG_EXPAND_SZ)) | |
281 { | |
282 dTHX; | |
283 if (!*svp) | |
284 *svp = sv_2mortal(newSVpvs("")); | |
285 SvGROW(*svp, datalen); | |
286 retval = RegQueryValueEx(handle, valuename, 0, NULL, | |
287 (PBYTE)SvPVX(*svp), &datalen); | |
288 if (retval == ERROR_SUCCESS) { | |
289 str = SvPVX(*svp); | |
290 SvCUR_set(*svp,datalen-1); | |
291 } | |
292 } | |
293 RegCloseKey(handle); | |
294 } | |
295 return str; | |
296 } | |
297 | |
298 /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ | |
299 static char* | |
300 get_regstr(const char *valuename, SV **svp) | |
301 { | |
302 char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp); | |
303 if (!str) | |
304 str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp); | |
305 return str; | |
306 } | |
307 | |
308 /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */ | |
309 static char * | |
310 get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) | |
311 { | |
312 char base[10]; | |
313 va_list ap; | |
314 char mod_name[MAX_PATH+1]; | |
315 char *ptr; | |
316 char *optr; | |
317 char *strip; | |
318 STRLEN baselen; | |
319 | |
320 va_start(ap, trailing_path); | |
321 strip = va_arg(ap, char *); | |
322 | |
323 sprintf(base, "%d.%d", (int)PERL_REVISION, (int)PERL_VERSION); | |
324 baselen = strlen(base); | |
325 | |
326 if (!*w32_module_name) { | |
327 set_w32_module_name(); | |
328 } | |
329 strcpy(mod_name, w32_module_name); | |
330 ptr = strrchr(mod_name, '/'); | |
331 while (ptr && strip) { | |
332 /* look for directories to skip back */ | |
333 optr = ptr; | |
334 *ptr = '\0'; | |
335 ptr = strrchr(mod_name, '/'); | |
336 /* avoid stripping component if there is no slash, | |
337 * or it doesn't match ... */ | |
338 if (!ptr || stricmp(ptr+1, strip) != 0) { | |
339 /* ... but not if component matches m|5\.$patchlevel.*| */ | |
340 if (!ptr || !(*strip == '5' && *(ptr+1) == '5' | |
341 && strncmp(strip, base, baselen) == 0 | |
342 && strncmp(ptr+1, base, baselen) == 0)) | |
343 { | |
344 *optr = '/'; | |
345 ptr = optr; | |
346 } | |
347 } | |
348 strip = va_arg(ap, char *); | |
349 } | |
350 if (!ptr) { | |
351 ptr = mod_name; | |
352 *ptr++ = '.'; | |
353 *ptr = '/'; | |
354 } | |
355 va_end(ap); | |
356 strcpy(++ptr, trailing_path); | |
357 | |
358 /* only add directory if it exists */ | |
359 if (GetFileAttributes(mod_name) != (DWORD) -1) { | |
360 /* directory exists */ | |
361 dTHX; | |
362 if (!*prev_pathp) | |
363 *prev_pathp = sv_2mortal(newSVpvs("")); | |
364 else if (SvPVX(*prev_pathp)) | |
365 sv_catpvs(*prev_pathp, ";"); | |
366 sv_catpv(*prev_pathp, mod_name); | |
367 if(len) | |
368 *len = SvCUR(*prev_pathp); | |
369 return SvPVX(*prev_pathp); | |
370 } | |
371 | |
372 return NULL; | |
373 } | |
374 | |
375 EXTERN_C char * | |
376 win32_get_privlib(const char *pl, STRLEN *const len) | |
377 { | |
378 char *stdlib = "lib"; | |
379 char buffer[MAX_PATH+1]; | |
380 SV *sv = NULL; | |
381 | |
382 /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ | |
383 sprintf(buffer, "%s-%s", stdlib, pl); | |
384 if (!get_regstr(buffer, &sv)) | |
385 (void)get_regstr(stdlib, &sv); | |
386 | |
387 /* $stdlib .= ";$EMD/../../lib" */ | |
388 return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL); | |
389 } | |
390 | |
391 static char * | |
392 win32_get_xlib(const char *pl, const char *xlib, const char *libname, | |
393 STRLEN *const len) | |
394 { | |
395 char regstr[40]; | |
396 char pathstr[MAX_PATH+1]; | |
397 SV *sv1 = NULL; | |
398 SV *sv2 = NULL; | |
399 | |
400 /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */ | |
401 sprintf(regstr, "%s-%s", xlib, pl); | |
402 (void)get_regstr(regstr, &sv1); | |
403 | |
404 /* $xlib .= | |
405 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */ | |
406 sprintf(pathstr, "%s/%s/lib", libname, pl); | |
407 (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL); | |
408 | |
409 /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */ | |
410 (void)get_regstr(xlib, &sv2); | |
411 | |
412 /* $xlib .= | |
413 * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */ | |
414 sprintf(pathstr, "%s/lib", libname); | |
415 (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL); | |
416 | |
417 if (!sv1 && !sv2) | |
418 return NULL; | |
419 if (!sv1) { | |
420 sv1 = sv2; | |
421 } else if (sv2) { | |
422 dTHX; | |
423 sv_catpv(sv1, ";"); | |
424 sv_catsv(sv1, sv2); | |
425 } | |
426 | |
427 if (len) | |
428 *len = SvCUR(sv1); | |
429 return SvPVX(sv1); | |
430 } | |
431 | |
432 EXTERN_C char * | |
433 win32_get_sitelib(const char *pl, STRLEN *const len) | |
434 { | |
435 return win32_get_xlib(pl, "sitelib", "site", len); | |
436 } | |
437 | |
438 #ifndef PERL_VENDORLIB_NAME | |
439 # define PERL_VENDORLIB_NAME "vendor" | |
440 #endif | |
441 | |
442 EXTERN_C char * | |
443 win32_get_vendorlib(const char *pl, STRLEN *const len) | |
444 { | |
445 return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len); | |
446 } | |
447 | |
448 static BOOL | |
449 has_shell_metachars(const char *ptr) | |
450 { | |
451 int inquote = 0; | |
452 char quote = '\0'; | |
453 | |
454 /* | |
455 * Scan string looking for redirection (< or >) or pipe | |
456 * characters (|) that are not in a quoted string. | |
457 * Shell variable interpolation (%VAR%) can also happen inside strings. | |
458 */ | |
459 while (*ptr) { | |
460 switch(*ptr) { | |
461 case '%': | |
462 return TRUE; | |
463 case '\'': | |
464 case '\"': | |
465 if (inquote) { | |
466 if (quote == *ptr) { | |
467 inquote = 0; | |
468 quote = '\0'; | |
469 } | |
470 } | |
471 else { | |
472 quote = *ptr; | |
473 inquote++; | |
474 } | |
475 break; | |
476 case '>': | |
477 case '<': | |
478 case '|': | |
479 if (!inquote) | |
480 return TRUE; | |
481 default: | |
482 break; | |
483 } | |
484 ++ptr; | |
485 } | |
486 return FALSE; | |
487 } | |
488 | |
489 #if !defined(PERL_IMPLICIT_SYS) | |
490 /* since the current process environment is being updated in util.c | |
491 * the library functions will get the correct environment | |
492 */ | |
493 PerlIO * | |
494 Perl_my_popen(pTHX_ const char *cmd, const char *mode) | |
495 { | |
496 PERL_FLUSHALL_FOR_CHILD; | |
497 return win32_popen(cmd, mode); | |
498 } | |
499 | |
500 long | |
501 Perl_my_pclose(pTHX_ PerlIO *fp) | |
502 { | |
503 return win32_pclose(fp); | |
504 } | |
505 #endif | |
506 | |
507 DllExport unsigned long | |
508 win32_os_id(void) | |
509 { | |
510 return (unsigned long)g_osver.dwPlatformId; | |
511 } | |
512 | |
513 DllExport int | |
514 win32_getpid(void) | |
515 { | |
516 #ifdef USE_ITHREADS | |
517 dTHX; | |
518 if (w32_pseudo_id) | |
519 return -((int)w32_pseudo_id); | |
520 #endif | |
521 return _getpid(); | |
522 } | |
523 | |
524 /* Tokenize a string. Words are null-separated, and the list | |
525 * ends with a doubled null. Any character (except null and | |
526 * including backslash) may be escaped by preceding it with a | |
527 * backslash (the backslash will be stripped). | |
528 * Returns number of words in result buffer. | |
529 */ | |
530 static long | |
531 tokenize(const char *str, char **dest, char ***destv) | |
532 { | |
533 char *retstart = NULL; | |
534 char **retvstart = 0; | |
535 int items = -1; | |
536 if (str) { | |
537 int slen = strlen(str); | |
538 char *ret; | |
539 char **retv; | |
540 Newx(ret, slen+2, char); | |
541 Newx(retv, (slen+3)/2, char*); | |
542 | |
543 retstart = ret; | |
544 retvstart = retv; | |
545 *retv = ret; | |
546 items = 0; | |
547 while (*str) { | |
548 *ret = *str++; | |
549 if (*ret == '\\' && *str) | |
550 *ret = *str++; | |
551 else if (*ret == ' ') { | |
552 while (*str == ' ') | |
553 str++; | |
554 if (ret == retstart) | |
555 ret--; | |
556 else { | |
557 *ret = '\0'; | |
558 ++items; | |
559 if (*str) | |
560 *++retv = ret+1; | |
561 } | |
562 } | |
563 else if (!*str) | |
564 ++items; | |
565 ret++; | |
566 } | |
567 retvstart[items] = NULL; | |
568 *ret++ = '\0'; | |
569 *ret = '\0'; | |
570 } | |
571 *dest = retstart; | |
572 *destv = retvstart; | |
573 return items; | |
574 } | |
575 | |
576 static void | |
577 get_shell(void) | |
578 { | |
579 dTHX; | |
580 if (!w32_perlshell_tokens) { | |
581 /* we don't use COMSPEC here for two reasons: | |
582 * 1. the same reason perl on UNIX doesn't use SHELL--rampant and | |
583 * uncontrolled unportability of the ensuing scripts. | |
584 * 2. PERL5SHELL could be set to a shell that may not be fit for | |
585 * interactive use (which is what most programs look in COMSPEC | |
586 * for). | |
587 */ | |
588 const char* defaultshell = "cmd.exe /x/d/c"; | |
589 const char *usershell = PerlEnv_getenv("PERL5SHELL"); | |
590 w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, | |
591 &w32_perlshell_tokens, | |
592 &w32_perlshell_vec); | |
593 } | |
594 } | |
595 | |
596 int | |
597 Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) | |
598 { | |
599 char **argv; | |
600 char *str; | |
601 int status; | |
602 int flag = P_WAIT; | |
603 int index = 0; | |
604 | |
605 PERL_ARGS_ASSERT_DO_ASPAWN; | |
606 | |
607 if (sp <= mark) | |
608 return -1; | |
609 | |
610 get_shell(); | |
611 Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*); | |
612 | |
613 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { | |
614 ++mark; | |
615 flag = SvIVx(*mark); | |
616 } | |
617 | |
618 while (++mark <= sp) { | |
619 if (*mark && (str = SvPV_nolen(*mark))) | |
620 argv[index++] = str; | |
621 else | |
622 argv[index++] = ""; | |
623 } | |
624 argv[index++] = 0; | |
625 | |
626 status = win32_spawnvp(flag, | |
627 (const char*)(really ? SvPV_nolen(really) : argv[0]), | |
628 (const char* const*)argv); | |
629 | |
630 if (status < 0 && (errno == ENOEXEC || errno == ENOENT)) { | |
631 /* possible shell-builtin, invoke with shell */ | |
632 int sh_items; | |
633 sh_items = w32_perlshell_items; | |
634 while (--index >= 0) | |
635 argv[index+sh_items] = argv[index]; | |
636 while (--sh_items >= 0) | |
637 argv[sh_items] = w32_perlshell_vec[sh_items]; | |
638 | |
639 status = win32_spawnvp(flag, | |
640 (const char*)(really ? SvPV_nolen(really) : argv[0]), | |
641 (const char* const*)argv); | |
642 } | |
643 | |
644 if (flag == P_NOWAIT) { | |
645 PL_statusvalue = -1; /* >16bits hint for pp_system() */ | |
646 } | |
647 else { | |
648 if (status < 0) { | |
649 if (ckWARN(WARN_EXEC)) | |
650 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); | |
651 status = 255 * 256; | |
652 } | |
653 else | |
654 status *= 256; | |
655 PL_statusvalue = status; | |
656 } | |
657 Safefree(argv); | |
658 return (status); | |
659 } | |
660 | |
661 /* returns pointer to the next unquoted space or the end of the string */ | |
662 static char* | |
663 find_next_space(const char *s) | |
664 { | |
665 bool in_quotes = FALSE; | |
666 while (*s) { | |
667 /* ignore doubled backslashes, or backslash+quote */ | |
668 if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) { | |
669 s += 2; | |
670 } | |
671 /* keep track of when we're within quotes */ | |
672 else if (*s == '"') { | |
673 s++; | |
674 in_quotes = !in_quotes; | |
675 } | |
676 /* break it up only at spaces that aren't in quotes */ | |
677 else if (!in_quotes && isSPACE(*s)) | |
678 return (char*)s; | |
679 else | |
680 s++; | |
681 } | |
682 return (char*)s; | |
683 } | |
684 | |
685 static int | |
686 do_spawn2(pTHX_ const char *cmd, int exectype) { | |
687 return do_spawn2_handles(aTHX_ cmd, exectype, NULL); | |
688 } | |
689 | |
690 static int | |
691 do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles) | |
692 { | |
693 char **a; | |
694 char *s; | |
695 char **argv; | |
696 int status = -1; | |
697 BOOL needToTry = TRUE; | |
698 char *cmd2; | |
699 | |
700 /* Save an extra exec if possible. See if there are shell | |
701 * metacharacters in it */ | |
702 if (!has_shell_metachars(cmd)) { | |
703 Newx(argv, strlen(cmd) / 2 + 2, char*); | |
704 Newx(cmd2, strlen(cmd) + 1, char); | |
705 strcpy(cmd2, cmd); | |
706 a = argv; | |
707 for (s = cmd2; *s;) { | |
708 while (*s && isSPACE(*s)) | |
709 s++; | |
710 if (*s) | |
711 *(a++) = s; | |
712 s = find_next_space(s); | |
713 if (*s) | |
714 *s++ = '\0'; | |
715 } | |
716 *a = NULL; | |
717 if (argv[0]) { | |
718 switch (exectype) { | |
719 case EXECF_SPAWN: | |
720 status = win32_spawnvp(P_WAIT, argv[0], | |
721 (const char* const*)argv); | |
722 break; | |
723 case EXECF_SPAWN_NOWAIT: | |
724 status = do_spawnvp_handles(P_NOWAIT, argv[0], | |
725 (const char* const*)argv, handles); | |
726 break; | |
727 case EXECF_EXEC: | |
728 status = win32_execvp(argv[0], (const char* const*)argv); | |
729 break; | |
730 } | |
731 if (status != -1 || errno == 0) | |
732 needToTry = FALSE; | |
733 } | |
734 Safefree(argv); | |
735 Safefree(cmd2); | |
736 } | |
737 if (needToTry) { | |
738 char **argv; | |
739 int i = -1; | |
740 get_shell(); | |
741 Newx(argv, w32_perlshell_items + 2, char*); | |
742 while (++i < w32_perlshell_items) | |
743 argv[i] = w32_perlshell_vec[i]; | |
744 argv[i++] = (char *)cmd; | |
745 argv[i] = NULL; | |
746 switch (exectype) { | |
747 case EXECF_SPAWN: | |
748 status = win32_spawnvp(P_WAIT, argv[0], | |
749 (const char* const*)argv); | |
750 break; | |
751 case EXECF_SPAWN_NOWAIT: | |
752 status = do_spawnvp_handles(P_NOWAIT, argv[0], | |
753 (const char* const*)argv, handles); | |
754 break; | |
755 case EXECF_EXEC: | |
756 status = win32_execvp(argv[0], (const char* const*)argv); | |
757 break; | |
758 } | |
759 cmd = argv[0]; | |
760 Safefree(argv); | |
761 } | |
762 if (exectype == EXECF_SPAWN_NOWAIT) { | |
763 PL_statusvalue = -1; /* >16bits hint for pp_system() */ | |
764 } | |
765 else { | |
766 if (status < 0) { | |
767 if (ckWARN(WARN_EXEC)) | |
768 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", | |
769 (exectype == EXECF_EXEC ? "exec" : "spawn"), | |
770 cmd, strerror(errno)); | |
771 status = 255 * 256; | |
772 } | |
773 else | |
774 status *= 256; | |
775 PL_statusvalue = status; | |
776 } | |
777 return (status); | |
778 } | |
779 | |
780 int | |
781 Perl_do_spawn(pTHX_ char *cmd) | |
782 { | |
783 PERL_ARGS_ASSERT_DO_SPAWN; | |
784 | |
785 return do_spawn2(aTHX_ cmd, EXECF_SPAWN); | |
786 } | |
787 | |
788 int | |
789 Perl_do_spawn_nowait(pTHX_ char *cmd) | |
790 { | |
791 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT; | |
792 | |
793 return do_spawn2(aTHX_ cmd, EXECF_SPAWN_NOWAIT); | |
794 } | |
795 | |
796 bool | |
797 Perl_do_exec(pTHX_ const char *cmd) | |
798 { | |
799 PERL_ARGS_ASSERT_DO_EXEC; | |
800 | |
801 do_spawn2(aTHX_ cmd, EXECF_EXEC); | |
802 return FALSE; | |
803 } | |
804 | |
805 /* The idea here is to read all the directory names into a string table | |
806 * (separated by nulls) and when one of the other dir functions is called | |
807 * return the pointer to the current file name. | |
808 */ | |
809 DllExport DIR * | |
810 win32_opendir(const char *filename) | |
811 { | |
812 dTHXa(NULL); | |
813 DIR *dirp; | |
814 long len; | |
815 long idx; | |
816 char scanname[MAX_PATH+3]; | |
817 WCHAR wscanname[sizeof(scanname)]; | |
818 WIN32_FIND_DATAW wFindData; | |
819 char buffer[MAX_PATH*2]; | |
820 BOOL use_default; | |
821 | |
822 len = strlen(filename); | |
823 if (len == 0) { | |
824 errno = ENOENT; | |
825 return NULL; | |
826 } | |
827 if (len > MAX_PATH) { | |
828 errno = ENAMETOOLONG; | |
829 return NULL; | |
830 } | |
831 | |
832 /* Get us a DIR structure */ | |
833 Newxz(dirp, 1, DIR); | |
834 | |
835 /* Create the search pattern */ | |
836 strcpy(scanname, filename); | |
837 | |
838 /* bare drive name means look in cwd for drive */ | |
839 if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') { | |
840 scanname[len++] = '.'; | |
841 scanname[len++] = '/'; | |
842 } | |
843 else if (scanname[len-1] != '/' && scanname[len-1] != '\\') { | |
844 scanname[len++] = '/'; | |
845 } | |
846 scanname[len++] = '*'; | |
847 scanname[len] = '\0'; | |
848 | |
849 /* do the FindFirstFile call */ | |
850 MultiByteToWideChar(CP_ACP, 0, scanname, -1, wscanname, sizeof(wscanname)/sizeof(WCHAR)); | |
851 aTHXa(PERL_GET_THX); | |
852 dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData); | |
853 | |
854 if (dirp->handle == INVALID_HANDLE_VALUE) { | |
855 DWORD err = GetLastError(); | |
856 /* FindFirstFile() fails on empty drives! */ | |
857 switch (err) { | |
858 case ERROR_FILE_NOT_FOUND: | |
859 return dirp; | |
860 case ERROR_NO_MORE_FILES: | |
861 case ERROR_PATH_NOT_FOUND: | |
862 errno = ENOENT; | |
863 break; | |
864 case ERROR_NOT_ENOUGH_MEMORY: | |
865 errno = ENOMEM; | |
866 break; | |
867 default: | |
868 errno = EINVAL; | |
869 break; | |
870 } | |
871 Safefree(dirp); | |
872 return NULL; | |
873 } | |
874 | |
875 use_default = FALSE; | |
876 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, | |
877 wFindData.cFileName, -1, | |
878 buffer, sizeof(buffer), NULL, &use_default); | |
879 if (use_default && *wFindData.cAlternateFileName) { | |
880 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, | |
881 wFindData.cAlternateFileName, -1, | |
882 buffer, sizeof(buffer), NULL, NULL); | |
883 } | |
884 | |
885 /* now allocate the first part of the string table for | |
886 * the filenames that we find. | |
887 */ | |
888 idx = strlen(buffer)+1; | |
889 if (idx < 256) | |
890 dirp->size = 256; | |
891 else | |
892 dirp->size = idx; | |
893 Newx(dirp->start, dirp->size, char); | |
894 strcpy(dirp->start, buffer); | |
895 dirp->nfiles++; | |
896 dirp->end = dirp->curr = dirp->start; | |
897 dirp->end += idx; | |
898 return dirp; | |
899 } | |
900 | |
901 | |
902 /* Readdir just returns the current string pointer and bumps the | |
903 * string pointer to the nDllExport entry. | |
904 */ | |
905 DllExport struct direct * | |
906 win32_readdir(DIR *dirp) | |
907 { | |
908 long len; | |
909 | |
910 if (dirp->curr) { | |
911 /* first set up the structure to return */ | |
912 len = strlen(dirp->curr); | |
913 strcpy(dirp->dirstr.d_name, dirp->curr); | |
914 dirp->dirstr.d_namlen = len; | |
915 | |
916 /* Fake an inode */ | |
917 dirp->dirstr.d_ino = dirp->curr - dirp->start; | |
918 | |
919 /* Now set up for the next call to readdir */ | |
920 dirp->curr += len + 1; | |
921 if (dirp->curr >= dirp->end) { | |
922 BOOL res; | |
923 char buffer[MAX_PATH*2]; | |
924 | |
925 if (dirp->handle == INVALID_HANDLE_VALUE) { | |
926 res = 0; | |
927 } | |
928 /* finding the next file that matches the wildcard | |
929 * (which should be all of them in this directory!). | |
930 */ | |
931 else { | |
932 WIN32_FIND_DATAW wFindData; | |
933 res = FindNextFileW(dirp->handle, &wFindData); | |
934 if (res) { | |
935 BOOL use_default = FALSE; | |
936 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, | |
937 wFindData.cFileName, -1, | |
938 buffer, sizeof(buffer), NULL, &use_default); | |
939 if (use_default && *wFindData.cAlternateFileName) { | |
940 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, | |
941 wFindData.cAlternateFileName, -1, | |
942 buffer, sizeof(buffer), NULL, NULL); | |
943 } | |
944 } | |
945 } | |
946 if (res) { | |
947 long endpos = dirp->end - dirp->start; | |
948 long newsize = endpos + strlen(buffer) + 1; | |
949 /* bump the string table size by enough for the | |
950 * new name and its null terminator */ | |
951 while (newsize > dirp->size) { | |
952 long curpos = dirp->curr - dirp->start; | |
953 dirp->size *= 2; | |
954 Renew(dirp->start, dirp->size, char); | |
955 dirp->curr = dirp->start + curpos; | |
956 } | |
957 strcpy(dirp->start + endpos, buffer); | |
958 dirp->end = dirp->start + newsize; | |
959 dirp->nfiles++; | |
960 } | |
961 else { | |
962 dirp->curr = NULL; | |
963 if (dirp->handle != INVALID_HANDLE_VALUE) { | |
964 FindClose(dirp->handle); | |
965 dirp->handle = INVALID_HANDLE_VALUE; | |
966 } | |
967 } | |
968 } | |
969 return &(dirp->dirstr); | |
970 } | |
971 else | |
972 return NULL; | |
973 } | |
974 | |
975 /* Telldir returns the current string pointer position */ | |
976 DllExport long | |
977 win32_telldir(DIR *dirp) | |
978 { | |
979 return dirp->curr ? (dirp->curr - dirp->start) : -1; | |
980 } | |
981 | |
982 | |
983 /* Seekdir moves the string pointer to a previously saved position | |
984 * (returned by telldir). | |
985 */ | |
986 DllExport void | |
987 win32_seekdir(DIR *dirp, long loc) | |
988 { | |
989 dirp->curr = loc == -1 ? NULL : dirp->start + loc; | |
990 } | |
991 | |
992 /* Rewinddir resets the string pointer to the start */ | |
993 DllExport void | |
994 win32_rewinddir(DIR *dirp) | |
995 { | |
996 dirp->curr = dirp->start; | |
997 } | |
998 | |
999 /* free the memory allocated by opendir */ | |
1000 DllExport int | |
1001 win32_closedir(DIR *dirp) | |
1002 { | |
1003 if (dirp->handle != INVALID_HANDLE_VALUE) | |
1004 FindClose(dirp->handle); | |
1005 Safefree(dirp->start); | |
1006 Safefree(dirp); | |
1007 return 1; | |
1008 } | |
1009 | |
1010 /* duplicate a open DIR* for interpreter cloning */ | |
1011 DllExport DIR * | |
1012 win32_dirp_dup(DIR *const dirp, CLONE_PARAMS *const param) | |
1013 { | |
1014 dVAR; | |
1015 PerlInterpreter *const from = param->proto_perl; | |
1016 PerlInterpreter *const to = (PerlInterpreter *)PERL_GET_THX; | |
1017 | |
1018 long pos; | |
1019 DIR *dup; | |
1020 | |
1021 /* switch back to original interpreter because win32_readdir() | |
1022 * might Renew(dirp->start). | |
1023 */ | |
1024 if (from != to) { | |
1025 PERL_SET_THX(from); | |
1026 } | |
1027 | |
1028 /* mark current position; read all remaining entries into the | |
1029 * cache, and then restore to current position. | |
1030 */ | |
1031 pos = win32_telldir(dirp); | |
1032 while (win32_readdir(dirp)) { | |
1033 /* read all entries into cache */ | |
1034 } | |
1035 win32_seekdir(dirp, pos); | |
1036 | |
1037 /* switch back to new interpreter to allocate new DIR structure */ | |
1038 if (from != to) { | |
1039 PERL_SET_THX(to); | |
1040 } | |
1041 | |
1042 Newx(dup, 1, DIR); | |
1043 memcpy(dup, dirp, sizeof(DIR)); | |
1044 | |
1045 Newx(dup->start, dirp->size, char); | |
1046 memcpy(dup->start, dirp->start, dirp->size); | |
1047 | |
1048 dup->end = dup->start + (dirp->end - dirp->start); | |
1049 if (dirp->curr) | |
1050 dup->curr = dup->start + (dirp->curr - dirp->start); | |
1051 | |
1052 return dup; | |
1053 } | |
1054 | |
1055 /* | |
1056 * various stubs | |
1057 */ | |
1058 | |
1059 | |
1060 /* Ownership | |
1061 * | |
1062 * Just pretend that everyone is a superuser. NT will let us know if | |
1063 * we don\'t really have permission to do something. | |
1064 */ | |
1065 | |
1066 #define ROOT_UID ((uid_t)0) | |
1067 #define ROOT_GID ((gid_t)0) | |
1068 | |
1069 uid_t | |
1070 getuid(void) | |
1071 { | |
1072 return ROOT_UID; | |
1073 } | |
1074 | |
1075 uid_t | |
1076 geteuid(void) | |
1077 { | |
1078 return ROOT_UID; | |
1079 } | |
1080 | |
1081 gid_t | |
1082 getgid(void) | |
1083 { | |
1084 return ROOT_GID; | |
1085 } | |
1086 | |
1087 gid_t | |
1088 getegid(void) | |
1089 { | |
1090 return ROOT_GID; | |
1091 } | |
1092 | |
1093 int | |
1094 setuid(uid_t auid) | |
1095 { | |
1096 return (auid == ROOT_UID ? 0 : -1); | |
1097 } | |
1098 | |
1099 int | |
1100 setgid(gid_t agid) | |
1101 { | |
1102 return (agid == ROOT_GID ? 0 : -1); | |
1103 } | |
1104 | |
1105 EXTERN_C char * | |
1106 getlogin(void) | |
1107 { | |
1108 dTHX; | |
1109 char *buf = w32_getlogin_buffer; | |
1110 DWORD size = sizeof(w32_getlogin_buffer); | |
1111 if (GetUserName(buf,&size)) | |
1112 return buf; | |
1113 return (char*)NULL; | |
1114 } | |
1115 | |
1116 int | |
1117 chown(const char *path, uid_t owner, gid_t group) | |
1118 { | |
1119 /* XXX noop */ | |
1120 return 0; | |
1121 } | |
1122 | |
1123 /* | |
1124 * XXX this needs strengthening (for PerlIO) | |
1125 * -- BKS, 11-11-200 | |
1126 */ | |
1127 #if !defined(__MINGW64_VERSION_MAJOR) || __MINGW64_VERSION_MAJOR < 4 | |
1128 int mkstemp(const char *path) | |
1129 { | |
1130 dTHX; | |
1131 char buf[MAX_PATH+1]; | |
1132 int i = 0, fd = -1; | |
1133 | |
1134 retry: | |
1135 if (i++ > 10) { /* give up */ | |
1136 errno = ENOENT; | |
1137 return -1; | |
1138 } | |
1139 if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) { | |
1140 errno = ENOENT; | |
1141 return -1; | |
1142 } | |
1143 fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600); | |
1144 if (fd == -1) | |
1145 goto retry; | |
1146 return fd; | |
1147 } | |
1148 #endif | |
1149 | |
1150 static long | |
1151 find_pid(pTHX_ int pid) | |
1152 { | |
1153 long child = w32_num_children; | |
1154 while (--child >= 0) { | |
1155 if ((int)w32_child_pids[child] == pid) | |
1156 return child; | |
1157 } | |
1158 return -1; | |
1159 } | |
1160 | |
1161 static void | |
1162 remove_dead_process(long child) | |
1163 { | |
1164 if (child >= 0) { | |
1165 dTHX; | |
1166 CloseHandle(w32_child_handles[child]); | |
1167 Move(&w32_child_handles[child+1], &w32_child_handles[child], | |
1168 (w32_num_children-child-1), HANDLE); | |
1169 Move(&w32_child_pids[child+1], &w32_child_pids[child], | |
1170 (w32_num_children-child-1), DWORD); | |
1171 w32_num_children--; | |
1172 } | |
1173 } | |
1174 | |
1175 #ifdef USE_ITHREADS | |
1176 static long | |
1177 find_pseudo_pid(pTHX_ int pid) | |
1178 { | |
1179 long child = w32_num_pseudo_children; | |
1180 while (--child >= 0) { | |
1181 if ((int)w32_pseudo_child_pids[child] == pid) | |
1182 return child; | |
1183 } | |
1184 return -1; | |
1185 } | |
1186 | |
1187 static void | |
1188 remove_dead_pseudo_process(long child) | |
1189 { | |
1190 if (child >= 0) { | |
1191 dTHX; | |
1192 CloseHandle(w32_pseudo_child_handles[child]); | |
1193 Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child], | |
1194 (w32_num_pseudo_children-child-1), HANDLE); | |
1195 Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child], | |
1196 (w32_num_pseudo_children-child-1), DWORD); | |
1197 Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child], | |
1198 (w32_num_pseudo_children-child-1), HWND); | |
1199 Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child], | |
1200 (w32_num_pseudo_children-child-1), char); | |
1201 w32_num_pseudo_children--; | |
1202 } | |
1203 } | |
1204 | |
1205 void | |
1206 win32_wait_for_children(pTHX) | |
1207 { | |
1208 if (w32_pseudo_children && w32_num_pseudo_children) { | |
1209 long child = 0; | |
1210 long count = 0; | |
1211 HANDLE handles[MAXIMUM_WAIT_OBJECTS]; | |
1212 | |
1213 for (child = 0; child < w32_num_pseudo_children; ++child) { | |
1214 if (!w32_pseudo_child_sigterm[child]) | |
1215 handles[count++] = w32_pseudo_child_handles[child]; | |
1216 } | |
1217 /* XXX should use MsgWaitForMultipleObjects() to continue | |
1218 * XXX processing messages while we wait. | |
1219 */ | |
1220 WaitForMultipleObjects(count, handles, TRUE, INFINITE); | |
1221 | |
1222 while (w32_num_pseudo_children) | |
1223 CloseHandle(w32_pseudo_child_handles[--w32_num_pseudo_children]); | |
1224 } | |
1225 } | |
1226 #endif | |
1227 | |
1228 static int | |
1229 terminate_process(DWORD pid, HANDLE process_handle, int sig) | |
1230 { | |
1231 switch(sig) { | |
1232 case 0: | |
1233 /* "Does process exist?" use of kill */ | |
1234 return 1; | |
1235 case 2: | |
1236 if (GenerateConsoleCtrlEvent(CTRL_C_EVENT, pid)) | |
1237 return 1; | |
1238 break; | |
1239 case SIGBREAK: | |
1240 case SIGTERM: | |
1241 if (GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pid)) | |
1242 return 1; | |
1243 break; | |
1244 default: /* For now be backwards compatible with perl 5.6 */ | |
1245 case 9: | |
1246 /* Note that we will only be able to kill processes owned by the | |
1247 * current process owner, even when we are running as an administrator. | |
1248 * To kill processes of other owners we would need to set the | |
1249 * 'SeDebugPrivilege' privilege before obtaining the process handle. | |
1250 */ | |
1251 if (TerminateProcess(process_handle, sig)) | |
1252 return 1; | |
1253 break; | |
1254 } | |
1255 return 0; | |
1256 } | |
1257 | |
1258 /* returns number of processes killed */ | |
1259 static int | |
1260 my_killpg(int pid, int sig) | |
1261 { | |
1262 HANDLE process_handle; | |
1263 HANDLE snapshot_handle; | |
1264 int killed = 0; | |
1265 | |
1266 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); | |
1267 if (process_handle == NULL) | |
1268 return 0; | |
1269 | |
1270 killed += terminate_process(pid, process_handle, sig); | |
1271 | |
1272 snapshot_handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); | |
1273 if (snapshot_handle != INVALID_HANDLE_VALUE) { | |
1274 PROCESSENTRY32 entry; | |
1275 | |
1276 entry.dwSize = sizeof(entry); | |
1277 if (Process32First(snapshot_handle, &entry)) { | |
1278 do { | |
1279 if (entry.th32ParentProcessID == (DWORD)pid) | |
1280 killed += my_killpg(entry.th32ProcessID, sig); | |
1281 entry.dwSize = sizeof(entry); | |
1282 } | |
1283 while (Process32Next(snapshot_handle, &entry)); | |
1284 } | |
1285 CloseHandle(snapshot_handle); | |
1286 } | |
1287 CloseHandle(process_handle); | |
1288 return killed; | |
1289 } | |
1290 | |
1291 /* returns number of processes killed */ | |
1292 static int | |
1293 my_kill(int pid, int sig) | |
1294 { | |
1295 int retval = 0; | |
1296 HANDLE process_handle; | |
1297 | |
1298 if (sig < 0) | |
1299 return my_killpg(pid, -sig); | |
1300 | |
1301 process_handle = OpenProcess(PROCESS_TERMINATE, FALSE, pid); | |
1302 /* OpenProcess() returns NULL on error, *not* INVALID_HANDLE_VALUE */ | |
1303 if (process_handle != NULL) { | |
1304 retval = terminate_process(pid, process_handle, sig); | |
1305 CloseHandle(process_handle); | |
1306 } | |
1307 return retval; | |
1308 } | |
1309 | |
1310 #ifdef USE_ITHREADS | |
1311 /* Get a child pseudo-process HWND, with retrying and delaying/yielding. | |
1312 * The "tries" parameter is the number of retries to make, with a Sleep(1) | |
1313 * (waiting and yielding the time slot) between each try. Specifying 0 causes | |
1314 * only Sleep(0) (no waiting and potentially no yielding) to be used, so is not | |
1315 * recommended | |
1316 * Returns an hwnd != INVALID_HANDLE_VALUE (so be aware that NULL can be | |
1317 * returned) or croaks if the child pseudo-process doesn't schedule and deliver | |
1318 * a HWND in the time period allowed. | |
1319 */ | |
1320 static HWND | |
1321 get_hwnd_delay(pTHX, long child, DWORD tries) | |
1322 { | |
1323 HWND hwnd = w32_pseudo_child_message_hwnds[child]; | |
1324 if (hwnd != INVALID_HANDLE_VALUE) return hwnd; | |
1325 | |
1326 /* Pseudo-process has not yet properly initialized since hwnd isn't set. | |
1327 * Fast sleep: On some NT kernels/systems, a Sleep(0) won't deschedule a | |
1328 * thread 100% of the time since threads are attached to a CPU for NUMA and | |
1329 * caching reasons, and the child thread was attached to a different CPU | |
1330 * therefore there is no workload on that CPU and Sleep(0) returns control | |
1331 * without yielding the time slot. | |
1332 * https://rt.perl.org/rt3/Ticket/Display.html?id=88840 | |
1333 */ | |
1334 Sleep(0); | |
1335 win32_async_check(aTHX); | |
1336 hwnd = w32_pseudo_child_message_hwnds[child]; | |
1337 if (hwnd != INVALID_HANDLE_VALUE) return hwnd; | |
1338 | |
1339 { | |
1340 unsigned int count = 0; | |
1341 /* No Sleep(1) if tries==0, just fail instead if we get this far. */ | |
1342 while (count++ < tries) { | |
1343 Sleep(1); | |
1344 win32_async_check(aTHX); | |
1345 hwnd = w32_pseudo_child_message_hwnds[child]; | |
1346 if (hwnd != INVALID_HANDLE_VALUE) return hwnd; | |
1347 } | |
1348 } | |
1349 | |
1350 Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled"); | |
1351 } | |
1352 #endif | |
1353 | |
1354 DllExport int | |
1355 win32_kill(int pid, int sig) | |
1356 { | |
1357 dTHX; | |
1358 long child; | |
1359 #ifdef USE_ITHREADS | |
1360 if (pid < 0) { | |
1361 /* it is a pseudo-forked child */ | |
1362 child = find_pseudo_pid(aTHX_ -pid); | |
1363 if (child >= 0) { | |
1364 HANDLE hProcess = w32_pseudo_child_handles[child]; | |
1365 switch (sig) { | |
1366 case 0: | |
1367 /* "Does process exist?" use of kill */ | |
1368 return 0; | |
1369 | |
1370 case 9: { | |
1371 /* kill -9 style un-graceful exit */ | |
1372 /* Do a wait to make sure child starts and isn't in DLL | |
1373 * Loader Lock */ | |
1374 HWND hwnd = get_hwnd_delay(aTHX, child, 5); | |
1375 if (TerminateThread(hProcess, sig)) { | |
1376 /* Allow the scheduler to finish cleaning up the other | |
1377 * thread. | |
1378 * Otherwise, if we ExitProcess() before another context | |
1379 * switch happens we will end up with a process exit | |
1380 * code of "sig" instead of our own exit status. | |
1381 * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976 | |
1382 */ | |
1383 Sleep(0); | |
1384 remove_dead_pseudo_process(child); | |
1385 return 0; | |
1386 } | |
1387 break; | |
1388 } | |
1389 | |
1390 default: { | |
1391 HWND hwnd = get_hwnd_delay(aTHX, child, 5); | |
1392 /* We fake signals to pseudo-processes using Win32 | |
1393 * message queue. */ | |
1394 if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) || | |
1395 PostThreadMessage(-pid, WM_USER_KILL, sig, 0)) | |
1396 { | |
1397 /* Don't wait for child process to terminate after we send a | |
1398 * SIGTERM because the child may be blocked in a system call | |
1399 * and never receive the signal. | |
1400 */ | |
1401 if (sig == SIGTERM) { | |
1402 Sleep(0); | |
1403 w32_pseudo_child_sigterm[child] = 1; | |
1404 } | |
1405 /* It might be us ... */ | |
1406 PERL_ASYNC_CHECK(); | |
1407 return 0; | |
1408 } | |
1409 break; | |
1410 } | |
1411 } /* switch */ | |
1412 } | |
1413 } | |
1414 else | |
1415 #endif | |
1416 { | |
1417 child = find_pid(aTHX_ pid); | |
1418 if (child >= 0) { | |
1419 if (my_kill(pid, sig)) { | |
1420 DWORD exitcode = 0; | |
1421 if (GetExitCodeProcess(w32_child_handles[child], &exitcode) && | |
1422 exitcode != STILL_ACTIVE) | |
1423 { | |
1424 remove_dead_process(child); | |
1425 } | |
1426 return 0; | |
1427 } | |
1428 } | |
1429 else { | |
1430 if (my_kill(pid, sig)) | |
1431 return 0; | |
1432 } | |
1433 } | |
1434 errno = EINVAL; | |
1435 return -1; | |
1436 } | |
1437 | |
1438 DllExport int | |
1439 win32_stat(const char *path, Stat_t *sbuf) | |
1440 { | |
1441 char buffer[MAX_PATH+1]; | |
1442 int l = strlen(path); | |
1443 dTHX; | |
1444 int res; | |
1445 int nlink = 1; | |
1446 BOOL expect_dir = FALSE; | |
1447 | |
1448 GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT", | |
1449 GV_NOTQUAL, SVt_PV); | |
1450 BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy)); | |
1451 | |
1452 if (l > 1) { | |
1453 switch(path[l - 1]) { | |
1454 /* FindFirstFile() and stat() are buggy with a trailing | |
1455 * slashes, except for the root directory of a drive */ | |
1456 case '\\': | |
1457 case '/': | |
1458 if (l > sizeof(buffer)) { | |
1459 errno = ENAMETOOLONG; | |
1460 return -1; | |
1461 } | |
1462 --l; | |
1463 strncpy(buffer, path, l); | |
1464 /* remove additional trailing slashes */ | |
1465 while (l > 1 && (buffer[l-1] == '/' || buffer[l-1] == '\\')) | |
1466 --l; | |
1467 /* add back slash if we otherwise end up with just a drive letter */ | |
1468 if (l == 2 && isALPHA(buffer[0]) && buffer[1] == ':') | |
1469 buffer[l++] = '\\'; | |
1470 buffer[l] = '\0'; | |
1471 path = buffer; | |
1472 expect_dir = TRUE; | |
1473 break; | |
1474 | |
1475 /* FindFirstFile() is buggy with "x:", so add a dot :-( */ | |
1476 case ':': | |
1477 if (l == 2 && isALPHA(path[0])) { | |
1478 buffer[0] = path[0]; | |
1479 buffer[1] = ':'; | |
1480 buffer[2] = '.'; | |
1481 buffer[3] = '\0'; | |
1482 l = 3; | |
1483 path = buffer; | |
1484 } | |
1485 break; | |
1486 } | |
1487 } | |
1488 | |
1489 path = PerlDir_mapA(path); | |
1490 l = strlen(path); | |
1491 | |
1492 if (!sloppy) { | |
1493 /* We must open & close the file once; otherwise file attribute changes */ | |
1494 /* might not yet have propagated to "other" hard links of the same file. */ | |
1495 /* This also gives us an opportunity to determine the number of links. */ | |
1496 HANDLE handle = CreateFileA(path, 0, 0, NULL, OPEN_EXISTING, 0, NULL); | |
1497 if (handle != INVALID_HANDLE_VALUE) { | |
1498 BY_HANDLE_FILE_INFORMATION bhi; | |
1499 if (GetFileInformationByHandle(handle, &bhi)) | |
1500 nlink = bhi.nNumberOfLinks; | |
1501 CloseHandle(handle); | |
1502 } | |
1503 } | |
1504 | |
1505 /* path will be mapped correctly above */ | |
1506 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
1507 res = _stati64(path, sbuf); | |
1508 #else | |
1509 res = stat(path, sbuf); | |
1510 #endif | |
1511 sbuf->st_nlink = nlink; | |
1512 | |
1513 if (res < 0) { | |
1514 /* CRT is buggy on sharenames, so make sure it really isn't. | |
1515 * XXX using GetFileAttributesEx() will enable us to set | |
1516 * sbuf->st_*time (but note that's not available on the | |
1517 * Windows of 1995) */ | |
1518 DWORD r = GetFileAttributesA(path); | |
1519 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_DIRECTORY)) { | |
1520 /* sbuf may still contain old garbage since stat() failed */ | |
1521 Zero(sbuf, 1, Stat_t); | |
1522 sbuf->st_mode = S_IFDIR | S_IREAD; | |
1523 errno = 0; | |
1524 if (!(r & FILE_ATTRIBUTE_READONLY)) | |
1525 sbuf->st_mode |= S_IWRITE | S_IEXEC; | |
1526 return 0; | |
1527 } | |
1528 } | |
1529 else { | |
1530 if (l == 3 && isALPHA(path[0]) && path[1] == ':' | |
1531 && (path[2] == '\\' || path[2] == '/')) | |
1532 { | |
1533 /* The drive can be inaccessible, some _stat()s are buggy */ | |
1534 if (!GetVolumeInformationA(path,NULL,0,NULL,NULL,NULL,NULL,0)) { | |
1535 errno = ENOENT; | |
1536 return -1; | |
1537 } | |
1538 } | |
1539 if (expect_dir && !S_ISDIR(sbuf->st_mode)) { | |
1540 errno = ENOTDIR; | |
1541 return -1; | |
1542 } | |
1543 if (S_ISDIR(sbuf->st_mode)) { | |
1544 /* Ensure the "write" bit is switched off in the mode for | |
1545 * directories with the read-only attribute set. Some compilers | |
1546 * switch it on for directories, which is technically correct | |
1547 * (directories are indeed always writable unless denied by DACLs), | |
1548 * but we want stat() and -w to reflect the state of the read-only | |
1549 * attribute for symmetry with chmod(). */ | |
1550 DWORD r = GetFileAttributesA(path); | |
1551 if (r != 0xffffffff && (r & FILE_ATTRIBUTE_READONLY)) { | |
1552 sbuf->st_mode &= ~S_IWRITE; | |
1553 } | |
1554 } | |
1555 } | |
1556 return res; | |
1557 } | |
1558 | |
1559 #define isSLASH(c) ((c) == '/' || (c) == '\\') | |
1560 #define SKIP_SLASHES(s) \ | |
1561 STMT_START { \ | |
1562 while (*(s) && isSLASH(*(s))) \ | |
1563 ++(s); \ | |
1564 } STMT_END | |
1565 #define COPY_NONSLASHES(d,s) \ | |
1566 STMT_START { \ | |
1567 while (*(s) && !isSLASH(*(s))) \ | |
1568 *(d)++ = *(s)++; \ | |
1569 } STMT_END | |
1570 | |
1571 /* Find the longname of a given path. path is destructively modified. | |
1572 * It should have space for at least MAX_PATH characters. */ | |
1573 DllExport char * | |
1574 win32_longpath(char *path) | |
1575 { | |
1576 WIN32_FIND_DATA fdata; | |
1577 HANDLE fhand; | |
1578 char tmpbuf[MAX_PATH+1]; | |
1579 char *tmpstart = tmpbuf; | |
1580 char *start = path; | |
1581 char sep; | |
1582 if (!path) | |
1583 return NULL; | |
1584 | |
1585 /* drive prefix */ | |
1586 if (isALPHA(path[0]) && path[1] == ':') { | |
1587 start = path + 2; | |
1588 *tmpstart++ = path[0]; | |
1589 *tmpstart++ = ':'; | |
1590 } | |
1591 /* UNC prefix */ | |
1592 else if (isSLASH(path[0]) && isSLASH(path[1])) { | |
1593 start = path + 2; | |
1594 *tmpstart++ = path[0]; | |
1595 *tmpstart++ = path[1]; | |
1596 SKIP_SLASHES(start); | |
1597 COPY_NONSLASHES(tmpstart,start); /* copy machine name */ | |
1598 if (*start) { | |
1599 *tmpstart++ = *start++; | |
1600 SKIP_SLASHES(start); | |
1601 COPY_NONSLASHES(tmpstart,start); /* copy share name */ | |
1602 } | |
1603 } | |
1604 *tmpstart = '\0'; | |
1605 while (*start) { | |
1606 /* copy initial slash, if any */ | |
1607 if (isSLASH(*start)) { | |
1608 *tmpstart++ = *start++; | |
1609 *tmpstart = '\0'; | |
1610 SKIP_SLASHES(start); | |
1611 } | |
1612 | |
1613 /* FindFirstFile() expands "." and "..", so we need to pass | |
1614 * those through unmolested */ | |
1615 if (*start == '.' | |
1616 && (!start[1] || isSLASH(start[1]) | |
1617 || (start[1] == '.' && (!start[2] || isSLASH(start[2]))))) | |
1618 { | |
1619 COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */ | |
1620 *tmpstart = '\0'; | |
1621 continue; | |
1622 } | |
1623 | |
1624 /* if this is the end, bust outta here */ | |
1625 if (!*start) | |
1626 break; | |
1627 | |
1628 /* now we're at a non-slash; walk up to next slash */ | |
1629 while (*start && !isSLASH(*start)) | |
1630 ++start; | |
1631 | |
1632 /* stop and find full name of component */ | |
1633 sep = *start; | |
1634 *start = '\0'; | |
1635 fhand = FindFirstFile(path,&fdata); | |
1636 *start = sep; | |
1637 if (fhand != INVALID_HANDLE_VALUE) { | |
1638 STRLEN len = strlen(fdata.cFileName); | |
1639 if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { | |
1640 strcpy(tmpstart, fdata.cFileName); | |
1641 tmpstart += len; | |
1642 FindClose(fhand); | |
1643 } | |
1644 else { | |
1645 FindClose(fhand); | |
1646 errno = ERANGE; | |
1647 return NULL; | |
1648 } | |
1649 } | |
1650 else { | |
1651 /* failed a step, just return without side effects */ | |
1652 /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ | |
1653 errno = EINVAL; | |
1654 return NULL; | |
1655 } | |
1656 } | |
1657 strcpy(path,tmpbuf); | |
1658 return path; | |
1659 } | |
1660 | |
1661 static void | |
1662 out_of_memory(void) | |
1663 { | |
1664 if (PL_curinterp) | |
1665 croak_no_mem(); | |
1666 exit(1); | |
1667 } | |
1668 | |
1669 void | |
1670 win32_croak_not_implemented(const char * fname) | |
1671 { | |
1672 PERL_ARGS_ASSERT_WIN32_CROAK_NOT_IMPLEMENTED; | |
1673 | |
1674 Perl_croak_nocontext("%s not implemented!\n", fname); | |
1675 } | |
1676 | |
1677 /* Converts a wide character (UTF-16) string to the Windows ANSI code page, | |
1678 * potentially using the system's default replacement character for any | |
1679 * unrepresentable characters. The caller must free() the returned string. */ | |
1680 static char* | |
1681 wstr_to_str(const wchar_t* wstr) | |
1682 { | |
1683 BOOL used_default = FALSE; | |
1684 size_t wlen = wcslen(wstr) + 1; | |
1685 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, | |
1686 NULL, 0, NULL, NULL); | |
1687 char* str = (char*)malloc(len); | |
1688 if (!str) | |
1689 out_of_memory(); | |
1690 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, | |
1691 str, len, NULL, &used_default); | |
1692 return str; | |
1693 } | |
1694 | |
1695 /* The win32_ansipath() function takes a Unicode filename and converts it | |
1696 * into the current Windows codepage. If some characters cannot be mapped, | |
1697 * then it will convert the short name instead. | |
1698 * | |
1699 * The buffer to the ansi pathname must be freed with win32_free() when it | |
1700 * it no longer needed. | |
1701 * | |
1702 * The argument to win32_ansipath() must exist before this function is | |
1703 * called; otherwise there is no way to determine the short path name. | |
1704 * | |
1705 * Ideas for future refinement: | |
1706 * - Only convert those segments of the path that are not in the current | |
1707 * codepage, but leave the other segments in their long form. | |
1708 * - If the resulting name is longer than MAX_PATH, start converting | |
1709 * additional path segments into short names until the full name | |
1710 * is shorter than MAX_PATH. Shorten the filename part last! | |
1711 */ | |
1712 DllExport char * | |
1713 win32_ansipath(const WCHAR *widename) | |
1714 { | |
1715 char *name; | |
1716 BOOL use_default = FALSE; | |
1717 size_t widelen = wcslen(widename)+1; | |
1718 int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, | |
1719 NULL, 0, NULL, NULL); | |
1720 name = (char*)win32_malloc(len); | |
1721 if (!name) | |
1722 out_of_memory(); | |
1723 | |
1724 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, | |
1725 name, len, NULL, &use_default); | |
1726 if (use_default) { | |
1727 DWORD shortlen = GetShortPathNameW(widename, NULL, 0); | |
1728 if (shortlen) { | |
1729 WCHAR *shortname = (WCHAR*)win32_malloc(shortlen*sizeof(WCHAR)); | |
1730 if (!shortname) | |
1731 out_of_memory(); | |
1732 shortlen = GetShortPathNameW(widename, shortname, shortlen)+1; | |
1733 | |
1734 len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, | |
1735 NULL, 0, NULL, NULL); | |
1736 name = (char*)win32_realloc(name, len); | |
1737 if (!name) | |
1738 out_of_memory(); | |
1739 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, | |
1740 name, len, NULL, NULL); | |
1741 win32_free(shortname); | |
1742 } | |
1743 } | |
1744 return name; | |
1745 } | |
1746 | |
1747 /* the returned string must be freed with win32_freeenvironmentstrings which is | |
1748 * implemented as a macro | |
1749 * void win32_freeenvironmentstrings(void* block) | |
1750 */ | |
1751 DllExport char * | |
1752 win32_getenvironmentstrings(void) | |
1753 { | |
1754 LPWSTR lpWStr, lpWTmp; | |
1755 LPSTR lpStr, lpTmp; | |
1756 DWORD env_len, wenvstrings_len = 0, aenvstrings_len = 0; | |
1757 | |
1758 /* Get the process environment strings */ | |
1759 lpWTmp = lpWStr = (LPWSTR) GetEnvironmentStringsW(); | |
1760 for (wenvstrings_len = 1; *lpWTmp != '\0'; lpWTmp += env_len + 1) { | |
1761 env_len = wcslen(lpWTmp); | |
1762 /* calculate the size of the environment strings */ | |
1763 wenvstrings_len += env_len + 1; | |
1764 } | |
1765 | |
1766 /* Get the number of bytes required to store the ACP encoded string */ | |
1767 aenvstrings_len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, | |
1768 lpWStr, wenvstrings_len, NULL, 0, NULL, NULL); | |
1769 lpTmp = lpStr = (char *)win32_calloc(aenvstrings_len, sizeof(char)); | |
1770 if(!lpTmp) | |
1771 out_of_memory(); | |
1772 | |
1773 /* Convert the string from UTF-16 encoding to ACP encoding */ | |
1774 WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, lpWStr, wenvstrings_len, lpStr, | |
1775 aenvstrings_len, NULL, NULL); | |
1776 | |
1777 FreeEnvironmentStringsW(lpWStr); | |
1778 | |
1779 return(lpStr); | |
1780 } | |
1781 | |
1782 DllExport char * | |
1783 win32_getenv(const char *name) | |
1784 { | |
1785 dTHX; | |
1786 DWORD needlen; | |
1787 SV *curitem = NULL; | |
1788 DWORD last_err; | |
1789 | |
1790 needlen = GetEnvironmentVariableA(name,NULL,0); | |
1791 if (needlen != 0) { | |
1792 curitem = sv_2mortal(newSVpvs("")); | |
1793 do { | |
1794 SvGROW(curitem, needlen+1); | |
1795 needlen = GetEnvironmentVariableA(name,SvPVX(curitem), | |
1796 needlen); | |
1797 } while (needlen >= SvLEN(curitem)); | |
1798 SvCUR_set(curitem, needlen); | |
1799 } | |
1800 else { | |
1801 last_err = GetLastError(); | |
1802 if (last_err == ERROR_NOT_ENOUGH_MEMORY) { | |
1803 /* It appears the variable is in the env, but the Win32 API | |
1804 doesn't have a canned way of getting it. So we fall back to | |
1805 grabbing the whole env and pulling this value out if possible */ | |
1806 char *envv = GetEnvironmentStrings(); | |
1807 char *cur = envv; | |
1808 STRLEN len; | |
1809 while (*cur) { | |
1810 char *end = strchr(cur,'='); | |
1811 if (end && end != cur) { | |
1812 *end = '\0'; | |
1813 if (!strcmp(cur,name)) { | |
1814 curitem = sv_2mortal(newSVpv(end+1,0)); | |
1815 *end = '='; | |
1816 break; | |
1817 } | |
1818 *end = '='; | |
1819 cur = end + strlen(end+1)+2; | |
1820 } | |
1821 else if ((len = strlen(cur))) | |
1822 cur += len+1; | |
1823 } | |
1824 FreeEnvironmentStrings(envv); | |
1825 } | |
1826 else { | |
1827 /* last ditch: allow any environment variables that begin with 'PERL' | |
1828 to be obtained from the registry, if found there */ | |
1829 if (strncmp(name, "PERL", 4) == 0) | |
1830 (void)get_regstr(name, &curitem); | |
1831 } | |
1832 } | |
1833 if (curitem && SvCUR(curitem)) | |
1834 return SvPVX(curitem); | |
1835 | |
1836 return NULL; | |
1837 } | |
1838 | |
1839 DllExport int | |
1840 win32_putenv(const char *name) | |
1841 { | |
1842 char* curitem; | |
1843 char* val; | |
1844 int relval = -1; | |
1845 | |
1846 if (name) { | |
1847 curitem = (char *) win32_malloc(strlen(name)+1); | |
1848 strcpy(curitem, name); | |
1849 val = strchr(curitem, '='); | |
1850 if (val) { | |
1851 /* The sane way to deal with the environment. | |
1852 * Has these advantages over putenv() & co.: | |
1853 * * enables us to store a truly empty value in the | |
1854 * environment (like in UNIX). | |
1855 * * we don't have to deal with RTL globals, bugs and leaks | |
1856 * (specifically, see http://support.microsoft.com/kb/235601). | |
1857 * * Much faster. | |
1858 * Why you may want to use the RTL environment handling | |
1859 * (previously enabled by USE_WIN32_RTL_ENV): | |
1860 * * environ[] and RTL functions will not reflect changes, | |
1861 * which might be an issue if extensions want to access | |
1862 * the env. via RTL. This cuts both ways, since RTL will | |
1863 * not see changes made by extensions that call the Win32 | |
1864 * functions directly, either. | |
1865 * GSAR 97-06-07 | |
1866 */ | |
1867 *val++ = '\0'; | |
1868 if (SetEnvironmentVariableA(curitem, *val ? val : NULL)) | |
1869 relval = 0; | |
1870 } | |
1871 win32_free(curitem); | |
1872 } | |
1873 return relval; | |
1874 } | |
1875 | |
1876 static long | |
1877 filetime_to_clock(PFILETIME ft) | |
1878 { | |
1879 __int64 qw = ft->dwHighDateTime; | |
1880 qw <<= 32; | |
1881 qw |= ft->dwLowDateTime; | |
1882 qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ | |
1883 return (long) qw; | |
1884 } | |
1885 | |
1886 DllExport int | |
1887 win32_times(struct tms *timebuf) | |
1888 { | |
1889 FILETIME user; | |
1890 FILETIME kernel; | |
1891 FILETIME dummy; | |
1892 clock_t process_time_so_far = clock(); | |
1893 if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, | |
1894 &kernel,&user)) { | |
1895 timebuf->tms_utime = filetime_to_clock(&user); | |
1896 timebuf->tms_stime = filetime_to_clock(&kernel); | |
1897 timebuf->tms_cutime = 0; | |
1898 timebuf->tms_cstime = 0; | |
1899 } else { | |
1900 /* That failed - e.g. Win95 fallback to clock() */ | |
1901 timebuf->tms_utime = process_time_so_far; | |
1902 timebuf->tms_stime = 0; | |
1903 timebuf->tms_cutime = 0; | |
1904 timebuf->tms_cstime = 0; | |
1905 } | |
1906 return process_time_so_far; | |
1907 } | |
1908 | |
1909 /* fix utime() so it works on directories in NT */ | |
1910 static BOOL | |
1911 filetime_from_time(PFILETIME pFileTime, time_t Time) | |
1912 { | |
1913 struct tm *pTM = localtime(&Time); | |
1914 SYSTEMTIME SystemTime; | |
1915 FILETIME LocalTime; | |
1916 | |
1917 if (pTM == NULL) | |
1918 return FALSE; | |
1919 | |
1920 SystemTime.wYear = pTM->tm_year + 1900; | |
1921 SystemTime.wMonth = pTM->tm_mon + 1; | |
1922 SystemTime.wDay = pTM->tm_mday; | |
1923 SystemTime.wHour = pTM->tm_hour; | |
1924 SystemTime.wMinute = pTM->tm_min; | |
1925 SystemTime.wSecond = pTM->tm_sec; | |
1926 SystemTime.wMilliseconds = 0; | |
1927 | |
1928 return SystemTimeToFileTime(&SystemTime, &LocalTime) && | |
1929 LocalFileTimeToFileTime(&LocalTime, pFileTime); | |
1930 } | |
1931 | |
1932 DllExport int | |
1933 win32_unlink(const char *filename) | |
1934 { | |
1935 dTHX; | |
1936 int ret; | |
1937 DWORD attrs; | |
1938 | |
1939 filename = PerlDir_mapA(filename); | |
1940 attrs = GetFileAttributesA(filename); | |
1941 if (attrs == 0xFFFFFFFF) { | |
1942 errno = ENOENT; | |
1943 return -1; | |
1944 } | |
1945 if (attrs & FILE_ATTRIBUTE_READONLY) { | |
1946 (void)SetFileAttributesA(filename, attrs & ~FILE_ATTRIBUTE_READONLY); | |
1947 ret = unlink(filename); | |
1948 if (ret == -1) | |
1949 (void)SetFileAttributesA(filename, attrs); | |
1950 } | |
1951 else | |
1952 ret = unlink(filename); | |
1953 return ret; | |
1954 } | |
1955 | |
1956 DllExport int | |
1957 win32_utime(const char *filename, struct utimbuf *times) | |
1958 { | |
1959 dTHX; | |
1960 HANDLE handle; | |
1961 FILETIME ftCreate; | |
1962 FILETIME ftAccess; | |
1963 FILETIME ftWrite; | |
1964 struct utimbuf TimeBuffer; | |
1965 int rc; | |
1966 | |
1967 filename = PerlDir_mapA(filename); | |
1968 rc = utime(filename, times); | |
1969 | |
1970 /* EACCES: path specifies directory or readonly file */ | |
1971 if (rc == 0 || errno != EACCES) | |
1972 return rc; | |
1973 | |
1974 if (times == NULL) { | |
1975 times = &TimeBuffer; | |
1976 time(×->actime); | |
1977 times->modtime = times->actime; | |
1978 } | |
1979 | |
1980 /* This will (and should) still fail on readonly files */ | |
1981 handle = CreateFileA(filename, GENERIC_READ | GENERIC_WRITE, | |
1982 FILE_SHARE_READ | FILE_SHARE_DELETE, NULL, | |
1983 OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); | |
1984 if (handle == INVALID_HANDLE_VALUE) | |
1985 return rc; | |
1986 | |
1987 if (GetFileTime(handle, &ftCreate, &ftAccess, &ftWrite) && | |
1988 filetime_from_time(&ftAccess, times->actime) && | |
1989 filetime_from_time(&ftWrite, times->modtime) && | |
1990 SetFileTime(handle, &ftCreate, &ftAccess, &ftWrite)) | |
1991 { | |
1992 rc = 0; | |
1993 } | |
1994 | |
1995 CloseHandle(handle); | |
1996 return rc; | |
1997 } | |
1998 | |
1999 typedef union { | |
2000 unsigned __int64 ft_i64; | |
2001 FILETIME ft_val; | |
2002 } FT_t; | |
2003 | |
2004 #ifdef __GNUC__ | |
2005 #define Const64(x) x##LL | |
2006 #else | |
2007 #define Const64(x) x##i64 | |
2008 #endif | |
2009 /* Number of 100 nanosecond units from 1/1/1601 to 1/1/1970 */ | |
2010 #define EPOCH_BIAS Const64(116444736000000000) | |
2011 | |
2012 /* NOTE: This does not compute the timezone info (doing so can be expensive, | |
2013 * and appears to be unsupported even by glibc) */ | |
2014 DllExport int | |
2015 win32_gettimeofday(struct timeval *tp, void *not_used) | |
2016 { | |
2017 FT_t ft; | |
2018 | |
2019 /* this returns time in 100-nanosecond units (i.e. tens of usecs) */ | |
2020 GetSystemTimeAsFileTime(&ft.ft_val); | |
2021 | |
2022 /* seconds since epoch */ | |
2023 tp->tv_sec = (long)((ft.ft_i64 - EPOCH_BIAS) / Const64(10000000)); | |
2024 | |
2025 /* microseconds remaining */ | |
2026 tp->tv_usec = (long)((ft.ft_i64 / Const64(10)) % Const64(1000000)); | |
2027 | |
2028 return 0; | |
2029 } | |
2030 | |
2031 DllExport int | |
2032 win32_uname(struct utsname *name) | |
2033 { | |
2034 struct hostent *hep; | |
2035 STRLEN nodemax = sizeof(name->nodename)-1; | |
2036 | |
2037 /* sysname */ | |
2038 switch (g_osver.dwPlatformId) { | |
2039 case VER_PLATFORM_WIN32_WINDOWS: | |
2040 strcpy(name->sysname, "Windows"); | |
2041 break; | |
2042 case VER_PLATFORM_WIN32_NT: | |
2043 strcpy(name->sysname, "Windows NT"); | |
2044 break; | |
2045 case VER_PLATFORM_WIN32s: | |
2046 strcpy(name->sysname, "Win32s"); | |
2047 break; | |
2048 default: | |
2049 strcpy(name->sysname, "Win32 Unknown"); | |
2050 break; | |
2051 } | |
2052 | |
2053 /* release */ | |
2054 sprintf(name->release, "%d.%d", | |
2055 g_osver.dwMajorVersion, g_osver.dwMinorVersion); | |
2056 | |
2057 /* version */ | |
2058 sprintf(name->version, "Build %d", | |
2059 g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT | |
2060 ? g_osver.dwBuildNumber : (g_osver.dwBuildNumber & 0xffff)); | |
2061 if (g_osver.szCSDVersion[0]) { | |
2062 char *buf = name->version + strlen(name->version); | |
2063 sprintf(buf, " (%s)", g_osver.szCSDVersion); | |
2064 } | |
2065 | |
2066 /* nodename */ | |
2067 hep = win32_gethostbyname("localhost"); | |
2068 if (hep) { | |
2069 STRLEN len = strlen(hep->h_name); | |
2070 if (len <= nodemax) { | |
2071 strcpy(name->nodename, hep->h_name); | |
2072 } | |
2073 else { | |
2074 strncpy(name->nodename, hep->h_name, nodemax); | |
2075 name->nodename[nodemax] = '\0'; | |
2076 } | |
2077 } | |
2078 else { | |
2079 DWORD sz = nodemax; | |
2080 if (!GetComputerName(name->nodename, &sz)) | |
2081 *name->nodename = '\0'; | |
2082 } | |
2083 | |
2084 /* machine (architecture) */ | |
2085 { | |
2086 SYSTEM_INFO info; | |
2087 DWORD procarch; | |
2088 char *arch; | |
2089 GetSystemInfo(&info); | |
2090 | |
2091 #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION)) | |
2092 procarch = info.u.s.wProcessorArchitecture; | |
2093 #else | |
2094 procarch = info.wProcessorArchitecture; | |
2095 #endif | |
2096 switch (procarch) { | |
2097 case PROCESSOR_ARCHITECTURE_INTEL: | |
2098 arch = "x86"; break; | |
2099 case PROCESSOR_ARCHITECTURE_IA64: | |
2100 arch = "ia64"; break; | |
2101 case PROCESSOR_ARCHITECTURE_AMD64: | |
2102 arch = "amd64"; break; | |
2103 case PROCESSOR_ARCHITECTURE_UNKNOWN: | |
2104 arch = "unknown"; break; | |
2105 default: | |
2106 sprintf(name->machine, "unknown(0x%x)", procarch); | |
2107 arch = name->machine; | |
2108 break; | |
2109 } | |
2110 if (name->machine != arch) | |
2111 strcpy(name->machine, arch); | |
2112 } | |
2113 return 0; | |
2114 } | |
2115 | |
2116 /* Timing related stuff */ | |
2117 | |
2118 int | |
2119 do_raise(pTHX_ int sig) | |
2120 { | |
2121 if (sig < SIG_SIZE) { | |
2122 Sighandler_t handler = w32_sighandler[sig]; | |
2123 if (handler == SIG_IGN) { | |
2124 return 0; | |
2125 } | |
2126 else if (handler != SIG_DFL) { | |
2127 (*handler)(sig); | |
2128 return 0; | |
2129 } | |
2130 else { | |
2131 /* Choose correct default behaviour */ | |
2132 switch (sig) { | |
2133 #ifdef SIGCLD | |
2134 case SIGCLD: | |
2135 #endif | |
2136 #ifdef SIGCHLD | |
2137 case SIGCHLD: | |
2138 #endif | |
2139 case 0: | |
2140 return 0; | |
2141 case SIGTERM: | |
2142 default: | |
2143 break; | |
2144 } | |
2145 } | |
2146 } | |
2147 /* Tell caller to exit thread/process as appropriate */ | |
2148 return 1; | |
2149 } | |
2150 | |
2151 void | |
2152 sig_terminate(pTHX_ int sig) | |
2153 { | |
2154 Perl_warn(aTHX_ "Terminating on signal SIG%s(%d)\n",PL_sig_name[sig], sig); | |
2155 /* exit() seems to be safe, my_exit() or die() is a problem in ^C | |
2156 thread | |
2157 */ | |
2158 exit(sig); | |
2159 } | |
2160 | |
2161 DllExport int | |
2162 win32_async_check(pTHX) | |
2163 { | |
2164 MSG msg; | |
2165 HWND hwnd = w32_message_hwnd; | |
2166 | |
2167 /* Reset w32_poll_count before doing anything else, incase we dispatch | |
2168 * messages that end up calling back into perl */ | |
2169 w32_poll_count = 0; | |
2170 | |
2171 if (hwnd != INVALID_HANDLE_VALUE) { | |
2172 /* Passing PeekMessage -1 as HWND (2nd arg) only gets PostThreadMessage() messages | |
2173 * and ignores window messages - should co-exist better with windows apps e.g. Tk | |
2174 */ | |
2175 if (hwnd == NULL) | |
2176 hwnd = (HWND)-1; | |
2177 | |
2178 while (PeekMessage(&msg, hwnd, WM_TIMER, WM_TIMER, PM_REMOVE|PM_NOYIELD) || | |
2179 PeekMessage(&msg, hwnd, WM_USER_MIN, WM_USER_MAX, PM_REMOVE|PM_NOYIELD)) | |
2180 { | |
2181 /* re-post a WM_QUIT message (we'll mark it as read later) */ | |
2182 if(msg.message == WM_QUIT) { | |
2183 PostQuitMessage((int)msg.wParam); | |
2184 break; | |
2185 } | |
2186 | |
2187 if(!CallMsgFilter(&msg, MSGF_USER)) | |
2188 { | |
2189 TranslateMessage(&msg); | |
2190 DispatchMessage(&msg); | |
2191 } | |
2192 } | |
2193 } | |
2194 | |
2195 /* Call PeekMessage() to mark all pending messages in the queue as "old". | |
2196 * This is necessary when we are being called by win32_msgwait() to | |
2197 * make sure MsgWaitForMultipleObjects() stops reporting the same waiting | |
2198 * message over and over. An example how this can happen is when | |
2199 * Perl is calling win32_waitpid() inside a GUI application and the GUI | |
2200 * is generating messages before the process terminated. | |
2201 */ | |
2202 PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE|PM_NOYIELD); | |
2203 | |
2204 /* Above or other stuff may have set a signal flag */ | |
2205 if (PL_sig_pending) | |
2206 despatch_signals(); | |
2207 | |
2208 return 1; | |
2209 } | |
2210 | |
2211 /* This function will not return until the timeout has elapsed, or until | |
2212 * one of the handles is ready. */ | |
2213 DllExport DWORD | |
2214 win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD resultp) | |
2215 { | |
2216 /* We may need several goes at this - so compute when we stop */ | |
2217 FT_t ticks = {0}; | |
2218 unsigned __int64 endtime = timeout; | |
2219 if (timeout != INFINITE) { | |
2220 GetSystemTimeAsFileTime(&ticks.ft_val); | |
2221 ticks.ft_i64 /= 10000; | |
2222 endtime += ticks.ft_i64; | |
2223 } | |
2224 /* This was a race condition. Do not let a non INFINITE timeout to | |
2225 * MsgWaitForMultipleObjects roll under 0 creating a near | |
2226 * infinity/~(UINT32)0 timeout which will appear as a deadlock to the | |
2227 * user who did a CORE perl function with a non infinity timeout, | |
2228 * sleep for example. This is 64 to 32 truncation minefield. | |
2229 * | |
2230 * This scenario can only be created if the timespan from the return of | |
2231 * MsgWaitForMultipleObjects to GetSystemTimeAsFileTime exceeds 1 ms. To | |
2232 * generate the scenario, manual breakpoints in a C debugger are required, | |
2233 * or a context switch occurred in win32_async_check in PeekMessage, or random | |
2234 * messages are delivered to the *thread* message queue of the Perl thread | |
2235 * from another process (msctf.dll doing IPC among its instances, VS debugger | |
2236 * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096]. | |
2237 */ | |
2238 while (ticks.ft_i64 <= endtime) { | |
2239 /* if timeout's type is lengthened, remember to split 64b timeout | |
2240 * into multiple non-infinity runs of MWFMO */ | |
2241 DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE, | |
2242 (DWORD)(endtime - ticks.ft_i64), | |
2243 QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE); | |
2244 if (resultp) | |
2245 *resultp = result; | |
2246 if (result == WAIT_TIMEOUT) { | |
2247 /* Ran out of time - explicit return of zero to avoid -ve if we | |
2248 have scheduling issues | |
2249 */ | |
2250 return 0; | |
2251 } | |
2252 if (timeout != INFINITE) { | |
2253 GetSystemTimeAsFileTime(&ticks.ft_val); | |
2254 ticks.ft_i64 /= 10000; | |
2255 } | |
2256 if (result == WAIT_OBJECT_0 + count) { | |
2257 /* Message has arrived - check it */ | |
2258 (void)win32_async_check(aTHX); | |
2259 } | |
2260 else { | |
2261 /* Not timeout or message - one of handles is ready */ | |
2262 break; | |
2263 } | |
2264 } | |
2265 /* If we are past the end say zero */ | |
2266 if (!ticks.ft_i64 || ticks.ft_i64 > endtime) | |
2267 return 0; | |
2268 /* compute time left to wait */ | |
2269 ticks.ft_i64 = endtime - ticks.ft_i64; | |
2270 /* if more ms than DWORD, then return max DWORD */ | |
2271 return ticks.ft_i64 <= UINT_MAX ? (DWORD)ticks.ft_i64 : UINT_MAX; | |
2272 } | |
2273 | |
2274 int | |
2275 win32_internal_wait(pTHX_ int *status, DWORD timeout) | |
2276 { | |
2277 /* XXX this wait emulation only knows about processes | |
2278 * spawned via win32_spawnvp(P_NOWAIT, ...). | |
2279 */ | |
2280 int i, retval; | |
2281 DWORD exitcode, waitcode; | |
2282 | |
2283 #ifdef USE_ITHREADS | |
2284 if (w32_num_pseudo_children) { | |
2285 win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles, | |
2286 timeout, &waitcode); | |
2287 /* Time out here if there are no other children to wait for. */ | |
2288 if (waitcode == WAIT_TIMEOUT) { | |
2289 if (!w32_num_children) { | |
2290 return 0; | |
2291 } | |
2292 } | |
2293 else if (waitcode != WAIT_FAILED) { | |
2294 if (waitcode >= WAIT_ABANDONED_0 | |
2295 && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) | |
2296 i = waitcode - WAIT_ABANDONED_0; | |
2297 else | |
2298 i = waitcode - WAIT_OBJECT_0; | |
2299 if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { | |
2300 *status = (int)((exitcode & 0xff) << 8); | |
2301 retval = (int)w32_pseudo_child_pids[i]; | |
2302 remove_dead_pseudo_process(i); | |
2303 return -retval; | |
2304 } | |
2305 } | |
2306 } | |
2307 #endif | |
2308 | |
2309 if (!w32_num_children) { | |
2310 errno = ECHILD; | |
2311 return -1; | |
2312 } | |
2313 | |
2314 /* if a child exists, wait for it to die */ | |
2315 win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode); | |
2316 if (waitcode == WAIT_TIMEOUT) { | |
2317 return 0; | |
2318 } | |
2319 if (waitcode != WAIT_FAILED) { | |
2320 if (waitcode >= WAIT_ABANDONED_0 | |
2321 && waitcode < WAIT_ABANDONED_0 + w32_num_children) | |
2322 i = waitcode - WAIT_ABANDONED_0; | |
2323 else | |
2324 i = waitcode - WAIT_OBJECT_0; | |
2325 if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) { | |
2326 *status = (int)((exitcode & 0xff) << 8); | |
2327 retval = (int)w32_child_pids[i]; | |
2328 remove_dead_process(i); | |
2329 return retval; | |
2330 } | |
2331 } | |
2332 | |
2333 errno = GetLastError(); | |
2334 return -1; | |
2335 } | |
2336 | |
2337 DllExport int | |
2338 win32_waitpid(int pid, int *status, int flags) | |
2339 { | |
2340 dTHX; | |
2341 DWORD timeout = (flags & WNOHANG) ? 0 : INFINITE; | |
2342 int retval = -1; | |
2343 long child; | |
2344 if (pid == -1) /* XXX threadid == 1 ? */ | |
2345 return win32_internal_wait(aTHX_ status, timeout); | |
2346 #ifdef USE_ITHREADS | |
2347 else if (pid < 0) { | |
2348 child = find_pseudo_pid(aTHX_ -pid); | |
2349 if (child >= 0) { | |
2350 HANDLE hThread = w32_pseudo_child_handles[child]; | |
2351 DWORD waitcode; | |
2352 win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode); | |
2353 if (waitcode == WAIT_TIMEOUT) { | |
2354 return 0; | |
2355 } | |
2356 else if (waitcode == WAIT_OBJECT_0) { | |
2357 if (GetExitCodeThread(hThread, &waitcode)) { | |
2358 *status = (int)((waitcode & 0xff) << 8); | |
2359 retval = (int)w32_pseudo_child_pids[child]; | |
2360 remove_dead_pseudo_process(child); | |
2361 return -retval; | |
2362 } | |
2363 } | |
2364 else | |
2365 errno = ECHILD; | |
2366 } | |
2367 } | |
2368 #endif | |
2369 else { | |
2370 HANDLE hProcess; | |
2371 DWORD waitcode; | |
2372 child = find_pid(aTHX_ pid); | |
2373 if (child >= 0) { | |
2374 hProcess = w32_child_handles[child]; | |
2375 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); | |
2376 if (waitcode == WAIT_TIMEOUT) { | |
2377 return 0; | |
2378 } | |
2379 else if (waitcode == WAIT_OBJECT_0) { | |
2380 if (GetExitCodeProcess(hProcess, &waitcode)) { | |
2381 *status = (int)((waitcode & 0xff) << 8); | |
2382 retval = (int)w32_child_pids[child]; | |
2383 remove_dead_process(child); | |
2384 return retval; | |
2385 } | |
2386 } | |
2387 else | |
2388 errno = ECHILD; | |
2389 } | |
2390 else { | |
2391 hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); | |
2392 if (hProcess) { | |
2393 win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); | |
2394 if (waitcode == WAIT_TIMEOUT) { | |
2395 CloseHandle(hProcess); | |
2396 return 0; | |
2397 } | |
2398 else if (waitcode == WAIT_OBJECT_0) { | |
2399 if (GetExitCodeProcess(hProcess, &waitcode)) { | |
2400 *status = (int)((waitcode & 0xff) << 8); | |
2401 CloseHandle(hProcess); | |
2402 return pid; | |
2403 } | |
2404 } | |
2405 CloseHandle(hProcess); | |
2406 } | |
2407 else | |
2408 errno = ECHILD; | |
2409 } | |
2410 } | |
2411 return retval >= 0 ? pid : retval; | |
2412 } | |
2413 | |
2414 DllExport int | |
2415 win32_wait(int *status) | |
2416 { | |
2417 dTHX; | |
2418 return win32_internal_wait(aTHX_ status, INFINITE); | |
2419 } | |
2420 | |
2421 DllExport unsigned int | |
2422 win32_sleep(unsigned int t) | |
2423 { | |
2424 dTHX; | |
2425 /* Win32 times are in ms so *1000 in and /1000 out */ | |
2426 if (t > UINT_MAX / 1000) { | |
2427 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), | |
2428 "sleep(%lu) too large", t); | |
2429 } | |
2430 return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000; | |
2431 } | |
2432 | |
2433 DllExport unsigned int | |
2434 win32_alarm(unsigned int sec) | |
2435 { | |
2436 /* | |
2437 * the 'obvious' implentation is SetTimer() with a callback | |
2438 * which does whatever receiving SIGALRM would do | |
2439 * we cannot use SIGALRM even via raise() as it is not | |
2440 * one of the supported codes in <signal.h> | |
2441 */ | |
2442 dTHX; | |
2443 | |
2444 if (w32_message_hwnd == INVALID_HANDLE_VALUE) | |
2445 w32_message_hwnd = win32_create_message_window(); | |
2446 | |
2447 if (sec) { | |
2448 if (w32_message_hwnd == NULL) | |
2449 w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL); | |
2450 else { | |
2451 w32_timerid = 1; | |
2452 SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL); | |
2453 } | |
2454 } | |
2455 else { | |
2456 if (w32_timerid) { | |
2457 KillTimer(w32_message_hwnd, w32_timerid); | |
2458 w32_timerid = 0; | |
2459 } | |
2460 } | |
2461 return 0; | |
2462 } | |
2463 | |
2464 extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); | |
2465 | |
2466 DllExport char * | |
2467 win32_crypt(const char *txt, const char *salt) | |
2468 { | |
2469 dTHX; | |
2470 return des_fcrypt(txt, salt, w32_crypt_buffer); | |
2471 } | |
2472 | |
2473 /* simulate flock by locking a range on the file */ | |
2474 | |
2475 #define LK_LEN 0xffff0000 | |
2476 | |
2477 DllExport int | |
2478 win32_flock(int fd, int oper) | |
2479 { | |
2480 OVERLAPPED o; | |
2481 int i = -1; | |
2482 HANDLE fh; | |
2483 | |
2484 fh = (HANDLE)_get_osfhandle(fd); | |
2485 if (fh == (HANDLE)-1) /* _get_osfhandle() already sets errno to EBADF */ | |
2486 return -1; | |
2487 | |
2488 memset(&o, 0, sizeof(o)); | |
2489 | |
2490 switch(oper) { | |
2491 case LOCK_SH: /* shared lock */ | |
2492 if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o)) | |
2493 i = 0; | |
2494 break; | |
2495 case LOCK_EX: /* exclusive lock */ | |
2496 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o)) | |
2497 i = 0; | |
2498 break; | |
2499 case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ | |
2500 if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) | |
2501 i = 0; | |
2502 break; | |
2503 case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ | |
2504 if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, | |
2505 0, LK_LEN, 0, &o)) | |
2506 i = 0; | |
2507 break; | |
2508 case LOCK_UN: /* unlock lock */ | |
2509 if (UnlockFileEx(fh, 0, LK_LEN, 0, &o)) | |
2510 i = 0; | |
2511 break; | |
2512 default: /* unknown */ | |
2513 errno = EINVAL; | |
2514 return -1; | |
2515 } | |
2516 if (i == -1) { | |
2517 if (GetLastError() == ERROR_LOCK_VIOLATION) | |
2518 errno = EWOULDBLOCK; | |
2519 else | |
2520 errno = EINVAL; | |
2521 } | |
2522 return i; | |
2523 } | |
2524 | |
2525 #undef LK_LEN | |
2526 | |
2527 extern int convert_wsa_error_to_errno(int wsaerr); /* in win32sck.c */ | |
2528 | |
2529 /* Get the errno value corresponding to the given err. This function is not | |
2530 * intended to handle conversion of general GetLastError() codes. It only exists | |
2531 * to translate Windows sockets error codes from WSAGetLastError(). Such codes | |
2532 * used to be assigned to errno/$! in earlier versions of perl; this function is | |
2533 * used to catch any old Perl code which is still trying to assign such values | |
2534 * to $! and convert them to errno values instead. | |
2535 */ | |
2536 int | |
2537 win32_get_errno(int err) | |
2538 { | |
2539 return convert_wsa_error_to_errno(err); | |
2540 } | |
2541 | |
2542 /* | |
2543 * redirected io subsystem for all XS modules | |
2544 * | |
2545 */ | |
2546 | |
2547 DllExport int * | |
2548 win32_errno(void) | |
2549 { | |
2550 return (&errno); | |
2551 } | |
2552 | |
2553 DllExport char *** | |
2554 win32_environ(void) | |
2555 { | |
2556 return (&(_environ)); | |
2557 } | |
2558 | |
2559 /* the rest are the remapped stdio routines */ | |
2560 DllExport FILE * | |
2561 win32_stderr(void) | |
2562 { | |
2563 return (stderr); | |
2564 } | |
2565 | |
2566 DllExport FILE * | |
2567 win32_stdin(void) | |
2568 { | |
2569 return (stdin); | |
2570 } | |
2571 | |
2572 DllExport FILE * | |
2573 win32_stdout(void) | |
2574 { | |
2575 return (stdout); | |
2576 } | |
2577 | |
2578 DllExport int | |
2579 win32_ferror(FILE *fp) | |
2580 { | |
2581 return (ferror(fp)); | |
2582 } | |
2583 | |
2584 | |
2585 DllExport int | |
2586 win32_feof(FILE *fp) | |
2587 { | |
2588 return (feof(fp)); | |
2589 } | |
2590 | |
2591 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT | |
2592 extern int convert_errno_to_wsa_error(int err); /* in win32sck.c */ | |
2593 #endif | |
2594 | |
2595 /* | |
2596 * Since the errors returned by the socket error function | |
2597 * WSAGetLastError() are not known by the library routine strerror | |
2598 * we have to roll our own to cover the case of socket errors | |
2599 * that could not be converted to regular errno values by | |
2600 * get_last_socket_error() in win32/win32sck.c. | |
2601 */ | |
2602 | |
2603 DllExport char * | |
2604 win32_strerror(int e) | |
2605 { | |
2606 #if !defined __MINGW32__ /* compiler intolerance */ | |
2607 extern int sys_nerr; | |
2608 #endif | |
2609 | |
2610 if (e < 0 || e > sys_nerr) { | |
2611 dTHXa(NULL); | |
2612 if (e < 0) | |
2613 e = GetLastError(); | |
2614 #ifdef ERRNO_HAS_POSIX_SUPPLEMENT | |
2615 /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno | |
2616 * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but | |
2617 * sys_nerr is still 43 and strerror() returns "Unknown error" for them. | |
2618 * We must therefore still roll our own messages for these codes, and | |
2619 * additionally map them to corresponding Windows (sockets) error codes | |
2620 * first to avoid getting the wrong system message. | |
2621 */ | |
2622 else if (e >= EADDRINUSE && e <= EWOULDBLOCK) { | |
2623 e = convert_errno_to_wsa_error(e); | |
2624 } | |
2625 #endif | |
2626 | |
2627 aTHXa(PERL_GET_THX); | |
2628 if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | |
2629 |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0, | |
2630 w32_strerror_buffer, sizeof(w32_strerror_buffer), | |
2631 NULL) == 0) | |
2632 { | |
2633 strcpy(w32_strerror_buffer, "Unknown Error"); | |
2634 } | |
2635 return w32_strerror_buffer; | |
2636 } | |
2637 #undef strerror | |
2638 return strerror(e); | |
2639 #define strerror win32_strerror | |
2640 } | |
2641 | |
2642 DllExport void | |
2643 win32_str_os_error(void *sv, DWORD dwErr) | |
2644 { | |
2645 DWORD dwLen; | |
2646 char *sMsg; | |
2647 dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER | |
2648 |FORMAT_MESSAGE_IGNORE_INSERTS | |
2649 |FORMAT_MESSAGE_FROM_SYSTEM, NULL, | |
2650 dwErr, 0, (char *)&sMsg, 1, NULL); | |
2651 /* strip trailing whitespace and period */ | |
2652 if (0 < dwLen) { | |
2653 do { | |
2654 --dwLen; /* dwLen doesn't include trailing null */ | |
2655 } while (0 < dwLen && isSPACE(sMsg[dwLen])); | |
2656 if ('.' != sMsg[dwLen]) | |
2657 dwLen++; | |
2658 sMsg[dwLen] = '\0'; | |
2659 } | |
2660 if (0 == dwLen) { | |
2661 sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/); | |
2662 if (sMsg) | |
2663 dwLen = sprintf(sMsg, | |
2664 "Unknown error #0x%lX (lookup 0x%lX)", | |
2665 dwErr, GetLastError()); | |
2666 } | |
2667 if (sMsg) { | |
2668 dTHX; | |
2669 sv_setpvn((SV*)sv, sMsg, dwLen); | |
2670 LocalFree(sMsg); | |
2671 } | |
2672 } | |
2673 | |
2674 DllExport int | |
2675 win32_fprintf(FILE *fp, const char *format, ...) | |
2676 { | |
2677 va_list marker; | |
2678 va_start(marker, format); /* Initialize variable arguments. */ | |
2679 | |
2680 return (vfprintf(fp, format, marker)); | |
2681 } | |
2682 | |
2683 DllExport int | |
2684 win32_printf(const char *format, ...) | |
2685 { | |
2686 va_list marker; | |
2687 va_start(marker, format); /* Initialize variable arguments. */ | |
2688 | |
2689 return (vprintf(format, marker)); | |
2690 } | |
2691 | |
2692 DllExport int | |
2693 win32_vfprintf(FILE *fp, const char *format, va_list args) | |
2694 { | |
2695 return (vfprintf(fp, format, args)); | |
2696 } | |
2697 | |
2698 DllExport int | |
2699 win32_vprintf(const char *format, va_list args) | |
2700 { | |
2701 return (vprintf(format, args)); | |
2702 } | |
2703 | |
2704 DllExport size_t | |
2705 win32_fread(void *buf, size_t size, size_t count, FILE *fp) | |
2706 { | |
2707 return fread(buf, size, count, fp); | |
2708 } | |
2709 | |
2710 DllExport size_t | |
2711 win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp) | |
2712 { | |
2713 return fwrite(buf, size, count, fp); | |
2714 } | |
2715 | |
2716 #define MODE_SIZE 10 | |
2717 | |
2718 DllExport FILE * | |
2719 win32_fopen(const char *filename, const char *mode) | |
2720 { | |
2721 dTHXa(NULL); | |
2722 FILE *f; | |
2723 | |
2724 if (!*filename) | |
2725 return NULL; | |
2726 | |
2727 if (stricmp(filename, "/dev/null")==0) | |
2728 filename = "NUL"; | |
2729 | |
2730 aTHXa(PERL_GET_THX); | |
2731 f = fopen(PerlDir_mapA(filename), mode); | |
2732 /* avoid buffering headaches for child processes */ | |
2733 if (f && *mode == 'a') | |
2734 win32_fseek(f, 0, SEEK_END); | |
2735 return f; | |
2736 } | |
2737 | |
2738 DllExport FILE * | |
2739 win32_fdopen(int handle, const char *mode) | |
2740 { | |
2741 FILE *f; | |
2742 f = fdopen(handle, (char *) mode); | |
2743 /* avoid buffering headaches for child processes */ | |
2744 if (f && *mode == 'a') | |
2745 win32_fseek(f, 0, SEEK_END); | |
2746 return f; | |
2747 } | |
2748 | |
2749 DllExport FILE * | |
2750 win32_freopen(const char *path, const char *mode, FILE *stream) | |
2751 { | |
2752 dTHXa(NULL); | |
2753 if (stricmp(path, "/dev/null")==0) | |
2754 path = "NUL"; | |
2755 | |
2756 aTHXa(PERL_GET_THX); | |
2757 return freopen(PerlDir_mapA(path), mode, stream); | |
2758 } | |
2759 | |
2760 DllExport int | |
2761 win32_fclose(FILE *pf) | |
2762 { | |
2763 #ifdef WIN32_NO_SOCKETS | |
2764 return fclose(pf); | |
2765 #else | |
2766 return my_fclose(pf); /* defined in win32sck.c */ | |
2767 #endif | |
2768 } | |
2769 | |
2770 DllExport int | |
2771 win32_fputs(const char *s,FILE *pf) | |
2772 { | |
2773 return fputs(s, pf); | |
2774 } | |
2775 | |
2776 DllExport int | |
2777 win32_fputc(int c,FILE *pf) | |
2778 { | |
2779 return fputc(c,pf); | |
2780 } | |
2781 | |
2782 DllExport int | |
2783 win32_ungetc(int c,FILE *pf) | |
2784 { | |
2785 return ungetc(c,pf); | |
2786 } | |
2787 | |
2788 DllExport int | |
2789 win32_getc(FILE *pf) | |
2790 { | |
2791 return getc(pf); | |
2792 } | |
2793 | |
2794 DllExport int | |
2795 win32_fileno(FILE *pf) | |
2796 { | |
2797 return fileno(pf); | |
2798 } | |
2799 | |
2800 DllExport void | |
2801 win32_clearerr(FILE *pf) | |
2802 { | |
2803 clearerr(pf); | |
2804 return; | |
2805 } | |
2806 | |
2807 DllExport int | |
2808 win32_fflush(FILE *pf) | |
2809 { | |
2810 return fflush(pf); | |
2811 } | |
2812 | |
2813 DllExport Off_t | |
2814 win32_ftell(FILE *pf) | |
2815 { | |
2816 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
2817 fpos_t pos; | |
2818 if (fgetpos(pf, &pos)) | |
2819 return -1; | |
2820 return (Off_t)pos; | |
2821 #else | |
2822 return ftell(pf); | |
2823 #endif | |
2824 } | |
2825 | |
2826 DllExport int | |
2827 win32_fseek(FILE *pf, Off_t offset,int origin) | |
2828 { | |
2829 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
2830 fpos_t pos; | |
2831 switch (origin) { | |
2832 case SEEK_CUR: | |
2833 if (fgetpos(pf, &pos)) | |
2834 return -1; | |
2835 offset += pos; | |
2836 break; | |
2837 case SEEK_END: | |
2838 fseek(pf, 0, SEEK_END); | |
2839 pos = _telli64(fileno(pf)); | |
2840 offset += pos; | |
2841 break; | |
2842 case SEEK_SET: | |
2843 break; | |
2844 default: | |
2845 errno = EINVAL; | |
2846 return -1; | |
2847 } | |
2848 return fsetpos(pf, &offset); | |
2849 #else | |
2850 return fseek(pf, (long)offset, origin); | |
2851 #endif | |
2852 } | |
2853 | |
2854 DllExport int | |
2855 win32_fgetpos(FILE *pf,fpos_t *p) | |
2856 { | |
2857 return fgetpos(pf, p); | |
2858 } | |
2859 | |
2860 DllExport int | |
2861 win32_fsetpos(FILE *pf,const fpos_t *p) | |
2862 { | |
2863 return fsetpos(pf, p); | |
2864 } | |
2865 | |
2866 DllExport void | |
2867 win32_rewind(FILE *pf) | |
2868 { | |
2869 rewind(pf); | |
2870 return; | |
2871 } | |
2872 | |
2873 DllExport int | |
2874 win32_tmpfd(void) | |
2875 { | |
2876 char prefix[MAX_PATH+1]; | |
2877 char filename[MAX_PATH+1]; | |
2878 DWORD len = GetTempPath(MAX_PATH, prefix); | |
2879 if (len && len < MAX_PATH) { | |
2880 if (GetTempFileName(prefix, "plx", 0, filename)) { | |
2881 HANDLE fh = CreateFile(filename, | |
2882 DELETE | GENERIC_READ | GENERIC_WRITE, | |
2883 0, | |
2884 NULL, | |
2885 CREATE_ALWAYS, | |
2886 FILE_ATTRIBUTE_NORMAL | |
2887 | FILE_FLAG_DELETE_ON_CLOSE, | |
2888 NULL); | |
2889 if (fh != INVALID_HANDLE_VALUE) { | |
2890 int fd = win32_open_osfhandle((intptr_t)fh, 0); | |
2891 if (fd >= 0) { | |
2892 PERL_DEB(dTHX;) | |
2893 DEBUG_p(PerlIO_printf(Perl_debug_log, | |
2894 "Created tmpfile=%s\n",filename)); | |
2895 return fd; | |
2896 } | |
2897 } | |
2898 } | |
2899 } | |
2900 return -1; | |
2901 } | |
2902 | |
2903 DllExport FILE* | |
2904 win32_tmpfile(void) | |
2905 { | |
2906 int fd = win32_tmpfd(); | |
2907 if (fd >= 0) | |
2908 return win32_fdopen(fd, "w+b"); | |
2909 return NULL; | |
2910 } | |
2911 | |
2912 DllExport void | |
2913 win32_abort(void) | |
2914 { | |
2915 abort(); | |
2916 return; | |
2917 } | |
2918 | |
2919 DllExport int | |
2920 win32_fstat(int fd, Stat_t *sbufptr) | |
2921 { | |
2922 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
2923 return _fstati64(fd, sbufptr); | |
2924 #else | |
2925 return fstat(fd, sbufptr); | |
2926 #endif | |
2927 } | |
2928 | |
2929 DllExport int | |
2930 win32_pipe(int *pfd, unsigned int size, int mode) | |
2931 { | |
2932 return _pipe(pfd, size, mode); | |
2933 } | |
2934 | |
2935 DllExport PerlIO* | |
2936 win32_popenlist(const char *mode, IV narg, SV **args) | |
2937 { | |
2938 get_shell(); | |
2939 | |
2940 return do_popen(mode, NULL, narg, args); | |
2941 } | |
2942 | |
2943 STATIC PerlIO* | |
2944 do_popen(const char *mode, const char *command, IV narg, SV **args) { | |
2945 int p[2]; | |
2946 int handles[3]; | |
2947 int parent, child; | |
2948 int stdfd; | |
2949 int ourmode; | |
2950 int childpid; | |
2951 DWORD nhandle; | |
2952 int lock_held = 0; | |
2953 const char **args_pvs = NULL; | |
2954 | |
2955 /* establish which ends read and write */ | |
2956 if (strchr(mode,'w')) { | |
2957 stdfd = 0; /* stdin */ | |
2958 parent = 1; | |
2959 child = 0; | |
2960 nhandle = STD_INPUT_HANDLE; | |
2961 } | |
2962 else if (strchr(mode,'r')) { | |
2963 stdfd = 1; /* stdout */ | |
2964 parent = 0; | |
2965 child = 1; | |
2966 nhandle = STD_OUTPUT_HANDLE; | |
2967 } | |
2968 else | |
2969 return NULL; | |
2970 | |
2971 /* set the correct mode */ | |
2972 if (strchr(mode,'b')) | |
2973 ourmode = O_BINARY; | |
2974 else if (strchr(mode,'t')) | |
2975 ourmode = O_TEXT; | |
2976 else | |
2977 ourmode = _fmode & (O_TEXT | O_BINARY); | |
2978 | |
2979 /* the child doesn't inherit handles */ | |
2980 ourmode |= O_NOINHERIT; | |
2981 | |
2982 if (win32_pipe(p, 512, ourmode) == -1) | |
2983 return NULL; | |
2984 | |
2985 /* Previously this code redirected stdin/out temporarily so the | |
2986 child process inherited those handles, this caused race | |
2987 conditions when another thread was writing/reading those | |
2988 handles. | |
2989 | |
2990 To avoid that we just feed the handles to CreateProcess() so | |
2991 the handles are redirected only in the child. | |
2992 */ | |
2993 handles[child] = p[child]; | |
2994 handles[parent] = -1; | |
2995 handles[2] = -1; | |
2996 | |
2997 /* CreateProcess() requires inheritable handles */ | |
2998 if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT, | |
2999 HANDLE_FLAG_INHERIT)) { | |
3000 goto cleanup; | |
3001 } | |
3002 | |
3003 /* start the child */ | |
3004 { | |
3005 dTHX; | |
3006 | |
3007 if (command) { | |
3008 if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1) | |
3009 goto cleanup; | |
3010 | |
3011 } | |
3012 else { | |
3013 int i; | |
3014 const char *exe_name; | |
3015 | |
3016 Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *); | |
3017 SAVEFREEPV(args_pvs); | |
3018 for (i = 0; i < narg; ++i) | |
3019 args_pvs[i] = SvPV_nolen(args[i]); | |
3020 args_pvs[i] = NULL; | |
3021 exe_name = qualified_path(args_pvs[0], TRUE); | |
3022 if (!exe_name) | |
3023 /* let CreateProcess() try to find it instead */ | |
3024 exe_name = args_pvs[0]; | |
3025 | |
3026 if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) { | |
3027 goto cleanup; | |
3028 } | |
3029 } | |
3030 | |
3031 win32_close(p[child]); | |
3032 | |
3033 sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); | |
3034 | |
3035 /* set process id so that it can be returned by perl's open() */ | |
3036 PL_forkprocess = childpid; | |
3037 } | |
3038 | |
3039 /* we have an fd, return a file stream */ | |
3040 return (PerlIO_fdopen(p[parent], (char *)mode)); | |
3041 | |
3042 cleanup: | |
3043 /* we don't need to check for errors here */ | |
3044 win32_close(p[0]); | |
3045 win32_close(p[1]); | |
3046 | |
3047 return (NULL); | |
3048 } | |
3049 | |
3050 /* | |
3051 * a popen() clone that respects PERL5SHELL | |
3052 * | |
3053 * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000 | |
3054 */ | |
3055 | |
3056 DllExport PerlIO* | |
3057 win32_popen(const char *command, const char *mode) | |
3058 { | |
3059 #ifdef USE_RTL_POPEN | |
3060 return _popen(command, mode); | |
3061 #else | |
3062 return do_popen(mode, command, 0, NULL); | |
3063 #endif /* USE_RTL_POPEN */ | |
3064 } | |
3065 | |
3066 /* | |
3067 * pclose() clone | |
3068 */ | |
3069 | |
3070 DllExport int | |
3071 win32_pclose(PerlIO *pf) | |
3072 { | |
3073 #ifdef USE_RTL_POPEN | |
3074 return _pclose(pf); | |
3075 #else | |
3076 dTHX; | |
3077 int childpid, status; | |
3078 SV *sv; | |
3079 | |
3080 sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE); | |
3081 | |
3082 if (SvIOK(sv)) | |
3083 childpid = SvIVX(sv); | |
3084 else | |
3085 childpid = 0; | |
3086 | |
3087 if (!childpid) { | |
3088 errno = EBADF; | |
3089 return -1; | |
3090 } | |
3091 | |
3092 #ifdef USE_PERLIO | |
3093 PerlIO_close(pf); | |
3094 #else | |
3095 fclose(pf); | |
3096 #endif | |
3097 SvIVX(sv) = 0; | |
3098 | |
3099 if (win32_waitpid(childpid, &status, 0) == -1) | |
3100 return -1; | |
3101 | |
3102 return status; | |
3103 | |
3104 #endif /* USE_RTL_POPEN */ | |
3105 } | |
3106 | |
3107 DllExport int | |
3108 win32_link(const char *oldname, const char *newname) | |
3109 { | |
3110 dTHXa(NULL); | |
3111 WCHAR wOldName[MAX_PATH+1]; | |
3112 WCHAR wNewName[MAX_PATH+1]; | |
3113 | |
3114 if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) && | |
3115 MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) && | |
3116 ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)), | |
3117 CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL))) | |
3118 { | |
3119 return 0; | |
3120 } | |
3121 /* This isn't perfect, eg. Win32 returns ERROR_ACCESS_DENIED for | |
3122 both permissions errors and if the source is a directory, while | |
3123 POSIX wants EACCES and EPERM respectively. | |
3124 | |
3125 Determined by experimentation on Windows 7 x64 SP1, since MS | |
3126 don't document what error codes are returned. | |
3127 */ | |
3128 switch (GetLastError()) { | |
3129 case ERROR_BAD_NET_NAME: | |
3130 case ERROR_BAD_NETPATH: | |
3131 case ERROR_BAD_PATHNAME: | |
3132 case ERROR_FILE_NOT_FOUND: | |
3133 case ERROR_FILENAME_EXCED_RANGE: | |
3134 case ERROR_INVALID_DRIVE: | |
3135 case ERROR_PATH_NOT_FOUND: | |
3136 errno = ENOENT; | |
3137 break; | |
3138 case ERROR_ALREADY_EXISTS: | |
3139 errno = EEXIST; | |
3140 break; | |
3141 case ERROR_ACCESS_DENIED: | |
3142 errno = EACCES; | |
3143 break; | |
3144 case ERROR_NOT_SAME_DEVICE: | |
3145 errno = EXDEV; | |
3146 break; | |
3147 case ERROR_DISK_FULL: | |
3148 errno = ENOSPC; | |
3149 break; | |
3150 case ERROR_NOT_ENOUGH_QUOTA: | |
3151 errno = EDQUOT; | |
3152 break; | |
3153 default: | |
3154 /* ERROR_INVALID_FUNCTION - eg. on a FAT volume */ | |
3155 errno = EINVAL; | |
3156 break; | |
3157 } | |
3158 return -1; | |
3159 } | |
3160 | |
3161 DllExport int | |
3162 win32_rename(const char *oname, const char *newname) | |
3163 { | |
3164 char szOldName[MAX_PATH+1]; | |
3165 BOOL bResult; | |
3166 DWORD dwFlags = MOVEFILE_COPY_ALLOWED; | |
3167 dTHX; | |
3168 | |
3169 if (stricmp(newname, oname)) | |
3170 dwFlags |= MOVEFILE_REPLACE_EXISTING; | |
3171 strcpy(szOldName, PerlDir_mapA(oname)); | |
3172 | |
3173 bResult = MoveFileExA(szOldName,PerlDir_mapA(newname), dwFlags); | |
3174 if (!bResult) { | |
3175 DWORD err = GetLastError(); | |
3176 switch (err) { | |
3177 case ERROR_BAD_NET_NAME: | |
3178 case ERROR_BAD_NETPATH: | |
3179 case ERROR_BAD_PATHNAME: | |
3180 case ERROR_FILE_NOT_FOUND: | |
3181 case ERROR_FILENAME_EXCED_RANGE: | |
3182 case ERROR_INVALID_DRIVE: | |
3183 case ERROR_NO_MORE_FILES: | |
3184 case ERROR_PATH_NOT_FOUND: | |
3185 errno = ENOENT; | |
3186 break; | |
3187 case ERROR_DISK_FULL: | |
3188 errno = ENOSPC; | |
3189 break; | |
3190 case ERROR_NOT_ENOUGH_QUOTA: | |
3191 errno = EDQUOT; | |
3192 break; | |
3193 default: | |
3194 errno = EACCES; | |
3195 break; | |
3196 } | |
3197 return -1; | |
3198 } | |
3199 return 0; | |
3200 } | |
3201 | |
3202 DllExport int | |
3203 win32_setmode(int fd, int mode) | |
3204 { | |
3205 return setmode(fd, mode); | |
3206 } | |
3207 | |
3208 DllExport int | |
3209 win32_chsize(int fd, Off_t size) | |
3210 { | |
3211 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
3212 int retval = 0; | |
3213 Off_t cur, end, extend; | |
3214 | |
3215 cur = win32_tell(fd); | |
3216 if (cur < 0) | |
3217 return -1; | |
3218 end = win32_lseek(fd, 0, SEEK_END); | |
3219 if (end < 0) | |
3220 return -1; | |
3221 extend = size - end; | |
3222 if (extend == 0) { | |
3223 /* do nothing */ | |
3224 } | |
3225 else if (extend > 0) { | |
3226 /* must grow the file, padding with nulls */ | |
3227 char b[4096]; | |
3228 int oldmode = win32_setmode(fd, O_BINARY); | |
3229 size_t count; | |
3230 memset(b, '\0', sizeof(b)); | |
3231 do { | |
3232 count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend; | |
3233 count = win32_write(fd, b, count); | |
3234 if ((int)count < 0) { | |
3235 retval = -1; | |
3236 break; | |
3237 } | |
3238 } while ((extend -= count) > 0); | |
3239 win32_setmode(fd, oldmode); | |
3240 } | |
3241 else { | |
3242 /* shrink the file */ | |
3243 win32_lseek(fd, size, SEEK_SET); | |
3244 if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) { | |
3245 errno = EACCES; | |
3246 retval = -1; | |
3247 } | |
3248 } | |
3249 win32_lseek(fd, cur, SEEK_SET); | |
3250 return retval; | |
3251 #else | |
3252 return chsize(fd, (long)size); | |
3253 #endif | |
3254 } | |
3255 | |
3256 DllExport Off_t | |
3257 win32_lseek(int fd, Off_t offset, int origin) | |
3258 { | |
3259 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
3260 return _lseeki64(fd, offset, origin); | |
3261 #else | |
3262 return lseek(fd, (long)offset, origin); | |
3263 #endif | |
3264 } | |
3265 | |
3266 DllExport Off_t | |
3267 win32_tell(int fd) | |
3268 { | |
3269 #if defined(WIN64) || defined(USE_LARGE_FILES) | |
3270 return _telli64(fd); | |
3271 #else | |
3272 return tell(fd); | |
3273 #endif | |
3274 } | |
3275 | |
3276 DllExport int | |
3277 win32_open(const char *path, int flag, ...) | |
3278 { | |
3279 dTHXa(NULL); | |
3280 va_list ap; | |
3281 int pmode; | |
3282 | |
3283 va_start(ap, flag); | |
3284 pmode = va_arg(ap, int); | |
3285 va_end(ap); | |
3286 | |
3287 if (stricmp(path, "/dev/null")==0) | |
3288 path = "NUL"; | |
3289 | |
3290 aTHXa(PERL_GET_THX); | |
3291 return open(PerlDir_mapA(path), flag, pmode); | |
3292 } | |
3293 | |
3294 /* close() that understands socket */ | |
3295 extern int my_close(int); /* in win32sck.c */ | |
3296 | |
3297 DllExport int | |
3298 win32_close(int fd) | |
3299 { | |
3300 #ifdef WIN32_NO_SOCKETS | |
3301 return close(fd); | |
3302 #else | |
3303 return my_close(fd); | |
3304 #endif | |
3305 } | |
3306 | |
3307 DllExport int | |
3308 win32_eof(int fd) | |
3309 { | |
3310 return eof(fd); | |
3311 } | |
3312 | |
3313 DllExport int | |
3314 win32_isatty(int fd) | |
3315 { | |
3316 /* The Microsoft isatty() function returns true for *all* | |
3317 * character mode devices, including "nul". Our implementation | |
3318 * should only return true if the handle has a console buffer. | |
3319 */ | |
3320 DWORD mode; | |
3321 HANDLE fh = (HANDLE)_get_osfhandle(fd); | |
3322 if (fh == (HANDLE)-1) { | |
3323 /* errno is already set to EBADF */ | |
3324 return 0; | |
3325 } | |
3326 | |
3327 if (GetConsoleMode(fh, &mode)) | |
3328 return 1; | |
3329 | |
3330 errno = ENOTTY; | |
3331 return 0; | |
3332 } | |
3333 | |
3334 DllExport int | |
3335 win32_dup(int fd) | |
3336 { | |
3337 return dup(fd); | |
3338 } | |
3339 | |
3340 DllExport int | |
3341 win32_dup2(int fd1,int fd2) | |
3342 { | |
3343 return dup2(fd1,fd2); | |
3344 } | |
3345 | |
3346 DllExport int | |
3347 win32_read(int fd, void *buf, unsigned int cnt) | |
3348 { | |
3349 return read(fd, buf, cnt); | |
3350 } | |
3351 | |
3352 DllExport int | |
3353 win32_write(int fd, const void *buf, unsigned int cnt) | |
3354 { | |
3355 return write(fd, buf, cnt); | |
3356 } | |
3357 | |
3358 DllExport int | |
3359 win32_mkdir(const char *dir, int mode) | |
3360 { | |
3361 dTHX; | |
3362 return mkdir(PerlDir_mapA(dir)); /* just ignore mode */ | |
3363 } | |
3364 | |
3365 DllExport int | |
3366 win32_rmdir(const char *dir) | |
3367 { | |
3368 dTHX; | |
3369 return rmdir(PerlDir_mapA(dir)); | |
3370 } | |
3371 | |
3372 DllExport int | |
3373 win32_chdir(const char *dir) | |
3374 { | |
3375 if (!dir) { | |
3376 errno = ENOENT; | |
3377 return -1; | |
3378 } | |
3379 return chdir(dir); | |
3380 } | |
3381 | |
3382 DllExport int | |
3383 win32_access(const char *path, int mode) | |
3384 { | |
3385 dTHX; | |
3386 return access(PerlDir_mapA(path), mode); | |
3387 } | |
3388 | |
3389 DllExport int | |
3390 win32_chmod(const char *path, int mode) | |
3391 { | |
3392 dTHX; | |
3393 return chmod(PerlDir_mapA(path), mode); | |
3394 } | |
3395 | |
3396 | |
3397 static char * | |
3398 create_command_line(char *cname, STRLEN clen, const char * const *args) | |
3399 { | |
3400 PERL_DEB(dTHX;) | |
3401 int index, argc; | |
3402 char *cmd, *ptr; | |
3403 const char *arg; | |
3404 STRLEN len = 0; | |
3405 bool bat_file = FALSE; | |
3406 bool cmd_shell = FALSE; | |
3407 bool dumb_shell = FALSE; | |
3408 bool extra_quotes = FALSE; | |
3409 bool quote_next = FALSE; | |
3410 | |
3411 if (!cname) | |
3412 cname = (char*)args[0]; | |
3413 | |
3414 /* The NT cmd.exe shell has the following peculiarity that needs to be | |
3415 * worked around. It strips a leading and trailing dquote when any | |
3416 * of the following is true: | |
3417 * 1. the /S switch was used | |
3418 * 2. there are more than two dquotes | |
3419 * 3. there is a special character from this set: &<>()@^| | |
3420 * 4. no whitespace characters within the two dquotes | |
3421 * 5. string between two dquotes isn't an executable file | |
3422 * To work around this, we always add a leading and trailing dquote | |
3423 * to the string, if the first argument is either "cmd.exe" or "cmd", | |
3424 * and there were at least two or more arguments passed to cmd.exe | |
3425 * (not including switches). | |
3426 * XXX the above rules (from "cmd /?") don't seem to be applied | |
3427 * always, making for the convolutions below :-( | |
3428 */ | |
3429 if (cname) { | |
3430 if (!clen) | |
3431 clen = strlen(cname); | |
3432 | |
3433 if (clen > 4 | |
3434 && (stricmp(&cname[clen-4], ".bat") == 0 | |
3435 || (stricmp(&cname[clen-4], ".cmd") == 0))) | |
3436 { | |
3437 bat_file = TRUE; | |
3438 len += 3; | |
3439 } | |
3440 else { | |
3441 char *exe = strrchr(cname, '/'); | |
3442 char *exe2 = strrchr(cname, '\\'); | |
3443 if (exe2 > exe) | |
3444 exe = exe2; | |
3445 if (exe) | |
3446 ++exe; | |
3447 else | |
3448 exe = cname; | |
3449 if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) { | |
3450 cmd_shell = TRUE; | |
3451 len += 3; | |
3452 } | |
3453 else if (stricmp(exe, "command.com") == 0 | |
3454 || stricmp(exe, "command") == 0) | |
3455 { | |
3456 dumb_shell = TRUE; | |
3457 } | |
3458 } | |
3459 } | |
3460 | |
3461 DEBUG_p(PerlIO_printf(Perl_debug_log, "Args ")); | |
3462 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { | |
3463 STRLEN curlen = strlen(arg); | |
3464 if (!(arg[0] == '"' && arg[curlen-1] == '"')) | |
3465 len += 2; /* assume quoting needed (worst case) */ | |
3466 len += curlen + 1; | |
3467 DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg)); | |
3468 } | |
3469 DEBUG_p(PerlIO_printf(Perl_debug_log, "\n")); | |
3470 | |
3471 argc = index; | |
3472 Newx(cmd, len, char); | |
3473 ptr = cmd; | |
3474 | |
3475 if (bat_file) { | |
3476 *ptr++ = '"'; | |
3477 extra_quotes = TRUE; | |
3478 } | |
3479 | |
3480 for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { | |
3481 bool do_quote = 0; | |
3482 STRLEN curlen = strlen(arg); | |
3483 | |
3484 /* we want to protect empty arguments and ones with spaces with | |
3485 * dquotes, but only if they aren't already there */ | |
3486 if (!dumb_shell) { | |
3487 if (!curlen) { | |
3488 do_quote = 1; | |
3489 } | |
3490 else if (quote_next) { | |
3491 /* see if it really is multiple arguments pretending to | |
3492 * be one and force a set of quotes around it */ | |
3493 if (*find_next_space(arg)) | |
3494 do_quote = 1; | |
3495 } | |
3496 else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) { | |
3497 STRLEN i = 0; | |
3498 while (i < curlen) { | |
3499 if (isSPACE(arg[i])) { | |
3500 do_quote = 1; | |
3501 } | |
3502 else if (arg[i] == '"') { | |
3503 do_quote = 0; | |
3504 break; | |
3505 } | |
3506 i++; | |
3507 } | |
3508 } | |
3509 } | |
3510 | |
3511 if (do_quote) | |
3512 *ptr++ = '"'; | |
3513 | |
3514 strcpy(ptr, arg); | |
3515 ptr += curlen; | |
3516 | |
3517 if (do_quote) | |
3518 *ptr++ = '"'; | |
3519 | |
3520 if (args[index+1]) | |
3521 *ptr++ = ' '; | |
3522 | |
3523 if (!extra_quotes | |
3524 && cmd_shell | |
3525 && curlen >= 2 | |
3526 && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */ | |
3527 && stricmp(arg+curlen-2, "/c") == 0) | |
3528 { | |
3529 /* is there a next argument? */ | |
3530 if (args[index+1]) { | |
3531 /* are there two or more next arguments? */ | |
3532 if (args[index+2]) { | |
3533 *ptr++ = '"'; | |
3534 extra_quotes = TRUE; | |
3535 } | |
3536 else { | |
3537 /* single argument, force quoting if it has spaces */ | |
3538 quote_next = TRUE; | |
3539 } | |
3540 } | |
3541 } | |
3542 } | |
3543 | |
3544 if (extra_quotes) | |
3545 *ptr++ = '"'; | |
3546 | |
3547 *ptr = '\0'; | |
3548 | |
3549 return cmd; | |
3550 } | |
3551 | |
3552 static const char *exe_extensions[] = | |
3553 { | |
3554 ".exe", /* this must be first */ | |
3555 ".cmd", | |
3556 ".bat" | |
3557 }; | |
3558 | |
3559 static char * | |
3560 qualified_path(const char *cmd, bool other_exts) | |
3561 { | |
3562 char *pathstr; | |
3563 char *fullcmd, *curfullcmd; | |
3564 STRLEN cmdlen = 0; | |
3565 int has_slash = 0; | |
3566 | |
3567 if (!cmd) | |
3568 return NULL; | |
3569 fullcmd = (char*)cmd; | |
3570 while (*fullcmd) { | |
3571 if (*fullcmd == '/' || *fullcmd == '\\') | |
3572 has_slash++; | |
3573 fullcmd++; | |
3574 cmdlen++; | |
3575 } | |
3576 | |
3577 /* look in PATH */ | |
3578 { | |
3579 dTHX; | |
3580 pathstr = PerlEnv_getenv("PATH"); | |
3581 } | |
3582 /* worst case: PATH is a single directory; we need additional space | |
3583 * to append "/", ".exe" and trailing "\0" */ | |
3584 Newx(fullcmd, (pathstr ? strlen(pathstr) : 0) + cmdlen + 6, char); | |
3585 curfullcmd = fullcmd; | |
3586 | |
3587 while (1) { | |
3588 DWORD res; | |
3589 | |
3590 /* start by appending the name to the current prefix */ | |
3591 strcpy(curfullcmd, cmd); | |
3592 curfullcmd += cmdlen; | |
3593 | |
3594 /* if it doesn't end with '.', or has no extension, try adding | |
3595 * a trailing .exe first */ | |
3596 if (cmd[cmdlen-1] != '.' | |
3597 && (cmdlen < 4 || cmd[cmdlen-4] != '.')) | |
3598 { | |
3599 int i; | |
3600 /* first extension is .exe */ | |
3601 int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1; | |
3602 for (i = 0; i < ext_limit; ++i) { | |
3603 strcpy(curfullcmd, exe_extensions[i]); | |
3604 res = GetFileAttributes(fullcmd); | |
3605 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) | |
3606 return fullcmd; | |
3607 } | |
3608 | |
3609 *curfullcmd = '\0'; | |
3610 } | |
3611 | |
3612 /* that failed, try the bare name */ | |
3613 res = GetFileAttributes(fullcmd); | |
3614 if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) | |
3615 return fullcmd; | |
3616 | |
3617 /* quit if no other path exists, or if cmd already has path */ | |
3618 if (!pathstr || !*pathstr || has_slash) | |
3619 break; | |
3620 | |
3621 /* skip leading semis */ | |
3622 while (*pathstr == ';') | |
3623 pathstr++; | |
3624 | |
3625 /* build a new prefix from scratch */ | |
3626 curfullcmd = fullcmd; | |
3627 while (*pathstr && *pathstr != ';') { | |
3628 if (*pathstr == '"') { /* foo;"baz;etc";bar */ | |
3629 pathstr++; /* skip initial '"' */ | |
3630 while (*pathstr && *pathstr != '"') { | |
3631 *curfullcmd++ = *pathstr++; | |
3632 } | |
3633 if (*pathstr) | |
3634 pathstr++; /* skip trailing '"' */ | |
3635 } | |
3636 else { | |
3637 *curfullcmd++ = *pathstr++; | |
3638 } | |
3639 } | |
3640 if (*pathstr) | |
3641 pathstr++; /* skip trailing semi */ | |
3642 if (curfullcmd > fullcmd /* append a dir separator */ | |
3643 && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\') | |
3644 { | |
3645 *curfullcmd++ = '\\'; | |
3646 } | |
3647 } | |
3648 | |
3649 Safefree(fullcmd); | |
3650 return NULL; | |
3651 } | |
3652 | |
3653 /* The following are just place holders. | |
3654 * Some hosts may provide and environment that the OS is | |
3655 * not tracking, therefore, these host must provide that | |
3656 * environment and the current directory to CreateProcess | |
3657 */ | |
3658 | |
3659 DllExport void* | |
3660 win32_get_childenv(void) | |
3661 { | |
3662 return NULL; | |
3663 } | |
3664 | |
3665 DllExport void | |
3666 win32_free_childenv(void* d) | |
3667 { | |
3668 } | |
3669 | |
3670 DllExport void | |
3671 win32_clearenv(void) | |
3672 { | |
3673 char *envv = GetEnvironmentStrings(); | |
3674 char *cur = envv; | |
3675 STRLEN len; | |
3676 while (*cur) { | |
3677 char *end = strchr(cur,'='); | |
3678 if (end && end != cur) { | |
3679 *end = '\0'; | |
3680 SetEnvironmentVariable(cur, NULL); | |
3681 *end = '='; | |
3682 cur = end + strlen(end+1)+2; | |
3683 } | |
3684 else if ((len = strlen(cur))) | |
3685 cur += len+1; | |
3686 } | |
3687 FreeEnvironmentStrings(envv); | |
3688 } | |
3689 | |
3690 DllExport char* | |
3691 win32_get_childdir(void) | |
3692 { | |
3693 char* ptr; | |
3694 char szfilename[MAX_PATH+1]; | |
3695 | |
3696 GetCurrentDirectoryA(MAX_PATH+1, szfilename); | |
3697 Newx(ptr, strlen(szfilename)+1, char); | |
3698 strcpy(ptr, szfilename); | |
3699 return ptr; | |
3700 } | |
3701 | |
3702 DllExport void | |
3703 win32_free_childdir(char* d) | |
3704 { | |
3705 Safefree(d); | |
3706 } | |
3707 | |
3708 | |
3709 /* XXX this needs to be made more compatible with the spawnvp() | |
3710 * provided by the various RTLs. In particular, searching for | |
3711 * *.{com,bat,cmd} files (as done by the RTLs) is unimplemented. | |
3712 * This doesn't significantly affect perl itself, because we | |
3713 * always invoke things using PERL5SHELL if a direct attempt to | |
3714 * spawn the executable fails. | |
3715 * | |
3716 * XXX splitting and rejoining the commandline between do_aspawn() | |
3717 * and win32_spawnvp() could also be avoided. | |
3718 */ | |
3719 | |
3720 DllExport int | |
3721 win32_spawnvp(int mode, const char *cmdname, const char *const *argv) | |
3722 { | |
3723 #ifdef USE_RTL_SPAWNVP | |
3724 return _spawnvp(mode, cmdname, (char * const *)argv); | |
3725 #else | |
3726 return do_spawnvp_handles(mode, cmdname, argv, NULL); | |
3727 #endif | |
3728 } | |
3729 | |
3730 static int | |
3731 do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, | |
3732 const int *handles) { | |
3733 dTHXa(NULL); | |
3734 int ret; | |
3735 void* env; | |
3736 char* dir; | |
3737 child_IO_table tbl; | |
3738 STARTUPINFO StartupInfo; | |
3739 PROCESS_INFORMATION ProcessInformation; | |
3740 DWORD create = 0; | |
3741 char *cmd; | |
3742 char *fullcmd = NULL; | |
3743 char *cname = (char *)cmdname; | |
3744 STRLEN clen = 0; | |
3745 | |
3746 if (cname) { | |
3747 clen = strlen(cname); | |
3748 /* if command name contains dquotes, must remove them */ | |
3749 if (strchr(cname, '"')) { | |
3750 cmd = cname; | |
3751 Newx(cname,clen+1,char); | |
3752 clen = 0; | |
3753 while (*cmd) { | |
3754 if (*cmd != '"') { | |
3755 cname[clen] = *cmd; | |
3756 ++clen; | |
3757 } | |
3758 ++cmd; | |
3759 } | |
3760 cname[clen] = '\0'; | |
3761 } | |
3762 } | |
3763 | |
3764 cmd = create_command_line(cname, clen, argv); | |
3765 | |
3766 aTHXa(PERL_GET_THX); | |
3767 env = PerlEnv_get_childenv(); | |
3768 dir = PerlEnv_get_childdir(); | |
3769 | |
3770 switch(mode) { | |
3771 case P_NOWAIT: /* asynch + remember result */ | |
3772 if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) { | |
3773 errno = EAGAIN; | |
3774 ret = -1; | |
3775 goto RETVAL; | |
3776 } | |
3777 /* Create a new process group so we can use GenerateConsoleCtrlEvent() | |
3778 * in win32_kill() | |
3779 */ | |
3780 create |= CREATE_NEW_PROCESS_GROUP; | |
3781 /* FALL THROUGH */ | |
3782 | |
3783 case P_WAIT: /* synchronous execution */ | |
3784 break; | |
3785 default: /* invalid mode */ | |
3786 errno = EINVAL; | |
3787 ret = -1; | |
3788 goto RETVAL; | |
3789 } | |
3790 | |
3791 memset(&StartupInfo,0,sizeof(StartupInfo)); | |
3792 StartupInfo.cb = sizeof(StartupInfo); | |
3793 memset(&tbl,0,sizeof(tbl)); | |
3794 PerlEnv_get_child_IO(&tbl); | |
3795 StartupInfo.dwFlags = tbl.dwFlags; | |
3796 StartupInfo.dwX = tbl.dwX; | |
3797 StartupInfo.dwY = tbl.dwY; | |
3798 StartupInfo.dwXSize = tbl.dwXSize; | |
3799 StartupInfo.dwYSize = tbl.dwYSize; | |
3800 StartupInfo.dwXCountChars = tbl.dwXCountChars; | |
3801 StartupInfo.dwYCountChars = tbl.dwYCountChars; | |
3802 StartupInfo.dwFillAttribute = tbl.dwFillAttribute; | |
3803 StartupInfo.wShowWindow = tbl.wShowWindow; | |
3804 StartupInfo.hStdInput = handles && handles[0] != -1 ? | |
3805 (HANDLE)_get_osfhandle(handles[0]) : tbl.childStdIn; | |
3806 StartupInfo.hStdOutput = handles && handles[1] != -1 ? | |
3807 (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut; | |
3808 StartupInfo.hStdError = handles && handles[2] != -1 ? | |
3809 (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr; | |
3810 if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE && | |
3811 StartupInfo.hStdOutput == INVALID_HANDLE_VALUE && | |
3812 StartupInfo.hStdError == INVALID_HANDLE_VALUE) | |
3813 { | |
3814 create |= CREATE_NEW_CONSOLE; | |
3815 } | |
3816 else { | |
3817 StartupInfo.dwFlags |= STARTF_USESTDHANDLES; | |
3818 } | |
3819 if (w32_use_showwindow) { | |
3820 StartupInfo.dwFlags |= STARTF_USESHOWWINDOW; | |
3821 StartupInfo.wShowWindow = w32_showwindow; | |
3822 } | |
3823 | |
3824 DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n", | |
3825 cname,cmd)); | |
3826 RETRY: | |
3827 if (!CreateProcess(cname, /* search PATH to find executable */ | |
3828 cmd, /* executable, and its arguments */ | |
3829 NULL, /* process attributes */ | |
3830 NULL, /* thread attributes */ | |
3831 TRUE, /* inherit handles */ | |
3832 create, /* creation flags */ | |
3833 (LPVOID)env, /* inherit environment */ | |
3834 dir, /* inherit cwd */ | |
3835 &StartupInfo, | |
3836 &ProcessInformation)) | |
3837 { | |
3838 /* initial NULL argument to CreateProcess() does a PATH | |
3839 * search, but it always first looks in the directory | |
3840 * where the current process was started, which behavior | |
3841 * is undesirable for backward compatibility. So we | |
3842 * jump through our own hoops by picking out the path | |
3843 * we really want it to use. */ | |
3844 if (!fullcmd) { | |
3845 fullcmd = qualified_path(cname, FALSE); | |
3846 if (fullcmd) { | |
3847 if (cname != cmdname) | |
3848 Safefree(cname); | |
3849 cname = fullcmd; | |
3850 DEBUG_p(PerlIO_printf(Perl_debug_log, | |
3851 "Retrying [%s] with same args\n", | |
3852 cname)); | |
3853 goto RETRY; | |
3854 } | |
3855 } | |
3856 errno = ENOENT; | |
3857 ret = -1; | |
3858 goto RETVAL; | |
3859 } | |
3860 | |
3861 if (mode == P_NOWAIT) { | |
3862 /* asynchronous spawn -- store handle, return PID */ | |
3863 ret = (int)ProcessInformation.dwProcessId; | |
3864 | |
3865 w32_child_handles[w32_num_children] = ProcessInformation.hProcess; | |
3866 w32_child_pids[w32_num_children] = (DWORD)ret; | |
3867 ++w32_num_children; | |
3868 } | |
3869 else { | |
3870 DWORD status; | |
3871 win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL); | |
3872 /* FIXME: if msgwait returned due to message perhaps forward the | |
3873 "signal" to the process | |
3874 */ | |
3875 GetExitCodeProcess(ProcessInformation.hProcess, &status); | |
3876 ret = (int)status; | |
3877 CloseHandle(ProcessInformation.hProcess); | |
3878 } | |
3879 | |
3880 CloseHandle(ProcessInformation.hThread); | |
3881 | |
3882 RETVAL: | |
3883 PerlEnv_free_childenv(env); | |
3884 PerlEnv_free_childdir(dir); | |
3885 Safefree(cmd); | |
3886 if (cname != cmdname) | |
3887 Safefree(cname); | |
3888 return ret; | |
3889 } | |
3890 | |
3891 DllExport int | |
3892 win32_execv(const char *cmdname, const char *const *argv) | |
3893 { | |
3894 #ifdef USE_ITHREADS | |
3895 dTHX; | |
3896 /* if this is a pseudo-forked child, we just want to spawn | |
3897 * the new program, and return */ | |
3898 if (w32_pseudo_id) | |
3899 return _spawnv(P_WAIT, cmdname, argv); | |
3900 #endif | |
3901 return _execv(cmdname, argv); | |
3902 } | |
3903 | |
3904 DllExport int | |
3905 win32_execvp(const char *cmdname, const char *const *argv) | |
3906 { | |
3907 #ifdef USE_ITHREADS | |
3908 dTHX; | |
3909 /* if this is a pseudo-forked child, we just want to spawn | |
3910 * the new program, and return */ | |
3911 if (w32_pseudo_id) { | |
3912 int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv); | |
3913 if (status != -1) { | |
3914 my_exit(status); | |
3915 return 0; | |
3916 } | |
3917 else | |
3918 return status; | |
3919 } | |
3920 #endif | |
3921 return _execvp(cmdname, argv); | |
3922 } | |
3923 | |
3924 DllExport void | |
3925 win32_perror(const char *str) | |
3926 { | |
3927 perror(str); | |
3928 } | |
3929 | |
3930 DllExport void | |
3931 win32_setbuf(FILE *pf, char *buf) | |
3932 { | |
3933 setbuf(pf, buf); | |
3934 } | |
3935 | |
3936 DllExport int | |
3937 win32_setvbuf(FILE *pf, char *buf, int type, size_t size) | |
3938 { | |
3939 return setvbuf(pf, buf, type, size); | |
3940 } | |
3941 | |
3942 DllExport int | |
3943 win32_flushall(void) | |
3944 { | |
3945 return flushall(); | |
3946 } | |
3947 | |
3948 DllExport int | |
3949 win32_fcloseall(void) | |
3950 { | |
3951 return fcloseall(); | |
3952 } | |
3953 | |
3954 DllExport char* | |
3955 win32_fgets(char *s, int n, FILE *pf) | |
3956 { | |
3957 return fgets(s, n, pf); | |
3958 } | |
3959 | |
3960 DllExport char* | |
3961 win32_gets(char *s) | |
3962 { | |
3963 return gets(s); | |
3964 } | |
3965 | |
3966 DllExport int | |
3967 win32_fgetc(FILE *pf) | |
3968 { | |
3969 return fgetc(pf); | |
3970 } | |
3971 | |
3972 DllExport int | |
3973 win32_putc(int c, FILE *pf) | |
3974 { | |
3975 return putc(c,pf); | |
3976 } | |
3977 | |
3978 DllExport int | |
3979 win32_puts(const char *s) | |
3980 { | |
3981 return puts(s); | |
3982 } | |
3983 | |
3984 DllExport int | |
3985 win32_getchar(void) | |
3986 { | |
3987 return getchar(); | |
3988 } | |
3989 | |
3990 DllExport int | |
3991 win32_putchar(int c) | |
3992 { | |
3993 return putchar(c); | |
3994 } | |
3995 | |
3996 #ifdef MYMALLOC | |
3997 | |
3998 #ifndef USE_PERL_SBRK | |
3999 | |
4000 static char *committed = NULL; /* XXX threadead */ | |
4001 static char *base = NULL; /* XXX threadead */ | |
4002 static char *reserved = NULL; /* XXX threadead */ | |
4003 static char *brk = NULL; /* XXX threadead */ | |
4004 static DWORD pagesize = 0; /* XXX threadead */ | |
4005 | |
4006 void * | |
4007 sbrk(ptrdiff_t need) | |
4008 { | |
4009 void *result; | |
4010 if (!pagesize) | |
4011 {SYSTEM_INFO info; | |
4012 GetSystemInfo(&info); | |
4013 /* Pretend page size is larger so we don't perpetually | |
4014 * call the OS to commit just one page ... | |
4015 */ | |
4016 pagesize = info.dwPageSize << 3; | |
4017 } | |
4018 if (brk+need >= reserved) | |
4019 { | |
4020 DWORD size = brk+need-reserved; | |
4021 char *addr; | |
4022 char *prev_committed = NULL; | |
4023 if (committed && reserved && committed < reserved) | |
4024 { | |
4025 /* Commit last of previous chunk cannot span allocations */ | |
4026 addr = (char *) VirtualAlloc(committed,reserved-committed,MEM_COMMIT,PAGE_READWRITE); | |
4027 if (addr) | |
4028 { | |
4029 /* Remember where we committed from in case we want to decommit later */ | |
4030 prev_committed = committed; | |
4031 committed = reserved; | |
4032 } | |
4033 } | |
4034 /* Reserve some (more) space | |
4035 * Contiguous blocks give us greater efficiency, so reserve big blocks - | |
4036 * this is only address space not memory... | |
4037 * Note this is a little sneaky, 1st call passes NULL as reserved | |
4038 * so lets system choose where we start, subsequent calls pass | |
4039 * the old end address so ask for a contiguous block | |
4040 */ | |
4041 sbrk_reserve: | |
4042 if (size < 64*1024*1024) | |
4043 size = 64*1024*1024; | |
4044 size = ((size + pagesize - 1) / pagesize) * pagesize; | |
4045 addr = (char *) VirtualAlloc(reserved,size,MEM_RESERVE,PAGE_NOACCESS); | |
4046 if (addr) | |
4047 { | |
4048 reserved = addr+size; | |
4049 if (!base) | |
4050 base = addr; | |
4051 if (!committed) | |
4052 committed = base; | |
4053 if (!brk) | |
4054 brk = committed; | |
4055 } | |
4056 else if (reserved) | |
4057 { | |
4058 /* The existing block could not be extended far enough, so decommit | |
4059 * anything that was just committed above and start anew */ | |
4060 if (prev_committed) | |
4061 { | |
4062 if (!VirtualFree(prev_committed,reserved-prev_committed,MEM_DECOMMIT)) | |
4063 return (void *) -1; | |
4064 } | |
4065 reserved = base = committed = brk = NULL; | |
4066 size = need; | |
4067 goto sbrk_reserve; | |
4068 } | |
4069 else | |
4070 { | |
4071 return (void *) -1; | |
4072 } | |
4073 } | |
4074 result = brk; | |
4075 brk += need; | |
4076 if (brk > committed) | |
4077 { | |
4078 DWORD size = ((brk-committed + pagesize -1)/pagesize) * pagesize; | |
4079 char *addr; | |
4080 if (committed+size > reserved) | |
4081 size = reserved-committed; | |
4082 addr = (char *) VirtualAlloc(committed,size,MEM_COMMIT,PAGE_READWRITE); | |
4083 if (addr) | |
4084 committed += size; | |
4085 else | |
4086 return (void *) -1; | |
4087 } | |
4088 return result; | |
4089 } | |
4090 | |
4091 #endif | |
4092 #endif | |
4093 | |
4094 DllExport void* | |
4095 win32_malloc(size_t size) | |
4096 { | |
4097 return malloc(size); | |
4098 } | |
4099 | |
4100 DllExport void* | |
4101 win32_calloc(size_t numitems, size_t size) | |
4102 { | |
4103 return calloc(numitems,size); | |
4104 } | |
4105 | |
4106 DllExport void* | |
4107 win32_realloc(void *block, size_t size) | |
4108 { | |
4109 return realloc(block,size); | |
4110 } | |
4111 | |
4112 DllExport void | |
4113 win32_free(void *block) | |
4114 { | |
4115 free(block); | |
4116 } | |
4117 | |
4118 | |
4119 DllExport int | |
4120 win32_open_osfhandle(intptr_t handle, int flags) | |
4121 { | |
4122 return _open_osfhandle(handle, flags); | |
4123 } | |
4124 | |
4125 DllExport intptr_t | |
4126 win32_get_osfhandle(int fd) | |
4127 { | |
4128 return (intptr_t)_get_osfhandle(fd); | |
4129 } | |
4130 | |
4131 DllExport FILE * | |
4132 win32_fdupopen(FILE *pf) | |
4133 { | |
4134 FILE* pfdup; | |
4135 fpos_t pos; | |
4136 char mode[3]; | |
4137 int fileno = win32_dup(win32_fileno(pf)); | |
4138 | |
4139 /* open the file in the same mode */ | |
4140 if((pf)->_flag & _IOREAD) { | |
4141 mode[0] = 'r'; | |
4142 mode[1] = 0; | |
4143 } | |
4144 else if((pf)->_flag & _IOWRT) { | |
4145 mode[0] = 'a'; | |
4146 mode[1] = 0; | |
4147 } | |
4148 else if((pf)->_flag & _IORW) { | |
4149 mode[0] = 'r'; | |
4150 mode[1] = '+'; | |
4151 mode[2] = 0; | |
4152 } | |
4153 | |
4154 /* it appears that the binmode is attached to the | |
4155 * file descriptor so binmode files will be handled | |
4156 * correctly | |
4157 */ | |
4158 pfdup = win32_fdopen(fileno, mode); | |
4159 | |
4160 /* move the file pointer to the same position */ | |
4161 if (!fgetpos(pf, &pos)) { | |
4162 fsetpos(pfdup, &pos); | |
4163 } | |
4164 return pfdup; | |
4165 } | |
4166 | |
4167 DllExport void* | |
4168 win32_dynaload(const char* filename) | |
4169 { | |
4170 dTHXa(NULL); | |
4171 char buf[MAX_PATH+1]; | |
4172 const char *first; | |
4173 | |
4174 /* LoadLibrary() doesn't recognize forward slashes correctly, | |
4175 * so turn 'em back. */ | |
4176 first = strchr(filename, '/'); | |
4177 if (first) { | |
4178 STRLEN len = strlen(filename); | |
4179 if (len <= MAX_PATH) { | |
4180 strcpy(buf, filename); | |
4181 filename = &buf[first - filename]; | |
4182 while (*filename) { | |
4183 if (*filename == '/') | |
4184 *(char*)filename = '\\'; | |
4185 ++filename; | |
4186 } | |
4187 filename = buf; | |
4188 } | |
4189 } | |
4190 aTHXa(PERL_GET_THX); | |
4191 return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); | |
4192 } | |
4193 | |
4194 XS(w32_SetChildShowWindow) | |
4195 { | |
4196 dXSARGS; | |
4197 BOOL use_showwindow = w32_use_showwindow; | |
4198 /* use "unsigned short" because Perl has redefined "WORD" */ | |
4199 unsigned short showwindow = w32_showwindow; | |
4200 | |
4201 if (items > 1) | |
4202 croak_xs_usage(cv, "[showwindow]"); | |
4203 | |
4204 if (items == 0 || !SvOK(ST(0))) | |
4205 w32_use_showwindow = FALSE; | |
4206 else { | |
4207 w32_use_showwindow = TRUE; | |
4208 w32_showwindow = (unsigned short)SvIV(ST(0)); | |
4209 } | |
4210 | |
4211 EXTEND(SP, 1); | |
4212 if (use_showwindow) | |
4213 ST(0) = sv_2mortal(newSViv(showwindow)); | |
4214 else | |
4215 ST(0) = &PL_sv_undef; | |
4216 XSRETURN(1); | |
4217 } | |
4218 | |
4219 void | |
4220 Perl_init_os_extras(void) | |
4221 { | |
4222 dTHXa(NULL); | |
4223 char *file = __FILE__; | |
4224 | |
4225 /* Initialize Win32CORE if it has been statically linked. */ | |
4226 #ifndef PERL_IS_MINIPERL | |
4227 void (*pfn_init)(pTHX); | |
4228 HMODULE module = (HMODULE)((w32_perldll_handle == INVALID_HANDLE_VALUE) | |
4229 ? GetModuleHandle(NULL) | |
4230 : w32_perldll_handle); | |
4231 pfn_init = (void (*)(pTHX))GetProcAddress(module, "init_Win32CORE"); | |
4232 aTHXa(PERL_GET_THX); | |
4233 if (pfn_init) | |
4234 pfn_init(aTHX); | |
4235 #else | |
4236 aTHXa(PERL_GET_THX); | |
4237 #endif | |
4238 | |
4239 newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); | |
4240 } | |
4241 | |
4242 void * | |
4243 win32_signal_context(void) | |
4244 { | |
4245 dTHX; | |
4246 #ifdef MULTIPLICITY | |
4247 if (!my_perl) { | |
4248 my_perl = PL_curinterp; | |
4249 PERL_SET_THX(my_perl); | |
4250 } | |
4251 return my_perl; | |
4252 #else | |
4253 return PL_curinterp; | |
4254 #endif | |
4255 } | |
4256 | |
4257 | |
4258 BOOL WINAPI | |
4259 win32_ctrlhandler(DWORD dwCtrlType) | |
4260 { | |
4261 #ifdef MULTIPLICITY | |
4262 dTHXa(PERL_GET_SIG_CONTEXT); | |
4263 | |
4264 if (!my_perl) | |
4265 return FALSE; | |
4266 #endif | |
4267 | |
4268 switch(dwCtrlType) { | |
4269 case CTRL_CLOSE_EVENT: | |
4270 /* A signal that the system sends to all processes attached to a console when | |
4271 the user closes the console (either by choosing the Close command from the | |
4272 console window's System menu, or by choosing the End Task command from the | |
4273 Task List | |
4274 */ | |
4275 if (do_raise(aTHX_ 1)) /* SIGHUP */ | |
4276 sig_terminate(aTHX_ 1); | |
4277 return TRUE; | |
4278 | |
4279 case CTRL_C_EVENT: | |
4280 /* A CTRL+c signal was received */ | |
4281 if (do_raise(aTHX_ SIGINT)) | |
4282 sig_terminate(aTHX_ SIGINT); | |
4283 return TRUE; | |
4284 | |
4285 case CTRL_BREAK_EVENT: | |
4286 /* A CTRL+BREAK signal was received */ | |
4287 if (do_raise(aTHX_ SIGBREAK)) | |
4288 sig_terminate(aTHX_ SIGBREAK); | |
4289 return TRUE; | |
4290 | |
4291 case CTRL_LOGOFF_EVENT: | |
4292 /* A signal that the system sends to all console processes when a user is logging | |
4293 off. This signal does not indicate which user is logging off, so no | |
4294 assumptions can be made. | |
4295 */ | |
4296 break; | |
4297 case CTRL_SHUTDOWN_EVENT: | |
4298 /* A signal that the system sends to all console processes when the system is | |
4299 shutting down. | |
4300 */ | |
4301 if (do_raise(aTHX_ SIGTERM)) | |
4302 sig_terminate(aTHX_ SIGTERM); | |
4303 return TRUE; | |
4304 default: | |
4305 break; | |
4306 } | |
4307 return FALSE; | |
4308 } | |
4309 | |
4310 | |
4311 #ifdef SET_INVALID_PARAMETER_HANDLER | |
4312 # include <crtdbg.h> | |
4313 #endif | |
4314 | |
4315 static void | |
4316 ansify_path(void) | |
4317 { | |
4318 size_t len; | |
4319 char *ansi_path; | |
4320 WCHAR *wide_path; | |
4321 WCHAR *wide_dir; | |
4322 | |
4323 /* fetch Unicode version of PATH */ | |
4324 len = 2000; | |
4325 wide_path = (WCHAR*)win32_malloc(len*sizeof(WCHAR)); | |
4326 while (wide_path) { | |
4327 size_t newlen = GetEnvironmentVariableW(L"PATH", wide_path, len); | |
4328 if (newlen == 0) { | |
4329 win32_free(wide_path); | |
4330 return; | |
4331 } | |
4332 if (newlen < len) | |
4333 break; | |
4334 len = newlen; | |
4335 wide_path = (WCHAR*)win32_realloc(wide_path, len*sizeof(WCHAR)); | |
4336 } | |
4337 if (!wide_path) | |
4338 return; | |
4339 | |
4340 /* convert to ANSI pathnames */ | |
4341 wide_dir = wide_path; | |
4342 ansi_path = NULL; | |
4343 while (wide_dir) { | |
4344 WCHAR *sep = wcschr(wide_dir, ';'); | |
4345 char *ansi_dir; | |
4346 size_t ansi_len; | |
4347 size_t wide_len; | |
4348 | |
4349 if (sep) | |
4350 *sep++ = '\0'; | |
4351 | |
4352 /* remove quotes around pathname */ | |
4353 if (*wide_dir == '"') | |
4354 ++wide_dir; | |
4355 wide_len = wcslen(wide_dir); | |
4356 if (wide_len && wide_dir[wide_len-1] == '"') | |
4357 wide_dir[wide_len-1] = '\0'; | |
4358 | |
4359 /* append ansi_dir to ansi_path */ | |
4360 ansi_dir = win32_ansipath(wide_dir); | |
4361 ansi_len = strlen(ansi_dir); | |
4362 if (ansi_path) { | |
4363 size_t newlen = len + 1 + ansi_len; | |
4364 ansi_path = (char*)win32_realloc(ansi_path, newlen+1); | |
4365 if (!ansi_path) | |
4366 break; | |
4367 ansi_path[len] = ';'; | |
4368 memcpy(ansi_path+len+1, ansi_dir, ansi_len+1); | |
4369 len = newlen; | |
4370 } | |
4371 else { | |
4372 len = ansi_len; | |
4373 ansi_path = (char*)win32_malloc(5+len+1); | |
4374 if (!ansi_path) | |
4375 break; | |
4376 memcpy(ansi_path, "PATH=", 5); | |
4377 memcpy(ansi_path+5, ansi_dir, len+1); | |
4378 len += 5; | |
4379 } | |
4380 win32_free(ansi_dir); | |
4381 wide_dir = sep; | |
4382 } | |
4383 | |
4384 if (ansi_path) { | |
4385 /* Update C RTL environ array. This will only have full effect if | |
4386 * perl_parse() is later called with `environ` as the `env` argument. | |
4387 * Otherwise S_init_postdump_symbols() will overwrite PATH again. | |
4388 * | |
4389 * We do have to ansify() the PATH before Perl has been fully | |
4390 * initialized because S_find_script() uses the PATH when perl | |
4391 * is being invoked with the -S option. This happens before %ENV | |
4392 * is initialized in S_init_postdump_symbols(). | |
4393 * | |
4394 * XXX Is this a bug? Should S_find_script() use the environment | |
4395 * XXX passed in the `env` arg to parse_perl()? | |
4396 */ | |
4397 putenv(ansi_path); | |
4398 /* Keep system environment in sync because S_init_postdump_symbols() | |
4399 * will not call mg_set() if it initializes %ENV from `environ`. | |
4400 */ | |
4401 SetEnvironmentVariableA("PATH", ansi_path+5); | |
4402 win32_free(ansi_path); | |
4403 } | |
4404 win32_free(wide_path); | |
4405 } | |
4406 | |
4407 void | |
4408 Perl_win32_init(int *argcp, char ***argvp) | |
4409 { | |
4410 #ifdef SET_INVALID_PARAMETER_HANDLER | |
4411 _invalid_parameter_handler oldHandler, newHandler; | |
4412 newHandler = my_invalid_parameter_handler; | |
4413 oldHandler = _set_invalid_parameter_handler(newHandler); | |
4414 _CrtSetReportMode(_CRT_ASSERT, 0); | |
4415 #endif | |
4416 /* Disable floating point errors, Perl will trap the ones we | |
4417 * care about. VC++ RTL defaults to switching these off | |
4418 * already, but some RTLs don't. Since we don't | |
4419 * want to be at the vendor's whim on the default, we set | |
4420 * it explicitly here. | |
4421 */ | |
4422 #if !defined(__GNUC__) | |
4423 _control87(MCW_EM, MCW_EM); | |
4424 #endif | |
4425 MALLOC_INIT; | |
4426 | |
4427 /* When the manifest resource requests Common-Controls v6 then | |
4428 * user32.dll no longer registers all the Windows classes used for | |
4429 * standard controls but leaves some of them to be registered by | |
4430 * comctl32.dll. InitCommonControls() doesn't do anything but calling | |
4431 * it makes sure comctl32.dll gets loaded into the process and registers | |
4432 * the standard control classes. Without this even normal Windows APIs | |
4433 * like MessageBox() can fail under some versions of Windows XP. | |
4434 */ | |
4435 InitCommonControls(); | |
4436 | |
4437 g_osver.dwOSVersionInfoSize = sizeof(g_osver); | |
4438 GetVersionEx(&g_osver); | |
4439 | |
4440 #ifdef WIN32_DYN_IOINFO_SIZE | |
4441 { | |
4442 Size_t ioinfo_size = _msize((void*)__pioinfo[0]);; | |
4443 if((SSize_t)ioinfo_size <= 0) { /* -1 is err */ | |
4444 fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */ | |
4445 exit(1); | |
4446 } | |
4447 ioinfo_size /= IOINFO_ARRAY_ELTS; | |
4448 w32_ioinfo_size = ioinfo_size; | |
4449 } | |
4450 #endif | |
4451 | |
4452 ansify_path(); | |
4453 } | |
4454 | |
4455 void | |
4456 Perl_win32_term(void) | |
4457 { | |
4458 HINTS_REFCNT_TERM; | |
4459 OP_REFCNT_TERM; | |
4460 PERLIO_TERM; | |
4461 MALLOC_TERM; | |
4462 } | |
4463 | |
4464 void | |
4465 win32_get_child_IO(child_IO_table* ptbl) | |
4466 { | |
4467 ptbl->childStdIn = GetStdHandle(STD_INPUT_HANDLE); | |
4468 ptbl->childStdOut = GetStdHandle(STD_OUTPUT_HANDLE); | |
4469 ptbl->childStdErr = GetStdHandle(STD_ERROR_HANDLE); | |
4470 } | |
4471 | |
4472 Sighandler_t | |
4473 win32_signal(int sig, Sighandler_t subcode) | |
4474 { | |
4475 dTHXa(NULL); | |
4476 if (sig < SIG_SIZE) { | |
4477 int save_errno = errno; | |
4478 Sighandler_t result; | |
4479 #ifdef SET_INVALID_PARAMETER_HANDLER | |
4480 /* Silence our invalid parameter handler since we expect to make some | |
4481 * calls with invalid signal numbers giving a SIG_ERR result. */ | |
4482 BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE); | |
4483 #endif | |
4484 result = signal(sig, subcode); | |
4485 #ifdef SET_INVALID_PARAMETER_HANDLER | |
4486 set_silent_invalid_parameter_handler(oldvalue); | |
4487 #endif | |
4488 aTHXa(PERL_GET_THX); | |
4489 if (result == SIG_ERR) { | |
4490 result = w32_sighandler[sig]; | |
4491 errno = save_errno; | |
4492 } | |
4493 w32_sighandler[sig] = subcode; | |
4494 return result; | |
4495 } | |
4496 else { | |
4497 errno = EINVAL; | |
4498 return SIG_ERR; | |
4499 } | |
4500 } | |
4501 | |
4502 /* The PerlMessageWindowClass's WindowProc */ | |
4503 LRESULT CALLBACK | |
4504 win32_message_window_proc(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) | |
4505 { | |
4506 return win32_process_message(hwnd, msg, wParam, lParam) ? | |
4507 0 : DefWindowProc(hwnd, msg, wParam, lParam); | |
4508 } | |
4509 | |
4510 /* The real message handler. Can be called with | |
4511 * hwnd == NULL to process our thread messages. Returns TRUE for any messages | |
4512 * that it processes */ | |
4513 static LRESULT | |
4514 win32_process_message(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) | |
4515 { | |
4516 /* BEWARE. The context retrieved using dTHX; is the context of the | |
4517 * 'parent' thread during the CreateWindow() phase - i.e. for all messages | |
4518 * up to and including WM_CREATE. If it ever happens that you need the | |
4519 * 'child' context before this, then it needs to be passed into | |
4520 * win32_create_message_window(), and passed to the WM_NCCREATE handler | |
4521 * from the lparam of CreateWindow(). It could then be stored/retrieved | |
4522 * using [GS]etWindowLongPtr(... GWLP_USERDATA ...), possibly eliminating | |
4523 * the dTHX calls here. */ | |
4524 /* XXX For now it is assumed that the overhead of the dTHX; for what | |
4525 * are relativley infrequent code-paths, is better than the added | |
4526 * complexity of getting the correct context passed into | |
4527 * win32_create_message_window() */ | |
4528 dTHX; | |
4529 | |
4530 switch(msg) { | |
4531 | |
4532 #ifdef USE_ITHREADS | |
4533 case WM_USER_MESSAGE: { | |
4534 long child = find_pseudo_pid(aTHX_ (int)wParam); | |
4535 if (child >= 0) { | |
4536 w32_pseudo_child_message_hwnds[child] = (HWND)lParam; | |
4537 return 1; | |
4538 } | |
4539 break; | |
4540 } | |
4541 #endif | |
4542 | |
4543 case WM_USER_KILL: { | |
4544 /* We use WM_USER_KILL to fake kill() with other signals */ | |
4545 int sig = (int)wParam; | |
4546 if (do_raise(aTHX_ sig)) | |
4547 sig_terminate(aTHX_ sig); | |
4548 | |
4549 return 1; | |
4550 } | |
4551 | |
4552 case WM_TIMER: { | |
4553 /* alarm() is a one-shot but SetTimer() repeats so kill it */ | |
4554 if (w32_timerid && w32_timerid==(UINT)wParam) { | |
4555 KillTimer(w32_message_hwnd, w32_timerid); | |
4556 w32_timerid=0; | |
4557 | |
4558 /* Now fake a call to signal handler */ | |
4559 if (do_raise(aTHX_ 14)) | |
4560 sig_terminate(aTHX_ 14); | |
4561 | |
4562 return 1; | |
4563 } | |
4564 break; | |
4565 } | |
4566 | |
4567 default: | |
4568 break; | |
4569 | |
4570 } /* switch */ | |
4571 | |
4572 /* Above or other stuff may have set a signal flag, and we may not have | |
4573 * been called from win32_async_check() (e.g. some other GUI's message | |
4574 * loop. BUT DON'T dispatch signals here: If someone has set a SIGALRM | |
4575 * handler that die's, and the message loop that calls here is wrapped | |
4576 * in an eval, then you may well end up with orphaned windows - signals | |
4577 * are dispatched by win32_async_check() */ | |
4578 | |
4579 return 0; | |
4580 } | |
4581 | |
4582 void | |
4583 win32_create_message_window_class(void) | |
4584 { | |
4585 /* create the window class for "message only" windows */ | |
4586 WNDCLASS wc; | |
4587 | |
4588 Zero(&wc, 1, wc); | |
4589 wc.lpfnWndProc = win32_message_window_proc; | |
4590 wc.hInstance = (HINSTANCE)GetModuleHandle(NULL); | |
4591 wc.lpszClassName = "PerlMessageWindowClass"; | |
4592 | |
4593 /* second and subsequent calls will fail, but class | |
4594 * will already be registered */ | |
4595 RegisterClass(&wc); | |
4596 } | |
4597 | |
4598 HWND | |
4599 win32_create_message_window(void) | |
4600 { | |
4601 win32_create_message_window_class(); | |
4602 return CreateWindow("PerlMessageWindowClass", "PerlMessageWindow", | |
4603 0, 0, 0, 0, 0, HWND_MESSAGE, NULL, NULL, NULL); | |
4604 } | |
4605 | |
4606 #ifdef HAVE_INTERP_INTERN | |
4607 | |
4608 static void | |
4609 win32_csighandler(int sig) | |
4610 { | |
4611 #if 0 | |
4612 dTHXa(PERL_GET_SIG_CONTEXT); | |
4613 Perl_warn(aTHX_ "Got signal %d",sig); | |
4614 #endif | |
4615 /* Does nothing */ | |
4616 } | |
4617 | |
4618 #if defined(__MINGW32__) && defined(__cplusplus) | |
4619 #define CAST_HWND__(x) (HWND__*)(x) | |
4620 #else | |
4621 #define CAST_HWND__(x) x | |
4622 #endif | |
4623 | |
4624 void | |
4625 Perl_sys_intern_init(pTHX) | |
4626 { | |
4627 int i; | |
4628 | |
4629 w32_perlshell_tokens = NULL; | |
4630 w32_perlshell_vec = (char**)NULL; | |
4631 w32_perlshell_items = 0; | |
4632 w32_fdpid = newAV(); | |
4633 Newx(w32_children, 1, child_tab); | |
4634 w32_num_children = 0; | |
4635 # ifdef USE_ITHREADS | |
4636 w32_pseudo_id = 0; | |
4637 Newx(w32_pseudo_children, 1, pseudo_child_tab); | |
4638 w32_num_pseudo_children = 0; | |
4639 # endif | |
4640 w32_timerid = 0; | |
4641 w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); | |
4642 w32_poll_count = 0; | |
4643 for (i=0; i < SIG_SIZE; i++) { | |
4644 w32_sighandler[i] = SIG_DFL; | |
4645 } | |
4646 # ifdef MULTIPLICITY | |
4647 if (my_perl == PL_curinterp) { | |
4648 # else | |
4649 { | |
4650 # endif | |
4651 /* Force C runtime signal stuff to set its console handler */ | |
4652 signal(SIGINT,win32_csighandler); | |
4653 signal(SIGBREAK,win32_csighandler); | |
4654 | |
4655 /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP | |
4656 * flag. This has the side-effect of disabling Ctrl-C events in all | |
4657 * processes in this group. | |
4658 * We re-enable Ctrl-C handling by calling SetConsoleCtrlHandler() | |
4659 * with a NULL handler. | |
4660 */ | |
4661 SetConsoleCtrlHandler(NULL,FALSE); | |
4662 | |
4663 /* Push our handler on top */ | |
4664 SetConsoleCtrlHandler(win32_ctrlhandler,TRUE); | |
4665 } | |
4666 } | |
4667 | |
4668 void | |
4669 Perl_sys_intern_clear(pTHX) | |
4670 { | |
4671 Safefree(w32_perlshell_tokens); | |
4672 Safefree(w32_perlshell_vec); | |
4673 /* NOTE: w32_fdpid is freed by sv_clean_all() */ | |
4674 Safefree(w32_children); | |
4675 if (w32_timerid) { | |
4676 KillTimer(w32_message_hwnd, w32_timerid); | |
4677 w32_timerid = 0; | |
4678 } | |
4679 if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE) | |
4680 DestroyWindow(w32_message_hwnd); | |
4681 # ifdef MULTIPLICITY | |
4682 if (my_perl == PL_curinterp) { | |
4683 # else | |
4684 { | |
4685 # endif | |
4686 SetConsoleCtrlHandler(win32_ctrlhandler,FALSE); | |
4687 } | |
4688 # ifdef USE_ITHREADS | |
4689 Safefree(w32_pseudo_children); | |
4690 # endif | |
4691 } | |
4692 | |
4693 # ifdef USE_ITHREADS | |
4694 | |
4695 void | |
4696 Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) | |
4697 { | |
4698 PERL_ARGS_ASSERT_SYS_INTERN_DUP; | |
4699 | |
4700 dst->perlshell_tokens = NULL; | |
4701 dst->perlshell_vec = (char**)NULL; | |
4702 dst->perlshell_items = 0; | |
4703 dst->fdpid = newAV(); | |
4704 Newxz(dst->children, 1, child_tab); | |
4705 dst->pseudo_id = 0; | |
4706 Newxz(dst->pseudo_children, 1, pseudo_child_tab); | |
4707 dst->timerid = 0; | |
4708 dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); | |
4709 dst->poll_count = 0; | |
4710 Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t); | |
4711 } | |
4712 # endif /* USE_ITHREADS */ | |
4713 #endif /* HAVE_INTERP_INTERN */ |