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