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