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