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 (*Argv[0] != '/' && *Argv[0] != '\\'
203 && !(*Argv[0] && *Argv[1] == ':'
204 && (*Argv[2] == '/' || *Argv[2] != '\\'))
205 ) /* will swawnvp use PATH? */
206 TAINT_ENV(); /* testing IFS here is overkill, probably */
207 /* We should check PERL_SH* and PERLLIB_* as well? */
208 if (really && *(tmps = SvPV(really, na)))
209 rc = result(trueflag, spawnvp(flag,tmps,Argv));
211 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
213 if (rc < 0 && dowarn)
214 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
215 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
222 #define EXECF_SPAWN 0
224 #define EXECF_TRUEEXEC 2
227 do_spawn2(cmd, execf)
238 if ((shell = getenv("EMXSHELL")) != NULL)
240 else if ((shell = getenv("SHELL")) != NULL)
242 else if ((shell = getenv("COMSPEC")) != NULL)
247 /* Consensus on perl5-porters is that it is _very_ important to
248 have a shell which will not change between computers with the
249 same architecture, to avoid "action on a distance".
250 And to have simple build, this shell should be sh. */
255 while (*cmd && isSPACE(*cmd))
258 /* save an extra exec if possible */
259 /* see if there are shell metacharacters in it */
261 if (*cmd == '.' && isSPACE(cmd[1]))
264 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
267 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
271 for (s = cmd; *s; s++) {
272 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
273 if (*s == '\n' && !s[1]) {
278 if (execf == EXECF_TRUEEXEC)
279 return execl(shell,shell,copt,cmd,(char*)0);
280 else if (execf == EXECF_EXEC)
281 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
282 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
284 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
285 if (rc < 0 && dowarn)
286 warn("Can't %s \"%s\": %s",
287 (execf == EXECF_SPAWN ? "spawn" : "exec"),
288 shell, Strerror(errno));
289 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
294 New(402,Argv, (s - cmd) / 2 + 2, char*);
295 Cmd = savepvn(cmd, s-cmd);
298 while (*s && isSPACE(*s)) s++;
301 while (*s && !isSPACE(*s)) s++;
307 if (execf == EXECF_TRUEEXEC)
308 rc = execvp(Argv[0],Argv);
309 else if (execf == EXECF_EXEC)
310 rc = spawnvp(P_OVERLAY,Argv[0],Argv);
312 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
313 if (rc < 0 && dowarn)
314 warn("Can't %s \"%s\": %s",
315 (execf == EXECF_SPAWN ? "spawn" : "exec"),
316 Argv[0], Strerror(errno));
317 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
328 return do_spawn2(cmd, EXECF_SPAWN);
335 return do_spawn2(cmd, EXECF_EXEC);
342 return do_spawn2(cmd, EXECF_TRUEEXEC);
352 return popen(cmd, mode);
354 char *shell = getenv("EMXSHELL");
357 my_setenv("EMXSHELL", SH_PATH);
358 res = popen(cmd, mode);
359 my_setenv("EMXSHELL", shell);
365 /*****************************************************************************/
371 die(no_func, "Unsupported function fork");
377 /*****************************************************************************/
378 /* not implemented in EMX 0.9a */
380 void * ctermid(x) { return 0; }
382 #ifdef MYTTYNAME /* was not in emx0.9a */
383 void * ttyname(x) { return 0; }
386 /*****************************************************************************/
387 /* my socket forwarders - EMX lib only provides static forwarders */
389 static HMODULE htcp = 0;
397 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
398 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
399 return (void *) ((void * (*)(void)) fcn) ();
404 tcp1(char *name, int arg)
409 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
410 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
411 ((void (*)(int)) fcn) (arg);
414 void * gethostent() { return tcp0("GETHOSTENT"); }
415 void * getnetent() { return tcp0("GETNETENT"); }
416 void * getprotoent() { return tcp0("GETPROTOENT"); }
417 void * getservent() { return tcp0("GETSERVENT"); }
418 void sethostent(x) { tcp1("SETHOSTENT", x); }
419 void setnetent(x) { tcp1("SETNETENT", x); }
420 void setprotoent(x) { tcp1("SETPROTOENT", x); }
421 void setservent(x) { tcp1("SETSERVENT", x); }
422 void endhostent() { tcp0("ENDHOSTENT"); }
423 void endnetent() { tcp0("ENDNETENT"); }
424 void endprotoent() { tcp0("ENDPROTOENT"); }
425 void endservent() { tcp0("ENDSERVENT"); }
427 /*****************************************************************************/
428 /* not implemented in C Set++ */
431 int setuid(x) { errno = EINVAL; return -1; }
432 int setgid(x) { errno = EINVAL; return -1; }
435 /*****************************************************************************/
436 /* stat() hack for char/block device */
440 /* First attempt used DosQueryFSAttach which crashed the system when
441 used with 5.001. Now just look for /dev/. */
444 os2_stat(char *name, struct stat *st)
446 static int ino = SHRT_MAX;
448 if (stricmp(name, "/dev/con") != 0
449 && stricmp(name, "/dev/tty") != 0)
450 return stat(name, st);
452 memset(st, 0, sizeof *st);
453 st->st_mode = S_IFCHR|0666;
454 st->st_ino = (ino-- & 0x7FFF);
463 /* SBRK() emulation, mostly moved to malloc.c. */
466 sys_alloc(int size) {
468 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
470 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
472 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
476 #endif /* USE_PERL_SBRK */
480 char *tmppath = TMPPATH1;
485 char *p = getenv("TMP"), *tpath;
488 if (!p) p = getenv("TEMP");
491 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
494 strcpy(tpath + len + 1, TMPPATH1);
500 XS(XS_File__Copy_syscopy)
503 if (items < 2 || items > 3)
504 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
506 char * src = (char *)SvPV(ST(0),na);
507 char * dst = (char *)SvPV(ST(1),na);
514 flag = (unsigned long)SvIV(ST(2));
517 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
518 ST(0) = sv_newmortal();
519 sv_setiv(ST(0), (IV)RETVAL);
528 static char fname[9];
529 int pos = 6, len, avlen;
530 unsigned int sum = 0;
535 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
537 if (SvTYPE(sv) != SVt_PVAV)
538 croak("Not array reference given to mod2fname");
540 avlen = av_len((AV*)sv);
542 croak("Empty array reference given to mod2fname");
544 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
545 strncpy(fname, s, 8);
547 if (len < 6) pos = len;
549 sum = 33 * sum + *(s++); /* Checksumming first chars to
550 * get the capitalization into c.s. */
554 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
556 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
560 fname[pos] = 'A' + (sum % 26);
561 fname[pos + 1] = 'A' + (sum / 26 % 26);
562 fname[pos + 2] = '\0';
563 return (char *)fname;
566 XS(XS_DynaLoader_mod2fname)
570 croak("Usage: DynaLoader::mod2fname(sv)");
575 RETVAL = mod2fname(sv);
576 ST(0) = sv_newmortal();
577 sv_setpv((SV*)ST(0), RETVAL);
585 static char buf[300];
590 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
591 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
597 OS2_Perl_data_t OS2_Perl_data;
602 char *file = __FILE__;
606 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
607 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
608 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
611 sv_setiv(GvSV(gv), 1);
622 OS2_Perl_data.xs_init = &Xs_OS2_init;
623 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
624 sh_path[0] = shell[0];
625 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
626 int l = strlen(shell);
627 if (shell[l-1] == '/' || shell[l-1] == '\\') {
630 if (l > STATIC_FILE_LENGTH - 7) {
631 die("PERL_SH_DIR too long");
633 strncpy(sh_path, shell, l);
634 strcpy(sh_path + l, "/sh.exe");
638 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
641 perllib_mangle(char *s, unsigned int l)
643 static char *newp, *oldp;
644 static int newl, oldl, notfound;
645 static char ret[STATIC_FILE_LENGTH+1];
647 if (!newp && !notfound) {
648 newp = getenv("PERLLIB_PREFIX");
651 while (*newp && !isSPACE(*newp) && *newp != ';') {
652 newp++; oldl++; /* Skip digits. */
654 while (*newp && (isSPACE(*newp) || *newp == ';')) {
655 newp++; /* Skip whitespace. */
658 if (newl == 0 || oldl == 0) {
659 die("Malformed PERLLIB_PREFIX");
671 if (l <= oldl || strnicmp(oldp, s, oldl) != 0) {
674 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
675 die("Malformed PERLLIB_PREFIX");
677 strncpy(ret, newp, newl);
678 strcpy(ret + newl, s + oldl);
682 extern void dlopen();
683 void *fakedl = &dlopen; /* Pull in dynaloading part. */