projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
A bug introduced in #8217 (the undefined variable in the
[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
568ad336 1165#ifndef HAS_GETHOSTENT /* Older versions of EMX did not have it... */
760ac839 1166void * gethostent() { return tcp0("GETHOSTENT"); }
1167void * getnetent() { return tcp0("GETNETENT"); }
1168void * getprotoent() { return tcp0("GETPROTOENT"); }
1169void * getservent() { return tcp0("GETSERVENT"); }
568ad336 1170#endif
1171
760ac839 1172void sethostent(x) { tcp1("SETHOSTENT", x); }
1173void setnetent(x) { tcp1("SETNETENT", x); }
1174void setprotoent(x) { tcp1("SETPROTOENT", x); }
1175void setservent(x) { tcp1("SETSERVENT", x); }
1176void endhostent() { tcp0("ENDHOSTENT"); }
1177void endnetent() { tcp0("ENDNETENT"); }
1178void endprotoent() { tcp0("ENDPROTOENT"); }
1179void endservent() { tcp0("ENDSERVENT"); }
1180
1181/*****************************************************************************/
1182/* not implemented in C Set++ */
1183
1184#ifndef __EMX__
1185int setuid(x) { errno = EINVAL; return -1; }
1186int setgid(x) { errno = EINVAL; return -1; }
1187#endif
4633a7c4 1188
1189/*****************************************************************************/
1190/* stat() hack for char/block device */
1191
1192#if OS2_STAT_HACK
1193
1194 /* First attempt used DosQueryFSAttach which crashed the system when
1195 used with 5.001. Now just look for /dev/. */
1196
1197int
1198os2_stat(char *name, struct stat *st)
1199{
1200 static int ino = SHRT_MAX;
1201
1202 if (stricmp(name, "/dev/con") != 0
1203 && stricmp(name, "/dev/tty") != 0)
1204 return stat(name, st);
1205
1206 memset(st, 0, sizeof *st);
1207 st->st_mode = S_IFCHR|0666;
1208 st->st_ino = (ino-- & 0x7FFF);
1209 st->st_nlink = 1;
1210 return 0;
1211}
1212
1213#endif
c0c09dfd 1214
760ac839 1215#ifdef USE_PERL_SBRK
c0c09dfd 1216
760ac839 1217/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1218
1219void *
760ac839 1220sys_alloc(int size) {
1221 void *got;
1222 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1223
c0c09dfd 1224 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1225 return (void *) -1;
4bfbfac5 1226 } else if ( rc )
23da6c43 1227 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1228 return got;
c0c09dfd 1229}
760ac839 1230
1231#endif /* USE_PERL_SBRK */
c0c09dfd 1232
1233/* tmp path */
1234
1235char *tmppath = TMPPATH1;
1236
1237void
1238settmppath()
1239{
1240 char *p = getenv("TMP"), *tpath;
1241 int len;
1242
1243 if (!p) p = getenv("TEMP");
1244 if (!p) return;
1245 len = strlen(p);
1246 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
db7c17d7 1247 if (tpath) {
1248 strcpy(tpath, p);
1249 tpath[len] = '/';
1250 strcpy(tpath + len + 1, TMPPATH1);
1251 tmppath = tpath;
1252 }
c0c09dfd 1253}
7a2f0d5b 1254
1255#include "XSUB.h"
1256
1257XS(XS_File__Copy_syscopy)
1258{
1259 dXSARGS;
1260 if (items < 2 || items > 3)
23da6c43 1261 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
7a2f0d5b 1262 {
2d8e6c8d 1263 STRLEN n_a;
1264 char * src = (char *)SvPV(ST(0),n_a);
1265 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 1266 U32 flag;
1267 int RETVAL, rc;
1268
1269 if (items < 3)
1270 flag = 0;
1271 else {
1272 flag = (unsigned long)SvIV(ST(2));
1273 }
1274
6f064249 1275 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b 1276 ST(0) = sv_newmortal();
1277 sv_setiv(ST(0), (IV)RETVAL);
1278 }
1279 XSRETURN(1);
1280}
1281
017f25f1 1282#include "patchlevel.h"
1283
6f064249 1284char *
23da6c43 1285mod2fname(pTHX_ SV *sv)
6f064249 1286{
1287 static char fname[9];
760ac839 1288 int pos = 6, len, avlen;
1289 unsigned int sum = 0;
6f064249 1290 AV *av;
1291 SV *svp;
1292 char *s;
2d8e6c8d 1293 STRLEN n_a;
6f064249 1294
23da6c43 1295 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
6f064249 1296 sv = SvRV(sv);
1297 if (SvTYPE(sv) != SVt_PVAV)
23da6c43 1298 Perl_croak_nocontext("Not array reference given to mod2fname");
760ac839 1299
1300 avlen = av_len((AV*)sv);
1301 if (avlen < 0)
23da6c43 1302 Perl_croak_nocontext("Empty array reference given to mod2fname");
760ac839 1303
2d8e6c8d 1304 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 1305 strncpy(fname, s, 8);
760ac839 1306 len = strlen(s);
1307 if (len < 6) pos = len;
1308 while (*s) {
1309 sum = 33 * sum + *(s++); /* Checksumming first chars to
1310 * get the capitalization into c.s. */
1311 }
1312 avlen --;
1313 while (avlen >= 0) {
2d8e6c8d 1314 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839 1315 while (*s) {
1316 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1317 }
1318 avlen --;
1319 }
3aefca04 1320#ifdef USE_THREADS
1321 sum++; /* Avoid conflict of DLLs in memory. */
1322#endif
cceca5ed 1323 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
760ac839 1324 fname[pos] = 'A' + (sum % 26);
1325 fname[pos + 1] = 'A' + (sum / 26 % 26);
1326 fname[pos + 2] = '\0';
6f064249 1327 return (char *)fname;
1328}
1329
1330XS(XS_DynaLoader_mod2fname)
1331{
1332 dXSARGS;
1333 if (items != 1)
23da6c43 1334 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
6f064249 1335 {
1336 SV * sv = ST(0);
1337 char * RETVAL;
1338
23da6c43 1339 RETVAL = mod2fname(aTHX_ sv);
6f064249 1340 ST(0) = sv_newmortal();
1341 sv_setpv((SV*)ST(0), RETVAL);
1342 }
1343 XSRETURN(1);
1344}
1345
1346char *
1347os2error(int rc)
1348{
1349 static char buf[300];
1350 ULONG len;
1351
55497cff 1352 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 1353 if (rc == 0)
1354 return NULL;
1355 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1356 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
ed344e4f 1357 else {
6f064249 1358 buf[len] = '\0';
ed344e4f 1359 if (len && buf[len - 1] == '\n')
1360 buf[--len] = 0;
1361 if (len && buf[len - 1] == '\r')
1362 buf[--len] = 0;
1363 if (len && buf[len - 1] == '.')
1364 buf[--len] = 0;
1365 }
6f064249 1366 return buf;
1367}
1368
760ac839 1369char *
23da6c43 1370os2_execname(pTHX)
ed344e4f 1371{
1372 char buf[300], *p;
1373
1374 if (_execname(buf, sizeof buf) != 0)
1375 return PL_origargv[0];
1376 p = buf;
1377 while (*p) {
1378 if (*p == '\\')
1379 *p = '/';
1380 p++;
1381 }
1382 p = savepv(buf);
1383 SAVEFREEPV(p);
1384 return p;
1385}
1386
1387char *
760ac839 1388perllib_mangle(char *s, unsigned int l)
1389{
1390 static char *newp, *oldp;
1391 static int newl, oldl, notfound;
1392 static char ret[STATIC_FILE_LENGTH+1];
1393
1394 if (!newp && !notfound) {
1395 newp = getenv("PERLLIB_PREFIX");
1396 if (newp) {
ff68c719 1397 char *s;
1398
760ac839 1399 oldp = newp;
89078e0f 1400 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839 1401 newp++; oldl++; /* Skip digits. */
1402 }
1403 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1404 newp++; /* Skip whitespace. */
1405 }
1406 newl = strlen(newp);
1407 if (newl == 0 || oldl == 0) {
23da6c43 1408 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 1409 }
ff68c719 1410 strcpy(ret, newp);
1411 s = ret;
1412 while (*s) {
1413 if (*s == '\\') *s = '/';
1414 s++;
1415 }
760ac839 1416 } else {
1417 notfound = 1;
1418 }
1419 }
1420 if (!newp) {
1421 return s;
1422 }
1423 if (l == 0) {
1424 l = strlen(s);
1425 }
3bbf9c2b 1426 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839 1427 return s;
1428 }
1429 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
23da6c43 1430 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 1431 }
89078e0f 1432 strcpy(ret + newl, s + oldl);
760ac839 1433 return ret;
1434}
6f064249 1435
4bfbfac5 1436unsigned long
1437Perl_hab_GET() /* Needed if perl.h cannot be included */
1438{
1439 return perl_hab_GET();
1440}
1441
1442HMQ
1443Perl_Register_MQ(int serve)
1444{
1445 PPIB pib;
1446 PTIB tib;
1447
1448 if (Perl_os2_initial_mode++)
1449 return Perl_hmq;
1450 DosGetInfoBlocks(&tib, &pib);
1451 Perl_os2_initial_mode = pib->pib_ultype;
1452 Perl_hmq_refcnt = 1;
1453 /* Try morphing into a PM application. */
1454 if (pib->pib_ultype != 3) /* 2 is VIO */
1455 pib->pib_ultype = 3; /* 3 is PM */
1456 init_PMWIN_entries();
1457 /* 64 messages if before OS/2 3.0, ignored otherwise */
1458 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1459 if (!Perl_hmq) {
1460 static int cnt;
1461 if (cnt++)
1462 _exit(188); /* Panic can try to create a window. */
23da6c43 1463 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
4bfbfac5 1464 }
1465 return Perl_hmq;
1466}
1467
1468int
1469Perl_Serve_Messages(int force)
1470{
1471 int cnt = 0;
1472 QMSG msg;
1473
1474 if (Perl_hmq_servers && !force)
1475 return 0;
1476 if (!Perl_hmq_refcnt)
23da6c43 1477 Perl_croak_nocontext("No message queue");
4bfbfac5 1478 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1479 cnt++;
1480 if (msg.msg == WM_QUIT)
23da6c43 1481 Perl_croak_nocontext("QUITing...");
4bfbfac5 1482 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1483 }
1484 return cnt;
1485}
1486
1487int
1488Perl_Process_Messages(int force, I32 *cntp)
1489{
1490 QMSG msg;
1491
1492 if (Perl_hmq_servers && !force)
1493 return 0;
1494 if (!Perl_hmq_refcnt)
23da6c43 1495 Perl_croak_nocontext("No message queue");
4bfbfac5 1496 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1497 if (cntp)
1498 (*cntp)++;
1499 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1500 if (msg.msg == WM_DESTROY)
1501 return -1;
1502 if (msg.msg == WM_CREATE)
1503 return +1;
1504 }
23da6c43 1505 Perl_croak_nocontext("QUITing...");
4bfbfac5 1506}
1507
1508void
1509Perl_Deregister_MQ(int serve)
1510{
1511 PPIB pib;
1512 PTIB tib;
1513
1514 if (--Perl_hmq_refcnt == 0) {
1515 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1516 Perl_hmq = 0;
1517 /* Try morphing back from a PM application. */
1518 if (pib->pib_ultype == 3) /* 3 is PM */
1519 pib->pib_ultype = Perl_os2_initial_mode;
1520 else
23da6c43 1521 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
4bfbfac5 1522 pib->pib_ultype);
1523 }
1524}
1525
6f064249 1526extern void dlopen();
1527void *fakedl = &dlopen; /* Pull in dynaloading part. */
3bbf9c2b 1528
1529#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1530 && ((path)[2] == '/' || (path)[2] == '\\'))
1531#define sys_is_rooted _fnisabs
1532#define sys_is_relative _fnisrel
1533#define current_drive _getdrive
1534
1535#undef chdir /* Was _chdir2. */
1536#define sys_chdir(p) (chdir(p) == 0)
1537#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1538
4bfbfac5 1539static int DOS_harderr_state = -1;
1540
1541XS(XS_OS2_Error)
1542{
1543 dXSARGS;
1544 if (items != 2)
23da6c43 1545 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
4bfbfac5 1546 {
1547 int arg1 = SvIV(ST(0));
1548 int arg2 = SvIV(ST(1));
1549 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1550 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1551 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1552 unsigned long rc;
1553
1554 if (CheckOSError(DosError(a)))
23da6c43 1555 Perl_croak_nocontext("DosError(%d) failed", a);
4bfbfac5 1556 ST(0) = sv_newmortal();
1557 if (DOS_harderr_state >= 0)
1558 sv_setiv(ST(0), DOS_harderr_state);
1559 DOS_harderr_state = RETVAL;
1560 }
1561 XSRETURN(1);
1562}
1563
1564static signed char DOS_suppression_state = -1;
1565
1566XS(XS_OS2_Errors2Drive)
1567{
1568 dXSARGS;
1569 if (items != 1)
23da6c43 1570 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
4bfbfac5 1571 {
2d8e6c8d 1572 STRLEN n_a;
4bfbfac5 1573 SV *sv = ST(0);
1574 int suppress = SvOK(sv);
2d8e6c8d 1575 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5 1576 char drive = (s ? *s : 0);
1577 unsigned long rc;
1578
1579 if (suppress && !isALPHA(drive))
23da6c43 1580 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
4bfbfac5 1581 if (CheckOSError(DosSuppressPopUps((suppress
1582 ? SPU_ENABLESUPPRESSION
1583 : SPU_DISABLESUPPRESSION),
1584 drive)))
23da6c43 1585 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
4bfbfac5 1586 ST(0) = sv_newmortal();
1587 if (DOS_suppression_state > 0)
1588 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1589 else if (DOS_suppression_state == 0)
1590 sv_setpvn(ST(0), "", 0);
1591 DOS_suppression_state = drive;
1592 }
1593 XSRETURN(1);
1594}
1595
1596static const char * const si_fields[QSV_MAX] = {
1597 "MAX_PATH_LENGTH",
1598 "MAX_TEXT_SESSIONS",
1599 "MAX_PM_SESSIONS",
1600 "MAX_VDM_SESSIONS",
1601 "BOOT_DRIVE",
1602 "DYN_PRI_VARIATION",
1603 "MAX_WAIT",
1604 "MIN_SLICE",
1605 "MAX_SLICE",
1606 "PAGE_SIZE",
1607 "VERSION_MAJOR",
1608 "VERSION_MINOR",
1609 "VERSION_REVISION",
1610 "MS_COUNT",
1611 "TIME_LOW",
1612 "TIME_HIGH",
1613 "TOTPHYSMEM",
1614 "TOTRESMEM",
1615 "TOTAVAILMEM",
1616 "MAXPRMEM",
1617 "MAXSHMEM",
1618 "TIMER_INTERVAL",
1619 "MAX_COMP_LENGTH",
1620 "FOREGROUND_FS_SESSION",
1621 "FOREGROUND_PROCESS"
1622};
1623
1624XS(XS_OS2_SysInfo)
1625{
1626 dXSARGS;
1627 if (items != 0)
23da6c43 1628 Perl_croak_nocontext("Usage: OS2::SysInfo()");
4bfbfac5 1629 {
1630 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1631 APIRET rc = NO_ERROR; /* Return code */
1632 int i = 0, j = 0;
1633
1634 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1635 QSV_MAX, /* information */
1636 (PVOID)si,
1637 sizeof(si))))
23da6c43 1638 Perl_croak_nocontext("DosQuerySysInfo() failed");
4bfbfac5 1639 EXTEND(SP,2*QSV_MAX);
1640 while (i < QSV_MAX) {
1641 ST(j) = sv_newmortal();
1642 sv_setpv(ST(j++), si_fields[i]);
1643 ST(j) = sv_newmortal();
1644 sv_setiv(ST(j++), si[i]);
1645 i++;
1646 }
1647 }
1648 XSRETURN(2 * QSV_MAX);
1649}
1650
1651XS(XS_OS2_BootDrive)
1652{
1653 dXSARGS;
1654 if (items != 0)
23da6c43 1655 Perl_croak_nocontext("Usage: OS2::BootDrive()");
4bfbfac5 1656 {
1657 ULONG si[1] = {0}; /* System Information Data Buffer */
1658 APIRET rc = NO_ERROR; /* Return code */
1659 char c;
1660
1661 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1662 (PVOID)si, sizeof(si))))
23da6c43 1663 Perl_croak_nocontext("DosQuerySysInfo() failed");
4bfbfac5 1664 ST(0) = sv_newmortal();
1665 c = 'a' - 1 + si[0];
1666 sv_setpvn(ST(0), &c, 1);
1667 }
1668 XSRETURN(1);
1669}
1670
1671XS(XS_OS2_MorphPM)
1672{
1673 dXSARGS;
1674 if (items != 1)
23da6c43 1675 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
4bfbfac5 1676 {
1677 bool serve = SvOK(ST(0));
1678 unsigned long pmq = perl_hmq_GET(serve);
1679
1680 ST(0) = sv_newmortal();
1681 sv_setiv(ST(0), pmq);
1682 }
1683 XSRETURN(1);
1684}
1685
1686XS(XS_OS2_UnMorphPM)
1687{
1688 dXSARGS;
1689 if (items != 1)
23da6c43 1690 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
4bfbfac5 1691 {
1692 bool serve = SvOK(ST(0));
1693
1694 perl_hmq_UNSET(serve);
1695 }
1696 XSRETURN(0);
1697}
1698
1699XS(XS_OS2_Serve_Messages)
1700{
1701 dXSARGS;
1702 if (items != 1)
23da6c43 1703 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
4bfbfac5 1704 {
1705 bool force = SvOK(ST(0));
1706 unsigned long cnt = Perl_Serve_Messages(force);
1707
1708 ST(0) = sv_newmortal();
1709 sv_setiv(ST(0), cnt);
1710 }
1711 XSRETURN(1);
1712}
1713
1714XS(XS_OS2_Process_Messages)
1715{
1716 dXSARGS;
1717 if (items < 1 || items > 2)
23da6c43 1718 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
4bfbfac5 1719 {
1720 bool force = SvOK(ST(0));
1721 unsigned long cnt;
4bfbfac5 1722
1723 if (items == 2) {
47344f21 1724 I32 cntr;
4bfbfac5 1725 SV *sv = ST(1);
1726 int fake = SvIV(sv); /* Force SvIVX */
1727
1728 if (!SvIOK(sv))
23da6c43 1729 Perl_croak_nocontext("Can't upgrade count to IV");
47344f21 1730 cntr = SvIVX(sv);
1731 cnt = Perl_Process_Messages(force, &cntr);
1732 SvIVX(sv) = cntr;
1733 } else {
1734 cnt = Perl_Process_Messages(force, NULL);
1735 }
4bfbfac5 1736 ST(0) = sv_newmortal();
1737 sv_setiv(ST(0), cnt);
1738 }
1739 XSRETURN(1);
1740}
1741
3bbf9c2b 1742XS(XS_Cwd_current_drive)
1743{
1744 dXSARGS;
1745 if (items != 0)
23da6c43 1746 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3bbf9c2b 1747 {
1748 char RETVAL;
1749
1750 RETVAL = current_drive();
1751 ST(0) = sv_newmortal();
1752 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1753 }
1754 XSRETURN(1);
1755}
1756
1757XS(XS_Cwd_sys_chdir)
1758{
1759 dXSARGS;
1760 if (items != 1)
23da6c43 1761 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3bbf9c2b 1762 {
2d8e6c8d 1763 STRLEN n_a;
1764 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1765 bool RETVAL;
1766
1767 RETVAL = sys_chdir(path);
54310121 1768 ST(0) = boolSV(RETVAL);
3bbf9c2b 1769 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1770 }
1771 XSRETURN(1);
1772}
1773
1774XS(XS_Cwd_change_drive)
1775{
1776 dXSARGS;
1777 if (items != 1)
23da6c43 1778 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3bbf9c2b 1779 {
2d8e6c8d 1780 STRLEN n_a;
1781 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b 1782 bool RETVAL;
1783
1784 RETVAL = change_drive(d);
54310121 1785 ST(0) = boolSV(RETVAL);
3bbf9c2b 1786 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1787 }
1788 XSRETURN(1);
1789}
1790
1791XS(XS_Cwd_sys_is_absolute)
1792{
1793 dXSARGS;
1794 if (items != 1)
23da6c43 1795 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3bbf9c2b 1796 {
2d8e6c8d 1797 STRLEN n_a;
1798 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1799 bool RETVAL;
1800
1801 RETVAL = sys_is_absolute(path);
54310121 1802 ST(0) = boolSV(RETVAL);
3bbf9c2b 1803 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1804 }
1805 XSRETURN(1);
1806}
1807
1808XS(XS_Cwd_sys_is_rooted)
1809{
1810 dXSARGS;
1811 if (items != 1)
23da6c43 1812 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3bbf9c2b 1813 {
2d8e6c8d 1814 STRLEN n_a;
1815 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1816 bool RETVAL;
1817
1818 RETVAL = sys_is_rooted(path);
54310121 1819 ST(0) = boolSV(RETVAL);
3bbf9c2b 1820 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1821 }
1822 XSRETURN(1);
1823}
1824
1825XS(XS_Cwd_sys_is_relative)
1826{
1827 dXSARGS;
1828 if (items != 1)
23da6c43 1829 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3bbf9c2b 1830 {
2d8e6c8d 1831 STRLEN n_a;
1832 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1833 bool RETVAL;
1834
1835 RETVAL = sys_is_relative(path);
54310121 1836 ST(0) = boolSV(RETVAL);
3bbf9c2b 1837 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1838 }
1839 XSRETURN(1);
1840}
1841
1842XS(XS_Cwd_sys_cwd)
1843{
1844 dXSARGS;
1845 if (items != 0)
23da6c43 1846 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3bbf9c2b 1847 {
1848 char p[MAXPATHLEN];
1849 char * RETVAL;
1850 RETVAL = _getcwd2(p, MAXPATHLEN);
1851 ST(0) = sv_newmortal();
1852 sv_setpv((SV*)ST(0), RETVAL);
1853 }
1854 XSRETURN(1);
1855}
1856
1857XS(XS_Cwd_sys_abspath)
1858{
1859 dXSARGS;
1860 if (items < 1 || items > 2)
23da6c43 1861 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
3bbf9c2b 1862 {
2d8e6c8d 1863 STRLEN n_a;
1864 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 1865 char * dir;
1866 char p[MAXPATHLEN];
1867 char * RETVAL;
1868
1869 if (items < 2)
1870 dir = NULL;
1871 else {
2d8e6c8d 1872 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b 1873 }
1874 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1875 path += 2;
1876 }
1877 if (dir == NULL) {
1878 if (_abspath(p, path, MAXPATHLEN) == 0) {
1879 RETVAL = p;
1880 } else {
1881 RETVAL = NULL;
1882 }
1883 } else {
1884 /* Absolute with drive: */
1885 if ( sys_is_absolute(path) ) {
1886 if (_abspath(p, path, MAXPATHLEN) == 0) {
1887 RETVAL = p;
1888 } else {
1889 RETVAL = NULL;
1890 }
1891 } else if (path[0] == '/' || path[0] == '\\') {
1892 /* Rooted, but maybe on different drive. */
1893 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1894 char p1[MAXPATHLEN];
1895
1896 /* Need to prepend the drive. */
1897 p1[0] = dir[0];
1898 p1[1] = dir[1];
1899 Copy(path, p1 + 2, strlen(path) + 1, char);
1900 RETVAL = p;
1901 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1902 RETVAL = p;
1903 } else {
1904 RETVAL = NULL;
1905 }
1906 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1907 RETVAL = p;
1908 } else {
1909 RETVAL = NULL;
1910 }
1911 } else {
1912 /* Either path is relative, or starts with a drive letter. */
1913 /* If the path starts with a drive letter, then dir is
1914 relevant only if
1915 a/b) it is absolute/x:relative on the same drive.
1916 c) path is on current drive, and dir is rooted
1917 In all the cases it is safe to drop the drive part
1918 of the path. */
1919 if ( !sys_is_relative(path) ) {
1920 int is_drived;
1921
1922 if ( ( ( sys_is_absolute(dir)
1923 || (isALPHA(dir[0]) && dir[1] == ':'
1924 && strnicmp(dir, path,1) == 0))
1925 && strnicmp(dir, path,1) == 0)
1926 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1927 && toupper(path[0]) == current_drive())) {
1928 path += 2;
1929 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1930 RETVAL = p; goto done;
1931 } else {
1932 RETVAL = NULL; goto done;
1933 }
1934 }
1935 {
1936 /* Need to prepend the absolute path of dir. */
1937 char p1[MAXPATHLEN];
1938
1939 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1940 int l = strlen(p1);
1941
1942 if (p1[ l - 1 ] != '/') {
1943 p1[ l ] = '/';
1944 l++;
1945 }
1946 Copy(path, p1 + l, strlen(path) + 1, char);
1947 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1948 RETVAL = p;
1949 } else {
1950 RETVAL = NULL;
1951 }
1952 } else {
1953 RETVAL = NULL;
1954 }
1955 }
1956 done:
1957 }
1958 }
1959 ST(0) = sv_newmortal();
1960 sv_setpv((SV*)ST(0), RETVAL);
1961 }
1962 XSRETURN(1);
1963}
72ea3524 1964typedef APIRET (*PELP)(PSZ path, ULONG type);
1965
1966APIRET
1967ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1968{
4bfbfac5 1969 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
72ea3524 1970 return (*(PELP)ExtFCN[ord])(path, type);
1971}
3bbf9c2b 1972
72ea3524 1973#define extLibpath(type) \
1974 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1975 : BEGIN_LIBPATH))) \
3bbf9c2b 1976 ? NULL : to )
1977
1978#define extLibpath_set(p,type) \
72ea3524 1979 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1980 : BEGIN_LIBPATH))))
3bbf9c2b 1981
1982XS(XS_Cwd_extLibpath)
1983{
1984 dXSARGS;
1985 if (items < 0 || items > 1)
23da6c43 1986 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3bbf9c2b 1987 {
1988 bool type;
1989 char to[1024];
1990 U32 rc;
1991 char * RETVAL;
1992
1993 if (items < 1)
1994 type = 0;
1995 else {
1996 type = (int)SvIV(ST(0));
1997 }
1998
1999 RETVAL = extLibpath(type);
2000 ST(0) = sv_newmortal();
2001 sv_setpv((SV*)ST(0), RETVAL);
2002 }
2003 XSRETURN(1);
2004}
2005
2006XS(XS_Cwd_extLibpath_set)
2007{
2008 dXSARGS;
2009 if (items < 1 || items > 2)
23da6c43 2010 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3bbf9c2b 2011 {
2d8e6c8d 2012 STRLEN n_a;
2013 char * s = (char *)SvPV(ST(0),n_a);
3bbf9c2b 2014 bool type;
2015 U32 rc;
2016 bool RETVAL;
2017
2018 if (items < 2)
2019 type = 0;
2020 else {
2021 type = (int)SvIV(ST(1));
2022 }
2023
2024 RETVAL = extLibpath_set(s, type);
54310121 2025 ST(0) = boolSV(RETVAL);
3bbf9c2b 2026 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2027 }
2028 XSRETURN(1);
2029}
2030
2031int
23da6c43 2032Xs_OS2_init(pTHX)
3bbf9c2b 2033{
2034 char *file = __FILE__;
2035 {
2036 GV *gv;
55497cff 2037
2038 if (_emx_env & 0x200) { /* OS/2 */
2039 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2040 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2041 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2042 }
4bfbfac5 2043 newXS("OS2::Error", XS_OS2_Error, file);
2044 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2045 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2046 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2047 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2048 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2049 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2050 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b 2051 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2052 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2053 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2054 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2055 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2056 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2057 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2058 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2059 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
3bbf9c2b 2060 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2061 GvMULTI_on(gv);
2062#ifdef PERL_IS_AOUT
2063 sv_setiv(GvSV(gv), 1);
2064#endif
4bfbfac5 2065 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2066 GvMULTI_on(gv);
2067 sv_setiv(GvSV(gv), _emx_rev);
2068 sv_setpv(GvSV(gv), _emx_vprt);
2069 SvIOK_on(GvSV(gv));
2070 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2071 GvMULTI_on(gv);
2072 sv_setiv(GvSV(gv), _emx_env);
2073 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2074 GvMULTI_on(gv);
2075 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
3bbf9c2b 2076 }
2077}
2078
2079OS2_Perl_data_t OS2_Perl_data;
2080
2081void
aa689395 2082Perl_OS2_init(char **env)
3bbf9c2b 2083{
2084 char *shell;
2085
18f739ee 2086 MALLOC_INIT;
3bbf9c2b 2087 settmppath();
2088 OS2_Perl_data.xs_init = &Xs_OS2_init;
28743a51 2089 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
ed344e4f 2090 if (environ == NULL && env) {
aa689395 2091 environ = env;
2092 }
3bbf9c2b 2093 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c 2094 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2095 strcpy(PL_sh_path, SH_PATH);
2096 PL_sh_path[0] = shell[0];
3bbf9c2b 2097 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 2098 int l = strlen(shell), i;
3bbf9c2b 2099 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2100 l--;
2101 }
6b88bc9c 2102 New(1304, PL_sh_path, l + 8, char);
2103 strncpy(PL_sh_path, shell, l);
2104 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 2105 for (i = 0; i < l; i++) {
6b88bc9c 2106 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 2107 }
3bbf9c2b 2108 }
dd96f567 2109 MUTEX_INIT(&start_thread_mutex);
017f25f1 2110 os2_mytype = my_type(); /* Do it before morphing. Needed? */
3bbf9c2b 2111}
2112
55497cff 2113#undef tmpnam
2114#undef tmpfile
2115
2116char *
2117my_tmpnam (char *str)
2118{
2119 char *p = getenv("TMP"), *tpath;
2120 int len;
2121
2122 if (!p) p = getenv("TEMP");
2123 tpath = tempnam(p, "pltmp");
2124 if (str && tpath) {
2125 strcpy(str, tpath);
2126 return str;
2127 }
2128 return tpath;
2129}
2130
2131FILE *
2132my_tmpfile ()
2133{
2134 struct stat s;
2135
2136 stat(".", &s);
2137 if (s.st_mode & S_IWOTH) {
2138 return tmpfile();
2139 }
2140 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2141 grants TMP. */
2142}
367f3c24 2143
2144#undef flock
2145
2146/* This code was contributed by Rocco Caputo. */
2147int
dd96f567 2148my_flock(int handle, int o)
367f3c24 2149{
2150 FILELOCK rNull, rFull;
2151 ULONG timeout, handle_type, flag_word;
2152 APIRET rc;
2153 int blocking, shared;
2154 static int use_my = -1;
2155
2156 if (use_my == -1) {
2157 char *s = getenv("USE_PERL_FLOCK");
2158 if (s)
2159 use_my = atoi(s);
2160 else
2161 use_my = 1;
2162 }
2163 if (!(_emx_env & 0x200) || !use_my)
dd96f567 2164 return flock(handle, o); /* Delegate to EMX. */
367f3c24 2165
2166 // is this a file?
2167 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2168 (handle_type & 0xFF))
2169 {
2170 errno = EBADF;
2171 return -1;
2172 }
2173 // set lock/unlock ranges
2174 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2175 rFull.lRange = 0x7FFFFFFF;
2176 // set timeout for blocking
dd96f567 2177 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
367f3c24 2178 // shared or exclusive?
dd96f567 2179 shared = (o & LOCK_SH) ? 1 : 0;
367f3c24 2180 // do not block the unlock
dd96f567 2181 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 2182 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2183 switch (rc) {
2184 case 0:
2185 errno = 0;
2186 return 0;
2187 case ERROR_INVALID_HANDLE:
2188 errno = EBADF;
2189 return -1;
2190 case ERROR_SHARING_BUFFER_EXCEEDED:
2191 errno = ENOLCK;
2192 return -1;
2193 case ERROR_LOCK_VIOLATION:
2194 break; // not an error
2195 case ERROR_INVALID_PARAMETER:
2196 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2197 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2198 errno = EINVAL;
2199 return -1;
2200 case ERROR_INTERRUPT:
2201 errno = EINTR;
2202 return -1;
2203 default:
2204 errno = EINVAL;
2205 return -1;
2206 }
2207 }
2208 // lock may block
dd96f567 2209 if (o & (LOCK_SH | LOCK_EX)) {
367f3c24 2210 // for blocking operations
2211 for (;;) {
2212 rc =
2213 DosSetFileLocks(
2214 handle,
2215 &rNull,
2216 &rFull,
2217 timeout,
2218 shared
2219 );
2220 switch (rc) {
2221 case 0:
2222 errno = 0;
2223 return 0;
2224 case ERROR_INVALID_HANDLE:
2225 errno = EBADF;
2226 return -1;
2227 case ERROR_SHARING_BUFFER_EXCEEDED:
2228 errno = ENOLCK;
2229 return -1;
2230 case ERROR_LOCK_VIOLATION:
2231 if (!blocking) {
2232 errno = EWOULDBLOCK;
2233 return -1;
2234 }
2235 break;
2236 case ERROR_INVALID_PARAMETER:
2237 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2238 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2239 errno = EINVAL;
2240 return -1;
2241 case ERROR_INTERRUPT:
2242 errno = EINTR;
2243 return -1;
2244 default:
2245 errno = EINVAL;
2246 return -1;
2247 }
2248 // give away timeslice
2249 DosSleep(1);
2250 }
2251 }
2252
2253 errno = 0;
2254 return 0;
2255}
Unnamed repository; edit this file to name it for gitweb.