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