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