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 /*****************************************************************************/
25 int setpriority(int which, int pid, int val)
27 return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
28 val >> 8, val & 0xFF, abs(pid));
31 int getpriority(int which /* ignored */, int pid)
35 DosGetInfoBlocks(&tib, &pib);
36 return tib->tib_ptib2->tib2_ulpri;
39 /*****************************************************************************/
43 result(int flag, int pid)
46 Signal_t (*ihand)(); /* place to save signal during system() */
47 Signal_t (*qhand)(); /* place to save signal during system() */
49 if (pid < 0 || flag != 0)
52 ihand = signal(SIGINT, SIG_IGN);
53 qhand = signal(SIGQUIT, SIG_IGN);
55 r = wait4pid(pid, &status, 0);
56 } while (r == -1 && errno == EINTR);
57 signal(SIGINT, ihand);
58 signal(SIGQUIT, qhand);
60 statusvalue = (U16)status;
63 return status & 0xFFFF;
67 do_aspawn(really,mark,sp)
75 int flag = P_WAIT, trueflag;
78 New(401,Argv, sp - mark + 1, char*);
81 if (mark < sp && SvIOKp(*(mark+1))) {
86 while (++mark <= sp) {
88 *a++ = SvPVx(*mark, na);
98 if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */
99 TAINT_ENV(); /* testing IFS here is overkill, probably */
100 if (really && *(tmps = SvPV(really, na)))
101 rc = result(trueflag, spawnvp(flag,tmps,Argv));
103 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
105 if (rc < 0 && dowarn)
106 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
107 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
125 if ((shell = getenv("EMXSHELL")) != NULL)
127 else if ((shell = getenv("SHELL")) != NULL)
129 else if ((shell = getenv("COMSPEC")) != NULL)
134 /* Consensus on perl5-porters is that it is _very_ important to
135 have a shell which will not change between computers with the
136 same architecture, to avoid "action on a distance".
137 And to have simple build, this shell should be sh. */
142 while (*cmd && isSPACE(*cmd))
145 /* save an extra exec if possible */
146 /* see if there are shell metacharacters in it */
148 if (*cmd == '.' && isSPACE(cmd[1]))
151 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
154 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
158 for (s = cmd; *s; s++) {
159 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
160 if (*s == '\n' && !s[1]) {
166 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
167 if (rc < 0 && dowarn)
168 warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
169 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
174 New(402,Argv, (s - cmd) / 2 + 2, char*);
175 Cmd = savepvn(cmd, s-cmd);
178 while (*s && isSPACE(*s)) s++;
181 while (*s && !isSPACE(*s)) s++;
187 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
188 if (rc < 0 && dowarn)
189 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
190 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
202 char *shell = getenv("EMXSHELL");
205 my_setenv("EMXSHELL", "sh.exe");
206 res = popen(cmd, mode);
207 my_setenv("EMXSHELL", shell);
211 /*****************************************************************************/
217 die(no_func, "Unsupported function fork");
223 /*****************************************************************************/
224 /* not implemented in EMX 0.9a */
226 void * ctermid(x) { return 0; }
228 #ifdef MYTTYNAME /* was not in emx0.9a */
229 void * ttyname(x) { return 0; }
232 void * gethostent() { return 0; }
233 void * getnetent() { return 0; }
234 void * getprotoent() { return 0; }
235 void * getservent() { return 0; }
236 void sethostent(x) {}
238 void setprotoent(x) {}
239 void setservent(x) {}
240 void endhostent(x) {}
242 void endprotoent(x) {}
243 void endservent(x) {}
245 /*****************************************************************************/
246 /* stat() hack for char/block device */
250 /* First attempt used DosQueryFSAttach which crashed the system when
251 used with 5.001. Now just look for /dev/. */
254 os2_stat(char *name, struct stat *st)
256 static int ino = SHRT_MAX;
258 if (stricmp(name, "/dev/con") != 0
259 && stricmp(name, "/dev/tty") != 0)
260 return stat(name, st);
262 memset(st, 0, sizeof *st);
263 st->st_mode = S_IFCHR|0666;
264 st->st_ino = (ino-- & 0x7FFF);
273 static char *oldchunk;
276 #define _32_K (1<<15)
277 #define _64_K (1<<16)
279 /* The real problem is that DosAllocMem will grant memory on 64K-chunks
280 * boundaries only. Note that addressable space for application memory
281 * is around 240M, thus we will run out of addressable space if we
282 * allocate around 14M worth of 4K segments.
283 * Thus we allocate memory in 64K chunks, and abandon the rest of the old
284 * chunk if the new is bigger than that rest. Also, we just allocate
285 * whatever is requested if the size is bigger that 32K. With this strategy
286 * we cannot lose more than 1/2 of addressable space. */
296 else if (size <= oldsize) {
301 } else if (size >= _32_K) {
308 rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE);
309 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
311 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
313 /* Chunk is small, register the rest for future allocs. */
314 oldchunk = got + reqsize;
315 oldsize = size - reqsize;
319 #endif /* ! defined NO_SYS_ALLOC */
323 char *tmppath = TMPPATH1;
328 char *p = getenv("TMP"), *tpath;
331 if (!p) p = getenv("TEMP");
334 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
337 strcpy(tpath + len + 1, TMPPATH1);
343 XS(XS_File__Copy_syscopy)
346 if (items < 2 || items > 3)
347 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
349 char * src = (char *)SvPV(ST(0),na);
350 char * dst = (char *)SvPV(ST(1),na);
357 flag = (unsigned long)SvIV(ST(2));
360 errno = DosCopy(src, dst, flag);
362 ST(0) = sv_newmortal();
363 sv_setiv(ST(0), (IV)RETVAL);
368 OS2_Perl_data_t OS2_Perl_data;
373 char *file = __FILE__;
375 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
383 OS2_Perl_data.xs_init = &Xs_OS2_init;