3 #define INCL_DOSFILEMGR
9 * Various Unix compatibility functions for OS/2
21 /*****************************************************************************/
22 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
23 static PFN ExtFCN[2]; /* Labeled by ord below. */
24 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
25 #define ORD_QUERY_ELP 0
31 if (ExtFCN[ord] == NULL) {
32 static HMODULE hdosc = 0;
37 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
39 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
40 die("This version of OS/2 does not support doscalls.%i",
44 if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
48 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
50 #define QSS_INI_BUFFER 1024
53 get_sysinfo(ULONG pid, ULONG flags)
56 ULONG rc, buf_len = QSS_INI_BUFFER;
58 New(1322, pbuffer, buf_len, char);
59 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
60 rc = QuerySysState(flags, pid, pbuffer, buf_len);
61 while (rc == ERROR_BUFFER_OVERFLOW) {
62 Renew(pbuffer, buf_len *= 2, char);
63 rc = QuerySysState(flags, pid, pbuffer, buf_len);
70 return (PQTOPLEVEL)pbuffer;
73 #define PRIO_ERR 0x1111
81 psi = get_sysinfo(pid, QSS_PROCESS);
85 if (pid != psi->procdata->pid) {
87 croak("panic: wrong pid in sysinfo");
89 prio = psi->procdata->threads->priority;
95 setpriority(int which, int pid, int val)
100 prio = sys_prio(pid);
102 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
103 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
104 /* Do not change class. */
105 return CheckOSError(DosSetPriority((pid < 0)
106 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
108 (32 - val) % 32 - (prio & 0xFF),
111 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
112 /* Documentation claims one can change both class and basevalue,
113 * but I find it wrong. */
114 /* Change class, but since delta == 0 denotes absolute 0, correct. */
115 if (CheckOSError(DosSetPriority((pid < 0)
116 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
117 priors[(32 - val) >> 5] + 1,
121 if ( ((32 - val) % 32) == 0 ) return 0;
122 return CheckOSError(DosSetPriority((pid < 0)
123 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
129 /* else return CheckOSError(DosSetPriority((pid < 0) */
130 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
131 /* priors[(32 - val) >> 5] + 1, */
132 /* (32 - val) % 32 - (prio & 0xFF), */
138 getpriority(int which /* ignored */, int pid)
144 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
145 /* DosGetInfoBlocks has old priority! */
146 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
147 /* if (pid != pib->pib_ulpid) { */
149 if (ret == PRIO_ERR) {
153 /* ret = tib->tib_ptib2->tib2_ulpri; */
154 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
157 /*****************************************************************************/
159 typedef void (*Sigfunc) _((int));
162 result(int flag, int pid)
165 Signal_t (*ihand)(); /* place to save signal during system() */
166 Signal_t (*qhand)(); /* place to save signal during system() */
172 if (pid < 0 || flag != 0)
176 ihand = rsignal(SIGINT, SIG_IGN);
177 qhand = rsignal(SIGQUIT, SIG_IGN);
179 r = wait4pid(pid, &status, 0);
180 } while (r == -1 && errno == EINTR);
181 rsignal(SIGINT, ihand);
182 rsignal(SIGQUIT, qhand);
184 statusvalue = (U16)status;
187 return status & 0xFFFF;
189 ihand = rsignal(SIGINT, SIG_IGN);
190 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
191 rsignal(SIGINT, ihand);
192 statusvalue = res.codeResult << 8 | res.codeTerminate;
200 do_aspawn(really,mark,sp)
208 int flag = P_WAIT, trueflag, err, secondtry = 0;
211 New(1301,Argv, sp - mark + 3, char*);
214 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
219 while (++mark <= sp) {
221 *a++ = SvPVx(*mark, na);
231 if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
233 if (Argv[0][0] != '/' && Argv[0][0] != '\\'
234 && !(Argv[0][0] && Argv[0][1] == ':'
235 && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
236 ) /* will swawnvp use PATH? */
237 TAINT_ENV(); /* testing IFS here is overkill, probably */
238 /* We should check PERL_SH* and PERLLIB_* as well? */
240 if (really && *(tmps = SvPV(really, na)))
241 rc = result(trueflag, spawnvp(flag,tmps,Argv));
243 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
245 if (rc < 0 && secondtry == 0
246 && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */
248 if (err == ENOENT) { /* No such file. */
249 /* One reason may be that EMX added .exe. We suppose
250 that .exe-less files are automatically shellable. */
252 (no_dir = strrchr(Argv[0], '/'))
253 || (no_dir = strrchr(Argv[0], '\\'))
254 || (no_dir = Argv[0]);
255 if (!strchr(no_dir, '.')) {
257 if (stat(Argv[0], &buffer) != -1) { /* File exists. */
258 /* Maybe we need to specify the full name here? */
262 } else if (err == ENOEXEC) { /* Need to send to shell. */
274 if (rc < 0 && dowarn)
275 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
276 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
283 #define EXECF_SPAWN 0
285 #define EXECF_TRUEEXEC 2
286 #define EXECF_SPAWN_NOWAIT 3
289 do_spawn2(cmd, execf)
296 char *shell, *copt, *news = NULL;
297 int rc, added_shell = 0, err, seenspace = 0;
298 char fullcmd[MAXNAMLEN + 1];
301 if ((shell = getenv("EMXSHELL")) != NULL)
303 else if ((shell = getenv("SHELL")) != NULL)
305 else if ((shell = getenv("COMSPEC")) != NULL)
310 /* Consensus on perl5-porters is that it is _very_ important to
311 have a shell which will not change between computers with the
312 same architecture, to avoid "action on a distance".
313 And to have simple build, this shell should be sh. */
318 while (*cmd && isSPACE(*cmd))
321 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
322 STRLEN l = strlen(sh_path);
324 New(1302, news, strlen(cmd) - 7 + l + 1, char);
325 strcpy(news, sh_path);
326 strcpy(news + l, cmd + 7);
331 /* save an extra exec if possible */
332 /* see if there are shell metacharacters in it */
334 if (*cmd == '.' && isSPACE(cmd[1]))
337 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
340 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
344 for (s = cmd; *s; s++) {
345 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
346 if (*s == '\n' && s[1] == '\0') {
349 } else if (*s == '\\' && !seenspace) {
350 continue; /* Allow backslashes in names */
353 if (execf == EXECF_TRUEEXEC)
354 return execl(shell,shell,copt,cmd,(char*)0);
355 else if (execf == EXECF_EXEC)
356 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
357 else if (execf == EXECF_SPAWN_NOWAIT)
358 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
359 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
361 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
362 if (rc < 0 && dowarn)
363 warn("Can't %s \"%s\": %s",
364 (execf == EXECF_SPAWN ? "spawn" : "exec"),
365 shell, Strerror(errno));
366 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
367 if (news) Safefree(news);
369 } else if (*s == ' ' || *s == '\t') {
374 New(1303,Argv, (s - cmd) / 2 + 2, char*);
375 Cmd = savepvn(cmd, s-cmd);
378 while (*s && isSPACE(*s)) s++;
381 while (*s && !isSPACE(*s)) s++;
389 if (execf == EXECF_TRUEEXEC)
390 rc = execvp(Argv[0],Argv);
391 else if (execf == EXECF_EXEC)
392 rc = spawnvp(P_OVERLAY,Argv[0],Argv);
393 else if (execf == EXECF_SPAWN_NOWAIT)
394 rc = spawnvp(P_NOWAIT,Argv[0],Argv);
396 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
399 if (err == ENOENT) { /* No such file. */
400 /* One reason may be that EMX added .exe. We suppose
401 that .exe-less files are automatically shellable. */
403 (no_dir = strrchr(Argv[0], '/'))
404 || (no_dir = strrchr(Argv[0], '\\'))
405 || (no_dir = Argv[0]);
406 if (!strchr(no_dir, '.')) {
408 if (stat(Argv[0], &buffer) != -1) { /* File exists. */
409 /* Maybe we need to specify the full name here? */
413 } else if (err == ENOEXEC) { /* Need to send to shell. */
417 if (rc < 0 && dowarn)
418 warn("Can't %s \"%s\": %s",
419 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
421 Argv[0], Strerror(err));
422 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
425 if (news) Safefree(news);
434 return do_spawn2(cmd, EXECF_SPAWN);
441 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
448 return do_spawn2(cmd, EXECF_EXEC);
455 return do_spawn2(cmd, EXECF_TRUEEXEC);
459 my_syspopen(cmd,mode)
466 register I32 this, that, newfd;
467 register I32 pid, rc;
473 /* `this' is what we use in the parent, `that' in the child. */
474 this = (*mode == 'w');
478 taint_proper("Insecure %s%s", "EXEC");
480 /* Now we need to spawn the child. */
481 newfd = dup(*mode == 'r'); /* Preserve std* */
482 if (p[that] != (*mode == 'r')) {
483 dup2(p[that], *mode == 'r');
486 /* Where is `this' and newfd now? */
487 fcntl(p[this], F_SETFD, FD_CLOEXEC);
488 fcntl(newfd, F_SETFD, FD_CLOEXEC);
489 pid = do_spawn_nowait(cmd);
490 if (newfd != (*mode == 'r')) {
491 dup2(newfd, *mode == 'r'); /* Return std* back. */
499 if (p[that] < p[this]) {
500 dup2(p[this], p[that]);
504 sv = *av_fetch(fdpid,p[this],TRUE);
505 (void)SvUPGRADE(sv,SVt_IV);
508 return PerlIO_fdopen(p[this], mode);
510 #else /* USE_POPEN */
516 res = popen(cmd, mode);
518 char *shell = getenv("EMXSHELL");
520 my_setenv("EMXSHELL", sh_path);
521 res = popen(cmd, mode);
522 my_setenv("EMXSHELL", shell);
524 sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
525 (void)SvUPGRADE(sv,SVt_IV);
526 SvIVX(sv) = -1; /* A cooky. */
529 #endif /* USE_POPEN */
533 /******************************************************************/
539 die(no_func, "Unsupported function fork");
545 /*******************************************************************/
546 /* not implemented in EMX 0.9a */
548 void * ctermid(x) { return 0; }
550 #ifdef MYTTYNAME /* was not in emx0.9a */
551 void * ttyname(x) { return 0; }
554 /******************************************************************/
555 /* my socket forwarders - EMX lib only provides static forwarders */
557 static HMODULE htcp = 0;
565 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
567 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
568 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
569 return (void *) ((void * (*)(void)) fcn) ();
574 tcp1(char *name, int arg)
579 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
581 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
582 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
583 ((void (*)(int)) fcn) (arg);
586 void * gethostent() { return tcp0("GETHOSTENT"); }
587 void * getnetent() { return tcp0("GETNETENT"); }
588 void * getprotoent() { return tcp0("GETPROTOENT"); }
589 void * getservent() { return tcp0("GETSERVENT"); }
590 void sethostent(x) { tcp1("SETHOSTENT", x); }
591 void setnetent(x) { tcp1("SETNETENT", x); }
592 void setprotoent(x) { tcp1("SETPROTOENT", x); }
593 void setservent(x) { tcp1("SETSERVENT", x); }
594 void endhostent() { tcp0("ENDHOSTENT"); }
595 void endnetent() { tcp0("ENDNETENT"); }
596 void endprotoent() { tcp0("ENDPROTOENT"); }
597 void endservent() { tcp0("ENDSERVENT"); }
599 /*****************************************************************************/
600 /* not implemented in C Set++ */
603 int setuid(x) { errno = EINVAL; return -1; }
604 int setgid(x) { errno = EINVAL; return -1; }
607 /*****************************************************************************/
608 /* stat() hack for char/block device */
612 /* First attempt used DosQueryFSAttach which crashed the system when
613 used with 5.001. Now just look for /dev/. */
616 os2_stat(char *name, struct stat *st)
618 static int ino = SHRT_MAX;
620 if (stricmp(name, "/dev/con") != 0
621 && stricmp(name, "/dev/tty") != 0)
622 return stat(name, st);
624 memset(st, 0, sizeof *st);
625 st->st_mode = S_IFCHR|0666;
626 st->st_ino = (ino-- & 0x7FFF);
635 /* SBRK() emulation, mostly moved to malloc.c. */
638 sys_alloc(int size) {
640 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
642 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
644 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
648 #endif /* USE_PERL_SBRK */
652 char *tmppath = TMPPATH1;
657 char *p = getenv("TMP"), *tpath;
660 if (!p) p = getenv("TEMP");
663 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
666 strcpy(tpath + len + 1, TMPPATH1);
672 XS(XS_File__Copy_syscopy)
675 if (items < 2 || items > 3)
676 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
678 char * src = (char *)SvPV(ST(0),na);
679 char * dst = (char *)SvPV(ST(1),na);
686 flag = (unsigned long)SvIV(ST(2));
689 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
690 ST(0) = sv_newmortal();
691 sv_setiv(ST(0), (IV)RETVAL);
700 static char fname[9];
701 int pos = 6, len, avlen;
702 unsigned int sum = 0;
707 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
709 if (SvTYPE(sv) != SVt_PVAV)
710 croak("Not array reference given to mod2fname");
712 avlen = av_len((AV*)sv);
714 croak("Empty array reference given to mod2fname");
716 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
717 strncpy(fname, s, 8);
719 if (len < 6) pos = len;
721 sum = 33 * sum + *(s++); /* Checksumming first chars to
722 * get the capitalization into c.s. */
726 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
728 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
732 fname[pos] = 'A' + (sum % 26);
733 fname[pos + 1] = 'A' + (sum / 26 % 26);
734 fname[pos + 2] = '\0';
735 return (char *)fname;
738 XS(XS_DynaLoader_mod2fname)
742 croak("Usage: DynaLoader::mod2fname(sv)");
747 RETVAL = mod2fname(sv);
748 ST(0) = sv_newmortal();
749 sv_setpv((SV*)ST(0), RETVAL);
757 static char buf[300];
760 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
763 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
764 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
771 perllib_mangle(char *s, unsigned int l)
773 static char *newp, *oldp;
774 static int newl, oldl, notfound;
775 static char ret[STATIC_FILE_LENGTH+1];
777 if (!newp && !notfound) {
778 newp = getenv("PERLLIB_PREFIX");
783 while (*newp && !isSPACE(*newp) && *newp != ';') {
784 newp++; oldl++; /* Skip digits. */
786 while (*newp && (isSPACE(*newp) || *newp == ';')) {
787 newp++; /* Skip whitespace. */
790 if (newl == 0 || oldl == 0) {
791 die("Malformed PERLLIB_PREFIX");
796 if (*s == '\\') *s = '/';
809 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
812 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
813 die("Malformed PERLLIB_PREFIX");
815 strcpy(ret + newl, s + oldl);
819 extern void dlopen();
820 void *fakedl = &dlopen; /* Pull in dynaloading part. */
822 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
823 && ((path)[2] == '/' || (path)[2] == '\\'))
824 #define sys_is_rooted _fnisabs
825 #define sys_is_relative _fnisrel
826 #define current_drive _getdrive
828 #undef chdir /* Was _chdir2. */
829 #define sys_chdir(p) (chdir(p) == 0)
830 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
832 XS(XS_Cwd_current_drive)
836 croak("Usage: Cwd::current_drive()");
840 RETVAL = current_drive();
841 ST(0) = sv_newmortal();
842 sv_setpvn(ST(0), (char *)&RETVAL, 1);
851 croak("Usage: Cwd::sys_chdir(path)");
853 char * path = (char *)SvPV(ST(0),na);
856 RETVAL = sys_chdir(path);
857 ST(0) = boolSV(RETVAL);
858 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
863 XS(XS_Cwd_change_drive)
867 croak("Usage: Cwd::change_drive(d)");
869 char d = (char)*SvPV(ST(0),na);
872 RETVAL = change_drive(d);
873 ST(0) = boolSV(RETVAL);
874 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
879 XS(XS_Cwd_sys_is_absolute)
883 croak("Usage: Cwd::sys_is_absolute(path)");
885 char * path = (char *)SvPV(ST(0),na);
888 RETVAL = sys_is_absolute(path);
889 ST(0) = boolSV(RETVAL);
890 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
895 XS(XS_Cwd_sys_is_rooted)
899 croak("Usage: Cwd::sys_is_rooted(path)");
901 char * path = (char *)SvPV(ST(0),na);
904 RETVAL = sys_is_rooted(path);
905 ST(0) = boolSV(RETVAL);
906 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
911 XS(XS_Cwd_sys_is_relative)
915 croak("Usage: Cwd::sys_is_relative(path)");
917 char * path = (char *)SvPV(ST(0),na);
920 RETVAL = sys_is_relative(path);
921 ST(0) = boolSV(RETVAL);
922 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
931 croak("Usage: Cwd::sys_cwd()");
935 RETVAL = _getcwd2(p, MAXPATHLEN);
936 ST(0) = sv_newmortal();
937 sv_setpv((SV*)ST(0), RETVAL);
942 XS(XS_Cwd_sys_abspath)
945 if (items < 1 || items > 2)
946 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
948 char * path = (char *)SvPV(ST(0),na);
956 dir = (char *)SvPV(ST(1),na);
958 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
962 if (_abspath(p, path, MAXPATHLEN) == 0) {
968 /* Absolute with drive: */
969 if ( sys_is_absolute(path) ) {
970 if (_abspath(p, path, MAXPATHLEN) == 0) {
975 } else if (path[0] == '/' || path[0] == '\\') {
976 /* Rooted, but maybe on different drive. */
977 if (isALPHA(dir[0]) && dir[1] == ':' ) {
980 /* Need to prepend the drive. */
983 Copy(path, p1 + 2, strlen(path) + 1, char);
985 if (_abspath(p, p1, MAXPATHLEN) == 0) {
990 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
996 /* Either path is relative, or starts with a drive letter. */
997 /* If the path starts with a drive letter, then dir is
999 a/b) it is absolute/x:relative on the same drive.
1000 c) path is on current drive, and dir is rooted
1001 In all the cases it is safe to drop the drive part
1003 if ( !sys_is_relative(path) ) {
1006 if ( ( ( sys_is_absolute(dir)
1007 || (isALPHA(dir[0]) && dir[1] == ':'
1008 && strnicmp(dir, path,1) == 0))
1009 && strnicmp(dir, path,1) == 0)
1010 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1011 && toupper(path[0]) == current_drive())) {
1013 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1014 RETVAL = p; goto done;
1016 RETVAL = NULL; goto done;
1020 /* Need to prepend the absolute path of dir. */
1021 char p1[MAXPATHLEN];
1023 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1026 if (p1[ l - 1 ] != '/') {
1030 Copy(path, p1 + l, strlen(path) + 1, char);
1031 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1043 ST(0) = sv_newmortal();
1044 sv_setpv((SV*)ST(0), RETVAL);
1048 typedef APIRET (*PELP)(PSZ path, ULONG type);
1051 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1053 loadByOrd(ord); /* Guarantied to load or die! */
1054 return (*(PELP)ExtFCN[ord])(path, type);
1057 #define extLibpath(type) \
1058 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1059 : BEGIN_LIBPATH))) \
1062 #define extLibpath_set(p,type) \
1063 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1066 XS(XS_Cwd_extLibpath)
1069 if (items < 0 || items > 1)
1070 croak("Usage: Cwd::extLibpath(type = 0)");
1080 type = (int)SvIV(ST(0));
1083 RETVAL = extLibpath(type);
1084 ST(0) = sv_newmortal();
1085 sv_setpv((SV*)ST(0), RETVAL);
1090 XS(XS_Cwd_extLibpath_set)
1093 if (items < 1 || items > 2)
1094 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1096 char * s = (char *)SvPV(ST(0),na);
1104 type = (int)SvIV(ST(1));
1107 RETVAL = extLibpath_set(s, type);
1108 ST(0) = boolSV(RETVAL);
1109 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1117 char *file = __FILE__;
1121 if (_emx_env & 0x200) { /* OS/2 */
1122 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1123 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1124 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1126 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1127 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1128 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1129 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1130 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1131 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1132 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1133 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1134 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1135 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1138 sv_setiv(GvSV(gv), 1);
1143 OS2_Perl_data_t OS2_Perl_data;
1146 Perl_OS2_init(char **env)
1151 OS2_Perl_data.xs_init = &Xs_OS2_init;
1152 if (environ == NULL) {
1155 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1156 New(1304, sh_path, strlen(SH_PATH) + 1, char);
1157 strcpy(sh_path, SH_PATH);
1158 sh_path[0] = shell[0];
1159 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1160 int l = strlen(shell), i;
1161 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1164 New(1304, sh_path, l + 8, char);
1165 strncpy(sh_path, shell, l);
1166 strcpy(sh_path + l, "/sh.exe");
1167 for (i = 0; i < l; i++) {
1168 if (sh_path[i] == '\\') sh_path[i] = '/';
1177 my_tmpnam (char *str)
1179 char *p = getenv("TMP"), *tpath;
1182 if (!p) p = getenv("TEMP");
1183 tpath = tempnam(p, "pltmp");
1197 if (s.st_mode & S_IWOTH) {
1200 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1206 /* This code was contributed by Rocco Caputo. */
1208 my_flock(int handle, int op)
1210 FILELOCK rNull, rFull;
1211 ULONG timeout, handle_type, flag_word;
1213 int blocking, shared;
1214 static int use_my = -1;
1217 char *s = getenv("USE_PERL_FLOCK");
1223 if (!(_emx_env & 0x200) || !use_my)
1224 return flock(handle, op); /* Delegate to EMX. */
1227 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1228 (handle_type & 0xFF))
1233 // set lock/unlock ranges
1234 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1235 rFull.lRange = 0x7FFFFFFF;
1236 // set timeout for blocking
1237 timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1;
1238 // shared or exclusive?
1239 shared = (op & LOCK_SH) ? 1 : 0;
1240 // do not block the unlock
1241 if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1242 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1247 case ERROR_INVALID_HANDLE:
1250 case ERROR_SHARING_BUFFER_EXCEEDED:
1253 case ERROR_LOCK_VIOLATION:
1254 break; // not an error
1255 case ERROR_INVALID_PARAMETER:
1256 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1257 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1260 case ERROR_INTERRUPT:
1269 if (op & (LOCK_SH | LOCK_EX)) {
1270 // for blocking operations
1284 case ERROR_INVALID_HANDLE:
1287 case ERROR_SHARING_BUFFER_EXCEEDED:
1290 case ERROR_LOCK_VIOLATION:
1292 errno = EWOULDBLOCK;
1296 case ERROR_INVALID_PARAMETER:
1297 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1298 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1301 case ERROR_INTERRUPT:
1308 // give away timeslice