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

Revision 14545, 52.2 KB checked in by ghudson, 24 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, 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/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
7#define INCL_DOSPROCESS
8#define SPU_DISABLESUPPRESSION          0
9#define SPU_ENABLESUPPRESSION           1
10#include <os2.h>
11
12#include <sys/uflags.h>
13
14/*
15 * Various Unix compatibility functions for OS/2
16 */
17
18#include <stdio.h>
19#include <errno.h>
20#include <limits.h>
21#include <process.h>
22#include <fcntl.h>
23
24#include "EXTERN.h"
25#include "perl.h"
26
27#ifdef USE_THREADS
28
29typedef void (*emx_startroutine)(void *);
30typedef void* (*pthreads_startroutine)(void *);
31
32enum pthreads_state {
33    pthreads_st_none = 0,
34    pthreads_st_run,
35    pthreads_st_exited,
36    pthreads_st_detached,
37    pthreads_st_waited,
38};
39const char *pthreads_states[] = {
40    "uninit",
41    "running",
42    "exited",
43    "detached",
44    "waited for",
45};
46
47typedef struct {
48    void *status;
49    perl_cond cond;
50    enum pthreads_state state;
51} thread_join_t;
52
53thread_join_t *thread_join_data;
54int thread_join_count;
55perl_mutex start_thread_mutex;
56
57int
58pthread_join(perl_os_thread tid, void **status)
59{
60    MUTEX_LOCK(&start_thread_mutex);
61    switch (thread_join_data[tid].state) {
62    case pthreads_st_exited:
63        thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
64        MUTEX_UNLOCK(&start_thread_mutex);
65        *status = thread_join_data[tid].status;
66        break;
67    case pthreads_st_waited:
68        MUTEX_UNLOCK(&start_thread_mutex);
69        croak("join with a thread with a waiter");
70        break;
71    case pthreads_st_run:
72        thread_join_data[tid].state = pthreads_st_waited;
73        COND_INIT(&thread_join_data[tid].cond);
74        MUTEX_UNLOCK(&start_thread_mutex);
75        COND_WAIT(&thread_join_data[tid].cond, NULL);   
76        COND_DESTROY(&thread_join_data[tid].cond);
77        thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
78        *status = thread_join_data[tid].status;
79        break;
80    default:
81        MUTEX_UNLOCK(&start_thread_mutex);
82        croak("join: unknown thread state: '%s'",
83              pthreads_states[thread_join_data[tid].state]);
84        break;
85    }
86    return 0;
87}
88
89void
90pthread_startit(void *arg)
91{
92    /* Thread is already started, we need to transfer control only */
93    pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
94    int tid = pthread_self();
95    void *retval;
96   
97    arg = ((void**)arg)[1];
98    if (tid >= thread_join_count) {
99        int oc = thread_join_count;
100       
101        thread_join_count = tid + 5 + tid/5;
102        if (thread_join_data) {
103            Renew(thread_join_data, thread_join_count, thread_join_t);
104            Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
105        } else {
106            Newz(1323, thread_join_data, thread_join_count, thread_join_t);
107        }
108    }
109    if (thread_join_data[tid].state != pthreads_st_none)
110        croak("attempt to reuse thread id %i", tid);
111    thread_join_data[tid].state = pthreads_st_run;
112    /* Now that we copied/updated the guys, we may release the caller... */
113    MUTEX_UNLOCK(&start_thread_mutex);
114    thread_join_data[tid].status = (*start_routine)(arg);
115    switch (thread_join_data[tid].state) {
116    case pthreads_st_waited:
117        COND_SIGNAL(&thread_join_data[tid].cond);   
118        break;
119    default:
120        thread_join_data[tid].state = pthreads_st_exited;
121        break;
122    }
123}
124
125int
126pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
127               void *(*start_routine)(void*), void *arg)
128{
129    void *args[2];
130
131    args[0] = (void*)start_routine;
132    args[1] = arg;
133
134    MUTEX_LOCK(&start_thread_mutex);
135    *tid = _beginthread(pthread_startit, /*stack*/ NULL,
136                        /*stacksize*/ 10*1024*1024, (void*)args);
137    MUTEX_LOCK(&start_thread_mutex);
138    MUTEX_UNLOCK(&start_thread_mutex);
139    return *tid ? 0 : EINVAL;
140}
141
142int
143pthread_detach(perl_os_thread tid)
144{
145    MUTEX_LOCK(&start_thread_mutex);
146    switch (thread_join_data[tid].state) {
147    case pthreads_st_waited:
148        MUTEX_UNLOCK(&start_thread_mutex);
149        croak("detach on a thread with a waiter");
150        break;
151    case pthreads_st_run:
152        thread_join_data[tid].state = pthreads_st_detached;
153        MUTEX_UNLOCK(&start_thread_mutex);
154        break;
155    default:
156        MUTEX_UNLOCK(&start_thread_mutex);
157        croak("detach: unknown thread state: '%s'",
158              pthreads_states[thread_join_data[tid].state]);
159        break;
160    }
161    return 0;
162}
163
164/* This is a very bastardized version: */
165int
166os2_cond_wait(perl_cond *c, perl_mutex *m)
167{                                               
168    int rc;
169    STRLEN n_a;
170    if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
171        croak("panic: COND_WAIT-reset: rc=%i", rc);             
172    if (m) MUTEX_UNLOCK(m);                                     
173    if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
174        && (rc != ERROR_INTERRUPT))
175        croak("panic: COND_WAIT: rc=%i", rc);           
176    if (rc == ERROR_INTERRUPT)
177        errno = EINTR;
178    if (m) MUTEX_LOCK(m);                                       
179}
180#endif
181
182/*****************************************************************************/
183/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
184static PFN ExtFCN[2];                   /* Labeled by ord below. */
185static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
186#define ORD_QUERY_ELP   0
187#define ORD_SET_ELP     1
188struct PMWIN_entries_t PMWIN_entries;
189
190APIRET
191loadByOrd(char *modname, ULONG ord)
192{
193    if (ExtFCN[ord] == NULL) {
194        static HMODULE hdosc = 0;
195        BYTE buf[20];
196        PFN fcn;
197        APIRET rc;
198
199        if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
200                                                  modname, &hdosc)))
201            || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
202            croak("This version of OS/2 does not support %s.%i",
203                  modname, loadOrd[ord]);
204        ExtFCN[ord] = fcn;
205    }
206    if ((long)ExtFCN[ord] == -1)
207        croak("panic queryaddr");
208}
209
210void
211init_PMWIN_entries(void)
212{
213    static HMODULE hpmwin = 0;
214    static const int ords[] = {
215        763,                            /* Initialize */
216        716,                            /* CreateMsgQueue */
217        726,                            /* DestroyMsgQueue */
218        918,                            /* PeekMsg */
219        915,                            /* GetMsg */
220        912,                            /* DispatchMsg */
221    };
222    BYTE buf[20];
223    int i = 0;
224    unsigned long rc;
225
226    if (hpmwin)
227        return;
228
229    if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
230        croak("This version of OS/2 does not support pmwin: error in %s", buf);
231    while (i <= 5) {
232        if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
233                                          ((PFN*)&PMWIN_entries)+i)))
234            croak("This version of OS/2 does not support pmwin.%d", ords[i]);
235        i++;
236    }
237}
238
239
240/* priorities */
241static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
242                                               self inverse. */
243#define QSS_INI_BUFFER 1024
244
245PQTOPLEVEL
246get_sysinfo(ULONG pid, ULONG flags)
247{
248    char *pbuffer;
249    ULONG rc, buf_len = QSS_INI_BUFFER;
250
251    New(1322, pbuffer, buf_len, char);
252    /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
253    rc = QuerySysState(flags, pid, pbuffer, buf_len);
254    while (rc == ERROR_BUFFER_OVERFLOW) {
255        Renew(pbuffer, buf_len *= 2, char);
256        rc = QuerySysState(flags, pid, pbuffer, buf_len);
257    }
258    if (rc) {
259        FillOSError(rc);
260        Safefree(pbuffer);
261        return 0;
262    }
263    return (PQTOPLEVEL)pbuffer;
264}
265
266#define PRIO_ERR 0x1111
267
268static ULONG
269sys_prio(pid)
270{
271  ULONG prio;
272  PQTOPLEVEL psi;
273
274  psi = get_sysinfo(pid, QSS_PROCESS);
275  if (!psi) {
276      return PRIO_ERR;
277  }
278  if (pid != psi->procdata->pid) {
279      Safefree(psi);
280      croak("panic: wrong pid in sysinfo");
281  }
282  prio = psi->procdata->threads->priority;
283  Safefree(psi);
284  return prio;
285}
286
287int
288setpriority(int which, int pid, int val)
289{
290  ULONG rc, prio;
291  PQTOPLEVEL psi;
292
293  prio = sys_prio(pid);
294
295  if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
296  if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
297      /* Do not change class. */
298      return CheckOSError(DosSetPriority((pid < 0)
299                                         ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
300                                         0,
301                                         (32 - val) % 32 - (prio & 0xFF),
302                                         abs(pid)))
303      ? -1 : 0;
304  } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
305      /* Documentation claims one can change both class and basevalue,
306       * but I find it wrong. */
307      /* Change class, but since delta == 0 denotes absolute 0, correct. */
308      if (CheckOSError(DosSetPriority((pid < 0)
309                                      ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
310                                      priors[(32 - val) >> 5] + 1,
311                                      0,
312                                      abs(pid))))
313          return -1;
314      if ( ((32 - val) % 32) == 0 ) return 0;
315      return CheckOSError(DosSetPriority((pid < 0)
316                                         ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
317                                         0,
318                                         (32 - val) % 32,
319                                         abs(pid)))
320          ? -1 : 0;
321  }
322/*   else return CheckOSError(DosSetPriority((pid < 0)  */
323/*                                        ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
324/*                                        priors[(32 - val) >> 5] + 1,  */
325/*                                        (32 - val) % 32 - (prio & 0xFF),  */
326/*                                        abs(pid))) */
327/*       ? -1 : 0; */
328}
329
330int
331getpriority(int which /* ignored */, int pid)
332{
333  TIB *tib;
334  PIB *pib;
335  ULONG rc, ret;
336
337  if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
338  /* DosGetInfoBlocks has old priority! */
339/*   if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
340/*   if (pid != pib->pib_ulpid) { */
341  ret = sys_prio(pid);
342  if (ret == PRIO_ERR) {
343      return -1;
344  }
345/*   } else */
346/*       ret = tib->tib_ptib2->tib2_ulpri; */
347  return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
348}
349
350/*****************************************************************************/
351/* spawn */
352
353/* There is no big sense to make it thread-specific, since signals
354   are delivered to thread 1 only.  XXXX Maybe make it into an array? */
355static int spawn_pid;
356static int spawn_killed;
357
358static Signal_t
359spawn_sighandler(int sig)
360{
361    /* Some programs do not arrange for the keyboard signals to be
362       delivered to them.  We need to deliver the signal manually. */
363    /* We may get a signal only if
364       a) kid does not receive keyboard signal: deliver it;
365       b) kid already died, and we get a signal.  We may only hope
366          that the pid number was not reused.
367     */
368   
369    if (spawn_killed)
370        sig = SIGKILL;                  /* Try harder. */
371    kill(spawn_pid, sig);
372    spawn_killed = 1;
373}
374
375static int
376result(int flag, int pid)
377{
378        int r, status;
379        Signal_t (*ihand)();     /* place to save signal during system() */
380        Signal_t (*qhand)();     /* place to save signal during system() */
381#ifndef __EMX__
382        RESULTCODES res;
383        int rpid;
384#endif
385
386        if (pid < 0 || flag != 0)
387                return pid;
388
389#ifdef __EMX__
390        spawn_pid = pid;
391        spawn_killed = 0;
392        ihand = rsignal(SIGINT, &spawn_sighandler);
393        qhand = rsignal(SIGQUIT, &spawn_sighandler);
394        do {
395            r = wait4pid(pid, &status, 0);
396        } while (r == -1 && errno == EINTR);
397        rsignal(SIGINT, ihand);
398        rsignal(SIGQUIT, qhand);
399
400        PL_statusvalue = (U16)status;
401        if (r < 0)
402                return -1;
403        return status & 0xFFFF;
404#else
405        ihand = rsignal(SIGINT, SIG_IGN);
406        r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
407        rsignal(SIGINT, ihand);
408        PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
409        if (r)
410                return -1;
411        return PL_statusvalue;
412#endif
413}
414
415#define EXECF_SPAWN 0
416#define EXECF_EXEC 1
417#define EXECF_TRUEEXEC 2
418#define EXECF_SPAWN_NOWAIT 3
419#define EXECF_SPAWN_BYFLAG 4
420
421/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
422
423static int
424my_type()
425{
426    int rc;
427    TIB *tib;
428    PIB *pib;
429   
430    if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
431    if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
432        return -1;
433   
434    return (pib->pib_ultype);
435}
436
437static ULONG
438file_type(char *path)
439{
440    int rc;
441    ULONG apptype;
442   
443    if (!(_emx_env & 0x200))
444        croak("file_type not implemented on DOS"); /* not OS/2. */
445    if (CheckOSError(DosQueryAppType(path, &apptype))) {
446        switch (rc) {
447        case ERROR_FILE_NOT_FOUND:
448        case ERROR_PATH_NOT_FOUND:
449            return -1;
450        case ERROR_ACCESS_DENIED:       /* Directory with this name found? */
451            return -3;
452        default:                        /* Found, but not an
453                                           executable, or some other
454                                           read error. */
455            return -2;
456        }
457    }   
458    return apptype;
459}
460
461static ULONG os2_mytype;
462
463/* Spawn/exec a program, revert to shell if needed. */
464/* global PL_Argv[] contains arguments. */
465
466int
467do_spawn_ve(really, flag, execf, inicmd, addflag)
468SV *really;
469U32 flag;
470U32 execf;
471char *inicmd;
472U32 addflag;
473{
474    dTHR;
475        int trueflag = flag;
476        int rc, pass = 1;
477        char *tmps;
478        char buf[256], *s = 0, scrbuf[280];
479        char *args[4];
480        static char * fargs[4]
481            = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
482        char **argsp = fargs;
483        char nargs = 4;
484        int force_shell;
485        int new_stderr = -1, nostderr = 0, fl_stderr;
486        STRLEN n_a;
487       
488        if (flag == P_WAIT)
489                flag = P_NOWAIT;
490
491      retry:
492        if (strEQ(PL_Argv[0],"/bin/sh"))
493            PL_Argv[0] = PL_sh_path;
494
495        if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
496            && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
497                 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
498            ) /* will spawnvp use PATH? */
499            TAINT_ENV();        /* testing IFS here is overkill, probably */
500        /* We should check PERL_SH* and PERLLIB_* as well? */
501        if (!really || !*(tmps = SvPV(really, n_a)))
502            tmps = PL_Argv[0];
503
504      reread:
505        force_shell = 0;
506        if (_emx_env & 0x200) { /* OS/2. */
507            int type = file_type(tmps);
508          type_again:
509            if (type == -1) {           /* Not found */
510                errno = ENOENT;
511                rc = -1;
512                goto do_script;
513            }
514            else if (type == -2) {              /* Not an EXE */
515                errno = ENOEXEC;
516                rc = -1;
517                goto do_script;
518            }
519            else if (type == -3) {              /* Is a directory? */
520                /* Special-case this */
521                char tbuf[512];
522                int l = strlen(tmps);
523
524                if (l + 5 <= sizeof tbuf) {
525                    strcpy(tbuf, tmps);
526                    strcpy(tbuf + l, ".exe");
527                    type = file_type(tbuf);
528                    if (type >= -3)
529                        goto type_again;
530                }
531               
532                errno = ENOEXEC;
533                rc = -1;
534                goto do_script;
535            }
536            switch (type & 7) {
537                /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
538            case FAPPTYP_WINDOWAPI:
539            {
540                if (os2_mytype != 3) {  /* not PM */
541                    if (flag == P_NOWAIT)
542                        flag = P_PM;
543                    else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
544                        warn("Starting PM process with flag=%d, mytype=%d",
545                             flag, os2_mytype);
546                }
547            }
548            break;
549            case FAPPTYP_NOTWINDOWCOMPAT:
550            {
551                if (os2_mytype != 0) {  /* not full screen */
552                    if (flag == P_NOWAIT)
553                        flag = P_SESSION;
554                    else if ((flag & 7) != P_SESSION)
555                        warn("Starting Full Screen process with flag=%d, mytype=%d",
556                             flag, os2_mytype);
557                }
558            }
559            break;
560            case FAPPTYP_NOTSPEC:
561                /* Let the shell handle this... */
562                force_shell = 1;
563                goto doshell_args;
564                break;
565            }
566        }
567
568        if (addflag) {
569            addflag = 0;
570            new_stderr = dup(2);                /* Preserve stderr */
571            if (new_stderr == -1) {
572                if (errno == EBADF)
573                    nostderr = 1;
574                else {
575                    rc = -1;
576                    goto finish;
577                }
578            } else
579                fl_stderr = fcntl(2, F_GETFD);
580            rc = dup2(1,2);
581            if (rc == -1)
582                goto finish;
583            fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
584        }
585
586#if 0
587        rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
588#else
589        if (execf == EXECF_TRUEEXEC)
590            rc = execvp(tmps,PL_Argv);
591        else if (execf == EXECF_EXEC)
592            rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
593        else if (execf == EXECF_SPAWN_NOWAIT)
594            rc = spawnvp(flag,tmps,PL_Argv);
595        else                            /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
596            rc = result(trueflag,
597                        spawnvp(flag,tmps,PL_Argv));
598#endif
599        if (rc < 0 && pass == 1
600            && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
601              do_script:
602            {
603            int err = errno;
604
605            if (err == ENOENT || err == ENOEXEC) {
606                /* No such file, or is a script. */
607                /* Try adding script extensions to the file name, and
608                   search on PATH. */
609                char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
610
611                if (scr) {
612                    FILE *file;
613                    char *s = 0, *s1;
614                    int l;
615
616                    l = strlen(scr);
617               
618                    if (l >= sizeof scrbuf) {
619                       Safefree(scr);
620                     longbuf:
621                       warn("Size of scriptname too big: %d", l);
622                       rc = -1;
623                       goto finish;
624                    }
625                    strcpy(scrbuf, scr);
626                    Safefree(scr);
627                    scr = scrbuf;
628
629                    file = fopen(scr, "r");
630                    PL_Argv[0] = scr;
631                    if (!file)
632                        goto panic_file;
633                    if (!fgets(buf, sizeof buf, file)) { /* Empty... */
634
635                        buf[0] = 0;
636                        fclose(file);
637                        /* Special case: maybe from -Zexe build, so
638                           there is an executable around (contrary to
639                           documentation, DosQueryAppType sometimes (?)
640                           does not append ".exe", so we could have
641                           reached this place). */
642                        if (l + 5 < sizeof scrbuf) {
643                            strcpy(scrbuf + l, ".exe");
644                            if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
645                                && !S_ISDIR(PL_statbuf.st_mode)) {
646                                /* Found */
647                                tmps = scr;
648                                pass++;
649                                goto reread;
650                            } else
651                                scrbuf[l] = 0;
652                        } else
653                            goto longbuf;
654                    }
655                    if (fclose(file) != 0) { /* Failure */
656                      panic_file:
657                        warn("Error reading \"%s\": %s",
658                             scr, Strerror(errno));
659                        buf[0] = 0;     /* Not #! */
660                        goto doshell_args;
661                    }
662                    if (buf[0] == '#') {
663                        if (buf[1] == '!')
664                            s = buf + 2;
665                    } else if (buf[0] == 'e') {
666                        if (strnEQ(buf, "extproc", 7)
667                            && isSPACE(buf[7]))
668                            s = buf + 8;
669                    } else if (buf[0] == 'E') {
670                        if (strnEQ(buf, "EXTPROC", 7)
671                            && isSPACE(buf[7]))
672                            s = buf + 8;
673                    }
674                    if (!s) {
675                        buf[0] = 0;     /* Not #! */
676                        goto doshell_args;
677                    }
678                   
679                    s1 = s;
680                    nargs = 0;
681                    argsp = args;
682                    while (1) {
683                        /* Do better than pdksh: allow a few args,
684                           strip trailing whitespace.  */
685                        while (isSPACE(*s))
686                            s++;
687                        if (*s == 0)
688                            break;
689                        if (nargs == 4) {
690                            nargs = -1;
691                            break;
692                        }
693                        args[nargs++] = s;
694                        while (*s && !isSPACE(*s))
695                            s++;
696                        if (*s == 0)
697                            break;
698                        *s++ = 0;
699                    }
700                    if (nargs == -1) {
701                        warn("Too many args on %.*s line of \"%s\"",
702                             s1 - buf, buf, scr);
703                        nargs = 4;
704                        argsp = fargs;
705                    }
706                  doshell_args:
707                    {
708                        char **a = PL_Argv;
709                        char *exec_args[2];
710
711                        if (force_shell
712                            || (!buf[0] && file)) { /* File without magic */
713                            /* In fact we tried all what pdksh would
714                               try.  There is no point in calling
715                               pdksh, we may just emulate its logic. */
716                            char *shell = getenv("EXECSHELL");
717                            char *shell_opt = NULL;
718
719                            if (!shell) {
720                                char *s;
721
722                                shell_opt = "/c";
723                                shell = getenv("OS2_SHELL");
724                                if (inicmd) { /* No spaces at start! */
725                                    s = inicmd;
726                                    while (*s && !isSPACE(*s)) {
727                                        if (*s++ = '/') {
728                                            inicmd = NULL; /* Cannot use */
729                                            break;
730                                        }
731                                    }
732                                }
733                                if (!inicmd) {
734                                    s = PL_Argv[0];
735                                    while (*s) {
736                                        /* Dosish shells will choke on slashes
737                                           in paths, fortunately, this is
738                                           important for zeroth arg only. */
739                                        if (*s == '/')
740                                            *s = '\\';
741                                        s++;
742                                    }
743                                }
744                            }
745                            /* If EXECSHELL is set, we do not set */
746                           
747                            if (!shell)
748                                shell = ((_emx_env & 0x200)
749                                         ? "c:/os2/cmd.exe"
750                                         : "c:/command.com");
751                            nargs = shell_opt ? 2 : 1;  /* shell file args */
752                            exec_args[0] = shell;
753                            exec_args[1] = shell_opt;
754                            argsp = exec_args;
755                            if (nargs == 2 && inicmd) {
756                                /* Use the original cmd line */
757                                /* XXXX This is good only until we refuse
758                                        quoted arguments... */
759                                PL_Argv[0] = inicmd;
760                                PL_Argv[1] = Nullch;
761                            }
762                        } else if (!buf[0] && inicmd) { /* No file */
763                            /* Start with the original cmdline. */
764                            /* XXXX This is good only until we refuse
765                                    quoted arguments... */
766
767                            PL_Argv[0] = inicmd;
768                            PL_Argv[1] = Nullch;
769                            nargs = 2;  /* shell -c */
770                        }
771
772                        while (a[1])            /* Get to the end */
773                            a++;
774                        a++;                    /* Copy finil NULL too */
775                        while (a >= PL_Argv) {
776                            *(a + nargs) = *a;  /* PL_Argv was preallocated to be
777                                                   long enough. */
778                            a--;
779                        }
780                        while (--nargs >= 0)
781                            PL_Argv[nargs] = argsp[nargs];
782                        /* Enable pathless exec if #! (as pdksh). */
783                        pass = (buf[0] == '#' ? 2 : 3);
784                        goto retry;
785                    }
786                }
787                /* Not found: restore errno */
788                errno = err;
789            }
790          }
791        } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
792            char *no_dir = strrchr(PL_Argv[0], '/');
793
794            /* Do as pdksh port does: if not found with /, try without
795               path. */
796            if (no_dir) {
797                PL_Argv[0] = no_dir + 1;
798                pass++;
799                goto retry;
800            }
801        }
802        if (rc < 0 && ckWARN(WARN_EXEC))
803            Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
804                 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
805                  ? "spawn" : "exec"),
806                 PL_Argv[0], Strerror(errno));
807        if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
808            && ((trueflag & 0xFF) == P_WAIT))
809            rc = -1;
810
811  finish:
812    if (new_stderr != -1) {     /* How can we use error codes? */
813        dup2(new_stderr, 2);
814        close(new_stderr);
815        fcntl(2, F_SETFD, fl_stderr);
816    } else if (nostderr)
817       close(2);
818    return rc;
819}
820
821/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
822int
823do_spawn3(char *cmd, int execf, int flag)
824{
825    register char **a;
826    register char *s;
827    char flags[10];
828    char *shell, *copt, *news = NULL;
829    int rc, err, seenspace = 0, mergestderr = 0;
830    char fullcmd[MAXNAMLEN + 1];
831
832#ifdef TRYSHELL
833    if ((shell = getenv("EMXSHELL")) != NULL)
834        copt = "-c";
835    else if ((shell = getenv("SHELL")) != NULL)
836        copt = "-c";
837    else if ((shell = getenv("COMSPEC")) != NULL)
838        copt = "/C";
839    else
840        shell = "cmd.exe";
841#else
842    /* Consensus on perl5-porters is that it is _very_ important to
843       have a shell which will not change between computers with the
844       same architecture, to avoid "action on a distance".
845       And to have simple build, this shell should be sh. */
846    shell = PL_sh_path;
847    copt = "-c";
848#endif
849
850    while (*cmd && isSPACE(*cmd))
851        cmd++;
852
853    if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
854        STRLEN l = strlen(PL_sh_path);
855       
856        New(1302, news, strlen(cmd) - 7 + l + 1, char);
857        strcpy(news, PL_sh_path);
858        strcpy(news + l, cmd + 7);
859        cmd = news;
860    }
861
862    /* save an extra exec if possible */
863    /* see if there are shell metacharacters in it */
864
865    if (*cmd == '.' && isSPACE(cmd[1]))
866        goto doshell;
867
868    if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
869        goto doshell;
870
871    for (s = cmd; *s && isALPHA(*s); s++) ;     /* catch VAR=val gizmo */
872    if (*s == '=')
873        goto doshell;
874
875    for (s = cmd; *s; s++) {
876        if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
877            if (*s == '\n' && s[1] == '\0') {
878                *s = '\0';
879                break;
880            } else if (*s == '\\' && !seenspace) {
881                continue;               /* Allow backslashes in names */
882            } else if (*s == '>' && s >= cmd + 3
883                        && s[-1] == '2' && s[1] == '&' && s[2] == '1'
884                        && isSPACE(s[-2]) ) {
885                char *t = s + 3;
886
887                while (*t && isSPACE(*t))
888                    t++;
889                if (!*t) {
890                    s[-2] = '\0';
891                    mergestderr = 1;
892                    break;              /* Allow 2>&1 as the last thing */
893                }
894            }
895            /* We do not convert this to do_spawn_ve since shell
896               should be smart enough to start itself gloriously. */
897          doshell:
898            if (execf == EXECF_TRUEEXEC)
899                rc = execl(shell,shell,copt,cmd,(char*)0);             
900            else if (execf == EXECF_EXEC)
901                rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
902            else if (execf == EXECF_SPAWN_NOWAIT)
903                rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
904            else if (execf == EXECF_SPAWN_BYFLAG)
905                rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
906            else {
907                /* In the ak code internal P_NOWAIT is P_WAIT ??? */
908                rc = result(P_WAIT,
909                            spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
910                if (rc < 0 && ckWARN(WARN_EXEC))
911                    Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
912                         (execf == EXECF_SPAWN ? "spawn" : "exec"),
913                         shell, Strerror(errno));
914                if (rc < 0)
915                    rc = -1;
916            }
917            if (news)
918                Safefree(news);
919            return rc;
920        } else if (*s == ' ' || *s == '\t') {
921            seenspace = 1;
922        }
923    }
924
925    /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
926    New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
927    PL_Cmd = savepvn(cmd, s-cmd);
928    a = PL_Argv;
929    for (s = PL_Cmd; *s;) {
930        while (*s && isSPACE(*s)) s++;
931        if (*s)
932            *(a++) = s;
933        while (*s && !isSPACE(*s)) s++;
934        if (*s)
935            *s++ = '\0';
936    }
937    *a = Nullch;
938    if (PL_Argv[0])
939        rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr);
940    else
941        rc = -1;
942    if (news)
943        Safefree(news);
944    do_execfree();
945    return rc;
946}
947
948/* Array spawn.  */
949int
950do_aspawn(really,mark,sp)
951SV *really;
952register SV **mark;
953register SV **sp;
954{
955    dTHR;
956    register char **a;
957    int rc;
958    int flag = P_WAIT, flag_set = 0;
959    STRLEN n_a;
960
961    if (sp > mark) {
962        New(1301,PL_Argv, sp - mark + 3, char*);
963        a = PL_Argv;
964
965        if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
966                ++mark;
967                flag = SvIVx(*mark);
968                flag_set = 1;
969
970        }
971
972        while (++mark <= sp) {
973            if (*mark)
974                *a++ = SvPVx(*mark, n_a);
975            else
976                *a++ = "";
977        }
978        *a = Nullch;
979
980        if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
981            rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag);
982        } else
983            rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
984    } else
985        rc = -1;
986    do_execfree();
987    return rc;
988}
989
990int
991do_spawn(cmd)
992char *cmd;
993{
994    return do_spawn3(cmd, EXECF_SPAWN, 0);
995}
996
997int
998do_spawn_nowait(cmd)
999char *cmd;
1000{
1001    return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
1002}
1003
1004bool
1005do_exec(cmd)
1006char *cmd;
1007{
1008    do_spawn3(cmd, EXECF_EXEC, 0);
1009    return FALSE;
1010}
1011
1012bool
1013os2exec(cmd)
1014char *cmd;
1015{
1016    return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
1017}
1018
1019PerlIO *
1020my_syspopen(cmd,mode)
1021char    *cmd;
1022char    *mode;
1023{
1024#ifndef USE_POPEN
1025
1026    int p[2];
1027    register I32 this, that, newfd;
1028    register I32 pid, rc;
1029    PerlIO *res;
1030    SV *sv;
1031    int fh_fl;
1032   
1033    /* `this' is what we use in the parent, `that' in the child. */
1034    this = (*mode == 'w');
1035    that = !this;
1036    if (PL_tainting) {
1037        taint_env();
1038        taint_proper("Insecure %s%s", "EXEC");
1039    }
1040    if (pipe(p) < 0)
1041        return Nullfp;
1042    /* Now we need to spawn the child. */
1043    if (p[this] == (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1044        int new = dup(p[this]);
1045
1046        if (new == -1)
1047            goto closepipes;
1048        close(p[this]);
1049        p[this] = new;
1050    }
1051    newfd = dup(*mode == 'r');          /* Preserve std* */
1052    if (newfd == -1) {         
1053        /* This cannot happen due to fh being bad after pipe(), since
1054           pipe() should have created fh 0 and 1 even if they were
1055           initially closed.  But we closed p[this] before.  */
1056        if (errno != EBADF) {
1057          closepipes:
1058            close(p[0]);
1059            close(p[1]);
1060            return Nullfp;
1061        }
1062    } else
1063        fh_fl = fcntl(*mode == 'r', F_GETFD);
1064    if (p[that] != (*mode == 'r')) {    /* if fh 0/1 was initially closed. */
1065        dup2(p[that], *mode == 'r');
1066        close(p[that]);
1067    }
1068    /* Where is `this' and newfd now? */
1069    fcntl(p[this], F_SETFD, FD_CLOEXEC);
1070    if (newfd != -1)
1071        fcntl(newfd, F_SETFD, FD_CLOEXEC);
1072    pid = do_spawn_nowait(cmd);
1073    if (newfd == -1)
1074        close(*mode == 'r');            /* It was closed initially */
1075    else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1076        dup2(newfd, *mode == 'r');      /* Return std* back. */
1077        close(newfd);
1078        fcntl(*mode == 'r', F_SETFD, fh_fl);
1079    } else
1080        fcntl(*mode == 'r', F_SETFD, fh_fl);
1081    if (p[that] == (*mode == 'r'))
1082        close(p[that]);
1083    if (pid == -1) {
1084        close(p[this]);
1085        return Nullfp;
1086    }
1087    if (p[that] < p[this]) {            /* Make fh as small as possible */
1088        dup2(p[this], p[that]);
1089        close(p[this]);
1090        p[this] = p[that];
1091    }
1092    sv = *av_fetch(PL_fdpid,p[this],TRUE);
1093    (void)SvUPGRADE(sv,SVt_IV);
1094    SvIVX(sv) = pid;
1095    PL_forkprocess = pid;
1096    return PerlIO_fdopen(p[this], mode);
1097
1098#else  /* USE_POPEN */
1099
1100    PerlIO *res;
1101    SV *sv;
1102
1103#  ifdef TRYSHELL
1104    res = popen(cmd, mode);
1105#  else
1106    char *shell = getenv("EMXSHELL");
1107
1108    my_setenv("EMXSHELL", PL_sh_path);
1109    res = popen(cmd, mode);
1110    my_setenv("EMXSHELL", shell);
1111#  endif
1112    sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1113    (void)SvUPGRADE(sv,SVt_IV);
1114    SvIVX(sv) = -1;                     /* A cooky. */
1115    return res;
1116
1117#endif /* USE_POPEN */
1118
1119}
1120
1121/******************************************************************/
1122
1123#ifndef HAS_FORK
1124int
1125fork(void)
1126{
1127    croak(PL_no_func, "Unsupported function fork");
1128    errno = EINVAL;
1129    return -1;
1130}
1131#endif
1132
1133/*******************************************************************/
1134/* not implemented in EMX 0.9a */
1135
1136void *  ctermid(x)      { return 0; }
1137
1138#ifdef MYTTYNAME /* was not in emx0.9a */
1139void *  ttyname(x)      { return 0; }
1140#endif
1141
1142/******************************************************************/
1143/* my socket forwarders - EMX lib only provides static forwarders */
1144
1145static HMODULE htcp = 0;
1146
1147static void *
1148tcp0(char *name)
1149{
1150    static BYTE buf[20];
1151    PFN fcn;
1152
1153    if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1154    if (!htcp)
1155        DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1156    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1157        return (void *) ((void * (*)(void)) fcn) ();
1158    return 0;
1159}
1160
1161static void
1162tcp1(char *name, int arg)
1163{
1164    static BYTE buf[20];
1165    PFN fcn;
1166
1167    if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1168    if (!htcp)
1169        DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1170    if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1171        ((void (*)(int)) fcn) (arg);
1172}
1173
1174void *  gethostent()    { return tcp0("GETHOSTENT");  }
1175void *  getnetent()     { return tcp0("GETNETENT");   }
1176void *  getprotoent()   { return tcp0("GETPROTOENT"); }
1177void *  getservent()    { return tcp0("GETSERVENT");  }
1178void    sethostent(x)   { tcp1("SETHOSTENT",  x); }
1179void    setnetent(x)    { tcp1("SETNETENT",   x); }
1180void    setprotoent(x)  { tcp1("SETPROTOENT", x); }
1181void    setservent(x)   { tcp1("SETSERVENT",  x); }
1182void    endhostent()    { tcp0("ENDHOSTENT");  }
1183void    endnetent()     { tcp0("ENDNETENT");   }
1184void    endprotoent()   { tcp0("ENDPROTOENT"); }
1185void    endservent()    { tcp0("ENDSERVENT");  }
1186
1187/*****************************************************************************/
1188/* not implemented in C Set++ */
1189
1190#ifndef __EMX__
1191int     setuid(x)       { errno = EINVAL; return -1; }
1192int     setgid(x)       { errno = EINVAL; return -1; }
1193#endif
1194
1195/*****************************************************************************/
1196/* stat() hack for char/block device */
1197
1198#if OS2_STAT_HACK
1199
1200    /* First attempt used DosQueryFSAttach which crashed the system when
1201       used with 5.001. Now just look for /dev/. */
1202
1203int
1204os2_stat(char *name, struct stat *st)
1205{
1206    static int ino = SHRT_MAX;
1207
1208    if (stricmp(name, "/dev/con") != 0
1209     && stricmp(name, "/dev/tty") != 0)
1210        return stat(name, st);
1211
1212    memset(st, 0, sizeof *st);
1213    st->st_mode = S_IFCHR|0666;
1214    st->st_ino = (ino-- & 0x7FFF);
1215    st->st_nlink = 1;
1216    return 0;
1217}
1218
1219#endif
1220
1221#ifdef USE_PERL_SBRK
1222
1223/* SBRK() emulation, mostly moved to malloc.c. */
1224
1225void *
1226sys_alloc(int size) {
1227    void *got;
1228    APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1229
1230    if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1231        return (void *) -1;
1232    } else if ( rc )
1233        croak("Got an error from DosAllocMem: %li", (long)rc);
1234    return got;
1235}
1236
1237#endif /* USE_PERL_SBRK */
1238
1239/* tmp path */
1240
1241char *tmppath = TMPPATH1;
1242
1243void
1244settmppath()
1245{
1246    char *p = getenv("TMP"), *tpath;
1247    int len;
1248
1249    if (!p) p = getenv("TEMP");
1250    if (!p) return;
1251    len = strlen(p);
1252    tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1253    if (tpath) {
1254        strcpy(tpath, p);
1255        tpath[len] = '/';
1256        strcpy(tpath + len + 1, TMPPATH1);
1257        tmppath = tpath;
1258    }
1259}
1260
1261#include "XSUB.h"
1262
1263XS(XS_File__Copy_syscopy)
1264{
1265    dXSARGS;
1266    if (items < 2 || items > 3)
1267        croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1268    {
1269        STRLEN n_a;
1270        char *  src = (char *)SvPV(ST(0),n_a);
1271        char *  dst = (char *)SvPV(ST(1),n_a);
1272        U32     flag;
1273        int     RETVAL, rc;
1274
1275        if (items < 3)
1276            flag = 0;
1277        else {
1278            flag = (unsigned long)SvIV(ST(2));
1279        }
1280
1281        RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1282        ST(0) = sv_newmortal();
1283        sv_setiv(ST(0), (IV)RETVAL);
1284    }
1285    XSRETURN(1);
1286}
1287
1288#include "patchlevel.h"
1289
1290char *
1291mod2fname(sv)
1292     SV   *sv;
1293{
1294    static char fname[9];
1295    int pos = 6, len, avlen;
1296    unsigned int sum = 0;
1297    AV  *av;
1298    SV  *svp;
1299    char *s;
1300    STRLEN n_a;
1301
1302    if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1303    sv = SvRV(sv);
1304    if (SvTYPE(sv) != SVt_PVAV)
1305      croak("Not array reference given to mod2fname");
1306
1307    avlen = av_len((AV*)sv);
1308    if (avlen < 0)
1309      croak("Empty array reference given to mod2fname");
1310
1311    s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1312    strncpy(fname, s, 8);
1313    len = strlen(s);
1314    if (len < 6) pos = len;
1315    while (*s) {
1316        sum = 33 * sum + *(s++);        /* Checksumming first chars to
1317                                         * get the capitalization into c.s. */
1318    }
1319    avlen --;
1320    while (avlen >= 0) {
1321        s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1322        while (*s) {
1323            sum = 33 * sum + *(s++);    /* 7 is primitive mod 13. */
1324        }
1325        avlen --;
1326    }
1327#ifdef USE_THREADS
1328    sum++;                              /* Avoid conflict of DLLs in memory. */
1329#endif
1330    sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2;  /*  */
1331    fname[pos] = 'A' + (sum % 26);
1332    fname[pos + 1] = 'A' + (sum / 26 % 26);
1333    fname[pos + 2] = '\0';
1334    return (char *)fname;
1335}
1336
1337XS(XS_DynaLoader_mod2fname)
1338{
1339    dXSARGS;
1340    if (items != 1)
1341        croak("Usage: DynaLoader::mod2fname(sv)");
1342    {
1343        SV *    sv = ST(0);
1344        char *  RETVAL;
1345
1346        RETVAL = mod2fname(sv);
1347        ST(0) = sv_newmortal();
1348        sv_setpv((SV*)ST(0), RETVAL);
1349    }
1350    XSRETURN(1);
1351}
1352
1353char *
1354os2error(int rc)
1355{
1356        static char buf[300];
1357        ULONG len;
1358
1359        if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1360        if (rc == 0)
1361                return NULL;
1362        if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1363                sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1364        else {
1365                buf[len] = '\0';
1366                if (len && buf[len - 1] == '\n')
1367                        buf[--len] = 0;
1368                if (len && buf[len - 1] == '\r')
1369                        buf[--len] = 0;
1370                if (len && buf[len - 1] == '.')
1371                        buf[--len] = 0;
1372        }
1373        return buf;
1374}
1375
1376char *
1377os2_execname(void)
1378{
1379  char buf[300], *p;
1380
1381  if (_execname(buf, sizeof buf) != 0)
1382        return PL_origargv[0];
1383  p = buf;
1384  while (*p) {
1385    if (*p == '\\')
1386        *p = '/';
1387    p++;
1388  }
1389  p = savepv(buf);
1390  SAVEFREEPV(p);
1391  return p;
1392}
1393
1394char *
1395perllib_mangle(char *s, unsigned int l)
1396{
1397    static char *newp, *oldp;
1398    static int newl, oldl, notfound;
1399    static char ret[STATIC_FILE_LENGTH+1];
1400   
1401    if (!newp && !notfound) {
1402        newp = getenv("PERLLIB_PREFIX");
1403        if (newp) {
1404            char *s;
1405           
1406            oldp = newp;
1407            while (*newp && !isSPACE(*newp) && *newp != ';') {
1408                newp++; oldl++;         /* Skip digits. */
1409            }
1410            while (*newp && (isSPACE(*newp) || *newp == ';')) {
1411                newp++;                 /* Skip whitespace. */
1412            }
1413            newl = strlen(newp);
1414            if (newl == 0 || oldl == 0) {
1415                croak("Malformed PERLLIB_PREFIX");
1416            }
1417            strcpy(ret, newp);
1418            s = ret;
1419            while (*s) {
1420                if (*s == '\\') *s = '/';
1421                s++;
1422            }
1423        } else {
1424            notfound = 1;
1425        }
1426    }
1427    if (!newp) {
1428        return s;
1429    }
1430    if (l == 0) {
1431        l = strlen(s);
1432    }
1433    if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1434        return s;
1435    }
1436    if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1437        croak("Malformed PERLLIB_PREFIX");
1438    }
1439    strcpy(ret + newl, s + oldl);
1440    return ret;
1441}
1442
1443unsigned long
1444Perl_hab_GET()                  /* Needed if perl.h cannot be included */
1445{
1446    return perl_hab_GET();
1447}
1448
1449HMQ
1450Perl_Register_MQ(int serve)
1451{
1452    PPIB pib;
1453    PTIB tib;
1454
1455    if (Perl_os2_initial_mode++)
1456        return Perl_hmq;
1457    DosGetInfoBlocks(&tib, &pib);
1458    Perl_os2_initial_mode = pib->pib_ultype;
1459    Perl_hmq_refcnt = 1;
1460    /* Try morphing into a PM application. */
1461    if (pib->pib_ultype != 3)           /* 2 is VIO */
1462        pib->pib_ultype = 3;            /* 3 is PM */
1463    init_PMWIN_entries();
1464    /* 64 messages if before OS/2 3.0, ignored otherwise */
1465    Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1466    if (!Perl_hmq) {
1467        static int cnt;
1468        if (cnt++)
1469            _exit(188);                 /* Panic can try to create a window. */
1470        croak("Cannot create a message queue, or morph to a PM application");
1471    }
1472    return Perl_hmq;
1473}
1474
1475int
1476Perl_Serve_Messages(int force)
1477{
1478    int cnt = 0;
1479    QMSG msg;
1480
1481    if (Perl_hmq_servers && !force)
1482        return 0;
1483    if (!Perl_hmq_refcnt)
1484        croak("No message queue");
1485    while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1486        cnt++;
1487        if (msg.msg == WM_QUIT)
1488            croak("QUITing...");
1489        (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1490    }
1491    return cnt;
1492}
1493
1494int
1495Perl_Process_Messages(int force, I32 *cntp)
1496{
1497    QMSG msg;
1498
1499    if (Perl_hmq_servers && !force)
1500        return 0;
1501    if (!Perl_hmq_refcnt)
1502        croak("No message queue");
1503    while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1504        if (cntp)
1505            (*cntp)++;
1506        (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1507        if (msg.msg == WM_DESTROY)
1508            return -1;
1509        if (msg.msg == WM_CREATE)
1510            return +1;
1511    }
1512    croak("QUITing...");
1513}
1514
1515void
1516Perl_Deregister_MQ(int serve)
1517{
1518    PPIB pib;
1519    PTIB tib;
1520
1521    if (--Perl_hmq_refcnt == 0) {
1522        (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1523        Perl_hmq = 0;
1524        /* Try morphing back from a PM application. */
1525        if (pib->pib_ultype == 3)               /* 3 is PM */
1526            pib->pib_ultype = Perl_os2_initial_mode;
1527        else
1528            warn("Unexpected program mode %d when morphing back from PM",
1529                 pib->pib_ultype);
1530    }
1531}
1532
1533extern void dlopen();
1534void *fakedl = &dlopen;         /* Pull in dynaloading part. */
1535
1536#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1537                                && ((path)[2] == '/' || (path)[2] == '\\'))
1538#define sys_is_rooted _fnisabs
1539#define sys_is_relative _fnisrel
1540#define current_drive _getdrive
1541
1542#undef chdir                            /* Was _chdir2. */
1543#define sys_chdir(p) (chdir(p) == 0)
1544#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1545
1546static int DOS_harderr_state = -1;   
1547
1548XS(XS_OS2_Error)
1549{
1550    dXSARGS;
1551    if (items != 2)
1552        croak("Usage: OS2::Error(harderr, exception)");
1553    {
1554        int     arg1 = SvIV(ST(0));
1555        int     arg2 = SvIV(ST(1));
1556        int     a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1557                     | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1558        int     RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1559        unsigned long rc;
1560
1561        if (CheckOSError(DosError(a)))
1562            croak("DosError(%d) failed", a);
1563        ST(0) = sv_newmortal();
1564        if (DOS_harderr_state >= 0)
1565            sv_setiv(ST(0), DOS_harderr_state);
1566        DOS_harderr_state = RETVAL;
1567    }
1568    XSRETURN(1);
1569}
1570
1571static signed char DOS_suppression_state = -1;   
1572
1573XS(XS_OS2_Errors2Drive)
1574{
1575    dXSARGS;
1576    if (items != 1)
1577        croak("Usage: OS2::Errors2Drive(drive)");
1578    {
1579        STRLEN n_a;
1580        SV  *sv = ST(0);
1581        int     suppress = SvOK(sv);
1582        char    *s = suppress ? SvPV(sv, n_a) : NULL;
1583        char    drive = (s ? *s : 0);
1584        unsigned long rc;
1585
1586        if (suppress && !isALPHA(drive))
1587            croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1588        if (CheckOSError(DosSuppressPopUps((suppress
1589                                            ? SPU_ENABLESUPPRESSION
1590                                            : SPU_DISABLESUPPRESSION),
1591                                           drive)))
1592            croak("DosSuppressPopUps(%c) failed", drive);
1593        ST(0) = sv_newmortal();
1594        if (DOS_suppression_state > 0)
1595            sv_setpvn(ST(0), &DOS_suppression_state, 1);
1596        else if (DOS_suppression_state == 0)
1597            sv_setpvn(ST(0), "", 0);
1598        DOS_suppression_state = drive;
1599    }
1600    XSRETURN(1);
1601}
1602
1603static const char * const si_fields[QSV_MAX] = {
1604  "MAX_PATH_LENGTH",
1605  "MAX_TEXT_SESSIONS",
1606  "MAX_PM_SESSIONS",
1607  "MAX_VDM_SESSIONS",
1608  "BOOT_DRIVE",
1609  "DYN_PRI_VARIATION",
1610  "MAX_WAIT",
1611  "MIN_SLICE",
1612  "MAX_SLICE",
1613  "PAGE_SIZE",
1614  "VERSION_MAJOR",
1615  "VERSION_MINOR",
1616  "VERSION_REVISION",
1617  "MS_COUNT",
1618  "TIME_LOW",
1619  "TIME_HIGH",
1620  "TOTPHYSMEM",
1621  "TOTRESMEM",
1622  "TOTAVAILMEM",
1623  "MAXPRMEM",
1624  "MAXSHMEM",
1625  "TIMER_INTERVAL",
1626  "MAX_COMP_LENGTH",
1627  "FOREGROUND_FS_SESSION",
1628  "FOREGROUND_PROCESS"
1629};
1630
1631XS(XS_OS2_SysInfo)
1632{
1633    dXSARGS;
1634    if (items != 0)
1635        croak("Usage: OS2::SysInfo()");
1636    {
1637        ULONG   si[QSV_MAX] = {0};      /* System Information Data Buffer */
1638        APIRET  rc      = NO_ERROR;     /* Return code            */
1639        int i = 0, j = 0;
1640
1641        if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1642                                         QSV_MAX, /* information */
1643                                         (PVOID)si,
1644                                         sizeof(si))))
1645            croak("DosQuerySysInfo() failed");
1646        EXTEND(SP,2*QSV_MAX);
1647        while (i < QSV_MAX) {
1648            ST(j) = sv_newmortal();
1649            sv_setpv(ST(j++), si_fields[i]);
1650            ST(j) = sv_newmortal();
1651            sv_setiv(ST(j++), si[i]);
1652            i++;
1653        }
1654    }
1655    XSRETURN(2 * QSV_MAX);
1656}
1657
1658XS(XS_OS2_BootDrive)
1659{
1660    dXSARGS;
1661    if (items != 0)
1662        croak("Usage: OS2::BootDrive()");
1663    {
1664        ULONG   si[1] = {0};    /* System Information Data Buffer */
1665        APIRET  rc    = NO_ERROR;       /* Return code            */
1666        char c;
1667       
1668        if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1669                                         (PVOID)si, sizeof(si))))
1670            croak("DosQuerySysInfo() failed");
1671        ST(0) = sv_newmortal();
1672        c = 'a' - 1 + si[0];
1673        sv_setpvn(ST(0), &c, 1);
1674    }
1675    XSRETURN(1);
1676}
1677
1678XS(XS_OS2_MorphPM)
1679{
1680    dXSARGS;
1681    if (items != 1)
1682        croak("Usage: OS2::MorphPM(serve)");
1683    {
1684        bool  serve = SvOK(ST(0));
1685        unsigned long   pmq = perl_hmq_GET(serve);
1686
1687        ST(0) = sv_newmortal();
1688        sv_setiv(ST(0), pmq);
1689    }
1690    XSRETURN(1);
1691}
1692
1693XS(XS_OS2_UnMorphPM)
1694{
1695    dXSARGS;
1696    if (items != 1)
1697        croak("Usage: OS2::UnMorphPM(serve)");
1698    {
1699        bool  serve = SvOK(ST(0));
1700
1701        perl_hmq_UNSET(serve);
1702    }
1703    XSRETURN(0);
1704}
1705
1706XS(XS_OS2_Serve_Messages)
1707{
1708    dXSARGS;
1709    if (items != 1)
1710        croak("Usage: OS2::Serve_Messages(force)");
1711    {
1712        bool  force = SvOK(ST(0));
1713        unsigned long   cnt = Perl_Serve_Messages(force);
1714
1715        ST(0) = sv_newmortal();
1716        sv_setiv(ST(0), cnt);
1717    }
1718    XSRETURN(1);
1719}
1720
1721XS(XS_OS2_Process_Messages)
1722{
1723    dXSARGS;
1724    if (items < 1 || items > 2)
1725        croak("Usage: OS2::Process_Messages(force [, cnt])");
1726    {
1727        bool  force = SvOK(ST(0));
1728        unsigned long   cnt;
1729        I32 *cntp = NULL;
1730
1731        if (items == 2) {
1732            SV *sv = ST(1);
1733            int fake = SvIV(sv);        /* Force SvIVX */
1734           
1735            if (!SvIOK(sv))
1736                croak("Can't upgrade count to IV");
1737            cntp = &SvIVX(sv);
1738        }
1739        cnt =  Perl_Process_Messages(force, cntp);
1740        ST(0) = sv_newmortal();
1741        sv_setiv(ST(0), cnt);
1742    }
1743    XSRETURN(1);
1744}
1745
1746XS(XS_Cwd_current_drive)
1747{
1748    dXSARGS;
1749    if (items != 0)
1750        croak("Usage: Cwd::current_drive()");
1751    {
1752        char    RETVAL;
1753
1754        RETVAL = current_drive();
1755        ST(0) = sv_newmortal();
1756        sv_setpvn(ST(0), (char *)&RETVAL, 1);
1757    }
1758    XSRETURN(1);
1759}
1760
1761XS(XS_Cwd_sys_chdir)
1762{
1763    dXSARGS;
1764    if (items != 1)
1765        croak("Usage: Cwd::sys_chdir(path)");
1766    {
1767        STRLEN n_a;
1768        char *  path = (char *)SvPV(ST(0),n_a);
1769        bool    RETVAL;
1770
1771        RETVAL = sys_chdir(path);
1772        ST(0) = boolSV(RETVAL);
1773        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1774    }
1775    XSRETURN(1);
1776}
1777
1778XS(XS_Cwd_change_drive)
1779{
1780    dXSARGS;
1781    if (items != 1)
1782        croak("Usage: Cwd::change_drive(d)");
1783    {
1784        STRLEN n_a;
1785        char    d = (char)*SvPV(ST(0),n_a);
1786        bool    RETVAL;
1787
1788        RETVAL = change_drive(d);
1789        ST(0) = boolSV(RETVAL);
1790        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1791    }
1792    XSRETURN(1);
1793}
1794
1795XS(XS_Cwd_sys_is_absolute)
1796{
1797    dXSARGS;
1798    if (items != 1)
1799        croak("Usage: Cwd::sys_is_absolute(path)");
1800    {
1801        STRLEN n_a;
1802        char *  path = (char *)SvPV(ST(0),n_a);
1803        bool    RETVAL;
1804
1805        RETVAL = sys_is_absolute(path);
1806        ST(0) = boolSV(RETVAL);
1807        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1808    }
1809    XSRETURN(1);
1810}
1811
1812XS(XS_Cwd_sys_is_rooted)
1813{
1814    dXSARGS;
1815    if (items != 1)
1816        croak("Usage: Cwd::sys_is_rooted(path)");
1817    {
1818        STRLEN n_a;
1819        char *  path = (char *)SvPV(ST(0),n_a);
1820        bool    RETVAL;
1821
1822        RETVAL = sys_is_rooted(path);
1823        ST(0) = boolSV(RETVAL);
1824        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1825    }
1826    XSRETURN(1);
1827}
1828
1829XS(XS_Cwd_sys_is_relative)
1830{
1831    dXSARGS;
1832    if (items != 1)
1833        croak("Usage: Cwd::sys_is_relative(path)");
1834    {
1835        STRLEN n_a;
1836        char *  path = (char *)SvPV(ST(0),n_a);
1837        bool    RETVAL;
1838
1839        RETVAL = sys_is_relative(path);
1840        ST(0) = boolSV(RETVAL);
1841        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1842    }
1843    XSRETURN(1);
1844}
1845
1846XS(XS_Cwd_sys_cwd)
1847{
1848    dXSARGS;
1849    if (items != 0)
1850        croak("Usage: Cwd::sys_cwd()");
1851    {
1852        char p[MAXPATHLEN];
1853        char *  RETVAL;
1854        RETVAL = _getcwd2(p, MAXPATHLEN);
1855        ST(0) = sv_newmortal();
1856        sv_setpv((SV*)ST(0), RETVAL);
1857    }
1858    XSRETURN(1);
1859}
1860
1861XS(XS_Cwd_sys_abspath)
1862{
1863    dXSARGS;
1864    if (items < 1 || items > 2)
1865        croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1866    {
1867        STRLEN n_a;
1868        char *  path = (char *)SvPV(ST(0),n_a);
1869        char *  dir;
1870        char p[MAXPATHLEN];
1871        char *  RETVAL;
1872
1873        if (items < 2)
1874            dir = NULL;
1875        else {
1876            dir = (char *)SvPV(ST(1),n_a);
1877        }
1878        if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1879            path += 2;
1880        }
1881        if (dir == NULL) {
1882            if (_abspath(p, path, MAXPATHLEN) == 0) {
1883                RETVAL = p;
1884            } else {
1885                RETVAL = NULL;
1886            }
1887        } else {
1888            /* Absolute with drive: */
1889            if ( sys_is_absolute(path) ) {
1890                if (_abspath(p, path, MAXPATHLEN) == 0) {
1891                    RETVAL = p;
1892                } else {
1893                    RETVAL = NULL;
1894                }
1895            } else if (path[0] == '/' || path[0] == '\\') {
1896                /* Rooted, but maybe on different drive. */
1897                if (isALPHA(dir[0]) && dir[1] == ':' ) {
1898                    char p1[MAXPATHLEN];
1899
1900                    /* Need to prepend the drive. */
1901                    p1[0] = dir[0];
1902                    p1[1] = dir[1];
1903                    Copy(path, p1 + 2, strlen(path) + 1, char);
1904                    RETVAL = p;
1905                    if (_abspath(p, p1, MAXPATHLEN) == 0) {
1906                        RETVAL = p;
1907                    } else {
1908                        RETVAL = NULL;
1909                    }
1910                } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1911                    RETVAL = p;
1912                } else {
1913                    RETVAL = NULL;
1914                }
1915            } else {
1916                /* Either path is relative, or starts with a drive letter. */
1917                /* If the path starts with a drive letter, then dir is
1918                   relevant only if
1919                   a/b) it is absolute/x:relative on the same drive. 
1920                   c)   path is on current drive, and dir is rooted
1921                   In all the cases it is safe to drop the drive part
1922                   of the path. */
1923                if ( !sys_is_relative(path) ) {
1924                    int is_drived;
1925
1926                    if ( ( ( sys_is_absolute(dir)
1927                             || (isALPHA(dir[0]) && dir[1] == ':'
1928                                 && strnicmp(dir, path,1) == 0))
1929                           && strnicmp(dir, path,1) == 0)
1930                         || ( !(isALPHA(dir[0]) && dir[1] == ':')
1931                              && toupper(path[0]) == current_drive())) {
1932                        path += 2;
1933                    } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1934                        RETVAL = p; goto done;
1935                    } else {
1936                        RETVAL = NULL; goto done;
1937                    }
1938                }
1939                {
1940                    /* Need to prepend the absolute path of dir. */
1941                    char p1[MAXPATHLEN];
1942
1943                    if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1944                        int l = strlen(p1);
1945
1946                        if (p1[ l - 1 ] != '/') {
1947                            p1[ l ] = '/';
1948                            l++;
1949                        }
1950                        Copy(path, p1 + l, strlen(path) + 1, char);
1951                        if (_abspath(p, p1, MAXPATHLEN) == 0) {
1952                            RETVAL = p;
1953                        } else {
1954                            RETVAL = NULL;
1955                        }
1956                    } else {
1957                        RETVAL = NULL;
1958                    }
1959                }
1960              done:
1961            }
1962        }
1963        ST(0) = sv_newmortal();
1964        sv_setpv((SV*)ST(0), RETVAL);
1965    }
1966    XSRETURN(1);
1967}
1968typedef APIRET (*PELP)(PSZ path, ULONG type);
1969
1970APIRET
1971ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1972{
1973    loadByOrd("doscalls",ord);          /* Guarantied to load or die! */
1974    return (*(PELP)ExtFCN[ord])(path, type);
1975}
1976
1977#define extLibpath(type)                                                \
1978    (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH   \
1979                                                 : BEGIN_LIBPATH)))     \
1980     ? NULL : to )
1981
1982#define extLibpath_set(p,type)                                  \
1983    (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH   \
1984                                                 : BEGIN_LIBPATH))))
1985
1986XS(XS_Cwd_extLibpath)
1987{
1988    dXSARGS;
1989    if (items < 0 || items > 1)
1990        croak("Usage: Cwd::extLibpath(type = 0)");
1991    {
1992        bool    type;
1993        char    to[1024];
1994        U32     rc;
1995        char *  RETVAL;
1996
1997        if (items < 1)
1998            type = 0;
1999        else {
2000            type = (int)SvIV(ST(0));
2001        }
2002
2003        RETVAL = extLibpath(type);
2004        ST(0) = sv_newmortal();
2005        sv_setpv((SV*)ST(0), RETVAL);
2006    }
2007    XSRETURN(1);
2008}
2009
2010XS(XS_Cwd_extLibpath_set)
2011{
2012    dXSARGS;
2013    if (items < 1 || items > 2)
2014        croak("Usage: Cwd::extLibpath_set(s, type = 0)");
2015    {
2016        STRLEN n_a;
2017        char *  s = (char *)SvPV(ST(0),n_a);
2018        bool    type;
2019        U32     rc;
2020        bool    RETVAL;
2021
2022        if (items < 2)
2023            type = 0;
2024        else {
2025            type = (int)SvIV(ST(1));
2026        }
2027
2028        RETVAL = extLibpath_set(s, type);
2029        ST(0) = boolSV(RETVAL);
2030        if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2031    }
2032    XSRETURN(1);
2033}
2034
2035int
2036Xs_OS2_init()
2037{
2038    char *file = __FILE__;
2039    {
2040        GV *gv;
2041
2042        if (_emx_env & 0x200) { /* OS/2 */
2043            newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2044            newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2045            newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2046        }
2047        newXS("OS2::Error", XS_OS2_Error, file);
2048        newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2049        newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2050        newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2051        newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2052        newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2053        newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2054        newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2055        newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2056        newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2057        newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2058        newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2059        newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2060        newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2061        newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2062        newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2063        newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2064        gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2065        GvMULTI_on(gv);
2066#ifdef PERL_IS_AOUT
2067        sv_setiv(GvSV(gv), 1);
2068#endif
2069        gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2070        GvMULTI_on(gv);
2071        sv_setiv(GvSV(gv), _emx_rev);
2072        sv_setpv(GvSV(gv), _emx_vprt);
2073        SvIOK_on(GvSV(gv));
2074        gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2075        GvMULTI_on(gv);
2076        sv_setiv(GvSV(gv), _emx_env);
2077        gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2078        GvMULTI_on(gv);
2079        sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2080    }
2081}
2082
2083OS2_Perl_data_t OS2_Perl_data;
2084
2085void
2086Perl_OS2_init(char **env)
2087{
2088    char *shell;
2089
2090    MALLOC_INIT;
2091    settmppath();
2092    OS2_Perl_data.xs_init = &Xs_OS2_init;
2093    _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2094    if (environ == NULL && env) {
2095        environ = env;
2096    }
2097    if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2098        New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2099        strcpy(PL_sh_path, SH_PATH);
2100        PL_sh_path[0] = shell[0];
2101    } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2102        int l = strlen(shell), i;
2103        if (shell[l-1] == '/' || shell[l-1] == '\\') {
2104            l--;
2105        }
2106        New(1304, PL_sh_path, l + 8, char);
2107        strncpy(PL_sh_path, shell, l);
2108        strcpy(PL_sh_path + l, "/sh.exe");
2109        for (i = 0; i < l; i++) {
2110            if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2111        }
2112    }
2113    MUTEX_INIT(&start_thread_mutex);
2114    os2_mytype = my_type();             /* Do it before morphing.  Needed? */
2115}
2116
2117#undef tmpnam
2118#undef tmpfile
2119
2120char *
2121my_tmpnam (char *str)
2122{
2123    char *p = getenv("TMP"), *tpath;
2124    int len;
2125
2126    if (!p) p = getenv("TEMP");
2127    tpath = tempnam(p, "pltmp");
2128    if (str && tpath) {
2129        strcpy(str, tpath);
2130        return str;
2131    }
2132    return tpath;
2133}
2134
2135FILE *
2136my_tmpfile ()
2137{
2138    struct stat s;
2139
2140    stat(".", &s);
2141    if (s.st_mode & S_IWOTH) {
2142        return tmpfile();
2143    }
2144    return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2145                                             grants TMP. */
2146}
2147
2148#undef flock
2149
2150/* This code was contributed by Rocco Caputo. */
2151int
2152my_flock(int handle, int o)
2153{
2154  FILELOCK      rNull, rFull;
2155  ULONG         timeout, handle_type, flag_word;
2156  APIRET        rc;
2157  int           blocking, shared;
2158  static int    use_my = -1;
2159
2160  if (use_my == -1) {
2161    char *s = getenv("USE_PERL_FLOCK");
2162    if (s)
2163        use_my = atoi(s);
2164    else
2165        use_my = 1;
2166  }
2167  if (!(_emx_env & 0x200) || !use_my)
2168    return flock(handle, o);    /* Delegate to EMX. */
2169 
2170                                        // is this a file?
2171  if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2172      (handle_type & 0xFF))
2173  {
2174    errno = EBADF;
2175    return -1;
2176  }
2177                                        // set lock/unlock ranges
2178  rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2179  rFull.lRange = 0x7FFFFFFF;
2180                                        // set timeout for blocking
2181  timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2182                                        // shared or exclusive?
2183  shared = (o & LOCK_SH) ? 1 : 0;
2184                                        // do not block the unlock
2185  if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2186    rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2187    switch (rc) {
2188      case 0:
2189        errno = 0;
2190        return 0;
2191      case ERROR_INVALID_HANDLE:
2192        errno = EBADF;
2193        return -1;
2194      case ERROR_SHARING_BUFFER_EXCEEDED:
2195        errno = ENOLCK;
2196        return -1;
2197      case ERROR_LOCK_VIOLATION:
2198        break;                          // not an error
2199      case ERROR_INVALID_PARAMETER:
2200      case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2201      case ERROR_READ_LOCKS_NOT_SUPPORTED:
2202        errno = EINVAL;
2203        return -1;
2204      case ERROR_INTERRUPT:
2205        errno = EINTR;
2206        return -1;
2207      default:
2208        errno = EINVAL;
2209        return -1;
2210    }
2211  }
2212                                        // lock may block
2213  if (o & (LOCK_SH | LOCK_EX)) {
2214                                        // for blocking operations
2215    for (;;) {
2216      rc =
2217        DosSetFileLocks(
2218                handle,
2219                &rNull,
2220                &rFull,
2221                timeout,
2222                shared
2223        );
2224      switch (rc) {
2225        case 0:
2226          errno = 0;
2227          return 0;
2228        case ERROR_INVALID_HANDLE:
2229          errno = EBADF;
2230          return -1;
2231        case ERROR_SHARING_BUFFER_EXCEEDED:
2232          errno = ENOLCK;
2233          return -1;
2234        case ERROR_LOCK_VIOLATION:
2235          if (!blocking) {
2236            errno = EWOULDBLOCK;
2237            return -1;
2238          }
2239          break;
2240        case ERROR_INVALID_PARAMETER:
2241        case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2242        case ERROR_READ_LOCKS_NOT_SUPPORTED:
2243          errno = EINVAL;
2244          return -1;
2245        case ERROR_INTERRUPT:
2246          errno = EINTR;
2247          return -1;
2248        default:
2249          errno = EINVAL;
2250          return -1;
2251      }
2252                                        // give away timeslice
2253      DosSleep(1);
2254    }
2255  }
2256
2257  errno = 0;
2258  return 0;
2259}
Note: See TracBrowser for help on using the repository browser.