projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
integrate mainline changes
[p5sagit/p5-mst-13.2.git] / os2 / os2.c
CommitLineData
4633a7c4 1#define INCL_DOS
2#define INCL_NOPM
7a2f0d5b 3#define INCL_DOSFILEMGR
760ac839 4#define INCL_DOSMEMMGR
5#define INCL_DOSERRORS
6e7c9e4d 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
4633a7c4 10#include <os2.h>
11
28743a51 12#include <sys/uflags.h>
13
4633a7c4 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>
72ea3524 22#include <fcntl.h>
4633a7c4 23
24#include "EXTERN.h"
25#include "perl.h"
26
dd96f567 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;
3aefca04 49 perl_cond cond;
dd96f567 50 enum pthreads_state state;
51} thread_join_t;
52
53thread_join_t *thread_join_data;
54int thread_join_count;
3aefca04 55perl_mutex start_thread_mutex;
dd96f567 56
57int
3aefca04 58pthread_join(perl_os_thread tid, void **status)
dd96f567 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
3aefca04 126pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
dd96f567 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
3aefca04 143pthread_detach(perl_os_thread tid)
dd96f567 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
3aefca04 166os2_cond_wait(perl_cond *c, perl_mutex *m)
dd96f567 167{
168 int rc;
2d8e6c8d 169 STRLEN n_a;
170 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
dd96f567 171 croak("panic: COND_WAIT-reset: rc=%i", rc);
172 if (m) MUTEX_UNLOCK(m);
91643db9 173 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
174 && (rc != ERROR_INTERRUPT))
dd96f567 175 croak("panic: COND_WAIT: rc=%i", rc);
91643db9 176 if (rc == ERROR_INTERRUPT)
177 errno = EINTR;
dd96f567 178 if (m) MUTEX_LOCK(m);
179}
180#endif
181
4633a7c4 182/*****************************************************************************/
72ea3524 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
4bfbfac5 188struct PMWIN_entries_t PMWIN_entries;
72ea3524 189
190APIRET
4bfbfac5 191loadByOrd(char *modname, ULONG ord)
72ea3524 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,
4bfbfac5 200 modname, &hdosc)))
72ea3524 201 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
4bfbfac5 202 croak("This version of OS/2 does not support %s.%i",
203 modname, loadOrd[ord]);
72ea3524 204 ExtFCN[ord] = fcn;
205 }
4bfbfac5 206 if ((long)ExtFCN[ord] == -1)
207 croak("panic queryaddr");
72ea3524 208}
209
4bfbfac5 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
4633a7c4 240/* priorities */
6f064249 241static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
242 self inverse. */
243#define QSS_INI_BUFFER 1024
4633a7c4 244
6f064249 245PQTOPLEVEL
246get_sysinfo(ULONG pid, ULONG flags)
4633a7c4 247{
6f064249 248 char *pbuffer;
249 ULONG rc, buf_len = QSS_INI_BUFFER;
250
fc36a67e 251 New(1322, pbuffer, buf_len, char);
6f064249 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);
df3ef7a9 256 rc = QuerySysState(flags, pid, pbuffer, buf_len);
6f064249 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
55497cff 295 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 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; */
4633a7c4 328}
329
6f064249 330int
331getpriority(int which /* ignored */, int pid)
4633a7c4 332{
333 TIB *tib;
334 PIB *pib;
6f064249 335 ULONG rc, ret;
336
55497cff 337 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 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);
4633a7c4 348}
349
350/*****************************************************************************/
351/* spawn */
2c2e0e8c 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}
72ea3524 374
4633a7c4 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() */
760ac839 381#ifndef __EMX__
382 RESULTCODES res;
383 int rpid;
384#endif
4633a7c4 385
760ac839 386 if (pid < 0 || flag != 0)
4633a7c4 387 return pid;
388
760ac839 389#ifdef __EMX__
2c2e0e8c 390 spawn_pid = pid;
391 spawn_killed = 0;
392 ihand = rsignal(SIGINT, &spawn_sighandler);
393 qhand = rsignal(SIGQUIT, &spawn_sighandler);
c0c09dfd 394 do {
395 r = wait4pid(pid, &status, 0);
396 } while (r == -1 && errno == EINTR);
72ea3524 397 rsignal(SIGINT, ihand);
398 rsignal(SIGQUIT, qhand);
4633a7c4 399
6b88bc9c 400 PL_statusvalue = (U16)status;
4633a7c4 401 if (r < 0)
402 return -1;
403 return status & 0xFFFF;
760ac839 404#else
72ea3524 405 ihand = rsignal(SIGINT, SIG_IGN);
760ac839 406 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
72ea3524 407 rsignal(SIGINT, ihand);
6b88bc9c 408 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
760ac839 409 if (r)
410 return -1;
6b88bc9c 411 return PL_statusvalue;
760ac839 412#endif
4633a7c4 413}
414
491527d0 415#define EXECF_SPAWN 0
416#define EXECF_EXEC 1
417#define EXECF_TRUEEXEC 2
418#define EXECF_SPAWN_NOWAIT 3
4435c477 419#define EXECF_SPAWN_BYFLAG 4
491527d0 420
017f25f1 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
491527d0 463/* Spawn/exec a program, revert to shell if needed. */
6b88bc9c 464/* global PL_Argv[] contains arguments. */
491527d0 465
4633a7c4 466int
5838269b 467do_spawn_ve(really, flag, execf, inicmd, addflag)
4633a7c4 468SV *really;
491527d0 469U32 flag;
470U32 execf;
2c2e0e8c 471char *inicmd;
5838269b 472U32 addflag;
4633a7c4 473{
dd96f567 474 dTHR;
491527d0 475 int trueflag = flag;
a97be121 476 int rc, pass = 1;
491527d0 477 char *tmps;
6756f2f0 478 char buf[256], *s = 0, scrbuf[280];
491527d0 479 char *args[4];
480 static char * fargs[4]
481 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
482 char **argsp = fargs;
483 char nargs = 4;
017f25f1 484 int force_shell;
5838269b 485 int new_stderr = -1, nostderr = 0, fl_stderr;
2d8e6c8d 486 STRLEN n_a;
491527d0 487
4633a7c4 488 if (flag == P_WAIT)
489 flag = P_NOWAIT;
490
491527d0 491 retry:
6b88bc9c 492 if (strEQ(PL_Argv[0],"/bin/sh"))
493 PL_Argv[0] = PL_sh_path;
3bbf9c2b 494
6b88bc9c 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] != '\\'))
2c2e0e8c 498 ) /* will spawnvp use PATH? */
c0c09dfd 499 TAINT_ENV(); /* testing IFS here is overkill, probably */
760ac839 500 /* We should check PERL_SH* and PERLLIB_* as well? */
2d8e6c8d 501 if (!really || !*(tmps = SvPV(really, n_a)))
6b88bc9c 502 tmps = PL_Argv[0];
017f25f1 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
5838269b 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
491527d0 586#if 0
6b88bc9c 587 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
491527d0 588#else
589 if (execf == EXECF_TRUEEXEC)
6b88bc9c 590 rc = execvp(tmps,PL_Argv);
491527d0 591 else if (execf == EXECF_EXEC)
6b88bc9c 592 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
491527d0 593 else if (execf == EXECF_SPAWN_NOWAIT)
017f25f1 594 rc = spawnvp(flag,tmps,PL_Argv);
4435c477 595 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
491527d0 596 rc = result(trueflag,
017f25f1 597 spawnvp(flag,tmps,PL_Argv));
491527d0 598#endif
2c2e0e8c 599 if (rc < 0 && pass == 1
6b88bc9c 600 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
017f25f1 601 do_script:
602 {
a97be121 603 int err = errno;
604
2c2e0e8c 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. */
6b88bc9c 609 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
2c2e0e8c 610
611 if (scr) {
e96326af 612 FILE *file;
2c2e0e8c 613 char *s = 0, *s1;
e96326af 614 int l;
2c2e0e8c 615
e96326af 616 l = strlen(scr);
617
618 if (l >= sizeof scrbuf) {
619 Safefree(scr);
620 longbuf:
5838269b 621 warn("Size of scriptname too big: %d", l);
622 rc = -1;
623 goto finish;
e96326af 624 }
625 strcpy(scrbuf, scr);
626 Safefree(scr);
627 scr = scrbuf;
628
629 file = fopen(scr, "r");
6b88bc9c 630 PL_Argv[0] = scr;
2c2e0e8c 631 if (!file)
632 goto panic_file;
017f25f1 633 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
017f25f1 634
635 buf[0] = 0;
2c2e0e8c 636 fclose(file);
017f25f1 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). */
6756f2f0 642 if (l + 5 < sizeof scrbuf) {
643 strcpy(scrbuf + l, ".exe");
644 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
017f25f1 645 && !S_ISDIR(PL_statbuf.st_mode)) {
646 /* Found */
647 tmps = scr;
648 pass++;
649 goto reread;
6756f2f0 650 } else
651 scrbuf[l] = 0;
652 } else
653 goto longbuf;
2c2e0e8c 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 {
6b88bc9c 708 char **a = PL_Argv;
2c2e0e8c 709 char *exec_args[2];
710
017f25f1 711 if (force_shell
712 || (!buf[0] && file)) { /* File without magic */
2c2e0e8c 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) {
6b88bc9c 734 s = PL_Argv[0];
2c2e0e8c 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 }
491527d0 743 }
491527d0 744 }
2c2e0e8c 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... */
6b88bc9c 759 PL_Argv[0] = inicmd;
760 PL_Argv[1] = Nullch;
491527d0 761 }
2c2e0e8c 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
6b88bc9c 767 PL_Argv[0] = inicmd;
768 PL_Argv[1] = Nullch;
2c2e0e8c 769 nargs = 2; /* shell -c */
770 }
771
772 while (a[1]) /* Get to the end */
773 a++;
774 a++; /* Copy finil NULL too */
6b88bc9c 775 while (a >= PL_Argv) {
776 *(a + nargs) = *a; /* PL_Argv was preallocated to be
2c2e0e8c 777 long enough. */
778 a--;
491527d0 779 }
2c2e0e8c 780 while (nargs-- >= 0)
6b88bc9c 781 PL_Argv[nargs] = argsp[nargs];
2c2e0e8c 782 /* Enable pathless exec if #! (as pdksh). */
783 pass = (buf[0] == '#' ? 2 : 3);
784 goto retry;
e29f6e02 785 }
786 }
2c2e0e8c 787 /* Not found: restore errno */
491527d0 788 errno = err;
2c2e0e8c 789 }
017f25f1 790 }
a97be121 791 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
6b88bc9c 792 char *no_dir = strrchr(PL_Argv[0], '/');
2c2e0e8c 793
794 /* Do as pdksh port does: if not found with /, try without
795 path. */
796 if (no_dir) {
6b88bc9c 797 PL_Argv[0] = no_dir + 1;
2c2e0e8c 798 pass++;
e29f6e02 799 goto retry;
800 }
801 }
0453d815 802 if (rc < 0 && ckWARN(WARN_EXEC))
803 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
491527d0 804 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
805 ? "spawn" : "exec"),
a97be121 806 PL_Argv[0], Strerror(errno));
491527d0 807 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
808 && ((trueflag & 0xFF) == P_WAIT))
6e7c9e4d 809 rc = -1;
491527d0 810
5838269b 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);
491527d0 818 return rc;
819}
820
491527d0 821/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
4633a7c4 822int
4435c477 823do_spawn3(char *cmd, int execf, int flag)
4633a7c4 824{
825 register char **a;
826 register char *s;
827 char flags[10];
3bbf9c2b 828 char *shell, *copt, *news = NULL;
5838269b 829 int rc, err, seenspace = 0, mergestderr = 0;
e29f6e02 830 char fullcmd[MAXNAMLEN + 1];
4633a7c4 831
c0c09dfd 832#ifdef TRYSHELL
833 if ((shell = getenv("EMXSHELL")) != NULL)
834 copt = "-c";
835 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4 836 copt = "-c";
837 else if ((shell = getenv("COMSPEC")) != NULL)
838 copt = "/C";
839 else
840 shell = "cmd.exe";
c0c09dfd 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. */
6b88bc9c 846 shell = PL_sh_path;
c0c09dfd 847 copt = "-c";
848#endif
849
850 while (*cmd && isSPACE(*cmd))
851 cmd++;
4633a7c4 852
3bbf9c2b 853 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
6b88bc9c 854 STRLEN l = strlen(PL_sh_path);
3bbf9c2b 855
2cc2f81f 856 New(1302, news, strlen(cmd) - 7 + l + 1, char);
6b88bc9c 857 strcpy(news, PL_sh_path);
3bbf9c2b 858 strcpy(news + l, cmd + 7);
859 cmd = news;
860 }
861
4633a7c4 862 /* save an extra exec if possible */
863 /* see if there are shell metacharacters in it */
864
c0c09dfd 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
4633a7c4 875 for (s = cmd; *s; s++) {
c0c09dfd 876 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 877 if (*s == '\n' && s[1] == '\0') {
4633a7c4 878 *s = '\0';
879 break;
a0914d8e 880 } else if (*s == '\\' && !seenspace) {
881 continue; /* Allow backslashes in names */
5838269b 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 }
4633a7c4 894 }
491527d0 895 /* We do not convert this to do_spawn_ve since shell
896 should be smart enough to start itself gloriously. */
c0c09dfd 897 doshell:
760ac839 898 if (execf == EXECF_TRUEEXEC)
2c2e0e8c 899 rc = execl(shell,shell,copt,cmd,(char*)0);
760ac839 900 else if (execf == EXECF_EXEC)
2c2e0e8c 901 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 902 else if (execf == EXECF_SPAWN_NOWAIT)
2c2e0e8c 903 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
4435c477 904 else if (execf == EXECF_SPAWN_BYFLAG)
905 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
2c2e0e8c 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));
0453d815 910 if (rc < 0 && ckWARN(WARN_EXEC))
911 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
2c2e0e8c 912 (execf == EXECF_SPAWN ? "spawn" : "exec"),
913 shell, Strerror(errno));
6e7c9e4d 914 if (rc < 0)
915 rc = -1;
2c2e0e8c 916 }
917 if (news)
918 Safefree(news);
c0c09dfd 919 return rc;
a0914d8e 920 } else if (*s == ' ' || *s == '\t') {
921 seenspace = 1;
4633a7c4 922 }
923 }
c0c09dfd 924
491527d0 925 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
6b88bc9c 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;) {
4633a7c4 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;
6b88bc9c 938 if (PL_Argv[0])
4435c477 939 rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr);
491527d0 940 else
4633a7c4 941 rc = -1;
2c2e0e8c 942 if (news)
943 Safefree(news);
4633a7c4 944 do_execfree();
945 return rc;
946}
947
4435c477 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
760ac839 990int
991do_spawn(cmd)
992char *cmd;
993{
4435c477 994 return do_spawn3(cmd, EXECF_SPAWN, 0);
760ac839 995}
996
72ea3524 997int
998do_spawn_nowait(cmd)
999char *cmd;
1000{
4435c477 1001 return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524 1002}
1003
760ac839 1004bool
1005do_exec(cmd)
1006char *cmd;
1007{
4435c477 1008 do_spawn3(cmd, EXECF_EXEC, 0);
017f25f1 1009 return FALSE;
760ac839 1010}
1011
1012bool
1013os2exec(cmd)
1014char *cmd;
1015{
4435c477 1016 return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
760ac839 1017}
1018
3bbf9c2b 1019PerlIO *
1020my_syspopen(cmd,mode)
c0c09dfd 1021char *cmd;
1022char *mode;
1023{
72ea3524 1024#ifndef USE_POPEN
1025
1026 int p[2];
1027 register I32 this, that, newfd;
1028 register I32 pid, rc;
3bbf9c2b 1029 PerlIO *res;
1030 SV *sv;
5838269b 1031 int fh_fl;
72ea3524 1032
72ea3524 1033 /* `this' is what we use in the parent, `that' in the child. */
1034 this = (*mode == 'w');
1035 that = !this;
6b88bc9c 1036 if (PL_tainting) {
72ea3524 1037 taint_env();
1038 taint_proper("Insecure %s%s", "EXEC");
1039 }
c2267164 1040 if (pipe(p) < 0)
1041 return Nullfp;
72ea3524 1042 /* Now we need to spawn the child. */
5838269b 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 }
72ea3524 1051 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b 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. */
72ea3524 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);
5838269b 1070 if (newfd != -1)
1071 fcntl(newfd, F_SETFD, FD_CLOEXEC);
72ea3524 1072 pid = do_spawn_nowait(cmd);
5838269b 1073 if (newfd == -1)
1074 close(*mode == 'r'); /* It was closed initially */
1075 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524 1076 dup2(newfd, *mode == 'r'); /* Return std* back. */
1077 close(newfd);
5838269b 1078 fcntl(*mode == 'r', F_SETFD, fh_fl);
1079 } else
1080 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0 1081 if (p[that] == (*mode == 'r'))
1082 close(p[that]);
72ea3524 1083 if (pid == -1) {
1084 close(p[this]);
5838269b 1085 return Nullfp;
72ea3524 1086 }
5838269b 1087 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524 1088 dup2(p[this], p[that]);
1089 close(p[this]);
1090 p[this] = p[that];
1091 }
6b88bc9c 1092 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524 1093 (void)SvUPGRADE(sv,SVt_IV);
1094 SvIVX(sv) = pid;
6b88bc9c 1095 PL_forkprocess = pid;
72ea3524 1096 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1097
72ea3524 1098#else /* USE_POPEN */
1099
1100 PerlIO *res;
1101 SV *sv;
1102
1103# ifdef TRYSHELL
3bbf9c2b 1104 res = popen(cmd, mode);
72ea3524 1105# else
c0c09dfd 1106 char *shell = getenv("EMXSHELL");
3bbf9c2b 1107
6b88bc9c 1108 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 1109 res = popen(cmd, mode);
1110 my_setenv("EMXSHELL", shell);
72ea3524 1111# endif
6b88bc9c 1112 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
3bbf9c2b 1113 (void)SvUPGRADE(sv,SVt_IV);
1114 SvIVX(sv) = -1; /* A cooky. */
1115 return res;
72ea3524 1116
1117#endif /* USE_POPEN */
1118
c0c09dfd 1119}
1120
3bbf9c2b 1121/******************************************************************/
4633a7c4 1122
1123#ifndef HAS_FORK
1124int
1125fork(void)
1126{
4bfbfac5 1127 croak(PL_no_func, "Unsupported function fork");
4633a7c4 1128 errno = EINVAL;
1129 return -1;
1130}
1131#endif
1132
3bbf9c2b 1133/*******************************************************************/
4633a7c4 1134/* not implemented in EMX 0.9a */
1135
1136void * ctermid(x) { return 0; }
eacfb5f1 1137
1138#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 1139void * ttyname(x) { return 0; }
eacfb5f1 1140#endif
4633a7c4 1141
3bbf9c2b 1142/******************************************************************/
760ac839 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;
55497cff 1152
1153 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 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;
55497cff 1166
1167 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 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
4633a7c4 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
c0c09dfd 1220
760ac839 1221#ifdef USE_PERL_SBRK
c0c09dfd 1222
760ac839 1223/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1224
1225void *
760ac839 1226sys_alloc(int size) {
1227 void *got;
1228 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1229
c0c09dfd 1230 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1231 return (void *) -1;
4bfbfac5 1232 } else if ( rc )
1233 croak("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1234 return got;
c0c09dfd 1235}
760ac839 1236
1237#endif /* USE_PERL_SBRK */
c0c09dfd 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);
db7c17d7 1253 if (tpath) {
1254 strcpy(tpath, p);
1255 tpath[len] = '/';
1256 strcpy(tpath + len + 1, TMPPATH1);
1257 tmppath = tpath;
1258 }
c0c09dfd 1259}
7a2f0d5b 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 {
2d8e6c8d 1269 STRLEN n_a;
1270 char * src = (char *)SvPV(ST(0),n_a);
1271 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 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
6f064249 1281 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b 1282 ST(0) = sv_newmortal();
1283 sv_setiv(ST(0), (IV)RETVAL);
1284 }
1285 XSRETURN(1);
1286}
1287
017f25f1 1288#include "patchlevel.h"
1289
6f064249 1290char *
1291mod2fname(sv)
1292 SV *sv;
1293{
1294 static char fname[9];
760ac839 1295 int pos = 6, len, avlen;
1296 unsigned int sum = 0;
6f064249 1297 AV *av;
1298 SV *svp;
1299 char *s;
2d8e6c8d 1300 STRLEN n_a;
6f064249 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");
760ac839 1306
1307 avlen = av_len((AV*)sv);
1308 if (avlen < 0)
6f064249 1309 croak("Empty array reference given to mod2fname");
760ac839 1310
2d8e6c8d 1311 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 1312 strncpy(fname, s, 8);
760ac839 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) {
2d8e6c8d 1321 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839 1322 while (*s) {
1323 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1324 }
1325 avlen --;
1326 }
3aefca04 1327#ifdef USE_THREADS
1328 sum++; /* Avoid conflict of DLLs in memory. */
1329#endif
cceca5ed 1330 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
760ac839 1331 fname[pos] = 'A' + (sum % 26);
1332 fname[pos + 1] = 'A' + (sum / 26 % 26);
1333 fname[pos + 2] = '\0';
6f064249 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
55497cff 1359 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 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);
6e7c9e4d 1364 else {
6f064249 1365 buf[len] = '\0';
6e7c9e4d 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 }
6f064249 1373 return buf;
1374}
1375
760ac839 1376char *
6e7c9e4d 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 *
760ac839 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) {
ff68c719 1404 char *s;
1405
760ac839 1406 oldp = newp;
89078e0f 1407 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839 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) {
4bfbfac5 1415 croak("Malformed PERLLIB_PREFIX");
760ac839 1416 }
ff68c719 1417 strcpy(ret, newp);
1418 s = ret;
1419 while (*s) {
1420 if (*s == '\\') *s = '/';
1421 s++;
1422 }
760ac839 1423 } else {
1424 notfound = 1;
1425 }
1426 }
1427 if (!newp) {
1428 return s;
1429 }
1430 if (l == 0) {
1431 l = strlen(s);
1432 }
3bbf9c2b 1433 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839 1434 return s;
1435 }
1436 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
4bfbfac5 1437 croak("Malformed PERLLIB_PREFIX");
760ac839 1438 }
89078e0f 1439 strcpy(ret + newl, s + oldl);
760ac839 1440 return ret;
1441}
6f064249 1442
4bfbfac5 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
6f064249 1533extern void dlopen();
1534void *fakedl = &dlopen; /* Pull in dynaloading part. */
3bbf9c2b 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
4bfbfac5 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 {
2d8e6c8d 1579 STRLEN n_a;
4bfbfac5 1580 SV *sv = ST(0);
1581 int suppress = SvOK(sv);
2d8e6c8d 1582 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5 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
3bbf9c2b 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 {
2d8e6c8d 1767 STRLEN n_a;
1768 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1769 bool RETVAL;
1770
1771 RETVAL = sys_chdir(path);
54310121 1772 ST(0) = boolSV(RETVAL);
3bbf9c2b 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 {
2d8e6c8d 1784 STRLEN n_a;
1785 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b 1786 bool RETVAL;
1787
1788 RETVAL = change_drive(d);
54310121 1789 ST(0) = boolSV(RETVAL);
3bbf9c2b 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 {
2d8e6c8d 1801 STRLEN n_a;
1802 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1803 bool RETVAL;
1804
1805 RETVAL = sys_is_absolute(path);
54310121 1806 ST(0) = boolSV(RETVAL);
3bbf9c2b 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 {
2d8e6c8d 1818 STRLEN n_a;
1819 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1820 bool RETVAL;
1821
1822 RETVAL = sys_is_rooted(path);
54310121 1823 ST(0) = boolSV(RETVAL);
3bbf9c2b 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 {
2d8e6c8d 1835 STRLEN n_a;
1836 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1837 bool RETVAL;
1838
1839 RETVAL = sys_is_relative(path);
54310121 1840 ST(0) = boolSV(RETVAL);
3bbf9c2b 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 {
2d8e6c8d 1867 STRLEN n_a;
1868 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1869 char * dir;
1870 char p[MAXPATHLEN];
1871 char * RETVAL;
1872
1873 if (items < 2)
1874 dir = NULL;
1875 else {
2d8e6c8d 1876 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b 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}
72ea3524 1968typedef APIRET (*PELP)(PSZ path, ULONG type);
1969
1970APIRET
1971ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1972{
4bfbfac5 1973 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
72ea3524 1974 return (*(PELP)ExtFCN[ord])(path, type);
1975}
3bbf9c2b 1976
72ea3524 1977#define extLibpath(type) \
1978 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1979 : BEGIN_LIBPATH))) \
3bbf9c2b 1980 ? NULL : to )
1981
1982#define extLibpath_set(p,type) \
72ea3524 1983 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1984 : BEGIN_LIBPATH))))
3bbf9c2b 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 {
2d8e6c8d 2016 STRLEN n_a;
2017 char * s = (char *)SvPV(ST(0),n_a);
3bbf9c2b 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);
54310121 2029 ST(0) = boolSV(RETVAL);
3bbf9c2b 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;
55497cff 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 }
4bfbfac5 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);
3bbf9c2b 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);
3bbf9c2b 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
4bfbfac5 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);
3bbf9c2b 2080 }
2081}
2082
2083OS2_Perl_data_t OS2_Perl_data;
2084
2085void
aa689395 2086Perl_OS2_init(char **env)
3bbf9c2b 2087{
2088 char *shell;
2089
18f739ee 2090 MALLOC_INIT;
3bbf9c2b 2091 settmppath();
2092 OS2_Perl_data.xs_init = &Xs_OS2_init;
28743a51 2093 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
6e7c9e4d 2094 if (environ == NULL && env) {
aa689395 2095 environ = env;
2096 }
3bbf9c2b 2097 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c 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];
3bbf9c2b 2101 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 2102 int l = strlen(shell), i;
3bbf9c2b 2103 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2104 l--;
2105 }
6b88bc9c 2106 New(1304, PL_sh_path, l + 8, char);
2107 strncpy(PL_sh_path, shell, l);
2108 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 2109 for (i = 0; i < l; i++) {
6b88bc9c 2110 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 2111 }
3bbf9c2b 2112 }
dd96f567 2113 MUTEX_INIT(&start_thread_mutex);
017f25f1 2114 os2_mytype = my_type(); /* Do it before morphing. Needed? */
3bbf9c2b 2115}
2116
55497cff 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}
367f3c24 2147
2148#undef flock
2149
2150/* This code was contributed by Rocco Caputo. */
2151int
dd96f567 2152my_flock(int handle, int o)
367f3c24 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)
dd96f567 2168 return flock(handle, o); /* Delegate to EMX. */
367f3c24 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
dd96f567 2181 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
367f3c24 2182 // shared or exclusive?
dd96f567 2183 shared = (o & LOCK_SH) ? 1 : 0;
367f3c24 2184 // do not block the unlock
dd96f567 2185 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 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
dd96f567 2213 if (o & (LOCK_SH | LOCK_EX)) {
367f3c24 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}
Unnamed repository; edit this file to name it for gitweb.