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
perldelta: Add entry for new XS macro isUTF8_CHAR
[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 1347{
eb578fdb
KW		 1348 char **a;
1349 char *s;
3bbf9c2b 1350 char *shell, *copt, *news = NULL;
2d766320 1351 int rc, seenspace = 0, mergestderr = 0;
4633a7c4 1352
c0c09dfd 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
5aaab254 1478os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing)
4435c477 1479{
eb578fdb
KW		 1480 SV **argp = (SV **)args;
1481 SV **last = argp + cnt;
1482 char **a;
4435c477
IZ		 1483 int rc;
1484 int flag = P_WAIT, flag_set = 0;
1485 STRLEN n_a;
1486
9d419b5f
IZ		 1487 if (cnt) {
1488 Newx(PL_Argv, cnt + 3, char*); /* 3 extra to expand #! */
4435c477
IZ		 1489 a = PL_Argv;
1490
9d419b5f
IZ		 1491 if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) {
1492 flag = SvIVx(*argp);
1493 flag_set = 1;
1494 } else
1495 --argp;
4435c477 1496
9d419b5f
IZ		 1497 while (++argp < last) {
1498 if (*argp)
1499 *a++ = SvPVx(*argp, n_a);
4435c477
IZ		 1500 else
1501 *a++ = "";
1502 }
4e205ed6 1503 *a = NULL;
4435c477 1504
622913ab 1505 if ( flag_set && (a == PL_Argv + 1)
9d419b5f 1506 && !really && execing == ASPAWN_WAIT ) { /* One arg? */
23da6c43 1507 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
9d419b5f
IZ		 1508 } else {
1509 const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT};
1510
1511 rc = do_spawn_ve(aTHX_ really, flag, execf[execing], NULL, 0);
1512 }
4435c477
IZ		 1513 } else
1514 rc = -1;
1515 do_execfree();
1516 return rc;
1517}
1518
622913ab
IZ		 1519/* Array spawn. */
1520int
5aaab254 1521os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp)
622913ab 1522{
9d419b5f 1523 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_WAIT);
622913ab
IZ		 1524}
1525
1526/* Array exec. */
1527bool
1528Perl_do_aexec(pTHX_ SV* really, SV** vmark, SV** vsp)
1529{
9d419b5f 1530 return os2_aspawn_4(aTHX_ really, vmark + 1, vsp - vmark, ASPAWN_EXEC);
622913ab
IZ		 1531}
1532
760ac839 1533int
23da6c43 1534os2_do_spawn(pTHX_ char *cmd)
760ac839 1535{
23da6c43 1536 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
760ac839
LW		 1537}
1538
72ea3524 1539int
23da6c43 1540do_spawn_nowait(pTHX_ char *cmd)
72ea3524 1541{
23da6c43 1542 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
72ea3524
IZ		 1543}
1544
760ac839 1545bool
751e07d2 1546Perl_do_exec(pTHX_ const char *cmd)
760ac839 1547{
23da6c43 1548 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
017f25f1 1549 return FALSE;
760ac839
LW		 1550}
1551
1552bool
23da6c43 1553os2exec(pTHX_ char *cmd)
760ac839 1554{
23da6c43 1555 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
760ac839
LW		 1556}
1557
3bbf9c2b 1558PerlIO *
9d419b5f 1559my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args)
c0c09dfd 1560{
72ea3524 1561#ifndef USE_POPEN
72ea3524 1562 int p[2];
eb578fdb
KW		 1563 I32 this, that, newfd;
1564 I32 pid;
3bbf9c2b 1565 SV *sv;
2d766320 1566 int fh_fl = 0; /* Pacify the warning */
72ea3524 1567
72ea3524
IZ		 1568 /* `this' is what we use in the parent, `that' in the child. */
1569 this = (*mode == 'w');
1570 that = !this;
284167a5 1571 if (TAINTING_get) {
72ea3524
IZ		 1572 taint_env();
1573 taint_proper("Insecure %s%s", "EXEC");
1574 }
c2267164 1575 if (pipe(p) < 0)
4e205ed6 1576 return NULL;
72ea3524 1577 /* Now we need to spawn the child. */
5838269b
IZ		 1578 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1579 int new = dup(p[this]);
1580
1581 if (new == -1)
1582 goto closepipes;
1583 close(p[this]);
1584 p[this] = new;
1585 }
72ea3524 1586 newfd = dup(*mode == 'r'); /* Preserve std* */
5838269b
IZ		 1587 if (newfd == -1) {
1588 /* This cannot happen due to fh being bad after pipe(), since
1589 pipe() should have created fh 0 and 1 even if they were
1590 initially closed. But we closed p[this] before. */
1591 if (errno != EBADF) {
1592 closepipes:
1593 close(p[0]);
1594 close(p[1]);
4e205ed6 1595 return NULL;
5838269b
IZ		 1596 }
1597 } else
1598 fh_fl = fcntl(*mode == 'r', F_GETFD);
1599 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
72ea3524
IZ		 1600 dup2(p[that], *mode == 'r');
1601 close(p[that]);
1602 }
1603 /* Where is `this' and newfd now? */
1604 fcntl(p[this], F_SETFD, FD_CLOEXEC);
5838269b
IZ		 1605 if (newfd != -1)
1606 fcntl(newfd, F_SETFD, FD_CLOEXEC);
9d419b5f 1607 if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */
4e205ed6 1608 pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT);
9d419b5f
IZ		 1609 } else
1610 pid = do_spawn_nowait(aTHX_ cmd);
5838269b
IZ		 1611 if (newfd == -1)
1612 close(*mode == 'r'); /* It was closed initially */
1613 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
72ea3524
IZ		 1614 dup2(newfd, *mode == 'r'); /* Return std* back. */
1615 close(newfd);
5838269b
IZ		 1616 fcntl(*mode == 'r', F_SETFD, fh_fl);
1617 } else
1618 fcntl(*mode == 'r', F_SETFD, fh_fl);
491527d0
GS		 1619 if (p[that] == (*mode == 'r'))
1620 close(p[that]);
72ea3524
IZ		 1621 if (pid == -1) {
1622 close(p[this]);
4e205ed6 1623 return NULL;
72ea3524 1624 }
5838269b 1625 if (p[that] < p[this]) { /* Make fh as small as possible */
72ea3524
IZ		 1626 dup2(p[this], p[that]);
1627 close(p[this]);
1628 p[this] = p[that];
1629 }
6b88bc9c 1630 sv = *av_fetch(PL_fdpid,p[this],TRUE);
72ea3524
IZ		 1631 (void)SvUPGRADE(sv,SVt_IV);
1632 SvIVX(sv) = pid;
6b88bc9c 1633 PL_forkprocess = pid;
72ea3524 1634 return PerlIO_fdopen(p[this], mode);
3bbf9c2b 1635
72ea3524
IZ		 1636#else /* USE_POPEN */
1637
1638 PerlIO *res;
1639 SV *sv;
1640
9d419b5f
IZ		 1641 if (cnt)
1642 Perl_croak(aTHX_ "List form of piped open not implemented");
1643
72ea3524 1644# ifdef TRYSHELL
3bbf9c2b 1645 res = popen(cmd, mode);
72ea3524 1646# else
c0c09dfd 1647 char *shell = getenv("EMXSHELL");
3bbf9c2b 1648
6b88bc9c 1649 my_setenv("EMXSHELL", PL_sh_path);
c0c09dfd 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 2013
b9f2b683 2014 avlen = av_tindex((AV*)sv);
760ac839 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 3464 SvTAINTED_on(ST(0));
3bbf9c2b
IZ		 3465 }
3466 XSRETURN(1);
3467}
3468
3469XS(XS_Cwd_sys_abspath)
3470{
3471 dXSARGS;
5723cfe4
IZ		 3472 if (items > 2)
3473 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3bbf9c2b 3474 {
2d8e6c8d 3475 STRLEN n_a;
5723cfe4 3476 char * path = items ? (char *)SvPV(ST(0),n_a) : ".";
f5f423e4 3477 char * dir, *s, *t, *e;
3bbf9c2b
IZ		 3478 char p[MAXPATHLEN];
3479 char * RETVAL;
f5f423e4
IZ		 3480 int l;
3481 SV *sv;
3bbf9c2b
IZ		 3482
3483 if (items < 2)
3484 dir = NULL;
3485 else {
2d8e6c8d 3486 dir = (char *)SvPV(ST(1),n_a);
3bbf9c2b
IZ		 3487 }
3488 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
3489 path += 2;
3490 }
3491 if (dir == NULL) {
3492 if (_abspath(p, path, MAXPATHLEN) == 0) {
3493 RETVAL = p;
3494 } else {
3495 RETVAL = NULL;
3496 }
3497 } else {
3498 /* Absolute with drive: */
3499 if ( sys_is_absolute(path) ) {
3500 if (_abspath(p, path, MAXPATHLEN) == 0) {
3501 RETVAL = p;
3502 } else {
3503 RETVAL = NULL;
3504 }
3505 } else if (path[0] == '/' || path[0] == '\\') {
3506 /* Rooted, but maybe on different drive. */
3507 if (isALPHA(dir[0]) && dir[1] == ':' ) {
3508 char p1[MAXPATHLEN];
3509
3510 /* Need to prepend the drive. */
3511 p1[0] = dir[0];
3512 p1[1] = dir[1];
3513 Copy(path, p1 + 2, strlen(path) + 1, char);
3514 RETVAL = p;
3515 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3516 RETVAL = p;
3517 } else {
3518 RETVAL = NULL;
3519 }
3520 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3521 RETVAL = p;
3522 } else {
3523 RETVAL = NULL;
3524 }
3525 } else {
3526 /* Either path is relative, or starts with a drive letter. */
3527 /* If the path starts with a drive letter, then dir is
3528 relevant only if
3529 a/b) it is absolute/x:relative on the same drive.
3530 c) path is on current drive, and dir is rooted
3531 In all the cases it is safe to drop the drive part
3532 of the path. */
3533 if ( !sys_is_relative(path) ) {
3bbf9c2b
IZ		 3534 if ( ( ( sys_is_absolute(dir)
3535 || (isALPHA(dir[0]) && dir[1] == ':'
3536 && strnicmp(dir, path,1) == 0))
3537 && strnicmp(dir, path,1) == 0)
3538 || ( !(isALPHA(dir[0]) && dir[1] == ':')
3539 && toupper(path[0]) == current_drive())) {
3540 path += 2;
3541 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
3542 RETVAL = p; goto done;
3543 } else {
3544 RETVAL = NULL; goto done;
3545 }
3546 }
3547 {
3548 /* Need to prepend the absolute path of dir. */
3549 char p1[MAXPATHLEN];
3550
3551 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
3552 int l = strlen(p1);
3553
3554 if (p1[ l - 1 ] != '/') {
3555 p1[ l ] = '/';
3556 l++;
3557 }
3558 Copy(path, p1 + l, strlen(path) + 1, char);
3559 if (_abspath(p, p1, MAXPATHLEN) == 0) {
3560 RETVAL = p;
3561 } else {
3562 RETVAL = NULL;
3563 }
3564 } else {
3565 RETVAL = NULL;
3566 }
3567 }
3568 done:
3569 }
3570 }
f5f423e4
IZ		 3571 if (!RETVAL)
3572 XSRETURN_EMPTY;
3573 /* Backslashes are already converted to slashes. */
3574 /* Remove trailing slashes */
3575 l = strlen(RETVAL);
3576 while (l > 0 && RETVAL[l-1] == '/')
3577 l--;
3bbf9c2b 3578 ST(0) = sv_newmortal();
f5f423e4 3579 sv_setpvn( sv = (SV*)ST(0), RETVAL, l);
45ee47cb
IZ		 3580 /* Remove duplicate slashes, skipping the first three, which
3581 may be parts of a server-based path */
3582 s = t = 3 + SvPV_force(sv, n_a);
f5f423e4 3583 e = SvEND(sv);
45ee47cb
IZ		 3584 /* Do not worry about multibyte chars here, this would contradict the
3585 eventual UTFization, and currently most other places break too... */
f5f423e4
IZ		 3586 while (s < e) {
3587 if (s[0] == t[-1] && s[0] == '/')
3588 s++; /* Skip duplicate / */
3589 else
3590 *t++ = *s++;
3591 }
45ee47cb
IZ		 3592 if (t < e) {
3593 *t = 0;
3594 SvCUR_set(sv, t - SvPVX(sv));
3595 }
5723cfe4
IZ		 3596 if (!items)
3597 SvTAINTED_on(ST(0));
3bbf9c2b
IZ		 3598 }
3599 XSRETURN(1);
3600}
72ea3524
IZ		 3601typedef APIRET (*PELP)(PSZ path, ULONG type);
3602
5a9d0041
IZ		 3603/* Kernels after 2000/09/15 understand this too: */
3604#ifndef LIBPATHSTRICT
3605# define LIBPATHSTRICT 3
3606#endif
3607
72ea3524 3608APIRET
1933e12c 3609ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal)
72ea3524 3610{
5a9d0041 3611 ULONG what;
1933e12c 3612 PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */
5a9d0041 3613
1933e12c
IZ		 3614 if (!f) /* Impossible with fatal */
3615 return Perl_rc;
5a9d0041
IZ		 3616 if (type > 0)
3617 what = END_LIBPATH;
3618 else if (type == 0)
3619 what = BEGIN_LIBPATH;
3620 else
3621 what = LIBPATHSTRICT;
35bc1fdc 3622 return (*(PELP)f)(path, what);
72ea3524 3623}
3bbf9c2b 3624
1933e12c
IZ		 3625#define extLibpath(to,type, fatal) \
3626 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type), fatal)) ? NULL : (to) )
3627
3628#define extLibpath_set(p,type, fatal) \
3629 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type), fatal)))
3bbf9c2b 3630
1933e12c
IZ		 3631static void
3632early_error(char *msg1, char *msg2, char *msg3)
3633{ /* Buffer overflow detected; there is very little we can do... */
3634 ULONG rc;
3635
3636 DosWrite(2, msg1, strlen(msg1), &rc);
3637 DosWrite(2, msg2, strlen(msg2), &rc);
3638 DosWrite(2, msg3, strlen(msg3), &rc);
3639 DosExit(EXIT_PROCESS, 2);
3640}
3bbf9c2b
IZ		 3641
3642XS(XS_Cwd_extLibpath)
3643{
3644 dXSARGS;
3645 if (items < 0 || items > 1)
1933e12c 3646 Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)");
3bbf9c2b 3647 {
5a9d0041 3648 IV type;
3bbf9c2b
IZ		 3649 char to[1024];
3650 U32 rc;
3651 char * RETVAL;
622913ab 3652 dXSTARG;
1933e12c 3653 STRLEN l;
3bbf9c2b
IZ		 3654
3655 if (items < 1)
3656 type = 0;
3657 else {
5a9d0041 3658 type = SvIV(ST(0));
3bbf9c2b
IZ		 3659 }
3660
5a9d0041 3661 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
1933e12c 3662 RETVAL = extLibpath(to, type, 1); /* Make errors fatal */
5a9d0041 3663 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
1933e12c
IZ		 3664 Perl_croak_nocontext("panic OS2::extLibpath parameter");
3665 l = strlen(to);
3666 if (l >= sizeof(to))
3667 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3668 to, "'\r\n"); /* Will not return */
622913ab
IZ		 3669 sv_setpv(TARG, RETVAL);
3670 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 3671 }
3672 XSRETURN(1);
3673}
3674
3675XS(XS_Cwd_extLibpath_set)
3676{
3677 dXSARGS;
3678 if (items < 1 || items > 2)
1933e12c 3679 Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)");
3bbf9c2b 3680 {
2d8e6c8d
GS		 3681 STRLEN n_a;
3682 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 3683 IV type;
3bbf9c2b
IZ		 3684 U32 rc;
3685 bool RETVAL;
3686
3687 if (items < 2)
3688 type = 0;
3689 else {
5a9d0041 3690 type = SvIV(ST(1));
3bbf9c2b
IZ		 3691 }
3692
1933e12c 3693 RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */
54310121 3694 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3695 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3696 }
3697 XSRETURN(1);
3698}
3699
1933e12c
IZ		 3700ULONG
3701fill_extLibpath(int type, char *pre, char *post, int replace, char *msg)
3702{
3703 char buf[2048], *to = buf, buf1[300], *s;
3704 STRLEN l;
3705 ULONG rc;
3706
3707 if (!pre && !post)
3708 return 0;
3709 if (pre) {
3710 pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg);
3711 if (!pre)
3712 return ERROR_INVALID_PARAMETER;
3713 l = strlen(pre);
3714 if (l >= sizeof(buf)/2)
3715 return ERROR_BUFFER_OVERFLOW;
3716 s = pre - 1;
3717 while (*++s)
3718 if (*s == '/')
2391436b 3719 *s = '\\'; /* Be extra cautious */
1933e12c
IZ		 3720 memcpy(to, pre, l);
3721 if (!l || to[l-1] != ';')
3722 to[l++] = ';';
3723 to += l;
3724 }
3725
3726 if (!replace) {
3727 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3728 rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */
3729 if (rc)
3730 return rc;
3731 if (to[0] == 1 && to[1] == 0)
3732 return ERROR_INVALID_PARAMETER;
3733 to += strlen(to);
3734 if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */
3735 early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `",
3736 buf, "'\r\n"); /* Will not return */
3737 if (to > buf && to[-1] != ';')
3738 *to++ = ';';
3739 }
3740 if (post) {
3741 post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg);
3742 if (!post)
3743 return ERROR_INVALID_PARAMETER;
3744 l = strlen(post);
3745 if (l + to - buf >= sizeof(buf) - 1)
3746 return ERROR_BUFFER_OVERFLOW;
3747 s = post - 1;
3748 while (*++s)
3749 if (*s == '/')
2391436b 3750 *s = '\\'; /* Be extra cautious */
1933e12c
IZ		 3751 memcpy(to, post, l);
3752 if (!l || to[l-1] != ';')
3753 to[l++] = ';';
3754 to += l;
3755 }
3756 *to = 0;
3757 rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */
3758 return rc;
3759}
3760
30500b05
IZ		 3761/* Input: Address, BufLen
3762APIRET APIENTRY
3763DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3764 ULONG * Offset, ULONG Address);
3765*/
3766
3767DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3768 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3769 ULONG * Offset, ULONG Address),
3770 (hmod, obj, BufLen, Buf, Offset, Address))
3771
30500b05
IZ		 3772static SV*
3773module_name_at(void *pp, enum module_name_how how)
3774{
5c728af0 3775 dTHX;
30500b05
IZ		 3776 char buf[MAXPATHLEN];
3777 char *p = buf;
3778 HMODULE mod;
622913ab
IZ		 3779 ULONG obj, offset, rc, addr = (ULONG)pp;
3780
3781 if (how & mod_name_HMODULE) {
3782 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3783 Perl_croak(aTHX_ "Can't get short module name from a handle");
3784 mod = (HMODULE)pp;
3785 how &= ~mod_name_HMODULE;
3786 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
30500b05
IZ		 3787 return &PL_sv_undef;
3788 if (how == mod_name_handle)
3789 return newSVuv(mod);
3790 /* Full name... */
622913ab 3791 if ( how != mod_name_shortname
30500b05
IZ		 3792 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3793 return &PL_sv_undef;
3794 while (*p) {
3795 if (*p == '\\')
3796 *p = '/';
3797 p++;
3798 }
3799 return newSVpv(buf, 0);
3800}
3801
3802static SV*
3803module_name_of_cv(SV *cv, enum module_name_how how)
3804{
5c728af0
IZ		 3805 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3806 dTHX;
3807
622913ab
IZ		 3808 if (how & mod_name_C_function)
3809 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3810 else if (how & mod_name_HMODULE)
3811 return module_name_at((void*)SvIV(cv), how);
5c728af0
IZ		 3812 Perl_croak(aTHX_ "Not an XSUB reference");
3813 }
30500b05
IZ		 3814 return module_name_at(CvXSUB(SvRV(cv)), how);
3815}
3816
30500b05
IZ		 3817XS(XS_OS2_DLLname)
3818{
3819 dXSARGS;
3820 if (items > 2)
3821 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3822 {
3823 SV * RETVAL;
3824 int how;
3825
3826 if (items < 1)
3827 how = mod_name_full;
3828 else {
3829 how = (int)SvIV(ST(0));
3830 }
3831 if (items < 2)
3832 RETVAL = module_name(how);
3833 else
3834 RETVAL = module_name_of_cv(ST(1), how);
3835 ST(0) = RETVAL;
3836 sv_2mortal(ST(0));
3837 }
3838 XSRETURN(1);
3839}
3840
622913ab
IZ		 3841DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3842 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3843 (r1, r2, buf, szbuf, fnum))
3844
3845XS(XS_OS2__headerInfo)
3846{
3847 dXSARGS;
3848 if (items > 4 || items < 2)
3849 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3850 {
3851 ULONG req = (ULONG)SvIV(ST(0));
3852 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3853 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3854 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3855
3856 if (size <= 0)
3857 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
c2b90b61 3858 ST(0) = newSVpvs("");
622913ab
IZ		 3859 SvGROW(ST(0), size + 1);
3860 sv_2mortal(ST(0));
3861
3862 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3863 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3864 req, size, handle, offset, os2error(Perl_rc));
3865 SvCUR_set(ST(0), size);
3866 *SvEND(ST(0)) = 0;
3867 }
3868 XSRETURN(1);
3869}
3870
3871#define DQHI_QUERYLIBPATHSIZE 4
3872#define DQHI_QUERYLIBPATH 5
3873
3874XS(XS_OS2_libPath)
3875{
3876 dXSARGS;
3877 if (items != 0)
3878 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3879 {
3880 ULONG size;
3881 STRLEN n_a;
3882
3883 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3884 DQHI_QUERYLIBPATHSIZE))
3885 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3886 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3887 os2error(Perl_rc));
c2b90b61 3888 ST(0) = newSVpvs("");
622913ab
IZ		 3889 SvGROW(ST(0), size + 1);
3890 sv_2mortal(ST(0));
3891
3892 /* We should be careful: apparently, this entry point does not
3893 pay attention to the size argument, so may overwrite
3894 unrelated data! */
3895 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3896 DQHI_QUERYLIBPATH))
3897 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3898 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3899 SvCUR_set(ST(0), size);
3900 *SvEND(ST(0)) = 0;
3901 }
3902 XSRETURN(1);
3903}
3904
5ba48348
JH		 3905#define get_control87() _control87(0,0)
3906#define set_control87 _control87
3907
3908XS(XS_OS2__control87)
3909{
3910 dXSARGS;
3911 if (items != 2)
5c728af0 3912 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
5ba48348
JH		 3913 {
3914 unsigned new = (unsigned)SvIV(ST(0));
3915 unsigned mask = (unsigned)SvIV(ST(1));
3916 unsigned RETVAL;
622913ab 3917 dXSTARG;
5ba48348
JH		 3918
3919 RETVAL = _control87(new, mask);
622913ab
IZ		 3920 XSprePUSH; PUSHi((IV)RETVAL);
3921 }
3922 XSRETURN(1);
3923}
3924
3925XS(XS_OS2_mytype)
3926{
3927 dXSARGS;
3928 int which = 0;
3929
3930 if (items < 0 || items > 1)
3931 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3932 if (items == 1)
3933 which = (int)SvIV(ST(0));
3934 {
3935 unsigned RETVAL;
3936 dXSTARG;
3937
3938 switch (which) {
3939 case 0:
3940 RETVAL = os2_mytype; /* Reset after fork */
3941 break;
3942 case 1:
3943 RETVAL = os2_mytype_ini; /* Before any fork */
3944 break;
3945 case 2:
3946 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3947 break;
3948 case 3:
3949 RETVAL = my_type(); /* Morphed type */
3950 break;
3951 default:
3952 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3953 }
3954 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3955 }
3956 XSRETURN(1);
3957}
3958
622913ab
IZ		 3959
3960XS(XS_OS2_mytype_set)
3961{
3962 dXSARGS;
3963 int type;
3964
3965 if (items == 1)
3966 type = (int)SvIV(ST(0));
3967 else
3968 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3969 my_type_set(type);
9d419b5f 3970 XSRETURN_YES;
622913ab
IZ		 3971}
3972
3973
5ba48348
JH		 3974XS(XS_OS2_get_control87)
3975{
3976 dXSARGS;
3977 if (items != 0)
5c728af0 3978 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
5ba48348
JH		 3979 {
3980 unsigned RETVAL;
622913ab 3981 dXSTARG;
5ba48348
JH		 3982
3983 RETVAL = get_control87();
622913ab 3984 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3985 }
3986 XSRETURN(1);
3987}
3988
3989
3990XS(XS_OS2_set_control87)
3991{
3992 dXSARGS;
3993 if (items < 0 || items > 2)
5c728af0 3994 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
5ba48348
JH		 3995 {
3996 unsigned new;
3997 unsigned mask;
3998 unsigned RETVAL;
622913ab 3999 dXSTARG;
5ba48348
JH		 4000
4001 if (items < 1)
4002 new = MCW_EM;
4003 else {
4004 new = (unsigned)SvIV(ST(0));
4005 }
4006
4007 if (items < 2)
4008 mask = MCW_EM;
4009 else {
4010 mask = (unsigned)SvIV(ST(1));
4011 }
4012
4013 RETVAL = set_control87(new, mask);
622913ab
IZ		 4014 XSprePUSH; PUSHi((IV)RETVAL);
4015 }
4016 XSRETURN(1);
4017}
4018
4019XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
4020{
4021 dXSARGS;
4022 if (items < 0 || items > 1)
4023 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
4024 {
4025 LONG delta;
4026 ULONG RETVAL, rc;
4027 dXSTARG;
4028
4029 if (items < 1)
4030 delta = 0;
4031 else
4032 delta = (LONG)SvIV(ST(0));
4033
4034 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
4035 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
4036 XSprePUSH; PUSHu((UV)RETVAL);
5ba48348
JH		 4037 }
4038 XSRETURN(1);
4039}
4040
9d419b5f
IZ		 4041/* wait>0: force wait, wait<0: force nowait;
4042 if restore, save/restore flags; otherwise flags are in oflags.
4043
4044 Returns 1 if connected, 0 if not (due to nowait); croaks on error. */
4045static ULONG
4046connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags)
4047{
4048 ULONG ret = ERROR_INTERRUPT, rc, flags;
4049
4050 if (restore && wait)
4051 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4052 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4053 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4054 flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT);
4055 /* We know (o)flags unless wait == 0 && restore */
4056 if (wait && (flags != oflags))
4057 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4058 while (ret == ERROR_INTERRUPT)
4059 ret = DosConnectNPipe(hpipe);
4060 (void)CheckOSError(ret);
4061 if (restore && wait && (flags != oflags))
4062 os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back");
4063 /* We know flags unless wait == 0 && restore */
4064 if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1)
4065 && (ret == ERROR_PIPE_NOT_CONNECTED) )
4066 return 0; /* normal return value */
4067 if (ret == NO_ERROR)
4068 return 1;
4069 croak_with_os2error("DosConnectNPipe()");
4070}
4071
4072/* With a lot of manual editing:
4073NO_OUTPUT ULONG
4074DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0)
4075 PREINIT:
4076 ULONG rc;
4077 C_ARGS:
4078 pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout
4079 POSTCALL:
4080 if (CheckOSError(RETVAL))
4081 croak_with_os2error("OS2::mkpipe() error");
4082*/
4083XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */
4084XS(XS_OS2_pipe)
4085{
4086 dXSARGS;
4087 if (items < 2 || items > 8)
4088 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)");
4089 {
4090 ULONG RETVAL;
bfd025d9 4091 PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
9d419b5f
IZ		 4092 HPIPE hpipe;
4093 SV *OpenMode = ST(1);
4094 ULONG ulOpenMode;
4095 int connect = 0, count, message_r = 0, message = 0, b = 0;
4096 ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc;
4097 STRLEN len;
4e205ed6 4098 char *s, buf[10], *s1, *perltype = NULL;
9d419b5f
IZ		 4099 PerlIO *perlio;
4100 double timeout;
4101
4102 if (!pszName || !*pszName)
4103 Perl_croak(aTHX_ "OS2::pipe(): empty pipe name");
4104 s = SvPV(OpenMode, len);
4105 if (len == 4 && strEQ(s, "wait")) { /* DosWaitNPipe() */
4106 ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */
4107
4108 if (items == 3) {
4109 timeout = (double)SvNV(ST(2));
4110 ms = timeout * 1000;
4111 if (timeout < 0)
4112 ms = 0xFFFFFFFF; /* Indefinite */
4113 else if (timeout && !ms)
4114 ms = 1;
4115 } else if (items > 3)
4116 Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items);
4117
4118 while (ret == ERROR_INTERRUPT)
4119 ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */
4120 os2cp_croak(ret, "DosWaitNPipe()");
4121 XSRETURN_YES;
4122 }
4123 if (len == 4 && strEQ(s, "call")) { /* DosCallNPipe() */
4124 ULONG ms = 0xFFFFFFFF, got; /* Indefinite */
4125 STRLEN l;
4126 char *s;
4127 char buf[8192];
4128 STRLEN ll = sizeof(buf);
4129 char *b = buf;
4130
4131 if (items < 3 || items > 5)
4132 Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])");
4133 s = SvPV(ST(2), l);
4134 if (items >= 4) {
4135 timeout = (double)SvNV(ST(3));
4136 ms = timeout * 1000;
4137 if (timeout < 0)
4138 ms = 0xFFFFFFFF; /* Indefinite */
4139 else if (timeout && !ms)
4140 ms = 1;
4141 }
4142 if (items >= 5) {
4143 STRLEN lll = SvUV(ST(4));
4144 SV *sv = NEWSV(914, lll);
4145
4146 sv_2mortal(sv);
4147 ll = lll;
4148 b = SvPVX(sv);
4149 }
4150
4151 os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms),
4152 "DosCallNPipe()");
4153 XSRETURN_PVN(b, got);
4154 }
4155 s1 = buf;
4156 if (len && len <= 3 && !(*s >= '0' && *s <= '9')) {
4157 int r, w, R, W;
4158
4159 r = strchr(s, 'r') != 0;
4160 w = strchr(s, 'w') != 0;
4161 R = strchr(s, 'R') != 0;
4162 W = strchr(s, 'W') != 0;
4163 b = strchr(s, 'b') != 0;
4164 if (r + w + R + W + b != len || (r && R) || (w && W))
4165 Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s);
4166 if ((r || R) && (w || W))
4167 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX;
4168 else if (r || R)
4169 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND;
4170 else
4171 ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND;
4172 if (R)
4173 message = message_r = 1;
4174 if (W)
4175 message = 1;
4176 else if (w && R)
4177 Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes");
4178 } else
4179 ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */
4180
4181 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX
4182 || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND )
4183 *s1++ = 'r';
4184 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4185 *s1++ = '+';
4186 if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4187 *s1++ = 'w';
4188 if (b)
4189 *s1++ = 'b';
4190 *s1 = 0;
4191 if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX )
4192 perltype = "+<&";
4193 else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND )
4194 perltype = ">&";
4195 else
4196 perltype = "<&";
4197
4198 if (items < 3)
4199 connect = -1; /* no wait */
4200 else if (SvTRUE(ST(2))) {
4201 s = SvPV(ST(2), len);
4202 if (len == 6 && strEQ(s, "nowait"))
4203 connect = -1; /* no wait */
4204 else if (len == 4 && strEQ(s, "wait"))
4205 connect = 1; /* wait */
4206 else
4207 Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s);
4208 }
4209
4210 if (items < 4)
4211 count = 1;
4212 else
4213 count = (int)SvIV(ST(3));
4214
4215 if (items < 5)
4216 ulInbufLength = 8192;
4217 else
4218 ulInbufLength = (ULONG)SvUV(ST(4));
4219
4220 if (items < 6)
4221 ulOutbufLength = ulInbufLength;
4222 else
4223 ulOutbufLength = (ULONG)SvUV(ST(5));
4224
4225 if (count < -1 || count == 0 || count >= 255)
4226 Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count);
4227 if (count < 0 )
4228 count = 255; /* Unlimited */
4229
4230 ulPipeMode = count;
4231 if (items < 7)
4232 ulPipeMode |= (NP_WAIT
4233 | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE)
4234 | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE));
4235 else
4236 ulPipeMode |= (ULONG)SvUV(ST(6));
4237
4238 if (items < 8)
4239 timeout = 0;
4240 else
4241 timeout = (double)SvNV(ST(7));
4242 ulTimeout = timeout * 1000;
4243 if (timeout < 0)
4244 ulTimeout = 0xFFFFFFFF; /* Indefinite */
4245 else if (timeout && !ulTimeout)
4246 ulTimeout = 1;
4247
4248 RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout);
4249 if (CheckOSError(RETVAL))
4250 croak_with_os2error("OS2::pipe(): DosCreateNPipe() error");
4251
4252 if (connect)
4253 connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */
4254 hpipe = __imphandle(hpipe);
4255
4256 perlio = PerlIO_fdopen(hpipe, buf);
4257 ST(0) = sv_newmortal();
4258 {
4259 GV *gv = newGVgen("OS2::pipe");
d5eb9a46 4260 if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) )
9d419b5f
IZ		 4261 sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1)));
4262 else
4263 ST(0) = &PL_sv_undef;
4264 }
4265 }
4266 XSRETURN(1);
4267}
4268
4269XS(XS_OS2_pipeCntl); /* prototype to pass -Wmissing-prototypes */
4270XS(XS_OS2_pipeCntl)
4271{
4272 dXSARGS;
4273 if (items < 2 || items > 3)
4274 Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])");
4275 {
4276 ULONG rc;
4277 PerlIO *perlio = IoIFP(sv_2io(ST(0)));
4278 IV fn = PerlIO_fileno(perlio);
4279 HPIPE hpipe = (HPIPE)fn;
4280 STRLEN len;
4281 char *s = SvPV(ST(1), len);
4282 int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0;
4283 int peek = 0, state = 0, info = 0;
4284
4285 if (fn < 0)
4286 Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe");
4287 if (items == 3)
4288 wait = (SvTRUE(ST(2)) ? 1 : -1);
4289
4290 switch (len) {
4291 case 4:
4292 if (strEQ(s, "byte"))
4293 message = 0;
4294 else if (strEQ(s, "peek"))
4295 peek = 1;
4296 else if (strEQ(s, "info"))
4297 info = 1;
4298 else
4299 goto unknown;
4300 break;
4301 case 5:
4302 if (strEQ(s, "reset"))
4303 disconnect = connect = 1;
4304 else if (strEQ(s, "state"))
4305 query = 1;
4306 else
4307 goto unknown;
4308 break;
4309 case 7:
4310 if (strEQ(s, "connect"))
4311 connect = 1;
4312 else if (strEQ(s, "message"))
4313 message = 1;
4314 else
4315 goto unknown;
4316 break;
4317 case 9:
4318 if (!strEQ(s, "readstate"))
4319 goto unknown;
4320 state = 1;
4321 break;
4322 case 10:
4323 if (!strEQ(s, "disconnect"))
4324 goto unknown;
4325 disconnect = 1;
4326 break;
4327 default:
4328 unknown:
4329 Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s);
4330 break;
4331 }
4332
4333 if (items == 3 && !connect)
4334 Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s);
4335
4336 XSprePUSH; /* Do not need arguments any more */
4337 if (disconnect) {
4338 os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()");
4339 PerlIO_clearerr(perlio);
4340 }
4341 if (connect) {
4342 if (!connectNPipe(hpipe, wait , 1, 0))
4343 XSRETURN_IV(-1);
4344 }
4345 if (query) {
4346 ULONG flags;
4347
4348 os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()");
4349 XSRETURN_UV(flags);
4350 }
4351 if (peek || state || info) {
4352 ULONG BytesRead, PipeState;
4353 AVAILDATA BytesAvail;
4354
4355 os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail,
4356 &PipeState), "DosPeekNPipe() for state");
4357 if (state) {
4358 EXTEND(SP, 3);
22f1178f 4359 mPUSHu(PipeState);
9d419b5f 4360 /* Bytes (available/in-message) */
22f1178f
VP		 4361 mPUSHi(BytesAvail.cbpipe);
4362 mPUSHi(BytesAvail.cbmessage);
9d419b5f
IZ		 4363 XSRETURN(3);
4364 } else if (info) {
4365 /* L S S C C C/Z*
4366 ID of the (remote) computer
4367 buffers (out/in)
4368 instances (max/actual)
4369 */
4370 struct pipe_info_t {
4371 ULONG id; /* char id[4]; */
4372 PIPEINFO pInfo;
4373 char buf[512];
4374 } b;
4375 int size;
4376
4377 os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)),
4378 "DosQueryNPipeInfo(1)");
4379 os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)),
4380 "DosQueryNPipeInfo(2)");
4381 size = b.pInfo.cbName;
4382 /* Trailing 0 is included in cbName - undocumented; so
4383 one should always extract with Z* */
4384 if (size) /* name length 254 or less */
4385 size--;
4386 else
4387 size = strlen(b.pInfo.szName);
4388 EXTEND(SP, 6);
22f1178f
VP		 4389 mPUSHp(b.pInfo.szName, size);
4390 mPUSHu(b.id);
4391 mPUSHi(b.pInfo.cbOut);
4392 mPUSHi(b.pInfo.cbIn);
4393 mPUSHi(b.pInfo.cbMaxInst);
4394 mPUSHi(b.pInfo.cbCurInst);
9d419b5f
IZ		 4395 XSRETURN(6);
4396 } else if (BytesAvail.cbpipe == 0) {
4397 XSRETURN_NO;
4398 } else {
4399 SV *tmp = NEWSV(914, BytesAvail.cbpipe);
4400 char *s = SvPVX(tmp);
4401
4402 sv_2mortal(tmp);
4403 os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead,
4404 &BytesAvail, &PipeState), "DosPeekNPipe()");
4405 SvCUR_set(tmp, BytesRead);
4406 *SvEND(tmp) = 0;
4407 SvPOK_on(tmp);
4408 XSprePUSH; PUSHs(tmp);
4409 XSRETURN(1);
4410 }
4411 }
4412 if (message > -1) {
4413 ULONG oflags, flags;
4414
4415 os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()");
4416 /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */
4417 oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE);
4418 flags = (oflags & NP_NOWAIT)
4419 | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE);
4420 if (flags != oflags)
4421 os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()");
4422 }
4423 }
4424 XSRETURN_YES;
4425}
4426
4427/*
4428NO_OUTPUT ULONG
4429DosOpen(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);
4430 PREINIT:
4431 ULONG rc;
4432 C_ARGS:
4433 pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf
4434 POSTCALL:
4435 if (CheckOSError(RETVAL))
4436 croak_with_os2error("OS2::open() error");
4437*/
4438XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */
4439XS(XS_OS2_open)
4440{
4441 dXSARGS;
4442 if (items < 2 || items > 6)
4443 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)");
4444 {
4445#line 39 "pipe.xs"
4446 ULONG rc;
4447#line 113 "pipe.c"
4448 ULONG RETVAL;
bfd025d9 4449 PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL );
9d419b5f
IZ		 4450 HFILE hFile;
4451 ULONG ulAction;
4452 ULONG ulOpenMode = (ULONG)SvUV(ST(1));
4453 ULONG ulOpenFlags;
4454 ULONG ulAttribute;
4455 ULONG ulFileSize;
4456 PEAOP2 pEABuf;
4457
4458 if (items < 3)
4459 ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW;
4460 else {
4461 ulOpenFlags = (ULONG)SvUV(ST(2));
4462 }
4463
4464 if (items < 4)
4465 ulAttribute = FILE_NORMAL;
4466 else {
4467 ulAttribute = (ULONG)SvUV(ST(3));
4468 }
4469
4470 if (items < 5)
4471 ulFileSize = 0;
4472 else {
4473 ulFileSize = (ULONG)SvUV(ST(4));
4474 }
4475
4476 if (items < 6)
4477 pEABuf = NULL;
4478 else {
4479 pEABuf = (PEAOP2)SvUV(ST(5));
4480 }
4481
4482 RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf);
4483 if (CheckOSError(RETVAL))
4484 croak_with_os2error("OS2::open() error");
4485 XSprePUSH; EXTEND(SP,2);
4486 PUSHs(sv_newmortal());
4487 sv_setuv(ST(0), (UV)hFile);
4488 PUSHs(sv_newmortal());
4489 sv_setuv(ST(1), (UV)ulAction);
4490 }
4491 XSRETURN(2);
4492}
4493
3bbf9c2b 4494int
23da6c43 4495Xs_OS2_init(pTHX)
3bbf9c2b
IZ		 4496{
4497 char *file = __FILE__;
4498 {
4499 GV *gv;
55497cff 4500
4501 if (_emx_env & 0x200) { /* OS/2 */
4502 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
4503 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
4504 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1933e12c
IZ		 4505 newXS("OS2::extLibpath", XS_Cwd_extLibpath, file);
4506 newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file);
55497cff 4507 }
4bfbfac5
IZ		 4508 newXS("OS2::Error", XS_OS2_Error, file);
4509 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
4510 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
622913ab
IZ		 4511 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
4512 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4bfbfac5
IZ		 4513 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
4514 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
4515 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
4516 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
4517 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b
IZ		 4518 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
4519 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
4520 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
4521 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
4522 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
4523 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
4524 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
4525 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
4526 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
d79a646b 4527 newXS("OS2::replaceModule", XS_OS2_replaceModule, file);
59ad941d 4528 newXS("OS2::perfSysCall", XS_OS2_perfSysCall, file);
5ba48348
JH		 4529 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
4530 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
4531 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
30500b05 4532 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
622913ab
IZ		 4533 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
4534 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
4535 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
4536 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
4537 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
1933e12c
IZ		 4538 newXSproto("OS2::msCounter", XS_OS2_msCounter, file, "");
4539 newXSproto("OS2::ms_sleep", XS_OS2_ms_sleep, file, "$;$");
4540 newXSproto("OS2::_InfoTable", XS_OS2__InfoTable, file, ";$");
622913ab
IZ		 4541 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
4542 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
4543 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
4544 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
9d419b5f
IZ		 4545 newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$");
4546 newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$");
4547 newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$");
3bbf9c2b
IZ		 4548 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
4549 GvMULTI_on(gv);
4550#ifdef PERL_IS_AOUT
4551 sv_setiv(GvSV(gv), 1);
764df951 4552#endif
59ad941d
IZ		 4553 gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV);
4554 GvMULTI_on(gv);
4555#ifdef PERL_IS_AOUT
4556 sv_setiv(GvSV(gv), 1);
4557#endif
764df951
IZ		 4558 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
4559 GvMULTI_on(gv);
4560 sv_setiv(GvSV(gv), exe_is_aout());
4bfbfac5
IZ		 4561 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
4562 GvMULTI_on(gv);
4563 sv_setiv(GvSV(gv), _emx_rev);
4564 sv_setpv(GvSV(gv), _emx_vprt);
4565 SvIOK_on(GvSV(gv));
4566 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
4567 GvMULTI_on(gv);
4568 sv_setiv(GvSV(gv), _emx_env);
4569 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
4570 GvMULTI_on(gv);
4571 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87
IZ		 4572 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
4573 GvMULTI_on(gv);
4574 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 4575 }
2d766320 4576 return 0;
3bbf9c2b
IZ		 4577}
4578
764df951
IZ		 4579extern void _emx_init(void*);
4580
4581static void jmp_out_of_atexit(void);
4582
4583#define FORCE_EMX_INIT_CONTRACT_ARGV 1
4584#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
4585
4586static void
4587my_emx_init(void *layout) {
622913ab 4588 static volatile void *old_esp = 0; /* Cannot be on stack! */
764df951
IZ		 4589
4590 /* Can't just call emx_init(), since it moves the stack pointer */
4591 /* It also busts a lot of registers, so be extra careful */
4592 __asm__( "pushf\n"
4593 "pusha\n"
4594 "movl %%esp, %1\n"
4595 "push %0\n"
4596 "call __emx_init\n"
4597 "movl %1, %%esp\n"
4598 "popa\n"
622913ab 4599 "popf\n" : : "r" (layout), "m" (old_esp) );
764df951
IZ		 4600}
4601
4602struct layout_table_t {
4603 ULONG text_base;
4604 ULONG text_end;
4605 ULONG data_base;
4606 ULONG data_end;
4607 ULONG bss_base;
4608 ULONG bss_end;
4609 ULONG heap_base;
4610 ULONG heap_end;
4611 ULONG heap_brk;
4612 ULONG heap_off;
4613 ULONG os2_dll;
4614 ULONG stack_base;
4615 ULONG stack_end;
4616 ULONG flags;
4617 ULONG reserved[2];
4618 char options[64];
4619};
4620
4621static ULONG
4622my_os_version() {
622913ab 4623 static ULONG osv_res; /* Cannot be on stack! */
764df951 4624
c4e0013e
IZ		 4625 /* Can't just call __os_version(), since it does not follow C
4626 calling convention: it busts a lot of registers, so be extra careful */
764df951
IZ		 4627 __asm__( "pushf\n"
4628 "pusha\n"
4629 "call ___os_version\n"
4630 "movl %%eax, %0\n"
4631 "popa\n"
622913ab 4632 "popf\n" : "=m" (osv_res) );
764df951 4633
622913ab 4634 return osv_res;
764df951
IZ		 4635}
4636
4637static void
4638force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
4639{
4640 /* Calling emx_init() will bust the top of stack: it installs an
4641 exception handler and puts argv data there. */
4642 char *oldarg, *oldenv;
4643 void *oldstackend, *oldstack;
4644 PPIB pib;
4645 PTIB tib;
764df951
IZ		 4646 ULONG rc, error = 0, out;
4647 char buf[512];
4648 static struct layout_table_t layout_table;
4649 struct {
4650 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
4651 double alignment1;
4652 EXCEPTIONREGISTRATIONRECORD xreg;
4653 } *newstack;
4654 char *s;
4655
622913ab 4656 layout_table.os2_dll = (ULONG)&os2_dll_fake;
764df951
IZ		 4657 layout_table.flags = 0x02000002; /* flags: application, OMF */
4658
4659 DosGetInfoBlocks(&tib, &pib);
4660 oldarg = pib->pib_pchcmd;
4661 oldenv = pib->pib_pchenv;
4662 oldstack = tib->tib_pstack;
4663 oldstackend = tib->tib_pstacklimit;
4664
1933e12c
IZ		 4665 if ( (char*)&s < (char*)oldstack + 4*1024
4666 || (char *)oldstackend < (char*)oldstack + 52*1024 )
4667 early_error("It is a lunacy to try to run EMX Perl ",
4668 "with less than 64K of stack;\r\n",
4669 " at least with non-EMX starter...\r\n");
4670
764df951
IZ		 4671 /* Minimize the damage to the stack via reducing the size of argv. */
4672 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
4673 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
4674 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
4675 }
4676
4677 newstack = alloca(sizeof(*newstack));
4678 /* Emulate the stack probe */
4679 s = ((char*)newstack) + sizeof(*newstack);
4680 while (s > (char*)newstack) {
4681 s[-1] = 0;
4682 s -= 4096;
4683 }
4684
4685 /* Reassigning stack is documented to work */
4686 tib->tib_pstack = (void*)newstack;
4687 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
4688
4689 /* Can't just call emx_init(), since it moves the stack pointer */
4690 my_emx_init((void*)&layout_table);
4691
4692 /* Remove the exception handler, cannot use it - too low on the stack.
4693 Check whether it is inside the new stack. */
4694 buf[0] = 0;
4695 if (tib->tib_pexchain >= tib->tib_pstacklimit
4696 || tib->tib_pexchain < tib->tib_pstack) {
4697 error = 1;
4698 sprintf(buf,
4699 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
4700 (unsigned long)tib->tib_pstack,
4701 (unsigned long)tib->tib_pexchain,
4702 (unsigned long)tib->tib_pstacklimit);
4703 goto finish;
4704 }
4705 if (tib->tib_pexchain != &(newstack->xreg)) {
4706 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
4707 (unsigned long)tib->tib_pexchain,
4708 (unsigned long)&(newstack->xreg));
4709 }
4710 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
4711 if (rc)
4712 sprintf(buf + strlen(buf),
4713 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4714
4715 if (preg) {
4716 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
4717 preg->prev_structure = 0;
4718 preg->ExceptionHandler = _emx_exception;
4719 rc = DosSetExceptionHandler(preg);
4720 if (rc) {
4721 sprintf(buf + strlen(buf),
4722 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
4723 DosWrite(2, buf, strlen(buf), &out);
4724 emx_exception_init = 1; /* Do it around spawn*() calls */
4725 }
4726 } else
4727 emx_exception_init = 1; /* Do it around spawn*() calls */
4728
4729 finish:
4730 /* Restore the damage */
4731 pib->pib_pchcmd = oldarg;
4732 pib->pib_pchcmd = oldenv;
4733 tib->tib_pstacklimit = oldstackend;
4734 tib->tib_pstack = oldstack;
4735 emx_runtime_init = 1;
4736 if (buf[0])
4737 DosWrite(2, buf, strlen(buf), &out);
4738 if (error)
4739 exit(56);
4740}
4741
764df951
IZ		 4742static void
4743jmp_out_of_atexit(void)
4744{
4745 if (longjmp_at_exit)
4746 longjmp(at_exit_buf, 1);
4747}
4748
4749extern void _CRT_term(void);
4750
764df951
IZ		 4751void
4752Perl_OS2_term(void **p, int exitstatus, int flags)
4753{
4754 if (!emx_runtime_secondary)
4755 return;
4756
4757 /* The principal executable is not running the same CRTL, so there
4758 is nobody to shutdown *this* CRTL except us... */
4759 if (flags & FORCE_EMX_DEINIT_EXIT) {
4760 if (p && !emx_exception_init)
4761 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4762 /* Do not run the executable's CRTL's termination routines */
4763 exit(exitstatus); /* Run at-exit, flush buffers, etc */
4764 }
4765 /* Run at-exit list, and jump out at the end */
4766 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
4767 longjmp_at_exit = 1;
4768 exit(exitstatus); /* The first pass through "if" */
4769 }
4770
4771 /* Get here if we managed to jump out of exit(), or did not run atexit. */
4772 longjmp_at_exit = 0; /* Maybe exit() is called again? */
4773#if 0 /* _atexit_n is not exported */
4774 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
4775 _atexit_n = 0; /* Remove the atexit() handlers */
4776#endif
4777 /* Will segfault on program termination if we leave this dangling... */
4778 if (p && !emx_exception_init)
4779 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
4780 /* Typically there is no need to do this, done from _DLL_InitTerm() */
4781 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
4782 _CRT_term(); /* Flush buffers, etc. */
4783 /* Now it is a good time to call exit() in the caller's CRTL... */
4784}
4785
4786#include <emx/startup.h>
4787
4788extern ULONG __os_version(); /* See system.doc */
4789
764df951
IZ		 4790void
4791check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
4792{
1933e12c 4793 ULONG v_crt, v_emx, count = 0, rc = NO_ERROR, rc1, maybe_inited = 0;
622913ab
IZ		 4794 static HMTX hmtx_emx_init = NULLHANDLE;
4795 static int emx_init_done = 0;
764df951
IZ		 4796
4797 /* If _environ is not set, this code sits in a DLL which
4798 uses a CRT DLL which not compatible with the executable's
4799 CRT library. Some parts of the DLL are not initialized.
4800 */
4801 if (_environ != NULL)
4802 return; /* Properly initialized */
4803
622913ab
IZ		 4804 /* It is not DOS, so we may use OS/2 API now */
4805 /* Some data we manipulate is static; protect ourselves from
4806 calling the same API from a different thread. */
4807 DosEnterMustComplete(&count);
4808
4809 rc1 = DosEnterCritSec();
4810 if (!hmtx_emx_init)
4811 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
4812 else
4813 maybe_inited = 1;
4814
4815 if (rc != NO_ERROR)
4816 hmtx_emx_init = NULLHANDLE;
4817
4818 if (rc1 == NO_ERROR)
4819 DosExitCritSec();
4820 DosExitMustComplete(&count);
4821
4822 while (maybe_inited) { /* Other thread did or is doing the same now */
4823 if (emx_init_done)
4824 return;
4825 rc = DosRequestMutexSem(hmtx_emx_init,
4826 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
4827 if (rc == ERROR_INTERRUPT)
4828 continue;
4829 if (rc != NO_ERROR) {
4830 char buf[80];
4831 ULONG out;
4832
4833 sprintf(buf,
4834 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
4835 DosWrite(2, buf, strlen(buf), &out);
4836 return;
4837 }
4838 DosReleaseMutexSem(hmtx_emx_init);
4839 return;
4840 }
4841
764df951
IZ		 4842 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
4843 initialized either. Uninitialized EMX.DLL returns 0 in the low
4844 nibble of __os_version(). */
4845 v_emx = my_os_version();
4846
4847 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
4848 (=>_CRT_init=>_entry2) via a call to __os_version(), then
4849 reset when the EXE initialization code calls _text=>_init=>_entry2.
4850 The first time they are wrongly set to 0; the second time the
4851 EXE initialization code had already called emx_init=>initialize1
4852 which correctly set version_major, version_minor used by
4853 __os_version(). */
4854 v_crt = (_osmajor | _osminor);
4855
4856 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
4857 force_init_emx_runtime( preg,
4858 FORCE_EMX_INIT_CONTRACT_ARGV
4859 | FORCE_EMX_INIT_INSTALL_ATEXIT );
4860 emx_wasnt_initialized = 1;
4861 /* Update CRTL data basing on now-valid EMX runtime data */
4862 if (!v_crt) { /* The only wrong data are the versions. */
4863 v_emx = my_os_version(); /* *Now* it works */
4864 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
4865 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
4866 }
4867 }
4868 emx_runtime_secondary = 1;
4869 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
4870 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
4871
9e2a34c1 4872 if (env == NULL) { /* Fetch from the process info block */
764df951
IZ		 4873 int c = 0;
4874 PPIB pib;
4875 PTIB tib;
4876 char *e, **ep;
4877
4878 DosGetInfoBlocks(&tib, &pib);
4879 e = pib->pib_pchenv;
4880 while (*e) { /* Get count */
4881 c++;
4882 e = e + strlen(e) + 1;
4883 }
a02a5408 4884 Newx(env, c + 1, char*);
764df951
IZ		 4885 ep = env;
4886 e = pib->pib_pchenv;
4887 while (c--) {
4888 *ep++ = e;
4889 e = e + strlen(e) + 1;
4890 }
4891 *ep = NULL;
4892 }
4893 _environ = _org_environ = env;
622913ab
IZ		 4894 emx_init_done = 1;
4895 if (hmtx_emx_init)
4896 DosReleaseMutexSem(hmtx_emx_init);
764df951
IZ		 4897}
4898
4899#define ENTRY_POINT 0x10000
4900
4901static int
4902exe_is_aout(void)
4903{
4904 struct layout_table_t *layout;
4905 if (emx_wasnt_initialized)
4906 return 0;
4907 /* Now we know that the principal executable is an EMX application
4908 - unless somebody did already play with delayed initialization... */
4909 /* With EMX applications to determine whether it is AOUT one needs
4910 to examine the start of the executable to find "layout" */
4911 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
4912 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
4913 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
4914 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
4915 return 0; /* ! EMX executable */
4916 /* Fix alignment */
4917 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
4918 return !(layout->flags & 2);
4919}
4920
3bbf9c2b 4921void
aa689395 4922Perl_OS2_init(char **env)
3bbf9c2b 4923{
764df951
IZ		 4924 Perl_OS2_init3(env, 0, 0);
4925}
4926
4927void
4928Perl_OS2_init3(char **env, void **preg, int flags)
4929{
1933e12c
IZ		 4930 char *shell, *s;
4931 ULONG rc;
3bbf9c2b 4932
764df951 4933 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
18f739ee 4934 MALLOC_INIT;
764df951
IZ		 4935
4936 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
4937
3bbf9c2b
IZ		 4938 settmppath();
4939 OS2_Perl_data.xs_init = &Xs_OS2_init;
1933e12c
IZ		 4940 if (perl_sh_installed) {
4941 int l = strlen(perl_sh_installed);
4942
a02a5408 4943 Newx(PL_sh_path, l + 1, char);
1933e12c
IZ		 4944 memcpy(PL_sh_path, perl_sh_installed, l + 1);
4945 } else if ( (shell = getenv("PERL_SH_DRIVE")) ) {
a02a5408 4946 Newx(PL_sh_path, strlen(SH_PATH) + 1, char);
6b88bc9c
GS		 4947 strcpy(PL_sh_path, SH_PATH);
4948 PL_sh_path[0] = shell[0];
3bbf9c2b 4949 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 4950 int l = strlen(shell), i;
1933e12c
IZ		 4951
4952 while (l && (shell[l-1] == '/' || shell[l-1] == '\\'))
3bbf9c2b 4953 l--;
a02a5408 4954 Newx(PL_sh_path, l + 8, char);
6b88bc9c
GS		 4955 strncpy(PL_sh_path, shell, l);
4956 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 4957 for (i = 0; i < l; i++) {
6b88bc9c 4958 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 4959 }
3bbf9c2b 4960 }
5c728af0 4961#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
dd96f567 4962 MUTEX_INIT(&start_thread_mutex);
622913ab 4963 MUTEX_INIT(&perlos2_state_mutex);
5c728af0 4964#endif
017f25f1 4965 os2_mytype = my_type(); /* Do it before morphing. Needed? */
622913ab
IZ		 4966 os2_mytype_ini = os2_mytype;
4967 Perl_os2_initial_mode = -1; /* Uninit */
1933e12c
IZ		 4968
4969 s = getenv("PERL_BEGINLIBPATH");
4970 if (s)
4971 rc = fill_extLibpath(0, s, NULL, 1, "PERL_BEGINLIBPATH");
4972 else
4973 rc = fill_extLibpath(0, getenv("PERL_PRE_BEGINLIBPATH"), getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH");
4974 if (!rc) {
4975 s = getenv("PERL_ENDLIBPATH");
4976 if (s)
4977 rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH");
4978 else
4979 rc = fill_extLibpath(1, getenv("PERL_PRE_ENDLIBPATH"), getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH");
4980 }
4981 if (rc) {
4982 char buf[1024];
4983
4984 snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n",
4985 os2error(rc));
4986 DosWrite(2, buf, strlen(buf), &rc);
4987 exit(2);
4988 }
4989
4990 _emxload_env("PERL_EMXLOAD_SECS");
5ba48348
JH		 4991 /* Some DLLs reset FP flags on load. We may have been linked with them */
4992 _control87(MCW_EM, MCW_EM);
3bbf9c2b
IZ		 4993}
4994
59ad941d
IZ		 4995int
4996fd_ok(int fd)
4997{
4998 static ULONG max_fh = 0;
4999
5000 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
5001 if (fd >= max_fh) { /* Renew */
5002 LONG delta = 0;
5003
5004 if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */
5005 return 1;
5006 }
5007 return fd < max_fh;
5008}
5009
5010/* Kernels up to Oct 2003 trap on (invalid) dup(max_fh); [off-by-one + double fault]. */
5011int
5012dup2(int from, int to)
5013{
5014 if (fd_ok(from < to ? to : from))
5015 return _dup2(from, to);
5016 errno = EBADF;
5017 return -1;
5018}
5019
5020int
5021dup(int from)
5022{
5023 if (fd_ok(from))
5024 return _dup(from);
5025 errno = EBADF;
5026 return -1;
5027}
5028
55497cff 5029#undef tmpnam
5030#undef tmpfile
5031
5032char *
5033my_tmpnam (char *str)
5034{
5035 char *p = getenv("TMP"), *tpath;
55497cff 5036
5037 if (!p) p = getenv("TEMP");
5038 tpath = tempnam(p, "pltmp");
5039 if (str && tpath) {
5040 strcpy(str, tpath);
5041 return str;
5042 }
5043 return tpath;
5044}
5045
5046FILE *
5047my_tmpfile ()
5048{
5049 struct stat s;
5050
5051 stat(".", &s);
5052 if (s.st_mode & S_IWOTH) {
5053 return tmpfile();
5054 }
5055 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
5056 grants TMP. */
5057}
367f3c24 5058
5ba48348
JH		 5059#undef rmdir
5060
cd4e750a
IZ		 5061/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
5062 trailing slashes, so we need to support this as well. */
5063
5ba48348
JH		 5064int
5065my_rmdir (__const__ char *s)
5066{
cd4e750a
IZ		 5067 char b[MAXPATHLEN];
5068 char *buf = b;
5ba48348 5069 STRLEN l = strlen(s);
cd4e750a 5070 int rc;
5ba48348 5071
cd4e750a
IZ		 5072 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
5073 if (l >= sizeof b)
a02a5408 5074 Newx(buf, l + 1, char);
5ba48348 5075 strcpy(buf,s);
cd4e750a
IZ		 5076 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5077 l--;
5078 buf[l] = 0;
5ba48348
JH		 5079 s = buf;
5080 }
cd4e750a
IZ		 5081 rc = rmdir(s);
5082 if (b != buf)
5083 Safefree(buf);
5084 return rc;
5ba48348
JH		 5085}
5086
5087#undef mkdir
5088
5089int
5090my_mkdir (__const__ char *s, long perm)
5091{
cd4e750a
IZ		 5092 char b[MAXPATHLEN];
5093 char *buf = b;
5ba48348 5094 STRLEN l = strlen(s);
cd4e750a 5095 int rc;
5ba48348
JH		 5096
5097 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
cd4e750a 5098 if (l >= sizeof b)
a02a5408 5099 Newx(buf, l + 1, char);
5ba48348 5100 strcpy(buf,s);
cd4e750a
IZ		 5101 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
5102 l--;
5103 buf[l] = 0;
5ba48348
JH		 5104 s = buf;
5105 }
cd4e750a
IZ		 5106 rc = mkdir(s, perm);
5107 if (b != buf)
5108 Safefree(buf);
5109 return rc;
5ba48348
JH		 5110}
5111
367f3c24
IZ		 5112#undef flock
5113
5114/* This code was contributed by Rocco Caputo. */
5115int
dd96f567 5116my_flock(int handle, int o)
367f3c24
IZ		 5117{
5118 FILELOCK rNull, rFull;
5119 ULONG timeout, handle_type, flag_word;
5120 APIRET rc;
5121 int blocking, shared;
622913ab 5122 static int use_my_flock = -1;
367f3c24 5123
622913ab
IZ		 5124 if (use_my_flock == -1) {
5125 MUTEX_LOCK(&perlos2_state_mutex);
5126 if (use_my_flock == -1) {
367f3c24
IZ		 5127 char *s = getenv("USE_PERL_FLOCK");
5128 if (s)
622913ab 5129 use_my_flock = atoi(s);
367f3c24 5130 else
622913ab
IZ		 5131 use_my_flock = 1;
5132 }
5133 MUTEX_UNLOCK(&perlos2_state_mutex);
367f3c24 5134 }
622913ab 5135 if (!(_emx_env & 0x200) || !use_my_flock)
dd96f567 5136 return flock(handle, o); /* Delegate to EMX. */
367f3c24 5137
cb69f87a 5138 /* is this a file? */
367f3c24
IZ		 5139 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
5140 (handle_type & 0xFF))
5141 {
5142 errno = EBADF;
5143 return -1;
5144 }
cb69f87a 5145 /* set lock/unlock ranges */
367f3c24
IZ		 5146 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
5147 rFull.lRange = 0x7FFFFFFF;
cb69f87a 5148 /* set timeout for blocking */
dd96f567 5149 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
cb69f87a 5150 /* shared or exclusive? */
dd96f567 5151 shared = (o & LOCK_SH) ? 1 : 0;
cb69f87a 5152 /* do not block the unlock */
dd96f567 5153 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24
IZ		 5154 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
5155 switch (rc) {
5156 case 0:
5157 errno = 0;
5158 return 0;
5159 case ERROR_INVALID_HANDLE:
5160 errno = EBADF;
5161 return -1;
5162 case ERROR_SHARING_BUFFER_EXCEEDED:
5163 errno = ENOLCK;
5164 return -1;
5165 case ERROR_LOCK_VIOLATION:
cb69f87a 5166 break; /* not an error */
367f3c24
IZ		 5167 case ERROR_INVALID_PARAMETER:
5168 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5169 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5170 errno = EINVAL;
5171 return -1;
5172 case ERROR_INTERRUPT:
5173 errno = EINTR;
5174 return -1;
5175 default:
5176 errno = EINVAL;
5177 return -1;
5178 }
5179 }
cb69f87a 5180 /* lock may block */
dd96f567 5181 if (o & (LOCK_SH | LOCK_EX)) {
cb69f87a 5182 /* for blocking operations */
367f3c24
IZ		 5183 for (;;) {
5184 rc =
5185 DosSetFileLocks(
5186 handle,
5187 &rNull,
5188 &rFull,
5189 timeout,
5190 shared
5191 );
5192 switch (rc) {
5193 case 0:
5194 errno = 0;
5195 return 0;
5196 case ERROR_INVALID_HANDLE:
5197 errno = EBADF;
5198 return -1;
5199 case ERROR_SHARING_BUFFER_EXCEEDED:
5200 errno = ENOLCK;
5201 return -1;
5202 case ERROR_LOCK_VIOLATION:
5203 if (!blocking) {
5204 errno = EWOULDBLOCK;
5205 return -1;
5206 }
5207 break;
5208 case ERROR_INVALID_PARAMETER:
5209 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
5210 case ERROR_READ_LOCKS_NOT_SUPPORTED:
5211 errno = EINVAL;
5212 return -1;
5213 case ERROR_INTERRUPT:
5214 errno = EINTR;
5215 return -1;
5216 default:
5217 errno = EINVAL;
5218 return -1;
5219 }
cb69f87a 5220 /* give away timeslice */
367f3c24
IZ		 5221 DosSleep(1);
5222 }
5223 }
5224
5225 errno = 0;
5226 return 0;
5227}
f72c975a 5228
f72c975a
IZ		 5229static int
5230use_my_pwent(void)
5231{
5232 if (_my_pwent == -1) {
5233 char *s = getenv("USE_PERL_PWENT");
5234 if (s)
5235 _my_pwent = atoi(s);
5236 else
5237 _my_pwent = 1;
5238 }
5239 return _my_pwent;
5240}
5241
5242#undef setpwent
5243#undef getpwent
5244#undef endpwent
5245
5246void
5247my_setpwent(void)
5248{
5249 if (!use_my_pwent()) {
5250 setpwent(); /* Delegate to EMX. */
5251 return;
5252 }
5253 pwent_cnt = 0;
5254}
5255
5256void
5257my_endpwent(void)
5258{
5259 if (!use_my_pwent()) {
5260 endpwent(); /* Delegate to EMX. */
5261 return;
5262 }
5263}
5264
5265struct passwd *
5266my_getpwent (void)
5267{
5268 if (!use_my_pwent())
5269 return getpwent(); /* Delegate to EMX. */
5270 if (pwent_cnt++)
cb69f87a 5271 return 0; /* Return one entry only */
f72c975a
IZ		 5272 return getpwuid(0);
5273}
5274
f72c975a
IZ		 5275void
5276setgrent(void)
5277{
5278 grent_cnt = 0;
5279}
5280
5281void
5282endgrent(void)
5283{
5284}
5285
5286struct group *
5287getgrent (void)
5288{
5289 if (grent_cnt++)
cb69f87a 5290 return 0; /* Return one entry only */
f72c975a
IZ		 5291 return getgrgid(0);
5292}
5293
5294#undef getpwuid
5295#undef getpwnam
5296
5297/* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
5298static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
5299
5300static struct passwd *
5301passw_wrap(struct passwd *p)
5302{
f72c975a
IZ		 5303 char *s;
5304
5305 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
5306 return p;
5307 pw = *p;
5308 s = getenv("PW_PASSWD");
5309 if (!s)
5310 s = (char*)pw_p; /* Make match impossible */
5311
5312 pw.pw_passwd = s;
5313 return &pw;
5314}
5315
5316struct passwd *
5317my_getpwuid (uid_t id)
5318{
5319 return passw_wrap(getpwuid(id));
5320}
5321
5322struct passwd *
5323my_getpwnam (__const__ char *n)
5324{
5325 return passw_wrap(getpwnam(n));
5326}
a64c954a
IZ		 5327
5328char *
5329gcvt_os2 (double value, int digits, char *buffer)
5330{
622913ab
IZ		 5331 double absv = value > 0 ? value : -value;
5332 /* EMX implementation is lousy between 0.1 and 0.0001 (uses exponents below
5333 0.1), 1-digit stuff is ok below 0.001; multi-digit below 0.0001. */
5334 int buggy;
5335
5336 absv *= 10000;
5337 buggy = (absv < 1000 && (absv >= 10 || (absv > 1 && floor(absv) != absv)));
5338
5339 if (buggy) {
5340 char pat[12];
5341
5342 sprintf(pat, "%%.%dg", digits);
5343 sprintf(buffer, pat, value);
5344 return buffer;
5345 }
a64c954a
IZ		 5346 return gcvt (value, digits, buffer);
5347}
5c728af0
IZ		 5348
5349#undef fork
5350int fork_with_resources()
5351{
5352#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5353 dTHX;
5354 void *ctx = PERL_GET_CONTEXT;
5355#endif
622913ab 5356 unsigned fpflag = _control87(0,0);
5c728af0
IZ		 5357 int rc = fork();
5358
5c728af0 5359 if (rc == 0) { /* child */
622913ab 5360#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(USE_SLOW_THREAD_SPECIFIC)
5c728af0
IZ		 5361 ALLOC_THREAD_KEY; /* Acquire the thread-local memory */
5362 PERL_SET_CONTEXT(ctx); /* Reinit the thread-local memory */
5c728af0 5363#endif
622913ab
IZ		 5364
5365 { /* Reload loaded-on-demand DLLs */
5366 struct dll_handle_t *dlls = dll_handles;
5367
5368 while (dlls->modname) {
5369 char dllname[260], fail[260];
5370 ULONG rc;
5371
5372 if (!dlls->handle) { /* Was not loaded */
5373 dlls++;
5374 continue;
5375 }
5376 /* It was loaded in the parent. We need to reload it. */
5377
5378 rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname);
5379 if (rc) {
5380 Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx",
5381 dlls->modname, (int)dlls->handle, rc, rc);
5382 dlls++;
5383 continue;
5384 }
5385 rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle);
5386 if (rc)
5387 Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'",
5388 dllname, fail);
5389 dlls++;
5390 }
5391 }
5392
5393 { /* Support message queue etc. */
5394 os2_mytype = my_type();
5395 /* Apparently, subprocesses (in particular, fork()) do not
5396 inherit the morphed state, so os2_mytype is the same as
5397 os2_mytype_ini. */
5398
5399 if (Perl_os2_initial_mode != -1
5400 && Perl_os2_initial_mode != os2_mytype) {
5401 /* XXXX ??? */
5402 }
5403 }
5404 if (Perl_HAB_set)
5405 (void)_obtain_Perl_HAB;
5406 if (Perl_hmq_refcnt) {
5407 if (my_type() != 3)
5408 my_type_set(3);
5409 Create_HMQ(Perl_hmq_servers != 0,
5410 "Cannot create a message queue on fork");
5411 }
5412
5413 /* We may have loaded some modules */
5414 _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */
5415 }
5c728af0
IZ		 5416 return rc;
5417}
622913ab 5418
1933e12c
IZ		 5419/* APIRET APIENTRY DosGetInfoSeg(PSEL pselGlobal, PSEL pselLocal); */
5420
5421ULONG _THUNK_FUNCTION(Dos16GetInfoSeg)(USHORT *pGlobal, USHORT *pLocal);
5422
5423APIRET APIENTRY
5424myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal)
5425{
5426 APIRET rc;
5427 USHORT gSel, lSel; /* Will not cross 64K boundary */
5428
5429 rc = ((USHORT)
5430 (_THUNK_PROLOG (4+4);
5431 _THUNK_FLAT (&gSel);
5432 _THUNK_FLAT (&lSel);
5433 _THUNK_CALL (Dos16GetInfoSeg)));
5434 if (rc)
5435 return rc;
5436 *pGlobal = MAKEPGINFOSEG(gSel);
5437 *pLocal = MAKEPLINFOSEG(lSel);
5438 return rc;
5439}
5440
5441static void
5442GetInfoTables(void)
5443{
5444 ULONG rc = 0;
5445
5446 MUTEX_LOCK(&perlos2_state_mutex);
5447 if (!gTable)
5448 rc = myDosGetInfoSeg(&gTable, &lTable);
5449 MUTEX_UNLOCK(&perlos2_state_mutex);
5450 os2cp_croak(rc, "Dos16GetInfoSeg");
5451}
5452
5453ULONG
5454msCounter(void)
5455{ /* XXXX Is not lTable thread-specific? */
5456 if (!gTable)
5457 GetInfoTables();
5458 return gTable->SIS_MsCount;
5459}
5460
5461ULONG
5462InfoTable(int local)
5463{
5464 if (!gTable)
5465 GetInfoTables();
5466 return local ? (ULONG)lTable : (ULONG)gTable;
5467}
Unnamed repository; edit this file 'description' to name the repository.