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
12 #include <sys/uflags.h>
15 * Various Unix compatibility functions for OS/2
24 #define PERLIO_NOT_STDIO 0
31 typedef void (*emx_startroutine)(void *);
32 typedef void* (*pthreads_startroutine)(void *);
41 const char *pthreads_states[] = {
52 enum pthreads_state state;
55 thread_join_t *thread_join_data;
56 int thread_join_count;
57 perl_mutex start_thread_mutex;
60 pthread_join(perl_os_thread tid, void **status)
62 MUTEX_LOCK(&start_thread_mutex);
63 switch (thread_join_data[tid].state) {
64 case pthreads_st_exited:
65 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
66 MUTEX_UNLOCK(&start_thread_mutex);
67 *status = thread_join_data[tid].status;
69 case pthreads_st_waited:
70 MUTEX_UNLOCK(&start_thread_mutex);
71 Perl_croak_nocontext("join with a thread with a waiter");
74 thread_join_data[tid].state = pthreads_st_waited;
75 COND_INIT(&thread_join_data[tid].cond);
76 MUTEX_UNLOCK(&start_thread_mutex);
77 COND_WAIT(&thread_join_data[tid].cond, NULL);
78 COND_DESTROY(&thread_join_data[tid].cond);
79 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
80 *status = thread_join_data[tid].status;
83 MUTEX_UNLOCK(&start_thread_mutex);
84 Perl_croak_nocontext("join: unknown thread state: '%s'",
85 pthreads_states[thread_join_data[tid].state]);
92 pthread_startit(void *arg)
94 /* Thread is already started, we need to transfer control only */
95 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
96 int tid = pthread_self();
99 arg = ((void**)arg)[1];
100 if (tid >= thread_join_count) {
101 int oc = thread_join_count;
103 thread_join_count = tid + 5 + tid/5;
104 if (thread_join_data) {
105 Renew(thread_join_data, thread_join_count, thread_join_t);
106 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
108 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
111 if (thread_join_data[tid].state != pthreads_st_none)
112 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
113 thread_join_data[tid].state = pthreads_st_run;
114 /* Now that we copied/updated the guys, we may release the caller... */
115 MUTEX_UNLOCK(&start_thread_mutex);
116 thread_join_data[tid].status = (*start_routine)(arg);
117 switch (thread_join_data[tid].state) {
118 case pthreads_st_waited:
119 COND_SIGNAL(&thread_join_data[tid].cond);
122 thread_join_data[tid].state = pthreads_st_exited;
128 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
129 void *(*start_routine)(void*), void *arg)
133 args[0] = (void*)start_routine;
136 MUTEX_LOCK(&start_thread_mutex);
137 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
138 /*stacksize*/ 10*1024*1024, (void*)args);
139 MUTEX_LOCK(&start_thread_mutex);
140 MUTEX_UNLOCK(&start_thread_mutex);
141 return *tid ? 0 : EINVAL;
145 pthread_detach(perl_os_thread tid)
147 MUTEX_LOCK(&start_thread_mutex);
148 switch (thread_join_data[tid].state) {
149 case pthreads_st_waited:
150 MUTEX_UNLOCK(&start_thread_mutex);
151 Perl_croak_nocontext("detach on a thread with a waiter");
153 case pthreads_st_run:
154 thread_join_data[tid].state = pthreads_st_detached;
155 MUTEX_UNLOCK(&start_thread_mutex);
158 MUTEX_UNLOCK(&start_thread_mutex);
159 Perl_croak_nocontext("detach: unknown thread state: '%s'",
160 pthreads_states[thread_join_data[tid].state]);
166 /* This is a very bastardized version: */
168 os2_cond_wait(perl_cond *c, perl_mutex *m)
172 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
173 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
174 if (m) MUTEX_UNLOCK(m);
175 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
176 && (rc != ERROR_INTERRUPT))
177 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
178 if (rc == ERROR_INTERRUPT)
180 if (m) MUTEX_LOCK(m);
184 /*****************************************************************************/
185 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
186 static PFN ExtFCN[2]; /* Labeled by ord below. */
187 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
188 #define ORD_QUERY_ELP 0
189 #define ORD_SET_ELP 1
190 struct PMWIN_entries_t PMWIN_entries;
193 loadByOrd(char *modname, ULONG ord)
195 if (ExtFCN[ord] == NULL) {
196 static HMODULE hdosc = 0;
201 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
203 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
204 Perl_croak_nocontext("This version of OS/2 does not support %s.%i",
205 modname, loadOrd[ord]);
208 if ((long)ExtFCN[ord] == -1)
209 Perl_croak_nocontext("panic queryaddr");
213 init_PMWIN_entries(void)
215 static HMODULE hpmwin = 0;
216 static const int ords[] = {
217 763, /* Initialize */
218 716, /* CreateMsgQueue */
219 726, /* DestroyMsgQueue */
222 912, /* DispatchMsg */
231 if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
232 Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf);
234 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
235 ((PFN*)&PMWIN_entries)+i)))
236 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
243 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
245 #define QSS_INI_BUFFER 1024
248 get_sysinfo(ULONG pid, ULONG flags)
251 ULONG rc, buf_len = QSS_INI_BUFFER;
253 New(1322, pbuffer, buf_len, char);
254 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
255 rc = QuerySysState(flags, pid, pbuffer, buf_len);
256 while (rc == ERROR_BUFFER_OVERFLOW) {
257 Renew(pbuffer, buf_len *= 2, char);
258 rc = QuerySysState(flags, pid, pbuffer, buf_len);
265 return (PQTOPLEVEL)pbuffer;
268 #define PRIO_ERR 0x1111
276 psi = get_sysinfo(pid, QSS_PROCESS);
280 if (pid != psi->procdata->pid) {
282 Perl_croak_nocontext("panic: wrong pid in sysinfo");
284 prio = psi->procdata->threads->priority;
290 setpriority(int which, int pid, int val)
295 prio = sys_prio(pid);
297 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
298 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
299 /* Do not change class. */
300 return CheckOSError(DosSetPriority((pid < 0)
301 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
303 (32 - val) % 32 - (prio & 0xFF),
306 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
307 /* Documentation claims one can change both class and basevalue,
308 * but I find it wrong. */
309 /* Change class, but since delta == 0 denotes absolute 0, correct. */
310 if (CheckOSError(DosSetPriority((pid < 0)
311 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
312 priors[(32 - val) >> 5] + 1,
316 if ( ((32 - val) % 32) == 0 ) return 0;
317 return CheckOSError(DosSetPriority((pid < 0)
318 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
324 /* else return CheckOSError(DosSetPriority((pid < 0) */
325 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
326 /* priors[(32 - val) >> 5] + 1, */
327 /* (32 - val) % 32 - (prio & 0xFF), */
333 getpriority(int which /* ignored */, int pid)
339 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
340 /* DosGetInfoBlocks has old priority! */
341 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
342 /* if (pid != pib->pib_ulpid) { */
344 if (ret == PRIO_ERR) {
348 /* ret = tib->tib_ptib2->tib2_ulpri; */
349 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
352 /*****************************************************************************/
355 /* There is no big sense to make it thread-specific, since signals
356 are delivered to thread 1 only. XXXX Maybe make it into an array? */
357 static int spawn_pid;
358 static int spawn_killed;
361 spawn_sighandler(int sig)
363 /* Some programs do not arrange for the keyboard signals to be
364 delivered to them. We need to deliver the signal manually. */
365 /* We may get a signal only if
366 a) kid does not receive keyboard signal: deliver it;
367 b) kid already died, and we get a signal. We may only hope
368 that the pid number was not reused.
372 sig = SIGKILL; /* Try harder. */
373 kill(spawn_pid, sig);
378 result(pTHX_ int flag, int pid)
381 Signal_t (*ihand)(); /* place to save signal during system() */
382 Signal_t (*qhand)(); /* place to save signal during system() */
388 if (pid < 0 || flag != 0)
394 ihand = rsignal(SIGINT, &spawn_sighandler);
395 qhand = rsignal(SIGQUIT, &spawn_sighandler);
397 r = wait4pid(pid, &status, 0);
398 } while (r == -1 && errno == EINTR);
399 rsignal(SIGINT, ihand);
400 rsignal(SIGQUIT, qhand);
402 PL_statusvalue = (U16)status;
405 return status & 0xFFFF;
407 ihand = rsignal(SIGINT, SIG_IGN);
408 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
409 rsignal(SIGINT, ihand);
410 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
413 return PL_statusvalue;
417 #define EXECF_SPAWN 0
419 #define EXECF_TRUEEXEC 2
420 #define EXECF_SPAWN_NOWAIT 3
421 #define EXECF_SPAWN_BYFLAG 4
423 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
432 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
433 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
436 return (pib->pib_ultype);
440 file_type(char *path)
445 if (!(_emx_env & 0x200))
446 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
447 if (CheckOSError(DosQueryAppType(path, &apptype))) {
449 case ERROR_FILE_NOT_FOUND:
450 case ERROR_PATH_NOT_FOUND:
452 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
454 default: /* Found, but not an
455 executable, or some other
463 static ULONG os2_mytype;
465 /* Spawn/exec a program, revert to shell if needed. */
466 /* global PL_Argv[] contains arguments. */
469 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
474 char buf[256], *s = 0, scrbuf[280];
476 static char * fargs[4]
477 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
478 char **argsp = fargs;
481 int new_stderr = -1, nostderr = 0, fl_stderr;
488 if (strEQ(PL_Argv[0],"/bin/sh"))
489 PL_Argv[0] = PL_sh_path;
491 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
492 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
493 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
494 ) /* will spawnvp use PATH? */
495 TAINT_ENV(); /* testing IFS here is overkill, probably */
496 /* We should check PERL_SH* and PERLLIB_* as well? */
497 if (!really || !*(tmps = SvPV(really, n_a)))
502 if (_emx_env & 0x200) { /* OS/2. */
503 int type = file_type(tmps);
505 if (type == -1) { /* Not found */
510 else if (type == -2) { /* Not an EXE */
515 else if (type == -3) { /* Is a directory? */
516 /* Special-case this */
518 int l = strlen(tmps);
520 if (l + 5 <= sizeof tbuf) {
522 strcpy(tbuf + l, ".exe");
523 type = file_type(tbuf);
533 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
534 case FAPPTYP_WINDOWAPI:
536 if (os2_mytype != 3) { /* not PM */
537 if (flag == P_NOWAIT)
539 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
540 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
545 case FAPPTYP_NOTWINDOWCOMPAT:
547 if (os2_mytype != 0) { /* not full screen */
548 if (flag == P_NOWAIT)
550 else if ((flag & 7) != P_SESSION)
551 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
556 case FAPPTYP_NOTSPEC:
557 /* Let the shell handle this... */
566 new_stderr = dup(2); /* Preserve stderr */
567 if (new_stderr == -1) {
575 fl_stderr = fcntl(2, F_GETFD);
579 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
583 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
585 if (execf == EXECF_TRUEEXEC)
586 rc = execvp(tmps,PL_Argv);
587 else if (execf == EXECF_EXEC)
588 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
589 else if (execf == EXECF_SPAWN_NOWAIT)
590 rc = spawnvp(flag,tmps,PL_Argv);
591 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
592 rc = result(aTHX_ trueflag,
593 spawnvp(flag,tmps,PL_Argv));
595 if (rc < 0 && pass == 1
596 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
601 if (err == ENOENT || err == ENOEXEC) {
602 /* No such file, or is a script. */
603 /* Try adding script extensions to the file name, and
605 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
610 char *s = 0, *s1, *s2;
615 if (l >= sizeof scrbuf) {
618 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
626 file = PerlIO_open(scr, "r");
631 rd = PerlIO_read(file, buf, sizeof buf-1);
633 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
635 if (!rd) { /* Empty... */
638 /* Special case: maybe from -Zexe build, so
639 there is an executable around (contrary to
640 documentation, DosQueryAppType sometimes (?)
641 does not append ".exe", so we could have
642 reached this place). */
643 if (l + 5 < sizeof scrbuf) {
644 strcpy(scrbuf + l, ".exe");
645 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
646 && !S_ISDIR(PL_statbuf.st_mode)) {
656 if (PerlIO_close(file) != 0) { /* Failure */
658 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
659 scr, Strerror(errno));
660 buf[0] = 0; /* Not #! */
666 } else if (buf[0] == 'e') {
667 if (strnEQ(buf, "extproc", 7)
670 } else if (buf[0] == 'E') {
671 if (strnEQ(buf, "EXTPROC", 7)
676 buf[0] = 0; /* Not #! */
684 /* Do better than pdksh: allow a few args,
685 strip trailing whitespace. */
695 while (*s && !isSPACE(*s))
702 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
713 || (!buf[0] && file)) { /* File without magic */
714 /* In fact we tried all what pdksh would
715 try. There is no point in calling
716 pdksh, we may just emulate its logic. */
717 char *shell = getenv("EXECSHELL");
718 char *shell_opt = NULL;
724 shell = getenv("OS2_SHELL");
725 if (inicmd) { /* No spaces at start! */
727 while (*s && !isSPACE(*s)) {
729 inicmd = NULL; /* Cannot use */
737 /* Dosish shells will choke on slashes
738 in paths, fortunately, this is
739 important for zeroth arg only. */
746 /* If EXECSHELL is set, we do not set */
749 shell = ((_emx_env & 0x200)
752 nargs = shell_opt ? 2 : 1; /* shell file args */
753 exec_args[0] = shell;
754 exec_args[1] = shell_opt;
756 if (nargs == 2 && inicmd) {
757 /* Use the original cmd line */
758 /* XXXX This is good only until we refuse
759 quoted arguments... */
763 } else if (!buf[0] && inicmd) { /* No file */
764 /* Start with the original cmdline. */
765 /* XXXX This is good only until we refuse
766 quoted arguments... */
770 nargs = 2; /* shell -c */
773 while (a[1]) /* Get to the end */
775 a++; /* Copy finil NULL too */
776 while (a >= PL_Argv) {
777 *(a + nargs) = *a; /* PL_Argv was preallocated to be
782 PL_Argv[nargs] = argsp[nargs];
783 /* Enable pathless exec if #! (as pdksh). */
784 pass = (buf[0] == '#' ? 2 : 3);
788 /* Not found: restore errno */
792 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
793 char *no_dir = strrchr(PL_Argv[0], '/');
795 /* Do as pdksh port does: if not found with /, try without
798 PL_Argv[0] = no_dir + 1;
803 if (rc < 0 && ckWARN(WARN_EXEC))
804 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
805 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
807 PL_Argv[0], Strerror(errno));
808 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
809 && ((trueflag & 0xFF) == P_WAIT))
813 if (new_stderr != -1) { /* How can we use error codes? */
816 fcntl(2, F_SETFD, fl_stderr);
822 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
824 do_spawn3(pTHX_ char *cmd, int execf, int flag)
829 char *shell, *copt, *news = NULL;
830 int rc, err, seenspace = 0, mergestderr = 0;
831 char fullcmd[MAXNAMLEN + 1];
834 if ((shell = getenv("EMXSHELL")) != NULL)
836 else if ((shell = getenv("SHELL")) != NULL)
838 else if ((shell = getenv("COMSPEC")) != NULL)
843 /* Consensus on perl5-porters is that it is _very_ important to
844 have a shell which will not change between computers with the
845 same architecture, to avoid "action on a distance".
846 And to have simple build, this shell should be sh. */
851 while (*cmd && isSPACE(*cmd))
854 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
855 STRLEN l = strlen(PL_sh_path);
857 New(1302, news, strlen(cmd) - 7 + l + 1, char);
858 strcpy(news, PL_sh_path);
859 strcpy(news + l, cmd + 7);
863 /* save an extra exec if possible */
864 /* see if there are shell metacharacters in it */
866 if (*cmd == '.' && isSPACE(cmd[1]))
869 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
872 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
876 for (s = cmd; *s; s++) {
877 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
878 if (*s == '\n' && s[1] == '\0') {
881 } else if (*s == '\\' && !seenspace) {
882 continue; /* Allow backslashes in names */
883 } else if (*s == '>' && s >= cmd + 3
884 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
885 && isSPACE(s[-2]) ) {
888 while (*t && isSPACE(*t))
893 break; /* Allow 2>&1 as the last thing */
896 /* We do not convert this to do_spawn_ve since shell
897 should be smart enough to start itself gloriously. */
899 if (execf == EXECF_TRUEEXEC)
900 rc = execl(shell,shell,copt,cmd,(char*)0);
901 else if (execf == EXECF_EXEC)
902 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
903 else if (execf == EXECF_SPAWN_NOWAIT)
904 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
905 else if (execf == EXECF_SPAWN_BYFLAG)
906 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
908 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
909 rc = result(aTHX_ P_WAIT,
910 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
911 if (rc < 0 && ckWARN(WARN_EXEC))
912 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
913 (execf == EXECF_SPAWN ? "spawn" : "exec"),
914 shell, Strerror(errno));
921 } else if (*s == ' ' || *s == '\t') {
926 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
927 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
928 PL_Cmd = savepvn(cmd, s-cmd);
930 for (s = PL_Cmd; *s;) {
931 while (*s && isSPACE(*s)) s++;
934 while (*s && !isSPACE(*s)) s++;
940 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
951 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
955 int flag = P_WAIT, flag_set = 0;
959 New(1301,PL_Argv, sp - mark + 3, char*);
962 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
969 while (++mark <= sp) {
971 *a++ = SvPVx(*mark, n_a);
977 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
978 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
980 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
988 os2_do_spawn(pTHX_ char *cmd)
990 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
994 do_spawn_nowait(pTHX_ char *cmd)
996 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1000 Perl_do_exec(pTHX_ char *cmd)
1002 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1007 os2exec(pTHX_ char *cmd)
1009 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1013 my_syspopen(pTHX_ char *cmd, char *mode)
1018 register I32 this, that, newfd;
1019 register I32 pid, rc;
1024 /* `this' is what we use in the parent, `that' in the child. */
1025 this = (*mode == 'w');
1029 taint_proper("Insecure %s%s", "EXEC");
1033 /* Now we need to spawn the child. */
1034 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1035 int new = dup(p[this]);
1042 newfd = dup(*mode == 'r'); /* Preserve std* */
1044 /* This cannot happen due to fh being bad after pipe(), since
1045 pipe() should have created fh 0 and 1 even if they were
1046 initially closed. But we closed p[this] before. */
1047 if (errno != EBADF) {
1054 fh_fl = fcntl(*mode == 'r', F_GETFD);
1055 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1056 dup2(p[that], *mode == 'r');
1059 /* Where is `this' and newfd now? */
1060 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1062 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1063 pid = do_spawn_nowait(aTHX_ cmd);
1065 close(*mode == 'r'); /* It was closed initially */
1066 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1067 dup2(newfd, *mode == 'r'); /* Return std* back. */
1069 fcntl(*mode == 'r', F_SETFD, fh_fl);
1071 fcntl(*mode == 'r', F_SETFD, fh_fl);
1072 if (p[that] == (*mode == 'r'))
1078 if (p[that] < p[this]) { /* Make fh as small as possible */
1079 dup2(p[this], p[that]);
1083 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1084 (void)SvUPGRADE(sv,SVt_IV);
1086 PL_forkprocess = pid;
1087 return PerlIO_fdopen(p[this], mode);
1089 #else /* USE_POPEN */
1095 res = popen(cmd, mode);
1097 char *shell = getenv("EMXSHELL");
1099 my_setenv("EMXSHELL", PL_sh_path);
1100 res = popen(cmd, mode);
1101 my_setenv("EMXSHELL", shell);
1103 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1104 (void)SvUPGRADE(sv,SVt_IV);
1105 SvIVX(sv) = -1; /* A cooky. */
1108 #endif /* USE_POPEN */
1112 /******************************************************************/
1118 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1124 /*******************************************************************/
1125 /* not implemented in EMX 0.9d */
1127 char * ctermid(char *s) { return 0; }
1129 #ifdef MYTTYNAME /* was not in emx0.9a */
1130 void * ttyname(x) { return 0; }
1133 /******************************************************************/
1134 /* my socket forwarders - EMX lib only provides static forwarders */
1136 static HMODULE htcp = 0;
1141 static BYTE buf[20];
1144 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1146 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1147 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1148 return (void *) ((void * (*)(void)) fcn) ();
1153 tcp1(char *name, int arg)
1155 static BYTE buf[20];
1158 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1160 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1161 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1162 ((void (*)(int)) fcn) (arg);
1165 void * gethostent() { return tcp0("GETHOSTENT"); }
1166 void * getnetent() { return tcp0("GETNETENT"); }
1167 void * getprotoent() { return tcp0("GETPROTOENT"); }
1168 void * getservent() { return tcp0("GETSERVENT"); }
1169 void sethostent(x) { tcp1("SETHOSTENT", x); }
1170 void setnetent(x) { tcp1("SETNETENT", x); }
1171 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1172 void setservent(x) { tcp1("SETSERVENT", x); }
1173 void endhostent() { tcp0("ENDHOSTENT"); }
1174 void endnetent() { tcp0("ENDNETENT"); }
1175 void endprotoent() { tcp0("ENDPROTOENT"); }
1176 void endservent() { tcp0("ENDSERVENT"); }
1178 /*****************************************************************************/
1179 /* not implemented in C Set++ */
1182 int setuid(x) { errno = EINVAL; return -1; }
1183 int setgid(x) { errno = EINVAL; return -1; }
1186 /*****************************************************************************/
1187 /* stat() hack for char/block device */
1191 /* First attempt used DosQueryFSAttach which crashed the system when
1192 used with 5.001. Now just look for /dev/. */
1195 os2_stat(char *name, struct stat *st)
1197 static int ino = SHRT_MAX;
1199 if (stricmp(name, "/dev/con") != 0
1200 && stricmp(name, "/dev/tty") != 0)
1201 return stat(name, st);
1203 memset(st, 0, sizeof *st);
1204 st->st_mode = S_IFCHR|0666;
1205 st->st_ino = (ino-- & 0x7FFF);
1212 #ifdef USE_PERL_SBRK
1214 /* SBRK() emulation, mostly moved to malloc.c. */
1217 sys_alloc(int size) {
1219 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1221 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1224 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1228 #endif /* USE_PERL_SBRK */
1232 char *tmppath = TMPPATH1;
1237 char *p = getenv("TMP"), *tpath;
1240 if (!p) p = getenv("TEMP");
1243 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1247 strcpy(tpath + len + 1, TMPPATH1);
1254 XS(XS_File__Copy_syscopy)
1257 if (items < 2 || items > 3)
1258 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1261 char * src = (char *)SvPV(ST(0),n_a);
1262 char * dst = (char *)SvPV(ST(1),n_a);
1269 flag = (unsigned long)SvIV(ST(2));
1272 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1273 ST(0) = sv_newmortal();
1274 sv_setiv(ST(0), (IV)RETVAL);
1279 #include "patchlevel.h"
1282 mod2fname(pTHX_ SV *sv)
1284 static char fname[9];
1285 int pos = 6, len, avlen;
1286 unsigned int sum = 0;
1292 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1294 if (SvTYPE(sv) != SVt_PVAV)
1295 Perl_croak_nocontext("Not array reference given to mod2fname");
1297 avlen = av_len((AV*)sv);
1299 Perl_croak_nocontext("Empty array reference given to mod2fname");
1301 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1302 strncpy(fname, s, 8);
1304 if (len < 6) pos = len;
1306 sum = 33 * sum + *(s++); /* Checksumming first chars to
1307 * get the capitalization into c.s. */
1310 while (avlen >= 0) {
1311 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1313 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1318 sum++; /* Avoid conflict of DLLs in memory. */
1320 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1321 fname[pos] = 'A' + (sum % 26);
1322 fname[pos + 1] = 'A' + (sum / 26 % 26);
1323 fname[pos + 2] = '\0';
1324 return (char *)fname;
1327 XS(XS_DynaLoader_mod2fname)
1331 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1336 RETVAL = mod2fname(aTHX_ sv);
1337 ST(0) = sv_newmortal();
1338 sv_setpv((SV*)ST(0), RETVAL);
1346 static char buf[300];
1349 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1352 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1353 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1356 if (len && buf[len - 1] == '\n')
1358 if (len && buf[len - 1] == '\r')
1360 if (len && buf[len - 1] == '.')
1371 if (_execname(buf, sizeof buf) != 0)
1372 return PL_origargv[0];
1385 perllib_mangle(char *s, unsigned int l)
1387 static char *newp, *oldp;
1388 static int newl, oldl, notfound;
1389 static char ret[STATIC_FILE_LENGTH+1];
1391 if (!newp && !notfound) {
1392 newp = getenv("PERLLIB_PREFIX");
1397 while (*newp && !isSPACE(*newp) && *newp != ';') {
1398 newp++; oldl++; /* Skip digits. */
1400 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1401 newp++; /* Skip whitespace. */
1403 newl = strlen(newp);
1404 if (newl == 0 || oldl == 0) {
1405 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1410 if (*s == '\\') *s = '/';
1423 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1426 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1427 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1429 strcpy(ret + newl, s + oldl);
1434 Perl_hab_GET() /* Needed if perl.h cannot be included */
1436 return perl_hab_GET();
1440 Perl_Register_MQ(int serve)
1445 if (Perl_os2_initial_mode++)
1447 DosGetInfoBlocks(&tib, &pib);
1448 Perl_os2_initial_mode = pib->pib_ultype;
1449 Perl_hmq_refcnt = 1;
1450 /* Try morphing into a PM application. */
1451 if (pib->pib_ultype != 3) /* 2 is VIO */
1452 pib->pib_ultype = 3; /* 3 is PM */
1453 init_PMWIN_entries();
1454 /* 64 messages if before OS/2 3.0, ignored otherwise */
1455 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1459 _exit(188); /* Panic can try to create a window. */
1460 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1466 Perl_Serve_Messages(int force)
1471 if (Perl_hmq_servers && !force)
1473 if (!Perl_hmq_refcnt)
1474 Perl_croak_nocontext("No message queue");
1475 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1477 if (msg.msg == WM_QUIT)
1478 Perl_croak_nocontext("QUITing...");
1479 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1485 Perl_Process_Messages(int force, I32 *cntp)
1489 if (Perl_hmq_servers && !force)
1491 if (!Perl_hmq_refcnt)
1492 Perl_croak_nocontext("No message queue");
1493 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1496 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1497 if (msg.msg == WM_DESTROY)
1499 if (msg.msg == WM_CREATE)
1502 Perl_croak_nocontext("QUITing...");
1506 Perl_Deregister_MQ(int serve)
1511 if (--Perl_hmq_refcnt == 0) {
1512 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1514 /* Try morphing back from a PM application. */
1515 if (pib->pib_ultype == 3) /* 3 is PM */
1516 pib->pib_ultype = Perl_os2_initial_mode;
1518 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1523 extern void dlopen();
1524 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1526 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1527 && ((path)[2] == '/' || (path)[2] == '\\'))
1528 #define sys_is_rooted _fnisabs
1529 #define sys_is_relative _fnisrel
1530 #define current_drive _getdrive
1532 #undef chdir /* Was _chdir2. */
1533 #define sys_chdir(p) (chdir(p) == 0)
1534 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1536 static int DOS_harderr_state = -1;
1542 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1544 int arg1 = SvIV(ST(0));
1545 int arg2 = SvIV(ST(1));
1546 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1547 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1548 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1551 if (CheckOSError(DosError(a)))
1552 Perl_croak_nocontext("DosError(%d) failed", a);
1553 ST(0) = sv_newmortal();
1554 if (DOS_harderr_state >= 0)
1555 sv_setiv(ST(0), DOS_harderr_state);
1556 DOS_harderr_state = RETVAL;
1561 static signed char DOS_suppression_state = -1;
1563 XS(XS_OS2_Errors2Drive)
1567 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1571 int suppress = SvOK(sv);
1572 char *s = suppress ? SvPV(sv, n_a) : NULL;
1573 char drive = (s ? *s : 0);
1576 if (suppress && !isALPHA(drive))
1577 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1578 if (CheckOSError(DosSuppressPopUps((suppress
1579 ? SPU_ENABLESUPPRESSION
1580 : SPU_DISABLESUPPRESSION),
1582 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1583 ST(0) = sv_newmortal();
1584 if (DOS_suppression_state > 0)
1585 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1586 else if (DOS_suppression_state == 0)
1587 sv_setpvn(ST(0), "", 0);
1588 DOS_suppression_state = drive;
1593 static const char * const si_fields[QSV_MAX] = {
1595 "MAX_TEXT_SESSIONS",
1599 "DYN_PRI_VARIATION",
1617 "FOREGROUND_FS_SESSION",
1618 "FOREGROUND_PROCESS"
1625 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1627 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1628 APIRET rc = NO_ERROR; /* Return code */
1631 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1632 QSV_MAX, /* information */
1635 Perl_croak_nocontext("DosQuerySysInfo() failed");
1636 EXTEND(SP,2*QSV_MAX);
1637 while (i < QSV_MAX) {
1638 ST(j) = sv_newmortal();
1639 sv_setpv(ST(j++), si_fields[i]);
1640 ST(j) = sv_newmortal();
1641 sv_setiv(ST(j++), si[i]);
1645 XSRETURN(2 * QSV_MAX);
1648 XS(XS_OS2_BootDrive)
1652 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1654 ULONG si[1] = {0}; /* System Information Data Buffer */
1655 APIRET rc = NO_ERROR; /* Return code */
1658 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1659 (PVOID)si, sizeof(si))))
1660 Perl_croak_nocontext("DosQuerySysInfo() failed");
1661 ST(0) = sv_newmortal();
1662 c = 'a' - 1 + si[0];
1663 sv_setpvn(ST(0), &c, 1);
1672 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1674 bool serve = SvOK(ST(0));
1675 unsigned long pmq = perl_hmq_GET(serve);
1677 ST(0) = sv_newmortal();
1678 sv_setiv(ST(0), pmq);
1683 XS(XS_OS2_UnMorphPM)
1687 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1689 bool serve = SvOK(ST(0));
1691 perl_hmq_UNSET(serve);
1696 XS(XS_OS2_Serve_Messages)
1700 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1702 bool force = SvOK(ST(0));
1703 unsigned long cnt = Perl_Serve_Messages(force);
1705 ST(0) = sv_newmortal();
1706 sv_setiv(ST(0), cnt);
1711 XS(XS_OS2_Process_Messages)
1714 if (items < 1 || items > 2)
1715 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1717 bool force = SvOK(ST(0));
1723 int fake = SvIV(sv); /* Force SvIVX */
1726 Perl_croak_nocontext("Can't upgrade count to IV");
1728 cnt = Perl_Process_Messages(force, &cntr);
1731 cnt = Perl_Process_Messages(force, NULL);
1733 ST(0) = sv_newmortal();
1734 sv_setiv(ST(0), cnt);
1739 XS(XS_Cwd_current_drive)
1743 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1747 RETVAL = current_drive();
1748 ST(0) = sv_newmortal();
1749 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1754 XS(XS_Cwd_sys_chdir)
1758 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1761 char * path = (char *)SvPV(ST(0),n_a);
1764 RETVAL = sys_chdir(path);
1765 ST(0) = boolSV(RETVAL);
1766 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1771 XS(XS_Cwd_change_drive)
1775 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1778 char d = (char)*SvPV(ST(0),n_a);
1781 RETVAL = change_drive(d);
1782 ST(0) = boolSV(RETVAL);
1783 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1788 XS(XS_Cwd_sys_is_absolute)
1792 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1795 char * path = (char *)SvPV(ST(0),n_a);
1798 RETVAL = sys_is_absolute(path);
1799 ST(0) = boolSV(RETVAL);
1800 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1805 XS(XS_Cwd_sys_is_rooted)
1809 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1812 char * path = (char *)SvPV(ST(0),n_a);
1815 RETVAL = sys_is_rooted(path);
1816 ST(0) = boolSV(RETVAL);
1817 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1822 XS(XS_Cwd_sys_is_relative)
1826 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1829 char * path = (char *)SvPV(ST(0),n_a);
1832 RETVAL = sys_is_relative(path);
1833 ST(0) = boolSV(RETVAL);
1834 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1843 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1847 RETVAL = _getcwd2(p, MAXPATHLEN);
1848 ST(0) = sv_newmortal();
1849 sv_setpv((SV*)ST(0), RETVAL);
1854 XS(XS_Cwd_sys_abspath)
1857 if (items < 1 || items > 2)
1858 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1861 char * path = (char *)SvPV(ST(0),n_a);
1869 dir = (char *)SvPV(ST(1),n_a);
1871 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1875 if (_abspath(p, path, MAXPATHLEN) == 0) {
1881 /* Absolute with drive: */
1882 if ( sys_is_absolute(path) ) {
1883 if (_abspath(p, path, MAXPATHLEN) == 0) {
1888 } else if (path[0] == '/' || path[0] == '\\') {
1889 /* Rooted, but maybe on different drive. */
1890 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1891 char p1[MAXPATHLEN];
1893 /* Need to prepend the drive. */
1896 Copy(path, p1 + 2, strlen(path) + 1, char);
1898 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1903 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1909 /* Either path is relative, or starts with a drive letter. */
1910 /* If the path starts with a drive letter, then dir is
1912 a/b) it is absolute/x:relative on the same drive.
1913 c) path is on current drive, and dir is rooted
1914 In all the cases it is safe to drop the drive part
1916 if ( !sys_is_relative(path) ) {
1919 if ( ( ( sys_is_absolute(dir)
1920 || (isALPHA(dir[0]) && dir[1] == ':'
1921 && strnicmp(dir, path,1) == 0))
1922 && strnicmp(dir, path,1) == 0)
1923 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1924 && toupper(path[0]) == current_drive())) {
1926 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1927 RETVAL = p; goto done;
1929 RETVAL = NULL; goto done;
1933 /* Need to prepend the absolute path of dir. */
1934 char p1[MAXPATHLEN];
1936 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1939 if (p1[ l - 1 ] != '/') {
1943 Copy(path, p1 + l, strlen(path) + 1, char);
1944 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1956 ST(0) = sv_newmortal();
1957 sv_setpv((SV*)ST(0), RETVAL);
1961 typedef APIRET (*PELP)(PSZ path, ULONG type);
1964 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1966 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1967 return (*(PELP)ExtFCN[ord])(path, type);
1970 #define extLibpath(type) \
1971 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1972 : BEGIN_LIBPATH))) \
1975 #define extLibpath_set(p,type) \
1976 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1979 XS(XS_Cwd_extLibpath)
1982 if (items < 0 || items > 1)
1983 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
1993 type = (int)SvIV(ST(0));
1996 RETVAL = extLibpath(type);
1997 ST(0) = sv_newmortal();
1998 sv_setpv((SV*)ST(0), RETVAL);
2003 XS(XS_Cwd_extLibpath_set)
2006 if (items < 1 || items > 2)
2007 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2010 char * s = (char *)SvPV(ST(0),n_a);
2018 type = (int)SvIV(ST(1));
2021 RETVAL = extLibpath_set(s, type);
2022 ST(0) = boolSV(RETVAL);
2023 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2031 char *file = __FILE__;
2035 if (_emx_env & 0x200) { /* OS/2 */
2036 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2037 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2038 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2040 newXS("OS2::Error", XS_OS2_Error, file);
2041 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2042 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2043 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2044 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2045 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2046 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2047 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2048 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2049 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2050 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2051 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2052 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2053 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2054 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2055 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2056 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2057 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2060 sv_setiv(GvSV(gv), 1);
2062 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2064 sv_setiv(GvSV(gv), _emx_rev);
2065 sv_setpv(GvSV(gv), _emx_vprt);
2067 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2069 sv_setiv(GvSV(gv), _emx_env);
2070 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2072 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2076 OS2_Perl_data_t OS2_Perl_data;
2079 Perl_OS2_init(char **env)
2085 OS2_Perl_data.xs_init = &Xs_OS2_init;
2086 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2087 if (environ == NULL && env) {
2090 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2091 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2092 strcpy(PL_sh_path, SH_PATH);
2093 PL_sh_path[0] = shell[0];
2094 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2095 int l = strlen(shell), i;
2096 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2099 New(1304, PL_sh_path, l + 8, char);
2100 strncpy(PL_sh_path, shell, l);
2101 strcpy(PL_sh_path + l, "/sh.exe");
2102 for (i = 0; i < l; i++) {
2103 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2106 MUTEX_INIT(&start_thread_mutex);
2107 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2114 my_tmpnam (char *str)
2116 char *p = getenv("TMP"), *tpath;
2119 if (!p) p = getenv("TEMP");
2120 tpath = tempnam(p, "pltmp");
2134 if (s.st_mode & S_IWOTH) {
2137 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2143 /* This code was contributed by Rocco Caputo. */
2145 my_flock(int handle, int o)
2147 FILELOCK rNull, rFull;
2148 ULONG timeout, handle_type, flag_word;
2150 int blocking, shared;
2151 static int use_my = -1;
2154 char *s = getenv("USE_PERL_FLOCK");
2160 if (!(_emx_env & 0x200) || !use_my)
2161 return flock(handle, o); /* Delegate to EMX. */
2164 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2165 (handle_type & 0xFF))
2170 // set lock/unlock ranges
2171 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2172 rFull.lRange = 0x7FFFFFFF;
2173 // set timeout for blocking
2174 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2175 // shared or exclusive?
2176 shared = (o & LOCK_SH) ? 1 : 0;
2177 // do not block the unlock
2178 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2179 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2184 case ERROR_INVALID_HANDLE:
2187 case ERROR_SHARING_BUFFER_EXCEEDED:
2190 case ERROR_LOCK_VIOLATION:
2191 break; // not an error
2192 case ERROR_INVALID_PARAMETER:
2193 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2194 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2197 case ERROR_INTERRUPT:
2206 if (o & (LOCK_SH | LOCK_EX)) {
2207 // for blocking operations
2221 case ERROR_INVALID_HANDLE:
2224 case ERROR_SHARING_BUFFER_EXCEEDED:
2227 case ERROR_LOCK_VIOLATION:
2229 errno = EWOULDBLOCK;
2233 case ERROR_INVALID_PARAMETER:
2234 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2235 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2238 case ERROR_INTERRUPT:
2245 // give away timeslice