X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=45e1d2fb65a9e75e111e93772de671b77bc49c6e;hb=355b129945f44493ff7efa1481d95ddca2d2f87f;hp=19b9f597f6c063b940c1d769042cfa218a6818bb;hpb=b56ec34489067f612a4e5d2fecae86c5bbfffd5c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index 19b9f59..45e1d2f 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -3,8 +3,14 @@ #define INCL_DOSFILEMGR #define INCL_DOSMEMMGR #define INCL_DOSERRORS +/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ +#define INCL_DOSPROCESS +#define SPU_DISABLESUPPRESSION 0 +#define SPU_ENABLESUPPRESSION 1 #include +#include + /* * Various Unix compatibility functions for OS/2 */ @@ -60,7 +66,7 @@ pthread_join(perl_os_thread tid, void **status) break; case pthreads_st_waited: MUTEX_UNLOCK(&start_thread_mutex); - croak("join with a thread with a waiter"); + Perl_croak_nocontext("join with a thread with a waiter"); break; case pthreads_st_run: thread_join_data[tid].state = pthreads_st_waited; @@ -73,7 +79,7 @@ pthread_join(perl_os_thread tid, void **status) break; default: MUTEX_UNLOCK(&start_thread_mutex); - croak("join: unknown thread state: '%s'", + Perl_croak_nocontext("join: unknown thread state: '%s'", pthreads_states[thread_join_data[tid].state]); break; } @@ -101,7 +107,7 @@ pthread_startit(void *arg) } } if (thread_join_data[tid].state != pthreads_st_none) - croak("attempt to reuse thread id %i", tid); + Perl_croak_nocontext("attempt to reuse thread id %i", tid); thread_join_data[tid].state = pthreads_st_run; /* Now that we copied/updated the guys, we may release the caller... */ MUTEX_UNLOCK(&start_thread_mutex); @@ -140,7 +146,7 @@ pthread_detach(perl_os_thread tid) switch (thread_join_data[tid].state) { case pthreads_st_waited: MUTEX_UNLOCK(&start_thread_mutex); - croak("detach on a thread with a waiter"); + Perl_croak_nocontext("detach on a thread with a waiter"); break; case pthreads_st_run: thread_join_data[tid].state = pthreads_st_detached; @@ -148,7 +154,7 @@ pthread_detach(perl_os_thread tid) break; default: MUTEX_UNLOCK(&start_thread_mutex); - croak("detach: unknown thread state: '%s'", + Perl_croak_nocontext("detach: unknown thread state: '%s'", pthreads_states[thread_join_data[tid].state]); break; } @@ -160,12 +166,13 @@ int os2_cond_wait(perl_cond *c, perl_mutex *m) { int rc; - if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET)) - croak("panic: COND_WAIT-reset: rc=%i", rc); + STRLEN n_a; + if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) + Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) && (rc != ERROR_INTERRUPT)) - croak("panic: COND_WAIT: rc=%i", rc); + Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc); if (rc == ERROR_INTERRUPT) errno = EINTR; if (m) MUTEX_LOCK(m); @@ -178,9 +185,10 @@ static PFN ExtFCN[2]; /* Labeled by ord below. */ static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ #define ORD_QUERY_ELP 0 #define ORD_SET_ELP 1 +struct PMWIN_entries_t PMWIN_entries; APIRET -loadByOrd(ULONG ord) +loadByOrd(char *modname, ULONG ord) { if (ExtFCN[ord] == NULL) { static HMODULE hdosc = 0; @@ -189,15 +197,46 @@ loadByOrd(ULONG ord) APIRET rc; if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, - "doscalls", &hdosc))) + modname, &hdosc))) || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) - die("This version of OS/2 does not support doscalls.%i", - loadOrd[ord]); + Perl_croak_nocontext("This version of OS/2 does not support %s.%i", + modname, loadOrd[ord]); ExtFCN[ord] = fcn; } - if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); + if ((long)ExtFCN[ord] == -1) + Perl_croak_nocontext("panic queryaddr"); } +void +init_PMWIN_entries(void) +{ + static HMODULE hpmwin = 0; + static const int ords[] = { + 763, /* Initialize */ + 716, /* CreateMsgQueue */ + 726, /* DestroyMsgQueue */ + 918, /* PeekMsg */ + 915, /* GetMsg */ + 912, /* DispatchMsg */ + }; + BYTE buf[20]; + int i = 0; + unsigned long rc; + + if (hpmwin) + return; + + if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin))) + Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf); + while (i <= 5) { + if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, + ((PFN*)&PMWIN_entries)+i))) + Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]); + i++; + } +} + + /* priorities */ static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, self inverse. */ @@ -238,7 +277,7 @@ sys_prio(pid) } if (pid != psi->procdata->pid) { Safefree(psi); - croak("panic: wrong pid in sysinfo"); + Perl_croak_nocontext("panic: wrong pid in sysinfo"); } prio = psi->procdata->threads->priority; Safefree(psi); @@ -334,8 +373,9 @@ spawn_sighandler(int sig) } static int -result(int flag, int pid) +result(pTHX_ int flag, int pid) { + dTHR; int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ @@ -377,6 +417,7 @@ result(int flag, int pid) #define EXECF_EXEC 1 #define EXECF_TRUEEXEC 2 #define EXECF_SPAWN_NOWAIT 3 +#define EXECF_SPAWN_BYFLAG 4 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ @@ -401,7 +442,7 @@ file_type(char *path) ULONG apptype; if (!(_emx_env & 0x200)) - croak("file_type not implemented on DOS"); /* not OS/2. */ + Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ if (CheckOSError(DosQueryAppType(path, &apptype))) { switch (rc) { case ERROR_FILE_NOT_FOUND: @@ -424,11 +465,7 @@ static ULONG os2_mytype; /* global PL_Argv[] contains arguments. */ int -do_spawn_ve(really, flag, execf, inicmd) -SV *really; -U32 flag; -U32 execf; -char *inicmd; +do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag) { dTHR; int trueflag = flag; @@ -441,6 +478,8 @@ char *inicmd; char **argsp = fargs; char nargs = 4; int force_shell; + int new_stderr = -1, nostderr = 0, fl_stderr; + STRLEN n_a; if (flag == P_WAIT) flag = P_NOWAIT; @@ -455,7 +494,7 @@ char *inicmd; ) /* will spawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ /* We should check PERL_SH* and PERLLIB_* as well? */ - if (!really || !*(tmps = SvPV(really, PL_na))) + if (!really || !*(tmps = SvPV(really, n_a))) tmps = PL_Argv[0]; reread: @@ -498,7 +537,7 @@ char *inicmd; if (flag == P_NOWAIT) flag = P_PM; else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) - warn("Starting PM process with flag=%d, mytype=%d", + Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d", flag, os2_mytype); } } @@ -509,7 +548,7 @@ char *inicmd; if (flag == P_NOWAIT) flag = P_SESSION; else if ((flag & 7) != P_SESSION) - warn("Starting Full Screen process with flag=%d, mytype=%d", + Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d", flag, os2_mytype); } } @@ -522,8 +561,26 @@ char *inicmd; } } + if (addflag) { + addflag = 0; + new_stderr = dup(2); /* Preserve stderr */ + if (new_stderr == -1) { + if (errno == EBADF) + nostderr = 1; + else { + rc = -1; + goto finish; + } + } else + fl_stderr = fcntl(2, F_GETFD); + rc = dup2(1,2); + if (rc == -1) + goto finish; + fcntl(new_stderr, F_SETFD, FD_CLOEXEC); + } + #if 0 - rc = result(trueflag, spawnvp(flag,tmps,PL_Argv)); + rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); #else if (execf == EXECF_TRUEEXEC) rc = execvp(tmps,PL_Argv); @@ -531,8 +588,8 @@ char *inicmd; rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnvp(flag,tmps,PL_Argv); - else /* EXECF_SPAWN */ - rc = result(trueflag, + else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ + rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv)); #endif if (rc < 0 && pass == 1 @@ -546,21 +603,26 @@ char *inicmd; /* Try adding script extensions to the file name, and search on PATH. */ char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); - int l = strlen(scr); - - if (l >= sizeof scrbuf) { - Safefree(scr); - longbuf: - croak("Size of scriptname too big: %d", l); - } - strcpy(scrbuf, scr); - Safefree(scr); - scr = scrbuf; if (scr) { - FILE *file = fopen(scr, "r"); + FILE *file; char *s = 0, *s1; + int l; + l = strlen(scr); + + if (l >= sizeof scrbuf) { + Safefree(scr); + longbuf: + Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l); + rc = -1; + goto finish; + } + strcpy(scrbuf, scr); + Safefree(scr); + scr = scrbuf; + + file = fopen(scr, "r"); PL_Argv[0] = scr; if (!file) goto panic_file; @@ -588,7 +650,7 @@ char *inicmd; } if (fclose(file) != 0) { /* Failure */ panic_file: - warn("Error reading \"%s\": %s", + Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s", scr, Strerror(errno)); buf[0] = 0; /* Not #! */ goto doshell_args; @@ -632,7 +694,7 @@ char *inicmd; *s++ = 0; } if (nargs == -1) { - warn("Too many args on %.*s line of \"%s\"", + Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"", s1 - buf, buf, scr); nargs = 4; argsp = fargs; @@ -711,7 +773,7 @@ char *inicmd; long enough. */ a--; } - while (nargs-- >= 0) + while (--nargs >= 0) PL_Argv[nargs] = argsp[nargs]; /* Enable pathless exec if #! (as pdksh). */ pass = (buf[0] == '#' ? 2 : 3); @@ -733,66 +795,35 @@ char *inicmd; goto retry; } } - if (rc < 0 && PL_dowarn) - warn("Can't %s \"%s\": %s\n", + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n", ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) ? "spawn" : "exec"), PL_Argv[0], Strerror(errno)); if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) && ((trueflag & 0xFF) == P_WAIT)) - rc = 255 << 8; /* Emulate the fork(). */ - - return rc; -} - -/* Array spawn. */ -int -do_aspawn(really,mark,sp) -SV *really; -register SV **mark; -register SV **sp; -{ - dTHR; - register char **a; - char *tmps = NULL; - int rc; - int flag = P_WAIT, trueflag, err, secondtry = 0; - - if (sp > mark) { - New(1301,PL_Argv, sp - mark + 3, char*); - a = PL_Argv; - - if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); - } - - while (++mark <= sp) { - if (*mark) - *a++ = SvPVx(*mark, PL_na); - else - *a++ = ""; - } - *a = Nullch; - - rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL); - } else - rc = -1; - do_execfree(); + rc = -1; + + finish: + if (new_stderr != -1) { /* How can we use error codes? */ + dup2(new_stderr, 2); + close(new_stderr); + fcntl(2, F_SETFD, fl_stderr); + } else if (nostderr) + close(2); return rc; } /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ int -do_spawn2(cmd, execf) -char *cmd; -int execf; +do_spawn3(pTHX_ char *cmd, int execf, int flag) { + dTHR; register char **a; register char *s; char flags[10]; char *shell, *copt, *news = NULL; - int rc, err, seenspace = 0; + int rc, err, seenspace = 0, mergestderr = 0; char fullcmd[MAXNAMLEN + 1]; #ifdef TRYSHELL @@ -845,6 +876,18 @@ int execf; break; } else if (*s == '\\' && !seenspace) { continue; /* Allow backslashes in names */ + } else if (*s == '>' && s >= cmd + 3 + && s[-1] == '2' && s[1] == '&' && s[2] == '1' + && isSPACE(s[-2]) ) { + char *t = s + 3; + + while (*t && isSPACE(*t)) + t++; + if (!*t) { + s[-2] = '\0'; + mergestderr = 1; + break; /* Allow 2>&1 as the last thing */ + } } /* We do not convert this to do_spawn_ve since shell should be smart enough to start itself gloriously. */ @@ -855,15 +898,18 @@ int execf; rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); + else if (execf == EXECF_SPAWN_BYFLAG) + rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); else { /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - rc = result(P_WAIT, + rc = result(aTHX_ P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); - if (rc < 0 && PL_dowarn) - warn("Can't %s \"%s\": %s", + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (execf == EXECF_SPAWN ? "spawn" : "exec"), shell, Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + if (rc < 0) + rc = -1; } if (news) Safefree(news); @@ -887,7 +933,7 @@ int execf; } *a = Nullch; if (PL_Argv[0]) - rc = do_spawn_ve(NULL, 0, execf, cmd); + rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr); else rc = -1; if (news) @@ -896,39 +942,76 @@ int execf; return rc; } +/* Array spawn. */ int -do_spawn(cmd) -char *cmd; +os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp) { - return do_spawn2(cmd, EXECF_SPAWN); + dTHR; + register char **a; + int rc; + int flag = P_WAIT, flag_set = 0; + STRLEN n_a; + + if (sp > mark) { + New(1301,PL_Argv, sp - mark + 3, char*); + a = PL_Argv; + + if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { + ++mark; + flag = SvIVx(*mark); + flag_set = 1; + + } + + while (++mark <= sp) { + if (*mark) + *a++ = SvPVx(*mark, n_a); + else + *a++ = ""; + } + *a = Nullch; + + if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ + rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); + } else + rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0); + } else + rc = -1; + do_execfree(); + return rc; } int -do_spawn_nowait(cmd) -char *cmd; +os2_do_spawn(pTHX_ char *cmd) { - return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0); +} + +int +do_spawn_nowait(pTHX_ char *cmd) +{ + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0); } bool -do_exec(cmd) -char *cmd; +Perl_do_exec(pTHX_ char *cmd) { - do_spawn2(cmd, EXECF_EXEC); + dTHR; + do_spawn3(aTHX_ cmd, EXECF_EXEC, 0); return FALSE; } bool -os2exec(cmd) -char *cmd; +os2exec(pTHX_ char *cmd) { - return do_spawn2(cmd, EXECF_TRUEEXEC); + dTHR; + return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0); } PerlIO * -my_syspopen(cmd,mode) -char *cmd; -char *mode; +my_syspopen(pTHX_ char *cmd, char *mode) { #ifndef USE_POPEN @@ -937,6 +1020,7 @@ char *mode; register I32 pid, rc; PerlIO *res; SV *sv; + int fh_fl; /* `this' is what we use in the parent, `that' in the child. */ this = (*mode == 'w'); @@ -948,26 +1032,51 @@ char *mode; if (pipe(p) < 0) return Nullfp; /* Now we need to spawn the child. */ + if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ + int new = dup(p[this]); + + if (new == -1) + goto closepipes; + close(p[this]); + p[this] = new; + } newfd = dup(*mode == 'r'); /* Preserve std* */ - if (p[that] != (*mode == 'r')) { + if (newfd == -1) { + /* This cannot happen due to fh being bad after pipe(), since + pipe() should have created fh 0 and 1 even if they were + initially closed. But we closed p[this] before. */ + if (errno != EBADF) { + closepipes: + close(p[0]); + close(p[1]); + return Nullfp; + } + } else + fh_fl = fcntl(*mode == 'r', F_GETFD); + if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ dup2(p[that], *mode == 'r'); close(p[that]); } /* Where is `this' and newfd now? */ fcntl(p[this], F_SETFD, FD_CLOEXEC); - fcntl(newfd, F_SETFD, FD_CLOEXEC); - pid = do_spawn_nowait(cmd); - if (newfd != (*mode == 'r')) { + if (newfd != -1) + fcntl(newfd, F_SETFD, FD_CLOEXEC); + pid = do_spawn_nowait(aTHX_ cmd); + if (newfd == -1) + close(*mode == 'r'); /* It was closed initially */ + else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ dup2(newfd, *mode == 'r'); /* Return std* back. */ close(newfd); - } + fcntl(*mode == 'r', F_SETFD, fh_fl); + } else + fcntl(*mode == 'r', F_SETFD, fh_fl); if (p[that] == (*mode == 'r')) close(p[that]); if (pid == -1) { close(p[this]); - return NULL; + return Nullfp; } - if (p[that] < p[this]) { + if (p[that] < p[this]) { /* Make fh as small as possible */ dup2(p[this], p[that]); close(p[this]); p[this] = p[that]; @@ -1007,7 +1116,7 @@ char *mode; int fork(void) { - die(no_func, "Unsupported function fork"); + Perl_croak_nocontext(PL_no_func, "Unsupported function fork"); errno = EINVAL; return -1; } @@ -1033,7 +1142,7 @@ tcp0(char *name) static BYTE buf[20]; PFN fcn; - if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ + if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -1047,7 +1156,7 @@ tcp1(char *name, int arg) static BYTE buf[20]; PFN fcn; - if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ + if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */ if (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -1112,7 +1221,8 @@ sys_alloc(int size) { if (rc == ERROR_NOT_ENOUGH_MEMORY) { return (void *) -1; - } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); + } else if ( rc ) + Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); return got; } @@ -1132,10 +1242,12 @@ settmppath() if (!p) return; len = strlen(p); tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); - strcpy(tpath, p); - tpath[len] = '/'; - strcpy(tpath + len + 1, TMPPATH1); - tmppath = tpath; + if (tpath) { + strcpy(tpath, p); + tpath[len] = '/'; + strcpy(tpath + len + 1, TMPPATH1); + tmppath = tpath; + } } #include "XSUB.h" @@ -1144,10 +1256,11 @@ XS(XS_File__Copy_syscopy) { dXSARGS; if (items < 2 || items > 3) - croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); + Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); { - char * src = (char *)SvPV(ST(0),PL_na); - char * dst = (char *)SvPV(ST(1),PL_na); + STRLEN n_a; + char * src = (char *)SvPV(ST(0),n_a); + char * dst = (char *)SvPV(ST(1),n_a); U32 flag; int RETVAL, rc; @@ -1167,8 +1280,7 @@ XS(XS_File__Copy_syscopy) #include "patchlevel.h" char * -mod2fname(sv) - SV *sv; +mod2fname(pTHX_ SV *sv) { static char fname[9]; int pos = 6, len, avlen; @@ -1176,17 +1288,18 @@ mod2fname(sv) AV *av; SV *svp; char *s; + STRLEN n_a; - if (!SvROK(sv)) croak("Not a reference given to mod2fname"); + if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname"); sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVAV) - croak("Not array reference given to mod2fname"); + Perl_croak_nocontext("Not array reference given to mod2fname"); avlen = av_len((AV*)sv); if (avlen < 0) - croak("Empty array reference given to mod2fname"); + Perl_croak_nocontext("Empty array reference given to mod2fname"); - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na); + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); strncpy(fname, s, 8); len = strlen(s); if (len < 6) pos = len; @@ -1196,7 +1309,7 @@ mod2fname(sv) } avlen --; while (avlen >= 0) { - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na); + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); while (*s) { sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ } @@ -1205,7 +1318,7 @@ mod2fname(sv) #ifdef USE_THREADS sum++; /* Avoid conflict of DLLs in memory. */ #endif - sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */ + sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */ fname[pos] = 'A' + (sum % 26); fname[pos + 1] = 'A' + (sum / 26 % 26); fname[pos + 2] = '\0'; @@ -1216,12 +1329,12 @@ XS(XS_DynaLoader_mod2fname) { dXSARGS; if (items != 1) - croak("Usage: DynaLoader::mod2fname(sv)"); + Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); { SV * sv = ST(0); char * RETVAL; - RETVAL = mod2fname(sv); + RETVAL = mod2fname(aTHX_ sv); ST(0) = sv_newmortal(); sv_setpv((SV*)ST(0), RETVAL); } @@ -1239,18 +1352,38 @@ os2error(int rc) return NULL; if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); - else + else { buf[len] = '\0'; - if (len > 0 && buf[len - 1] == '\n') - buf[len - 1] = '\0'; - if (len > 1 && buf[len - 2] == '\r') - buf[len - 2] = '\0'; - if (len > 2 && buf[len - 3] == '.') - buf[len - 3] = '\0'; + if (len && buf[len - 1] == '\n') + buf[--len] = 0; + if (len && buf[len - 1] == '\r') + buf[--len] = 0; + if (len && buf[len - 1] == '.') + buf[--len] = 0; + } return buf; } char * +os2_execname(pTHX) +{ + dTHR; + char buf[300], *p; + + if (_execname(buf, sizeof buf) != 0) + return PL_origargv[0]; + p = buf; + while (*p) { + if (*p == '\\') + *p = '/'; + p++; + } + p = savepv(buf); + SAVEFREEPV(p); + return p; +} + +char * perllib_mangle(char *s, unsigned int l) { static char *newp, *oldp; @@ -1271,7 +1404,7 @@ perllib_mangle(char *s, unsigned int l) } newl = strlen(newp); if (newl == 0 || oldl == 0) { - die("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } strcpy(ret, newp); s = ret; @@ -1293,12 +1426,102 @@ perllib_mangle(char *s, unsigned int l) return s; } if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { - die("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); } strcpy(ret + newl, s + oldl); return ret; } +unsigned long +Perl_hab_GET() /* Needed if perl.h cannot be included */ +{ + return perl_hab_GET(); +} + +HMQ +Perl_Register_MQ(int serve) +{ + PPIB pib; + PTIB tib; + + if (Perl_os2_initial_mode++) + return Perl_hmq; + DosGetInfoBlocks(&tib, &pib); + Perl_os2_initial_mode = pib->pib_ultype; + Perl_hmq_refcnt = 1; + /* Try morphing into a PM application. */ + if (pib->pib_ultype != 3) /* 2 is VIO */ + pib->pib_ultype = 3; /* 3 is PM */ + init_PMWIN_entries(); + /* 64 messages if before OS/2 3.0, ignored otherwise */ + Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); + if (!Perl_hmq) { + static int cnt; + if (cnt++) + _exit(188); /* Panic can try to create a window. */ + Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application"); + } + return Perl_hmq; +} + +int +Perl_Serve_Messages(int force) +{ + int cnt = 0; + QMSG msg; + + if (Perl_hmq_servers && !force) + return 0; + if (!Perl_hmq_refcnt) + Perl_croak_nocontext("No message queue"); + while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { + cnt++; + if (msg.msg == WM_QUIT) + Perl_croak_nocontext("QUITing..."); + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + } + return cnt; +} + +int +Perl_Process_Messages(int force, I32 *cntp) +{ + QMSG msg; + + if (Perl_hmq_servers && !force) + return 0; + if (!Perl_hmq_refcnt) + Perl_croak_nocontext("No message queue"); + while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { + if (cntp) + (*cntp)++; + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + if (msg.msg == WM_DESTROY) + return -1; + if (msg.msg == WM_CREATE) + return +1; + } + Perl_croak_nocontext("QUITing..."); +} + +void +Perl_Deregister_MQ(int serve) +{ + PPIB pib; + PTIB tib; + + if (--Perl_hmq_refcnt == 0) { + (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); + Perl_hmq = 0; + /* Try morphing back from a PM application. */ + if (pib->pib_ultype == 3) /* 3 is PM */ + pib->pib_ultype = Perl_os2_initial_mode; + else + Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", + pib->pib_ultype); + } +} + extern void dlopen(); void *fakedl = &dlopen; /* Pull in dynaloading part. */ @@ -1312,11 +1535,211 @@ void *fakedl = &dlopen; /* Pull in dynaloading part. */ #define sys_chdir(p) (chdir(p) == 0) #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) +static int DOS_harderr_state = -1; + +XS(XS_OS2_Error) +{ + dXSARGS; + if (items != 2) + Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); + { + int arg1 = SvIV(ST(0)); + int arg2 = SvIV(ST(1)); + int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) + | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); + int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); + unsigned long rc; + + if (CheckOSError(DosError(a))) + Perl_croak_nocontext("DosError(%d) failed", a); + ST(0) = sv_newmortal(); + if (DOS_harderr_state >= 0) + sv_setiv(ST(0), DOS_harderr_state); + DOS_harderr_state = RETVAL; + } + XSRETURN(1); +} + +static signed char DOS_suppression_state = -1; + +XS(XS_OS2_Errors2Drive) +{ + dXSARGS; + if (items != 1) + Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); + { + STRLEN n_a; + SV *sv = ST(0); + int suppress = SvOK(sv); + char *s = suppress ? SvPV(sv, n_a) : NULL; + char drive = (s ? *s : 0); + unsigned long rc; + + if (suppress && !isALPHA(drive)) + Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); + if (CheckOSError(DosSuppressPopUps((suppress + ? SPU_ENABLESUPPRESSION + : SPU_DISABLESUPPRESSION), + drive))) + Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive); + ST(0) = sv_newmortal(); + if (DOS_suppression_state > 0) + sv_setpvn(ST(0), &DOS_suppression_state, 1); + else if (DOS_suppression_state == 0) + sv_setpvn(ST(0), "", 0); + DOS_suppression_state = drive; + } + XSRETURN(1); +} + +static const char * const si_fields[QSV_MAX] = { + "MAX_PATH_LENGTH", + "MAX_TEXT_SESSIONS", + "MAX_PM_SESSIONS", + "MAX_VDM_SESSIONS", + "BOOT_DRIVE", + "DYN_PRI_VARIATION", + "MAX_WAIT", + "MIN_SLICE", + "MAX_SLICE", + "PAGE_SIZE", + "VERSION_MAJOR", + "VERSION_MINOR", + "VERSION_REVISION", + "MS_COUNT", + "TIME_LOW", + "TIME_HIGH", + "TOTPHYSMEM", + "TOTRESMEM", + "TOTAVAILMEM", + "MAXPRMEM", + "MAXSHMEM", + "TIMER_INTERVAL", + "MAX_COMP_LENGTH", + "FOREGROUND_FS_SESSION", + "FOREGROUND_PROCESS" +}; + +XS(XS_OS2_SysInfo) +{ + dXSARGS; + if (items != 0) + Perl_croak_nocontext("Usage: OS2::SysInfo()"); + { + ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ + APIRET rc = NO_ERROR; /* Return code */ + int i = 0, j = 0; + + if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */ + QSV_MAX, /* information */ + (PVOID)si, + sizeof(si)))) + Perl_croak_nocontext("DosQuerySysInfo() failed"); + EXTEND(SP,2*QSV_MAX); + while (i < QSV_MAX) { + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), si_fields[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), si[i]); + i++; + } + } + XSRETURN(2 * QSV_MAX); +} + +XS(XS_OS2_BootDrive) +{ + dXSARGS; + if (items != 0) + Perl_croak_nocontext("Usage: OS2::BootDrive()"); + { + ULONG si[1] = {0}; /* System Information Data Buffer */ + APIRET rc = NO_ERROR; /* Return code */ + char c; + + if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, + (PVOID)si, sizeof(si)))) + Perl_croak_nocontext("DosQuerySysInfo() failed"); + ST(0) = sv_newmortal(); + c = 'a' - 1 + si[0]; + sv_setpvn(ST(0), &c, 1); + } + XSRETURN(1); +} + +XS(XS_OS2_MorphPM) +{ + dXSARGS; + if (items != 1) + Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); + { + bool serve = SvOK(ST(0)); + unsigned long pmq = perl_hmq_GET(serve); + + ST(0) = sv_newmortal(); + sv_setiv(ST(0), pmq); + } + XSRETURN(1); +} + +XS(XS_OS2_UnMorphPM) +{ + dXSARGS; + if (items != 1) + Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); + { + bool serve = SvOK(ST(0)); + + perl_hmq_UNSET(serve); + } + XSRETURN(0); +} + +XS(XS_OS2_Serve_Messages) +{ + dXSARGS; + if (items != 1) + Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); + { + bool force = SvOK(ST(0)); + unsigned long cnt = Perl_Serve_Messages(force); + + ST(0) = sv_newmortal(); + sv_setiv(ST(0), cnt); + } + XSRETURN(1); +} + +XS(XS_OS2_Process_Messages) +{ + dXSARGS; + if (items < 1 || items > 2) + Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); + { + bool force = SvOK(ST(0)); + unsigned long cnt; + I32 *cntp = NULL; + + if (items == 2) { + SV *sv = ST(1); + int fake = SvIV(sv); /* Force SvIVX */ + + if (!SvIOK(sv)) + Perl_croak_nocontext("Can't upgrade count to IV"); + cntp = &SvIVX(sv); + } + cnt = Perl_Process_Messages(force, cntp); + ST(0) = sv_newmortal(); + sv_setiv(ST(0), cnt); + } + XSRETURN(1); +} + XS(XS_Cwd_current_drive) { dXSARGS; if (items != 0) - croak("Usage: Cwd::current_drive()"); + Perl_croak_nocontext("Usage: Cwd::current_drive()"); { char RETVAL; @@ -1331,9 +1754,10 @@ XS(XS_Cwd_sys_chdir) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_chdir(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_chdir(path); @@ -1347,9 +1771,10 @@ XS(XS_Cwd_change_drive) { dXSARGS; if (items != 1) - croak("Usage: Cwd::change_drive(d)"); + Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); { - char d = (char)*SvPV(ST(0),PL_na); + STRLEN n_a; + char d = (char)*SvPV(ST(0),n_a); bool RETVAL; RETVAL = change_drive(d); @@ -1363,9 +1788,10 @@ XS(XS_Cwd_sys_is_absolute) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_absolute(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_absolute(path); @@ -1379,9 +1805,10 @@ XS(XS_Cwd_sys_is_rooted) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_rooted(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_rooted(path); @@ -1395,9 +1822,10 @@ XS(XS_Cwd_sys_is_relative) { dXSARGS; if (items != 1) - croak("Usage: Cwd::sys_is_relative(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); bool RETVAL; RETVAL = sys_is_relative(path); @@ -1411,7 +1839,7 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - croak("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { char p[MAXPATHLEN]; char * RETVAL; @@ -1426,9 +1854,10 @@ XS(XS_Cwd_sys_abspath) { dXSARGS; if (items < 1 || items > 2) - croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); + Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)"); { - char * path = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); char * dir; char p[MAXPATHLEN]; char * RETVAL; @@ -1436,7 +1865,7 @@ XS(XS_Cwd_sys_abspath) if (items < 2) dir = NULL; else { - dir = (char *)SvPV(ST(1),PL_na); + dir = (char *)SvPV(ST(1),n_a); } if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { path += 2; @@ -1533,7 +1962,7 @@ typedef APIRET (*PELP)(PSZ path, ULONG type); APIRET ExtLIBPATH(ULONG ord, PSZ path, ULONG type) { - loadByOrd(ord); /* Guarantied to load or die! */ + loadByOrd("doscalls",ord); /* Guarantied to load or die! */ return (*(PELP)ExtFCN[ord])(path, type); } @@ -1550,7 +1979,7 @@ XS(XS_Cwd_extLibpath) { dXSARGS; if (items < 0 || items > 1) - croak("Usage: Cwd::extLibpath(type = 0)"); + Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)"); { bool type; char to[1024]; @@ -1574,9 +2003,10 @@ XS(XS_Cwd_extLibpath_set) { dXSARGS; if (items < 1 || items > 2) - croak("Usage: Cwd::extLibpath_set(s, type = 0)"); + Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)"); { - char * s = (char *)SvPV(ST(0),PL_na); + STRLEN n_a; + char * s = (char *)SvPV(ST(0),n_a); bool type; U32 rc; bool RETVAL; @@ -1595,7 +2025,7 @@ XS(XS_Cwd_extLibpath_set) } int -Xs_OS2_init() +Xs_OS2_init(pTHX) { char *file = __FILE__; { @@ -1606,6 +2036,14 @@ Xs_OS2_init() newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); } + newXS("OS2::Error", XS_OS2_Error, file); + newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); + newXS("OS2::SysInfo", XS_OS2_SysInfo, file); + newXS("OS2::BootDrive", XS_OS2_BootDrive, file); + newXS("OS2::MorphPM", XS_OS2_MorphPM, file); + newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); + newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file); + newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file); newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); newXS("Cwd::current_drive", XS_Cwd_current_drive, file); newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); @@ -1620,6 +2058,17 @@ Xs_OS2_init() #ifdef PERL_IS_AOUT sv_setiv(GvSV(gv), 1); #endif + gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_rev); + sv_setpv(GvSV(gv), _emx_vprt); + SvIOK_on(GvSV(gv)); + gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_env); + gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); } } @@ -1633,7 +2082,8 @@ Perl_OS2_init(char **env) MALLOC_INIT; settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; - if (environ == NULL) { + _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); + if (environ == NULL && env) { environ = env; } if ( (shell = getenv("PERL_SH_DRIVE")) ) {