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