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