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