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