X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2Fos2.c;h=f8f4a82735d8498a8d5b64404416409b8bfdc6ac;hb=24a13b90d71fdf865506aa54584da797a181adbb;hp=d5d761e9b7bc41abcf9b1974af1ea13895e636b6;hpb=89078e0fc0659c720f21de63d8d61f6f995a7d0b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/os2.c b/os2/os2.c index d5d761e..f8f4a82 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -13,11 +13,37 @@ #include #include #include +#include #include "EXTERN.h" #include "perl.h" /*****************************************************************************/ +/* 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. */ @@ -34,7 +60,7 @@ get_sysinfo(ULONG pid, ULONG flags) 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 +99,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 +141,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 +156,7 @@ getpriority(int which /* ignored */, int pid) /*****************************************************************************/ /* spawn */ +typedef void (*Sigfunc) _((int)); static int result(int flag, int pid) @@ -144,22 +173,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; @@ -174,12 +203,12 @@ register SV **mark; register SV **sp; { 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(401,Argv, sp - mark + 3, char*); a = Argv; if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { @@ -199,17 +228,49 @@ register SV **sp; if (flag == P_WAIT) flag = P_NOWAIT; - if (*Argv[0] != '/' && *Argv[0] != '\\' - && !(*Argv[0] && *Argv[1] == ':' - && (*Argv[2] == '/' || *Argv[2] != '\\')) + 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? */ + retry: 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 && secondtry == 0 + && (!tmps || !*tmps)) { /* 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. */ + 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 if (err == ENOEXEC) { /* Need to send to shell. */ + doshell: + while (a >= Argv) { + *(a + 2) = *a; + a--; + } + *Argv = sh_path; + *(Argv + 1) = "-c"; + secondtry = 1; + goto retry; + } + } if (rc < 0 && dowarn) warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ @@ -222,6 +283,7 @@ register SV **sp; #define EXECF_SPAWN 0 #define EXECF_EXEC 1 #define EXECF_TRUEEXEC 2 +#define EXECF_SPAWN_NOWAIT 3 int do_spawn2(cmd, execf) @@ -231,8 +293,9 @@ int execf; register char **a; register char *s; char flags[10]; - char *shell, *copt; - int rc; + char *shell, *copt, *news = NULL; + int rc, added_shell = 0, err; + char fullcmd[MAXNAMLEN + 1]; #ifdef TRYSHELL if ((shell = getenv("EMXSHELL")) != NULL) @@ -248,13 +311,23 @@ 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 while (*cmd && isSPACE(*cmd)) cmd++; + if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { + STRLEN l = strlen(sh_path); + + New(4545, news, strlen(cmd) - 7 + l, char); + strcpy(news, sh_path); + strcpy(news + l, cmd + 7); + cmd = news; + added_shell = 1; + } + /* save an extra exec if possible */ /* see if there are shell metacharacters in it */ @@ -270,7 +343,7 @@ int execf; for (s = cmd; *s; s++) { if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && !s[1]) { + if (*s == '\n' && s[1] == '\0') { *s = '\0'; break; } @@ -279,6 +352,8 @@ int execf; 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)); @@ -287,6 +362,7 @@ int execf; (execf == EXECF_SPAWN ? "spawn" : "exec"), shell, Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ + if (news) Safefree(news); return rc; } } @@ -304,19 +380,45 @@ int execf; } *a = Nullch; if (Argv[0]) { + int err; + if (execf == EXECF_TRUEEXEC) rc = execvp(Argv[0],Argv); else if (execf == EXECF_EXEC) rc = spawnvp(P_OVERLAY,Argv[0],Argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(P_NOWAIT,Argv[0],Argv); else rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); + if (rc < 0) { + 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. */ + 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 if (err == ENOEXEC) { /* Need to send to shell. */ + goto doshell; + } + } if (rc < 0 && dowarn) warn("Can't %s \"%s\": %s", - (execf == EXECF_SPAWN ? "spawn" : "exec"), - Argv[0], Strerror(errno)); + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + Argv[0], Strerror(err)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ } else rc = -1; + if (news) Safefree(news); do_execfree(); return rc; } @@ -328,6 +430,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; @@ -342,27 +451,82 @@ char *cmd; return do_spawn2(cmd, EXECF_TRUEEXEC); } -#ifndef HAS_FORK -FILE * -my_popen(cmd,mode) +PerlIO * +my_syspopen(cmd,mode) char *cmd; char *mode; { -#ifdef TRYSHELL - return popen(cmd, mode); -#else - char *shell = getenv("EMXSHELL"); - FILE *res; +#ifndef USE_POPEN + + int p[2]; + register I32 this, that, newfd; + register I32 pid, rc; + PerlIO *res; + SV *sv; - my_setenv("EMXSHELL", SH_PATH); + if (pipe(p) < 0) + return Nullfp; + /* `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"); + } + /* 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); + } + 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); + +#else /* USE_POPEN */ + + PerlIO *res; + SV *sv; + +# ifdef TRYSHELL + res = popen(cmd, mode); +# else + char *shell = getenv("EMXSHELL"); + + my_setenv("EMXSHELL", sh_path); res = popen(cmd, mode); my_setenv("EMXSHELL", shell); +# endif + sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE); + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = -1; /* A cooky. */ return res; -#endif + +#endif /* USE_POPEN */ + } -#endif -/*****************************************************************************/ +/******************************************************************/ #ifndef HAS_FORK int @@ -374,7 +538,7 @@ fork(void) } #endif -/*****************************************************************************/ +/*******************************************************************/ /* not implemented in EMX 0.9a */ void * ctermid(x) { return 0; } @@ -383,7 +547,7 @@ void * ctermid(x) { return 0; } void * ttyname(x) { return 0; } #endif -/*****************************************************************************/ +/******************************************************************/ /* my socket forwarders - EMX lib only provides static forwarders */ static HMODULE htcp = 0; @@ -393,6 +557,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) @@ -405,6 +571,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) @@ -585,6 +753,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)) @@ -594,49 +763,6 @@ os2error(int rc) return buf; } -OS2_Perl_data_t OS2_Perl_data; - -int -Xs_OS2_init() -{ - char *file = __FILE__; - { - GV *gv; - - newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); - newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); - gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); - GvMULTI_on(gv); -#ifdef PERL_IS_AOUT - sv_setiv(GvSV(gv), 1); -#endif - } -} - -void -Perl_OS2_init() -{ - char *shell; - - settmppath(); - OS2_Perl_data.xs_init = &Xs_OS2_init; - if ( (shell = getenv("PERL_SH_DRIVE")) ) { - sh_path[0] = shell[0]; - } else if ( (shell = getenv("PERL_SH_DIR")) ) { - int l = strlen(shell); - if (shell[l-1] == '/' || shell[l-1] == '\\') { - l--; - } - if (l > STATIC_FILE_LENGTH - 7) { - die("PERL_SH_DIR too long"); - } - strncpy(sh_path, shell, l); - strcpy(sh_path + l, "/sh.exe"); - } -} - -char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI; - char * perllib_mangle(char *s, unsigned int l) { @@ -647,6 +773,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. */ @@ -658,6 +786,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; } @@ -668,16 +802,397 @@ perllib_mangle(char *s, unsigned int l) if (l == 0) { l = strlen(s); } - if (l <= oldl || strnicmp(oldp, s, oldl) != 0) { + if (l < oldl || strnicmp(oldp, s, oldl) != 0) { return s; } 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; } extern void dlopen(); void *fakedl = &dlopen; /* Pull in dynaloading part. */ + +#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ + && ((path)[2] == '/' || (path)[2] == '\\')) +#define sys_is_rooted _fnisabs +#define sys_is_relative _fnisrel +#define current_drive _getdrive + +#undef chdir /* Was _chdir2. */ +#define sys_chdir(p) (chdir(p) == 0) +#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) + +XS(XS_Cwd_current_drive) +{ + dXSARGS; + if (items != 0) + croak("Usage: Cwd::current_drive()"); + { + char RETVAL; + + RETVAL = current_drive(); + ST(0) = sv_newmortal(); + sv_setpvn(ST(0), (char *)&RETVAL, 1); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_chdir) +{ + dXSARGS; + if (items != 1) + croak("Usage: Cwd::sys_chdir(path)"); + { + char * path = (char *)SvPV(ST(0),na); + bool RETVAL; + + RETVAL = sys_chdir(path); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +XS(XS_Cwd_change_drive) +{ + dXSARGS; + if (items != 1) + croak("Usage: Cwd::change_drive(d)"); + { + char d = (char)*SvPV(ST(0),na); + bool RETVAL; + + RETVAL = change_drive(d); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_is_absolute) +{ + dXSARGS; + if (items != 1) + croak("Usage: Cwd::sys_is_absolute(path)"); + { + char * path = (char *)SvPV(ST(0),na); + bool RETVAL; + + RETVAL = sys_is_absolute(path); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_is_rooted) +{ + dXSARGS; + if (items != 1) + croak("Usage: Cwd::sys_is_rooted(path)"); + { + char * path = (char *)SvPV(ST(0),na); + bool RETVAL; + + RETVAL = sys_is_rooted(path); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_is_relative) +{ + dXSARGS; + if (items != 1) + croak("Usage: Cwd::sys_is_relative(path)"); + { + char * path = (char *)SvPV(ST(0),na); + bool RETVAL; + + RETVAL = sys_is_relative(path); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_cwd) +{ + dXSARGS; + if (items != 0) + croak("Usage: Cwd::sys_cwd()"); + { + char p[MAXPATHLEN]; + char * RETVAL; + RETVAL = _getcwd2(p, MAXPATHLEN); + ST(0) = sv_newmortal(); + sv_setpv((SV*)ST(0), RETVAL); + } + XSRETURN(1); +} + +XS(XS_Cwd_sys_abspath) +{ + dXSARGS; + if (items < 1 || items > 2) + croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); + { + char * path = (char *)SvPV(ST(0),na); + char * dir; + char p[MAXPATHLEN]; + char * RETVAL; + + if (items < 2) + dir = NULL; + else { + dir = (char *)SvPV(ST(1),na); + } + if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { + path += 2; + } + if (dir == NULL) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Absolute with drive: */ + if ( sys_is_absolute(path) ) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (path[0] == '/' || path[0] == '\\') { + /* Rooted, but maybe on different drive. */ + if (isALPHA(dir[0]) && dir[1] == ':' ) { + char p1[MAXPATHLEN]; + + /* Need to prepend the drive. */ + p1[0] = dir[0]; + p1[1] = dir[1]; + Copy(path, p1 + 2, strlen(path) + 1, char); + RETVAL = p; + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Either path is relative, or starts with a drive letter. */ + /* If the path starts with a drive letter, then dir is + relevant only if + a/b) it is absolute/x:relative on the same drive. + c) path is on current drive, and dir is rooted + In all the cases it is safe to drop the drive part + of the path. */ + if ( !sys_is_relative(path) ) { + int is_drived; + + if ( ( ( sys_is_absolute(dir) + || (isALPHA(dir[0]) && dir[1] == ':' + && strnicmp(dir, path,1) == 0)) + && strnicmp(dir, path,1) == 0) + || ( !(isALPHA(dir[0]) && dir[1] == ':') + && toupper(path[0]) == current_drive())) { + path += 2; + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; goto done; + } else { + RETVAL = NULL; goto done; + } + } + { + /* Need to prepend the absolute path of dir. */ + char p1[MAXPATHLEN]; + + if (_abspath(p1, dir, MAXPATHLEN) == 0) { + int l = strlen(p1); + + if (p1[ l - 1 ] != '/') { + p1[ l ] = '/'; + l++; + } + Copy(path, p1 + l, strlen(path) + 1, char); + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + RETVAL = NULL; + } + } + done: + } + } + ST(0) = sv_newmortal(); + sv_setpv((SV*)ST(0), RETVAL); + } + 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(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH))) \ + ? NULL : to ) + +#define extLibpath_set(p,type) \ + (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ + : BEGIN_LIBPATH)))) + +XS(XS_Cwd_extLibpath) +{ + dXSARGS; + if (items < 0 || items > 1) + croak("Usage: Cwd::extLibpath(type = 0)"); + { + bool type; + char to[1024]; + U32 rc; + char * RETVAL; + + if (items < 1) + type = 0; + else { + type = (int)SvIV(ST(0)); + } + + RETVAL = extLibpath(type); + ST(0) = sv_newmortal(); + sv_setpv((SV*)ST(0), RETVAL); + } + XSRETURN(1); +} + +XS(XS_Cwd_extLibpath_set) +{ + dXSARGS; + if (items < 1 || items > 2) + croak("Usage: Cwd::extLibpath_set(s, type = 0)"); + { + char * s = (char *)SvPV(ST(0),na); + bool type; + U32 rc; + bool RETVAL; + + if (items < 2) + type = 0; + else { + type = (int)SvIV(ST(1)); + } + + RETVAL = extLibpath_set(s, type); + ST(0) = RETVAL ? &sv_yes : &sv_no; + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + } + XSRETURN(1); +} + +int +Xs_OS2_init() +{ + char *file = __FILE__; + { + GV *gv; + + 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); + newXS("Cwd::change_drive", XS_Cwd_change_drive, file); + newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); + newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); + 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); + gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); + GvMULTI_on(gv); +#ifdef PERL_IS_AOUT + sv_setiv(GvSV(gv), 1); +#endif + } +} + +OS2_Perl_data_t OS2_Perl_data; + +void +Perl_OS2_init(char **env) +{ + char *shell; + + settmppath(); + OS2_Perl_data.xs_init = &Xs_OS2_init; + if (environ == NULL) { + environ = env; + } + if ( (shell = getenv("PERL_SH_DRIVE")) ) { + New(404, 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), i; + if (shell[l-1] == '/' || shell[l-1] == '\\') { + l--; + } + New(404, 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] = '/'; + } + } +} + +#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. */ +}