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 #ifndef HAS_GETHOSTENT /* Older versions of EMX did not have it... */
1166 void * gethostent() { return tcp0("GETHOSTENT"); }
1167 void * getnetent() { return tcp0("GETNETENT"); }
1168 void * getprotoent() { return tcp0("GETPROTOENT"); }
1169 void * getservent() { return tcp0("GETSERVENT"); }
1172 void sethostent(x) { tcp1("SETHOSTENT", x); }
1173 void setnetent(x) { tcp1("SETNETENT", x); }
1174 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1175 void setservent(x) { tcp1("SETSERVENT", x); }
1176 void endhostent() { tcp0("ENDHOSTENT"); }
1177 void endnetent() { tcp0("ENDNETENT"); }
1178 void endprotoent() { tcp0("ENDPROTOENT"); }
1179 void endservent() { tcp0("ENDSERVENT"); }
1181 /*****************************************************************************/
1182 /* not implemented in C Set++ */
1185 int setuid(x) { errno = EINVAL; return -1; }
1186 int setgid(x) { errno = EINVAL; return -1; }
1189 /*****************************************************************************/
1190 /* stat() hack for char/block device */
1194 /* First attempt used DosQueryFSAttach which crashed the system when
1195 used with 5.001. Now just look for /dev/. */
1198 os2_stat(char *name, struct stat *st)
1200 static int ino = SHRT_MAX;
1202 if (stricmp(name, "/dev/con") != 0
1203 && stricmp(name, "/dev/tty") != 0)
1204 return stat(name, st);
1206 memset(st, 0, sizeof *st);
1207 st->st_mode = S_IFCHR|0666;
1208 st->st_ino = (ino-- & 0x7FFF);
1215 #ifdef USE_PERL_SBRK
1217 /* SBRK() emulation, mostly moved to malloc.c. */
1220 sys_alloc(int size) {
1222 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1224 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1227 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1231 #endif /* USE_PERL_SBRK */
1235 char *tmppath = TMPPATH1;
1240 char *p = getenv("TMP"), *tpath;
1243 if (!p) p = getenv("TEMP");
1246 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1250 strcpy(tpath + len + 1, TMPPATH1);
1257 XS(XS_File__Copy_syscopy)
1260 if (items < 2 || items > 3)
1261 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1264 char * src = (char *)SvPV(ST(0),n_a);
1265 char * dst = (char *)SvPV(ST(1),n_a);
1272 flag = (unsigned long)SvIV(ST(2));
1275 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1276 ST(0) = sv_newmortal();
1277 sv_setiv(ST(0), (IV)RETVAL);
1282 #include "patchlevel.h"
1285 mod2fname(pTHX_ SV *sv)
1287 static char fname[9];
1288 int pos = 6, len, avlen;
1289 unsigned int sum = 0;
1295 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1297 if (SvTYPE(sv) != SVt_PVAV)
1298 Perl_croak_nocontext("Not array reference given to mod2fname");
1300 avlen = av_len((AV*)sv);
1302 Perl_croak_nocontext("Empty array reference given to mod2fname");
1304 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1305 strncpy(fname, s, 8);
1307 if (len < 6) pos = len;
1309 sum = 33 * sum + *(s++); /* Checksumming first chars to
1310 * get the capitalization into c.s. */
1313 while (avlen >= 0) {
1314 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1316 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1321 sum++; /* Avoid conflict of DLLs in memory. */
1323 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1324 fname[pos] = 'A' + (sum % 26);
1325 fname[pos + 1] = 'A' + (sum / 26 % 26);
1326 fname[pos + 2] = '\0';
1327 return (char *)fname;
1330 XS(XS_DynaLoader_mod2fname)
1334 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1339 RETVAL = mod2fname(aTHX_ sv);
1340 ST(0) = sv_newmortal();
1341 sv_setpv((SV*)ST(0), RETVAL);
1349 static char buf[300];
1352 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1355 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1356 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1359 if (len && buf[len - 1] == '\n')
1361 if (len && buf[len - 1] == '\r')
1363 if (len && buf[len - 1] == '.')
1374 if (_execname(buf, sizeof buf) != 0)
1375 return PL_origargv[0];
1388 perllib_mangle(char *s, unsigned int l)
1390 static char *newp, *oldp;
1391 static int newl, oldl, notfound;
1392 static char ret[STATIC_FILE_LENGTH+1];
1394 if (!newp && !notfound) {
1395 newp = getenv("PERLLIB_PREFIX");
1400 while (*newp && !isSPACE(*newp) && *newp != ';') {
1401 newp++; oldl++; /* Skip digits. */
1403 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1404 newp++; /* Skip whitespace. */
1406 newl = strlen(newp);
1407 if (newl == 0 || oldl == 0) {
1408 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1413 if (*s == '\\') *s = '/';
1426 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1429 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1430 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1432 strcpy(ret + newl, s + oldl);
1437 Perl_hab_GET() /* Needed if perl.h cannot be included */
1439 return perl_hab_GET();
1443 Perl_Register_MQ(int serve)
1448 if (Perl_os2_initial_mode++)
1450 DosGetInfoBlocks(&tib, &pib);
1451 Perl_os2_initial_mode = pib->pib_ultype;
1452 Perl_hmq_refcnt = 1;
1453 /* Try morphing into a PM application. */
1454 if (pib->pib_ultype != 3) /* 2 is VIO */
1455 pib->pib_ultype = 3; /* 3 is PM */
1456 init_PMWIN_entries();
1457 /* 64 messages if before OS/2 3.0, ignored otherwise */
1458 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1462 _exit(188); /* Panic can try to create a window. */
1463 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1469 Perl_Serve_Messages(int force)
1474 if (Perl_hmq_servers && !force)
1476 if (!Perl_hmq_refcnt)
1477 Perl_croak_nocontext("No message queue");
1478 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1480 if (msg.msg == WM_QUIT)
1481 Perl_croak_nocontext("QUITing...");
1482 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1488 Perl_Process_Messages(int force, I32 *cntp)
1492 if (Perl_hmq_servers && !force)
1494 if (!Perl_hmq_refcnt)
1495 Perl_croak_nocontext("No message queue");
1496 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1499 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1500 if (msg.msg == WM_DESTROY)
1502 if (msg.msg == WM_CREATE)
1505 Perl_croak_nocontext("QUITing...");
1509 Perl_Deregister_MQ(int serve)
1514 if (--Perl_hmq_refcnt == 0) {
1515 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1517 /* Try morphing back from a PM application. */
1518 if (pib->pib_ultype == 3) /* 3 is PM */
1519 pib->pib_ultype = Perl_os2_initial_mode;
1521 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1526 extern void dlopen();
1527 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1529 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1530 && ((path)[2] == '/' || (path)[2] == '\\'))
1531 #define sys_is_rooted _fnisabs
1532 #define sys_is_relative _fnisrel
1533 #define current_drive _getdrive
1535 #undef chdir /* Was _chdir2. */
1536 #define sys_chdir(p) (chdir(p) == 0)
1537 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1539 static int DOS_harderr_state = -1;
1545 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1547 int arg1 = SvIV(ST(0));
1548 int arg2 = SvIV(ST(1));
1549 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1550 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1551 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1554 if (CheckOSError(DosError(a)))
1555 Perl_croak_nocontext("DosError(%d) failed", a);
1556 ST(0) = sv_newmortal();
1557 if (DOS_harderr_state >= 0)
1558 sv_setiv(ST(0), DOS_harderr_state);
1559 DOS_harderr_state = RETVAL;
1564 static signed char DOS_suppression_state = -1;
1566 XS(XS_OS2_Errors2Drive)
1570 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1574 int suppress = SvOK(sv);
1575 char *s = suppress ? SvPV(sv, n_a) : NULL;
1576 char drive = (s ? *s : 0);
1579 if (suppress && !isALPHA(drive))
1580 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1581 if (CheckOSError(DosSuppressPopUps((suppress
1582 ? SPU_ENABLESUPPRESSION
1583 : SPU_DISABLESUPPRESSION),
1585 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1586 ST(0) = sv_newmortal();
1587 if (DOS_suppression_state > 0)
1588 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1589 else if (DOS_suppression_state == 0)
1590 sv_setpvn(ST(0), "", 0);
1591 DOS_suppression_state = drive;
1596 static const char * const si_fields[QSV_MAX] = {
1598 "MAX_TEXT_SESSIONS",
1602 "DYN_PRI_VARIATION",
1620 "FOREGROUND_FS_SESSION",
1621 "FOREGROUND_PROCESS"
1628 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1630 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1631 APIRET rc = NO_ERROR; /* Return code */
1634 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1635 QSV_MAX, /* information */
1638 Perl_croak_nocontext("DosQuerySysInfo() failed");
1639 EXTEND(SP,2*QSV_MAX);
1640 while (i < QSV_MAX) {
1641 ST(j) = sv_newmortal();
1642 sv_setpv(ST(j++), si_fields[i]);
1643 ST(j) = sv_newmortal();
1644 sv_setiv(ST(j++), si[i]);
1648 XSRETURN(2 * QSV_MAX);
1651 XS(XS_OS2_BootDrive)
1655 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1657 ULONG si[1] = {0}; /* System Information Data Buffer */
1658 APIRET rc = NO_ERROR; /* Return code */
1661 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1662 (PVOID)si, sizeof(si))))
1663 Perl_croak_nocontext("DosQuerySysInfo() failed");
1664 ST(0) = sv_newmortal();
1665 c = 'a' - 1 + si[0];
1666 sv_setpvn(ST(0), &c, 1);
1675 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1677 bool serve = SvOK(ST(0));
1678 unsigned long pmq = perl_hmq_GET(serve);
1680 ST(0) = sv_newmortal();
1681 sv_setiv(ST(0), pmq);
1686 XS(XS_OS2_UnMorphPM)
1690 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1692 bool serve = SvOK(ST(0));
1694 perl_hmq_UNSET(serve);
1699 XS(XS_OS2_Serve_Messages)
1703 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1705 bool force = SvOK(ST(0));
1706 unsigned long cnt = Perl_Serve_Messages(force);
1708 ST(0) = sv_newmortal();
1709 sv_setiv(ST(0), cnt);
1714 XS(XS_OS2_Process_Messages)
1717 if (items < 1 || items > 2)
1718 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1720 bool force = SvOK(ST(0));
1726 int fake = SvIV(sv); /* Force SvIVX */
1729 Perl_croak_nocontext("Can't upgrade count to IV");
1731 cnt = Perl_Process_Messages(force, &cntr);
1734 cnt = Perl_Process_Messages(force, NULL);
1736 ST(0) = sv_newmortal();
1737 sv_setiv(ST(0), cnt);
1742 XS(XS_Cwd_current_drive)
1746 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1750 RETVAL = current_drive();
1751 ST(0) = sv_newmortal();
1752 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1757 XS(XS_Cwd_sys_chdir)
1761 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1764 char * path = (char *)SvPV(ST(0),n_a);
1767 RETVAL = sys_chdir(path);
1768 ST(0) = boolSV(RETVAL);
1769 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1774 XS(XS_Cwd_change_drive)
1778 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1781 char d = (char)*SvPV(ST(0),n_a);
1784 RETVAL = change_drive(d);
1785 ST(0) = boolSV(RETVAL);
1786 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1791 XS(XS_Cwd_sys_is_absolute)
1795 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1798 char * path = (char *)SvPV(ST(0),n_a);
1801 RETVAL = sys_is_absolute(path);
1802 ST(0) = boolSV(RETVAL);
1803 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1808 XS(XS_Cwd_sys_is_rooted)
1812 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1815 char * path = (char *)SvPV(ST(0),n_a);
1818 RETVAL = sys_is_rooted(path);
1819 ST(0) = boolSV(RETVAL);
1820 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1825 XS(XS_Cwd_sys_is_relative)
1829 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1832 char * path = (char *)SvPV(ST(0),n_a);
1835 RETVAL = sys_is_relative(path);
1836 ST(0) = boolSV(RETVAL);
1837 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1846 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1850 RETVAL = _getcwd2(p, MAXPATHLEN);
1851 ST(0) = sv_newmortal();
1852 sv_setpv((SV*)ST(0), RETVAL);
1857 XS(XS_Cwd_sys_abspath)
1860 if (items < 1 || items > 2)
1861 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1864 char * path = (char *)SvPV(ST(0),n_a);
1872 dir = (char *)SvPV(ST(1),n_a);
1874 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1878 if (_abspath(p, path, MAXPATHLEN) == 0) {
1884 /* Absolute with drive: */
1885 if ( sys_is_absolute(path) ) {
1886 if (_abspath(p, path, MAXPATHLEN) == 0) {
1891 } else if (path[0] == '/' || path[0] == '\\') {
1892 /* Rooted, but maybe on different drive. */
1893 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1894 char p1[MAXPATHLEN];
1896 /* Need to prepend the drive. */
1899 Copy(path, p1 + 2, strlen(path) + 1, char);
1901 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1906 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1912 /* Either path is relative, or starts with a drive letter. */
1913 /* If the path starts with a drive letter, then dir is
1915 a/b) it is absolute/x:relative on the same drive.
1916 c) path is on current drive, and dir is rooted
1917 In all the cases it is safe to drop the drive part
1919 if ( !sys_is_relative(path) ) {
1922 if ( ( ( sys_is_absolute(dir)
1923 || (isALPHA(dir[0]) && dir[1] == ':'
1924 && strnicmp(dir, path,1) == 0))
1925 && strnicmp(dir, path,1) == 0)
1926 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1927 && toupper(path[0]) == current_drive())) {
1929 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1930 RETVAL = p; goto done;
1932 RETVAL = NULL; goto done;
1936 /* Need to prepend the absolute path of dir. */
1937 char p1[MAXPATHLEN];
1939 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1942 if (p1[ l - 1 ] != '/') {
1946 Copy(path, p1 + l, strlen(path) + 1, char);
1947 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1959 ST(0) = sv_newmortal();
1960 sv_setpv((SV*)ST(0), RETVAL);
1964 typedef APIRET (*PELP)(PSZ path, ULONG type);
1967 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1969 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1970 return (*(PELP)ExtFCN[ord])(path, type);
1973 #define extLibpath(type) \
1974 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1975 : BEGIN_LIBPATH))) \
1978 #define extLibpath_set(p,type) \
1979 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1982 XS(XS_Cwd_extLibpath)
1985 if (items < 0 || items > 1)
1986 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
1996 type = (int)SvIV(ST(0));
1999 RETVAL = extLibpath(type);
2000 ST(0) = sv_newmortal();
2001 sv_setpv((SV*)ST(0), RETVAL);
2006 XS(XS_Cwd_extLibpath_set)
2009 if (items < 1 || items > 2)
2010 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2013 char * s = (char *)SvPV(ST(0),n_a);
2021 type = (int)SvIV(ST(1));
2024 RETVAL = extLibpath_set(s, type);
2025 ST(0) = boolSV(RETVAL);
2026 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2034 char *file = __FILE__;
2038 if (_emx_env & 0x200) { /* OS/2 */
2039 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2040 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2041 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2043 newXS("OS2::Error", XS_OS2_Error, file);
2044 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2045 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2046 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2047 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2048 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2049 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2050 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2051 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2052 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2053 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2054 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2055 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2056 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2057 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2058 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2059 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2060 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2063 sv_setiv(GvSV(gv), 1);
2065 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2067 sv_setiv(GvSV(gv), _emx_rev);
2068 sv_setpv(GvSV(gv), _emx_vprt);
2070 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2072 sv_setiv(GvSV(gv), _emx_env);
2073 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2075 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2079 OS2_Perl_data_t OS2_Perl_data;
2082 Perl_OS2_init(char **env)
2088 OS2_Perl_data.xs_init = &Xs_OS2_init;
2089 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2090 if (environ == NULL && env) {
2093 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2094 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2095 strcpy(PL_sh_path, SH_PATH);
2096 PL_sh_path[0] = shell[0];
2097 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2098 int l = strlen(shell), i;
2099 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2102 New(1304, PL_sh_path, l + 8, char);
2103 strncpy(PL_sh_path, shell, l);
2104 strcpy(PL_sh_path + l, "/sh.exe");
2105 for (i = 0; i < l; i++) {
2106 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2109 MUTEX_INIT(&start_thread_mutex);
2110 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2117 my_tmpnam (char *str)
2119 char *p = getenv("TMP"), *tpath;
2122 if (!p) p = getenv("TEMP");
2123 tpath = tempnam(p, "pltmp");
2137 if (s.st_mode & S_IWOTH) {
2140 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2146 /* This code was contributed by Rocco Caputo. */
2148 my_flock(int handle, int o)
2150 FILELOCK rNull, rFull;
2151 ULONG timeout, handle_type, flag_word;
2153 int blocking, shared;
2154 static int use_my = -1;
2157 char *s = getenv("USE_PERL_FLOCK");
2163 if (!(_emx_env & 0x200) || !use_my)
2164 return flock(handle, o); /* Delegate to EMX. */
2167 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2168 (handle_type & 0xFF))
2173 // set lock/unlock ranges
2174 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2175 rFull.lRange = 0x7FFFFFFF;
2176 // set timeout for blocking
2177 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2178 // shared or exclusive?
2179 shared = (o & LOCK_SH) ? 1 : 0;
2180 // do not block the unlock
2181 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2182 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2187 case ERROR_INVALID_HANDLE:
2190 case ERROR_SHARING_BUFFER_EXCEEDED:
2193 case ERROR_LOCK_VIOLATION:
2194 break; // not an error
2195 case ERROR_INVALID_PARAMETER:
2196 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2197 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2200 case ERROR_INTERRUPT:
2209 if (o & (LOCK_SH | LOCK_EX)) {
2210 // for blocking operations
2224 case ERROR_INVALID_HANDLE:
2227 case ERROR_SHARING_BUFFER_EXCEEDED:
2230 case ERROR_LOCK_VIOLATION:
2232 errno = EWOULDBLOCK;
2236 case ERROR_INVALID_PARAMETER:
2237 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2238 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2241 case ERROR_INTERRUPT:
2248 // give away timeslice