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