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