source: trunk/third/perl/os2/os2.c @ 10724

Revision 10724, 29.9 KB checked in by ghudson, 27 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r10723, which included commits to RCS files with non-trunk default branches.
Line 
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#include <fcntl.h>
17
18#include "EXTERN.h"
19#include "perl.h"
20
21/*****************************************************************************/
22/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
23static PFN ExtFCN[2];                   /* Labeled by ord below. */
24static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
25#define ORD_QUERY_ELP   0
26#define ORD_SET_ELP     1
27
28APIRET
29loadByOrd(ULONG ord)
30{
31    if (ExtFCN[ord] == NULL) {
32        static HMODULE hdosc = 0;
33        BYTE buf[20];
34        PFN fcn;
35        APIRET rc;
36
37        if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
38                                                  "doscalls", &hdosc)))
39            || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
40            die("This version of OS/2 does not support doscalls.%i",
41                loadOrd[ord]);
42        ExtFCN[ord] = fcn;
43    }
44    if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
45}
46
47/* priorities */
48static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
49                                               self inverse. */
50#define QSS_INI_BUFFER 1024
51
52PQTOPLEVEL
53get_sysinfo(ULONG pid, ULONG flags)
54{
55    char *pbuffer;
56    ULONG rc, buf_len = QSS_INI_BUFFER;
57
58    New(1322, pbuffer, buf_len, char);
59    /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
60    rc = QuerySysState(flags, pid, pbuffer, buf_len);
61    while (rc == ERROR_BUFFER_OVERFLOW) {
62        Renew(pbuffer, buf_len *= 2, char);
63        rc = QuerySysState(flags, pid, pbuffer, buf_len);
64    }
65    if (rc) {
66        FillOSError(rc);
67        Safefree(pbuffer);
68        return 0;
69    }
70    return (PQTOPLEVEL)pbuffer;
71}
72
73#define PRIO_ERR 0x1111
74
75static ULONG
76sys_prio(pid)
77{
78  ULONG prio;
79  PQTOPLEVEL psi;
80
81  psi = get_sysinfo(pid, QSS_PROCESS);
82  if (!psi) {
83      return PRIO_ERR;
84  }
85  if (pid != psi->procdata->pid) {
86      Safefree(psi);
87      croak("panic: wrong pid in sysinfo");
88  }
89  prio = psi->procdata->threads->priority;
90  Safefree(psi);
91  return prio;
92}
93
94int
95setpriority(int which, int pid, int val)
96{
97  ULONG rc, prio;
98  PQTOPLEVEL psi;
99
100  prio = sys_prio(pid);
101
102  if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
103  if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
104      /* Do not change class. */
105      return CheckOSError(DosSetPriority((pid < 0)
106                                         ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
107                                         0,
108                                         (32 - val) % 32 - (prio & 0xFF),
109                                         abs(pid)))
110      ? -1 : 0;
111  } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
112      /* Documentation claims one can change both class and basevalue,
113       * but I find it wrong. */
114      /* Change class, but since delta == 0 denotes absolute 0, correct. */
115      if (CheckOSError(DosSetPriority((pid < 0)
116                                      ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
117                                      priors[(32 - val) >> 5] + 1,
118                                      0,
119                                      abs(pid))))
120          return -1;
121      if ( ((32 - val) % 32) == 0 ) return 0;
122      return CheckOSError(DosSetPriority((pid < 0)
123                                         ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
124                                         0,
125                                         (32 - val) % 32,
126                                         abs(pid)))
127          ? -1 : 0;
128  }
129/*   else return CheckOSError(DosSetPriority((pid < 0)  */
130/*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
131/*                                        priors[(32 - val) >> 5] + 1,  */
132/*                                        (32 - val) % 32 - (prio & 0xFF),  */
133/*                                        abs(pid))) */
134/*       ? -1 : 0; */
135}
136
137int
138getpriority(int which /* ignored */, int pid)
139{
140  TIB *tib;
141  PIB *pib;
142  ULONG rc, ret;
143
144  if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
145  /* DosGetInfoBlocks has old priority! */
146/*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
147/*   if (pid != pib->pib_ulpid) { */
148  ret = sys_prio(pid);
149  if (ret == PRIO_ERR) {
150      return -1;
151  }
152/*   } else */
153/*       ret = tib->tib_ptib2->tib2_ulpri; */
154  return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
155}
156
157/*****************************************************************************/
158/* spawn */
159typedef void (*Sigfunc) _((int));
160
161static int
162result(int flag, int pid)
163{
164        int r, status;
165        Signal_t (*ihand)();     /* place to save signal during system() */
166        Signal_t (*qhand)();     /* place to save signal during system() */
167#ifndef __EMX__
168        RESULTCODES res;
169        int rpid;
170#endif
171
172        if (pid < 0 || flag != 0)
173                return pid;
174
175#ifdef __EMX__
176        ihand = rsignal(SIGINT, SIG_IGN);
177        qhand = rsignal(SIGQUIT, SIG_IGN);
178        do {
179            r = wait4pid(pid, &status, 0);
180        } while (r == -1 && errno == EINTR);
181        rsignal(SIGINT, ihand);
182        rsignal(SIGQUIT, qhand);
183
184        statusvalue = (U16)status;
185        if (r < 0)
186                return -1;
187        return status & 0xFFFF;
188#else
189        ihand = rsignal(SIGINT, SIG_IGN);
190        r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
191        rsignal(SIGINT, ihand);
192        statusvalue = res.codeResult << 8 | res.codeTerminate;
193        if (r)
194                return -1;
195        return statusvalue;
196#endif
197}
198
199int
200do_aspawn(really,mark,sp)
201SV *really;
202register SV **mark;
203register SV **sp;
204{
205    register char **a;
206    char *tmps = NULL;
207    int rc;
208    int flag = P_WAIT, trueflag, err, secondtry = 0;
209
210    if (sp > mark) {
211        New(1301,Argv, sp - mark + 3, char*);
212        a = Argv;
213
214        if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
215                ++mark;
216                flag = SvIVx(*mark);
217        }
218
219        while (++mark <= sp) {
220            if (*mark)
221                *a++ = SvPVx(*mark, na);
222            else
223                *a++ = "";
224        }
225        *a = Nullch;
226
227        trueflag = flag;
228        if (flag == P_WAIT)
229                flag = P_NOWAIT;
230
231        if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
232
233        if (Argv[0][0] != '/' && Argv[0][0] != '\\'
234            && !(Argv[0][0] && Argv[0][1] == ':'
235                 && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
236            ) /* will swawnvp use PATH? */
237            TAINT_ENV();        /* testing IFS here is overkill, probably */
238        /* We should check PERL_SH* and PERLLIB_* as well? */
239      retry:
240        if (really && *(tmps = SvPV(really, na)))
241            rc = result(trueflag, spawnvp(flag,tmps,Argv));
242        else
243            rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
244
245        if (rc < 0 && secondtry == 0
246            && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */
247            err = errno;
248            if (err == ENOENT) {        /* No such file. */
249                /* One reason may be that EMX added .exe. We suppose
250                   that .exe-less files are automatically shellable. */
251                char *no_dir;
252                (no_dir = strrchr(Argv[0], '/'))
253                    || (no_dir = strrchr(Argv[0], '\\'))
254                    || (no_dir = Argv[0]);
255                if (!strchr(no_dir, '.')) {
256                    struct stat buffer;
257                    if (stat(Argv[0], &buffer) != -1) { /* File exists. */
258                        /* Maybe we need to specify the full name here? */
259                        goto doshell;
260                    }
261                }
262            } else if (err == ENOEXEC) { /* Need to send to shell. */
263              doshell:
264                while (a >= Argv) {
265                    *(a + 2) = *a;
266                    a--;
267                }
268                *Argv = sh_path;
269                *(Argv + 1) = "-c";
270                secondtry = 1;
271                goto retry;
272            }
273        }
274        if (rc < 0 && dowarn)
275            warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
276        if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
277    } else
278        rc = -1;
279    do_execfree();
280    return rc;
281}
282
283#define EXECF_SPAWN 0
284#define EXECF_EXEC 1
285#define EXECF_TRUEEXEC 2
286#define EXECF_SPAWN_NOWAIT 3
287
288int
289do_spawn2(cmd, execf)
290char *cmd;
291int execf;
292{
293    register char **a;
294    register char *s;
295    char flags[10];
296    char *shell, *copt, *news = NULL;
297    int rc, added_shell = 0, err, seenspace = 0;
298    char fullcmd[MAXNAMLEN + 1];
299
300#ifdef TRYSHELL
301    if ((shell = getenv("EMXSHELL")) != NULL)
302        copt = "-c";
303    else if ((shell = getenv("SHELL")) != NULL)
304        copt = "-c";
305    else if ((shell = getenv("COMSPEC")) != NULL)
306        copt = "/C";
307    else
308        shell = "cmd.exe";
309#else
310    /* Consensus on perl5-porters is that it is _very_ important to
311       have a shell which will not change between computers with the
312       same architecture, to avoid "action on a distance".
313       And to have simple build, this shell should be sh. */
314    shell = sh_path;
315    copt = "-c";
316#endif
317
318    while (*cmd && isSPACE(*cmd))
319        cmd++;
320
321    if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
322        STRLEN l = strlen(sh_path);
323       
324        New(1302, news, strlen(cmd) - 7 + l + 1, char);
325        strcpy(news, sh_path);
326        strcpy(news + l, cmd + 7);
327        cmd = news;
328        added_shell = 1;
329    }
330
331    /* save an extra exec if possible */
332    /* see if there are shell metacharacters in it */
333
334    if (*cmd == '.' && isSPACE(cmd[1]))
335        goto doshell;
336
337    if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
338        goto doshell;
339
340    for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
341    if (*s == '=')
342        goto doshell;
343
344    for (s = cmd; *s; s++) {
345        if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
346            if (*s == '\n' && s[1] == '\0') {
347                *s = '\0';
348                break;
349            } else if (*s == '\\' && !seenspace) {
350                continue;               /* Allow backslashes in names */
351            }
352          doshell:
353            if (execf == EXECF_TRUEEXEC)
354                return execl(shell,shell,copt,cmd,(char*)0);
355            else if (execf == EXECF_EXEC)
356                return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
357            else if (execf == EXECF_SPAWN_NOWAIT)
358                return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
359            /* In the ak code internal P_NOWAIT is P_WAIT ??? */
360            rc = result(P_WAIT,
361                        spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
362            if (rc < 0 && dowarn)
363                warn("Can't %s \"%s\": %s",
364                     (execf == EXECF_SPAWN ? "spawn" : "exec"),
365                     shell, Strerror(errno));
366            if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
367            if (news) Safefree(news);
368            return rc;
369        } else if (*s == ' ' || *s == '\t') {
370            seenspace = 1;
371        }
372    }
373
374    New(1303,Argv, (s - cmd) / 2 + 2, char*);
375    Cmd = savepvn(cmd, s-cmd);
376    a = Argv;
377    for (s = Cmd; *s;) {
378        while (*s && isSPACE(*s)) s++;
379        if (*s)
380            *(a++) = s;
381        while (*s && !isSPACE(*s)) s++;
382        if (*s)
383            *s++ = '\0';
384    }
385    *a = Nullch;
386    if (Argv[0]) {
387        int err;
388       
389        if (execf == EXECF_TRUEEXEC)
390            rc = execvp(Argv[0],Argv);
391        else if (execf == EXECF_EXEC)
392            rc = spawnvp(P_OVERLAY,Argv[0],Argv);
393        else if (execf == EXECF_SPAWN_NOWAIT)
394            rc = spawnvp(P_NOWAIT,Argv[0],Argv);
395        else
396            rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
397        if (rc < 0) {
398            err = errno;
399            if (err == ENOENT) {        /* No such file. */
400                /* One reason may be that EMX added .exe. We suppose
401                   that .exe-less files are automatically shellable. */
402                char *no_dir;
403                (no_dir = strrchr(Argv[0], '/'))
404                    || (no_dir = strrchr(Argv[0], '\\'))
405                    || (no_dir = Argv[0]);
406                if (!strchr(no_dir, '.')) {
407                    struct stat buffer;
408                    if (stat(Argv[0], &buffer) != -1) { /* File exists. */
409                        /* Maybe we need to specify the full name here? */
410                        goto doshell;
411                    }
412                }
413            } else if (err == ENOEXEC) { /* Need to send to shell. */
414                goto doshell;
415            }
416        }
417        if (rc < 0 && dowarn)
418            warn("Can't %s \"%s\": %s",
419                 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
420                  ? "spawn" : "exec"),
421                 Argv[0], Strerror(err));
422        if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
423    } else
424        rc = -1;
425    if (news) Safefree(news);
426    do_execfree();
427    return rc;
428}
429
430int
431do_spawn(cmd)
432char *cmd;
433{
434    return do_spawn2(cmd, EXECF_SPAWN);
435}
436
437int
438do_spawn_nowait(cmd)
439char *cmd;
440{
441    return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
442}
443
444bool
445do_exec(cmd)
446char *cmd;
447{
448    return do_spawn2(cmd, EXECF_EXEC);
449}
450
451bool
452os2exec(cmd)
453char *cmd;
454{
455    return do_spawn2(cmd, EXECF_TRUEEXEC);
456}
457
458PerlIO *
459my_syspopen(cmd,mode)
460char    *cmd;
461char    *mode;
462{
463#ifndef USE_POPEN
464
465    int p[2];
466    register I32 this, that, newfd;
467    register I32 pid, rc;
468    PerlIO *res;
469    SV *sv;
470   
471    if (pipe(p) < 0)
472        return Nullfp;
473    /* `this' is what we use in the parent, `that' in the child. */
474    this = (*mode == 'w');
475    that = !this;
476    if (tainting) {
477        taint_env();
478        taint_proper("Insecure %s%s", "EXEC");
479    }
480    /* Now we need to spawn the child. */
481    newfd = dup(*mode == 'r');          /* Preserve std* */
482    if (p[that] != (*mode == 'r')) {
483        dup2(p[that], *mode == 'r');
484        close(p[that]);
485    }
486    /* Where is `this' and newfd now? */
487    fcntl(p[this], F_SETFD, FD_CLOEXEC);
488    fcntl(newfd, F_SETFD, FD_CLOEXEC);
489    pid = do_spawn_nowait(cmd);
490    if (newfd != (*mode == 'r')) {
491        dup2(newfd, *mode == 'r');      /* Return std* back. */
492        close(newfd);
493    }
494    close(p[that]);
495    if (pid == -1) {
496        close(p[this]);
497        return NULL;
498    }
499    if (p[that] < p[this]) {
500        dup2(p[this], p[that]);
501        close(p[this]);
502        p[this] = p[that];
503    }
504    sv = *av_fetch(fdpid,p[this],TRUE);
505    (void)SvUPGRADE(sv,SVt_IV);
506    SvIVX(sv) = pid;
507    forkprocess = pid;
508    return PerlIO_fdopen(p[this], mode);
509
510#else  /* USE_POPEN */
511
512    PerlIO *res;
513    SV *sv;
514
515#  ifdef TRYSHELL
516    res = popen(cmd, mode);
517#  else
518    char *shell = getenv("EMXSHELL");
519
520    my_setenv("EMXSHELL", sh_path);
521    res = popen(cmd, mode);
522    my_setenv("EMXSHELL", shell);
523#  endif
524    sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
525    (void)SvUPGRADE(sv,SVt_IV);
526    SvIVX(sv) = -1;                     /* A cooky. */
527    return res;
528
529#endif /* USE_POPEN */
530
531}
532
533/******************************************************************/
534
535#ifndef HAS_FORK
536int
537fork(void)
538{
539    die(no_func, "Unsupported function fork");
540    errno = EINVAL;
541    return -1;
542}
543#endif
544
545/*******************************************************************/
546/* not implemented in EMX 0.9a */
547
548void *  ctermid(x)      { return 0; }
549
550#ifdef MYTTYNAME /* was not in emx0.9a */
551void *  ttyname(x)      { return 0; }
552#endif
553
554/******************************************************************/
555/* my socket forwarders - EMX lib only provides static forwarders */
556
557static HMODULE htcp = 0;
558
559static void *
560tcp0(char *name)
561{
562    static BYTE buf[20];
563    PFN fcn;
564
565    if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
566    if (!htcp)
567        DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
568    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
569        return (void *) ((void * (*)(void)) fcn) ();
570    return 0;
571}
572
573static void
574tcp1(char *name, int arg)
575{
576    static BYTE buf[20];
577    PFN fcn;
578
579    if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
580    if (!htcp)
581        DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
582    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
583        ((void (*)(int)) fcn) (arg);
584}
585
586void *  gethostent()    { return tcp0("GETHOSTENT");  }
587void *  getnetent()     { return tcp0("GETNETENT");   }
588void *  getprotoent()   { return tcp0("GETPROTOENT"); }
589void *  getservent()    { return tcp0("GETSERVENT");  }
590void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
591void    setnetent(x)    { tcp1("SETNETENT",   x); }
592void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
593void    setservent(x)   { tcp1("SETSERVENT",  x); }
594void    endhostent()    { tcp0("ENDHOSTENT");  }
595void    endnetent()     { tcp0("ENDNETENT");   }
596void    endprotoent()   { tcp0("ENDPROTOENT"); }
597void    endservent()    { tcp0("ENDSERVENT");  }
598
599/*****************************************************************************/
600/* not implemented in C Set++ */
601
602#ifndef __EMX__
603int     setuid(x)       { errno = EINVAL; return -1; }
604int     setgid(x)       { errno = EINVAL; return -1; }
605#endif
606
607/*****************************************************************************/
608/* stat() hack for char/block device */
609
610#if OS2_STAT_HACK
611
612    /* First attempt used DosQueryFSAttach which crashed the system when
613       used with 5.001. Now just look for /dev/. */
614
615int
616os2_stat(char *name, struct stat *st)
617{
618    static int ino = SHRT_MAX;
619
620    if (stricmp(name, "/dev/con") != 0
621     && stricmp(name, "/dev/tty") != 0)
622        return stat(name, st);
623
624    memset(st, 0, sizeof *st);
625    st->st_mode = S_IFCHR|0666;
626    st->st_ino = (ino-- & 0x7FFF);
627    st->st_nlink = 1;
628    return 0;
629}
630
631#endif
632
633#ifdef USE_PERL_SBRK
634
635/* SBRK() emulation, mostly moved to malloc.c. */
636
637void *
638sys_alloc(int size) {
639    void *got;
640    APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
641
642    if (rc == ERROR_NOT_ENOUGH_MEMORY) {
643        return (void *) -1;
644    } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
645    return got;
646}
647
648#endif /* USE_PERL_SBRK */
649
650/* tmp path */
651
652char *tmppath = TMPPATH1;
653
654void
655settmppath()
656{
657    char *p = getenv("TMP"), *tpath;
658    int len;
659
660    if (!p) p = getenv("TEMP");
661    if (!p) return;
662    len = strlen(p);
663    tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
664    strcpy(tpath, p);
665    tpath[len] = '/';
666    strcpy(tpath + len + 1, TMPPATH1);
667    tmppath = tpath;
668}
669
670#include "XSUB.h"
671
672XS(XS_File__Copy_syscopy)
673{
674    dXSARGS;
675    if (items < 2 || items > 3)
676        croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
677    {
678        char *  src = (char *)SvPV(ST(0),na);
679        char *  dst = (char *)SvPV(ST(1),na);
680        U32     flag;
681        int     RETVAL, rc;
682
683        if (items < 3)
684            flag = 0;
685        else {
686            flag = (unsigned long)SvIV(ST(2));
687        }
688
689        RETVAL = !CheckOSError(DosCopy(src, dst, flag));
690        ST(0) = sv_newmortal();
691        sv_setiv(ST(0), (IV)RETVAL);
692    }
693    XSRETURN(1);
694}
695
696char *
697mod2fname(sv)
698     SV   *sv;
699{
700    static char fname[9];
701    int pos = 6, len, avlen;
702    unsigned int sum = 0;
703    AV  *av;
704    SV  *svp;
705    char *s;
706
707    if (!SvROK(sv)) croak("Not a reference given to mod2fname");
708    sv = SvRV(sv);
709    if (SvTYPE(sv) != SVt_PVAV)
710      croak("Not array reference given to mod2fname");
711
712    avlen = av_len((AV*)sv);
713    if (avlen < 0)
714      croak("Empty array reference given to mod2fname");
715
716    s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
717    strncpy(fname, s, 8);
718    len = strlen(s);
719    if (len < 6) pos = len;
720    while (*s) {
721        sum = 33 * sum + *(s++);        /* Checksumming first chars to
722                                         * get the capitalization into c.s. */
723    }
724    avlen --;
725    while (avlen >= 0) {
726        s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
727        while (*s) {
728            sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
729        }
730        avlen --;
731    }
732    fname[pos] = 'A' + (sum % 26);
733    fname[pos + 1] = 'A' + (sum / 26 % 26);
734    fname[pos + 2] = '\0';
735    return (char *)fname;
736}
737
738XS(XS_DynaLoader_mod2fname)
739{
740    dXSARGS;
741    if (items != 1)
742        croak("Usage: DynaLoader::mod2fname(sv)");
743    {
744        SV *    sv = ST(0);
745        char *  RETVAL;
746
747        RETVAL = mod2fname(sv);
748        ST(0) = sv_newmortal();
749        sv_setpv((SV*)ST(0), RETVAL);
750    }
751    XSRETURN(1);
752}
753
754char *
755os2error(int rc)
756{
757        static char buf[300];
758        ULONG len;
759
760        if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
761        if (rc == 0)
762                return NULL;
763        if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
764                sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
765        else
766                buf[len] = '\0';
767        return buf;
768}
769
770char *
771perllib_mangle(char *s, unsigned int l)
772{
773    static char *newp, *oldp;
774    static int newl, oldl, notfound;
775    static char ret[STATIC_FILE_LENGTH+1];
776   
777    if (!newp && !notfound) {
778        newp = getenv("PERLLIB_PREFIX");
779        if (newp) {
780            char *s;
781           
782            oldp = newp;
783            while (*newp && !isSPACE(*newp) && *newp != ';') {
784                newp++; oldl++;         /* Skip digits. */
785            }
786            while (*newp && (isSPACE(*newp) || *newp == ';')) {
787                newp++;                 /* Skip whitespace. */
788            }
789            newl = strlen(newp);
790            if (newl == 0 || oldl == 0) {
791                die("Malformed PERLLIB_PREFIX");
792            }
793            strcpy(ret, newp);
794            s = ret;
795            while (*s) {
796                if (*s == '\\') *s = '/';
797                s++;
798            }
799        } else {
800            notfound = 1;
801        }
802    }
803    if (!newp) {
804        return s;
805    }
806    if (l == 0) {
807        l = strlen(s);
808    }
809    if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
810        return s;
811    }
812    if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
813        die("Malformed PERLLIB_PREFIX");
814    }
815    strcpy(ret + newl, s + oldl);
816    return ret;
817}
818
819extern void dlopen();
820void *fakedl = &dlopen;         /* Pull in dynaloading part. */
821
822#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
823                                && ((path)[2] == '/' || (path)[2] == '\\'))
824#define sys_is_rooted _fnisabs
825#define sys_is_relative _fnisrel
826#define current_drive _getdrive
827
828#undef chdir                            /* Was _chdir2. */
829#define sys_chdir(p) (chdir(p) == 0)
830#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
831
832XS(XS_Cwd_current_drive)
833{
834    dXSARGS;
835    if (items != 0)
836        croak("Usage: Cwd::current_drive()");
837    {
838        char    RETVAL;
839
840        RETVAL = current_drive();
841        ST(0) = sv_newmortal();
842        sv_setpvn(ST(0), (char *)&RETVAL, 1);
843    }
844    XSRETURN(1);
845}
846
847XS(XS_Cwd_sys_chdir)
848{
849    dXSARGS;
850    if (items != 1)
851        croak("Usage: Cwd::sys_chdir(path)");
852    {
853        char *  path = (char *)SvPV(ST(0),na);
854        bool    RETVAL;
855
856        RETVAL = sys_chdir(path);
857        ST(0) = boolSV(RETVAL);
858        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
859    }
860    XSRETURN(1);
861}
862
863XS(XS_Cwd_change_drive)
864{
865    dXSARGS;
866    if (items != 1)
867        croak("Usage: Cwd::change_drive(d)");
868    {
869        char    d = (char)*SvPV(ST(0),na);
870        bool    RETVAL;
871
872        RETVAL = change_drive(d);
873        ST(0) = boolSV(RETVAL);
874        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
875    }
876    XSRETURN(1);
877}
878
879XS(XS_Cwd_sys_is_absolute)
880{
881    dXSARGS;
882    if (items != 1)
883        croak("Usage: Cwd::sys_is_absolute(path)");
884    {
885        char *  path = (char *)SvPV(ST(0),na);
886        bool    RETVAL;
887
888        RETVAL = sys_is_absolute(path);
889        ST(0) = boolSV(RETVAL);
890        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
891    }
892    XSRETURN(1);
893}
894
895XS(XS_Cwd_sys_is_rooted)
896{
897    dXSARGS;
898    if (items != 1)
899        croak("Usage: Cwd::sys_is_rooted(path)");
900    {
901        char *  path = (char *)SvPV(ST(0),na);
902        bool    RETVAL;
903
904        RETVAL = sys_is_rooted(path);
905        ST(0) = boolSV(RETVAL);
906        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
907    }
908    XSRETURN(1);
909}
910
911XS(XS_Cwd_sys_is_relative)
912{
913    dXSARGS;
914    if (items != 1)
915        croak("Usage: Cwd::sys_is_relative(path)");
916    {
917        char *  path = (char *)SvPV(ST(0),na);
918        bool    RETVAL;
919
920        RETVAL = sys_is_relative(path);
921        ST(0) = boolSV(RETVAL);
922        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
923    }
924    XSRETURN(1);
925}
926
927XS(XS_Cwd_sys_cwd)
928{
929    dXSARGS;
930    if (items != 0)
931        croak("Usage: Cwd::sys_cwd()");
932    {
933        char p[MAXPATHLEN];
934        char *  RETVAL;
935        RETVAL = _getcwd2(p, MAXPATHLEN);
936        ST(0) = sv_newmortal();
937        sv_setpv((SV*)ST(0), RETVAL);
938    }
939    XSRETURN(1);
940}
941
942XS(XS_Cwd_sys_abspath)
943{
944    dXSARGS;
945    if (items < 1 || items > 2)
946        croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
947    {
948        char *  path = (char *)SvPV(ST(0),na);
949        char *  dir;
950        char p[MAXPATHLEN];
951        char *  RETVAL;
952
953        if (items < 2)
954            dir = NULL;
955        else {
956            dir = (char *)SvPV(ST(1),na);
957        }
958        if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
959            path += 2;
960        }
961        if (dir == NULL) {
962            if (_abspath(p, path, MAXPATHLEN) == 0) {
963                RETVAL = p;
964            } else {
965                RETVAL = NULL;
966            }
967        } else {
968            /* Absolute with drive: */
969            if ( sys_is_absolute(path) ) {
970                if (_abspath(p, path, MAXPATHLEN) == 0) {
971                    RETVAL = p;
972                } else {
973                    RETVAL = NULL;
974                }
975            } else if (path[0] == '/' || path[0] == '\\') {
976                /* Rooted, but maybe on different drive. */
977                if (isALPHA(dir[0]) && dir[1] == ':' ) {
978                    char p1[MAXPATHLEN];
979
980                    /* Need to prepend the drive. */
981                    p1[0] = dir[0];
982                    p1[1] = dir[1];
983                    Copy(path, p1 + 2, strlen(path) + 1, char);
984                    RETVAL = p;
985                    if (_abspath(p, p1, MAXPATHLEN) == 0) {
986                        RETVAL = p;
987                    } else {
988                        RETVAL = NULL;
989                    }
990                } else if (_abspath(p, path, MAXPATHLEN) == 0) {
991                    RETVAL = p;
992                } else {
993                    RETVAL = NULL;
994                }
995            } else {
996                /* Either path is relative, or starts with a drive letter. */
997                /* If the path starts with a drive letter, then dir is
998                   relevant only if
999                   a/b) it is absolute/x:relative on the same drive. 
1000                   c)   path is on current drive, and dir is rooted
1001                   In all the cases it is safe to drop the drive part
1002                   of the path. */
1003                if ( !sys_is_relative(path) ) {
1004                    int is_drived;
1005
1006                    if ( ( ( sys_is_absolute(dir)
1007                             || (isALPHA(dir[0]) && dir[1] == ':'
1008                                 && strnicmp(dir, path,1) == 0))
1009                           && strnicmp(dir, path,1) == 0)
1010                         || ( !(isALPHA(dir[0]) && dir[1] == ':')
1011                              && toupper(path[0]) == current_drive())) {
1012                        path += 2;
1013                    } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1014                        RETVAL = p; goto done;
1015                    } else {
1016                        RETVAL = NULL; goto done;
1017                    }
1018                }
1019                {
1020                    /* Need to prepend the absolute path of dir. */
1021                    char p1[MAXPATHLEN];
1022
1023                    if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1024                        int l = strlen(p1);
1025
1026                        if (p1[ l - 1 ] != '/') {
1027                            p1[ l ] = '/';
1028                            l++;
1029                        }
1030                        Copy(path, p1 + l, strlen(path) + 1, char);
1031                        if (_abspath(p, p1, MAXPATHLEN) == 0) {
1032                            RETVAL = p;
1033                        } else {
1034                            RETVAL = NULL;
1035                        }
1036                    } else {
1037                        RETVAL = NULL;
1038                    }
1039                }
1040              done:
1041            }
1042        }
1043        ST(0) = sv_newmortal();
1044        sv_setpv((SV*)ST(0), RETVAL);
1045    }
1046    XSRETURN(1);
1047}
1048typedef APIRET (*PELP)(PSZ path, ULONG type);
1049
1050APIRET
1051ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1052{
1053    loadByOrd(ord);                     /* Guarantied to load or die! */
1054    return (*(PELP)ExtFCN[ord])(path, type);
1055}
1056
1057#define extLibpath(type)                                                \
1058    (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1059                                                 : BEGIN_LIBPATH)))     \
1060     ? NULL : to )
1061
1062#define extLibpath_set(p,type)                                  \
1063    (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1064                                                 : BEGIN_LIBPATH))))
1065
1066XS(XS_Cwd_extLibpath)
1067{
1068    dXSARGS;
1069    if (items < 0 || items > 1)
1070        croak("Usage: Cwd::extLibpath(type = 0)");
1071    {
1072        bool    type;
1073        char    to[1024];
1074        U32     rc;
1075        char *  RETVAL;
1076
1077        if (items < 1)
1078            type = 0;
1079        else {
1080            type = (int)SvIV(ST(0));
1081        }
1082
1083        RETVAL = extLibpath(type);
1084        ST(0) = sv_newmortal();
1085        sv_setpv((SV*)ST(0), RETVAL);
1086    }
1087    XSRETURN(1);
1088}
1089
1090XS(XS_Cwd_extLibpath_set)
1091{
1092    dXSARGS;
1093    if (items < 1 || items > 2)
1094        croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1095    {
1096        char *  s = (char *)SvPV(ST(0),na);
1097        bool    type;
1098        U32     rc;
1099        bool    RETVAL;
1100
1101        if (items < 2)
1102            type = 0;
1103        else {
1104            type = (int)SvIV(ST(1));
1105        }
1106
1107        RETVAL = extLibpath_set(s, type);
1108        ST(0) = boolSV(RETVAL);
1109        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1110    }
1111    XSRETURN(1);
1112}
1113
1114int
1115Xs_OS2_init()
1116{
1117    char *file = __FILE__;
1118    {
1119        GV *gv;
1120
1121        if (_emx_env & 0x200) { /* OS/2 */
1122            newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1123            newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1124            newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1125        }
1126        newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1127        newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1128        newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1129        newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1130        newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1131        newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1132        newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1133        newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1134        newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1135        gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1136        GvMULTI_on(gv);
1137#ifdef PERL_IS_AOUT
1138        sv_setiv(GvSV(gv), 1);
1139#endif
1140    }
1141}
1142
1143OS2_Perl_data_t OS2_Perl_data;
1144
1145void
1146Perl_OS2_init(char **env)
1147{
1148    char *shell;
1149
1150    settmppath();
1151    OS2_Perl_data.xs_init = &Xs_OS2_init;
1152    if (environ == NULL) {
1153        environ = env;
1154    }
1155    if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1156        New(1304, sh_path, strlen(SH_PATH) + 1, char);
1157        strcpy(sh_path, SH_PATH);
1158        sh_path[0] = shell[0];
1159    } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1160        int l = strlen(shell), i;
1161        if (shell[l-1] == '/' || shell[l-1] == '\\') {
1162            l--;
1163        }
1164        New(1304, sh_path, l + 8, char);
1165        strncpy(sh_path, shell, l);
1166        strcpy(sh_path + l, "/sh.exe");
1167        for (i = 0; i < l; i++) {
1168            if (sh_path[i] == '\\') sh_path[i] = '/';
1169        }
1170    }
1171}
1172
1173#undef tmpnam
1174#undef tmpfile
1175
1176char *
1177my_tmpnam (char *str)
1178{
1179    char *p = getenv("TMP"), *tpath;
1180    int len;
1181
1182    if (!p) p = getenv("TEMP");
1183    tpath = tempnam(p, "pltmp");
1184    if (str && tpath) {
1185        strcpy(str, tpath);
1186        return str;
1187    }
1188    return tpath;
1189}
1190
1191FILE *
1192my_tmpfile ()
1193{
1194    struct stat s;
1195
1196    stat(".", &s);
1197    if (s.st_mode & S_IWOTH) {
1198        return tmpfile();
1199    }
1200    return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1201                                             grants TMP. */
1202}
1203
1204#undef flock
1205
1206/* This code was contributed by Rocco Caputo. */
1207int
1208my_flock(int handle, int op)
1209{
1210  FILELOCK      rNull, rFull;
1211  ULONG         timeout, handle_type, flag_word;
1212  APIRET        rc;
1213  int           blocking, shared;
1214  static int    use_my = -1;
1215
1216  if (use_my == -1) {
1217    char *s = getenv("USE_PERL_FLOCK");
1218    if (s)
1219        use_my = atoi(s);
1220    else
1221        use_my = 1;
1222  }
1223  if (!(_emx_env & 0x200) || !use_my)
1224    return flock(handle, op);   /* Delegate to EMX. */
1225 
1226                                        // is this a file?
1227  if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1228      (handle_type & 0xFF))
1229  {
1230    errno = EBADF;
1231    return -1;
1232  }
1233                                        // set lock/unlock ranges
1234  rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1235  rFull.lRange = 0x7FFFFFFF;
1236                                        // set timeout for blocking
1237  timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1;
1238                                        // shared or exclusive?
1239  shared = (op & LOCK_SH) ? 1 : 0;
1240                                        // do not block the unlock
1241  if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1242    rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1243    switch (rc) {
1244      case 0:
1245        errno = 0;
1246        return 0;
1247      case ERROR_INVALID_HANDLE:
1248        errno = EBADF;
1249        return -1;
1250      case ERROR_SHARING_BUFFER_EXCEEDED:
1251        errno = ENOLCK;
1252        return -1;
1253      case ERROR_LOCK_VIOLATION:
1254        break;                          // not an error
1255      case ERROR_INVALID_PARAMETER:
1256      case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1257      case ERROR_READ_LOCKS_NOT_SUPPORTED:
1258        errno = EINVAL;
1259        return -1;
1260      case ERROR_INTERRUPT:
1261        errno = EINTR;
1262        return -1;
1263      default:
1264        errno = EINVAL;
1265        return -1;
1266    }
1267  }
1268                                        // lock may block
1269  if (op & (LOCK_SH | LOCK_EX)) {
1270                                        // for blocking operations
1271    for (;;) {
1272      rc =
1273        DosSetFileLocks(
1274                handle,
1275                &rNull,
1276                &rFull,
1277                timeout,
1278                shared
1279        );
1280      switch (rc) {
1281        case 0:
1282          errno = 0;
1283          return 0;
1284        case ERROR_INVALID_HANDLE:
1285          errno = EBADF;
1286          return -1;
1287        case ERROR_SHARING_BUFFER_EXCEEDED:
1288          errno = ENOLCK;
1289          return -1;
1290        case ERROR_LOCK_VIOLATION:
1291          if (!blocking) {
1292            errno = EWOULDBLOCK;
1293            return -1;
1294          }
1295          break;
1296        case ERROR_INVALID_PARAMETER:
1297        case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1298        case ERROR_READ_LOCKS_NOT_SUPPORTED:
1299          errno = EINVAL;
1300          return -1;
1301        case ERROR_INTERRUPT:
1302          errno = EINTR;
1303          return -1;
1304        default:
1305          errno = EINVAL;
1306          return -1;
1307      }
1308                                        // give away timeslice
1309      DosSleep(1);
1310    }
1311  }
1312
1313  errno = 0;
1314  return 0;
1315}
Note: See TracBrowser for help on using the repository browser.