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
Re: [PATCH 5.8.1 @20218] OS/2 API
[perl5.git] / os2 / os2.c
CommitLineData
4633a7c4
LW		 1#define INCL_DOS
2#define INCL_NOPM
7a2f0d5b 3#define INCL_DOSFILEMGR
760ac839
LW		 4#define INCL_DOSMEMMGR
5#define INCL_DOSERRORS
622913ab
IZ		 6#define INCL_WINERRORS
7#define INCL_WINSYS
ed344e4f
IZ		 8/* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
9#define INCL_DOSPROCESS
10#define SPU_DISABLESUPPRESSION 0
11#define SPU_ENABLESUPPRESSION 1
4633a7c4 12#include <os2.h>
5ba48348 13#include "dlfcn.h"
5c728af0 14#include <emx/syscalls.h>
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
622913ab
IZ		 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
5c728af0
IZ		 202#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
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,
213 pthreads_st_norun,
214 pthreads_st_exited_waited,
215};
622913ab 216const char * const pthreads_states[] = {
5c728af0
IZ		 217 "uninit",
218 "running",
219 "exited",
220 "detached",
221 "waited for",
222 "could not start",
223 "exited, then waited on",
224};
225
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)) {
622913ab
IZ		 232 snprintf(pthreads_state_buf, sizeof(pthreads_state_buf),
233 "unknown thread state %d", (int)state);
234 return pthreads_state_buf;
5c728af0
IZ		 235 }
236 return pthreads_states[state];
237}
238
239typedef struct {
240 void *status;
241 perl_cond cond;
242 enum pthreads_state state;
243} thread_join_t;
244
245thread_join_t *thread_join_data;
246int thread_join_count;
247perl_mutex start_thread_mutex;
622913ab
IZ		 248static perl_mutex perlos2_state_mutex;
249
5c728af0
IZ		 250
251int
252pthread_join(perl_os_thread tid, void **status)
253{
254 MUTEX_LOCK(&start_thread_mutex);
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 }
263 switch (thread_join_data[tid].state) {
264 case pthreads_st_exited:
265 thread_join_data[tid].state = pthreads_st_exited_waited;
266 *status = thread_join_data[tid].status;
267 MUTEX_UNLOCK(&start_thread_mutex);
268 COND_SIGNAL(&thread_join_data[tid].cond);
269 break;
270 case pthreads_st_waited:
271 MUTEX_UNLOCK(&start_thread_mutex);
272 Perl_croak_nocontext("join with a thread with a waiter");
273 break;
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 }
285 case pthreads_st_run:
286 {
287 perl_cond cond;
288
289 thread_join_data[tid].state = pthreads_st_waited;
290 thread_join_data[tid].status = (void *)status;
291 COND_INIT(&thread_join_data[tid].cond);
292 cond = thread_join_data[tid].cond;
293 COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex);
294 COND_DESTROY(&cond);
295 MUTEX_UNLOCK(&start_thread_mutex);
296 break;
297 }
298 default:
299 MUTEX_UNLOCK(&start_thread_mutex);
300 Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'",
301 pthreads_state_string(thread_join_data[tid].state));
302 break;
303 }
304 return 0;
305}
306
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 */
318void
319pthread_startit(void *arg1)
320{
321 /* Thread is already started, we need to transfer control only */
322 pthr_startit args = *(pthr_startit *)arg1;
323 int tid = pthread_self();
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);
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 }
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 }
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);
366 rc = (*args.sub)(args.arg);
367 MUTEX_LOCK(&start_thread_mutex);
368 switch (thread_join_data[tid].state) {
369 case pthreads_st_waited:
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;
373 break;
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. */
380 thread_join_data[tid].state = pthreads_st_exited;
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 */
386 break;
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));
392 }
393 MUTEX_UNLOCK(&start_thread_mutex);
394}
395
396int
397pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr,
398 void *(*start_routine)(void*), void *arg)
399{
400 dTHX;
401 pthr_startit args;
402
403 args.sub = (void*)start_routine;
404 args.arg = arg;
405 args.ctx = PERL_GET_CONTEXT;
406
407 MUTEX_LOCK(&start_thread_mutex);
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 */
418 MUTEX_UNLOCK(&start_thread_mutex);
419 return 0;
420}
421
422int
423pthread_detach(perl_os_thread tid)
424{
425 MUTEX_LOCK(&start_thread_mutex);
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 }
433 switch (thread_join_data[tid].state) {
434 case pthreads_st_waited:
435 MUTEX_UNLOCK(&start_thread_mutex);
436 Perl_croak_nocontext("detach on a thread with a waiter");
437 break;
438 case pthreads_st_run:
439 thread_join_data[tid].state = pthreads_st_detached;
440 MUTEX_UNLOCK(&start_thread_mutex);
441 break;
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 }
461 default:
462 MUTEX_UNLOCK(&start_thread_mutex);
463 Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'",
464 pthreads_state_string(thread_join_data[tid].state));
465 break;
466 }
467 return 0;
468}
469
470/* This is a very bastardized version; may be OK due to edge trigger of Wait */
471int
472os2_cond_wait(perl_cond *c, perl_mutex *m)
473{
474 int rc;
475 STRLEN n_a;
476 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
622913ab 477 Perl_rc = rc, croak_with_os2error("panic: COND_WAIT-reset");
5c728af0
IZ		 478 if (m) MUTEX_UNLOCK(m);
479 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
480 && (rc != ERROR_INTERRUPT))
622913ab 481 croak_with_os2error("panic: COND_WAIT");
5c728af0
IZ		 482 if (rc == ERROR_INTERRUPT)
483 errno = EINTR;
484 if (m) MUTEX_LOCK(m);
485 return 0;
486}
487#endif
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 {
622913ab 493 struct dll_handle_t *dll;
35bc1fdc
IZ		 494 const char *entryname;
495 int entrypoint;
622913ab 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 */
622913ab
IZ		 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
622913ab
IZ		 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{
622913ab
IZ		 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
622913ab
IZ		 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);
622913ab
IZ		 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 */
622913ab
IZ		 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;
622913ab
IZ		 964 char *real_name;
965 char const * args[4];
966 static const char * const fargs[4]
491527d0 967 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
622913ab 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;
622913ab
IZ		 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? */
622913ab
IZ		 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. */
622913ab 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];
622913ab 1013 int l = strlen(real_name);
017f25f1
IZ		 1014
1015 if (l + 5 <= sizeof tbuf) {
622913ab 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:
622913ab 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;
622913ab 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;
622913ab 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
622913ab 1080 rc = result(aTHX_ trueflag, spawnvp(flag,real_name,PL_Argv));
491527d0
GS		 1081#else
1082 if (execf == EXECF_TRUEEXEC)
622913ab 1083 rc = execvp(real_name,PL_Argv);
491527d0 1084 else if (execf == EXECF_EXEC)
622913ab 1085 rc = spawnvp(trueflag | P_OVERLAY,real_name,PL_Argv);
491527d0 1086 else if (execf == EXECF_SPAWN_NOWAIT)
622913ab 1087 rc = spawnvp(flag,real_name,PL_Argv);
764df951 1088 else if (execf == EXECF_SYNC)
622913ab 1089 rc = spawnvp(trueflag,real_name,PL_Argv);
4435c477 1090 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
23da6c43 1091 rc = result(aTHX_ trueflag,
622913ab 1092 spawnvp(flag,real_name,PL_Argv));
491527d0 1093#endif
622913ab 1094 if (rc < 0 && pass == 1) {
017f25f1 1095 do_script:
622913ab 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 */
622913ab 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:
622913ab
IZ		 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;
622913ab 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 }
622913ab
IZ		 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 }
622913ab
IZ		 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"),
622913ab
IZ		 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
622913ab 1451/* Array spawn/exec. */
4435c477 1452int
622913ab 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
622913ab
IZ		 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
622913ab
IZ		 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
622913ab
IZ		 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
5c728af0
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;
5c728af0
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;
622913ab 1712 MUTEX_LOCK(&perlos2_state_mutex);
4633a7c4 1713 st->st_ino = (ino-- & 0x7FFF);
622913ab 1714 MUTEX_UNLOCK(&perlos2_state_mutex);
4633a7c4
LW		 1715 st->st_nlink = 1;
1716 return 0;
1717}
1718
5c728af0
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
622913ab 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");
622913ab 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;
622913ab 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));
622913ab 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;
622913ab 1894 dXSTARG;
6f064249 1895
23da6c43 1896 RETVAL = mod2fname(aTHX_ sv);
622913ab
IZ		 1897 sv_setpv(TARG, RETVAL);
1898 XSprePUSH; PUSHTARG;
6f064249 1899 }
1900 XSRETURN(1);
1901}
1902
1903char *
1904os2error(int rc)
1905{
5c728af0 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) {
622913ab
IZ		 1915 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1916 s = os2error_buf + strlen(os2error_buf);
9fed8b87 1917 } else
622913ab
IZ		 1918 s = os2error_buf;
1919 if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf),
9fed8b87 1920 rc, "OSO001.MSG", &len)) {
622913ab
IZ		 1921 char *name = "";
1922
9fed8b87 1923 if (!number) {
622913ab
IZ		 1924 sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc);
1925 s = os2error_buf + strlen(os2error_buf);
9fed8b87 1926 }
622913ab
IZ		 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;
622913ab 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 }
622913ab 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;
5c728af0
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) {
622913ab
IZ		 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 }
622913ab
IZ		 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 }
622913ab
IZ		 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
622913ab
IZ		 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{
8c4b3a79 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);
622913ab
IZ		 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 }
8c4b3a79 2118 }
622913ab 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++;
622913ab
IZ		 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{
622913ab 2175 if (serve & REGISTERMQ_WILL_SERVE)
5ba48348 2176 Perl_hmq_servers--;
622913ab 2177
5ba48348 2178 if (--Perl_hmq_refcnt <= 0) {
622913ab
IZ		 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;
622913ab
IZ		 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. */
622913ab
IZ		 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",
622913ab
IZ		 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)))
622913ab 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)))
622913ab
IZ		 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
622913ab
IZ		 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",
622913ab
IZ		 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 {
622913ab
IZ		 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 */
622913ab 2658 int i = 0, j = 0, last = QSV_MAX_WARP3;
4bfbfac5 2659
622913ab
IZ		 2660 if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */
2661 last, /* info for Warp 3 */
4bfbfac5
IZ		 2662 (PVOID)si,
2663 sizeof(si))))
622913ab
IZ		 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 }
622913ab 2683 XSRETURN(2 * last);
4bfbfac5 2684 }
622913ab
IZ		 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;
622913ab 2727 dXSTARG;
4bfbfac5
IZ		 2728
2729 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
2730 (PVOID)si, sizeof(si))))
622913ab 2731 croak_with_os2error("DosQuerySysInfo() failed");
4bfbfac5 2732 c = 'a' - 1 + si[0];
622913ab
IZ		 2733 sv_setpvn(TARG, &c, 1);
2734 XSprePUSH; PUSHTARG;
4bfbfac5
IZ		 2735 }
2736 XSRETURN(1);
2737}
2738
622913ab
IZ		 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);
622913ab 2765 dXSTARG;
4bfbfac5 2766
622913ab 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);
622913ab 2793 dXSTARG;
4bfbfac5 2794
622913ab 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;
622913ab 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 }
622913ab 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;
622913ab 2835 dXSTARG;
3bbf9c2b
IZ		 2836
2837 RETVAL = current_drive();
622913ab
IZ		 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;
622913ab
IZ		 2937
2938 /* Can't use TARG, since tainting behaves differently */
3bbf9c2b
IZ		 2939 RETVAL = _getcwd2(p, MAXPATHLEN);
2940 ST(0) = sv_newmortal();
622913ab 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;
5723cfe4
IZ		 2952 if (items > 2)
2953 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)");
3bbf9c2b 2954 {
2d8e6c8d 2955 STRLEN n_a;
5723cfe4 2956 char * path = items ? (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 }
5723cfe4
IZ		 3076#ifndef INCOMPLETE_TAINTS
3077 if (!items)
3078 SvTAINTED_on(ST(0));
3079#endif
3bbf9c2b
IZ		 3080 }
3081 XSRETURN(1);
3082}
72ea3524
IZ		 3083typedef APIRET (*PELP)(PSZ path, ULONG type);
3084
5a9d0041
IZ		 3085/* Kernels after 2000/09/15 understand this too: */
3086#ifndef LIBPATHSTRICT
3087# define LIBPATHSTRICT 3
3088#endif
3089
72ea3524 3090APIRET
5a9d0041 3091ExtLIBPATH(ULONG ord, PSZ path, IV type)
72ea3524 3092{
5a9d0041 3093 ULONG what;
35bc1fdc 3094 PFN f = loadByOrdinal(ord, 1); /* Guarantied to load or die! */
5a9d0041 3095
5a9d0041
IZ		 3096 if (type > 0)
3097 what = END_LIBPATH;
3098 else if (type == 0)
3099 what = BEGIN_LIBPATH;
3100 else
3101 what = LIBPATHSTRICT;
35bc1fdc 3102 return (*(PELP)f)(path, what);
72ea3524 3103}
3bbf9c2b 3104
5a9d0041 3105#define extLibpath(to,type) \
35bc1fdc 3106 (CheckOSError(ExtLIBPATH(ORD_DosQueryExtLibpath, (to), (type))) ? NULL : (to) )
3bbf9c2b
IZ		 3107
3108#define extLibpath_set(p,type) \
35bc1fdc 3109 (!CheckOSError(ExtLIBPATH(ORD_DosSetExtLibpath, (p), (type))))
3bbf9c2b
IZ		 3110
3111XS(XS_Cwd_extLibpath)
3112{
3113 dXSARGS;
3114 if (items < 0 || items > 1)
23da6c43 3115 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
3bbf9c2b 3116 {
5a9d0041 3117 IV type;
3bbf9c2b
IZ		 3118 char to[1024];
3119 U32 rc;
3120 char * RETVAL;
622913ab 3121 dXSTARG;
3bbf9c2b
IZ		 3122
3123 if (items < 1)
3124 type = 0;
3125 else {
5a9d0041 3126 type = SvIV(ST(0));
3bbf9c2b
IZ		 3127 }
3128
5a9d0041
IZ		 3129 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
3130 RETVAL = extLibpath(to, type);
3131 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
3132 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
622913ab
IZ		 3133 sv_setpv(TARG, RETVAL);
3134 XSprePUSH; PUSHTARG;
3bbf9c2b
IZ		 3135 }
3136 XSRETURN(1);
3137}
3138
3139XS(XS_Cwd_extLibpath_set)
3140{
3141 dXSARGS;
3142 if (items < 1 || items > 2)
23da6c43 3143 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
3bbf9c2b 3144 {
2d8e6c8d
GS		 3145 STRLEN n_a;
3146 char * s = (char *)SvPV(ST(0),n_a);
5a9d0041 3147 IV type;
3bbf9c2b
IZ		 3148 U32 rc;
3149 bool RETVAL;
3150
3151 if (items < 2)
3152 type = 0;
3153 else {
5a9d0041 3154 type = SvIV(ST(1));
3bbf9c2b
IZ		 3155 }
3156
3157 RETVAL = extLibpath_set(s, type);
54310121 3158 ST(0) = boolSV(RETVAL);
3bbf9c2b
IZ		 3159 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
3160 }
3161 XSRETURN(1);
3162}
3163
30500b05
IZ		 3164/* Input: Address, BufLen
3165APIRET APIENTRY
3166DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3167 ULONG * Offset, ULONG Address);
3168*/
3169
3170DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
3171 (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
3172 ULONG * Offset, ULONG Address),
3173 (hmod, obj, BufLen, Buf, Offset, Address))
3174
622913ab
IZ		 3175enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full,
3176 mod_name_C_function = 0x100, mod_name_HMODULE = 0x200};
30500b05
IZ		 3177
3178static SV*
3179module_name_at(void *pp, enum module_name_how how)
3180{
5c728af0 3181 dTHX;
30500b05
IZ		 3182 char buf[MAXPATHLEN];
3183 char *p = buf;
3184 HMODULE mod;
622913ab
IZ		 3185 ULONG obj, offset, rc, addr = (ULONG)pp;
3186
3187 if (how & mod_name_HMODULE) {
3188 if ((how & ~mod_name_HMODULE) == mod_name_shortname)
3189 Perl_croak(aTHX_ "Can't get short module name from a handle");
3190 mod = (HMODULE)pp;
3191 how &= ~mod_name_HMODULE;
3192 } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr))
30500b05
IZ		 3193 return &PL_sv_undef;
3194 if (how == mod_name_handle)
3195 return newSVuv(mod);
3196 /* Full name... */
622913ab 3197 if ( how != mod_name_shortname
30500b05
IZ		 3198 && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
3199 return &PL_sv_undef;
3200 while (*p) {
3201 if (*p == '\\')
3202 *p = '/';
3203 p++;
3204 }
3205 return newSVpv(buf, 0);
3206}
3207
3208static SV*
3209module_name_of_cv(SV *cv, enum module_name_how how)
3210{
5c728af0
IZ		 3211 if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) {
3212 dTHX;
3213
622913ab
IZ		 3214 if (how & mod_name_C_function)
3215 return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function);
3216 else if (how & mod_name_HMODULE)
3217 return module_name_at((void*)SvIV(cv), how);
5c728af0
IZ		 3218 Perl_croak(aTHX_ "Not an XSUB reference");
3219 }
30500b05
IZ		 3220 return module_name_at(CvXSUB(SvRV(cv)), how);
3221}
3222
3223/* Find module name to which *this* subroutine is compiled */
3224#define module_name(how) module_name_at(&module_name_at, how)
3225
3226XS(XS_OS2_DLLname)
3227{
3228 dXSARGS;
3229 if (items > 2)
3230 Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
3231 {
3232 SV * RETVAL;
3233 int how;
3234
3235 if (items < 1)
3236 how = mod_name_full;
3237 else {
3238 how = (int)SvIV(ST(0));
3239 }
3240 if (items < 2)
3241 RETVAL = module_name(how);
3242 else
3243 RETVAL = module_name_of_cv(ST(1), how);
3244 ST(0) = RETVAL;
3245 sv_2mortal(ST(0));
3246 }
3247 XSRETURN(1);
3248}
3249
622913ab
IZ		 3250DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo,
3251 (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum),
3252 (r1, r2, buf, szbuf, fnum))
3253
3254XS(XS_OS2__headerInfo)
3255{
3256 dXSARGS;
3257 if (items > 4 || items < 2)
3258 Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])");
3259 {
3260 ULONG req = (ULONG)SvIV(ST(0));
3261 STRLEN size = (STRLEN)SvIV(ST(1)), n_a;
3262 ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0);
3263 ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0);
3264
3265 if (size <= 0)
3266 Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size);
3267 ST(0) = newSVpvn("",0);
3268 SvGROW(ST(0), size + 1);
3269 sv_2mortal(ST(0));
3270
3271 if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req))
3272 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3273 req, size, handle, offset, os2error(Perl_rc));
3274 SvCUR_set(ST(0), size);
3275 *SvEND(ST(0)) = 0;
3276 }
3277 XSRETURN(1);
3278}
3279
3280#define DQHI_QUERYLIBPATHSIZE 4
3281#define DQHI_QUERYLIBPATH 5
3282
3283XS(XS_OS2_libPath)
3284{
3285 dXSARGS;
3286 if (items != 0)
3287 Perl_croak(aTHX_ "Usage: OS2::libPath()");
3288 {
3289 ULONG size;
3290 STRLEN n_a;
3291
3292 if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size),
3293 DQHI_QUERYLIBPATHSIZE))
3294 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3295 DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0,
3296 os2error(Perl_rc));
3297 ST(0) = newSVpvn("",0);
3298 SvGROW(ST(0), size + 1);
3299 sv_2mortal(ST(0));
3300
3301 /* We should be careful: apparently, this entry point does not
3302 pay attention to the size argument, so may overwrite
3303 unrelated data! */
3304 if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size,
3305 DQHI_QUERYLIBPATH))
3306 Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s",
3307 DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc));
3308 SvCUR_set(ST(0), size);
3309 *SvEND(ST(0)) = 0;
3310 }
3311 XSRETURN(1);
3312}
3313
5ba48348
JH		 3314#define get_control87() _control87(0,0)
3315#define set_control87 _control87
3316
3317XS(XS_OS2__control87)
3318{
3319 dXSARGS;
3320 if (items != 2)
5c728af0 3321 Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)");
5ba48348
JH		 3322 {
3323 unsigned new = (unsigned)SvIV(ST(0));
3324 unsigned mask = (unsigned)SvIV(ST(1));
3325 unsigned RETVAL;
622913ab 3326 dXSTARG;
5ba48348
JH		 3327
3328 RETVAL = _control87(new, mask);
622913ab
IZ		 3329 XSprePUSH; PUSHi((IV)RETVAL);
3330 }
3331 XSRETURN(1);
3332}
3333
3334XS(XS_OS2_mytype)
3335{
3336 dXSARGS;
3337 int which = 0;
3338
3339 if (items < 0 || items > 1)
3340 Perl_croak(aTHX_ "Usage: OS2::mytype([which])");
3341 if (items == 1)
3342 which = (int)SvIV(ST(0));
3343 {
3344 unsigned RETVAL;
3345 dXSTARG;
3346
3347 switch (which) {
3348 case 0:
3349 RETVAL = os2_mytype; /* Reset after fork */
3350 break;
3351 case 1:
3352 RETVAL = os2_mytype_ini; /* Before any fork */
3353 break;
3354 case 2:
3355 RETVAL = Perl_os2_initial_mode; /* Before first morphing */
3356 break;
3357 case 3:
3358 RETVAL = my_type(); /* Morphed type */
3359 break;
3360 default:
3361 Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which);
3362 }
3363 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3364 }
3365 XSRETURN(1);
3366}
3367
622913ab
IZ		 3368
3369XS(XS_OS2_mytype_set)
3370{
3371 dXSARGS;
3372 int type;
3373
3374 if (items == 1)
3375 type = (int)SvIV(ST(0));
3376 else
3377 Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)");
3378 my_type_set(type);
3379 XSRETURN_EMPTY;
3380}
3381
3382
5ba48348
JH		 3383XS(XS_OS2_get_control87)
3384{
3385 dXSARGS;
3386 if (items != 0)
5c728af0 3387 Perl_croak(aTHX_ "Usage: OS2::get_control87()");
5ba48348
JH		 3388 {
3389 unsigned RETVAL;
622913ab 3390 dXSTARG;
5ba48348
JH		 3391
3392 RETVAL = get_control87();
622913ab 3393 XSprePUSH; PUSHi((IV)RETVAL);
5ba48348
JH		 3394 }
3395 XSRETURN(1);
3396}
3397
3398
3399XS(XS_OS2_set_control87)
3400{
3401 dXSARGS;
3402 if (items < 0 || items > 2)
5c728af0 3403 Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
5ba48348
JH		 3404 {
3405 unsigned new;
3406 unsigned mask;
3407 unsigned RETVAL;
622913ab 3408 dXSTARG;
5ba48348
JH		 3409
3410 if (items < 1)
3411 new = MCW_EM;
3412 else {
3413 new = (unsigned)SvIV(ST(0));
3414 }
3415
3416 if (items < 2)
3417 mask = MCW_EM;
3418 else {
3419 mask = (unsigned)SvIV(ST(1));
3420 }
3421
3422 RETVAL = set_control87(new, mask);
622913ab
IZ		 3423 XSprePUSH; PUSHi((IV)RETVAL);
3424 }
3425 XSRETURN(1);
3426}
3427
3428XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */
3429{
3430 dXSARGS;
3431 if (items < 0 || items > 1)
3432 Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)");
3433 {
3434 LONG delta;
3435 ULONG RETVAL, rc;
3436 dXSTARG;
3437
3438 if (items < 1)
3439 delta = 0;
3440 else
3441 delta = (LONG)SvIV(ST(0));
3442
3443 if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL)))
3444 croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error");
3445 XSprePUSH; PUSHu((UV)RETVAL);
5ba48348
JH		 3446 }
3447 XSRETURN(1);
3448}
3449
3bbf9c2b 3450int
23da6c43 3451Xs_OS2_init(pTHX)
3bbf9c2b
IZ		 3452{
3453 char *file = __FILE__;
3454 {
3455 GV *gv;
55497cff 3456
3457 if (_emx_env & 0x200) { /* OS/2 */
3458 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
3459 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
3460 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
3461 }
4bfbfac5
IZ		 3462 newXS("OS2::Error", XS_OS2_Error, file);
3463 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
3464 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
622913ab
IZ		 3465 newXSproto("OS2::DevCap", XS_OS2_DevCap, file, ";$$");
3466 newXSproto("OS2::SysInfoFor", XS_OS2_SysInfoFor, file, "$;$");
4bfbfac5
IZ		 3467 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
3468 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
3469 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
3470 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
3471 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
3bbf9c2b
IZ		 3472 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
3473 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
3474 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
3475 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
3476 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
3477 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
3478 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
3479 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
3480 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
5ba48348
JH		 3481 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
3482 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
3483 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
30500b05 3484 newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
622913ab
IZ		 3485 newXSproto("OS2::mytype", XS_OS2_mytype, file, ";$");
3486 newXSproto("OS2::mytype_set", XS_OS2_mytype_set, file, "$");
3487 newXSproto("OS2::_headerInfo", XS_OS2__headerInfo, file, "$$;$$");
3488 newXSproto("OS2::libPath", XS_OS2_libPath, file, "");
3489 newXSproto("OS2::Timer", XS_OS2_Timer, file, "");
3490 newXSproto("OS2::incrMaxFHandles", XS_OS2_incrMaxFHandles, file, ";$");
3491 newXSproto("OS2::SysValues", XS_OS2_SysValues, file, ";$$");
3492 newXSproto("OS2::SysValues_set", XS_OS2_SysValues_set, file, "$$;$");
3493 newXSproto("OS2::Beep", XS_OS2_Beep, file, ";$$");
3bbf9c2b
IZ		 3494 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
3495 GvMULTI_on(gv);
3496#ifdef PERL_IS_AOUT
3497 sv_setiv(GvSV(gv), 1);
764df951
IZ		 3498#endif
3499 gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV);
3500 GvMULTI_on(gv);
3501 sv_setiv(GvSV(gv), exe_is_aout());
4bfbfac5
IZ		 3502 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
3503 GvMULTI_on(gv);
3504 sv_setiv(GvSV(gv), _emx_rev);
3505 sv_setpv(GvSV(gv), _emx_vprt);
3506 SvIOK_on(GvSV(gv));
3507 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
3508 GvMULTI_on(gv);
3509 sv_setiv(GvSV(gv), _emx_env);
3510 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
3511 GvMULTI_on(gv);
3512 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
9fed8b87
IZ		 3513 gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV);
3514 GvMULTI_on(gv);
3515 sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */
3bbf9c2b 3516 }
2d766320 3517 return 0;
3bbf9c2b
IZ		 3518}
3519
764df951
IZ		 3520extern void _emx_init(void*);
3521
3522static void jmp_out_of_atexit(void);
3523
3524#define FORCE_EMX_INIT_CONTRACT_ARGV 1
3525#define FORCE_EMX_INIT_INSTALL_ATEXIT 2
3526
3527static void
3528my_emx_init(void *layout) {
622913ab 3529 static volatile void *old_esp = 0; /* Cannot be on stack! */
764df951
IZ		 3530
3531 /* Can't just call emx_init(), since it moves the stack pointer */
3532 /* It also busts a lot of registers, so be extra careful */
3533 __asm__( "pushf\n"
3534 "pusha\n"
3535 "movl %%esp, %1\n"
3536 "push %0\n"
3537 "call __emx_init\n"
3538 "movl %1, %%esp\n"
3539 "popa\n"
622913ab 3540 "popf\n" : : "r" (layout), "m" (old_esp) );
764df951
IZ		 3541}
3542
3543struct layout_table_t {
3544 ULONG text_base;
3545 ULONG text_end;
3546 ULONG data_base;
3547 ULONG data_end;
3548 ULONG bss_base;
3549 ULONG bss_end;
3550 ULONG heap_base;
3551 ULONG heap_end;
3552 ULONG heap_brk;
3553 ULONG heap_off;
3554 ULONG os2_dll;
3555 ULONG stack_base;
3556 ULONG stack_end;
3557 ULONG flags;
3558 ULONG reserved[2];
3559 char options[64];
3560};
3561
3562static ULONG
3563my_os_version() {
622913ab 3564 static ULONG osv_res; /* Cannot be on stack! */
764df951 3565
c4e0013e
IZ		 3566 /* Can't just call __os_version(), since it does not follow C
3567 calling convention: it busts a lot of registers, so be extra careful */
764df951
IZ		 3568 __asm__( "pushf\n"
3569 "pusha\n"
3570 "call ___os_version\n"
3571 "movl %%eax, %0\n"
3572 "popa\n"
622913ab 3573 "popf\n" : "=m" (osv_res) );
764df951 3574
622913ab 3575 return osv_res;
764df951
IZ		 3576}
3577
3578static void
3579force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags)
3580{
3581 /* Calling emx_init() will bust the top of stack: it installs an
3582 exception handler and puts argv data there. */
3583 char *oldarg, *oldenv;
3584 void *oldstackend, *oldstack;
3585 PPIB pib;
3586 PTIB tib;
764df951
IZ		 3587 ULONG rc, error = 0, out;
3588 char buf[512];
3589 static struct layout_table_t layout_table;
3590 struct {
3591 char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */
3592 double alignment1;
3593 EXCEPTIONREGISTRATIONRECORD xreg;
3594 } *newstack;
3595 char *s;
3596
622913ab 3597 layout_table.os2_dll = (ULONG)&os2_dll_fake;
764df951
IZ		 3598 layout_table.flags = 0x02000002; /* flags: application, OMF */
3599
3600 DosGetInfoBlocks(&tib, &pib);
3601 oldarg = pib->pib_pchcmd;
3602 oldenv = pib->pib_pchenv;
3603 oldstack = tib->tib_pstack;
3604 oldstackend = tib->tib_pstacklimit;
3605
3606 /* Minimize the damage to the stack via reducing the size of argv. */
3607 if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) {
3608 pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */
3609 pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */
3610 }
3611
3612 newstack = alloca(sizeof(*newstack));
3613 /* Emulate the stack probe */
3614 s = ((char*)newstack) + sizeof(*newstack);
3615 while (s > (char*)newstack) {
3616 s[-1] = 0;
3617 s -= 4096;
3618 }
3619
3620 /* Reassigning stack is documented to work */
3621 tib->tib_pstack = (void*)newstack;
3622 tib->tib_pstacklimit = (void*)((char*)newstack + sizeof(*newstack));
3623
3624 /* Can't just call emx_init(), since it moves the stack pointer */
3625 my_emx_init((void*)&layout_table);
3626
3627 /* Remove the exception handler, cannot use it - too low on the stack.
3628 Check whether it is inside the new stack. */
3629 buf[0] = 0;
3630 if (tib->tib_pexchain >= tib->tib_pstacklimit
3631 || tib->tib_pexchain < tib->tib_pstack) {
3632 error = 1;
3633 sprintf(buf,
3634 "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n",
3635 (unsigned long)tib->tib_pstack,
3636 (unsigned long)tib->tib_pexchain,
3637 (unsigned long)tib->tib_pstacklimit);
3638 goto finish;
3639 }
3640 if (tib->tib_pexchain != &(newstack->xreg)) {
3641 sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n",
3642 (unsigned long)tib->tib_pexchain,
3643 (unsigned long)&(newstack->xreg));
3644 }
3645 rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain);
3646 if (rc)
3647 sprintf(buf + strlen(buf),
3648 "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3649
3650 if (preg) {
3651 /* ExceptionRecords should be on stack, in a correct order. Sigh... */
3652 preg->prev_structure = 0;
3653 preg->ExceptionHandler = _emx_exception;
3654 rc = DosSetExceptionHandler(preg);
3655 if (rc) {
3656 sprintf(buf + strlen(buf),
3657 "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc);
3658 DosWrite(2, buf, strlen(buf), &out);
3659 emx_exception_init = 1; /* Do it around spawn*() calls */
3660 }
3661 } else
3662 emx_exception_init = 1; /* Do it around spawn*() calls */
3663
3664 finish:
3665 /* Restore the damage */
3666 pib->pib_pchcmd = oldarg;
3667 pib->pib_pchcmd = oldenv;
3668 tib->tib_pstacklimit = oldstackend;
3669 tib->tib_pstack = oldstack;
3670 emx_runtime_init = 1;
3671 if (buf[0])
3672 DosWrite(2, buf, strlen(buf), &out);
3673 if (error)
3674 exit(56);
3675}
3676
764df951
IZ		 3677static void
3678jmp_out_of_atexit(void)
3679{
3680 if (longjmp_at_exit)
3681 longjmp(at_exit_buf, 1);
3682}
3683
3684extern void _CRT_term(void);
3685
764df951
IZ		 3686void
3687Perl_OS2_term(void **p, int exitstatus, int flags)
3688{
3689 if (!emx_runtime_secondary)
3690 return;
3691
3692 /* The principal executable is not running the same CRTL, so there
3693 is nobody to shutdown *this* CRTL except us... */
3694 if (flags & FORCE_EMX_DEINIT_EXIT) {
3695 if (p && !emx_exception_init)
3696 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3697 /* Do not run the executable's CRTL's termination routines */
3698 exit(exitstatus); /* Run at-exit, flush buffers, etc */
3699 }
3700 /* Run at-exit list, and jump out at the end */
3701 if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) {
3702 longjmp_at_exit = 1;
3703 exit(exitstatus); /* The first pass through "if" */
3704 }
3705
3706 /* Get here if we managed to jump out of exit(), or did not run atexit. */
3707 longjmp_at_exit = 0; /* Maybe exit() is called again? */
3708#if 0 /* _atexit_n is not exported */
3709 if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT)
3710 _atexit_n = 0; /* Remove the atexit() handlers */
3711#endif
3712 /* Will segfault on program termination if we leave this dangling... */
3713 if (p && !emx_exception_init)
3714 DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p);
3715 /* Typically there is no need to do this, done from _DLL_InitTerm() */
3716 if (flags & FORCE_EMX_DEINIT_CRT_TERM)
3717 _CRT_term(); /* Flush buffers, etc. */
3718 /* Now it is a good time to call exit() in the caller's CRTL... */
3719}
3720
3721#include <emx/startup.h>
3722
3723extern ULONG __os_version(); /* See system.doc */
3724
764df951
IZ		 3725void
3726check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg)
3727{
622913ab
IZ		 3728 ULONG v_crt, v_emx, count = 0, rc, rc1, maybe_inited = 0;
3729 static HMTX hmtx_emx_init = NULLHANDLE;
3730 static int emx_init_done = 0;
764df951
IZ		 3731
3732 /* If _environ is not set, this code sits in a DLL which
3733 uses a CRT DLL which not compatible with the executable's
3734 CRT library. Some parts of the DLL are not initialized.
3735 */
3736 if (_environ != NULL)
3737 return; /* Properly initialized */
3738
622913ab
IZ		 3739 /* It is not DOS, so we may use OS/2 API now */
3740 /* Some data we manipulate is static; protect ourselves from
3741 calling the same API from a different thread. */
3742 DosEnterMustComplete(&count);
3743
3744 rc1 = DosEnterCritSec();
3745 if (!hmtx_emx_init)
3746 rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/
3747 else
3748 maybe_inited = 1;
3749
3750 if (rc != NO_ERROR)
3751 hmtx_emx_init = NULLHANDLE;
3752
3753 if (rc1 == NO_ERROR)
3754 DosExitCritSec();
3755 DosExitMustComplete(&count);
3756
3757 while (maybe_inited) { /* Other thread did or is doing the same now */
3758 if (emx_init_done)
3759 return;
3760 rc = DosRequestMutexSem(hmtx_emx_init,
3761 (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */
3762 if (rc == ERROR_INTERRUPT)
3763 continue;
3764 if (rc != NO_ERROR) {
3765 char buf[80];
3766 ULONG out;
3767
3768 sprintf(buf,
3769 "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc);
3770 DosWrite(2, buf, strlen(buf), &out);
3771 return;
3772 }
3773 DosReleaseMutexSem(hmtx_emx_init);
3774 return;
3775 }
3776
764df951
IZ		 3777 /* If the executable does not use EMX.DLL, EMX.DLL is not completely
3778 initialized either. Uninitialized EMX.DLL returns 0 in the low
3779 nibble of __os_version(). */
3780 v_emx = my_os_version();
3781
3782 /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL
3783 (=>_CRT_init=>_entry2) via a call to __os_version(), then
3784 reset when the EXE initialization code calls _text=>_init=>_entry2.
3785 The first time they are wrongly set to 0; the second time the
3786 EXE initialization code had already called emx_init=>initialize1
3787 which correctly set version_major, version_minor used by
3788 __os_version(). */
3789 v_crt = (_osmajor | _osminor);
3790
3791 if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */
3792 force_init_emx_runtime( preg,
3793 FORCE_EMX_INIT_CONTRACT_ARGV
3794 | FORCE_EMX_INIT_INSTALL_ATEXIT );
3795 emx_wasnt_initialized = 1;
3796 /* Update CRTL data basing on now-valid EMX runtime data */
3797 if (!v_crt) { /* The only wrong data are the versions. */
3798 v_emx = my_os_version(); /* *Now* it works */
3799 *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */
3800 *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF;
3801 }
3802 }
3803 emx_runtime_secondary = 1;
3804 /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */
3805 atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */
3806
9e2a34c1 3807 if (env == NULL) { /* Fetch from the process info block */
764df951
IZ		 3808 int c = 0;
3809 PPIB pib;
3810 PTIB tib;
3811 char *e, **ep;
3812
3813 DosGetInfoBlocks(&tib, &pib);
3814 e = pib->pib_pchenv;
3815 while (*e) { /* Get count */
3816 c++;
3817 e = e + strlen(e) + 1;
3818 }
764df951
IZ		 3819 New(1307, env, c + 1, char*);
3820 ep = env;
3821 e = pib->pib_pchenv;
3822 while (c--) {
3823 *ep++ = e;
3824 e = e + strlen(e) + 1;
3825 }
3826 *ep = NULL;
3827 }
3828 _environ = _org_environ = env;
622913ab
IZ		 3829 emx_init_done = 1;
3830 if (hmtx_emx_init)
3831 DosReleaseMutexSem(hmtx_emx_init);
764df951
IZ		 3832}
3833
3834#define ENTRY_POINT 0x10000
3835
3836static int
3837exe_is_aout(void)
3838{
3839 struct layout_table_t *layout;
3840 if (emx_wasnt_initialized)
3841 return 0;
3842 /* Now we know that the principal executable is an EMX application
3843 - unless somebody did already play with delayed initialization... */
3844 /* With EMX applications to determine whether it is AOUT one needs
3845 to examine the start of the executable to find "layout" */
3846 if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */
3847 || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */
3848 || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */
3849 || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */
3850 return 0; /* ! EMX executable */
3851 /* Fix alignment */
3852 Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*);
3853 return !(layout->flags & 2);
3854}
3855
3bbf9c2b 3856void
aa689395 3857Perl_OS2_init(char **env)
3bbf9c2b 3858{
764df951
IZ		 3859 Perl_OS2_init3(env, 0, 0);
3860}
3861
3862void
3863Perl_OS2_init3(char **env, void **preg, int flags)
3864{
3bbf9c2b
IZ		 3865 char *shell;
3866
764df951 3867 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
18f739ee 3868 MALLOC_INIT;
764df951
IZ		 3869
3870 check_emx_runtime(env, (EXCEPTIONREGISTRATIONRECORD *)preg);
3871
3bbf9c2b
IZ		 3872 settmppath();
3873 OS2_Perl_data.xs_init = &Xs_OS2_init;
3874 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
6b88bc9c
GS		 3875 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
3876 strcpy(PL_sh_path, SH_PATH);
3877 PL_sh_path[0] = shell[0];
3bbf9c2b 3878 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
ff68c719 3879 int l = strlen(shell), i;
3bbf9c2b
IZ		 3880 if (shell[l-1] == '/' || shell[l-1] == '\\') {
3881 l--;
3882 }
6b88bc9c
GS		 3883 New(1304, PL_sh_path, l + 8, char);
3884 strncpy(PL_sh_path, shell, l);
3885 strcpy(PL_sh_path + l, "/sh.exe");
ff68c719 3886 for (i = 0; i < l; i++) {
6b88bc9c 3887 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
ff68c719 3888 }
3bbf9c2b 3889 }
5c728af0 3890#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
dd96f567 3891 MUTEX_INIT(&start_thread_mutex);
622913ab 3892 MUTEX_INIT(&perlos2_state_mutex);
5c728af0 3893#endif
017f25f1 3894 os2_mytype = my_type(); /* Do it before morphing. Needed? */
622913ab
IZ		 3895 os2_mytype_ini = os2_mytype;
3896 Perl_os2_initial_mode = -1; /* Uninit */
5ba48348
JH		 3897 /* Some DLLs reset FP flags on load. We may have been linked with them */
3898 _control87(MCW_EM, MCW_EM);
3bbf9c2b
IZ		 3899}
3900
55497cff 3901#undef tmpnam
3902#undef tmpfile
3903
3904char *
3905my_tmpnam (char *str)
3906{
3907 char *p = getenv("TMP"), *tpath;
55497cff 3908
3909 if (!p) p = getenv("TEMP");
3910 tpath = tempnam(p, "pltmp");
3911 if (str && tpath) {
3912 strcpy(str, tpath);
3913 return str;
3914 }
3915 return tpath;
3916}
3917
3918FILE *
3919my_tmpfile ()
3920{
3921 struct stat s;
3922
3923 stat(".", &s);
3924 if (s.st_mode & S_IWOTH) {
3925 return tmpfile();
3926 }
3927 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
3928 grants TMP. */
3929}
367f3c24 3930
5ba48348
JH		 3931#undef rmdir
3932
cd4e750a
IZ		 3933/* EMX flavors do not tolerate trailing slashes. t/op/mkdir.t has many
3934 trailing slashes, so we need to support this as well. */
3935
5ba48348
JH		 3936int
3937my_rmdir (__const__ char *s)
3938{
cd4e750a
IZ		 3939 char b[MAXPATHLEN];
3940 char *buf = b;
5ba48348 3941 STRLEN l = strlen(s);
cd4e750a 3942 int rc;
5ba48348 3943
cd4e750a
IZ		 3944 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
3945 if (l >= sizeof b)
3946 New(1305, buf, l + 1, char);
5ba48348 3947 strcpy(buf,s);
cd4e750a
IZ		 3948 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3949 l--;
3950 buf[l] = 0;
5ba48348
JH		 3951 s = buf;
3952 }
cd4e750a
IZ		 3953 rc = rmdir(s);
3954 if (b != buf)
3955 Safefree(buf);
3956 return rc;
5ba48348
JH		 3957}
3958
3959#undef mkdir
3960
3961int
3962my_mkdir (__const__ char *s, long perm)
3963{
cd4e750a
IZ		 3964 char b[MAXPATHLEN];
3965 char *buf = b;
5ba48348 3966 STRLEN l = strlen(s);
cd4e750a 3967 int rc;
5ba48348
JH		 3968
3969 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
cd4e750a
IZ		 3970 if (l >= sizeof b)
3971 New(1305, buf, l + 1, char);
5ba48348 3972 strcpy(buf,s);
cd4e750a
IZ		 3973 while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\'))
3974 l--;
3975 buf[l] = 0;
5ba48348
JH		 3976 s = buf;
3977 }
cd4e750a
IZ		 3978 rc = mkdir(s, perm);
3979 if (b != buf)
3980 Safefree(buf);
3981 return rc;
5ba48348
JH		 3982}
3983
367f3c24
IZ		 3984#undef flock
3985
3986/* This code was contributed by Rocco Caputo. */
3987int
dd96f567 3988my_flock(int handle, int o)
367f3c24
IZ		 3989{
3990 FILELOCK rNull, rFull;
3991 ULONG timeout, handle_type, flag_word;
3992 APIRET rc;
3993 int blocking, shared;
622913ab 3994 static int use_my_flock = -1;
367f3c24 3995
622913ab
IZ		 3996 if (use_my_flock == -1) {
3997 MUTEX_LOCK(&perlos2_state_mutex);
3998 if (use_my_flock == -1) {
367f3c24
IZ		 3999 char *s = getenv("USE_PERL_FLOCK");
4000 if (s)
622913ab 4001 use_my_flock = atoi(s);
367f3c24 4002 else
622913ab
IZ		 4003 use_my_flock = 1;
4004 }
4005 MUTEX_UNLOCK(&perlos2_state_mutex);
367f3c24 4006 }
622913ab 4007 if (!(_emx_env & 0x200) || !use_my_flock)
dd96f567 4008 return flock(handle, o); /* Delegate to EMX. */
367f3c24 4009
cb69f87a 4010 /* is this a file? */
367f3c24
IZ		 4011 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
4012 (handle_type & 0xFF))
4013 {
4014 errno = EBADF;
4015 return -1;
4016 }
cb69f87a 4017 /* set lock/unlock ranges */
367f3c24
IZ		 4018 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
4019 rFull.lRange = 0x7FFFFFFF;
cb69f87a 4020 /* set timeout for blocking */
dd96f567 4021 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
cb69f87a 4022 /* shared or exclusive? */
dd96f567 4023 shared = (o & LOCK_SH) ? 1 : 0;
cb69f87a 4024 /* do not block the unlock */
dd96f567 4025 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
367f3c24
IZ		 4026 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
4027 switch (rc) {
4028 case 0:
4029 errno = 0;
4030 return 0;
4031 case ERROR_INVALID_HANDLE:
4032 errno = EBADF;
4033 return -1;
4034 case ERROR_SHARING_BUFFER_EXCEEDED:
4035 errno = ENOLCK;
4036 return -1;
4037 case ERROR_LOCK_VIOLATION:
cb69f87a 4038 break; /* not an error */
367f3c24
IZ		 4039 case ERROR_INVALID_PARAMETER:
4040 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
4041 case ERROR_READ_LOCKS_NOT_SUPPORTED:
4042 errno = EINVAL;
4043 return -1;
4044 case ERROR_INTERRUPT:
4045 errno = EINTR;
4046 return -1;
4047 default:
4048 errno = EINVAL;
4049 return -1;
4050 }
4051 }
cb69f87a 4052 /* lock may block */
dd96f567 4053 if (o & (LOCK_SH | LOCK_EX)) {
cb69f87a 4054 /* for blocking operations */
367f3c24
IZ		 4055 for (;;) {
4056 rc =
4057 DosSetFileLocks(
4058 handle,
4059 &rNull,
4060 &rFull,
4061 timeout,
4062 shared
4063 );
4064 switch (rc) {
4065 case 0: