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