Commit | Line | Data |
4633a7c4 |
1 | #define INCL_DOS |
2 | #define INCL_NOPM |
7a2f0d5b |
3 | #define INCL_DOSFILEMGR |
c0c09dfd |
4 | #ifndef NO_SYS_ALLOC |
5 | # define INCL_DOSMEMMGR |
6 | # define INCL_DOSERRORS |
7 | #endif /* ! defined NO_SYS_ALLOC */ |
4633a7c4 |
8 | #include <os2.h> |
9 | |
10 | /* |
11 | * Various Unix compatibility functions for OS/2 |
12 | */ |
13 | |
14 | #include <stdio.h> |
15 | #include <errno.h> |
16 | #include <limits.h> |
17 | #include <process.h> |
18 | |
19 | #include "EXTERN.h" |
20 | #include "perl.h" |
21 | |
22 | /*****************************************************************************/ |
23 | /* priorities */ |
6f064249 |
24 | static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, |
25 | self inverse. */ |
26 | #define QSS_INI_BUFFER 1024 |
4633a7c4 |
27 | |
6f064249 |
28 | PQTOPLEVEL |
29 | get_sysinfo(ULONG pid, ULONG flags) |
4633a7c4 |
30 | { |
6f064249 |
31 | char *pbuffer; |
32 | ULONG rc, buf_len = QSS_INI_BUFFER; |
33 | |
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); |
40 | } |
41 | if (rc) { |
42 | FillOSError(rc); |
43 | Safefree(pbuffer); |
44 | return 0; |
45 | } |
46 | return (PQTOPLEVEL)pbuffer; |
47 | } |
48 | |
49 | #define PRIO_ERR 0x1111 |
50 | |
51 | static ULONG |
52 | sys_prio(pid) |
53 | { |
54 | ULONG prio; |
55 | PQTOPLEVEL psi; |
56 | |
57 | psi = get_sysinfo(pid, QSS_PROCESS); |
58 | if (!psi) { |
59 | return PRIO_ERR; |
60 | } |
61 | if (pid != psi->procdata->pid) { |
62 | Safefree(psi); |
63 | croak("panic: wrong pid in sysinfo"); |
64 | } |
65 | prio = psi->procdata->threads->priority; |
66 | Safefree(psi); |
67 | return prio; |
68 | } |
69 | |
70 | int |
71 | setpriority(int which, int pid, int val) |
72 | { |
73 | ULONG rc, prio; |
74 | PQTOPLEVEL psi; |
75 | |
76 | prio = sys_prio(pid); |
77 | |
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, |
82 | 0, |
83 | (32 - val) % 32 - (prio & 0xFF), |
84 | abs(pid))) |
85 | ? -1 : 0; |
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, |
93 | 0, |
94 | abs(pid)))) |
95 | return -1; |
96 | if ( ((32 - val) % 32) == 0 ) return 0; |
97 | return CheckOSError(DosSetPriority((pid < 0) |
98 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
99 | 0, |
100 | (32 - val) % 32, |
101 | abs(pid))) |
102 | ? -1 : 0; |
103 | } |
104 | /* else return CheckOSError(DosSetPriority((pid < 0) */ |
105 | /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ |
106 | /* priors[(32 - val) >> 5] + 1, */ |
107 | /* (32 - val) % 32 - (prio & 0xFF), */ |
108 | /* abs(pid))) */ |
109 | /* ? -1 : 0; */ |
4633a7c4 |
110 | } |
111 | |
6f064249 |
112 | int |
113 | getpriority(int which /* ignored */, int pid) |
4633a7c4 |
114 | { |
115 | TIB *tib; |
116 | PIB *pib; |
6f064249 |
117 | ULONG rc, ret; |
118 | |
119 | /* DosGetInfoBlocks has old priority! */ |
120 | /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ |
121 | /* if (pid != pib->pib_ulpid) { */ |
122 | ret = sys_prio(pid); |
123 | if (ret == PRIO_ERR) { |
124 | return -1; |
125 | } |
126 | /* } else */ |
127 | /* ret = tib->tib_ptib2->tib2_ulpri; */ |
128 | return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); |
4633a7c4 |
129 | } |
130 | |
131 | /*****************************************************************************/ |
132 | /* spawn */ |
133 | |
134 | static int |
135 | result(int flag, int pid) |
136 | { |
137 | int r, status; |
138 | Signal_t (*ihand)(); /* place to save signal during system() */ |
139 | Signal_t (*qhand)(); /* place to save signal during system() */ |
140 | |
c0c09dfd |
141 | if (pid < 0 || flag != 0) |
4633a7c4 |
142 | return pid; |
143 | |
144 | ihand = signal(SIGINT, SIG_IGN); |
145 | qhand = signal(SIGQUIT, SIG_IGN); |
c0c09dfd |
146 | do { |
147 | r = wait4pid(pid, &status, 0); |
148 | } while (r == -1 && errno == EINTR); |
4633a7c4 |
149 | signal(SIGINT, ihand); |
150 | signal(SIGQUIT, qhand); |
151 | |
152 | statusvalue = (U16)status; |
153 | if (r < 0) |
154 | return -1; |
155 | return status & 0xFFFF; |
156 | } |
157 | |
158 | int |
159 | do_aspawn(really,mark,sp) |
160 | SV *really; |
161 | register SV **mark; |
162 | register SV **sp; |
163 | { |
164 | register char **a; |
165 | char *tmps; |
166 | int rc; |
167 | int flag = P_WAIT, trueflag; |
168 | |
169 | if (sp > mark) { |
170 | New(401,Argv, sp - mark + 1, char*); |
171 | a = Argv; |
172 | |
173 | if (mark < sp && SvIOKp(*(mark+1))) { |
174 | ++mark; |
175 | flag = SvIVx(*mark); |
176 | } |
177 | |
178 | while (++mark <= sp) { |
179 | if (*mark) |
180 | *a++ = SvPVx(*mark, na); |
181 | else |
182 | *a++ = ""; |
183 | } |
184 | *a = Nullch; |
185 | |
186 | trueflag = flag; |
187 | if (flag == P_WAIT) |
188 | flag = P_NOWAIT; |
189 | |
c0c09dfd |
190 | if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */ |
191 | TAINT_ENV(); /* testing IFS here is overkill, probably */ |
4633a7c4 |
192 | if (really && *(tmps = SvPV(really, na))) |
193 | rc = result(trueflag, spawnvp(flag,tmps,Argv)); |
194 | else |
195 | rc = result(trueflag, spawnvp(flag,Argv[0],Argv)); |
196 | |
197 | if (rc < 0 && dowarn) |
198 | warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); |
c0c09dfd |
199 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 |
200 | } else |
201 | rc = -1; |
202 | do_execfree(); |
203 | return rc; |
204 | } |
205 | |
206 | int |
207 | do_spawn(cmd) |
208 | char *cmd; |
209 | { |
210 | register char **a; |
211 | register char *s; |
212 | char flags[10]; |
213 | char *shell, *copt; |
214 | int rc; |
215 | |
c0c09dfd |
216 | #ifdef TRYSHELL |
217 | if ((shell = getenv("EMXSHELL")) != NULL) |
218 | copt = "-c"; |
219 | else if ((shell = getenv("SHELL")) != NULL) |
4633a7c4 |
220 | copt = "-c"; |
221 | else if ((shell = getenv("COMSPEC")) != NULL) |
222 | copt = "/C"; |
223 | else |
224 | shell = "cmd.exe"; |
c0c09dfd |
225 | #else |
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. */ |
6f064249 |
230 | shell = SH_PATH; |
c0c09dfd |
231 | copt = "-c"; |
232 | #endif |
233 | |
234 | while (*cmd && isSPACE(*cmd)) |
235 | cmd++; |
4633a7c4 |
236 | |
237 | /* save an extra exec if possible */ |
238 | /* see if there are shell metacharacters in it */ |
239 | |
c0c09dfd |
240 | if (*cmd == '.' && isSPACE(cmd[1])) |
241 | goto doshell; |
242 | |
243 | if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) |
244 | goto doshell; |
245 | |
246 | for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ |
247 | if (*s == '=') |
248 | goto doshell; |
249 | |
4633a7c4 |
250 | for (s = cmd; *s; s++) { |
c0c09dfd |
251 | if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { |
4633a7c4 |
252 | if (*s == '\n' && !s[1]) { |
253 | *s = '\0'; |
254 | break; |
255 | } |
c0c09dfd |
256 | doshell: |
257 | rc = result(P_WAIT, |
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(). */ |
262 | return rc; |
4633a7c4 |
263 | } |
264 | } |
c0c09dfd |
265 | |
4633a7c4 |
266 | New(402,Argv, (s - cmd) / 2 + 2, char*); |
267 | Cmd = savepvn(cmd, s-cmd); |
268 | a = Argv; |
269 | for (s = Cmd; *s;) { |
270 | while (*s && isSPACE(*s)) s++; |
271 | if (*s) |
272 | *(a++) = s; |
273 | while (*s && !isSPACE(*s)) s++; |
274 | if (*s) |
275 | *s++ = '\0'; |
276 | } |
277 | *a = Nullch; |
278 | if (Argv[0]) { |
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)); |
c0c09dfd |
282 | if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ |
4633a7c4 |
283 | } else |
284 | rc = -1; |
285 | do_execfree(); |
286 | return rc; |
287 | } |
288 | |
6f064249 |
289 | #ifndef HAS_FORK |
c0c09dfd |
290 | FILE * |
291 | my_popen(cmd,mode) |
292 | char *cmd; |
293 | char *mode; |
294 | { |
295 | char *shell = getenv("EMXSHELL"); |
296 | FILE *res; |
297 | |
6f064249 |
298 | my_setenv("EMXSHELL", SH_PATH); |
c0c09dfd |
299 | res = popen(cmd, mode); |
300 | my_setenv("EMXSHELL", shell); |
301 | return res; |
302 | } |
6f064249 |
303 | #endif |
c0c09dfd |
304 | |
4633a7c4 |
305 | /*****************************************************************************/ |
306 | |
307 | #ifndef HAS_FORK |
308 | int |
309 | fork(void) |
310 | { |
311 | die(no_func, "Unsupported function fork"); |
312 | errno = EINVAL; |
313 | return -1; |
314 | } |
315 | #endif |
316 | |
317 | /*****************************************************************************/ |
318 | /* not implemented in EMX 0.9a */ |
319 | |
320 | void * ctermid(x) { return 0; } |
eacfb5f1 |
321 | |
322 | #ifdef MYTTYNAME /* was not in emx0.9a */ |
4633a7c4 |
323 | void * ttyname(x) { return 0; } |
eacfb5f1 |
324 | #endif |
4633a7c4 |
325 | |
326 | void * gethostent() { return 0; } |
327 | void * getnetent() { return 0; } |
328 | void * getprotoent() { return 0; } |
329 | void * getservent() { return 0; } |
330 | void sethostent(x) {} |
331 | void setnetent(x) {} |
332 | void setprotoent(x) {} |
333 | void setservent(x) {} |
334 | void endhostent(x) {} |
335 | void endnetent(x) {} |
336 | void endprotoent(x) {} |
337 | void endservent(x) {} |
338 | |
339 | /*****************************************************************************/ |
340 | /* stat() hack for char/block device */ |
341 | |
342 | #if OS2_STAT_HACK |
343 | |
344 | /* First attempt used DosQueryFSAttach which crashed the system when |
345 | used with 5.001. Now just look for /dev/. */ |
346 | |
347 | int |
348 | os2_stat(char *name, struct stat *st) |
349 | { |
350 | static int ino = SHRT_MAX; |
351 | |
352 | if (stricmp(name, "/dev/con") != 0 |
353 | && stricmp(name, "/dev/tty") != 0) |
354 | return stat(name, st); |
355 | |
356 | memset(st, 0, sizeof *st); |
357 | st->st_mode = S_IFCHR|0666; |
358 | st->st_ino = (ino-- & 0x7FFF); |
359 | st->st_nlink = 1; |
360 | return 0; |
361 | } |
362 | |
363 | #endif |
c0c09dfd |
364 | |
365 | #ifndef NO_SYS_ALLOC |
366 | |
7a2f0d5b |
367 | static char *oldchunk; |
368 | static long oldsize; |
c0c09dfd |
369 | |
7a2f0d5b |
370 | #define _32_K (1<<15) |
371 | #define _64_K (1<<16) |
c0c09dfd |
372 | |
7a2f0d5b |
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. */ |
c0c09dfd |
381 | |
382 | void * |
383 | sbrk(int size) |
384 | { |
385 | char *got; |
386 | APIRET rc; |
7a2f0d5b |
387 | int small, reqsize; |
c0c09dfd |
388 | |
389 | if (!size) return 0; |
7a2f0d5b |
390 | else if (size <= oldsize) { |
391 | got = oldchunk; |
392 | oldchunk += size; |
393 | oldsize -= size; |
394 | return (void *)got; |
395 | } else if (size >= _32_K) { |
396 | small = 0; |
397 | } else { |
398 | reqsize = size; |
399 | size = _64_K; |
400 | small = 1; |
c0c09dfd |
401 | } |
402 | rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE); |
403 | if (rc == ERROR_NOT_ENOUGH_MEMORY) { |
404 | return (void *) -1; |
405 | } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); |
7a2f0d5b |
406 | if (small) { |
407 | /* Chunk is small, register the rest for future allocs. */ |
408 | oldchunk = got + reqsize; |
409 | oldsize = size - reqsize; |
410 | } |
c0c09dfd |
411 | return (void *)got; |
412 | } |
413 | #endif /* ! defined NO_SYS_ALLOC */ |
414 | |
415 | /* tmp path */ |
416 | |
417 | char *tmppath = TMPPATH1; |
418 | |
419 | void |
420 | settmppath() |
421 | { |
422 | char *p = getenv("TMP"), *tpath; |
423 | int len; |
424 | |
425 | if (!p) p = getenv("TEMP"); |
426 | if (!p) return; |
427 | len = strlen(p); |
428 | tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); |
429 | strcpy(tpath, p); |
430 | tpath[len] = '/'; |
431 | strcpy(tpath + len + 1, TMPPATH1); |
432 | tmppath = tpath; |
433 | } |
7a2f0d5b |
434 | |
435 | #include "XSUB.h" |
436 | |
437 | XS(XS_File__Copy_syscopy) |
438 | { |
439 | dXSARGS; |
440 | if (items < 2 || items > 3) |
441 | croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); |
442 | { |
443 | char * src = (char *)SvPV(ST(0),na); |
444 | char * dst = (char *)SvPV(ST(1),na); |
445 | U32 flag; |
446 | int RETVAL, rc; |
447 | |
448 | if (items < 3) |
449 | flag = 0; |
450 | else { |
451 | flag = (unsigned long)SvIV(ST(2)); |
452 | } |
453 | |
6f064249 |
454 | RETVAL = !CheckOSError(DosCopy(src, dst, flag)); |
7a2f0d5b |
455 | ST(0) = sv_newmortal(); |
456 | sv_setiv(ST(0), (IV)RETVAL); |
457 | } |
458 | XSRETURN(1); |
459 | } |
460 | |
6f064249 |
461 | char * |
462 | mod2fname(sv) |
463 | SV *sv; |
464 | { |
465 | static char fname[9]; |
466 | int pos = 7; |
467 | int len; |
468 | AV *av; |
469 | SV *svp; |
470 | char *s; |
471 | |
472 | if (!SvROK(sv)) croak("Not a reference given to mod2fname"); |
473 | sv = SvRV(sv); |
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; |
481 | fname[pos] = '_'; |
482 | fname[pos + 1] = '\0'; |
483 | return (char *)fname; |
484 | } |
485 | |
486 | XS(XS_DynaLoader_mod2fname) |
487 | { |
488 | dXSARGS; |
489 | if (items != 1) |
490 | croak("Usage: DynaLoader::mod2fname(sv)"); |
491 | { |
492 | SV * sv = ST(0); |
493 | char * RETVAL; |
494 | |
495 | RETVAL = mod2fname(sv); |
496 | ST(0) = sv_newmortal(); |
497 | sv_setpv((SV*)ST(0), RETVAL); |
498 | } |
499 | XSRETURN(1); |
500 | } |
501 | |
502 | char * |
503 | os2error(int rc) |
504 | { |
505 | static char buf[300]; |
506 | ULONG len; |
507 | |
508 | if (rc == 0) |
509 | return NULL; |
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); |
512 | else |
513 | buf[len] = '\0'; |
514 | return buf; |
515 | } |
516 | |
7a2f0d5b |
517 | OS2_Perl_data_t OS2_Perl_data; |
518 | |
519 | int |
520 | Xs_OS2_init() |
521 | { |
522 | char *file = __FILE__; |
523 | { |
6f064249 |
524 | GV *gv; |
525 | |
7a2f0d5b |
526 | newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); |
6f064249 |
527 | newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); |
528 | #ifdef PERL_IS_AOUT |
529 | gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); |
530 | GvMULTI_on(gv); |
531 | sv_setiv(GvSV(gv), 1); |
532 | #endif |
7a2f0d5b |
533 | } |
534 | } |
535 | |
536 | void |
537 | Perl_OS2_init() |
538 | { |
6f064249 |
539 | char *shell; |
540 | |
7a2f0d5b |
541 | settmppath(); |
542 | OS2_Perl_data.xs_init = &Xs_OS2_init; |
6f064249 |
543 | if ( (shell = getenv("PERL_SH_DRIVE")) ) { |
544 | sh_path[0] = shell[0]; |
545 | } |
7a2f0d5b |
546 | } |
6f064249 |
547 | |
548 | char sh_path[33] = BIN_SH; |
549 | |
550 | extern void dlopen(); |
551 | void *fakedl = &dlopen; /* Pull in dynaloading part. */ |