perl 5.003_07: lib/ExtUtils/MM_Unix.pm
[perl.git] / os2 / os2.c
1 #define INCL_DOS
2 #define INCL_NOPM
3 #define INCL_DOSFILEMGR
4 #define INCL_DOSMEMMGR
5 #define INCL_DOSERRORS
6 #include <os2.h>
7
8 /*
9  * Various Unix compatibility functions for OS/2
10  */
11
12 #include <stdio.h>
13 #include <errno.h>
14 #include <limits.h>
15 #include <process.h>
16
17 #include "EXTERN.h"
18 #include "perl.h"
19
20 /*****************************************************************************/
21 /* priorities */
22 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
23                                                self inverse. */
24 #define QSS_INI_BUFFER 1024
25
26 PQTOPLEVEL
27 get_sysinfo(ULONG pid, ULONG flags)
28 {
29     char *pbuffer;
30     ULONG rc, buf_len = QSS_INI_BUFFER;
31
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);
38     }
39     if (rc) {
40         FillOSError(rc);
41         Safefree(pbuffer);
42         return 0;
43     }
44     return (PQTOPLEVEL)pbuffer;
45 }
46
47 #define PRIO_ERR 0x1111
48
49 static ULONG
50 sys_prio(pid)
51 {
52   ULONG prio;
53   PQTOPLEVEL psi;
54
55   psi = get_sysinfo(pid, QSS_PROCESS);
56   if (!psi) {
57       return PRIO_ERR;
58   }
59   if (pid != psi->procdata->pid) {
60       Safefree(psi);
61       croak("panic: wrong pid in sysinfo");
62   }
63   prio = psi->procdata->threads->priority;
64   Safefree(psi);
65   return prio;
66 }
67
68 int 
69 setpriority(int which, int pid, int val)
70 {
71   ULONG rc, prio;
72   PQTOPLEVEL psi;
73
74   prio = sys_prio(pid);
75
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,
80                                          0, 
81                                          (32 - val) % 32 - (prio & 0xFF), 
82                                          abs(pid)))
83       ? -1 : 0;
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, 
91                                       0, 
92                                       abs(pid)))) 
93           return -1;
94       if ( ((32 - val) % 32) == 0 ) return 0;
95       return CheckOSError(DosSetPriority((pid < 0) 
96                                          ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
97                                          0, 
98                                          (32 - val) % 32, 
99                                          abs(pid)))
100           ? -1 : 0;
101   } 
102 /*   else return CheckOSError(DosSetPriority((pid < 0)  */
103 /*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
104 /*                                        priors[(32 - val) >> 5] + 1,  */
105 /*                                        (32 - val) % 32 - (prio & 0xFF),  */
106 /*                                        abs(pid))) */
107 /*       ? -1 : 0; */
108 }
109
110 int 
111 getpriority(int which /* ignored */, int pid)
112 {
113   TIB *tib;
114   PIB *pib;
115   ULONG rc, ret;
116
117   /* DosGetInfoBlocks has old priority! */
118 /*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
119 /*   if (pid != pib->pib_ulpid) { */
120   ret = sys_prio(pid);
121   if (ret == PRIO_ERR) {
122       return -1;
123   }
124 /*   } else */
125 /*       ret = tib->tib_ptib2->tib2_ulpri; */
126   return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
127 }
128
129 /*****************************************************************************/
130 /* spawn */
131
132 static int
133 result(int flag, int pid)
134 {
135         int r, status;
136         Signal_t (*ihand)();     /* place to save signal during system() */
137         Signal_t (*qhand)();     /* place to save signal during system() */
138 #ifndef __EMX__
139         RESULTCODES res;
140         int rpid;
141 #endif
142
143         if (pid < 0 || flag != 0)
144                 return pid;
145
146 #ifdef __EMX__
147         ihand = signal(SIGINT, SIG_IGN);
148         qhand = signal(SIGQUIT, SIG_IGN);
149         do {
150             r = wait4pid(pid, &status, 0);
151         } while (r == -1 && errno == EINTR);
152         signal(SIGINT, ihand);
153         signal(SIGQUIT, qhand);
154
155         statusvalue = (U16)status;
156         if (r < 0)
157                 return -1;
158         return status & 0xFFFF;
159 #else
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;
164         if (r)
165                 return -1;
166         return statusvalue;
167 #endif
168 }
169
170 int
171 do_aspawn(really,mark,sp)
172 SV *really;
173 register SV **mark;
174 register SV **sp;
175 {
176     register char **a;
177     char *tmps;
178     int rc;
179     int flag = P_WAIT, trueflag;
180
181     if (sp > mark) {
182         New(401,Argv, sp - mark + 1, char*);
183         a = Argv;
184
185         if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
186                 ++mark;
187                 flag = SvIVx(*mark);
188         }
189
190         while (++mark <= sp) {
191             if (*mark)
192                 *a++ = SvPVx(*mark, na);
193             else
194                 *a++ = "";
195         }
196         *a = Nullch;
197
198         trueflag = flag;
199         if (flag == P_WAIT)
200                 flag = P_NOWAIT;
201
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));
210         else
211             rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
212
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(). */
216     } else
217         rc = -1;
218     do_execfree();
219     return rc;
220 }
221
222 #define EXECF_SPAWN 0
223 #define EXECF_EXEC 1
224 #define EXECF_TRUEEXEC 2
225
226 int
227 do_spawn2(cmd, execf)
228 char *cmd;
229 int execf;
230 {
231     register char **a;
232     register char *s;
233     char flags[10];
234     char *shell, *copt;
235     int rc;
236
237 #ifdef TRYSHELL
238     if ((shell = getenv("EMXSHELL")) != NULL)
239         copt = "-c";
240     else if ((shell = getenv("SHELL")) != NULL)
241         copt = "-c";
242     else if ((shell = getenv("COMSPEC")) != NULL)
243         copt = "/C";
244     else
245         shell = "cmd.exe";
246 #else
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. */
251     shell = SH_PATH;
252     copt = "-c";
253 #endif 
254
255     while (*cmd && isSPACE(*cmd))
256         cmd++;
257
258     /* save an extra exec if possible */
259     /* see if there are shell metacharacters in it */
260
261     if (*cmd == '.' && isSPACE(cmd[1]))
262         goto doshell;
263
264     if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
265         goto doshell;
266
267     for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
268     if (*s == '=')
269         goto doshell;
270
271     for (s = cmd; *s; s++) {
272         if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
273             if (*s == '\n' && !s[1]) {
274                 *s = '\0';
275                 break;
276             }
277           doshell:
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 ??? */
283             rc = result(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(). */
290             return rc;
291         }
292     }
293
294     New(402,Argv, (s - cmd) / 2 + 2, char*);
295     Cmd = savepvn(cmd, s-cmd);
296     a = Argv;
297     for (s = Cmd; *s;) {
298         while (*s && isSPACE(*s)) s++;
299         if (*s)
300             *(a++) = s;
301         while (*s && !isSPACE(*s)) s++;
302         if (*s)
303             *s++ = '\0';
304     }
305     *a = Nullch;
306     if (Argv[0]) {
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);
311         else
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(). */
318     } else
319         rc = -1;
320     do_execfree();
321     return rc;
322 }
323
324 int
325 do_spawn(cmd)
326 char *cmd;
327 {
328     return do_spawn2(cmd, EXECF_SPAWN);
329 }
330
331 bool
332 do_exec(cmd)
333 char *cmd;
334 {
335     return do_spawn2(cmd, EXECF_EXEC);
336 }
337
338 bool
339 os2exec(cmd)
340 char *cmd;
341 {
342     return do_spawn2(cmd, EXECF_TRUEEXEC);
343 }
344
345 #ifndef HAS_FORK
346 FILE *
347 my_popen(cmd,mode)
348 char    *cmd;
349 char    *mode;
350 {
351 #ifdef TRYSHELL
352     return popen(cmd, mode);
353 #else
354     char *shell = getenv("EMXSHELL");
355     FILE *res;
356     
357     my_setenv("EMXSHELL", SH_PATH);
358     res = popen(cmd, mode);
359     my_setenv("EMXSHELL", shell);
360     return res;
361 #endif 
362 }
363 #endif
364
365 /*****************************************************************************/
366
367 #ifndef HAS_FORK
368 int
369 fork(void)
370 {
371     die(no_func, "Unsupported function fork");
372     errno = EINVAL;
373     return -1;
374 }
375 #endif
376
377 /*****************************************************************************/
378 /* not implemented in EMX 0.9a */
379
380 void *  ctermid(x)      { return 0; }
381
382 #ifdef MYTTYNAME /* was not in emx0.9a */
383 void *  ttyname(x)      { return 0; }
384 #endif
385
386 /*****************************************************************************/
387 /* my socket forwarders - EMX lib only provides static forwarders */
388
389 static HMODULE htcp = 0;
390
391 static void *
392 tcp0(char *name)
393 {
394     static BYTE buf[20];
395     PFN fcn;
396     if (!htcp)
397         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
398     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
399         return (void *) ((void * (*)(void)) fcn) ();
400     return 0;
401 }
402
403 static void
404 tcp1(char *name, int arg)
405 {
406     static BYTE buf[20];
407     PFN fcn;
408     if (!htcp)
409         DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
410     if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
411         ((void (*)(int)) fcn) (arg);
412 }
413
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");  }
426
427 /*****************************************************************************/
428 /* not implemented in C Set++ */
429
430 #ifndef __EMX__
431 int     setuid(x)       { errno = EINVAL; return -1; }
432 int     setgid(x)       { errno = EINVAL; return -1; }
433 #endif
434
435 /*****************************************************************************/
436 /* stat() hack for char/block device */
437
438 #if OS2_STAT_HACK
439
440     /* First attempt used DosQueryFSAttach which crashed the system when
441        used with 5.001. Now just look for /dev/. */
442
443 int
444 os2_stat(char *name, struct stat *st)
445 {
446     static int ino = SHRT_MAX;
447
448     if (stricmp(name, "/dev/con") != 0
449      && stricmp(name, "/dev/tty") != 0)
450         return stat(name, st);
451
452     memset(st, 0, sizeof *st);
453     st->st_mode = S_IFCHR|0666;
454     st->st_ino = (ino-- & 0x7FFF);
455     st->st_nlink = 1;
456     return 0;
457 }
458
459 #endif
460
461 #ifdef USE_PERL_SBRK
462
463 /* SBRK() emulation, mostly moved to malloc.c. */
464
465 void *
466 sys_alloc(int size) {
467     void *got;
468     APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
469
470     if (rc == ERROR_NOT_ENOUGH_MEMORY) {
471         return (void *) -1;
472     } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
473     return got;
474 }
475
476 #endif /* USE_PERL_SBRK */
477
478 /* tmp path */
479
480 char *tmppath = TMPPATH1;
481
482 void
483 settmppath()
484 {
485     char *p = getenv("TMP"), *tpath;
486     int len;
487
488     if (!p) p = getenv("TEMP");
489     if (!p) return;
490     len = strlen(p);
491     tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
492     strcpy(tpath, p);
493     tpath[len] = '/';
494     strcpy(tpath + len + 1, TMPPATH1);
495     tmppath = tpath;
496 }
497
498 #include "XSUB.h"
499
500 XS(XS_File__Copy_syscopy)
501 {
502     dXSARGS;
503     if (items < 2 || items > 3)
504         croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
505     {
506         char *  src = (char *)SvPV(ST(0),na);
507         char *  dst = (char *)SvPV(ST(1),na);
508         U32     flag;
509         int     RETVAL, rc;
510
511         if (items < 3)
512             flag = 0;
513         else {
514             flag = (unsigned long)SvIV(ST(2));
515         }
516
517         RETVAL = !CheckOSError(DosCopy(src, dst, flag));
518         ST(0) = sv_newmortal();
519         sv_setiv(ST(0), (IV)RETVAL);
520     }
521     XSRETURN(1);
522 }
523
524 char *
525 mod2fname(sv)
526      SV   *sv;
527 {
528     static char fname[9];
529     int pos = 6, len, avlen;
530     unsigned int sum = 0;
531     AV  *av;
532     SV  *svp;
533     char *s;
534
535     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
536     sv = SvRV(sv);
537     if (SvTYPE(sv) != SVt_PVAV) 
538       croak("Not array reference given to mod2fname");
539
540     avlen = av_len((AV*)sv);
541     if (avlen < 0) 
542       croak("Empty array reference given to mod2fname");
543
544     s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
545     strncpy(fname, s, 8);
546     len = strlen(s);
547     if (len < 6) pos = len;
548     while (*s) {
549         sum = 33 * sum + *(s++);        /* Checksumming first chars to
550                                          * get the capitalization into c.s. */
551     }
552     avlen --;
553     while (avlen >= 0) {
554         s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
555         while (*s) {
556             sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
557         }
558         avlen --;
559     }
560     fname[pos] = 'A' + (sum % 26);
561     fname[pos + 1] = 'A' + (sum / 26 % 26);
562     fname[pos + 2] = '\0';
563     return (char *)fname;
564 }
565
566 XS(XS_DynaLoader_mod2fname)
567 {
568     dXSARGS;
569     if (items != 1)
570         croak("Usage: DynaLoader::mod2fname(sv)");
571     {
572         SV *    sv = ST(0);
573         char *  RETVAL;
574
575         RETVAL = mod2fname(sv);
576         ST(0) = sv_newmortal();
577         sv_setpv((SV*)ST(0), RETVAL);
578     }
579     XSRETURN(1);
580 }
581
582 char *
583 os2error(int rc)
584 {
585         static char buf[300];
586         ULONG len;
587
588         if (rc == 0)
589                 return NULL;
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);
592         else
593                 buf[len] = '\0';
594         return buf;
595 }
596
597 OS2_Perl_data_t OS2_Perl_data;
598
599 int
600 Xs_OS2_init()
601 {
602     char *file = __FILE__;
603     {
604         GV *gv;
605         
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);
609         GvMULTI_on(gv);
610 #ifdef PERL_IS_AOUT
611         sv_setiv(GvSV(gv), 1);
612 #endif 
613     }
614 }
615
616 void
617 Perl_OS2_init()
618 {
619     char *shell;
620
621     settmppath();
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] == '\\') {
628             l--;
629         }
630         if (l > STATIC_FILE_LENGTH - 7) {
631             die("PERL_SH_DIR too long");
632         }
633         strncpy(sh_path, shell, l);
634         strcpy(sh_path + l, "/sh.exe");
635     }
636 }
637
638 char sh_path[STATIC_FILE_LENGTH+1] = SH_PATH_INI;
639
640 char *
641 perllib_mangle(char *s, unsigned int l)
642 {
643     static char *newp, *oldp;
644     static int newl, oldl, notfound;
645     static char ret[STATIC_FILE_LENGTH+1];
646     
647     if (!newp && !notfound) {
648         newp = getenv("PERLLIB_PREFIX");
649         if (newp) {
650             oldp = newp;
651             while (*newp && !isSPACE(*newp) && *newp != ';') {
652                 newp++; oldl++;         /* Skip digits. */
653             }
654             while (*newp && (isSPACE(*newp) || *newp == ';')) {
655                 newp++;                 /* Skip whitespace. */
656             }
657             newl = strlen(newp);
658             if (newl == 0 || oldl == 0) {
659                 die("Malformed PERLLIB_PREFIX");
660             }
661         } else {
662             notfound = 1;
663         }
664     }
665     if (!newp) {
666         return s;
667     }
668     if (l == 0) {
669         l = strlen(s);
670     }
671     if (l <= oldl || strnicmp(oldp, s, oldl) != 0) {
672         return s;
673     }
674     if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
675         die("Malformed PERLLIB_PREFIX");
676     }
677     strncpy(ret, newp, newl);
678     strcpy(ret + newl, s + oldl);
679     return ret;
680 }
681
682 extern void dlopen();
683 void *fakedl = &dlopen;         /* Pull in dynaloading part. */