home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / os2 / os2.c < prev    next >
Encoding:
C/C++ Source or Header  |  2000-03-11  |  52.2 KB  |  2,260 lines
  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.  
  29. typedef void (*emx_startroutine)(void *);
  30. typedef void* (*pthreads_startroutine)(void *);
  31.  
  32. enum pthreads_state {
  33.     pthreads_st_none = 0, 
  34.     pthreads_st_run,
  35.     pthreads_st_exited, 
  36.     pthreads_st_detached, 
  37.     pthreads_st_waited,
  38. };
  39. const char *pthreads_states[] = {
  40.     "uninit",
  41.     "running",
  42.     "exited",
  43.     "detached",
  44.     "waited for",
  45. };
  46.  
  47. typedef struct {
  48.     void *status;
  49.     perl_cond cond;
  50.     enum pthreads_state state;
  51. } thread_join_t;
  52.  
  53. thread_join_t *thread_join_data;
  54. int thread_join_count;
  55. perl_mutex start_thread_mutex;
  56.  
  57. int
  58. pthread_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.  
  89. void
  90. pthread_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.  
  125. int
  126. pthread_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.  
  142. int 
  143. pthread_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: */
  165. int
  166. os2_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. */
  184. static PFN ExtFCN[2];            /* Labeled by ord below. */
  185. static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
  186. #define ORD_QUERY_ELP    0
  187. #define ORD_SET_ELP    1
  188. struct PMWIN_entries_t PMWIN_entries;
  189.  
  190. APIRET
  191. loadByOrd(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.  
  210. void 
  211. init_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 */
  241. static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
  242.                            self inverse. */
  243. #define QSS_INI_BUFFER 1024
  244.  
  245. PQTOPLEVEL
  246. get_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.  
  268. static ULONG
  269. sys_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.  
  287. int 
  288. setpriority(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.  
  330. int 
  331. getpriority(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? */
  355. static int spawn_pid;
  356. static int spawn_killed;
  357.  
  358. static Signal_t
  359. spawn_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.  
  375. static int
  376. result(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.  
  423. static int
  424. my_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.  
  437. static ULONG
  438. file_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.  
  461. static ULONG os2_mytype;
  462.  
  463. /* Spawn/exec a program, revert to shell if needed. */
  464. /* global PL_Argv[] contains arguments. */
  465.  
  466. int
  467. do_spawn_ve(really, flag, execf, inicmd, addflag)
  468. SV *really;
  469. U32 flag;
  470. U32 execf;
  471. char *inicmd;
  472. U32 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. */
  822. int
  823. do_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.  */
  949. int
  950. do_aspawn(really,mark,sp)
  951. SV *really;
  952. register SV **mark;
  953. register 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.  
  990. int
  991. do_spawn(cmd)
  992. char *cmd;
  993. {
  994.     return do_spawn3(cmd, EXECF_SPAWN, 0);
  995. }
  996.  
  997. int
  998. do_spawn_nowait(cmd)
  999. char *cmd;
  1000. {
  1001.     return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
  1002. }
  1003.  
  1004. bool
  1005. do_exec(cmd)
  1006. char *cmd;
  1007. {
  1008.     do_spawn3(cmd, EXECF_EXEC, 0);
  1009.     return FALSE;
  1010. }
  1011.  
  1012. bool
  1013. os2exec(cmd)
  1014. char *cmd;
  1015. {
  1016.     return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
  1017. }
  1018.  
  1019. PerlIO *
  1020. my_syspopen(cmd,mode)
  1021. char    *cmd;
  1022. char    *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
  1124. int
  1125. fork(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.  
  1136. void *    ctermid(x)    { return 0; }
  1137.  
  1138. #ifdef MYTTYNAME /* was not in emx0.9a */
  1139. void *    ttyname(x)    { return 0; }
  1140. #endif
  1141.  
  1142. /******************************************************************/
  1143. /* my socket forwarders - EMX lib only provides static forwarders */
  1144.  
  1145. static HMODULE htcp = 0;
  1146.  
  1147. static void *
  1148. tcp0(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.  
  1161. static void
  1162. tcp1(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.  
  1174. void *    gethostent()    { return tcp0("GETHOSTENT");  }
  1175. void *    getnetent()    { return tcp0("GETNETENT");   }
  1176. void *    getprotoent()    { return tcp0("GETPROTOENT"); }
  1177. void *    getservent()    { return tcp0("GETSERVENT");  }
  1178. void    sethostent(x)    { tcp1("SETHOSTENT",  x); }
  1179. void    setnetent(x)    { tcp1("SETNETENT",   x); }
  1180. void    setprotoent(x)    { tcp1("SETPROTOENT", x); }
  1181. void    setservent(x)    { tcp1("SETSERVENT",  x); }
  1182. void    endhostent()    { tcp0("ENDHOSTENT");  }
  1183. void    endnetent()    { tcp0("ENDNETENT");   }
  1184. void    endprotoent()    { tcp0("ENDPROTOENT"); }
  1185. void    endservent()    { tcp0("ENDSERVENT");  }
  1186.  
  1187. /*****************************************************************************/
  1188. /* not implemented in C Set++ */
  1189.  
  1190. #ifndef __EMX__
  1191. int    setuid(x)    { errno = EINVAL; return -1; }
  1192. int    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.  
  1203. int
  1204. os2_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.  
  1225. void *
  1226. sys_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.  
  1241. char *tmppath = TMPPATH1;
  1242.  
  1243. void
  1244. settmppath()
  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.  
  1263. XS(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.  
  1290. char *
  1291. mod2fname(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.  
  1337. XS(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.  
  1353. char *
  1354. os2error(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.  
  1376. char *
  1377. os2_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.  
  1394. char *
  1395. perllib_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.  
  1443. unsigned long 
  1444. Perl_hab_GET()            /* Needed if perl.h cannot be included */
  1445. {
  1446.     return perl_hab_GET();
  1447. }
  1448.  
  1449. HMQ
  1450. Perl_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.  
  1475. int
  1476. Perl_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.  
  1494. int
  1495. Perl_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.  
  1515. void
  1516. Perl_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.  
  1533. extern void dlopen();
  1534. void *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.  
  1546. static int DOS_harderr_state = -1;    
  1547.  
  1548. XS(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.  
  1571. static signed char DOS_suppression_state = -1;    
  1572.  
  1573. XS(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.  
  1603. static 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.  
  1631. XS(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.  
  1658. XS(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.  
  1678. XS(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.  
  1693. XS(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.  
  1706. XS(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.  
  1721. XS(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.  
  1746. XS(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.  
  1761. XS(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.  
  1778. XS(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.  
  1795. XS(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.  
  1812. XS(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.  
  1829. XS(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.  
  1846. XS(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.  
  1861. XS(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. }
  1968. typedef APIRET (*PELP)(PSZ path, ULONG type);
  1969.  
  1970. APIRET
  1971. ExtLIBPATH(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.  
  1986. XS(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.  
  2010. XS(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.  
  2035. int
  2036. Xs_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.  
  2083. OS2_Perl_data_t OS2_Perl_data;
  2084.  
  2085. void
  2086. Perl_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.  
  2120. char *
  2121. my_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.  
  2135. FILE *
  2136. my_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. */
  2151. int 
  2152. my_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. }
  2260.