win32/ipproc.c

   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