projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
lexical warnings update (warning.t fails one test
[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
4435c477 415#define EXECF_SPAWN_BYFLAG 4
491527d0 416
017f25f1 417/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
418
419static int
420my_type()
421{
422 int rc;
423 TIB *tib;
424 PIB *pib;
425
426 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
427 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
428 return -1;
429
430 return (pib->pib_ultype);
431}
432
433static ULONG
434file_type(char *path)
435{
436 int rc;
437 ULONG apptype;
438
439 if (!(_emx_env & 0x200))
440 croak("file_type not implemented on DOS"); /* not OS/2. */
441 if (CheckOSError(DosQueryAppType(path, &apptype))) {
442 switch (rc) {
443 case ERROR_FILE_NOT_FOUND:
444 case ERROR_PATH_NOT_FOUND:
445 return -1;
446 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
447 return -3;
448 default: /* Found, but not an
449 executable, or some other
450 read error. */
451 return -2;
452 }
453 }
454 return apptype;
455}
456
457static ULONG os2_mytype;
458
491527d0 459/* Spawn/exec a program, revert to shell if needed. */
6b88bc9c 460/* global PL_Argv[] contains arguments. */
491527d0 461
4633a7c4 462int
5838269b 463do_spawn_ve(really, flag, execf, inicmd, addflag)
4633a7c4 464SV *really;
491527d0 465U32 flag;
466U32 execf;
2c2e0e8c 467char *inicmd;
5838269b 468U32 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)
540 warn("Starting PM process with flag=%d, mytype=%d",
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)
551 warn("Starting Full Screen process with flag=%d, mytype=%d",
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
6b88bc9c 583 rc = result(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 */
491527d0 592 rc = result(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:
5838269b 617 warn("Size of scriptname too big: %d", l);
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:
653 warn("Error reading \"%s\": %s",
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) {
697 warn("Too many args on %.*s line of \"%s\"",
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 }
2c2e0e8c 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))
805 rc = 255 << 8; /* Emulate the fork(). */
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
4435c477 819do_spawn3(char *cmd, int execf, int flag)
4633a7c4 820{
821 register char **a;
822 register char *s;
823 char flags[10];
3bbf9c2b 824 char *shell, *copt, *news = NULL;
5838269b 825 int rc, err, seenspace = 0, mergestderr = 0;
e29f6e02 826 char fullcmd[MAXNAMLEN + 1];
4633a7c4 827
c0c09dfd 828#ifdef TRYSHELL
829 if ((shell = getenv("EMXSHELL")) != NULL)
830 copt = "-c";
831 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4 832 copt = "-c";
833 else if ((shell = getenv("COMSPEC")) != NULL)
834 copt = "/C";
835 else
836 shell = "cmd.exe";
c0c09dfd 837#else
838 /* Consensus on perl5-porters is that it is _very_ important to
839 have a shell which will not change between computers with the
840 same architecture, to avoid "action on a distance".
841 And to have simple build, this shell should be sh. */
6b88bc9c 842 shell = PL_sh_path;
c0c09dfd 843 copt = "-c";
844#endif
845
846 while (*cmd && isSPACE(*cmd))
847 cmd++;
4633a7c4 848
3bbf9c2b 849 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
6b88bc9c 850 STRLEN l = strlen(PL_sh_path);
3bbf9c2b 851
2cc2f81f 852 New(1302, news, strlen(cmd) - 7 + l + 1, char);
6b88bc9c 853 strcpy(news, PL_sh_path);
3bbf9c2b 854 strcpy(news + l, cmd + 7);
855 cmd = news;
856 }
857
4633a7c4 858 /* save an extra exec if possible */
859 /* see if there are shell metacharacters in it */
860
c0c09dfd 861 if (*cmd == '.' && isSPACE(cmd[1]))
862 goto doshell;
863
864 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
865 goto doshell;
866
867 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
868 if (*s == '=')
869 goto doshell;
870
4633a7c4 871 for (s = cmd; *s; s++) {
c0c09dfd 872 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 873 if (*s == '\n' && s[1] == '\0') {
4633a7c4 874 *s = '\0';
875 break;
a0914d8e 876 } else if (*s == '\\' && !seenspace) {
877 continue; /* Allow backslashes in names */
5838269b 878 } else if (*s == '>' && s >= cmd + 3
879 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
880 && isSPACE(s[-2]) ) {
881 char *t = s + 3;
882
883 while (*t && isSPACE(*t))
884 t++;
885 if (!*t) {
886 s[-2] = '\0';
887 mergestderr = 1;
888 break; /* Allow 2>&1 as the last thing */
889 }
4633a7c4 890 }
491527d0 891 /* We do not convert this to do_spawn_ve since shell
892 should be smart enough to start itself gloriously. */
c0c09dfd 893 doshell:
760ac839 894 if (execf == EXECF_TRUEEXEC)
2c2e0e8c 895 rc = execl(shell,shell,copt,cmd,(char*)0);
760ac839 896 else if (execf == EXECF_EXEC)
2c2e0e8c 897 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 898 else if (execf == EXECF_SPAWN_NOWAIT)
2c2e0e8c 899 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
4435c477 900 else if (execf == EXECF_SPAWN_BYFLAG)
901 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
2c2e0e8c 902 else {
903 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
904 rc = result(P_WAIT,
905 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
0453d815 906 if (rc < 0 && ckWARN(WARN_EXEC))
907 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
2c2e0e8c 908 (execf == EXECF_SPAWN ? "spawn" : "exec"),
909 shell, Strerror(errno));
910 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
911 }
912 if (news)
913 Safefree(news);
c0c09dfd 914 return rc;
a0914d8e 915 } else if (*s == ' ' || *s == '\t') {
916 seenspace = 1;
4633a7c4 917 }
918 }
c0c09dfd 919
491527d0 920 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
6b88bc9c 921 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
922 PL_Cmd = savepvn(cmd, s-cmd);
923 a = PL_Argv;
924 for (s = PL_Cmd; *s;) {
4633a7c4 925 while (*s && isSPACE(*s)) s++;
926 if (*s)
927 *(a++) = s;
928 while (*s && !isSPACE(*s)) s++;
929 if (*s)
930 *s++ = '\0';
931 }
932 *a = Nullch;
6b88bc9c 933 if (PL_Argv[0])
4435c477 934 rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr);
491527d0 935 else
4633a7c4 936 rc = -1;
2c2e0e8c 937 if (news)
938 Safefree(news);
4633a7c4 939 do_execfree();
940 return rc;
941}
942
4435c477 943/* Array spawn. */
944int
945do_aspawn(really,mark,sp)
946SV *really;
947register SV **mark;
948register SV **sp;
949{
950 dTHR;
951 register char **a;
952 int rc;
953 int flag = P_WAIT, flag_set = 0;
954 STRLEN n_a;
955
956 if (sp > mark) {
957 New(1301,PL_Argv, sp - mark + 3, char*);
958 a = PL_Argv;
959
960 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
961 ++mark;
962 flag = SvIVx(*mark);
963 flag_set = 1;
964
965 }
966
967 while (++mark <= sp) {
968 if (*mark)
969 *a++ = SvPVx(*mark, n_a);
970 else
971 *a++ = "";
972 }
973 *a = Nullch;
974
975 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
976 rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag);
977 } else
978 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0);
979 } else
980 rc = -1;
981 do_execfree();
982 return rc;
983}
984
760ac839 985int
986do_spawn(cmd)
987char *cmd;
988{
4435c477 989 return do_spawn3(cmd, EXECF_SPAWN, 0);
760ac839 990}
991
72ea3524 992int
993do_spawn_nowait(cmd)
994char *cmd;
995{
4435c477 996 return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524 997}
998
760ac839 999bool
1000do_exec(cmd)
1001char *cmd;
1002{
4435c477 1003 do_spawn3(cmd, EXECF_EXEC, 0);
017f25f1 1004 return FALSE;
760ac839 1005}
1006
1007bool
1008os2exec(cmd)
1009char *cmd;
1010{
4435c477 1011 return do_spawn3(cmd, EXECF_TRUEEXEC, 0);
760ac839 1012}
1013
3bbf9c2b 1014PerlIO *
1015my_syspopen(cmd,mode)
c0c09dfd 1016char *cmd;
1017char *mode;
1018{
72ea3524 1019#ifndef USE_POPEN
1020
1021 int p[2];
1022 register I32 this, that, newfd;
1023 register I32 pid, rc;
3bbf9c2b 1024 PerlIO *res;
1025 SV *sv;
5838269b 1026 int fh_fl;
72ea3524 1027
72ea3524 1028 /* `this' is what we use in the parent, `that' in the child. */
1029 this = (*mode == 'w');
1030 that = !this;
6b88bc9c 1031 if (PL_tainting) {
72ea3524 1032 taint_env();
1033 taint_proper("Insecure %s%s", "EXEC");
1034 }
c2267164 1035 if (pipe(p) < 0)
1036 return Nullfp;
72ea3524 1037 /* Now we need to spawn the child. */
5838269b 1038 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1039 int new = dup(p[this]);
1040
1041 if (new == -1)
1042 goto closepipes;
1043 close(p[this]);
1044 p[this] = new;
1045 }
72ea3524 1046 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b 1047 if (newfd == -1) {
1048 /* This cannot happen due to fh being bad after pipe(), since
1049 pipe() should have created fh 0 and 1 even if they were
1050 initially closed. But we closed p[this] before. */
1051 if (errno != EBADF) {
1052 closepipes:
1053 close(p[0]);
1054 close(p[1]);
1055 return Nullfp;
1056 }
1057 } else
1058 fh_fl = fcntl(*mode == 'r', F_GETFD);
1059 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
72ea3524 1060 dup2(p[that], *mode == 'r');
1061 close(p[that]);
1062 }
1063 /* Where is `this' and newfd now? */
1064 fcntl(p[this], F_SETFD, FD_CLOEXEC);
5838269b 1065 if (newfd != -1)
1066 fcntl(newfd, F_SETFD, FD_CLOEXEC);
72ea3524 1067 pid = do_spawn_nowait(cmd);
5838269b 1068 if (newfd == -1)
1069 close(*mode == 'r'); /* It was closed initially */
1070 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524 1071 dup2(newfd, *mode == 'r'); /* Return std* back. */
1072 close(newfd);
5838269b 1073 fcntl(*mode == 'r', F_SETFD, fh_fl);
1074 } else
1075 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0 1076 if (p[that] == (*mode == 'r'))
1077 close(p[that]);
72ea3524 1078 if (pid == -1) {
1079 close(p[this]);
5838269b 1080 return Nullfp;
72ea3524 1081 }
5838269b 1082 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524 1083 dup2(p[this], p[that]);
1084 close(p[this]);
1085 p[this] = p[that];
1086 }
6b88bc9c 1087 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524 1088 (void)SvUPGRADE(sv,SVt_IV);
1089 SvIVX(sv) = pid;
6b88bc9c 1090 PL_forkprocess = pid;
72ea3524 1091 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1092
72ea3524 1093#else /* USE_POPEN */
1094
1095 PerlIO *res;
1096 SV *sv;
1097
1098# ifdef TRYSHELL
3bbf9c2b 1099 res = popen(cmd, mode);
72ea3524 1100# else
c0c09dfd 1101 char *shell = getenv("EMXSHELL");
3bbf9c2b 1102
6b88bc9c 1103 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 1104 res = popen(cmd, mode);
1105 my_setenv("EMXSHELL", shell);
72ea3524 1106# endif
6b88bc9c 1107 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
3bbf9c2b 1108 (void)SvUPGRADE(sv,SVt_IV);
1109 SvIVX(sv) = -1; /* A cooky. */
1110 return res;
72ea3524 1111
1112#endif /* USE_POPEN */
1113
c0c09dfd 1114}
1115
3bbf9c2b 1116/******************************************************************/
4633a7c4 1117
1118#ifndef HAS_FORK
1119int
1120fork(void)
1121{
4bfbfac5 1122 croak(PL_no_func, "Unsupported function fork");
4633a7c4 1123 errno = EINVAL;
1124 return -1;
1125}
1126#endif
1127
3bbf9c2b 1128/*******************************************************************/
4633a7c4 1129/* not implemented in EMX 0.9a */
1130
1131void * ctermid(x) { return 0; }
eacfb5f1 1132
1133#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 1134void * ttyname(x) { return 0; }
eacfb5f1 1135#endif
4633a7c4 1136
3bbf9c2b 1137/******************************************************************/
760ac839 1138/* my socket forwarders - EMX lib only provides static forwarders */
1139
1140static HMODULE htcp = 0;
1141
1142static void *
1143tcp0(char *name)
1144{
1145 static BYTE buf[20];
1146 PFN fcn;
55497cff 1147
1148 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 1149 if (!htcp)
1150 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1151 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1152 return (void *) ((void * (*)(void)) fcn) ();
1153 return 0;
1154}
1155
1156static void
1157tcp1(char *name, int arg)
1158{
1159 static BYTE buf[20];
1160 PFN fcn;
55497cff 1161
1162 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 1163 if (!htcp)
1164 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1165 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1166 ((void (*)(int)) fcn) (arg);
1167}
1168
1169void * gethostent() { return tcp0("GETHOSTENT"); }
1170void * getnetent() { return tcp0("GETNETENT"); }
1171void * getprotoent() { return tcp0("GETPROTOENT"); }
1172void * getservent() { return tcp0("GETSERVENT"); }
1173void sethostent(x) { tcp1("SETHOSTENT", x); }
1174void setnetent(x) { tcp1("SETNETENT", x); }
1175void setprotoent(x) { tcp1("SETPROTOENT", x); }
1176void setservent(x) { tcp1("SETSERVENT", x); }
1177void endhostent() { tcp0("ENDHOSTENT"); }
1178void endnetent() { tcp0("ENDNETENT"); }
1179void endprotoent() { tcp0("ENDPROTOENT"); }
1180void endservent() { tcp0("ENDSERVENT"); }
1181
1182/*****************************************************************************/
1183/* not implemented in C Set++ */
1184
1185#ifndef __EMX__
1186int setuid(x) { errno = EINVAL; return -1; }
1187int setgid(x) { errno = EINVAL; return -1; }
1188#endif
4633a7c4 1189
1190/*****************************************************************************/
1191/* stat() hack for char/block device */
1192
1193#if OS2_STAT_HACK
1194
1195 /* First attempt used DosQueryFSAttach which crashed the system when
1196 used with 5.001. Now just look for /dev/. */
1197
1198int
1199os2_stat(char *name, struct stat *st)
1200{
1201 static int ino = SHRT_MAX;
1202
1203 if (stricmp(name, "/dev/con") != 0
1204 && stricmp(name, "/dev/tty") != 0)
1205 return stat(name, st);
1206
1207 memset(st, 0, sizeof *st);
1208 st->st_mode = S_IFCHR|0666;
1209 st->st_ino = (ino-- & 0x7FFF);
1210 st->st_nlink = 1;
1211 return 0;
1212}
1213
1214#endif
c0c09dfd 1215
760ac839 1216#ifdef USE_PERL_SBRK
c0c09dfd 1217
760ac839 1218/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1219
1220void *
760ac839 1221sys_alloc(int size) {
1222 void *got;
1223 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1224
c0c09dfd 1225 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1226 return (void *) -1;
4bfbfac5 1227 } else if ( rc )
1228 croak("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1229 return got;
c0c09dfd 1230}
760ac839 1231
1232#endif /* USE_PERL_SBRK */
c0c09dfd 1233
1234/* tmp path */
1235
1236char *tmppath = TMPPATH1;
1237
1238void
1239settmppath()
1240{
1241 char *p = getenv("TMP"), *tpath;
1242 int len;
1243
1244 if (!p) p = getenv("TEMP");
1245 if (!p) return;
1246 len = strlen(p);
1247 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
db7c17d7 1248 if (tpath) {
1249 strcpy(tpath, p);
1250 tpath[len] = '/';
1251 strcpy(tpath + len + 1, TMPPATH1);
1252 tmppath = tpath;
1253 }
c0c09dfd 1254}
7a2f0d5b 1255
1256#include "XSUB.h"
1257
1258XS(XS_File__Copy_syscopy)
1259{
1260 dXSARGS;
1261 if (items < 2 || items > 3)
1262 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1263 {
2d8e6c8d 1264 STRLEN n_a;
1265 char * src = (char *)SvPV(ST(0),n_a);
1266 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 1267 U32 flag;
1268 int RETVAL, rc;
1269
1270 if (items < 3)
1271 flag = 0;
1272 else {
1273 flag = (unsigned long)SvIV(ST(2));
1274 }
1275
6f064249 1276 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b 1277 ST(0) = sv_newmortal();
1278 sv_setiv(ST(0), (IV)RETVAL);
1279 }
1280 XSRETURN(1);
1281}
1282
017f25f1 1283#include "patchlevel.h"
1284
6f064249 1285char *
1286mod2fname(sv)
1287 SV *sv;
1288{
1289 static char fname[9];
760ac839 1290 int pos = 6, len, avlen;
1291 unsigned int sum = 0;
6f064249 1292 AV *av;
1293 SV *svp;
1294 char *s;
2d8e6c8d 1295 STRLEN n_a;
6f064249 1296
1297 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1298 sv = SvRV(sv);
1299 if (SvTYPE(sv) != SVt_PVAV)
1300 croak("Not array reference given to mod2fname");
760ac839 1301
1302 avlen = av_len((AV*)sv);
1303 if (avlen < 0)
6f064249 1304 croak("Empty array reference given to mod2fname");
760ac839 1305
2d8e6c8d 1306 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 1307 strncpy(fname, s, 8);
760ac839 1308 len = strlen(s);
1309 if (len < 6) pos = len;
1310 while (*s) {
1311 sum = 33 * sum + *(s++); /* Checksumming first chars to
1312 * get the capitalization into c.s. */
1313 }
1314 avlen --;
1315 while (avlen >= 0) {
2d8e6c8d 1316 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839 1317 while (*s) {
1318 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1319 }
1320 avlen --;
1321 }
3aefca04 1322#ifdef USE_THREADS
1323 sum++; /* Avoid conflict of DLLs in memory. */
1324#endif
cceca5ed 1325 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
760ac839 1326 fname[pos] = 'A' + (sum % 26);
1327 fname[pos + 1] = 'A' + (sum / 26 % 26);
1328 fname[pos + 2] = '\0';
6f064249 1329 return (char *)fname;
1330}
1331
1332XS(XS_DynaLoader_mod2fname)
1333{
1334 dXSARGS;
1335 if (items != 1)
1336 croak("Usage: DynaLoader::mod2fname(sv)");
1337 {
1338 SV * sv = ST(0);
1339 char * RETVAL;
1340
1341 RETVAL = mod2fname(sv);
1342 ST(0) = sv_newmortal();
1343 sv_setpv((SV*)ST(0), RETVAL);
1344 }
1345 XSRETURN(1);
1346}
1347
1348char *
1349os2error(int rc)
1350{
1351 static char buf[300];
1352 ULONG len;
1353
55497cff 1354 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 1355 if (rc == 0)
1356 return NULL;
1357 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1358 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1359 else
1360 buf[len] = '\0';
017f25f1 1361 if (len > 0 && buf[len - 1] == '\n')
1362 buf[len - 1] = '\0';
1363 if (len > 1 && buf[len - 2] == '\r')
1364 buf[len - 2] = '\0';
1365 if (len > 2 && buf[len - 3] == '.')
1366 buf[len - 3] = '\0';
6f064249 1367 return buf;
1368}
1369
760ac839 1370char *
1371perllib_mangle(char *s, unsigned int l)
1372{
1373 static char *newp, *oldp;
1374 static int newl, oldl, notfound;
1375 static char ret[STATIC_FILE_LENGTH+1];
1376
1377 if (!newp && !notfound) {
1378 newp = getenv("PERLLIB_PREFIX");
1379 if (newp) {
ff68c719 1380 char *s;
1381
760ac839 1382 oldp = newp;
89078e0f 1383 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839 1384 newp++; oldl++; /* Skip digits. */
1385 }
1386 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1387 newp++; /* Skip whitespace. */
1388 }
1389 newl = strlen(newp);
1390 if (newl == 0 || oldl == 0) {
4bfbfac5 1391 croak("Malformed PERLLIB_PREFIX");
760ac839 1392 }
ff68c719 1393 strcpy(ret, newp);
1394 s = ret;
1395 while (*s) {
1396 if (*s == '\\') *s = '/';
1397 s++;
1398 }
760ac839 1399 } else {
1400 notfound = 1;
1401 }
1402 }
1403 if (!newp) {
1404 return s;
1405 }
1406 if (l == 0) {
1407 l = strlen(s);
1408 }
3bbf9c2b 1409 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839 1410 return s;
1411 }
1412 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
4bfbfac5 1413 croak("Malformed PERLLIB_PREFIX");
760ac839 1414 }
89078e0f 1415 strcpy(ret + newl, s + oldl);
760ac839 1416 return ret;
1417}
6f064249 1418
4bfbfac5 1419unsigned long
1420Perl_hab_GET() /* Needed if perl.h cannot be included */
1421{
1422 return perl_hab_GET();
1423}
1424
1425HMQ
1426Perl_Register_MQ(int serve)
1427{
1428 PPIB pib;
1429 PTIB tib;
1430
1431 if (Perl_os2_initial_mode++)
1432 return Perl_hmq;
1433 DosGetInfoBlocks(&tib, &pib);
1434 Perl_os2_initial_mode = pib->pib_ultype;
1435 Perl_hmq_refcnt = 1;
1436 /* Try morphing into a PM application. */
1437 if (pib->pib_ultype != 3) /* 2 is VIO */
1438 pib->pib_ultype = 3; /* 3 is PM */
1439 init_PMWIN_entries();
1440 /* 64 messages if before OS/2 3.0, ignored otherwise */
1441 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1442 if (!Perl_hmq) {
1443 static int cnt;
1444 if (cnt++)
1445 _exit(188); /* Panic can try to create a window. */
1446 croak("Cannot create a message queue, or morph to a PM application");
1447 }
1448 return Perl_hmq;
1449}
1450
1451int
1452Perl_Serve_Messages(int force)
1453{
1454 int cnt = 0;
1455 QMSG msg;
1456
1457 if (Perl_hmq_servers && !force)
1458 return 0;
1459 if (!Perl_hmq_refcnt)
1460 croak("No message queue");
1461 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1462 cnt++;
1463 if (msg.msg == WM_QUIT)
1464 croak("QUITing...");
1465 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1466 }
1467 return cnt;
1468}
1469
1470int
1471Perl_Process_Messages(int force, I32 *cntp)
1472{
1473 QMSG msg;
1474
1475 if (Perl_hmq_servers && !force)
1476 return 0;
1477 if (!Perl_hmq_refcnt)
1478 croak("No message queue");
1479 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1480 if (cntp)
1481 (*cntp)++;
1482 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1483 if (msg.msg == WM_DESTROY)
1484 return -1;
1485 if (msg.msg == WM_CREATE)
1486 return +1;
1487 }
1488 croak("QUITing...");
1489}
1490
1491void
1492Perl_Deregister_MQ(int serve)
1493{
1494 PPIB pib;
1495 PTIB tib;
1496
1497 if (--Perl_hmq_refcnt == 0) {
1498 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1499 Perl_hmq = 0;
1500 /* Try morphing back from a PM application. */
1501 if (pib->pib_ultype == 3) /* 3 is PM */
1502 pib->pib_ultype = Perl_os2_initial_mode;
1503 else
1504 warn("Unexpected program mode %d when morphing back from PM",
1505 pib->pib_ultype);
1506 }
1507}
1508
6f064249 1509extern void dlopen();
1510void *fakedl = &dlopen; /* Pull in dynaloading part. */
3bbf9c2b 1511
1512#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1513 && ((path)[2] == '/' || (path)[2] == '\\'))
1514#define sys_is_rooted _fnisabs
1515#define sys_is_relative _fnisrel
1516#define current_drive _getdrive
1517
1518#undef chdir /* Was _chdir2. */
1519#define sys_chdir(p) (chdir(p) == 0)
1520#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1521
4bfbfac5 1522static int DOS_harderr_state = -1;
1523
1524XS(XS_OS2_Error)
1525{
1526 dXSARGS;
1527 if (items != 2)
1528 croak("Usage: OS2::Error(harderr, exception)");
1529 {
1530 int arg1 = SvIV(ST(0));
1531 int arg2 = SvIV(ST(1));
1532 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1533 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1534 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1535 unsigned long rc;
1536
1537 if (CheckOSError(DosError(a)))
1538 croak("DosError(%d) failed", a);
1539 ST(0) = sv_newmortal();
1540 if (DOS_harderr_state >= 0)
1541 sv_setiv(ST(0), DOS_harderr_state);
1542 DOS_harderr_state = RETVAL;
1543 }
1544 XSRETURN(1);
1545}
1546
1547static signed char DOS_suppression_state = -1;
1548
1549XS(XS_OS2_Errors2Drive)
1550{
1551 dXSARGS;
1552 if (items != 1)
1553 croak("Usage: OS2::Errors2Drive(drive)");
1554 {
2d8e6c8d 1555 STRLEN n_a;
4bfbfac5 1556 SV *sv = ST(0);
1557 int suppress = SvOK(sv);
2d8e6c8d 1558 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5 1559 char drive = (s ? *s : 0);
1560 unsigned long rc;
1561
1562 if (suppress && !isALPHA(drive))
1563 croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1564 if (CheckOSError(DosSuppressPopUps((suppress
1565 ? SPU_ENABLESUPPRESSION
1566 : SPU_DISABLESUPPRESSION),
1567 drive)))
1568 croak("DosSuppressPopUps(%c) failed", drive);
1569 ST(0) = sv_newmortal();
1570 if (DOS_suppression_state > 0)
1571 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1572 else if (DOS_suppression_state == 0)
1573 sv_setpvn(ST(0), "", 0);
1574 DOS_suppression_state = drive;
1575 }
1576 XSRETURN(1);
1577}
1578
1579static const char * const si_fields[QSV_MAX] = {
1580 "MAX_PATH_LENGTH",
1581 "MAX_TEXT_SESSIONS",
1582 "MAX_PM_SESSIONS",
1583 "MAX_VDM_SESSIONS",
1584 "BOOT_DRIVE",
1585 "DYN_PRI_VARIATION",
1586 "MAX_WAIT",
1587 "MIN_SLICE",
1588 "MAX_SLICE",
1589 "PAGE_SIZE",
1590 "VERSION_MAJOR",
1591 "VERSION_MINOR",
1592 "VERSION_REVISION",
1593 "MS_COUNT",
1594 "TIME_LOW",
1595 "TIME_HIGH",
1596 "TOTPHYSMEM",
1597 "TOTRESMEM",
1598 "TOTAVAILMEM",
1599 "MAXPRMEM",
1600 "MAXSHMEM",
1601 "TIMER_INTERVAL",
1602 "MAX_COMP_LENGTH",
1603 "FOREGROUND_FS_SESSION",
1604 "FOREGROUND_PROCESS"
1605};
1606
1607XS(XS_OS2_SysInfo)
1608{
1609 dXSARGS;
1610 if (items != 0)
1611 croak("Usage: OS2::SysInfo()");
1612 {
1613 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1614 APIRET rc = NO_ERROR; /* Return code */
1615 int i = 0, j = 0;
1616
1617 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1618 QSV_MAX, /* information */
1619 (PVOID)si,
1620 sizeof(si))))
1621 croak("DosQuerySysInfo() failed");
1622 EXTEND(SP,2*QSV_MAX);
1623 while (i < QSV_MAX) {
1624 ST(j) = sv_newmortal();
1625 sv_setpv(ST(j++), si_fields[i]);
1626 ST(j) = sv_newmortal();
1627 sv_setiv(ST(j++), si[i]);
1628 i++;
1629 }
1630 }
1631 XSRETURN(2 * QSV_MAX);
1632}
1633
1634XS(XS_OS2_BootDrive)
1635{
1636 dXSARGS;
1637 if (items != 0)
1638 croak("Usage: OS2::BootDrive()");
1639 {
1640 ULONG si[1] = {0}; /* System Information Data Buffer */
1641 APIRET rc = NO_ERROR; /* Return code */
1642 char c;
1643
1644 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1645 (PVOID)si, sizeof(si))))
1646 croak("DosQuerySysInfo() failed");
1647 ST(0) = sv_newmortal();
1648 c = 'a' - 1 + si[0];
1649 sv_setpvn(ST(0), &c, 1);
1650 }
1651 XSRETURN(1);
1652}
1653
1654XS(XS_OS2_MorphPM)
1655{
1656 dXSARGS;
1657 if (items != 1)
1658 croak("Usage: OS2::MorphPM(serve)");
1659 {
1660 bool serve = SvOK(ST(0));
1661 unsigned long pmq = perl_hmq_GET(serve);
1662
1663 ST(0) = sv_newmortal();
1664 sv_setiv(ST(0), pmq);
1665 }
1666 XSRETURN(1);
1667}
1668
1669XS(XS_OS2_UnMorphPM)
1670{
1671 dXSARGS;
1672 if (items != 1)
1673 croak("Usage: OS2::UnMorphPM(serve)");
1674 {
1675 bool serve = SvOK(ST(0));
1676
1677 perl_hmq_UNSET(serve);
1678 }
1679 XSRETURN(0);
1680}
1681
1682XS(XS_OS2_Serve_Messages)
1683{
1684 dXSARGS;
1685 if (items != 1)
1686 croak("Usage: OS2::Serve_Messages(force)");
1687 {
1688 bool force = SvOK(ST(0));
1689 unsigned long cnt = Perl_Serve_Messages(force);
1690
1691 ST(0) = sv_newmortal();
1692 sv_setiv(ST(0), cnt);
1693 }
1694 XSRETURN(1);
1695}
1696
1697XS(XS_OS2_Process_Messages)
1698{
1699 dXSARGS;
1700 if (items < 1 || items > 2)
1701 croak("Usage: OS2::Process_Messages(force [, cnt])");
1702 {
1703 bool force = SvOK(ST(0));
1704 unsigned long cnt;
1705 I32 *cntp = NULL;
1706
1707 if (items == 2) {
1708 SV *sv = ST(1);
1709 int fake = SvIV(sv); /* Force SvIVX */
1710
1711 if (!SvIOK(sv))
1712 croak("Can't upgrade count to IV");
1713 cntp = &SvIVX(sv);
1714 }
1715 cnt = Perl_Process_Messages(force, cntp);
1716 ST(0) = sv_newmortal();
1717 sv_setiv(ST(0), cnt);
1718 }
1719 XSRETURN(1);
1720}
1721
3bbf9c2b 1722XS(XS_Cwd_current_drive)
1723{
1724 dXSARGS;
1725 if (items != 0)
1726 croak("Usage: Cwd::current_drive()");
1727 {
1728 char RETVAL;
1729
1730 RETVAL = current_drive();
1731 ST(0) = sv_newmortal();
1732 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1733 }
1734 XSRETURN(1);
1735}
1736
1737XS(XS_Cwd_sys_chdir)
1738{
1739 dXSARGS;
1740 if (items != 1)
1741 croak("Usage: Cwd::sys_chdir(path)");
1742 {
2d8e6c8d 1743 STRLEN n_a;
1744 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1745 bool RETVAL;
1746
1747 RETVAL = sys_chdir(path);
54310121 1748 ST(0) = boolSV(RETVAL);
3bbf9c2b 1749 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1750 }
1751 XSRETURN(1);
1752}
1753
1754XS(XS_Cwd_change_drive)
1755{
1756 dXSARGS;
1757 if (items != 1)
1758 croak("Usage: Cwd::change_drive(d)");
1759 {
2d8e6c8d 1760 STRLEN n_a;
1761 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b 1762 bool RETVAL;
1763
1764 RETVAL = change_drive(d);
54310121 1765 ST(0) = boolSV(RETVAL);
3bbf9c2b 1766 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1767 }
1768 XSRETURN(1);
1769}
1770
1771XS(XS_Cwd_sys_is_absolute)
1772{
1773 dXSARGS;
1774 if (items != 1)
1775 croak("Usage: Cwd::sys_is_absolute(path)");
1776 {
2d8e6c8d 1777 STRLEN n_a;
1778 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1779 bool RETVAL;
1780
1781 RETVAL = sys_is_absolute(path);
54310121 1782 ST(0) = boolSV(RETVAL);
3bbf9c2b 1783 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1784 }
1785 XSRETURN(1);
1786}
1787
1788XS(XS_Cwd_sys_is_rooted)
1789{
1790 dXSARGS;
1791 if (items != 1)
1792 croak("Usage: Cwd::sys_is_rooted(path)");
1793 {
2d8e6c8d 1794 STRLEN n_a;
1795 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1796 bool RETVAL;
1797
1798 RETVAL = sys_is_rooted(path);
54310121 1799 ST(0) = boolSV(RETVAL);
3bbf9c2b 1800 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1801 }
1802 XSRETURN(1);
1803}
1804
1805XS(XS_Cwd_sys_is_relative)
1806{
1807 dXSARGS;
1808 if (items != 1)
1809 croak("Usage: Cwd::sys_is_relative(path)");
1810 {
2d8e6c8d 1811 STRLEN n_a;
1812 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1813 bool RETVAL;
1814
1815 RETVAL = sys_is_relative(path);
54310121 1816 ST(0) = boolSV(RETVAL);
3bbf9c2b 1817 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1818 }
1819 XSRETURN(1);
1820}
1821
1822XS(XS_Cwd_sys_cwd)
1823{
1824 dXSARGS;
1825 if (items != 0)
1826 croak("Usage: Cwd::sys_cwd()");
1827 {
1828 char p[MAXPATHLEN];
1829 char * RETVAL;
1830 RETVAL = _getcwd2(p, MAXPATHLEN);
1831 ST(0) = sv_newmortal();
1832 sv_setpv((SV*)ST(0), RETVAL);
1833 }
1834 XSRETURN(1);
1835}
1836
1837XS(XS_Cwd_sys_abspath)
1838{
1839 dXSARGS;
1840 if (items < 1 || items > 2)
1841 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1842 {
2d8e6c8d 1843 STRLEN n_a;
1844 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1845 char * dir;
1846 char p[MAXPATHLEN];
1847 char * RETVAL;
1848
1849 if (items < 2)
1850 dir = NULL;
1851 else {
2d8e6c8d 1852 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b 1853 }
1854 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1855 path += 2;
1856 }
1857 if (dir == NULL) {
1858 if (_abspath(p, path, MAXPATHLEN) == 0) {
1859 RETVAL = p;
1860 } else {
1861 RETVAL = NULL;
1862 }
1863 } else {
1864 /* Absolute with drive: */
1865 if ( sys_is_absolute(path) ) {
1866 if (_abspath(p, path, MAXPATHLEN) == 0) {
1867 RETVAL = p;
1868 } else {
1869 RETVAL = NULL;
1870 }
1871 } else if (path[0] == '/' || path[0] == '\\') {
1872 /* Rooted, but maybe on different drive. */
1873 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1874 char p1[MAXPATHLEN];
1875
1876 /* Need to prepend the drive. */
1877 p1[0] = dir[0];
1878 p1[1] = dir[1];
1879 Copy(path, p1 + 2, strlen(path) + 1, char);
1880 RETVAL = p;
1881 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1882 RETVAL = p;
1883 } else {
1884 RETVAL = NULL;
1885 }
1886 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1887 RETVAL = p;
1888 } else {
1889 RETVAL = NULL;
1890 }
1891 } else {
1892 /* Either path is relative, or starts with a drive letter. */
1893 /* If the path starts with a drive letter, then dir is
1894 relevant only if
1895 a/b) it is absolute/x:relative on the same drive.
1896 c) path is on current drive, and dir is rooted
1897 In all the cases it is safe to drop the drive part
1898 of the path. */
1899 if ( !sys_is_relative(path) ) {
1900 int is_drived;
1901
1902 if ( ( ( sys_is_absolute(dir)
1903 || (isALPHA(dir[0]) && dir[1] == ':'
1904 && strnicmp(dir, path,1) == 0))
1905 && strnicmp(dir, path,1) == 0)
1906 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1907 && toupper(path[0]) == current_drive())) {
1908 path += 2;
1909 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1910 RETVAL = p; goto done;
1911 } else {
1912 RETVAL = NULL; goto done;
1913 }
1914 }
1915 {
1916 /* Need to prepend the absolute path of dir. */
1917 char p1[MAXPATHLEN];
1918
1919 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1920 int l = strlen(p1);
1921
1922 if (p1[ l - 1 ] != '/') {
1923 p1[ l ] = '/';
1924 l++;
1925 }
1926 Copy(path, p1 + l, strlen(path) + 1, char);
1927 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1928 RETVAL = p;
1929 } else {
1930 RETVAL = NULL;
1931 }
1932 } else {
1933 RETVAL = NULL;
1934 }
1935 }
1936 done:
1937 }
1938 }
1939 ST(0) = sv_newmortal();
1940 sv_setpv((SV*)ST(0), RETVAL);
1941 }
1942 XSRETURN(1);
1943}
72ea3524 1944typedef APIRET (*PELP)(PSZ path, ULONG type);
1945
1946APIRET
1947ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1948{
4bfbfac5 1949 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
72ea3524 1950 return (*(PELP)ExtFCN[ord])(path, type);
1951}
3bbf9c2b 1952
72ea3524 1953#define extLibpath(type) \
1954 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1955 : BEGIN_LIBPATH))) \
3bbf9c2b 1956 ? NULL : to )
1957
1958#define extLibpath_set(p,type) \
72ea3524 1959 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1960 : BEGIN_LIBPATH))))
3bbf9c2b 1961
1962XS(XS_Cwd_extLibpath)
1963{
1964 dXSARGS;
1965 if (items < 0 || items > 1)
1966 croak("Usage: Cwd::extLibpath(type = 0)");
1967 {
1968 bool type;
1969 char to[1024];
1970 U32 rc;
1971 char * RETVAL;
1972
1973 if (items < 1)
1974 type = 0;
1975 else {
1976 type = (int)SvIV(ST(0));
1977 }
1978
1979 RETVAL = extLibpath(type);
1980 ST(0) = sv_newmortal();
1981 sv_setpv((SV*)ST(0), RETVAL);
1982 }
1983 XSRETURN(1);
1984}
1985
1986XS(XS_Cwd_extLibpath_set)
1987{
1988 dXSARGS;
1989 if (items < 1 || items > 2)
1990 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1991 {
2d8e6c8d 1992 STRLEN n_a;
1993 char * s = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1994 bool type;
1995 U32 rc;
1996 bool RETVAL;
1997
1998 if (items < 2)
1999 type = 0;
2000 else {
2001 type = (int)SvIV(ST(1));
2002 }
2003
2004 RETVAL = extLibpath_set(s, type);
54310121 2005 ST(0) = boolSV(RETVAL);
3bbf9c2b 2006 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2007 }
2008 XSRETURN(1);
2009}
2010
2011int
2012Xs_OS2_init()
2013{
2014 char *file = __FILE__;
2015 {
2016 GV *gv;
55497cff 2017
2018 if (_emx_env & 0x200) { /* OS/2 */
2019 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2020 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2021 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2022 }
4bfbfac5 2023 newXS("OS2::Error", XS_OS2_Error, file);
2024 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2025 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2026 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2027 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2028 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2029 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2030 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b 2031 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2032 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2033 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2034 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2035 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2036 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2037 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2038 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2039 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3bbf9c2b 2040 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2041 GvMULTI_on(gv);
2042#ifdef PERL_IS_AOUT
2043 sv_setiv(GvSV(gv), 1);
2044#endif
4bfbfac5 2045 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2046 GvMULTI_on(gv);
2047 sv_setiv(GvSV(gv), _emx_rev);
2048 sv_setpv(GvSV(gv), _emx_vprt);
2049 SvIOK_on(GvSV(gv));
2050 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2051 GvMULTI_on(gv);
2052 sv_setiv(GvSV(gv), _emx_env);
2053 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2054 GvMULTI_on(gv);
2055 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3bbf9c2b 2056 }
2057}
2058
2059OS2_Perl_data_t OS2_Perl_data;
2060
2061void
aa689395 2062Perl_OS2_init(char **env)
3bbf9c2b 2063{
2064 char *shell;
2065
18f739ee 2066 MALLOC_INIT;
3bbf9c2b 2067 settmppath();
2068 OS2_Perl_data.xs_init = &Xs_OS2_init;
28743a51 2069 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
aa689395 2070 if (environ == NULL) {
2071 environ = env;
2072 }
3bbf9c2b 2073 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c 2074 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2075 strcpy(PL_sh_path, SH_PATH);
2076 PL_sh_path[0] = shell[0];
3bbf9c2b 2077 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 2078 int l = strlen(shell), i;
3bbf9c2b 2079 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2080 l--;
2081 }
6b88bc9c 2082 New(1304, PL_sh_path, l + 8, char);
2083 strncpy(PL_sh_path, shell, l);
2084 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 2085 for (i = 0; i < l; i++) {
6b88bc9c 2086 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 2087 }
3bbf9c2b 2088 }
dd96f567 2089 MUTEX_INIT(&start_thread_mutex);
017f25f1 2090 os2_mytype = my_type(); /* Do it before morphing. Needed? */
3bbf9c2b 2091}
2092
55497cff 2093#undef tmpnam
2094#undef tmpfile
2095
2096char *
2097my_tmpnam (char *str)
2098{
2099 char *p = getenv("TMP"), *tpath;
2100 int len;
2101
2102 if (!p) p = getenv("TEMP");
2103 tpath = tempnam(p, "pltmp");
2104 if (str && tpath) {
2105 strcpy(str, tpath);
2106 return str;
2107 }
2108 return tpath;
2109}
2110
2111FILE *
2112my_tmpfile ()
2113{
2114 struct stat s;
2115
2116 stat(".", &s);
2117 if (s.st_mode & S_IWOTH) {
2118 return tmpfile();
2119 }
2120 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2121 grants TMP. */
2122}
367f3c24 2123
2124#undef flock
2125
2126/* This code was contributed by Rocco Caputo. */
2127int
dd96f567 2128my_flock(int handle, int o)
367f3c24 2129{
2130 FILELOCK rNull, rFull;
2131 ULONG timeout, handle_type, flag_word;
2132 APIRET rc;
2133 int blocking, shared;
2134 static int use_my = -1;
2135
2136 if (use_my == -1) {
2137 char *s = getenv("USE_PERL_FLOCK");
2138 if (s)
2139 use_my = atoi(s);
2140 else
2141 use_my = 1;
2142 }
2143 if (!(_emx_env & 0x200) || !use_my)
dd96f567 2144 return flock(handle, o); /* Delegate to EMX. */
367f3c24 2145
2146 // is this a file?
2147 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2148 (handle_type & 0xFF))
2149 {
2150 errno = EBADF;
2151 return -1;
2152 }
2153 // set lock/unlock ranges
2154 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2155 rFull.lRange = 0x7FFFFFFF;
2156 // set timeout for blocking
dd96f567 2157 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
367f3c24 2158 // shared or exclusive?
dd96f567 2159 shared = (o & LOCK_SH) ? 1 : 0;
367f3c24 2160 // do not block the unlock
dd96f567 2161 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 2162 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2163 switch (rc) {
2164 case 0:
2165 errno = 0;
2166 return 0;
2167 case ERROR_INVALID_HANDLE:
2168 errno = EBADF;
2169 return -1;
2170 case ERROR_SHARING_BUFFER_EXCEEDED:
2171 errno = ENOLCK;
2172 return -1;
2173 case ERROR_LOCK_VIOLATION:
2174 break; // not an error
2175 case ERROR_INVALID_PARAMETER:
2176 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2177 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2178 errno = EINVAL;
2179 return -1;
2180 case ERROR_INTERRUPT:
2181 errno = EINTR;
2182 return -1;
2183 default:
2184 errno = EINVAL;
2185 return -1;
2186 }
2187 }
2188 // lock may block
dd96f567 2189 if (o & (LOCK_SH | LOCK_EX)) {
367f3c24 2190 // for blocking operations
2191 for (;;) {
2192 rc =
2193 DosSetFileLocks(
2194 handle,
2195 &rNull,
2196 &rFull,
2197 timeout,
2198 shared
2199 );
2200 switch (rc) {
2201 case 0:
2202 errno = 0;
2203 return 0;
2204 case ERROR_INVALID_HANDLE:
2205 errno = EBADF;
2206 return -1;
2207 case ERROR_SHARING_BUFFER_EXCEEDED:
2208 errno = ENOLCK;
2209 return -1;
2210 case ERROR_LOCK_VIOLATION:
2211 if (!blocking) {
2212 errno = EWOULDBLOCK;
2213 return -1;
2214 }
2215 break;
2216 case ERROR_INVALID_PARAMETER:
2217 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2218 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2219 errno = EINVAL;
2220 return -1;
2221 case ERROR_INTERRUPT:
2222 errno = EINTR;
2223 return -1;
2224 default:
2225 errno = EINVAL;
2226 return -1;
2227 }
2228 // give away timeslice
2229 DosSleep(1);
2230 }
2231 }
2232
2233 errno = 0;
2234 return 0;
2235}
Unnamed repository; edit this file to name it for gitweb.