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