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