source: vendor/perl/5.8.8/os2/os2.c

Last change on this file was 3181, checked in by bird, 18 years ago

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