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