projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Regen modlib and toc.
[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"
5c728af0 12#include <emx/syscalls.h>
4633a7c4 13
28743a51 14#include <sys/uflags.h>
15
4633a7c4 16/*
17 * Various Unix compatibility functions for OS/2
18 */
19
20#include <stdio.h>
21#include <errno.h>
22#include <limits.h>
23#include <process.h>
72ea3524 24#include <fcntl.h>
f72c975a 25#include <pwd.h>
26#include <grp.h>
4633a7c4 27
a03d92b2 28#define PERLIO_NOT_STDIO 0
8e4bc33b 29
4633a7c4 30#include "EXTERN.h"
31#include "perl.h"
32
5c728af0 33#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
34
35typedef void (*emx_startroutine)(void *);
36typedef void* (*pthreads_startroutine)(void *);
37
38enum pthreads_state {
39 pthreads_st_none = 0,
40 pthreads_st_run,
41 pthreads_st_exited,
42 pthreads_st_detached,
43 pthreads_st_waited,
44 pthreads_st_norun,
45 pthreads_st_exited_waited,
46};
47const char *pthreads_states[] = {
48 "uninit",
49 "running",
50 "exited",
51 "detached",
52 "waited for",
53 "could not start",
54 "exited, then waited on",
55};
56
57enum pthread_exists { pthread_not_existant = -0xff };
58
59static const char*
60pthreads_state_string(enum pthreads_state state)
61{
62 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
63 static char buf[80];
64
65 snprintf(buf, sizeof(buf), "unknown thread state %d", (int)state);
66 return buf;
67 }
68 return pthreads_states[state];
69}
70
71typedef struct {
72 void *status;
73 perl_cond cond;
74 enum pthreads_state state;
75} thread_join_t;
76
77thread_join_t *thread_join_data;
78int thread_join_count;
79perl_mutex start_thread_mutex;
80
81int
82pthread_join(perl_os_thread tid, void **status)
83{
84 MUTEX_LOCK(&start_thread_mutex);
85 if (tid < 1 || tid >= thread_join_count) {
86 MUTEX_UNLOCK(&start_thread_mutex);
87 if (tid != pthread_not_existant)
88 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
89 Perl_warn_nocontext("panic: join with a thread which could not start");
90 *status = 0;
91 return 0;
92 }
93 switch (thread_join_data[tid].state) {
94 case pthreads_st_exited:
95 thread_join_data[tid].state = pthreads_st_exited_waited;
96 *status = thread_join_data[tid].status;
97 MUTEX_UNLOCK(&start_thread_mutex);
98 COND_SIGNAL(&thread_join_data[tid].cond);
99 break;
100 case pthreads_st_waited:
101 MUTEX_UNLOCK(&start_thread_mutex);
102 Perl_croak_nocontext("join with a thread with a waiter");
103 break;
104 case pthreads_st_norun:
105 {
106 int state = (int)thread_join_data[tid].status;
107
108 thread_join_data[tid].state = pthreads_st_none;
109 MUTEX_UNLOCK(&start_thread_mutex);
110 Perl_croak_nocontext("panic: join with a thread which could not run"
111 " due to attempt of tid reuse (state='%s')",
112 pthreads_state_string(state));
113 break;
114 }
115 case pthreads_st_run:
116 {
117 perl_cond cond;
118
119 thread_join_data[tid].state = pthreads_st_waited;
120 thread_join_data[tid].status = (void *)status;
121 COND_INIT(&thread_join_data[tid].cond);
122 cond = thread_join_data[tid].cond;
123 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
124 COND_DESTROY(&cond);
125 MUTEX_UNLOCK(&start_thread_mutex);
126 break;
127 }
128 default:
129 MUTEX_UNLOCK(&start_thread_mutex);
130 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
131 pthreads_state_string(thread_join_data[tid].state));
132 break;
133 }
134 return 0;
135}
136
137typedef struct {
138 pthreads_startroutine sub;
139 void *arg;
140 void *ctx;
141} pthr_startit;
142
143/* The lock is used:
144 a) Since we temporarily usurp the caller interp, so malloc() may
145 use it to decide on debugging the call;
146 b) Since *args is on the caller's stack.
147 */
148void
149pthread_startit(void *arg1)
150{
151 /* Thread is already started, we need to transfer control only */
152 pthr_startit args = *(pthr_startit *)arg1;
153 int tid = pthread_self();
154 void *rc;
155 int state;
156
157 if (tid <= 1) {
158 /* Can't croak, the setjmp() is not in scope... */
159 char buf[80];
160
161 snprintf(buf, sizeof(buf),
162 "panic: thread with strange ordinal %d created\n\r", tid);
163 write(2,buf,strlen(buf));
164 MUTEX_UNLOCK(&start_thread_mutex);
165 return;
166 }
167 /* Until args.sub resets it, makes debugging Perl_malloc() work: */
168 PERL_SET_CONTEXT(0);
169 if (tid >= thread_join_count) {
170 int oc = thread_join_count;
171
172 thread_join_count = tid + 5 + tid/5;
173 if (thread_join_data) {
174 Renew(thread_join_data, thread_join_count, thread_join_t);
175 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
176 } else {
177 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
178 }
179 }
180 if (thread_join_data[tid].state != pthreads_st_none) {
181 /* Can't croak, the setjmp() is not in scope... */
182 char buf[80];
183
184 snprintf(buf, sizeof(buf),
185 "panic: attempt to reuse thread id %d (state='%s')\n\r",
186 tid, pthreads_state_string(thread_join_data[tid].state));
187 write(2,buf,strlen(buf));
188 thread_join_data[tid].status = (void*)thread_join_data[tid].state;
189 thread_join_data[tid].state = pthreads_st_norun;
190 MUTEX_UNLOCK(&start_thread_mutex);
191 return;
192 }
193 thread_join_data[tid].state = pthreads_st_run;
194 /* Now that we copied/updated the guys, we may release the caller... */
195 MUTEX_UNLOCK(&start_thread_mutex);
196 rc = (*args.sub)(args.arg);
197 MUTEX_LOCK(&start_thread_mutex);
198 switch (thread_join_data[tid].state) {
199 case pthreads_st_waited:
200 COND_SIGNAL(&thread_join_data[tid].cond);
201 thread_join_data[tid].state = pthreads_st_none;
202 *((void**)thread_join_data[tid].status) = rc;
203 break;
204 case pthreads_st_detached:
205 thread_join_data[tid].state = pthreads_st_none;
206 break;
207 case pthreads_st_run:
208 /* Somebody can wait on us; cannot exit, since OS can reuse the tid
209 and our waiter will get somebody else's status. */
210 thread_join_data[tid].state = pthreads_st_exited;
211 thread_join_data[tid].status = rc;
212 COND_INIT(&thread_join_data[tid].cond);
213 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
214 COND_DESTROY(&thread_join_data[tid].cond);
215 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
216 break;
217 default:
218 state = thread_join_data[tid].state;
219 MUTEX_UNLOCK(&start_thread_mutex);
220 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
221 pthreads_state_string(state));
222 }
223 MUTEX_UNLOCK(&start_thread_mutex);
224}
225
226int
227pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
228 void *(*start_routine)(void*), void *arg)
229{
230 dTHX;
231 pthr_startit args;
232
233 args.sub = (void*)start_routine;
234 args.arg = arg;
235 args.ctx = PERL_GET_CONTEXT;
236
237 MUTEX_LOCK(&start_thread_mutex);
238 /* Test suite creates 31 extra threads;
239 on machine without shared-memory-hogs this stack sizeis OK with 31: */
240 *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
241 /*stacksize*/ 4*1024*1024, (void*)&args);
242 if (*tidp == -1) {
243 *tidp = pthread_not_existant;
244 MUTEX_UNLOCK(&start_thread_mutex);
245 return EINVAL;
246 }
247 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
248 MUTEX_UNLOCK(&start_thread_mutex);
249 return 0;
250}
251
252int
253pthread_detach(perl_os_thread tid)
254{
255 MUTEX_LOCK(&start_thread_mutex);
256 if (tid < 1 || tid >= thread_join_count) {
257 MUTEX_UNLOCK(&start_thread_mutex);
258 if (tid != pthread_not_existant)
259 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
260 Perl_warn_nocontext("detach of a thread which could not start");
261 return 0;
262 }
263 switch (thread_join_data[tid].state) {
264 case pthreads_st_waited:
265 MUTEX_UNLOCK(&start_thread_mutex);
266 Perl_croak_nocontext("detach on a thread with a waiter");
267 break;
268 case pthreads_st_run:
269 thread_join_data[tid].state = pthreads_st_detached;
270 MUTEX_UNLOCK(&start_thread_mutex);
271 break;
272 case pthreads_st_exited:
273 MUTEX_UNLOCK(&start_thread_mutex);
274 COND_SIGNAL(&thread_join_data[tid].cond);
275 break;
276 case pthreads_st_detached:
277 MUTEX_UNLOCK(&start_thread_mutex);
278 Perl_warn_nocontext("detach on an already detached thread");
279 break;
280 case pthreads_st_norun:
281 {
282 int state = (int)thread_join_data[tid].status;
283
284 thread_join_data[tid].state = pthreads_st_none;
285 MUTEX_UNLOCK(&start_thread_mutex);
286 Perl_croak_nocontext("panic: detaching thread which could not run"
287 " due to attempt of tid reuse (state='%s')",
288 pthreads_state_string(state));
289 break;
290 }
291 default:
292 MUTEX_UNLOCK(&start_thread_mutex);
293 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
294 pthreads_state_string(thread_join_data[tid].state));
295 break;
296 }
297 return 0;
298}
299
300/* This is a very bastardized version; may be OK due to edge trigger of Wait */
301int
302os2_cond_wait(perl_cond *c, perl_mutex *m)
303{
304 int rc;
305 STRLEN n_a;
306 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
307 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
308 if (m) MUTEX_UNLOCK(m);
309 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
310 && (rc != ERROR_INTERRUPT))
311 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
312 if (rc == ERROR_INTERRUPT)
313 errno = EINTR;
314 if (m) MUTEX_LOCK(m);
315 return 0;
316}
317#endif
318
764df951 319static int exe_is_aout(void);
320
4633a7c4 321/*****************************************************************************/
72ea3524 322/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
35bc1fdc 323#define C_ARR_LEN(sym) (sizeof(sym)/sizeof(*sym))
324
325struct dll_handle {
326 const char *modname;
327 HMODULE handle;
328};
329static struct dll_handle doscalls_handle = {"doscalls", 0};
330static struct dll_handle tcp_handle = {"tcp32dll", 0};
331static struct dll_handle pmwin_handle = {"pmwin", 0};
332static struct dll_handle rexx_handle = {"rexx", 0};
333static struct dll_handle rexxapi_handle = {"rexxapi", 0};
334static struct dll_handle sesmgr_handle = {"sesmgr", 0};
335static struct dll_handle pmshapi_handle = {"pmshapi", 0};
336
337/* This should match enum entries_ordinals defined in os2ish.h. */
338static const struct {
339 struct dll_handle *dll;
340 const char *entryname;
341 int entrypoint;
342} loadOrdinals[ORD_NENTRIES] = {
343 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
344 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
345 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
346 {&tcp_handle, "SETHOSTENT", 0},
347 {&tcp_handle, "SETNETENT" , 0},
348 {&tcp_handle, "SETPROTOENT", 0},
349 {&tcp_handle, "SETSERVENT", 0},
350 {&tcp_handle, "GETHOSTENT", 0},
351 {&tcp_handle, "GETNETENT" , 0},
352 {&tcp_handle, "GETPROTOENT", 0},
353 {&tcp_handle, "GETSERVENT", 0},
354 {&tcp_handle, "ENDHOSTENT", 0},
355 {&tcp_handle, "ENDNETENT", 0},
356 {&tcp_handle, "ENDPROTOENT", 0},
357 {&tcp_handle, "ENDSERVENT", 0},
358 {&pmwin_handle, NULL, 763}, /* WinInitialize */
359 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
360 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
361 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
362 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
363 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
364 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
365 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
366 /* These are needed in extensions.
367 How to protect PMSHAPI: it comes through EMX functions? */
368 {&rexx_handle, "RexxStart", 0},
369 {&rexx_handle, "RexxVariablePool", 0},
370 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
371 {&rexxapi_handle, "RexxDeregisterFunction", 0},
372 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
373 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
374 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
375 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
376 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
377 {&pmshapi_handle, "PRF32RESET", 0},
378 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
379 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
380
381 /* At least some of these do not work by name, since they need
382 WIN32 instead of WIN... */
383#if 0
384 These were generated with
385 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
386 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
387 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
388#endif
389 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
390 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
391 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
392 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
393 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
394 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
395 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
396 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
397 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
398 {&pmwin_handle, NULL, 768}, /* WinIsChild */
399 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
400 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
401 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
402 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
403 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
404 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
405 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
406 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
407 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
408 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
409 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
410 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
30500b05 411 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
35bc1fdc 412 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
413 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
414 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
30500b05 415 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
416 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
417 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
418 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
419 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
420 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
421 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
422 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
423 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
424 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
425 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
426 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
427 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
428 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
429 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
35bc1fdc 430};
431
432static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
433const Perl_PFN * const pExtFCN = ExtFCN;
4bfbfac5 434struct PMWIN_entries_t PMWIN_entries;
72ea3524 435
5ba48348 436HMODULE
35bc1fdc 437loadModule(const char *modname, int fail)
5ba48348 438{
439 HMODULE h = (HMODULE)dlopen(modname, 0);
35bc1fdc 440
441 if (!h && fail)
5ba48348 442 Perl_croak_nocontext("Error loading module '%s': %s",
443 modname, dlerror());
444 return h;
445}
446
35bc1fdc 447PFN
448loadByOrdinal(enum entries_ordinals ord, int fail)
72ea3524 449{
450 if (ExtFCN[ord] == NULL) {
e71dd89f 451 PFN fcn = (PFN)-1;
72ea3524 452 APIRET rc;
453
35bc1fdc 454 if (!loadOrdinals[ord].dll->handle)
455 loadOrdinals[ord].dll->handle
456 = loadModule(loadOrdinals[ord].dll->modname, fail);
457 if (!loadOrdinals[ord].dll->handle)
458 return 0; /* Possible with FAIL==0 only */
459 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
460 loadOrdinals[ord].entrypoint,
461 loadOrdinals[ord].entryname,&fcn))) {
462 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
463
464 if (!fail)
465 return 0;
466 if (!s)
467 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
e71dd89f 468 Perl_croak_nocontext(
35bc1fdc 469 "This version of OS/2 does not support %s.%s",
470 loadOrdinals[ord].dll->modname, s);
471 }
72ea3524 472 ExtFCN[ord] = fcn;
473 }
35bc1fdc 474 if ((long)ExtFCN[ord] == -1)
23da6c43 475 Perl_croak_nocontext("panic queryaddr");
35bc1fdc 476 return ExtFCN[ord];
72ea3524 477}
478
4bfbfac5 479void
480init_PMWIN_entries(void)
481{
35bc1fdc 482 int i;
483
484 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
485 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
4bfbfac5 486}
487
35bc1fdc 488/*****************************************************/
489/* socket forwarders without linking with tcpip DLLs */
490
491DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
492DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
493DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
494DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
495
496DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
497DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
498DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
499DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
500
501DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
502DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
503DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
504DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
4bfbfac5 505
4633a7c4 506/* priorities */
6f064249 507static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
508 self inverse. */
509#define QSS_INI_BUFFER 1024
4633a7c4 510
35bc1fdc 511ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
512static int pidtid_lookup;
513
6f064249 514PQTOPLEVEL
515get_sysinfo(ULONG pid, ULONG flags)
4633a7c4 516{
6f064249 517 char *pbuffer;
518 ULONG rc, buf_len = QSS_INI_BUFFER;
35bc1fdc 519 PQTOPLEVEL psi;
6f064249 520
35bc1fdc 521 if (!pidtid_lookup) {
522 pidtid_lookup = 1;
523 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
524 }
525 if (pDosVerifyPidTid) { /* Warp3 or later */
526 /* Up to some fixpak QuerySysState() kills the system if a non-existent
527 pid is used. */
30500b05 528 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
35bc1fdc 529 return 0;
530 }
fc36a67e 531 New(1322, pbuffer, buf_len, char);
6f064249 532 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
533 rc = QuerySysState(flags, pid, pbuffer, buf_len);
534 while (rc == ERROR_BUFFER_OVERFLOW) {
535 Renew(pbuffer, buf_len *= 2, char);
df3ef7a9 536 rc = QuerySysState(flags, pid, pbuffer, buf_len);
6f064249 537 }
538 if (rc) {
539 FillOSError(rc);
540 Safefree(pbuffer);
541 return 0;
542 }
35bc1fdc 543 psi = (PQTOPLEVEL)pbuffer;
544 if (psi && pid && pid != psi->procdata->pid) {
545 Safefree(psi);
546 Perl_croak_nocontext("panic: wrong pid in sysinfo");
547 }
548 return psi;
6f064249 549}
550
551#define PRIO_ERR 0x1111
552
553static ULONG
554sys_prio(pid)
555{
556 ULONG prio;
557 PQTOPLEVEL psi;
558
35bc1fdc 559 if (!pid)
560 return PRIO_ERR;
6f064249 561 psi = get_sysinfo(pid, QSS_PROCESS);
35bc1fdc 562 if (!psi)
6f064249 563 return PRIO_ERR;
6f064249 564 prio = psi->procdata->threads->priority;
565 Safefree(psi);
566 return prio;
567}
568
569int
570setpriority(int which, int pid, int val)
571{
2d766320 572 ULONG rc, prio = sys_prio(pid);
6f064249 573
55497cff 574 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 575 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
576 /* Do not change class. */
577 return CheckOSError(DosSetPriority((pid < 0)
578 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
579 0,
580 (32 - val) % 32 - (prio & 0xFF),
581 abs(pid)))
582 ? -1 : 0;
583 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
584 /* Documentation claims one can change both class and basevalue,
585 * but I find it wrong. */
586 /* Change class, but since delta == 0 denotes absolute 0, correct. */
587 if (CheckOSError(DosSetPriority((pid < 0)
588 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
589 priors[(32 - val) >> 5] + 1,
590 0,
591 abs(pid))))
592 return -1;
593 if ( ((32 - val) % 32) == 0 ) return 0;
594 return CheckOSError(DosSetPriority((pid < 0)
595 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
596 0,
597 (32 - val) % 32,
598 abs(pid)))
599 ? -1 : 0;
600 }
4633a7c4 601}
602
6f064249 603int
604getpriority(int which /* ignored */, int pid)
4633a7c4 605{
2d766320 606 ULONG ret;
6f064249 607
55497cff 608 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 609 ret = sys_prio(pid);
610 if (ret == PRIO_ERR) {
611 return -1;
612 }
6f064249 613 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
4633a7c4 614}
615
616/*****************************************************************************/
617/* spawn */
2c2e0e8c 618
764df951 619int emx_runtime_init; /* If 1, we need to manually init it */
620int emx_exception_init; /* If 1, we need to manually set it */
621
2c2e0e8c 622/* There is no big sense to make it thread-specific, since signals
623 are delivered to thread 1 only. XXXX Maybe make it into an array? */
624static int spawn_pid;
625static int spawn_killed;
626
627static Signal_t
628spawn_sighandler(int sig)
629{
630 /* Some programs do not arrange for the keyboard signals to be
631 delivered to them. We need to deliver the signal manually. */
632 /* We may get a signal only if
633 a) kid does not receive keyboard signal: deliver it;
634 b) kid already died, and we get a signal. We may only hope
635 that the pid number was not reused.
636 */
637
638 if (spawn_killed)
639 sig = SIGKILL; /* Try harder. */
640 kill(spawn_pid, sig);
641 spawn_killed = 1;
642}
72ea3524 643
4633a7c4 644static int
23da6c43 645result(pTHX_ int flag, int pid)
4633a7c4 646{
647 int r, status;
648 Signal_t (*ihand)(); /* place to save signal during system() */
649 Signal_t (*qhand)(); /* place to save signal during system() */
760ac839 650#ifndef __EMX__
651 RESULTCODES res;
652 int rpid;
653#endif
4633a7c4 654
760ac839 655 if (pid < 0 || flag != 0)
4633a7c4 656 return pid;
657
760ac839 658#ifdef __EMX__
2c2e0e8c 659 spawn_pid = pid;
660 spawn_killed = 0;
661 ihand = rsignal(SIGINT, &spawn_sighandler);
662 qhand = rsignal(SIGQUIT, &spawn_sighandler);
c0c09dfd 663 do {
664 r = wait4pid(pid, &status, 0);
665 } while (r == -1 && errno == EINTR);
72ea3524 666 rsignal(SIGINT, ihand);
667 rsignal(SIGQUIT, qhand);
4633a7c4 668
6b88bc9c 669 PL_statusvalue = (U16)status;
4633a7c4 670 if (r < 0)
671 return -1;
672 return status & 0xFFFF;
760ac839 673#else
72ea3524 674 ihand = rsignal(SIGINT, SIG_IGN);
760ac839 675 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
72ea3524 676 rsignal(SIGINT, ihand);
6b88bc9c 677 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
760ac839 678 if (r)
679 return -1;
6b88bc9c 680 return PL_statusvalue;
760ac839 681#endif
4633a7c4 682}
683
764df951 684enum execf_t {
685 EXECF_SPAWN,
686 EXECF_EXEC,
687 EXECF_TRUEEXEC,
688 EXECF_SPAWN_NOWAIT,
689 EXECF_SPAWN_BYFLAG,
690 EXECF_SYNC
691};
491527d0 692
017f25f1 693/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
694
695static int
696my_type()
697{
698 int rc;
699 TIB *tib;
700 PIB *pib;
701
702 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
703 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
704 return -1;
705
706 return (pib->pib_ultype);
707}
708
709static ULONG
710file_type(char *path)
711{
712 int rc;
713 ULONG apptype;
714
715 if (!(_emx_env & 0x200))
23da6c43 716 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
017f25f1 717 if (CheckOSError(DosQueryAppType(path, &apptype))) {
718 switch (rc) {
719 case ERROR_FILE_NOT_FOUND:
720 case ERROR_PATH_NOT_FOUND:
721 return -1;
722 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
723 return -3;
724 default: /* Found, but not an
725 executable, or some other
726 read error. */
727 return -2;
728 }
729 }
730 return apptype;
731}
732
733static ULONG os2_mytype;
734
491527d0 735/* Spawn/exec a program, revert to shell if needed. */
6b88bc9c 736/* global PL_Argv[] contains arguments. */
491527d0 737
764df951 738extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
739 EXCEPTIONREGISTRATIONRECORD *,
740 CONTEXTRECORD *,
741 void *);
742
4633a7c4 743int
23da6c43 744do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
4633a7c4 745{
491527d0 746 int trueflag = flag;
a97be121 747 int rc, pass = 1;
491527d0 748 char *tmps;
491527d0 749 char *args[4];
750 static char * fargs[4]
751 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
752 char **argsp = fargs;
2d766320 753 int nargs = 4;
017f25f1 754 int force_shell;
65850d11 755 int new_stderr = -1, nostderr = 0;
2d766320 756 int fl_stderr = 0;
2d8e6c8d 757 STRLEN n_a;
1c46958a 758 char *buf;
759 PerlIO *file;
491527d0 760
4633a7c4 761 if (flag == P_WAIT)
762 flag = P_NOWAIT;
763
491527d0 764 retry:
6b88bc9c 765 if (strEQ(PL_Argv[0],"/bin/sh"))
766 PL_Argv[0] = PL_sh_path;
3bbf9c2b 767
760ac839 768 /* We should check PERL_SH* and PERLLIB_* as well? */
2d8e6c8d 769 if (!really || !*(tmps = SvPV(really, n_a)))
6b88bc9c 770 tmps = PL_Argv[0];
dfcfdb64 771 if (tmps[0] != '/' && tmps[0] != '\\'
772 && !(tmps[0] && tmps[1] == ':'
773 && (tmps[2] == '/' || tmps[2] != '\\'))
774 ) /* will spawnvp use PATH? */
775 TAINT_ENV(); /* testing IFS here is overkill, probably */
017f25f1 776
777 reread:
778 force_shell = 0;
779 if (_emx_env & 0x200) { /* OS/2. */
780 int type = file_type(tmps);
781 type_again:
782 if (type == -1) { /* Not found */
783 errno = ENOENT;
784 rc = -1;
785 goto do_script;
786 }
787 else if (type == -2) { /* Not an EXE */
788 errno = ENOEXEC;
789 rc = -1;
790 goto do_script;
791 }
792 else if (type == -3) { /* Is a directory? */
793 /* Special-case this */
794 char tbuf[512];
795 int l = strlen(tmps);
796
797 if (l + 5 <= sizeof tbuf) {
798 strcpy(tbuf, tmps);
799 strcpy(tbuf + l, ".exe");
800 type = file_type(tbuf);
801 if (type >= -3)
802 goto type_again;
803 }
804
805 errno = ENOEXEC;
806 rc = -1;
807 goto do_script;
808 }
809 switch (type & 7) {
810 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
811 case FAPPTYP_WINDOWAPI:
812 {
813 if (os2_mytype != 3) { /* not PM */
814 if (flag == P_NOWAIT)
815 flag = P_PM;
816 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
f98bc0c6 817 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
017f25f1 818 flag, os2_mytype);
819 }
820 }
821 break;
822 case FAPPTYP_NOTWINDOWCOMPAT:
823 {
824 if (os2_mytype != 0) { /* not full screen */
825 if (flag == P_NOWAIT)
826 flag = P_SESSION;
827 else if ((flag & 7) != P_SESSION)
f98bc0c6 828 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
017f25f1 829 flag, os2_mytype);
830 }
831 }
832 break;
833 case FAPPTYP_NOTSPEC:
834 /* Let the shell handle this... */
835 force_shell = 1;
1c46958a 836 buf = ""; /* Pacify a warning */
837 file = 0; /* Pacify a warning */
017f25f1 838 goto doshell_args;
839 break;
840 }
841 }
842
5838269b 843 if (addflag) {
844 addflag = 0;
845 new_stderr = dup(2); /* Preserve stderr */
846 if (new_stderr == -1) {
847 if (errno == EBADF)
848 nostderr = 1;
849 else {
850 rc = -1;
851 goto finish;
852 }
853 } else
854 fl_stderr = fcntl(2, F_GETFD);
855 rc = dup2(1,2);
856 if (rc == -1)
857 goto finish;
858 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
859 }
860
491527d0 861#if 0
23da6c43 862 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
491527d0 863#else
864 if (execf == EXECF_TRUEEXEC)
6b88bc9c 865 rc = execvp(tmps,PL_Argv);
491527d0 866 else if (execf == EXECF_EXEC)
6b88bc9c 867 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
491527d0 868 else if (execf == EXECF_SPAWN_NOWAIT)
017f25f1 869 rc = spawnvp(flag,tmps,PL_Argv);
764df951 870 else if (execf == EXECF_SYNC)
871 rc = spawnvp(trueflag,tmps,PL_Argv);
4435c477 872 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
23da6c43 873 rc = result(aTHX_ trueflag,
017f25f1 874 spawnvp(flag,tmps,PL_Argv));
491527d0 875#endif
2c2e0e8c 876 if (rc < 0 && pass == 1
6b88bc9c 877 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
017f25f1 878 do_script:
879 {
a97be121 880 int err = errno;
881
2c2e0e8c 882 if (err == ENOENT || err == ENOEXEC) {
883 /* No such file, or is a script. */
884 /* Try adding script extensions to the file name, and
885 search on PATH. */
6b88bc9c 886 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
2c2e0e8c 887
888 if (scr) {
1c46958a 889 char *s = 0, *s1;
890 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
891 SV *bufsv = sv_newmortal();
2c2e0e8c 892
e96326af 893 Safefree(scr);
1c46958a 894 scr = SvPV(scrsv, n_a); /* free()ed later */
e96326af 895
a03d92b2 896 file = PerlIO_open(scr, "r");
6b88bc9c 897 PL_Argv[0] = scr;
2c2e0e8c 898 if (!file)
899 goto panic_file;
017f25f1 900
1c46958a 901 buf = sv_gets(bufsv, file, 0 /* No append */);
902 if (!buf)
903 buf = ""; /* XXX Needed? */
904 if (!buf[0]) { /* Empty... */
a03d92b2 905 PerlIO_close(file);
017f25f1 906 /* Special case: maybe from -Zexe build, so
907 there is an executable around (contrary to
908 documentation, DosQueryAppType sometimes (?)
909 does not append ".exe", so we could have
910 reached this place). */
1c46958a 911 sv_catpv(scrsv, ".exe");
912 scr = SvPV(scrsv, n_a); /* Reload */
913 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
914 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
017f25f1 915 tmps = scr;
916 pass++;
917 goto reread;
1c46958a 918 } else { /* Restore */
919 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
920 *SvEND(scrsv) = 0;
921 }
2c2e0e8c 922 }
a03d92b2 923 if (PerlIO_close(file) != 0) { /* Failure */
2c2e0e8c 924 panic_file:
f98bc0c6 925 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
2c2e0e8c 926 scr, Strerror(errno));
1c46958a 927 buf = ""; /* Not #! */
2c2e0e8c 928 goto doshell_args;
929 }
930 if (buf[0] == '#') {
931 if (buf[1] == '!')
932 s = buf + 2;
933 } else if (buf[0] == 'e') {
934 if (strnEQ(buf, "extproc", 7)
935 && isSPACE(buf[7]))
936 s = buf + 8;
937 } else if (buf[0] == 'E') {
938 if (strnEQ(buf, "EXTPROC", 7)
939 && isSPACE(buf[7]))
940 s = buf + 8;
941 }
942 if (!s) {
1c46958a 943 buf = ""; /* Not #! */
2c2e0e8c 944 goto doshell_args;
945 }
946
947 s1 = s;
948 nargs = 0;
949 argsp = args;
950 while (1) {
951 /* Do better than pdksh: allow a few args,
952 strip trailing whitespace. */
953 while (isSPACE(*s))
954 s++;
955 if (*s == 0)
956 break;
957 if (nargs == 4) {
958 nargs = -1;
959 break;
960 }
961 args[nargs++] = s;
962 while (*s && !isSPACE(*s))
963 s++;
964 if (*s == 0)
965 break;
966 *s++ = 0;
967 }
968 if (nargs == -1) {
f98bc0c6 969 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
2c2e0e8c 970 s1 - buf, buf, scr);
971 nargs = 4;
972 argsp = fargs;
973 }
1c46958a 974 /* Can jump from far, buf/file invalid if force_shell: */
2c2e0e8c 975 doshell_args:
976 {
6b88bc9c 977 char **a = PL_Argv;
2c2e0e8c 978 char *exec_args[2];
979
017f25f1 980 if (force_shell
981 || (!buf[0] && file)) { /* File without magic */
2c2e0e8c 982 /* In fact we tried all what pdksh would
983 try. There is no point in calling
984 pdksh, we may just emulate its logic. */
985 char *shell = getenv("EXECSHELL");
986 char *shell_opt = NULL;
987
988 if (!shell) {
989 char *s;
990
991 shell_opt = "/c";
992 shell = getenv("OS2_SHELL");
993 if (inicmd) { /* No spaces at start! */
994 s = inicmd;
995 while (*s && !isSPACE(*s)) {
2d766320 996 if (*s++ == '/') {
2c2e0e8c 997 inicmd = NULL; /* Cannot use */
998 break;
999 }
1000 }
1001 }
1002 if (!inicmd) {
6b88bc9c 1003 s = PL_Argv[0];
2c2e0e8c 1004 while (*s) {
1005 /* Dosish shells will choke on slashes
1006 in paths, fortunately, this is
1007 important for zeroth arg only. */
1008 if (*s == '/')
1009 *s = '\\';
1010 s++;
1011 }
491527d0 1012 }
491527d0 1013 }
2c2e0e8c 1014 /* If EXECSHELL is set, we do not set */
1015
1016 if (!shell)
1017 shell = ((_emx_env & 0x200)
1018 ? "c:/os2/cmd.exe"
1019 : "c:/command.com");
1020 nargs = shell_opt ? 2 : 1; /* shell file args */
1021 exec_args[0] = shell;
1022 exec_args[1] = shell_opt;
1023 argsp = exec_args;
1024 if (nargs == 2 && inicmd) {
1025 /* Use the original cmd line */
1026 /* XXXX This is good only until we refuse
1027 quoted arguments... */
6b88bc9c 1028 PL_Argv[0] = inicmd;
1029 PL_Argv[1] = Nullch;
491527d0 1030 }
2c2e0e8c 1031 } else if (!buf[0] && inicmd) { /* No file */
1032 /* Start with the original cmdline. */
1033 /* XXXX This is good only until we refuse
1034 quoted arguments... */
1035
6b88bc9c 1036 PL_Argv[0] = inicmd;
1037 PL_Argv[1] = Nullch;
2c2e0e8c 1038 nargs = 2; /* shell -c */
1039 }
1040
1041 while (a[1]) /* Get to the end */
1042 a++;
1043 a++; /* Copy finil NULL too */
6b88bc9c 1044 while (a >= PL_Argv) {
1045 *(a + nargs) = *a; /* PL_Argv was preallocated to be
2c2e0e8c 1046 long enough. */
1047 a--;
491527d0 1048 }
d5d69632 1049 while (--nargs >= 0)
6b88bc9c 1050 PL_Argv[nargs] = argsp[nargs];
2c2e0e8c 1051 /* Enable pathless exec if #! (as pdksh). */
1052 pass = (buf[0] == '#' ? 2 : 3);
1053 goto retry;
e29f6e02 1054 }
1055 }
2c2e0e8c 1056 /* Not found: restore errno */
491527d0 1057 errno = err;
2c2e0e8c 1058 }
017f25f1 1059 }
a97be121 1060 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
6b88bc9c 1061 char *no_dir = strrchr(PL_Argv[0], '/');
2c2e0e8c 1062
1063 /* Do as pdksh port does: if not found with /, try without
1064 path. */
1065 if (no_dir) {
6b88bc9c 1066 PL_Argv[0] = no_dir + 1;
2c2e0e8c 1067 pass++;
e29f6e02 1068 goto retry;
1069 }
1070 }
0453d815 1071 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1072 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
491527d0 1073 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1074 ? "spawn" : "exec"),
a97be121 1075 PL_Argv[0], Strerror(errno));
491527d0 1076 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1077 && ((trueflag & 0xFF) == P_WAIT))
ed344e4f 1078 rc = -1;
491527d0 1079
5838269b 1080 finish:
1081 if (new_stderr != -1) { /* How can we use error codes? */
1082 dup2(new_stderr, 2);
1083 close(new_stderr);
1084 fcntl(2, F_SETFD, fl_stderr);
1085 } else if (nostderr)
1086 close(2);
491527d0 1087 return rc;
1088}
1089
491527d0 1090/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
4633a7c4 1091int
23da6c43 1092do_spawn3(pTHX_ char *cmd, int execf, int flag)
4633a7c4 1093{
1094 register char **a;
1095 register char *s;
3bbf9c2b 1096 char *shell, *copt, *news = NULL;
2d766320 1097 int rc, seenspace = 0, mergestderr = 0;
4633a7c4 1098
c0c09dfd 1099#ifdef TRYSHELL
1100 if ((shell = getenv("EMXSHELL")) != NULL)
1101 copt = "-c";
1102 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4 1103 copt = "-c";
1104 else if ((shell = getenv("COMSPEC")) != NULL)
1105 copt = "/C";
1106 else
1107 shell = "cmd.exe";
c0c09dfd 1108#else
1109 /* Consensus on perl5-porters is that it is _very_ important to
1110 have a shell which will not change between computers with the
1111 same architecture, to avoid "action on a distance".
1112 And to have simple build, this shell should be sh. */
6b88bc9c 1113 shell = PL_sh_path;
c0c09dfd 1114 copt = "-c";
1115#endif
1116
1117 while (*cmd && isSPACE(*cmd))
1118 cmd++;
4633a7c4 1119
3bbf9c2b 1120 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
6b88bc9c 1121 STRLEN l = strlen(PL_sh_path);
3bbf9c2b 1122
2cc2f81f 1123 New(1302, news, strlen(cmd) - 7 + l + 1, char);
6b88bc9c 1124 strcpy(news, PL_sh_path);
3bbf9c2b 1125 strcpy(news + l, cmd + 7);
1126 cmd = news;
1127 }
1128
4633a7c4 1129 /* save an extra exec if possible */
1130 /* see if there are shell metacharacters in it */
1131
c0c09dfd 1132 if (*cmd == '.' && isSPACE(cmd[1]))
1133 goto doshell;
1134
1135 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1136 goto doshell;
1137
1138 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1139 if (*s == '=')
1140 goto doshell;
1141
4633a7c4 1142 for (s = cmd; *s; s++) {
c0c09dfd 1143 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 1144 if (*s == '\n' && s[1] == '\0') {
4633a7c4 1145 *s = '\0';
1146 break;
a0914d8e 1147 } else if (*s == '\\' && !seenspace) {
1148 continue; /* Allow backslashes in names */
5838269b 1149 } else if (*s == '>' && s >= cmd + 3
1150 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1151 && isSPACE(s[-2]) ) {
1152 char *t = s + 3;
1153
1154 while (*t && isSPACE(*t))
1155 t++;
1156 if (!*t) {
1157 s[-2] = '\0';
1158 mergestderr = 1;
1159 break; /* Allow 2>&1 as the last thing */
1160 }
4633a7c4 1161 }
491527d0 1162 /* We do not convert this to do_spawn_ve since shell
1163 should be smart enough to start itself gloriously. */
c0c09dfd 1164 doshell:
760ac839 1165 if (execf == EXECF_TRUEEXEC)
764df951 1166 rc = execl(shell,shell,copt,cmd,(char*)0);
760ac839 1167 else if (execf == EXECF_EXEC)
2c2e0e8c 1168 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 1169 else if (execf == EXECF_SPAWN_NOWAIT)
2c2e0e8c 1170 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
4435c477 1171 else if (execf == EXECF_SPAWN_BYFLAG)
1172 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
2c2e0e8c 1173 else {
1174 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
764df951 1175 if (execf == EXECF_SYNC)
1176 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1177 else
1178 rc = result(aTHX_ P_WAIT,
1179 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
0453d815 1180 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1181 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
2c2e0e8c 1182 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1183 shell, Strerror(errno));
ed344e4f 1184 if (rc < 0)
1185 rc = -1;
2c2e0e8c 1186 }
1187 if (news)
1188 Safefree(news);
c0c09dfd 1189 return rc;
a0914d8e 1190 } else if (*s == ' ' || *s == '\t') {
1191 seenspace = 1;
4633a7c4 1192 }
1193 }
c0c09dfd 1194
491527d0 1195 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
6b88bc9c 1196 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1197 PL_Cmd = savepvn(cmd, s-cmd);
1198 a = PL_Argv;
1199 for (s = PL_Cmd; *s;) {
4633a7c4 1200 while (*s && isSPACE(*s)) s++;
1201 if (*s)
1202 *(a++) = s;
1203 while (*s && !isSPACE(*s)) s++;
1204 if (*s)
1205 *s++ = '\0';
1206 }
1207 *a = Nullch;
6b88bc9c 1208 if (PL_Argv[0])
23da6c43 1209 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
491527d0 1210 else
4633a7c4 1211 rc = -1;
2c2e0e8c 1212 if (news)
1213 Safefree(news);
4633a7c4 1214 do_execfree();
1215 return rc;
1216}
1217
4435c477 1218/* Array spawn. */
1219int
2d766320 1220os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
4435c477 1221{
2d766320 1222 register SV **mark = (SV **)vmark;
1223 register SV **sp = (SV **)vsp;
4435c477 1224 register char **a;
1225 int rc;
1226 int flag = P_WAIT, flag_set = 0;
1227 STRLEN n_a;
1228
1229 if (sp > mark) {
1230 New(1301,PL_Argv, sp - mark + 3, char*);
1231 a = PL_Argv;
1232
1233 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1234 ++mark;
1235 flag = SvIVx(*mark);
1236 flag_set = 1;
1237
1238 }
1239
1240 while (++mark <= sp) {
1241 if (*mark)
1242 *a++ = SvPVx(*mark, n_a);
1243 else
1244 *a++ = "";
1245 }
1246 *a = Nullch;
1247
1248 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
23da6c43 1249 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
4435c477 1250 } else
23da6c43 1251 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
4435c477 1252 } else
1253 rc = -1;
1254 do_execfree();
1255 return rc;
1256}
1257
760ac839 1258int
23da6c43 1259os2_do_spawn(pTHX_ char *cmd)
760ac839 1260{
23da6c43 1261 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
760ac839 1262}
1263
72ea3524 1264int
23da6c43 1265do_spawn_nowait(pTHX_ char *cmd)
72ea3524 1266{
23da6c43 1267 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524 1268}
1269
760ac839 1270bool
23da6c43 1271Perl_do_exec(pTHX_ char *cmd)
760ac839 1272{
23da6c43 1273 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
017f25f1 1274 return FALSE;
760ac839 1275}
1276
1277bool
23da6c43 1278os2exec(pTHX_ char *cmd)
760ac839 1279{
23da6c43 1280 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
760ac839 1281}
1282
3bbf9c2b 1283PerlIO *
23da6c43 1284my_syspopen(pTHX_ char *cmd, char *mode)
c0c09dfd 1285{
72ea3524 1286#ifndef USE_POPEN
72ea3524 1287 int p[2];
1288 register I32 this, that, newfd;
2d766320 1289 register I32 pid;
3bbf9c2b 1290 SV *sv;
2d766320 1291 int fh_fl = 0; /* Pacify the warning */
72ea3524 1292
72ea3524 1293 /* `this' is what we use in the parent, `that' in the child. */
1294 this = (*mode == 'w');
1295 that = !this;
6b88bc9c 1296 if (PL_tainting) {
72ea3524 1297 taint_env();
1298 taint_proper("Insecure %s%s", "EXEC");
1299 }
c2267164 1300 if (pipe(p) < 0)
1301 return Nullfp;
72ea3524 1302 /* Now we need to spawn the child. */
5838269b 1303 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1304 int new = dup(p[this]);
1305
1306 if (new == -1)
1307 goto closepipes;
1308 close(p[this]);
1309 p[this] = new;
1310 }
72ea3524 1311 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b 1312 if (newfd == -1) {
1313 /* This cannot happen due to fh being bad after pipe(), since
1314 pipe() should have created fh 0 and 1 even if they were
1315 initially closed. But we closed p[this] before. */
1316 if (errno != EBADF) {
1317 closepipes:
1318 close(p[0]);
1319 close(p[1]);
1320 return Nullfp;
1321 }
1322 } else
1323 fh_fl = fcntl(*mode == 'r', F_GETFD);
1324 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
72ea3524 1325 dup2(p[that], *mode == 'r');
1326 close(p[that]);
1327 }
1328 /* Where is `this' and newfd now? */
1329 fcntl(p[this], F_SETFD, FD_CLOEXEC);
5838269b 1330 if (newfd != -1)
1331 fcntl(newfd, F_SETFD, FD_CLOEXEC);
23da6c43 1332 pid = do_spawn_nowait(aTHX_ cmd);
5838269b 1333 if (newfd == -1)
1334 close(*mode == 'r'); /* It was closed initially */
1335 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524 1336 dup2(newfd, *mode == 'r'); /* Return std* back. */
1337 close(newfd);
5838269b 1338 fcntl(*mode == 'r', F_SETFD, fh_fl);
1339 } else
1340 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0 1341 if (p[that] == (*mode == 'r'))
1342 close(p[that]);
72ea3524 1343 if (pid == -1) {
1344 close(p[this]);
5838269b 1345 return Nullfp;
72ea3524 1346 }
5838269b 1347 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524 1348 dup2(p[this], p[that]);
1349 close(p[this]);
1350 p[this] = p[that];
1351 }
6b88bc9c 1352 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524 1353 (void)SvUPGRADE(sv,SVt_IV);
1354 SvIVX(sv) = pid;
6b88bc9c 1355 PL_forkprocess = pid;
72ea3524 1356 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1357
72ea3524 1358#else /* USE_POPEN */
1359
1360 PerlIO *res;
1361 SV *sv;
1362
1363# ifdef TRYSHELL
3bbf9c2b 1364 res = popen(cmd, mode);
72ea3524 1365# else
c0c09dfd 1366 char *shell = getenv("EMXSHELL");
3bbf9c2b 1367
6b88bc9c 1368 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 1369 res = popen(cmd, mode);
1370 my_setenv("EMXSHELL", shell);
72ea3524 1371# endif
6b88bc9c 1372 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
3bbf9c2b 1373 (void)SvUPGRADE(sv,SVt_IV);
1374 SvIVX(sv) = -1; /* A cooky. */
1375 return res;
72ea3524 1376
1377#endif /* USE_POPEN */
1378
c0c09dfd 1379}
1380
3bbf9c2b 1381/******************************************************************/
4633a7c4 1382
1383#ifndef HAS_FORK
1384int
1385fork(void)
1386{
23da6c43 1387 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
4633a7c4 1388 errno = EINVAL;
1389 return -1;
1390}
1391#endif
1392
3bbf9c2b 1393/*******************************************************************/
46e87256 1394/* not implemented in EMX 0.9d */
4633a7c4 1395
46e87256 1396char * ctermid(char *s) { return 0; }
eacfb5f1 1397
1398#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 1399void * ttyname(x) { return 0; }
eacfb5f1 1400#endif
4633a7c4 1401
760ac839 1402/*****************************************************************************/
1403/* not implemented in C Set++ */
1404
1405#ifndef __EMX__
1406int setuid(x) { errno = EINVAL; return -1; }
1407int setgid(x) { errno = EINVAL; return -1; }
1408#endif
4633a7c4 1409
1410/*****************************************************************************/
1411/* stat() hack for char/block device */
1412
1413#if OS2_STAT_HACK
1414
5c728af0 1415enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1416 os2_stat_archived = 0x1000000, /* 0100000000 */
1417 os2_stat_hidden = 0x2000000, /* 0200000000 */
1418 os2_stat_system = 0x4000000, /* 0400000000 */
1419 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1420};
1421
1422#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1423
1424static void
1425massage_os2_attr(struct stat *st)
1426{
1427 if ( ((st->st_mode & S_IFMT) != S_IFREG
1428 && (st->st_mode & S_IFMT) != S_IFDIR)
1429 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1430 return;
1431
1432 if ( st->st_attr & FILE_ARCHIVED )
1433 st->st_mode |= (os2_stat_archived | os2_stat_force);
1434 if ( st->st_attr & FILE_HIDDEN )
1435 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1436 if ( st->st_attr & FILE_SYSTEM )
1437 st->st_mode |= (os2_stat_system | os2_stat_force);
1438}
1439
4633a7c4 1440 /* First attempt used DosQueryFSAttach which crashed the system when
1441 used with 5.001. Now just look for /dev/. */
4633a7c4 1442int
2d766320 1443os2_stat(const char *name, struct stat *st)
4633a7c4 1444{
1445 static int ino = SHRT_MAX;
5c728af0 1446 STRLEN l = strlen(name);
1447
1448 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1449 || ( stricmp(name + 5, "con") != 0
1450 && stricmp(name + 5, "tty") != 0
1451 && stricmp(name + 5, "nul") != 0
1452 && stricmp(name + 5, "null") != 0) ) {
1453 int s = stat(name, st);
1454
1455 if (s)
1456 return s;
1457 massage_os2_attr(st);
1458 return 0;
1459 }
4633a7c4 1460
1461 memset(st, 0, sizeof *st);
1462 st->st_mode = S_IFCHR|0666;
1463 st->st_ino = (ino-- & 0x7FFF);
1464 st->st_nlink = 1;
1465 return 0;
1466}
1467
5c728af0 1468int
1469os2_fstat(int handle, struct stat *st)
1470{
1471 int s = fstat(handle, st);
1472
1473 if (s)
1474 return s;
1475 massage_os2_attr(st);
1476 return 0;
1477}
1478
1479#undef chmod
1480int
1481os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1482{
1483 int attr, rc;
1484
1485 if (!(pmode & os2_stat_force))
1486 return chmod(name, pmode);
1487
1488 attr = __chmod (name, 0, 0); /* Get attributes */
1489 if (attr < 0)
1490 return -1;
1491 if (pmode & S_IWRITE)
1492 attr &= ~FILE_READONLY;
1493 else
1494 attr |= FILE_READONLY;
1495 /* New logic */
1496 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1497
1498 if ( pmode & os2_stat_archived )
1499 attr |= FILE_ARCHIVED;
1500 if ( pmode & os2_stat_hidden )
1501 attr |= FILE_HIDDEN;
1502 if ( pmode & os2_stat_system )
1503 attr |= FILE_SYSTEM;
1504
1505 rc = __chmod (name, 1, attr);
1506 if (rc >= 0) rc = 0;
1507 return rc;
1508}
1509
4633a7c4 1510#endif
c0c09dfd 1511
760ac839 1512#ifdef USE_PERL_SBRK
c0c09dfd 1513
760ac839 1514/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1515
1516void *
760ac839 1517sys_alloc(int size) {
1518 void *got;
1519 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1520
c0c09dfd 1521 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1522 return (void *) -1;
4bfbfac5 1523 } else if ( rc )
23da6c43 1524 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1525 return got;
c0c09dfd 1526}
760ac839 1527
1528#endif /* USE_PERL_SBRK */
c0c09dfd 1529
1530/* tmp path */
1531
1532char *tmppath = TMPPATH1;
1533
1534void
1535settmppath()
1536{
1537 char *p = getenv("TMP"), *tpath;
1538 int len;
1539
1540 if (!p) p = getenv("TEMP");
1541 if (!p) return;
1542 len = strlen(p);
1543 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
db7c17d7 1544 if (tpath) {
1545 strcpy(tpath, p);
1546 tpath[len] = '/';
1547 strcpy(tpath + len + 1, TMPPATH1);
1548 tmppath = tpath;
1549 }
c0c09dfd 1550}
7a2f0d5b 1551
1552#include "XSUB.h"
1553
1554XS(XS_File__Copy_syscopy)
1555{
1556 dXSARGS;
1557 if (items < 2 || items > 3)
23da6c43 1558 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
7a2f0d5b 1559 {
2d8e6c8d 1560 STRLEN n_a;
1561 char * src = (char *)SvPV(ST(0),n_a);
1562 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 1563 U32 flag;
1564 int RETVAL, rc;
1565
1566 if (items < 3)
1567 flag = 0;
1568 else {
1569 flag = (unsigned long)SvIV(ST(2));
1570 }
1571
6f064249 1572 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
7a2f0d5b 1573 ST(0) = sv_newmortal();
1574 sv_setiv(ST(0), (IV)RETVAL);
1575 }
1576 XSRETURN(1);
1577}
1578
1c46958a 1579#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
017f25f1 1580#include "patchlevel.h"
1c46958a 1581#undef PERL_PATCHLEVEL_H_IMPLICIT
017f25f1 1582
6f064249 1583char *
23da6c43 1584mod2fname(pTHX_ SV *sv)
6f064249 1585{
1586 static char fname[9];
760ac839 1587 int pos = 6, len, avlen;
1588 unsigned int sum = 0;
6f064249 1589 char *s;
2d8e6c8d 1590 STRLEN n_a;
6f064249 1591
23da6c43 1592 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
6f064249 1593 sv = SvRV(sv);
1594 if (SvTYPE(sv) != SVt_PVAV)
23da6c43 1595 Perl_croak_nocontext("Not array reference given to mod2fname");
760ac839 1596
1597 avlen = av_len((AV*)sv);
1598 if (avlen < 0)
23da6c43 1599 Perl_croak_nocontext("Empty array reference given to mod2fname");
760ac839 1600
2d8e6c8d 1601 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 1602 strncpy(fname, s, 8);
760ac839 1603 len = strlen(s);
1604 if (len < 6) pos = len;
1605 while (*s) {
1606 sum = 33 * sum + *(s++); /* Checksumming first chars to
1607 * get the capitalization into c.s. */
1608 }
1609 avlen --;
1610 while (avlen >= 0) {
2d8e6c8d 1611 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839 1612 while (*s) {
1613 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1614 }
1615 avlen --;
1616 }
bea19d3f 1617 /* We always load modules as *specific* DLLs, and with the full name.
1618 When loading a specific DLL by its full name, one cannot get a
1619 different DLL, even if a DLL with the same basename is loaded already.
1620 Thus there is no need to include the version into the mangling scheme. */
1621#if 0
1622 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1623#else
1624# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1625# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1626# endif
1627 sum += COMPATIBLE_VERSION_SUM;
1628#endif
760ac839 1629 fname[pos] = 'A' + (sum % 26);
1630 fname[pos + 1] = 'A' + (sum / 26 % 26);
1631 fname[pos + 2] = '\0';
6f064249 1632 return (char *)fname;
1633}
1634
1635XS(XS_DynaLoader_mod2fname)
1636{
1637 dXSARGS;
1638 if (items != 1)
23da6c43 1639 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
6f064249 1640 {
1641 SV * sv = ST(0);
1642 char * RETVAL;
1643
23da6c43 1644 RETVAL = mod2fname(aTHX_ sv);
6f064249 1645 ST(0) = sv_newmortal();
1646 sv_setpv((SV*)ST(0), RETVAL);
1647 }
1648 XSRETURN(1);
1649}
1650
1651char *
1652os2error(int rc)
1653{
5c728af0 1654 dTHX;
6f064249 1655 static char buf[300];
1656 ULONG len;
9fed8b87 1657 char *s;
1658 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
6f064249 1659
55497cff 1660 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 1661 if (rc == 0)
9fed8b87 1662 return "";
1663 if (number) {
1664 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1665 s = buf + strlen(buf);
1666 } else
1667 s = buf;
1668 if (DosGetMessage(NULL, 0, s, sizeof(buf) - 1 - (s-buf),
1669 rc, "OSO001.MSG", &len)) {
1670 if (!number) {
1671 sprintf(buf, "SYS%04d=%#x: ", rc, rc);
1672 s = buf + strlen(buf);
1673 }
1674 sprintf(s, "[No description found in OSO001.MSG]");
1675 } else {
1676 s[len] = '\0';
1677 if (len && s[len - 1] == '\n')
1678 s[--len] = 0;
1679 if (len && s[len - 1] == '\r')
1680 s[--len] = 0;
1681 if (len && s[len - 1] == '.')
1682 s[--len] = 0;
1683 if (len >= 10 && number && strnEQ(s, buf, 7)
1684 && s[7] == ':' && s[8] == ' ')
1685 /* Some messages start with SYSdddd:, some not */
1686 Move(s + 9, s, (len -= 9) + 1, char);
ed344e4f 1687 }
6f064249 1688 return buf;
1689}
1690
30500b05 1691void
1692ResetWinError(void)
1693{
1694 WinError_2_Perl_rc;
1695}
1696
1697void
1698CroakWinError(int die, char *name)
1699{
1700 FillWinError;
5c728af0 1701 if (die && Perl_rc) {
1702 dTHX;
1703
1704 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
1705 }
30500b05 1706}
1707
760ac839 1708char *
23da6c43 1709os2_execname(pTHX)
ed344e4f 1710{
5ba48348 1711 char buf[300], *p, *o = PL_origargv[0], ok = 1;
ed344e4f 1712
1713 if (_execname(buf, sizeof buf) != 0)
5ba48348 1714 return o;
ed344e4f 1715 p = buf;
1716 while (*p) {
1717 if (*p == '\\')
1718 *p = '/';
5ba48348 1719 if (*p == '/') {
1720 if (ok && *o != '/' && *o != '\\')
1721 ok = 0;
1722 } else if (ok && tolower(*o) != tolower(*p))
1723 ok = 0;
ed344e4f 1724 p++;
5ba48348 1725 o++;
1726 }
1727 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1728 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1729 p = buf;
1730 while (*p) {
1731 if (*p == '\\')
1732 *p = '/';
1733 p++;
1734 }
ed344e4f 1735 }
1736 p = savepv(buf);
1737 SAVEFREEPV(p);
1738 return p;
1739}
1740
1741char *
760ac839 1742perllib_mangle(char *s, unsigned int l)
1743{
1744 static char *newp, *oldp;
1745 static int newl, oldl, notfound;
1746 static char ret[STATIC_FILE_LENGTH+1];
1747
1748 if (!newp && !notfound) {
1749 newp = getenv("PERLLIB_PREFIX");
1750 if (newp) {
ff68c719 1751 char *s;
1752
760ac839 1753 oldp = newp;
89078e0f 1754 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839 1755 newp++; oldl++; /* Skip digits. */
1756 }
1757 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1758 newp++; /* Skip whitespace. */
1759 }
1760 newl = strlen(newp);
1761 if (newl == 0 || oldl == 0) {
23da6c43 1762 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 1763 }
ff68c719 1764 strcpy(ret, newp);
1765 s = ret;
1766 while (*s) {
1767 if (*s == '\\') *s = '/';
1768 s++;
1769 }
760ac839 1770 } else {
1771 notfound = 1;
1772 }
1773 }
1774 if (!newp) {
1775 return s;
1776 }
1777 if (l == 0) {
1778 l = strlen(s);
1779 }
3bbf9c2b 1780 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839 1781 return s;
1782 }
1783 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
23da6c43 1784 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 1785 }
89078e0f 1786 strcpy(ret + newl, s + oldl);
760ac839 1787 return ret;
1788}
6f064249 1789
4bfbfac5 1790unsigned long
1791Perl_hab_GET() /* Needed if perl.h cannot be included */
1792{
1793 return perl_hab_GET();
1794}
1795
1796HMQ
1797Perl_Register_MQ(int serve)
1798{
8c4b3a79 1799 if (Perl_hmq_refcnt <= 0) {
4bfbfac5 1800 PPIB pib;
1801 PTIB tib;
1802
30500b05 1803 Perl_hmq_refcnt = 0; /* Be extra safe */
4bfbfac5 1804 DosGetInfoBlocks(&tib, &pib);
1805 Perl_os2_initial_mode = pib->pib_ultype;
4bfbfac5 1806 /* Try morphing into a PM application. */
1807 if (pib->pib_ultype != 3) /* 2 is VIO */
1808 pib->pib_ultype = 3; /* 3 is PM */
1809 init_PMWIN_entries();
1810 /* 64 messages if before OS/2 3.0, ignored otherwise */
1811 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1812 if (!Perl_hmq) {
5c728af0 1813 dTHX;
4bfbfac5 1814 static int cnt;
5ba48348 1815
1816 SAVEINT(cnt); /* Allow catch()ing. */
4bfbfac5 1817 if (cnt++)
1818 _exit(188); /* Panic can try to create a window. */
23da6c43 1819 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
4bfbfac5 1820 }
8c4b3a79 1821 }
5ba48348 1822 if (serve) {
1823 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1824 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1825 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1826 Perl_hmq_servers++;
1827 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1828 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1829 Perl_hmq_refcnt++;
4bfbfac5 1830 return Perl_hmq;
1831}
1832
1833int
1834Perl_Serve_Messages(int force)
1835{
1836 int cnt = 0;
1837 QMSG msg;
1838
5ba48348 1839 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 1840 return 0;
5ba48348 1841 if (Perl_hmq_refcnt <= 0)
23da6c43 1842 Perl_croak_nocontext("No message queue");
4bfbfac5 1843 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1844 cnt++;
1845 if (msg.msg == WM_QUIT)
23da6c43 1846 Perl_croak_nocontext("QUITing...");
4bfbfac5 1847 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1848 }
1849 return cnt;
1850}
1851
1852int
1853Perl_Process_Messages(int force, I32 *cntp)
1854{
1855 QMSG msg;
1856
5ba48348 1857 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 1858 return 0;
5ba48348 1859 if (Perl_hmq_refcnt <= 0)
23da6c43 1860 Perl_croak_nocontext("No message queue");
4bfbfac5 1861 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1862 if (cntp)
1863 (*cntp)++;
1864 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1865 if (msg.msg == WM_DESTROY)
1866 return -1;
1867 if (msg.msg == WM_CREATE)
1868 return +1;
1869 }
23da6c43 1870 Perl_croak_nocontext("QUITing...");
4bfbfac5 1871}
1872
1873void
1874Perl_Deregister_MQ(int serve)
1875{
1876 PPIB pib;
1877 PTIB tib;
1878
5ba48348 1879 if (serve)
1880 Perl_hmq_servers--;
1881 if (--Perl_hmq_refcnt <= 0) {
1882 init_PMWIN_entries(); /* To be extra safe */
4bfbfac5 1883 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1884 Perl_hmq = 0;
1885 /* Try morphing back from a PM application. */
5ba48348 1886 DosGetInfoBlocks(&tib, &pib);
4bfbfac5 1887 if (pib->pib_ultype == 3) /* 3 is PM */
1888 pib->pib_ultype = Perl_os2_initial_mode;
1889 else
23da6c43 1890 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
4bfbfac5 1891 pib->pib_ultype);
5ba48348 1892 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1893 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
4bfbfac5 1894}
1895
3bbf9c2b 1896#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1897 && ((path)[2] == '/' || (path)[2] == '\\'))
1898#define sys_is_rooted _fnisabs
1899#define sys_is_relative _fnisrel
1900#define current_drive _getdrive
1901
1902#undef chdir /* Was _chdir2. */
1903#define sys_chdir(p) (chdir(p) == 0)
1904#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1905
4bfbfac5 1906static int DOS_harderr_state = -1;
1907
1908XS(XS_OS2_Error)
1909{
1910 dXSARGS;
1911 if (items != 2)
23da6c43 1912 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
4bfbfac5 1913 {
1914 int arg1 = SvIV(ST(0));
1915 int arg2 = SvIV(ST(1));
1916 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1917 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1918 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1919 unsigned long rc;
1920
1921 if (CheckOSError(DosError(a)))
23da6c43 1922 Perl_croak_nocontext("DosError(%d) failed", a);
4bfbfac5 1923 ST(0) = sv_newmortal();
1924 if (DOS_harderr_state >= 0)
1925 sv_setiv(ST(0), DOS_harderr_state);
1926 DOS_harderr_state = RETVAL;
1927 }
1928 XSRETURN(1);
1929}
1930
1931static signed char DOS_suppression_state = -1;
1932
1933XS(XS_OS2_Errors2Drive)
1934{
1935 dXSARGS;
1936 if (items != 1)
23da6c43 1937 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
4bfbfac5 1938 {
2d8e6c8d 1939 STRLEN n_a;
4bfbfac5 1940 SV *sv = ST(0);
1941 int suppress = SvOK(sv);
2d8e6c8d 1942 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5 1943 char drive = (s ? *s : 0);
1944 unsigned long rc;
1945
1946 if (suppress && !isALPHA(drive))
23da6c43 1947 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
4bfbfac5 1948 if (CheckOSError(DosSuppressPopUps((suppress
1949 ? SPU_ENABLESUPPRESSION
1950 : SPU_DISABLESUPPRESSION),
1951 drive)))
23da6c43 1952 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
4bfbfac5 1953 ST(0) = sv_newmortal();
1954 if (DOS_suppression_state > 0)
1955 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1956 else if (DOS_suppression_state == 0)
1957 sv_setpvn(ST(0), "", 0);
1958 DOS_suppression_state = drive;
1959 }
1960 XSRETURN(1);
1961}
1962
1963static const char * const si_fields[QSV_MAX] = {
1964 "MAX_PATH_LENGTH",
1965 "MAX_TEXT_SESSIONS",
1966 "MAX_PM_SESSIONS",
1967 "MAX_VDM_SESSIONS",
1968 "BOOT_DRIVE",
1969 "DYN_PRI_VARIATION",
1970 "MAX_WAIT",
1971 "MIN_SLICE",
1972 "MAX_SLICE",
1973 "PAGE_SIZE",
1974 "VERSION_MAJOR",
1975 "VERSION_MINOR",
1976 "VERSION_REVISION",
1977 "MS_COUNT",
1978 "TIME_LOW",
1979 "TIME_HIGH",
1980 "TOTPHYSMEM",
1981 "TOTRESMEM",
1982 "TOTAVAILMEM",
1983 "MAXPRMEM",
1984 "MAXSHMEM",
1985 "TIMER_INTERVAL",
1986 "MAX_COMP_LENGTH",
1987 "FOREGROUND_FS_SESSION",
1988 "FOREGROUND_PROCESS"
1989};
1990
1991XS(XS_OS2_SysInfo)
1992{
1993 dXSARGS;
1994 if (items != 0)
23da6c43 1995 Perl_croak_nocontext("Usage: OS2::SysInfo()");
4bfbfac5 1996 {
1997 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1998 APIRET rc = NO_ERROR; /* Return code */
1999 int i = 0, j = 0;
2000
2001 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
2002 QSV_MAX, /* information */
2003 (PVOID)si,
2004 sizeof(si))))
23da6c43 2005 Perl_croak_nocontext("DosQuerySysInfo() failed");
4bfbfac5 2006 EXTEND(SP,2*QSV_MAX);
2007 while (i < QSV_MAX) {
2008 ST(j) = sv_newmortal();
2009 sv_setpv(ST(j++), si_fields[i]);
2010 ST(j) = sv_newmortal();
2011 sv_setiv(ST(j++), si[i]);
2012 i++;
2013 }
2014 }
2015 XSRETURN(2 * QSV_MAX);
2016}
2017
2018XS(XS_OS2_BootDrive)
2019{
2020 dXSARGS;
2021 if (items != 0)
23da6c43 2022 Perl_croak_nocontext("Usage: OS2::BootDrive()");
4bfbfac5 2023 {
2024 ULONG si[1] = {0}; /* System Information Data Buffer */
2025 APIRET rc = NO_ERROR; /* Return code */
2026 char c;
2027
2028 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2029 (PVOID)si, sizeof(si))))
23da6c43 2030 Perl_croak_nocontext("DosQuerySysInfo() failed");
4bfbfac5 2031 ST(0) = sv_newmortal();
2032 c = 'a' - 1 + si[0];
2033 sv_setpvn(ST(0), &c, 1);
2034 }
2035 XSRETURN(1);
2036}
2037
2038XS(XS_OS2_MorphPM)
2039{
2040 dXSARGS;
2041 if (items != 1)
23da6c43 2042 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
4bfbfac5 2043 {
2044 bool serve = SvOK(ST(0));
2045 unsigned long pmq = perl_hmq_GET(serve);
2046
2047 ST(0) = sv_newmortal();
2048 sv_setiv(ST(0), pmq);
2049 }
2050 XSRETURN(1);
2051}
2052
2053XS(XS_OS2_UnMorphPM)
2054{
2055 dXSARGS;
2056 if (items != 1)
23da6c43 2057 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
4bfbfac5 2058 {
2059 bool serve = SvOK(ST(0));
2060
2061 perl_hmq_UNSET(serve);
2062 }
2063 XSRETURN(0);
2064}
2065
2066XS(XS_OS2_Serve_Messages)
2067{
2068 dXSARGS;
2069 if (items != 1)
23da6c43 2070 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
4bfbfac5 2071 {
2072 bool force = SvOK(ST(0));
2073 unsigned long cnt = Perl_Serve_Messages(force);
2074
2075 ST(0) = sv_newmortal();
2076 sv_setiv(ST(0), cnt);
2077 }
2078 XSRETURN(1);
2079}
2080
2081XS(XS_OS2_Process_Messages)
2082{
2083 dXSARGS;
2084 if (items < 1 || items > 2)
23da6c43 2085 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
4bfbfac5 2086 {
2087 bool force = SvOK(ST(0));
2088 unsigned long cnt;
4bfbfac5 2089
2090 if (items == 2) {
47344f21 2091 I32 cntr;
4bfbfac5 2092 SV *sv = ST(1);
2d766320 2093
2094 (void)SvIV(sv); /* Force SvIVX */
4bfbfac5 2095 if (!SvIOK(sv))
23da6c43 2096 Perl_croak_nocontext("Can't upgrade count to IV");
47344f21 2097 cntr = SvIVX(sv);
2098 cnt = Perl_Process_Messages(force, &cntr);
2099 SvIVX(sv) = cntr;
2100 } else {
2101 cnt = Perl_Process_Messages(force, NULL);
2102 }
4bfbfac5 2103 ST(0) = sv_newmortal();
2104 sv_setiv(ST(0), cnt);
2105 }
2106 XSRETURN(1);
2107}
2108
3bbf9c2b 2109XS(XS_Cwd_current_drive)
2110{
2111 dXSARGS;
2112 if (items != 0)
23da6c43 2113 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3bbf9c2b 2114 {
2115 char RETVAL;
2116
2117 RETVAL = current_drive();
2118 ST(0) = sv_newmortal();
2119 sv_setpvn(ST(0), (char *)&RETVAL, 1);
2120 }
2121 XSRETURN(1);
2122}
2123
2124XS(XS_Cwd_sys_chdir)
2125{
2126 dXSARGS;
2127 if (items != 1)
23da6c43 2128 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3bbf9c2b 2129 {
2d8e6c8d 2130 STRLEN n_a;
2131 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 2132 bool RETVAL;
2133
2134 RETVAL = sys_chdir(path);
54310121 2135 ST(0) = boolSV(RETVAL);
3bbf9c2b 2136 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2137 }
2138 XSRETURN(1);
2139}
2140
2141XS(XS_Cwd_change_drive)
2142{
2143 dXSARGS;
2144 if (items != 1)
23da6c43 2145 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3bbf9c2b 2146 {
2d8e6c8d 2147 STRLEN n_a;
2148 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b 2149 bool RETVAL;
2150
2151 RETVAL = change_drive(d);
54310121 2152 ST(0) = boolSV(RETVAL);
3bbf9c2b 2153 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2154 }
2155 XSRETURN(1);
2156}
2157
2158XS(XS_Cwd_sys_is_absolute)
2159{
2160 dXSARGS;
2161 if (items != 1)
23da6c43 2162 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3bbf9c2b 2163 {
2d8e6c8d 2164 STRLEN n_a;
2165 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 2166 bool RETVAL;
2167
2168 RETVAL = sys_is_absolute(path);
54310121 2169 ST(0) = boolSV(RETVAL);
3bbf9c2b 2170 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2171 }
2172 XSRETURN(1);
2173}
2174
2175XS(XS_Cwd_sys_is_rooted)
2176{
2177 dXSARGS;
2178 if (items != 1)
23da6c43 2179 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3bbf9c2b 2180 {
2d8e6c8d 2181 STRLEN n_a;
2182 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 2183 bool RETVAL;
2184
2185 RETVAL = sys_is_rooted(path);
54310121 2186 ST(0) = boolSV(RETVAL);
3bbf9c2b 2187 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2188 }
2189 XSRETURN(1);
2190}
2191
2192XS(XS_Cwd_sys_is_relative)
2193{
2194 dXSARGS;
2195 if (items != 1)
23da6c43 2196 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3bbf9c2b 2197 {
2d8e6c8d 2198 STRLEN n_a;
2199 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b 2200 bool RETVAL;
2201
2202 RETVAL = sys_is_relative(path);
54310121 2203 ST(0) = boolSV(RETVAL);
3bbf9c2b 2204 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2205 }
2206 XSRETURN(1);
2207}
2208
2209XS(XS_Cwd_sys_cwd)
2210{
2211 dXSARGS;
2212 if (items != 0)
23da6c43 2213 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3bbf9c2b 2214 {
2215 char p[MAXPATHLEN];
2216 char * RETVAL;
2217 RETVAL = _getcwd2(p, MAXPATHLEN);
2218 ST(0) = sv_newmortal();
2219 sv_setpv((SV*)ST(0), RETVAL);
ebdd4fa0 2220#ifndef INCOMPLETE_TAINTS
2221 SvTAINTED_on(ST(0));
2222#endif
3bbf9c2b 2223 }
2224 XSRETURN(1);
2225}
2226
2227XS(XS_Cwd_sys_abspath)
2228{
2229 dXSARGS;
2230 if (items < 1 || items > 2)
23da6c43 2231 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
3bbf9c2b 2232 {
2d8e6c8d 2233 STRLEN n_a;
2234 char * path = (char *)SvPV(ST(0),n_a);
f5f423e4 2235 char * dir, *s, *t, *e;
3bbf9c2b 2236 char p[MAXPATHLEN];
2237 char * RETVAL;
f5f423e4 2238 int l;
2239 SV *sv;
3bbf9c2b 2240
2241 if (items < 2)
2242 dir = NULL;
2243 else {
2d8e6c8d 2244 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b 2245 }
2246 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
2247 path += 2;
2248 }
2249 if (dir == NULL) {
2250 if (_abspath(p, path, MAXPATHLEN) == 0) {
2251 RETVAL = p;
2252 } else {
2253 RETVAL = NULL;
2254 }
2255 } else {
2256 /* Absolute with drive: */
2257 if ( sys_is_absolute(path) ) {
2258 if (_abspath(p, path, MAXPATHLEN) == 0) {
2259 RETVAL = p;
2260 } else {
2261 RETVAL = NULL;
2262 }
2263 } else if (path[0] == '/' || path[0] == '\\') {
2264 /* Rooted, but maybe on different drive. */
2265 if (isALPHA(dir[0]) && dir[1] == ':' ) {
2266 char p1[MAXPATHLEN];
2267
2268 /* Need to prepend the drive. */
2269 p1[0] = dir[0];
2270 p1[1] = dir[1];
2271 Copy(path, p1 + 2, strlen(path) + 1, char);
2272 RETVAL = p;
2273 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2274 RETVAL = p;
2275 } else {
2276 RETVAL = NULL;
2277 }
2278 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2279 RETVAL = p;
2280 } else {
2281 RETVAL = NULL;
2282 }
2283 } else {
2284 /* Either path is relative, or starts with a drive letter. */
2285 /* If the path starts with a drive letter, then dir is
2286 relevant only if
2287 a/b) it is absolute/x:relative on the same drive.
2288 c) path is on current drive, and dir is rooted
2289 In all the cases it is safe to drop the drive part
2290 of the path. */
2291 if ( !sys_is_relative(path) ) {
3bbf9c2b 2292 if ( ( ( sys_is_absolute(dir)
2293 || (isALPHA(dir[0]) && dir[1] == ':'
2294 && strnicmp(dir, path,1) == 0))
2295 && strnicmp(dir, path,1) == 0)
2296 || ( !(isALPHA(dir[0]) && dir[1] == ':')
2297 && toupper(path[0]) == current_drive())) {
2298 path += 2;
2299 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
2300 RETVAL = p; goto done;
2301 } else {
2302 RETVAL = NULL; goto done;
2303 }
2304 }
2305 {
2306 /* Need to prepend the absolute path of dir. */
2307 char p1[MAXPATHLEN];
2308
2309 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
2310 int l = strlen(p1);
2311
2312 if (p1[ l - 1 ] != '/') {
2313 p1[ l ] = '/';
2314 l++;
2315 }
2316 Copy(path, p1 + l, strlen(path) + 1, char);
2317 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2318 RETVAL = p;
2319 } else {
2320 RETVAL = NULL;
2321 }
2322 } else {
2323 RETVAL = NULL;
2324 }
2325 }
2326 done:
2327 }
2328 }
f5f423e4 2329 if (!RETVAL)
2330 XSRETURN_EMPTY;
2331 /* Backslashes are already converted to slashes. */
2332 /* Remove trailing slashes */
2333 l = strlen(RETVAL);
2334 while (l > 0 && RETVAL[l-1] == '/')
2335 l--;
3bbf9c2b 2336 ST(0) = sv_newmortal();
f5f423e4 2337 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
45ee47cb 2338 /* Remove duplicate slashes, skipping the first three, which
2339 may be parts of a server-based path */
2340 s = t = 3 + SvPV_force(sv, n_a);
f5f423e4 2341 e = SvEND(sv);
45ee47cb 2342 /* Do not worry about multibyte chars here, this would contradict the
2343 eventual UTFization, and currently most other places break too... */
f5f423e4 2344 while (s < e) {
2345 if (s[0] == t[-1] && s[0] == '/')
2346 s++; /* Skip duplicate / */
2347 else
2348 *t++ = *s++;
2349 }
45ee47cb 2350 if (t < e) {
2351 *t = 0;
2352 SvCUR_set(sv, t - SvPVX(sv));
2353 }
3bbf9c2b 2354 }
2355 XSRETURN(1);
2356}
72ea3524 2357typedef APIRET (*PELP)(PSZ path, ULONG type);
2358
5a9d0041 2359/* Kernels after 2000/09/15 understand this too: */
2360#ifndef LIBPATHSTRICT
2361# define LIBPATHSTRICT 3
2362#endif
2363
72ea3524 2364APIRET
5a9d0041 2365ExtLIBPATH(ULONG ord, PSZ path, IV type)
72ea3524 2366{
5a9d0041 2367 ULONG what;
35bc1fdc 2368 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
5a9d0041 2369
5a9d0041 2370 if (type > 0)
2371 what = END_LIBPATH;
2372 else if (type == 0)
2373 what = BEGIN_LIBPATH;
2374 else
2375 what = LIBPATHSTRICT;
35bc1fdc 2376 return (*(PELP)f)(path, what);
72ea3524 2377}
3bbf9c2b 2378
5a9d0041 2379#define extLibpath(to,type) \
35bc1fdc 2380 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3bbf9c2b 2381
2382#define extLibpath_set(p,type) \
35bc1fdc 2383 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3bbf9c2b 2384
2385XS(XS_Cwd_extLibpath)
2386{
2387 dXSARGS;
2388 if (items < 0 || items > 1)
23da6c43 2389 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3bbf9c2b 2390 {
5a9d0041 2391 IV type;
3bbf9c2b 2392 char to[1024];
2393 U32 rc;
2394 char * RETVAL;
2395
2396 if (items < 1)
2397 type = 0;
2398 else {
5a9d0041 2399 type = SvIV(ST(0));
3bbf9c2b 2400 }
2401
5a9d0041 2402 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2403 RETVAL = extLibpath(to, type);
2404 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2405 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
3bbf9c2b 2406 ST(0) = sv_newmortal();
2407 sv_setpv((SV*)ST(0), RETVAL);
2408 }
2409 XSRETURN(1);
2410}
2411
2412XS(XS_Cwd_extLibpath_set)
2413{
2414 dXSARGS;
2415 if (items < 1 || items > 2)
23da6c43 2416 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3bbf9c2b 2417 {
2d8e6c8d 2418 STRLEN n_a;
2419 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 2420 IV type;
3bbf9c2b 2421 U32 rc;
2422 bool RETVAL;
2423
2424 if (items < 2)
2425 type = 0;
2426 else {
5a9d0041 2427 type = SvIV(ST(1));
3bbf9c2b 2428 }
2429
2430 RETVAL = extLibpath_set(s, type);
54310121 2431 ST(0) = boolSV(RETVAL);
3bbf9c2b 2432 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2433 }
2434 XSRETURN(1);
2435}
2436
30500b05 2437/* Input: Address, BufLen
2438APIRET APIENTRY
2439DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2440 ULONG * Offset, ULONG Address);
2441*/
2442
2443DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
2444 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
2445 ULONG * Offset, ULONG Address),
2446 (hmod, obj, BufLen, Buf, Offset, Address))
2447
2448enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
2449
2450static SV*
2451module_name_at(void *pp, enum module_name_how how)
2452{
5c728af0 2453 dTHX;
30500b05 2454 char buf[MAXPATHLEN];
2455 char *p = buf;
2456 HMODULE mod;
2457 ULONG obj, offset, rc;
2458
2459 if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
2460 return &PL_sv_undef;
2461 if (how == mod_name_handle)
2462 return newSVuv(mod);
2463 /* Full name... */
2464 if ( how == mod_name_full
2465 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
2466 return &PL_sv_undef;
2467 while (*p) {
2468 if (*p == '\\')
2469 *p = '/';
2470 p++;
2471 }
2472 return newSVpv(buf, 0);
2473}
2474
2475static SV*
2476module_name_of_cv(SV *cv, enum module_name_how how)
2477{
5c728af0 2478 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
2479 dTHX;
2480
2481 Perl_croak(aTHX_ "Not an XSUB reference");
2482 }
30500b05 2483 return module_name_at(CvXSUB(SvRV(cv)), how);
2484}
2485
2486/* Find module name to which *this* subroutine is compiled */
2487#define module_name(how) module_name_at(&module_name_at, how)
2488
2489XS(XS_OS2_DLLname)
2490{
2491 dXSARGS;
2492 if (items > 2)
2493 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
2494 {
2495 SV * RETVAL;
2496 int how;
2497
2498 if (items < 1)
2499 how = mod_name_full;
2500 else {
2501 how = (int)SvIV(ST(0));
2502 }
2503 if (items < 2)
2504 RETVAL = module_name(how);
2505 else
2506 RETVAL = module_name_of_cv(ST(1), how);
2507 ST(0) = RETVAL;
2508 sv_2mortal(ST(0));
2509 }
2510 XSRETURN(1);
2511}
2512
5ba48348 2513#define get_control87() _control87(0,0)
2514#define set_control87 _control87
2515
2516XS(XS_OS2__control87)
2517{
2518 dXSARGS;
2519 if (items != 2)
5c728af0 2520 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
5ba48348 2521 {
2522 unsigned new = (unsigned)SvIV(ST(0));
2523 unsigned mask = (unsigned)SvIV(ST(1));
2524 unsigned RETVAL;
2525
2526 RETVAL = _control87(new, mask);
2527 ST(0) = sv_newmortal();
2528 sv_setiv(ST(0), (IV)RETVAL);
2529 }
2530 XSRETURN(1);
2531}
2532
2533XS(XS_OS2_get_control87)
2534{
2535 dXSARGS;
2536 if (items != 0)
5c728af0 2537 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
5ba48348 2538 {
2539 unsigned RETVAL;
2540
2541 RETVAL = get_control87();
2542 ST(0) = sv_newmortal();
2543 sv_setiv(ST(0), (IV)RETVAL);
2544 }
2545 XSRETURN(1);
2546}
2547
2548
2549XS(XS_OS2_set_control87)
2550{
2551 dXSARGS;
2552 if (items < 0 || items > 2)
5c728af0 2553 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
5ba48348 2554 {
2555 unsigned new;
2556 unsigned mask;
2557 unsigned RETVAL;
2558
2559 if (items < 1)
2560 new = MCW_EM;
2561 else {
2562 new = (unsigned)SvIV(ST(0));
2563 }
2564
2565 if (items < 2)
2566 mask = MCW_EM;
2567 else {
2568 mask = (unsigned)SvIV(ST(1));
2569 }
2570
2571 RETVAL = set_control87(new, mask);
2572 ST(0) = sv_newmortal();
2573 sv_setiv(ST(0), (IV)RETVAL);
2574 }
2575 XSRETURN(1);
2576}
2577
3bbf9c2b 2578int
23da6c43 2579Xs_OS2_init(pTHX)
3bbf9c2b 2580{
2581 char *file = __FILE__;
2582 {
2583 GV *gv;
55497cff 2584
2585 if (_emx_env & 0x200) { /* OS/2 */
2586 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2587 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2588 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2589 }
4bfbfac5 2590 newXS("OS2::Error", XS_OS2_Error, file);
2591 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2592 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2593 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2594 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2595 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2596 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2597 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b 2598 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2599 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2600 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2601 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2602 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2603 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2604 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2605 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2606 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
5ba48348 2607 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2608 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2609 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
30500b05 2610 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
3bbf9c2b 2611 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2612 GvMULTI_on(gv);
2613#ifdef PERL_IS_AOUT
2614 sv_setiv(GvSV(gv), 1);
764df951 2615#endif
2616 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
2617 GvMULTI_on(gv);
2618 sv_setiv(GvSV(gv), exe_is_aout());
4bfbfac5 2619 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2620 GvMULTI_on(gv);
2621 sv_setiv(GvSV(gv), _emx_rev);
2622 sv_setpv(GvSV(gv), _emx_vprt);
2623 SvIOK_on(GvSV(gv));
2624 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2625 GvMULTI_on(gv);
2626 sv_setiv(GvSV(gv), _emx_env);
2627 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2628 GvMULTI_on(gv);
2629 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87 2630 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
2631 GvMULTI_on(gv);
2632 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 2633 }
2d766320 2634 return 0;
3bbf9c2b 2635}
2636
2637OS2_Perl_data_t OS2_Perl_data;
2638
764df951 2639extern void _emx_init(void*);
2640
2641static void jmp_out_of_atexit(void);
2642
2643#define FORCE_EMX_INIT_CONTRACT_ARGV 1
2644#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
2645
2646static void
2647my_emx_init(void *layout) {
2648 static volatile void *p = 0; /* Cannot be on stack! */
2649
2650 /* Can't just call emx_init(), since it moves the stack pointer */
2651 /* It also busts a lot of registers, so be extra careful */
2652 __asm__( "pushf\n"
2653 "pusha\n"
2654 "movl %%esp, %1\n"
2655 "push %0\n"
2656 "call __emx_init\n"
2657 "movl %1, %%esp\n"
2658 "popa\n"
2659 "popf\n" : : "r" (layout), "m" (p) );
2660}
2661
2662struct layout_table_t {
2663 ULONG text_base;
2664 ULONG text_end;
2665 ULONG data_base;
2666 ULONG data_end;
2667 ULONG bss_base;
2668 ULONG bss_end;
2669 ULONG heap_base;
2670 ULONG heap_end;
2671 ULONG heap_brk;
2672 ULONG heap_off;
2673 ULONG os2_dll;
2674 ULONG stack_base;
2675 ULONG stack_end;
2676 ULONG flags;
2677 ULONG reserved[2];
2678 char options[64];
2679};
2680
2681static ULONG
2682my_os_version() {
2683 static ULONG res; /* Cannot be on stack! */
2684
c4e0013e 2685 /* Can't just call __os_version(), since it does not follow C
2686 calling convention: it busts a lot of registers, so be extra careful */
764df951 2687 __asm__( "pushf\n"
2688 "pusha\n"
2689 "call ___os_version\n"
2690 "movl %%eax, %0\n"
2691 "popa\n"
2692 "popf\n" : "=m" (res) );
2693
2694 return res;
2695}
2696
2697static void
2698force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
2699{
2700 /* Calling emx_init() will bust the top of stack: it installs an
2701 exception handler and puts argv data there. */
2702 char *oldarg, *oldenv;
2703 void *oldstackend, *oldstack;
2704 PPIB pib;
2705 PTIB tib;
2706 static ULONG os2_dll;
2707 ULONG rc, error = 0, out;
2708 char buf[512];
2709 static struct layout_table_t layout_table;
2710 struct {
2711 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
2712 double alignment1;
2713 EXCEPTIONREGISTRATIONRECORD xreg;
2714 } *newstack;
2715 char *s;
2716
2717 layout_table.os2_dll = (ULONG)&os2_dll;
2718 layout_table.flags = 0x02000002; /* flags: application, OMF */
2719
2720 DosGetInfoBlocks(&tib, &pib);
2721 oldarg = pib->pib_pchcmd;
2722 oldenv = pib->pib_pchenv;
2723 oldstack = tib->tib_pstack;
2724 oldstackend = tib->tib_pstacklimit;
2725
2726 /* Minimize the damage to the stack via reducing the size of argv. */
2727 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
2728 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
2729 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
2730 }
2731
2732 newstack = alloca(sizeof(*newstack));
2733 /* Emulate the stack probe */
2734 s = ((char*)newstack) + sizeof(*newstack);
2735 while (s > (char*)newstack) {
2736 s[-1] = 0;
2737 s -= 4096;
2738 }
2739
2740 /* Reassigning stack is documented to work */
2741 tib->tib_pstack = (void*)newstack;
2742 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
2743
2744 /* Can't just call emx_init(), since it moves the stack pointer */
2745 my_emx_init((void*)&layout_table);
2746
2747 /* Remove the exception handler, cannot use it - too low on the stack.
2748 Check whether it is inside the new stack. */
2749 buf[0] = 0;
2750 if (tib->tib_pexchain >= tib->tib_pstacklimit
2751 || tib->tib_pexchain < tib->tib_pstack) {
2752 error = 1;
2753 sprintf(buf,
2754 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
2755 (unsigned long)tib->tib_pstack,
2756 (unsigned long)tib->tib_pexchain,
2757 (unsigned long)tib->tib_pstacklimit);
2758 goto finish;
2759 }
2760 if (tib->tib_pexchain != &(newstack->xreg)) {
2761 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
2762 (unsigned long)tib->tib_pexchain,
2763 (unsigned long)&(newstack->xreg));
2764 }
2765 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
2766 if (rc)
2767 sprintf(buf + strlen(buf),
2768 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2769
2770 if (preg) {
2771 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
2772 preg->prev_structure = 0;
2773 preg->ExceptionHandler = _emx_exception;
2774 rc = DosSetExceptionHandler(preg);
2775 if (rc) {
2776 sprintf(buf + strlen(buf),
2777 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
2778 DosWrite(2, buf, strlen(buf), &out);
2779 emx_exception_init = 1; /* Do it around spawn*() calls */
2780 }
2781 } else
2782 emx_exception_init = 1; /* Do it around spawn*() calls */
2783
2784 finish:
2785 /* Restore the damage */
2786 pib->pib_pchcmd = oldarg;
2787 pib->pib_pchcmd = oldenv;
2788 tib->tib_pstacklimit = oldstackend;
2789 tib->tib_pstack = oldstack;
2790 emx_runtime_init = 1;
2791 if (buf[0])
2792 DosWrite(2, buf, strlen(buf), &out);
2793 if (error)
2794 exit(56);
2795}
2796
2797jmp_buf at_exit_buf;
2798int longjmp_at_exit;
2799
2800static void
2801jmp_out_of_atexit(void)
2802{
2803 if (longjmp_at_exit)
2804 longjmp(at_exit_buf, 1);
2805}
2806
2807extern void _CRT_term(void);
2808
2809int emx_runtime_secondary;
2810
2811void
2812Perl_OS2_term(void **p, int exitstatus, int flags)
2813{
2814 if (!emx_runtime_secondary)
2815 return;
2816
2817 /* The principal executable is not running the same CRTL, so there
2818 is nobody to shutdown *this* CRTL except us... */
2819 if (flags & FORCE_EMX_DEINIT_EXIT) {
2820 if (p && !emx_exception_init)
2821 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2822 /* Do not run the executable's CRTL's termination routines */
2823 exit(exitstatus); /* Run at-exit, flush buffers, etc */
2824 }
2825 /* Run at-exit list, and jump out at the end */
2826 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
2827 longjmp_at_exit = 1;
2828 exit(exitstatus); /* The first pass through "if" */
2829 }
2830
2831 /* Get here if we managed to jump out of exit(), or did not run atexit. */
2832 longjmp_at_exit = 0; /* Maybe exit() is called again? */
2833#if 0 /* _atexit_n is not exported */
2834 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
2835 _atexit_n = 0; /* Remove the atexit() handlers */
2836#endif
2837 /* Will segfault on program termination if we leave this dangling... */
2838 if (p && !emx_exception_init)
2839 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
2840 /* Typically there is no need to do this, done from _DLL_InitTerm() */
2841 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
2842 _CRT_term(); /* Flush buffers, etc. */
2843 /* Now it is a good time to call exit() in the caller's CRTL... */
2844}
2845
2846#include <emx/startup.h>
2847
2848extern ULONG __os_version(); /* See system.doc */
2849
2850static int emx_wasnt_initialized;
2851
2852void
2853check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
2854{
2855 ULONG v_crt, v_emx;
2856
2857 /* If _environ is not set, this code sits in a DLL which
2858 uses a CRT DLL which not compatible with the executable's
2859 CRT library. Some parts of the DLL are not initialized.
2860 */
2861 if (_environ != NULL)
2862 return; /* Properly initialized */
2863
2864 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
2865 initialized either. Uninitialized EMX.DLL returns 0 in the low
2866 nibble of __os_version(). */
2867 v_emx = my_os_version();
2868
2869 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
2870 (=>_CRT_init=>_entry2) via a call to __os_version(), then
2871 reset when the EXE initialization code calls _text=>_init=>_entry2.
2872 The first time they are wrongly set to 0; the second time the
2873 EXE initialization code had already called emx_init=>initialize1
2874 which correctly set version_major, version_minor used by
2875 __os_version(). */
2876 v_crt = (_osmajor | _osminor);
2877
2878 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
2879 force_init_emx_runtime( preg,
2880 FORCE_EMX_INIT_CONTRACT_ARGV
2881 | FORCE_EMX_INIT_INSTALL_ATEXIT );
2882 emx_wasnt_initialized = 1;
2883 /* Update CRTL data basing on now-valid EMX runtime data */
2884 if (!v_crt) { /* The only wrong data are the versions. */
2885 v_emx = my_os_version(); /* *Now* it works */
2886 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
2887 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
2888 }
2889 }
2890 emx_runtime_secondary = 1;
2891 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
2892 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
2893
9e2a34c1 2894 if (env == NULL) { /* Fetch from the process info block */
764df951 2895 int c = 0;
2896 PPIB pib;
2897 PTIB tib;
2898 char *e, **ep;
2899
2900 DosGetInfoBlocks(&tib, &pib);
2901 e = pib->pib_pchenv;
2902 while (*e) { /* Get count */
2903 c++;
2904 e = e + strlen(e) + 1;
2905 }
764df951 2906 New(1307, env, c + 1, char*);
2907 ep = env;
2908 e = pib->pib_pchenv;
2909 while (c--) {
2910 *ep++ = e;
2911 e = e + strlen(e) + 1;
2912 }
2913 *ep = NULL;
2914 }
2915 _environ = _org_environ = env;
2916}
2917
2918#define ENTRY_POINT 0x10000
2919
2920static int
2921exe_is_aout(void)
2922{
2923 struct layout_table_t *layout;
2924 if (emx_wasnt_initialized)
2925 return 0;
2926 /* Now we know that the principal executable is an EMX application
2927 - unless somebody did already play with delayed initialization... */
2928 /* With EMX applications to determine whether it is AOUT one needs
2929 to examine the start of the executable to find "layout" */
2930 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
2931 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
2932 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
2933 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
2934 return 0; /* ! EMX executable */
2935 /* Fix alignment */
2936 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
2937 return !(layout->flags & 2);
2938}
2939
3bbf9c2b 2940void
aa689395 2941Perl_OS2_init(char **env)
3bbf9c2b 2942{
764df951 2943 Perl_OS2_init3(env, 0, 0);
2944}
2945
2946void
2947Perl_OS2_init3(char **env, void **preg, int flags)
2948{
3bbf9c2b 2949 char *shell;
2950
764df951 2951 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
18f739ee 2952 MALLOC_INIT;
764df951 2953
2954 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
2955
3bbf9c2b 2956 settmppath();
2957 OS2_Perl_data.xs_init = &Xs_OS2_init;
2958 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c 2959 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2960 strcpy(PL_sh_path, SH_PATH);
2961 PL_sh_path[0] = shell[0];
3bbf9c2b 2962 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 2963 int l = strlen(shell), i;
3bbf9c2b 2964 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2965 l--;
2966 }
6b88bc9c 2967 New(1304, PL_sh_path, l + 8, char);
2968 strncpy(PL_sh_path, shell, l);
2969 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 2970 for (i = 0; i < l; i++) {
6b88bc9c 2971 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 2972 }
3bbf9c2b 2973 }
5c728af0 2974#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
dd96f567 2975 MUTEX_INIT(&start_thread_mutex);
5c728af0 2976#endif
017f25f1 2977 os2_mytype = my_type(); /* Do it before morphing. Needed? */
5ba48348 2978 /* Some DLLs reset FP flags on load. We may have been linked with them */
2979 _control87(MCW_EM, MCW_EM);
3bbf9c2b 2980}
2981
55497cff 2982#undef tmpnam
2983#undef tmpfile
2984
2985char *
2986my_tmpnam (char *str)
2987{
2988 char *p = getenv("TMP"), *tpath;
55497cff 2989
2990 if (!p) p = getenv("TEMP");
2991 tpath = tempnam(p, "pltmp");
2992 if (str && tpath) {
2993 strcpy(str, tpath);
2994 return str;
2995 }
2996 return tpath;
2997}
2998
2999FILE *
3000my_tmpfile ()
3001{
3002 struct stat s;
3003
3004 stat(".", &s);
3005 if (s.st_mode & S_IWOTH) {
3006 return tmpfile();
3007 }
3008 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3009 grants TMP. */
3010}
367f3c24 3011
5ba48348 3012#undef rmdir
3013
cd4e750a 3014/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
3015 trailing slashes, so we need to support this as well. */
3016
5ba48348 3017int
3018my_rmdir (__const__ char *s)
3019{
cd4e750a 3020 char b[MAXPATHLEN];
3021 char *buf = b;
5ba48348 3022 STRLEN l = strlen(s);
cd4e750a 3023 int rc;
5ba48348 3024
cd4e750a 3025 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3026 if (l >= sizeof b)
3027 New(1305, buf, l + 1, char);
5ba48348 3028 strcpy(buf,s);
cd4e750a 3029 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3030 l--;
3031 buf[l] = 0;
5ba48348 3032 s = buf;
3033 }
cd4e750a 3034 rc = rmdir(s);
3035 if (b != buf)
3036 Safefree(buf);
3037 return rc;
5ba48348 3038}
3039
3040#undef mkdir
3041
3042int
3043my_mkdir (__const__ char *s, long perm)
3044{
cd4e750a 3045 char b[MAXPATHLEN];
3046 char *buf = b;
5ba48348 3047 STRLEN l = strlen(s);
cd4e750a 3048 int rc;
5ba48348 3049
3050 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
cd4e750a 3051 if (l >= sizeof b)
3052 New(1305, buf, l + 1, char);
5ba48348 3053 strcpy(buf,s);
cd4e750a 3054 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3055 l--;
3056 buf[l] = 0;
5ba48348 3057 s = buf;
3058 }
cd4e750a 3059 rc = mkdir(s, perm);
3060 if (b != buf)
3061 Safefree(buf);
3062 return rc;
5ba48348 3063}
3064
367f3c24 3065#undef flock
3066
3067/* This code was contributed by Rocco Caputo. */
3068int
dd96f567 3069my_flock(int handle, int o)
367f3c24 3070{
3071 FILELOCK rNull, rFull;
3072 ULONG timeout, handle_type, flag_word;
3073 APIRET rc;
3074 int blocking, shared;
3075 static int use_my = -1;
3076
3077 if (use_my == -1) {
3078 char *s = getenv("USE_PERL_FLOCK");
3079 if (s)
3080 use_my = atoi(s);
3081 else
3082 use_my = 1;
3083 }
3084 if (!(_emx_env & 0x200) || !use_my)
dd96f567 3085 return flock(handle, o); /* Delegate to EMX. */
367f3c24 3086
cb69f87a 3087 /* is this a file? */
367f3c24 3088 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
3089 (handle_type & 0xFF))
3090 {
3091 errno = EBADF;
3092 return -1;
3093 }
cb69f87a 3094 /* set lock/unlock ranges */
367f3c24 3095 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
3096 rFull.lRange = 0x7FFFFFFF;
cb69f87a 3097 /* set timeout for blocking */
dd96f567 3098 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
cb69f87a 3099 /* shared or exclusive? */
dd96f567 3100 shared = (o & LOCK_SH) ? 1 : 0;
cb69f87a 3101 /* do not block the unlock */
dd96f567 3102 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24 3103 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
3104 switch (rc) {
3105 case 0:
3106 errno = 0;
3107 return 0;
3108 case ERROR_INVALID_HANDLE:
3109 errno = EBADF;
3110 return -1;
3111 case ERROR_SHARING_BUFFER_EXCEEDED:
3112 errno = ENOLCK;
3113 return -1;
3114 case ERROR_LOCK_VIOLATION:
cb69f87a 3115 break; /* not an error */
367f3c24 3116 case ERROR_INVALID_PARAMETER:
3117 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3118 case ERROR_READ_LOCKS_NOT_SUPPORTED:
3119 errno = EINVAL;
3120 return -1;
3121 case ERROR_INTERRUPT:
3122 errno = EINTR;
3123 return -1;
3124 default:
3125 errno = EINVAL;
3126 return -1;
3127 }
3128 }
cb69f87a 3129 /* lock may block */
dd96f567 3130 if (o & (LOCK_SH | LOCK_EX)) {
cb69f87a 3131 /* for blocking operations */
367f3c24 3132 for (;;) {
3133 rc =
3134 DosSetFileLocks(
3135 handle,
3136 &rNull,
3137 &rFull,
3138 timeout,
3139 shared
3140 );
3141 switch (rc) {
3142 case 0:
3143 errno = 0;
3144 return 0;
3145 case ERROR_INVALID_HANDLE:
3146 errno = EBADF;
3147 return -1;
3148 case ERROR_SHARING_BUFFER_EXCEEDED:
3149 errno = ENOLCK;
3150 return -1;
3151 case ERROR_LOCK_VIOLATION:
3152 if (!blocking) {
3153 errno = EWOULDBLOCK;
3154 return -1;
3155 }
3156 break;
3157 case ERROR_INVALID_PARAMETER:
3158 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
3159 case ERROR_READ_LOCKS_NOT_SUPPORTED:
3160 errno = EINVAL;
3161 return -1;
3162 case ERROR_INTERRUPT:
3163 errno = EINTR;
3164 return -1;
3165 default:
3166 errno = EINVAL;
3167 return -1;
3168 }
cb69f87a 3169 /* give away timeslice */
367f3c24 3170 DosSleep(1);
3171 }
3172 }
3173
3174 errno = 0;
3175 return 0;
3176}
f72c975a 3177
3178static int pwent_cnt;
3179static int _my_pwent = -1;
3180
3181static int
3182use_my_pwent(void)
3183{
3184 if (_my_pwent == -1) {
3185 char *s = getenv("USE_PERL_PWENT");
3186 if (s)
3187 _my_pwent = atoi(s);
3188 else
3189 _my_pwent = 1;
3190 }
3191 return _my_pwent;
3192}
3193
3194#undef setpwent
3195#undef getpwent
3196#undef endpwent
3197
3198void
3199my_setpwent(void)
3200{
3201 if (!use_my_pwent()) {
3202 setpwent(); /* Delegate to EMX. */
3203 return;
3204 }
3205 pwent_cnt = 0;
3206}
3207
3208void
3209my_endpwent(void)
3210{
3211 if (!use_my_pwent()) {
3212 endpwent(); /* Delegate to EMX. */
3213 return;
3214 }
3215}
3216
3217struct passwd *
3218my_getpwent (void)
3219{
3220 if (!use_my_pwent())
3221 return getpwent(); /* Delegate to EMX. */
3222 if (pwent_cnt++)
cb69f87a 3223 return 0; /* Return one entry only */
f72c975a 3224 return getpwuid(0);
3225}
3226
3227static int grent_cnt;
3228
3229void
3230setgrent(void)
3231{
3232 grent_cnt = 0;
3233}
3234
3235void
3236endgrent(void)
3237{
3238}
3239
3240struct group *
3241getgrent (void)
3242{
3243 if (grent_cnt++)
cb69f87a 3244 return 0; /* Return one entry only */
f72c975a 3245 return getgrgid(0);
3246}
3247
3248#undef getpwuid
3249#undef getpwnam
3250
3251/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
3252static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
3253
3254static struct passwd *
3255passw_wrap(struct passwd *p)
3256{
3257 static struct passwd pw;
3258 char *s;
3259
3260 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
3261 return p;
3262 pw = *p;
3263 s = getenv("PW_PASSWD");
3264 if (!s)
3265 s = (char*)pw_p; /* Make match impossible */
3266
3267 pw.pw_passwd = s;
3268 return &pw;
3269}
3270
3271struct passwd *
3272my_getpwuid (uid_t id)
3273{
3274 return passw_wrap(getpwuid(id));
3275}
3276
3277struct passwd *
3278my_getpwnam (__const__ char *n)
3279{
3280 return passw_wrap(getpwnam(n));
3281}
a64c954a 3282
3283char *
3284gcvt_os2 (double value, int digits, char *buffer)
3285{
3286 return gcvt (value, digits, buffer);
3287}
5c728af0 3288
3289#undef fork
3290int fork_with_resources()
3291{
3292#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3293 dTHX;
3294 void *ctx = PERL_GET_CONTEXT;
3295#endif
3296
3297 int rc = fork();
3298
3299#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
3300 if (rc == 0) { /* child */
3301 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
3302 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
3303 }
3304#endif
3305 return rc;
3306}
Unnamed repository; edit this file to name it for gitweb.