3 #define INCL_DOSFILEMGR
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
13 #include <sys/uflags.h>
16 * Various Unix compatibility functions for OS/2
25 #define PERLIO_NOT_STDIO 0
32 typedef void (*emx_startroutine)(void *);
33 typedef void* (*pthreads_startroutine)(void *);
42 const char *pthreads_states[] = {
53 enum pthreads_state state;
56 thread_join_t *thread_join_data;
57 int thread_join_count;
58 perl_mutex start_thread_mutex;
61 pthread_join(perl_os_thread tid, void **status)
63 MUTEX_LOCK(&start_thread_mutex);
64 switch (thread_join_data[tid].state) {
65 case pthreads_st_exited:
66 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
67 MUTEX_UNLOCK(&start_thread_mutex);
68 *status = thread_join_data[tid].status;
70 case pthreads_st_waited:
71 MUTEX_UNLOCK(&start_thread_mutex);
72 Perl_croak_nocontext("join with a thread with a waiter");
75 thread_join_data[tid].state = pthreads_st_waited;
76 COND_INIT(&thread_join_data[tid].cond);
77 MUTEX_UNLOCK(&start_thread_mutex);
78 COND_WAIT(&thread_join_data[tid].cond, NULL);
79 COND_DESTROY(&thread_join_data[tid].cond);
80 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
81 *status = thread_join_data[tid].status;
84 MUTEX_UNLOCK(&start_thread_mutex);
85 Perl_croak_nocontext("join: unknown thread state: '%s'",
86 pthreads_states[thread_join_data[tid].state]);
93 pthread_startit(void *arg)
95 /* Thread is already started, we need to transfer control only */
96 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
97 int tid = pthread_self();
100 arg = ((void**)arg)[1];
101 if (tid >= thread_join_count) {
102 int oc = thread_join_count;
104 thread_join_count = tid + 5 + tid/5;
105 if (thread_join_data) {
106 Renew(thread_join_data, thread_join_count, thread_join_t);
107 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
109 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
112 if (thread_join_data[tid].state != pthreads_st_none)
113 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
114 thread_join_data[tid].state = pthreads_st_run;
115 /* Now that we copied/updated the guys, we may release the caller... */
116 MUTEX_UNLOCK(&start_thread_mutex);
117 thread_join_data[tid].status = (*start_routine)(arg);
118 switch (thread_join_data[tid].state) {
119 case pthreads_st_waited:
120 COND_SIGNAL(&thread_join_data[tid].cond);
123 thread_join_data[tid].state = pthreads_st_exited;
129 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
130 void *(*start_routine)(void*), void *arg)
134 args[0] = (void*)start_routine;
137 MUTEX_LOCK(&start_thread_mutex);
138 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
139 /*stacksize*/ 10*1024*1024, (void*)args);
140 MUTEX_LOCK(&start_thread_mutex);
141 MUTEX_UNLOCK(&start_thread_mutex);
142 return *tid ? 0 : EINVAL;
146 pthread_detach(perl_os_thread tid)
148 MUTEX_LOCK(&start_thread_mutex);
149 switch (thread_join_data[tid].state) {
150 case pthreads_st_waited:
151 MUTEX_UNLOCK(&start_thread_mutex);
152 Perl_croak_nocontext("detach on a thread with a waiter");
154 case pthreads_st_run:
155 thread_join_data[tid].state = pthreads_st_detached;
156 MUTEX_UNLOCK(&start_thread_mutex);
159 MUTEX_UNLOCK(&start_thread_mutex);
160 Perl_croak_nocontext("detach: unknown thread state: '%s'",
161 pthreads_states[thread_join_data[tid].state]);
167 /* This is a very bastardized version: */
169 os2_cond_wait(perl_cond *c, perl_mutex *m)
173 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
174 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
175 if (m) MUTEX_UNLOCK(m);
176 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
177 && (rc != ERROR_INTERRUPT))
178 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
179 if (rc == ERROR_INTERRUPT)
181 if (m) MUTEX_LOCK(m);
185 /*****************************************************************************/
186 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
187 static PFN ExtFCN[2]; /* Labeled by ord below. */
188 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
189 #define ORD_QUERY_ELP 0
190 #define ORD_SET_ELP 1
191 struct PMWIN_entries_t PMWIN_entries;
194 loadModule(char *modname)
196 HMODULE h = (HMODULE)dlopen(modname, 0);
198 Perl_croak_nocontext("Error loading module '%s': %s",
204 loadByOrd(char *modname, ULONG ord)
206 if (ExtFCN[ord] == NULL) {
207 static HMODULE hdosc = 0;
212 hdosc = loadModule(modname);
213 if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
214 Perl_croak_nocontext(
215 "This version of OS/2 does not support %s.%i",
216 modname, loadOrd[ord]);
219 if ((long)ExtFCN[ord] == -1)
220 Perl_croak_nocontext("panic queryaddr");
224 init_PMWIN_entries(void)
226 static HMODULE hpmwin = 0;
227 static const int ords[] = {
228 763, /* Initialize */
229 716, /* CreateMsgQueue */
230 726, /* DestroyMsgQueue */
233 912, /* DispatchMsg */
234 753, /* GetLastError */
235 705, /* CancelShutdown */
244 hpmwin = loadModule("pmwin");
245 while (i < sizeof(ords)/sizeof(int)) {
246 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
247 ((PFN*)&PMWIN_entries)+i)))
248 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
255 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
257 #define QSS_INI_BUFFER 1024
260 get_sysinfo(ULONG pid, ULONG flags)
263 ULONG rc, buf_len = QSS_INI_BUFFER;
265 New(1322, pbuffer, buf_len, char);
266 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
267 rc = QuerySysState(flags, pid, pbuffer, buf_len);
268 while (rc == ERROR_BUFFER_OVERFLOW) {
269 Renew(pbuffer, buf_len *= 2, char);
270 rc = QuerySysState(flags, pid, pbuffer, buf_len);
277 return (PQTOPLEVEL)pbuffer;
280 #define PRIO_ERR 0x1111
288 psi = get_sysinfo(pid, QSS_PROCESS);
292 if (pid != psi->procdata->pid) {
294 Perl_croak_nocontext("panic: wrong pid in sysinfo");
296 prio = psi->procdata->threads->priority;
302 setpriority(int which, int pid, int val)
307 prio = sys_prio(pid);
309 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
310 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
311 /* Do not change class. */
312 return CheckOSError(DosSetPriority((pid < 0)
313 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
315 (32 - val) % 32 - (prio & 0xFF),
318 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
319 /* Documentation claims one can change both class and basevalue,
320 * but I find it wrong. */
321 /* Change class, but since delta == 0 denotes absolute 0, correct. */
322 if (CheckOSError(DosSetPriority((pid < 0)
323 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
324 priors[(32 - val) >> 5] + 1,
328 if ( ((32 - val) % 32) == 0 ) return 0;
329 return CheckOSError(DosSetPriority((pid < 0)
330 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
336 /* else return CheckOSError(DosSetPriority((pid < 0) */
337 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
338 /* priors[(32 - val) >> 5] + 1, */
339 /* (32 - val) % 32 - (prio & 0xFF), */
345 getpriority(int which /* ignored */, int pid)
351 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
352 /* DosGetInfoBlocks has old priority! */
353 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
354 /* if (pid != pib->pib_ulpid) { */
356 if (ret == PRIO_ERR) {
360 /* ret = tib->tib_ptib2->tib2_ulpri; */
361 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
364 /*****************************************************************************/
367 /* There is no big sense to make it thread-specific, since signals
368 are delivered to thread 1 only. XXXX Maybe make it into an array? */
369 static int spawn_pid;
370 static int spawn_killed;
373 spawn_sighandler(int sig)
375 /* Some programs do not arrange for the keyboard signals to be
376 delivered to them. We need to deliver the signal manually. */
377 /* We may get a signal only if
378 a) kid does not receive keyboard signal: deliver it;
379 b) kid already died, and we get a signal. We may only hope
380 that the pid number was not reused.
384 sig = SIGKILL; /* Try harder. */
385 kill(spawn_pid, sig);
390 result(pTHX_ int flag, int pid)
393 Signal_t (*ihand)(); /* place to save signal during system() */
394 Signal_t (*qhand)(); /* place to save signal during system() */
400 if (pid < 0 || flag != 0)
406 ihand = rsignal(SIGINT, &spawn_sighandler);
407 qhand = rsignal(SIGQUIT, &spawn_sighandler);
409 r = wait4pid(pid, &status, 0);
410 } while (r == -1 && errno == EINTR);
411 rsignal(SIGINT, ihand);
412 rsignal(SIGQUIT, qhand);
414 PL_statusvalue = (U16)status;
417 return status & 0xFFFF;
419 ihand = rsignal(SIGINT, SIG_IGN);
420 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
421 rsignal(SIGINT, ihand);
422 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
425 return PL_statusvalue;
429 #define EXECF_SPAWN 0
431 #define EXECF_TRUEEXEC 2
432 #define EXECF_SPAWN_NOWAIT 3
433 #define EXECF_SPAWN_BYFLAG 4
435 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
444 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
445 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
448 return (pib->pib_ultype);
452 file_type(char *path)
457 if (!(_emx_env & 0x200))
458 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
459 if (CheckOSError(DosQueryAppType(path, &apptype))) {
461 case ERROR_FILE_NOT_FOUND:
462 case ERROR_PATH_NOT_FOUND:
464 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
466 default: /* Found, but not an
467 executable, or some other
475 static ULONG os2_mytype;
477 /* Spawn/exec a program, revert to shell if needed. */
478 /* global PL_Argv[] contains arguments. */
481 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
486 char buf[256], *s = 0, scrbuf[280];
488 static char * fargs[4]
489 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
490 char **argsp = fargs;
493 int new_stderr = -1, nostderr = 0, fl_stderr;
500 if (strEQ(PL_Argv[0],"/bin/sh"))
501 PL_Argv[0] = PL_sh_path;
503 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
504 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
505 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
506 ) /* will spawnvp use PATH? */
507 TAINT_ENV(); /* testing IFS here is overkill, probably */
508 /* We should check PERL_SH* and PERLLIB_* as well? */
509 if (!really || !*(tmps = SvPV(really, n_a)))
514 if (_emx_env & 0x200) { /* OS/2. */
515 int type = file_type(tmps);
517 if (type == -1) { /* Not found */
522 else if (type == -2) { /* Not an EXE */
527 else if (type == -3) { /* Is a directory? */
528 /* Special-case this */
530 int l = strlen(tmps);
532 if (l + 5 <= sizeof tbuf) {
534 strcpy(tbuf + l, ".exe");
535 type = file_type(tbuf);
545 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
546 case FAPPTYP_WINDOWAPI:
548 if (os2_mytype != 3) { /* not PM */
549 if (flag == P_NOWAIT)
551 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
552 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
557 case FAPPTYP_NOTWINDOWCOMPAT:
559 if (os2_mytype != 0) { /* not full screen */
560 if (flag == P_NOWAIT)
562 else if ((flag & 7) != P_SESSION)
563 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
568 case FAPPTYP_NOTSPEC:
569 /* Let the shell handle this... */
578 new_stderr = dup(2); /* Preserve stderr */
579 if (new_stderr == -1) {
587 fl_stderr = fcntl(2, F_GETFD);
591 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
595 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
597 if (execf == EXECF_TRUEEXEC)
598 rc = execvp(tmps,PL_Argv);
599 else if (execf == EXECF_EXEC)
600 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
601 else if (execf == EXECF_SPAWN_NOWAIT)
602 rc = spawnvp(flag,tmps,PL_Argv);
603 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
604 rc = result(aTHX_ trueflag,
605 spawnvp(flag,tmps,PL_Argv));
607 if (rc < 0 && pass == 1
608 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
613 if (err == ENOENT || err == ENOEXEC) {
614 /* No such file, or is a script. */
615 /* Try adding script extensions to the file name, and
617 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
622 char *s = 0, *s1, *s2;
627 if (l >= sizeof scrbuf) {
630 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
638 file = PerlIO_open(scr, "r");
643 rd = PerlIO_read(file, buf, sizeof buf-1);
645 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
647 if (!rd) { /* Empty... */
650 /* Special case: maybe from -Zexe build, so
651 there is an executable around (contrary to
652 documentation, DosQueryAppType sometimes (?)
653 does not append ".exe", so we could have
654 reached this place). */
655 if (l + 5 < sizeof scrbuf) {
656 strcpy(scrbuf + l, ".exe");
657 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
658 && !S_ISDIR(PL_statbuf.st_mode)) {
668 if (PerlIO_close(file) != 0) { /* Failure */
670 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
671 scr, Strerror(errno));
672 buf[0] = 0; /* Not #! */
678 } else if (buf[0] == 'e') {
679 if (strnEQ(buf, "extproc", 7)
682 } else if (buf[0] == 'E') {
683 if (strnEQ(buf, "EXTPROC", 7)
688 buf[0] = 0; /* Not #! */
696 /* Do better than pdksh: allow a few args,
697 strip trailing whitespace. */
707 while (*s && !isSPACE(*s))
714 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
725 || (!buf[0] && file)) { /* File without magic */
726 /* In fact we tried all what pdksh would
727 try. There is no point in calling
728 pdksh, we may just emulate its logic. */
729 char *shell = getenv("EXECSHELL");
730 char *shell_opt = NULL;
736 shell = getenv("OS2_SHELL");
737 if (inicmd) { /* No spaces at start! */
739 while (*s && !isSPACE(*s)) {
741 inicmd = NULL; /* Cannot use */
749 /* Dosish shells will choke on slashes
750 in paths, fortunately, this is
751 important for zeroth arg only. */
758 /* If EXECSHELL is set, we do not set */
761 shell = ((_emx_env & 0x200)
764 nargs = shell_opt ? 2 : 1; /* shell file args */
765 exec_args[0] = shell;
766 exec_args[1] = shell_opt;
768 if (nargs == 2 && inicmd) {
769 /* Use the original cmd line */
770 /* XXXX This is good only until we refuse
771 quoted arguments... */
775 } else if (!buf[0] && inicmd) { /* No file */
776 /* Start with the original cmdline. */
777 /* XXXX This is good only until we refuse
778 quoted arguments... */
782 nargs = 2; /* shell -c */
785 while (a[1]) /* Get to the end */
787 a++; /* Copy finil NULL too */
788 while (a >= PL_Argv) {
789 *(a + nargs) = *a; /* PL_Argv was preallocated to be
794 PL_Argv[nargs] = argsp[nargs];
795 /* Enable pathless exec if #! (as pdksh). */
796 pass = (buf[0] == '#' ? 2 : 3);
800 /* Not found: restore errno */
804 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
805 char *no_dir = strrchr(PL_Argv[0], '/');
807 /* Do as pdksh port does: if not found with /, try without
810 PL_Argv[0] = no_dir + 1;
815 if (rc < 0 && ckWARN(WARN_EXEC))
816 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
817 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
819 PL_Argv[0], Strerror(errno));
820 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
821 && ((trueflag & 0xFF) == P_WAIT))
825 if (new_stderr != -1) { /* How can we use error codes? */
828 fcntl(2, F_SETFD, fl_stderr);
834 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
836 do_spawn3(pTHX_ char *cmd, int execf, int flag)
841 char *shell, *copt, *news = NULL;
842 int rc, err, seenspace = 0, mergestderr = 0;
843 char fullcmd[MAXNAMLEN + 1];
846 if ((shell = getenv("EMXSHELL")) != NULL)
848 else if ((shell = getenv("SHELL")) != NULL)
850 else if ((shell = getenv("COMSPEC")) != NULL)
855 /* Consensus on perl5-porters is that it is _very_ important to
856 have a shell which will not change between computers with the
857 same architecture, to avoid "action on a distance".
858 And to have simple build, this shell should be sh. */
863 while (*cmd && isSPACE(*cmd))
866 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
867 STRLEN l = strlen(PL_sh_path);
869 New(1302, news, strlen(cmd) - 7 + l + 1, char);
870 strcpy(news, PL_sh_path);
871 strcpy(news + l, cmd + 7);
875 /* save an extra exec if possible */
876 /* see if there are shell metacharacters in it */
878 if (*cmd == '.' && isSPACE(cmd[1]))
881 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
884 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
888 for (s = cmd; *s; s++) {
889 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
890 if (*s == '\n' && s[1] == '\0') {
893 } else if (*s == '\\' && !seenspace) {
894 continue; /* Allow backslashes in names */
895 } else if (*s == '>' && s >= cmd + 3
896 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
897 && isSPACE(s[-2]) ) {
900 while (*t && isSPACE(*t))
905 break; /* Allow 2>&1 as the last thing */
908 /* We do not convert this to do_spawn_ve since shell
909 should be smart enough to start itself gloriously. */
911 if (execf == EXECF_TRUEEXEC)
912 rc = execl(shell,shell,copt,cmd,(char*)0);
913 else if (execf == EXECF_EXEC)
914 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
915 else if (execf == EXECF_SPAWN_NOWAIT)
916 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
917 else if (execf == EXECF_SPAWN_BYFLAG)
918 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
920 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
921 rc = result(aTHX_ P_WAIT,
922 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
923 if (rc < 0 && ckWARN(WARN_EXEC))
924 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
925 (execf == EXECF_SPAWN ? "spawn" : "exec"),
926 shell, Strerror(errno));
933 } else if (*s == ' ' || *s == '\t') {
938 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
939 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
940 PL_Cmd = savepvn(cmd, s-cmd);
942 for (s = PL_Cmd; *s;) {
943 while (*s && isSPACE(*s)) s++;
946 while (*s && !isSPACE(*s)) s++;
952 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
963 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
967 int flag = P_WAIT, flag_set = 0;
971 New(1301,PL_Argv, sp - mark + 3, char*);
974 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
981 while (++mark <= sp) {
983 *a++ = SvPVx(*mark, n_a);
989 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
990 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
992 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1000 os2_do_spawn(pTHX_ char *cmd)
1002 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1006 do_spawn_nowait(pTHX_ char *cmd)
1008 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1012 Perl_do_exec(pTHX_ char *cmd)
1014 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1019 os2exec(pTHX_ char *cmd)
1021 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1025 my_syspopen(pTHX_ char *cmd, char *mode)
1030 register I32 this, that, newfd;
1031 register I32 pid, rc;
1036 /* `this' is what we use in the parent, `that' in the child. */
1037 this = (*mode == 'w');
1041 taint_proper("Insecure %s%s", "EXEC");
1045 /* Now we need to spawn the child. */
1046 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1047 int new = dup(p[this]);
1054 newfd = dup(*mode == 'r'); /* Preserve std* */
1056 /* This cannot happen due to fh being bad after pipe(), since
1057 pipe() should have created fh 0 and 1 even if they were
1058 initially closed. But we closed p[this] before. */
1059 if (errno != EBADF) {
1066 fh_fl = fcntl(*mode == 'r', F_GETFD);
1067 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1068 dup2(p[that], *mode == 'r');
1071 /* Where is `this' and newfd now? */
1072 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1074 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1075 pid = do_spawn_nowait(aTHX_ cmd);
1077 close(*mode == 'r'); /* It was closed initially */
1078 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1079 dup2(newfd, *mode == 'r'); /* Return std* back. */
1081 fcntl(*mode == 'r', F_SETFD, fh_fl);
1083 fcntl(*mode == 'r', F_SETFD, fh_fl);
1084 if (p[that] == (*mode == 'r'))
1090 if (p[that] < p[this]) { /* Make fh as small as possible */
1091 dup2(p[this], p[that]);
1095 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1096 (void)SvUPGRADE(sv,SVt_IV);
1098 PL_forkprocess = pid;
1099 return PerlIO_fdopen(p[this], mode);
1101 #else /* USE_POPEN */
1107 res = popen(cmd, mode);
1109 char *shell = getenv("EMXSHELL");
1111 my_setenv("EMXSHELL", PL_sh_path);
1112 res = popen(cmd, mode);
1113 my_setenv("EMXSHELL", shell);
1115 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1116 (void)SvUPGRADE(sv,SVt_IV);
1117 SvIVX(sv) = -1; /* A cooky. */
1120 #endif /* USE_POPEN */
1124 /******************************************************************/
1130 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1136 /*******************************************************************/
1137 /* not implemented in EMX 0.9d */
1139 char * ctermid(char *s) { return 0; }
1141 #ifdef MYTTYNAME /* was not in emx0.9a */
1142 void * ttyname(x) { return 0; }
1145 /******************************************************************/
1146 /* my socket forwarders - EMX lib only provides static forwarders */
1148 static HMODULE htcp = 0;
1155 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1157 htcp = loadModule("tcp32dll");
1158 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1159 return (void *) ((void * (*)(void)) fcn) ();
1164 tcp1(char *name, int arg)
1166 static BYTE buf[20];
1169 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1171 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1172 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1173 ((void (*)(int)) fcn) (arg);
1176 struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
1177 struct netent * getnetent() { return tcp0("GETNETENT"); }
1178 struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
1179 struct servent * getservent() { return tcp0("GETSERVENT"); }
1181 void sethostent(x) { tcp1("SETHOSTENT", x); }
1182 void setnetent(x) { tcp1("SETNETENT", x); }
1183 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1184 void setservent(x) { tcp1("SETSERVENT", x); }
1185 void endhostent() { tcp0("ENDHOSTENT"); }
1186 void endnetent() { tcp0("ENDNETENT"); }
1187 void endprotoent() { tcp0("ENDPROTOENT"); }
1188 void endservent() { tcp0("ENDSERVENT"); }
1190 /*****************************************************************************/
1191 /* not implemented in C Set++ */
1194 int setuid(x) { errno = EINVAL; return -1; }
1195 int setgid(x) { errno = EINVAL; return -1; }
1198 /*****************************************************************************/
1199 /* stat() hack for char/block device */
1203 /* First attempt used DosQueryFSAttach which crashed the system when
1204 used with 5.001. Now just look for /dev/. */
1207 os2_stat(char *name, struct stat *st)
1209 static int ino = SHRT_MAX;
1211 if (stricmp(name, "/dev/con") != 0
1212 && stricmp(name, "/dev/tty") != 0)
1213 return stat(name, st);
1215 memset(st, 0, sizeof *st);
1216 st->st_mode = S_IFCHR|0666;
1217 st->st_ino = (ino-- & 0x7FFF);
1224 #ifdef USE_PERL_SBRK
1226 /* SBRK() emulation, mostly moved to malloc.c. */
1229 sys_alloc(int size) {
1231 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1233 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1236 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1240 #endif /* USE_PERL_SBRK */
1244 char *tmppath = TMPPATH1;
1249 char *p = getenv("TMP"), *tpath;
1252 if (!p) p = getenv("TEMP");
1255 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1259 strcpy(tpath + len + 1, TMPPATH1);
1266 XS(XS_File__Copy_syscopy)
1269 if (items < 2 || items > 3)
1270 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1273 char * src = (char *)SvPV(ST(0),n_a);
1274 char * dst = (char *)SvPV(ST(1),n_a);
1281 flag = (unsigned long)SvIV(ST(2));
1284 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1285 ST(0) = sv_newmortal();
1286 sv_setiv(ST(0), (IV)RETVAL);
1291 #include "patchlevel.h"
1294 mod2fname(pTHX_ SV *sv)
1296 static char fname[9];
1297 int pos = 6, len, avlen;
1298 unsigned int sum = 0;
1304 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1306 if (SvTYPE(sv) != SVt_PVAV)
1307 Perl_croak_nocontext("Not array reference given to mod2fname");
1309 avlen = av_len((AV*)sv);
1311 Perl_croak_nocontext("Empty array reference given to mod2fname");
1313 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1314 strncpy(fname, s, 8);
1316 if (len < 6) pos = len;
1318 sum = 33 * sum + *(s++); /* Checksumming first chars to
1319 * get the capitalization into c.s. */
1322 while (avlen >= 0) {
1323 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1325 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1330 sum++; /* Avoid conflict of DLLs in memory. */
1332 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1333 fname[pos] = 'A' + (sum % 26);
1334 fname[pos + 1] = 'A' + (sum / 26 % 26);
1335 fname[pos + 2] = '\0';
1336 return (char *)fname;
1339 XS(XS_DynaLoader_mod2fname)
1343 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1348 RETVAL = mod2fname(aTHX_ sv);
1349 ST(0) = sv_newmortal();
1350 sv_setpv((SV*)ST(0), RETVAL);
1358 static char buf[300];
1361 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1364 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1365 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1368 if (len && buf[len - 1] == '\n')
1370 if (len && buf[len - 1] == '\r')
1372 if (len && buf[len - 1] == '.')
1381 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1383 if (_execname(buf, sizeof buf) != 0)
1390 if (ok && *o != '/' && *o != '\\')
1392 } else if (ok && tolower(*o) != tolower(*p))
1397 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1398 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1412 perllib_mangle(char *s, unsigned int l)
1414 static char *newp, *oldp;
1415 static int newl, oldl, notfound;
1416 static char ret[STATIC_FILE_LENGTH+1];
1418 if (!newp && !notfound) {
1419 newp = getenv("PERLLIB_PREFIX");
1424 while (*newp && !isSPACE(*newp) && *newp != ';') {
1425 newp++; oldl++; /* Skip digits. */
1427 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1428 newp++; /* Skip whitespace. */
1430 newl = strlen(newp);
1431 if (newl == 0 || oldl == 0) {
1432 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1437 if (*s == '\\') *s = '/';
1450 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1453 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1454 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1456 strcpy(ret + newl, s + oldl);
1461 Perl_hab_GET() /* Needed if perl.h cannot be included */
1463 return perl_hab_GET();
1467 Perl_Register_MQ(int serve)
1472 if (Perl_os2_initial_mode++)
1474 DosGetInfoBlocks(&tib, &pib);
1475 Perl_os2_initial_mode = pib->pib_ultype;
1476 /* Try morphing into a PM application. */
1477 if (pib->pib_ultype != 3) /* 2 is VIO */
1478 pib->pib_ultype = 3; /* 3 is PM */
1479 init_PMWIN_entries();
1480 /* 64 messages if before OS/2 3.0, ignored otherwise */
1481 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1485 SAVEINT(cnt); /* Allow catch()ing. */
1487 _exit(188); /* Panic can try to create a window. */
1488 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1491 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1492 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1493 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1495 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1496 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1502 Perl_Serve_Messages(int force)
1507 if (Perl_hmq_servers > 0 && !force)
1509 if (Perl_hmq_refcnt <= 0)
1510 Perl_croak_nocontext("No message queue");
1511 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1513 if (msg.msg == WM_QUIT)
1514 Perl_croak_nocontext("QUITing...");
1515 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1521 Perl_Process_Messages(int force, I32 *cntp)
1525 if (Perl_hmq_servers > 0 && !force)
1527 if (Perl_hmq_refcnt <= 0)
1528 Perl_croak_nocontext("No message queue");
1529 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1532 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1533 if (msg.msg == WM_DESTROY)
1535 if (msg.msg == WM_CREATE)
1538 Perl_croak_nocontext("QUITing...");
1542 Perl_Deregister_MQ(int serve)
1549 if (--Perl_hmq_refcnt <= 0) {
1550 init_PMWIN_entries(); /* To be extra safe */
1551 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1553 /* Try morphing back from a PM application. */
1554 DosGetInfoBlocks(&tib, &pib);
1555 if (pib->pib_ultype == 3) /* 3 is PM */
1556 pib->pib_ultype = Perl_os2_initial_mode;
1558 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1560 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1561 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1564 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1565 && ((path)[2] == '/' || (path)[2] == '\\'))
1566 #define sys_is_rooted _fnisabs
1567 #define sys_is_relative _fnisrel
1568 #define current_drive _getdrive
1570 #undef chdir /* Was _chdir2. */
1571 #define sys_chdir(p) (chdir(p) == 0)
1572 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1574 static int DOS_harderr_state = -1;
1580 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1582 int arg1 = SvIV(ST(0));
1583 int arg2 = SvIV(ST(1));
1584 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1585 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1586 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1589 if (CheckOSError(DosError(a)))
1590 Perl_croak_nocontext("DosError(%d) failed", a);
1591 ST(0) = sv_newmortal();
1592 if (DOS_harderr_state >= 0)
1593 sv_setiv(ST(0), DOS_harderr_state);
1594 DOS_harderr_state = RETVAL;
1599 static signed char DOS_suppression_state = -1;
1601 XS(XS_OS2_Errors2Drive)
1605 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1609 int suppress = SvOK(sv);
1610 char *s = suppress ? SvPV(sv, n_a) : NULL;
1611 char drive = (s ? *s : 0);
1614 if (suppress && !isALPHA(drive))
1615 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1616 if (CheckOSError(DosSuppressPopUps((suppress
1617 ? SPU_ENABLESUPPRESSION
1618 : SPU_DISABLESUPPRESSION),
1620 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1621 ST(0) = sv_newmortal();
1622 if (DOS_suppression_state > 0)
1623 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1624 else if (DOS_suppression_state == 0)
1625 sv_setpvn(ST(0), "", 0);
1626 DOS_suppression_state = drive;
1631 static const char * const si_fields[QSV_MAX] = {
1633 "MAX_TEXT_SESSIONS",
1637 "DYN_PRI_VARIATION",
1655 "FOREGROUND_FS_SESSION",
1656 "FOREGROUND_PROCESS"
1663 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1665 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1666 APIRET rc = NO_ERROR; /* Return code */
1669 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1670 QSV_MAX, /* information */
1673 Perl_croak_nocontext("DosQuerySysInfo() failed");
1674 EXTEND(SP,2*QSV_MAX);
1675 while (i < QSV_MAX) {
1676 ST(j) = sv_newmortal();
1677 sv_setpv(ST(j++), si_fields[i]);
1678 ST(j) = sv_newmortal();
1679 sv_setiv(ST(j++), si[i]);
1683 XSRETURN(2 * QSV_MAX);
1686 XS(XS_OS2_BootDrive)
1690 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1692 ULONG si[1] = {0}; /* System Information Data Buffer */
1693 APIRET rc = NO_ERROR; /* Return code */
1696 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1697 (PVOID)si, sizeof(si))))
1698 Perl_croak_nocontext("DosQuerySysInfo() failed");
1699 ST(0) = sv_newmortal();
1700 c = 'a' - 1 + si[0];
1701 sv_setpvn(ST(0), &c, 1);
1710 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1712 bool serve = SvOK(ST(0));
1713 unsigned long pmq = perl_hmq_GET(serve);
1715 ST(0) = sv_newmortal();
1716 sv_setiv(ST(0), pmq);
1721 XS(XS_OS2_UnMorphPM)
1725 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1727 bool serve = SvOK(ST(0));
1729 perl_hmq_UNSET(serve);
1734 XS(XS_OS2_Serve_Messages)
1738 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1740 bool force = SvOK(ST(0));
1741 unsigned long cnt = Perl_Serve_Messages(force);
1743 ST(0) = sv_newmortal();
1744 sv_setiv(ST(0), cnt);
1749 XS(XS_OS2_Process_Messages)
1752 if (items < 1 || items > 2)
1753 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1755 bool force = SvOK(ST(0));
1761 int fake = SvIV(sv); /* Force SvIVX */
1764 Perl_croak_nocontext("Can't upgrade count to IV");
1766 cnt = Perl_Process_Messages(force, &cntr);
1769 cnt = Perl_Process_Messages(force, NULL);
1771 ST(0) = sv_newmortal();
1772 sv_setiv(ST(0), cnt);
1777 XS(XS_Cwd_current_drive)
1781 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1785 RETVAL = current_drive();
1786 ST(0) = sv_newmortal();
1787 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1792 XS(XS_Cwd_sys_chdir)
1796 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1799 char * path = (char *)SvPV(ST(0),n_a);
1802 RETVAL = sys_chdir(path);
1803 ST(0) = boolSV(RETVAL);
1804 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1809 XS(XS_Cwd_change_drive)
1813 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1816 char d = (char)*SvPV(ST(0),n_a);
1819 RETVAL = change_drive(d);
1820 ST(0) = boolSV(RETVAL);
1821 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1826 XS(XS_Cwd_sys_is_absolute)
1830 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1833 char * path = (char *)SvPV(ST(0),n_a);
1836 RETVAL = sys_is_absolute(path);
1837 ST(0) = boolSV(RETVAL);
1838 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1843 XS(XS_Cwd_sys_is_rooted)
1847 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1850 char * path = (char *)SvPV(ST(0),n_a);
1853 RETVAL = sys_is_rooted(path);
1854 ST(0) = boolSV(RETVAL);
1855 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1860 XS(XS_Cwd_sys_is_relative)
1864 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1867 char * path = (char *)SvPV(ST(0),n_a);
1870 RETVAL = sys_is_relative(path);
1871 ST(0) = boolSV(RETVAL);
1872 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1881 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1885 RETVAL = _getcwd2(p, MAXPATHLEN);
1886 ST(0) = sv_newmortal();
1887 sv_setpv((SV*)ST(0), RETVAL);
1892 XS(XS_Cwd_sys_abspath)
1895 if (items < 1 || items > 2)
1896 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1899 char * path = (char *)SvPV(ST(0),n_a);
1907 dir = (char *)SvPV(ST(1),n_a);
1909 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1913 if (_abspath(p, path, MAXPATHLEN) == 0) {
1919 /* Absolute with drive: */
1920 if ( sys_is_absolute(path) ) {
1921 if (_abspath(p, path, MAXPATHLEN) == 0) {
1926 } else if (path[0] == '/' || path[0] == '\\') {
1927 /* Rooted, but maybe on different drive. */
1928 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1929 char p1[MAXPATHLEN];
1931 /* Need to prepend the drive. */
1934 Copy(path, p1 + 2, strlen(path) + 1, char);
1936 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1941 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1947 /* Either path is relative, or starts with a drive letter. */
1948 /* If the path starts with a drive letter, then dir is
1950 a/b) it is absolute/x:relative on the same drive.
1951 c) path is on current drive, and dir is rooted
1952 In all the cases it is safe to drop the drive part
1954 if ( !sys_is_relative(path) ) {
1957 if ( ( ( sys_is_absolute(dir)
1958 || (isALPHA(dir[0]) && dir[1] == ':'
1959 && strnicmp(dir, path,1) == 0))
1960 && strnicmp(dir, path,1) == 0)
1961 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1962 && toupper(path[0]) == current_drive())) {
1964 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1965 RETVAL = p; goto done;
1967 RETVAL = NULL; goto done;
1971 /* Need to prepend the absolute path of dir. */
1972 char p1[MAXPATHLEN];
1974 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1977 if (p1[ l - 1 ] != '/') {
1981 Copy(path, p1 + l, strlen(path) + 1, char);
1982 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1994 ST(0) = sv_newmortal();
1995 sv_setpv((SV*)ST(0), RETVAL);
1999 typedef APIRET (*PELP)(PSZ path, ULONG type);
2002 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
2004 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
2005 return (*(PELP)ExtFCN[ord])(path, type);
2008 #define extLibpath(type) \
2009 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
2010 : BEGIN_LIBPATH))) \
2013 #define extLibpath_set(p,type) \
2014 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
2017 XS(XS_Cwd_extLibpath)
2020 if (items < 0 || items > 1)
2021 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2031 type = (int)SvIV(ST(0));
2034 RETVAL = extLibpath(type);
2035 ST(0) = sv_newmortal();
2036 sv_setpv((SV*)ST(0), RETVAL);
2041 XS(XS_Cwd_extLibpath_set)
2044 if (items < 1 || items > 2)
2045 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2048 char * s = (char *)SvPV(ST(0),n_a);
2056 type = (int)SvIV(ST(1));
2059 RETVAL = extLibpath_set(s, type);
2060 ST(0) = boolSV(RETVAL);
2061 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2066 #define get_control87() _control87(0,0)
2067 #define set_control87 _control87
2069 XS(XS_OS2__control87)
2073 croak("Usage: OS2::_control87(new,mask)");
2075 unsigned new = (unsigned)SvIV(ST(0));
2076 unsigned mask = (unsigned)SvIV(ST(1));
2079 RETVAL = _control87(new, mask);
2080 ST(0) = sv_newmortal();
2081 sv_setiv(ST(0), (IV)RETVAL);
2086 XS(XS_OS2_get_control87)
2090 croak("Usage: OS2::get_control87()");
2094 RETVAL = get_control87();
2095 ST(0) = sv_newmortal();
2096 sv_setiv(ST(0), (IV)RETVAL);
2102 XS(XS_OS2_set_control87)
2105 if (items < 0 || items > 2)
2106 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2115 new = (unsigned)SvIV(ST(0));
2121 mask = (unsigned)SvIV(ST(1));
2124 RETVAL = set_control87(new, mask);
2125 ST(0) = sv_newmortal();
2126 sv_setiv(ST(0), (IV)RETVAL);
2134 char *file = __FILE__;
2138 if (_emx_env & 0x200) { /* OS/2 */
2139 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2140 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2141 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2143 newXS("OS2::Error", XS_OS2_Error, file);
2144 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2145 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2146 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2147 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2148 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2149 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2150 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2151 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2152 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2153 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2154 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2155 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2156 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2157 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2158 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2159 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2160 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2161 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2162 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2163 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2166 sv_setiv(GvSV(gv), 1);
2168 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2170 sv_setiv(GvSV(gv), _emx_rev);
2171 sv_setpv(GvSV(gv), _emx_vprt);
2173 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2175 sv_setiv(GvSV(gv), _emx_env);
2176 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2178 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2182 OS2_Perl_data_t OS2_Perl_data;
2185 Perl_OS2_init(char **env)
2191 OS2_Perl_data.xs_init = &Xs_OS2_init;
2192 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2193 if (environ == NULL && env) {
2196 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2197 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2198 strcpy(PL_sh_path, SH_PATH);
2199 PL_sh_path[0] = shell[0];
2200 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2201 int l = strlen(shell), i;
2202 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2205 New(1304, PL_sh_path, l + 8, char);
2206 strncpy(PL_sh_path, shell, l);
2207 strcpy(PL_sh_path + l, "/sh.exe");
2208 for (i = 0; i < l; i++) {
2209 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2212 MUTEX_INIT(&start_thread_mutex);
2213 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2214 /* Some DLLs reset FP flags on load. We may have been linked with them */
2215 _control87(MCW_EM, MCW_EM);
2222 my_tmpnam (char *str)
2224 char *p = getenv("TMP"), *tpath;
2227 if (!p) p = getenv("TEMP");
2228 tpath = tempnam(p, "pltmp");
2242 if (s.st_mode & S_IWOTH) {
2245 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2252 my_rmdir (__const__ char *s)
2254 char buf[MAXPATHLEN];
2255 STRLEN l = strlen(s);
2257 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2268 my_mkdir (__const__ char *s, long perm)
2270 char buf[MAXPATHLEN];
2271 STRLEN l = strlen(s);
2273 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2278 return mkdir(s, perm);
2283 /* This code was contributed by Rocco Caputo. */
2285 my_flock(int handle, int o)
2287 FILELOCK rNull, rFull;
2288 ULONG timeout, handle_type, flag_word;
2290 int blocking, shared;
2291 static int use_my = -1;
2294 char *s = getenv("USE_PERL_FLOCK");
2300 if (!(_emx_env & 0x200) || !use_my)
2301 return flock(handle, o); /* Delegate to EMX. */
2304 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2305 (handle_type & 0xFF))
2310 // set lock/unlock ranges
2311 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2312 rFull.lRange = 0x7FFFFFFF;
2313 // set timeout for blocking
2314 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2315 // shared or exclusive?
2316 shared = (o & LOCK_SH) ? 1 : 0;
2317 // do not block the unlock
2318 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2319 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2324 case ERROR_INVALID_HANDLE:
2327 case ERROR_SHARING_BUFFER_EXCEEDED:
2330 case ERROR_LOCK_VIOLATION:
2331 break; // not an error
2332 case ERROR_INVALID_PARAMETER:
2333 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2334 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2337 case ERROR_INTERRUPT:
2346 if (o & (LOCK_SH | LOCK_EX)) {
2347 // for blocking operations
2361 case ERROR_INVALID_HANDLE:
2364 case ERROR_SHARING_BUFFER_EXCEEDED:
2367 case ERROR_LOCK_VIOLATION:
2369 errno = EWOULDBLOCK;
2373 case ERROR_INVALID_PARAMETER:
2374 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2375 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2378 case ERROR_INTERRUPT:
2385 // give away timeslice