1 | #define INCL_DOS |
---|
2 | #define INCL_NOPM |
---|
3 | #define INCL_DOSFILEMGR |
---|
4 | #define INCL_DOSMEMMGR |
---|
5 | #define INCL_DOSERRORS |
---|
6 | /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */ |
---|
7 | #define INCL_DOSPROCESS |
---|
8 | #define SPU_DISABLESUPPRESSION 0 |
---|
9 | #define SPU_ENABLESUPPRESSION 1 |
---|
10 | #include <os2.h> |
---|
11 | |
---|
12 | #include <sys/uflags.h> |
---|
13 | |
---|
14 | /* |
---|
15 | * Various Unix compatibility functions for OS/2 |
---|
16 | */ |
---|
17 | |
---|
18 | #include <stdio.h> |
---|
19 | #include <errno.h> |
---|
20 | #include <limits.h> |
---|
21 | #include <process.h> |
---|
22 | #include <fcntl.h> |
---|
23 | |
---|
24 | #include "EXTERN.h" |
---|
25 | #include "perl.h" |
---|
26 | |
---|
27 | #ifdef USE_THREADS |
---|
28 | |
---|
29 | typedef void (*emx_startroutine)(void *); |
---|
30 | typedef void* (*pthreads_startroutine)(void *); |
---|
31 | |
---|
32 | enum pthreads_state { |
---|
33 | pthreads_st_none = 0, |
---|
34 | pthreads_st_run, |
---|
35 | pthreads_st_exited, |
---|
36 | pthreads_st_detached, |
---|
37 | pthreads_st_waited, |
---|
38 | }; |
---|
39 | const char *pthreads_states[] = { |
---|
40 | "uninit", |
---|
41 | "running", |
---|
42 | "exited", |
---|
43 | "detached", |
---|
44 | "waited for", |
---|
45 | }; |
---|
46 | |
---|
47 | typedef struct { |
---|
48 | void *status; |
---|
49 | perl_cond cond; |
---|
50 | enum pthreads_state state; |
---|
51 | } thread_join_t; |
---|
52 | |
---|
53 | thread_join_t *thread_join_data; |
---|
54 | int thread_join_count; |
---|
55 | perl_mutex start_thread_mutex; |
---|
56 | |
---|
57 | int |
---|
58 | pthread_join(perl_os_thread tid, void **status) |
---|
59 | { |
---|
60 | MUTEX_LOCK(&start_thread_mutex); |
---|
61 | switch (thread_join_data[tid].state) { |
---|
62 | case pthreads_st_exited: |
---|
63 | thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ |
---|
64 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
65 | *status = thread_join_data[tid].status; |
---|
66 | break; |
---|
67 | case pthreads_st_waited: |
---|
68 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
69 | croak("join with a thread with a waiter"); |
---|
70 | break; |
---|
71 | case pthreads_st_run: |
---|
72 | thread_join_data[tid].state = pthreads_st_waited; |
---|
73 | COND_INIT(&thread_join_data[tid].cond); |
---|
74 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
75 | COND_WAIT(&thread_join_data[tid].cond, NULL); |
---|
76 | COND_DESTROY(&thread_join_data[tid].cond); |
---|
77 | thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ |
---|
78 | *status = thread_join_data[tid].status; |
---|
79 | break; |
---|
80 | default: |
---|
81 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
82 | croak("join: unknown thread state: '%s'", |
---|
83 | pthreads_states[thread_join_data[tid].state]); |
---|
84 | break; |
---|
85 | } |
---|
86 | return 0; |
---|
87 | } |
---|
88 | |
---|
89 | void |
---|
90 | pthread_startit(void *arg) |
---|
91 | { |
---|
92 | /* Thread is already started, we need to transfer control only */ |
---|
93 | pthreads_startroutine start_routine = *((pthreads_startroutine*)arg); |
---|
94 | int tid = pthread_self(); |
---|
95 | void *retval; |
---|
96 | |
---|
97 | arg = ((void**)arg)[1]; |
---|
98 | if (tid >= thread_join_count) { |
---|
99 | int oc = thread_join_count; |
---|
100 | |
---|
101 | thread_join_count = tid + 5 + tid/5; |
---|
102 | if (thread_join_data) { |
---|
103 | Renew(thread_join_data, thread_join_count, thread_join_t); |
---|
104 | Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); |
---|
105 | } else { |
---|
106 | Newz(1323, thread_join_data, thread_join_count, thread_join_t); |
---|
107 | } |
---|
108 | } |
---|
109 | if (thread_join_data[tid].state != pthreads_st_none) |
---|
110 | croak("attempt to reuse thread id %i", tid); |
---|
111 | thread_join_data[tid].state = pthreads_st_run; |
---|
112 | /* Now that we copied/updated the guys, we may release the caller... */ |
---|
113 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
114 | thread_join_data[tid].status = (*start_routine)(arg); |
---|
115 | switch (thread_join_data[tid].state) { |
---|
116 | case pthreads_st_waited: |
---|
117 | COND_SIGNAL(&thread_join_data[tid].cond); |
---|
118 | break; |
---|
119 | default: |
---|
120 | thread_join_data[tid].state = pthreads_st_exited; |
---|
121 | break; |
---|
122 | } |
---|
123 | } |
---|
124 | |
---|
125 | int |
---|
126 | pthread_create(perl_os_thread *tid, const pthread_attr_t *attr, |
---|
127 | void *(*start_routine)(void*), void *arg) |
---|
128 | { |
---|
129 | void *args[2]; |
---|
130 | |
---|
131 | args[0] = (void*)start_routine; |
---|
132 | args[1] = arg; |
---|
133 | |
---|
134 | MUTEX_LOCK(&start_thread_mutex); |
---|
135 | *tid = _beginthread(pthread_startit, /*stack*/ NULL, |
---|
136 | /*stacksize*/ 10*1024*1024, (void*)args); |
---|
137 | MUTEX_LOCK(&start_thread_mutex); |
---|
138 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
139 | return *tid ? 0 : EINVAL; |
---|
140 | } |
---|
141 | |
---|
142 | int |
---|
143 | pthread_detach(perl_os_thread tid) |
---|
144 | { |
---|
145 | MUTEX_LOCK(&start_thread_mutex); |
---|
146 | switch (thread_join_data[tid].state) { |
---|
147 | case pthreads_st_waited: |
---|
148 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
149 | croak("detach on a thread with a waiter"); |
---|
150 | break; |
---|
151 | case pthreads_st_run: |
---|
152 | thread_join_data[tid].state = pthreads_st_detached; |
---|
153 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
154 | break; |
---|
155 | default: |
---|
156 | MUTEX_UNLOCK(&start_thread_mutex); |
---|
157 | croak("detach: unknown thread state: '%s'", |
---|
158 | pthreads_states[thread_join_data[tid].state]); |
---|
159 | break; |
---|
160 | } |
---|
161 | return 0; |
---|
162 | } |
---|
163 | |
---|
164 | /* This is a very bastardized version: */ |
---|
165 | int |
---|
166 | os2_cond_wait(perl_cond *c, perl_mutex *m) |
---|
167 | { |
---|
168 | int rc; |
---|
169 | STRLEN n_a; |
---|
170 | if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) |
---|
171 | croak("panic: COND_WAIT-reset: rc=%i", rc); |
---|
172 | if (m) MUTEX_UNLOCK(m); |
---|
173 | if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) |
---|
174 | && (rc != ERROR_INTERRUPT)) |
---|
175 | croak("panic: COND_WAIT: rc=%i", rc); |
---|
176 | if (rc == ERROR_INTERRUPT) |
---|
177 | errno = EINTR; |
---|
178 | if (m) MUTEX_LOCK(m); |
---|
179 | } |
---|
180 | #endif |
---|
181 | |
---|
182 | /*****************************************************************************/ |
---|
183 | /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */ |
---|
184 | static PFN ExtFCN[2]; /* Labeled by ord below. */ |
---|
185 | static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */ |
---|
186 | #define ORD_QUERY_ELP 0 |
---|
187 | #define ORD_SET_ELP 1 |
---|
188 | struct PMWIN_entries_t PMWIN_entries; |
---|
189 | |
---|
190 | APIRET |
---|
191 | loadByOrd(char *modname, ULONG ord) |
---|
192 | { |
---|
193 | if (ExtFCN[ord] == NULL) { |
---|
194 | static HMODULE hdosc = 0; |
---|
195 | BYTE buf[20]; |
---|
196 | PFN fcn; |
---|
197 | APIRET rc; |
---|
198 | |
---|
199 | if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf, |
---|
200 | modname, &hdosc))) |
---|
201 | || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn))) |
---|
202 | croak("This version of OS/2 does not support %s.%i", |
---|
203 | modname, loadOrd[ord]); |
---|
204 | ExtFCN[ord] = fcn; |
---|
205 | } |
---|
206 | if ((long)ExtFCN[ord] == -1) |
---|
207 | croak("panic queryaddr"); |
---|
208 | } |
---|
209 | |
---|
210 | void |
---|
211 | init_PMWIN_entries(void) |
---|
212 | { |
---|
213 | static HMODULE hpmwin = 0; |
---|
214 | static const int ords[] = { |
---|
215 | 763, /* Initialize */ |
---|
216 | 716, /* CreateMsgQueue */ |
---|
217 | 726, /* DestroyMsgQueue */ |
---|
218 | 918, /* PeekMsg */ |
---|
219 | 915, /* GetMsg */ |
---|
220 | 912, /* DispatchMsg */ |
---|
221 | }; |
---|
222 | BYTE buf[20]; |
---|
223 | int i = 0; |
---|
224 | unsigned long rc; |
---|
225 | |
---|
226 | if (hpmwin) |
---|
227 | return; |
---|
228 | |
---|
229 | if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin))) |
---|
230 | croak("This version of OS/2 does not support pmwin: error in %s", buf); |
---|
231 | while (i <= 5) { |
---|
232 | if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL, |
---|
233 | ((PFN*)&PMWIN_entries)+i))) |
---|
234 | croak("This version of OS/2 does not support pmwin.%d", ords[i]); |
---|
235 | i++; |
---|
236 | } |
---|
237 | } |
---|
238 | |
---|
239 | |
---|
240 | /* priorities */ |
---|
241 | static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, |
---|
242 | self inverse. */ |
---|
243 | #define QSS_INI_BUFFER 1024 |
---|
244 | |
---|
245 | PQTOPLEVEL |
---|
246 | get_sysinfo(ULONG pid, ULONG flags) |
---|
247 | { |
---|
248 | char *pbuffer; |
---|
249 | ULONG rc, buf_len = QSS_INI_BUFFER; |
---|
250 | |
---|
251 | New(1322, pbuffer, buf_len, char); |
---|
252 | /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ |
---|
253 | rc = QuerySysState(flags, pid, pbuffer, buf_len); |
---|
254 | while (rc == ERROR_BUFFER_OVERFLOW) { |
---|
255 | Renew(pbuffer, buf_len *= 2, char); |
---|
256 | rc = QuerySysState(flags, pid, pbuffer, buf_len); |
---|
257 | } |
---|
258 | if (rc) { |
---|
259 | FillOSError(rc); |
---|
260 | Safefree(pbuffer); |
---|
261 | return 0; |
---|
262 | } |
---|
263 | return (PQTOPLEVEL)pbuffer; |
---|
264 | } |
---|
265 | |
---|
266 | #define PRIO_ERR 0x1111 |
---|
267 | |
---|
268 | static ULONG |
---|
269 | sys_prio(pid) |
---|
270 | { |
---|
271 | ULONG prio; |
---|
272 | PQTOPLEVEL psi; |
---|
273 | |
---|
274 | psi = get_sysinfo(pid, QSS_PROCESS); |
---|
275 | if (!psi) { |
---|
276 | return PRIO_ERR; |
---|
277 | } |
---|
278 | if (pid != psi->procdata->pid) { |
---|
279 | Safefree(psi); |
---|
280 | croak("panic: wrong pid in sysinfo"); |
---|
281 | } |
---|
282 | prio = psi->procdata->threads->priority; |
---|
283 | Safefree(psi); |
---|
284 | return prio; |
---|
285 | } |
---|
286 | |
---|
287 | int |
---|
288 | setpriority(int which, int pid, int val) |
---|
289 | { |
---|
290 | ULONG rc, prio; |
---|
291 | PQTOPLEVEL psi; |
---|
292 | |
---|
293 | prio = sys_prio(pid); |
---|
294 | |
---|
295 | if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ |
---|
296 | if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { |
---|
297 | /* Do not change class. */ |
---|
298 | return CheckOSError(DosSetPriority((pid < 0) |
---|
299 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
---|
300 | 0, |
---|
301 | (32 - val) % 32 - (prio & 0xFF), |
---|
302 | abs(pid))) |
---|
303 | ? -1 : 0; |
---|
304 | } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { |
---|
305 | /* Documentation claims one can change both class and basevalue, |
---|
306 | * but I find it wrong. */ |
---|
307 | /* Change class, but since delta == 0 denotes absolute 0, correct. */ |
---|
308 | if (CheckOSError(DosSetPriority((pid < 0) |
---|
309 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
---|
310 | priors[(32 - val) >> 5] + 1, |
---|
311 | 0, |
---|
312 | abs(pid)))) |
---|
313 | return -1; |
---|
314 | if ( ((32 - val) % 32) == 0 ) return 0; |
---|
315 | return CheckOSError(DosSetPriority((pid < 0) |
---|
316 | ? PRTYS_PROCESSTREE : PRTYS_PROCESS, |
---|
317 | 0, |
---|
318 | (32 - val) % 32, |
---|
319 | abs(pid))) |
---|
320 | ? -1 : 0; |
---|
321 | } |
---|
322 | /* else return CheckOSError(DosSetPriority((pid < 0) */ |
---|
323 | /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */ |
---|
324 | /* priors[(32 - val) >> 5] + 1, */ |
---|
325 | /* (32 - val) % 32 - (prio & 0xFF), */ |
---|
326 | /* abs(pid))) */ |
---|
327 | /* ? -1 : 0; */ |
---|
328 | } |
---|
329 | |
---|
330 | int |
---|
331 | getpriority(int which /* ignored */, int pid) |
---|
332 | { |
---|
333 | TIB *tib; |
---|
334 | PIB *pib; |
---|
335 | ULONG rc, ret; |
---|
336 | |
---|
337 | if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */ |
---|
338 | /* DosGetInfoBlocks has old priority! */ |
---|
339 | /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */ |
---|
340 | /* if (pid != pib->pib_ulpid) { */ |
---|
341 | ret = sys_prio(pid); |
---|
342 | if (ret == PRIO_ERR) { |
---|
343 | return -1; |
---|
344 | } |
---|
345 | /* } else */ |
---|
346 | /* ret = tib->tib_ptib2->tib2_ulpri; */ |
---|
347 | return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF); |
---|
348 | } |
---|
349 | |
---|
350 | /*****************************************************************************/ |
---|
351 | /* spawn */ |
---|
352 | |
---|
353 | /* There is no big sense to make it thread-specific, since signals |
---|
354 | are delivered to thread 1 only. XXXX Maybe make it into an array? */ |
---|
355 | static int spawn_pid; |
---|
356 | static int spawn_killed; |
---|
357 | |
---|
358 | static Signal_t |
---|
359 | spawn_sighandler(int sig) |
---|
360 | { |
---|
361 | /* Some programs do not arrange for the keyboard signals to be |
---|
362 | delivered to them. We need to deliver the signal manually. */ |
---|
363 | /* We may get a signal only if |
---|
364 | a) kid does not receive keyboard signal: deliver it; |
---|
365 | b) kid already died, and we get a signal. We may only hope |
---|
366 | that the pid number was not reused. |
---|
367 | */ |
---|
368 | |
---|
369 | if (spawn_killed) |
---|
370 | sig = SIGKILL; /* Try harder. */ |
---|
371 | kill(spawn_pid, sig); |
---|
372 | spawn_killed = 1; |
---|
373 | } |
---|
374 | |
---|
375 | static int |
---|
376 | result(int flag, int pid) |
---|
377 | { |
---|
378 | int r, status; |
---|
379 | Signal_t (*ihand)(); /* place to save signal during system() */ |
---|
380 | Signal_t (*qhand)(); /* place to save signal during system() */ |
---|
381 | #ifndef __EMX__ |
---|
382 | RESULTCODES res; |
---|
383 | int rpid; |
---|
384 | #endif |
---|
385 | |
---|
386 | if (pid < 0 || flag != 0) |
---|
387 | return pid; |
---|
388 | |
---|
389 | #ifdef __EMX__ |
---|
390 | spawn_pid = pid; |
---|
391 | spawn_killed = 0; |
---|
392 | ihand = rsignal(SIGINT, &spawn_sighandler); |
---|
393 | qhand = rsignal(SIGQUIT, &spawn_sighandler); |
---|
394 | do { |
---|
395 | r = wait4pid(pid, &status, 0); |
---|
396 | } while (r == -1 && errno == EINTR); |
---|
397 | rsignal(SIGINT, ihand); |
---|
398 | rsignal(SIGQUIT, qhand); |
---|
399 | |
---|
400 | PL_statusvalue = (U16)status; |
---|
401 | if (r < 0) |
---|
402 | return -1; |
---|
403 | return status & 0xFFFF; |
---|
404 | #else |
---|
405 | ihand = rsignal(SIGINT, SIG_IGN); |
---|
406 | r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); |
---|
407 | rsignal(SIGINT, ihand); |
---|
408 | PL_statusvalue = res.codeResult << 8 | res.codeTerminate; |
---|
409 | if (r) |
---|
410 | return -1; |
---|
411 | return PL_statusvalue; |
---|
412 | #endif |
---|
413 | } |
---|
414 | |
---|
415 | #define EXECF_SPAWN 0 |
---|
416 | #define EXECF_EXEC 1 |
---|
417 | #define EXECF_TRUEEXEC 2 |
---|
418 | #define EXECF_SPAWN_NOWAIT 3 |
---|
419 | #define EXECF_SPAWN_BYFLAG 4 |
---|
420 | |
---|
421 | /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */ |
---|
422 | |
---|
423 | static int |
---|
424 | my_type() |
---|
425 | { |
---|
426 | int rc; |
---|
427 | TIB *tib; |
---|
428 | PIB *pib; |
---|
429 | |
---|
430 | if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ |
---|
431 | if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) |
---|
432 | return -1; |
---|
433 | |
---|
434 | return (pib->pib_ultype); |
---|
435 | } |
---|
436 | |
---|
437 | static ULONG |
---|
438 | file_type(char *path) |
---|
439 | { |
---|
440 | int rc; |
---|
441 | ULONG apptype; |
---|
442 | |
---|
443 | if (!(_emx_env & 0x200)) |
---|
444 | croak("file_type not implemented on DOS"); /* not OS/2. */ |
---|
445 | if (CheckOSError(DosQueryAppType(path, &apptype))) { |
---|
446 | switch (rc) { |
---|
447 | case ERROR_FILE_NOT_FOUND: |
---|
448 | case ERROR_PATH_NOT_FOUND: |
---|
449 | return -1; |
---|
450 | case ERROR_ACCESS_DENIED: /* Directory with this name found? */ |
---|
451 | return -3; |
---|
452 | default: /* Found, but not an |
---|
453 | executable, or some other |
---|
454 | read error. */ |
---|
455 | return -2; |
---|
456 | } |
---|
457 | } |
---|
458 | return apptype; |
---|
459 | } |
---|
460 | |
---|
461 | static ULONG os2_mytype; |
---|
462 | |
---|
463 | /* Spawn/exec a program, revert to shell if needed. */ |
---|
464 | /* global PL_Argv[] contains arguments. */ |
---|
465 | |
---|
466 | int |
---|
467 | do_spawn_ve(really, flag, execf, inicmd, addflag) |
---|
468 | SV *really; |
---|
469 | U32 flag; |
---|
470 | U32 execf; |
---|
471 | char *inicmd; |
---|
472 | U32 addflag; |
---|
473 | { |
---|
474 | dTHR; |
---|
475 | int trueflag = flag; |
---|
476 | int rc, pass = 1; |
---|
477 | char *tmps; |
---|
478 | char buf[256], *s = 0, scrbuf[280]; |
---|
479 | char *args[4]; |
---|
480 | static char * fargs[4] |
---|
481 | = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; |
---|
482 | char **argsp = fargs; |
---|
483 | char nargs = 4; |
---|
484 | int force_shell; |
---|
485 | int new_stderr = -1, nostderr = 0, fl_stderr; |
---|
486 | STRLEN n_a; |
---|
487 | |
---|
488 | if (flag == P_WAIT) |
---|
489 | flag = P_NOWAIT; |
---|
490 | |
---|
491 | retry: |
---|
492 | if (strEQ(PL_Argv[0],"/bin/sh")) |
---|
493 | PL_Argv[0] = PL_sh_path; |
---|
494 | |
---|
495 | if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\' |
---|
496 | && !(PL_Argv[0][0] && PL_Argv[0][1] == ':' |
---|
497 | && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\')) |
---|
498 | ) /* will spawnvp use PATH? */ |
---|
499 | TAINT_ENV(); /* testing IFS here is overkill, probably */ |
---|
500 | /* We should check PERL_SH* and PERLLIB_* as well? */ |
---|
501 | if (!really || !*(tmps = SvPV(really, n_a))) |
---|
502 | tmps = PL_Argv[0]; |
---|
503 | |
---|
504 | reread: |
---|
505 | force_shell = 0; |
---|
506 | if (_emx_env & 0x200) { /* OS/2. */ |
---|
507 | int type = file_type(tmps); |
---|
508 | type_again: |
---|
509 | if (type == -1) { /* Not found */ |
---|
510 | errno = ENOENT; |
---|
511 | rc = -1; |
---|
512 | goto do_script; |
---|
513 | } |
---|
514 | else if (type == -2) { /* Not an EXE */ |
---|
515 | errno = ENOEXEC; |
---|
516 | rc = -1; |
---|
517 | goto do_script; |
---|
518 | } |
---|
519 | else if (type == -3) { /* Is a directory? */ |
---|
520 | /* Special-case this */ |
---|
521 | char tbuf[512]; |
---|
522 | int l = strlen(tmps); |
---|
523 | |
---|
524 | if (l + 5 <= sizeof tbuf) { |
---|
525 | strcpy(tbuf, tmps); |
---|
526 | strcpy(tbuf + l, ".exe"); |
---|
527 | type = file_type(tbuf); |
---|
528 | if (type >= -3) |
---|
529 | goto type_again; |
---|
530 | } |
---|
531 | |
---|
532 | errno = ENOEXEC; |
---|
533 | rc = -1; |
---|
534 | goto do_script; |
---|
535 | } |
---|
536 | switch (type & 7) { |
---|
537 | /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ |
---|
538 | case FAPPTYP_WINDOWAPI: |
---|
539 | { |
---|
540 | if (os2_mytype != 3) { /* not PM */ |
---|
541 | if (flag == P_NOWAIT) |
---|
542 | flag = P_PM; |
---|
543 | else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION) |
---|
544 | warn("Starting PM process with flag=%d, mytype=%d", |
---|
545 | flag, os2_mytype); |
---|
546 | } |
---|
547 | } |
---|
548 | break; |
---|
549 | case FAPPTYP_NOTWINDOWCOMPAT: |
---|
550 | { |
---|
551 | if (os2_mytype != 0) { /* not full screen */ |
---|
552 | if (flag == P_NOWAIT) |
---|
553 | flag = P_SESSION; |
---|
554 | else if ((flag & 7) != P_SESSION) |
---|
555 | warn("Starting Full Screen process with flag=%d, mytype=%d", |
---|
556 | flag, os2_mytype); |
---|
557 | } |
---|
558 | } |
---|
559 | break; |
---|
560 | case FAPPTYP_NOTSPEC: |
---|
561 | /* Let the shell handle this... */ |
---|
562 | force_shell = 1; |
---|
563 | goto doshell_args; |
---|
564 | break; |
---|
565 | } |
---|
566 | } |
---|
567 | |
---|
568 | if (addflag) { |
---|
569 | addflag = 0; |
---|
570 | new_stderr = dup(2); /* Preserve stderr */ |
---|
571 | if (new_stderr == -1) { |
---|
572 | if (errno == EBADF) |
---|
573 | nostderr = 1; |
---|
574 | else { |
---|
575 | rc = -1; |
---|
576 | goto finish; |
---|
577 | } |
---|
578 | } else |
---|
579 | fl_stderr = fcntl(2, F_GETFD); |
---|
580 | rc = dup2(1,2); |
---|
581 | if (rc == -1) |
---|
582 | goto finish; |
---|
583 | fcntl(new_stderr, F_SETFD, FD_CLOEXEC); |
---|
584 | } |
---|
585 | |
---|
586 | #if 0 |
---|
587 | rc = result(trueflag, spawnvp(flag,tmps,PL_Argv)); |
---|
588 | #else |
---|
589 | if (execf == EXECF_TRUEEXEC) |
---|
590 | rc = execvp(tmps,PL_Argv); |
---|
591 | else if (execf == EXECF_EXEC) |
---|
592 | rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv); |
---|
593 | else if (execf == EXECF_SPAWN_NOWAIT) |
---|
594 | rc = spawnvp(flag,tmps,PL_Argv); |
---|
595 | else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ |
---|
596 | rc = result(trueflag, |
---|
597 | spawnvp(flag,tmps,PL_Argv)); |
---|
598 | #endif |
---|
599 | if (rc < 0 && pass == 1 |
---|
600 | && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */ |
---|
601 | do_script: |
---|
602 | { |
---|
603 | int err = errno; |
---|
604 | |
---|
605 | if (err == ENOENT || err == ENOEXEC) { |
---|
606 | /* No such file, or is a script. */ |
---|
607 | /* Try adding script extensions to the file name, and |
---|
608 | search on PATH. */ |
---|
609 | char *scr = find_script(PL_Argv[0], TRUE, NULL, 0); |
---|
610 | |
---|
611 | if (scr) { |
---|
612 | FILE *file; |
---|
613 | char *s = 0, *s1; |
---|
614 | int l; |
---|
615 | |
---|
616 | l = strlen(scr); |
---|
617 | |
---|
618 | if (l >= sizeof scrbuf) { |
---|
619 | Safefree(scr); |
---|
620 | longbuf: |
---|
621 | warn("Size of scriptname too big: %d", l); |
---|
622 | rc = -1; |
---|
623 | goto finish; |
---|
624 | } |
---|
625 | strcpy(scrbuf, scr); |
---|
626 | Safefree(scr); |
---|
627 | scr = scrbuf; |
---|
628 | |
---|
629 | file = fopen(scr, "r"); |
---|
630 | PL_Argv[0] = scr; |
---|
631 | if (!file) |
---|
632 | goto panic_file; |
---|
633 | if (!fgets(buf, sizeof buf, file)) { /* Empty... */ |
---|
634 | |
---|
635 | buf[0] = 0; |
---|
636 | fclose(file); |
---|
637 | /* Special case: maybe from -Zexe build, so |
---|
638 | there is an executable around (contrary to |
---|
639 | documentation, DosQueryAppType sometimes (?) |
---|
640 | does not append ".exe", so we could have |
---|
641 | reached this place). */ |
---|
642 | if (l + 5 < sizeof scrbuf) { |
---|
643 | strcpy(scrbuf + l, ".exe"); |
---|
644 | if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0 |
---|
645 | && !S_ISDIR(PL_statbuf.st_mode)) { |
---|
646 | /* Found */ |
---|
647 | tmps = scr; |
---|
648 | pass++; |
---|
649 | goto reread; |
---|
650 | } else |
---|
651 | scrbuf[l] = 0; |
---|
652 | } else |
---|
653 | goto longbuf; |
---|
654 | } |
---|
655 | if (fclose(file) != 0) { /* Failure */ |
---|
656 | panic_file: |
---|
657 | warn("Error reading \"%s\": %s", |
---|
658 | scr, Strerror(errno)); |
---|
659 | buf[0] = 0; /* Not #! */ |
---|
660 | goto doshell_args; |
---|
661 | } |
---|
662 | if (buf[0] == '#') { |
---|
663 | if (buf[1] == '!') |
---|
664 | s = buf + 2; |
---|
665 | } else if (buf[0] == 'e') { |
---|
666 | if (strnEQ(buf, "extproc", 7) |
---|
667 | && isSPACE(buf[7])) |
---|
668 | s = buf + 8; |
---|
669 | } else if (buf[0] == 'E') { |
---|
670 | if (strnEQ(buf, "EXTPROC", 7) |
---|
671 | && isSPACE(buf[7])) |
---|
672 | s = buf + 8; |
---|
673 | } |
---|
674 | if (!s) { |
---|
675 | buf[0] = 0; /* Not #! */ |
---|
676 | goto doshell_args; |
---|
677 | } |
---|
678 | |
---|
679 | s1 = s; |
---|
680 | nargs = 0; |
---|
681 | argsp = args; |
---|
682 | while (1) { |
---|
683 | /* Do better than pdksh: allow a few args, |
---|
684 | strip trailing whitespace. */ |
---|
685 | while (isSPACE(*s)) |
---|
686 | s++; |
---|
687 | if (*s == 0) |
---|
688 | break; |
---|
689 | if (nargs == 4) { |
---|
690 | nargs = -1; |
---|
691 | break; |
---|
692 | } |
---|
693 | args[nargs++] = s; |
---|
694 | while (*s && !isSPACE(*s)) |
---|
695 | s++; |
---|
696 | if (*s == 0) |
---|
697 | break; |
---|
698 | *s++ = 0; |
---|
699 | } |
---|
700 | if (nargs == -1) { |
---|
701 | warn("Too many args on %.*s line of \"%s\"", |
---|
702 | s1 - buf, buf, scr); |
---|
703 | nargs = 4; |
---|
704 | argsp = fargs; |
---|
705 | } |
---|
706 | doshell_args: |
---|
707 | { |
---|
708 | char **a = PL_Argv; |
---|
709 | char *exec_args[2]; |
---|
710 | |
---|
711 | if (force_shell |
---|
712 | || (!buf[0] && file)) { /* File without magic */ |
---|
713 | /* In fact we tried all what pdksh would |
---|
714 | try. There is no point in calling |
---|
715 | pdksh, we may just emulate its logic. */ |
---|
716 | char *shell = getenv("EXECSHELL"); |
---|
717 | char *shell_opt = NULL; |
---|
718 | |
---|
719 | if (!shell) { |
---|
720 | char *s; |
---|
721 | |
---|
722 | shell_opt = "/c"; |
---|
723 | shell = getenv("OS2_SHELL"); |
---|
724 | if (inicmd) { /* No spaces at start! */ |
---|
725 | s = inicmd; |
---|
726 | while (*s && !isSPACE(*s)) { |
---|
727 | if (*s++ = '/') { |
---|
728 | inicmd = NULL; /* Cannot use */ |
---|
729 | break; |
---|
730 | } |
---|
731 | } |
---|
732 | } |
---|
733 | if (!inicmd) { |
---|
734 | s = PL_Argv[0]; |
---|
735 | while (*s) { |
---|
736 | /* Dosish shells will choke on slashes |
---|
737 | in paths, fortunately, this is |
---|
738 | important for zeroth arg only. */ |
---|
739 | if (*s == '/') |
---|
740 | *s = '\\'; |
---|
741 | s++; |
---|
742 | } |
---|
743 | } |
---|
744 | } |
---|
745 | /* If EXECSHELL is set, we do not set */ |
---|
746 | |
---|
747 | if (!shell) |
---|
748 | shell = ((_emx_env & 0x200) |
---|
749 | ? "c:/os2/cmd.exe" |
---|
750 | : "c:/command.com"); |
---|
751 | nargs = shell_opt ? 2 : 1; /* shell file args */ |
---|
752 | exec_args[0] = shell; |
---|
753 | exec_args[1] = shell_opt; |
---|
754 | argsp = exec_args; |
---|
755 | if (nargs == 2 && inicmd) { |
---|
756 | /* Use the original cmd line */ |
---|
757 | /* XXXX This is good only until we refuse |
---|
758 | quoted arguments... */ |
---|
759 | PL_Argv[0] = inicmd; |
---|
760 | PL_Argv[1] = Nullch; |
---|
761 | } |
---|
762 | } else if (!buf[0] && inicmd) { /* No file */ |
---|
763 | /* Start with the original cmdline. */ |
---|
764 | /* XXXX This is good only until we refuse |
---|
765 | quoted arguments... */ |
---|
766 | |
---|
767 | PL_Argv[0] = inicmd; |
---|
768 | PL_Argv[1] = Nullch; |
---|
769 | nargs = 2; /* shell -c */ |
---|
770 | } |
---|
771 | |
---|
772 | while (a[1]) /* Get to the end */ |
---|
773 | a++; |
---|
774 | a++; /* Copy finil NULL too */ |
---|
775 | while (a >= PL_Argv) { |
---|
776 | *(a + nargs) = *a; /* PL_Argv was preallocated to be |
---|
777 | long enough. */ |
---|
778 | a--; |
---|
779 | } |
---|
780 | while (--nargs >= 0) |
---|
781 | PL_Argv[nargs] = argsp[nargs]; |
---|
782 | /* Enable pathless exec if #! (as pdksh). */ |
---|
783 | pass = (buf[0] == '#' ? 2 : 3); |
---|
784 | goto retry; |
---|
785 | } |
---|
786 | } |
---|
787 | /* Not found: restore errno */ |
---|
788 | errno = err; |
---|
789 | } |
---|
790 | } |
---|
791 | } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ |
---|
792 | char *no_dir = strrchr(PL_Argv[0], '/'); |
---|
793 | |
---|
794 | /* Do as pdksh port does: if not found with /, try without |
---|
795 | path. */ |
---|
796 | if (no_dir) { |
---|
797 | PL_Argv[0] = no_dir + 1; |
---|
798 | pass++; |
---|
799 | goto retry; |
---|
800 | } |
---|
801 | } |
---|
802 | if (rc < 0 && ckWARN(WARN_EXEC)) |
---|
803 | Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n", |
---|
804 | ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) |
---|
805 | ? "spawn" : "exec"), |
---|
806 | PL_Argv[0], Strerror(errno)); |
---|
807 | if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) |
---|
808 | && ((trueflag & 0xFF) == P_WAIT)) |
---|
809 | rc = -1; |
---|
810 | |
---|
811 | finish: |
---|
812 | if (new_stderr != -1) { /* How can we use error codes? */ |
---|
813 | dup2(new_stderr, 2); |
---|
814 | close(new_stderr); |
---|
815 | fcntl(2, F_SETFD, fl_stderr); |
---|
816 | } else if (nostderr) |
---|
817 | close(2); |
---|
818 | return rc; |
---|
819 | } |
---|
820 | |
---|
821 | /* Try converting 1-arg form to (usually shell-less) multi-arg form. */ |
---|
822 | int |
---|
823 | do_spawn3(char *cmd, int execf, int flag) |
---|
824 | { |
---|
825 | register char **a; |
---|
826 | register char *s; |
---|
827 | char flags[10]; |
---|
828 | char *shell, *copt, *news = NULL; |
---|
829 | int rc, err, seenspace = 0, mergestderr = 0; |
---|
830 | char fullcmd[MAXNAMLEN + 1]; |
---|
831 | |
---|
832 | #ifdef TRYSHELL |
---|
833 | if ((shell = getenv("EMXSHELL")) != NULL) |
---|
834 | copt = "-c"; |
---|
835 | else if ((shell = getenv("SHELL")) != NULL) |
---|
836 | copt = "-c"; |
---|
837 | else if ((shell = getenv("COMSPEC")) != NULL) |
---|
838 | copt = "/C"; |
---|
839 | else |
---|
840 | shell = "cmd.exe"; |
---|
841 | #else |
---|
842 | /* Consensus on perl5-porters is that it is _very_ important to |
---|
843 | have a shell which will not change between computers with the |
---|
844 | same architecture, to avoid "action on a distance". |
---|
845 | And to have simple build, this shell should be sh. */ |
---|
846 | shell = PL_sh_path; |
---|
847 | copt = "-c"; |
---|
848 | #endif |
---|
849 | |
---|
850 | while (*cmd && isSPACE(*cmd)) |
---|
851 | cmd++; |
---|
852 | |
---|
853 | if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) { |
---|
854 | STRLEN l = strlen(PL_sh_path); |
---|
855 | |
---|
856 | New(1302, news, strlen(cmd) - 7 + l + 1, char); |
---|
857 | strcpy(news, PL_sh_path); |
---|
858 | strcpy(news + l, cmd + 7); |
---|
859 | cmd = news; |
---|
860 | } |
---|
861 | |
---|
862 | /* save an extra exec if possible */ |
---|
863 | /* see if there are shell metacharacters in it */ |
---|
864 | |
---|
865 | if (*cmd == '.' && isSPACE(cmd[1])) |
---|
866 | goto doshell; |
---|
867 | |
---|
868 | if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) |
---|
869 | goto doshell; |
---|
870 | |
---|
871 | for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ |
---|
872 | if (*s == '=') |
---|
873 | goto doshell; |
---|
874 | |
---|
875 | for (s = cmd; *s; s++) { |
---|
876 | if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { |
---|
877 | if (*s == '\n' && s[1] == '\0') { |
---|
878 | *s = '\0'; |
---|
879 | break; |
---|
880 | } else if (*s == '\\' && !seenspace) { |
---|
881 | continue; /* Allow backslashes in names */ |
---|
882 | } else if (*s == '>' && s >= cmd + 3 |
---|
883 | && s[-1] == '2' && s[1] == '&' && s[2] == '1' |
---|
884 | && isSPACE(s[-2]) ) { |
---|
885 | char *t = s + 3; |
---|
886 | |
---|
887 | while (*t && isSPACE(*t)) |
---|
888 | t++; |
---|
889 | if (!*t) { |
---|
890 | s[-2] = '\0'; |
---|
891 | mergestderr = 1; |
---|
892 | break; /* Allow 2>&1 as the last thing */ |
---|
893 | } |
---|
894 | } |
---|
895 | /* We do not convert this to do_spawn_ve since shell |
---|
896 | should be smart enough to start itself gloriously. */ |
---|
897 | doshell: |
---|
898 | if (execf == EXECF_TRUEEXEC) |
---|
899 | rc = execl(shell,shell,copt,cmd,(char*)0); |
---|
900 | else if (execf == EXECF_EXEC) |
---|
901 | rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); |
---|
902 | else if (execf == EXECF_SPAWN_NOWAIT) |
---|
903 | rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); |
---|
904 | else if (execf == EXECF_SPAWN_BYFLAG) |
---|
905 | rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); |
---|
906 | else { |
---|
907 | /* In the ak code internal P_NOWAIT is P_WAIT ??? */ |
---|
908 | rc = result(P_WAIT, |
---|
909 | spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); |
---|
910 | if (rc < 0 && ckWARN(WARN_EXEC)) |
---|
911 | Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", |
---|
912 | (execf == EXECF_SPAWN ? "spawn" : "exec"), |
---|
913 | shell, Strerror(errno)); |
---|
914 | if (rc < 0) |
---|
915 | rc = -1; |
---|
916 | } |
---|
917 | if (news) |
---|
918 | Safefree(news); |
---|
919 | return rc; |
---|
920 | } else if (*s == ' ' || *s == '\t') { |
---|
921 | seenspace = 1; |
---|
922 | } |
---|
923 | } |
---|
924 | |
---|
925 | /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ |
---|
926 | New(1303,PL_Argv, (s - cmd + 11) / 2, char*); |
---|
927 | PL_Cmd = savepvn(cmd, s-cmd); |
---|
928 | a = PL_Argv; |
---|
929 | for (s = PL_Cmd; *s;) { |
---|
930 | while (*s && isSPACE(*s)) s++; |
---|
931 | if (*s) |
---|
932 | *(a++) = s; |
---|
933 | while (*s && !isSPACE(*s)) s++; |
---|
934 | if (*s) |
---|
935 | *s++ = '\0'; |
---|
936 | } |
---|
937 | *a = Nullch; |
---|
938 | if (PL_Argv[0]) |
---|
939 | rc = do_spawn_ve(NULL, flag, execf, cmd, mergestderr); |
---|
940 | else |
---|
941 | rc = -1; |
---|
942 | if (news) |
---|
943 | Safefree(news); |
---|
944 | do_execfree(); |
---|
945 | return rc; |
---|
946 | } |
---|
947 | |
---|
948 | /* Array spawn. */ |
---|
949 | int |
---|
950 | do_aspawn(really,mark,sp) |
---|
951 | SV *really; |
---|
952 | register SV **mark; |
---|
953 | register SV **sp; |
---|
954 | { |
---|
955 | dTHR; |
---|
956 | register char **a; |
---|
957 | int rc; |
---|
958 | int flag = P_WAIT, flag_set = 0; |
---|
959 | STRLEN n_a; |
---|
960 | |
---|
961 | if (sp > mark) { |
---|
962 | New(1301,PL_Argv, sp - mark + 3, char*); |
---|
963 | a = PL_Argv; |
---|
964 | |
---|
965 | if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { |
---|
966 | ++mark; |
---|
967 | flag = SvIVx(*mark); |
---|
968 | flag_set = 1; |
---|
969 | |
---|
970 | } |
---|
971 | |
---|
972 | while (++mark <= sp) { |
---|
973 | if (*mark) |
---|
974 | *a++ = SvPVx(*mark, n_a); |
---|
975 | else |
---|
976 | *a++ = ""; |
---|
977 | } |
---|
978 | *a = Nullch; |
---|
979 | |
---|
980 | if (flag_set && (a == PL_Argv + 1)) { /* One arg? */ |
---|
981 | rc = do_spawn3(a[-1], EXECF_SPAWN_BYFLAG, flag); |
---|
982 | } else |
---|
983 | rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL, 0); |
---|
984 | } else |
---|
985 | rc = -1; |
---|
986 | do_execfree(); |
---|
987 | return rc; |
---|
988 | } |
---|
989 | |
---|
990 | int |
---|
991 | do_spawn(cmd) |
---|
992 | char *cmd; |
---|
993 | { |
---|
994 | return do_spawn3(cmd, EXECF_SPAWN, 0); |
---|
995 | } |
---|
996 | |
---|
997 | int |
---|
998 | do_spawn_nowait(cmd) |
---|
999 | char *cmd; |
---|
1000 | { |
---|
1001 | return do_spawn3(cmd, EXECF_SPAWN_NOWAIT,0); |
---|
1002 | } |
---|
1003 | |
---|
1004 | bool |
---|
1005 | do_exec(cmd) |
---|
1006 | char *cmd; |
---|
1007 | { |
---|
1008 | do_spawn3(cmd, EXECF_EXEC, 0); |
---|
1009 | return FALSE; |
---|
1010 | } |
---|
1011 | |
---|
1012 | bool |
---|
1013 | os2exec(cmd) |
---|
1014 | char *cmd; |
---|
1015 | { |
---|
1016 | return do_spawn3(cmd, EXECF_TRUEEXEC, 0); |
---|
1017 | } |
---|
1018 | |
---|
1019 | PerlIO * |
---|
1020 | my_syspopen(cmd,mode) |
---|
1021 | char *cmd; |
---|
1022 | char *mode; |
---|
1023 | { |
---|
1024 | #ifndef USE_POPEN |
---|
1025 | |
---|
1026 | int p[2]; |
---|
1027 | register I32 this, that, newfd; |
---|
1028 | register I32 pid, rc; |
---|
1029 | PerlIO *res; |
---|
1030 | SV *sv; |
---|
1031 | int fh_fl; |
---|
1032 | |
---|
1033 | /* `this' is what we use in the parent, `that' in the child. */ |
---|
1034 | this = (*mode == 'w'); |
---|
1035 | that = !this; |
---|
1036 | if (PL_tainting) { |
---|
1037 | taint_env(); |
---|
1038 | taint_proper("Insecure %s%s", "EXEC"); |
---|
1039 | } |
---|
1040 | if (pipe(p) < 0) |
---|
1041 | return Nullfp; |
---|
1042 | /* Now we need to spawn the child. */ |
---|
1043 | if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ |
---|
1044 | int new = dup(p[this]); |
---|
1045 | |
---|
1046 | if (new == -1) |
---|
1047 | goto closepipes; |
---|
1048 | close(p[this]); |
---|
1049 | p[this] = new; |
---|
1050 | } |
---|
1051 | newfd = dup(*mode == 'r'); /* Preserve std* */ |
---|
1052 | if (newfd == -1) { |
---|
1053 | /* This cannot happen due to fh being bad after pipe(), since |
---|
1054 | pipe() should have created fh 0 and 1 even if they were |
---|
1055 | initially closed. But we closed p[this] before. */ |
---|
1056 | if (errno != EBADF) { |
---|
1057 | closepipes: |
---|
1058 | close(p[0]); |
---|
1059 | close(p[1]); |
---|
1060 | return Nullfp; |
---|
1061 | } |
---|
1062 | } else |
---|
1063 | fh_fl = fcntl(*mode == 'r', F_GETFD); |
---|
1064 | if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ |
---|
1065 | dup2(p[that], *mode == 'r'); |
---|
1066 | close(p[that]); |
---|
1067 | } |
---|
1068 | /* Where is `this' and newfd now? */ |
---|
1069 | fcntl(p[this], F_SETFD, FD_CLOEXEC); |
---|
1070 | if (newfd != -1) |
---|
1071 | fcntl(newfd, F_SETFD, FD_CLOEXEC); |
---|
1072 | pid = do_spawn_nowait(cmd); |
---|
1073 | if (newfd == -1) |
---|
1074 | close(*mode == 'r'); /* It was closed initially */ |
---|
1075 | else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ |
---|
1076 | dup2(newfd, *mode == 'r'); /* Return std* back. */ |
---|
1077 | close(newfd); |
---|
1078 | fcntl(*mode == 'r', F_SETFD, fh_fl); |
---|
1079 | } else |
---|
1080 | fcntl(*mode == 'r', F_SETFD, fh_fl); |
---|
1081 | if (p[that] == (*mode == 'r')) |
---|
1082 | close(p[that]); |
---|
1083 | if (pid == -1) { |
---|
1084 | close(p[this]); |
---|
1085 | return Nullfp; |
---|
1086 | } |
---|
1087 | if (p[that] < p[this]) { /* Make fh as small as possible */ |
---|
1088 | dup2(p[this], p[that]); |
---|
1089 | close(p[this]); |
---|
1090 | p[this] = p[that]; |
---|
1091 | } |
---|
1092 | sv = *av_fetch(PL_fdpid,p[this],TRUE); |
---|
1093 | (void)SvUPGRADE(sv,SVt_IV); |
---|
1094 | SvIVX(sv) = pid; |
---|
1095 | PL_forkprocess = pid; |
---|
1096 | return PerlIO_fdopen(p[this], mode); |
---|
1097 | |
---|
1098 | #else /* USE_POPEN */ |
---|
1099 | |
---|
1100 | PerlIO *res; |
---|
1101 | SV *sv; |
---|
1102 | |
---|
1103 | # ifdef TRYSHELL |
---|
1104 | res = popen(cmd, mode); |
---|
1105 | # else |
---|
1106 | char *shell = getenv("EMXSHELL"); |
---|
1107 | |
---|
1108 | my_setenv("EMXSHELL", PL_sh_path); |
---|
1109 | res = popen(cmd, mode); |
---|
1110 | my_setenv("EMXSHELL", shell); |
---|
1111 | # endif |
---|
1112 | sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE); |
---|
1113 | (void)SvUPGRADE(sv,SVt_IV); |
---|
1114 | SvIVX(sv) = -1; /* A cooky. */ |
---|
1115 | return res; |
---|
1116 | |
---|
1117 | #endif /* USE_POPEN */ |
---|
1118 | |
---|
1119 | } |
---|
1120 | |
---|
1121 | /******************************************************************/ |
---|
1122 | |
---|
1123 | #ifndef HAS_FORK |
---|
1124 | int |
---|
1125 | fork(void) |
---|
1126 | { |
---|
1127 | croak(PL_no_func, "Unsupported function fork"); |
---|
1128 | errno = EINVAL; |
---|
1129 | return -1; |
---|
1130 | } |
---|
1131 | #endif |
---|
1132 | |
---|
1133 | /*******************************************************************/ |
---|
1134 | /* not implemented in EMX 0.9a */ |
---|
1135 | |
---|
1136 | void * ctermid(x) { return 0; } |
---|
1137 | |
---|
1138 | #ifdef MYTTYNAME /* was not in emx0.9a */ |
---|
1139 | void * ttyname(x) { return 0; } |
---|
1140 | #endif |
---|
1141 | |
---|
1142 | /******************************************************************/ |
---|
1143 | /* my socket forwarders - EMX lib only provides static forwarders */ |
---|
1144 | |
---|
1145 | static HMODULE htcp = 0; |
---|
1146 | |
---|
1147 | static void * |
---|
1148 | tcp0(char *name) |
---|
1149 | { |
---|
1150 | static BYTE buf[20]; |
---|
1151 | PFN fcn; |
---|
1152 | |
---|
1153 | if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ |
---|
1154 | if (!htcp) |
---|
1155 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
---|
1156 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
---|
1157 | return (void *) ((void * (*)(void)) fcn) (); |
---|
1158 | return 0; |
---|
1159 | } |
---|
1160 | |
---|
1161 | static void |
---|
1162 | tcp1(char *name, int arg) |
---|
1163 | { |
---|
1164 | static BYTE buf[20]; |
---|
1165 | PFN fcn; |
---|
1166 | |
---|
1167 | if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */ |
---|
1168 | if (!htcp) |
---|
1169 | DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); |
---|
1170 | if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) |
---|
1171 | ((void (*)(int)) fcn) (arg); |
---|
1172 | } |
---|
1173 | |
---|
1174 | void * gethostent() { return tcp0("GETHOSTENT"); } |
---|
1175 | void * getnetent() { return tcp0("GETNETENT"); } |
---|
1176 | void * getprotoent() { return tcp0("GETPROTOENT"); } |
---|
1177 | void * getservent() { return tcp0("GETSERVENT"); } |
---|
1178 | void sethostent(x) { tcp1("SETHOSTENT", x); } |
---|
1179 | void setnetent(x) { tcp1("SETNETENT", x); } |
---|
1180 | void setprotoent(x) { tcp1("SETPROTOENT", x); } |
---|
1181 | void setservent(x) { tcp1("SETSERVENT", x); } |
---|
1182 | void endhostent() { tcp0("ENDHOSTENT"); } |
---|
1183 | void endnetent() { tcp0("ENDNETENT"); } |
---|
1184 | void endprotoent() { tcp0("ENDPROTOENT"); } |
---|
1185 | void endservent() { tcp0("ENDSERVENT"); } |
---|
1186 | |
---|
1187 | /*****************************************************************************/ |
---|
1188 | /* not implemented in C Set++ */ |
---|
1189 | |
---|
1190 | #ifndef __EMX__ |
---|
1191 | int setuid(x) { errno = EINVAL; return -1; } |
---|
1192 | int setgid(x) { errno = EINVAL; return -1; } |
---|
1193 | #endif |
---|
1194 | |
---|
1195 | /*****************************************************************************/ |
---|
1196 | /* stat() hack for char/block device */ |
---|
1197 | |
---|
1198 | #if OS2_STAT_HACK |
---|
1199 | |
---|
1200 | /* First attempt used DosQueryFSAttach which crashed the system when |
---|
1201 | used with 5.001. Now just look for /dev/. */ |
---|
1202 | |
---|
1203 | int |
---|
1204 | os2_stat(char *name, struct stat *st) |
---|
1205 | { |
---|
1206 | static int ino = SHRT_MAX; |
---|
1207 | |
---|
1208 | if (stricmp(name, "/dev/con") != 0 |
---|
1209 | && stricmp(name, "/dev/tty") != 0) |
---|
1210 | return stat(name, st); |
---|
1211 | |
---|
1212 | memset(st, 0, sizeof *st); |
---|
1213 | st->st_mode = S_IFCHR|0666; |
---|
1214 | st->st_ino = (ino-- & 0x7FFF); |
---|
1215 | st->st_nlink = 1; |
---|
1216 | return 0; |
---|
1217 | } |
---|
1218 | |
---|
1219 | #endif |
---|
1220 | |
---|
1221 | #ifdef USE_PERL_SBRK |
---|
1222 | |
---|
1223 | /* SBRK() emulation, mostly moved to malloc.c. */ |
---|
1224 | |
---|
1225 | void * |
---|
1226 | sys_alloc(int size) { |
---|
1227 | void *got; |
---|
1228 | APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); |
---|
1229 | |
---|
1230 | if (rc == ERROR_NOT_ENOUGH_MEMORY) { |
---|
1231 | return (void *) -1; |
---|
1232 | } else if ( rc ) |
---|
1233 | croak("Got an error from DosAllocMem: %li", (long)rc); |
---|
1234 | return got; |
---|
1235 | } |
---|
1236 | |
---|
1237 | #endif /* USE_PERL_SBRK */ |
---|
1238 | |
---|
1239 | /* tmp path */ |
---|
1240 | |
---|
1241 | char *tmppath = TMPPATH1; |
---|
1242 | |
---|
1243 | void |
---|
1244 | settmppath() |
---|
1245 | { |
---|
1246 | char *p = getenv("TMP"), *tpath; |
---|
1247 | int len; |
---|
1248 | |
---|
1249 | if (!p) p = getenv("TEMP"); |
---|
1250 | if (!p) return; |
---|
1251 | len = strlen(p); |
---|
1252 | tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); |
---|
1253 | if (tpath) { |
---|
1254 | strcpy(tpath, p); |
---|
1255 | tpath[len] = '/'; |
---|
1256 | strcpy(tpath + len + 1, TMPPATH1); |
---|
1257 | tmppath = tpath; |
---|
1258 | } |
---|
1259 | } |
---|
1260 | |
---|
1261 | #include "XSUB.h" |
---|
1262 | |
---|
1263 | XS(XS_File__Copy_syscopy) |
---|
1264 | { |
---|
1265 | dXSARGS; |
---|
1266 | if (items < 2 || items > 3) |
---|
1267 | croak("Usage: File::Copy::syscopy(src,dst,flag=0)"); |
---|
1268 | { |
---|
1269 | STRLEN n_a; |
---|
1270 | char * src = (char *)SvPV(ST(0),n_a); |
---|
1271 | char * dst = (char *)SvPV(ST(1),n_a); |
---|
1272 | U32 flag; |
---|
1273 | int RETVAL, rc; |
---|
1274 | |
---|
1275 | if (items < 3) |
---|
1276 | flag = 0; |
---|
1277 | else { |
---|
1278 | flag = (unsigned long)SvIV(ST(2)); |
---|
1279 | } |
---|
1280 | |
---|
1281 | RETVAL = !CheckOSError(DosCopy(src, dst, flag)); |
---|
1282 | ST(0) = sv_newmortal(); |
---|
1283 | sv_setiv(ST(0), (IV)RETVAL); |
---|
1284 | } |
---|
1285 | XSRETURN(1); |
---|
1286 | } |
---|
1287 | |
---|
1288 | #include "patchlevel.h" |
---|
1289 | |
---|
1290 | char * |
---|
1291 | mod2fname(sv) |
---|
1292 | SV *sv; |
---|
1293 | { |
---|
1294 | static char fname[9]; |
---|
1295 | int pos = 6, len, avlen; |
---|
1296 | unsigned int sum = 0; |
---|
1297 | AV *av; |
---|
1298 | SV *svp; |
---|
1299 | char *s; |
---|
1300 | STRLEN n_a; |
---|
1301 | |
---|
1302 | if (!SvROK(sv)) croak("Not a reference given to mod2fname"); |
---|
1303 | sv = SvRV(sv); |
---|
1304 | if (SvTYPE(sv) != SVt_PVAV) |
---|
1305 | croak("Not array reference given to mod2fname"); |
---|
1306 | |
---|
1307 | avlen = av_len((AV*)sv); |
---|
1308 | if (avlen < 0) |
---|
1309 | croak("Empty array reference given to mod2fname"); |
---|
1310 | |
---|
1311 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); |
---|
1312 | strncpy(fname, s, 8); |
---|
1313 | len = strlen(s); |
---|
1314 | if (len < 6) pos = len; |
---|
1315 | while (*s) { |
---|
1316 | sum = 33 * sum + *(s++); /* Checksumming first chars to |
---|
1317 | * get the capitalization into c.s. */ |
---|
1318 | } |
---|
1319 | avlen --; |
---|
1320 | while (avlen >= 0) { |
---|
1321 | s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); |
---|
1322 | while (*s) { |
---|
1323 | sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ |
---|
1324 | } |
---|
1325 | avlen --; |
---|
1326 | } |
---|
1327 | #ifdef USE_THREADS |
---|
1328 | sum++; /* Avoid conflict of DLLs in memory. */ |
---|
1329 | #endif |
---|
1330 | sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */ |
---|
1331 | fname[pos] = 'A' + (sum % 26); |
---|
1332 | fname[pos + 1] = 'A' + (sum / 26 % 26); |
---|
1333 | fname[pos + 2] = '\0'; |
---|
1334 | return (char *)fname; |
---|
1335 | } |
---|
1336 | |
---|
1337 | XS(XS_DynaLoader_mod2fname) |
---|
1338 | { |
---|
1339 | dXSARGS; |
---|
1340 | if (items != 1) |
---|
1341 | croak("Usage: DynaLoader::mod2fname(sv)"); |
---|
1342 | { |
---|
1343 | SV * sv = ST(0); |
---|
1344 | char * RETVAL; |
---|
1345 | |
---|
1346 | RETVAL = mod2fname(sv); |
---|
1347 | ST(0) = sv_newmortal(); |
---|
1348 | sv_setpv((SV*)ST(0), RETVAL); |
---|
1349 | } |
---|
1350 | XSRETURN(1); |
---|
1351 | } |
---|
1352 | |
---|
1353 | char * |
---|
1354 | os2error(int rc) |
---|
1355 | { |
---|
1356 | static char buf[300]; |
---|
1357 | ULONG len; |
---|
1358 | |
---|
1359 | if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ |
---|
1360 | if (rc == 0) |
---|
1361 | return NULL; |
---|
1362 | if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len)) |
---|
1363 | sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc); |
---|
1364 | else { |
---|
1365 | buf[len] = '\0'; |
---|
1366 | if (len && buf[len - 1] == '\n') |
---|
1367 | buf[--len] = 0; |
---|
1368 | if (len && buf[len - 1] == '\r') |
---|
1369 | buf[--len] = 0; |
---|
1370 | if (len && buf[len - 1] == '.') |
---|
1371 | buf[--len] = 0; |
---|
1372 | } |
---|
1373 | return buf; |
---|
1374 | } |
---|
1375 | |
---|
1376 | char * |
---|
1377 | os2_execname(void) |
---|
1378 | { |
---|
1379 | char buf[300], *p; |
---|
1380 | |
---|
1381 | if (_execname(buf, sizeof buf) != 0) |
---|
1382 | return PL_origargv[0]; |
---|
1383 | p = buf; |
---|
1384 | while (*p) { |
---|
1385 | if (*p == '\\') |
---|
1386 | *p = '/'; |
---|
1387 | p++; |
---|
1388 | } |
---|
1389 | p = savepv(buf); |
---|
1390 | SAVEFREEPV(p); |
---|
1391 | return p; |
---|
1392 | } |
---|
1393 | |
---|
1394 | char * |
---|
1395 | perllib_mangle(char *s, unsigned int l) |
---|
1396 | { |
---|
1397 | static char *newp, *oldp; |
---|
1398 | static int newl, oldl, notfound; |
---|
1399 | static char ret[STATIC_FILE_LENGTH+1]; |
---|
1400 | |
---|
1401 | if (!newp && !notfound) { |
---|
1402 | newp = getenv("PERLLIB_PREFIX"); |
---|
1403 | if (newp) { |
---|
1404 | char *s; |
---|
1405 | |
---|
1406 | oldp = newp; |
---|
1407 | while (*newp && !isSPACE(*newp) && *newp != ';') { |
---|
1408 | newp++; oldl++; /* Skip digits. */ |
---|
1409 | } |
---|
1410 | while (*newp && (isSPACE(*newp) || *newp == ';')) { |
---|
1411 | newp++; /* Skip whitespace. */ |
---|
1412 | } |
---|
1413 | newl = strlen(newp); |
---|
1414 | if (newl == 0 || oldl == 0) { |
---|
1415 | croak("Malformed PERLLIB_PREFIX"); |
---|
1416 | } |
---|
1417 | strcpy(ret, newp); |
---|
1418 | s = ret; |
---|
1419 | while (*s) { |
---|
1420 | if (*s == '\\') *s = '/'; |
---|
1421 | s++; |
---|
1422 | } |
---|
1423 | } else { |
---|
1424 | notfound = 1; |
---|
1425 | } |
---|
1426 | } |
---|
1427 | if (!newp) { |
---|
1428 | return s; |
---|
1429 | } |
---|
1430 | if (l == 0) { |
---|
1431 | l = strlen(s); |
---|
1432 | } |
---|
1433 | if (l < oldl || strnicmp(oldp, s, oldl) != 0) { |
---|
1434 | return s; |
---|
1435 | } |
---|
1436 | if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { |
---|
1437 | croak("Malformed PERLLIB_PREFIX"); |
---|
1438 | } |
---|
1439 | strcpy(ret + newl, s + oldl); |
---|
1440 | return ret; |
---|
1441 | } |
---|
1442 | |
---|
1443 | unsigned long |
---|
1444 | Perl_hab_GET() /* Needed if perl.h cannot be included */ |
---|
1445 | { |
---|
1446 | return perl_hab_GET(); |
---|
1447 | } |
---|
1448 | |
---|
1449 | HMQ |
---|
1450 | Perl_Register_MQ(int serve) |
---|
1451 | { |
---|
1452 | PPIB pib; |
---|
1453 | PTIB tib; |
---|
1454 | |
---|
1455 | if (Perl_os2_initial_mode++) |
---|
1456 | return Perl_hmq; |
---|
1457 | DosGetInfoBlocks(&tib, &pib); |
---|
1458 | Perl_os2_initial_mode = pib->pib_ultype; |
---|
1459 | Perl_hmq_refcnt = 1; |
---|
1460 | /* Try morphing into a PM application. */ |
---|
1461 | if (pib->pib_ultype != 3) /* 2 is VIO */ |
---|
1462 | pib->pib_ultype = 3; /* 3 is PM */ |
---|
1463 | init_PMWIN_entries(); |
---|
1464 | /* 64 messages if before OS/2 3.0, ignored otherwise */ |
---|
1465 | Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); |
---|
1466 | if (!Perl_hmq) { |
---|
1467 | static int cnt; |
---|
1468 | if (cnt++) |
---|
1469 | _exit(188); /* Panic can try to create a window. */ |
---|
1470 | croak("Cannot create a message queue, or morph to a PM application"); |
---|
1471 | } |
---|
1472 | return Perl_hmq; |
---|
1473 | } |
---|
1474 | |
---|
1475 | int |
---|
1476 | Perl_Serve_Messages(int force) |
---|
1477 | { |
---|
1478 | int cnt = 0; |
---|
1479 | QMSG msg; |
---|
1480 | |
---|
1481 | if (Perl_hmq_servers && !force) |
---|
1482 | return 0; |
---|
1483 | if (!Perl_hmq_refcnt) |
---|
1484 | croak("No message queue"); |
---|
1485 | while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { |
---|
1486 | cnt++; |
---|
1487 | if (msg.msg == WM_QUIT) |
---|
1488 | croak("QUITing..."); |
---|
1489 | (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); |
---|
1490 | } |
---|
1491 | return cnt; |
---|
1492 | } |
---|
1493 | |
---|
1494 | int |
---|
1495 | Perl_Process_Messages(int force, I32 *cntp) |
---|
1496 | { |
---|
1497 | QMSG msg; |
---|
1498 | |
---|
1499 | if (Perl_hmq_servers && !force) |
---|
1500 | return 0; |
---|
1501 | if (!Perl_hmq_refcnt) |
---|
1502 | croak("No message queue"); |
---|
1503 | while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { |
---|
1504 | if (cntp) |
---|
1505 | (*cntp)++; |
---|
1506 | (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); |
---|
1507 | if (msg.msg == WM_DESTROY) |
---|
1508 | return -1; |
---|
1509 | if (msg.msg == WM_CREATE) |
---|
1510 | return +1; |
---|
1511 | } |
---|
1512 | croak("QUITing..."); |
---|
1513 | } |
---|
1514 | |
---|
1515 | void |
---|
1516 | Perl_Deregister_MQ(int serve) |
---|
1517 | { |
---|
1518 | PPIB pib; |
---|
1519 | PTIB tib; |
---|
1520 | |
---|
1521 | if (--Perl_hmq_refcnt == 0) { |
---|
1522 | (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); |
---|
1523 | Perl_hmq = 0; |
---|
1524 | /* Try morphing back from a PM application. */ |
---|
1525 | if (pib->pib_ultype == 3) /* 3 is PM */ |
---|
1526 | pib->pib_ultype = Perl_os2_initial_mode; |
---|
1527 | else |
---|
1528 | warn("Unexpected program mode %d when morphing back from PM", |
---|
1529 | pib->pib_ultype); |
---|
1530 | } |
---|
1531 | } |
---|
1532 | |
---|
1533 | extern void dlopen(); |
---|
1534 | void *fakedl = &dlopen; /* Pull in dynaloading part. */ |
---|
1535 | |
---|
1536 | #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ |
---|
1537 | && ((path)[2] == '/' || (path)[2] == '\\')) |
---|
1538 | #define sys_is_rooted _fnisabs |
---|
1539 | #define sys_is_relative _fnisrel |
---|
1540 | #define current_drive _getdrive |
---|
1541 | |
---|
1542 | #undef chdir /* Was _chdir2. */ |
---|
1543 | #define sys_chdir(p) (chdir(p) == 0) |
---|
1544 | #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d))) |
---|
1545 | |
---|
1546 | static int DOS_harderr_state = -1; |
---|
1547 | |
---|
1548 | XS(XS_OS2_Error) |
---|
1549 | { |
---|
1550 | dXSARGS; |
---|
1551 | if (items != 2) |
---|
1552 | croak("Usage: OS2::Error(harderr, exception)"); |
---|
1553 | { |
---|
1554 | int arg1 = SvIV(ST(0)); |
---|
1555 | int arg2 = SvIV(ST(1)); |
---|
1556 | int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) |
---|
1557 | | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); |
---|
1558 | int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); |
---|
1559 | unsigned long rc; |
---|
1560 | |
---|
1561 | if (CheckOSError(DosError(a))) |
---|
1562 | croak("DosError(%d) failed", a); |
---|
1563 | ST(0) = sv_newmortal(); |
---|
1564 | if (DOS_harderr_state >= 0) |
---|
1565 | sv_setiv(ST(0), DOS_harderr_state); |
---|
1566 | DOS_harderr_state = RETVAL; |
---|
1567 | } |
---|
1568 | XSRETURN(1); |
---|
1569 | } |
---|
1570 | |
---|
1571 | static signed char DOS_suppression_state = -1; |
---|
1572 | |
---|
1573 | XS(XS_OS2_Errors2Drive) |
---|
1574 | { |
---|
1575 | dXSARGS; |
---|
1576 | if (items != 1) |
---|
1577 | croak("Usage: OS2::Errors2Drive(drive)"); |
---|
1578 | { |
---|
1579 | STRLEN n_a; |
---|
1580 | SV *sv = ST(0); |
---|
1581 | int suppress = SvOK(sv); |
---|
1582 | char *s = suppress ? SvPV(sv, n_a) : NULL; |
---|
1583 | char drive = (s ? *s : 0); |
---|
1584 | unsigned long rc; |
---|
1585 | |
---|
1586 | if (suppress && !isALPHA(drive)) |
---|
1587 | croak("Non-char argument '%c' to OS2::Errors2Drive()", drive); |
---|
1588 | if (CheckOSError(DosSuppressPopUps((suppress |
---|
1589 | ? SPU_ENABLESUPPRESSION |
---|
1590 | : SPU_DISABLESUPPRESSION), |
---|
1591 | drive))) |
---|
1592 | croak("DosSuppressPopUps(%c) failed", drive); |
---|
1593 | ST(0) = sv_newmortal(); |
---|
1594 | if (DOS_suppression_state > 0) |
---|
1595 | sv_setpvn(ST(0), &DOS_suppression_state, 1); |
---|
1596 | else if (DOS_suppression_state == 0) |
---|
1597 | sv_setpvn(ST(0), "", 0); |
---|
1598 | DOS_suppression_state = drive; |
---|
1599 | } |
---|
1600 | XSRETURN(1); |
---|
1601 | } |
---|
1602 | |
---|
1603 | static const char * const si_fields[QSV_MAX] = { |
---|
1604 | "MAX_PATH_LENGTH", |
---|
1605 | "MAX_TEXT_SESSIONS", |
---|
1606 | "MAX_PM_SESSIONS", |
---|
1607 | "MAX_VDM_SESSIONS", |
---|
1608 | "BOOT_DRIVE", |
---|
1609 | "DYN_PRI_VARIATION", |
---|
1610 | "MAX_WAIT", |
---|
1611 | "MIN_SLICE", |
---|
1612 | "MAX_SLICE", |
---|
1613 | "PAGE_SIZE", |
---|
1614 | "VERSION_MAJOR", |
---|
1615 | "VERSION_MINOR", |
---|
1616 | "VERSION_REVISION", |
---|
1617 | "MS_COUNT", |
---|
1618 | "TIME_LOW", |
---|
1619 | "TIME_HIGH", |
---|
1620 | "TOTPHYSMEM", |
---|
1621 | "TOTRESMEM", |
---|
1622 | "TOTAVAILMEM", |
---|
1623 | "MAXPRMEM", |
---|
1624 | "MAXSHMEM", |
---|
1625 | "TIMER_INTERVAL", |
---|
1626 | "MAX_COMP_LENGTH", |
---|
1627 | "FOREGROUND_FS_SESSION", |
---|
1628 | "FOREGROUND_PROCESS" |
---|
1629 | }; |
---|
1630 | |
---|
1631 | XS(XS_OS2_SysInfo) |
---|
1632 | { |
---|
1633 | dXSARGS; |
---|
1634 | if (items != 0) |
---|
1635 | croak("Usage: OS2::SysInfo()"); |
---|
1636 | { |
---|
1637 | ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */ |
---|
1638 | APIRET rc = NO_ERROR; /* Return code */ |
---|
1639 | int i = 0, j = 0; |
---|
1640 | |
---|
1641 | if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */ |
---|
1642 | QSV_MAX, /* information */ |
---|
1643 | (PVOID)si, |
---|
1644 | sizeof(si)))) |
---|
1645 | croak("DosQuerySysInfo() failed"); |
---|
1646 | EXTEND(SP,2*QSV_MAX); |
---|
1647 | while (i < QSV_MAX) { |
---|
1648 | ST(j) = sv_newmortal(); |
---|
1649 | sv_setpv(ST(j++), si_fields[i]); |
---|
1650 | ST(j) = sv_newmortal(); |
---|
1651 | sv_setiv(ST(j++), si[i]); |
---|
1652 | i++; |
---|
1653 | } |
---|
1654 | } |
---|
1655 | XSRETURN(2 * QSV_MAX); |
---|
1656 | } |
---|
1657 | |
---|
1658 | XS(XS_OS2_BootDrive) |
---|
1659 | { |
---|
1660 | dXSARGS; |
---|
1661 | if (items != 0) |
---|
1662 | croak("Usage: OS2::BootDrive()"); |
---|
1663 | { |
---|
1664 | ULONG si[1] = {0}; /* System Information Data Buffer */ |
---|
1665 | APIRET rc = NO_ERROR; /* Return code */ |
---|
1666 | char c; |
---|
1667 | |
---|
1668 | if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, |
---|
1669 | (PVOID)si, sizeof(si)))) |
---|
1670 | croak("DosQuerySysInfo() failed"); |
---|
1671 | ST(0) = sv_newmortal(); |
---|
1672 | c = 'a' - 1 + si[0]; |
---|
1673 | sv_setpvn(ST(0), &c, 1); |
---|
1674 | } |
---|
1675 | XSRETURN(1); |
---|
1676 | } |
---|
1677 | |
---|
1678 | XS(XS_OS2_MorphPM) |
---|
1679 | { |
---|
1680 | dXSARGS; |
---|
1681 | if (items != 1) |
---|
1682 | croak("Usage: OS2::MorphPM(serve)"); |
---|
1683 | { |
---|
1684 | bool serve = SvOK(ST(0)); |
---|
1685 | unsigned long pmq = perl_hmq_GET(serve); |
---|
1686 | |
---|
1687 | ST(0) = sv_newmortal(); |
---|
1688 | sv_setiv(ST(0), pmq); |
---|
1689 | } |
---|
1690 | XSRETURN(1); |
---|
1691 | } |
---|
1692 | |
---|
1693 | XS(XS_OS2_UnMorphPM) |
---|
1694 | { |
---|
1695 | dXSARGS; |
---|
1696 | if (items != 1) |
---|
1697 | croak("Usage: OS2::UnMorphPM(serve)"); |
---|
1698 | { |
---|
1699 | bool serve = SvOK(ST(0)); |
---|
1700 | |
---|
1701 | perl_hmq_UNSET(serve); |
---|
1702 | } |
---|
1703 | XSRETURN(0); |
---|
1704 | } |
---|
1705 | |
---|
1706 | XS(XS_OS2_Serve_Messages) |
---|
1707 | { |
---|
1708 | dXSARGS; |
---|
1709 | if (items != 1) |
---|
1710 | croak("Usage: OS2::Serve_Messages(force)"); |
---|
1711 | { |
---|
1712 | bool force = SvOK(ST(0)); |
---|
1713 | unsigned long cnt = Perl_Serve_Messages(force); |
---|
1714 | |
---|
1715 | ST(0) = sv_newmortal(); |
---|
1716 | sv_setiv(ST(0), cnt); |
---|
1717 | } |
---|
1718 | XSRETURN(1); |
---|
1719 | } |
---|
1720 | |
---|
1721 | XS(XS_OS2_Process_Messages) |
---|
1722 | { |
---|
1723 | dXSARGS; |
---|
1724 | if (items < 1 || items > 2) |
---|
1725 | croak("Usage: OS2::Process_Messages(force [, cnt])"); |
---|
1726 | { |
---|
1727 | bool force = SvOK(ST(0)); |
---|
1728 | unsigned long cnt; |
---|
1729 | I32 *cntp = NULL; |
---|
1730 | |
---|
1731 | if (items == 2) { |
---|
1732 | SV *sv = ST(1); |
---|
1733 | int fake = SvIV(sv); /* Force SvIVX */ |
---|
1734 | |
---|
1735 | if (!SvIOK(sv)) |
---|
1736 | croak("Can't upgrade count to IV"); |
---|
1737 | cntp = &SvIVX(sv); |
---|
1738 | } |
---|
1739 | cnt = Perl_Process_Messages(force, cntp); |
---|
1740 | ST(0) = sv_newmortal(); |
---|
1741 | sv_setiv(ST(0), cnt); |
---|
1742 | } |
---|
1743 | XSRETURN(1); |
---|
1744 | } |
---|
1745 | |
---|
1746 | XS(XS_Cwd_current_drive) |
---|
1747 | { |
---|
1748 | dXSARGS; |
---|
1749 | if (items != 0) |
---|
1750 | croak("Usage: Cwd::current_drive()"); |
---|
1751 | { |
---|
1752 | char RETVAL; |
---|
1753 | |
---|
1754 | RETVAL = current_drive(); |
---|
1755 | ST(0) = sv_newmortal(); |
---|
1756 | sv_setpvn(ST(0), (char *)&RETVAL, 1); |
---|
1757 | } |
---|
1758 | XSRETURN(1); |
---|
1759 | } |
---|
1760 | |
---|
1761 | XS(XS_Cwd_sys_chdir) |
---|
1762 | { |
---|
1763 | dXSARGS; |
---|
1764 | if (items != 1) |
---|
1765 | croak("Usage: Cwd::sys_chdir(path)"); |
---|
1766 | { |
---|
1767 | STRLEN n_a; |
---|
1768 | char * path = (char *)SvPV(ST(0),n_a); |
---|
1769 | bool RETVAL; |
---|
1770 | |
---|
1771 | RETVAL = sys_chdir(path); |
---|
1772 | ST(0) = boolSV(RETVAL); |
---|
1773 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
1774 | } |
---|
1775 | XSRETURN(1); |
---|
1776 | } |
---|
1777 | |
---|
1778 | XS(XS_Cwd_change_drive) |
---|
1779 | { |
---|
1780 | dXSARGS; |
---|
1781 | if (items != 1) |
---|
1782 | croak("Usage: Cwd::change_drive(d)"); |
---|
1783 | { |
---|
1784 | STRLEN n_a; |
---|
1785 | char d = (char)*SvPV(ST(0),n_a); |
---|
1786 | bool RETVAL; |
---|
1787 | |
---|
1788 | RETVAL = change_drive(d); |
---|
1789 | ST(0) = boolSV(RETVAL); |
---|
1790 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
1791 | } |
---|
1792 | XSRETURN(1); |
---|
1793 | } |
---|
1794 | |
---|
1795 | XS(XS_Cwd_sys_is_absolute) |
---|
1796 | { |
---|
1797 | dXSARGS; |
---|
1798 | if (items != 1) |
---|
1799 | croak("Usage: Cwd::sys_is_absolute(path)"); |
---|
1800 | { |
---|
1801 | STRLEN n_a; |
---|
1802 | char * path = (char *)SvPV(ST(0),n_a); |
---|
1803 | bool RETVAL; |
---|
1804 | |
---|
1805 | RETVAL = sys_is_absolute(path); |
---|
1806 | ST(0) = boolSV(RETVAL); |
---|
1807 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
1808 | } |
---|
1809 | XSRETURN(1); |
---|
1810 | } |
---|
1811 | |
---|
1812 | XS(XS_Cwd_sys_is_rooted) |
---|
1813 | { |
---|
1814 | dXSARGS; |
---|
1815 | if (items != 1) |
---|
1816 | croak("Usage: Cwd::sys_is_rooted(path)"); |
---|
1817 | { |
---|
1818 | STRLEN n_a; |
---|
1819 | char * path = (char *)SvPV(ST(0),n_a); |
---|
1820 | bool RETVAL; |
---|
1821 | |
---|
1822 | RETVAL = sys_is_rooted(path); |
---|
1823 | ST(0) = boolSV(RETVAL); |
---|
1824 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
1825 | } |
---|
1826 | XSRETURN(1); |
---|
1827 | } |
---|
1828 | |
---|
1829 | XS(XS_Cwd_sys_is_relative) |
---|
1830 | { |
---|
1831 | dXSARGS; |
---|
1832 | if (items != 1) |
---|
1833 | croak("Usage: Cwd::sys_is_relative(path)"); |
---|
1834 | { |
---|
1835 | STRLEN n_a; |
---|
1836 | char * path = (char *)SvPV(ST(0),n_a); |
---|
1837 | bool RETVAL; |
---|
1838 | |
---|
1839 | RETVAL = sys_is_relative(path); |
---|
1840 | ST(0) = boolSV(RETVAL); |
---|
1841 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
1842 | } |
---|
1843 | XSRETURN(1); |
---|
1844 | } |
---|
1845 | |
---|
1846 | XS(XS_Cwd_sys_cwd) |
---|
1847 | { |
---|
1848 | dXSARGS; |
---|
1849 | if (items != 0) |
---|
1850 | croak("Usage: Cwd::sys_cwd()"); |
---|
1851 | { |
---|
1852 | char p[MAXPATHLEN]; |
---|
1853 | char * RETVAL; |
---|
1854 | RETVAL = _getcwd2(p, MAXPATHLEN); |
---|
1855 | ST(0) = sv_newmortal(); |
---|
1856 | sv_setpv((SV*)ST(0), RETVAL); |
---|
1857 | } |
---|
1858 | XSRETURN(1); |
---|
1859 | } |
---|
1860 | |
---|
1861 | XS(XS_Cwd_sys_abspath) |
---|
1862 | { |
---|
1863 | dXSARGS; |
---|
1864 | if (items < 1 || items > 2) |
---|
1865 | croak("Usage: Cwd::sys_abspath(path, dir = NULL)"); |
---|
1866 | { |
---|
1867 | STRLEN n_a; |
---|
1868 | char * path = (char *)SvPV(ST(0),n_a); |
---|
1869 | char * dir; |
---|
1870 | char p[MAXPATHLEN]; |
---|
1871 | char * RETVAL; |
---|
1872 | |
---|
1873 | if (items < 2) |
---|
1874 | dir = NULL; |
---|
1875 | else { |
---|
1876 | dir = (char *)SvPV(ST(1),n_a); |
---|
1877 | } |
---|
1878 | if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { |
---|
1879 | path += 2; |
---|
1880 | } |
---|
1881 | if (dir == NULL) { |
---|
1882 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
---|
1883 | RETVAL = p; |
---|
1884 | } else { |
---|
1885 | RETVAL = NULL; |
---|
1886 | } |
---|
1887 | } else { |
---|
1888 | /* Absolute with drive: */ |
---|
1889 | if ( sys_is_absolute(path) ) { |
---|
1890 | if (_abspath(p, path, MAXPATHLEN) == 0) { |
---|
1891 | RETVAL = p; |
---|
1892 | } else { |
---|
1893 | RETVAL = NULL; |
---|
1894 | } |
---|
1895 | } else if (path[0] == '/' || path[0] == '\\') { |
---|
1896 | /* Rooted, but maybe on different drive. */ |
---|
1897 | if (isALPHA(dir[0]) && dir[1] == ':' ) { |
---|
1898 | char p1[MAXPATHLEN]; |
---|
1899 | |
---|
1900 | /* Need to prepend the drive. */ |
---|
1901 | p1[0] = dir[0]; |
---|
1902 | p1[1] = dir[1]; |
---|
1903 | Copy(path, p1 + 2, strlen(path) + 1, char); |
---|
1904 | RETVAL = p; |
---|
1905 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
---|
1906 | RETVAL = p; |
---|
1907 | } else { |
---|
1908 | RETVAL = NULL; |
---|
1909 | } |
---|
1910 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
---|
1911 | RETVAL = p; |
---|
1912 | } else { |
---|
1913 | RETVAL = NULL; |
---|
1914 | } |
---|
1915 | } else { |
---|
1916 | /* Either path is relative, or starts with a drive letter. */ |
---|
1917 | /* If the path starts with a drive letter, then dir is |
---|
1918 | relevant only if |
---|
1919 | a/b) it is absolute/x:relative on the same drive. |
---|
1920 | c) path is on current drive, and dir is rooted |
---|
1921 | In all the cases it is safe to drop the drive part |
---|
1922 | of the path. */ |
---|
1923 | if ( !sys_is_relative(path) ) { |
---|
1924 | int is_drived; |
---|
1925 | |
---|
1926 | if ( ( ( sys_is_absolute(dir) |
---|
1927 | || (isALPHA(dir[0]) && dir[1] == ':' |
---|
1928 | && strnicmp(dir, path,1) == 0)) |
---|
1929 | && strnicmp(dir, path,1) == 0) |
---|
1930 | || ( !(isALPHA(dir[0]) && dir[1] == ':') |
---|
1931 | && toupper(path[0]) == current_drive())) { |
---|
1932 | path += 2; |
---|
1933 | } else if (_abspath(p, path, MAXPATHLEN) == 0) { |
---|
1934 | RETVAL = p; goto done; |
---|
1935 | } else { |
---|
1936 | RETVAL = NULL; goto done; |
---|
1937 | } |
---|
1938 | } |
---|
1939 | { |
---|
1940 | /* Need to prepend the absolute path of dir. */ |
---|
1941 | char p1[MAXPATHLEN]; |
---|
1942 | |
---|
1943 | if (_abspath(p1, dir, MAXPATHLEN) == 0) { |
---|
1944 | int l = strlen(p1); |
---|
1945 | |
---|
1946 | if (p1[ l - 1 ] != '/') { |
---|
1947 | p1[ l ] = '/'; |
---|
1948 | l++; |
---|
1949 | } |
---|
1950 | Copy(path, p1 + l, strlen(path) + 1, char); |
---|
1951 | if (_abspath(p, p1, MAXPATHLEN) == 0) { |
---|
1952 | RETVAL = p; |
---|
1953 | } else { |
---|
1954 | RETVAL = NULL; |
---|
1955 | } |
---|
1956 | } else { |
---|
1957 | RETVAL = NULL; |
---|
1958 | } |
---|
1959 | } |
---|
1960 | done: |
---|
1961 | } |
---|
1962 | } |
---|
1963 | ST(0) = sv_newmortal(); |
---|
1964 | sv_setpv((SV*)ST(0), RETVAL); |
---|
1965 | } |
---|
1966 | XSRETURN(1); |
---|
1967 | } |
---|
1968 | typedef APIRET (*PELP)(PSZ path, ULONG type); |
---|
1969 | |
---|
1970 | APIRET |
---|
1971 | ExtLIBPATH(ULONG ord, PSZ path, ULONG type) |
---|
1972 | { |
---|
1973 | loadByOrd("doscalls",ord); /* Guarantied to load or die! */ |
---|
1974 | return (*(PELP)ExtFCN[ord])(path, type); |
---|
1975 | } |
---|
1976 | |
---|
1977 | #define extLibpath(type) \ |
---|
1978 | (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \ |
---|
1979 | : BEGIN_LIBPATH))) \ |
---|
1980 | ? NULL : to ) |
---|
1981 | |
---|
1982 | #define extLibpath_set(p,type) \ |
---|
1983 | (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \ |
---|
1984 | : BEGIN_LIBPATH)))) |
---|
1985 | |
---|
1986 | XS(XS_Cwd_extLibpath) |
---|
1987 | { |
---|
1988 | dXSARGS; |
---|
1989 | if (items < 0 || items > 1) |
---|
1990 | croak("Usage: Cwd::extLibpath(type = 0)"); |
---|
1991 | { |
---|
1992 | bool type; |
---|
1993 | char to[1024]; |
---|
1994 | U32 rc; |
---|
1995 | char * RETVAL; |
---|
1996 | |
---|
1997 | if (items < 1) |
---|
1998 | type = 0; |
---|
1999 | else { |
---|
2000 | type = (int)SvIV(ST(0)); |
---|
2001 | } |
---|
2002 | |
---|
2003 | RETVAL = extLibpath(type); |
---|
2004 | ST(0) = sv_newmortal(); |
---|
2005 | sv_setpv((SV*)ST(0), RETVAL); |
---|
2006 | } |
---|
2007 | XSRETURN(1); |
---|
2008 | } |
---|
2009 | |
---|
2010 | XS(XS_Cwd_extLibpath_set) |
---|
2011 | { |
---|
2012 | dXSARGS; |
---|
2013 | if (items < 1 || items > 2) |
---|
2014 | croak("Usage: Cwd::extLibpath_set(s, type = 0)"); |
---|
2015 | { |
---|
2016 | STRLEN n_a; |
---|
2017 | char * s = (char *)SvPV(ST(0),n_a); |
---|
2018 | bool type; |
---|
2019 | U32 rc; |
---|
2020 | bool RETVAL; |
---|
2021 | |
---|
2022 | if (items < 2) |
---|
2023 | type = 0; |
---|
2024 | else { |
---|
2025 | type = (int)SvIV(ST(1)); |
---|
2026 | } |
---|
2027 | |
---|
2028 | RETVAL = extLibpath_set(s, type); |
---|
2029 | ST(0) = boolSV(RETVAL); |
---|
2030 | if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); |
---|
2031 | } |
---|
2032 | XSRETURN(1); |
---|
2033 | } |
---|
2034 | |
---|
2035 | int |
---|
2036 | Xs_OS2_init() |
---|
2037 | { |
---|
2038 | char *file = __FILE__; |
---|
2039 | { |
---|
2040 | GV *gv; |
---|
2041 | |
---|
2042 | if (_emx_env & 0x200) { /* OS/2 */ |
---|
2043 | newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); |
---|
2044 | newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); |
---|
2045 | newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); |
---|
2046 | } |
---|
2047 | newXS("OS2::Error", XS_OS2_Error, file); |
---|
2048 | newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); |
---|
2049 | newXS("OS2::SysInfo", XS_OS2_SysInfo, file); |
---|
2050 | newXS("OS2::BootDrive", XS_OS2_BootDrive, file); |
---|
2051 | newXS("OS2::MorphPM", XS_OS2_MorphPM, file); |
---|
2052 | newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file); |
---|
2053 | newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file); |
---|
2054 | newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file); |
---|
2055 | newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); |
---|
2056 | newXS("Cwd::current_drive", XS_Cwd_current_drive, file); |
---|
2057 | newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file); |
---|
2058 | newXS("Cwd::change_drive", XS_Cwd_change_drive, file); |
---|
2059 | newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file); |
---|
2060 | newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file); |
---|
2061 | newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file); |
---|
2062 | newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file); |
---|
2063 | newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file); |
---|
2064 | gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); |
---|
2065 | GvMULTI_on(gv); |
---|
2066 | #ifdef PERL_IS_AOUT |
---|
2067 | sv_setiv(GvSV(gv), 1); |
---|
2068 | #endif |
---|
2069 | gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); |
---|
2070 | GvMULTI_on(gv); |
---|
2071 | sv_setiv(GvSV(gv), _emx_rev); |
---|
2072 | sv_setpv(GvSV(gv), _emx_vprt); |
---|
2073 | SvIOK_on(GvSV(gv)); |
---|
2074 | gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); |
---|
2075 | GvMULTI_on(gv); |
---|
2076 | sv_setiv(GvSV(gv), _emx_env); |
---|
2077 | gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); |
---|
2078 | GvMULTI_on(gv); |
---|
2079 | sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); |
---|
2080 | } |
---|
2081 | } |
---|
2082 | |
---|
2083 | OS2_Perl_data_t OS2_Perl_data; |
---|
2084 | |
---|
2085 | void |
---|
2086 | Perl_OS2_init(char **env) |
---|
2087 | { |
---|
2088 | char *shell; |
---|
2089 | |
---|
2090 | MALLOC_INIT; |
---|
2091 | settmppath(); |
---|
2092 | OS2_Perl_data.xs_init = &Xs_OS2_init; |
---|
2093 | _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY); |
---|
2094 | if (environ == NULL && env) { |
---|
2095 | environ = env; |
---|
2096 | } |
---|
2097 | if ( (shell = getenv("PERL_SH_DRIVE")) ) { |
---|
2098 | New(1304, PL_sh_path, strlen(SH_PATH) + 1, char); |
---|
2099 | strcpy(PL_sh_path, SH_PATH); |
---|
2100 | PL_sh_path[0] = shell[0]; |
---|
2101 | } else if ( (shell = getenv("PERL_SH_DIR")) ) { |
---|
2102 | int l = strlen(shell), i; |
---|
2103 | if (shell[l-1] == '/' || shell[l-1] == '\\') { |
---|
2104 | l--; |
---|
2105 | } |
---|
2106 | New(1304, PL_sh_path, l + 8, char); |
---|
2107 | strncpy(PL_sh_path, shell, l); |
---|
2108 | strcpy(PL_sh_path + l, "/sh.exe"); |
---|
2109 | for (i = 0; i < l; i++) { |
---|
2110 | if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; |
---|
2111 | } |
---|
2112 | } |
---|
2113 | MUTEX_INIT(&start_thread_mutex); |
---|
2114 | os2_mytype = my_type(); /* Do it before morphing. Needed? */ |
---|
2115 | } |
---|
2116 | |
---|
2117 | #undef tmpnam |
---|
2118 | #undef tmpfile |
---|
2119 | |
---|
2120 | char * |
---|
2121 | my_tmpnam (char *str) |
---|
2122 | { |
---|
2123 | char *p = getenv("TMP"), *tpath; |
---|
2124 | int len; |
---|
2125 | |
---|
2126 | if (!p) p = getenv("TEMP"); |
---|
2127 | tpath = tempnam(p, "pltmp"); |
---|
2128 | if (str && tpath) { |
---|
2129 | strcpy(str, tpath); |
---|
2130 | return str; |
---|
2131 | } |
---|
2132 | return tpath; |
---|
2133 | } |
---|
2134 | |
---|
2135 | FILE * |
---|
2136 | my_tmpfile () |
---|
2137 | { |
---|
2138 | struct stat s; |
---|
2139 | |
---|
2140 | stat(".", &s); |
---|
2141 | if (s.st_mode & S_IWOTH) { |
---|
2142 | return tmpfile(); |
---|
2143 | } |
---|
2144 | return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but |
---|
2145 | grants TMP. */ |
---|
2146 | } |
---|
2147 | |
---|
2148 | #undef flock |
---|
2149 | |
---|
2150 | /* This code was contributed by Rocco Caputo. */ |
---|
2151 | int |
---|
2152 | my_flock(int handle, int o) |
---|
2153 | { |
---|
2154 | FILELOCK rNull, rFull; |
---|
2155 | ULONG timeout, handle_type, flag_word; |
---|
2156 | APIRET rc; |
---|
2157 | int blocking, shared; |
---|
2158 | static int use_my = -1; |
---|
2159 | |
---|
2160 | if (use_my == -1) { |
---|
2161 | char *s = getenv("USE_PERL_FLOCK"); |
---|
2162 | if (s) |
---|
2163 | use_my = atoi(s); |
---|
2164 | else |
---|
2165 | use_my = 1; |
---|
2166 | } |
---|
2167 | if (!(_emx_env & 0x200) || !use_my) |
---|
2168 | return flock(handle, o); /* Delegate to EMX. */ |
---|
2169 | |
---|
2170 | // is this a file? |
---|
2171 | if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) || |
---|
2172 | (handle_type & 0xFF)) |
---|
2173 | { |
---|
2174 | errno = EBADF; |
---|
2175 | return -1; |
---|
2176 | } |
---|
2177 | // set lock/unlock ranges |
---|
2178 | rNull.lOffset = rNull.lRange = rFull.lOffset = 0; |
---|
2179 | rFull.lRange = 0x7FFFFFFF; |
---|
2180 | // set timeout for blocking |
---|
2181 | timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1; |
---|
2182 | // shared or exclusive? |
---|
2183 | shared = (o & LOCK_SH) ? 1 : 0; |
---|
2184 | // do not block the unlock |
---|
2185 | if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) { |
---|
2186 | rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared); |
---|
2187 | switch (rc) { |
---|
2188 | case 0: |
---|
2189 | errno = 0; |
---|
2190 | return 0; |
---|
2191 | case ERROR_INVALID_HANDLE: |
---|
2192 | errno = EBADF; |
---|
2193 | return -1; |
---|
2194 | case ERROR_SHARING_BUFFER_EXCEEDED: |
---|
2195 | errno = ENOLCK; |
---|
2196 | return -1; |
---|
2197 | case ERROR_LOCK_VIOLATION: |
---|
2198 | break; // not an error |
---|
2199 | case ERROR_INVALID_PARAMETER: |
---|
2200 | case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: |
---|
2201 | case ERROR_READ_LOCKS_NOT_SUPPORTED: |
---|
2202 | errno = EINVAL; |
---|
2203 | return -1; |
---|
2204 | case ERROR_INTERRUPT: |
---|
2205 | errno = EINTR; |
---|
2206 | return -1; |
---|
2207 | default: |
---|
2208 | errno = EINVAL; |
---|
2209 | return -1; |
---|
2210 | } |
---|
2211 | } |
---|
2212 | // lock may block |
---|
2213 | if (o & (LOCK_SH | LOCK_EX)) { |
---|
2214 | // for blocking operations |
---|
2215 | for (;;) { |
---|
2216 | rc = |
---|
2217 | DosSetFileLocks( |
---|
2218 | handle, |
---|
2219 | &rNull, |
---|
2220 | &rFull, |
---|
2221 | timeout, |
---|
2222 | shared |
---|
2223 | ); |
---|
2224 | switch (rc) { |
---|
2225 | case 0: |
---|
2226 | errno = 0; |
---|
2227 | return 0; |
---|
2228 | case ERROR_INVALID_HANDLE: |
---|
2229 | errno = EBADF; |
---|
2230 | return -1; |
---|
2231 | case ERROR_SHARING_BUFFER_EXCEEDED: |
---|
2232 | errno = ENOLCK; |
---|
2233 | return -1; |
---|
2234 | case ERROR_LOCK_VIOLATION: |
---|
2235 | if (!blocking) { |
---|
2236 | errno = EWOULDBLOCK; |
---|
2237 | return -1; |
---|
2238 | } |
---|
2239 | break; |
---|
2240 | case ERROR_INVALID_PARAMETER: |
---|
2241 | case ERROR_ATOMIC_LOCK_NOT_SUPPORTED: |
---|
2242 | case ERROR_READ_LOCKS_NOT_SUPPORTED: |
---|
2243 | errno = EINVAL; |
---|
2244 | return -1; |
---|
2245 | case ERROR_INTERRUPT: |
---|
2246 | errno = EINTR; |
---|
2247 | return -1; |
---|
2248 | default: |
---|
2249 | errno = EINVAL; |
---|
2250 | return -1; |
---|
2251 | } |
---|
2252 | // give away timeslice |
---|
2253 | DosSleep(1); |
---|
2254 | } |
---|
2255 | } |
---|
2256 | |
---|
2257 | errno = 0; |
---|
2258 | return 0; |
---|
2259 | } |
---|