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
27 #define PERLIO_NOT_STDIO 0
34 typedef void (*emx_startroutine)(void *);
35 typedef void* (*pthreads_startroutine)(void *);
44 const char *pthreads_states[] = {
55 enum pthreads_state state;
58 thread_join_t *thread_join_data;
59 int thread_join_count;
60 perl_mutex start_thread_mutex;
63 pthread_join(perl_os_thread tid, void **status)
65 MUTEX_LOCK(&start_thread_mutex);
66 switch (thread_join_data[tid].state) {
67 case pthreads_st_exited:
68 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
69 MUTEX_UNLOCK(&start_thread_mutex);
70 *status = thread_join_data[tid].status;
72 case pthreads_st_waited:
73 MUTEX_UNLOCK(&start_thread_mutex);
74 Perl_croak_nocontext("join with a thread with a waiter");
77 thread_join_data[tid].state = pthreads_st_waited;
78 COND_INIT(&thread_join_data[tid].cond);
79 MUTEX_UNLOCK(&start_thread_mutex);
80 COND_WAIT(&thread_join_data[tid].cond, NULL);
81 COND_DESTROY(&thread_join_data[tid].cond);
82 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
83 *status = thread_join_data[tid].status;
86 MUTEX_UNLOCK(&start_thread_mutex);
87 Perl_croak_nocontext("join: unknown thread state: '%s'",
88 pthreads_states[thread_join_data[tid].state]);
95 pthread_startit(void *arg)
97 /* Thread is already started, we need to transfer control only */
98 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
99 int tid = pthread_self();
102 arg = ((void**)arg)[1];
103 if (tid >= thread_join_count) {
104 int oc = thread_join_count;
106 thread_join_count = tid + 5 + tid/5;
107 if (thread_join_data) {
108 Renew(thread_join_data, thread_join_count, thread_join_t);
109 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
111 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
114 if (thread_join_data[tid].state != pthreads_st_none)
115 Perl_croak_nocontext("attempt to reuse thread id %i", tid);
116 thread_join_data[tid].state = pthreads_st_run;
117 /* Now that we copied/updated the guys, we may release the caller... */
118 MUTEX_UNLOCK(&start_thread_mutex);
119 thread_join_data[tid].status = (*start_routine)(arg);
120 switch (thread_join_data[tid].state) {
121 case pthreads_st_waited:
122 COND_SIGNAL(&thread_join_data[tid].cond);
125 thread_join_data[tid].state = pthreads_st_exited;
131 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
132 void *(*start_routine)(void*), void *arg)
136 args[0] = (void*)start_routine;
139 MUTEX_LOCK(&start_thread_mutex);
140 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
141 /*stacksize*/ 10*1024*1024, (void*)args);
142 MUTEX_LOCK(&start_thread_mutex);
143 MUTEX_UNLOCK(&start_thread_mutex);
144 return *tid ? 0 : EINVAL;
148 pthread_detach(perl_os_thread tid)
150 MUTEX_LOCK(&start_thread_mutex);
151 switch (thread_join_data[tid].state) {
152 case pthreads_st_waited:
153 MUTEX_UNLOCK(&start_thread_mutex);
154 Perl_croak_nocontext("detach on a thread with a waiter");
156 case pthreads_st_run:
157 thread_join_data[tid].state = pthreads_st_detached;
158 MUTEX_UNLOCK(&start_thread_mutex);
161 MUTEX_UNLOCK(&start_thread_mutex);
162 Perl_croak_nocontext("detach: unknown thread state: '%s'",
163 pthreads_states[thread_join_data[tid].state]);
169 /* This is a very bastardized version: */
171 os2_cond_wait(perl_cond *c, perl_mutex *m)
175 if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET))
176 Perl_croak_nocontext("panic: COND_WAIT-reset: rc=%i", rc);
177 if (m) MUTEX_UNLOCK(m);
178 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
179 && (rc != ERROR_INTERRUPT))
180 Perl_croak_nocontext("panic: COND_WAIT: rc=%i", rc);
181 if (rc == ERROR_INTERRUPT)
183 if (m) MUTEX_LOCK(m);
187 /*****************************************************************************/
188 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
189 static PFN ExtFCN[2]; /* Labeled by ord below. */
190 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
191 #define ORD_QUERY_ELP 0
192 #define ORD_SET_ELP 1
193 struct PMWIN_entries_t PMWIN_entries;
196 loadModule(char *modname)
198 HMODULE h = (HMODULE)dlopen(modname, 0);
200 Perl_croak_nocontext("Error loading module '%s': %s",
206 loadByOrd(char *modname, ULONG ord)
208 if (ExtFCN[ord] == NULL) {
209 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]);
221 if ((long)ExtFCN[ord] == -1)
222 Perl_croak_nocontext("panic queryaddr");
226 init_PMWIN_entries(void)
228 static HMODULE hpmwin = 0;
229 static const int ords[] = {
230 763, /* Initialize */
231 716, /* CreateMsgQueue */
232 726, /* DestroyMsgQueue */
235 912, /* DispatchMsg */
236 753, /* GetLastError */
237 705, /* CancelShutdown */
246 hpmwin = loadModule("pmwin");
247 while (i < sizeof(ords)/sizeof(int)) {
248 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
249 ((PFN*)&PMWIN_entries)+i)))
250 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
257 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
259 #define QSS_INI_BUFFER 1024
262 get_sysinfo(ULONG pid, ULONG flags)
265 ULONG rc, buf_len = QSS_INI_BUFFER;
267 New(1322, pbuffer, buf_len, char);
268 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
269 rc = QuerySysState(flags, pid, pbuffer, buf_len);
270 while (rc == ERROR_BUFFER_OVERFLOW) {
271 Renew(pbuffer, buf_len *= 2, char);
272 rc = QuerySysState(flags, pid, pbuffer, buf_len);
279 return (PQTOPLEVEL)pbuffer;
282 #define PRIO_ERR 0x1111
290 psi = get_sysinfo(pid, QSS_PROCESS);
294 if (pid != psi->procdata->pid) {
296 Perl_croak_nocontext("panic: wrong pid in sysinfo");
298 prio = psi->procdata->threads->priority;
304 setpriority(int which, int pid, int val)
309 prio = sys_prio(pid);
311 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
312 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
313 /* Do not change class. */
314 return CheckOSError(DosSetPriority((pid < 0)
315 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
317 (32 - val) % 32 - (prio & 0xFF),
320 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
321 /* Documentation claims one can change both class and basevalue,
322 * but I find it wrong. */
323 /* Change class, but since delta == 0 denotes absolute 0, correct. */
324 if (CheckOSError(DosSetPriority((pid < 0)
325 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
326 priors[(32 - val) >> 5] + 1,
330 if ( ((32 - val) % 32) == 0 ) return 0;
331 return CheckOSError(DosSetPriority((pid < 0)
332 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
338 /* else return CheckOSError(DosSetPriority((pid < 0) */
339 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
340 /* priors[(32 - val) >> 5] + 1, */
341 /* (32 - val) % 32 - (prio & 0xFF), */
347 getpriority(int which /* ignored */, int pid)
353 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
354 /* DosGetInfoBlocks has old priority! */
355 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
356 /* if (pid != pib->pib_ulpid) { */
358 if (ret == PRIO_ERR) {
362 /* ret = tib->tib_ptib2->tib2_ulpri; */
363 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
366 /*****************************************************************************/
369 /* There is no big sense to make it thread-specific, since signals
370 are delivered to thread 1 only. XXXX Maybe make it into an array? */
371 static int spawn_pid;
372 static int spawn_killed;
375 spawn_sighandler(int sig)
377 /* Some programs do not arrange for the keyboard signals to be
378 delivered to them. We need to deliver the signal manually. */
379 /* We may get a signal only if
380 a) kid does not receive keyboard signal: deliver it;
381 b) kid already died, and we get a signal. We may only hope
382 that the pid number was not reused.
386 sig = SIGKILL; /* Try harder. */
387 kill(spawn_pid, sig);
392 result(pTHX_ int flag, int pid)
395 Signal_t (*ihand)(); /* place to save signal during system() */
396 Signal_t (*qhand)(); /* place to save signal during system() */
402 if (pid < 0 || flag != 0)
408 ihand = rsignal(SIGINT, &spawn_sighandler);
409 qhand = rsignal(SIGQUIT, &spawn_sighandler);
411 r = wait4pid(pid, &status, 0);
412 } while (r == -1 && errno == EINTR);
413 rsignal(SIGINT, ihand);
414 rsignal(SIGQUIT, qhand);
416 PL_statusvalue = (U16)status;
419 return status & 0xFFFF;
421 ihand = rsignal(SIGINT, SIG_IGN);
422 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
423 rsignal(SIGINT, ihand);
424 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
427 return PL_statusvalue;
431 #define EXECF_SPAWN 0
433 #define EXECF_TRUEEXEC 2
434 #define EXECF_SPAWN_NOWAIT 3
435 #define EXECF_SPAWN_BYFLAG 4
437 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
446 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
447 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
450 return (pib->pib_ultype);
454 file_type(char *path)
459 if (!(_emx_env & 0x200))
460 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
461 if (CheckOSError(DosQueryAppType(path, &apptype))) {
463 case ERROR_FILE_NOT_FOUND:
464 case ERROR_PATH_NOT_FOUND:
466 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
468 default: /* Found, but not an
469 executable, or some other
477 static ULONG os2_mytype;
479 /* Spawn/exec a program, revert to shell if needed. */
480 /* global PL_Argv[] contains arguments. */
483 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
488 char buf[256], *s = 0, scrbuf[280];
490 static char * fargs[4]
491 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
492 char **argsp = fargs;
495 int new_stderr = -1, nostderr = 0, fl_stderr;
502 if (strEQ(PL_Argv[0],"/bin/sh"))
503 PL_Argv[0] = PL_sh_path;
505 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
506 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
507 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
508 ) /* will spawnvp use PATH? */
509 TAINT_ENV(); /* testing IFS here is overkill, probably */
510 /* We should check PERL_SH* and PERLLIB_* as well? */
511 if (!really || !*(tmps = SvPV(really, n_a)))
516 if (_emx_env & 0x200) { /* OS/2. */
517 int type = file_type(tmps);
519 if (type == -1) { /* Not found */
524 else if (type == -2) { /* Not an EXE */
529 else if (type == -3) { /* Is a directory? */
530 /* Special-case this */
532 int l = strlen(tmps);
534 if (l + 5 <= sizeof tbuf) {
536 strcpy(tbuf + l, ".exe");
537 type = file_type(tbuf);
547 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
548 case FAPPTYP_WINDOWAPI:
550 if (os2_mytype != 3) { /* not PM */
551 if (flag == P_NOWAIT)
553 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
554 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
559 case FAPPTYP_NOTWINDOWCOMPAT:
561 if (os2_mytype != 0) { /* not full screen */
562 if (flag == P_NOWAIT)
564 else if ((flag & 7) != P_SESSION)
565 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
570 case FAPPTYP_NOTSPEC:
571 /* Let the shell handle this... */
580 new_stderr = dup(2); /* Preserve stderr */
581 if (new_stderr == -1) {
589 fl_stderr = fcntl(2, F_GETFD);
593 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
597 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
599 if (execf == EXECF_TRUEEXEC)
600 rc = execvp(tmps,PL_Argv);
601 else if (execf == EXECF_EXEC)
602 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
603 else if (execf == EXECF_SPAWN_NOWAIT)
604 rc = spawnvp(flag,tmps,PL_Argv);
605 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
606 rc = result(aTHX_ trueflag,
607 spawnvp(flag,tmps,PL_Argv));
609 if (rc < 0 && pass == 1
610 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
615 if (err == ENOENT || err == ENOEXEC) {
616 /* No such file, or is a script. */
617 /* Try adding script extensions to the file name, and
619 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
624 char *s = 0, *s1, *s2;
629 if (l >= sizeof scrbuf) {
632 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
640 file = PerlIO_open(scr, "r");
645 rd = PerlIO_read(file, buf, sizeof buf-1);
647 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
649 if (!rd) { /* Empty... */
652 /* Special case: maybe from -Zexe build, so
653 there is an executable around (contrary to
654 documentation, DosQueryAppType sometimes (?)
655 does not append ".exe", so we could have
656 reached this place). */
657 if (l + 5 < sizeof scrbuf) {
658 strcpy(scrbuf + l, ".exe");
659 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
660 && !S_ISDIR(PL_statbuf.st_mode)) {
670 if (PerlIO_close(file) != 0) { /* Failure */
672 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
673 scr, Strerror(errno));
674 buf[0] = 0; /* Not #! */
680 } else if (buf[0] == 'e') {
681 if (strnEQ(buf, "extproc", 7)
684 } else if (buf[0] == 'E') {
685 if (strnEQ(buf, "EXTPROC", 7)
690 buf[0] = 0; /* Not #! */
698 /* Do better than pdksh: allow a few args,
699 strip trailing whitespace. */
709 while (*s && !isSPACE(*s))
716 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
727 || (!buf[0] && file)) { /* File without magic */
728 /* In fact we tried all what pdksh would
729 try. There is no point in calling
730 pdksh, we may just emulate its logic. */
731 char *shell = getenv("EXECSHELL");
732 char *shell_opt = NULL;
738 shell = getenv("OS2_SHELL");
739 if (inicmd) { /* No spaces at start! */
741 while (*s && !isSPACE(*s)) {
743 inicmd = NULL; /* Cannot use */
751 /* Dosish shells will choke on slashes
752 in paths, fortunately, this is
753 important for zeroth arg only. */
760 /* If EXECSHELL is set, we do not set */
763 shell = ((_emx_env & 0x200)
766 nargs = shell_opt ? 2 : 1; /* shell file args */
767 exec_args[0] = shell;
768 exec_args[1] = shell_opt;
770 if (nargs == 2 && inicmd) {
771 /* Use the original cmd line */
772 /* XXXX This is good only until we refuse
773 quoted arguments... */
777 } else if (!buf[0] && inicmd) { /* No file */
778 /* Start with the original cmdline. */
779 /* XXXX This is good only until we refuse
780 quoted arguments... */
784 nargs = 2; /* shell -c */
787 while (a[1]) /* Get to the end */
789 a++; /* Copy finil NULL too */
790 while (a >= PL_Argv) {
791 *(a + nargs) = *a; /* PL_Argv was preallocated to be
796 PL_Argv[nargs] = argsp[nargs];
797 /* Enable pathless exec if #! (as pdksh). */
798 pass = (buf[0] == '#' ? 2 : 3);
802 /* Not found: restore errno */
806 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
807 char *no_dir = strrchr(PL_Argv[0], '/');
809 /* Do as pdksh port does: if not found with /, try without
812 PL_Argv[0] = no_dir + 1;
817 if (rc < 0 && ckWARN(WARN_EXEC))
818 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
819 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
821 PL_Argv[0], Strerror(errno));
822 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
823 && ((trueflag & 0xFF) == P_WAIT))
827 if (new_stderr != -1) { /* How can we use error codes? */
830 fcntl(2, F_SETFD, fl_stderr);
836 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
838 do_spawn3(pTHX_ char *cmd, int execf, int flag)
843 char *shell, *copt, *news = NULL;
844 int rc, err, seenspace = 0, mergestderr = 0;
845 char fullcmd[MAXNAMLEN + 1];
848 if ((shell = getenv("EMXSHELL")) != NULL)
850 else if ((shell = getenv("SHELL")) != NULL)
852 else if ((shell = getenv("COMSPEC")) != NULL)
857 /* Consensus on perl5-porters is that it is _very_ important to
858 have a shell which will not change between computers with the
859 same architecture, to avoid "action on a distance".
860 And to have simple build, this shell should be sh. */
865 while (*cmd && isSPACE(*cmd))
868 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
869 STRLEN l = strlen(PL_sh_path);
871 New(1302, news, strlen(cmd) - 7 + l + 1, char);
872 strcpy(news, PL_sh_path);
873 strcpy(news + l, cmd + 7);
877 /* save an extra exec if possible */
878 /* see if there are shell metacharacters in it */
880 if (*cmd == '.' && isSPACE(cmd[1]))
883 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
886 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
890 for (s = cmd; *s; s++) {
891 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
892 if (*s == '\n' && s[1] == '\0') {
895 } else if (*s == '\\' && !seenspace) {
896 continue; /* Allow backslashes in names */
897 } else if (*s == '>' && s >= cmd + 3
898 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
899 && isSPACE(s[-2]) ) {
902 while (*t && isSPACE(*t))
907 break; /* Allow 2>&1 as the last thing */
910 /* We do not convert this to do_spawn_ve since shell
911 should be smart enough to start itself gloriously. */
913 if (execf == EXECF_TRUEEXEC)
914 rc = execl(shell,shell,copt,cmd,(char*)0);
915 else if (execf == EXECF_EXEC)
916 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
917 else if (execf == EXECF_SPAWN_NOWAIT)
918 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
919 else if (execf == EXECF_SPAWN_BYFLAG)
920 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
922 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
923 rc = result(aTHX_ P_WAIT,
924 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
925 if (rc < 0 && ckWARN(WARN_EXEC))
926 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
927 (execf == EXECF_SPAWN ? "spawn" : "exec"),
928 shell, Strerror(errno));
935 } else if (*s == ' ' || *s == '\t') {
940 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
941 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
942 PL_Cmd = savepvn(cmd, s-cmd);
944 for (s = PL_Cmd; *s;) {
945 while (*s && isSPACE(*s)) s++;
948 while (*s && !isSPACE(*s)) s++;
954 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
965 os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
969 int flag = P_WAIT, flag_set = 0;
973 New(1301,PL_Argv, sp - mark + 3, char*);
976 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
983 while (++mark <= sp) {
985 *a++ = SvPVx(*mark, n_a);
991 if (flag_set && (a == PL_Argv + 1)) { /* One arg? */
992 rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag);
994 rc = do_spawn_ve(aTHX_ really, flag, EXECF_SPAWN, NULL, 0);
1002 os2_do_spawn(pTHX_ char *cmd)
1004 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
1008 do_spawn_nowait(pTHX_ char *cmd)
1010 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1014 Perl_do_exec(pTHX_ char *cmd)
1016 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1021 os2exec(pTHX_ char *cmd)
1023 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1027 my_syspopen(pTHX_ char *cmd, char *mode)
1032 register I32 this, that, newfd;
1033 register I32 pid, rc;
1038 /* `this' is what we use in the parent, `that' in the child. */
1039 this = (*mode == 'w');
1043 taint_proper("Insecure %s%s", "EXEC");
1047 /* Now we need to spawn the child. */
1048 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1049 int new = dup(p[this]);
1056 newfd = dup(*mode == 'r'); /* Preserve std* */
1058 /* This cannot happen due to fh being bad after pipe(), since
1059 pipe() should have created fh 0 and 1 even if they were
1060 initially closed. But we closed p[this] before. */
1061 if (errno != EBADF) {
1068 fh_fl = fcntl(*mode == 'r', F_GETFD);
1069 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1070 dup2(p[that], *mode == 'r');
1073 /* Where is `this' and newfd now? */
1074 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1076 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1077 pid = do_spawn_nowait(aTHX_ cmd);
1079 close(*mode == 'r'); /* It was closed initially */
1080 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1081 dup2(newfd, *mode == 'r'); /* Return std* back. */
1083 fcntl(*mode == 'r', F_SETFD, fh_fl);
1085 fcntl(*mode == 'r', F_SETFD, fh_fl);
1086 if (p[that] == (*mode == 'r'))
1092 if (p[that] < p[this]) { /* Make fh as small as possible */
1093 dup2(p[this], p[that]);
1097 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1098 (void)SvUPGRADE(sv,SVt_IV);
1100 PL_forkprocess = pid;
1101 return PerlIO_fdopen(p[this], mode);
1103 #else /* USE_POPEN */
1109 res = popen(cmd, mode);
1111 char *shell = getenv("EMXSHELL");
1113 my_setenv("EMXSHELL", PL_sh_path);
1114 res = popen(cmd, mode);
1115 my_setenv("EMXSHELL", shell);
1117 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1118 (void)SvUPGRADE(sv,SVt_IV);
1119 SvIVX(sv) = -1; /* A cooky. */
1122 #endif /* USE_POPEN */
1126 /******************************************************************/
1132 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1138 /*******************************************************************/
1139 /* not implemented in EMX 0.9d */
1141 char * ctermid(char *s) { return 0; }
1143 #ifdef MYTTYNAME /* was not in emx0.9a */
1144 void * ttyname(x) { return 0; }
1147 /******************************************************************/
1148 /* my socket forwarders - EMX lib only provides static forwarders */
1150 static HMODULE htcp = 0;
1157 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1159 htcp = loadModule("tcp32dll");
1160 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1161 return (void *) ((void * (*)(void)) fcn) ();
1166 tcp1(char *name, int arg)
1168 static BYTE buf[20];
1171 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1173 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1174 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1175 ((void (*)(int)) fcn) (arg);
1178 struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
1179 struct netent * getnetent() { return tcp0("GETNETENT"); }
1180 struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
1181 struct servent * getservent() { return tcp0("GETSERVENT"); }
1183 void sethostent(x) { tcp1("SETHOSTENT", x); }
1184 void setnetent(x) { tcp1("SETNETENT", x); }
1185 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1186 void setservent(x) { tcp1("SETSERVENT", x); }
1187 void endhostent() { tcp0("ENDHOSTENT"); }
1188 void endnetent() { tcp0("ENDNETENT"); }
1189 void endprotoent() { tcp0("ENDPROTOENT"); }
1190 void endservent() { tcp0("ENDSERVENT"); }
1192 /*****************************************************************************/
1193 /* not implemented in C Set++ */
1196 int setuid(x) { errno = EINVAL; return -1; }
1197 int setgid(x) { errno = EINVAL; return -1; }
1200 /*****************************************************************************/
1201 /* stat() hack for char/block device */
1205 /* First attempt used DosQueryFSAttach which crashed the system when
1206 used with 5.001. Now just look for /dev/. */
1209 os2_stat(char *name, struct stat *st)
1211 static int ino = SHRT_MAX;
1213 if (stricmp(name, "/dev/con") != 0
1214 && stricmp(name, "/dev/tty") != 0)
1215 return stat(name, st);
1217 memset(st, 0, sizeof *st);
1218 st->st_mode = S_IFCHR|0666;
1219 st->st_ino = (ino-- & 0x7FFF);
1226 #ifdef USE_PERL_SBRK
1228 /* SBRK() emulation, mostly moved to malloc.c. */
1231 sys_alloc(int size) {
1233 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1235 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1238 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1242 #endif /* USE_PERL_SBRK */
1246 char *tmppath = TMPPATH1;
1251 char *p = getenv("TMP"), *tpath;
1254 if (!p) p = getenv("TEMP");
1257 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1261 strcpy(tpath + len + 1, TMPPATH1);
1268 XS(XS_File__Copy_syscopy)
1271 if (items < 2 || items > 3)
1272 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1275 char * src = (char *)SvPV(ST(0),n_a);
1276 char * dst = (char *)SvPV(ST(1),n_a);
1283 flag = (unsigned long)SvIV(ST(2));
1286 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1287 ST(0) = sv_newmortal();
1288 sv_setiv(ST(0), (IV)RETVAL);
1293 #include "patchlevel.h"
1296 mod2fname(pTHX_ SV *sv)
1298 static char fname[9];
1299 int pos = 6, len, avlen;
1300 unsigned int sum = 0;
1306 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1308 if (SvTYPE(sv) != SVt_PVAV)
1309 Perl_croak_nocontext("Not array reference given to mod2fname");
1311 avlen = av_len((AV*)sv);
1313 Perl_croak_nocontext("Empty array reference given to mod2fname");
1315 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1316 strncpy(fname, s, 8);
1318 if (len < 6) pos = len;
1320 sum = 33 * sum + *(s++); /* Checksumming first chars to
1321 * get the capitalization into c.s. */
1324 while (avlen >= 0) {
1325 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1327 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1332 sum++; /* Avoid conflict of DLLs in memory. */
1334 /* We always load modules as *specific* DLLs, and with the full name.
1335 When loading a specific DLL by its full name, one cannot get a
1336 different DLL, even if a DLL with the same basename is loaded already.
1337 Thus there is no need to include the version into the mangling scheme. */
1339 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1341 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1342 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1344 sum += COMPATIBLE_VERSION_SUM;
1346 fname[pos] = 'A' + (sum % 26);
1347 fname[pos + 1] = 'A' + (sum / 26 % 26);
1348 fname[pos + 2] = '\0';
1349 return (char *)fname;
1352 XS(XS_DynaLoader_mod2fname)
1356 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1361 RETVAL = mod2fname(aTHX_ sv);
1362 ST(0) = sv_newmortal();
1363 sv_setpv((SV*)ST(0), RETVAL);
1371 static char buf[300];
1374 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1377 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1378 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1381 if (len && buf[len - 1] == '\n')
1383 if (len && buf[len - 1] == '\r')
1385 if (len && buf[len - 1] == '.')
1394 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1396 if (_execname(buf, sizeof buf) != 0)
1403 if (ok && *o != '/' && *o != '\\')
1405 } else if (ok && tolower(*o) != tolower(*p))
1410 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1411 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1425 perllib_mangle(char *s, unsigned int l)
1427 static char *newp, *oldp;
1428 static int newl, oldl, notfound;
1429 static char ret[STATIC_FILE_LENGTH+1];
1431 if (!newp && !notfound) {
1432 newp = getenv("PERLLIB_PREFIX");
1437 while (*newp && !isSPACE(*newp) && *newp != ';') {
1438 newp++; oldl++; /* Skip digits. */
1440 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1441 newp++; /* Skip whitespace. */
1443 newl = strlen(newp);
1444 if (newl == 0 || oldl == 0) {
1445 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1450 if (*s == '\\') *s = '/';
1463 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1466 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1467 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1469 strcpy(ret + newl, s + oldl);
1474 Perl_hab_GET() /* Needed if perl.h cannot be included */
1476 return perl_hab_GET();
1480 Perl_Register_MQ(int serve)
1485 if (Perl_os2_initial_mode++)
1487 DosGetInfoBlocks(&tib, &pib);
1488 Perl_os2_initial_mode = pib->pib_ultype;
1489 /* Try morphing into a PM application. */
1490 if (pib->pib_ultype != 3) /* 2 is VIO */
1491 pib->pib_ultype = 3; /* 3 is PM */
1492 init_PMWIN_entries();
1493 /* 64 messages if before OS/2 3.0, ignored otherwise */
1494 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1498 SAVEINT(cnt); /* Allow catch()ing. */
1500 _exit(188); /* Panic can try to create a window. */
1501 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1504 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1505 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1506 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1508 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1509 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1515 Perl_Serve_Messages(int force)
1520 if (Perl_hmq_servers > 0 && !force)
1522 if (Perl_hmq_refcnt <= 0)
1523 Perl_croak_nocontext("No message queue");
1524 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1526 if (msg.msg == WM_QUIT)
1527 Perl_croak_nocontext("QUITing...");
1528 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1534 Perl_Process_Messages(int force, I32 *cntp)
1538 if (Perl_hmq_servers > 0 && !force)
1540 if (Perl_hmq_refcnt <= 0)
1541 Perl_croak_nocontext("No message queue");
1542 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1545 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1546 if (msg.msg == WM_DESTROY)
1548 if (msg.msg == WM_CREATE)
1551 Perl_croak_nocontext("QUITing...");
1555 Perl_Deregister_MQ(int serve)
1562 if (--Perl_hmq_refcnt <= 0) {
1563 init_PMWIN_entries(); /* To be extra safe */
1564 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1566 /* Try morphing back from a PM application. */
1567 DosGetInfoBlocks(&tib, &pib);
1568 if (pib->pib_ultype == 3) /* 3 is PM */
1569 pib->pib_ultype = Perl_os2_initial_mode;
1571 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1573 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1574 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1577 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1578 && ((path)[2] == '/' || (path)[2] == '\\'))
1579 #define sys_is_rooted _fnisabs
1580 #define sys_is_relative _fnisrel
1581 #define current_drive _getdrive
1583 #undef chdir /* Was _chdir2. */
1584 #define sys_chdir(p) (chdir(p) == 0)
1585 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1587 static int DOS_harderr_state = -1;
1593 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1595 int arg1 = SvIV(ST(0));
1596 int arg2 = SvIV(ST(1));
1597 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1598 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1599 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1602 if (CheckOSError(DosError(a)))
1603 Perl_croak_nocontext("DosError(%d) failed", a);
1604 ST(0) = sv_newmortal();
1605 if (DOS_harderr_state >= 0)
1606 sv_setiv(ST(0), DOS_harderr_state);
1607 DOS_harderr_state = RETVAL;
1612 static signed char DOS_suppression_state = -1;
1614 XS(XS_OS2_Errors2Drive)
1618 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1622 int suppress = SvOK(sv);
1623 char *s = suppress ? SvPV(sv, n_a) : NULL;
1624 char drive = (s ? *s : 0);
1627 if (suppress && !isALPHA(drive))
1628 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1629 if (CheckOSError(DosSuppressPopUps((suppress
1630 ? SPU_ENABLESUPPRESSION
1631 : SPU_DISABLESUPPRESSION),
1633 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1634 ST(0) = sv_newmortal();
1635 if (DOS_suppression_state > 0)
1636 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1637 else if (DOS_suppression_state == 0)
1638 sv_setpvn(ST(0), "", 0);
1639 DOS_suppression_state = drive;
1644 static const char * const si_fields[QSV_MAX] = {
1646 "MAX_TEXT_SESSIONS",
1650 "DYN_PRI_VARIATION",
1668 "FOREGROUND_FS_SESSION",
1669 "FOREGROUND_PROCESS"
1676 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1678 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1679 APIRET rc = NO_ERROR; /* Return code */
1682 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1683 QSV_MAX, /* information */
1686 Perl_croak_nocontext("DosQuerySysInfo() failed");
1687 EXTEND(SP,2*QSV_MAX);
1688 while (i < QSV_MAX) {
1689 ST(j) = sv_newmortal();
1690 sv_setpv(ST(j++), si_fields[i]);
1691 ST(j) = sv_newmortal();
1692 sv_setiv(ST(j++), si[i]);
1696 XSRETURN(2 * QSV_MAX);
1699 XS(XS_OS2_BootDrive)
1703 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1705 ULONG si[1] = {0}; /* System Information Data Buffer */
1706 APIRET rc = NO_ERROR; /* Return code */
1709 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1710 (PVOID)si, sizeof(si))))
1711 Perl_croak_nocontext("DosQuerySysInfo() failed");
1712 ST(0) = sv_newmortal();
1713 c = 'a' - 1 + si[0];
1714 sv_setpvn(ST(0), &c, 1);
1723 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1725 bool serve = SvOK(ST(0));
1726 unsigned long pmq = perl_hmq_GET(serve);
1728 ST(0) = sv_newmortal();
1729 sv_setiv(ST(0), pmq);
1734 XS(XS_OS2_UnMorphPM)
1738 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1740 bool serve = SvOK(ST(0));
1742 perl_hmq_UNSET(serve);
1747 XS(XS_OS2_Serve_Messages)
1751 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1753 bool force = SvOK(ST(0));
1754 unsigned long cnt = Perl_Serve_Messages(force);
1756 ST(0) = sv_newmortal();
1757 sv_setiv(ST(0), cnt);
1762 XS(XS_OS2_Process_Messages)
1765 if (items < 1 || items > 2)
1766 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1768 bool force = SvOK(ST(0));
1774 int fake = SvIV(sv); /* Force SvIVX */
1777 Perl_croak_nocontext("Can't upgrade count to IV");
1779 cnt = Perl_Process_Messages(force, &cntr);
1782 cnt = Perl_Process_Messages(force, NULL);
1784 ST(0) = sv_newmortal();
1785 sv_setiv(ST(0), cnt);
1790 XS(XS_Cwd_current_drive)
1794 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1798 RETVAL = current_drive();
1799 ST(0) = sv_newmortal();
1800 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1805 XS(XS_Cwd_sys_chdir)
1809 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1812 char * path = (char *)SvPV(ST(0),n_a);
1815 RETVAL = sys_chdir(path);
1816 ST(0) = boolSV(RETVAL);
1817 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1822 XS(XS_Cwd_change_drive)
1826 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1829 char d = (char)*SvPV(ST(0),n_a);
1832 RETVAL = change_drive(d);
1833 ST(0) = boolSV(RETVAL);
1834 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1839 XS(XS_Cwd_sys_is_absolute)
1843 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1846 char * path = (char *)SvPV(ST(0),n_a);
1849 RETVAL = sys_is_absolute(path);
1850 ST(0) = boolSV(RETVAL);
1851 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1856 XS(XS_Cwd_sys_is_rooted)
1860 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1863 char * path = (char *)SvPV(ST(0),n_a);
1866 RETVAL = sys_is_rooted(path);
1867 ST(0) = boolSV(RETVAL);
1868 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1873 XS(XS_Cwd_sys_is_relative)
1877 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1880 char * path = (char *)SvPV(ST(0),n_a);
1883 RETVAL = sys_is_relative(path);
1884 ST(0) = boolSV(RETVAL);
1885 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1894 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1898 RETVAL = _getcwd2(p, MAXPATHLEN);
1899 ST(0) = sv_newmortal();
1900 sv_setpv((SV*)ST(0), RETVAL);
1905 XS(XS_Cwd_sys_abspath)
1908 if (items < 1 || items > 2)
1909 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1912 char * path = (char *)SvPV(ST(0),n_a);
1920 dir = (char *)SvPV(ST(1),n_a);
1922 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1926 if (_abspath(p, path, MAXPATHLEN) == 0) {
1932 /* Absolute with drive: */
1933 if ( sys_is_absolute(path) ) {
1934 if (_abspath(p, path, MAXPATHLEN) == 0) {
1939 } else if (path[0] == '/' || path[0] == '\\') {
1940 /* Rooted, but maybe on different drive. */
1941 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1942 char p1[MAXPATHLEN];
1944 /* Need to prepend the drive. */
1947 Copy(path, p1 + 2, strlen(path) + 1, char);
1949 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1954 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1960 /* Either path is relative, or starts with a drive letter. */
1961 /* If the path starts with a drive letter, then dir is
1963 a/b) it is absolute/x:relative on the same drive.
1964 c) path is on current drive, and dir is rooted
1965 In all the cases it is safe to drop the drive part
1967 if ( !sys_is_relative(path) ) {
1970 if ( ( ( sys_is_absolute(dir)
1971 || (isALPHA(dir[0]) && dir[1] == ':'
1972 && strnicmp(dir, path,1) == 0))
1973 && strnicmp(dir, path,1) == 0)
1974 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1975 && toupper(path[0]) == current_drive())) {
1977 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1978 RETVAL = p; goto done;
1980 RETVAL = NULL; goto done;
1984 /* Need to prepend the absolute path of dir. */
1985 char p1[MAXPATHLEN];
1987 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1990 if (p1[ l - 1 ] != '/') {
1994 Copy(path, p1 + l, strlen(path) + 1, char);
1995 if (_abspath(p, p1, MAXPATHLEN) == 0) {
2007 ST(0) = sv_newmortal();
2008 sv_setpv((SV*)ST(0), RETVAL);
2012 typedef APIRET (*PELP)(PSZ path, ULONG type);
2014 /* Kernels after 2000/09/15 understand this too: */
2015 #ifndef LIBPATHSTRICT
2016 # define LIBPATHSTRICT 3
2020 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2024 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
2028 what = BEGIN_LIBPATH;
2030 what = LIBPATHSTRICT;
2031 return (*(PELP)ExtFCN[ord])(path, what);
2034 #define extLibpath(to,type) \
2035 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) )
2037 #define extLibpath_set(p,type) \
2038 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type))))
2040 XS(XS_Cwd_extLibpath)
2043 if (items < 0 || items > 1)
2044 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2057 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2058 RETVAL = extLibpath(to, type);
2059 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2060 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2061 ST(0) = sv_newmortal();
2062 sv_setpv((SV*)ST(0), RETVAL);
2067 XS(XS_Cwd_extLibpath_set)
2070 if (items < 1 || items > 2)
2071 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2074 char * s = (char *)SvPV(ST(0),n_a);
2085 RETVAL = extLibpath_set(s, type);
2086 ST(0) = boolSV(RETVAL);
2087 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2092 #define get_control87() _control87(0,0)
2093 #define set_control87 _control87
2095 XS(XS_OS2__control87)
2099 croak("Usage: OS2::_control87(new,mask)");
2101 unsigned new = (unsigned)SvIV(ST(0));
2102 unsigned mask = (unsigned)SvIV(ST(1));
2105 RETVAL = _control87(new, mask);
2106 ST(0) = sv_newmortal();
2107 sv_setiv(ST(0), (IV)RETVAL);
2112 XS(XS_OS2_get_control87)
2116 croak("Usage: OS2::get_control87()");
2120 RETVAL = get_control87();
2121 ST(0) = sv_newmortal();
2122 sv_setiv(ST(0), (IV)RETVAL);
2128 XS(XS_OS2_set_control87)
2131 if (items < 0 || items > 2)
2132 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2141 new = (unsigned)SvIV(ST(0));
2147 mask = (unsigned)SvIV(ST(1));
2150 RETVAL = set_control87(new, mask);
2151 ST(0) = sv_newmortal();
2152 sv_setiv(ST(0), (IV)RETVAL);
2160 char *file = __FILE__;
2164 if (_emx_env & 0x200) { /* OS/2 */
2165 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2166 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2167 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2169 newXS("OS2::Error", XS_OS2_Error, file);
2170 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2171 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2172 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2173 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2174 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2175 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2176 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2177 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2178 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2179 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2180 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2181 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2182 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2183 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2184 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2185 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2186 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2187 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2188 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2189 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2192 sv_setiv(GvSV(gv), 1);
2194 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2196 sv_setiv(GvSV(gv), _emx_rev);
2197 sv_setpv(GvSV(gv), _emx_vprt);
2199 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2201 sv_setiv(GvSV(gv), _emx_env);
2202 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2204 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2208 OS2_Perl_data_t OS2_Perl_data;
2211 Perl_OS2_init(char **env)
2217 OS2_Perl_data.xs_init = &Xs_OS2_init;
2218 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2219 if (environ == NULL && env) {
2222 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2223 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2224 strcpy(PL_sh_path, SH_PATH);
2225 PL_sh_path[0] = shell[0];
2226 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2227 int l = strlen(shell), i;
2228 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2231 New(1304, PL_sh_path, l + 8, char);
2232 strncpy(PL_sh_path, shell, l);
2233 strcpy(PL_sh_path + l, "/sh.exe");
2234 for (i = 0; i < l; i++) {
2235 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2238 MUTEX_INIT(&start_thread_mutex);
2239 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2240 /* Some DLLs reset FP flags on load. We may have been linked with them */
2241 _control87(MCW_EM, MCW_EM);
2248 my_tmpnam (char *str)
2250 char *p = getenv("TMP"), *tpath;
2253 if (!p) p = getenv("TEMP");
2254 tpath = tempnam(p, "pltmp");
2268 if (s.st_mode & S_IWOTH) {
2271 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2278 my_rmdir (__const__ char *s)
2280 char buf[MAXPATHLEN];
2281 STRLEN l = strlen(s);
2283 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2294 my_mkdir (__const__ char *s, long perm)
2296 char buf[MAXPATHLEN];
2297 STRLEN l = strlen(s);
2299 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2304 return mkdir(s, perm);
2309 /* This code was contributed by Rocco Caputo. */
2311 my_flock(int handle, int o)
2313 FILELOCK rNull, rFull;
2314 ULONG timeout, handle_type, flag_word;
2316 int blocking, shared;
2317 static int use_my = -1;
2320 char *s = getenv("USE_PERL_FLOCK");
2326 if (!(_emx_env & 0x200) || !use_my)
2327 return flock(handle, o); /* Delegate to EMX. */
2330 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2331 (handle_type & 0xFF))
2336 // set lock/unlock ranges
2337 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2338 rFull.lRange = 0x7FFFFFFF;
2339 // set timeout for blocking
2340 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2341 // shared or exclusive?
2342 shared = (o & LOCK_SH) ? 1 : 0;
2343 // do not block the unlock
2344 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2345 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2350 case ERROR_INVALID_HANDLE:
2353 case ERROR_SHARING_BUFFER_EXCEEDED:
2356 case ERROR_LOCK_VIOLATION:
2357 break; // not an error
2358 case ERROR_INVALID_PARAMETER:
2359 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2360 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2363 case ERROR_INTERRUPT:
2372 if (o & (LOCK_SH | LOCK_EX)) {
2373 // for blocking operations
2387 case ERROR_INVALID_HANDLE:
2390 case ERROR_SHARING_BUFFER_EXCEEDED:
2393 case ERROR_LOCK_VIOLATION:
2395 errno = EWOULDBLOCK;
2399 case ERROR_INVALID_PARAMETER:
2400 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2401 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2404 case ERROR_INTERRUPT:
2411 // give away timeslice
2420 static int pwent_cnt;
2421 static int _my_pwent = -1;
2426 if (_my_pwent == -1) {
2427 char *s = getenv("USE_PERL_PWENT");
2429 _my_pwent = atoi(s);
2443 if (!use_my_pwent()) {
2444 setpwent(); /* Delegate to EMX. */
2453 if (!use_my_pwent()) {
2454 endpwent(); /* Delegate to EMX. */
2462 if (!use_my_pwent())
2463 return getpwent(); /* Delegate to EMX. */
2465 return 0; // Return one entry only
2469 static int grent_cnt;
2486 return 0; // Return one entry only
2493 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2494 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2496 static struct passwd *
2497 passw_wrap(struct passwd *p)
2499 static struct passwd pw;
2502 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2505 s = getenv("PW_PASSWD");
2507 s = (char*)pw_p; /* Make match impossible */
2514 my_getpwuid (uid_t id)
2516 return passw_wrap(getpwuid(id));
2520 my_getpwnam (__const__ char *n)
2522 return passw_wrap(getpwnam(n));