projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Lots of VMS changes. vms/gen_shrfls.pl (which parses header files)
[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
8/*
9 * Various Unix compatibility functions for OS/2
10 */
11
12#include <stdio.h>
13#include <errno.h>
14#include <limits.h>
15#include <process.h>
72ea3524 16#include <fcntl.h>
4633a7c4 17
18#include "EXTERN.h"
19#include "perl.h"
20
dd96f567 21#ifdef USE_THREADS
22
23typedef void (*emx_startroutine)(void *);
24typedef void* (*pthreads_startroutine)(void *);
25
26enum pthreads_state {
27 pthreads_st_none = 0,
28 pthreads_st_run,
29 pthreads_st_exited,
30 pthreads_st_detached,
31 pthreads_st_waited,
32};
33const char *pthreads_states[] = {
34 "uninit",
35 "running",
36 "exited",
37 "detached",
38 "waited for",
39};
40
41typedef struct {
42 void *status;
43 pthread_cond_t cond;
44 enum pthreads_state state;
45} thread_join_t;
46
47thread_join_t *thread_join_data;
48int thread_join_count;
49pthread_mutex_t start_thread_mutex;
50
51int
52pthread_join(pthread_t tid, void **status)
53{
54 MUTEX_LOCK(&start_thread_mutex);
55 switch (thread_join_data[tid].state) {
56 case pthreads_st_exited:
57 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
58 MUTEX_UNLOCK(&start_thread_mutex);
59 *status = thread_join_data[tid].status;
60 break;
61 case pthreads_st_waited:
62 MUTEX_UNLOCK(&start_thread_mutex);
63 croak("join with a thread with a waiter");
64 break;
65 case pthreads_st_run:
66 thread_join_data[tid].state = pthreads_st_waited;
67 COND_INIT(&thread_join_data[tid].cond);
68 MUTEX_UNLOCK(&start_thread_mutex);
69 COND_WAIT(&thread_join_data[tid].cond, NULL);
70 COND_DESTROY(&thread_join_data[tid].cond);
71 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
72 *status = thread_join_data[tid].status;
73 break;
74 default:
75 MUTEX_UNLOCK(&start_thread_mutex);
76 croak("join: unknown thread state: '%s'",
77 pthreads_states[thread_join_data[tid].state]);
78 break;
79 }
80 return 0;
81}
82
83void
84pthread_startit(void *arg)
85{
86 /* Thread is already started, we need to transfer control only */
87 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
88 int tid = pthread_self();
89 void *retval;
90
91 arg = ((void**)arg)[1];
92 if (tid >= thread_join_count) {
93 int oc = thread_join_count;
94
95 thread_join_count = tid + 5 + tid/5;
96 if (thread_join_data) {
97 Renew(thread_join_data, thread_join_count, thread_join_t);
98 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
99 } else {
100 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
101 }
102 }
103 if (thread_join_data[tid].state != pthreads_st_none)
104 croak("attempt to reuse thread id %i", tid);
105 thread_join_data[tid].state = pthreads_st_run;
106 /* Now that we copied/updated the guys, we may release the caller... */
107 MUTEX_UNLOCK(&start_thread_mutex);
108 thread_join_data[tid].status = (*start_routine)(arg);
109 switch (thread_join_data[tid].state) {
110 case pthreads_st_waited:
111 COND_SIGNAL(&thread_join_data[tid].cond);
112 break;
113 default:
114 thread_join_data[tid].state = pthreads_st_exited;
115 break;
116 }
117}
118
119int
120pthread_create(pthread_t *tid, const pthread_attr_t *attr,
121 void *(*start_routine)(void*), void *arg)
122{
123 void *args[2];
124
125 args[0] = (void*)start_routine;
126 args[1] = arg;
127
128 MUTEX_LOCK(&start_thread_mutex);
129 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
130 /*stacksize*/ 10*1024*1024, (void*)args);
131 MUTEX_LOCK(&start_thread_mutex);
132 MUTEX_UNLOCK(&start_thread_mutex);
133 return *tid ? 0 : EINVAL;
134}
135
136int
137pthread_detach(pthread_t tid)
138{
139 MUTEX_LOCK(&start_thread_mutex);
140 switch (thread_join_data[tid].state) {
141 case pthreads_st_waited:
142 MUTEX_UNLOCK(&start_thread_mutex);
143 croak("detach on a thread with a waiter");
144 break;
145 case pthreads_st_run:
146 thread_join_data[tid].state = pthreads_st_detached;
147 MUTEX_UNLOCK(&start_thread_mutex);
148 break;
149 default:
150 MUTEX_UNLOCK(&start_thread_mutex);
151 croak("detach: unknown thread state: '%s'",
152 pthreads_states[thread_join_data[tid].state]);
153 break;
154 }
155 return 0;
156}
157
158/* This is a very bastardized version: */
159int
160os2_cond_wait(pthread_cond_t *c, pthread_mutex_t *m)
161{
162 int rc;
163 if ((rc = DosResetEventSem(*c,&na)) && (rc != ERROR_ALREADY_RESET))
164 croak("panic: COND_WAIT-reset: rc=%i", rc);
165 if (m) MUTEX_UNLOCK(m);
166 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)))
167 croak("panic: COND_WAIT: rc=%i", rc);
168 if (m) MUTEX_LOCK(m);
169}
170#endif
171
4633a7c4 172/*****************************************************************************/
72ea3524 173/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
174static PFN ExtFCN[2]; /* Labeled by ord below. */
175static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
176#define ORD_QUERY_ELP 0
177#define ORD_SET_ELP 1
178
179APIRET
180loadByOrd(ULONG ord)
181{
182 if (ExtFCN[ord] == NULL) {
183 static HMODULE hdosc = 0;
184 BYTE buf[20];
185 PFN fcn;
186 APIRET rc;
187
188 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
189 "doscalls", &hdosc)))
190 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
191 die("This version of OS/2 does not support doscalls.%i",
192 loadOrd[ord]);
193 ExtFCN[ord] = fcn;
194 }
195 if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
196}
197
4633a7c4 198/* priorities */
6f064249 199static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
200 self inverse. */
201#define QSS_INI_BUFFER 1024
4633a7c4 202
6f064249 203PQTOPLEVEL
204get_sysinfo(ULONG pid, ULONG flags)
4633a7c4 205{
6f064249 206 char *pbuffer;
207 ULONG rc, buf_len = QSS_INI_BUFFER;
208
fc36a67e 209 New(1322, pbuffer, buf_len, char);
6f064249 210 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
211 rc = QuerySysState(flags, pid, pbuffer, buf_len);
212 while (rc == ERROR_BUFFER_OVERFLOW) {
213 Renew(pbuffer, buf_len *= 2, char);
df3ef7a9 214 rc = QuerySysState(flags, pid, pbuffer, buf_len);
6f064249 215 }
216 if (rc) {
217 FillOSError(rc);
218 Safefree(pbuffer);
219 return 0;
220 }
221 return (PQTOPLEVEL)pbuffer;
222}
223
224#define PRIO_ERR 0x1111
225
226static ULONG
227sys_prio(pid)
228{
229 ULONG prio;
230 PQTOPLEVEL psi;
231
232 psi = get_sysinfo(pid, QSS_PROCESS);
233 if (!psi) {
234 return PRIO_ERR;
235 }
236 if (pid != psi->procdata->pid) {
237 Safefree(psi);
238 croak("panic: wrong pid in sysinfo");
239 }
240 prio = psi->procdata->threads->priority;
241 Safefree(psi);
242 return prio;
243}
244
245int
246setpriority(int which, int pid, int val)
247{
248 ULONG rc, prio;
249 PQTOPLEVEL psi;
250
251 prio = sys_prio(pid);
252
55497cff 253 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 254 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
255 /* Do not change class. */
256 return CheckOSError(DosSetPriority((pid < 0)
257 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
258 0,
259 (32 - val) % 32 - (prio & 0xFF),
260 abs(pid)))
261 ? -1 : 0;
262 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
263 /* Documentation claims one can change both class and basevalue,
264 * but I find it wrong. */
265 /* Change class, but since delta == 0 denotes absolute 0, correct. */
266 if (CheckOSError(DosSetPriority((pid < 0)
267 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
268 priors[(32 - val) >> 5] + 1,
269 0,
270 abs(pid))))
271 return -1;
272 if ( ((32 - val) % 32) == 0 ) return 0;
273 return CheckOSError(DosSetPriority((pid < 0)
274 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
275 0,
276 (32 - val) % 32,
277 abs(pid)))
278 ? -1 : 0;
279 }
280/* else return CheckOSError(DosSetPriority((pid < 0) */
281/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
282/* priors[(32 - val) >> 5] + 1, */
283/* (32 - val) % 32 - (prio & 0xFF), */
284/* abs(pid))) */
285/* ? -1 : 0; */
4633a7c4 286}
287
6f064249 288int
289getpriority(int which /* ignored */, int pid)
4633a7c4 290{
291 TIB *tib;
292 PIB *pib;
6f064249 293 ULONG rc, ret;
294
55497cff 295 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 296 /* DosGetInfoBlocks has old priority! */
297/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
298/* if (pid != pib->pib_ulpid) { */
299 ret = sys_prio(pid);
300 if (ret == PRIO_ERR) {
301 return -1;
302 }
303/* } else */
304/* ret = tib->tib_ptib2->tib2_ulpri; */
305 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
4633a7c4 306}
307
308/*****************************************************************************/
309/* spawn */
72ea3524 310typedef void (*Sigfunc) _((int));
311
4633a7c4 312static int
313result(int flag, int pid)
314{
315 int r, status;
316 Signal_t (*ihand)(); /* place to save signal during system() */
317 Signal_t (*qhand)(); /* place to save signal during system() */
760ac839 318#ifndef __EMX__
319 RESULTCODES res;
320 int rpid;
321#endif
4633a7c4 322
760ac839 323 if (pid < 0 || flag != 0)
4633a7c4 324 return pid;
325
760ac839 326#ifdef __EMX__
72ea3524 327 ihand = rsignal(SIGINT, SIG_IGN);
328 qhand = rsignal(SIGQUIT, SIG_IGN);
c0c09dfd 329 do {
330 r = wait4pid(pid, &status, 0);
331 } while (r == -1 && errno == EINTR);
72ea3524 332 rsignal(SIGINT, ihand);
333 rsignal(SIGQUIT, qhand);
4633a7c4 334
335 statusvalue = (U16)status;
336 if (r < 0)
337 return -1;
338 return status & 0xFFFF;
760ac839 339#else
72ea3524 340 ihand = rsignal(SIGINT, SIG_IGN);
760ac839 341 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
72ea3524 342 rsignal(SIGINT, ihand);
760ac839 343 statusvalue = res.codeResult << 8 | res.codeTerminate;
344 if (r)
345 return -1;
346 return statusvalue;
347#endif
4633a7c4 348}
349
350int
351do_aspawn(really,mark,sp)
352SV *really;
353register SV **mark;
354register SV **sp;
355{
dd96f567 356 dTHR;
4633a7c4 357 register char **a;
e29f6e02 358 char *tmps = NULL;
4633a7c4 359 int rc;
e29f6e02 360 int flag = P_WAIT, trueflag, err, secondtry = 0;
4633a7c4 361
362 if (sp > mark) {
fc36a67e 363 New(1301,Argv, sp - mark + 3, char*);
4633a7c4 364 a = Argv;
365
760ac839 366 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
4633a7c4 367 ++mark;
368 flag = SvIVx(*mark);
369 }
370
371 while (++mark <= sp) {
372 if (*mark)
373 *a++ = SvPVx(*mark, na);
374 else
375 *a++ = "";
376 }
377 *a = Nullch;
378
379 trueflag = flag;
380 if (flag == P_WAIT)
381 flag = P_NOWAIT;
382
ff68c719 383 if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
3bbf9c2b 384
385 if (Argv[0][0] != '/' && Argv[0][0] != '\\'
386 && !(Argv[0][0] && Argv[0][1] == ':'
387 && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
760ac839 388 ) /* will swawnvp use PATH? */
c0c09dfd 389 TAINT_ENV(); /* testing IFS here is overkill, probably */
760ac839 390 /* We should check PERL_SH* and PERLLIB_* as well? */
e29f6e02 391 retry:
4633a7c4 392 if (really && *(tmps = SvPV(really, na)))
393 rc = result(trueflag, spawnvp(flag,tmps,Argv));
394 else
395 rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
396
e29f6e02 397 if (rc < 0 && secondtry == 0
398 && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */
399 err = errno;
400 if (err == ENOENT) { /* No such file. */
401 /* One reason may be that EMX added .exe. We suppose
402 that .exe-less files are automatically shellable. */
403 char *no_dir;
404 (no_dir = strrchr(Argv[0], '/'))
405 || (no_dir = strrchr(Argv[0], '\\'))
406 || (no_dir = Argv[0]);
407 if (!strchr(no_dir, '.')) {
408 struct stat buffer;
409 if (stat(Argv[0], &buffer) != -1) { /* File exists. */
410 /* Maybe we need to specify the full name here? */
411 goto doshell;
412 }
413 }
414 } else if (err == ENOEXEC) { /* Need to send to shell. */
415 doshell:
416 while (a >= Argv) {
417 *(a + 2) = *a;
418 a--;
419 }
420 *Argv = sh_path;
421 *(Argv + 1) = "-c";
422 secondtry = 1;
423 goto retry;
424 }
425 }
4633a7c4 426 if (rc < 0 && dowarn)
427 warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
c0c09dfd 428 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4 429 } else
430 rc = -1;
431 do_execfree();
432 return rc;
433}
434
760ac839 435#define EXECF_SPAWN 0
436#define EXECF_EXEC 1
437#define EXECF_TRUEEXEC 2
72ea3524 438#define EXECF_SPAWN_NOWAIT 3
760ac839 439
4633a7c4 440int
760ac839 441do_spawn2(cmd, execf)
4633a7c4 442char *cmd;
760ac839 443int execf;
4633a7c4 444{
445 register char **a;
446 register char *s;
447 char flags[10];
3bbf9c2b 448 char *shell, *copt, *news = NULL;
a0914d8e 449 int rc, added_shell = 0, err, seenspace = 0;
e29f6e02 450 char fullcmd[MAXNAMLEN + 1];
4633a7c4 451
c0c09dfd 452#ifdef TRYSHELL
453 if ((shell = getenv("EMXSHELL")) != NULL)
454 copt = "-c";
455 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4 456 copt = "-c";
457 else if ((shell = getenv("COMSPEC")) != NULL)
458 copt = "/C";
459 else
460 shell = "cmd.exe";
c0c09dfd 461#else
462 /* Consensus on perl5-porters is that it is _very_ important to
463 have a shell which will not change between computers with the
464 same architecture, to avoid "action on a distance".
465 And to have simple build, this shell should be sh. */
ff68c719 466 shell = sh_path;
c0c09dfd 467 copt = "-c";
468#endif
469
470 while (*cmd && isSPACE(*cmd))
471 cmd++;
4633a7c4 472
3bbf9c2b 473 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
ff68c719 474 STRLEN l = strlen(sh_path);
3bbf9c2b 475
2cc2f81f 476 New(1302, news, strlen(cmd) - 7 + l + 1, char);
ff68c719 477 strcpy(news, sh_path);
3bbf9c2b 478 strcpy(news + l, cmd + 7);
479 cmd = news;
e29f6e02 480 added_shell = 1;
3bbf9c2b 481 }
482
4633a7c4 483 /* save an extra exec if possible */
484 /* see if there are shell metacharacters in it */
485
c0c09dfd 486 if (*cmd == '.' && isSPACE(cmd[1]))
487 goto doshell;
488
489 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
490 goto doshell;
491
492 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
493 if (*s == '=')
494 goto doshell;
495
4633a7c4 496 for (s = cmd; *s; s++) {
c0c09dfd 497 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 498 if (*s == '\n' && s[1] == '\0') {
4633a7c4 499 *s = '\0';
500 break;
a0914d8e 501 } else if (*s == '\\' && !seenspace) {
502 continue; /* Allow backslashes in names */
4633a7c4 503 }
c0c09dfd 504 doshell:
760ac839 505 if (execf == EXECF_TRUEEXEC)
506 return execl(shell,shell,copt,cmd,(char*)0);
507 else if (execf == EXECF_EXEC)
508 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 509 else if (execf == EXECF_SPAWN_NOWAIT)
510 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
760ac839 511 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
c0c09dfd 512 rc = result(P_WAIT,
760ac839 513 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
c0c09dfd 514 if (rc < 0 && dowarn)
760ac839 515 warn("Can't %s \"%s\": %s",
516 (execf == EXECF_SPAWN ? "spawn" : "exec"),
517 shell, Strerror(errno));
c0c09dfd 518 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
3bbf9c2b 519 if (news) Safefree(news);
c0c09dfd 520 return rc;
a0914d8e 521 } else if (*s == ' ' || *s == '\t') {
522 seenspace = 1;
4633a7c4 523 }
524 }
c0c09dfd 525
fc36a67e 526 New(1303,Argv, (s - cmd) / 2 + 2, char*);
4633a7c4 527 Cmd = savepvn(cmd, s-cmd);
528 a = Argv;
529 for (s = Cmd; *s;) {
530 while (*s && isSPACE(*s)) s++;
531 if (*s)
532 *(a++) = s;
533 while (*s && !isSPACE(*s)) s++;
534 if (*s)
535 *s++ = '\0';
536 }
537 *a = Nullch;
538 if (Argv[0]) {
e29f6e02 539 int err;
540
760ac839 541 if (execf == EXECF_TRUEEXEC)
542 rc = execvp(Argv[0],Argv);
543 else if (execf == EXECF_EXEC)
544 rc = spawnvp(P_OVERLAY,Argv[0],Argv);
72ea3524 545 else if (execf == EXECF_SPAWN_NOWAIT)
546 rc = spawnvp(P_NOWAIT,Argv[0],Argv);
760ac839 547 else
548 rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
e29f6e02 549 if (rc < 0) {
550 err = errno;
551 if (err == ENOENT) { /* No such file. */
552 /* One reason may be that EMX added .exe. We suppose
553 that .exe-less files are automatically shellable. */
554 char *no_dir;
555 (no_dir = strrchr(Argv[0], '/'))
556 || (no_dir = strrchr(Argv[0], '\\'))
557 || (no_dir = Argv[0]);
558 if (!strchr(no_dir, '.')) {
559 struct stat buffer;
560 if (stat(Argv[0], &buffer) != -1) { /* File exists. */
561 /* Maybe we need to specify the full name here? */
562 goto doshell;
563 }
564 }
565 } else if (err == ENOEXEC) { /* Need to send to shell. */
566 goto doshell;
567 }
568 }
4633a7c4 569 if (rc < 0 && dowarn)
760ac839 570 warn("Can't %s \"%s\": %s",
e29f6e02 571 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
572 ? "spawn" : "exec"),
573 Argv[0], Strerror(err));
c0c09dfd 574 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
4633a7c4 575 } else
576 rc = -1;
3bbf9c2b 577 if (news) Safefree(news);
4633a7c4 578 do_execfree();
579 return rc;
580}
581
760ac839 582int
583do_spawn(cmd)
584char *cmd;
585{
586 return do_spawn2(cmd, EXECF_SPAWN);
587}
588
72ea3524 589int
590do_spawn_nowait(cmd)
591char *cmd;
592{
593 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
594}
595
760ac839 596bool
597do_exec(cmd)
598char *cmd;
599{
600 return do_spawn2(cmd, EXECF_EXEC);
601}
602
603bool
604os2exec(cmd)
605char *cmd;
606{
607 return do_spawn2(cmd, EXECF_TRUEEXEC);
608}
609
3bbf9c2b 610PerlIO *
611my_syspopen(cmd,mode)
c0c09dfd 612char *cmd;
613char *mode;
614{
72ea3524 615#ifndef USE_POPEN
616
617 int p[2];
618 register I32 this, that, newfd;
619 register I32 pid, rc;
3bbf9c2b 620 PerlIO *res;
621 SV *sv;
72ea3524 622
623 if (pipe(p) < 0)
624 return Nullfp;
625 /* `this' is what we use in the parent, `that' in the child. */
626 this = (*mode == 'w');
627 that = !this;
628 if (tainting) {
629 taint_env();
630 taint_proper("Insecure %s%s", "EXEC");
631 }
632 /* Now we need to spawn the child. */
633 newfd = dup(*mode == 'r'); /* Preserve std* */
634 if (p[that] != (*mode == 'r')) {
635 dup2(p[that], *mode == 'r');
636 close(p[that]);
637 }
638 /* Where is `this' and newfd now? */
639 fcntl(p[this], F_SETFD, FD_CLOEXEC);
640 fcntl(newfd, F_SETFD, FD_CLOEXEC);
641 pid = do_spawn_nowait(cmd);
642 if (newfd != (*mode == 'r')) {
643 dup2(newfd, *mode == 'r'); /* Return std* back. */
644 close(newfd);
645 }
646 close(p[that]);
647 if (pid == -1) {
648 close(p[this]);
649 return NULL;
650 }
651 if (p[that] < p[this]) {
652 dup2(p[this], p[that]);
653 close(p[this]);
654 p[this] = p[that];
655 }
656 sv = *av_fetch(fdpid,p[this],TRUE);
657 (void)SvUPGRADE(sv,SVt_IV);
658 SvIVX(sv) = pid;
659 forkprocess = pid;
660 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 661
72ea3524 662#else /* USE_POPEN */
663
664 PerlIO *res;
665 SV *sv;
666
667# ifdef TRYSHELL
3bbf9c2b 668 res = popen(cmd, mode);
72ea3524 669# else
c0c09dfd 670 char *shell = getenv("EMXSHELL");
3bbf9c2b 671
ff68c719 672 my_setenv("EMXSHELL", sh_path);
c0c09dfd 673 res = popen(cmd, mode);
674 my_setenv("EMXSHELL", shell);
72ea3524 675# endif
3bbf9c2b 676 sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
677 (void)SvUPGRADE(sv,SVt_IV);
678 SvIVX(sv) = -1; /* A cooky. */
679 return res;
72ea3524 680
681#endif /* USE_POPEN */
682
c0c09dfd 683}
684
3bbf9c2b 685/******************************************************************/
4633a7c4 686
687#ifndef HAS_FORK
688int
689fork(void)
690{
691 die(no_func, "Unsupported function fork");
692 errno = EINVAL;
693 return -1;
694}
695#endif
696
3bbf9c2b 697/*******************************************************************/
4633a7c4 698/* not implemented in EMX 0.9a */
699
700void * ctermid(x) { return 0; }
eacfb5f1 701
702#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 703void * ttyname(x) { return 0; }
eacfb5f1 704#endif
4633a7c4 705
3bbf9c2b 706/******************************************************************/
760ac839 707/* my socket forwarders - EMX lib only provides static forwarders */
708
709static HMODULE htcp = 0;
710
711static void *
712tcp0(char *name)
713{
714 static BYTE buf[20];
715 PFN fcn;
55497cff 716
717 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 718 if (!htcp)
719 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
720 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
721 return (void *) ((void * (*)(void)) fcn) ();
722 return 0;
723}
724
725static void
726tcp1(char *name, int arg)
727{
728 static BYTE buf[20];
729 PFN fcn;
55497cff 730
731 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
760ac839 732 if (!htcp)
733 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
734 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
735 ((void (*)(int)) fcn) (arg);
736}
737
738void * gethostent() { return tcp0("GETHOSTENT"); }
739void * getnetent() { return tcp0("GETNETENT"); }
740void * getprotoent() { return tcp0("GETPROTOENT"); }
741void * getservent() { return tcp0("GETSERVENT"); }
742void sethostent(x) { tcp1("SETHOSTENT", x); }
743void setnetent(x) { tcp1("SETNETENT", x); }
744void setprotoent(x) { tcp1("SETPROTOENT", x); }
745void setservent(x) { tcp1("SETSERVENT", x); }
746void endhostent() { tcp0("ENDHOSTENT"); }
747void endnetent() { tcp0("ENDNETENT"); }
748void endprotoent() { tcp0("ENDPROTOENT"); }
749void endservent() { tcp0("ENDSERVENT"); }
750
751/*****************************************************************************/
752/* not implemented in C Set++ */
753
754#ifndef __EMX__
755int setuid(x) { errno = EINVAL; return -1; }
756int setgid(x) { errno = EINVAL; return -1; }
757#endif
4633a7c4 758
759/*****************************************************************************/
760/* stat() hack for char/block device */
761
762#if OS2_STAT_HACK
763
764 /* First attempt used DosQueryFSAttach which crashed the system when
765 used with 5.001. Now just look for /dev/. */
766
767int
768os2_stat(char *name, struct stat *st)
769{
770 static int ino = SHRT_MAX;
771
772 if (stricmp(name, "/dev/con") != 0
773 && stricmp(name, "/dev/tty") != 0)
774 return stat(name, st);
775
776 memset(st, 0, sizeof *st);
777 st->st_mode = S_IFCHR|0666;
778 st->st_ino = (ino-- & 0x7FFF);
779 st->st_nlink = 1;
780 return 0;
781}
782
783#endif
c0c09dfd 784
760ac839 785#ifdef USE_PERL_SBRK
c0c09dfd 786
760ac839 787/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 788
789void *
760ac839 790sys_alloc(int size) {
791 void *got;
792 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
793
c0c09dfd 794 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
795 return (void *) -1;
796 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
760ac839 797 return got;
c0c09dfd 798}
760ac839 799
800#endif /* USE_PERL_SBRK */
c0c09dfd 801
802/* tmp path */
803
804char *tmppath = TMPPATH1;
805
806void
807settmppath()
808{
809 char *p = getenv("TMP"), *tpath;
810 int len;
811
812 if (!p) p = getenv("TEMP");
813 if (!p) return;
814 len = strlen(p);
815 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
816 strcpy(tpath, p);
817 tpath[len] = '/';
818 strcpy(tpath + len + 1, TMPPATH1);
819 tmppath = tpath;
820}
7a2f0d5b 821
822#include "XSUB.h"
823
824XS(XS_File__Copy_syscopy)
825{
826 dXSARGS;
827 if (items < 2 || items > 3)
828 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
829 {
830 char * src = (char *)SvPV(ST(0),na);
831 char * dst = (char *)SvPV(ST(1),na);
832 U32 flag;
833 int RETVAL, rc;
834
835 if (items < 3)
836 flag = 0;
837 else {
838 flag = (unsigned long)SvIV(ST(2));
839 }
840
6f064249 841 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b 842 ST(0) = sv_newmortal();
843 sv_setiv(ST(0), (IV)RETVAL);
844 }
845 XSRETURN(1);
846}
847
6f064249 848char *
849mod2fname(sv)
850 SV *sv;
851{
852 static char fname[9];
760ac839 853 int pos = 6, len, avlen;
854 unsigned int sum = 0;
6f064249 855 AV *av;
856 SV *svp;
857 char *s;
858
859 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
860 sv = SvRV(sv);
861 if (SvTYPE(sv) != SVt_PVAV)
862 croak("Not array reference given to mod2fname");
760ac839 863
864 avlen = av_len((AV*)sv);
865 if (avlen < 0)
6f064249 866 croak("Empty array reference given to mod2fname");
760ac839 867
868 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
6f064249 869 strncpy(fname, s, 8);
760ac839 870 len = strlen(s);
871 if (len < 6) pos = len;
872 while (*s) {
873 sum = 33 * sum + *(s++); /* Checksumming first chars to
874 * get the capitalization into c.s. */
875 }
876 avlen --;
877 while (avlen >= 0) {
878 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
879 while (*s) {
880 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
881 }
882 avlen --;
883 }
884 fname[pos] = 'A' + (sum % 26);
885 fname[pos + 1] = 'A' + (sum / 26 % 26);
886 fname[pos + 2] = '\0';
6f064249 887 return (char *)fname;
888}
889
890XS(XS_DynaLoader_mod2fname)
891{
892 dXSARGS;
893 if (items != 1)
894 croak("Usage: DynaLoader::mod2fname(sv)");
895 {
896 SV * sv = ST(0);
897 char * RETVAL;
898
899 RETVAL = mod2fname(sv);
900 ST(0) = sv_newmortal();
901 sv_setpv((SV*)ST(0), RETVAL);
902 }
903 XSRETURN(1);
904}
905
906char *
907os2error(int rc)
908{
909 static char buf[300];
910 ULONG len;
911
55497cff 912 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 913 if (rc == 0)
914 return NULL;
915 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
916 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
917 else
918 buf[len] = '\0';
919 return buf;
920}
921
760ac839 922char *
923perllib_mangle(char *s, unsigned int l)
924{
925 static char *newp, *oldp;
926 static int newl, oldl, notfound;
927 static char ret[STATIC_FILE_LENGTH+1];
928
929 if (!newp && !notfound) {
930 newp = getenv("PERLLIB_PREFIX");
931 if (newp) {
ff68c719 932 char *s;
933
760ac839 934 oldp = newp;
89078e0f 935 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839 936 newp++; oldl++; /* Skip digits. */
937 }
938 while (*newp && (isSPACE(*newp) || *newp == ';')) {
939 newp++; /* Skip whitespace. */
940 }
941 newl = strlen(newp);
942 if (newl == 0 || oldl == 0) {
943 die("Malformed PERLLIB_PREFIX");
944 }
ff68c719 945 strcpy(ret, newp);
946 s = ret;
947 while (*s) {
948 if (*s == '\\') *s = '/';
949 s++;
950 }
760ac839 951 } else {
952 notfound = 1;
953 }
954 }
955 if (!newp) {
956 return s;
957 }
958 if (l == 0) {
959 l = strlen(s);
960 }
3bbf9c2b 961 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839 962 return s;
963 }
964 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
965 die("Malformed PERLLIB_PREFIX");
966 }
89078e0f 967 strcpy(ret + newl, s + oldl);
760ac839 968 return ret;
969}
6f064249 970
971extern void dlopen();
972void *fakedl = &dlopen; /* Pull in dynaloading part. */
3bbf9c2b 973
974#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
975 && ((path)[2] == '/' || (path)[2] == '\\'))
976#define sys_is_rooted _fnisabs
977#define sys_is_relative _fnisrel
978#define current_drive _getdrive
979
980#undef chdir /* Was _chdir2. */
981#define sys_chdir(p) (chdir(p) == 0)
982#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
983
984XS(XS_Cwd_current_drive)
985{
986 dXSARGS;
987 if (items != 0)
988 croak("Usage: Cwd::current_drive()");
989 {
990 char RETVAL;
991
992 RETVAL = current_drive();
993 ST(0) = sv_newmortal();
994 sv_setpvn(ST(0), (char *)&RETVAL, 1);
995 }
996 XSRETURN(1);
997}
998
999XS(XS_Cwd_sys_chdir)
1000{
1001 dXSARGS;
1002 if (items != 1)
1003 croak("Usage: Cwd::sys_chdir(path)");
1004 {
1005 char * path = (char *)SvPV(ST(0),na);
1006 bool RETVAL;
1007
1008 RETVAL = sys_chdir(path);
54310121 1009 ST(0) = boolSV(RETVAL);
3bbf9c2b 1010 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1011 }
1012 XSRETURN(1);
1013}
1014
1015XS(XS_Cwd_change_drive)
1016{
1017 dXSARGS;
1018 if (items != 1)
1019 croak("Usage: Cwd::change_drive(d)");
1020 {
1021 char d = (char)*SvPV(ST(0),na);
1022 bool RETVAL;
1023
1024 RETVAL = change_drive(d);
54310121 1025 ST(0) = boolSV(RETVAL);
3bbf9c2b 1026 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1027 }
1028 XSRETURN(1);
1029}
1030
1031XS(XS_Cwd_sys_is_absolute)
1032{
1033 dXSARGS;
1034 if (items != 1)
1035 croak("Usage: Cwd::sys_is_absolute(path)");
1036 {
1037 char * path = (char *)SvPV(ST(0),na);
1038 bool RETVAL;
1039
1040 RETVAL = sys_is_absolute(path);
54310121 1041 ST(0) = boolSV(RETVAL);
3bbf9c2b 1042 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1043 }
1044 XSRETURN(1);
1045}
1046
1047XS(XS_Cwd_sys_is_rooted)
1048{
1049 dXSARGS;
1050 if (items != 1)
1051 croak("Usage: Cwd::sys_is_rooted(path)");
1052 {
1053 char * path = (char *)SvPV(ST(0),na);
1054 bool RETVAL;
1055
1056 RETVAL = sys_is_rooted(path);
54310121 1057 ST(0) = boolSV(RETVAL);
3bbf9c2b 1058 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1059 }
1060 XSRETURN(1);
1061}
1062
1063XS(XS_Cwd_sys_is_relative)
1064{
1065 dXSARGS;
1066 if (items != 1)
1067 croak("Usage: Cwd::sys_is_relative(path)");
1068 {
1069 char * path = (char *)SvPV(ST(0),na);
1070 bool RETVAL;
1071
1072 RETVAL = sys_is_relative(path);
54310121 1073 ST(0) = boolSV(RETVAL);
3bbf9c2b 1074 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1075 }
1076 XSRETURN(1);
1077}
1078
1079XS(XS_Cwd_sys_cwd)
1080{
1081 dXSARGS;
1082 if (items != 0)
1083 croak("Usage: Cwd::sys_cwd()");
1084 {
1085 char p[MAXPATHLEN];
1086 char * RETVAL;
1087 RETVAL = _getcwd2(p, MAXPATHLEN);
1088 ST(0) = sv_newmortal();
1089 sv_setpv((SV*)ST(0), RETVAL);
1090 }
1091 XSRETURN(1);
1092}
1093
1094XS(XS_Cwd_sys_abspath)
1095{
1096 dXSARGS;
1097 if (items < 1 || items > 2)
1098 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1099 {
1100 char * path = (char *)SvPV(ST(0),na);
1101 char * dir;
1102 char p[MAXPATHLEN];
1103 char * RETVAL;
1104
1105 if (items < 2)
1106 dir = NULL;
1107 else {
1108 dir = (char *)SvPV(ST(1),na);
1109 }
1110 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1111 path += 2;
1112 }
1113 if (dir == NULL) {
1114 if (_abspath(p, path, MAXPATHLEN) == 0) {
1115 RETVAL = p;
1116 } else {
1117 RETVAL = NULL;
1118 }
1119 } else {
1120 /* Absolute with drive: */
1121 if ( sys_is_absolute(path) ) {
1122 if (_abspath(p, path, MAXPATHLEN) == 0) {
1123 RETVAL = p;
1124 } else {
1125 RETVAL = NULL;
1126 }
1127 } else if (path[0] == '/' || path[0] == '\\') {
1128 /* Rooted, but maybe on different drive. */
1129 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1130 char p1[MAXPATHLEN];
1131
1132 /* Need to prepend the drive. */
1133 p1[0] = dir[0];
1134 p1[1] = dir[1];
1135 Copy(path, p1 + 2, strlen(path) + 1, char);
1136 RETVAL = p;
1137 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1138 RETVAL = p;
1139 } else {
1140 RETVAL = NULL;
1141 }
1142 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1143 RETVAL = p;
1144 } else {
1145 RETVAL = NULL;
1146 }
1147 } else {
1148 /* Either path is relative, or starts with a drive letter. */
1149 /* If the path starts with a drive letter, then dir is
1150 relevant only if
1151 a/b) it is absolute/x:relative on the same drive.
1152 c) path is on current drive, and dir is rooted
1153 In all the cases it is safe to drop the drive part
1154 of the path. */
1155 if ( !sys_is_relative(path) ) {
1156 int is_drived;
1157
1158 if ( ( ( sys_is_absolute(dir)
1159 || (isALPHA(dir[0]) && dir[1] == ':'
1160 && strnicmp(dir, path,1) == 0))
1161 && strnicmp(dir, path,1) == 0)
1162 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1163 && toupper(path[0]) == current_drive())) {
1164 path += 2;
1165 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1166 RETVAL = p; goto done;
1167 } else {
1168 RETVAL = NULL; goto done;
1169 }
1170 }
1171 {
1172 /* Need to prepend the absolute path of dir. */
1173 char p1[MAXPATHLEN];
1174
1175 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1176 int l = strlen(p1);
1177
1178 if (p1[ l - 1 ] != '/') {
1179 p1[ l ] = '/';
1180 l++;
1181 }
1182 Copy(path, p1 + l, strlen(path) + 1, char);
1183 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1184 RETVAL = p;
1185 } else {
1186 RETVAL = NULL;
1187 }
1188 } else {
1189 RETVAL = NULL;
1190 }
1191 }
1192 done:
1193 }
1194 }
1195 ST(0) = sv_newmortal();
1196 sv_setpv((SV*)ST(0), RETVAL);
1197 }
1198 XSRETURN(1);
1199}
72ea3524 1200typedef APIRET (*PELP)(PSZ path, ULONG type);
1201
1202APIRET
1203ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1204{
1205 loadByOrd(ord); /* Guarantied to load or die! */
1206 return (*(PELP)ExtFCN[ord])(path, type);
1207}
3bbf9c2b 1208
72ea3524 1209#define extLibpath(type) \
1210 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1211 : BEGIN_LIBPATH))) \
3bbf9c2b 1212 ? NULL : to )
1213
1214#define extLibpath_set(p,type) \
72ea3524 1215 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1216 : BEGIN_LIBPATH))))
3bbf9c2b 1217
1218XS(XS_Cwd_extLibpath)
1219{
1220 dXSARGS;
1221 if (items < 0 || items > 1)
1222 croak("Usage: Cwd::extLibpath(type = 0)");
1223 {
1224 bool type;
1225 char to[1024];
1226 U32 rc;
1227 char * RETVAL;
1228
1229 if (items < 1)
1230 type = 0;
1231 else {
1232 type = (int)SvIV(ST(0));
1233 }
1234
1235 RETVAL = extLibpath(type);
1236 ST(0) = sv_newmortal();
1237 sv_setpv((SV*)ST(0), RETVAL);
1238 }
1239 XSRETURN(1);
1240}
1241
1242XS(XS_Cwd_extLibpath_set)
1243{
1244 dXSARGS;
1245 if (items < 1 || items > 2)
1246 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1247 {
1248 char * s = (char *)SvPV(ST(0),na);
1249 bool type;
1250 U32 rc;
1251 bool RETVAL;
1252
1253 if (items < 2)
1254 type = 0;
1255 else {
1256 type = (int)SvIV(ST(1));
1257 }
1258
1259 RETVAL = extLibpath_set(s, type);
54310121 1260 ST(0) = boolSV(RETVAL);
3bbf9c2b 1261 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1262 }
1263 XSRETURN(1);
1264}
1265
1266int
1267Xs_OS2_init()
1268{
1269 char *file = __FILE__;
1270 {
1271 GV *gv;
55497cff 1272
1273 if (_emx_env & 0x200) { /* OS/2 */
1274 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1275 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1276 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1277 }
3bbf9c2b 1278 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1279 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1280 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1281 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1282 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1283 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1284 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1285 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1286 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3bbf9c2b 1287 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1288 GvMULTI_on(gv);
1289#ifdef PERL_IS_AOUT
1290 sv_setiv(GvSV(gv), 1);
1291#endif
1292 }
1293}
1294
1295OS2_Perl_data_t OS2_Perl_data;
1296
1297void
aa689395 1298Perl_OS2_init(char **env)
3bbf9c2b 1299{
1300 char *shell;
1301
18f739ee 1302 MALLOC_INIT;
3bbf9c2b 1303 settmppath();
1304 OS2_Perl_data.xs_init = &Xs_OS2_init;
aa689395 1305 if (environ == NULL) {
1306 environ = env;
1307 }
3bbf9c2b 1308 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
fc36a67e 1309 New(1304, sh_path, strlen(SH_PATH) + 1, char);
ff68c719 1310 strcpy(sh_path, SH_PATH);
3bbf9c2b 1311 sh_path[0] = shell[0];
1312 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 1313 int l = strlen(shell), i;
3bbf9c2b 1314 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1315 l--;
1316 }
fc36a67e 1317 New(1304, sh_path, l + 8, char);
3bbf9c2b 1318 strncpy(sh_path, shell, l);
1319 strcpy(sh_path + l, "/sh.exe");
ff68c719 1320 for (i = 0; i < l; i++) {
1321 if (sh_path[i] == '\\') sh_path[i] = '/';
1322 }
3bbf9c2b 1323 }
dd96f567 1324 MUTEX_INIT(&start_thread_mutex);
3bbf9c2b 1325}
1326
55497cff 1327#undef tmpnam
1328#undef tmpfile
1329
1330char *
1331my_tmpnam (char *str)
1332{
1333 char *p = getenv("TMP"), *tpath;
1334 int len;
1335
1336 if (!p) p = getenv("TEMP");
1337 tpath = tempnam(p, "pltmp");
1338 if (str && tpath) {
1339 strcpy(str, tpath);
1340 return str;
1341 }
1342 return tpath;
1343}
1344
1345FILE *
1346my_tmpfile ()
1347{
1348 struct stat s;
1349
1350 stat(".", &s);
1351 if (s.st_mode & S_IWOTH) {
1352 return tmpfile();
1353 }
1354 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1355 grants TMP. */
1356}
367f3c24 1357
1358#undef flock
1359
1360/* This code was contributed by Rocco Caputo. */
1361int
dd96f567 1362my_flock(int handle, int o)
367f3c24 1363{
1364 FILELOCK rNull, rFull;
1365 ULONG timeout, handle_type, flag_word;
1366 APIRET rc;
1367 int blocking, shared;
1368 static int use_my = -1;
1369
1370 if (use_my == -1) {
1371 char *s = getenv("USE_PERL_FLOCK");
1372 if (s)
1373 use_my = atoi(s);
1374 else
1375 use_my = 1;
1376 }
1377 if (!(_emx_env & 0x200) || !use_my)
dd96f567 1378 return flock(handle, o); /* Delegate to EMX. */
367f3c24 1379
1380 // is this a file?
1381 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1382 (handle_type & 0xFF))
1383 {
1384 errno = EBADF;
1385 return -1;
1386 }
1387 // set lock/unlock ranges
1388 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1389 rFull.lRange = 0x7FFFFFFF;
1390 // set timeout for blocking
dd96f567 1391 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
367f3c24 1392 // shared or exclusive?
dd96f567 1393 shared = (o & LOCK_SH) ? 1 : 0;
367f3c24 1394 // do not block the unlock
dd96f567 1395 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 1396 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1397 switch (rc) {
1398 case 0:
1399 errno = 0;
1400 return 0;
1401 case ERROR_INVALID_HANDLE:
1402 errno = EBADF;
1403 return -1;
1404 case ERROR_SHARING_BUFFER_EXCEEDED:
1405 errno = ENOLCK;
1406 return -1;
1407 case ERROR_LOCK_VIOLATION:
1408 break; // not an error
1409 case ERROR_INVALID_PARAMETER:
1410 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1411 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1412 errno = EINVAL;
1413 return -1;
1414 case ERROR_INTERRUPT:
1415 errno = EINTR;
1416 return -1;
1417 default:
1418 errno = EINVAL;
1419 return -1;
1420 }
1421 }
1422 // lock may block
dd96f567 1423 if (o & (LOCK_SH | LOCK_EX)) {
367f3c24 1424 // for blocking operations
1425 for (;;) {
1426 rc =
1427 DosSetFileLocks(
1428 handle,
1429 &rNull,
1430 &rFull,
1431 timeout,
1432 shared
1433 );
1434 switch (rc) {
1435 case 0:
1436 errno = 0;
1437 return 0;
1438 case ERROR_INVALID_HANDLE:
1439 errno = EBADF;
1440 return -1;
1441 case ERROR_SHARING_BUFFER_EXCEEDED:
1442 errno = ENOLCK;
1443 return -1;
1444 case ERROR_LOCK_VIOLATION:
1445 if (!blocking) {
1446 errno = EWOULDBLOCK;
1447 return -1;
1448 }
1449 break;
1450 case ERROR_INVALID_PARAMETER:
1451 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1452 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1453 errno = EINVAL;
1454 return -1;
1455 case ERROR_INTERRUPT:
1456 errno = EINTR;
1457 return -1;
1458 default:
1459 errno = EINVAL;
1460 return -1;
1461 }
1462 // give away timeslice
1463 DosSleep(1);
1464 }
1465 }
1466
1467 errno = 0;
1468 return 0;
1469}
Unnamed repository; edit this file to name it for gitweb.