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)
382 Signal_t (*ihand)(); /* place to save signal during system() */
383 Signal_t (*qhand)(); /* place to save signal during system() */
389 if (pid < 0 || flag != 0)
395 ihand = rsignal(SIGINT, &spawn_sighandler);
396 qhand = rsignal(SIGQUIT, &spawn_sighandler);
398 r = wait4pid(pid, &status, 0);
399 } while (r == -1 && errno == EINTR);
400 rsignal(SIGINT, ihand);
401 rsignal(SIGQUIT, qhand);
403 PL_statusvalue = (U16)status;
406 return status & 0xFFFF;
408 ihand = rsignal(SIGINT, SIG_IGN);
409 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
410 rsignal(SIGINT, ihand);
411 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
414 return PL_statusvalue;
418 #define EXECF_SPAWN 0
420 #define EXECF_TRUEEXEC 2
421 #define EXECF_SPAWN_NOWAIT 3
422 #define EXECF_SPAWN_BYFLAG 4
424 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
433 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
434 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
437 return (pib->pib_ultype);
441 file_type(char *path)
446 if (!(_emx_env & 0x200))
447 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
448 if (CheckOSError(DosQueryAppType(path, &apptype))) {
450 case ERROR_FILE_NOT_FOUND:
451 case ERROR_PATH_NOT_FOUND:
453 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
455 default: /* Found, but not an
456 executable, or some other
464 static ULONG os2_mytype;
466 /* Spawn/exec a program, revert to shell if needed. */
467 /* global PL_Argv[] contains arguments. */
470 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
476 char buf[256], *s = 0, scrbuf[280];
478 static char * fargs[4]
479 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
480 char **argsp = fargs;
483 int new_stderr = -1, nostderr = 0, fl_stderr;
490 if (strEQ(PL_Argv[0],"/bin/sh"))
491 PL_Argv[0] = PL_sh_path;
493 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
494 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
495 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
496 ) /* will spawnvp use PATH? */
497 TAINT_ENV(); /* testing IFS here is overkill, probably */
498 /* We should check PERL_SH* and PERLLIB_* as well? */
499 if (!really || !*(tmps = SvPV(really, n_a)))
504 if (_emx_env & 0x200) { /* OS/2. */
505 int type = file_type(tmps);
507 if (type == -1) { /* Not found */
512 else if (type == -2) { /* Not an EXE */
517 else if (type == -3) { /* Is a directory? */
518 /* Special-case this */
520 int l = strlen(tmps);
522 if (l + 5 <= sizeof tbuf) {
524 strcpy(tbuf + l, ".exe");
525 type = file_type(tbuf);
535 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
536 case FAPPTYP_WINDOWAPI:
538 if (os2_mytype != 3) { /* not PM */
539 if (flag == P_NOWAIT)
541 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
542 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
547 case FAPPTYP_NOTWINDOWCOMPAT:
549 if (os2_mytype != 0) { /* not full screen */
550 if (flag == P_NOWAIT)
552 else if ((flag & 7) != P_SESSION)
553 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
558 case FAPPTYP_NOTSPEC:
559 /* Let the shell handle this... */
568 new_stderr = dup(2); /* Preserve stderr */
569 if (new_stderr == -1) {
577 fl_stderr = fcntl(2, F_GETFD);
581 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
585 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
587 if (execf == EXECF_TRUEEXEC)
588 rc = execvp(tmps,PL_Argv);
589 else if (execf == EXECF_EXEC)
590 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
591 else if (execf == EXECF_SPAWN_NOWAIT)
592 rc = spawnvp(flag,tmps,PL_Argv);
593 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
594 rc = result(aTHX_ trueflag,
595 spawnvp(flag,tmps,PL_Argv));
597 if (rc < 0 && pass == 1
598 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
603 if (err == ENOENT || err == ENOEXEC) {
604 /* No such file, or is a script. */
605 /* Try adding script extensions to the file name, and
607 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
612 char *s = 0, *s1, *s2;
617 if (l >= sizeof scrbuf) {
620 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
628 file = PerlIO_open(scr, "r");
633 rd = PerlIO_read(file, buf, sizeof buf-1);
635 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
637 if (!rd) { /* Empty... */
640 /* Special case: maybe from -Zexe build, so
641 there is an executable around (contrary to
642 documentation, DosQueryAppType sometimes (?)
643 does not append ".exe", so we could have
644 reached this place). */
645 if (l + 5 < sizeof scrbuf) {
646 strcpy(scrbuf + l, ".exe");
647 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
648 && !S_ISDIR(PL_statbuf.st_mode)) {
658 if (PerlIO_close(file) != 0) { /* Failure */
660 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
661 scr, Strerror(errno));
662 buf[0] = 0; /* Not #! */
668 } else if (buf[0] == 'e') {
669 if (strnEQ(buf, "extproc", 7)
672 } else if (buf[0] == 'E') {
673 if (strnEQ(buf, "EXTPROC", 7)
678 buf[0] = 0; /* Not #! */
686 /* Do better than pdksh: allow a few args,
687 strip trailing whitespace. */
697 while (*s && !isSPACE(*s))
704 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
715 || (!buf[0] && file)) { /* File without magic */
716 /* In fact we tried all what pdksh would
717 try. There is no point in calling
718 pdksh, we may just emulate its logic. */
719 char *shell = getenv("EXECSHELL");
720 char *shell_opt = NULL;
726 shell = getenv("OS2_SHELL");
727 if (inicmd) { /* No spaces at start! */
729 while (*s && !isSPACE(*s)) {
731 inicmd = NULL; /* Cannot use */
739 /* Dosish shells will choke on slashes
740 in paths, fortunately, this is
741 important for zeroth arg only. */
748 /* If EXECSHELL is set, we do not set */
751 shell = ((_emx_env & 0x200)
754 nargs = shell_opt ? 2 : 1; /* shell file args */
755 exec_args[0] = shell;
756 exec_args[1] = shell_opt;
758 if (nargs == 2 && inicmd) {
759 /* Use the original cmd line */
760 /* XXXX This is good only until we refuse
761 quoted arguments... */
765 } else if (!buf[0] && inicmd) { /* No file */
766 /* Start with the original cmdline. */
767 /* XXXX This is good only until we refuse
768 quoted arguments... */
772 nargs = 2; /* shell -c */
775 while (a[1]) /* Get to the end */
777 a++; /* Copy finil NULL too */
778 while (a >= PL_Argv) {
779 *(a + nargs) = *a; /* PL_Argv was preallocated to be
784 PL_Argv[nargs] = argsp[nargs];
785 /* Enable pathless exec if #! (as pdksh). */
786 pass = (buf[0] == '#' ? 2 : 3);
790 /* Not found: restore errno */
794 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
795 char *no_dir = strrchr(PL_Argv[0], '/');
797 /* Do as pdksh port does: if not found with /, try without
800 PL_Argv[0] = no_dir + 1;
805 if (rc < 0 && ckWARN(WARN_EXEC))
806 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
807 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
809 PL_Argv[0], Strerror(errno));
810 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
811 && ((trueflag & 0xFF) == P_WAIT))
815 if (new_stderr != -1) { /* How can we use error codes? */
818 fcntl(2, F_SETFD, fl_stderr);
824 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
826 do_spawn3(pTHX_ char *cmd, int execf, int flag)
832 char *shell, *copt, *news = NULL;
833 int rc, err, seenspace = 0, mergestderr = 0;
834 char fullcmd[MAXNAMLEN + 1];
837 if ((shell = getenv("EMXSHELL")) != NULL)
839 else if ((shell = getenv("SHELL")) != NULL)
841 else if ((shell = getenv("COMSPEC")) != NULL)
846 /* Consensus on perl5-porters is that it is _very_ important to
847 have a shell which will not change between computers with the
848 same architecture, to avoid "action on a distance".
849 And to have simple build, this shell should be sh. */
854 while (*cmd && isSPACE(*cmd))
857 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
858 STRLEN l = strlen(PL_sh_path);
860 New(1302, news, strlen(cmd) - 7 + l + 1, char);
861 strcpy(news, PL_sh_path);
862 strcpy(news + l, cmd + 7);
866 /* save an extra exec if possible */
867 /* see if there are shell metacharacters in it */
869 if (*cmd == '.' && isSPACE(cmd[1]))
872 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
875 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
879 for (s = cmd; *s; s++) {
880 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
881 if (*s == '\n' && s[1] == '\0') {
884 } else if (*s == '\\' && !seenspace) {
885 continue; /* Allow backslashes in names */
886 } else if (*s == '>' && s >= cmd + 3
887 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
888 && isSPACE(s[-2]) ) {
891 while (*t && isSPACE(*t))
896 break; /* Allow 2>&1 as the last thing */
899 /* We do not convert this to do_spawn_ve since shell
900 should be smart enough to start itself gloriously. */
902 if (execf == EXECF_TRUEEXEC)
903 rc = execl(shell,shell,copt,cmd,(char*)0);
904 else if (execf == EXECF_EXEC)
905 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
906 else if (execf == EXECF_SPAWN_NOWAIT)
907 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
908 else if (execf == EXECF_SPAWN_BYFLAG)
909 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
911 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
912 rc = result(aTHX_ P_WAIT,
913 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
914 if (rc < 0 && ckWARN(WARN_EXEC))
915 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
916 (execf == EXECF_SPAWN ? "spawn" : "exec"),
917 shell, Strerror(errno));
924 } else if (*s == ' ' || *s == '\t') {
929 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
930 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
931 PL_Cmd = savepvn(cmd, s-cmd);
933 for (s = PL_Cmd; *s;) {
934 while (*s && isSPACE(*s)) s++;
937 while (*s && !isSPACE(*s)) s++;
943 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
954 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
959 int flag = P_WAIT, flag_set = 0;
963 New(1301,PL_Argv, sp - mark + 3, char*);
966 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
973 while (++mark <= sp) {
975 *a++ = SvPVx(*mark, n_a);
981 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
982 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
984 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
992 os2_do_spawn(pTHX_ char *cmd)
995 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
999 do_spawn_nowait(pTHX_ char *cmd)
1002 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1006 Perl_do_exec(pTHX_ char *cmd)
1009 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1014 os2exec(pTHX_ char *cmd)
1017 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1021 my_syspopen(pTHX_ char *cmd, char *mode)
1026 register I32 this, that, newfd;
1027 register I32 pid, rc;
1032 /* `this' is what we use in the parent, `that' in the child. */
1033 this = (*mode == 'w');
1037 taint_proper("Insecure %s%s", "EXEC");
1041 /* Now we need to spawn the child. */
1042 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1043 int new = dup(p[this]);
1050 newfd = dup(*mode == 'r'); /* Preserve std* */
1052 /* This cannot happen due to fh being bad after pipe(), since
1053 pipe() should have created fh 0 and 1 even if they were
1054 initially closed. But we closed p[this] before. */
1055 if (errno != EBADF) {
1062 fh_fl = fcntl(*mode == 'r', F_GETFD);
1063 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1064 dup2(p[that], *mode == 'r');
1067 /* Where is `this' and newfd now? */
1068 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1070 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1071 pid = do_spawn_nowait(aTHX_ cmd);
1073 close(*mode == 'r'); /* It was closed initially */
1074 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1075 dup2(newfd, *mode == 'r'); /* Return std* back. */
1077 fcntl(*mode == 'r', F_SETFD, fh_fl);
1079 fcntl(*mode == 'r', F_SETFD, fh_fl);
1080 if (p[that] == (*mode == 'r'))
1086 if (p[that] < p[this]) { /* Make fh as small as possible */
1087 dup2(p[this], p[that]);
1091 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1092 (void)SvUPGRADE(sv,SVt_IV);
1094 PL_forkprocess = pid;
1095 return PerlIO_fdopen(p[this], mode);
1097 #else /* USE_POPEN */
1103 res = popen(cmd, mode);
1105 char *shell = getenv("EMXSHELL");
1107 my_setenv("EMXSHELL", PL_sh_path);
1108 res = popen(cmd, mode);
1109 my_setenv("EMXSHELL", shell);
1111 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1112 (void)SvUPGRADE(sv,SVt_IV);
1113 SvIVX(sv) = -1; /* A cooky. */
1116 #endif /* USE_POPEN */
1120 /******************************************************************/
1126 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1132 /*******************************************************************/
1133 /* not implemented in EMX 0.9d */
1135 char * ctermid(char *s) { return 0; }
1137 #ifdef MYTTYNAME /* was not in emx0.9a */
1138 void * ttyname(x) { return 0; }
1141 /******************************************************************/
1142 /* my socket forwarders - EMX lib only provides static forwarders */
1144 static HMODULE htcp = 0;
1149 static BYTE buf[20];
1152 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1154 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1155 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1156 return (void *) ((void * (*)(void)) fcn) ();
1161 tcp1(char *name, int arg)
1163 static BYTE buf[20];
1166 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1168 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1169 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1170 ((void (*)(int)) fcn) (arg);
1173 void * gethostent() { return tcp0("GETHOSTENT"); }
1174 void * getnetent() { return tcp0("GETNETENT"); }
1175 void * getprotoent() { return tcp0("GETPROTOENT"); }
1176 void * getservent() { return tcp0("GETSERVENT"); }
1177 void sethostent(x) { tcp1("SETHOSTENT", x); }
1178 void setnetent(x) { tcp1("SETNETENT", x); }
1179 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1180 void setservent(x) { tcp1("SETSERVENT", x); }
1181 void endhostent() { tcp0("ENDHOSTENT"); }
1182 void endnetent() { tcp0("ENDNETENT"); }
1183 void endprotoent() { tcp0("ENDPROTOENT"); }
1184 void endservent() { tcp0("ENDSERVENT"); }
1186 /*****************************************************************************/
1187 /* not implemented in C Set++ */
1190 int setuid(x) { errno = EINVAL; return -1; }
1191 int setgid(x) { errno = EINVAL; return -1; }
1194 /*****************************************************************************/
1195 /* stat() hack for char/block device */
1199 /* First attempt used DosQueryFSAttach which crashed the system when
1200 used with 5.001. Now just look for /dev/. */
1203 os2_stat(char *name, struct stat *st)
1205 static int ino = SHRT_MAX;
1207 if (stricmp(name, "/dev/con") != 0
1208 && stricmp(name, "/dev/tty") != 0)
1209 return stat(name, st);
1211 memset(st, 0, sizeof *st);
1212 st->st_mode = S_IFCHR|0666;
1213 st->st_ino = (ino-- & 0x7FFF);
1220 #ifdef USE_PERL_SBRK
1222 /* SBRK() emulation, mostly moved to malloc.c. */
1225 sys_alloc(int size) {
1227 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1229 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1232 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1236 #endif /* USE_PERL_SBRK */
1240 char *tmppath = TMPPATH1;
1245 char *p = getenv("TMP"), *tpath;
1248 if (!p) p = getenv("TEMP");
1251 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1255 strcpy(tpath + len + 1, TMPPATH1);
1262 XS(XS_File__Copy_syscopy)
1265 if (items < 2 || items > 3)
1266 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1269 char * src = (char *)SvPV(ST(0),n_a);
1270 char * dst = (char *)SvPV(ST(1),n_a);
1277 flag = (unsigned long)SvIV(ST(2));
1280 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1281 ST(0) = sv_newmortal();
1282 sv_setiv(ST(0), (IV)RETVAL);
1287 #include "patchlevel.h"
1290 mod2fname(pTHX_ SV *sv)
1292 static char fname[9];
1293 int pos = 6, len, avlen;
1294 unsigned int sum = 0;
1300 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1302 if (SvTYPE(sv) != SVt_PVAV)
1303 Perl_croak_nocontext("Not array reference given to mod2fname");
1305 avlen = av_len((AV*)sv);
1307 Perl_croak_nocontext("Empty array reference given to mod2fname");
1309 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1310 strncpy(fname, s, 8);
1312 if (len < 6) pos = len;
1314 sum = 33 * sum + *(s++); /* Checksumming first chars to
1315 * get the capitalization into c.s. */
1318 while (avlen >= 0) {
1319 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1321 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1326 sum++; /* Avoid conflict of DLLs in memory. */
1328 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1329 fname[pos] = 'A' + (sum % 26);
1330 fname[pos + 1] = 'A' + (sum / 26 % 26);
1331 fname[pos + 2] = '\0';
1332 return (char *)fname;
1335 XS(XS_DynaLoader_mod2fname)
1339 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1344 RETVAL = mod2fname(aTHX_ sv);
1345 ST(0) = sv_newmortal();
1346 sv_setpv((SV*)ST(0), RETVAL);
1354 static char buf[300];
1357 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1360 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1361 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1364 if (len && buf[len - 1] == '\n')
1366 if (len && buf[len - 1] == '\r')
1368 if (len && buf[len - 1] == '.')
1380 if (_execname(buf, sizeof buf) != 0)
1381 return PL_origargv[0];
1394 perllib_mangle(char *s, unsigned int l)
1396 static char *newp, *oldp;
1397 static int newl, oldl, notfound;
1398 static char ret[STATIC_FILE_LENGTH+1];
1400 if (!newp && !notfound) {
1401 newp = getenv("PERLLIB_PREFIX");
1406 while (*newp && !isSPACE(*newp) && *newp != ';') {
1407 newp++; oldl++; /* Skip digits. */
1409 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1410 newp++; /* Skip whitespace. */
1412 newl = strlen(newp);
1413 if (newl == 0 || oldl == 0) {
1414 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1419 if (*s == '\\') *s = '/';
1432 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1435 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1436 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1438 strcpy(ret + newl, s + oldl);
1443 Perl_hab_GET() /* Needed if perl.h cannot be included */
1445 return perl_hab_GET();
1449 Perl_Register_MQ(int serve)
1454 if (Perl_os2_initial_mode++)
1456 DosGetInfoBlocks(&tib, &pib);
1457 Perl_os2_initial_mode = pib->pib_ultype;
1458 Perl_hmq_refcnt = 1;
1459 /* Try morphing into a PM application. */
1460 if (pib->pib_ultype != 3) /* 2 is VIO */
1461 pib->pib_ultype = 3; /* 3 is PM */
1462 init_PMWIN_entries();
1463 /* 64 messages if before OS/2 3.0, ignored otherwise */
1464 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1468 _exit(188); /* Panic can try to create a window. */
1469 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1475 Perl_Serve_Messages(int force)
1480 if (Perl_hmq_servers && !force)
1482 if (!Perl_hmq_refcnt)
1483 Perl_croak_nocontext("No message queue");
1484 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1486 if (msg.msg == WM_QUIT)
1487 Perl_croak_nocontext("QUITing...");
1488 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1494 Perl_Process_Messages(int force, I32 *cntp)
1498 if (Perl_hmq_servers && !force)
1500 if (!Perl_hmq_refcnt)
1501 Perl_croak_nocontext("No message queue");
1502 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1505 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1506 if (msg.msg == WM_DESTROY)
1508 if (msg.msg == WM_CREATE)
1511 Perl_croak_nocontext("QUITing...");
1515 Perl_Deregister_MQ(int serve)
1520 if (--Perl_hmq_refcnt == 0) {
1521 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1523 /* Try morphing back from a PM application. */
1524 if (pib->pib_ultype == 3) /* 3 is PM */
1525 pib->pib_ultype = Perl_os2_initial_mode;
1527 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1532 extern void dlopen();
1533 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1535 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1536 && ((path)[2] == '/' || (path)[2] == '\\'))
1537 #define sys_is_rooted _fnisabs
1538 #define sys_is_relative _fnisrel
1539 #define current_drive _getdrive
1541 #undef chdir /* Was _chdir2. */
1542 #define sys_chdir(p) (chdir(p) == 0)
1543 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1545 static int DOS_harderr_state = -1;
1551 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1553 int arg1 = SvIV(ST(0));
1554 int arg2 = SvIV(ST(1));
1555 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1556 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1557 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1560 if (CheckOSError(DosError(a)))
1561 Perl_croak_nocontext("DosError(%d) failed", a);
1562 ST(0) = sv_newmortal();
1563 if (DOS_harderr_state >= 0)
1564 sv_setiv(ST(0), DOS_harderr_state);
1565 DOS_harderr_state = RETVAL;
1570 static signed char DOS_suppression_state = -1;
1572 XS(XS_OS2_Errors2Drive)
1576 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1580 int suppress = SvOK(sv);
1581 char *s = suppress ? SvPV(sv, n_a) : NULL;
1582 char drive = (s ? *s : 0);
1585 if (suppress && !isALPHA(drive))
1586 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1587 if (CheckOSError(DosSuppressPopUps((suppress
1588 ? SPU_ENABLESUPPRESSION
1589 : SPU_DISABLESUPPRESSION),
1591 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1592 ST(0) = sv_newmortal();
1593 if (DOS_suppression_state > 0)
1594 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1595 else if (DOS_suppression_state == 0)
1596 sv_setpvn(ST(0), "", 0);
1597 DOS_suppression_state = drive;
1602 static const char * const si_fields[QSV_MAX] = {
1604 "MAX_TEXT_SESSIONS",
1608 "DYN_PRI_VARIATION",
1626 "FOREGROUND_FS_SESSION",
1627 "FOREGROUND_PROCESS"
1634 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1636 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1637 APIRET rc = NO_ERROR; /* Return code */
1640 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1641 QSV_MAX, /* information */
1644 Perl_croak_nocontext("DosQuerySysInfo() failed");
1645 EXTEND(SP,2*QSV_MAX);
1646 while (i < QSV_MAX) {
1647 ST(j) = sv_newmortal();
1648 sv_setpv(ST(j++), si_fields[i]);
1649 ST(j) = sv_newmortal();
1650 sv_setiv(ST(j++), si[i]);
1654 XSRETURN(2 * QSV_MAX);
1657 XS(XS_OS2_BootDrive)
1661 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1663 ULONG si[1] = {0}; /* System Information Data Buffer */
1664 APIRET rc = NO_ERROR; /* Return code */
1667 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1668 (PVOID)si, sizeof(si))))
1669 Perl_croak_nocontext("DosQuerySysInfo() failed");
1670 ST(0) = sv_newmortal();
1671 c = 'a' - 1 + si[0];
1672 sv_setpvn(ST(0), &c, 1);
1681 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1683 bool serve = SvOK(ST(0));
1684 unsigned long pmq = perl_hmq_GET(serve);
1686 ST(0) = sv_newmortal();
1687 sv_setiv(ST(0), pmq);
1692 XS(XS_OS2_UnMorphPM)
1696 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1698 bool serve = SvOK(ST(0));
1700 perl_hmq_UNSET(serve);
1705 XS(XS_OS2_Serve_Messages)
1709 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1711 bool force = SvOK(ST(0));
1712 unsigned long cnt = Perl_Serve_Messages(force);
1714 ST(0) = sv_newmortal();
1715 sv_setiv(ST(0), cnt);
1720 XS(XS_OS2_Process_Messages)
1723 if (items < 1 || items > 2)
1724 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1726 bool force = SvOK(ST(0));
1732 int fake = SvIV(sv); /* Force SvIVX */
1735 Perl_croak_nocontext("Can't upgrade count to IV");
1737 cnt = Perl_Process_Messages(force, &cntr);
1740 cnt = Perl_Process_Messages(force, NULL);
1742 ST(0) = sv_newmortal();
1743 sv_setiv(ST(0), cnt);
1748 XS(XS_Cwd_current_drive)
1752 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1756 RETVAL = current_drive();
1757 ST(0) = sv_newmortal();
1758 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1763 XS(XS_Cwd_sys_chdir)
1767 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1770 char * path = (char *)SvPV(ST(0),n_a);
1773 RETVAL = sys_chdir(path);
1774 ST(0) = boolSV(RETVAL);
1775 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1780 XS(XS_Cwd_change_drive)
1784 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1787 char d = (char)*SvPV(ST(0),n_a);
1790 RETVAL = change_drive(d);
1791 ST(0) = boolSV(RETVAL);
1792 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1797 XS(XS_Cwd_sys_is_absolute)
1801 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1804 char * path = (char *)SvPV(ST(0),n_a);
1807 RETVAL = sys_is_absolute(path);
1808 ST(0) = boolSV(RETVAL);
1809 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1814 XS(XS_Cwd_sys_is_rooted)
1818 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1821 char * path = (char *)SvPV(ST(0),n_a);
1824 RETVAL = sys_is_rooted(path);
1825 ST(0) = boolSV(RETVAL);
1826 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1831 XS(XS_Cwd_sys_is_relative)
1835 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1838 char * path = (char *)SvPV(ST(0),n_a);
1841 RETVAL = sys_is_relative(path);
1842 ST(0) = boolSV(RETVAL);
1843 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1852 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1856 RETVAL = _getcwd2(p, MAXPATHLEN);
1857 ST(0) = sv_newmortal();
1858 sv_setpv((SV*)ST(0), RETVAL);
1863 XS(XS_Cwd_sys_abspath)
1866 if (items < 1 || items > 2)
1867 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1870 char * path = (char *)SvPV(ST(0),n_a);
1878 dir = (char *)SvPV(ST(1),n_a);
1880 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1884 if (_abspath(p, path, MAXPATHLEN) == 0) {
1890 /* Absolute with drive: */
1891 if ( sys_is_absolute(path) ) {
1892 if (_abspath(p, path, MAXPATHLEN) == 0) {
1897 } else if (path[0] == '/' || path[0] == '\\') {
1898 /* Rooted, but maybe on different drive. */
1899 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1900 char p1[MAXPATHLEN];
1902 /* Need to prepend the drive. */
1905 Copy(path, p1 + 2, strlen(path) + 1, char);
1907 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1912 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1918 /* Either path is relative, or starts with a drive letter. */
1919 /* If the path starts with a drive letter, then dir is
1921 a/b) it is absolute/x:relative on the same drive.
1922 c) path is on current drive, and dir is rooted
1923 In all the cases it is safe to drop the drive part
1925 if ( !sys_is_relative(path) ) {
1928 if ( ( ( sys_is_absolute(dir)
1929 || (isALPHA(dir[0]) && dir[1] == ':'
1930 && strnicmp(dir, path,1) == 0))
1931 && strnicmp(dir, path,1) == 0)
1932 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1933 && toupper(path[0]) == current_drive())) {
1935 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1936 RETVAL = p; goto done;
1938 RETVAL = NULL; goto done;
1942 /* Need to prepend the absolute path of dir. */
1943 char p1[MAXPATHLEN];
1945 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1948 if (p1[ l - 1 ] != '/') {
1952 Copy(path, p1 + l, strlen(path) + 1, char);
1953 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1965 ST(0) = sv_newmortal();
1966 sv_setpv((SV*)ST(0), RETVAL);
1970 typedef APIRET (*PELP)(PSZ path, ULONG type);
1973 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1975 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
1976 return (*(PELP)ExtFCN[ord])(path, type);
1979 #define extLibpath(type) \
1980 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1981 : BEGIN_LIBPATH))) \
1984 #define extLibpath_set(p,type) \
1985 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1988 XS(XS_Cwd_extLibpath)
1991 if (items < 0 || items > 1)
1992 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2002 type = (int)SvIV(ST(0));
2005 RETVAL = extLibpath(type);
2006 ST(0) = sv_newmortal();
2007 sv_setpv((SV*)ST(0), RETVAL);
2012 XS(XS_Cwd_extLibpath_set)
2015 if (items < 1 || items > 2)
2016 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2019 char * s = (char *)SvPV(ST(0),n_a);
2027 type = (int)SvIV(ST(1));
2030 RETVAL = extLibpath_set(s, type);
2031 ST(0) = boolSV(RETVAL);
2032 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2040 char *file = __FILE__;
2044 if (_emx_env & 0x200) { /* OS/2 */
2045 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2046 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2047 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2049 newXS("OS2::Error", XS_OS2_Error, file);
2050 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2051 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2052 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2053 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2054 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2055 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2056 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2057 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2058 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2059 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2060 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2061 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2062 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2063 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2064 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2065 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2066 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2069 sv_setiv(GvSV(gv), 1);
2071 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2073 sv_setiv(GvSV(gv), _emx_rev);
2074 sv_setpv(GvSV(gv), _emx_vprt);
2076 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2078 sv_setiv(GvSV(gv), _emx_env);
2079 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2081 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2085 OS2_Perl_data_t OS2_Perl_data;
2088 Perl_OS2_init(char **env)
2094 OS2_Perl_data.xs_init = &Xs_OS2_init;
2095 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2096 if (environ == NULL && env) {
2099 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2100 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2101 strcpy(PL_sh_path, SH_PATH);
2102 PL_sh_path[0] = shell[0];
2103 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2104 int l = strlen(shell), i;
2105 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2108 New(1304, PL_sh_path, l + 8, char);
2109 strncpy(PL_sh_path, shell, l);
2110 strcpy(PL_sh_path + l, "/sh.exe");
2111 for (i = 0; i < l; i++) {
2112 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2115 MUTEX_INIT(&start_thread_mutex);
2116 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2123 my_tmpnam (char *str)
2125 char *p = getenv("TMP"), *tpath;
2128 if (!p) p = getenv("TEMP");
2129 tpath = tempnam(p, "pltmp");
2143 if (s.st_mode & S_IWOTH) {
2146 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2152 /* This code was contributed by Rocco Caputo. */
2154 my_flock(int handle, int o)
2156 FILELOCK rNull, rFull;
2157 ULONG timeout, handle_type, flag_word;
2159 int blocking, shared;
2160 static int use_my = -1;
2163 char *s = getenv("USE_PERL_FLOCK");
2169 if (!(_emx_env & 0x200) || !use_my)
2170 return flock(handle, o); /* Delegate to EMX. */
2173 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2174 (handle_type & 0xFF))
2179 // set lock/unlock ranges
2180 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2181 rFull.lRange = 0x7FFFFFFF;
2182 // set timeout for blocking
2183 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2184 // shared or exclusive?
2185 shared = (o & LOCK_SH) ? 1 : 0;
2186 // do not block the unlock
2187 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2188 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2193 case ERROR_INVALID_HANDLE:
2196 case ERROR_SHARING_BUFFER_EXCEEDED:
2199 case ERROR_LOCK_VIOLATION:
2200 break; // not an error
2201 case ERROR_INVALID_PARAMETER:
2202 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2203 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2206 case ERROR_INTERRUPT:
2215 if (o & (LOCK_SH | LOCK_EX)) {
2216 // for blocking operations
2230 case ERROR_INVALID_HANDLE:
2233 case ERROR_SHARING_BUFFER_EXCEEDED:
2236 case ERROR_LOCK_VIOLATION:
2238 errno = EWOULDBLOCK;
2242 case ERROR_INVALID_PARAMETER:
2243 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2244 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2247 case ERROR_INTERRUPT:
2254 // give away timeslice