Commit | Line | Data |
76e3520e |
1 | /* |
2 | |
3 | ipproc.c |
4 | Interface for perl process functions |
5 | |
6 | */ |
7 | |
8 | #include <ipproc.h> |
9 | #include <stdlib.h> |
10 | #include <fcntl.h> |
11 | |
12 | #define EXECF_EXEC 1 |
13 | #define EXECF_SPAWN 2 |
14 | #define EXECF_SPAWN_NOWAIT 3 |
15 | |
16 | class CPerlProc : public IPerlProc |
17 | { |
18 | public: |
19 | CPerlProc() |
20 | { |
21 | pPerl = NULL; |
22 | w32_perlshell_tokens = NULL; |
23 | w32_perlshell_items = -1; |
24 | w32_platform = -1; |
25 | #ifndef __BORLANDC__ |
26 | w32_num_children = 0; |
27 | #endif |
28 | }; |
29 | virtual void Abort(void); |
30 | virtual void Exit(int status); |
31 | virtual void _Exit(int status); |
32 | virtual int Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3); |
33 | virtual int Execv(const char *cmdname, const char *const *argv); |
34 | virtual int Execvp(const char *cmdname, const char *const *argv); |
35 | virtual uid_t Getuid(void); |
36 | virtual uid_t Geteuid(void); |
37 | virtual gid_t Getgid(void); |
38 | virtual gid_t Getegid(void); |
39 | virtual char *Getlogin(void); |
40 | virtual int Kill(int pid, int sig); |
41 | virtual int Killpg(int pid, int sig); |
42 | virtual int PauseProc(void); |
43 | virtual PerlIO* Popen(const char *command, const char *mode); |
44 | virtual int Pclose(PerlIO *stream); |
45 | virtual int Pipe(int *phandles); |
46 | virtual int Setuid(uid_t u); |
47 | virtual int Setgid(gid_t g); |
48 | virtual int Sleep(unsigned int); |
49 | virtual int Times(struct tms *timebuf); |
50 | virtual int Wait(int *status); |
51 | virtual Sighandler_t Signal(int sig, Sighandler_t subcode); |
52 | virtual void GetSysMsg(char*& msg, DWORD& dwLen, DWORD dwErr); |
53 | virtual void FreeBuf(char* msg); |
54 | virtual BOOL DoCmd(char *cmd); |
55 | virtual int Spawn(char*cmds); |
56 | virtual int Spawnvp(int mode, const char *cmdname, const char *const *argv); |
57 | virtual int ASpawn(void *vreally, void **vmark, void **vsp); |
58 | |
59 | inline void SetPerlObj(CPerlObj *p) { pPerl = p; }; |
60 | protected: |
61 | int Spawn(char *cmd, int exectype); |
62 | void GetShell(void); |
63 | long Tokenize(char *str, char **dest, char ***destv); |
64 | |
65 | inline int IsWin95(void) |
66 | { |
67 | return (os_id() == VER_PLATFORM_WIN32_WINDOWS); |
68 | }; |
69 | inline int IsWinNT(void) |
70 | { |
71 | return (os_id() == VER_PLATFORM_WIN32_NT); |
72 | }; |
73 | |
74 | inline long filetime_to_clock(PFILETIME ft) |
75 | { |
76 | __int64 qw = ft->dwHighDateTime; |
77 | qw <<= 32; |
78 | qw |= ft->dwLowDateTime; |
79 | qw /= 10000; /* File time ticks at 0.1uS, clock at 1mS */ |
80 | return (long) qw; |
81 | }; |
82 | |
83 | DWORD os_id(void) |
84 | { |
85 | if((-1) == w32_platform) |
86 | { |
87 | OSVERSIONINFO osver; |
88 | |
89 | memset(&osver, 0, sizeof(OSVERSIONINFO)); |
90 | osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); |
91 | GetVersionEx(&osver); |
92 | w32_platform = osver.dwPlatformId; |
93 | } |
94 | return (w32_platform); |
95 | }; |
96 | |
97 | DWORD w32_platform; |
98 | char szLoginNameStr[128]; |
99 | char *w32_perlshell_tokens; |
100 | long w32_perlshell_items; |
101 | char **w32_perlshell_vec; |
102 | #ifndef __BORLANDC__ |
103 | long w32_num_children; |
104 | HANDLE w32_child_pids[MAXIMUM_WAIT_OBJECTS]; |
105 | #endif |
106 | CPerlObj *pPerl; |
107 | }; |
108 | |
109 | |
110 | static BOOL |
111 | has_redirection(char *ptr) |
112 | { |
113 | int inquote = 0; |
114 | char quote = '\0'; |
115 | |
116 | /* |
117 | * Scan string looking for redirection (< or >) or pipe |
118 | * characters (|) that are not in a quoted string |
119 | */ |
120 | while(*ptr) { |
121 | switch(*ptr) { |
122 | case '\'': |
123 | case '\"': |
124 | if(inquote) { |
125 | if(quote == *ptr) { |
126 | inquote = 0; |
127 | quote = '\0'; |
128 | } |
129 | } |
130 | else { |
131 | quote = *ptr; |
132 | inquote++; |
133 | } |
134 | break; |
135 | case '>': |
136 | case '<': |
137 | case '|': |
138 | if(!inquote) |
139 | return TRUE; |
140 | default: |
141 | break; |
142 | } |
143 | ++ptr; |
144 | } |
145 | return FALSE; |
146 | } |
147 | |
148 | /* Tokenize a string. Words are null-separated, and the list |
149 | * ends with a doubled null. Any character (except null and |
150 | * including backslash) may be escaped by preceding it with a |
151 | * backslash (the backslash will be stripped). |
152 | * Returns number of words in result buffer. |
153 | */ |
154 | long |
155 | CPerlProc::Tokenize(char *str, char **dest, char ***destv) |
156 | { |
157 | char *retstart = Nullch; |
158 | char **retvstart = 0; |
159 | int items = -1; |
160 | if (str) { |
161 | int slen = strlen(str); |
162 | register char *ret; |
163 | register char **retv; |
164 | New(1307, ret, slen+2, char); |
165 | New(1308, retv, (slen+3)/2, char*); |
166 | |
167 | retstart = ret; |
168 | retvstart = retv; |
169 | *retv = ret; |
170 | items = 0; |
171 | while (*str) { |
172 | *ret = *str++; |
173 | if (*ret == '\\' && *str) |
174 | *ret = *str++; |
175 | else if (*ret == ' ') { |
176 | while (*str == ' ') |
177 | str++; |
178 | if (ret == retstart) |
179 | ret--; |
180 | else { |
181 | *ret = '\0'; |
182 | ++items; |
183 | if (*str) |
184 | *++retv = ret+1; |
185 | } |
186 | } |
187 | else if (!*str) |
188 | ++items; |
189 | ret++; |
190 | } |
191 | retvstart[items] = Nullch; |
192 | *ret++ = '\0'; |
193 | *ret = '\0'; |
194 | } |
195 | *dest = retstart; |
196 | *destv = retvstart; |
197 | return items; |
198 | } |
199 | |
200 | |
201 | void |
202 | CPerlProc::GetShell(void) |
203 | { |
204 | if (!w32_perlshell_tokens) { |
205 | /* we don't use COMSPEC here for two reasons: |
206 | * 1. the same reason perl on UNIX doesn't use SHELL--rampant and |
207 | * uncontrolled unportability of the ensuing scripts. |
208 | * 2. PERL5SHELL could be set to a shell that may not be fit for |
209 | * interactive use (which is what most programs look in COMSPEC |
210 | * for). |
211 | */ |
212 | char* defaultshell = (IsWinNT() ? "cmd.exe /x/c" : "command.com /c"); |
213 | char* usershell = getenv("PERL5SHELL"); |
214 | w32_perlshell_items = Tokenize(usershell ? usershell : defaultshell, |
215 | &w32_perlshell_tokens, |
216 | &w32_perlshell_vec); |
217 | } |
218 | } |
219 | |
220 | int |
221 | CPerlProc::ASpawn(void *vreally, void **vmark, void **vsp) |
222 | { |
223 | SV *really = (SV*)vreally; |
224 | SV **mark = (SV**)vmark; |
225 | SV **sp = (SV**)vsp; |
226 | char **argv; |
227 | char *str; |
228 | int status; |
229 | int flag = P_WAIT; |
230 | int index = 0; |
231 | |
232 | if (sp <= mark) |
233 | return -1; |
234 | |
235 | GetShell(); |
236 | New(1306, argv, (sp - mark) + w32_perlshell_items + 2, char*); |
237 | |
238 | if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { |
239 | ++mark; |
240 | flag = SvIVx(*mark); |
241 | } |
242 | |
243 | while(++mark <= sp) { |
244 | if (*mark && (str = SvPV(*mark, na))) |
245 | argv[index++] = str; |
246 | else |
247 | argv[index++] = ""; |
248 | } |
249 | argv[index++] = 0; |
250 | |
251 | status = Spawnvp(flag, |
252 | (really ? SvPV(really,na) : argv[0]), |
253 | (const char* const*)argv); |
254 | |
255 | if (status < 0 && errno == ENOEXEC) { |
256 | /* possible shell-builtin, invoke with shell */ |
257 | int sh_items; |
258 | sh_items = w32_perlshell_items; |
259 | while (--index >= 0) |
260 | argv[index+sh_items] = argv[index]; |
261 | while (--sh_items >= 0) |
262 | argv[sh_items] = w32_perlshell_vec[sh_items]; |
263 | |
264 | status = Spawnvp(flag, |
265 | (really ? SvPV(really,na) : argv[0]), |
266 | (const char* const*)argv); |
267 | } |
268 | |
269 | if (status < 0) { |
270 | if (pPerl->Perl_dowarn) |
271 | warn("Can't spawn \"%s\": %s", argv[0], strerror(errno)); |
272 | status = 255 * 256; |
273 | } |
274 | else if (flag != P_NOWAIT) |
275 | status *= 256; |
276 | Safefree(argv); |
277 | return (pPerl->Perl_statusvalue = status); |
278 | } |
279 | |
280 | |
281 | int |
282 | CPerlProc::Spawn(char *cmd, int exectype) |
283 | { |
284 | char **a; |
285 | char *s; |
286 | char **argv; |
287 | int status = -1; |
288 | BOOL needToTry = TRUE; |
289 | char *cmd2; |
290 | |
291 | /* Save an extra exec if possible. See if there are shell |
292 | * metacharacters in it */ |
293 | if(!has_redirection(cmd)) { |
294 | New(1301,argv, strlen(cmd) / 2 + 2, char*); |
295 | New(1302,cmd2, strlen(cmd) + 1, char); |
296 | strcpy(cmd2, cmd); |
297 | a = argv; |
298 | for (s = cmd2; *s;) { |
299 | while (*s && isspace(*s)) |
300 | s++; |
301 | if (*s) |
302 | *(a++) = s; |
303 | while(*s && !isspace(*s)) |
304 | s++; |
305 | if(*s) |
306 | *s++ = '\0'; |
307 | } |
308 | *a = Nullch; |
309 | if (argv[0]) { |
310 | switch (exectype) { |
311 | case EXECF_SPAWN: |
312 | status = Spawnvp(P_WAIT, argv[0], |
313 | (const char* const*)argv); |
314 | break; |
315 | case EXECF_SPAWN_NOWAIT: |
316 | status = Spawnvp(P_NOWAIT, argv[0], |
317 | (const char* const*)argv); |
318 | break; |
319 | case EXECF_EXEC: |
320 | status = Execvp(argv[0], (const char* const*)argv); |
321 | break; |
322 | } |
323 | if (status != -1 || errno == 0) |
324 | needToTry = FALSE; |
325 | } |
326 | Safefree(argv); |
327 | Safefree(cmd2); |
328 | } |
329 | if (needToTry) { |
330 | char **argv; |
331 | int i = -1; |
332 | GetShell(); |
333 | New(1306, argv, w32_perlshell_items + 2, char*); |
334 | while (++i < w32_perlshell_items) |
335 | argv[i] = w32_perlshell_vec[i]; |
336 | argv[i++] = cmd; |
337 | argv[i] = Nullch; |
338 | switch (exectype) { |
339 | case EXECF_SPAWN: |
340 | status = Spawnvp(P_WAIT, argv[0], |
341 | (const char* const*)argv); |
342 | break; |
343 | case EXECF_SPAWN_NOWAIT: |
344 | status = Spawnvp(P_NOWAIT, argv[0], |
345 | (const char* const*)argv); |
346 | break; |
347 | case EXECF_EXEC: |
348 | status = Execvp(argv[0], (const char* const*)argv); |
349 | break; |
350 | } |
351 | cmd = argv[0]; |
352 | Safefree(argv); |
353 | } |
354 | if (status < 0) { |
355 | if (pPerl->Perl_dowarn) |
356 | warn("Can't %s \"%s\": %s", |
357 | (exectype == EXECF_EXEC ? "exec" : "spawn"), |
358 | cmd, strerror(errno)); |
359 | status = 255 * 256; |
360 | } |
361 | else if (exectype != EXECF_SPAWN_NOWAIT) |
362 | status *= 256; |
363 | return (pPerl->Perl_statusvalue = status); |
364 | } |
365 | |
366 | |
367 | void CPerlProc::Abort(void) |
368 | { |
369 | abort(); |
370 | } |
371 | |
372 | void CPerlProc::Exit(int status) |
373 | { |
374 | exit(status); |
375 | } |
376 | |
377 | void CPerlProc::_Exit(int status) |
378 | { |
379 | _exit(status); |
380 | } |
381 | |
382 | int CPerlProc::Execl(const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) |
383 | { |
384 | return execl(cmdname, arg0, arg1, arg2, arg3); |
385 | } |
386 | |
387 | int CPerlProc::Execv(const char *cmdname, const char *const *argv) |
388 | { |
389 | return execv(cmdname, argv); |
390 | } |
391 | |
392 | int CPerlProc::Execvp(const char *cmdname, const char *const *argv) |
393 | { |
394 | return execvp(cmdname, argv); |
395 | } |
396 | |
397 | #define ROOT_UID ((uid_t)0) |
398 | #define ROOT_GID ((gid_t)0) |
399 | |
400 | uid_t CPerlProc::Getuid(void) |
401 | { |
402 | return ROOT_UID; |
403 | } |
404 | |
405 | uid_t CPerlProc::Geteuid(void) |
406 | { |
407 | return ROOT_UID; |
408 | } |
409 | |
410 | gid_t CPerlProc::Getgid(void) |
411 | { |
412 | return ROOT_GID; |
413 | } |
414 | |
415 | gid_t CPerlProc::Getegid(void) |
416 | { |
417 | return ROOT_GID; |
418 | } |
419 | |
420 | |
421 | char *CPerlProc::Getlogin(void) |
422 | { |
423 | char unknown[] = "<Unknown>"; |
424 | unsigned long len; |
425 | |
426 | len = sizeof(szLoginNameStr); |
427 | if(!GetUserName(szLoginNameStr, &len)) |
428 | { |
429 | strcpy(szLoginNameStr, unknown); |
430 | } |
431 | return szLoginNameStr; |
432 | } |
433 | |
434 | int CPerlProc::Kill(int pid, int sig) |
435 | { |
436 | HANDLE hProcess; |
437 | |
438 | hProcess = OpenProcess(PROCESS_ALL_ACCESS, FALSE, (DWORD)pid); |
439 | if(hProcess == NULL) |
440 | croak("kill process failed!\n"); |
441 | |
442 | if(TerminateProcess(hProcess, 0) == FALSE) |
443 | croak("kill process failed!\n"); |
444 | |
445 | CloseHandle(hProcess); |
446 | return 0; |
447 | } |
448 | |
449 | int CPerlProc::Killpg(int pid, int sig) |
450 | { |
451 | croak("killpg not implemented!\n"); |
452 | return 0; |
453 | } |
454 | |
455 | int CPerlProc::PauseProc(void) |
456 | { |
457 | Sleep((unsigned int)((32767L << 16) + 32767)); |
458 | return 0; |
459 | } |
460 | |
461 | PerlIO* CPerlProc::Popen(const char *command, const char *mode) |
462 | { |
463 | return (PerlIO*)_popen(command, mode); |
464 | } |
465 | |
466 | int CPerlProc::Pclose(PerlIO *pf) |
467 | { |
468 | return _pclose((FILE*)pf); |
469 | } |
470 | |
471 | int CPerlProc::Pipe(int *phandles) |
472 | { |
473 | return _pipe(phandles, 512, O_BINARY); |
474 | } |
475 | |
476 | int CPerlProc::Sleep(unsigned int s) |
477 | { |
478 | ::Sleep(s*1000); |
479 | return 0; |
480 | } |
481 | |
482 | int CPerlProc::Times(struct tms *timebuf) |
483 | { |
484 | FILETIME user; |
485 | FILETIME kernel; |
486 | FILETIME dummy; |
487 | if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, |
488 | &kernel,&user)) { |
489 | timebuf->tms_utime = filetime_to_clock(&user); |
490 | timebuf->tms_stime = filetime_to_clock(&kernel); |
491 | timebuf->tms_cutime = 0; |
492 | timebuf->tms_cstime = 0; |
493 | |
494 | } else { |
495 | /* That failed - e.g. Win95 fallback to clock() */ |
496 | clock_t t = clock(); |
497 | timebuf->tms_utime = t; |
498 | timebuf->tms_stime = 0; |
499 | timebuf->tms_cutime = 0; |
500 | timebuf->tms_cstime = 0; |
501 | } |
502 | return 0; |
503 | } |
504 | |
505 | int CPerlProc::Wait(int *status) |
506 | { |
507 | #ifdef __BORLANDC__ |
508 | return wait(status); |
509 | #else |
510 | /* XXX this wait emulation only knows about processes |
511 | * spawned via win32_spawnvp(P_NOWAIT, ...). |
512 | */ |
513 | int i, retval; |
514 | DWORD exitcode, waitcode; |
515 | |
516 | if (!w32_num_children) { |
517 | errno = ECHILD; |
518 | return -1; |
519 | } |
520 | |
521 | /* if a child exists, wait for it to die */ |
522 | waitcode = WaitForMultipleObjects(w32_num_children, |
523 | w32_child_pids, |
524 | FALSE, |
525 | INFINITE); |
526 | if (waitcode != WAIT_FAILED) { |
527 | if (waitcode >= WAIT_ABANDONED_0 |
528 | && waitcode < WAIT_ABANDONED_0 + w32_num_children) |
529 | i = waitcode - WAIT_ABANDONED_0; |
530 | else |
531 | i = waitcode - WAIT_OBJECT_0; |
532 | if (GetExitCodeProcess(w32_child_pids[i], &exitcode) ) { |
533 | CloseHandle(w32_child_pids[i]); |
534 | *status = (int)((exitcode & 0xff) << 8); |
535 | retval = (int)w32_child_pids[i]; |
536 | Copy(&w32_child_pids[i+1], &w32_child_pids[i], |
537 | (w32_num_children-i-1), HANDLE); |
538 | w32_num_children--; |
539 | return retval; |
540 | } |
541 | } |
542 | |
543 | FAILED: |
544 | errno = GetLastError(); |
545 | return -1; |
546 | |
547 | #endif |
548 | } |
549 | |
550 | int CPerlProc::Setuid(uid_t u) |
551 | { |
552 | return (u == ROOT_UID ? 0 : -1); |
553 | } |
554 | |
555 | int CPerlProc::Setgid(gid_t g) |
556 | { |
557 | return (g == ROOT_GID ? 0 : -1); |
558 | } |
559 | |
560 | Sighandler_t CPerlProc::Signal(int sig, Sighandler_t subcode) |
561 | { |
562 | return 0; |
563 | } |
564 | |
565 | void CPerlProc::GetSysMsg(char*& sMsg, DWORD& dwLen, DWORD dwErr) |
566 | { |
567 | dwLen = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER |
568 | |FORMAT_MESSAGE_IGNORE_INSERTS |
569 | |FORMAT_MESSAGE_FROM_SYSTEM, NULL, |
570 | dwErr, 0, (char *)&sMsg, 1, NULL); |
571 | if (0 < dwLen) { |
572 | while (0 < dwLen && isspace(sMsg[--dwLen])) |
573 | ; |
574 | if ('.' != sMsg[dwLen]) |
575 | dwLen++; |
576 | sMsg[dwLen]= '\0'; |
577 | } |
578 | if (0 == dwLen) { |
579 | sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/); |
580 | dwLen = sprintf(sMsg, |
581 | "Unknown error #0x%lX (lookup 0x%lX)", |
582 | dwErr, GetLastError()); |
583 | } |
584 | } |
585 | |
586 | void CPerlProc::FreeBuf(char* sMsg) |
587 | { |
588 | LocalFree(sMsg); |
589 | } |
590 | |
591 | BOOL CPerlProc::DoCmd(char *cmd) |
592 | { |
593 | Spawn(cmd, EXECF_EXEC); |
594 | return FALSE; |
595 | } |
596 | |
597 | int CPerlProc::Spawn(char* cmd) |
598 | { |
599 | return Spawn(cmd, EXECF_SPAWN); |
600 | } |
601 | |
602 | int CPerlProc::Spawnvp(int mode, const char *cmdname, const char *const *argv) |
603 | { |
604 | int status; |
605 | |
606 | status = spawnvp(mode, cmdname, (char * const *)argv); |
607 | #ifndef __BORLANDC__ |
608 | /* XXX For the P_NOWAIT case, Borland RTL returns pinfo.dwProcessId |
609 | * while VC RTL returns pinfo.hProcess. For purposes of the custom |
610 | * implementation of win32_wait(), we assume the latter. |
611 | */ |
612 | if (mode == P_NOWAIT && status >= 0) |
613 | w32_child_pids[w32_num_children++] = (HANDLE)status; |
614 | #endif |
615 | return status; |
616 | } |
617 | |
618 | |
619 | |
620 | |