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