This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Modify the common guard for the signal.h header, because
[perl5.git] / os2 / os2.c
CommitLineData
4633a7c4
LW		 1#define INCL_DOS
2#define INCL_NOPM
7a2f0d5b 3#define INCL_DOSFILEMGR
760ac839
LW		 4#define INCL_DOSMEMMGR
5#define INCL_DOSERRORS
622913ab
IZ		 6#define INCL_WINERRORS
7#define INCL_WINSYS
ed344e4f
IZ		 8/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
9#define INCL_DOSPROCESS
10#define SPU_DISABLESUPPRESSION 0
11#define SPU_ENABLESUPPRESSION 1
4633a7c4 12#include <os2.h>
5ba48348 13#include "dlfcn.h"
5c728af0 14#include <emx/syscalls.h>
4633a7c4 15
28743a51
IZ		 16#include <sys/uflags.h>
17
4633a7c4
LW		 18/*
19 * Various Unix compatibility functions for OS/2
20 */
21
22#include <stdio.h>
23#include <errno.h>
24#include <limits.h>
25#include <process.h>
72ea3524 26#include <fcntl.h>
f72c975a
IZ		 27#include <pwd.h>
28#include <grp.h>
4633a7c4 29
a03d92b2 30#define PERLIO_NOT_STDIO 0
8e4bc33b 31
4633a7c4
LW		 32#include "EXTERN.h"
33#include "perl.h"
34
622913ab
IZ		 35void
36croak_with_os2error(char *s)
37{
38 Perl_croak_nocontext("%s: %s", s, os2error(Perl_rc));
39}
40
41struct PMWIN_entries_t PMWIN_entries;
42
43/*****************************************************************************/
44/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
45
46struct dll_handle_t {
47 const char *modname;
48 HMODULE handle;
49 int requires_pm;
50};
51
52static struct dll_handle_t dll_handles[] = {
53 {"doscalls", 0, 0},
54 {"tcp32dll", 0, 0},
55 {"pmwin", 0, 1},
56 {"rexx", 0, 0},
57 {"rexxapi", 0, 0},
58 {"sesmgr", 0, 0},
59 {"pmshapi", 0, 1},
60 {"pmwp", 0, 1},
61 {"pmgpi", 0, 1},
62 {NULL, 0},
63};
64
65enum dll_handle_e {
66 dll_handle_doscalls,
67 dll_handle_tcp32dll,
68 dll_handle_pmwin,
69 dll_handle_rexx,
70 dll_handle_rexxapi,
71 dll_handle_sesmgr,
72 dll_handle_pmshapi,
73 dll_handle_pmwp,
74 dll_handle_pmgpi,
75 dll_handle_LAST,
76};
77
78#define doscalls_handle (dll_handles[dll_handle_doscalls])
79#define tcp_handle (dll_handles[dll_handle_tcp32dll])
80#define pmwin_handle (dll_handles[dll_handle_pmwin])
81#define rexx_handle (dll_handles[dll_handle_rexx])
82#define rexxapi_handle (dll_handles[dll_handle_rexxapi])
83#define sesmgr_handle (dll_handles[dll_handle_sesmgr])
84#define pmshapi_handle (dll_handles[dll_handle_pmshapi])
85#define pmwp_handle (dll_handles[dll_handle_pmwp])
86#define pmgpi_handle (dll_handles[dll_handle_pmgpi])
87
88/* The following local-scope data is not yet included:
89 fargs.140 // const => OK
90 ino.165 // locked - and the access is almost cosmetic
91 layout_table.260 // startup only, locked
92 osv_res.257 // startup only, locked
93 old_esp.254 // startup only, locked
94 priors // const ==> OK
95 use_my_flock.283 // locked
96 emx_init_done.268 // locked
97 dll_handles // locked
98 hmtx_emx_init.267 // THIS is the lock for startup
99 perlos2_state_mutex // THIS is the lock for all the rest
100BAD:
101 perlos2_state // see below
102*/
103/* The following global-scope data is not yet included:
104 OS2_Perl_data
105 pthreads_states // const now?
106 start_thread_mutex
107 thread_join_count // protected
108 thread_join_data // protected
109 tmppath
110
111 pDosVerifyPidTid
112
113 Perl_OS2_init3() - should it be protected?
114*/
115OS2_Perl_data_t OS2_Perl_data;
116
117static struct perlos2_state_t {
118 int po2__my_pwent; /* = -1; */
119 int po2_DOS_harderr_state; /* = -1; */
120 signed char po2_DOS_suppression_state; /* = -1; */
121 PFN po2_ExtFCN[ORD_NENTRIES]; /* Labeled by ord ORD_*. */
122/* struct PMWIN_entries_t po2_PMWIN_entries; */
123
124 int po2_emx_wasnt_initialized;
125
126 char po2_fname[9];
127 int po2_rmq_cnt;
128
129 int po2_grent_cnt;
130
131 char *po2_newp;
132 char *po2_oldp;
133 int po2_newl;
134 int po2_oldl;
135 int po2_notfound;
136 char po2_mangle_ret[STATIC_FILE_LENGTH+1];
137 ULONG po2_os2_dll_fake;
138 ULONG po2_os2_mytype;
139 ULONG po2_os2_mytype_ini;
140 int po2_pidtid_lookup;
141 struct passwd po2_pw;
142
143 int po2_pwent_cnt;
144 char po2_pthreads_state_buf[80];
145 char po2_os2error_buf[300];
146/* There is no big sense to make it thread-specific, since signals
147 are delivered to thread 1 only. XXXX Maybe make it into an array? */
148 int po2_spawn_pid;
149 int po2_spawn_killed;
150
151 jmp_buf po2_at_exit_buf;
152 int po2_longjmp_at_exit;
153 int po2_emx_runtime_init; /* If 1, we need to manually init it */
154 int po2_emx_exception_init; /* If 1, we need to manually set it */
155 int po2_emx_runtime_secondary;
156
157} perlos2_state = {
158 -1, /* po2__my_pwent */
159 -1, /* po2_DOS_harderr_state */
160 -1, /* po2_DOS_suppression_state */
161};
162
163#define Perl_po2() (&perlos2_state)
164
165#define ExtFCN (Perl_po2()->po2_ExtFCN)
166/* #define PMWIN_entries (Perl_po2()->po2_PMWIN_entries) */
167#define emx_wasnt_initialized (Perl_po2()->po2_emx_wasnt_initialized)
168#define fname (Perl_po2()->po2_fname)
169#define rmq_cnt (Perl_po2()->po2_rmq_cnt)
170#define grent_cnt (Perl_po2()->po2_grent_cnt)
171#define newp (Perl_po2()->po2_newp)
172#define oldp (Perl_po2()->po2_oldp)
173#define newl (Perl_po2()->po2_newl)
174#define oldl (Perl_po2()->po2_oldl)
175#define notfound (Perl_po2()->po2_notfound)
176#define mangle_ret (Perl_po2()->po2_mangle_ret)
177#define os2_dll_fake (Perl_po2()->po2_os2_dll_fake)
178#define os2_mytype (Perl_po2()->po2_os2_mytype)
179#define os2_mytype_ini (Perl_po2()->po2_os2_mytype_ini)
180#define pidtid_lookup (Perl_po2()->po2_pidtid_lookup)
181#define pw (Perl_po2()->po2_pw)
182#define pwent_cnt (Perl_po2()->po2_pwent_cnt)
183#define _my_pwent (Perl_po2()->po2__my_pwent)
184#define pthreads_state_buf (Perl_po2()->po2_pthreads_state_buf)
185#define os2error_buf (Perl_po2()->po2_os2error_buf)
186/* There is no big sense to make it thread-specific, since signals
187 are delivered to thread 1 only. XXXX Maybe make it into an array? */
188#define spawn_pid (Perl_po2()->po2_spawn_pid)
189#define spawn_killed (Perl_po2()->po2_spawn_killed)
190#define DOS_harderr_state (Perl_po2()->po2_DOS_harderr_state)
191#define DOS_suppression_state (Perl_po2()->po2_DOS_suppression_state)
192
193#define at_exit_buf (Perl_po2()->po2_at_exit_buf)
194#define longjmp_at_exit (Perl_po2()->po2_longjmp_at_exit)
195#define emx_runtime_init (Perl_po2()->po2_emx_runtime_init)
196#define emx_exception_init (Perl_po2()->po2_emx_exception_init)
197#define emx_runtime_secondary (Perl_po2()->po2_emx_runtime_secondary)
198
199const Perl_PFN * const pExtFCN = (Perl_po2()->po2_ExtFCN);
200
201
5c728af0
IZ		 202#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
203
204typedef void (*emx_startroutine)(void *);
205typedef void* (*pthreads_startroutine)(void *);
206
207enum pthreads_state {
208 pthreads_st_none = 0,
209 pthreads_st_run,
210 pthreads_st_exited,
211 pthreads_st_detached,
212 pthreads_st_waited,
213 pthreads_st_norun,
214 pthreads_st_exited_waited,
215};
622913ab 216const char * const pthreads_states[] = {
5c728af0
IZ		 217 "uninit",
218 "running",
219 "exited",
220 "detached",
221 "waited for",
222 "could not start",
223 "exited, then waited on",
224};
225
226enum pthread_exists { pthread_not_existant = -0xff };
227
228static const char*
229pthreads_state_string(enum pthreads_state state)
230{
231 if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) {
622913ab
IZ		 232 snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
233 "unknown thread state %d", (int)state);
234 return pthreads_state_buf;
5c728af0
IZ		 235 }
236 return pthreads_states[state];
237}
238
239typedef struct {
240 void *status;
241 perl_cond cond;
242 enum pthreads_state state;
243} thread_join_t;
244
245thread_join_t *thread_join_data;
246int thread_join_count;
247perl_mutex start_thread_mutex;
622913ab
IZ		 248static perl_mutex perlos2_state_mutex;
249
5c728af0
IZ		 250
251int
252pthread_join(perl_os_thread tid, void **status)
253{
254 MUTEX_LOCK(&start_thread_mutex);
255 if (tid < 1 || tid >= thread_join_count) {
256 MUTEX_UNLOCK(&start_thread_mutex);
257 if (tid != pthread_not_existant)
258 Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid);
259 Perl_warn_nocontext("panic: join with a thread which could not start");
260 *status = 0;
261 return 0;
262 }
263 switch (thread_join_data[tid].state) {
264 case pthreads_st_exited:
265 thread_join_data[tid].state = pthreads_st_exited_waited;
266 *status = thread_join_data[tid].status;
267 MUTEX_UNLOCK(&start_thread_mutex);
268 COND_SIGNAL(&thread_join_data[tid].cond);
269 break;
270 case pthreads_st_waited:
271 MUTEX_UNLOCK(&start_thread_mutex);
272 Perl_croak_nocontext("join with a thread with a waiter");
273 break;
274 case pthreads_st_norun:
275 {
276 int state = (int)thread_join_data[tid].status;
277
278 thread_join_data[tid].state = pthreads_st_none;
279 MUTEX_UNLOCK(&start_thread_mutex);
280 Perl_croak_nocontext("panic: join with a thread which could not run"
281 " due to attempt of tid reuse (state='%s')",
282 pthreads_state_string(state));
283 break;
284 }
285 case pthreads_st_run:
286 {
287 perl_cond cond;
288
289 thread_join_data[tid].state = pthreads_st_waited;
290 thread_join_data[tid].status = (void *)status;
291 COND_INIT(&thread_join_data[tid].cond);
292 cond = thread_join_data[tid].cond;
293 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
294 COND_DESTROY(&cond);
295 MUTEX_UNLOCK(&start_thread_mutex);
296 break;
297 }
298 default:
299 MUTEX_UNLOCK(&start_thread_mutex);
300 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
301 pthreads_state_string(thread_join_data[tid].state));
302 break;
303 }
304 return 0;
305}
306
307typedef struct {
308 pthreads_startroutine sub;
309 void *arg;
310 void *ctx;
311} pthr_startit;
312
313/* The lock is used:
314 a) Since we temporarily usurp the caller interp, so malloc() may
315 use it to decide on debugging the call;
316 b) Since *args is on the caller's stack.
317 */
318void
319pthread_startit(void *arg1)
320{
321 /* Thread is already started, we need to transfer control only */
322 pthr_startit args = *(pthr_startit *)arg1;
323 int tid = pthread_self();
324 void *rc;
325 int state;
326
327 if (tid <= 1) {
328 /* Can't croak, the setjmp() is not in scope... */
329 char buf[80];
330
331 snprintf(buf, sizeof(buf),
332 "panic: thread with strange ordinal %d created\n\r", tid);
333 write(2,buf,strlen(buf));
334 MUTEX_UNLOCK(&start_thread_mutex);
335 return;
336 }
337 /* Until args.sub resets it, makes debugging Perl_malloc() work: */
338 PERL_SET_CONTEXT(0);
339 if (tid >= thread_join_count) {
340 int oc = thread_join_count;
341
342 thread_join_count = tid + 5 + tid/5;
343 if (thread_join_data) {
344 Renew(thread_join_data, thread_join_count, thread_join_t);
345 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
346 } else {
347 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
348 }
349 }
350 if (thread_join_data[tid].state != pthreads_st_none) {
351 /* Can't croak, the setjmp() is not in scope... */
352 char buf[80];
353
354 snprintf(buf, sizeof(buf),
355 "panic: attempt to reuse thread id %d (state='%s')\n\r",
356 tid, pthreads_state_string(thread_join_data[tid].state));
357 write(2,buf,strlen(buf));
358 thread_join_data[tid].status = (void*)thread_join_data[tid].state;
359 thread_join_data[tid].state = pthreads_st_norun;
360 MUTEX_UNLOCK(&start_thread_mutex);
361 return;
362 }
363 thread_join_data[tid].state = pthreads_st_run;
364 /* Now that we copied/updated the guys, we may release the caller... */
365 MUTEX_UNLOCK(&start_thread_mutex);
366 rc = (*args.sub)(args.arg);
367 MUTEX_LOCK(&start_thread_mutex);
368 switch (thread_join_data[tid].state) {
369 case pthreads_st_waited:
370 COND_SIGNAL(&thread_join_data[tid].cond);
371 thread_join_data[tid].state = pthreads_st_none;
372 *((void**)thread_join_data[tid].status) = rc;
373 break;
374 case pthreads_st_detached:
375 thread_join_data[tid].state = pthreads_st_none;
376 break;
377 case pthreads_st_run:
378 /* Somebody can wait on us; cannot exit, since OS can reuse the tid
379 and our waiter will get somebody else's status. */
380 thread_join_data[tid].state = pthreads_st_exited;
381 thread_join_data[tid].status = rc;
382 COND_INIT(&thread_join_data[tid].cond);
383 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
384 COND_DESTROY(&thread_join_data[tid].cond);
385 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
386 break;
387 default:
388 state = thread_join_data[tid].state;
389 MUTEX_UNLOCK(&start_thread_mutex);
390 Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'",
391 pthreads_state_string(state));
392 }
393 MUTEX_UNLOCK(&start_thread_mutex);
394}
395
396int
397pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
398 void *(*start_routine)(void*), void *arg)
399{
400 dTHX;
401 pthr_startit args;
402
403 args.sub = (void*)start_routine;
404 args.arg = arg;
405 args.ctx = PERL_GET_CONTEXT;
406
407 MUTEX_LOCK(&start_thread_mutex);
408 /* Test suite creates 31 extra threads;
409 on machine without shared-memory-hogs this stack sizeis OK with 31: */
410 *tidp = _beginthread(pthread_startit, /*stack*/ NULL,
411 /*stacksize*/ 4*1024*1024, (void*)&args);
412 if (*tidp == -1) {
413 *tidp = pthread_not_existant;
414 MUTEX_UNLOCK(&start_thread_mutex);
415 return EINVAL;
416 }
417 MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */
418 MUTEX_UNLOCK(&start_thread_mutex);
419 return 0;
420}
421
422int
423pthread_detach(perl_os_thread tid)
424{
425 MUTEX_LOCK(&start_thread_mutex);
426 if (tid < 1 || tid >= thread_join_count) {
427 MUTEX_UNLOCK(&start_thread_mutex);
428 if (tid != pthread_not_existant)
429 Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid);
430 Perl_warn_nocontext("detach of a thread which could not start");
431 return 0;
432 }
433 switch (thread_join_data[tid].state) {
434 case pthreads_st_waited:
435 MUTEX_UNLOCK(&start_thread_mutex);
436 Perl_croak_nocontext("detach on a thread with a waiter");
437 break;
438 case pthreads_st_run:
439 thread_join_data[tid].state = pthreads_st_detached;
440 MUTEX_UNLOCK(&start_thread_mutex);
441 break;
442 case pthreads_st_exited:
443 MUTEX_UNLOCK(&start_thread_mutex);
444 COND_SIGNAL(&thread_join_data[tid].cond);
445 break;
446 case pthreads_st_detached:
447 MUTEX_UNLOCK(&start_thread_mutex);
448 Perl_warn_nocontext("detach on an already detached thread");
449 break;
450 case pthreads_st_norun:
451 {
452 int state = (int)thread_join_data[tid].status;
453
454 thread_join_data[tid].state = pthreads_st_none;
455 MUTEX_UNLOCK(&start_thread_mutex);
456 Perl_croak_nocontext("panic: detaching thread which could not run"
457 " due to attempt of tid reuse (state='%s')",
458 pthreads_state_string(state));
459 break;
460 }
461 default:
462 MUTEX_UNLOCK(&start_thread_mutex);
463 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
464 pthreads_state_string(thread_join_data[tid].state));
465 break;
466 }
467 return 0;
468}
469
470/* This is a very bastardized version; may be OK due to edge trigger of Wait */
471int
472os2_cond_wait(perl_cond *c, perl_mutex *m)
473{
474 int rc;
475 STRLEN n_a;
476 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
622913ab 477 Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset");
5c728af0
IZ		 478 if (m) MUTEX_UNLOCK(m);
479 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
480 && (rc != ERROR_INTERRUPT))
622913ab 481 croak_with_os2error("panic: COND_WAIT");
5c728af0
IZ		 482 if (rc == ERROR_INTERRUPT)
483 errno = EINTR;
484 if (m) MUTEX_LOCK(m);
485 return 0;
486}
487#endif
488
764df951
IZ		 489static int exe_is_aout(void);
490
35bc1fdc
IZ		 491/* This should match enum entries_ordinals defined in os2ish.h. */
492static const struct {
622913ab 493 struct dll_handle_t *dll;
35bc1fdc
IZ		 494 const char *entryname;
495 int entrypoint;
622913ab 496} loadOrdinals[] = {
35bc1fdc
IZ		 497 {&doscalls_handle, NULL, 874}, /* DosQueryExtLibpath */
498 {&doscalls_handle, NULL, 873}, /* DosSetExtLibpath */
499 {&doscalls_handle, NULL, 460}, /* DosVerifyPidTid */
500 {&tcp_handle, "SETHOSTENT", 0},
501 {&tcp_handle, "SETNETENT" , 0},
502 {&tcp_handle, "SETPROTOENT", 0},
503 {&tcp_handle, "SETSERVENT", 0},
504 {&tcp_handle, "GETHOSTENT", 0},
505 {&tcp_handle, "GETNETENT" , 0},
506 {&tcp_handle, "GETPROTOENT", 0},
507 {&tcp_handle, "GETSERVENT", 0},
508 {&tcp_handle, "ENDHOSTENT", 0},
509 {&tcp_handle, "ENDNETENT", 0},
510 {&tcp_handle, "ENDPROTOENT", 0},
511 {&tcp_handle, "ENDSERVENT", 0},
512 {&pmwin_handle, NULL, 763}, /* WinInitialize */
513 {&pmwin_handle, NULL, 716}, /* WinCreateMsgQueue */
514 {&pmwin_handle, NULL, 726}, /* WinDestroyMsgQueue */
515 {&pmwin_handle, NULL, 918}, /* WinPeekMsg */
516 {&pmwin_handle, NULL, 915}, /* WinGetMsg */
517 {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */
518 {&pmwin_handle, NULL, 753}, /* WinGetLastError */
519 {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */
520 /* These are needed in extensions.
521 How to protect PMSHAPI: it comes through EMX functions? */
522 {&rexx_handle, "RexxStart", 0},
523 {&rexx_handle, "RexxVariablePool", 0},
524 {&rexxapi_handle, "RexxRegisterFunctionExe", 0},
525 {&rexxapi_handle, "RexxDeregisterFunction", 0},
526 {&sesmgr_handle, "DOSSMSETTITLE", 0}, /* Would not work runtime-loaded */
527 {&pmshapi_handle, "PRF32QUERYPROFILESIZE", 0},
528 {&pmshapi_handle, "PRF32OPENPROFILE", 0},
529 {&pmshapi_handle, "PRF32CLOSEPROFILE", 0},
530 {&pmshapi_handle, "PRF32QUERYPROFILE", 0},
531 {&pmshapi_handle, "PRF32RESET", 0},
532 {&pmshapi_handle, "PRF32QUERYPROFILEDATA", 0},
533 {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0},
534
535 /* At least some of these do not work by name, since they need
536 WIN32 instead of WIN... */
537#if 0
538 These were generated with
539 nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries
540 perl -wnle "next unless /^0+\s+E\s+_(\w+)=(\w+).(\d+)/; print qq( ORD_$1,)" API-list-entries > API-list-ORD_
541 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
542#endif
543 {&pmshapi_handle, NULL, 123}, /* WinChangeSwitchEntry */
544 {&pmshapi_handle, NULL, 124}, /* WinQuerySwitchEntry */
545 {&pmshapi_handle, NULL, 125}, /* WinQuerySwitchHandle */
546 {&pmshapi_handle, NULL, 126}, /* WinQuerySwitchList */
547 {&pmshapi_handle, NULL, 131}, /* WinSwitchToProgram */
548 {&pmwin_handle, NULL, 702}, /* WinBeginEnumWindows */
549 {&pmwin_handle, NULL, 737}, /* WinEndEnumWindows */
550 {&pmwin_handle, NULL, 740}, /* WinEnumDlgItem */
551 {&pmwin_handle, NULL, 756}, /* WinGetNextWindow */
552 {&pmwin_handle, NULL, 768}, /* WinIsChild */
553 {&pmwin_handle, NULL, 799}, /* WinQueryActiveWindow */
554 {&pmwin_handle, NULL, 805}, /* WinQueryClassName */
555 {&pmwin_handle, NULL, 817}, /* WinQueryFocus */
556 {&pmwin_handle, NULL, 834}, /* WinQueryWindow */
557 {&pmwin_handle, NULL, 837}, /* WinQueryWindowPos */
558 {&pmwin_handle, NULL, 838}, /* WinQueryWindowProcess */
559 {&pmwin_handle, NULL, 841}, /* WinQueryWindowText */
560 {&pmwin_handle, NULL, 842}, /* WinQueryWindowTextLength */
561 {&pmwin_handle, NULL, 860}, /* WinSetFocus */
562 {&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
563 {&pmwin_handle, NULL, 877}, /* WinSetWindowText */
564 {&pmwin_handle, NULL, 883}, /* WinShowWindow */
30500b05 565 {&pmwin_handle, NULL, 772}, /* WinIsWindow */
35bc1fdc
IZ		 566 {&pmwin_handle, NULL, 899}, /* WinWindowFromId */
567 {&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
568 {&pmwin_handle, NULL, 919}, /* WinPostMsg */
30500b05
IZ		 569 {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
570 {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
571 {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
572 {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
573 {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
574 {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
575 {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
576 {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
577 {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
578 {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
579 {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
580 {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
581 {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
582 {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
583 {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
622913ab
IZ		 584 {&doscalls_handle, NULL, 582}, /* Dos32QueryHeaderInfo */
585 {&doscalls_handle, NULL, 362}, /* DosTmrQueryFreq */
586 {&doscalls_handle, NULL, 363}, /* DosTmrQueryTime */
587 {&pmwp_handle, NULL, 262}, /* WinQueryActiveDesktopPathname */
588 {&pmwin_handle, NULL, 765}, /* WinInvalidateRect */
589 {&pmwin_handle, NULL, 906}, /* WinCreateFrameControl */
590 {&pmwin_handle, NULL, 807}, /* WinQueryClipbrdFmtInfo */
591 {&pmwin_handle, NULL, 808}, /* WinQueryClipbrdOwner */
592 {&pmwin_handle, NULL, 809}, /* WinQueryClipbrdViewer */
593 {&pmwin_handle, NULL, 806}, /* WinQueryClipbrdData */
594 {&pmwin_handle, NULL, 793}, /* WinOpenClipbrd */
595 {&pmwin_handle, NULL, 707}, /* WinCloseClipbrd */
596 {&pmwin_handle, NULL, 854}, /* WinSetClipbrdData */
597 {&pmwin_handle, NULL, 855}, /* WinSetClipbrdOwner */
598 {&pmwin_handle, NULL, 856}, /* WinSetClipbrdViewer */
599 {&pmwin_handle, NULL, 739}, /* WinEnumClipbrdFmts */
600 {&pmwin_handle, NULL, 733}, /* WinEmptyClipbrd */
601 {&pmwin_handle, NULL, 700}, /* WinAddAtom */
602 {&pmwin_handle, NULL, 744}, /* WinFindAtom */
603 {&pmwin_handle, NULL, 721}, /* WinDeleteAtom */
604 {&pmwin_handle, NULL, 803}, /* WinQueryAtomUsage */
605 {&pmwin_handle, NULL, 802}, /* WinQueryAtomName */
606 {&pmwin_handle, NULL, 801}, /* WinQueryAtomLength */
607 {&pmwin_handle, NULL, 830}, /* WinQuerySystemAtomTable */
608 {&pmwin_handle, NULL, 714}, /* WinCreateAtomTable */
609 {&pmwin_handle, NULL, 724}, /* WinDestroyAtomTable */
610 {&pmwin_handle, NULL, 794}, /* WinOpenWindowDC */
611 {&pmgpi_handle, NULL, 610}, /* DevOpenDC */
612 {&pmgpi_handle, NULL, 606}, /* DevQueryCaps */
613 {&pmgpi_handle, NULL, 604}, /* DevCloseDC */
614 {&pmwin_handle, NULL, 789}, /* WinMessageBox */
615 {&pmwin_handle, NULL, 1015}, /* WinMessageBox2 */
616 {&pmwin_handle, NULL, 829}, /* WinQuerySysValue */
617 {&pmwin_handle, NULL, 873}, /* WinSetSysValue */
618 {&pmwin_handle, NULL, 701}, /* WinAlarm */
619 {&pmwin_handle, NULL, 745}, /* WinFlashWindow */
620 {&pmwin_handle, NULL, 780}, /* WinLoadPointer */
621 {&pmwin_handle, NULL, 828}, /* WinQuerySysPointer */
d79a646b 622 {&doscalls_handle, NULL, 417}, /* DosReplaceModule */
59ad941d
IZ		 623 {&doscalls_handle, NULL, 976}, /* DosPerfSysCall */
624 {&rexxapi_handle, "RexxRegisterSubcomExe", 0},
35bc1fdc
IZ		 625};
626
5ba48348 627HMODULE
35bc1fdc 628loadModule(const char *modname, int fail)
5ba48348
JH		 629{
630 HMODULE h = (HMODULE)dlopen(modname, 0);
35bc1fdc
IZ		 631
632 if (!h && fail)
5ba48348
JH		 633 Perl_croak_nocontext("Error loading module '%s': %s",
634 modname, dlerror());
635 return h;
636}
637
622913ab
IZ		 638/* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
639
640static int
641my_type()
642{
643 int rc;
644 TIB *tib;
645 PIB *pib;
646
647 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
648 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
649 return -1;
650
651 return (pib->pib_ultype);
652}
653
654static void
655my_type_set(int type)
656{
657 int rc;
658 TIB *tib;
659 PIB *pib;
660
661 if (!(_emx_env & 0x200))
662 Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */
663 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
664 croak_with_os2error("Error getting info blocks");
665 pib->pib_ultype = type;
666}
667
35bc1fdc
IZ		 668PFN
669loadByOrdinal(enum entries_ordinals ord, int fail)
72ea3524 670{
622913ab
IZ		 671 if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES)
672 Perl_croak_nocontext(
673 "Wrong size of loadOrdinals array: expected %d, actual %d",
674 sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES);
72ea3524 675 if (ExtFCN[ord] == NULL) {
e71dd89f 676 PFN fcn = (PFN)-1;
72ea3524
IZ		 677 APIRET rc;
678
622913ab
IZ		 679 if (!loadOrdinals[ord].dll->handle) {
680 if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */
681 char *s = getenv("PERL_ASIF_PM");
682
683 if (!s || !atoi(s)) {
684 /* The module will not function well without PM.
685 The usual way to detect PM is the existence of the mutex
686 \SEM32\PMDRAG.SEM. */
687 HMTX hMtx = 0;
688
689 if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM",
690 &hMtx)))
691 Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}",
692 loadOrdinals[ord].dll->modname);
693 DosCloseMutexSem(hMtx);
694 }
695 }
696 MUTEX_LOCK(&perlos2_state_mutex);
35bc1fdc
IZ		 697 loadOrdinals[ord].dll->handle
698 = loadModule(loadOrdinals[ord].dll->modname, fail);
622913ab
IZ		 699 MUTEX_UNLOCK(&perlos2_state_mutex);
700 }
35bc1fdc
IZ		 701 if (!loadOrdinals[ord].dll->handle)
702 return 0; /* Possible with FAIL==0 only */
703 if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle,
704 loadOrdinals[ord].entrypoint,
705 loadOrdinals[ord].entryname,&fcn))) {
706 char buf[20], *s = (char*)loadOrdinals[ord].entryname;
707
708 if (!fail)
709 return 0;
710 if (!s)
711 sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint);
e71dd89f 712 Perl_croak_nocontext(
35bc1fdc
IZ		 713 "This version of OS/2 does not support %s.%s",
714 loadOrdinals[ord].dll->modname, s);
715 }
72ea3524
IZ		 716 ExtFCN[ord] = fcn;
717 }
35bc1fdc 718 if ((long)ExtFCN[ord] == -1)
23da6c43 719 Perl_croak_nocontext("panic queryaddr");
35bc1fdc 720 return ExtFCN[ord];
72ea3524
IZ		 721}
722
4bfbfac5
IZ		 723void
724init_PMWIN_entries(void)
725{
35bc1fdc
IZ		 726 int i;
727
728 for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++)
729 ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1);
4bfbfac5
IZ		 730}
731
35bc1fdc
IZ		 732/*****************************************************/
733/* socket forwarders without linking with tcpip DLLs */
734
735DeclFuncByORD(struct hostent *, gethostent, ORD_GETHOSTENT, (void), ())
736DeclFuncByORD(struct netent *, getnetent, ORD_GETNETENT, (void), ())
737DeclFuncByORD(struct protoent *, getprotoent, ORD_GETPROTOENT, (void), ())
738DeclFuncByORD(struct servent *, getservent, ORD_GETSERVENT, (void), ())
739
740DeclVoidFuncByORD(sethostent, ORD_SETHOSTENT, (int x), (x))
741DeclVoidFuncByORD(setnetent, ORD_SETNETENT, (int x), (x))
742DeclVoidFuncByORD(setprotoent, ORD_SETPROTOENT, (int x), (x))
743DeclVoidFuncByORD(setservent, ORD_SETSERVENT, (int x), (x))
744
745DeclVoidFuncByORD(endhostent, ORD_ENDHOSTENT, (void), ())
746DeclVoidFuncByORD(endnetent, ORD_ENDNETENT, (void), ())
747DeclVoidFuncByORD(endprotoent, ORD_ENDPROTOENT, (void), ())
748DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ())
4bfbfac5 749
4633a7c4 750/* priorities */
622913ab
IZ		 751static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
752 self inverse. */
6f064249 753#define QSS_INI_BUFFER 1024
4633a7c4 754
35bc1fdc 755ULONG (*pDosVerifyPidTid) (PID pid, TID tid);
35bc1fdc 756
6f064249 757PQTOPLEVEL
758get_sysinfo(ULONG pid, ULONG flags)
4633a7c4 759{
6f064249 760 char *pbuffer;
761 ULONG rc, buf_len = QSS_INI_BUFFER;
35bc1fdc 762 PQTOPLEVEL psi;
6f064249 763
59ad941d
IZ		 764 if (pid) {
765 if (!pidtid_lookup) {
766 pidtid_lookup = 1;
767 *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0);
768 }
769 if (pDosVerifyPidTid) { /* Warp3 or later */
770 /* Up to some fixpak QuerySysState() kills the system if a non-existent
771 pid is used. */
772 if (CheckOSError(pDosVerifyPidTid(pid, 1)))
773 return 0;
774 }
35bc1fdc 775 }
fc36a67e 776 New(1322, pbuffer, buf_len, char);
6f064249 777 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
778 rc = QuerySysState(flags, pid, pbuffer, buf_len);
779 while (rc == ERROR_BUFFER_OVERFLOW) {
780 Renew(pbuffer, buf_len *= 2, char);
df3ef7a9 781 rc = QuerySysState(flags, pid, pbuffer, buf_len);
6f064249 782 }
783 if (rc) {
784 FillOSError(rc);
785 Safefree(pbuffer);
786 return 0;
787 }
35bc1fdc 788 psi = (PQTOPLEVEL)pbuffer;
bad9d6ae 789 if (psi && pid && psi->procdata && pid != psi->procdata->pid) {
35bc1fdc
IZ		 790 Safefree(psi);
791 Perl_croak_nocontext("panic: wrong pid in sysinfo");
792 }
793 return psi;
6f064249 794}
795
796#define PRIO_ERR 0x1111
797
798static ULONG
799sys_prio(pid)
800{
801 ULONG prio;
802 PQTOPLEVEL psi;
803
35bc1fdc
IZ		 804 if (!pid)
805 return PRIO_ERR;
6f064249 806 psi = get_sysinfo(pid, QSS_PROCESS);
35bc1fdc 807 if (!psi)
6f064249 808 return PRIO_ERR;
6f064249 809 prio = psi->procdata->threads->priority;
810 Safefree(psi);
811 return prio;
812}
813
814int
815setpriority(int which, int pid, int val)
816{
2d766320 817 ULONG rc, prio = sys_prio(pid);
6f064249 818
55497cff 819 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 820 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
821 /* Do not change class. */
822 return CheckOSError(DosSetPriority((pid < 0)
823 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
824 0,
825 (32 - val) % 32 - (prio & 0xFF),
826 abs(pid)))
827 ? -1 : 0;
828 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
829 /* Documentation claims one can change both class and basevalue,
830 * but I find it wrong. */
831 /* Change class, but since delta == 0 denotes absolute 0, correct. */
832 if (CheckOSError(DosSetPriority((pid < 0)
833 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
834 priors[(32 - val) >> 5] + 1,
835 0,
836 abs(pid))))
837 return -1;
838 if ( ((32 - val) % 32) == 0 ) return 0;
839 return CheckOSError(DosSetPriority((pid < 0)
840 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
841 0,
842 (32 - val) % 32,
843 abs(pid)))
844 ? -1 : 0;
845 }
4633a7c4
LW		 846}
847
6f064249 848int
849getpriority(int which /* ignored */, int pid)
4633a7c4 850{
2d766320 851 ULONG ret;
6f064249 852
55497cff 853 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
6f064249 854 ret = sys_prio(pid);
855 if (ret == PRIO_ERR) {
856 return -1;
857 }
6f064249 858 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
4633a7c4
LW		 859}
860
861/*****************************************************************************/
862/* spawn */
2c2e0e8c 863
764df951 864
2c2e0e8c
IZ		 865
866static Signal_t
867spawn_sighandler(int sig)
868{
869 /* Some programs do not arrange for the keyboard signals to be
870 delivered to them. We need to deliver the signal manually. */
871 /* We may get a signal only if
872 a) kid does not receive keyboard signal: deliver it;
873 b) kid already died, and we get a signal. We may only hope
874 that the pid number was not reused.
875 */
876
877 if (spawn_killed)
878 sig = SIGKILL; /* Try harder. */
879 kill(spawn_pid, sig);
880 spawn_killed = 1;
881}
72ea3524 882
4633a7c4 883static int
23da6c43 884result(pTHX_ int flag, int pid)
4633a7c4
LW		 885{
886 int r, status;
887 Signal_t (*ihand)(); /* place to save signal during system() */
888 Signal_t (*qhand)(); /* place to save signal during system() */
760ac839
LW		 889#ifndef __EMX__
890 RESULTCODES res;
891 int rpid;
892#endif
4633a7c4 893
760ac839 894 if (pid < 0 || flag != 0)
4633a7c4
LW		 895 return pid;
896
760ac839 897#ifdef __EMX__
2c2e0e8c
IZ		 898 spawn_pid = pid;
899 spawn_killed = 0;
900 ihand = rsignal(SIGINT, &spawn_sighandler);
901 qhand = rsignal(SIGQUIT, &spawn_sighandler);
c0c09dfd 902 do {
903 r = wait4pid(pid, &status, 0);
904 } while (r == -1 && errno == EINTR);
72ea3524
IZ		 905 rsignal(SIGINT, ihand);
906 rsignal(SIGQUIT, qhand);
4633a7c4 907
6b88bc9c 908 PL_statusvalue = (U16)status;
4633a7c4
LW		 909 if (r < 0)
910 return -1;
911 return status & 0xFFFF;
760ac839 912#else
72ea3524 913 ihand = rsignal(SIGINT, SIG_IGN);
760ac839 914 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
72ea3524 915 rsignal(SIGINT, ihand);
6b88bc9c 916 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
760ac839
LW		 917 if (r)
918 return -1;
6b88bc9c 919 return PL_statusvalue;
760ac839 920#endif
4633a7c4
LW		 921}
922
764df951
IZ		 923enum execf_t {
924 EXECF_SPAWN,
925 EXECF_EXEC,
926 EXECF_TRUEEXEC,
927 EXECF_SPAWN_NOWAIT,
928 EXECF_SPAWN_BYFLAG,
929 EXECF_SYNC
930};
491527d0 931
017f25f1
IZ		 932static ULONG
933file_type(char *path)
934{
935 int rc;
936 ULONG apptype;
937
938 if (!(_emx_env & 0x200))
23da6c43 939 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
017f25f1
IZ		 940 if (CheckOSError(DosQueryAppType(path, &apptype))) {
941 switch (rc) {
942 case ERROR_FILE_NOT_FOUND:
943 case ERROR_PATH_NOT_FOUND:
944 return -1;
945 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
946 return -3;
947 default: /* Found, but not an
948 executable, or some other
949 read error. */
950 return -2;
951 }
952 }
953 return apptype;
954}
955
491527d0 956/* Spawn/exec a program, revert to shell if needed. */
6b88bc9c 957/* global PL_Argv[] contains arguments. */
491527d0 958
764df951
IZ		 959extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
960 EXCEPTIONREGISTRATIONRECORD *,
961 CONTEXTRECORD *,
962 void *);
963
4633a7c4 964int
23da6c43 965do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
4633a7c4 966{
491527d0 967 int trueflag = flag;
a97be121 968 int rc, pass = 1;
622913ab
IZ		 969 char *real_name;
970 char const * args[4];
971 static const char * const fargs[4]
491527d0 972 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
622913ab 973 const char * const *argsp = fargs;
2d766320 974 int nargs = 4;
017f25f1 975 int force_shell;
65850d11 976 int new_stderr = -1, nostderr = 0;
2d766320 977 int fl_stderr = 0;
2d8e6c8d 978 STRLEN n_a;
1c46958a
IZ		 979 char *buf;
980 PerlIO *file;
491527d0 981
4633a7c4
LW		 982 if (flag == P_WAIT)
983 flag = P_NOWAIT;
622913ab
IZ		 984 if (really && !*(real_name = SvPV(really, n_a)))
985 really = Nullsv;
4633a7c4 986
491527d0 987 retry:
6b88bc9c
GS		 988 if (strEQ(PL_Argv[0],"/bin/sh"))
989 PL_Argv[0] = PL_sh_path;
3bbf9c2b 990
760ac839 991 /* We should check PERL_SH* and PERLLIB_* as well? */
622913ab
IZ		 992 if (!really || pass >= 2)
993 real_name = PL_Argv[0];
994 if (real_name[0] != '/' && real_name[0] != '\\'
995 && !(real_name[0] && real_name[1] == ':'
996 && (real_name[2] == '/' || real_name[2] != '\\'))
dfcfdb64
IZ		 997 ) /* will spawnvp use PATH? */
998 TAINT_ENV(); /* testing IFS here is overkill, probably */
017f25f1
IZ		 999
1000 reread:
1001 force_shell = 0;
1002 if (_emx_env & 0x200) { /* OS/2. */
622913ab 1003 int type = file_type(real_name);
017f25f1
IZ		 1004 type_again:
1005 if (type == -1) { /* Not found */
1006 errno = ENOENT;
1007 rc = -1;
1008 goto do_script;
1009 }
1010 else if (type == -2) { /* Not an EXE */
1011 errno = ENOEXEC;
1012 rc = -1;
1013 goto do_script;
1014 }
1015 else if (type == -3) { /* Is a directory? */
1016 /* Special-case this */
1017 char tbuf[512];
622913ab 1018 int l = strlen(real_name);
017f25f1
IZ		 1019
1020 if (l + 5 <= sizeof tbuf) {
622913ab 1021 strcpy(tbuf, real_name);
017f25f1
IZ		 1022 strcpy(tbuf + l, ".exe");
1023 type = file_type(tbuf);
1024 if (type >= -3)
1025 goto type_again;
1026 }
1027
1028 errno = ENOEXEC;
1029 rc = -1;
1030 goto do_script;
1031 }
1032 switch (type & 7) {
1033 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1034 case FAPPTYP_WINDOWAPI:
622913ab 1035 { /* Apparently, kids are started basing on startup type, not the morphed type */
017f25f1
IZ		 1036 if (os2_mytype != 3) { /* not PM */
1037 if (flag == P_NOWAIT)
1038 flag = P_PM;
622913ab 1039 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
f98bc0c6 1040 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
017f25f1
IZ		 1041 flag, os2_mytype);
1042 }
1043 }
1044 break;
1045 case FAPPTYP_NOTWINDOWCOMPAT:
1046 {
1047 if (os2_mytype != 0) { /* not full screen */
1048 if (flag == P_NOWAIT)
1049 flag = P_SESSION;
622913ab 1050 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
f98bc0c6 1051 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
017f25f1
IZ		 1052 flag, os2_mytype);
1053 }
1054 }
1055 break;
1056 case FAPPTYP_NOTSPEC:
1057 /* Let the shell handle this... */
1058 force_shell = 1;
1c46958a
IZ		 1059 buf = ""; /* Pacify a warning */
1060 file = 0; /* Pacify a warning */
017f25f1
IZ		 1061 goto doshell_args;
1062 break;
1063 }
1064 }
1065
5838269b
IZ		 1066 if (addflag) {
1067 addflag = 0;
1068 new_stderr = dup(2); /* Preserve stderr */
1069 if (new_stderr == -1) {
1070 if (errno == EBADF)
1071 nostderr = 1;
1072 else {
1073 rc = -1;
1074 goto finish;
1075 }
1076 } else
1077 fl_stderr = fcntl(2, F_GETFD);
1078 rc = dup2(1,2);
1079 if (rc == -1)
1080 goto finish;
1081 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1082 }
1083
491527d0 1084#if 0
622913ab 1085 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
491527d0
GS		 1086#else
1087 if (execf == EXECF_TRUEEXEC)
622913ab 1088 rc = execvp(real_name,PL_Argv);
491527d0 1089 else if (execf == EXECF_EXEC)
622913ab 1090 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
491527d0 1091 else if (execf == EXECF_SPAWN_NOWAIT)
622913ab 1092 rc = spawnvp(flag,real_name,PL_Argv);
764df951 1093 else if (execf == EXECF_SYNC)
622913ab 1094 rc = spawnvp(trueflag,real_name,PL_Argv);
4435c477 1095 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
23da6c43 1096 rc = result(aTHX_ trueflag,
622913ab 1097 spawnvp(flag,real_name,PL_Argv));
491527d0 1098#endif
622913ab 1099 if (rc < 0 && pass == 1) {
017f25f1 1100 do_script:
622913ab 1101 if (real_name == PL_Argv[0]) {
a97be121
IZ		 1102 int err = errno;
1103
2c2e0e8c
IZ		 1104 if (err == ENOENT || err == ENOEXEC) {
1105 /* No such file, or is a script. */
1106 /* Try adding script extensions to the file name, and
1107 search on PATH. */
6b88bc9c 1108 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
2c2e0e8c
IZ		 1109
1110 if (scr) {
1c46958a
IZ		 1111 char *s = 0, *s1;
1112 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1113 SV *bufsv = sv_newmortal();
2c2e0e8c 1114
e96326af 1115 Safefree(scr);
1c46958a 1116 scr = SvPV(scrsv, n_a); /* free()ed later */
e96326af 1117
a03d92b2 1118 file = PerlIO_open(scr, "r");
6b88bc9c 1119 PL_Argv[0] = scr;
2c2e0e8c
IZ		 1120 if (!file)
1121 goto panic_file;
017f25f1 1122
1c46958a
IZ		 1123 buf = sv_gets(bufsv, file, 0 /* No append */);
1124 if (!buf)
1125 buf = ""; /* XXX Needed? */
1126 if (!buf[0]) { /* Empty... */
a03d92b2 1127 PerlIO_close(file);
017f25f1
IZ		 1128 /* Special case: maybe from -Zexe build, so
1129 there is an executable around (contrary to
1130 documentation, DosQueryAppType sometimes (?)
1131 does not append ".exe", so we could have
1132 reached this place). */
1c46958a 1133 sv_catpv(scrsv, ".exe");
59ad941d 1134 PL_Argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
1c46958a
IZ		 1135 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
1136 && !S_ISDIR(PL_statbuf.st_mode)) { /* Found */
622913ab 1137 real_name = scr;
017f25f1
IZ		 1138 pass++;
1139 goto reread;
1c46958a
IZ		 1140 } else { /* Restore */
1141 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1142 *SvEND(scrsv) = 0;
1143 }
2c2e0e8c 1144 }
a03d92b2 1145 if (PerlIO_close(file) != 0) { /* Failure */
2c2e0e8c 1146 panic_file:
622913ab
IZ		 1147 if (ckWARN(WARN_EXEC))
1148 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
2c2e0e8c 1149 scr, Strerror(errno));
1c46958a 1150 buf = ""; /* Not #! */
2c2e0e8c
IZ		 1151 goto doshell_args;
1152 }
1153 if (buf[0] == '#') {
1154 if (buf[1] == '!')
1155 s = buf + 2;
1156 } else if (buf[0] == 'e') {
1157 if (strnEQ(buf, "extproc", 7)
1158 && isSPACE(buf[7]))
1159 s = buf + 8;
1160 } else if (buf[0] == 'E') {
1161 if (strnEQ(buf, "EXTPROC", 7)
1162 && isSPACE(buf[7]))
1163 s = buf + 8;
1164 }
1165 if (!s) {
1c46958a 1166 buf = ""; /* Not #! */
2c2e0e8c
IZ		 1167 goto doshell_args;
1168 }
1169
1170 s1 = s;
1171 nargs = 0;
1172 argsp = args;
1173 while (1) {
1174 /* Do better than pdksh: allow a few args,
1175 strip trailing whitespace. */
1176 while (isSPACE(*s))
1177 s++;
1178 if (*s == 0)
1179 break;
1180 if (nargs == 4) {
1181 nargs = -1;
1182 break;
1183 }
1184 args[nargs++] = s;
1185 while (*s && !isSPACE(*s))
1186 s++;
1187 if (*s == 0)
1188 break;
1189 *s++ = 0;
1190 }
1191 if (nargs == -1) {
f98bc0c6 1192 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
2c2e0e8c
IZ		 1193 s1 - buf, buf, scr);
1194 nargs = 4;
1195 argsp = fargs;
1196 }
1c46958a 1197 /* Can jump from far, buf/file invalid if force_shell: */
2c2e0e8c
IZ		 1198 doshell_args:
1199 {
6b88bc9c 1200 char **a = PL_Argv;
622913ab 1201 const char *exec_args[2];
2c2e0e8c 1202
017f25f1
IZ		 1203 if (force_shell
1204 || (!buf[0] && file)) { /* File without magic */
2c2e0e8c
IZ		 1205 /* In fact we tried all what pdksh would
1206 try. There is no point in calling
1207 pdksh, we may just emulate its logic. */
1208 char *shell = getenv("EXECSHELL");
1209 char *shell_opt = NULL;
1210
1211 if (!shell) {
1212 char *s;
1213
1214 shell_opt = "/c";
1215 shell = getenv("OS2_SHELL");
1216 if (inicmd) { /* No spaces at start! */
1217 s = inicmd;
1218 while (*s && !isSPACE(*s)) {
2d766320 1219 if (*s++ == '/') {
2c2e0e8c
IZ		 1220 inicmd = NULL; /* Cannot use */
1221 break;
1222 }
1223 }
1224 }
1225 if (!inicmd) {
6b88bc9c 1226 s = PL_Argv[0];
2c2e0e8c
IZ		 1227 while (*s) {
1228 /* Dosish shells will choke on slashes
1229 in paths, fortunately, this is
1230 important for zeroth arg only. */
1231 if (*s == '/')
1232 *s = '\\';
1233 s++;
1234 }
491527d0 1235 }
491527d0 1236 }
2c2e0e8c
IZ		 1237 /* If EXECSHELL is set, we do not set */
1238
1239 if (!shell)
1240 shell = ((_emx_env & 0x200)
1241 ? "c:/os2/cmd.exe"
1242 : "c:/command.com");
1243 nargs = shell_opt ? 2 : 1; /* shell file args */
1244 exec_args[0] = shell;
1245 exec_args[1] = shell_opt;
1246 argsp = exec_args;
1247 if (nargs == 2 && inicmd) {
1248 /* Use the original cmd line */
1249 /* XXXX This is good only until we refuse
1250 quoted arguments... */
6b88bc9c
GS		 1251 PL_Argv[0] = inicmd;
1252 PL_Argv[1] = Nullch;
491527d0 1253 }
2c2e0e8c
IZ		 1254 } else if (!buf[0] && inicmd) { /* No file */
1255 /* Start with the original cmdline. */
1256 /* XXXX This is good only until we refuse
1257 quoted arguments... */
1258
6b88bc9c
GS		 1259 PL_Argv[0] = inicmd;
1260 PL_Argv[1] = Nullch;
2c2e0e8c
IZ		 1261 nargs = 2; /* shell -c */
1262 }
1263
1264 while (a[1]) /* Get to the end */
1265 a++;
1266 a++; /* Copy finil NULL too */
6b88bc9c
GS		 1267 while (a >= PL_Argv) {
1268 *(a + nargs) = *a; /* PL_Argv was preallocated to be
2c2e0e8c
IZ		 1269 long enough. */
1270 a--;
491527d0 1271 }
622913ab
IZ		 1272 while (--nargs >= 0) /* XXXX Discard const... */
1273 PL_Argv[nargs] = (char*)argsp[nargs];
2c2e0e8c
IZ		 1274 /* Enable pathless exec if #! (as pdksh). */
1275 pass = (buf[0] == '#' ? 2 : 3);
1276 goto retry;
e29f6e02
IZ		 1277 }
1278 }
2c2e0e8c 1279 /* Not found: restore errno */
491527d0 1280 errno = err;
2c2e0e8c 1281 }
622913ab
IZ		 1282 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1283 if (rc < 0 && ckWARN(WARN_EXEC))
1284 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1285 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1286 ? "spawn" : "exec"),
1287 real_name, PL_Argv[0]);
1288 goto warned;
1289 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1290 if (rc < 0 && ckWARN(WARN_EXEC))
1291 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1292 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1293 ? "spawn" : "exec"),
1294 real_name, PL_Argv[0]);
1295 goto warned;
017f25f1 1296 }
a97be121 1297 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
6b88bc9c 1298 char *no_dir = strrchr(PL_Argv[0], '/');
2c2e0e8c
IZ		 1299
1300 /* Do as pdksh port does: if not found with /, try without
1301 path. */
1302 if (no_dir) {
6b88bc9c 1303 PL_Argv[0] = no_dir + 1;
2c2e0e8c 1304 pass++;
e29f6e02
IZ		 1305 goto retry;
1306 }
1307 }
0453d815 1308 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1309 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
491527d0
GS		 1310 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1311 ? "spawn" : "exec"),
622913ab
IZ		 1312 real_name, Strerror(errno));
1313 warned:
491527d0
GS		 1314 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1315 && ((trueflag & 0xFF) == P_WAIT))
ed344e4f 1316 rc = -1;
491527d0 1317
5838269b
IZ		 1318 finish:
1319 if (new_stderr != -1) { /* How can we use error codes? */
1320 dup2(new_stderr, 2);
1321 close(new_stderr);
1322 fcntl(2, F_SETFD, fl_stderr);
1323 } else if (nostderr)
1324 close(2);
491527d0
GS		 1325 return rc;
1326}
1327
491527d0 1328/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
4633a7c4 1329int
23da6c43 1330do_spawn3(pTHX_ char *cmd, int execf, int flag)
4633a7c4
LW		 1331{
1332 register char **a;
1333 register char *s;
3bbf9c2b 1334 char *shell, *copt, *news = NULL;
2d766320 1335 int rc, seenspace = 0, mergestderr = 0;
4633a7c4 1336
c0c09dfd 1337#ifdef TRYSHELL
1338 if ((shell = getenv("EMXSHELL")) != NULL)
1339 copt = "-c";
1340 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4
LW		 1341 copt = "-c";
1342 else if ((shell = getenv("COMSPEC")) != NULL)
1343 copt = "/C";
1344 else
1345 shell = "cmd.exe";
c0c09dfd 1346#else
1347 /* Consensus on perl5-porters is that it is _very_ important to
1348 have a shell which will not change between computers with the
1349 same architecture, to avoid "action on a distance".
1350 And to have simple build, this shell should be sh. */
6b88bc9c 1351 shell = PL_sh_path;
c0c09dfd 1352 copt = "-c";
1353#endif
1354
1355 while (*cmd && isSPACE(*cmd))
1356 cmd++;
4633a7c4 1357
3bbf9c2b 1358 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
6b88bc9c 1359 STRLEN l = strlen(PL_sh_path);
3bbf9c2b 1360
2cc2f81f 1361 New(1302, news, strlen(cmd) - 7 + l + 1, char);
6b88bc9c 1362 strcpy(news, PL_sh_path);
3bbf9c2b
IZ		 1363 strcpy(news + l, cmd + 7);
1364 cmd = news;
1365 }
1366
4633a7c4
LW		 1367 /* save an extra exec if possible */
1368 /* see if there are shell metacharacters in it */
1369
c0c09dfd 1370 if (*cmd == '.' && isSPACE(cmd[1]))
1371 goto doshell;
1372
1373 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1374 goto doshell;
1375
1376 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1377 if (*s == '=')
1378 goto doshell;
1379
4633a7c4 1380 for (s = cmd; *s; s++) {
c0c09dfd 1381 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 1382 if (*s == '\n' && s[1] == '\0') {
4633a7c4
LW		 1383 *s = '\0';
1384 break;
a0914d8e
IZ		 1385 } else if (*s == '\\' && !seenspace) {
1386 continue; /* Allow backslashes in names */
5838269b
IZ		 1387 } else if (*s == '>' && s >= cmd + 3
1388 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1389 && isSPACE(s[-2]) ) {
1390 char *t = s + 3;
1391
1392 while (*t && isSPACE(*t))
1393 t++;
1394 if (!*t) {
1395 s[-2] = '\0';
1396 mergestderr = 1;
1397 break; /* Allow 2>&1 as the last thing */
1398 }
4633a7c4 1399 }
491527d0
GS		 1400 /* We do not convert this to do_spawn_ve since shell
1401 should be smart enough to start itself gloriously. */
c0c09dfd 1402 doshell:
760ac839 1403 if (execf == EXECF_TRUEEXEC)
764df951 1404 rc = execl(shell,shell,copt,cmd,(char*)0);
760ac839 1405 else if (execf == EXECF_EXEC)
2c2e0e8c 1406 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 1407 else if (execf == EXECF_SPAWN_NOWAIT)
2c2e0e8c 1408 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
4435c477
IZ		 1409 else if (execf == EXECF_SPAWN_BYFLAG)
1410 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
2c2e0e8c
IZ		 1411 else {
1412 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
764df951
IZ		 1413 if (execf == EXECF_SYNC)
1414 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1415 else
1416 rc = result(aTHX_ P_WAIT,
1417 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
0453d815 1418 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1419 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
2c2e0e8c
IZ		 1420 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1421 shell, Strerror(errno));
ed344e4f
IZ		 1422 if (rc < 0)
1423 rc = -1;
2c2e0e8c
IZ		 1424 }
1425 if (news)
1426 Safefree(news);
c0c09dfd 1427 return rc;
a0914d8e
IZ		 1428 } else if (*s == ' ' || *s == '\t') {
1429 seenspace = 1;
4633a7c4
LW		 1430 }
1431 }
c0c09dfd 1432
491527d0 1433 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
6b88bc9c
GS		 1434 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
1435 PL_Cmd = savepvn(cmd, s-cmd);
1436 a = PL_Argv;
1437 for (s = PL_Cmd; *s;) {
4633a7c4
LW		 1438 while (*s && isSPACE(*s)) s++;
1439 if (*s)
1440 *(a++) = s;
1441 while (*s && !isSPACE(*s)) s++;
1442 if (*s)
1443 *s++ = '\0';
1444 }
1445 *a = Nullch;
6b88bc9c 1446 if (PL_Argv[0])
23da6c43 1447 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
491527d0 1448 else
4633a7c4 1449 rc = -1;
2c2e0e8c
IZ		 1450 if (news)
1451 Safefree(news);
4633a7c4
LW		 1452 do_execfree();
1453 return rc;
1454}
1455
622913ab 1456/* Array spawn/exec. */
4435c477 1457int
622913ab 1458os2_aspawn4(pTHX_ SV *really, register SV **vmark, register SV **vsp, int execing)
4435c477 1459{
2d766320
IZ		 1460 register SV **mark = (SV **)vmark;
1461 register SV **sp = (SV **)vsp;
4435c477
IZ		 1462 register char **a;
1463 int rc;
1464 int flag = P_WAIT, flag_set = 0;
1465 STRLEN n_a;
1466
1467 if (sp > mark) {
1468 New(1301,PL_Argv, sp - mark + 3, char*);
1469 a = PL_Argv;
1470
1471 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
1472 ++mark;
1473 flag = SvIVx(*mark);
1474 flag_set = 1;
1475
1476 }
1477
1478 while (++mark <= sp) {
1479 if (*mark)
1480 *a++ = SvPVx(*mark, n_a);
1481 else
1482 *a++ = "";
1483 }
1484 *a = Nullch;
1485
622913ab
IZ		 1486 if ( flag_set && (a == PL_Argv + 1)
1487 && !really && !execing ) { /* One arg? */
23da6c43 1488 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
4435c477 1489 } else
622913ab
IZ		 1490 rc = do_spawn_ve(aTHX_ really, flag,
1491 (execing ? EXECF_EXEC : EXECF_SPAWN), NULL, 0);
4435c477
IZ		 1492 } else
1493 rc = -1;
1494 do_execfree();
1495 return rc;
1496}
1497
622913ab
IZ		 1498/* Array spawn. */
1499int
1500os2_do_aspawn(pTHX_ SV *really, register SV **vmark, register SV **vsp)
1501{
1502 return os2_aspawn4(aTHX_ really, vmark, vsp, 0);
1503}
1504
1505/* Array exec. */
1506bool
1507Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1508{
1509 return os2_aspawn4(aTHX_ really, vmark, vsp, 1);
1510}
1511
760ac839 1512int
23da6c43 1513os2_do_spawn(pTHX_ char *cmd)
760ac839 1514{
23da6c43 1515 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
760ac839
LW		 1516}
1517
72ea3524 1518int
23da6c43 1519do_spawn_nowait(pTHX_ char *cmd)
72ea3524 1520{
23da6c43 1521 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524
IZ		 1522}
1523
760ac839 1524bool
23da6c43 1525Perl_do_exec(pTHX_ char *cmd)
760ac839 1526{
23da6c43 1527 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
017f25f1 1528 return FALSE;
760ac839
LW		 1529}
1530
1531bool
23da6c43 1532os2exec(pTHX_ char *cmd)
760ac839 1533{
23da6c43 1534 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
760ac839
LW		 1535}
1536
3bbf9c2b 1537PerlIO *
23da6c43 1538my_syspopen(pTHX_ char *cmd, char *mode)
c0c09dfd 1539{
72ea3524 1540#ifndef USE_POPEN
72ea3524
IZ		 1541 int p[2];
1542 register I32 this, that, newfd;
2d766320 1543 register I32 pid;
3bbf9c2b 1544 SV *sv;
2d766320 1545 int fh_fl = 0; /* Pacify the warning */
72ea3524 1546
72ea3524
IZ		 1547 /* `this' is what we use in the parent, `that' in the child. */
1548 this = (*mode == 'w');
1549 that = !this;
6b88bc9c 1550 if (PL_tainting) {
72ea3524
IZ		 1551 taint_env();
1552 taint_proper("Insecure %s%s", "EXEC");
1553 }
c2267164
IZ		 1554 if (pipe(p) < 0)
1555 return Nullfp;
72ea3524 1556 /* Now we need to spawn the child. */
5838269b
IZ		 1557 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1558 int new = dup(p[this]);
1559
1560 if (new == -1)
1561 goto closepipes;
1562 close(p[this]);
1563 p[this] = new;
1564 }
72ea3524 1565 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b
IZ		 1566 if (newfd == -1) {
1567 /* This cannot happen due to fh being bad after pipe(), since
1568 pipe() should have created fh 0 and 1 even if they were
1569 initially closed. But we closed p[this] before. */
1570 if (errno != EBADF) {
1571 closepipes:
1572 close(p[0]);
1573 close(p[1]);
1574 return Nullfp;
1575 }
1576 } else
1577 fh_fl = fcntl(*mode == 'r', F_GETFD);
1578 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
72ea3524
IZ		 1579 dup2(p[that], *mode == 'r');
1580 close(p[that]);
1581 }
1582 /* Where is `this' and newfd now? */
1583 fcntl(p[this], F_SETFD, FD_CLOEXEC);
5838269b
IZ		 1584 if (newfd != -1)
1585 fcntl(newfd, F_SETFD, FD_CLOEXEC);
23da6c43 1586 pid = do_spawn_nowait(aTHX_ cmd);
5838269b
IZ		 1587 if (newfd == -1)
1588 close(*mode == 'r'); /* It was closed initially */
1589 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524
IZ		 1590 dup2(newfd, *mode == 'r'); /* Return std* back. */
1591 close(newfd);
5838269b
IZ		 1592 fcntl(*mode == 'r', F_SETFD, fh_fl);
1593 } else
1594 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0
GS		 1595 if (p[that] == (*mode == 'r'))
1596 close(p[that]);
72ea3524
IZ		 1597 if (pid == -1) {
1598 close(p[this]);
5838269b 1599 return Nullfp;
72ea3524 1600 }
5838269b 1601 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524
IZ		 1602 dup2(p[this], p[that]);
1603 close(p[this]);
1604 p[this] = p[that];
1605 }
6b88bc9c 1606 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524
IZ		 1607 (void)SvUPGRADE(sv,SVt_IV);
1608 SvIVX(sv) = pid;
6b88bc9c 1609 PL_forkprocess = pid;
72ea3524 1610 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1611
72ea3524
IZ		 1612#else /* USE_POPEN */
1613
1614 PerlIO *res;
1615 SV *sv;
1616
1617# ifdef TRYSHELL
3bbf9c2b 1618 res = popen(cmd, mode);
72ea3524 1619# else
c0c09dfd 1620 char *shell = getenv("EMXSHELL");
3bbf9c2b 1621
6b88bc9c 1622 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 1623 res = popen(cmd, mode);
1624 my_setenv("EMXSHELL", shell);
72ea3524 1625# endif
6b88bc9c 1626 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
3bbf9c2b
IZ		 1627 (void)SvUPGRADE(sv,SVt_IV);
1628 SvIVX(sv) = -1; /* A cooky. */
1629 return res;
72ea3524
IZ		 1630
1631#endif /* USE_POPEN */
1632
c0c09dfd 1633}
1634
3bbf9c2b 1635/******************************************************************/
4633a7c4
LW		 1636
1637#ifndef HAS_FORK
1638int
1639fork(void)
1640{
23da6c43 1641 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
4633a7c4
LW		 1642 errno = EINVAL;
1643 return -1;
1644}
1645#endif
1646
3bbf9c2b 1647/*******************************************************************/
46e87256 1648/* not implemented in EMX 0.9d */
4633a7c4 1649
46e87256 1650char * ctermid(char *s) { return 0; }
eacfb5f1 1651
1652#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 1653void * ttyname(x) { return 0; }
eacfb5f1 1654#endif
4633a7c4 1655
760ac839
LW		 1656/*****************************************************************************/
1657/* not implemented in C Set++ */
1658
1659#ifndef __EMX__
1660int setuid(x) { errno = EINVAL; return -1; }
1661int setgid(x) { errno = EINVAL; return -1; }
1662#endif
4633a7c4
LW		 1663
1664/*****************************************************************************/
1665/* stat() hack for char/block device */
1666
1667#if OS2_STAT_HACK
1668
5c728af0
IZ		 1669enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1670 os2_stat_archived = 0x1000000, /* 0100000000 */
1671 os2_stat_hidden = 0x2000000, /* 0200000000 */
1672 os2_stat_system = 0x4000000, /* 0400000000 */
1673 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1674};
1675
1676#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1677
1678static void
1679massage_os2_attr(struct stat *st)
1680{
1681 if ( ((st->st_mode & S_IFMT) != S_IFREG
1682 && (st->st_mode & S_IFMT) != S_IFDIR)
1683 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1684 return;
1685
1686 if ( st->st_attr & FILE_ARCHIVED )
1687 st->st_mode |= (os2_stat_archived | os2_stat_force);
1688 if ( st->st_attr & FILE_HIDDEN )
1689 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1690 if ( st->st_attr & FILE_SYSTEM )
1691 st->st_mode |= (os2_stat_system | os2_stat_force);
1692}
1693
4633a7c4
LW		 1694 /* First attempt used DosQueryFSAttach which crashed the system when
1695 used with 5.001. Now just look for /dev/. */
4633a7c4 1696int
2d766320 1697os2_stat(const char *name, struct stat *st)
4633a7c4
LW		 1698{
1699 static int ino = SHRT_MAX;
5c728af0
IZ		 1700 STRLEN l = strlen(name);
1701
1702 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1703 || ( stricmp(name + 5, "con") != 0
1704 && stricmp(name + 5, "tty") != 0
1705 && stricmp(name + 5, "nul") != 0
1706 && stricmp(name + 5, "null") != 0) ) {
1707 int s = stat(name, st);
1708
1709 if (s)
1710 return s;
1711 massage_os2_attr(st);
1712 return 0;
1713 }
4633a7c4
LW		 1714
1715 memset(st, 0, sizeof *st);
1716 st->st_mode = S_IFCHR|0666;
622913ab 1717 MUTEX_LOCK(&perlos2_state_mutex);
4633a7c4 1718 st->st_ino = (ino-- & 0x7FFF);
622913ab 1719 MUTEX_UNLOCK(&perlos2_state_mutex);
4633a7c4
LW		 1720 st->st_nlink = 1;
1721 return 0;
1722}
1723
5c728af0
IZ		 1724int
1725os2_fstat(int handle, struct stat *st)
1726{
1727 int s = fstat(handle, st);
1728
1729 if (s)
1730 return s;
1731 massage_os2_attr(st);
1732 return 0;
1733}
1734
1735#undef chmod
1736int
1737os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1738{
1739 int attr, rc;
1740
1741 if (!(pmode & os2_stat_force))
1742 return chmod(name, pmode);
1743
1744 attr = __chmod (name, 0, 0); /* Get attributes */
1745 if (attr < 0)
1746 return -1;
1747 if (pmode & S_IWRITE)
1748 attr &= ~FILE_READONLY;
1749 else
1750 attr |= FILE_READONLY;
1751 /* New logic */
1752 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1753
1754 if ( pmode & os2_stat_archived )
1755 attr |= FILE_ARCHIVED;
1756 if ( pmode & os2_stat_hidden )
1757 attr |= FILE_HIDDEN;
1758 if ( pmode & os2_stat_system )
1759 attr |= FILE_SYSTEM;
1760
1761 rc = __chmod (name, 1, attr);
1762 if (rc >= 0) rc = 0;
1763 return rc;
1764}
1765
4633a7c4 1766#endif
c0c09dfd 1767
760ac839 1768#ifdef USE_PERL_SBRK
c0c09dfd 1769
760ac839 1770/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1771
1772void *
760ac839
LW		 1773sys_alloc(int size) {
1774 void *got;
1775 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1776
c0c09dfd 1777 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1778 return (void *) -1;
4bfbfac5 1779 } else if ( rc )
23da6c43 1780 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1781 return got;
c0c09dfd 1782}
760ac839
LW		 1783
1784#endif /* USE_PERL_SBRK */
c0c09dfd 1785
1786/* tmp path */
1787
622913ab 1788const char *tmppath = TMPPATH1;
c0c09dfd 1789
1790void
1791settmppath()
1792{
1793 char *p = getenv("TMP"), *tpath;
1794 int len;
1795
1796 if (!p) p = getenv("TEMP");
622913ab 1797 if (!p) p = getenv("TMPDIR");
c0c09dfd 1798 if (!p) return;
1799 len = strlen(p);
1800 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
db7c17d7
GS		 1801 if (tpath) {
1802 strcpy(tpath, p);
1803 tpath[len] = '/';
1804 strcpy(tpath + len + 1, TMPPATH1);
1805 tmppath = tpath;
1806 }
c0c09dfd 1807}
7a2f0d5b 1808
1809#include "XSUB.h"
1810
1811XS(XS_File__Copy_syscopy)
1812{
1813 dXSARGS;
1814 if (items < 2 || items > 3)
23da6c43 1815 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
7a2f0d5b 1816 {
2d8e6c8d
GS		 1817 STRLEN n_a;
1818 char * src = (char *)SvPV(ST(0),n_a);
1819 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 1820 U32 flag;
1821 int RETVAL, rc;
622913ab 1822 dXSTARG;
7a2f0d5b 1823
1824 if (items < 3)
1825 flag = 0;
1826 else {
1827 flag = (unsigned long)SvIV(ST(2));
1828 }
1829
6f064249 1830 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
622913ab 1831 XSprePUSH; PUSHi((IV)RETVAL);
7a2f0d5b 1832 }
1833 XSRETURN(1);
1834}
1835
d79a646b
JH		 1836/* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1837
1838DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1839 (char *old, char *new, char *backup), (old, new, backup))
1840
1841XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1842XS(XS_OS2_replaceModule)
1843{
1844 dXSARGS;
1845 if (items < 1 || items > 3)
1846 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1847 {
1848 char * target = (char *)SvPV_nolen(ST(0));
1849 char * source = (items < 2) ? Nullch : (char *)SvPV_nolen(ST(1));
1850 char * backup = (items < 3) ? Nullch : (char *)SvPV_nolen(ST(2));
1851
1852 if (!replaceModule(target, source, backup))
1853 croak_with_os2error("replaceModule() error");
1854 }
1855 XSRETURN_EMPTY;
1856}
1857
59ad941d
IZ		 1858/* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1859 ULONG ulParm2, ULONG ulParm3); */
1860
1861DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1862 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1863 (ulCommand, ulParm1, ulParm2, ulParm3))
1864
1865#ifndef CMD_KI_RDCNT
1866# define CMD_KI_RDCNT 0x63
1867#endif
1868#ifndef CMD_KI_GETQTY
1869# define CMD_KI_GETQTY 0x41
1870#endif
1871#ifndef QSV_NUMPROCESSORS
1872# define QSV_NUMPROCESSORS 26
1873#endif
1874
1875typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
1876
1877/*
1878NO_OUTPUT ULONG
1879perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1880 PREINIT:
1881 ULONG rc;
1882 POSTCALL:
1883 if (!RETVAL)
1884 croak_with_os2error("perfSysCall() error");
1885 */
1886
1887static int
1888numprocessors(void)
1889{
1890 ULONG res;
1891
1892 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1893 return 1; /* Old system? */
1894 return res;
1895}
1896
1897XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1898XS(XS_OS2_perfSysCall)
1899{
1900 dXSARGS;
1901 if (items < 0 || items > 4)
1902 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1903 SP -= items;
1904 {
1905 dXSTARG;
1906 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1907 myCPUUTIL u[64];
1908 int total = 0, tot2 = 0;
1909
1910 if (items < 1)
1911 ulCommand = CMD_KI_RDCNT;
1912 else {
1913 ulCommand = (ULONG)SvUV(ST(0));
1914 }
1915
1916 if (items < 2) {
1917 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1918 ulParm1 = (total ? (ULONG)u : 0);
1919
1920 if (total > C_ARRAY_LENGTH(u))
1921 croak("Unexpected number of processors: %d", total);
1922 } else {
1923 ulParm1 = (ULONG)SvUV(ST(1));
1924 }
1925
1926 if (items < 3) {
1927 tot2 = (ulCommand == CMD_KI_GETQTY);
1928 ulParm2 = (tot2 ? (ULONG)&res : 0);
1929 } else {
1930 ulParm2 = (ULONG)SvUV(ST(2));
1931 }
1932
1933 if (items < 4)
1934 ulParm3 = 0;
1935 else {
1936 ulParm3 = (ULONG)SvUV(ST(3));
1937 }
1938
1939 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1940 if (!RETVAL)
1941 croak_with_os2error("perfSysCall() error");
1942 if (total) {
1943 int i,j;
1944
1945 if (GIMME_V != G_ARRAY) {
1946 PUSHn(u[0][0]); /* Total ticks on the first processor */
1947 XSRETURN(1);
1948 }
1949 for (i=0; i < total; i++)
1950 for (j=0; j < 4; j++)
1951 PUSHs(sv_2mortal(newSVnv(u[i][j])));
1952 XSRETURN(4*total);
1953 }
1954 if (tot2) {
1955 PUSHu(res);
1956 XSRETURN(1);
1957 }
1958 }
1959 XSRETURN_EMPTY;
1960}
d79a646b 1961
1c46958a 1962#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
017f25f1 1963#include "patchlevel.h"
1c46958a 1964#undef PERL_PATCHLEVEL_H_IMPLICIT
017f25f1 1965
6f064249 1966char *
23da6c43 1967mod2fname(pTHX_ SV *sv)
6f064249 1968{
760ac839
LW		 1969 int pos = 6, len, avlen;
1970 unsigned int sum = 0;
6f064249 1971 char *s;
2d8e6c8d 1972 STRLEN n_a;
6f064249 1973
23da6c43 1974 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
6f064249 1975 sv = SvRV(sv);
1976 if (SvTYPE(sv) != SVt_PVAV)
23da6c43 1977 Perl_croak_nocontext("Not array reference given to mod2fname");
760ac839
LW		 1978
1979 avlen = av_len((AV*)sv);
1980 if (avlen < 0)
23da6c43 1981 Perl_croak_nocontext("Empty array reference given to mod2fname");
760ac839 1982
2d8e6c8d 1983 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 1984 strncpy(fname, s, 8);
760ac839
LW		 1985 len = strlen(s);
1986 if (len < 6) pos = len;
1987 while (*s) {
1988 sum = 33 * sum + *(s++); /* Checksumming first chars to
1989 * get the capitalization into c.s. */
1990 }
1991 avlen --;
1992 while (avlen >= 0) {
2d8e6c8d 1993 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839
LW		 1994 while (*s) {
1995 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1996 }
1997 avlen --;
1998 }
bea19d3f
IZ		 1999 /* We always load modules as *specific* DLLs, and with the full name.
2000 When loading a specific DLL by its full name, one cannot get a
2001 different DLL, even if a DLL with the same basename is loaded already.
2002 Thus there is no need to include the version into the mangling scheme. */
2003#if 0
2004 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
2005#else
2006# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
2007# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2008# endif
2009 sum += COMPATIBLE_VERSION_SUM;
2010#endif
760ac839
LW		 2011 fname[pos] = 'A' + (sum % 26);
2012 fname[pos + 1] = 'A' + (sum / 26 % 26);
2013 fname[pos + 2] = '\0';
6f064249 2014 return (char *)fname;
2015}
2016
2017XS(XS_DynaLoader_mod2fname)
2018{
2019 dXSARGS;
2020 if (items != 1)
23da6c43 2021 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
6f064249 2022 {
2023 SV * sv = ST(0);
2024 char * RETVAL;
622913ab 2025 dXSTARG;
6f064249 2026
23da6c43 2027 RETVAL = mod2fname(aTHX_ sv);
622913ab
IZ		 2028 sv_setpv(TARG, RETVAL);
2029 XSprePUSH; PUSHTARG;
6f064249 2030 }
2031 XSRETURN(1);
2032}
2033
2034char *
2035os2error(int rc)
2036{
5c728af0 2037 dTHX;
6f064249 2038 ULONG len;
9fed8b87
IZ		 2039 char *s;
2040 int number = SvTRUE(get_sv("OS2::nsyserror", TRUE));
6f064249 2041
55497cff 2042 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 2043 if (rc == 0)
9fed8b87
IZ		 2044 return "";
2045 if (number) {
622913ab
IZ		 2046 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2047 s = os2error_buf + strlen(os2error_buf);
9fed8b87 2048 } else
622913ab
IZ		 2049 s = os2error_buf;
2050 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
9fed8b87 2051 rc, "OSO001.MSG", &len)) {
622913ab
IZ		 2052 char *name = "";
2053
9fed8b87 2054 if (!number) {
622913ab
IZ		 2055 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2056 s = os2error_buf + strlen(os2error_buf);
9fed8b87 2057 }
622913ab
IZ		 2058 switch (rc) {
2059 case PMERR_INVALID_HWND:
2060 name = "PMERR_INVALID_HWND";
2061 break;
2062 case PMERR_INVALID_HMQ:
2063 name = "PMERR_INVALID_HMQ";
2064 break;
2065 case PMERR_CALL_FROM_WRONG_THREAD:
2066 name = "PMERR_CALL_FROM_WRONG_THREAD";
2067 break;
2068 case PMERR_NO_MSG_QUEUE:
2069 name = "PMERR_NO_MSG_QUEUE";
2070 break;
2071 case PMERR_NOT_IN_A_PM_SESSION:
2072 name = "PMERR_NOT_IN_A_PM_SESSION";
2073 break;
2074 }
2075 sprintf(s, "%s%s[No description found in OSO001.MSG]",
2076 name, (*name ? "=" : ""));
9fed8b87
IZ		 2077 } else {
2078 s[len] = '\0';
2079 if (len && s[len - 1] == '\n')
2080 s[--len] = 0;
2081 if (len && s[len - 1] == '\r')
2082 s[--len] = 0;
2083 if (len && s[len - 1] == '.')
2084 s[--len] = 0;
622913ab 2085 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
9fed8b87
IZ		 2086 && s[7] == ':' && s[8] == ' ')
2087 /* Some messages start with SYSdddd:, some not */
2088 Move(s + 9, s, (len -= 9) + 1, char);
ed344e4f 2089 }
622913ab 2090 return os2error_buf;
6f064249 2091}
2092
30500b05
IZ		 2093void
2094ResetWinError(void)
2095{
2096 WinError_2_Perl_rc;
2097}
2098
2099void
2100CroakWinError(int die, char *name)
2101{
2102 FillWinError;
5c728af0
IZ		 2103 if (die && Perl_rc) {
2104 dTHX;
2105
2106 Perl_croak(aTHX_ "%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
2107 }
30500b05
IZ		 2108}
2109
760ac839 2110char *
23da6c43 2111os2_execname(pTHX)
ed344e4f 2112{
5ba48348 2113 char buf[300], *p, *o = PL_origargv[0], ok = 1;
ed344e4f
IZ		 2114
2115 if (_execname(buf, sizeof buf) != 0)
5ba48348 2116 return o;
ed344e4f
IZ		 2117 p = buf;
2118 while (*p) {
2119 if (*p == '\\')
2120 *p = '/';
5ba48348
JH		 2121 if (*p == '/') {
2122 if (ok && *o != '/' && *o != '\\')
2123 ok = 0;
2124 } else if (ok && tolower(*o) != tolower(*p))
2125 ok = 0;
ed344e4f 2126 p++;
5ba48348
JH		 2127 o++;
2128 }
2129 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
2130 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
2131 p = buf;
2132 while (*p) {
2133 if (*p == '\\')
2134 *p = '/';
2135 p++;
2136 }
ed344e4f
IZ		 2137 }
2138 p = savepv(buf);
2139 SAVEFREEPV(p);
2140 return p;
2141}
2142
2143char *
760ac839
LW		 2144perllib_mangle(char *s, unsigned int l)
2145{
760ac839 2146 if (!newp && !notfound) {
622913ab
IZ		 2147 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2148 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2149 "_PREFIX");
2150 if (!newp)
2151 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION)
2152 STRINGIFY(PERL_VERSION) "_PREFIX");
2153 if (!newp)
2154 newp = getenv("PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
2155 if (!newp)
2156 newp = getenv("PERLLIB_PREFIX");
760ac839 2157 if (newp) {
ff68c719 2158 char *s;
2159
760ac839 2160 oldp = newp;
89078e0f 2161 while (*newp && !isSPACE(*newp) && *newp != ';') {
760ac839
LW		 2162 newp++; oldl++; /* Skip digits. */
2163 }
2164 while (*newp && (isSPACE(*newp) || *newp == ';')) {
2165 newp++; /* Skip whitespace. */
2166 }
2167 newl = strlen(newp);
2168 if (newl == 0 || oldl == 0) {
23da6c43 2169 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 2170 }
622913ab
IZ		 2171 strcpy(mangle_ret, newp);
2172 s = mangle_ret;
ff68c719 2173 while (*s) {
2174 if (*s == '\\') *s = '/';
2175 s++;
2176 }
760ac839
LW		 2177 } else {
2178 notfound = 1;
2179 }
2180 }
2181 if (!newp) {
2182 return s;
2183 }
2184 if (l == 0) {
2185 l = strlen(s);
2186 }
3bbf9c2b 2187 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
760ac839
LW		 2188 return s;
2189 }
2190 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
23da6c43 2191 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
760ac839 2192 }
622913ab
IZ		 2193 strcpy(mangle_ret + newl, s + oldl);
2194 return mangle_ret;
760ac839 2195}
6f064249 2196
4bfbfac5
IZ		 2197unsigned long
2198Perl_hab_GET() /* Needed if perl.h cannot be included */
2199{
2200 return perl_hab_GET();
2201}
2202
622913ab
IZ		 2203static void
2204Create_HMQ(int serve, char *message) /* Assumes morphing */
2205{
2206 unsigned fpflag = _control87(0,0);
2207
2208 init_PMWIN_entries();
2209 /* 64 messages if before OS/2 3.0, ignored otherwise */
2210 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2211 if (!Perl_hmq) {
2212 dTHX;
2213
2214 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2215 if (rmq_cnt++)
2216 _exit(188); /* Panic can try to create a window. */
2217 CroakWinError(1, message ? message : "Cannot create a message queue");
2218 }
2219 if (serve != -1)
2220 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2221 /* We may have loaded some modules */
2222 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2223}
2224
2225#define REGISTERMQ_WILL_SERVE 1
2226#define REGISTERMQ_IMEDIATE_UNMORPH 2
2227
4bfbfac5
IZ		 2228HMQ
2229Perl_Register_MQ(int serve)
2230{
8c4b3a79 2231 if (Perl_hmq_refcnt <= 0) {
4bfbfac5
IZ		 2232 PPIB pib;
2233 PTIB tib;
2234
30500b05 2235 Perl_hmq_refcnt = 0; /* Be extra safe */
4bfbfac5 2236 DosGetInfoBlocks(&tib, &pib);
622913ab
IZ		 2237 if (!Perl_morph_refcnt) {
2238 Perl_os2_initial_mode = pib->pib_ultype;
2239 /* Try morphing into a PM application. */
2240 if (pib->pib_ultype != 3) /* 2 is VIO */
2241 pib->pib_ultype = 3; /* 3 is PM */
2242 }
2243 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2244 "Cannot create a message queue, or morph to a PM application");
2245 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2246 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2247 pib->pib_ultype = Perl_os2_initial_mode;
4bfbfac5 2248 }
8c4b3a79 2249 }
622913ab 2250 if (serve & REGISTERMQ_WILL_SERVE) {
5ba48348
JH		 2251 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2252 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2253 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2254 Perl_hmq_servers++;
2255 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2256 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2257 Perl_hmq_refcnt++;
622913ab
IZ		 2258 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2259 Perl_morph_refcnt++;
4bfbfac5
IZ		 2260 return Perl_hmq;
2261}
2262
2263int
2264Perl_Serve_Messages(int force)
2265{
2266 int cnt = 0;
2267 QMSG msg;
2268
5ba48348 2269 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 2270 return 0;
5ba48348 2271 if (Perl_hmq_refcnt <= 0)
23da6c43 2272 Perl_croak_nocontext("No message queue");
4bfbfac5
IZ		 2273 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2274 cnt++;
2275 if (msg.msg == WM_QUIT)
23da6c43 2276 Perl_croak_nocontext("QUITing...");
4bfbfac5
IZ		 2277 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2278 }
2279 return cnt;
2280}
2281
2282int
2283Perl_Process_Messages(int force, I32 *cntp)
2284{
2285 QMSG msg;
2286
5ba48348 2287 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 2288 return 0;
5ba48348 2289 if (Perl_hmq_refcnt <= 0)
23da6c43 2290 Perl_croak_nocontext("No message queue");
4bfbfac5
IZ		 2291 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2292 if (cntp)
2293 (*cntp)++;
2294 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2295 if (msg.msg == WM_DESTROY)
2296 return -1;
2297 if (msg.msg == WM_CREATE)
2298 return +1;
2299 }
23da6c43 2300 Perl_croak_nocontext("QUITing...");
4bfbfac5
IZ		 2301}
2302
2303void
2304Perl_Deregister_MQ(int serve)
2305{
622913ab 2306 if (serve & REGISTERMQ_WILL_SERVE)
5ba48348 2307 Perl_hmq_servers--;
622913ab 2308
5ba48348 2309 if (--Perl_hmq_refcnt <= 0) {
622913ab
IZ		 2310 unsigned fpflag = _control87(0,0);
2311
5ba48348 2312 init_PMWIN_entries(); /* To be extra safe */
4bfbfac5
IZ		 2313 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2314 Perl_hmq = 0;
622913ab
IZ		 2315 /* We may have (un)loaded some modules */
2316 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2317 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2318 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2319 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
4bfbfac5 2320 /* Try morphing back from a PM application. */
622913ab
IZ		 2321 PPIB pib;
2322 PTIB tib;
2323
5ba48348 2324 DosGetInfoBlocks(&tib, &pib);
4bfbfac5
IZ		 2325 if (pib->pib_ultype == 3) /* 3 is PM */
2326 pib->pib_ultype = Perl_os2_initial_mode;
2327 else
23da6c43 2328 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
622913ab
IZ		 2329 pib->pib_ultype);
2330 }
4bfbfac5
IZ		 2331}
2332
3bbf9c2b
IZ		 2333#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2334 && ((path)[2] == '/' || (path)[2] == '\\'))
2335#define sys_is_rooted _fnisabs
2336#define sys_is_relative _fnisrel
2337#define current_drive _getdrive
2338
2339#undef chdir /* Was _chdir2. */
2340#define sys_chdir(p) (chdir(p) == 0)
2341#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2342
4bfbfac5
IZ		 2343XS(XS_OS2_Error)
2344{
2345 dXSARGS;
2346 if (items != 2)
23da6c43 2347 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
4bfbfac5
IZ		 2348 {
2349 int arg1 = SvIV(ST(0));
2350 int arg2 = SvIV(ST(1));
2351 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2352 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2353 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2354 unsigned long rc;
2355
2356 if (CheckOSError(DosError(a)))
622913ab 2357 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
4bfbfac5
IZ		 2358 ST(0) = sv_newmortal();
2359 if (DOS_harderr_state >= 0)
2360 sv_setiv(ST(0), DOS_harderr_state);
2361 DOS_harderr_state = RETVAL;
2362 }
2363 XSRETURN(1);
2364}
2365
4bfbfac5
IZ		 2366XS(XS_OS2_Errors2Drive)
2367{
2368 dXSARGS;
2369 if (items != 1)
23da6c43 2370 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
4bfbfac5 2371 {
2d8e6c8d 2372 STRLEN n_a;
4bfbfac5
IZ		 2373 SV *sv = ST(0);
2374 int suppress = SvOK(sv);
2d8e6c8d 2375 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5
IZ		 2376 char drive = (s ? *s : 0);
2377 unsigned long rc;
2378
2379 if (suppress && !isALPHA(drive))
23da6c43 2380 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
4bfbfac5
IZ		 2381 if (CheckOSError(DosSuppressPopUps((suppress
2382 ? SPU_ENABLESUPPRESSION
2383 : SPU_DISABLESUPPRESSION),
2384 drive)))
622913ab
IZ		 2385 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2386 os2error(Perl_rc));
4bfbfac5
IZ		 2387 ST(0) = sv_newmortal();
2388 if (DOS_suppression_state > 0)
2389 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2390 else if (DOS_suppression_state == 0)
2391 sv_setpvn(ST(0), "", 0);
2392 DOS_suppression_state = drive;
2393 }
2394 XSRETURN(1);
2395}
2396
622913ab
IZ		 2397ULONG (*pDosTmrQueryFreq) (PULONG);
2398ULONG (*pDosTmrQueryTime) (unsigned long long *);
2399
2400XS(XS_OS2_Timer)
2401{
2402 dXSARGS;
2403 static ULONG freq;
2404 unsigned long long count;
2405 ULONG rc;
2406
2407 if (items != 0)
2408 Perl_croak_nocontext("Usage: OS2::Timer()");
2409 if (!freq) {
2410 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2411 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2412 MUTEX_LOCK(&perlos2_state_mutex);
2413 if (!freq)
2414 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2415 croak_with_os2error("DosTmrQueryFreq");
2416 MUTEX_UNLOCK(&perlos2_state_mutex);
2417 }
2418 if (CheckOSError(pDosTmrQueryTime(&count)))
2419 croak_with_os2error("DosTmrQueryTime");
2420 {
2421 dXSTARG;
2422
2423 XSprePUSH; PUSHn(((NV)count)/freq);
2424 }
2425 XSRETURN(1);
2426}
2427
2428static const char * const dc_fields[] = {
2429 "FAMILY",
2430 "IO_CAPS",
2431 "TECHNOLOGY",
2432 "DRIVER_VERSION",
2433 "WIDTH",
2434 "HEIGHT",
2435 "WIDTH_IN_CHARS",
2436 "HEIGHT_IN_CHARS",
2437 "HORIZONTAL_RESOLUTION",
2438 "VERTICAL_RESOLUTION",
2439 "CHAR_WIDTH",
2440 "CHAR_HEIGHT",
2441 "SMALL_CHAR_WIDTH",
2442 "SMALL_CHAR_HEIGHT",
2443 "COLORS",
2444 "COLOR_PLANES",
2445 "COLOR_BITCOUNT",
2446 "COLOR_TABLE_SUPPORT",
2447 "MOUSE_BUTTONS",
2448 "FOREGROUND_MIX_SUPPORT",
2449 "BACKGROUND_MIX_SUPPORT",
2450 "VIO_LOADABLE_FONTS",
2451 "WINDOW_BYTE_ALIGNMENT",
2452 "BITMAP_FORMATS",
2453 "RASTER_CAPS",
2454 "MARKER_HEIGHT",
2455 "MARKER_WIDTH",
2456 "DEVICE_FONTS",
2457 "GRAPHICS_SUBSET",
2458 "GRAPHICS_VERSION",
2459 "GRAPHICS_VECTOR_SUBSET",
2460 "DEVICE_WINDOWING",
2461 "ADDITIONAL_GRAPHICS",
2462 "PHYS_COLORS",
2463 "COLOR_INDEX",
2464 "GRAPHICS_CHAR_WIDTH",
2465 "GRAPHICS_CHAR_HEIGHT",
2466 "HORIZONTAL_FONT_RES",
2467 "VERTICAL_FONT_RES",
2468 "DEVICE_FONT_SIM",
2469 "LINEWIDTH_THICK",
2470 "DEVICE_POLYSET_POINTS",
2471};
2472
2473enum {
2474 DevCap_dc, DevCap_hwnd
2475};
2476
2477HDC (*pWinOpenWindowDC) (HWND hwnd);
2478HMF (*pDevCloseDC) (HDC hdc);
2479HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2480 PDEVOPENDATA pdopData, HDC hdcComp);
2481BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2482
2483
2484XS(XS_OS2_DevCap)
2485{
2486 dXSARGS;
2487 if (items > 2)
2488 Perl_croak_nocontext("Usage: OS2::DevCap()");
2489 {
2490 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2491 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2492 int i = 0, j = 0, how = DevCap_dc;
2493 HDC hScreenDC;
2494 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2495 ULONG rc1 = NO_ERROR;
2496 HWND hwnd;
2497 static volatile int devcap_loaded;
2498
2499 if (!devcap_loaded) {
2500 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2501 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2502 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2503 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2504 devcap_loaded = 1;
2505 }
2506
2507 if (items >= 2)
2508 how = SvIV(ST(1));
2509 if (!items) { /* Get device contents from PM */
2510 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2511 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2512 if (CheckWinError(hScreenDC))
2513 croak_with_os2error("DevOpenDC() failed");
2514 } else if (how == DevCap_dc)
2515 hScreenDC = (HDC)SvIV(ST(0));
2516 else { /* DevCap_hwnd */
2517 if (!Perl_hmq)
2518 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2519 hwnd = (HWND)SvIV(ST(0));
2520 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2521 if (CheckWinError(hScreenDC))
2522 croak_with_os2error("WinOpenWindowDC() failed");
2523 }
2524 if (CheckWinError(pDevQueryCaps(hScreenDC,
2525 CAPS_FAMILY, /* W3 documented caps */
2526 CAPS_DEVICE_POLYSET_POINTS
2527 - CAPS_FAMILY + 1,
2528 si)))
2529 rc1 = Perl_rc;
2530 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2531 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2532 if (rc1)
2533 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
2534 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2535 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2536 ST(j) = sv_newmortal();
2537 sv_setpv(ST(j++), dc_fields[i]);
2538 ST(j) = sv_newmortal();
2539 sv_setiv(ST(j++), si[i]);
2540 i++;
2541 }
2542 }
2543 XSRETURN(2 * (CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2544}
2545
2546LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2547BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2548
2549const char * const sv_keys[] = {
2550 "SWAPBUTTON",
2551 "DBLCLKTIME",
2552 "CXDBLCLK",
2553 "CYDBLCLK",
2554 "CXSIZEBORDER",
2555 "CYSIZEBORDER",
2556 "ALARM",
2557 "7",
2558 "8",
2559 "CURSORRATE",
2560 "FIRSTSCROLLRATE",
2561 "SCROLLRATE",
2562 "NUMBEREDLISTS",
2563 "WARNINGFREQ",
2564 "NOTEFREQ",
2565 "ERRORFREQ",
2566 "WARNINGDURATION",
2567 "NOTEDURATION",
2568 "ERRORDURATION",
2569 "19",
2570 "CXSCREEN",
2571 "CYSCREEN",
2572 "CXVSCROLL",
2573 "CYHSCROLL",
2574 "CYVSCROLLARROW",
2575 "CXHSCROLLARROW",
2576 "CXBORDER",
2577 "CYBORDER",
2578 "CXDLGFRAME",
2579 "CYDLGFRAME",
2580 "CYTITLEBAR",
2581 "CYVSLIDER",
2582 "CXHSLIDER",
2583 "CXMINMAXBUTTON",
2584 "CYMINMAXBUTTON",
2585 "CYMENU",
2586 "CXFULLSCREEN",
2587 "CYFULLSCREEN",
2588 "CXICON",
2589 "CYICON",
2590 "CXPOINTER",
2591 "CYPOINTER",
2592 "DEBUG",
2593 "CPOINTERBUTTONS",
2594 "POINTERLEVEL",
2595 "CURSORLEVEL",
2596 "TRACKRECTLEVEL",
2597 "CTIMERS",
2598 "MOUSEPRESENT",
2599 "CXALIGN",
2600 "CYALIGN",
2601 "DESKTOPWORKAREAYTOP",
2602 "DESKTOPWORKAREAYBOTTOM",
2603 "DESKTOPWORKAREAXRIGHT",
2604 "DESKTOPWORKAREAXLEFT",
2605 "55",
2606 "NOTRESERVED",
2607 "EXTRAKEYBEEP",
2608 "SETLIGHTS",
2609 "INSERTMODE",
2610 "60",
2611 "61",
2612 "62",
2613 "63",
2614 "MENUROLLDOWNDELAY",
2615 "MENUROLLUPDELAY",
2616 "ALTMNEMONIC",
2617 "TASKLISTMOUSEACCESS",
2618 "CXICONTEXTWIDTH",
2619 "CICONTEXTLINES",
2620 "CHORDTIME",
2621 "CXCHORD",
2622 "CYCHORD",
2623 "CXMOTIONSTART",
2624 "CYMOTIONSTART",
2625 "BEGINDRAG",
2626 "ENDDRAG",
2627 "SINGLESELECT",
2628 "OPEN",
2629 "CONTEXTMENU",
2630 "CONTEXTHELP",
2631 "TEXTEDIT",
2632 "BEGINSELECT",
2633 "ENDSELECT",
2634 "BEGINDRAGKB",
2635 "ENDDRAGKB",
2636 "SELECTKB",
2637 "OPENKB",
2638 "CONTEXTMENUKB",
2639 "CONTEXTHELPKB",
2640 "TEXTEDITKB",
2641 "BEGINSELECTKB",
2642 "ENDSELECTKB",
2643 "ANIMATION",
2644 "ANIMATIONSPEED",
2645 "MONOICONS",
2646 "KBDALTERED",
2647 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
2648 "LOCKSTARTINPUT",
2649 "DYNAMICDRAG",
2650 "100",
2651 "101",
2652 "102",
2653 "103",
2654 "104",
2655 "105",
2656 "106",
2657 "107",
2658/* "CSYSVALUES",*/
2659 /* In recent DDK the limit is 108 */
2660};
2661
2662XS(XS_OS2_SysValues)
2663{
2664 dXSARGS;
2665 if (items > 2)
2666 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
2667 {
2668 int i = 0, j = 0, which = -1;
2669 HWND hwnd = HWND_DESKTOP;
2670 static volatile int sv_loaded;
2671 LONG RETVAL;
2672
2673 if (!sv_loaded) {
2674 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
2675 sv_loaded = 1;
2676 }
2677
2678 if (items == 2)
2679 hwnd = (HWND)SvIV(ST(1));
2680 if (items >= 1)
2681 which = (int)SvIV(ST(0));
2682 if (which == -1) {
2683 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
2684 while (i < C_ARRAY_LENGTH(sv_keys)) {
2685 ResetWinError();
2686 RETVAL = pWinQuerySysValue(hwnd, i);
2687 if ( !RETVAL
2688 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
2689 && i <= SV_PRINTSCREEN) ) {
2690 FillWinError;
2691 if (Perl_rc) {
2692 if (i > SV_PRINTSCREEN)
2693 break; /* May be not present on older systems */
2694 croak_with_os2error("SysValues():");
2695 }
2696
2697 }
2698 ST(j) = sv_newmortal();
2699 sv_setpv(ST(j++), sv_keys[i]);
2700 ST(j) = sv_newmortal();
2701 sv_setiv(ST(j++), RETVAL);
2702 i++;
2703 }
2704 XSRETURN(2 * i);
2705 } else {
2706 dXSTARG;
2707
2708 ResetWinError();
2709 RETVAL = pWinQuerySysValue(hwnd, which);
2710 if (!RETVAL) {
2711 FillWinError;
2712 if (Perl_rc)
2713 croak_with_os2error("SysValues():");
2714 }
2715 XSprePUSH; PUSHi((IV)RETVAL);
2716 }
2717 }
2718}
2719
2720XS(XS_OS2_SysValues_set)
2721{
2722 dXSARGS;
2723 if (items < 2 || items > 3)
2724 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
2725 {
2726 int which = (int)SvIV(ST(0));
2727 LONG val = (LONG)SvIV(ST(1));
2728 HWND hwnd = HWND_DESKTOP;
2729 static volatile int svs_loaded;
2730
2731 if (!svs_loaded) {
2732 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
2733 svs_loaded = 1;
2734 }
2735
2736 if (items == 3)
2737 hwnd = (HWND)SvIV(ST(2));
2738 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
2739 croak_with_os2error("SysValues_set()");
2740 }
2741 XSRETURN_EMPTY;
2742}
2743
2744#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
2745
2746static const char * const si_fields[] = {
4bfbfac5
IZ		 2747 "MAX_PATH_LENGTH",
2748 "MAX_TEXT_SESSIONS",
2749 "MAX_PM_SESSIONS",
2750 "MAX_VDM_SESSIONS",
2751 "BOOT_DRIVE",
2752 "DYN_PRI_VARIATION",
2753 "MAX_WAIT",
2754 "MIN_SLICE",
2755 "MAX_SLICE",
2756 "PAGE_SIZE",
2757 "VERSION_MAJOR",
2758 "VERSION_MINOR",
2759 "VERSION_REVISION",
2760 "MS_COUNT",
2761 "TIME_LOW",
2762 "TIME_HIGH",
2763 "TOTPHYSMEM",
2764 "TOTRESMEM",
2765 "TOTAVAILMEM",
2766 "MAXPRMEM",
2767 "MAXSHMEM",
2768 "TIMER_INTERVAL",
2769 "MAX_COMP_LENGTH",
2770 "FOREGROUND_FS_SESSION",
622913ab
IZ		 2771 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
2772 "NUMPROCESSORS",
2773 "MAXHPRMEM",
2774 "MAXHSHMEM",
2775 "MAXPROCESSES",
2776 "VIRTUALADDRESSLIMIT",
2777 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
4bfbfac5
IZ		 2778};
2779
2780XS(XS_OS2_SysInfo)
2781{
2782 dXSARGS;
2783 if (items != 0)
23da6c43 2784 Perl_croak_nocontext("Usage: OS2::SysInfo()");
4bfbfac5 2785 {
622913ab
IZ		 2786 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2787 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
4bfbfac5 2788 APIRET rc = NO_ERROR; /* Return code */
622913ab 2789 int i = 0, j = 0, last = QSV_MAX_WARP3;
4bfbfac5 2790
622913ab
IZ		 2791 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
2792 last, /* info for Warp 3 */
4bfbfac5
IZ		 2793 (PVOID)si,
2794 sizeof(si))))
622913ab
IZ		 2795 croak_with_os2error("DosQuerySysInfo() failed");
2796 while (last++ <= C_ARRAY_LENGTH(si)) {
2797 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
2798 (PVOID)(si+last-1),
2799 sizeof(*si)))) {
2800 if (Perl_rc != ERROR_INVALID_PARAMETER)
2801 croak_with_os2error("DosQuerySysInfo() failed");
2802 break;
2803 }
2804 }
2805 last--;
2806 EXTEND(SP,2*last);
2807 while (i < last) {
4bfbfac5
IZ		 2808 ST(j) = sv_newmortal();
2809 sv_setpv(ST(j++), si_fields[i]);
2810 ST(j) = sv_newmortal();
2811 sv_setiv(ST(j++), si[i]);
2812 i++;
2813 }
622913ab 2814 XSRETURN(2 * last);
4bfbfac5 2815 }
622913ab
IZ		 2816}
2817
2818XS(XS_OS2_SysInfoFor)
2819{
2820 dXSARGS;
2821 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
2822
2823 if (items < 1 || items > 2)
2824 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
2825 {
2826 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
2827 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
2828 APIRET rc = NO_ERROR; /* Return code */
2829 int i = 0;
2830 int start = (int)SvIV(ST(0));
2831
2832 if (count > C_ARRAY_LENGTH(si) || count <= 0)
2833 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
2834 if (CheckOSError(DosQuerySysInfo(start,
2835 start + count - 1,
2836 (PVOID)si,
2837 sizeof(si))))
2838 croak_with_os2error("DosQuerySysInfo() failed");
2839 EXTEND(SP,count);
2840 while (i < count) {
2841 ST(i) = sv_newmortal();
2842 sv_setiv(ST(i), si[i]);
2843 i++;
2844 }
2845 }
2846 XSRETURN(count);
4bfbfac5
IZ		 2847}
2848
2849XS(XS_OS2_BootDrive)
2850{
2851 dXSARGS;
2852 if (items != 0)
23da6c43 2853 Perl_croak_nocontext("Usage: OS2::BootDrive()");
4bfbfac5
IZ		 2854 {
2855 ULONG si[1] = {0}; /* System Information Data Buffer */
2856 APIRET rc = NO_ERROR; /* Return code */
2857 char c;
622913ab 2858 dXSTARG;
4bfbfac5
IZ		 2859
2860 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2861 (PVOID)si, sizeof(si))))
622913ab 2862 croak_with_os2error("DosQuerySysInfo() failed");
4bfbfac5 2863 c = 'a' - 1 + si[0];
622913ab
IZ		 2864 sv_setpvn(TARG, &c, 1);
2865 XSprePUSH; PUSHTARG;
4bfbfac5
IZ		 2866 }
2867 XSRETURN(1);
2868}
2869
622913ab
IZ		 2870XS(XS_OS2_Beep)
2871{
2872 dXSARGS;
2873 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
2874 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
2875 {
2876 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
2877 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
2878 ULONG rc;
2879
2880 if (CheckOSError(DosBeep(freq, ms)))
2881 croak_with_os2error("SysValues_set()");
2882 }
2883 XSRETURN_EMPTY;
2884}
2885
2886
2887
4bfbfac5
IZ		 2888XS(XS_OS2_MorphPM)
2889{
2890 dXSARGS;
2891 if (items != 1)
23da6c43 2892 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
4bfbfac5
IZ		 2893 {
2894 bool serve = SvOK(ST(0));
2895 unsigned long pmq = perl_hmq_GET(serve);
622913ab 2896 dXSTARG;
4bfbfac5 2897
622913ab 2898 XSprePUSH; PUSHi((IV)pmq);
4bfbfac5
IZ		 2899 }
2900 XSRETURN(1);
2901}
2902
2903XS(XS_OS2_UnMorphPM)
2904{
2905 dXSARGS;
2906 if (items != 1)
23da6c43 2907 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
4bfbfac5
IZ		 2908 {
2909 bool serve = SvOK(ST(0));
2910
2911 perl_hmq_UNSET(serve);
2912 }
2913 XSRETURN(0);
2914}
2915
2916XS(XS_OS2_Serve_Messages)
2917{
2918 dXSARGS;
2919 if (items != 1)
23da6c43 2920 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
4bfbfac5
IZ		 2921 {
2922 bool force = SvOK(ST(0));
2923 unsigned long cnt = Perl_Serve_Messages(force);
622913ab 2924 dXSTARG;
4bfbfac5 2925
622913ab 2926 XSprePUSH; PUSHi((IV)cnt);
4bfbfac5
IZ		 2927 }
2928 XSRETURN(1);
2929}
2930
2931XS(XS_OS2_Process_Messages)
2932{
2933 dXSARGS;
2934 if (items < 1 || items > 2)
23da6c43 2935 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
4bfbfac5
IZ		 2936 {
2937 bool force = SvOK(ST(0));
2938 unsigned long cnt;
622913ab 2939 dXSTARG;
4bfbfac5
IZ		 2940
2941 if (items == 2) {
47344f21 2942 I32 cntr;
4bfbfac5 2943 SV *sv = ST(1);
2d766320
IZ		 2944
2945 (void)SvIV(sv); /* Force SvIVX */
4bfbfac5 2946 if (!SvIOK(sv))
23da6c43 2947 Perl_croak_nocontext("Can't upgrade count to IV");
47344f21
YST		 2948 cntr = SvIVX(sv);
2949 cnt = Perl_Process_Messages(force, &cntr);
2950 SvIVX(sv) = cntr;
2951 } else {
2952 cnt = Perl_Process_Messages(force, NULL);
2953 }
622913ab 2954 XSprePUSH; PUSHi((IV)cnt);
4bfbfac5
IZ		 2955 }
2956 XSRETURN(1);
2957}
2958
3bbf9c2b
IZ		 2959XS(XS_Cwd_current_drive)
2960{
2961 dXSARGS;
2962 if (items != 0)
23da6c43 2963 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3bbf9c2b
IZ		 2964 {
2965 char RETVAL;
622913ab 2966 dXSTARG;
3bbf9c2b
IZ		 2967
2968 RETVAL = current_drive();
622913ab
IZ		 2969 sv_setpvn(TARG, (char *)&RETVAL, 1);
2970 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 2971 }
2972 XSRETURN(1);
2973}
2974
2975XS(XS_Cwd_sys_chdir)
2976{
2977 dXSARGS;
2978 if (items != 1)
23da6c43 2979 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3bbf9c2b 2980 {
2d8e6c8d
GS		 2981 STRLEN n_a;
2982 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 2983 bool RETVAL;
2984
2985 RETVAL = sys_chdir(path);
54310121 2986 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 2987 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2988 }
2989 XSRETURN(1);
2990}
2991
2992XS(XS_Cwd_change_drive)
2993{
2994 dXSARGS;
2995 if (items != 1)
23da6c43 2996 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3bbf9c2b 2997 {
2d8e6c8d
GS		 2998 STRLEN n_a;
2999 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3000 bool RETVAL;
3001
3002 RETVAL = change_drive(d);
54310121 3003 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3004 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3005 }
3006 XSRETURN(1);
3007}
3008
3009XS(XS_Cwd_sys_is_absolute)
3010{
3011 dXSARGS;
3012 if (items != 1)
23da6c43 3013 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3bbf9c2b 3014 {
2d8e6c8d
GS		 3015 STRLEN n_a;
3016 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3017 bool RETVAL;
3018
3019 RETVAL = sys_is_absolute(path);
54310121 3020 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3021 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3022 }
3023 XSRETURN(1);
3024}
3025
3026XS(XS_Cwd_sys_is_rooted)
3027{
3028 dXSARGS;
3029 if (items != 1)
23da6c43 3030 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3bbf9c2b 3031 {
2d8e6c8d
GS		 3032 STRLEN n_a;
3033 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3034 bool RETVAL;
3035
3036 RETVAL = sys_is_rooted(path);
54310121 3037 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3038 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3039 }
3040 XSRETURN(1);
3041}
3042
3043XS(XS_Cwd_sys_is_relative)
3044{
3045 dXSARGS;
3046 if (items != 1)
23da6c43 3047 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3bbf9c2b 3048 {
2d8e6c8d
GS		 3049 STRLEN n_a;
3050 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3051 bool RETVAL;
3052
3053 RETVAL = sys_is_relative(path);
54310121 3054 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3055 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3056 }
3057 XSRETURN(1);
3058}
3059
3060XS(XS_Cwd_sys_cwd)
3061{
3062 dXSARGS;
3063 if (items != 0)
23da6c43 3064 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3bbf9c2b
IZ		 3065 {
3066 char p[MAXPATHLEN];
3067 char * RETVAL;
622913ab
IZ		 3068
3069 /* Can't use TARG, since tainting behaves differently */
3bbf9c2b
IZ		 3070 RETVAL = _getcwd2(p, MAXPATHLEN);
3071 ST(0) = sv_newmortal();
622913ab 3072 sv_setpv(ST(0), RETVAL);
ebdd4fa0
JH		 3073#ifndef INCOMPLETE_TAINTS
3074 SvTAINTED_on(ST(0));
3075#endif
3bbf9c2b
IZ		 3076 }
3077 XSRETURN(1);
3078}
3079
3080XS(XS_Cwd_sys_abspath)
3081{
3082 dXSARGS;
5723cfe4
IZ		 3083 if (items > 2)
3084 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3bbf9c2b 3085 {
2d8e6c8d 3086 STRLEN n_a;
5723cfe4 3087 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
f5f423e4 3088 char * dir, *s, *t, *e;
3bbf9c2b
IZ		 3089 char p[MAXPATHLEN];
3090 char * RETVAL;
f5f423e4
IZ		 3091 int l;
3092 SV *sv;
3bbf9c2b
IZ		 3093
3094 if (items < 2)
3095 dir = NULL;
3096 else {
2d8e6c8d 3097 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b
IZ		 3098 }
3099 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3100 path += 2;
3101 }
3102 if (dir == NULL) {
3103 if (_abspath(p, path, MAXPATHLEN) == 0) {
3104 RETVAL = p;
3105 } else {
3106 RETVAL = NULL;
3107 }
3108 } else {
3109 /* Absolute with drive: */
3110 if ( sys_is_absolute(path) ) {
3111 if (_abspath(p, path, MAXPATHLEN) == 0) {
3112 RETVAL = p;
3113 } else {
3114 RETVAL = NULL;
3115 }
3116 } else if (path[0] == '/' || path[0] == '\\') {
3117 /* Rooted, but maybe on different drive. */
3118 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3119 char p1[MAXPATHLEN];
3120
3121 /* Need to prepend the drive. */
3122 p1[0] = dir[0];
3123 p1[1] = dir[1];
3124 Copy(path, p1 + 2, strlen(path) + 1, char);
3125 RETVAL = p;
3126 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3127 RETVAL = p;
3128 } else {
3129 RETVAL = NULL;
3130 }
3131 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3132 RETVAL = p;
3133 } else {
3134 RETVAL = NULL;
3135 }
3136 } else {
3137 /* Either path is relative, or starts with a drive letter. */
3138 /* If the path starts with a drive letter, then dir is
3139 relevant only if
3140 a/b) it is absolute/x:relative on the same drive.
3141 c) path is on current drive, and dir is rooted
3142 In all the cases it is safe to drop the drive part
3143 of the path. */
3144 if ( !sys_is_relative(path) ) {
3bbf9c2b
IZ		 3145 if ( ( ( sys_is_absolute(dir)
3146 || (isALPHA(dir[0]) && dir[1] == ':'
3147 && strnicmp(dir, path,1) == 0))
3148 && strnicmp(dir, path,1) == 0)
3149 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3150 && toupper(path[0]) == current_drive())) {
3151 path += 2;
3152 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3153 RETVAL = p; goto done;
3154 } else {
3155 RETVAL = NULL; goto done;
3156 }
3157 }
3158 {
3159 /* Need to prepend the absolute path of dir. */
3160 char p1[MAXPATHLEN];
3161
3162 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3163 int l = strlen(p1);
3164
3165 if (p1[ l - 1 ] != '/') {
3166 p1[ l ] = '/';
3167 l++;
3168 }
3169 Copy(path, p1 + l, strlen(path) + 1, char);
3170 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3171 RETVAL = p;
3172 } else {
3173 RETVAL = NULL;
3174 }
3175 } else {
3176 RETVAL = NULL;
3177 }
3178 }
3179 done:
3180 }
3181 }
f5f423e4
IZ		 3182 if (!RETVAL)
3183 XSRETURN_EMPTY;
3184 /* Backslashes are already converted to slashes. */
3185 /* Remove trailing slashes */
3186 l = strlen(RETVAL);
3187 while (l > 0 && RETVAL[l-1] == '/')
3188 l--;
3bbf9c2b 3189 ST(0) = sv_newmortal();
f5f423e4 3190 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
45ee47cb
IZ		 3191 /* Remove duplicate slashes, skipping the first three, which
3192 may be parts of a server-based path */
3193 s = t = 3 + SvPV_force(sv, n_a);
f5f423e4 3194 e = SvEND(sv);
45ee47cb
IZ		 3195 /* Do not worry about multibyte chars here, this would contradict the
3196 eventual UTFization, and currently most other places break too... */
f5f423e4
IZ		 3197 while (s < e) {
3198 if (s[0] == t[-1] && s[0] == '/')
3199 s++; /* Skip duplicate / */
3200 else
3201 *t++ = *s++;
3202 }
45ee47cb
IZ		 3203 if (t < e) {
3204 *t = 0;
3205 SvCUR_set(sv, t - SvPVX(sv));
3206 }
5723cfe4
IZ		 3207#ifndef INCOMPLETE_TAINTS
3208 if (!items)
3209 SvTAINTED_on(ST(0));
3210#endif
3bbf9c2b
IZ		 3211 }
3212 XSRETURN(1);
3213}
72ea3524
IZ		 3214typedef APIRET (*PELP)(PSZ path, ULONG type);
3215
5a9d0041
IZ		 3216/* Kernels after 2000/09/15 understand this too: */
3217#ifndef LIBPATHSTRICT
3218# define LIBPATHSTRICT 3
3219#endif
3220
72ea3524 3221APIRET
5a9d0041 3222ExtLIBPATH(ULONG ord, PSZ path, IV type)
72ea3524 3223{
5a9d0041 3224 ULONG what;
35bc1fdc 3225 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
5a9d0041 3226
5a9d0041
IZ		 3227 if (type > 0)
3228 what = END_LIBPATH;
3229 else if (type == 0)
3230 what = BEGIN_LIBPATH;
3231 else
3232 what = LIBPATHSTRICT;
35bc1fdc 3233 return (*(PELP)f)(path, what);
72ea3524 3234}
3bbf9c2b 3235
5a9d0041 3236#define extLibpath(to,type) \
35bc1fdc 3237 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3bbf9c2b
IZ		 3238
3239#define extLibpath_set(p,type) \
35bc1fdc 3240 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3bbf9c2b
IZ		 3241
3242XS(XS_Cwd_extLibpath)
3243{
3244 dXSARGS;
3245 if (items < 0 || items > 1)
23da6c43 3246 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3bbf9c2b 3247 {
5a9d0041 3248 IV type;
3bbf9c2b
IZ		 3249 char to[1024];
3250 U32 rc;
3251 char * RETVAL;
622913ab 3252 dXSTARG;
3bbf9c2b
IZ		 3253
3254 if (items < 1)
3255 type = 0;
3256 else {
5a9d0041 3257 type = SvIV(ST(0));
3bbf9c2b
IZ		 3258 }
3259
5a9d0041
IZ		 3260 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3261 RETVAL = extLibpath(to, type);
3262 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3263 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
622913ab
IZ		 3264 sv_setpv(TARG, RETVAL);
3265 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 3266 }
3267 XSRETURN(1);
3268}
3269
3270XS(XS_Cwd_extLibpath_set)
3271{
3272 dXSARGS;
3273 if (items < 1 || items > 2)
23da6c43 3274 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3bbf9c2b 3275 {
2d8e6c8d
GS		 3276 STRLEN n_a;
3277 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 3278 IV type;
3bbf9c2b
IZ		 3279 U32 rc;
3280 bool RETVAL;
3281
3282 if (items < 2)
3283 type = 0;
3284 else {
5a9d0041 3285 type = SvIV(ST(1));
3bbf9c2b
IZ		 3286 }
3287
3288 RETVAL = extLibpath_set(s, type);
54310121 3289 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3290 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3291 }
3292 XSRETURN(1);
3293}
3294
30500b05
IZ		 3295/* Input: Address, BufLen
3296APIRET APIENTRY
3297DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3298 ULONG * Offset, ULONG Address);
3299*/
3300
3301DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3302 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3303 ULONG * Offset, ULONG Address),
3304 (hmod, obj, BufLen, Buf, Offset, Address))
3305
622913ab
IZ		 3306enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3307 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
30500b05
IZ		 3308
3309static SV*
3310module_name_at(void *pp, enum module_name_how how)
3311{
5c728af0 3312 dTHX;
30500b05
IZ		 3313 char buf[MAXPATHLEN];
3314 char *p = buf;
3315 HMODULE mod;
622913ab
IZ		 3316 ULONG obj, offset, rc, addr = (ULONG)pp;
3317
3318 if (how & mod_name_HMODULE) {
3319 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3320 Perl_croak(aTHX_ "Can't get short module name from a handle");
3321 mod = (HMODULE)pp;
3322 how &= ~mod_name_HMODULE;
3323 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
30500b05
IZ		 3324 return &PL_sv_undef;
3325 if (how == mod_name_handle)
3326 return newSVuv(mod);
3327 /* Full name... */
622913ab 3328 if ( how != mod_name_shortname
30500b05
IZ		 3329 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3330 return &PL_sv_undef;
3331 while (*p) {
3332 if (*p == '\\')
3333 *p = '/';
3334 p++;
3335 }
3336 return newSVpv(buf, 0);
3337}
3338
3339static SV*
3340module_name_of_cv(SV *cv, enum module_name_how how)
3341{
5c728af0
IZ		 3342 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3343 dTHX;
3344
622913ab
IZ		 3345 if (how & mod_name_C_function)
3346 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3347 else if (how & mod_name_HMODULE)
3348 return module_name_at((void*)SvIV(cv), how);
5c728af0
IZ		 3349 Perl_croak(aTHX_ "Not an XSUB reference");
3350 }
30500b05
IZ		 3351 return module_name_at(CvXSUB(SvRV(cv)), how);
3352}
3353
3354/* Find module name to which *this* subroutine is compiled */
3355#define module_name(how) module_name_at(&module_name_at, how)
3356
3357XS(XS_OS2_DLLname)
3358{
3359 dXSARGS;
3360 if (items > 2)
3361 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3362 {
3363 SV * RETVAL;
3364 int how;
3365
3366 if (items < 1)
3367 how = mod_name_full;
3368 else {
3369 how = (int)SvIV(ST(0));
3370 }
3371 if (items < 2)
3372 RETVAL = module_name(how);
3373 else
3374 RETVAL = module_name_of_cv(ST(1), how);
3375 ST(0) = RETVAL;
3376 sv_2mortal(ST(0));
3377 }
3378 XSRETURN(1);
3379}
3380
622913ab
IZ		 3381DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3382 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3383 (r1, r2, buf, szbuf, fnum))
3384
3385XS(XS_OS2__headerInfo)
3386{
3387 dXSARGS;
3388 if (items > 4 || items < 2)
3389 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3390 {
3391 ULONG req = (ULONG)SvIV(ST(0));
3392 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3393 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3394 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3395
3396 if (size <= 0)
3397 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3398 ST(0) = newSVpvn("",0);
3399 SvGROW(ST(0), size + 1);
3400 sv_2mortal(ST(0));
3401
3402 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3403 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3404 req, size, handle, offset, os2error(Perl_rc));
3405 SvCUR_set(ST(0), size);
3406 *SvEND(ST(0)) = 0;
3407 }
3408 XSRETURN(1);
3409}
3410
3411#define DQHI_QUERYLIBPATHSIZE 4
3412#define DQHI_QUERYLIBPATH 5
3413
3414XS(XS_OS2_libPath)
3415{
3416 dXSARGS;
3417 if (items != 0)
3418 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3419 {
3420 ULONG size;
3421 STRLEN n_a;
3422
3423 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3424 DQHI_QUERYLIBPATHSIZE))
3425 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3426 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3427 os2error(Perl_rc));
3428 ST(0) = newSVpvn("",0);
3429 SvGROW(ST(0), size + 1);
3430 sv_2mortal(ST(0));
3431
3432 /* We should be careful: apparently, this entry point does not
3433 pay attention to the size argument, so may overwrite
3434 unrelated data! */
3435 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3436 DQHI_QUERYLIBPATH))
3437 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3438 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3439 SvCUR_set(ST(0), size);
3440 *SvEND(ST(0)) = 0;
3441 }
3442 XSRETURN(1);
3443}
3444
5ba48348
JH		 3445#define get_control87() _control87(0,0)
3446#define set_control87 _control87
3447
3448XS(XS_OS2__control87)
3449{
3450 dXSARGS;
3451 if (items != 2)
5c728af0 3452 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
5ba48348
JH		 3453 {
3454 unsigned new = (unsigned)SvIV(ST(0));
3455 unsigned mask = (unsigned)SvIV(ST(1));
3456 unsigned RETVAL;
622913ab 3457 dXSTARG;
5ba48348
JH		 3458
3459 RETVAL = _control87(new, mask);
622913ab
IZ		 3460 XSprePUSH; PUSHi((IV)RETVAL);
3461 }
3462 XSRETURN(1);
3463}
3464
3465XS(XS_OS2_mytype)
3466{
3467 dXSARGS;
3468 int which = 0;
3469
3470 if (items < 0 || items > 1)
3471 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3472 if (items == 1)
3473 which = (int)SvIV(ST(0));
3474 {
3475 unsigned RETVAL;
3476 dXSTARG;
3477
3478 switch (which) {
3479 case 0:
3480 RETVAL = os2_mytype; /* Reset after fork */
3481 break;
3482 case 1:
3483 RETVAL = os2_mytype_ini; /* Before any fork */
3484 break;
3485 case 2:
3486 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3487 break;
3488 case 3:
3489 RETVAL = my_type(); /* Morphed type */
3490 break;
3491 default:
3492 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3493 }
3494 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3495 }
3496 XSRETURN(1);
3497}
3498
622913ab
IZ		 3499
3500XS(XS_OS2_mytype_set)
3501{
3502 dXSARGS;
3503 int type;
3504
3505 if (items == 1)
3506 type = (int)SvIV(ST(0));
3507 else
3508 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3509 my_type_set(type);
3510 XSRETURN_EMPTY;
3511}
3512
3513
5ba48348
JH		 3514XS(XS_OS2_get_control87)
3515{
3516 dXSARGS;
3517 if (items != 0)
5c728af0 3518 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
5ba48348
JH		 3519 {
3520 unsigned RETVAL;
622913ab 3521 dXSTARG;
5ba48348
JH		 3522
3523 RETVAL = get_control87();
622913ab 3524 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3525 }
3526 XSRETURN(1);
3527}
3528
3529
3530XS(XS_OS2_set_control87)
3531{
3532 dXSARGS;
3533 if (items < 0 || items > 2)
5c728af0 3534 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
5ba48348
JH		 3535 {
3536 unsigned new;
3537 unsigned mask;
3538 unsigned RETVAL;
622913ab 3539 dXSTARG;
5ba48348
JH		 3540
3541 if (items < 1)
3542 new = MCW_EM;
3543 else {
3544 new = (unsigned)SvIV(ST(0));
3545 }
3546
3547 if (items < 2)
3548 mask = MCW_EM;
3549 else {
3550 mask = (unsigned)SvIV(ST(1));
3551 }
3552
3553 RETVAL = set_control87(new, mask);
622913ab
IZ		 3554 XSprePUSH; PUSHi((IV)RETVAL);
3555 }
3556 XSRETURN(1);
3557}
3558
3559XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
3560{
3561 dXSARGS;
3562 if (items < 0 || items > 1)
3563 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3564 {
3565 LONG delta;
3566 ULONG RETVAL, rc;
3567 dXSTARG;
3568
3569 if (items < 1)
3570 delta = 0;
3571 else
3572 delta = (LONG)SvIV(ST(0));
3573
3574 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3575 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3576 XSprePUSH; PUSHu((UV)RETVAL);
5ba48348
JH		 3577 }
3578 XSRETURN(1);
3579}
3580
3bbf9c2b 3581int
23da6c43 3582Xs_OS2_init(pTHX)
3bbf9c2b
IZ		 3583{
3584 char *file = __FILE__;
3585 {
3586 GV *gv;
55497cff 3587
3588 if (_emx_env & 0x200) { /* OS/2 */
3589 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3590 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3591 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3592 }
4bfbfac5
IZ		 3593 newXS("OS2::Error", XS_OS2_Error, file);
3594 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3595 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
622913ab
IZ		 3596 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3597 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4bfbfac5
IZ		 3598 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3599 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3600 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3601 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3602 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b
IZ		 3603 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3604 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3605 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3606 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3607 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3608 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3609 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3610 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3611 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
d79a646b 3612 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
59ad941d 3613 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
5ba48348
JH		 3614 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3615 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3616 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
30500b05 3617 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
622913ab
IZ		 3618 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3619 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3620 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3621 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3622 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3623 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3624 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3625 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3626 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3bbf9c2b
IZ		 3627 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3628 GvMULTI_on(gv);
3629#ifdef PERL_IS_AOUT
3630 sv_setiv(GvSV(gv), 1);
764df951 3631#endif
59ad941d
IZ		 3632 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
3633 GvMULTI_on(gv);
3634#ifdef PERL_IS_AOUT
3635 sv_setiv(GvSV(gv), 1);
3636#endif
764df951
IZ		 3637 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3638 GvMULTI_on(gv);
3639 sv_setiv(GvSV(gv), exe_is_aout());
4bfbfac5
IZ		 3640 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3641 GvMULTI_on(gv);
3642 sv_setiv(GvSV(gv), _emx_rev);
3643 sv_setpv(GvSV(gv), _emx_vprt);
3644 SvIOK_on(GvSV(gv));
3645 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3646 GvMULTI_on(gv);
3647 sv_setiv(GvSV(gv), _emx_env);
3648 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3649 GvMULTI_on(gv);
3650 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87
IZ		 3651 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3652 GvMULTI_on(gv);
3653 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 3654 }
2d766320 3655 return 0;
3bbf9c2b
IZ		 3656}
3657
764df951
IZ		 3658extern void _emx_init(void*);
3659
3660static void jmp_out_of_atexit(void);
3661
3662#define FORCE_EMX_INIT_CONTRACT_ARGV 1
3663#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
3664
3665static void
3666my_emx_init(void *layout) {
622913ab 3667 static volatile void *old_esp = 0; /* Cannot be on stack! */
764df951
IZ		 3668
3669 /* Can't just call emx_init(), since it moves the stack pointer */
3670 /* It also busts a lot of registers, so be extra careful */
3671 __asm__( "pushf\n"
3672 "pusha\n"
3673 "movl %%esp, %1\n"
3674 "push %0\n"
3675 "call __emx_init\n"
3676 "movl %1, %%esp\n"
3677 "popa\n"
622913ab 3678 "popf\n" : : "r" (layout), "m" (old_esp) );
764df951
IZ		 3679}
3680
3681struct layout_table_t {
3682 ULONG text_base;
3683 ULONG text_end;
3684 ULONG data_base;
3685 ULONG data_end;
3686 ULONG bss_base;
3687 ULONG bss_end;
3688 ULONG heap_base;
3689 ULONG heap_end;
3690 ULONG heap_brk;
3691 ULONG heap_off;
3692 ULONG os2_dll;
3693 ULONG stack_base;
3694 ULONG stack_end;
3695 ULONG flags;
3696 ULONG reserved[2];
3697 char options[64];
3698};
3699
3700static ULONG
3701my_os_version() {
622913ab 3702 static ULONG osv_res; /* Cannot be on stack! */
764df951 3703
c4e0013e
IZ		 3704 /* Can't just call __os_version(), since it does not follow C
3705 calling convention: it busts a lot of registers, so be extra careful */
764df951
IZ		 3706 __asm__( "pushf\n"
3707 "pusha\n"
3708 "call ___os_version\n"
3709 "movl %%eax, %0\n"
3710 "popa\n"
622913ab 3711 "popf\n" : "=m" (osv_res) );
764df951 3712
622913ab 3713 return osv_res;
764df951
IZ		 3714}
3715
3716static void
3717force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3718{
3719 /* Calling emx_init() will bust the top of stack: it installs an
3720 exception handler and puts argv data there. */
3721 char *oldarg, *oldenv;
3722 void *oldstackend, *oldstack;
3723 PPIB pib;
3724 PTIB tib;
764df951
IZ		 3725 ULONG rc, error = 0, out;
3726 char buf[512];
3727 static struct layout_table_t layout_table;
3728 struct {
3729 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3730 double alignment1;
3731 EXCEPTIONREGISTRATIONRECORD xreg;
3732 } *newstack;
3733 char *s;
3734
622913ab 3735 layout_table.os2_dll = (ULONG)&os2_dll_fake;
764df951
IZ		 3736 layout_table.flags = 0x02000002; /* flags: application, OMF */
3737
3738 DosGetInfoBlocks(&tib, &pib);
3739 oldarg = pib->pib_pchcmd;
3740 oldenv = pib->pib_pchenv;
3741 oldstack = tib->tib_pstack;
3742 oldstackend = tib->tib_pstacklimit;
3743
3744 /* Minimize the damage to the stack via reducing the size of argv. */
3745 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3746 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
3747 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
3748 }
3749
3750 newstack = alloca(sizeof(*newstack));
3751 /* Emulate the stack probe */
3752 s = ((char*)newstack) + sizeof(*newstack);
3753 while (s > (char*)newstack) {
3754 s[-1] = 0;
3755 s -= 4096;
3756 }
3757
3758 /* Reassigning stack is documented to work */
3759 tib->tib_pstack = (void*)newstack;
3760 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3761
3762 /* Can't just call emx_init(), since it moves the stack pointer */
3763 my_emx_init((void*)&layout_table);
3764
3765 /* Remove the exception handler, cannot use it - too low on the stack.
3766 Check whether it is inside the new stack. */
3767 buf[0] = 0;
3768 if (tib->tib_pexchain >= tib->tib_pstacklimit
3769 || tib->tib_pexchain < tib->tib_pstack) {
3770 error = 1;
3771 sprintf(buf,
3772 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3773 (unsigned long)tib->tib_pstack,
3774 (unsigned long)tib->tib_pexchain,
3775 (unsigned long)tib->tib_pstacklimit);
3776 goto finish;
3777 }
3778 if (tib->tib_pexchain != &(newstack->xreg)) {
3779 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3780 (unsigned long)tib->tib_pexchain,
3781 (unsigned long)&(newstack->xreg));
3782 }
3783 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3784 if (rc)
3785 sprintf(buf + strlen(buf),
3786 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3787
3788 if (preg) {
3789 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
3790 preg->prev_structure = 0;
3791 preg->ExceptionHandler = _emx_exception;
3792 rc = DosSetExceptionHandler(preg);
3793 if (rc) {
3794 sprintf(buf + strlen(buf),
3795 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3796 DosWrite(2, buf, strlen(buf), &out);
3797 emx_exception_init = 1; /* Do it around spawn*() calls */
3798 }
3799 } else
3800 emx_exception_init = 1; /* Do it around spawn*() calls */
3801
3802 finish:
3803 /* Restore the damage */
3804 pib->pib_pchcmd = oldarg;
3805 pib->pib_pchcmd = oldenv;
3806 tib->tib_pstacklimit = oldstackend;
3807 tib->tib_pstack = oldstack;
3808 emx_runtime_init = 1;
3809 if (buf[0])
3810 DosWrite(2, buf, strlen(buf), &out);
3811 if (error)
3812 exit(56);
3813}
3814
764df951
IZ		 3815static void
3816jmp_out_of_atexit(void)
3817{
3818 if (longjmp_at_exit)
3819 longjmp(at_exit_buf, 1);
3820}
3821
3822extern void _CRT_term(void);
3823
764df951
IZ		 3824void
3825Perl_OS2_term(void **p, int exitstatus, int flags)
3826{
3827 if (!emx_runtime_secondary)
3828 return;
3829
3830 /* The principal executable is not running the same CRTL, so there
3831 is nobody to shutdown *this* CRTL except us... */
3832 if (flags & FORCE_EMX_DEINIT_EXIT) {
3833 if (p && !emx_exception_init)
3834 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3835 /* Do not run the executable's CRTL's termination routines */
3836 exit(exitstatus); /* Run at-exit, flush buffers, etc */
3837 }
3838 /* Run at-exit list, and jump out at the end */
3839 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3840 longjmp_at_exit = 1;
3841 exit(exitstatus); /* The first pass through "if" */
3842 }
3843
3844 /* Get here if we managed to jump out of exit(), or did not run atexit. */
3845 longjmp_at_exit = 0; /* Maybe exit() is called again? */
3846#if 0 /* _atexit_n is not exported */
3847 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3848 _atexit_n = 0; /* Remove the atexit() handlers */
3849#endif
3850 /* Will segfault on program termination if we leave this dangling... */
3851 if (p && !emx_exception_init)
3852 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3853 /* Typically there is no need to do this, done from _DLL_InitTerm() */
3854 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3855 _CRT_term(); /* Flush buffers, etc. */
3856 /* Now it is a good time to call exit() in the caller's CRTL... */
3857}
3858
3859#include <emx/startup.h>
3860
3861extern ULONG __os_version(); /* See system.doc */
3862
764df951
IZ		 3863void
3864check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3865{
622913ab
IZ		 3866 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3867 static HMTX hmtx_emx_init = NULLHANDLE;
3868 static int emx_init_done = 0;
764df951
IZ		 3869
3870 /* If _environ is not set, this code sits in a DLL which
3871 uses a CRT DLL which not compatible with the executable's
3872 CRT library. Some parts of the DLL are not initialized.
3873 */
3874 if (_environ != NULL)
3875 return; /* Properly initialized */
3876
622913ab
IZ		 3877 /* It is not DOS, so we may use OS/2 API now */
3878 /* Some data we manipulate is static; protect ourselves from
3879 calling the same API from a different thread. */
3880 DosEnterMustComplete(&count);
3881
3882 rc1 = DosEnterCritSec();
3883 if (!hmtx_emx_init)
3884 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3885 else
3886 maybe_inited = 1;
3887
3888 if (rc != NO_ERROR)
3889 hmtx_emx_init = NULLHANDLE;
3890
3891 if (rc1 == NO_ERROR)
3892 DosExitCritSec();
3893 DosExitMustComplete(&count);
3894
3895 while (maybe_inited) { /* Other thread did or is doing the same now */
3896 if (emx_init_done)
3897 return;
3898 rc = DosRequestMutexSem(hmtx_emx_init,
3899 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
3900 if (rc == ERROR_INTERRUPT)
3901 continue;
3902 if (rc != NO_ERROR) {
3903 char buf[80];
3904 ULONG out;
3905
3906 sprintf(buf,
3907 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3908 DosWrite(2, buf, strlen(buf), &out);
3909 return;
3910 }
3911 DosReleaseMutexSem(hmtx_emx_init);
3912 return;
3913 }
3914
764df951
IZ		 3915 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
3916 initialized either. Uninitialized EMX.DLL returns 0 in the low
3917 nibble of __os_version(). */
3918 v_emx = my_os_version();
3919
3920 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3921 (=>_CRT_init=>_entry2) via a call to __os_version(), then
3922 reset when the EXE initialization code calls _text=>_init=>_entry2.
3923 The first time they are wrongly set to 0; the second time the
3924 EXE initialization code had already called emx_init=>initialize1
3925 which correctly set version_major, version_minor used by
3926 __os_version(). */
3927 v_crt = (_osmajor | _osminor);
3928
3929 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
3930 force_init_emx_runtime( preg,
3931 FORCE_EMX_INIT_CONTRACT_ARGV
3932 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3933 emx_wasnt_initialized = 1;
3934 /* Update CRTL data basing on now-valid EMX runtime data */
3935 if (!v_crt) { /* The only wrong data are the versions. */
3936 v_emx = my_os_version(); /* *Now* it works */
3937 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3938 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3939 }
3940 }
3941 emx_runtime_secondary = 1;
3942 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3943 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
3944
9e2a34c1 3945 if (env == NULL) { /* Fetch from the process info block */
764df951
IZ		 3946 int c = 0;
3947 PPIB pib;
3948 PTIB tib;
3949 char *e, **ep;
3950
3951 DosGetInfoBlocks(&tib, &pib);
3952 e = pib->pib_pchenv;
3953 while (*e) { /* Get count */
3954 c++;
3955 e = e + strlen(e) + 1;
3956 }
764df951
IZ		 3957 New(1307, env, c + 1, char*);
3958 ep = env;
3959 e = pib->pib_pchenv;
3960 while (c--) {
3961 *ep++ = e;
3962 e = e + strlen(e) + 1;
3963 }
3964 *ep = NULL;
3965 }
3966 _environ = _org_environ = env;
622913ab
IZ		 3967 emx_init_done = 1;
3968 if (hmtx_emx_init)
3969 DosReleaseMutexSem(hmtx_emx_init);
764df951
IZ		 3970}
3971
3972#define ENTRY_POINT 0x10000
3973
3974static int
3975exe_is_aout(void)
3976{
3977 struct layout_table_t *layout;
3978 if (emx_wasnt_initialized)
3979 return 0;
3980 /* Now we know that the principal executable is an EMX application
3981 - unless somebody did already play with delayed initialization... */
3982 /* With EMX applications to determine whether it is AOUT one needs
3983 to examine the start of the executable to find "layout" */
3984 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
3985 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
3986 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
3987 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
3988 return 0; /* ! EMX executable */
3989 /* Fix alignment */
3990 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3991 return !(layout->flags & 2);
3992}
3993
3bbf9c2b 3994void
aa689395 3995Perl_OS2_init(char **env)
3bbf9c2b 3996{
764df951
IZ		 3997 Perl_OS2_init3(env, 0, 0);
3998}
3999
4000void
4001Perl_OS2_init3(char **env, void **preg, int flags)
4002{
3bbf9c2b
IZ		 4003 char *shell;
4004
764df951 4005 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
18f739ee 4006 MALLOC_INIT;
764df951
IZ		 4007
4008 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4009
3bbf9c2b
IZ		 4010 settmppath();
4011 OS2_Perl_data.xs_init = &Xs_OS2_init;
4012 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c
GS		 4013 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
4014 strcpy(PL_sh_path, SH_PATH);
4015 PL_sh_path[0] = shell[0];
3bbf9c2b 4016 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 4017 int l = strlen(shell), i;
3bbf9c2b
IZ		 4018 if (shell[l-1] == '/' || shell[l-1] == '\\') {
4019 l--;
4020 }
6b88bc9c
GS		 4021 New(1304, PL_sh_path, l + 8, char);
4022 strncpy(PL_sh_path, shell, l);
4023 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 4024 for (i = 0; i < l; i++) {
6b88bc9c 4025 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 4026 }
3bbf9c2b 4027 }
5c728af0 4028#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
dd96f567 4029 MUTEX_INIT(&start_thread_mutex);
622913ab 4030 MUTEX_INIT(&perlos2_state_mutex);
5c728af0 4031#endif
017f25f1 4032 os2_mytype = my_type(); /* Do it before morphing. Needed? */
622913ab
IZ		 4033 os2_mytype_ini = os2_mytype;
4034 Perl_os2_initial_mode = -1; /* Uninit */
5ba48348
JH		 4035 /* Some DLLs reset FP flags on load. We may have been linked with them */
4036 _control87(MCW_EM, MCW_EM);
3bbf9c2b
IZ		 4037}
4038
59ad941d
IZ		 4039int
4040fd_ok(int fd)
4041{
4042 static ULONG max_fh = 0;
4043
4044 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
4045 if (fd >= max_fh) { /* Renew */
4046 LONG delta = 0;
4047
4048 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
4049 return 1;
4050 }
4051 return fd < max_fh;
4052}
4053
4054/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
4055int
4056dup2(int from, int to)
4057{
4058 if (fd_ok(from < to ? to : from))
4059 return _dup2(from, to);
4060 errno = EBADF;
4061 return -1;
4062}
4063
4064int
4065dup(int from)
4066{
4067 if (fd_ok(from))
4068 return _dup(from);
4069 errno = EBADF;
4070 return -1;
4071}
4072
55497cff 4073#undef tmpnam
4074#undef tmpfile
4075
4076char *
4077my_tmpnam (char *str)
4078{
4079 char *p = getenv("TMP"), *tpath;
55497cff 4080
4081 if (!p) p = getenv("TEMP");
4082 tpath = tempnam(p, "pltmp");
4083 if (str && tpath) {
4084 strcpy(str, tpath);
4085 return str;
4086 }
4087 return tpath;
4088}
4089
4090FILE *
4091my_tmpfile ()
4092{
4093 struct stat s;
4094
4095 stat(".", &s);
4096 if (s.st_mode & S_IWOTH) {
4097 return tmpfile();
4098 }
4099 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
4100 grants TMP. */
4101}
367f3c24 4102
5ba48348
JH		 4103#undef rmdir
4104
cd4e750a
IZ		 4105/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
4106 trailing slashes, so we need to support this as well. */
4107
5ba48348
JH		 4108int
4109my_rmdir (__const__ char *s)
4110{
cd4e750a
IZ		 4111 char b[MAXPATHLEN];
4112 char *buf = b;
5ba48348 4113 STRLEN l = strlen(s);
cd4e750a 4114 int rc;
5ba48348 4115
cd4e750a
IZ		 4116 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
4117 if (l >= sizeof b)
4118 New(1305, buf, l + 1, char);
5ba48348 4119 strcpy(buf,s);
cd4e750a
IZ		 4120 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
4121 l--;
4122 buf[l] = 0;
5ba48348
JH		 4123 s = buf;
4124 }
cd4e750a
IZ		 4125 rc = rmdir(s);
4126 if (b != buf)
4127 Safefree(buf);
4128 return rc;
5ba48348
JH		 4129}
4130
4131#undef mkdir
4132
4133int
4134my_mkdir (__const__ char *s, long perm)
4135{
cd4e750a
IZ		 4136 char b[MAXPATHLEN];
4137 char *buf = b;
5ba48348 4138 STRLEN l = strlen(s);
cd4e750a 4139 int rc;
5ba48348
JH		 4140
4141 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
cd4e750a
IZ		 4142 if (l >= sizeof b)
4143 New(1305, buf, l + 1, char);
5ba48348 4144 strcpy(buf,s);
cd4e750a
IZ		 4145 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
4146 l--;
4147 buf[l] = 0;
5ba48348
JH		 4148 s = buf;
4149 }
cd4e750a
IZ		 4150 rc = mkdir(s, perm);
4151 if (b != buf)
4152 Safefree(buf);
4153 return rc;
5ba48348
JH		 4154}
4155
367f3c24
IZ		 4156#undef flock
4157
4158/* This code was contributed by Rocco Caputo. */
4159int
dd96f567 4160my_flock(int handle, int o)
367f3c24
IZ		 4161{
4162 FILELOCK rNull, rFull;
4163 ULONG timeout, handle_type, flag_word;
4164 APIRET rc;
4165 int blocking, shared;
622913ab 4166 static int use_my_flock = -1;
367f3c24 4167
622913ab
IZ		 4168 if (use_my_flock == -1) {
4169 MUTEX_LOCK(&perlos2_state_mutex);
4170 if (use_my_flock == -1) {
367f3c24
IZ		 4171 char *s = getenv("USE_PERL_FLOCK");
4172 if (s)
622913ab 4173 use_my_flock = atoi(s);
367f3c24 4174 else
622913ab
IZ		 4175 use_my_flock = 1;
4176 }
4177 MUTEX_UNLOCK(&perlos2_state_mutex);
367f3c24 4178 }
622913ab 4179 if (!(_emx_env & 0x200) || !use_my_flock)
dd96f567 4180 return flock(handle, o); /* Delegate to EMX. */
367f3c24 4181
cb69f87a 4182 /* is this a file? */
367f3c24
IZ		 4183 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4184 (handle_type & 0xFF))
4185 {
4186 errno = EBADF;
4187 return -1;
4188 }
cb69f87a 4189 /* set lock/unlock ranges */
367f3c24
IZ		 4190 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4191 rFull.lRange = 0x7FFFFFFF;
cb69f87a 4192 /* set timeout for blocking */
dd96f567 4193 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
cb69f87a 4194 /* shared or exclusive? */
dd96f567 4195 shared = (o & LOCK_SH) ? 1 : 0;
cb69f87a 4196 /* do not block the unlock */
dd96f567 4197 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24
IZ		 4198 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4199 switch (rc) {
4200 case 0:
4201 errno = 0;
4202 return 0;
4203 case ERROR_INVALID_HANDLE:
4204 errno = EBADF;
4205 return -1;
4206 case ERROR_SHARING_BUFFER_EXCEEDED:
4207 errno = ENOLCK;
4208 return -1;
4209 case ERROR_LOCK_VIOLATION:
cb69f87a 4210 break; /* not an error */
367f3c24
IZ		 4211 case ERROR_INVALID_PARAMETER:
4212 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4213 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4214 errno = EINVAL;
4215 return -1;
4216 case ERROR_INTERRUPT:
4217 errno = EINTR;
4218 return -1;
4219 default:
4220 errno = EINVAL;
4221 return -1;
4222 }
4223 }
cb69f87a 4224 /* lock may block */
dd96f567 4225 if (o & (LOCK_SH | LOCK_EX)) {
cb69f87a 4226 /* for blocking operations */
367f3c24
IZ		 4227 for (;;) {
4228 rc =
4229 DosSetFileLocks(
4230 handle,
4231 &rNull,
4232 &rFull,
4233 timeout,
4234 shared
4235 );
4236 switch (rc) {
4237 case 0:
4238 errno = 0;
4239 return 0;
4240 case ERROR_INVALID_HANDLE:
4241 errno = EBADF;
4242 return -1;
4243 case ERROR_SHARING_BUFFER_EXCEEDED:
4244 errno = ENOLCK;
4245 return -1;
4246 case ERROR_LOCK_VIOLATION:
4247 if (!blocking) {
4248 errno = EWOULDBLOCK;
4249 return -1;
4250 }
4251 break;
4252 case ERROR_INVALID_PARAMETER:
4253 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4254 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4255 errno = EINVAL;
4256 return -1;
4257 case ERROR_INTERRUPT:
4258 errno = EINTR;
4259 return -1;
4260 default:
4261 errno = EINVAL;
4262 return -1;
4263 }
cb69f87a 4264 /* give away timeslice */
367f3c24
IZ		 4265 DosSleep(1);
4266 }
4267 }
4268
4269 errno = 0;
4270 return 0;
4271}
f72c975a 4272
f72c975a
IZ		 4273static int
4274use_my_pwent(void)
4275{
4276 if (_my_pwent == -1) {
4277 char *s = getenv("USE_PERL_PWENT");
4278 if (s)
4279 _my_pwent = atoi(s);
4280 else
4281 _my_pwent = 1;
4282 }
4283 return _my_pwent;
4284}
4285
4286#undef setpwent
4287#undef getpwent
4288#undef endpwent
4289
4290void
4291my_setpwent(void)
4292{
4293 if (!use_my_pwent()) {
4294 setpwent(); /* Delegate to EMX. */
4295 return;
4296 }
4297 pwent_cnt = 0;
4298}
4299
4300void
4301my_endpwent(void)
4302{
4303 if (!use_my_pwent()) {
4304 endpwent(); /* Delegate to EMX. */
4305 return;
4306 }
4307}
4308
4309struct passwd *
4310my_getpwent (void)
4311{
4312 if (!use_my_pwent())
4313 return getpwent(); /* Delegate to EMX. */
4314 if (pwent_cnt++)
cb69f87a 4315 return 0; /* Return one entry only */
f72c975a
IZ		 4316 return getpwuid(0);
4317}
4318
f72c975a
IZ		 4319void
4320setgrent(void)
4321{
4322 grent_cnt = 0;
4323}
4324
4325void
4326endgrent(void)
4327{
4328}
4329
4330struct group *
4331getgrent (void)
4332{
4333 if (grent_cnt++)
cb69f87a 4334 return 0; /* Return one entry only */
f72c975a
IZ		 4335 return getgrgid(0);
4336}
4337
4338#undef getpwuid
4339#undef getpwnam
4340
4341/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
4342static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
4343
4344static struct passwd *
4345passw_wrap(struct passwd *p)
4346{
f72c975a
IZ		 4347 char *s;
4348
4349 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
4350 return p;
4351 pw = *p;
4352 s = getenv("PW_PASSWD");
4353 if (!s)
4354 s = (char*)pw_p; /* Make match impossible */
4355
4356 pw.pw_passwd = s;
4357 return &pw;
4358}
4359
4360struct passwd *
4361my_getpwuid (uid_t id)
4362{
4363 return passw_wrap(getpwuid(id));
4364}
4365
4366struct passwd *
4367my_getpwnam (__const__ char *n)
4368{
4369 return passw_wrap(getpwnam(n));
4370}
a64c954a
IZ		 4371
4372char *
4373gcvt_os2 (double value, int digits, char *buffer)
4374{
622913ab
IZ		 4375 double absv = value > 0 ? value : -value;
4376 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
4377 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
4378 int buggy;
4379
4380 absv *= 10000;
4381 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
4382
4383 if (buggy) {
4384 char pat[12];
4385
4386 sprintf(pat, "%%.%dg", digits);
4387 sprintf(buffer, pat, value);
4388 return buffer;
4389 }
a64c954a
IZ		 4390 return gcvt (value, digits, buffer);
4391}
5c728af0
IZ		 4392
4393#undef fork
4394int fork_with_resources()
4395{
4396#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
4397 dTHX;
4398 void *ctx = PERL_GET_CONTEXT;
4399#endif
622913ab 4400 unsigned fpflag = _control87(0,0);
5c728af0
IZ		 4401 int rc = fork();
4402
5c728af0 4403 if (rc == 0) { /* child */
622913ab 4404#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5c728af0
IZ		 4405 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
4406 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
5c728af0 4407#endif
622913ab
IZ		 4408
4409 { /* Reload loaded-on-demand DLLs */
4410 struct dll_handle_t *dlls = dll_handles;
4411
4412 while (dlls->modname) {
4413 char dllname[260], fail[260];
4414 ULONG rc;
4415
4416 if (!dlls->handle) { /* Was not loaded */
4417 dlls++;
4418 continue;
4419 }
4420 /* It was loaded in the parent. We need to reload it. */
4421
4422 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
4423 if (rc) {
4424 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
4425 dlls->modname, (int)dlls->handle, rc, rc);
4426 dlls++;
4427 continue;
4428 }
4429 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
4430 if (rc)
4431 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
4432 dllname, fail);
4433 dlls++;
4434 }
4435 }
4436
4437 { /* Support message queue etc. */
4438 os2_mytype = my_type();
4439 /* Apparently, subprocesses (in particular, fork()) do not
4440 inherit the morphed state, so os2_mytype is the same as
4441 os2_mytype_ini. */
4442
4443 if (Perl_os2_initial_mode != -1
4444 && Perl_os2_initial_mode != os2_mytype) {
4445 /* XXXX ??? */
4446 }
4447 }
4448 if (Perl_HAB_set)
4449 (void)_obtain_Perl_HAB;
4450 if (Perl_hmq_refcnt) {
4451 if (my_type() != 3)
4452 my_type_set(3);
4453 Create_HMQ(Perl_hmq_servers != 0,
4454 "Cannot create a message queue on fork");
4455 }
4456
4457 /* We may have loaded some modules */
4458 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
4459 }
5c728af0
IZ		 4460 return rc;
4461}
622913ab 4462
Unnamed repository; edit this file 'description' to name the repository.