X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=d5457034c6272bd05f49eea97e8110e742fe6fe4;hb=3a6175e10304541293925e263645d3ac0b54f22f;hp=37219c85d61a10195a8cd10c94a7ce093de004a7;hpb=3bbf9c2bc59c6ee82df03650eca03d8d1d6f9de3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index 37219c8..d545703 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -13,11 +13,191 @@ #include #include #include +#include #include "EXTERN.h" #include "perl.h" +#ifdef USE_THREADS + +typedef void (*emx_startroutine)(void *); +typedef void* (*pthreads_startroutine)(void *); + +enum pthreads_state { + pthreads_st_none = 0, + pthreads_st_run, + pthreads_st_exited, + pthreads_st_detached, + pthreads_st_waited, +}; +const char *pthreads_states[] = { + "uninit", + "running", + "exited", + "detached", + "waited for", +}; + +typedef struct { + void *status; + perl_cond cond; + enum pthreads_state state; +} thread_join_t; + +thread_join_t *thread_join_data; +int thread_join_count; +perl_mutex start_thread_mutex; + +int +pthread_join(perl_os_thread tid, void **status) +{ + MUTEX_LOCK(&start_thread_mutex); + switch (thread_join_data[tid].state) { + case pthreads_st_exited: + thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ + MUTEX_UNLOCK(&start_thread_mutex); + *status = thread_join_data[tid].status; + break; + case pthreads_st_waited: + MUTEX_UNLOCK(&start_thread_mutex); + croak("join with a thread with a waiter"); + break; + case pthreads_st_run: + thread_join_data[tid].state = pthreads_st_waited; + COND_INIT(&thread_join_data[tid].cond); + MUTEX_UNLOCK(&start_thread_mutex); + COND_WAIT(&thread_join_data[tid].cond, NULL); + COND_DESTROY(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ + *status = thread_join_data[tid].status; + break; + default: + MUTEX_UNLOCK(&start_thread_mutex); + croak("join: unknown thread state: '%s'", + pthreads_states[thread_join_data[tid].state]); + break; + } + return 0; +} + +void +pthread_startit(void *arg) +{ + /* Thread is already started, we need to transfer control only */ + pthreads_startroutine start_routine = *((pthreads_startroutine*)arg); + int tid = pthread_self(); + void *retval; + + arg = ((void**)arg)[1]; + if (tid >= thread_join_count) { + int oc = thread_join_count; + + thread_join_count = tid + 5 + tid/5; + if (thread_join_data) { + Renew(thread_join_data, thread_join_count, thread_join_t); + Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); + } else { + Newz(1323, thread_join_data, thread_join_count, thread_join_t); + } + } + if (thread_join_data[tid].state != pthreads_st_none) + croak("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); + thread_join_data[tid].status = (*start_routine)(arg); + switch (thread_join_data[tid].state) { + case pthreads_st_waited: + COND_SIGNAL(&thread_join_data[tid].cond); + break; + default: + thread_join_data[tid].state = pthreads_st_exited; + break; + } +} + +int +pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, + void *(*start_routine)(void*), void *arg) +{ + void *args[2]; + + args[0] = (void*)start_routine; + args[1] = arg; + + MUTEX_LOCK(&start_thread_mutex); + *tid = _beginthread(pthread_startit, /*stack*/ NULL, + /*stacksize*/ 10*1024*1024, (void*)args); + MUTEX_LOCK(&start_thread_mutex); + MUTEX_UNLOCK(&start_thread_mutex); + return *tid ? 0 : EINVAL; +} + +int +pthread_detach(perl_os_thread tid) +{ + MUTEX_LOCK(&start_thread_mutex); + switch (thread_join_data[tid].state) { + case pthreads_st_waited: + MUTEX_UNLOCK(&start_thread_mutex); + croak("detach on a thread with a waiter"); + break; + case pthreads_st_run: + thread_join_data[tid].state = pthreads_st_detached; + MUTEX_UNLOCK(&start_thread_mutex); + break; + default: + MUTEX_UNLOCK(&start_thread_mutex); + croak("detach: unknown thread state: '%s'", + pthreads_states[thread_join_data[tid].state]); + break; + } + return 0; +} + +/* This is a very bastardized version: */ +int +os2_cond_wait(perl_cond *c, perl_mutex *m) +{ + int rc; + if ((rc = DosResetEventSem(*c,&na)) && (rc != ERROR_ALREADY_RESET)) + croak("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); + if (rc == ERROR_INTERRUPT) + errno = EINTR; + if (m) MUTEX_LOCK(m); +} +#endif + /*****************************************************************************/ +/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ +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 + +APIRET +loadByOrd(ULONG ord) +{ + if (ExtFCN[ord] == NULL) { + static HMODULE hdosc = 0; + BYTE buf[20]; + PFN fcn; + APIRET rc; + + if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, + "doscalls", &hdosc))) + || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) + die("This version of OS/2 does not support doscalls.%i", + loadOrd[ord]); + ExtFCN[ord] = fcn; + } + if ((long)ExtFCN[ord] == -1) die("panic queryaddr"); +} + /* priorities */ static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, self inverse. */ @@ -29,12 +209,12 @@ get_sysinfo(ULONG pid, ULONG flags) char *pbuffer; ULONG rc, buf_len = QSS_INI_BUFFER; - New(1022, pbuffer, buf_len, char); + New(1322, pbuffer, buf_len, char); /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ rc = QuerySysState(flags, pid, pbuffer, buf_len); while (rc == ERROR_BUFFER_OVERFLOW) { Renew(pbuffer, buf_len *= 2, char); - rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len); + rc = QuerySysState(flags, pid, pbuffer, buf_len); } if (rc) { FillOSError(rc); @@ -73,6 +253,7 @@ setpriority(int which, int pid, int val) prio = sys_prio(pid); + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { /* Do not change class. */ return CheckOSError(DosSetPriority((pid < 0) @@ -114,6 +295,7 @@ getpriority(int which /* ignored */, int pid) PIB *pib; ULONG rc, ret; + if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ /* DosGetInfoBlocks has old priority! */ /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ /* if (pid != pib->pib_ulpid) { */ @@ -128,6 +310,7 @@ getpriority(int which /* ignored */, int pid) /*****************************************************************************/ /* spawn */ +typedef void (*Sigfunc) _((int)); static int result(int flag, int pid) @@ -144,22 +327,22 @@ result(int flag, int pid) return pid; #ifdef __EMX__ - ihand = signal(SIGINT, SIG_IGN); - qhand = signal(SIGQUIT, SIG_IGN); + ihand = rsignal(SIGINT, SIG_IGN); + qhand = rsignal(SIGQUIT, SIG_IGN); do { r = wait4pid(pid, &status, 0); } while (r == -1 && errno == EINTR); - signal(SIGINT, ihand); - signal(SIGQUIT, qhand); + rsignal(SIGINT, ihand); + rsignal(SIGQUIT, qhand); statusvalue = (U16)status; if (r < 0) return -1; return status & 0xFFFF; #else - ihand = signal(SIGINT, SIG_IGN); + ihand = rsignal(SIGINT, SIG_IGN); r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); - signal(SIGINT, ihand); + rsignal(SIGINT, ihand); statusvalue = res.codeResult << 8 | res.codeTerminate; if (r) return -1; @@ -167,19 +350,186 @@ result(int flag, int pid) #endif } +#define EXECF_SPAWN 0 +#define EXECF_EXEC 1 +#define EXECF_TRUEEXEC 2 +#define EXECF_SPAWN_NOWAIT 3 + +/* Spawn/exec a program, revert to shell if needed. */ +/* global Argv[] contains arguments. */ + +int +do_spawn_ve(really, flag, execf) +SV *really; +U32 flag; +U32 execf; +{ + dTHR; + int trueflag = flag; + int rc, secondtry = 0, err; + char *tmps; + char buf[256], *s = 0; + char *args[4]; + static char * fargs[4] + = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; + char **argsp = fargs; + char nargs = 4; + + if (flag == P_WAIT) + flag = P_NOWAIT; + + retry: + if (strEQ(Argv[0],"/bin/sh")) + Argv[0] = sh_path; + + if (Argv[0][0] != '/' && Argv[0][0] != '\\' + && !(Argv[0][0] && Argv[0][1] == ':' + && (Argv[0][2] == '/' || Argv[0][2] != '\\')) + ) /* will swawnvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ + /* We should check PERL_SH* and PERLLIB_* as well? */ + if (!really || !*(tmps = SvPV(really, na))) + tmps = Argv[0]; +#if 0 + rc = result(trueflag, spawnvp(flag,tmps,Argv)); +#else + if (execf == EXECF_TRUEEXEC) + rc = execvp(tmps,Argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv); + else /* EXECF_SPAWN */ + rc = result(trueflag, + spawnvp(trueflag | P_NOWAIT,tmps,Argv)); +#endif + if (rc < 0 && secondtry == 0 + && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */ + err = errno; + if (err == ENOENT) { /* No such file. */ + /* One reason may be that EMX added .exe. We suppose + that .exe-less files are automatically shellable. + It might have also been .cmd file without + extension. */ + char *no_dir; + (no_dir = strrchr(Argv[0], '/')) + || (no_dir = strrchr(Argv[0], '\\')) + || (no_dir = Argv[0]); + if (!strchr(no_dir, '.')) { + struct stat buffer; + if (stat(Argv[0], &buffer) != -1) { /* File exists. */ + /* Maybe we need to specify the full name here? */ + goto doshell; + } else { + /* Try adding script extensions to the file name */ + char *scr; + if ((scr = find_script(Argv[0], TRUE, NULL, 0))) { + FILE *file = fopen(scr, "r"); + char *s = 0, *s1; + + Argv[0] = scr; + if (!file) + goto panic_file; + if (!fgets(buf, sizeof buf, file)) { + fclose(file); + goto panic_file; + } + if (fclose(file) != 0) { /* Failure */ + panic_file: + warn("Error reading \"%s\": %s", + scr, Strerror(errno)); + goto doshell; + } + if (buf[0] == '#') { + if (buf[1] == '!') + s = buf + 2; + } else if (buf[0] == 'e') { + if (strnEQ(buf, "extproc", 7) + && isSPACE(buf[7])) + s = buf + 8; + } else if (buf[0] == 'E') { + if (strnEQ(buf, "EXTPROC", 7) + && isSPACE(buf[7])) + s = buf + 8; + } + if (!s) + goto doshell; + s1 = s; + nargs = 0; + argsp = args; + while (1) { + while (isSPACE(*s)) + s++; + if (*s == 0) + break; + if (nargs == 4) { + nargs = -1; + break; + } + args[nargs++] = s; + while (*s && !isSPACE(*s)) + s++; + if (*s == 0) + break; + *s++ = 0; + } + if (nargs == -1) { + warn("Too many args on %.*s line of \"%s\"", + s1 - buf, buf, scr); + nargs = 4; + argsp = fargs; + } + goto doshell; + } + } + } + /* Restore errno */ + errno = err; + } else if (err == ENOEXEC) { /* Need to send to shell. */ + doshell: + { + char **a = Argv; + + while (a[1]) /* Get to the end */ + a++; + while (a >= Argv) { + *(a + nargs) = *a; /* Argv was preallocated to be + long enough. */ + a--; + } + while (nargs-- >= 0) + Argv[nargs] = argsp[nargs]; + secondtry = 1; + goto retry; + } + } + } + if (rc < 0 && dowarn) + warn("Can't %s \"%s\": %s\n", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + Argv[0], Strerror(err)); + if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) + && ((trueflag & 0xFF) == P_WAIT)) + rc = 255 << 8; /* Emulate the fork(). */ + + return rc; +} + int do_aspawn(really,mark,sp) SV *really; register SV **mark; register SV **sp; { + dTHR; register char **a; - char *tmps; + char *tmps = NULL; int rc; - int flag = P_WAIT, trueflag; + int flag = P_WAIT, trueflag, err, secondtry = 0; if (sp > mark) { - New(401,Argv, sp - mark + 1, char*); + New(1301,Argv, sp - mark + 3, char*); a = Argv; if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { @@ -195,36 +545,14 @@ register SV **sp; } *a = Nullch; - trueflag = flag; - if (flag == P_WAIT) - flag = P_NOWAIT; - - if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH; - - if (Argv[0][0] != '/' && Argv[0][0] != '\\' - && !(Argv[0][0] && Argv[0][1] == ':' - && (Argv[0][2] == '/' || Argv[0][2] != '\\')) - ) /* will swawnvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ - /* We should check PERL_SH* and PERLLIB_* as well? */ - if (really && *(tmps = SvPV(really, na))) - rc = result(trueflag, spawnvp(flag,tmps,Argv)); - else - rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); - - if (rc < 0 && dowarn) - warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + rc = do_spawn_ve(really, flag, EXECF_SPAWN); } else rc = -1; do_execfree(); return rc; } -#define EXECF_SPAWN 0 -#define EXECF_EXEC 1 -#define EXECF_TRUEEXEC 2 - +/* Try converting 1-arg form to (usually shell-less) multi-arg form. */ int do_spawn2(cmd, execf) char *cmd; @@ -234,7 +562,8 @@ int execf; register char *s; char flags[10]; char *shell, *copt, *news = NULL; - int rc; + int rc, added_shell = 0, err, seenspace = 0; + char fullcmd[MAXNAMLEN + 1]; #ifdef TRYSHELL if ((shell = getenv("EMXSHELL")) != NULL) @@ -250,7 +579,7 @@ int execf; have a shell which will not change between computers with the same architecture, to avoid "action on a distance". And to have simple build, this shell should be sh. */ - shell = SH_PATH; + shell = sh_path; copt = "-c"; #endif @@ -258,12 +587,13 @@ int execf; cmd++; if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { - STRLEN l = strlen(SH_PATH); + STRLEN l = strlen(sh_path); - New(4545, news, strlen(cmd) - 7 + l, char); - strcpy(news, SH_PATH); + New(1302, news, strlen(cmd) - 7 + l + 1, char); + strcpy(news, sh_path); strcpy(news + l, cmd + 7); cmd = news; + added_shell = 1; } /* save an extra exec if possible */ @@ -284,12 +614,18 @@ int execf; if (*s == '\n' && s[1] == '\0') { *s = '\0'; break; + } else if (*s == '\\' && !seenspace) { + continue; /* Allow backslashes in names */ } + /* We do not convert this to do_spawn_ve since shell + should be smart enough to start itself gloriously. */ doshell: if (execf == EXECF_TRUEEXEC) return execl(shell,shell,copt,cmd,(char*)0); else if (execf == EXECF_EXEC) return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); + else if (execf == EXECF_SPAWN_NOWAIT) + return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); /* In the ak code internal P_NOWAIT is P_WAIT ??? */ rc = result(P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); @@ -300,10 +636,13 @@ int execf; if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ if (news) Safefree(news); return rc; + } else if (*s == ' ' || *s == '\t') { + seenspace = 1; } } - New(402,Argv, (s - cmd) / 2 + 2, char*); + /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ + New(1303,Argv, (s - cmd + 11) / 2, char*); Cmd = savepvn(cmd, s-cmd); a = Argv; for (s = Cmd; *s;) { @@ -315,19 +654,9 @@ int execf; *s++ = '\0'; } *a = Nullch; - if (Argv[0]) { - if (execf == EXECF_TRUEEXEC) - rc = execvp(Argv[0],Argv); - else if (execf == EXECF_EXEC) - rc = spawnvp(P_OVERLAY,Argv[0],Argv); - else - rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); - if (rc < 0 && dowarn) - warn("Can't %s \"%s\": %s", - (execf == EXECF_SPAWN ? "spawn" : "exec"), - Argv[0], Strerror(errno)); - if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ - } else + if (Argv[0]) + rc = do_spawn_ve(NULL, 0, execf); + else rc = -1; if (news) Safefree(news); do_execfree(); @@ -341,6 +670,13 @@ char *cmd; return do_spawn2(cmd, EXECF_SPAWN); } +int +do_spawn_nowait(cmd) +char *cmd; +{ + return do_spawn2(cmd, EXECF_SPAWN_NOWAIT); +} + bool do_exec(cmd) char *cmd; @@ -360,22 +696,75 @@ my_syspopen(cmd,mode) char *cmd; char *mode; { +#ifndef USE_POPEN + + int p[2]; + register I32 this, that, newfd; + register I32 pid, rc; PerlIO *res; SV *sv; + + /* `this' is what we use in the parent, `that' in the child. */ + this = (*mode == 'w'); + that = !this; + if (tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); + } + if (pipe(p) < 0) + return Nullfp; + /* Now we need to spawn the child. */ + newfd = dup(*mode == 'r'); /* Preserve std* */ + if (p[that] != (*mode == 'r')) { + 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')) { + dup2(newfd, *mode == 'r'); /* Return std* back. */ + close(newfd); + } + if (p[that] == (*mode == 'r')) + close(p[that]); + if (pid == -1) { + close(p[this]); + return NULL; + } + if (p[that] < p[this]) { + dup2(p[this], p[that]); + close(p[this]); + p[this] = p[that]; + } + sv = *av_fetch(fdpid,p[this],TRUE); + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = pid; + forkprocess = pid; + return PerlIO_fdopen(p[this], mode); -#ifdef TRYSHELL +#else /* USE_POPEN */ + + PerlIO *res; + SV *sv; + +# ifdef TRYSHELL res = popen(cmd, mode); -#else +# else char *shell = getenv("EMXSHELL"); - my_setenv("EMXSHELL", SH_PATH); + my_setenv("EMXSHELL", sh_path); res = popen(cmd, mode); my_setenv("EMXSHELL", shell); -#endif +# endif sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = -1; /* A cooky. */ return res; + +#endif /* USE_POPEN */ + } /******************************************************************/ @@ -409,6 +798,8 @@ 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 (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -421,6 +812,8 @@ 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 (!htcp) DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) @@ -573,6 +966,9 @@ mod2fname(sv) } avlen --; } +#ifdef USE_THREADS + sum++; /* Avoid conflict of DLLs in memory. */ +#endif fname[pos] = 'A' + (sum % 26); fname[pos + 1] = 'A' + (sum / 26 % 26); fname[pos + 2] = '\0'; @@ -601,6 +997,7 @@ os2error(int rc) static char buf[300]; ULONG len; + if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ if (rc == 0) return NULL; if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) @@ -610,8 +1007,6 @@ os2error(int rc) return buf; } -char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI; - char * perllib_mangle(char *s, unsigned int l) { @@ -622,6 +1017,8 @@ perllib_mangle(char *s, unsigned int l) if (!newp && !notfound) { newp = getenv("PERLLIB_PREFIX"); if (newp) { + char *s; + oldp = newp; while (*newp && !isSPACE(*newp) && *newp != ';') { newp++; oldl++; /* Skip digits. */ @@ -633,6 +1030,12 @@ perllib_mangle(char *s, unsigned int l) if (newl == 0 || oldl == 0) { die("Malformed PERLLIB_PREFIX"); } + strcpy(ret, newp); + s = ret; + while (*s) { + if (*s == '\\') *s = '/'; + s++; + } } else { notfound = 1; } @@ -649,7 +1052,6 @@ perllib_mangle(char *s, unsigned int l) if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { die("Malformed PERLLIB_PREFIX"); } - strncpy(ret, newp, newl); strcpy(ret + newl, s + oldl); return ret; } @@ -692,7 +1094,7 @@ XS(XS_Cwd_sys_chdir) bool RETVAL; RETVAL = sys_chdir(path); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -708,7 +1110,7 @@ XS(XS_Cwd_change_drive) bool RETVAL; RETVAL = change_drive(d); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -724,7 +1126,7 @@ XS(XS_Cwd_sys_is_absolute) bool RETVAL; RETVAL = sys_is_absolute(path); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -740,7 +1142,7 @@ XS(XS_Cwd_sys_is_rooted) bool RETVAL; RETVAL = sys_is_rooted(path); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -756,7 +1158,7 @@ XS(XS_Cwd_sys_is_relative) bool RETVAL; RETVAL = sys_is_relative(path); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -883,15 +1285,23 @@ XS(XS_Cwd_sys_abspath) } XSRETURN(1); } +typedef APIRET (*PELP)(PSZ path, ULONG type); + +APIRET +ExtLIBPATH(ULONG ord, PSZ path, ULONG type) +{ + loadByOrd(ord); /* Guarantied to load or die! */ + return (*(PELP)ExtFCN[ord])(path, type); +} -#define extLibpath(type) \ - (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \ - : BEGIN_LIBPATH))) \ +#define extLibpath(type) \ + (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH))) \ ? NULL : to ) #define extLibpath_set(p,type) \ - (!CheckOSError(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \ - : BEGIN_LIBPATH)))) + (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH)))) XS(XS_Cwd_extLibpath) { @@ -935,7 +1345,7 @@ XS(XS_Cwd_extLibpath_set) } RETVAL = extLibpath_set(s, type); - ST(0) = RETVAL ? &sv_yes : &sv_no; + ST(0) = boolSV(RETVAL); if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); @@ -947,8 +1357,12 @@ Xs_OS2_init() char *file = __FILE__; { GV *gv; - - newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + + if (_emx_env & 0x200) { /* OS/2 */ + newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); + newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); + newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, 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); @@ -958,8 +1372,6 @@ Xs_OS2_init() newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); - newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); - newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); #ifdef PERL_IS_AOUT @@ -971,24 +1383,175 @@ Xs_OS2_init() OS2_Perl_data_t OS2_Perl_data; void -Perl_OS2_init() +Perl_OS2_init(char **env) { char *shell; + MALLOC_INIT; settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; + if (environ == NULL) { + environ = env; + } if ( (shell = getenv("PERL_SH_DRIVE")) ) { + New(1304, sh_path, strlen(SH_PATH) + 1, char); + strcpy(sh_path, SH_PATH); sh_path[0] = shell[0]; } else if ( (shell = getenv("PERL_SH_DIR")) ) { - int l = strlen(shell); + int l = strlen(shell), i; if (shell[l-1] == '/' || shell[l-1] == '\\') { l--; } - if (l > STATIC_FILE_LENGTH - 7) { - die("PERL_SH_DIR too long"); - } + New(1304, sh_path, l + 8, char); strncpy(sh_path, shell, l); strcpy(sh_path + l, "/sh.exe"); + for (i = 0; i < l; i++) { + if (sh_path[i] == '\\') sh_path[i] = '/'; + } } + MUTEX_INIT(&start_thread_mutex); } +#undef tmpnam +#undef tmpfile + +char * +my_tmpnam (char *str) +{ + char *p = getenv("TMP"), *tpath; + int len; + + if (!p) p = getenv("TEMP"); + tpath = tempnam(p, "pltmp"); + if (str && tpath) { + strcpy(str, tpath); + return str; + } + return tpath; +} + +FILE * +my_tmpfile () +{ + struct stat s; + + stat(".", &s); + if (s.st_mode & S_IWOTH) { + return tmpfile(); + } + return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but + grants TMP. */ +} + +#undef flock + +/* This code was contributed by Rocco Caputo. */ +int +my_flock(int handle, int o) +{ + FILELOCK rNull, rFull; + ULONG timeout, handle_type, flag_word; + APIRET rc; + int blocking, shared; + static int use_my = -1; + + if (use_my == -1) { + char *s = getenv("USE_PERL_FLOCK"); + if (s) + use_my = atoi(s); + else + use_my = 1; + } + if (!(_emx_env & 0x200) || !use_my) + return flock(handle, o); /* Delegate to EMX. */ + + // is this a file? + if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || + (handle_type & 0xFF)) + { + errno = EBADF; + return -1; + } + // set lock/unlock ranges + rNull.lOffset = rNull.lRange = rFull.lOffset = 0; + rFull.lRange = 0x7FFFFFFF; + // set timeout for blocking + timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; + // shared or exclusive? + shared = (o & LOCK_SH) ? 1 : 0; + // do not block the unlock + if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { + rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + break; // not an error + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + } + // lock may block + if (o & (LOCK_SH | LOCK_EX)) { + // for blocking operations + for (;;) { + rc = + DosSetFileLocks( + handle, + &rNull, + &rFull, + timeout, + shared + ); + switch (rc) { + case 0: + errno = 0; + return 0; + case ERROR_INVALID_HANDLE: + errno = EBADF; + return -1; + case ERROR_SHARING_BUFFER_EXCEEDED: + errno = ENOLCK; + return -1; + case ERROR_LOCK_VIOLATION: + if (!blocking) { + errno = EWOULDBLOCK; + return -1; + } + break; + case ERROR_INVALID_PARAMETER: + case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: + case ERROR_READ_LOCKS_NOT_SUPPORTED: + errno = EINVAL; + return -1; + case ERROR_INTERRUPT: + errno = EINTR; + return -1; + default: + errno = EINVAL; + return -1; + } + // give away timeslice + DosSleep(1); + } + } + + errno = 0; + return 0; +}