3 #define INCL_DOSFILEMGR
9 * Various Unix compatibility functions for OS/2
20 /*****************************************************************************/
22 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
24 #define QSS_INI_BUFFER 1024
27 get_sysinfo(ULONG pid, ULONG flags)
30 ULONG rc, buf_len = QSS_INI_BUFFER;
32 New(1022, pbuffer, buf_len, char);
33 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
34 rc = QuerySysState(flags, pid, pbuffer, buf_len);
35 while (rc == ERROR_BUFFER_OVERFLOW) {
36 Renew(pbuffer, buf_len *= 2, char);
37 rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
44 return (PQTOPLEVEL)pbuffer;
47 #define PRIO_ERR 0x1111
55 psi = get_sysinfo(pid, QSS_PROCESS);
59 if (pid != psi->procdata->pid) {
61 croak("panic: wrong pid in sysinfo");
63 prio = psi->procdata->threads->priority;
69 setpriority(int which, int pid, int val)
76 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
77 /* Do not change class. */
78 return CheckOSError(DosSetPriority((pid < 0)
79 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
81 (32 - val) % 32 - (prio & 0xFF),
84 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
85 /* Documentation claims one can change both class and basevalue,
86 * but I find it wrong. */
87 /* Change class, but since delta == 0 denotes absolute 0, correct. */
88 if (CheckOSError(DosSetPriority((pid < 0)
89 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
90 priors[(32 - val) >> 5] + 1,
94 if ( ((32 - val) % 32) == 0 ) return 0;
95 return CheckOSError(DosSetPriority((pid < 0)
96 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
102 /* else return CheckOSError(DosSetPriority((pid < 0) */
103 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
104 /* priors[(32 - val) >> 5] + 1, */
105 /* (32 - val) % 32 - (prio & 0xFF), */
111 getpriority(int which /* ignored */, int pid)
117 /* DosGetInfoBlocks has old priority! */
118 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
119 /* if (pid != pib->pib_ulpid) { */
121 if (ret == PRIO_ERR) {
125 /* ret = tib->tib_ptib2->tib2_ulpri; */
126 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
129 /*****************************************************************************/
133 result(int flag, int pid)
136 Signal_t (*ihand)(); /* place to save signal during system() */
137 Signal_t (*qhand)(); /* place to save signal during system() */
143 if (pid < 0 || flag != 0)
147 ihand = signal(SIGINT, SIG_IGN);
148 qhand = signal(SIGQUIT, SIG_IGN);
150 r = wait4pid(pid, &status, 0);
151 } while (r == -1 && errno == EINTR);
152 signal(SIGINT, ihand);
153 signal(SIGQUIT, qhand);
155 statusvalue = (U16)status;
158 return status & 0xFFFF;
160 ihand = signal(SIGINT, SIG_IGN);
161 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
162 signal(SIGINT, ihand);
163 statusvalue = res.codeResult << 8 | res.codeTerminate;
171 do_aspawn(really,mark,sp)
179 int flag = P_WAIT, trueflag;
182 New(401,Argv, sp - mark + 1, char*);
185 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
190 while (++mark <= sp) {
192 *a++ = SvPVx(*mark, na);
202 if (strEQ(Argv[0],"/bin/sh")) Argv[0] = SH_PATH;
204 if (Argv[0][0] != '/' && Argv[0][0] != '\\'
205 && !(Argv[0][0] && Argv[0][1] == ':'
206 && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
207 ) /* will swawnvp use PATH? */
208 TAINT_ENV(); /* testing IFS here is overkill, probably */
209 /* We should check PERL_SH* and PERLLIB_* as well? */
210 if (really && *(tmps = SvPV(really, na)))
211 rc = result(trueflag, spawnvp(flag,tmps,Argv));
213 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
215 if (rc < 0 && dowarn)
216 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
217 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
224 #define EXECF_SPAWN 0
226 #define EXECF_TRUEEXEC 2
229 do_spawn2(cmd, execf)
236 char *shell, *copt, *news = NULL;
240 if ((shell = getenv("EMXSHELL")) != NULL)
242 else if ((shell = getenv("SHELL")) != NULL)
244 else if ((shell = getenv("COMSPEC")) != NULL)
249 /* Consensus on perl5-porters is that it is _very_ important to
250 have a shell which will not change between computers with the
251 same architecture, to avoid "action on a distance".
252 And to have simple build, this shell should be sh. */
257 while (*cmd && isSPACE(*cmd))
260 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
261 STRLEN l = strlen(SH_PATH);
263 New(4545, news, strlen(cmd) - 7 + l, char);
264 strcpy(news, SH_PATH);
265 strcpy(news + l, cmd + 7);
269 /* save an extra exec if possible */
270 /* see if there are shell metacharacters in it */
272 if (*cmd == '.' && isSPACE(cmd[1]))
275 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
278 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
282 for (s = cmd; *s; s++) {
283 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
284 if (*s == '\n' && s[1] == '\0') {
289 if (execf == EXECF_TRUEEXEC)
290 return execl(shell,shell,copt,cmd,(char*)0);
291 else if (execf == EXECF_EXEC)
292 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
293 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
295 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
296 if (rc < 0 && dowarn)
297 warn("Can't %s \"%s\": %s",
298 (execf == EXECF_SPAWN ? "spawn" : "exec"),
299 shell, Strerror(errno));
300 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
301 if (news) Safefree(news);
306 New(402,Argv, (s - cmd) / 2 + 2, char*);
307 Cmd = savepvn(cmd, s-cmd);
310 while (*s && isSPACE(*s)) s++;
313 while (*s && !isSPACE(*s)) s++;
319 if (execf == EXECF_TRUEEXEC)
320 rc = execvp(Argv[0],Argv);
321 else if (execf == EXECF_EXEC)
322 rc = spawnvp(P_OVERLAY,Argv[0],Argv);
324 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
325 if (rc < 0 && dowarn)
326 warn("Can't %s \"%s\": %s",
327 (execf == EXECF_SPAWN ? "spawn" : "exec"),
328 Argv[0], Strerror(errno));
329 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
332 if (news) Safefree(news);
341 return do_spawn2(cmd, EXECF_SPAWN);
348 return do_spawn2(cmd, EXECF_EXEC);
355 return do_spawn2(cmd, EXECF_TRUEEXEC);
359 my_syspopen(cmd,mode)
367 res = popen(cmd, mode);
369 char *shell = getenv("EMXSHELL");
371 my_setenv("EMXSHELL", SH_PATH);
372 res = popen(cmd, mode);
373 my_setenv("EMXSHELL", shell);
375 sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
376 (void)SvUPGRADE(sv,SVt_IV);
377 SvIVX(sv) = -1; /* A cooky. */
381 /******************************************************************/
387 die(no_func, "Unsupported function fork");
393 /*******************************************************************/
394 /* not implemented in EMX 0.9a */
396 void * ctermid(x) { return 0; }
398 #ifdef MYTTYNAME /* was not in emx0.9a */
399 void * ttyname(x) { return 0; }
402 /******************************************************************/
403 /* my socket forwarders - EMX lib only provides static forwarders */
405 static HMODULE htcp = 0;
413 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
414 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
415 return (void *) ((void * (*)(void)) fcn) ();
420 tcp1(char *name, int arg)
425 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
426 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
427 ((void (*)(int)) fcn) (arg);
430 void * gethostent() { return tcp0("GETHOSTENT"); }
431 void * getnetent() { return tcp0("GETNETENT"); }
432 void * getprotoent() { return tcp0("GETPROTOENT"); }
433 void * getservent() { return tcp0("GETSERVENT"); }
434 void sethostent(x) { tcp1("SETHOSTENT", x); }
435 void setnetent(x) { tcp1("SETNETENT", x); }
436 void setprotoent(x) { tcp1("SETPROTOENT", x); }
437 void setservent(x) { tcp1("SETSERVENT", x); }
438 void endhostent() { tcp0("ENDHOSTENT"); }
439 void endnetent() { tcp0("ENDNETENT"); }
440 void endprotoent() { tcp0("ENDPROTOENT"); }
441 void endservent() { tcp0("ENDSERVENT"); }
443 /*****************************************************************************/
444 /* not implemented in C Set++ */
447 int setuid(x) { errno = EINVAL; return -1; }
448 int setgid(x) { errno = EINVAL; return -1; }
451 /*****************************************************************************/
452 /* stat() hack for char/block device */
456 /* First attempt used DosQueryFSAttach which crashed the system when
457 used with 5.001. Now just look for /dev/. */
460 os2_stat(char *name, struct stat *st)
462 static int ino = SHRT_MAX;
464 if (stricmp(name, "/dev/con") != 0
465 && stricmp(name, "/dev/tty") != 0)
466 return stat(name, st);
468 memset(st, 0, sizeof *st);
469 st->st_mode = S_IFCHR|0666;
470 st->st_ino = (ino-- & 0x7FFF);
479 /* SBRK() emulation, mostly moved to malloc.c. */
482 sys_alloc(int size) {
484 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
486 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
488 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
492 #endif /* USE_PERL_SBRK */
496 char *tmppath = TMPPATH1;
501 char *p = getenv("TMP"), *tpath;
504 if (!p) p = getenv("TEMP");
507 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
510 strcpy(tpath + len + 1, TMPPATH1);
516 XS(XS_File__Copy_syscopy)
519 if (items < 2 || items > 3)
520 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
522 char * src = (char *)SvPV(ST(0),na);
523 char * dst = (char *)SvPV(ST(1),na);
530 flag = (unsigned long)SvIV(ST(2));
533 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
534 ST(0) = sv_newmortal();
535 sv_setiv(ST(0), (IV)RETVAL);
544 static char fname[9];
545 int pos = 6, len, avlen;
546 unsigned int sum = 0;
551 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
553 if (SvTYPE(sv) != SVt_PVAV)
554 croak("Not array reference given to mod2fname");
556 avlen = av_len((AV*)sv);
558 croak("Empty array reference given to mod2fname");
560 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
561 strncpy(fname, s, 8);
563 if (len < 6) pos = len;
565 sum = 33 * sum + *(s++); /* Checksumming first chars to
566 * get the capitalization into c.s. */
570 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
572 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
576 fname[pos] = 'A' + (sum % 26);
577 fname[pos + 1] = 'A' + (sum / 26 % 26);
578 fname[pos + 2] = '\0';
579 return (char *)fname;
582 XS(XS_DynaLoader_mod2fname)
586 croak("Usage: DynaLoader::mod2fname(sv)");
591 RETVAL = mod2fname(sv);
592 ST(0) = sv_newmortal();
593 sv_setpv((SV*)ST(0), RETVAL);
601 static char buf[300];
606 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
607 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
613 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
616 perllib_mangle(char *s, unsigned int l)
618 static char *newp, *oldp;
619 static int newl, oldl, notfound;
620 static char ret[STATIC_FILE_LENGTH+1];
622 if (!newp && !notfound) {
623 newp = getenv("PERLLIB_PREFIX");
626 while (*newp && !isSPACE(*newp) && *newp != ';') {
627 newp++; oldl++; /* Skip digits. */
629 while (*newp && (isSPACE(*newp) || *newp == ';')) {
630 newp++; /* Skip whitespace. */
633 if (newl == 0 || oldl == 0) {
634 die("Malformed PERLLIB_PREFIX");
646 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
649 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
650 die("Malformed PERLLIB_PREFIX");
652 strncpy(ret, newp, newl);
653 strcpy(ret + newl, s + oldl);
657 extern void dlopen();
658 void *fakedl = &dlopen; /* Pull in dynaloading part. */
660 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
661 && ((path)[2] == '/' || (path)[2] == '\\'))
662 #define sys_is_rooted _fnisabs
663 #define sys_is_relative _fnisrel
664 #define current_drive _getdrive
666 #undef chdir /* Was _chdir2. */
667 #define sys_chdir(p) (chdir(p) == 0)
668 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
670 XS(XS_Cwd_current_drive)
674 croak("Usage: Cwd::current_drive()");
678 RETVAL = current_drive();
679 ST(0) = sv_newmortal();
680 sv_setpvn(ST(0), (char *)&RETVAL, 1);
689 croak("Usage: Cwd::sys_chdir(path)");
691 char * path = (char *)SvPV(ST(0),na);
694 RETVAL = sys_chdir(path);
695 ST(0) = RETVAL ? &sv_yes : &sv_no;
696 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
701 XS(XS_Cwd_change_drive)
705 croak("Usage: Cwd::change_drive(d)");
707 char d = (char)*SvPV(ST(0),na);
710 RETVAL = change_drive(d);
711 ST(0) = RETVAL ? &sv_yes : &sv_no;
712 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
717 XS(XS_Cwd_sys_is_absolute)
721 croak("Usage: Cwd::sys_is_absolute(path)");
723 char * path = (char *)SvPV(ST(0),na);
726 RETVAL = sys_is_absolute(path);
727 ST(0) = RETVAL ? &sv_yes : &sv_no;
728 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
733 XS(XS_Cwd_sys_is_rooted)
737 croak("Usage: Cwd::sys_is_rooted(path)");
739 char * path = (char *)SvPV(ST(0),na);
742 RETVAL = sys_is_rooted(path);
743 ST(0) = RETVAL ? &sv_yes : &sv_no;
744 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
749 XS(XS_Cwd_sys_is_relative)
753 croak("Usage: Cwd::sys_is_relative(path)");
755 char * path = (char *)SvPV(ST(0),na);
758 RETVAL = sys_is_relative(path);
759 ST(0) = RETVAL ? &sv_yes : &sv_no;
760 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
769 croak("Usage: Cwd::sys_cwd()");
773 RETVAL = _getcwd2(p, MAXPATHLEN);
774 ST(0) = sv_newmortal();
775 sv_setpv((SV*)ST(0), RETVAL);
780 XS(XS_Cwd_sys_abspath)
783 if (items < 1 || items > 2)
784 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
786 char * path = (char *)SvPV(ST(0),na);
794 dir = (char *)SvPV(ST(1),na);
796 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
800 if (_abspath(p, path, MAXPATHLEN) == 0) {
806 /* Absolute with drive: */
807 if ( sys_is_absolute(path) ) {
808 if (_abspath(p, path, MAXPATHLEN) == 0) {
813 } else if (path[0] == '/' || path[0] == '\\') {
814 /* Rooted, but maybe on different drive. */
815 if (isALPHA(dir[0]) && dir[1] == ':' ) {
818 /* Need to prepend the drive. */
821 Copy(path, p1 + 2, strlen(path) + 1, char);
823 if (_abspath(p, p1, MAXPATHLEN) == 0) {
828 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
834 /* Either path is relative, or starts with a drive letter. */
835 /* If the path starts with a drive letter, then dir is
837 a/b) it is absolute/x:relative on the same drive.
838 c) path is on current drive, and dir is rooted
839 In all the cases it is safe to drop the drive part
841 if ( !sys_is_relative(path) ) {
844 if ( ( ( sys_is_absolute(dir)
845 || (isALPHA(dir[0]) && dir[1] == ':'
846 && strnicmp(dir, path,1) == 0))
847 && strnicmp(dir, path,1) == 0)
848 || ( !(isALPHA(dir[0]) && dir[1] == ':')
849 && toupper(path[0]) == current_drive())) {
851 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
852 RETVAL = p; goto done;
854 RETVAL = NULL; goto done;
858 /* Need to prepend the absolute path of dir. */
861 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
864 if (p1[ l - 1 ] != '/') {
868 Copy(path, p1 + l, strlen(path) + 1, char);
869 if (_abspath(p, p1, MAXPATHLEN) == 0) {
881 ST(0) = sv_newmortal();
882 sv_setpv((SV*)ST(0), RETVAL);
887 #define extLibpath(type) \
888 (CheckOSError(DosQueryExtLIBPATH(to, ((type) ? END_LIBPATH \
892 #define extLibpath_set(p,type) \
893 (!CheckOSError(DosSetExtLIBPATH((p), ((type) ? END_LIBPATH \
896 XS(XS_Cwd_extLibpath)
899 if (items < 0 || items > 1)
900 croak("Usage: Cwd::extLibpath(type = 0)");
910 type = (int)SvIV(ST(0));
913 RETVAL = extLibpath(type);
914 ST(0) = sv_newmortal();
915 sv_setpv((SV*)ST(0), RETVAL);
920 XS(XS_Cwd_extLibpath_set)
923 if (items < 1 || items > 2)
924 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
926 char * s = (char *)SvPV(ST(0),na);
934 type = (int)SvIV(ST(1));
937 RETVAL = extLibpath_set(s, type);
938 ST(0) = RETVAL ? &sv_yes : &sv_no;
939 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
947 char *file = __FILE__;
951 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
952 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
953 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
954 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
955 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
956 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
957 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
958 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
959 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
960 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
961 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
962 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
963 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
966 sv_setiv(GvSV(gv), 1);
971 OS2_Perl_data_t OS2_Perl_data;
979 OS2_Perl_data.xs_init = &Xs_OS2_init;
980 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
981 sh_path[0] = shell[0];
982 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
983 int l = strlen(shell);
984 if (shell[l-1] == '/' || shell[l-1] == '\\') {
987 if (l > STATIC_FILE_LENGTH - 7) {
988 die("PERL_SH_DIR too long");
990 strncpy(sh_path, shell, l);
991 strcpy(sh_path + l, "/sh.exe");