MS-DOS patches to perl. Apply this patch to the standard perl source, version 4, patch level 19, using "patch -p." Do this in the root directory of the perl source distribution. You can cat all these patches together and pipe the output to patch -p. Len Reed Holos Software, Inc. ..!gatech!holos0!lbr holos0!lbr@gatech.edu -------------------------------------- *** msdos/subproc.c.old Sun Feb 23 08:48:16 1992 --- msdos/subproc.c Thu Nov 14 08:56:40 1991 *************** *** 0 **** --- 1,221 ---- + /* RCS -- $Header: c:/usr/lbr/perl/RCS/subproc.c 1.1 90/10/15 15:14:55 lbr Exp $ + -- SYNOPSIS -- Subprocess control for perl.exe: MS-DOS perl. + -- + -- DESCRIPTION + -- Interface between programs that want to call system(), etc., + -- and the swapping spawnv program. + -- This code was written for Microsoft C 6.0, but should be + -- nearly portable across modern MS-DOS compilers. ANSI + -- must be understood, and the far keyword must work. + -- + -- LOG + -- $Log: subproc.c $ + * Revision 1.1 90/10/15 15:14:55 lbr + * Initial revision + * + * + */ + + #include + #include + #include + #include + + #include "EXTERN.h" + #include "perl.h" + + static lookat_env(void); /* interrogate environment for subshell */ + static char *shell; /* full path name of $SHELL or $COMSPEC */ + static char *comspec; /* full path name of $COMSPEC */ + static char *metas; /* list of chars that are metachars to shell */ + static char *slashc; /* usually "/c" or "-c", for running subshell */ + char *DirSepStr; /* what to put between path elements */ + + static unsigned short unix_status(unsigned short); + + #ifdef MKS_SUPPORT + static int mksargs; /* true if MKSARGS in environ */ + extern char com_slashc[]; /* -c or /c for command.com: set at + startup by inspecting switch char. + */ + #else + #define mksargs 0 + static char com_slashc[] = "/c"; + #endif + + + /* Get value from environment. Treat null strings as unfound */ + + static char *getenv_or_null(char *var) + { + char *rval = getenv(var); + if (rval && strcmp(rval,"") == 0) + rval = NULL; + return rval; + } + + /* Find defaults from the environment. Done each time we need them, rather + than at startup, so that perl script can change them dynamically. + */ + + static lookat_env(void) + { + shell = getenv_or_null("SHELL"); + comspec = getenv_or_null("COMSPEC"); + metas = getenv_or_null("METACHAR"); + slashc = getenv_or_null("SLASHC"); + DirSepStr = getenv_or_null("DIRSEP"); + #ifdef MKS_SUPPORT + mksargs = getenv("MKSARGS") != NULL; + #endif + + if (comspec == NULL) + comspec = "\\command.com"; + + if (shell == NULL) { + shell = comspec; + if (metas == NULL) + metas = "|<>"; /* command.com list default */ + if (DirSepStr == NULL) + DirSepStr = "\\"; + if (slashc == NULL) + slashc = com_slashc; /* contains default switch char */ + } + else { + if (metas == NULL) + metas = KSH_META_CHARS; /* Korn shell list default */ + if (DirSepStr == NULL) + DirSepStr = mksargs ? "/" : "\\"; + if (slashc == NULL) /* MKS shell needs -e to pass back error code */ + slashc = mksargs ? "-ce" : "-c"; + } + } + + /* + * The following code is based on the do_exec and do_aexec functions + * in file doio.c + */ + + int + do_aspawn(really,arglast) + STR *really; + int *arglast; + { + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register char **a; + char **argv; + char *tmps; + int status; + + if (items) { + New(1101,argv, items+1, char*); + a = argv; + for (st += ++sp; items > 0; items--,st++) { + if (*st) + *a++ = str_get(*st); + else + *a++ = ""; + } + *a = Nullch; + if (really && *(tmps = str_get(really))) + status = swap_spawn(mksargs, tmps,argv); + else + status = swap_spawn(mksargs, argv[0], argv); + Safefree(argv); + } + return unix_status(status); + } + + int + do_spawn(char *cmd) + { + register char **a; + register char *s; + char **argv; + char flags[10]; + int status; + char *cmd2; + char *sh_argv[4]; + + lookat_env(); + + /* see if there are shell metacharacters in it */ + + if (strcspn(cmd, metas) != strlen(cmd)) { + sh_argv[0] = shell; /* sh.exe, command.com, or whatever */ + sh_argv[1] = slashc; /* -c or /c or whatever */ + sh_argv[2] = cmd; /* command line as supplied */ + sh_argv[3] = NULL; + doshell: + return unix_status(swap_spawn(mksargs, shell, sh_argv)); + } + + New(1102,argv, strlen(cmd) / 2 + 2, char*); + + New(1103,cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isspace(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isspace(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (argv[0]) { + status = swap_spawn(mksargs, argv[0], argv); + Safefree(cmd2); + Safefree(argv); + switch (status) { + case -2: + sh_argv[0] = comspec; /* command.com or whatever */ + sh_argv[1] = com_slashc; /* -c or /c or whatever */ + sh_argv[2] = cmd; /* command line as supplied */ + sh_argv[3] = NULL; + goto doshell; + + case -3: + sh_argv[0] = shell; /* shell script */ + sh_argv[1] = cmd; /* command line as supplied */ + sh_argv[2] = NULL; + goto doshell; + } + status = unix_status(status); + } + return status; + } + + /* Convert status as returned by MS-DOS int 21h, function 4dh call + to the unix wait(2) style expected by perl. + */ + + static unsigned short unix_status(unsigned short dos_status) + { + unsigned short result; + + switch (dos_status & 0xFF00) { + case 0xFF00: /* didn't find the program to run */ + result = 0xFF00; /* simulate child doing _exit(-1) */ + break; + + case 0x100: /* control break exit */ + result = SIGINT; /* child saw SIGINT */ + raise(SIGINT); /* keyboard signal to parent, too */ + break; + + default: /* undefined */ + case 0x200: /* critical error death */ + result = SIGABRT; + break; + + case 0x300: /* TSR exit! */ + case 0: /* child ran to completion */ + result = dos_status << 8; /* DOS uses low byte, unix high */ + break; + } + return result; + }