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