3 #define INCL_DOSFILEMGR
6 /* These 3 are needed for compile if os2.h includes os2tk.h, not os2emx.h */
7 #define INCL_DOSPROCESS
8 #define SPU_DISABLESUPPRESSION 0
9 #define SPU_ENABLESUPPRESSION 1
13 #include <sys/uflags.h>
16 * Various Unix compatibility functions for OS/2
25 #define PERLIO_NOT_STDIO 0
32 typedef void (*emx_startroutine)(void *);
33 typedef void* (*pthreads_startroutine)(void *);
42 const char *pthreads_states[] = {
53 enum pthreads_state state;
56 thread_join_t *thread_join_data;
57 int thread_join_count;
58 perl_mutex start_thread_mutex;
61 pthread_join(perl_os_thread tid, void **status)
63 MUTEX_LOCK(&start_thread_mutex);
64 switch (thread_join_data[tid].state) {
65 case pthreads_st_exited:
66 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
67 MUTEX_UNLOCK(&start_thread_mutex);
68 *status = thread_join_data[tid].status;
70 case pthreads_st_waited:
71 MUTEX_UNLOCK(&start_thread_mutex);
72 Perl_croak_nocontext("join with a thread with a waiter");
75 thread_join_data[tid].state = pthreads_st_waited;
76 COND_INIT(&thread_join_data[tid].cond);
77 MUTEX_UNLOCK(&start_thread_mutex);
78 COND_WAIT(&thread_join_data[tid].cond, NULL);
79 COND_DESTROY(&thread_join_data[tid].cond);
80 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
81 *status = thread_join_data[tid].status;
84 MUTEX_UNLOCK(&start_thread_mutex);
85 Perl_croak_nocontext("join: unknown thread state: '%s'",
86 pthreads_states[thread_join_data[tid].state]);
93 pthread_startit(void *arg)
95 /* Thread is already started, we need to transfer control only */
96 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
97 int tid = pthread_self();
100 arg = ((void**)arg)[1];
101 if (tid >= thread_join_count) {
102 int oc = thread_join_count;
104 thread_join_count = tid + 5 + tid/5;
105 if (thread_join_data) {
106 Renew(thread_join_data, thread_join_count, thread_join_t);
107 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
109 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
112 if (thread_join_data[tid].state != pthreads_st_none)
113 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
114 thread_join_data[tid].state = pthreads_st_run;
115 /* Now that we copied/updated the guys, we may release the caller... */
116 MUTEX_UNLOCK(&start_thread_mutex);
117 thread_join_data[tid].status = (*start_routine)(arg);
118 switch (thread_join_data[tid].state) {
119 case pthreads_st_waited:
120 COND_SIGNAL(&thread_join_data[tid].cond);
123 thread_join_data[tid].state = pthreads_st_exited;
129 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
130 void *(*start_routine)(void*), void *arg)
134 args[0] = (void*)start_routine;
137 MUTEX_LOCK(&start_thread_mutex);
138 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
139 /*stacksize*/ 10*1024*1024, (void*)args);
140 MUTEX_LOCK(&start_thread_mutex);
141 MUTEX_UNLOCK(&start_thread_mutex);
142 return *tid ? 0 : EINVAL;
146 pthread_detach(perl_os_thread tid)
148 MUTEX_LOCK(&start_thread_mutex);
149 switch (thread_join_data[tid].state) {
150 case pthreads_st_waited:
151 MUTEX_UNLOCK(&start_thread_mutex);
152 Perl_croak_nocontext("detach on a thread with a waiter");
154 case pthreads_st_run:
155 thread_join_data[tid].state = pthreads_st_detached;
156 MUTEX_UNLOCK(&start_thread_mutex);
159 MUTEX_UNLOCK(&start_thread_mutex);
160 Perl_croak_nocontext("detach: unknown thread state: '%s'",
161 pthreads_states[thread_join_data[tid].state]);
167 /* This is a very bastardized version: */
169 os2_cond_wait(perl_cond *c, perl_mutex *m)
173 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
174 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
175 if (m) MUTEX_UNLOCK(m);
176 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
177 && (rc != ERROR_INTERRUPT))
178 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
179 if (rc == ERROR_INTERRUPT)
181 if (m) MUTEX_LOCK(m);
185 /*****************************************************************************/
186 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
187 static PFN ExtFCN[2]; /* Labeled by ord below. */
188 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
189 #define ORD_QUERY_ELP 0
190 #define ORD_SET_ELP 1
191 struct PMWIN_entries_t PMWIN_entries;
194 loadModule(char *modname)
196 HMODULE h = (HMODULE)dlopen(modname, 0);
198 Perl_croak_nocontext("Error loading module '%s': %s",
204 loadByOrd(char *modname, ULONG ord)
206 if (ExtFCN[ord] == NULL) {
207 static HMODULE hdosc = 0;
214 hdosc = loadModule(modname);
215 if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
216 Perl_croak_nocontext(
217 "This version of OS/2 does not support %s.%i",
218 modname, loadOrd[ord]);
222 if ((long)ExtFCN[ord] == -1)
223 Perl_croak_nocontext("panic queryaddr");
227 init_PMWIN_entries(void)
229 static HMODULE hpmwin = 0;
230 static const int ords[] = {
231 763, /* Initialize */
232 716, /* CreateMsgQueue */
233 726, /* DestroyMsgQueue */
236 912, /* DispatchMsg */
237 753, /* GetLastError */
238 705, /* CancelShutdown */
247 hpmwin = loadModule("pmwin");
248 while (i < sizeof(ords)/sizeof(int)) {
249 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
250 ((PFN*)&PMWIN_entries)+i)))
251 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
258 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
260 #define QSS_INI_BUFFER 1024
263 get_sysinfo(ULONG pid, ULONG flags)
266 ULONG rc, buf_len = QSS_INI_BUFFER;
268 New(1322, pbuffer, buf_len, char);
269 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
270 rc = QuerySysState(flags, pid, pbuffer, buf_len);
271 while (rc == ERROR_BUFFER_OVERFLOW) {
272 Renew(pbuffer, buf_len *= 2, char);
273 rc = QuerySysState(flags, pid, pbuffer, buf_len);
280 return (PQTOPLEVEL)pbuffer;
283 #define PRIO_ERR 0x1111
291 psi = get_sysinfo(pid, QSS_PROCESS);
295 if (pid != psi->procdata->pid) {
297 Perl_croak_nocontext("panic: wrong pid in sysinfo");
299 prio = psi->procdata->threads->priority;
305 setpriority(int which, int pid, int val)
310 prio = sys_prio(pid);
312 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
313 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
314 /* Do not change class. */
315 return CheckOSError(DosSetPriority((pid < 0)
316 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
318 (32 - val) % 32 - (prio & 0xFF),
321 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
322 /* Documentation claims one can change both class and basevalue,
323 * but I find it wrong. */
324 /* Change class, but since delta == 0 denotes absolute 0, correct. */
325 if (CheckOSError(DosSetPriority((pid < 0)
326 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
327 priors[(32 - val) >> 5] + 1,
331 if ( ((32 - val) % 32) == 0 ) return 0;
332 return CheckOSError(DosSetPriority((pid < 0)
333 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
339 /* else return CheckOSError(DosSetPriority((pid < 0) */
340 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
341 /* priors[(32 - val) >> 5] + 1, */
342 /* (32 - val) % 32 - (prio & 0xFF), */
348 getpriority(int which /* ignored */, int pid)
354 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
355 /* DosGetInfoBlocks has old priority! */
356 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
357 /* if (pid != pib->pib_ulpid) { */
359 if (ret == PRIO_ERR) {
363 /* ret = tib->tib_ptib2->tib2_ulpri; */
364 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
367 /*****************************************************************************/
370 /* There is no big sense to make it thread-specific, since signals
371 are delivered to thread 1 only. XXXX Maybe make it into an array? */
372 static int spawn_pid;
373 static int spawn_killed;
376 spawn_sighandler(int sig)
378 /* Some programs do not arrange for the keyboard signals to be
379 delivered to them. We need to deliver the signal manually. */
380 /* We may get a signal only if
381 a) kid does not receive keyboard signal: deliver it;
382 b) kid already died, and we get a signal. We may only hope
383 that the pid number was not reused.
387 sig = SIGKILL; /* Try harder. */
388 kill(spawn_pid, sig);
393 result(pTHX_ int flag, int pid)
396 Signal_t (*ihand)(); /* place to save signal during system() */
397 Signal_t (*qhand)(); /* place to save signal during system() */
403 if (pid < 0 || flag != 0)
409 ihand = rsignal(SIGINT, &spawn_sighandler);
410 qhand = rsignal(SIGQUIT, &spawn_sighandler);
412 r = wait4pid(pid, &status, 0);
413 } while (r == -1 && errno == EINTR);
414 rsignal(SIGINT, ihand);
415 rsignal(SIGQUIT, qhand);
417 PL_statusvalue = (U16)status;
420 return status & 0xFFFF;
422 ihand = rsignal(SIGINT, SIG_IGN);
423 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
424 rsignal(SIGINT, ihand);
425 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
428 return PL_statusvalue;
432 #define EXECF_SPAWN 0
434 #define EXECF_TRUEEXEC 2
435 #define EXECF_SPAWN_NOWAIT 3
436 #define EXECF_SPAWN_BYFLAG 4
438 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
447 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
448 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
451 return (pib->pib_ultype);
455 file_type(char *path)
460 if (!(_emx_env & 0x200))
461 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
462 if (CheckOSError(DosQueryAppType(path, &apptype))) {
464 case ERROR_FILE_NOT_FOUND:
465 case ERROR_PATH_NOT_FOUND:
467 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
469 default: /* Found, but not an
470 executable, or some other
478 static ULONG os2_mytype;
480 /* Spawn/exec a program, revert to shell if needed. */
481 /* global PL_Argv[] contains arguments. */
484 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
489 char buf[256], *s = 0, scrbuf[280];
491 static char * fargs[4]
492 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
493 char **argsp = fargs;
496 int new_stderr = -1, nostderr = 0, fl_stderr;
503 if (strEQ(PL_Argv[0],"/bin/sh"))
504 PL_Argv[0] = PL_sh_path;
506 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
507 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
508 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
509 ) /* will spawnvp use PATH? */
510 TAINT_ENV(); /* testing IFS here is overkill, probably */
511 /* We should check PERL_SH* and PERLLIB_* as well? */
512 if (!really || !*(tmps = SvPV(really, n_a)))
517 if (_emx_env & 0x200) { /* OS/2. */
518 int type = file_type(tmps);
520 if (type == -1) { /* Not found */
525 else if (type == -2) { /* Not an EXE */
530 else if (type == -3) { /* Is a directory? */
531 /* Special-case this */
533 int l = strlen(tmps);
535 if (l + 5 <= sizeof tbuf) {
537 strcpy(tbuf + l, ".exe");
538 type = file_type(tbuf);
548 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
549 case FAPPTYP_WINDOWAPI:
551 if (os2_mytype != 3) { /* not PM */
552 if (flag == P_NOWAIT)
554 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
555 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
560 case FAPPTYP_NOTWINDOWCOMPAT:
562 if (os2_mytype != 0) { /* not full screen */
563 if (flag == P_NOWAIT)
565 else if ((flag & 7) != P_SESSION)
566 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
571 case FAPPTYP_NOTSPEC:
572 /* Let the shell handle this... */
581 new_stderr = dup(2); /* Preserve stderr */
582 if (new_stderr == -1) {
590 fl_stderr = fcntl(2, F_GETFD);
594 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
598 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
600 if (execf == EXECF_TRUEEXEC)
601 rc = execvp(tmps,PL_Argv);
602 else if (execf == EXECF_EXEC)
603 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
604 else if (execf == EXECF_SPAWN_NOWAIT)
605 rc = spawnvp(flag,tmps,PL_Argv);
606 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
607 rc = result(aTHX_ trueflag,
608 spawnvp(flag,tmps,PL_Argv));
610 if (rc < 0 && pass == 1
611 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
616 if (err == ENOENT || err == ENOEXEC) {
617 /* No such file, or is a script. */
618 /* Try adding script extensions to the file name, and
620 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
625 char *s = 0, *s1, *s2;
630 if (l >= sizeof scrbuf) {
633 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
641 file = PerlIO_open(scr, "r");
646 rd = PerlIO_read(file, buf, sizeof buf-1);
648 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
650 if (!rd) { /* Empty... */
653 /* Special case: maybe from -Zexe build, so
654 there is an executable around (contrary to
655 documentation, DosQueryAppType sometimes (?)
656 does not append ".exe", so we could have
657 reached this place). */
658 if (l + 5 < sizeof scrbuf) {
659 strcpy(scrbuf + l, ".exe");
660 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
661 && !S_ISDIR(PL_statbuf.st_mode)) {
671 if (PerlIO_close(file) != 0) { /* Failure */
673 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
674 scr, Strerror(errno));
675 buf[0] = 0; /* Not #! */
681 } else if (buf[0] == 'e') {
682 if (strnEQ(buf, "extproc", 7)
685 } else if (buf[0] == 'E') {
686 if (strnEQ(buf, "EXTPROC", 7)
691 buf[0] = 0; /* Not #! */
699 /* Do better than pdksh: allow a few args,
700 strip trailing whitespace. */
710 while (*s && !isSPACE(*s))
717 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
728 || (!buf[0] && file)) { /* File without magic */
729 /* In fact we tried all what pdksh would
730 try. There is no point in calling
731 pdksh, we may just emulate its logic. */
732 char *shell = getenv("EXECSHELL");
733 char *shell_opt = NULL;
739 shell = getenv("OS2_SHELL");
740 if (inicmd) { /* No spaces at start! */
742 while (*s && !isSPACE(*s)) {
744 inicmd = NULL; /* Cannot use */
752 /* Dosish shells will choke on slashes
753 in paths, fortunately, this is
754 important for zeroth arg only. */
761 /* If EXECSHELL is set, we do not set */
764 shell = ((_emx_env & 0x200)
767 nargs = shell_opt ? 2 : 1; /* shell file args */
768 exec_args[0] = shell;
769 exec_args[1] = shell_opt;
771 if (nargs == 2 && inicmd) {
772 /* Use the original cmd line */
773 /* XXXX This is good only until we refuse
774 quoted arguments... */
778 } else if (!buf[0] && inicmd) { /* No file */
779 /* Start with the original cmdline. */
780 /* XXXX This is good only until we refuse
781 quoted arguments... */
785 nargs = 2; /* shell -c */
788 while (a[1]) /* Get to the end */
790 a++; /* Copy finil NULL too */
791 while (a >= PL_Argv) {
792 *(a + nargs) = *a; /* PL_Argv was preallocated to be
797 PL_Argv[nargs] = argsp[nargs];
798 /* Enable pathless exec if #! (as pdksh). */
799 pass = (buf[0] == '#' ? 2 : 3);
803 /* Not found: restore errno */
807 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
808 char *no_dir = strrchr(PL_Argv[0], '/');
810 /* Do as pdksh port does: if not found with /, try without
813 PL_Argv[0] = no_dir + 1;
818 if (rc < 0 && ckWARN(WARN_EXEC))
819 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
820 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
822 PL_Argv[0], Strerror(errno));
823 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
824 && ((trueflag & 0xFF) == P_WAIT))
828 if (new_stderr != -1) { /* How can we use error codes? */
831 fcntl(2, F_SETFD, fl_stderr);
837 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
839 do_spawn3(pTHX_ char *cmd, int execf, int flag)
844 char *shell, *copt, *news = NULL;
845 int rc, err, seenspace = 0, mergestderr = 0;
846 char fullcmd[MAXNAMLEN + 1];
849 if ((shell = getenv("EMXSHELL")) != NULL)
851 else if ((shell = getenv("SHELL")) != NULL)
853 else if ((shell = getenv("COMSPEC")) != NULL)
858 /* Consensus on perl5-porters is that it is _very_ important to
859 have a shell which will not change between computers with the
860 same architecture, to avoid "action on a distance".
861 And to have simple build, this shell should be sh. */
866 while (*cmd && isSPACE(*cmd))
869 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
870 STRLEN l = strlen(PL_sh_path);
872 New(1302, news, strlen(cmd) - 7 + l + 1, char);
873 strcpy(news, PL_sh_path);
874 strcpy(news + l, cmd + 7);
878 /* save an extra exec if possible */
879 /* see if there are shell metacharacters in it */
881 if (*cmd == '.' && isSPACE(cmd[1]))
884 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
887 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
891 for (s = cmd; *s; s++) {
892 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
893 if (*s == '\n' && s[1] == '\0') {
896 } else if (*s == '\\' && !seenspace) {
897 continue; /* Allow backslashes in names */
898 } else if (*s == '>' && s >= cmd + 3
899 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
900 && isSPACE(s[-2]) ) {
903 while (*t && isSPACE(*t))
908 break; /* Allow 2>&1 as the last thing */
911 /* We do not convert this to do_spawn_ve since shell
912 should be smart enough to start itself gloriously. */
914 if (execf == EXECF_TRUEEXEC)
915 rc = execl(shell,shell,copt,cmd,(char*)0);
916 else if (execf == EXECF_EXEC)
917 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
918 else if (execf == EXECF_SPAWN_NOWAIT)
919 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
920 else if (execf == EXECF_SPAWN_BYFLAG)
921 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
923 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
924 rc = result(aTHX_ P_WAIT,
925 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
926 if (rc < 0 && ckWARN(WARN_EXEC))
927 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
928 (execf == EXECF_SPAWN ? "spawn" : "exec"),
929 shell, Strerror(errno));
936 } else if (*s == ' ' || *s == '\t') {
941 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
942 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
943 PL_Cmd = savepvn(cmd, s-cmd);
945 for (s = PL_Cmd; *s;) {
946 while (*s && isSPACE(*s)) s++;
949 while (*s && !isSPACE(*s)) s++;
955 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
966 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
970 int flag = P_WAIT, flag_set = 0;
974 New(1301,PL_Argv, sp - mark + 3, char*);
977 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
984 while (++mark <= sp) {
986 *a++ = SvPVx(*mark, n_a);
992 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
993 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
995 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1003 os2_do_spawn(pTHX_ char *cmd)
1005 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1009 do_spawn_nowait(pTHX_ char *cmd)
1011 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1015 Perl_do_exec(pTHX_ char *cmd)
1017 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1022 os2exec(pTHX_ char *cmd)
1024 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1028 my_syspopen(pTHX_ char *cmd, char *mode)
1033 register I32 this, that, newfd;
1034 register I32 pid, rc;
1039 /* `this' is what we use in the parent, `that' in the child. */
1040 this = (*mode == 'w');
1044 taint_proper("Insecure %s%s", "EXEC");
1048 /* Now we need to spawn the child. */
1049 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1050 int new = dup(p[this]);
1057 newfd = dup(*mode == 'r'); /* Preserve std* */
1059 /* This cannot happen due to fh being bad after pipe(), since
1060 pipe() should have created fh 0 and 1 even if they were
1061 initially closed. But we closed p[this] before. */
1062 if (errno != EBADF) {
1069 fh_fl = fcntl(*mode == 'r', F_GETFD);
1070 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1071 dup2(p[that], *mode == 'r');
1074 /* Where is `this' and newfd now? */
1075 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1077 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1078 pid = do_spawn_nowait(aTHX_ cmd);
1080 close(*mode == 'r'); /* It was closed initially */
1081 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1082 dup2(newfd, *mode == 'r'); /* Return std* back. */
1084 fcntl(*mode == 'r', F_SETFD, fh_fl);
1086 fcntl(*mode == 'r', F_SETFD, fh_fl);
1087 if (p[that] == (*mode == 'r'))
1093 if (p[that] < p[this]) { /* Make fh as small as possible */
1094 dup2(p[this], p[that]);
1098 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1099 (void)SvUPGRADE(sv,SVt_IV);
1101 PL_forkprocess = pid;
1102 return PerlIO_fdopen(p[this], mode);
1104 #else /* USE_POPEN */
1110 res = popen(cmd, mode);
1112 char *shell = getenv("EMXSHELL");
1114 my_setenv("EMXSHELL", PL_sh_path);
1115 res = popen(cmd, mode);
1116 my_setenv("EMXSHELL", shell);
1118 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1119 (void)SvUPGRADE(sv,SVt_IV);
1120 SvIVX(sv) = -1; /* A cooky. */
1123 #endif /* USE_POPEN */
1127 /******************************************************************/
1133 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1139 /*******************************************************************/
1140 /* not implemented in EMX 0.9d */
1142 char * ctermid(char *s) { return 0; }
1144 #ifdef MYTTYNAME /* was not in emx0.9a */
1145 void * ttyname(x) { return 0; }
1148 /******************************************************************/
1149 /* my socket forwarders - EMX lib only provides static forwarders */
1151 static HMODULE htcp = 0;
1158 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1160 htcp = loadModule("tcp32dll");
1161 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1162 return (void *) ((void * (*)(void)) fcn) ();
1167 tcp1(char *name, int arg)
1169 static BYTE buf[20];
1172 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1174 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1175 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1176 ((void (*)(int)) fcn) (arg);
1179 struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
1180 struct netent * getnetent() { return tcp0("GETNETENT"); }
1181 struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
1182 struct servent * getservent() { return tcp0("GETSERVENT"); }
1184 void sethostent(x) { tcp1("SETHOSTENT", x); }
1185 void setnetent(x) { tcp1("SETNETENT", x); }
1186 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1187 void setservent(x) { tcp1("SETSERVENT", x); }
1188 void endhostent() { tcp0("ENDHOSTENT"); }
1189 void endnetent() { tcp0("ENDNETENT"); }
1190 void endprotoent() { tcp0("ENDPROTOENT"); }
1191 void endservent() { tcp0("ENDSERVENT"); }
1193 /*****************************************************************************/
1194 /* not implemented in C Set++ */
1197 int setuid(x) { errno = EINVAL; return -1; }
1198 int setgid(x) { errno = EINVAL; return -1; }
1201 /*****************************************************************************/
1202 /* stat() hack for char/block device */
1206 /* First attempt used DosQueryFSAttach which crashed the system when
1207 used with 5.001. Now just look for /dev/. */
1210 os2_stat(char *name, struct stat *st)
1212 static int ino = SHRT_MAX;
1214 if (stricmp(name, "/dev/con") != 0
1215 && stricmp(name, "/dev/tty") != 0)
1216 return stat(name, st);
1218 memset(st, 0, sizeof *st);
1219 st->st_mode = S_IFCHR|0666;
1220 st->st_ino = (ino-- & 0x7FFF);
1227 #ifdef USE_PERL_SBRK
1229 /* SBRK() emulation, mostly moved to malloc.c. */
1232 sys_alloc(int size) {
1234 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1236 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1239 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1243 #endif /* USE_PERL_SBRK */
1247 char *tmppath = TMPPATH1;
1252 char *p = getenv("TMP"), *tpath;
1255 if (!p) p = getenv("TEMP");
1258 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1262 strcpy(tpath + len + 1, TMPPATH1);
1269 XS(XS_File__Copy_syscopy)
1272 if (items < 2 || items > 3)
1273 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1276 char * src = (char *)SvPV(ST(0),n_a);
1277 char * dst = (char *)SvPV(ST(1),n_a);
1284 flag = (unsigned long)SvIV(ST(2));
1287 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1288 ST(0) = sv_newmortal();
1289 sv_setiv(ST(0), (IV)RETVAL);
1294 #include "patchlevel.h"
1297 mod2fname(pTHX_ SV *sv)
1299 static char fname[9];
1300 int pos = 6, len, avlen;
1301 unsigned int sum = 0;
1307 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1309 if (SvTYPE(sv) != SVt_PVAV)
1310 Perl_croak_nocontext("Not array reference given to mod2fname");
1312 avlen = av_len((AV*)sv);
1314 Perl_croak_nocontext("Empty array reference given to mod2fname");
1316 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1317 strncpy(fname, s, 8);
1319 if (len < 6) pos = len;
1321 sum = 33 * sum + *(s++); /* Checksumming first chars to
1322 * get the capitalization into c.s. */
1325 while (avlen >= 0) {
1326 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1328 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1333 sum++; /* Avoid conflict of DLLs in memory. */
1335 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
1336 fname[pos] = 'A' + (sum % 26);
1337 fname[pos + 1] = 'A' + (sum / 26 % 26);
1338 fname[pos + 2] = '\0';
1339 return (char *)fname;
1342 XS(XS_DynaLoader_mod2fname)
1346 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1351 RETVAL = mod2fname(aTHX_ sv);
1352 ST(0) = sv_newmortal();
1353 sv_setpv((SV*)ST(0), RETVAL);
1361 static char buf[300];
1364 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1367 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1368 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1371 if (len && buf[len - 1] == '\n')
1373 if (len && buf[len - 1] == '\r')
1375 if (len && buf[len - 1] == '.')
1384 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1386 if (_execname(buf, sizeof buf) != 0)
1393 if (ok && *o != '/' && *o != '\\')
1395 } else if (ok && tolower(*o) != tolower(*p))
1400 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1401 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1415 perllib_mangle(char *s, unsigned int l)
1417 static char *newp, *oldp;
1418 static int newl, oldl, notfound;
1419 static char ret[STATIC_FILE_LENGTH+1];
1421 if (!newp && !notfound) {
1422 newp = getenv("PERLLIB_PREFIX");
1427 while (*newp && !isSPACE(*newp) && *newp != ';') {
1428 newp++; oldl++; /* Skip digits. */
1430 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1431 newp++; /* Skip whitespace. */
1433 newl = strlen(newp);
1434 if (newl == 0 || oldl == 0) {
1435 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1440 if (*s == '\\') *s = '/';
1453 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1456 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1457 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1459 strcpy(ret + newl, s + oldl);
1464 Perl_hab_GET() /* Needed if perl.h cannot be included */
1466 return perl_hab_GET();
1470 Perl_Register_MQ(int serve)
1475 if (Perl_os2_initial_mode++)
1477 DosGetInfoBlocks(&tib, &pib);
1478 Perl_os2_initial_mode = pib->pib_ultype;
1479 /* Try morphing into a PM application. */
1480 if (pib->pib_ultype != 3) /* 2 is VIO */
1481 pib->pib_ultype = 3; /* 3 is PM */
1482 init_PMWIN_entries();
1483 /* 64 messages if before OS/2 3.0, ignored otherwise */
1484 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1488 SAVEINT(cnt); /* Allow catch()ing. */
1490 _exit(188); /* Panic can try to create a window. */
1491 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1494 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1495 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1496 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1498 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1499 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1505 Perl_Serve_Messages(int force)
1510 if (Perl_hmq_servers > 0 && !force)
1512 if (Perl_hmq_refcnt <= 0)
1513 Perl_croak_nocontext("No message queue");
1514 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1516 if (msg.msg == WM_QUIT)
1517 Perl_croak_nocontext("QUITing...");
1518 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1524 Perl_Process_Messages(int force, I32 *cntp)
1528 if (Perl_hmq_servers > 0 && !force)
1530 if (Perl_hmq_refcnt <= 0)
1531 Perl_croak_nocontext("No message queue");
1532 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1535 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1536 if (msg.msg == WM_DESTROY)
1538 if (msg.msg == WM_CREATE)
1541 Perl_croak_nocontext("QUITing...");
1545 Perl_Deregister_MQ(int serve)
1552 if (--Perl_hmq_refcnt <= 0) {
1553 init_PMWIN_entries(); /* To be extra safe */
1554 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1556 /* Try morphing back from a PM application. */
1557 DosGetInfoBlocks(&tib, &pib);
1558 if (pib->pib_ultype == 3) /* 3 is PM */
1559 pib->pib_ultype = Perl_os2_initial_mode;
1561 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1563 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1564 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1567 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1568 && ((path)[2] == '/' || (path)[2] == '\\'))
1569 #define sys_is_rooted _fnisabs
1570 #define sys_is_relative _fnisrel
1571 #define current_drive _getdrive
1573 #undef chdir /* Was _chdir2. */
1574 #define sys_chdir(p) (chdir(p) == 0)
1575 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1577 static int DOS_harderr_state = -1;
1583 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1585 int arg1 = SvIV(ST(0));
1586 int arg2 = SvIV(ST(1));
1587 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1588 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1589 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1592 if (CheckOSError(DosError(a)))
1593 Perl_croak_nocontext("DosError(%d) failed", a);
1594 ST(0) = sv_newmortal();
1595 if (DOS_harderr_state >= 0)
1596 sv_setiv(ST(0), DOS_harderr_state);
1597 DOS_harderr_state = RETVAL;
1602 static signed char DOS_suppression_state = -1;
1604 XS(XS_OS2_Errors2Drive)
1608 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1612 int suppress = SvOK(sv);
1613 char *s = suppress ? SvPV(sv, n_a) : NULL;
1614 char drive = (s ? *s : 0);
1617 if (suppress && !isALPHA(drive))
1618 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1619 if (CheckOSError(DosSuppressPopUps((suppress
1620 ? SPU_ENABLESUPPRESSION
1621 : SPU_DISABLESUPPRESSION),
1623 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1624 ST(0) = sv_newmortal();
1625 if (DOS_suppression_state > 0)
1626 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1627 else if (DOS_suppression_state == 0)
1628 sv_setpvn(ST(0), "", 0);
1629 DOS_suppression_state = drive;
1634 static const char * const si_fields[QSV_MAX] = {
1636 "MAX_TEXT_SESSIONS",
1640 "DYN_PRI_VARIATION",
1658 "FOREGROUND_FS_SESSION",
1659 "FOREGROUND_PROCESS"
1666 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1668 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1669 APIRET rc = NO_ERROR; /* Return code */
1672 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1673 QSV_MAX, /* information */
1676 Perl_croak_nocontext("DosQuerySysInfo() failed");
1677 EXTEND(SP,2*QSV_MAX);
1678 while (i < QSV_MAX) {
1679 ST(j) = sv_newmortal();
1680 sv_setpv(ST(j++), si_fields[i]);
1681 ST(j) = sv_newmortal();
1682 sv_setiv(ST(j++), si[i]);
1686 XSRETURN(2 * QSV_MAX);
1689 XS(XS_OS2_BootDrive)
1693 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1695 ULONG si[1] = {0}; /* System Information Data Buffer */
1696 APIRET rc = NO_ERROR; /* Return code */
1699 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1700 (PVOID)si, sizeof(si))))
1701 Perl_croak_nocontext("DosQuerySysInfo() failed");
1702 ST(0) = sv_newmortal();
1703 c = 'a' - 1 + si[0];
1704 sv_setpvn(ST(0), &c, 1);
1713 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1715 bool serve = SvOK(ST(0));
1716 unsigned long pmq = perl_hmq_GET(serve);
1718 ST(0) = sv_newmortal();
1719 sv_setiv(ST(0), pmq);
1724 XS(XS_OS2_UnMorphPM)
1728 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1730 bool serve = SvOK(ST(0));
1732 perl_hmq_UNSET(serve);
1737 XS(XS_OS2_Serve_Messages)
1741 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1743 bool force = SvOK(ST(0));
1744 unsigned long cnt = Perl_Serve_Messages(force);
1746 ST(0) = sv_newmortal();
1747 sv_setiv(ST(0), cnt);
1752 XS(XS_OS2_Process_Messages)
1755 if (items < 1 || items > 2)
1756 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1758 bool force = SvOK(ST(0));
1764 int fake = SvIV(sv); /* Force SvIVX */
1767 Perl_croak_nocontext("Can't upgrade count to IV");
1769 cnt = Perl_Process_Messages(force, &cntr);
1772 cnt = Perl_Process_Messages(force, NULL);
1774 ST(0) = sv_newmortal();
1775 sv_setiv(ST(0), cnt);
1780 XS(XS_Cwd_current_drive)
1784 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1788 RETVAL = current_drive();
1789 ST(0) = sv_newmortal();
1790 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1795 XS(XS_Cwd_sys_chdir)
1799 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1802 char * path = (char *)SvPV(ST(0),n_a);
1805 RETVAL = sys_chdir(path);
1806 ST(0) = boolSV(RETVAL);
1807 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1812 XS(XS_Cwd_change_drive)
1816 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1819 char d = (char)*SvPV(ST(0),n_a);
1822 RETVAL = change_drive(d);
1823 ST(0) = boolSV(RETVAL);
1824 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1829 XS(XS_Cwd_sys_is_absolute)
1833 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1836 char * path = (char *)SvPV(ST(0),n_a);
1839 RETVAL = sys_is_absolute(path);
1840 ST(0) = boolSV(RETVAL);
1841 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1846 XS(XS_Cwd_sys_is_rooted)
1850 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1853 char * path = (char *)SvPV(ST(0),n_a);
1856 RETVAL = sys_is_rooted(path);
1857 ST(0) = boolSV(RETVAL);
1858 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1863 XS(XS_Cwd_sys_is_relative)
1867 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1870 char * path = (char *)SvPV(ST(0),n_a);
1873 RETVAL = sys_is_relative(path);
1874 ST(0) = boolSV(RETVAL);
1875 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1884 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1888 RETVAL = _getcwd2(p, MAXPATHLEN);
1889 ST(0) = sv_newmortal();
1890 sv_setpv((SV*)ST(0), RETVAL);
1895 XS(XS_Cwd_sys_abspath)
1898 if (items < 1 || items > 2)
1899 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1902 char * path = (char *)SvPV(ST(0),n_a);
1910 dir = (char *)SvPV(ST(1),n_a);
1912 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1916 if (_abspath(p, path, MAXPATHLEN) == 0) {
1922 /* Absolute with drive: */
1923 if ( sys_is_absolute(path) ) {
1924 if (_abspath(p, path, MAXPATHLEN) == 0) {
1929 } else if (path[0] == '/' || path[0] == '\\') {
1930 /* Rooted, but maybe on different drive. */
1931 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1932 char p1[MAXPATHLEN];
1934 /* Need to prepend the drive. */
1937 Copy(path, p1 + 2, strlen(path) + 1, char);
1939 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1944 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1950 /* Either path is relative, or starts with a drive letter. */
1951 /* If the path starts with a drive letter, then dir is
1953 a/b) it is absolute/x:relative on the same drive.
1954 c) path is on current drive, and dir is rooted
1955 In all the cases it is safe to drop the drive part
1957 if ( !sys_is_relative(path) ) {
1960 if ( ( ( sys_is_absolute(dir)
1961 || (isALPHA(dir[0]) && dir[1] == ':'
1962 && strnicmp(dir, path,1) == 0))
1963 && strnicmp(dir, path,1) == 0)
1964 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1965 && toupper(path[0]) == current_drive())) {
1967 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1968 RETVAL = p; goto done;
1970 RETVAL = NULL; goto done;
1974 /* Need to prepend the absolute path of dir. */
1975 char p1[MAXPATHLEN];
1977 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1980 if (p1[ l - 1 ] != '/') {
1984 Copy(path, p1 + l, strlen(path) + 1, char);
1985 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1997 ST(0) = sv_newmortal();
1998 sv_setpv((SV*)ST(0), RETVAL);
2002 typedef APIRET (*PELP)(PSZ path, ULONG type);
2005 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
2007 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
2008 return (*(PELP)ExtFCN[ord])(path, type);
2011 #define extLibpath(type) \
2012 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
2013 : BEGIN_LIBPATH))) \
2016 #define extLibpath_set(p,type) \
2017 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
2020 XS(XS_Cwd_extLibpath)
2023 if (items < 0 || items > 1)
2024 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2034 type = (int)SvIV(ST(0));
2037 RETVAL = extLibpath(type);
2038 ST(0) = sv_newmortal();
2039 sv_setpv((SV*)ST(0), RETVAL);
2044 XS(XS_Cwd_extLibpath_set)
2047 if (items < 1 || items > 2)
2048 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2051 char * s = (char *)SvPV(ST(0),n_a);
2059 type = (int)SvIV(ST(1));
2062 RETVAL = extLibpath_set(s, type);
2063 ST(0) = boolSV(RETVAL);
2064 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2069 #define get_control87() _control87(0,0)
2070 #define set_control87 _control87
2072 XS(XS_OS2__control87)
2076 croak("Usage: OS2::_control87(new,mask)");
2078 unsigned new = (unsigned)SvIV(ST(0));
2079 unsigned mask = (unsigned)SvIV(ST(1));
2082 RETVAL = _control87(new, mask);
2083 ST(0) = sv_newmortal();
2084 sv_setiv(ST(0), (IV)RETVAL);
2089 XS(XS_OS2_get_control87)
2093 croak("Usage: OS2::get_control87()");
2097 RETVAL = get_control87();
2098 ST(0) = sv_newmortal();
2099 sv_setiv(ST(0), (IV)RETVAL);
2105 XS(XS_OS2_set_control87)
2108 if (items < 0 || items > 2)
2109 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2118 new = (unsigned)SvIV(ST(0));
2124 mask = (unsigned)SvIV(ST(1));
2127 RETVAL = set_control87(new, mask);
2128 ST(0) = sv_newmortal();
2129 sv_setiv(ST(0), (IV)RETVAL);
2137 char *file = __FILE__;
2141 if (_emx_env & 0x200) { /* OS/2 */
2142 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2143 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2144 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2146 newXS("OS2::Error", XS_OS2_Error, file);
2147 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2148 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2149 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2150 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2151 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2152 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2153 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2154 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2155 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2156 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2157 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2158 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2159 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2160 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2161 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2162 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2163 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2164 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2165 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2166 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2169 sv_setiv(GvSV(gv), 1);
2171 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2173 sv_setiv(GvSV(gv), _emx_rev);
2174 sv_setpv(GvSV(gv), _emx_vprt);
2176 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2178 sv_setiv(GvSV(gv), _emx_env);
2179 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2181 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2185 OS2_Perl_data_t OS2_Perl_data;
2188 Perl_OS2_init(char **env)
2194 OS2_Perl_data.xs_init = &Xs_OS2_init;
2195 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2196 if (environ == NULL && env) {
2199 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2200 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2201 strcpy(PL_sh_path, SH_PATH);
2202 PL_sh_path[0] = shell[0];
2203 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2204 int l = strlen(shell), i;
2205 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2208 New(1304, PL_sh_path, l + 8, char);
2209 strncpy(PL_sh_path, shell, l);
2210 strcpy(PL_sh_path + l, "/sh.exe");
2211 for (i = 0; i < l; i++) {
2212 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2215 MUTEX_INIT(&start_thread_mutex);
2216 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2217 /* Some DLLs reset FP flags on load. We may have been linked with them */
2218 _control87(MCW_EM, MCW_EM);
2225 my_tmpnam (char *str)
2227 char *p = getenv("TMP"), *tpath;
2230 if (!p) p = getenv("TEMP");
2231 tpath = tempnam(p, "pltmp");
2245 if (s.st_mode & S_IWOTH) {
2248 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2255 my_rmdir (__const__ char *s)
2257 char buf[MAXPATHLEN];
2258 STRLEN l = strlen(s);
2260 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2271 my_mkdir (__const__ char *s, long perm)
2273 char buf[MAXPATHLEN];
2274 STRLEN l = strlen(s);
2276 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2281 return mkdir(s, perm);
2286 /* This code was contributed by Rocco Caputo. */
2288 my_flock(int handle, int o)
2290 FILELOCK rNull, rFull;
2291 ULONG timeout, handle_type, flag_word;
2293 int blocking, shared;
2294 static int use_my = -1;
2297 char *s = getenv("USE_PERL_FLOCK");
2303 if (!(_emx_env & 0x200) || !use_my)
2304 return flock(handle, o); /* Delegate to EMX. */
2307 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2308 (handle_type & 0xFF))
2313 // set lock/unlock ranges
2314 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2315 rFull.lRange = 0x7FFFFFFF;
2316 // set timeout for blocking
2317 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2318 // shared or exclusive?
2319 shared = (o & LOCK_SH) ? 1 : 0;
2320 // do not block the unlock
2321 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2322 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2327 case ERROR_INVALID_HANDLE:
2330 case ERROR_SHARING_BUFFER_EXCEEDED:
2333 case ERROR_LOCK_VIOLATION:
2334 break; // not an error
2335 case ERROR_INVALID_PARAMETER:
2336 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2337 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2340 case ERROR_INTERRUPT:
2349 if (o & (LOCK_SH | LOCK_EX)) {
2350 // for blocking operations
2364 case ERROR_INVALID_HANDLE:
2367 case ERROR_SHARING_BUFFER_EXCEEDED:
2370 case ERROR_LOCK_VIOLATION:
2372 errno = EWOULDBLOCK;
2376 case ERROR_INVALID_PARAMETER:
2377 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2378 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2381 case ERROR_INTERRUPT:
2388 // give away timeslice