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