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