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