projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Make #11082 more OS/2-specific.
[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);
3bbf9c2b 1974 char * dir;
1975 char p[MAXPATHLEN];
1976 char * RETVAL;
1977
1978 if (items < 2)
1979 dir = NULL;
1980 else {
2d8e6c8d 1981 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b 1982 }
1983 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1984 path += 2;
1985 }
1986 if (dir == NULL) {
1987 if (_abspath(p, path, MAXPATHLEN) == 0) {
1988 RETVAL = p;
1989 } else {
1990 RETVAL = NULL;
1991 }
1992 } else {
1993 /* Absolute with drive: */
1994 if ( sys_is_absolute(path) ) {
1995 if (_abspath(p, path, MAXPATHLEN) == 0) {
1996 RETVAL = p;
1997 } else {
1998 RETVAL = NULL;
1999 }
2000 } else if (path[0] == '/' || path[0] == '\\') {
2001 /* Rooted, but maybe on different drive. */
2002 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2003 char p1[MAXPATHLEN];
2004
2005 /* Need to prepend the drive. */
2006 p1[0] = dir[0];
2007 p1[1] = dir[1];
2008 Copy(path, p1 + 2, strlen(path) + 1, char);
2009 RETVAL = p;
2010 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2011 RETVAL = p;
2012 } else {
2013 RETVAL = NULL;
2014 }
2015 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2016 RETVAL = p;
2017 } else {
2018 RETVAL = NULL;
2019 }
2020 } else {
2021 /* Either path is relative, or starts with a drive letter. */
2022 /* If the path starts with a drive letter, then dir is
2023 relevant only if
2024 a/b) it is absolute/x:relative on the same drive.
2025 c) path is on current drive, and dir is rooted
2026 In all the cases it is safe to drop the drive part
2027 of the path. */
2028 if ( !sys_is_relative(path) ) {
3bbf9c2b 2029 if ( ( ( sys_is_absolute(dir)
2030 || (isALPHA(dir[0]) && dir[1] == ':'
2031 && strnicmp(dir, path,1) == 0))
2032 && strnicmp(dir, path,1) == 0)
2033 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2034 && toupper(path[0]) == current_drive())) {
2035 path += 2;
2036 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2037 RETVAL = p; goto done;
2038 } else {
2039 RETVAL = NULL; goto done;
2040 }
2041 }
2042 {
2043 /* Need to prepend the absolute path of dir. */
2044 char p1[MAXPATHLEN];
2045
2046 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2047 int l = strlen(p1);
2048
2049 if (p1[ l - 1 ] != '/') {
2050 p1[ l ] = '/';
2051 l++;
2052 }
2053 Copy(path, p1 + l, strlen(path) + 1, char);
2054 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2055 RETVAL = p;
2056 } else {
2057 RETVAL = NULL;
2058 }
2059 } else {
2060 RETVAL = NULL;
2061 }
2062 }
2063 done:
2064 }
2065 }
2066 ST(0) = sv_newmortal();
2067 sv_setpv((SV*)ST(0), RETVAL);
2068 }
2069 XSRETURN(1);
2070}
72ea3524 2071typedef APIRET (*PELP)(PSZ path, ULONG type);
2072
5a9d0041 2073/* Kernels after 2000/09/15 understand this too: */
2074#ifndef LIBPATHSTRICT
2075# define LIBPATHSTRICT 3
2076#endif
2077
72ea3524 2078APIRET
5a9d0041 2079ExtLIBPATH(ULONG ord, PSZ path, IV type)
72ea3524 2080{
5a9d0041 2081 ULONG what;
35bc1fdc 2082 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
5a9d0041 2083
5a9d0041 2084 if (type > 0)
2085 what = END_LIBPATH;
2086 else if (type == 0)
2087 what = BEGIN_LIBPATH;
2088 else
2089 what = LIBPATHSTRICT;
35bc1fdc 2090 return (*(PELP)f)(path, what);
72ea3524 2091}
3bbf9c2b 2092
5a9d0041 2093#define extLibpath(to,type) \
35bc1fdc 2094 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3bbf9c2b 2095
2096#define extLibpath_set(p,type) \
35bc1fdc 2097 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3bbf9c2b 2098
2099XS(XS_Cwd_extLibpath)
2100{
2101 dXSARGS;
2102 if (items < 0 || items > 1)
23da6c43 2103 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3bbf9c2b 2104 {
5a9d0041 2105 IV type;
3bbf9c2b 2106 char to[1024];
2107 U32 rc;
2108 char * RETVAL;
2109
2110 if (items < 1)
2111 type = 0;
2112 else {
5a9d0041 2113 type = SvIV(ST(0));
3bbf9c2b 2114 }
2115
5a9d0041 2116 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2117 RETVAL = extLibpath(to, type);
2118 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2119 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3bbf9c2b 2120 ST(0) = sv_newmortal();
2121 sv_setpv((SV*)ST(0), RETVAL);
2122 }
2123 XSRETURN(1);
2124}
2125
2126XS(XS_Cwd_extLibpath_set)
2127{
2128 dXSARGS;
2129 if (items < 1 || items > 2)
23da6c43 2130 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3bbf9c2b 2131 {
2d8e6c8d 2132 STRLEN n_a;
2133 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 2134 IV type;
3bbf9c2b 2135 U32 rc;
2136 bool RETVAL;
2137
2138 if (items < 2)
2139 type = 0;
2140 else {
5a9d0041 2141 type = SvIV(ST(1));
3bbf9c2b 2142 }
2143
2144 RETVAL = extLibpath_set(s, type);
54310121 2145 ST(0) = boolSV(RETVAL);
3bbf9c2b 2146 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2147 }
2148 XSRETURN(1);
2149}
2150
5ba48348 2151#define get_control87() _control87(0,0)
2152#define set_control87 _control87
2153
2154XS(XS_OS2__control87)
2155{
2156 dXSARGS;
2157 if (items != 2)
2158 croak("Usage: OS2::_control87(new,mask)");
2159 {
2160 unsigned new = (unsigned)SvIV(ST(0));
2161 unsigned mask = (unsigned)SvIV(ST(1));
2162 unsigned RETVAL;
2163
2164 RETVAL = _control87(new, mask);
2165 ST(0) = sv_newmortal();
2166 sv_setiv(ST(0), (IV)RETVAL);
2167 }
2168 XSRETURN(1);
2169}
2170
2171XS(XS_OS2_get_control87)
2172{
2173 dXSARGS;
2174 if (items != 0)
2175 croak("Usage: OS2::get_control87()");
2176 {
2177 unsigned RETVAL;
2178
2179 RETVAL = get_control87();
2180 ST(0) = sv_newmortal();
2181 sv_setiv(ST(0), (IV)RETVAL);
2182 }
2183 XSRETURN(1);
2184}
2185
2186
2187XS(XS_OS2_set_control87)
2188{
2189 dXSARGS;
2190 if (items < 0 || items > 2)
2191 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2192 {
2193 unsigned new;
2194 unsigned mask;
2195 unsigned RETVAL;
2196
2197 if (items < 1)
2198 new = MCW_EM;
2199 else {
2200 new = (unsigned)SvIV(ST(0));
2201 }
2202
2203 if (items < 2)
2204 mask = MCW_EM;
2205 else {
2206 mask = (unsigned)SvIV(ST(1));
2207 }
2208
2209 RETVAL = set_control87(new, mask);
2210 ST(0) = sv_newmortal();
2211 sv_setiv(ST(0), (IV)RETVAL);
2212 }
2213 XSRETURN(1);
2214}
2215
3bbf9c2b 2216int
23da6c43 2217Xs_OS2_init(pTHX)
3bbf9c2b 2218{
2219 char *file = __FILE__;
2220 {
2221 GV *gv;
55497cff 2222
2223 if (_emx_env & 0x200) { /* OS/2 */
2224 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2225 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2226 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2227 }
4bfbfac5 2228 newXS("OS2::Error", XS_OS2_Error, file);
2229 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2230 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2231 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2232 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2233 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2234 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2235 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b 2236 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2237 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2238 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2239 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2240 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2241 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2242 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2243 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2244 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
5ba48348 2245 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2246 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2247 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
3bbf9c2b 2248 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2249 GvMULTI_on(gv);
2250#ifdef PERL_IS_AOUT
2251 sv_setiv(GvSV(gv), 1);
2252#endif
4bfbfac5 2253 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2254 GvMULTI_on(gv);
2255 sv_setiv(GvSV(gv), _emx_rev);
2256 sv_setpv(GvSV(gv), _emx_vprt);
2257 SvIOK_on(GvSV(gv));
2258 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2259 GvMULTI_on(gv);
2260 sv_setiv(GvSV(gv), _emx_env);
2261 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2262 GvMULTI_on(gv);
2263 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87 2264 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2265 GvMULTI_on(gv);
2266 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 2267 }
2d766320 2268 return 0;
3bbf9c2b 2269}
2270
2271OS2_Perl_data_t OS2_Perl_data;
2272
2273void
aa689395 2274Perl_OS2_init(char **env)
3bbf9c2b 2275{
2276 char *shell;
2277
18f739ee 2278 MALLOC_INIT;
3bbf9c2b 2279 settmppath();
2280 OS2_Perl_data.xs_init = &Xs_OS2_init;
28743a51 2281 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
ed344e4f 2282 if (environ == NULL && env) {
aa689395 2283 environ = env;
2284 }
3bbf9c2b 2285 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c 2286 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2287 strcpy(PL_sh_path, SH_PATH);
2288 PL_sh_path[0] = shell[0];
3bbf9c2b 2289 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 2290 int l = strlen(shell), i;
3bbf9c2b 2291 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2292 l--;
2293 }
6b88bc9c 2294 New(1304, PL_sh_path, l + 8, char);
2295 strncpy(PL_sh_path, shell, l);
2296 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 2297 for (i = 0; i < l; i++) {
6b88bc9c 2298 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 2299 }
3bbf9c2b 2300 }
dd96f567 2301 MUTEX_INIT(&start_thread_mutex);
017f25f1 2302 os2_mytype = my_type(); /* Do it before morphing. Needed? */
5ba48348 2303 /* Some DLLs reset FP flags on load. We may have been linked with them */
2304 _control87(MCW_EM, MCW_EM);
3bbf9c2b 2305}
2306
55497cff 2307#undef tmpnam
2308#undef tmpfile
2309
2310char *
2311my_tmpnam (char *str)
2312{
2313 char *p = getenv("TMP"), *tpath;
55497cff 2314
2315 if (!p) p = getenv("TEMP");
2316 tpath = tempnam(p, "pltmp");
2317 if (str && tpath) {
2318 strcpy(str, tpath);
2319 return str;
2320 }
2321 return tpath;
2322}
2323
2324FILE *
2325my_tmpfile ()
2326{
2327 struct stat s;
2328
2329 stat(".", &s);
2330 if (s.st_mode & S_IWOTH) {
2331 return tmpfile();
2332 }
2333 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2334 grants TMP. */
2335}
367f3c24 2336
5ba48348 2337#undef rmdir
2338
2339int
2340my_rmdir (__const__ char *s)
2341{
2342 char buf[MAXPATHLEN];
2343 STRLEN l = strlen(s);
2344
2345 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2346 strcpy(buf,s);
2347 buf[l - 1] = 0;
2348 s = buf;
2349 }
2350 return rmdir(s);
2351}
2352
2353#undef mkdir
2354
2355int
2356my_mkdir (__const__ char *s, long perm)
2357{
2358 char buf[MAXPATHLEN];
2359 STRLEN l = strlen(s);
2360
2361 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2362 strcpy(buf,s);
2363 buf[l - 1] = 0;
2364 s = buf;
2365 }
2366 return mkdir(s, perm);
2367}
2368
367f3c24 2369#undef flock
2370
2371/* This code was contributed by Rocco Caputo. */
2372int
dd96f567 2373my_flock(int handle, int o)
367f3c24 2374{
2375 FILELOCK rNull, rFull;
2376 ULONG timeout, handle_type, flag_word;
2377 APIRET rc;
2378 int blocking, shared;
2379 static int use_my = -1;
2380
2381 if (use_my == -1) {
2382 char *s = getenv("USE_PERL_FLOCK");
2383 if (s)
2384 use_my = atoi(s);
2385 else
2386 use_my = 1;
2387 }
2388 if (!(_emx_env & 0x200) || !use_my)
dd96f567 2389 return flock(handle, o); /* Delegate to EMX. */
367f3c24 2390
2391 // is this a file?
2392 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2393 (handle_type & 0xFF))
2394 {
2395 errno = EBADF;
2396 return -1;
2397 }
2398 // set lock/unlock ranges
2399 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2400 rFull.lRange = 0x7FFFFFFF;
2401 // set timeout for blocking
dd96f567 2402 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
367f3c24 2403 // shared or exclusive?
dd96f567 2404 shared = (o & LOCK_SH) ? 1 : 0;
367f3c24 2405 // do not block the unlock
dd96f567 2406 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 2407 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2408 switch (rc) {
2409 case 0:
2410 errno = 0;
2411 return 0;
2412 case ERROR_INVALID_HANDLE:
2413 errno = EBADF;
2414 return -1;
2415 case ERROR_SHARING_BUFFER_EXCEEDED:
2416 errno = ENOLCK;
2417 return -1;
2418 case ERROR_LOCK_VIOLATION:
2419 break; // not an error
2420 case ERROR_INVALID_PARAMETER:
2421 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2422 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2423 errno = EINVAL;
2424 return -1;
2425 case ERROR_INTERRUPT:
2426 errno = EINTR;
2427 return -1;
2428 default:
2429 errno = EINVAL;
2430 return -1;
2431 }
2432 }
2433 // lock may block
dd96f567 2434 if (o & (LOCK_SH | LOCK_EX)) {
367f3c24 2435 // for blocking operations
2436 for (;;) {
2437 rc =
2438 DosSetFileLocks(
2439 handle,
2440 &rNull,
2441 &rFull,
2442 timeout,
2443 shared
2444 );
2445 switch (rc) {
2446 case 0:
2447 errno = 0;
2448 return 0;
2449 case ERROR_INVALID_HANDLE:
2450 errno = EBADF;
2451 return -1;
2452 case ERROR_SHARING_BUFFER_EXCEEDED:
2453 errno = ENOLCK;
2454 return -1;
2455 case ERROR_LOCK_VIOLATION:
2456 if (!blocking) {
2457 errno = EWOULDBLOCK;
2458 return -1;
2459 }
2460 break;
2461 case ERROR_INVALID_PARAMETER:
2462 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2463 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2464 errno = EINVAL;
2465 return -1;
2466 case ERROR_INTERRUPT:
2467 errno = EINTR;
2468 return -1;
2469 default:
2470 errno = EINVAL;
2471 return -1;
2472 }
2473 // give away timeslice
2474 DosSleep(1);
2475 }
2476 }
2477
2478 errno = 0;
2479 return 0;
2480}
f72c975a 2481
2482static int pwent_cnt;
2483static int _my_pwent = -1;
2484
2485static int
2486use_my_pwent(void)
2487{
2488 if (_my_pwent == -1) {
2489 char *s = getenv("USE_PERL_PWENT");
2490 if (s)
2491 _my_pwent = atoi(s);
2492 else
2493 _my_pwent = 1;
2494 }
2495 return _my_pwent;
2496}
2497
2498#undef setpwent
2499#undef getpwent
2500#undef endpwent
2501
2502void
2503my_setpwent(void)
2504{
2505 if (!use_my_pwent()) {
2506 setpwent(); /* Delegate to EMX. */
2507 return;
2508 }
2509 pwent_cnt = 0;
2510}
2511
2512void
2513my_endpwent(void)
2514{
2515 if (!use_my_pwent()) {
2516 endpwent(); /* Delegate to EMX. */
2517 return;
2518 }
2519}
2520
2521struct passwd *
2522my_getpwent (void)
2523{
2524 if (!use_my_pwent())
2525 return getpwent(); /* Delegate to EMX. */
2526 if (pwent_cnt++)
2527 return 0; // Return one entry only
2528 return getpwuid(0);
2529}
2530
2531static int grent_cnt;
2532
2533void
2534setgrent(void)
2535{
2536 grent_cnt = 0;
2537}
2538
2539void
2540endgrent(void)
2541{
2542}
2543
2544struct group *
2545getgrent (void)
2546{
2547 if (grent_cnt++)
2548 return 0; // Return one entry only
2549 return getgrgid(0);
2550}
2551
2552#undef getpwuid
2553#undef getpwnam
2554
2555/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2556static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2557
2558static struct passwd *
2559passw_wrap(struct passwd *p)
2560{
2561 static struct passwd pw;
2562 char *s;
2563
2564 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2565 return p;
2566 pw = *p;
2567 s = getenv("PW_PASSWD");
2568 if (!s)
2569 s = (char*)pw_p; /* Make match impossible */
2570
2571 pw.pw_passwd = s;
2572 return &pw;
2573}
2574
2575struct passwd *
2576my_getpwuid (uid_t id)
2577{
2578 return passw_wrap(getpwuid(id));
2579}
2580
2581struct passwd *
2582my_getpwnam (__const__ char *n)
2583{
2584 return passw_wrap(getpwnam(n));
2585}
Unnamed repository; edit this file to name it for gitweb.