This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
APItest: Remove use of macros about to be removed
[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 773PQTOPLEVEL
774get_sysinfo(ULONG pid, ULONG flags)
4633a7c4 775{
6f064249 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 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 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 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 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 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 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 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 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. */
491527d0 973
764df951
IZ		 974extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
975 EXCEPTIONREGISTRATIONRECORD *,
976 CONTEXTRECORD *,
977 void *);
978
4633a7c4 979int
282fc0b3 980do_spawn_ve(pTHX_ SV *really, const char **argv, U32 flag, U32 execf, char *inicmd, U32 addflag)
4633a7c4 981{
491527d0 982 int trueflag = flag;
a97be121 983 int rc, pass = 1;
1933e12c 984 char *real_name = NULL; /* Shut down the warning */
622913ab
IZ		 985 char const * args[4];
986 static const char * const fargs[4]
491527d0 987 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
622913ab 988 const char * const *argsp = fargs;
2d766320 989 int nargs = 4;
017f25f1 990 int force_shell;
65850d11 991 int new_stderr = -1, nostderr = 0;
2d766320 992 int fl_stderr = 0;
2d8e6c8d 993 STRLEN n_a;
1c46958a
IZ		 994 char *buf;
995 PerlIO *file;
491527d0 996
4633a7c4
LW		 997 if (flag == P_WAIT)
998 flag = P_NOWAIT;
282fc0b3
Z		 999 if (really) {
1000 real_name = SvPV(really, n_a);
1001 real_name = savepv(real_name);
1002 SAVEFREEPV(real_name);
1003 if (!*real_name)
1004 really = NULL;
1005 }
4633a7c4 1006
491527d0 1007 retry:
282fc0b3
Z		 1008 if (strEQ(argv[0],"/bin/sh"))
1009 argv[0] = PL_sh_path;
3bbf9c2b 1010
760ac839 1011 /* We should check PERL_SH* and PERLLIB_* as well? */
622913ab 1012 if (!really || pass >= 2)
282fc0b3 1013 real_name = argv[0];
622913ab
IZ		 1014 if (real_name[0] != '/' && real_name[0] != '\\'
1015 && !(real_name[0] && real_name[1] == ':'
1016 && (real_name[2] == '/' || real_name[2] != '\\'))
dfcfdb64
IZ		 1017 ) /* will spawnvp use PATH? */
1018 TAINT_ENV(); /* testing IFS here is overkill, probably */
017f25f1
IZ		 1019
1020 reread:
1021 force_shell = 0;
1022 if (_emx_env & 0x200) { /* OS/2. */
622913ab 1023 int type = file_type(real_name);
017f25f1
IZ		 1024 type_again:
1025 if (type == -1) { /* Not found */
1026 errno = ENOENT;
1027 rc = -1;
1028 goto do_script;
1029 }
1030 else if (type == -2) { /* Not an EXE */
1031 errno = ENOEXEC;
1032 rc = -1;
1033 goto do_script;
1034 }
1035 else if (type == -3) { /* Is a directory? */
1036 /* Special-case this */
1037 char tbuf[512];
622913ab 1038 int l = strlen(real_name);
017f25f1
IZ		 1039
1040 if (l + 5 <= sizeof tbuf) {
622913ab 1041 strcpy(tbuf, real_name);
017f25f1
IZ		 1042 strcpy(tbuf + l, ".exe");
1043 type = file_type(tbuf);
1044 if (type >= -3)
1045 goto type_again;
1046 }
1047
1048 errno = ENOEXEC;
1049 rc = -1;
1050 goto do_script;
1051 }
1052 switch (type & 7) {
1053 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
1054 case FAPPTYP_WINDOWAPI:
622913ab 1055 { /* Apparently, kids are started basing on startup type, not the morphed type */
017f25f1
IZ		 1056 if (os2_mytype != 3) { /* not PM */
1057 if (flag == P_NOWAIT)
1058 flag = P_PM;
622913ab 1059 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
f98bc0c6 1060 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d",
017f25f1
IZ		 1061 flag, os2_mytype);
1062 }
1063 }
1064 break;
1065 case FAPPTYP_NOTWINDOWCOMPAT:
1066 {
1067 if (os2_mytype != 0) { /* not full screen */
1068 if (flag == P_NOWAIT)
1069 flag = P_SESSION;
622913ab 1070 else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC))
f98bc0c6 1071 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d",
017f25f1
IZ		 1072 flag, os2_mytype);
1073 }
1074 }
1075 break;
1076 case FAPPTYP_NOTSPEC:
1077 /* Let the shell handle this... */
1078 force_shell = 1;
1c46958a
IZ		 1079 buf = ""; /* Pacify a warning */
1080 file = 0; /* Pacify a warning */
017f25f1
IZ		 1081 goto doshell_args;
1082 break;
1083 }
1084 }
1085
5838269b
IZ		 1086 if (addflag) {
1087 addflag = 0;
1088 new_stderr = dup(2); /* Preserve stderr */
1089 if (new_stderr == -1) {
1090 if (errno == EBADF)
1091 nostderr = 1;
1092 else {
1093 rc = -1;
1094 goto finish;
1095 }
1096 } else
1097 fl_stderr = fcntl(2, F_GETFD);
1098 rc = dup2(1,2);
1099 if (rc == -1)
1100 goto finish;
1101 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
1102 }
1103
491527d0 1104#if 0
282fc0b3 1105 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv));
491527d0
GS		 1106#else
1107 if (execf == EXECF_TRUEEXEC)
282fc0b3 1108 rc = execvp(real_name,argv);
491527d0 1109 else if (execf == EXECF_EXEC)
282fc0b3 1110 rc = spawnvp(trueflag | P_OVERLAY,real_name,argv);
491527d0 1111 else if (execf == EXECF_SPAWN_NOWAIT)
282fc0b3 1112 rc = spawnvp(flag,real_name,argv);
764df951 1113 else if (execf == EXECF_SYNC)
282fc0b3 1114 rc = spawnvp(trueflag,real_name,argv);
4435c477 1115 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
23da6c43 1116 rc = result(aTHX_ trueflag,
282fc0b3 1117 spawnvp(flag,real_name,argv));
491527d0 1118#endif
622913ab 1119 if (rc < 0 && pass == 1) {
017f25f1 1120 do_script:
282fc0b3 1121 if (real_name == argv[0]) {
a97be121
IZ		 1122 int err = errno;
1123
2c2e0e8c
IZ		 1124 if (err == ENOENT || err == ENOEXEC) {
1125 /* No such file, or is a script. */
1126 /* Try adding script extensions to the file name, and
1127 search on PATH. */
282fc0b3 1128 char *scr = find_script(argv[0], TRUE, NULL, 0);
2c2e0e8c
IZ		 1129
1130 if (scr) {
1c46958a
IZ		 1131 char *s = 0, *s1;
1132 SV *scrsv = sv_2mortal(newSVpv(scr, 0));
1133 SV *bufsv = sv_newmortal();
2c2e0e8c 1134
e96326af 1135 Safefree(scr);
1c46958a 1136 scr = SvPV(scrsv, n_a); /* free()ed later */
e96326af 1137
a03d92b2 1138 file = PerlIO_open(scr, "r");
282fc0b3 1139 argv[0] = scr;
2c2e0e8c
IZ		 1140 if (!file)
1141 goto panic_file;
017f25f1 1142
1c46958a
IZ		 1143 buf = sv_gets(bufsv, file, 0 /* No append */);
1144 if (!buf)
1145 buf = ""; /* XXX Needed? */
1146 if (!buf[0]) { /* Empty... */
d50541e1 1147 struct stat statbuf;
a03d92b2 1148 PerlIO_close(file);
017f25f1
IZ		 1149 /* Special case: maybe from -Zexe build, so
1150 there is an executable around (contrary to
1151 documentation, DosQueryAppType sometimes (?)
1152 does not append ".exe", so we could have
1153 reached this place). */
f8db7d5b 1154 sv_catpvs(scrsv, ".exe");
282fc0b3 1155 argv[0] = scr = SvPV(scrsv, n_a); /* Reload */
d50541e1
DIM		 1156 if (PerlLIO_stat(scr,&statbuf) >= 0
1157 && !S_ISDIR(statbuf.st_mode)) { /* Found */
622913ab 1158 real_name = scr;
017f25f1
IZ		 1159 pass++;
1160 goto reread;
1c46958a
IZ		 1161 } else { /* Restore */
1162 SvCUR_set(scrsv, SvCUR(scrsv) - 4);
1163 *SvEND(scrsv) = 0;
1164 }
2c2e0e8c 1165 }
a03d92b2 1166 if (PerlIO_close(file) != 0) { /* Failure */
2c2e0e8c 1167 panic_file:
622913ab
IZ		 1168 if (ckWARN(WARN_EXEC))
1169 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s",
2c2e0e8c 1170 scr, Strerror(errno));
1c46958a 1171 buf = ""; /* Not #! */
2c2e0e8c
IZ		 1172 goto doshell_args;
1173 }
1174 if (buf[0] == '#') {
1175 if (buf[1] == '!')
1176 s = buf + 2;
1177 } else if (buf[0] == 'e') {
c8b388b0 1178 if (strBEGINs(buf, "extproc")
2c2e0e8c
IZ		 1179 && isSPACE(buf[7]))
1180 s = buf + 8;
1181 } else if (buf[0] == 'E') {
c8b388b0 1182 if (strBEGINs(buf, "EXTPROC")
2c2e0e8c
IZ		 1183 && isSPACE(buf[7]))
1184 s = buf + 8;
1185 }
1186 if (!s) {
1c46958a 1187 buf = ""; /* Not #! */
2c2e0e8c
IZ		 1188 goto doshell_args;
1189 }
1190
1191 s1 = s;
1192 nargs = 0;
1193 argsp = args;
1194 while (1) {
1195 /* Do better than pdksh: allow a few args,
1196 strip trailing whitespace. */
1197 while (isSPACE(*s))
1198 s++;
1199 if (*s == 0)
1200 break;
1201 if (nargs == 4) {
1202 nargs = -1;
1203 break;
1204 }
1205 args[nargs++] = s;
1206 while (*s && !isSPACE(*s))
1207 s++;
1208 if (*s == 0)
1209 break;
1210 *s++ = 0;
1211 }
1212 if (nargs == -1) {
f98bc0c6 1213 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"",
2c2e0e8c
IZ		 1214 s1 - buf, buf, scr);
1215 nargs = 4;
1216 argsp = fargs;
1217 }
1c46958a 1218 /* Can jump from far, buf/file invalid if force_shell: */
2c2e0e8c
IZ		 1219 doshell_args:
1220 {
282fc0b3 1221 char **a = argv;
622913ab 1222 const char *exec_args[2];
2c2e0e8c 1223
017f25f1
IZ		 1224 if (force_shell
1225 || (!buf[0] && file)) { /* File without magic */
2c2e0e8c
IZ		 1226 /* In fact we tried all what pdksh would
1227 try. There is no point in calling
1228 pdksh, we may just emulate its logic. */
1229 char *shell = getenv("EXECSHELL");
1230 char *shell_opt = NULL;
1231
1232 if (!shell) {
1233 char *s;
1234
1235 shell_opt = "/c";
1236 shell = getenv("OS2_SHELL");
1237 if (inicmd) { /* No spaces at start! */
1238 s = inicmd;
1239 while (*s && !isSPACE(*s)) {
2d766320 1240 if (*s++ == '/') {
2c2e0e8c
IZ		 1241 inicmd = NULL; /* Cannot use */
1242 break;
1243 }
1244 }
1245 }
1246 if (!inicmd) {
282fc0b3 1247 s = argv[0];
2c2e0e8c
IZ		 1248 while (*s) {
1249 /* Dosish shells will choke on slashes
1250 in paths, fortunately, this is
1251 important for zeroth arg only. */
1252 if (*s == '/')
1253 *s = '\\';
1254 s++;
1255 }
491527d0 1256 }
491527d0 1257 }
2c2e0e8c
IZ		 1258 /* If EXECSHELL is set, we do not set */
1259
1260 if (!shell)
1261 shell = ((_emx_env & 0x200)
1262 ? "c:/os2/cmd.exe"
1263 : "c:/command.com");
1264 nargs = shell_opt ? 2 : 1; /* shell file args */
1265 exec_args[0] = shell;
1266 exec_args[1] = shell_opt;
1267 argsp = exec_args;
1268 if (nargs == 2 && inicmd) {
1269 /* Use the original cmd line */
1270 /* XXXX This is good only until we refuse
1271 quoted arguments... */
282fc0b3
Z		 1272 argv[0] = inicmd;
1273 argv[1] = NULL;
491527d0 1274 }
2c2e0e8c
IZ		 1275 } else if (!buf[0] && inicmd) { /* No file */
1276 /* Start with the original cmdline. */
1277 /* XXXX This is good only until we refuse
1278 quoted arguments... */
1279
282fc0b3
Z		 1280 argv[0] = inicmd;
1281 argv[1] = NULL;
2c2e0e8c
IZ		 1282 nargs = 2; /* shell -c */
1283 }
1284
1285 while (a[1]) /* Get to the end */
1286 a++;
1287 a++; /* Copy finil NULL too */
282fc0b3
Z		 1288 while (a >= argv) {
1289 *(a + nargs) = *a; /* argv was preallocated to be
2c2e0e8c
IZ		 1290 long enough. */
1291 a--;
491527d0 1292 }
622913ab 1293 while (--nargs >= 0) /* XXXX Discard const... */
282fc0b3 1294 argv[nargs] = (char*)argsp[nargs];
2c2e0e8c
IZ		 1295 /* Enable pathless exec if #! (as pdksh). */
1296 pass = (buf[0] == '#' ? 2 : 3);
1297 goto retry;
e29f6e02
IZ		 1298 }
1299 }
2c2e0e8c 1300 /* Not found: restore errno */
491527d0 1301 errno = err;
2c2e0e8c 1302 }
622913ab
IZ		 1303 } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */
1304 if (rc < 0 && ckWARN(WARN_EXEC))
1305 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'",
1306 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1307 ? "spawn" : "exec"),
282fc0b3 1308 real_name, argv[0]);
622913ab
IZ		 1309 goto warned;
1310 } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */
1311 if (rc < 0 && ckWARN(WARN_EXEC))
1312 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)",
1313 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1314 ? "spawn" : "exec"),
282fc0b3 1315 real_name, argv[0]);
622913ab 1316 goto warned;
017f25f1 1317 }
a97be121 1318 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
282fc0b3 1319 char *no_dir = strrchr(argv[0], '/');
2c2e0e8c
IZ		 1320
1321 /* Do as pdksh port does: if not found with /, try without
1322 path. */
1323 if (no_dir) {
282fc0b3 1324 argv[0] = no_dir + 1;
2c2e0e8c 1325 pass++;
e29f6e02
IZ		 1326 goto retry;
1327 }
1328 }
0453d815 1329 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1330 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n",
491527d0
GS		 1331 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
1332 ? "spawn" : "exec"),
622913ab
IZ		 1333 real_name, Strerror(errno));
1334 warned:
491527d0
GS		 1335 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
1336 && ((trueflag & 0xFF) == P_WAIT))
ed344e4f 1337 rc = -1;
491527d0 1338
5838269b
IZ		 1339 finish:
1340 if (new_stderr != -1) { /* How can we use error codes? */
1341 dup2(new_stderr, 2);
1342 close(new_stderr);
1343 fcntl(2, F_SETFD, fl_stderr);
1344 } else if (nostderr)
1345 close(2);
491527d0
GS		 1346 return rc;
1347}
1348
491527d0 1349/* Try converting 1-arg form to (usually shell-less) multi-arg form. */
4633a7c4 1350int
23da6c43 1351do_spawn3(pTHX_ char *cmd, int execf, int flag)
4633a7c4 1352{
282fc0b3 1353 char **argv, **a;
eb578fdb 1354 char *s;
3bbf9c2b 1355 char *shell, *copt, *news = NULL;
2d766320 1356 int rc, seenspace = 0, mergestderr = 0;
4633a7c4 1357
282fc0b3 1358 ENTER;
c0c09dfd 1359#ifdef TRYSHELL
1360 if ((shell = getenv("EMXSHELL")) != NULL)
1361 copt = "-c";
1362 else if ((shell = getenv("SHELL")) != NULL)
4633a7c4
LW		 1363 copt = "-c";
1364 else if ((shell = getenv("COMSPEC")) != NULL)
1365 copt = "/C";
1366 else
1367 shell = "cmd.exe";
c0c09dfd 1368#else
1369 /* Consensus on perl5-porters is that it is _very_ important to
1370 have a shell which will not change between computers with the
1371 same architecture, to avoid "action on a distance".
1372 And to have simple build, this shell should be sh. */
6b88bc9c 1373 shell = PL_sh_path;
c0c09dfd 1374 copt = "-c";
1375#endif
1376
1377 while (*cmd && isSPACE(*cmd))
1378 cmd++;
4633a7c4 1379
c8b388b0 1380 if (strBEGINs(cmd,"/bin/sh") && isSPACE(cmd[7])) {
6b88bc9c 1381 STRLEN l = strlen(PL_sh_path);
3bbf9c2b 1382
a02a5408 1383 Newx(news, strlen(cmd) - 7 + l + 1, char);
6b88bc9c 1384 strcpy(news, PL_sh_path);
3bbf9c2b
IZ		 1385 strcpy(news + l, cmd + 7);
1386 cmd = news;
1387 }
1388
4633a7c4
LW		 1389 /* save an extra exec if possible */
1390 /* see if there are shell metacharacters in it */
1391
c0c09dfd 1392 if (*cmd == '.' && isSPACE(cmd[1]))
1393 goto doshell;
1394
c8b388b0 1395 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
c0c09dfd 1396 goto doshell;
1397
1398 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
1399 if (*s == '=')
1400 goto doshell;
1401
4633a7c4 1402 for (s = cmd; *s; s++) {
c0c09dfd 1403 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
3bbf9c2b 1404 if (*s == '\n' && s[1] == '\0') {
4633a7c4
LW		 1405 *s = '\0';
1406 break;
a0914d8e
IZ		 1407 } else if (*s == '\\' && !seenspace) {
1408 continue; /* Allow backslashes in names */
5838269b
IZ		 1409 } else if (*s == '>' && s >= cmd + 3
1410 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
1411 && isSPACE(s[-2]) ) {
1412 char *t = s + 3;
1413
1414 while (*t && isSPACE(*t))
1415 t++;
1416 if (!*t) {
1417 s[-2] = '\0';
1418 mergestderr = 1;
1419 break; /* Allow 2>&1 as the last thing */
1420 }
4633a7c4 1421 }
491527d0
GS		 1422 /* We do not convert this to do_spawn_ve since shell
1423 should be smart enough to start itself gloriously. */
c0c09dfd 1424 doshell:
760ac839 1425 if (execf == EXECF_TRUEEXEC)
764df951 1426 rc = execl(shell,shell,copt,cmd,(char*)0);
760ac839 1427 else if (execf == EXECF_EXEC)
2c2e0e8c 1428 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
72ea3524 1429 else if (execf == EXECF_SPAWN_NOWAIT)
2c2e0e8c 1430 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
4435c477
IZ		 1431 else if (execf == EXECF_SPAWN_BYFLAG)
1432 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
2c2e0e8c
IZ		 1433 else {
1434 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
764df951
IZ		 1435 if (execf == EXECF_SYNC)
1436 rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0);
1437 else
1438 rc = result(aTHX_ P_WAIT,
1439 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
0453d815 1440 if (rc < 0 && ckWARN(WARN_EXEC))
f98bc0c6 1441 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s",
2c2e0e8c
IZ		 1442 (execf == EXECF_SPAWN ? "spawn" : "exec"),
1443 shell, Strerror(errno));
ed344e4f
IZ		 1444 if (rc < 0)
1445 rc = -1;
2c2e0e8c
IZ		 1446 }
1447 if (news)
1448 Safefree(news);
282fc0b3 1449 goto leave;
a0914d8e
IZ		 1450 } else if (*s == ' ' || *s == '\t') {
1451 seenspace = 1;
4633a7c4
LW		 1452 }
1453 }
c0c09dfd 1454
491527d0 1455 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
282fc0b3
Z		 1456 Newx(argv, (s - cmd + 11) / 2, char*);
1457 SAVEFREEPV(argv);
1458 cmd = savepvn(cmd, s-cmd);
1459 SAVEFREEPV(cmd);
1460 a = argv;
1461 for (s = cmd; *s;) {
4633a7c4
LW		 1462 while (*s && isSPACE(*s)) s++;
1463 if (*s)
1464 *(a++) = s;
1465 while (*s && !isSPACE(*s)) s++;
1466 if (*s)
1467 *s++ = '\0';
1468 }
4e205ed6 1469 *a = NULL;
282fc0b3
Z		 1470 if (argv[0])
1471 rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr);
491527d0 1472 else
4633a7c4 1473 rc = -1;
2c2e0e8c
IZ		 1474 if (news)
1475 Safefree(news);
282fc0b3
Z		 1476leave:
1477 LEAVE;
4633a7c4
LW		 1478 return rc;
1479}
1480
9d419b5f
IZ		 1481#define ASPAWN_WAIT 0
1482#define ASPAWN_EXEC 1
1483#define ASPAWN_NOWAIT 2
1484
622913ab 1485/* Array spawn/exec. */
4435c477 1486int
5aaab254 1487os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing)
4435c477 1488{
eb578fdb
KW		 1489 SV **argp = (SV **)args;
1490 SV **last = argp + cnt;
282fc0b3 1491 char **argv, **a;
4435c477
IZ		 1492 int rc;
1493 int flag = P_WAIT, flag_set = 0;
1494 STRLEN n_a;
1495
282fc0b3 1496 ENTER;
9d419b5f 1497 if (cnt) {
282fc0b3
Z		 1498 Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */
1499 SAVEFREEPV(argv);
1500 a = argv;
4435c477 1501
9d419b5f
IZ		 1502 if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
1503 flag = SvIVx(*argp);
1504 flag_set = 1;
1505 } else
1506 --argp;
4435c477 1507
9d419b5f 1508 while (++argp < last) {
282fc0b3
Z		 1509 if (*argp) {
1510 char *arg = SvPVx(*argp, n_a);
1511 arg = savepv(arg);
1512 SAVEFREEPV(arg);
1513 *a++ = arg;
1514 } else
4435c477
IZ		 1515 *a++ = "";
1516 }
4e205ed6 1517 *a = NULL;
4435c477 1518
282fc0b3 1519 if ( flag_set && (a == argv + 1)
9d419b5f 1520 && !really && execing == ASPAWN_WAIT ) { /* One arg? */
23da6c43 1521 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
9d419b5f
IZ		 1522 } else {
1523 const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
1524
282fc0b3 1525 rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0);
9d419b5f 1526 }
4435c477
IZ		 1527 } else
1528 rc = -1;
282fc0b3 1529 LEAVE;
4435c477
IZ		 1530 return rc;
1531}
1532
622913ab
IZ		 1533/* Array spawn. */
1534int
5aaab254 1535os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp)
622913ab 1536{
9d419b5f 1537 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
622913ab
IZ		 1538}
1539
1540/* Array exec. */
1541bool
1542Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1543{
9d419b5f 1544 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
622913ab
IZ		 1545}
1546
760ac839 1547int
23da6c43 1548os2_do_spawn(pTHX_ char *cmd)
760ac839 1549{
23da6c43 1550 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
760ac839
LW		 1551}
1552
72ea3524 1553int
23da6c43 1554do_spawn_nowait(pTHX_ char *cmd)
72ea3524 1555{
23da6c43 1556 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524
IZ		 1557}
1558
760ac839 1559bool
751e07d2 1560Perl_do_exec(pTHX_ const char *cmd)
760ac839 1561{
23da6c43 1562 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
017f25f1 1563 return FALSE;
760ac839
LW		 1564}
1565
1566bool
23da6c43 1567os2exec(pTHX_ char *cmd)
760ac839 1568{
23da6c43 1569 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
760ac839
LW		 1570}
1571
3bbf9c2b 1572PerlIO *
9d419b5f 1573my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
c0c09dfd 1574{
72ea3524 1575#ifndef USE_POPEN
72ea3524 1576 int p[2];
eb578fdb
KW		 1577 I32 this, that, newfd;
1578 I32 pid;
3bbf9c2b 1579 SV *sv;
2d766320 1580 int fh_fl = 0; /* Pacify the warning */
72ea3524 1581
72ea3524
IZ		 1582 /* `this' is what we use in the parent, `that' in the child. */
1583 this = (*mode == 'w');
1584 that = !this;
284167a5 1585 if (TAINTING_get) {
72ea3524
IZ		 1586 taint_env();
1587 taint_proper("Insecure %s%s", "EXEC");
1588 }
c2267164 1589 if (pipe(p) < 0)
4e205ed6 1590 return NULL;
72ea3524 1591 /* Now we need to spawn the child. */
5838269b
IZ		 1592 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1593 int new = dup(p[this]);
1594
1595 if (new == -1)
1596 goto closepipes;
1597 close(p[this]);
1598 p[this] = new;
1599 }
72ea3524 1600 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b
IZ		 1601 if (newfd == -1) {
1602 /* This cannot happen due to fh being bad after pipe(), since
1603 pipe() should have created fh 0 and 1 even if they were
1604 initially closed. But we closed p[this] before. */
1605 if (errno != EBADF) {
1606 closepipes:
1607 close(p[0]);
1608 close(p[1]);
4e205ed6 1609 return NULL;
5838269b
IZ		 1610 }
1611 } else
1612 fh_fl = fcntl(*mode == 'r', F_GETFD);
1613 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
72ea3524
IZ		 1614 dup2(p[that], *mode == 'r');
1615 close(p[that]);
1616 }
1617 /* Where is `this' and newfd now? */
1618 fcntl(p[this], F_SETFD, FD_CLOEXEC);
5838269b
IZ		 1619 if (newfd != -1)
1620 fcntl(newfd, F_SETFD, FD_CLOEXEC);
9d419b5f 1621 if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */
4e205ed6 1622 pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT);
9d419b5f
IZ		 1623 } else
1624 pid = do_spawn_nowait(aTHX_ cmd);
5838269b
IZ		 1625 if (newfd == -1)
1626 close(*mode == 'r'); /* It was closed initially */
1627 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524
IZ		 1628 dup2(newfd, *mode == 'r'); /* Return std* back. */
1629 close(newfd);
5838269b
IZ		 1630 fcntl(*mode == 'r', F_SETFD, fh_fl);
1631 } else
1632 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0
GS		 1633 if (p[that] == (*mode == 'r'))
1634 close(p[that]);
72ea3524
IZ		 1635 if (pid == -1) {
1636 close(p[this]);
4e205ed6 1637 return NULL;
72ea3524 1638 }
5838269b 1639 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524
IZ		 1640 dup2(p[this], p[that]);
1641 close(p[this]);
1642 p[this] = p[that];
1643 }
6b88bc9c 1644 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524
IZ		 1645 (void)SvUPGRADE(sv,SVt_IV);
1646 SvIVX(sv) = pid;
6b88bc9c 1647 PL_forkprocess = pid;
72ea3524 1648 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1649
72ea3524
IZ		 1650#else /* USE_POPEN */
1651
1652 PerlIO *res;
1653 SV *sv;
1654
9d419b5f
IZ		 1655 if (cnt)
1656 Perl_croak(aTHX_ "List form of piped open not implemented");
1657
72ea3524 1658# ifdef TRYSHELL
3bbf9c2b 1659 res = popen(cmd, mode);
72ea3524 1660# else
c0c09dfd 1661 char *shell = getenv("EMXSHELL");
3bbf9c2b 1662
6b88bc9c 1663 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 1664 res = popen(cmd, mode);
1665 my_setenv("EMXSHELL", shell);
72ea3524 1666# endif
6b88bc9c 1667 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
3bbf9c2b
IZ		 1668 (void)SvUPGRADE(sv,SVt_IV);
1669 SvIVX(sv) = -1; /* A cooky. */
1670 return res;
72ea3524
IZ		 1671
1672#endif /* USE_POPEN */
1673
c0c09dfd 1674}
1675
9d419b5f
IZ		 1676PerlIO *
1677my_syspopen(pTHX_ char *cmd, char *mode)
1678{
1679 return my_syspopen4(aTHX_ cmd, mode, 0, NULL);
1680}
1681
3bbf9c2b 1682/******************************************************************/
4633a7c4
LW		 1683
1684#ifndef HAS_FORK
1685int
1686fork(void)
1687{
23da6c43 1688 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
4633a7c4
LW		 1689 errno = EINVAL;
1690 return -1;
1691}
1692#endif
1693
3bbf9c2b 1694/*******************************************************************/
46e87256 1695/* not implemented in EMX 0.9d */
4633a7c4 1696
46e87256 1697char * ctermid(char *s) { return 0; }
eacfb5f1 1698
1699#ifdef MYTTYNAME /* was not in emx0.9a */
4633a7c4 1700void * ttyname(x) { return 0; }
eacfb5f1 1701#endif
4633a7c4 1702
760ac839
LW		 1703/*****************************************************************************/
1704/* not implemented in C Set++ */
1705
1706#ifndef __EMX__
1707int setuid(x) { errno = EINVAL; return -1; }
1708int setgid(x) { errno = EINVAL; return -1; }
1709#endif
4633a7c4
LW		 1710
1711/*****************************************************************************/
1712/* stat() hack for char/block device */
1713
1714#if OS2_STAT_HACK
1715
5c728af0
IZ		 1716enum os2_stat_extra { /* EMX 0.9d fix 4 defines up to 0100000 */
1717 os2_stat_archived = 0x1000000, /* 0100000000 */
1718 os2_stat_hidden = 0x2000000, /* 0200000000 */
1719 os2_stat_system = 0x4000000, /* 0400000000 */
1720 os2_stat_force = 0x8000000, /* Do not ignore flags on chmod */
1721};
1722
1723#define OS2_STAT_SPECIAL (os2_stat_system | os2_stat_archived | os2_stat_hidden)
1724
1725static void
1726massage_os2_attr(struct stat *st)
1727{
1728 if ( ((st->st_mode & S_IFMT) != S_IFREG
1729 && (st->st_mode & S_IFMT) != S_IFDIR)
1730 || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM)))
1731 return;
1732
1733 if ( st->st_attr & FILE_ARCHIVED )
1734 st->st_mode |= (os2_stat_archived | os2_stat_force);
1735 if ( st->st_attr & FILE_HIDDEN )
1736 st->st_mode |= (os2_stat_hidden | os2_stat_force);
1737 if ( st->st_attr & FILE_SYSTEM )
1738 st->st_mode |= (os2_stat_system | os2_stat_force);
1739}
1740
4633a7c4
LW		 1741 /* First attempt used DosQueryFSAttach which crashed the system when
1742 used with 5.001. Now just look for /dev/. */
4633a7c4 1743int
2d766320 1744os2_stat(const char *name, struct stat *st)
4633a7c4
LW		 1745{
1746 static int ino = SHRT_MAX;
5c728af0
IZ		 1747 STRLEN l = strlen(name);
1748
1749 if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0
1750 || ( stricmp(name + 5, "con") != 0
1751 && stricmp(name + 5, "tty") != 0
1752 && stricmp(name + 5, "nul") != 0
1753 && stricmp(name + 5, "null") != 0) ) {
1754 int s = stat(name, st);
1755
1756 if (s)
1757 return s;
1758 massage_os2_attr(st);
1759 return 0;
1760 }
4633a7c4
LW		 1761
1762 memset(st, 0, sizeof *st);
1763 st->st_mode = S_IFCHR|0666;
622913ab 1764 MUTEX_LOCK(&perlos2_state_mutex);
4633a7c4 1765 st->st_ino = (ino-- & 0x7FFF);
622913ab 1766 MUTEX_UNLOCK(&perlos2_state_mutex);
4633a7c4
LW		 1767 st->st_nlink = 1;
1768 return 0;
1769}
1770
5c728af0
IZ		 1771int
1772os2_fstat(int handle, struct stat *st)
1773{
1774 int s = fstat(handle, st);
1775
1776 if (s)
1777 return s;
1778 massage_os2_attr(st);
1779 return 0;
1780}
1781
1782#undef chmod
1783int
1784os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c */
1785{
1786 int attr, rc;
1787
1788 if (!(pmode & os2_stat_force))
1789 return chmod(name, pmode);
1790
1791 attr = __chmod (name, 0, 0); /* Get attributes */
1792 if (attr < 0)
1793 return -1;
1794 if (pmode & S_IWRITE)
1795 attr &= ~FILE_READONLY;
1796 else
1797 attr |= FILE_READONLY;
1798 /* New logic */
1799 attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM);
1800
1801 if ( pmode & os2_stat_archived )
1802 attr |= FILE_ARCHIVED;
1803 if ( pmode & os2_stat_hidden )
1804 attr |= FILE_HIDDEN;
1805 if ( pmode & os2_stat_system )
1806 attr |= FILE_SYSTEM;
1807
1808 rc = __chmod (name, 1, attr);
1809 if (rc >= 0) rc = 0;
1810 return rc;
1811}
1812
4633a7c4 1813#endif
c0c09dfd 1814
760ac839 1815#ifdef USE_PERL_SBRK
c0c09dfd 1816
760ac839 1817/* SBRK() emulation, mostly moved to malloc.c. */
c0c09dfd 1818
1819void *
760ac839
LW		 1820sys_alloc(int size) {
1821 void *got;
1822 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1823
c0c09dfd 1824 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1825 return (void *) -1;
4bfbfac5 1826 } else if ( rc )
23da6c43 1827 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
760ac839 1828 return got;
c0c09dfd 1829}
760ac839
LW		 1830
1831#endif /* USE_PERL_SBRK */
c0c09dfd 1832
1833/* tmp path */
1834
622913ab 1835const char *tmppath = TMPPATH1;
c0c09dfd 1836
1837void
1838settmppath()
1839{
1840 char *p = getenv("TMP"), *tpath;
1841 int len;
1842
1843 if (!p) p = getenv("TEMP");
622913ab 1844 if (!p) p = getenv("TMPDIR");
c0c09dfd 1845 if (!p) return;
1846 len = strlen(p);
1847 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
db7c17d7
GS		 1848 if (tpath) {
1849 strcpy(tpath, p);
1850 tpath[len] = '/';
1851 strcpy(tpath + len + 1, TMPPATH1);
1852 tmppath = tpath;
1853 }
c0c09dfd 1854}
7a2f0d5b 1855
1856#include "XSUB.h"
1857
1858XS(XS_File__Copy_syscopy)
1859{
1860 dXSARGS;
1861 if (items < 2 || items > 3)
23da6c43 1862 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
7a2f0d5b 1863 {
2d8e6c8d
GS		 1864 STRLEN n_a;
1865 char * src = (char *)SvPV(ST(0),n_a);
1866 char * dst = (char *)SvPV(ST(1),n_a);
7a2f0d5b 1867 U32 flag;
1868 int RETVAL, rc;
622913ab 1869 dXSTARG;
7a2f0d5b 1870
1871 if (items < 3)
1872 flag = 0;
1873 else {
1874 flag = (unsigned long)SvIV(ST(2));
1875 }
1876
6f064249 1877 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
622913ab 1878 XSprePUSH; PUSHi((IV)RETVAL);
7a2f0d5b 1879 }
1880 XSRETURN(1);
1881}
1882
d79a646b
JH		 1883/* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */
1884
1885DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule,
1886 (char *old, char *new, char *backup), (old, new, backup))
1887
1888XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */
1889XS(XS_OS2_replaceModule)
1890{
1891 dXSARGS;
1892 if (items < 1 || items > 3)
1893 Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])");
1894 {
1895 char * target = (char *)SvPV_nolen(ST(0));
4e205ed6
SP		 1896 char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1));
1897 char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2));
d79a646b
JH		 1898
1899 if (!replaceModule(target, source, backup))
1900 croak_with_os2error("replaceModule() error");
1901 }
9d419b5f 1902 XSRETURN_YES;
d79a646b
JH		 1903}
1904
59ad941d
IZ		 1905/* APIRET APIENTRY DosPerfSysCall(ULONG ulCommand, ULONG ulParm1,
1906 ULONG ulParm2, ULONG ulParm3); */
1907
1908DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall,
1909 (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3),
1910 (ulCommand, ulParm1, ulParm2, ulParm3))
1911
1912#ifndef CMD_KI_RDCNT
1913# define CMD_KI_RDCNT 0x63
1914#endif
1915#ifndef CMD_KI_GETQTY
1916# define CMD_KI_GETQTY 0x41
1917#endif
1918#ifndef QSV_NUMPROCESSORS
1919# define QSV_NUMPROCESSORS 26
1920#endif
1921
1922typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */
1923
1924/*
1925NO_OUTPUT ULONG
1926perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3)
1927 PREINIT:
1928 ULONG rc;
1929 POSTCALL:
1930 if (!RETVAL)
1931 croak_with_os2error("perfSysCall() error");
1932 */
1933
1934static int
1935numprocessors(void)
1936{
1937 ULONG res;
1938
1939 if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res)))
1940 return 1; /* Old system? */
1941 return res;
1942}
1943
1944XS(XS_OS2_perfSysCall); /* prototype to pass -Wmissing-prototypes */
1945XS(XS_OS2_perfSysCall)
1946{
1947 dXSARGS;
1948 if (items < 0 || items > 4)
1949 Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)");
1950 SP -= items;
1951 {
1952 dXSTARG;
1953 ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res;
1954 myCPUUTIL u[64];
1955 int total = 0, tot2 = 0;
1956
1957 if (items < 1)
1958 ulCommand = CMD_KI_RDCNT;
1959 else {
1960 ulCommand = (ULONG)SvUV(ST(0));
1961 }
1962
1963 if (items < 2) {
1964 total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0);
1965 ulParm1 = (total ? (ULONG)u : 0);
1966
1967 if (total > C_ARRAY_LENGTH(u))
1968 croak("Unexpected number of processors: %d", total);
1969 } else {
1970 ulParm1 = (ULONG)SvUV(ST(1));
1971 }
1972
1973 if (items < 3) {
1974 tot2 = (ulCommand == CMD_KI_GETQTY);
1975 ulParm2 = (tot2 ? (ULONG)&res : 0);
1976 } else {
1977 ulParm2 = (ULONG)SvUV(ST(2));
1978 }
1979
1980 if (items < 4)
1981 ulParm3 = 0;
1982 else {
1983 ulParm3 = (ULONG)SvUV(ST(3));
1984 }
1985
1986 RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3);
1987 if (!RETVAL)
1988 croak_with_os2error("perfSysCall() error");
9d419b5f 1989 XSprePUSH;
59ad941d
IZ		 1990 if (total) {
1991 int i,j;
1992
1993 if (GIMME_V != G_ARRAY) {
1994 PUSHn(u[0][0]); /* Total ticks on the first processor */
1995 XSRETURN(1);
1996 }
9d419b5f 1997 EXTEND(SP, 4*total);
59ad941d
IZ		 1998 for (i=0; i < total; i++)
1999 for (j=0; j < 4; j++)
2000 PUSHs(sv_2mortal(newSVnv(u[i][j])));
2001 XSRETURN(4*total);
2002 }
2003 if (tot2) {
2004 PUSHu(res);
2005 XSRETURN(1);
2006 }
2007 }
2008 XSRETURN_EMPTY;
2009}
d79a646b 2010
1c46958a 2011#define PERL_PATCHLEVEL_H_IMPLICIT /* Do not init local_patches. */
017f25f1 2012#include "patchlevel.h"
1c46958a 2013#undef PERL_PATCHLEVEL_H_IMPLICIT
017f25f1 2014
6f064249 2015char *
23da6c43 2016mod2fname(pTHX_ SV *sv)
6f064249 2017{
760ac839
LW		 2018 int pos = 6, len, avlen;
2019 unsigned int sum = 0;
6f064249 2020 char *s;
2d8e6c8d 2021 STRLEN n_a;
6f064249 2022
23da6c43 2023 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
6f064249 2024 sv = SvRV(sv);
2025 if (SvTYPE(sv) != SVt_PVAV)
23da6c43 2026 Perl_croak_nocontext("Not array reference given to mod2fname");
760ac839 2027
b9f2b683 2028 avlen = av_tindex((AV*)sv);
760ac839 2029 if (avlen < 0)
23da6c43 2030 Perl_croak_nocontext("Empty array reference given to mod2fname");
760ac839 2031
2d8e6c8d 2032 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
6f064249 2033 strncpy(fname, s, 8);
760ac839
LW		 2034 len = strlen(s);
2035 if (len < 6) pos = len;
2036 while (*s) {
2037 sum = 33 * sum + *(s++); /* Checksumming first chars to
2038 * get the capitalization into c.s. */
2039 }
2040 avlen --;
2041 while (avlen >= 0) {
2d8e6c8d 2042 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
760ac839
LW		 2043 while (*s) {
2044 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
2045 }
2046 avlen --;
2047 }
bea19d3f
IZ		 2048 /* We always load modules as *specific* DLLs, and with the full name.
2049 When loading a specific DLL by its full name, one cannot get a
2050 different DLL, even if a DLL with the same basename is loaded already.
2051 Thus there is no need to include the version into the mangling scheme. */
2052#if 0
2053 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
2054#else
2055# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
2056# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
2057# endif
2058 sum += COMPATIBLE_VERSION_SUM;
2059#endif
760ac839
LW		 2060 fname[pos] = 'A' + (sum % 26);
2061 fname[pos + 1] = 'A' + (sum / 26 % 26);
2062 fname[pos + 2] = '\0';
6f064249 2063 return (char *)fname;
2064}
2065
2066XS(XS_DynaLoader_mod2fname)
2067{
2068 dXSARGS;
2069 if (items != 1)
23da6c43 2070 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
6f064249 2071 {
2072 SV * sv = ST(0);
2073 char * RETVAL;
622913ab 2074 dXSTARG;
6f064249 2075
23da6c43 2076 RETVAL = mod2fname(aTHX_ sv);
622913ab
IZ		 2077 sv_setpv(TARG, RETVAL);
2078 XSprePUSH; PUSHTARG;
6f064249 2079 }
2080 XSRETURN(1);
2081}
2082
2083char *
2084os2error(int rc)
2085{
5c728af0 2086 dTHX;
6f064249 2087 ULONG len;
9fed8b87 2088 char *s;
64ace3f8 2089 int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD));
6f064249 2090
55497cff 2091 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
6f064249 2092 if (rc == 0)
9fed8b87
IZ		 2093 return "";
2094 if (number) {
622913ab
IZ		 2095 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2096 s = os2error_buf + strlen(os2error_buf);
9fed8b87 2097 } else
622913ab
IZ		 2098 s = os2error_buf;
2099 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
9fed8b87 2100 rc, "OSO001.MSG", &len)) {
622913ab
IZ		 2101 char *name = "";
2102
9fed8b87 2103 if (!number) {
622913ab
IZ		 2104 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
2105 s = os2error_buf + strlen(os2error_buf);
9fed8b87 2106 }
622913ab
IZ		 2107 switch (rc) {
2108 case PMERR_INVALID_HWND:
2109 name = "PMERR_INVALID_HWND";
2110 break;
2111 case PMERR_INVALID_HMQ:
2112 name = "PMERR_INVALID_HMQ";
2113 break;
2114 case PMERR_CALL_FROM_WRONG_THREAD:
2115 name = "PMERR_CALL_FROM_WRONG_THREAD";
2116 break;
2117 case PMERR_NO_MSG_QUEUE:
2118 name = "PMERR_NO_MSG_QUEUE";
2119 break;
2120 case PMERR_NOT_IN_A_PM_SESSION:
2121 name = "PMERR_NOT_IN_A_PM_SESSION";
2122 break;
9d419b5f
IZ		 2123 case PMERR_INVALID_ATOM:
2124 name = "PMERR_INVALID_ATOM";
2125 break;
2126 case PMERR_INVALID_HATOMTBL:
2127 name = "PMERR_INVALID_HATOMTMB";
2128 break;
2129 case PMERR_INVALID_INTEGER_ATOM:
2130 name = "PMERR_INVALID_INTEGER_ATOM";
2131 break;
2132 case PMERR_INVALID_ATOM_NAME:
2133 name = "PMERR_INVALID_ATOM_NAME";
2134 break;
2135 case PMERR_ATOM_NAME_NOT_FOUND:
2136 name = "PMERR_ATOM_NAME_NOT_FOUND";
2137 break;
622913ab
IZ		 2138 }
2139 sprintf(s, "%s%s[No description found in OSO001.MSG]",
2140 name, (*name ? "=" : ""));
9fed8b87
IZ		 2141 } else {
2142 s[len] = '\0';
2143 if (len && s[len - 1] == '\n')
2144 s[--len] = 0;
2145 if (len && s[len - 1] == '\r')
2146 s[--len] = 0;
2147 if (len && s[len - 1] == '.')
2148 s[--len] = 0;
622913ab 2149 if (len >= 10 && number && strnEQ(s, os2error_buf, 7)
9fed8b87
IZ		 2150 && s[7] == ':' && s[8] == ' ')
2151 /* Some messages start with SYSdddd:, some not */
2152 Move(s + 9, s, (len -= 9) + 1, char);
ed344e4f 2153 }
622913ab 2154 return os2error_buf;
6f064249 2155}
2156
30500b05
IZ		 2157void
2158ResetWinError(void)
2159{
2160 WinError_2_Perl_rc;
2161}
2162
2163void
2164CroakWinError(int die, char *name)
2165{
2166 FillWinError;
1933e12c
IZ		 2167 if (die && Perl_rc)
2168 croak_with_os2error(name ? name : "Win* API call");
2169}
5c728af0 2170
1933e12c
IZ		 2171static char *
2172dllname2buffer(pTHX_ char *buf, STRLEN l)
2173{
2174 char *o;
2175 STRLEN ll;
4e205ed6 2176 SV *dll = NULL;
1933e12c
IZ		 2177
2178 dll = module_name(mod_name_full);
2179 o = SvPV(dll, ll);
2180 if (ll < l)
2181 memcpy(buf,o,ll);
2182 SvREFCNT_dec(dll);
2183 return (ll >= l ? "???" : buf);
30500b05
IZ		 2184}
2185
1933e12c
IZ		 2186static char *
2187execname2buffer(char *buf, STRLEN l, char *oname)
ed344e4f 2188{
1933e12c 2189 char *p, *orig = oname, ok = oname != NULL;
ed344e4f 2190
1933e12c
IZ		 2191 if (_execname(buf, l) != 0) {
2192 if (!oname || strlen(oname) >= l)
2193 return oname;
2194 strcpy(buf, oname);
2195 ok = 0;
2196 }
ed344e4f
IZ		 2197 p = buf;
2198 while (*p) {
2199 if (*p == '\\')
2200 *p = '/';
5ba48348 2201 if (*p == '/') {
1933e12c 2202 if (ok && *oname != '/' && *oname != '\\')
5ba48348 2203 ok = 0;
1933e12c 2204 } else if (ok && tolower(*oname) != tolower(*p))
5ba48348 2205 ok = 0;
ed344e4f 2206 p++;
1933e12c 2207 oname++;
5ba48348 2208 }
1933e12c
IZ		 2209 if (ok) { /* orig matches the real name. Use orig: */
2210 strcpy(buf, orig); /* _execname() is always uppercased */
5ba48348
JH		 2211 p = buf;
2212 while (*p) {
2213 if (*p == '\\')
2214 *p = '/';
2215 p++;
2216 }
ed344e4f 2217 }
1933e12c
IZ		 2218 return buf;
2219}
2220
2221char *
2222os2_execname(pTHX)
2223{
2224 char buf[300], *p = execname2buffer(buf, sizeof buf, PL_origargv[0]);
2225
2226 p = savepv(p);
ed344e4f
IZ		 2227 SAVEFREEPV(p);
2228 return p;
2229}
2230
1933e12c
IZ		 2231int
2232Perl_OS2_handler_install(void *handler, enum Perlos2_handler how)
2233{
2234 char *s, b[300];
2235
2236 switch (how) {
2237 case Perlos2_handler_mangle:
2238 perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler;
2239 return 1;
2240 case Perlos2_handler_perl_sh:
2241 s = (char *)handler;
2242 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh");
2243 perl_sh_installed = savepv(s);
2244 return 1;
2245 case Perlos2_handler_perllib_from:
2246 s = (char *)handler;
2247 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from");
2248 oldl = strlen(s);
2249 oldp = savepv(s);
2250 return 1;
2251 case Perlos2_handler_perllib_to:
2252 s = (char *)handler;
2253 s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to");
2254 newl = strlen(s);
2255 newp = savepv(s);
2256 strcpy(mangle_ret, newp);
2257 s = mangle_ret - 1;
2258 while (*++s)
2259 if (*s == '\\')
2260 *s = '/';
2261 return 1;
2262 default:
2263 return 0;
2264 }
2265}
2266
2267/* Returns a malloc()ed copy */
2268char *
2269dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e flags, char *msg)
2270{
2271 char *from, *to = b, *e = b; /* `to' assignment: shut down the warning */
2272 STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */
2273
2274 if (l >= 2 && s[0] == '~') {
2275 switch (s[1]) {
2276 case 'i': case 'I':
2277 from = "installprefix"; break;
2278 case 'd': case 'D':
2279 from = "dll"; break;
2280 case 'e': case 'E':
2281 from = "exe"; break;
2282 default:
2283 from = NULL;
2284 froml = l + 1; /* Will not match */
2285 break;
2286 }
2287 if (from)
2288 froml = strlen(from) + 1;
2289 if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) {
2290 int strip = 1;
2291
2292 switch (s[1]) {
2293 case 'i': case 'I':
2294 strip = 0;
2295 tol = strlen(INSTALL_PREFIX);
2296 if (tol >= bl) {
2297 if (flags & dir_subst_fatal)
2298 Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX);
2299 else
2300 return NULL;
2301 }
2302 memcpy(b, INSTALL_PREFIX, tol + 1);
2303 to = b;
2304 e = b + tol;
2305 break;
2306 case 'd': case 'D':
2307 if (flags & dir_subst_fatal) {
2308 dTHX;
2309
2310 to = dllname2buffer(aTHX_ b, bl);
2311 } else { /* No Perl present yet */
2312 HMODULE self = find_myself();
2313 APIRET rc = DosQueryModuleName(self, bl, b);
2314
2315 if (rc)
2316 return 0;
2317 to = b - 1;
2318 while (*++to)
2319 if (*to == '\\')
2320 *to = '/';
2321 to = b;
2322 }
2323 break;
2324 case 'e': case 'E':
2325 if (flags & dir_subst_fatal) {
2326 dTHX;
2327
2328 to = execname2buffer(b, bl, PL_origargv[0]);
2329 } else
2330 to = execname2buffer(b, bl, NULL);
2331 break;
2332 }
2333 if (!to)
2334 return NULL;
2335 if (strip) {
2336 e = strrchr(to, '/');
2337 if (!e && (flags & dir_subst_fatal))
2338 Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to);
2339 else if (!e)
2340 return NULL;
2341 *e = 0;
2342 }
2343 s += froml; l -= froml;
2344 if (!l)
2345 return to;
2346 if (!tol)
2347 tol = strlen(to);
2348
2349 while (l >= 3 && (s[0] == '/' || s[0] == '\\')
2350 && s[1] == '.' && s[2] == '.'
2351 && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) {
2352 e = strrchr(b, '/');
2353 if (!e && (flags & dir_subst_fatal))
2354 Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg);
2355 else if (!e)
2356 return NULL;
2357 *e = 0;
2358 l -= 3; s += 3;
2359 }
2360 if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';')
2361 *e++ = '/';
2362 }
2363 } /* Else: copy as is */
2364 if (l && (flags & dir_subst_pathlike)) {
2365 STRLEN i = 0;
2366
2367 while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */
2368 i++;
2369 if (i < l - 2) { /* Found */
2370 rest = l - i - 1;
2371 l = i + 1;
2372 }
2373 }
2374 if (e + l >= b + bl) {
2375 if (flags & dir_subst_fatal)
2376 Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s);
2377 else
2378 return NULL;
2379 }
2380 memcpy(e, s, l);
2381 if (rest) {
2382 e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg);
2383 return e ? b : e;
2384 }
2385 e[l] = 0;
2386 return b;
2387}
2388
2389char *
2390perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol)
2391{
2392 if (!to)
2393 return s;
2394 if (l == 0)
2395 l = strlen(s);
2396 if (l < froml || strnicmp(from, s, froml) != 0)
2397 return s;
2398 if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH)
2399 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
2400 if (to && to != mangle_ret)
2401 memcpy(mangle_ret, to, tol);
2402 strcpy(mangle_ret + tol, s + froml);
2403 return mangle_ret;
2404}
2405
ed344e4f 2406char *
760ac839
LW		 2407perllib_mangle(char *s, unsigned int l)
2408{
1933e12c
IZ		 2409 char *name;
2410
2411 if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l)))
2412 return name;
760ac839 2413 if (!newp && !notfound) {
1933e12c 2414 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
622913ab
IZ		 2415 STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION)
2416 "_PREFIX");
2417 if (!newp)
1933e12c 2418 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION)
622913ab
IZ		 2419 STRINGIFY(PERL_VERSION) "_PREFIX");
2420 if (!newp)
1933e12c 2421 newp = getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX");
622913ab 2422 if (!newp)
1933e12c 2423 newp = getenv(name = "PERLLIB_PREFIX");
760ac839 2424 if (newp) {
1933e12c 2425 char *s, b[300];
ff68c719 2426
760ac839 2427 oldp = newp;
1933e12c
IZ		 2428 while (*newp && !isSPACE(*newp) && *newp != ';')
2429 newp++; /* Skip old name. */
2430 oldl = newp - oldp;
2431 s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name);
2432 oldp = savepv(s);
2433 oldl = strlen(s);
2434 while (*newp && (isSPACE(*newp) || *newp == ';'))
760ac839 2435 newp++; /* Skip whitespace. */
1933e12c
IZ		 2436 Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to);
2437 if (newl == 0 || oldl == 0)
2438 Perl_croak_nocontext("Malformed %s", name);
2439 } else
760ac839 2440 notfound = 1;
760ac839 2441 }
1933e12c 2442 if (!newp)
760ac839 2443 return s;
1933e12c 2444 if (l == 0)
760ac839 2445 l = strlen(s);
1933e12c 2446 if (l < oldl || strnicmp(oldp, s, oldl) != 0)
760ac839 2447 return s;
1933e12c 2448 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH)
23da6c43 2449 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
622913ab
IZ		 2450 strcpy(mangle_ret + newl, s + oldl);
2451 return mangle_ret;
760ac839 2452}
6f064249 2453
4bfbfac5
IZ		 2454unsigned long
2455Perl_hab_GET() /* Needed if perl.h cannot be included */
2456{
2457 return perl_hab_GET();
2458}
2459
622913ab
IZ		 2460static void
2461Create_HMQ(int serve, char *message) /* Assumes morphing */
2462{
2463 unsigned fpflag = _control87(0,0);
2464
2465 init_PMWIN_entries();
2466 /* 64 messages if before OS/2 3.0, ignored otherwise */
2467 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
2468 if (!Perl_hmq) {
2469 dTHX;
2470
2471 SAVEINT(rmq_cnt); /* Allow catch()ing. */
2472 if (rmq_cnt++)
2473 _exit(188); /* Panic can try to create a window. */
2474 CroakWinError(1, message ? message : "Cannot create a message queue");
2475 }
2476 if (serve != -1)
2477 (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve);
2478 /* We may have loaded some modules */
2479 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2480}
2481
2482#define REGISTERMQ_WILL_SERVE 1
2483#define REGISTERMQ_IMEDIATE_UNMORPH 2
2484
4bfbfac5
IZ		 2485HMQ
2486Perl_Register_MQ(int serve)
2487{
8c4b3a79 2488 if (Perl_hmq_refcnt <= 0) {
4bfbfac5
IZ		 2489 PPIB pib;
2490 PTIB tib;
2491
30500b05 2492 Perl_hmq_refcnt = 0; /* Be extra safe */
4bfbfac5 2493 DosGetInfoBlocks(&tib, &pib);
622913ab
IZ		 2494 if (!Perl_morph_refcnt) {
2495 Perl_os2_initial_mode = pib->pib_ultype;
2496 /* Try morphing into a PM application. */
2497 if (pib->pib_ultype != 3) /* 2 is VIO */
2498 pib->pib_ultype = 3; /* 3 is PM */
2499 }
2500 Create_HMQ(-1, /* We do CancelShutdown ourselves */
2501 "Cannot create a message queue, or morph to a PM application");
2502 if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) {
2503 if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3)
2504 pib->pib_ultype = Perl_os2_initial_mode;
4bfbfac5 2505 }
8c4b3a79 2506 }
622913ab 2507 if (serve & REGISTERMQ_WILL_SERVE) {
5ba48348
JH		 2508 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
2509 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
2510 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
2511 Perl_hmq_servers++;
2512 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
2513 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
2514 Perl_hmq_refcnt++;
622913ab
IZ		 2515 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH))
2516 Perl_morph_refcnt++;
4bfbfac5
IZ		 2517 return Perl_hmq;
2518}
2519
2520int
2521Perl_Serve_Messages(int force)
2522{
2523 int cnt = 0;
2524 QMSG msg;
2525
5ba48348 2526 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 2527 return 0;
5ba48348 2528 if (Perl_hmq_refcnt <= 0)
23da6c43 2529 Perl_croak_nocontext("No message queue");
4bfbfac5
IZ		 2530 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
2531 cnt++;
2532 if (msg.msg == WM_QUIT)
23da6c43 2533 Perl_croak_nocontext("QUITing...");
4bfbfac5
IZ		 2534 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2535 }
2536 return cnt;
2537}
2538
2539int
2540Perl_Process_Messages(int force, I32 *cntp)
2541{
2542 QMSG msg;
2543
5ba48348 2544 if (Perl_hmq_servers > 0 && !force)
4bfbfac5 2545 return 0;
5ba48348 2546 if (Perl_hmq_refcnt <= 0)
23da6c43 2547 Perl_croak_nocontext("No message queue");
4bfbfac5
IZ		 2548 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
2549 if (cntp)
2550 (*cntp)++;
2551 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
2552 if (msg.msg == WM_DESTROY)
2553 return -1;
2554 if (msg.msg == WM_CREATE)
2555 return +1;
2556 }
23da6c43 2557 Perl_croak_nocontext("QUITing...");
4bfbfac5
IZ		 2558}
2559
2560void
2561Perl_Deregister_MQ(int serve)
2562{
622913ab 2563 if (serve & REGISTERMQ_WILL_SERVE)
5ba48348 2564 Perl_hmq_servers--;
622913ab 2565
5ba48348 2566 if (--Perl_hmq_refcnt <= 0) {
622913ab
IZ		 2567 unsigned fpflag = _control87(0,0);
2568
5ba48348 2569 init_PMWIN_entries(); /* To be extra safe */
4bfbfac5
IZ		 2570 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
2571 Perl_hmq = 0;
622913ab
IZ		 2572 /* We may have (un)loaded some modules */
2573 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
2574 } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0)
2575 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */
2576 if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) {
4bfbfac5 2577 /* Try morphing back from a PM application. */
622913ab
IZ		 2578 PPIB pib;
2579 PTIB tib;
2580
5ba48348 2581 DosGetInfoBlocks(&tib, &pib);
4bfbfac5
IZ		 2582 if (pib->pib_ultype == 3) /* 3 is PM */
2583 pib->pib_ultype = Perl_os2_initial_mode;
2584 else
23da6c43 2585 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
622913ab
IZ		 2586 pib->pib_ultype);
2587 }
4bfbfac5
IZ		 2588}
2589
3bbf9c2b
IZ		 2590#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
2591 && ((path)[2] == '/' || (path)[2] == '\\'))
2592#define sys_is_rooted _fnisabs
2593#define sys_is_relative _fnisrel
2594#define current_drive _getdrive
2595
2596#undef chdir /* Was _chdir2. */
2597#define sys_chdir(p) (chdir(p) == 0)
2598#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
2599
4bfbfac5
IZ		 2600XS(XS_OS2_Error)
2601{
2602 dXSARGS;
2603 if (items != 2)
23da6c43 2604 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
4bfbfac5
IZ		 2605 {
2606 int arg1 = SvIV(ST(0));
2607 int arg2 = SvIV(ST(1));
2608 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
2609 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
2610 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
2611 unsigned long rc;
2612
2613 if (CheckOSError(DosError(a)))
622913ab 2614 Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc));
4bfbfac5
IZ		 2615 ST(0) = sv_newmortal();
2616 if (DOS_harderr_state >= 0)
2617 sv_setiv(ST(0), DOS_harderr_state);
2618 DOS_harderr_state = RETVAL;
2619 }
2620 XSRETURN(1);
2621}
2622
4bfbfac5
IZ		 2623XS(XS_OS2_Errors2Drive)
2624{
2625 dXSARGS;
2626 if (items != 1)
23da6c43 2627 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
4bfbfac5 2628 {
2d8e6c8d 2629 STRLEN n_a;
4bfbfac5
IZ		 2630 SV *sv = ST(0);
2631 int suppress = SvOK(sv);
2d8e6c8d 2632 char *s = suppress ? SvPV(sv, n_a) : NULL;
4bfbfac5
IZ		 2633 char drive = (s ? *s : 0);
2634 unsigned long rc;
2635
2636 if (suppress && !isALPHA(drive))
23da6c43 2637 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
4bfbfac5
IZ		 2638 if (CheckOSError(DosSuppressPopUps((suppress
2639 ? SPU_ENABLESUPPRESSION
2640 : SPU_DISABLESUPPRESSION),
2641 drive)))
622913ab
IZ		 2642 Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive,
2643 os2error(Perl_rc));
4bfbfac5
IZ		 2644 ST(0) = sv_newmortal();
2645 if (DOS_suppression_state > 0)
2646 sv_setpvn(ST(0), &DOS_suppression_state, 1);
2647 else if (DOS_suppression_state == 0)
75a8281e 2648 SvPVCLEAR(ST(0));
4bfbfac5
IZ		 2649 DOS_suppression_state = drive;
2650 }
2651 XSRETURN(1);
2652}
2653
1933e12c
IZ		 2654int
2655async_mssleep(ULONG ms, int switch_priority) {
2656 /* This is similar to DosSleep(), but has 8ms granularity in time-critical
2657 threads even on Warp3. */
2658 HEV hevEvent1 = 0; /* Event semaphore handle */
2659 HTIMER htimerEvent1 = 0; /* Timer handle */
2660 APIRET rc = NO_ERROR; /* Return code */
2661 int ret = 1;
2662 ULONG priority = 0, nesting; /* Shut down the warnings */
2663 PPIB pib;
2664 PTIB tib;
2665 char *e = NULL;
2666 APIRET badrc;
2667
2668 if (!(_emx_env & 0x200)) /* DOS */
2669 return !_sleep2(ms);
2670
2671 os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */
2672 &hevEvent1, /* Handle of semaphore returned */
2673 DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
2674 FALSE), /* Semaphore is in RESET state */
2675 "DosCreateEventSem");
2676
2677 if (ms >= switch_priority)
2678 switch_priority = 0;
2679 if (switch_priority) {
2680 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
2681 switch_priority = 0;
2682 else {
2683 /* In Warp3, to switch scheduling to 8ms step, one needs to do
2684 DosAsyncTimer() in time-critical thread. On laters versions,
2685 more and more cases of wait-for-something are covered.
2686
2687 It turns out that on Warp3fp42 it is the priority at the time
2688 of DosAsyncTimer() which matters. Let's hope that this works
2689 with later versions too... XXXX
2690 */
2691 priority = (tib->tib_ptib2->tib2_ulpri);
2692 if ((priority & 0xFF00) == 0x0300) /* already time-critical */
2693 switch_priority = 0;
2694 /* Make us time-critical. Just modifying TIB is not enough... */
2695 /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
2696 /* We do not want to run at high priority if a signal causes us
2697 to longjmp() out of this section... */
2698 if (DosEnterMustComplete(&nesting))
2699 switch_priority = 0;
2700 else
2701 DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
2702 }
2703 }
2704
2705 if ((badrc = DosAsyncTimer(ms,
2706 (HSEM) hevEvent1, /* Semaphore to post */
2707 &htimerEvent1))) /* Timer handler (returned) */
2708 e = "DosAsyncTimer";
2709
2710 if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
2711 /* Nobody switched priority while we slept... Ignore errors... */
2712 /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */
2713 if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
2714 rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
2715 }
2716 if (switch_priority)
2717 rc = DosExitMustComplete(&nesting); /* Ignore errors */
2718
2719 /* The actual blocking call is made with "normal" priority. This way we
2720 should not bother with DosSleep(0) etc. to compensate for us interrupting
2721 higher-priority threads. The goal is to prohibit the system spending too
2722 much time halt()ing, not to run us "no matter what". */
2723 if (!e) /* Wait for AsyncTimer event */
2724 badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
2725
2726 if (e) ; /* Do nothing */
2727 else if (badrc == ERROR_INTERRUPT)
2728 ret = 0;
2729 else if (badrc)
2730 e = "DosWaitEventSem";
2731 if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
2732 e = "DosCloseEventSem";
2733 badrc = rc;
2734 }
2735 if (e)
2736 os2cp_croak(badrc, e);
2737 return ret;
2738}
2739
2740XS(XS_OS2_ms_sleep) /* for testing only... */
2741{
2742 dXSARGS;
2743 ULONG ms, lim;
2744
2745 if (items > 2 || items < 1)
2746 Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
2747 ms = SvUV(ST(0));
2748 lim = items > 1 ? SvUV(ST(1)) : ms + 1;
2749 async_mssleep(ms, lim);
9d419b5f 2750 XSRETURN_YES;
1933e12c
IZ		 2751}
2752
622913ab
IZ		 2753ULONG (*pDosTmrQueryFreq) (PULONG);
2754ULONG (*pDosTmrQueryTime) (unsigned long long *);
2755
2756XS(XS_OS2_Timer)
2757{
2758 dXSARGS;
2759 static ULONG freq;
2760 unsigned long long count;
2761 ULONG rc;
2762
2763 if (items != 0)
2764 Perl_croak_nocontext("Usage: OS2::Timer()");
2765 if (!freq) {
2766 *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
2767 *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
2768 MUTEX_LOCK(&perlos2_state_mutex);
2769 if (!freq)
2770 if (CheckOSError(pDosTmrQueryFreq(&freq)))
2771 croak_with_os2error("DosTmrQueryFreq");
2772 MUTEX_UNLOCK(&perlos2_state_mutex);
2773 }
2774 if (CheckOSError(pDosTmrQueryTime(&count)))
2775 croak_with_os2error("DosTmrQueryTime");
2776 {
2777 dXSTARG;
2778
2779 XSprePUSH; PUSHn(((NV)count)/freq);
2780 }
2781 XSRETURN(1);
2782}
2783
1933e12c
IZ		 2784XS(XS_OS2_msCounter)
2785{
2786 dXSARGS;
2787
2788 if (items != 0)
2789 Perl_croak_nocontext("Usage: OS2::msCounter()");
2790 {
2791 dXSTARG;
2792
2793 XSprePUSH; PUSHu(msCounter());
2794 }
2795 XSRETURN(1);
2796}
2797
2798XS(XS_OS2__InfoTable)
2799{
2800 dXSARGS;
2801 int is_local = 0;
2802
2803 if (items > 1)
2804 Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
2805 if (items == 1)
2806 is_local = (int)SvIV(ST(0));
2807 {
2808 dXSTARG;
2809
2810 XSprePUSH; PUSHu(InfoTable(is_local));
2811 }
2812 XSRETURN(1);
2813}
2814
622913ab
IZ		 2815static const char * const dc_fields[] = {
2816 "FAMILY",
2817 "IO_CAPS",
2818 "TECHNOLOGY",
2819 "DRIVER_VERSION",
2820 "WIDTH",
2821 "HEIGHT",
2822 "WIDTH_IN_CHARS",
2823 "HEIGHT_IN_CHARS",
2824 "HORIZONTAL_RESOLUTION",
2825 "VERTICAL_RESOLUTION",
2826 "CHAR_WIDTH",
2827 "CHAR_HEIGHT",
2828 "SMALL_CHAR_WIDTH",
2829 "SMALL_CHAR_HEIGHT",
2830 "COLORS",
2831 "COLOR_PLANES",
2832 "COLOR_BITCOUNT",
2833 "COLOR_TABLE_SUPPORT",
2834 "MOUSE_BUTTONS",
2835 "FOREGROUND_MIX_SUPPORT",
2836 "BACKGROUND_MIX_SUPPORT",
2837 "VIO_LOADABLE_FONTS",
2838 "WINDOW_BYTE_ALIGNMENT",
2839 "BITMAP_FORMATS",
2840 "RASTER_CAPS",
2841 "MARKER_HEIGHT",
2842 "MARKER_WIDTH",
2843 "DEVICE_FONTS",
2844 "GRAPHICS_SUBSET",
2845 "GRAPHICS_VERSION",
2846 "GRAPHICS_VECTOR_SUBSET",
2847 "DEVICE_WINDOWING",
2848 "ADDITIONAL_GRAPHICS",
2849 "PHYS_COLORS",
2850 "COLOR_INDEX",
2851 "GRAPHICS_CHAR_WIDTH",
2852 "GRAPHICS_CHAR_HEIGHT",
2853 "HORIZONTAL_FONT_RES",
2854 "VERTICAL_FONT_RES",
2855 "DEVICE_FONT_SIM",
2856 "LINEWIDTH_THICK",
2857 "DEVICE_POLYSET_POINTS",
2858};
2859
2860enum {
2861 DevCap_dc, DevCap_hwnd
2862};
2863
2864HDC (*pWinOpenWindowDC) (HWND hwnd);
2865HMF (*pDevCloseDC) (HDC hdc);
2866HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
2867 PDEVOPENDATA pdopData, HDC hdcComp);
2868BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
2869
2870
2871XS(XS_OS2_DevCap)
2872{
2873 dXSARGS;
2874 if (items > 2)
2875 Perl_croak_nocontext("Usage: OS2::DevCap()");
2876 {
2877 /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
2878 LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
2879 int i = 0, j = 0, how = DevCap_dc;
2880 HDC hScreenDC;
2881 DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
2882 ULONG rc1 = NO_ERROR;
2883 HWND hwnd;
2884 static volatile int devcap_loaded;
2885
2886 if (!devcap_loaded) {
2887 *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
2888 *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
2889 *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
2890 *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
2891 devcap_loaded = 1;
2892 }
2893
2894 if (items >= 2)
2895 how = SvIV(ST(1));
2896 if (!items) { /* Get device contents from PM */
2897 hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
2898 (PDEVOPENDATA)&doStruc, NULLHANDLE);
2899 if (CheckWinError(hScreenDC))
2900 croak_with_os2error("DevOpenDC() failed");
2901 } else if (how == DevCap_dc)
2902 hScreenDC = (HDC)SvIV(ST(0));
2903 else { /* DevCap_hwnd */
2904 if (!Perl_hmq)
2905 Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
2906 hwnd = (HWND)SvIV(ST(0));
2907 hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
2908 if (CheckWinError(hScreenDC))
2909 croak_with_os2error("WinOpenWindowDC() failed");
2910 }
2911 if (CheckWinError(pDevQueryCaps(hScreenDC,
2912 CAPS_FAMILY, /* W3 documented caps */
2913 CAPS_DEVICE_POLYSET_POINTS
2914 - CAPS_FAMILY + 1,
2915 si)))
2916 rc1 = Perl_rc;
9d419b5f
IZ		 2917 else {
2918 EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
2919 while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
2920 ST(j) = sv_newmortal();
2921 sv_setpv(ST(j++), dc_fields[i]);
2922 ST(j) = sv_newmortal();
2923 sv_setiv(ST(j++), si[i]);
2924 i++;
2925 }
2926 i = CAPS_DEVICE_POLYSET_POINTS + 1;
2927 while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
2928 LONG l;
2929
2930 if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
2931 break;
2932 EXTEND(SP, j + 2);
2933 ST(j) = sv_newmortal();
2934 sv_setiv(ST(j++), i);
2935 ST(j) = sv_newmortal();
2936 sv_setiv(ST(j++), l);
2937 i++;
2938 }
2939 }
622913ab
IZ		 2940 if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
2941 Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
2942 if (rc1)
2943 Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
9d419b5f 2944 XSRETURN(j);
622913ab 2945 }
622913ab
IZ		 2946}
2947
2948LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
2949BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
2950
2951const char * const sv_keys[] = {
2952 "SWAPBUTTON",
2953 "DBLCLKTIME",
2954 "CXDBLCLK",
2955 "CYDBLCLK",
2956 "CXSIZEBORDER",
2957 "CYSIZEBORDER",
2958 "ALARM",
2959 "7",
2960 "8",
2961 "CURSORRATE",
2962 "FIRSTSCROLLRATE",
2963 "SCROLLRATE",
2964 "NUMBEREDLISTS",
2965 "WARNINGFREQ",
2966 "NOTEFREQ",
2967 "ERRORFREQ",
2968 "WARNINGDURATION",
2969 "NOTEDURATION",
2970 "ERRORDURATION",
2971 "19",
2972 "CXSCREEN",
2973 "CYSCREEN",
2974 "CXVSCROLL",
2975 "CYHSCROLL",
2976 "CYVSCROLLARROW",
2977 "CXHSCROLLARROW",
2978 "CXBORDER",
2979 "CYBORDER",
2980 "CXDLGFRAME",
2981 "CYDLGFRAME",
2982 "CYTITLEBAR",
2983 "CYVSLIDER",
2984 "CXHSLIDER",
2985 "CXMINMAXBUTTON",
2986 "CYMINMAXBUTTON",
2987 "CYMENU",
2988 "CXFULLSCREEN",
2989 "CYFULLSCREEN",
2990 "CXICON",
2991 "CYICON",
2992 "CXPOINTER",
2993 "CYPOINTER",
2994 "DEBUG",
2995 "CPOINTERBUTTONS",
2996 "POINTERLEVEL",
2997 "CURSORLEVEL",
2998 "TRACKRECTLEVEL",
2999 "CTIMERS",
3000 "MOUSEPRESENT",
3001 "CXALIGN",
3002 "CYALIGN",
3003 "DESKTOPWORKAREAYTOP",
3004 "DESKTOPWORKAREAYBOTTOM",
3005 "DESKTOPWORKAREAXRIGHT",
3006 "DESKTOPWORKAREAXLEFT",
3007 "55",
3008 "NOTRESERVED",
3009 "EXTRAKEYBEEP",
3010 "SETLIGHTS",
3011 "INSERTMODE",
3012 "60",
3013 "61",
3014 "62",
3015 "63",
3016 "MENUROLLDOWNDELAY",
3017 "MENUROLLUPDELAY",
3018 "ALTMNEMONIC",
3019 "TASKLISTMOUSEACCESS",
3020 "CXICONTEXTWIDTH",
3021 "CICONTEXTLINES",
3022 "CHORDTIME",
3023 "CXCHORD",
3024 "CYCHORD",
3025 "CXMOTIONSTART",
3026 "CYMOTIONSTART",
3027 "BEGINDRAG",
3028 "ENDDRAG",
3029 "SINGLESELECT",
3030 "OPEN",
3031 "CONTEXTMENU",
3032 "CONTEXTHELP",
3033 "TEXTEDIT",
3034 "BEGINSELECT",
3035 "ENDSELECT",
3036 "BEGINDRAGKB",
3037 "ENDDRAGKB",
3038 "SELECTKB",
3039 "OPENKB",
3040 "CONTEXTMENUKB",
3041 "CONTEXTHELPKB",
3042 "TEXTEDITKB",
3043 "BEGINSELECTKB",
3044 "ENDSELECTKB",
3045 "ANIMATION",
3046 "ANIMATIONSPEED",
3047 "MONOICONS",
3048 "KBDALTERED",
3049 "PRINTSCREEN", /* 97, the last one on one of the DDK header */
3050 "LOCKSTARTINPUT",
3051 "DYNAMICDRAG",
3052 "100",
3053 "101",
3054 "102",
3055 "103",
3056 "104",
3057 "105",
3058 "106",
3059 "107",
3060/* "CSYSVALUES",*/
3061 /* In recent DDK the limit is 108 */
3062};
3063
3064XS(XS_OS2_SysValues)
3065{
3066 dXSARGS;
3067 if (items > 2)
3068 Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
3069 {
3070 int i = 0, j = 0, which = -1;
3071 HWND hwnd = HWND_DESKTOP;
3072 static volatile int sv_loaded;
3073 LONG RETVAL;
3074
3075 if (!sv_loaded) {
3076 *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
3077 sv_loaded = 1;
3078 }
3079
3080 if (items == 2)
3081 hwnd = (HWND)SvIV(ST(1));
3082 if (items >= 1)
3083 which = (int)SvIV(ST(0));
3084 if (which == -1) {
3085 EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
3086 while (i < C_ARRAY_LENGTH(sv_keys)) {
3087 ResetWinError();
3088 RETVAL = pWinQuerySysValue(hwnd, i);
3089 if ( !RETVAL
3090 && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
3091 && i <= SV_PRINTSCREEN) ) {
3092 FillWinError;
3093 if (Perl_rc) {
3094 if (i > SV_PRINTSCREEN)
3095 break; /* May be not present on older systems */
3096 croak_with_os2error("SysValues():");
3097 }
3098
3099 }
3100 ST(j) = sv_newmortal();
3101 sv_setpv(ST(j++), sv_keys[i]);
3102 ST(j) = sv_newmortal();
3103 sv_setiv(ST(j++), RETVAL);
3104 i++;
3105 }
3106 XSRETURN(2 * i);
3107 } else {
3108 dXSTARG;
3109
3110 ResetWinError();
3111 RETVAL = pWinQuerySysValue(hwnd, which);
3112 if (!RETVAL) {
3113 FillWinError;
3114 if (Perl_rc)
3115 croak_with_os2error("SysValues():");
3116 }
3117 XSprePUSH; PUSHi((IV)RETVAL);
3118 }
3119 }
3120}
3121
3122XS(XS_OS2_SysValues_set)
3123{
3124 dXSARGS;
3125 if (items < 2 || items > 3)
3126 Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
3127 {
3128 int which = (int)SvIV(ST(0));
3129 LONG val = (LONG)SvIV(ST(1));
3130 HWND hwnd = HWND_DESKTOP;
3131 static volatile int svs_loaded;
3132
3133 if (!svs_loaded) {
3134 *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
3135 svs_loaded = 1;
3136 }
3137
3138 if (items == 3)
3139 hwnd = (HWND)SvIV(ST(2));
3140 if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
3141 croak_with_os2error("SysValues_set()");
3142 }
9d419b5f 3143 XSRETURN_YES;
622913ab
IZ		 3144}
3145
3146#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
3147
3148static const char * const si_fields[] = {
4bfbfac5
IZ		 3149 "MAX_PATH_LENGTH",
3150 "MAX_TEXT_SESSIONS",
3151 "MAX_PM_SESSIONS",
3152 "MAX_VDM_SESSIONS",
3153 "BOOT_DRIVE",
3154 "DYN_PRI_VARIATION",
3155 "MAX_WAIT",
3156 "MIN_SLICE",
3157 "MAX_SLICE",
3158 "PAGE_SIZE",
3159 "VERSION_MAJOR",
3160 "VERSION_MINOR",
3161 "VERSION_REVISION",
3162 "MS_COUNT",
3163 "TIME_LOW",
3164 "TIME_HIGH",
3165 "TOTPHYSMEM",
3166 "TOTRESMEM",
3167 "TOTAVAILMEM",
3168 "MAXPRMEM",
3169 "MAXSHMEM",
3170 "TIMER_INTERVAL",
3171 "MAX_COMP_LENGTH",
3172 "FOREGROUND_FS_SESSION",
622913ab
IZ		 3173 "FOREGROUND_PROCESS", /* Warp 3 toolkit defines up to this */
3174 "NUMPROCESSORS",
3175 "MAXHPRMEM",
3176 "MAXHSHMEM",
3177 "MAXPROCESSES",
3178 "VIRTUALADDRESSLIMIT",
3179 "INT10ENABLED", /* From $TOOLKIT-ddk\DDK\video\rel\os2c\include\base\os2\bsedos.h */
4bfbfac5
IZ		 3180};
3181
3182XS(XS_OS2_SysInfo)
3183{
3184 dXSARGS;
3185 if (items != 0)
23da6c43 3186 Perl_croak_nocontext("Usage: OS2::SysInfo()");
4bfbfac5 3187 {
622913ab
IZ		 3188 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3189 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
4bfbfac5 3190 APIRET rc = NO_ERROR; /* Return code */
622913ab 3191 int i = 0, j = 0, last = QSV_MAX_WARP3;
4bfbfac5 3192
622913ab
IZ		 3193 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
3194 last, /* info for Warp 3 */
4bfbfac5
IZ		 3195 (PVOID)si,
3196 sizeof(si))))
622913ab 3197 croak_with_os2error("DosQuerySysInfo() failed");
9d419b5f 3198 while (++last <= C_ARRAY_LENGTH(si)) {
622913ab
IZ		 3199 if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */
3200 (PVOID)(si+last-1),
3201 sizeof(*si)))) {
3202 if (Perl_rc != ERROR_INVALID_PARAMETER)
3203 croak_with_os2error("DosQuerySysInfo() failed");
3204 break;
3205 }
3206 }
9d419b5f 3207 last--; /* Count of successfully processed offsets */
622913ab
IZ		 3208 EXTEND(SP,2*last);
3209 while (i < last) {
4bfbfac5 3210 ST(j) = sv_newmortal();
9d419b5f
IZ		 3211 if (i < C_ARRAY_LENGTH(si_fields))
3212 sv_setpv(ST(j++), si_fields[i]);
3213 else
3214 sv_setiv(ST(j++), i + 1);
4bfbfac5 3215 ST(j) = sv_newmortal();
9d419b5f 3216 sv_setuv(ST(j++), si[i]);
4bfbfac5
IZ		 3217 i++;
3218 }
622913ab 3219 XSRETURN(2 * last);
4bfbfac5 3220 }
622913ab
IZ		 3221}
3222
3223XS(XS_OS2_SysInfoFor)
3224{
3225 dXSARGS;
3226 int count = (items == 2 ? (int)SvIV(ST(1)) : 1);
3227
3228 if (items < 1 || items > 2)
3229 Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])");
3230 {
3231 /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */
3232 ULONG si[C_ARRAY_LENGTH(si_fields) + 10];
3233 APIRET rc = NO_ERROR; /* Return code */
3234 int i = 0;
3235 int start = (int)SvIV(ST(0));
3236
3237 if (count > C_ARRAY_LENGTH(si) || count <= 0)
3238 Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count);
3239 if (CheckOSError(DosQuerySysInfo(start,
3240 start + count - 1,
3241 (PVOID)si,
3242 sizeof(si))))
3243 croak_with_os2error("DosQuerySysInfo() failed");
3244 EXTEND(SP,count);
3245 while (i < count) {
3246 ST(i) = sv_newmortal();
3247 sv_setiv(ST(i), si[i]);
3248 i++;
3249 }
3250 }
3251 XSRETURN(count);
4bfbfac5
IZ		 3252}
3253
3254XS(XS_OS2_BootDrive)
3255{
3256 dXSARGS;
3257 if (items != 0)
23da6c43 3258 Perl_croak_nocontext("Usage: OS2::BootDrive()");
4bfbfac5
IZ		 3259 {
3260 ULONG si[1] = {0}; /* System Information Data Buffer */
3261 APIRET rc = NO_ERROR; /* Return code */
3262 char c;
622913ab 3263 dXSTARG;
4bfbfac5
IZ		 3264
3265 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
3266 (PVOID)si, sizeof(si))))
622913ab 3267 croak_with_os2error("DosQuerySysInfo() failed");
4bfbfac5 3268 c = 'a' - 1 + si[0];
622913ab
IZ		 3269 sv_setpvn(TARG, &c, 1);
3270 XSprePUSH; PUSHTARG;
4bfbfac5
IZ		 3271 }
3272 XSRETURN(1);
3273}
3274
622913ab
IZ		 3275XS(XS_OS2_Beep)
3276{
3277 dXSARGS;
3278 if (items > 2) /* Defaults as for WinAlarm(ERROR) */
3279 Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)");
3280 {
3281 ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440);
3282 ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100);
3283 ULONG rc;
3284
3285 if (CheckOSError(DosBeep(freq, ms)))
3286 croak_with_os2error("SysValues_set()");
3287 }
9d419b5f 3288 XSRETURN_YES;
622913ab
IZ		 3289}
3290
3291
3292
4bfbfac5
IZ		 3293XS(XS_OS2_MorphPM)
3294{
3295 dXSARGS;
3296 if (items != 1)
23da6c43 3297 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
4bfbfac5
IZ		 3298 {
3299 bool serve = SvOK(ST(0));
3300 unsigned long pmq = perl_hmq_GET(serve);
622913ab 3301 dXSTARG;
4bfbfac5 3302
622913ab 3303 XSprePUSH; PUSHi((IV)pmq);
4bfbfac5
IZ		 3304 }
3305 XSRETURN(1);
3306}
3307
3308XS(XS_OS2_UnMorphPM)
3309{
3310 dXSARGS;
3311 if (items != 1)
23da6c43 3312 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
4bfbfac5
IZ		 3313 {
3314 bool serve = SvOK(ST(0));
3315
3316 perl_hmq_UNSET(serve);
3317 }
3318 XSRETURN(0);
3319}
3320
3321XS(XS_OS2_Serve_Messages)
3322{
3323 dXSARGS;
3324 if (items != 1)
23da6c43 3325 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
4bfbfac5
IZ		 3326 {
3327 bool force = SvOK(ST(0));
3328 unsigned long cnt = Perl_Serve_Messages(force);
622913ab 3329 dXSTARG;
4bfbfac5 3330
622913ab 3331 XSprePUSH; PUSHi((IV)cnt);
4bfbfac5
IZ		 3332 }
3333 XSRETURN(1);
3334}
3335
3336XS(XS_OS2_Process_Messages)
3337{
3338 dXSARGS;
3339 if (items < 1 || items > 2)
23da6c43 3340 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
4bfbfac5
IZ		 3341 {
3342 bool force = SvOK(ST(0));
3343 unsigned long cnt;
622913ab 3344 dXSTARG;
4bfbfac5
IZ		 3345
3346 if (items == 2) {
47344f21 3347 I32 cntr;
4bfbfac5 3348 SV *sv = ST(1);
2d766320
IZ		 3349
3350 (void)SvIV(sv); /* Force SvIVX */
4bfbfac5 3351 if (!SvIOK(sv))
23da6c43 3352 Perl_croak_nocontext("Can't upgrade count to IV");
47344f21
YST		 3353 cntr = SvIVX(sv);
3354 cnt = Perl_Process_Messages(force, &cntr);
3355 SvIVX(sv) = cntr;
3356 } else {
3357 cnt = Perl_Process_Messages(force, NULL);
3358 }
622913ab 3359 XSprePUSH; PUSHi((IV)cnt);
4bfbfac5
IZ		 3360 }
3361 XSRETURN(1);
3362}
3363
3bbf9c2b
IZ		 3364XS(XS_Cwd_current_drive)
3365{
3366 dXSARGS;
3367 if (items != 0)
23da6c43 3368 Perl_croak_nocontext("Usage: Cwd::current_drive()");
3bbf9c2b
IZ		 3369 {
3370 char RETVAL;
622913ab 3371 dXSTARG;
3bbf9c2b
IZ		 3372
3373 RETVAL = current_drive();
622913ab
IZ		 3374 sv_setpvn(TARG, (char *)&RETVAL, 1);
3375 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 3376 }
3377 XSRETURN(1);
3378}
3379
3380XS(XS_Cwd_sys_chdir)
3381{
3382 dXSARGS;
3383 if (items != 1)
23da6c43 3384 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
3bbf9c2b 3385 {
2d8e6c8d
GS		 3386 STRLEN n_a;
3387 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3388 bool RETVAL;
3389
3390 RETVAL = sys_chdir(path);
54310121 3391 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3392 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3393 }
3394 XSRETURN(1);
3395}
3396
3397XS(XS_Cwd_change_drive)
3398{
3399 dXSARGS;
3400 if (items != 1)
23da6c43 3401 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
3bbf9c2b 3402 {
2d8e6c8d
GS		 3403 STRLEN n_a;
3404 char d = (char)*SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3405 bool RETVAL;
3406
3407 RETVAL = change_drive(d);
54310121 3408 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3409 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3410 }
3411 XSRETURN(1);
3412}
3413
3414XS(XS_Cwd_sys_is_absolute)
3415{
3416 dXSARGS;
3417 if (items != 1)
23da6c43 3418 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
3bbf9c2b 3419 {
2d8e6c8d
GS		 3420 STRLEN n_a;
3421 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3422 bool RETVAL;
3423
3424 RETVAL = sys_is_absolute(path);
54310121 3425 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3426 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3427 }
3428 XSRETURN(1);
3429}
3430
3431XS(XS_Cwd_sys_is_rooted)
3432{
3433 dXSARGS;
3434 if (items != 1)
23da6c43 3435 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
3bbf9c2b 3436 {
2d8e6c8d
GS		 3437 STRLEN n_a;
3438 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3439 bool RETVAL;
3440
3441 RETVAL = sys_is_rooted(path);
54310121 3442 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3443 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3444 }
3445 XSRETURN(1);
3446}
3447
3448XS(XS_Cwd_sys_is_relative)
3449{
3450 dXSARGS;
3451 if (items != 1)
23da6c43 3452 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
3bbf9c2b 3453 {
2d8e6c8d
GS		 3454 STRLEN n_a;
3455 char * path = (char *)SvPV(ST(0),n_a);
3bbf9c2b
IZ		 3456 bool RETVAL;
3457
3458 RETVAL = sys_is_relative(path);
54310121 3459 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3460 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3461 }
3462 XSRETURN(1);
3463}
3464
3465XS(XS_Cwd_sys_cwd)
3466{
3467 dXSARGS;
3468 if (items != 0)
23da6c43 3469 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
3bbf9c2b
IZ		 3470 {
3471 char p[MAXPATHLEN];
3472 char * RETVAL;
622913ab
IZ		 3473
3474 /* Can't use TARG, since tainting behaves differently */
3bbf9c2b
IZ		 3475 RETVAL = _getcwd2(p, MAXPATHLEN);
3476 ST(0) = sv_newmortal();
622913ab 3477 sv_setpv(ST(0), RETVAL);
ebdd4fa0 3478 SvTAINTED_on(ST(0));
3bbf9c2b
IZ		 3479 }
3480 XSRETURN(1);
3481}
3482
3483XS(XS_Cwd_sys_abspath)
3484{
3485 dXSARGS;
5723cfe4
IZ		 3486 if (items > 2)
3487 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3bbf9c2b 3488 {
2d8e6c8d 3489 STRLEN n_a;
5723cfe4 3490 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
f5f423e4 3491 char * dir, *s, *t, *e;
3bbf9c2b
IZ		 3492 char p[MAXPATHLEN];
3493 char * RETVAL;
f5f423e4
IZ		 3494 int l;
3495 SV *sv;
3bbf9c2b
IZ		 3496
3497 if (items < 2)
3498 dir = NULL;
3499 else {
2d8e6c8d 3500 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b
IZ		 3501 }
3502 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3503 path += 2;
3504 }
3505 if (dir == NULL) {
3506 if (_abspath(p, path, MAXPATHLEN) == 0) {
3507 RETVAL = p;
3508 } else {
3509 RETVAL = NULL;
3510 }
3511 } else {
3512 /* Absolute with drive: */
3513 if ( sys_is_absolute(path) ) {
3514 if (_abspath(p, path, MAXPATHLEN) == 0) {
3515 RETVAL = p;
3516 } else {
3517 RETVAL = NULL;
3518 }
3519 } else if (path[0] == '/' || path[0] == '\\') {
3520 /* Rooted, but maybe on different drive. */
3521 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3522 char p1[MAXPATHLEN];
3523
3524 /* Need to prepend the drive. */
3525 p1[0] = dir[0];
3526 p1[1] = dir[1];
3527 Copy(path, p1 + 2, strlen(path) + 1, char);
3528 RETVAL = p;
3529 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3530 RETVAL = p;
3531 } else {
3532 RETVAL = NULL;
3533 }
3534 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3535 RETVAL = p;
3536 } else {
3537 RETVAL = NULL;
3538 }
3539 } else {
3540 /* Either path is relative, or starts with a drive letter. */
3541 /* If the path starts with a drive letter, then dir is
3542 relevant only if
3543 a/b) it is absolute/x:relative on the same drive.
3544 c) path is on current drive, and dir is rooted
3545 In all the cases it is safe to drop the drive part
3546 of the path. */
3547 if ( !sys_is_relative(path) ) {
3bbf9c2b
IZ		 3548 if ( ( ( sys_is_absolute(dir)
3549 || (isALPHA(dir[0]) && dir[1] == ':'
3550 && strnicmp(dir, path,1) == 0))
3551 && strnicmp(dir, path,1) == 0)
3552 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3553 && toupper(path[0]) == current_drive())) {
3554 path += 2;
3555 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3556 RETVAL = p; goto done;
3557 } else {
3558 RETVAL = NULL; goto done;
3559 }
3560 }
3561 {
3562 /* Need to prepend the absolute path of dir. */
3563 char p1[MAXPATHLEN];
3564
3565 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3566 int l = strlen(p1);
3567
3568 if (p1[ l - 1 ] != '/') {
3569 p1[ l ] = '/';
3570 l++;
3571 }
3572 Copy(path, p1 + l, strlen(path) + 1, char);
3573 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3574 RETVAL = p;
3575 } else {
3576 RETVAL = NULL;
3577 }
3578 } else {
3579 RETVAL = NULL;
3580 }
3581 }
3582 done:
3583 }
3584 }
f5f423e4
IZ		 3585 if (!RETVAL)
3586 XSRETURN_EMPTY;
3587 /* Backslashes are already converted to slashes. */
3588 /* Remove trailing slashes */
3589 l = strlen(RETVAL);
3590 while (l > 0 && RETVAL[l-1] == '/')
3591 l--;
3bbf9c2b 3592 ST(0) = sv_newmortal();
f5f423e4 3593 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
45ee47cb
IZ		 3594 /* Remove duplicate slashes, skipping the first three, which
3595 may be parts of a server-based path */
3596 s = t = 3 + SvPV_force(sv, n_a);
f5f423e4 3597 e = SvEND(sv);
45ee47cb
IZ		 3598 /* Do not worry about multibyte chars here, this would contradict the
3599 eventual UTFization, and currently most other places break too... */
f5f423e4
IZ		 3600 while (s < e) {
3601 if (s[0] == t[-1] && s[0] == '/')
3602 s++; /* Skip duplicate / */
3603 else
3604 *t++ = *s++;
3605 }
45ee47cb
IZ		 3606 if (t < e) {
3607 *t = 0;
3608 SvCUR_set(sv, t - SvPVX(sv));
3609 }
5723cfe4
IZ		 3610 if (!items)
3611 SvTAINTED_on(ST(0));
3bbf9c2b
IZ		 3612 }
3613 XSRETURN(1);
3614}
72ea3524
IZ		 3615typedef APIRET (*PELP)(PSZ path, ULONG type);
3616
5a9d0041
IZ		 3617/* Kernels after 2000/09/15 understand this too: */
3618#ifndef LIBPATHSTRICT
3619# define LIBPATHSTRICT 3
3620#endif
3621
72ea3524 3622APIRET
1933e12c 3623ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
72ea3524 3624{
5a9d0041 3625 ULONG what;
1933e12c 3626 PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */
5a9d0041 3627
1933e12c
IZ		 3628 if (!f) /* Impossible with fatal */
3629 return Perl_rc;
5a9d0041
IZ		 3630 if (type > 0)
3631 what = END_LIBPATH;
3632 else if (type == 0)
3633 what = BEGIN_LIBPATH;
3634 else
3635 what = LIBPATHSTRICT;
35bc1fdc 3636 return (*(PELP)f)(path, what);
72ea3524 3637}
3bbf9c2b 3638
1933e12c
IZ		 3639#define extLibpath(to,type, fatal) \
3640 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
3641
3642#define extLibpath_set(p,type, fatal) \
3643 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
3bbf9c2b 3644
1933e12c
IZ		 3645static void
3646early_error(char *msg1, char *msg2, char *msg3)
3647{ /* Buffer overflow detected; there is very little we can do... */
3648 ULONG rc;
3649
3650 DosWrite(2, msg1, strlen(msg1), &rc);
3651 DosWrite(2, msg2, strlen(msg2), &rc);
3652 DosWrite(2, msg3, strlen(msg3), &rc);
3653 DosExit(EXIT_PROCESS, 2);
3654}
3bbf9c2b
IZ		 3655
3656XS(XS_Cwd_extLibpath)
3657{
3658 dXSARGS;
3659 if (items < 0 || items > 1)
1933e12c 3660 Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
3bbf9c2b 3661 {
5a9d0041 3662 IV type;
3bbf9c2b
IZ		 3663 char to[1024];
3664 U32 rc;
3665 char * RETVAL;
622913ab 3666 dXSTARG;
1933e12c 3667 STRLEN l;
3bbf9c2b
IZ		 3668
3669 if (items < 1)
3670 type = 0;
3671 else {
5a9d0041 3672 type = SvIV(ST(0));
3bbf9c2b
IZ		 3673 }
3674
5a9d0041 3675 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
1933e12c 3676 RETVAL = extLibpath(to, type, 1); /* Make errors fatal */
5a9d0041 3677 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
1933e12c
IZ		 3678 Perl_croak_nocontext("panic OS2::extLibpath parameter");
3679 l = strlen(to);
3680 if (l >= sizeof(to))
3681 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3682 to, "'\r\n"); /* Will not return */
622913ab
IZ		 3683 sv_setpv(TARG, RETVAL);
3684 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 3685 }
3686 XSRETURN(1);
3687}
3688
3689XS(XS_Cwd_extLibpath_set)
3690{
3691 dXSARGS;
3692 if (items < 1 || items > 2)
1933e12c 3693 Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
3bbf9c2b 3694 {
2d8e6c8d
GS		 3695 STRLEN n_a;
3696 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 3697 IV type;
3bbf9c2b
IZ		 3698 U32 rc;
3699 bool RETVAL;
3700
3701 if (items < 2)
3702 type = 0;
3703 else {
5a9d0041 3704 type = SvIV(ST(1));
3bbf9c2b
IZ		 3705 }
3706
1933e12c 3707 RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */
54310121 3708 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3709 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3710 }
3711 XSRETURN(1);
3712}
3713
1933e12c
IZ		 3714ULONG
3715fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
3716{
3717 char buf[2048], *to = buf, buf1[300], *s;
3718 STRLEN l;
3719 ULONG rc;
3720
3721 if (!pre && !post)
3722 return 0;
3723 if (pre) {
3724 pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
3725 if (!pre)
3726 return ERROR_INVALID_PARAMETER;
3727 l = strlen(pre);
3728 if (l >= sizeof(buf)/2)
3729 return ERROR_BUFFER_OVERFLOW;
3730 s = pre - 1;
3731 while (*++s)
3732 if (*s == '/')
2391436b 3733 *s = '\\'; /* Be extra cautious */
1933e12c
IZ		 3734 memcpy(to, pre, l);
3735 if (!l || to[l-1] != ';')
3736 to[l++] = ';';
3737 to += l;
3738 }
3739
3740 if (!replace) {
3741 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3742 rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
3743 if (rc)
3744 return rc;
3745 if (to[0] == 1 && to[1] == 0)
3746 return ERROR_INVALID_PARAMETER;
3747 to += strlen(to);
3748 if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
3749 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3750 buf, "'\r\n"); /* Will not return */
3751 if (to > buf && to[-1] != ';')
3752 *to++ = ';';
3753 }
3754 if (post) {
3755 post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
3756 if (!post)
3757 return ERROR_INVALID_PARAMETER;
3758 l = strlen(post);
3759 if (l + to - buf >= sizeof(buf) - 1)
3760 return ERROR_BUFFER_OVERFLOW;
3761 s = post - 1;
3762 while (*++s)
3763 if (*s == '/')
2391436b 3764 *s = '\\'; /* Be extra cautious */
1933e12c
IZ		 3765 memcpy(to, post, l);
3766 if (!l || to[l-1] != ';')
3767 to[l++] = ';';
3768 to += l;
3769 }
3770 *to = 0;
3771 rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
3772 return rc;
3773}
3774
30500b05
IZ		 3775/* Input: Address, BufLen
3776APIRET APIENTRY
3777DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3778 ULONG * Offset, ULONG Address);
3779*/
3780
3781DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3782 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3783 ULONG * Offset, ULONG Address),
3784 (hmod, obj, BufLen, Buf, Offset, Address))
3785
30500b05
IZ		 3786static SV*
3787module_name_at(void *pp, enum module_name_how how)
3788{
5c728af0 3789 dTHX;
30500b05
IZ		 3790 char buf[MAXPATHLEN];
3791 char *p = buf;
3792 HMODULE mod;
622913ab
IZ		 3793 ULONG obj, offset, rc, addr = (ULONG)pp;
3794
3795 if (how & mod_name_HMODULE) {
3796 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3797 Perl_croak(aTHX_ "Can't get short module name from a handle");
3798 mod = (HMODULE)pp;
3799 how &= ~mod_name_HMODULE;
3800 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
30500b05
IZ		 3801 return &PL_sv_undef;
3802 if (how == mod_name_handle)
3803 return newSVuv(mod);
3804 /* Full name... */
622913ab 3805 if ( how != mod_name_shortname
30500b05
IZ		 3806 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3807 return &PL_sv_undef;
3808 while (*p) {
3809 if (*p == '\\')
3810 *p = '/';
3811 p++;
3812 }
3813 return newSVpv(buf, 0);
3814}
3815
3816static SV*
3817module_name_of_cv(SV *cv, enum module_name_how how)
3818{
5c728af0
IZ		 3819 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3820 dTHX;
3821
622913ab
IZ		 3822 if (how & mod_name_C_function)
3823 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3824 else if (how & mod_name_HMODULE)
3825 return module_name_at((void*)SvIV(cv), how);
5c728af0
IZ		 3826 Perl_croak(aTHX_ "Not an XSUB reference");
3827 }
30500b05
IZ		 3828 return module_name_at(CvXSUB(SvRV(cv)), how);
3829}
3830
30500b05
IZ		 3831XS(XS_OS2_DLLname)
3832{
3833 dXSARGS;
3834 if (items > 2)
3835 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3836 {
3837 SV * RETVAL;
3838 int how;
3839
3840 if (items < 1)
3841 how = mod_name_full;
3842 else {
3843 how = (int)SvIV(ST(0));
3844 }
3845 if (items < 2)
3846 RETVAL = module_name(how);
3847 else
3848 RETVAL = module_name_of_cv(ST(1), how);
3849 ST(0) = RETVAL;
3850 sv_2mortal(ST(0));
3851 }
3852 XSRETURN(1);
3853}
3854
622913ab
IZ		 3855DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3856 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3857 (r1, r2, buf, szbuf, fnum))
3858
3859XS(XS_OS2__headerInfo)
3860{
3861 dXSARGS;
3862 if (items > 4 || items < 2)
3863 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3864 {
3865 ULONG req = (ULONG)SvIV(ST(0));
3866 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3867 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3868 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3869
3870 if (size <= 0)
3871 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
c2b90b61 3872 ST(0) = newSVpvs("");
622913ab
IZ		 3873 SvGROW(ST(0), size + 1);
3874 sv_2mortal(ST(0));
3875
3876 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3877 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3878 req, size, handle, offset, os2error(Perl_rc));
3879 SvCUR_set(ST(0), size);
3880 *SvEND(ST(0)) = 0;
3881 }
3882 XSRETURN(1);
3883}
3884
3885#define DQHI_QUERYLIBPATHSIZE 4
3886#define DQHI_QUERYLIBPATH 5
3887
3888XS(XS_OS2_libPath)
3889{
3890 dXSARGS;
3891 if (items != 0)
3892 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3893 {
3894 ULONG size;
3895 STRLEN n_a;
3896
3897 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3898 DQHI_QUERYLIBPATHSIZE))
3899 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3900 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3901 os2error(Perl_rc));
c2b90b61 3902 ST(0) = newSVpvs("");
622913ab
IZ		 3903 SvGROW(ST(0), size + 1);
3904 sv_2mortal(ST(0));
3905
3906 /* We should be careful: apparently, this entry point does not
3907 pay attention to the size argument, so may overwrite
3908 unrelated data! */
3909 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3910 DQHI_QUERYLIBPATH))
3911 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3912 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3913 SvCUR_set(ST(0), size);
3914 *SvEND(ST(0)) = 0;
3915 }
3916 XSRETURN(1);
3917}
3918
5ba48348
JH		 3919#define get_control87() _control87(0,0)
3920#define set_control87 _control87
3921
3922XS(XS_OS2__control87)
3923{
3924 dXSARGS;
3925 if (items != 2)
5c728af0 3926 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
5ba48348
JH		 3927 {
3928 unsigned new = (unsigned)SvIV(ST(0));
3929 unsigned mask = (unsigned)SvIV(ST(1));
3930 unsigned RETVAL;
622913ab 3931 dXSTARG;
5ba48348
JH		 3932
3933 RETVAL = _control87(new, mask);
622913ab
IZ		 3934 XSprePUSH; PUSHi((IV)RETVAL);
3935 }
3936 XSRETURN(1);
3937}
3938
3939XS(XS_OS2_mytype)
3940{
3941 dXSARGS;
3942 int which = 0;
3943
3944 if (items < 0 || items > 1)
3945 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3946 if (items == 1)
3947 which = (int)SvIV(ST(0));
3948 {
3949 unsigned RETVAL;
3950 dXSTARG;
3951
3952 switch (which) {
3953 case 0:
3954 RETVAL = os2_mytype; /* Reset after fork */
3955 break;
3956 case 1:
3957 RETVAL = os2_mytype_ini; /* Before any fork */
3958 break;
3959 case 2:
3960 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3961 break;
3962 case 3:
3963 RETVAL = my_type(); /* Morphed type */
3964 break;
3965 default:
3966 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3967 }
3968 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3969 }
3970 XSRETURN(1);
3971}
3972
622913ab
IZ		 3973
3974XS(XS_OS2_mytype_set)
3975{
3976 dXSARGS;
3977 int type;
3978
3979 if (items == 1)
3980 type = (int)SvIV(ST(0));
3981 else
3982 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3983 my_type_set(type);
9d419b5f 3984 XSRETURN_YES;
622913ab
IZ		 3985}
3986
3987
5ba48348
JH		 3988XS(XS_OS2_get_control87)
3989{
3990 dXSARGS;
3991 if (items != 0)
5c728af0 3992 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
5ba48348
JH		 3993 {
3994 unsigned RETVAL;
622913ab 3995 dXSTARG;
5ba48348
JH		 3996
3997 RETVAL = get_control87();
622913ab 3998 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3999 }
4000 XSRETURN(1);
4001}
4002
4003
4004XS(XS_OS2_set_control87)
4005{
4006 dXSARGS;
4007 if (items < 0 || items > 2)
5c728af0 4008 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
5ba48348
JH		 4009 {
4010 unsigned new;
4011 unsigned mask;
4012 unsigned RETVAL;
622913ab 4013 dXSTARG;
5ba48348
JH		 4014
4015 if (items < 1)
4016 new = MCW_EM;
4017 else {
4018 new = (unsigned)SvIV(ST(0));
4019 }
4020
4021 if (items < 2)
4022 mask = MCW_EM;
4023 else {
4024 mask = (unsigned)SvIV(ST(1));
4025 }
4026
4027 RETVAL = set_control87(new, mask);
622913ab
IZ		 4028 XSprePUSH; PUSHi((IV)RETVAL);
4029 }
4030 XSRETURN(1);
4031}
4032
4033XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
4034{
4035 dXSARGS;
4036 if (items < 0 || items > 1)
4037 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
4038 {
4039 LONG delta;
4040 ULONG RETVAL, rc;
4041 dXSTARG;
4042
4043 if (items < 1)
4044 delta = 0;
4045 else
4046 delta = (LONG)SvIV(ST(0));
4047
4048 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
4049 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
4050 XSprePUSH; PUSHu((UV)RETVAL);
5ba48348
JH		 4051 }
4052 XSRETURN(1);
4053}
4054
9d419b5f
IZ		 4055/* wait>0: force wait, wait<0: force nowait;
4056 if restore, save/restore flags; otherwise flags are in oflags.
4057
4058 Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
4059static ULONG
4060connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
4061{
4062 ULONG ret = ERROR_INTERRUPT, rc, flags;
4063
4064 if (restore && wait)
4065 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4066 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4067 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4068 flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
4069 /* We know (o)flags unless wait == 0 && restore */
4070 if (wait && (flags != oflags))
4071 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4072 while (ret == ERROR_INTERRUPT)
4073 ret = DosConnectNPipe(hpipe);
4074 (void)CheckOSError(ret);
4075 if (restore && wait && (flags != oflags))
4076 os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
4077 /* We know flags unless wait == 0 && restore */
4078 if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
4079 && (ret == ERROR_PIPE_NOT_CONNECTED) )
4080 return 0; /* normal return value */
4081 if (ret == NO_ERROR)
4082 return 1;
4083 croak_with_os2error("DosConnectNPipe()");
4084}
4085
4086/* With a lot of manual editing:
4087NO_OUTPUT ULONG
4088DosCreateNPipe(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)
4089 PREINIT:
4090 ULONG rc;
4091 C_ARGS:
4092 pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
4093 POSTCALL:
4094 if (CheckOSError(RETVAL))
4095 croak_with_os2error("OS2::mkpipe() error");
4096*/
4097XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
4098XS(XS_OS2_pipe)
4099{
4100 dXSARGS;
4101 if (items < 2 || items > 8)
4102 Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)");
4103 {
4104 ULONG RETVAL;
bfd025d9 4105 PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
9d419b5f
IZ		 4106 HPIPE hpipe;
4107 SV *OpenMode = ST(1);
4108 ULONG ulOpenMode;
4109 int connect = 0, count, message_r = 0, message = 0, b = 0;
4110 ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
4111 STRLEN len;
4e205ed6 4112 char *s, buf[10], *s1, *perltype = NULL;
9d419b5f
IZ		 4113 PerlIO *perlio;
4114 double timeout;
4115
4116 if (!pszName || !*pszName)
4117 Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
4118 s = SvPV(OpenMode, len);
75a8281e 4119 if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */
9d419b5f
IZ		 4120 ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
4121
4122 if (items == 3) {
4123 timeout = (double)SvNV(ST(2));
4124 ms = timeout * 1000;
4125 if (timeout < 0)
4126 ms = 0xFFFFFFFF; /* Indefinite */
4127 else if (timeout && !ms)
4128 ms = 1;
4129 } else if (items > 3)
4130 Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
4131
4132 while (ret == ERROR_INTERRUPT)
4133 ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
4134 os2cp_croak(ret, "DosWaitNPipe()");
4135 XSRETURN_YES;
4136 }
75a8281e 4137 if (memEQs(s, len, "call")) { /* DosCallNPipe() */
9d419b5f
IZ		 4138 ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
4139 STRLEN l;
4140 char *s;
4141 char buf[8192];
4142 STRLEN ll = sizeof(buf);
4143 char *b = buf;
4144
4145 if (items < 3 || items > 5)
4146 Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
4147 s = SvPV(ST(2), l);
4148 if (items >= 4) {
4149 timeout = (double)SvNV(ST(3));
4150 ms = timeout * 1000;
4151 if (timeout < 0)
4152 ms = 0xFFFFFFFF; /* Indefinite */
4153 else if (timeout && !ms)
4154 ms = 1;
4155 }
4156 if (items >= 5) {
4157 STRLEN lll = SvUV(ST(4));
4158 SV *sv = NEWSV(914, lll);
4159
4160 sv_2mortal(sv);
4161 ll = lll;
4162 b = SvPVX(sv);
4163 }
4164
4165 os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
4166 "DosCallNPipe()");
4167 XSRETURN_PVN(b, got);
4168 }
4169 s1 = buf;
4170 if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
4171 int r, w, R, W;
4172
4173 r = strchr(s, 'r') != 0;
4174 w = strchr(s, 'w') != 0;
4175 R = strchr(s, 'R') != 0;
4176 W = strchr(s, 'W') != 0;
4177 b = strchr(s, 'b') != 0;
4178 if (r + w + R + W + b != len || (r && R) || (w && W))
4179 Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
4180 if ((r || R) && (w || W))
4181 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
4182 else if (r || R)
4183 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
4184 else
4185 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
4186 if (R)
4187 message = message_r = 1;
4188 if (W)
4189 message = 1;
4190 else if (w && R)
4191 Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
4192 } else
4193 ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
4194
4195 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
4196 || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
4197 *s1++ = 'r';
4198 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4199 *s1++ = '+';
4200 if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4201 *s1++ = 'w';
4202 if (b)
4203 *s1++ = 'b';
4204 *s1 = 0;
4205 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4206 perltype = "+<&";
4207 else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4208 perltype = ">&";
4209 else
4210 perltype = "<&";
4211
4212 if (items < 3)
4213 connect = -1; /* no wait */
4214 else if (SvTRUE(ST(2))) {
4215 s = SvPV(ST(2), len);
75a8281e 4216 if (memEQs(s, len, "nowait"))
9d419b5f 4217 connect = -1; /* no wait */
75a8281e 4218 else if (memEQs(s, len, "wait"))
9d419b5f
IZ		 4219 connect = 1; /* wait */
4220 else
4221 Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
4222 }
4223
4224 if (items < 4)
4225 count = 1;
4226 else
4227 count = (int)SvIV(ST(3));
4228
4229 if (items < 5)
4230 ulInbufLength = 8192;
4231 else
4232 ulInbufLength = (ULONG)SvUV(ST(4));
4233
4234 if (items < 6)
4235 ulOutbufLength = ulInbufLength;
4236 else
4237 ulOutbufLength = (ULONG)SvUV(ST(5));
4238
4239 if (count < -1 || count == 0 || count >= 255)
4240 Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
4241 if (count < 0 )
4242 count = 255; /* Unlimited */
4243
4244 ulPipeMode = count;
4245 if (items < 7)
4246 ulPipeMode |= (NP_WAIT
4247 | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
4248 | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
4249 else
4250 ulPipeMode |= (ULONG)SvUV(ST(6));
4251
4252 if (items < 8)
4253 timeout = 0;
4254 else
4255 timeout = (double)SvNV(ST(7));
4256 ulTimeout = timeout * 1000;
4257 if (timeout < 0)
4258 ulTimeout = 0xFFFFFFFF; /* Indefinite */
4259 else if (timeout && !ulTimeout)
4260 ulTimeout = 1;
4261
4262 RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
4263 if (CheckOSError(RETVAL))
4264 croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
4265
4266 if (connect)
4267 connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
4268 hpipe = __imphandle(hpipe);
4269
4270 perlio = PerlIO_fdopen(hpipe, buf);
4271 ST(0) = sv_newmortal();
4272 {
732d3893
FC		 4273 GV *gv = (GV *)sv_newmortal();
4274 gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0);
d5eb9a46 4275 if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) )
9d419b5f
IZ		 4276 sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
4277 else
4278 ST(0) = &PL_sv_undef;
4279 }
4280 }
4281 XSRETURN(1);
4282}
4283
4284XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
4285XS(XS_OS2_pipeCntl)
4286{
4287 dXSARGS;
4288 if (items < 2 || items > 3)
4289 Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
4290 {
4291 ULONG rc;
4292 PerlIO *perlio = IoIFP(sv_2io(ST(0)));
4293 IV fn = PerlIO_fileno(perlio);
4294 HPIPE hpipe = (HPIPE)fn;
4295 STRLEN len;
4296 char *s = SvPV(ST(1), len);
4297 int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
4298 int peek = 0, state = 0, info = 0;
4299
4300 if (fn < 0)
4301 Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
4302 if (items == 3)
4303 wait = (SvTRUE(ST(2)) ? 1 : -1);
4304
4305 switch (len) {
4306 case 4:
4307 if (strEQ(s, "byte"))
4308 message = 0;
4309 else if (strEQ(s, "peek"))
4310 peek = 1;
4311 else if (strEQ(s, "info"))
4312 info = 1;
4313 else
4314 goto unknown;
4315 break;
4316 case 5:
4317 if (strEQ(s, "reset"))
4318 disconnect = connect = 1;
4319 else if (strEQ(s, "state"))
4320 query = 1;
4321 else
4322 goto unknown;
4323 break;
4324 case 7:
4325 if (strEQ(s, "connect"))
4326 connect = 1;
4327 else if (strEQ(s, "message"))
4328 message = 1;
4329 else
4330 goto unknown;
4331 break;
4332 case 9:
4333 if (!strEQ(s, "readstate"))
4334 goto unknown;
4335 state = 1;
4336 break;
4337 case 10:
4338 if (!strEQ(s, "disconnect"))
4339 goto unknown;
4340 disconnect = 1;
4341 break;
4342 default:
4343 unknown:
4344 Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
4345 break;
4346 }
4347
4348 if (items == 3 && !connect)
4349 Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
4350
4351 XSprePUSH; /* Do not need arguments any more */
4352 if (disconnect) {
4353 os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
4354 PerlIO_clearerr(perlio);
4355 }
4356 if (connect) {
4357 if (!connectNPipe(hpipe, wait , 1, 0))
4358 XSRETURN_IV(-1);
4359 }
4360 if (query) {
4361 ULONG flags;
4362
4363 os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
4364 XSRETURN_UV(flags);
4365 }
4366 if (peek || state || info) {
4367 ULONG BytesRead, PipeState;
4368 AVAILDATA BytesAvail;
4369
4370 os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
4371 &PipeState), "DosPeekNPipe() for state");
4372 if (state) {
4373 EXTEND(SP, 3);
22f1178f 4374 mPUSHu(PipeState);
9d419b5f 4375 /* Bytes (available/in-message) */
22f1178f
VP		 4376 mPUSHi(BytesAvail.cbpipe);
4377 mPUSHi(BytesAvail.cbmessage);
9d419b5f
IZ		 4378 XSRETURN(3);
4379 } else if (info) {
4380 /* L S S C C C/Z*
4381 ID of the (remote) computer
4382 buffers (out/in)
4383 instances (max/actual)
4384 */
4385 struct pipe_info_t {
4386 ULONG id; /* char id[4]; */
4387 PIPEINFO pInfo;
4388 char buf[512];
4389 } b;
4390 int size;
4391
4392 os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
4393 "DosQueryNPipeInfo(1)");
4394 os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
4395 "DosQueryNPipeInfo(2)");
4396 size = b.pInfo.cbName;
4397 /* Trailing 0 is included in cbName - undocumented; so
4398 one should always extract with Z* */
4399 if (size) /* name length 254 or less */
4400 size--;
4401 else
4402 size = strlen(b.pInfo.szName);
4403 EXTEND(SP, 6);
22f1178f
VP		 4404 mPUSHp(b.pInfo.szName, size);
4405 mPUSHu(b.id);
4406 mPUSHi(b.pInfo.cbOut);
4407 mPUSHi(b.pInfo.cbIn);
4408 mPUSHi(b.pInfo.cbMaxInst);
4409 mPUSHi(b.pInfo.cbCurInst);
9d419b5f
IZ		 4410 XSRETURN(6);
4411 } else if (BytesAvail.cbpipe == 0) {
4412 XSRETURN_NO;
4413 } else {
4414 SV *tmp = NEWSV(914, BytesAvail.cbpipe);
4415 char *s = SvPVX(tmp);
4416
4417 sv_2mortal(tmp);
4418 os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
4419 &BytesAvail, &PipeState), "DosPeekNPipe()");
4420 SvCUR_set(tmp, BytesRead);
4421 *SvEND(tmp) = 0;
4422 SvPOK_on(tmp);
4423 XSprePUSH; PUSHs(tmp);
4424 XSRETURN(1);
4425 }
4426 }
4427 if (message > -1) {
4428 ULONG oflags, flags;
4429
4430 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4431 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4432 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4433 flags = (oflags & NP_NOWAIT)
4434 | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
4435 if (flags != oflags)
4436 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4437 }
4438 }
4439 XSRETURN_YES;
4440}
4441
4442/*
4443NO_OUTPUT ULONG
4444DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL);
4445 PREINIT:
4446 ULONG rc;
4447 C_ARGS:
4448 pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
4449 POSTCALL:
4450 if (CheckOSError(RETVAL))
4451 croak_with_os2error("OS2::open() error");
4452*/
4453XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
4454XS(XS_OS2_open)
4455{
4456 dXSARGS;
4457 if (items < 2 || items > 6)
4458 Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)");
4459 {
4460#line 39 "pipe.xs"
4461 ULONG rc;
4462#line 113 "pipe.c"
4463 ULONG RETVAL;
bfd025d9 4464 PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
9d419b5f
IZ		 4465 HFILE hFile;
4466 ULONG ulAction;
4467 ULONG ulOpenMode = (ULONG)SvUV(ST(1));
4468 ULONG ulOpenFlags;
4469 ULONG ulAttribute;
4470 ULONG ulFileSize;
4471 PEAOP2 pEABuf;
4472
4473 if (items < 3)
4474 ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
4475 else {
4476 ulOpenFlags = (ULONG)SvUV(ST(2));
4477 }
4478
4479 if (items < 4)
4480 ulAttribute = FILE_NORMAL;
4481 else {
4482 ulAttribute = (ULONG)SvUV(ST(3));
4483 }
4484
4485 if (items < 5)
4486 ulFileSize = 0;
4487 else {
4488 ulFileSize = (ULONG)SvUV(ST(4));
4489 }
4490
4491 if (items < 6)
4492 pEABuf = NULL;
4493 else {
4494 pEABuf = (PEAOP2)SvUV(ST(5));
4495 }
4496
4497 RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
4498 if (CheckOSError(RETVAL))
4499 croak_with_os2error("OS2::open() error");
4500 XSprePUSH; EXTEND(SP,2);
4501 PUSHs(sv_newmortal());
4502 sv_setuv(ST(0), (UV)hFile);
4503 PUSHs(sv_newmortal());
4504 sv_setuv(ST(1), (UV)ulAction);
4505 }
4506 XSRETURN(2);
4507}
4508
3bbf9c2b 4509int
23da6c43 4510Xs_OS2_init(pTHX)
3bbf9c2b
IZ		 4511{
4512 char *file = __FILE__;
4513 {
4514 GV *gv;
55497cff 4515
4516 if (_emx_env & 0x200) { /* OS/2 */
4517 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
4518 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
4519 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1933e12c
IZ		 4520 newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
4521 newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
55497cff 4522 }
4bfbfac5
IZ		 4523 newXS("OS2::Error", XS_OS2_Error, file);
4524 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
4525 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
622913ab
IZ		 4526 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
4527 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4bfbfac5
IZ		 4528 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
4529 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
4530 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
4531 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
4532 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b
IZ		 4533 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
4534 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
4535 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
4536 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
4537 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
4538 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
4539 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
4540 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
4541 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
d79a646b 4542 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
59ad941d 4543 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
5ba48348
JH		 4544 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
4545 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
4546 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
30500b05 4547 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
622913ab
IZ		 4548 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
4549 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
4550 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
4551 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
4552 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
1933e12c
IZ		 4553 newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
4554 newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
4555 newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
622913ab
IZ		 4556 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
4557 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
4558 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
4559 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
9d419b5f
IZ		 4560 newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
4561 newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
4562 newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
3bbf9c2b
IZ		 4563 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
4564 GvMULTI_on(gv);
4565#ifdef PERL_IS_AOUT
4566 sv_setiv(GvSV(gv), 1);
764df951 4567#endif
59ad941d
IZ		 4568 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
4569 GvMULTI_on(gv);
4570#ifdef PERL_IS_AOUT
4571 sv_setiv(GvSV(gv), 1);
4572#endif
764df951
IZ		 4573 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
4574 GvMULTI_on(gv);
4575 sv_setiv(GvSV(gv), exe_is_aout());
4bfbfac5
IZ		 4576 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
4577 GvMULTI_on(gv);
4578 sv_setiv(GvSV(gv), _emx_rev);
4579 sv_setpv(GvSV(gv), _emx_vprt);
4580 SvIOK_on(GvSV(gv));
4581 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
4582 GvMULTI_on(gv);
4583 sv_setiv(GvSV(gv), _emx_env);
4584 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
4585 GvMULTI_on(gv);
4586 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87
IZ		 4587 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
4588 GvMULTI_on(gv);
4589 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 4590 }
2d766320 4591 return 0;
3bbf9c2b
IZ		 4592}
4593
764df951
IZ		 4594extern void _emx_init(void*);
4595
4596static void jmp_out_of_atexit(void);
4597
4598#define FORCE_EMX_INIT_CONTRACT_ARGV 1
4599#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
4600
4601static void
4602my_emx_init(void *layout) {
622913ab 4603 static volatile void *old_esp = 0; /* Cannot be on stack! */
764df951
IZ		 4604
4605 /* Can't just call emx_init(), since it moves the stack pointer */
4606 /* It also busts a lot of registers, so be extra careful */
4607 __asm__( "pushf\n"
4608 "pusha\n"
4609 "movl %%esp, %1\n"
4610 "push %0\n"
4611 "call __emx_init\n"
4612 "movl %1, %%esp\n"
4613 "popa\n"
622913ab 4614 "popf\n" : : "r" (layout), "m" (old_esp) );
764df951
IZ		 4615}
4616
4617struct layout_table_t {
4618 ULONG text_base;
4619 ULONG text_end;
4620 ULONG data_base;
4621 ULONG data_end;
4622 ULONG bss_base;
4623 ULONG bss_end;
4624 ULONG heap_base;
4625 ULONG heap_end;
4626 ULONG heap_brk;
4627 ULONG heap_off;
4628 ULONG os2_dll;
4629 ULONG stack_base;
4630 ULONG stack_end;
4631 ULONG flags;
4632 ULONG reserved[2];
4633 char options[64];
4634};
4635
4636static ULONG
4637my_os_version() {
622913ab 4638 static ULONG osv_res; /* Cannot be on stack! */
764df951 4639
c4e0013e
IZ		 4640 /* Can't just call __os_version(), since it does not follow C
4641 calling convention: it busts a lot of registers, so be extra careful */
764df951
IZ		 4642 __asm__( "pushf\n"
4643 "pusha\n"
4644 "call ___os_version\n"
4645 "movl %%eax, %0\n"
4646 "popa\n"
622913ab 4647 "popf\n" : "=m" (osv_res) );
764df951 4648
622913ab 4649 return osv_res;
764df951
IZ		 4650}
4651
4652static void
4653force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
4654{
4655 /* Calling emx_init() will bust the top of stack: it installs an
4656 exception handler and puts argv data there. */
4657 char *oldarg, *oldenv;
4658 void *oldstackend, *oldstack;
4659 PPIB pib;
4660 PTIB tib;
764df951
IZ		 4661 ULONG rc, error = 0, out;
4662 char buf[512];
4663 static struct layout_table_t layout_table;
4664 struct {
4665 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
4666 double alignment1;
4667 EXCEPTIONREGISTRATIONRECORD xreg;
4668 } *newstack;
4669 char *s;
4670
622913ab 4671 layout_table.os2_dll = (ULONG)&os2_dll_fake;
764df951
IZ		 4672 layout_table.flags = 0x02000002; /* flags: application, OMF */
4673
4674 DosGetInfoBlocks(&tib, &pib);
4675 oldarg = pib->pib_pchcmd;
4676 oldenv = pib->pib_pchenv;
4677 oldstack = tib->tib_pstack;
4678 oldstackend = tib->tib_pstacklimit;
4679
1933e12c
IZ		 4680 if ( (char*)&s < (char*)oldstack + 4*1024
4681 || (char *)oldstackend < (char*)oldstack + 52*1024 )
4682 early_error("It is a lunacy to try to run EMX Perl ",
4683 "with less than 64K of stack;\r\n",
4684 " at least with non-EMX starter...\r\n");
4685
764df951
IZ		 4686 /* Minimize the damage to the stack via reducing the size of argv. */
4687 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
4688 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
4689 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
4690 }
4691
4692 newstack = alloca(sizeof(*newstack));
4693 /* Emulate the stack probe */
4694 s = ((char*)newstack) + sizeof(*newstack);
4695 while (s > (char*)newstack) {
4696 s[-1] = 0;
4697 s -= 4096;
4698 }
4699
4700 /* Reassigning stack is documented to work */
4701 tib->tib_pstack = (void*)newstack;
4702 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
4703
4704 /* Can't just call emx_init(), since it moves the stack pointer */
4705 my_emx_init((void*)&layout_table);
4706
4707 /* Remove the exception handler, cannot use it - too low on the stack.
4708 Check whether it is inside the new stack. */
4709 buf[0] = 0;
4710 if (tib->tib_pexchain >= tib->tib_pstacklimit
4711 || tib->tib_pexchain < tib->tib_pstack) {
4712 error = 1;
4713 sprintf(buf,
4714 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
4715 (unsigned long)tib->tib_pstack,
4716 (unsigned long)tib->tib_pexchain,
4717 (unsigned long)tib->tib_pstacklimit);
4718 goto finish;
4719 }
4720 if (tib->tib_pexchain != &(newstack->xreg)) {
4721 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
4722 (unsigned long)tib->tib_pexchain,
4723 (unsigned long)&(newstack->xreg));
4724 }
4725 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
4726 if (rc)
4727 sprintf(buf + strlen(buf),
4728 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4729
4730 if (preg) {
4731 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
4732 preg->prev_structure = 0;
4733 preg->ExceptionHandler = _emx_exception;
4734 rc = DosSetExceptionHandler(preg);
4735 if (rc) {
4736 sprintf(buf + strlen(buf),
4737 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4738 DosWrite(2, buf, strlen(buf), &out);
4739 emx_exception_init = 1; /* Do it around spawn*() calls */
4740 }
4741 } else
4742 emx_exception_init = 1; /* Do it around spawn*() calls */
4743
4744 finish:
4745 /* Restore the damage */
4746 pib->pib_pchcmd = oldarg;
4747 pib->pib_pchcmd = oldenv;
4748 tib->tib_pstacklimit = oldstackend;
4749 tib->tib_pstack = oldstack;
4750 emx_runtime_init = 1;
4751 if (buf[0])
4752 DosWrite(2, buf, strlen(buf), &out);
4753 if (error)
4754 exit(56);
4755}
4756
764df951
IZ		 4757static void
4758jmp_out_of_atexit(void)
4759{
4760 if (longjmp_at_exit)
4761 longjmp(at_exit_buf, 1);
4762}
4763
4764extern void _CRT_term(void);
4765
764df951
IZ		 4766void
4767Perl_OS2_term(void **p, int exitstatus, int flags)
4768{
4769 if (!emx_runtime_secondary)
4770 return;
4771
4772 /* The principal executable is not running the same CRTL, so there
4773 is nobody to shutdown *this* CRTL except us... */
4774 if (flags & FORCE_EMX_DEINIT_EXIT) {
4775 if (p && !emx_exception_init)
4776 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4777 /* Do not run the executable's CRTL's termination routines */
4778 exit(exitstatus); /* Run at-exit, flush buffers, etc */
4779 }
4780 /* Run at-exit list, and jump out at the end */
4781 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
4782 longjmp_at_exit = 1;
4783 exit(exitstatus); /* The first pass through "if" */
4784 }
4785
4786 /* Get here if we managed to jump out of exit(), or did not run atexit. */
4787 longjmp_at_exit = 0; /* Maybe exit() is called again? */
4788#if 0 /* _atexit_n is not exported */
4789 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
4790 _atexit_n = 0; /* Remove the atexit() handlers */
4791#endif
4792 /* Will segfault on program termination if we leave this dangling... */
4793 if (p && !emx_exception_init)
4794 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4795 /* Typically there is no need to do this, done from _DLL_InitTerm() */
4796 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
4797 _CRT_term(); /* Flush buffers, etc. */
4798 /* Now it is a good time to call exit() in the caller's CRTL... */
4799}
4800
4801#include <emx/startup.h>
4802
4803extern ULONG __os_version(); /* See system.doc */
4804
764df951
IZ		 4805void
4806check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
4807{
1933e12c 4808 ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
622913ab
IZ		 4809 static HMTX hmtx_emx_init = NULLHANDLE;
4810 static int emx_init_done = 0;
764df951
IZ		 4811
4812 /* If _environ is not set, this code sits in a DLL which
4813 uses a CRT DLL which not compatible with the executable's
4814 CRT library. Some parts of the DLL are not initialized.
4815 */
4816 if (_environ != NULL)
4817 return; /* Properly initialized */
4818
622913ab
IZ		 4819 /* It is not DOS, so we may use OS/2 API now */
4820 /* Some data we manipulate is static; protect ourselves from
4821 calling the same API from a different thread. */
4822 DosEnterMustComplete(&count);
4823
4824 rc1 = DosEnterCritSec();
4825 if (!hmtx_emx_init)
4826 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
4827 else
4828 maybe_inited = 1;
4829
4830 if (rc != NO_ERROR)
4831 hmtx_emx_init = NULLHANDLE;
4832
4833 if (rc1 == NO_ERROR)
4834 DosExitCritSec();
4835 DosExitMustComplete(&count);
4836
4837 while (maybe_inited) { /* Other thread did or is doing the same now */
4838 if (emx_init_done)
4839 return;
4840 rc = DosRequestMutexSem(hmtx_emx_init,
4841 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
4842 if (rc == ERROR_INTERRUPT)
4843 continue;
4844 if (rc != NO_ERROR) {
4845 char buf[80];
4846 ULONG out;
4847
4848 sprintf(buf,
4849 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
4850 DosWrite(2, buf, strlen(buf), &out);
4851 return;
4852 }
4853 DosReleaseMutexSem(hmtx_emx_init);
4854 return;
4855 }
4856
764df951
IZ		 4857 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
4858 initialized either. Uninitialized EMX.DLL returns 0 in the low
4859 nibble of __os_version(). */
4860 v_emx = my_os_version();
4861
4862 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
4863 (=>_CRT_init=>_entry2) via a call to __os_version(), then
4864 reset when the EXE initialization code calls _text=>_init=>_entry2.
4865 The first time they are wrongly set to 0; the second time the
4866 EXE initialization code had already called emx_init=>initialize1
4867 which correctly set version_major, version_minor used by
4868 __os_version(). */
4869 v_crt = (_osmajor | _osminor);
4870
4871 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
4872 force_init_emx_runtime( preg,
4873 FORCE_EMX_INIT_CONTRACT_ARGV
4874 | FORCE_EMX_INIT_INSTALL_ATEXIT );
4875 emx_wasnt_initialized = 1;
4876 /* Update CRTL data basing on now-valid EMX runtime data */
4877 if (!v_crt) { /* The only wrong data are the versions. */
4878 v_emx = my_os_version(); /* *Now* it works */
4879 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
4880 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
4881 }
4882 }
4883 emx_runtime_secondary = 1;
4884 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
4885 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
4886
9e2a34c1 4887 if (env == NULL) { /* Fetch from the process info block */
764df951
IZ		 4888 int c = 0;
4889 PPIB pib;
4890 PTIB tib;
4891 char *e, **ep;
4892
4893 DosGetInfoBlocks(&tib, &pib);
4894 e = pib->pib_pchenv;
4895 while (*e) { /* Get count */
4896 c++;
4897 e = e + strlen(e) + 1;
4898 }
a02a5408 4899 Newx(env, c + 1, char*);
764df951
IZ		 4900 ep = env;
4901 e = pib->pib_pchenv;
4902 while (c--) {
4903 *ep++ = e;
4904 e = e + strlen(e) + 1;
4905 }
4906 *ep = NULL;
4907 }
4908 _environ = _org_environ = env;
622913ab
IZ		 4909 emx_init_done = 1;
4910 if (hmtx_emx_init)
4911 DosReleaseMutexSem(hmtx_emx_init);
764df951
IZ		 4912}
4913
4914#define ENTRY_POINT 0x10000
4915
4916static int
4917exe_is_aout(void)
4918{
4919 struct layout_table_t *layout;
4920 if (emx_wasnt_initialized)
4921 return 0;
4922 /* Now we know that the principal executable is an EMX application
4923 - unless somebody did already play with delayed initialization... */
4924 /* With EMX applications to determine whether it is AOUT one needs
4925 to examine the start of the executable to find "layout" */
4926 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
4927 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
4928 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
4929 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
4930 return 0; /* ! EMX executable */
4931 /* Fix alignment */
4932 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
4933 return !(layout->flags & 2);
4934}
4935
3bbf9c2b 4936void
aa689395 4937Perl_OS2_init(char **env)
3bbf9c2b 4938{
764df951
IZ		 4939 Perl_OS2_init3(env, 0, 0);
4940}
4941
4942void
4943Perl_OS2_init3(char **env, void **preg, int flags)
4944{
1933e12c
IZ		 4945 char *shell, *s;
4946 ULONG rc;
3bbf9c2b 4947
764df951 4948 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
18f739ee 4949 MALLOC_INIT;
764df951
IZ		 4950
4951 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4952
3bbf9c2b
IZ		 4953 settmppath();
4954 OS2_Perl_data.xs_init = &Xs_OS2_init;
1933e12c
IZ		 4955 if (perl_sh_installed) {
4956 int l = strlen(perl_sh_installed);
4957
a02a5408 4958 Newx(PL_sh_path, l + 1, char);
1933e12c
IZ		 4959 memcpy(PL_sh_path, perl_sh_installed, l + 1);
4960 } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
a02a5408 4961 Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
6b88bc9c
GS		 4962 strcpy(PL_sh_path, SH_PATH);
4963 PL_sh_path[0] = shell[0];
3bbf9c2b 4964 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 4965 int l = strlen(shell), i;
1933e12c
IZ		 4966
4967 while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
3bbf9c2b 4968 l--;
a02a5408 4969 Newx(PL_sh_path, l + 8, char);
6b88bc9c
GS		 4970 strncpy(PL_sh_path, shell, l);
4971 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 4972 for (i = 0; i < l; i++) {
6b88bc9c 4973 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 4974 }
3bbf9c2b 4975 }
dd96f567 4976 MUTEX_INIT(&start_thread_mutex);
622913ab 4977 MUTEX_INIT(&perlos2_state_mutex);
017f25f1 4978 os2_mytype = my_type(); /* Do it before morphing. Needed? */
622913ab
IZ		 4979 os2_mytype_ini = os2_mytype;
4980 Perl_os2_initial_mode = -1; /* Uninit */
1933e12c
IZ		 4981
4982 s = getenv("PERL_BEGINLIBPATH");
4983 if (s)
4984 rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
4985 else
4986 rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
4987 if (!rc) {
4988 s = getenv("PERL_ENDLIBPATH");
4989 if (s)
4990 rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
4991 else
4992 rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
4993 }
4994 if (rc) {
4995 char buf[1024];
4996
4997 snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
4998 os2error(rc));
4999 DosWrite(2, buf, strlen(buf), &rc);
5000 exit(2);
5001 }
5002
5003 _emxload_env("PERL_EMXLOAD_SECS");
5ba48348
JH		 5004 /* Some DLLs reset FP flags on load. We may have been linked with them */
5005 _control87(MCW_EM, MCW_EM);
3bbf9c2b
IZ		 5006}
5007
59ad941d
IZ		 5008int
5009fd_ok(int fd)
5010{
5011 static ULONG max_fh = 0;
5012
5013 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
5014 if (fd >= max_fh) { /* Renew */
5015 LONG delta = 0;
5016
5017 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
5018 return 1;
5019 }
5020 return fd < max_fh;
5021}
5022
5023/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
5024int
5025dup2(int from, int to)
5026{
5027 if (fd_ok(from < to ? to : from))
5028 return _dup2(from, to);
5029 errno = EBADF;
5030 return -1;
5031}
5032
5033int
5034dup(int from)
5035{
5036 if (fd_ok(from))
5037 return _dup(from);
5038 errno = EBADF;
5039 return -1;
5040}
5041
55497cff 5042#undef tmpnam
5043#undef tmpfile
5044
5045char *
5046my_tmpnam (char *str)
5047{
5048 char *p = getenv("TMP"), *tpath;
55497cff 5049
5050 if (!p) p = getenv("TEMP");
5051 tpath = tempnam(p, "pltmp");
5052 if (str && tpath) {
5053 strcpy(str, tpath);
5054 return str;
5055 }
5056 return tpath;
5057}
5058
5059FILE *
5060my_tmpfile ()
5061{
5062 struct stat s;
5063
5064 stat(".", &s);
5065 if (s.st_mode & S_IWOTH) {
5066 return tmpfile();
5067 }
5068 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
5069 grants TMP. */
5070}
367f3c24 5071
5ba48348
JH		 5072#undef rmdir
5073
cd4e750a
IZ		 5074/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
5075 trailing slashes, so we need to support this as well. */
5076
5ba48348
JH		 5077int
5078my_rmdir (__const__ char *s)
5079{
cd4e750a
IZ		 5080 char b[MAXPATHLEN];
5081 char *buf = b;
5ba48348 5082 STRLEN l = strlen(s);
cd4e750a 5083 int rc;
5ba48348 5084
cd4e750a
IZ		 5085 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5086 if (l >= sizeof b)
a02a5408 5087 Newx(buf, l + 1, char);
5ba48348 5088 strcpy(buf,s);
cd4e750a
IZ		 5089 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5090 l--;
5091 buf[l] = 0;
5ba48348
JH		 5092 s = buf;
5093 }
cd4e750a
IZ		 5094 rc = rmdir(s);
5095 if (b != buf)
5096 Safefree(buf);
5097 return rc;
5ba48348
JH		 5098}
5099
5100#undef mkdir
5101
5102int
5103my_mkdir (__const__ char *s, long perm)
5104{
cd4e750a
IZ		 5105 char b[MAXPATHLEN];
5106 char *buf = b;
5ba48348 5107 STRLEN l = strlen(s);
cd4e750a 5108 int rc;
5ba48348
JH		 5109
5110 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
cd4e750a 5111 if (l >= sizeof b)
a02a5408 5112 Newx(buf, l + 1, char);
5ba48348 5113 strcpy(buf,s);
cd4e750a
IZ		 5114 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5115 l--;
5116 buf[l] = 0;
5ba48348
JH		 5117 s = buf;
5118 }
cd4e750a
IZ		 5119 rc = mkdir(s, perm);
5120 if (b != buf)
5121 Safefree(buf);
5122 return rc;
5ba48348
JH		 5123}
5124
367f3c24
IZ		 5125#undef flock
5126
5127/* This code was contributed by Rocco Caputo. */
5128int
dd96f567 5129my_flock(int handle, int o)
367f3c24
IZ		 5130{
5131 FILELOCK rNull, rFull;
5132 ULONG timeout, handle_type, flag_word;
5133 APIRET rc;
5134 int blocking, shared;
622913ab 5135 static int use_my_flock = -1;
367f3c24 5136
622913ab
IZ		 5137 if (use_my_flock == -1) {
5138 MUTEX_LOCK(&perlos2_state_mutex);
5139 if (use_my_flock == -1) {
367f3c24
IZ		 5140 char *s = getenv("USE_PERL_FLOCK");
5141 if (s)
622913ab 5142 use_my_flock = atoi(s);
367f3c24 5143 else
622913ab
IZ		 5144 use_my_flock = 1;
5145 }
5146 MUTEX_UNLOCK(&perlos2_state_mutex);
367f3c24 5147 }
622913ab 5148 if (!(_emx_env & 0x200) || !use_my_flock)
dd96f567 5149 return flock(handle, o); /* Delegate to EMX. */
367f3c24 5150
cb69f87a 5151 /* is this a file? */
367f3c24
IZ		 5152 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
5153 (handle_type & 0xFF))
5154 {
5155 errno = EBADF;
5156 return -1;
5157 }
cb69f87a 5158 /* set lock/unlock ranges */
367f3c24
IZ		 5159 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
5160 rFull.lRange = 0x7FFFFFFF;
cb69f87a 5161 /* set timeout for blocking */
dd96f567 5162 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
cb69f87a 5163 /* shared or exclusive? */
dd96f567 5164 shared = (o & LOCK_SH) ? 1 : 0;
cb69f87a 5165 /* do not block the unlock */
dd96f567 5166 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24
IZ		 5167 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
5168 switch (rc) {
5169 case 0:
5170 errno = 0;
5171 return 0;
5172 case ERROR_INVALID_HANDLE:
5173 errno = EBADF;
5174 return -1;
5175 case ERROR_SHARING_BUFFER_EXCEEDED:
5176 errno = ENOLCK;
5177 return -1;
5178 case ERROR_LOCK_VIOLATION:
cb69f87a 5179 break; /* not an error */
367f3c24
IZ		 5180 case ERROR_INVALID_PARAMETER:
5181 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5182 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5183 errno = EINVAL;
5184 return -1;
5185 case ERROR_INTERRUPT:
5186 errno = EINTR;
5187 return -1;
5188 default:
5189 errno = EINVAL;
5190 return -1;
5191 }
5192 }
cb69f87a 5193 /* lock may block */
dd96f567 5194 if (o & (LOCK_SH | LOCK_EX)) {
cb69f87a 5195 /* for blocking operations */
367f3c24
IZ		 5196 for (;;) {
5197 rc =
5198 DosSetFileLocks(
5199 handle,
5200 &rNull,
5201 &rFull,
5202 timeout,
5203 shared
5204 );
5205 switch (rc) {
5206 case 0:
5207 errno = 0;
5208 return 0;
5209 case ERROR_INVALID_HANDLE:
5210 errno = EBADF;
5211 return -1;
5212 case ERROR_SHARING_BUFFER_EXCEEDED:
5213 errno = ENOLCK;
5214 return -1;
5215 case ERROR_LOCK_VIOLATION:
5216 if (!blocking) {
5217 errno = EWOULDBLOCK;
5218 return -1;
5219 }
5220 break;
5221 case ERROR_INVALID_PARAMETER:
5222 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5223 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5224 errno = EINVAL;
5225 return -1;
5226 case ERROR_INTERRUPT:
5227 errno = EINTR;
5228 return -1;
5229 default:
5230 errno = EINVAL;
5231 return -1;
5232 }
cb69f87a 5233 /* give away timeslice */
367f3c24
IZ		 5234 DosSleep(1);
5235 }
5236 }
5237
5238 errno = 0;
5239 return 0;
5240}
f72c975a 5241
f72c975a
IZ		 5242static int
5243use_my_pwent(void)
5244{
5245 if (_my_pwent == -1) {
5246 char *s = getenv("USE_PERL_PWENT");
5247 if (s)
5248 _my_pwent = atoi(s);
5249 else
5250 _my_pwent = 1;
5251 }
5252 return _my_pwent;
5253}
5254
5255#undef setpwent
5256#undef getpwent
5257#undef endpwent
5258
5259void
5260my_setpwent(void)
5261{
5262 if (!use_my_pwent()) {
5263 setpwent(); /* Delegate to EMX. */
5264 return;
5265 }
5266 pwent_cnt = 0;
5267}
5268
5269void
5270my_endpwent(void)
5271{
5272 if (!use_my_pwent()) {
5273 endpwent(); /* Delegate to EMX. */
5274 return;
5275 }
5276}
5277
5278struct passwd *
5279my_getpwent (void)
5280{
5281 if (!use_my_pwent())
5282 return getpwent(); /* Delegate to EMX. */
5283 if (pwent_cnt++)
cb69f87a 5284 return 0; /* Return one entry only */
f72c975a
IZ		 5285 return getpwuid(0);
5286}
5287
f72c975a
IZ		 5288void
5289setgrent(void)
5290{
5291 grent_cnt = 0;
5292}
5293
5294void
5295endgrent(void)
5296{
5297}
5298
5299struct group *
5300getgrent (void)
5301{
5302 if (grent_cnt++)
cb69f87a 5303 return 0; /* Return one entry only */
f72c975a
IZ		 5304 return getgrgid(0);
5305}
5306
5307#undef getpwuid
5308#undef getpwnam
5309
5310/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
5311static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
5312
5313static struct passwd *
5314passw_wrap(struct passwd *p)
5315{
f72c975a
IZ		 5316 char *s;
5317
5318 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
5319 return p;
5320 pw = *p;
5321 s = getenv("PW_PASSWD");
5322 if (!s)
5323 s = (char*)pw_p; /* Make match impossible */
5324
5325 pw.pw_passwd = s;
5326 return &pw;
5327}
5328
5329struct passwd *
5330my_getpwuid (uid_t id)
5331{
5332 return passw_wrap(getpwuid(id));
5333}
5334
5335struct passwd *
5336my_getpwnam (__const__ char *n)
5337{
5338 return passw_wrap(getpwnam(n));
5339}
a64c954a
IZ		 5340
5341char *
5342gcvt_os2 (double value, int digits, char *buffer)
5343{
622913ab
IZ		 5344 double absv = value > 0 ? value : -value;
5345 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
5346 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
5347 int buggy;
5348
5349 absv *= 10000;
5350 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
5351
5352 if (buggy) {
5353 char pat[12];
5354
5355 sprintf(pat, "%%.%dg", digits);
5356 sprintf(buffer, pat, value);
5357 return buffer;
5358 }
a64c954a
IZ		 5359 return gcvt (value, digits, buffer);
5360}
5c728af0
IZ		 5361
5362#undef fork
5363int fork_with_resources()
5364{
5365#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5366 dTHX;
5367 void *ctx = PERL_GET_CONTEXT;
5368#endif
622913ab 5369 unsigned fpflag = _control87(0,0);
5c728af0
IZ		 5370 int rc = fork();
5371
5c728af0 5372 if (rc == 0) { /* child */
622913ab 5373#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5c728af0
IZ		 5374 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
5375 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
5c728af0 5376#endif
622913ab
IZ		 5377
5378 { /* Reload loaded-on-demand DLLs */
5379 struct dll_handle_t *dlls = dll_handles;
5380
5381 while (dlls->modname) {
5382 char dllname[260], fail[260];
5383 ULONG rc;
5384
5385 if (!dlls->handle) { /* Was not loaded */
5386 dlls++;
5387 continue;
5388 }
5389 /* It was loaded in the parent. We need to reload it. */
5390
5391 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
5392 if (rc) {
5393 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
5394 dlls->modname, (int)dlls->handle, rc, rc);
5395 dlls++;
5396 continue;
5397 }
5398 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
5399 if (rc)
5400 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
5401 dllname, fail);
5402 dlls++;
5403 }
5404 }
5405
5406 { /* Support message queue etc. */
5407 os2_mytype = my_type();
5408 /* Apparently, subprocesses (in particular, fork()) do not
5409 inherit the morphed state, so os2_mytype is the same as
5410 os2_mytype_ini. */
5411
5412 if (Perl_os2_initial_mode != -1
5413 && Perl_os2_initial_mode != os2_mytype) {
5414 /* XXXX ??? */
5415 }
5416 }
5417 if (Perl_HAB_set)
5418 (void)_obtain_Perl_HAB;
5419 if (Perl_hmq_refcnt) {
5420 if (my_type() != 3)
5421 my_type_set(3);
5422 Create_HMQ(Perl_hmq_servers != 0,
5423 "Cannot create a message queue on fork");
5424 }
5425
5426 /* We may have loaded some modules */
5427 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
5428 }
5c728af0
IZ		 5429 return rc;
5430}
622913ab 5431
1933e12c
IZ		 5432/* APIRET APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
5433
5434ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
5435
5436APIRET APIENTRY
5437myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
5438{
5439 APIRET rc;
5440 USHORT gSel, lSel; /* Will not cross 64K boundary */
5441
5442 rc = ((USHORT)
5443 (_THUNK_PROLOG (4+4);
5444 _THUNK_FLAT (&gSel);
5445 _THUNK_FLAT (&lSel);
5446 _THUNK_CALL (Dos16GetInfoSeg)));
5447 if (rc)
5448 return rc;
5449 *pGlobal = MAKEPGINFOSEG(gSel);
5450 *pLocal = MAKEPLINFOSEG(lSel);
5451 return rc;
5452}
5453
5454static void
5455GetInfoTables(void)
5456{
5457 ULONG rc = 0;
5458
5459 MUTEX_LOCK(&perlos2_state_mutex);
5460 if (!gTable)
5461 rc = myDosGetInfoSeg(&gTable, &lTable);
5462 MUTEX_UNLOCK(&perlos2_state_mutex);
5463 os2cp_croak(rc, "Dos16GetInfoSeg");
5464}
5465
5466ULONG
5467msCounter(void)
5468{ /* XXXX Is not lTable thread-specific? */
5469 if (!gTable)
5470 GetInfoTables();
5471 return gTable->SIS_MsCount;
5472}
5473
5474ULONG
5475InfoTable(int local)
5476{
5477 if (!gTable)
5478 GetInfoTables();
5479 return local ? (ULONG)lTable : (ULONG)gTable;
5480}
Unnamed repository; edit this file 'description' to name the repository.