source: trunk/essentials/dev-lang/perl/os2/os2.c

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

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