3 #define INCL_DOSFILEMGR
5 # define INCL_DOSMEMMGR
6 # define INCL_DOSERRORS
7 #endif /* ! defined NO_SYS_ALLOC */
11 * Various Unix compatibility functions for OS/2
22 /*****************************************************************************/
24 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
26 #define QSS_INI_BUFFER 1024
29 get_sysinfo(ULONG pid, ULONG flags)
32 ULONG rc, buf_len = QSS_INI_BUFFER;
34 New(1022, pbuffer, buf_len, char);
35 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
36 rc = QuerySysState(flags, pid, pbuffer, buf_len);
37 while (rc == ERROR_BUFFER_OVERFLOW) {
38 Renew(pbuffer, buf_len *= 2, char);
39 rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
46 return (PQTOPLEVEL)pbuffer;
49 #define PRIO_ERR 0x1111
57 psi = get_sysinfo(pid, QSS_PROCESS);
61 if (pid != psi->procdata->pid) {
63 croak("panic: wrong pid in sysinfo");
65 prio = psi->procdata->threads->priority;
71 setpriority(int which, int pid, int val)
78 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
79 /* Do not change class. */
80 return CheckOSError(DosSetPriority((pid < 0)
81 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
83 (32 - val) % 32 - (prio & 0xFF),
86 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
87 /* Documentation claims one can change both class and basevalue,
88 * but I find it wrong. */
89 /* Change class, but since delta == 0 denotes absolute 0, correct. */
90 if (CheckOSError(DosSetPriority((pid < 0)
91 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
92 priors[(32 - val) >> 5] + 1,
96 if ( ((32 - val) % 32) == 0 ) return 0;
97 return CheckOSError(DosSetPriority((pid < 0)
98 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
104 /* else return CheckOSError(DosSetPriority((pid < 0) */
105 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
106 /* priors[(32 - val) >> 5] + 1, */
107 /* (32 - val) % 32 - (prio & 0xFF), */
113 getpriority(int which /* ignored */, int pid)
119 /* DosGetInfoBlocks has old priority! */
120 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
121 /* if (pid != pib->pib_ulpid) { */
123 if (ret == PRIO_ERR) {
127 /* ret = tib->tib_ptib2->tib2_ulpri; */
128 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
131 /*****************************************************************************/
135 result(int flag, int pid)
138 Signal_t (*ihand)(); /* place to save signal during system() */
139 Signal_t (*qhand)(); /* place to save signal during system() */
141 if (pid < 0 || flag != 0)
144 ihand = signal(SIGINT, SIG_IGN);
145 qhand = signal(SIGQUIT, SIG_IGN);
147 r = wait4pid(pid, &status, 0);
148 } while (r == -1 && errno == EINTR);
149 signal(SIGINT, ihand);
150 signal(SIGQUIT, qhand);
152 statusvalue = (U16)status;
155 return status & 0xFFFF;
159 do_aspawn(really,mark,sp)
167 int flag = P_WAIT, trueflag;
170 New(401,Argv, sp - mark + 1, char*);
173 if (mark < sp && SvIOKp(*(mark+1))) {
178 while (++mark <= sp) {
180 *a++ = SvPVx(*mark, na);
190 if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */
191 TAINT_ENV(); /* testing IFS here is overkill, probably */
192 if (really && *(tmps = SvPV(really, na)))
193 rc = result(trueflag, spawnvp(flag,tmps,Argv));
195 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
197 if (rc < 0 && dowarn)
198 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
199 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
217 if ((shell = getenv("EMXSHELL")) != NULL)
219 else if ((shell = getenv("SHELL")) != NULL)
221 else if ((shell = getenv("COMSPEC")) != NULL)
226 /* Consensus on perl5-porters is that it is _very_ important to
227 have a shell which will not change between computers with the
228 same architecture, to avoid "action on a distance".
229 And to have simple build, this shell should be sh. */
234 while (*cmd && isSPACE(*cmd))
237 /* save an extra exec if possible */
238 /* see if there are shell metacharacters in it */
240 if (*cmd == '.' && isSPACE(cmd[1]))
243 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
246 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
250 for (s = cmd; *s; s++) {
251 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
252 if (*s == '\n' && !s[1]) {
258 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
259 if (rc < 0 && dowarn)
260 warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
261 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
266 New(402,Argv, (s - cmd) / 2 + 2, char*);
267 Cmd = savepvn(cmd, s-cmd);
270 while (*s && isSPACE(*s)) s++;
273 while (*s && !isSPACE(*s)) s++;
279 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
280 if (rc < 0 && dowarn)
281 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
282 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
295 char *shell = getenv("EMXSHELL");
298 my_setenv("EMXSHELL", SH_PATH);
299 res = popen(cmd, mode);
300 my_setenv("EMXSHELL", shell);
305 /*****************************************************************************/
311 die(no_func, "Unsupported function fork");
317 /*****************************************************************************/
318 /* not implemented in EMX 0.9a */
320 void * ctermid(x) { return 0; }
322 #ifdef MYTTYNAME /* was not in emx0.9a */
323 void * ttyname(x) { return 0; }
326 void * gethostent() { return 0; }
327 void * getnetent() { return 0; }
328 void * getprotoent() { return 0; }
329 void * getservent() { return 0; }
330 void sethostent(x) {}
332 void setprotoent(x) {}
333 void setservent(x) {}
334 void endhostent(x) {}
336 void endprotoent(x) {}
337 void endservent(x) {}
339 /*****************************************************************************/
340 /* stat() hack for char/block device */
344 /* First attempt used DosQueryFSAttach which crashed the system when
345 used with 5.001. Now just look for /dev/. */
348 os2_stat(char *name, struct stat *st)
350 static int ino = SHRT_MAX;
352 if (stricmp(name, "/dev/con") != 0
353 && stricmp(name, "/dev/tty") != 0)
354 return stat(name, st);
356 memset(st, 0, sizeof *st);
357 st->st_mode = S_IFCHR|0666;
358 st->st_ino = (ino-- & 0x7FFF);
367 static char *oldchunk;
370 #define _32_K (1<<15)
371 #define _64_K (1<<16)
373 /* The real problem is that DosAllocMem will grant memory on 64K-chunks
374 * boundaries only. Note that addressable space for application memory
375 * is around 240M, thus we will run out of addressable space if we
376 * allocate around 14M worth of 4K segments.
377 * Thus we allocate memory in 64K chunks, and abandon the rest of the old
378 * chunk if the new is bigger than that rest. Also, we just allocate
379 * whatever is requested if the size is bigger that 32K. With this strategy
380 * we cannot lose more than 1/2 of addressable space. */
390 else if (size <= oldsize) {
395 } else if (size >= _32_K) {
402 rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE);
403 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
405 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
407 /* Chunk is small, register the rest for future allocs. */
408 oldchunk = got + reqsize;
409 oldsize = size - reqsize;
413 #endif /* ! defined NO_SYS_ALLOC */
417 char *tmppath = TMPPATH1;
422 char *p = getenv("TMP"), *tpath;
425 if (!p) p = getenv("TEMP");
428 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
431 strcpy(tpath + len + 1, TMPPATH1);
437 XS(XS_File__Copy_syscopy)
440 if (items < 2 || items > 3)
441 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
443 char * src = (char *)SvPV(ST(0),na);
444 char * dst = (char *)SvPV(ST(1),na);
451 flag = (unsigned long)SvIV(ST(2));
454 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
455 ST(0) = sv_newmortal();
456 sv_setiv(ST(0), (IV)RETVAL);
465 static char fname[9];
472 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
474 if (SvTYPE(sv) != SVt_PVAV)
475 croak("Not array reference given to mod2fname");
476 if (av_len((AV*)sv) < 0)
477 croak("Empty array reference given to mod2fname");
478 s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
479 strncpy(fname, s, 8);
480 if ((len=strlen(s)) < 7) pos = len;
482 fname[pos + 1] = '\0';
483 return (char *)fname;
486 XS(XS_DynaLoader_mod2fname)
490 croak("Usage: DynaLoader::mod2fname(sv)");
495 RETVAL = mod2fname(sv);
496 ST(0) = sv_newmortal();
497 sv_setpv((SV*)ST(0), RETVAL);
505 static char buf[300];
510 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
511 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
517 OS2_Perl_data_t OS2_Perl_data;
522 char *file = __FILE__;
526 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
527 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
529 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
531 sv_setiv(GvSV(gv), 1);
542 OS2_Perl_data.xs_init = &Xs_OS2_init;
543 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
544 sh_path[0] = shell[0];
548 char sh_path[33] = BIN_SH;
550 extern void dlopen();
551 void *fakedl = &dlopen; /* Pull in dynaloading part. */