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 */
245 hpmwin = loadModule("pmwin");
246 while (i < sizeof(ords)/sizeof(int)) {
247 if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
248 ((PFN*)&PMWIN_entries)+i)))
249 Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
256 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
258 #define QSS_INI_BUFFER 1024
261 get_sysinfo(ULONG pid, ULONG flags)
264 ULONG rc, buf_len = QSS_INI_BUFFER;
266 New(1322, pbuffer, buf_len, char);
267 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
268 rc = QuerySysState(flags, pid, pbuffer, buf_len);
269 while (rc == ERROR_BUFFER_OVERFLOW) {
270 Renew(pbuffer, buf_len *= 2, char);
271 rc = QuerySysState(flags, pid, pbuffer, buf_len);
278 return (PQTOPLEVEL)pbuffer;
281 #define PRIO_ERR 0x1111
289 psi = get_sysinfo(pid, QSS_PROCESS);
293 if (pid != psi->procdata->pid) {
295 Perl_croak_nocontext("panic: wrong pid in sysinfo");
297 prio = psi->procdata->threads->priority;
303 setpriority(int which, int pid, int val)
305 ULONG rc, prio = sys_prio(pid);
307 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
308 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
309 /* Do not change class. */
310 return CheckOSError(DosSetPriority((pid < 0)
311 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
313 (32 - val) % 32 - (prio & 0xFF),
316 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
317 /* Documentation claims one can change both class and basevalue,
318 * but I find it wrong. */
319 /* Change class, but since delta == 0 denotes absolute 0, correct. */
320 if (CheckOSError(DosSetPriority((pid < 0)
321 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
322 priors[(32 - val) >> 5] + 1,
326 if ( ((32 - val) % 32) == 0 ) return 0;
327 return CheckOSError(DosSetPriority((pid < 0)
328 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
334 /* else return CheckOSError(DosSetPriority((pid < 0) */
335 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
336 /* priors[(32 - val) >> 5] + 1, */
337 /* (32 - val) % 32 - (prio & 0xFF), */
343 getpriority(int which /* ignored */, int pid)
347 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
349 if (ret == PRIO_ERR) {
352 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
355 /*****************************************************************************/
358 /* There is no big sense to make it thread-specific, since signals
359 are delivered to thread 1 only. XXXX Maybe make it into an array? */
360 static int spawn_pid;
361 static int spawn_killed;
364 spawn_sighandler(int sig)
366 /* Some programs do not arrange for the keyboard signals to be
367 delivered to them. We need to deliver the signal manually. */
368 /* We may get a signal only if
369 a) kid does not receive keyboard signal: deliver it;
370 b) kid already died, and we get a signal. We may only hope
371 that the pid number was not reused.
375 sig = SIGKILL; /* Try harder. */
376 kill(spawn_pid, sig);
381 result(pTHX_ int flag, int pid)
384 Signal_t (*ihand)(); /* place to save signal during system() */
385 Signal_t (*qhand)(); /* place to save signal during system() */
391 if (pid < 0 || flag != 0)
397 ihand = rsignal(SIGINT, &spawn_sighandler);
398 qhand = rsignal(SIGQUIT, &spawn_sighandler);
400 r = wait4pid(pid, &status, 0);
401 } while (r == -1 && errno == EINTR);
402 rsignal(SIGINT, ihand);
403 rsignal(SIGQUIT, qhand);
405 PL_statusvalue = (U16)status;
408 return status & 0xFFFF;
410 ihand = rsignal(SIGINT, SIG_IGN);
411 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
412 rsignal(SIGINT, ihand);
413 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
416 return PL_statusvalue;
420 #define EXECF_SPAWN 0
422 #define EXECF_TRUEEXEC 2
423 #define EXECF_SPAWN_NOWAIT 3
424 #define EXECF_SPAWN_BYFLAG 4
426 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
435 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
436 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
439 return (pib->pib_ultype);
443 file_type(char *path)
448 if (!(_emx_env & 0x200))
449 Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */
450 if (CheckOSError(DosQueryAppType(path, &apptype))) {
452 case ERROR_FILE_NOT_FOUND:
453 case ERROR_PATH_NOT_FOUND:
455 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
457 default: /* Found, but not an
458 executable, or some other
466 static ULONG os2_mytype;
468 /* Spawn/exec a program, revert to shell if needed. */
469 /* global PL_Argv[] contains arguments. */
472 do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
477 char buf[256], scrbuf[280];
479 static char * fargs[4]
480 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
481 char **argsp = fargs;
484 int new_stderr = -1, nostderr = 0;
492 if (strEQ(PL_Argv[0],"/bin/sh"))
493 PL_Argv[0] = PL_sh_path;
495 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
496 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
497 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
498 ) /* will spawnvp use PATH? */
499 TAINT_ENV(); /* testing IFS here is overkill, probably */
500 /* We should check PERL_SH* and PERLLIB_* as well? */
501 if (!really || !*(tmps = SvPV(really, n_a)))
506 if (_emx_env & 0x200) { /* OS/2. */
507 int type = file_type(tmps);
509 if (type == -1) { /* Not found */
514 else if (type == -2) { /* Not an EXE */
519 else if (type == -3) { /* Is a directory? */
520 /* Special-case this */
522 int l = strlen(tmps);
524 if (l + 5 <= sizeof tbuf) {
526 strcpy(tbuf + l, ".exe");
527 type = file_type(tbuf);
537 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
538 case FAPPTYP_WINDOWAPI:
540 if (os2_mytype != 3) { /* not PM */
541 if (flag == P_NOWAIT)
543 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
544 Perl_warner(aTHX_ WARN_EXEC, "Starting PM process with flag=%d, mytype=%d",
549 case FAPPTYP_NOTWINDOWCOMPAT:
551 if (os2_mytype != 0) { /* not full screen */
552 if (flag == P_NOWAIT)
554 else if ((flag & 7) != P_SESSION)
555 Perl_warner(aTHX_ WARN_EXEC, "Starting Full Screen process with flag=%d, mytype=%d",
560 case FAPPTYP_NOTSPEC:
561 /* Let the shell handle this... */
570 new_stderr = dup(2); /* Preserve stderr */
571 if (new_stderr == -1) {
579 fl_stderr = fcntl(2, F_GETFD);
583 fcntl(new_stderr, F_SETFD, FD_CLOEXEC);
587 rc = result(aTHX_ trueflag, spawnvp(flag,tmps,PL_Argv));
589 if (execf == EXECF_TRUEEXEC)
590 rc = execvp(tmps,PL_Argv);
591 else if (execf == EXECF_EXEC)
592 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
593 else if (execf == EXECF_SPAWN_NOWAIT)
594 rc = spawnvp(flag,tmps,PL_Argv);
595 else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */
596 rc = result(aTHX_ trueflag,
597 spawnvp(flag,tmps,PL_Argv));
599 if (rc < 0 && pass == 1
600 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
605 if (err == ENOENT || err == ENOEXEC) {
606 /* No such file, or is a script. */
607 /* Try adding script extensions to the file name, and
609 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
614 char *s = 0, *s1, *s2;
619 if (l >= sizeof scrbuf) {
622 Perl_warner(aTHX_ WARN_EXEC, "Size of scriptname too big: %d", l);
630 file = PerlIO_open(scr, "r");
635 rd = PerlIO_read(file, buf, sizeof buf-1);
637 if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
639 if (!rd) { /* Empty... */
642 /* Special case: maybe from -Zexe build, so
643 there is an executable around (contrary to
644 documentation, DosQueryAppType sometimes (?)
645 does not append ".exe", so we could have
646 reached this place). */
647 if (l + 5 < sizeof scrbuf) {
648 strcpy(scrbuf + l, ".exe");
649 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
650 && !S_ISDIR(PL_statbuf.st_mode)) {
660 if (PerlIO_close(file) != 0) { /* Failure */
662 Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
663 scr, Strerror(errno));
664 buf[0] = 0; /* Not #! */
670 } else if (buf[0] == 'e') {
671 if (strnEQ(buf, "extproc", 7)
674 } else if (buf[0] == 'E') {
675 if (strnEQ(buf, "EXTPROC", 7)
680 buf[0] = 0; /* Not #! */
688 /* Do better than pdksh: allow a few args,
689 strip trailing whitespace. */
699 while (*s && !isSPACE(*s))
706 Perl_warner(aTHX_ WARN_EXEC, "Too many args on %.*s line of \"%s\"",
717 || (!buf[0] && file)) { /* File without magic */
718 /* In fact we tried all what pdksh would
719 try. There is no point in calling
720 pdksh, we may just emulate its logic. */
721 char *shell = getenv("EXECSHELL");
722 char *shell_opt = NULL;
728 shell = getenv("OS2_SHELL");
729 if (inicmd) { /* No spaces at start! */
731 while (*s && !isSPACE(*s)) {
733 inicmd = NULL; /* Cannot use */
741 /* Dosish shells will choke on slashes
742 in paths, fortunately, this is
743 important for zeroth arg only. */
750 /* If EXECSHELL is set, we do not set */
753 shell = ((_emx_env & 0x200)
756 nargs = shell_opt ? 2 : 1; /* shell file args */
757 exec_args[0] = shell;
758 exec_args[1] = shell_opt;
760 if (nargs == 2 && inicmd) {
761 /* Use the original cmd line */
762 /* XXXX This is good only until we refuse
763 quoted arguments... */
767 } else if (!buf[0] && inicmd) { /* No file */
768 /* Start with the original cmdline. */
769 /* XXXX This is good only until we refuse
770 quoted arguments... */
774 nargs = 2; /* shell -c */
777 while (a[1]) /* Get to the end */
779 a++; /* Copy finil NULL too */
780 while (a >= PL_Argv) {
781 *(a + nargs) = *a; /* PL_Argv was preallocated to be
786 PL_Argv[nargs] = argsp[nargs];
787 /* Enable pathless exec if #! (as pdksh). */
788 pass = (buf[0] == '#' ? 2 : 3);
792 /* Not found: restore errno */
796 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
797 char *no_dir = strrchr(PL_Argv[0], '/');
799 /* Do as pdksh port does: if not found with /, try without
802 PL_Argv[0] = no_dir + 1;
807 if (rc < 0 && ckWARN(WARN_EXEC))
808 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n",
809 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
811 PL_Argv[0], Strerror(errno));
812 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
813 && ((trueflag & 0xFF) == P_WAIT))
817 if (new_stderr != -1) { /* How can we use error codes? */
820 fcntl(2, F_SETFD, fl_stderr);
826 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
828 do_spawn3(pTHX_ char *cmd, int execf, int flag)
832 char *shell, *copt, *news = NULL;
833 int rc, seenspace = 0, mergestderr = 0;
836 if ((shell = getenv("EMXSHELL")) != NULL)
838 else if ((shell = getenv("SHELL")) != NULL)
840 else if ((shell = getenv("COMSPEC")) != NULL)
845 /* Consensus on perl5-porters is that it is _very_ important to
846 have a shell which will not change between computers with the
847 same architecture, to avoid "action on a distance".
848 And to have simple build, this shell should be sh. */
853 while (*cmd && isSPACE(*cmd))
856 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
857 STRLEN l = strlen(PL_sh_path);
859 New(1302, news, strlen(cmd) - 7 + l + 1, char);
860 strcpy(news, PL_sh_path);
861 strcpy(news + l, cmd + 7);
865 /* save an extra exec if possible */
866 /* see if there are shell metacharacters in it */
868 if (*cmd == '.' && isSPACE(cmd[1]))
871 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
874 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
878 for (s = cmd; *s; s++) {
879 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
880 if (*s == '\n' && s[1] == '\0') {
883 } else if (*s == '\\' && !seenspace) {
884 continue; /* Allow backslashes in names */
885 } else if (*s == '>' && s >= cmd + 3
886 && s[-1] == '2' && s[1] == '&' && s[2] == '1'
887 && isSPACE(s[-2]) ) {
890 while (*t && isSPACE(*t))
895 break; /* Allow 2>&1 as the last thing */
898 /* We do not convert this to do_spawn_ve since shell
899 should be smart enough to start itself gloriously. */
901 if (execf == EXECF_TRUEEXEC)
902 rc = execl(shell,shell,copt,cmd,(char*)0);
903 else if (execf == EXECF_EXEC)
904 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
905 else if (execf == EXECF_SPAWN_NOWAIT)
906 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
907 else if (execf == EXECF_SPAWN_BYFLAG)
908 rc = spawnl(flag,shell,shell,copt,cmd,(char*)0);
910 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
911 rc = result(aTHX_ P_WAIT,
912 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
913 if (rc < 0 && ckWARN(WARN_EXEC))
914 Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s",
915 (execf == EXECF_SPAWN ? "spawn" : "exec"),
916 shell, Strerror(errno));
923 } else if (*s == ' ' || *s == '\t') {
928 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
929 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
930 PL_Cmd = savepvn(cmd, s-cmd);
932 for (s = PL_Cmd; *s;) {
933 while (*s && isSPACE(*s)) s++;
936 while (*s && !isSPACE(*s)) s++;
942 rc = do_spawn_ve(aTHX_ NULL, flag, execf, cmd, mergestderr);
953 os2_do_aspawn(pTHX_ SV *really, register void **vmark, register void **vsp)
955 register SV **mark = (SV **)vmark;
956 register SV **sp = (SV **)vsp;
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)
994 return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
998 do_spawn_nowait(pTHX_ char *cmd)
1000 return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
1004 Perl_do_exec(pTHX_ char *cmd)
1006 do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
1011 os2exec(pTHX_ char *cmd)
1013 return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
1017 my_syspopen(pTHX_ char *cmd, char *mode)
1021 register I32 this, that, newfd;
1024 int fh_fl = 0; /* Pacify the warning */
1026 /* `this' is what we use in the parent, `that' in the child. */
1027 this = (*mode == 'w');
1031 taint_proper("Insecure %s%s", "EXEC");
1035 /* Now we need to spawn the child. */
1036 if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1037 int new = dup(p[this]);
1044 newfd = dup(*mode == 'r'); /* Preserve std* */
1046 /* This cannot happen due to fh being bad after pipe(), since
1047 pipe() should have created fh 0 and 1 even if they were
1048 initially closed. But we closed p[this] before. */
1049 if (errno != EBADF) {
1056 fh_fl = fcntl(*mode == 'r', F_GETFD);
1057 if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */
1058 dup2(p[that], *mode == 'r');
1061 /* Where is `this' and newfd now? */
1062 fcntl(p[this], F_SETFD, FD_CLOEXEC);
1064 fcntl(newfd, F_SETFD, FD_CLOEXEC);
1065 pid = do_spawn_nowait(aTHX_ cmd);
1067 close(*mode == 'r'); /* It was closed initially */
1068 else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */
1069 dup2(newfd, *mode == 'r'); /* Return std* back. */
1071 fcntl(*mode == 'r', F_SETFD, fh_fl);
1073 fcntl(*mode == 'r', F_SETFD, fh_fl);
1074 if (p[that] == (*mode == 'r'))
1080 if (p[that] < p[this]) { /* Make fh as small as possible */
1081 dup2(p[this], p[that]);
1085 sv = *av_fetch(PL_fdpid,p[this],TRUE);
1086 (void)SvUPGRADE(sv,SVt_IV);
1088 PL_forkprocess = pid;
1089 return PerlIO_fdopen(p[this], mode);
1091 #else /* USE_POPEN */
1097 res = popen(cmd, mode);
1099 char *shell = getenv("EMXSHELL");
1101 my_setenv("EMXSHELL", PL_sh_path);
1102 res = popen(cmd, mode);
1103 my_setenv("EMXSHELL", shell);
1105 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
1106 (void)SvUPGRADE(sv,SVt_IV);
1107 SvIVX(sv) = -1; /* A cooky. */
1110 #endif /* USE_POPEN */
1114 /******************************************************************/
1120 Perl_croak_nocontext(PL_no_func, "Unsupported function fork");
1126 /*******************************************************************/
1127 /* not implemented in EMX 0.9d */
1129 char * ctermid(char *s) { return 0; }
1131 #ifdef MYTTYNAME /* was not in emx0.9a */
1132 void * ttyname(x) { return 0; }
1135 /******************************************************************/
1136 /* my socket forwarders - EMX lib only provides static forwarders */
1138 static HMODULE htcp = 0;
1145 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1147 htcp = loadModule("tcp32dll");
1148 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1149 return (void *) ((void * (*)(void)) fcn) ();
1154 tcp1(char *name, int arg)
1156 static BYTE buf[20];
1159 if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
1161 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1162 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1163 ((void (*)(int)) fcn) (arg);
1166 struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
1167 struct netent * getnetent() { return tcp0("GETNETENT"); }
1168 struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
1169 struct servent * getservent() { return tcp0("GETSERVENT"); }
1171 void sethostent(x) { tcp1("SETHOSTENT", x); }
1172 void setnetent(x) { tcp1("SETNETENT", x); }
1173 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1174 void setservent(x) { tcp1("SETSERVENT", x); }
1175 void endhostent() { tcp0("ENDHOSTENT"); }
1176 void endnetent() { tcp0("ENDNETENT"); }
1177 void endprotoent() { tcp0("ENDPROTOENT"); }
1178 void endservent() { tcp0("ENDSERVENT"); }
1180 /*****************************************************************************/
1181 /* not implemented in C Set++ */
1184 int setuid(x) { errno = EINVAL; return -1; }
1185 int setgid(x) { errno = EINVAL; return -1; }
1188 /*****************************************************************************/
1189 /* stat() hack for char/block device */
1193 /* First attempt used DosQueryFSAttach which crashed the system when
1194 used with 5.001. Now just look for /dev/. */
1197 os2_stat(const char *name, struct stat *st)
1199 static int ino = SHRT_MAX;
1201 if (stricmp(name, "/dev/con") != 0
1202 && stricmp(name, "/dev/tty") != 0)
1203 return stat(name, st);
1205 memset(st, 0, sizeof *st);
1206 st->st_mode = S_IFCHR|0666;
1207 st->st_ino = (ino-- & 0x7FFF);
1214 #ifdef USE_PERL_SBRK
1216 /* SBRK() emulation, mostly moved to malloc.c. */
1219 sys_alloc(int size) {
1221 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1223 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1226 Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc);
1230 #endif /* USE_PERL_SBRK */
1234 char *tmppath = TMPPATH1;
1239 char *p = getenv("TMP"), *tpath;
1242 if (!p) p = getenv("TEMP");
1245 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1249 strcpy(tpath + len + 1, TMPPATH1);
1256 XS(XS_File__Copy_syscopy)
1259 if (items < 2 || items > 3)
1260 Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)");
1263 char * src = (char *)SvPV(ST(0),n_a);
1264 char * dst = (char *)SvPV(ST(1),n_a);
1271 flag = (unsigned long)SvIV(ST(2));
1274 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1275 ST(0) = sv_newmortal();
1276 sv_setiv(ST(0), (IV)RETVAL);
1281 #include "patchlevel.h"
1284 mod2fname(pTHX_ SV *sv)
1286 static char fname[9];
1287 int pos = 6, len, avlen;
1288 unsigned int sum = 0;
1292 if (!SvROK(sv)) Perl_croak_nocontext("Not a reference given to mod2fname");
1294 if (SvTYPE(sv) != SVt_PVAV)
1295 Perl_croak_nocontext("Not array reference given to mod2fname");
1297 avlen = av_len((AV*)sv);
1299 Perl_croak_nocontext("Empty array reference given to mod2fname");
1301 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1302 strncpy(fname, s, 8);
1304 if (len < 6) pos = len;
1306 sum = 33 * sum + *(s++); /* Checksumming first chars to
1307 * get the capitalization into c.s. */
1310 while (avlen >= 0) {
1311 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a);
1313 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1318 sum++; /* Avoid conflict of DLLs in memory. */
1320 /* We always load modules as *specific* DLLs, and with the full name.
1321 When loading a specific DLL by its full name, one cannot get a
1322 different DLL, even if a DLL with the same basename is loaded already.
1323 Thus there is no need to include the version into the mangling scheme. */
1325 sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
1327 # ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
1328 # define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
1330 sum += COMPATIBLE_VERSION_SUM;
1332 fname[pos] = 'A' + (sum % 26);
1333 fname[pos + 1] = 'A' + (sum / 26 % 26);
1334 fname[pos + 2] = '\0';
1335 return (char *)fname;
1338 XS(XS_DynaLoader_mod2fname)
1342 Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)");
1347 RETVAL = mod2fname(aTHX_ sv);
1348 ST(0) = sv_newmortal();
1349 sv_setpv((SV*)ST(0), RETVAL);
1357 static char buf[300];
1360 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1363 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1364 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1367 if (len && buf[len - 1] == '\n')
1369 if (len && buf[len - 1] == '\r')
1371 if (len && buf[len - 1] == '.')
1380 char buf[300], *p, *o = PL_origargv[0], ok = 1;
1382 if (_execname(buf, sizeof buf) != 0)
1389 if (ok && *o != '/' && *o != '\\')
1391 } else if (ok && tolower(*o) != tolower(*p))
1396 if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
1397 strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
1411 perllib_mangle(char *s, unsigned int l)
1413 static char *newp, *oldp;
1414 static int newl, oldl, notfound;
1415 static char ret[STATIC_FILE_LENGTH+1];
1417 if (!newp && !notfound) {
1418 newp = getenv("PERLLIB_PREFIX");
1423 while (*newp && !isSPACE(*newp) && *newp != ';') {
1424 newp++; oldl++; /* Skip digits. */
1426 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1427 newp++; /* Skip whitespace. */
1429 newl = strlen(newp);
1430 if (newl == 0 || oldl == 0) {
1431 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1436 if (*s == '\\') *s = '/';
1449 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1452 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1453 Perl_croak_nocontext("Malformed PERLLIB_PREFIX");
1455 strcpy(ret + newl, s + oldl);
1460 Perl_hab_GET() /* Needed if perl.h cannot be included */
1462 return perl_hab_GET();
1466 Perl_Register_MQ(int serve)
1471 if (Perl_os2_initial_mode++)
1473 DosGetInfoBlocks(&tib, &pib);
1474 Perl_os2_initial_mode = pib->pib_ultype;
1475 /* Try morphing into a PM application. */
1476 if (pib->pib_ultype != 3) /* 2 is VIO */
1477 pib->pib_ultype = 3; /* 3 is PM */
1478 init_PMWIN_entries();
1479 /* 64 messages if before OS/2 3.0, ignored otherwise */
1480 Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
1484 SAVEINT(cnt); /* Allow catch()ing. */
1486 _exit(188); /* Panic can try to create a window. */
1487 Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
1490 if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
1491 && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
1492 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
1494 } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
1495 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1501 Perl_Serve_Messages(int force)
1506 if (Perl_hmq_servers > 0 && !force)
1508 if (Perl_hmq_refcnt <= 0)
1509 Perl_croak_nocontext("No message queue");
1510 while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
1512 if (msg.msg == WM_QUIT)
1513 Perl_croak_nocontext("QUITing...");
1514 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1520 Perl_Process_Messages(int force, I32 *cntp)
1524 if (Perl_hmq_servers > 0 && !force)
1526 if (Perl_hmq_refcnt <= 0)
1527 Perl_croak_nocontext("No message queue");
1528 while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
1531 (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
1532 if (msg.msg == WM_DESTROY)
1534 if (msg.msg == WM_CREATE)
1537 Perl_croak_nocontext("QUITing...");
1541 Perl_Deregister_MQ(int serve)
1548 if (--Perl_hmq_refcnt <= 0) {
1549 init_PMWIN_entries(); /* To be extra safe */
1550 (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
1552 /* Try morphing back from a PM application. */
1553 DosGetInfoBlocks(&tib, &pib);
1554 if (pib->pib_ultype == 3) /* 3 is PM */
1555 pib->pib_ultype = Perl_os2_initial_mode;
1557 Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
1559 } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
1560 (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
1563 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1564 && ((path)[2] == '/' || (path)[2] == '\\'))
1565 #define sys_is_rooted _fnisabs
1566 #define sys_is_relative _fnisrel
1567 #define current_drive _getdrive
1569 #undef chdir /* Was _chdir2. */
1570 #define sys_chdir(p) (chdir(p) == 0)
1571 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1573 static int DOS_harderr_state = -1;
1579 Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)");
1581 int arg1 = SvIV(ST(0));
1582 int arg2 = SvIV(ST(1));
1583 int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
1584 | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
1585 int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
1588 if (CheckOSError(DosError(a)))
1589 Perl_croak_nocontext("DosError(%d) failed", a);
1590 ST(0) = sv_newmortal();
1591 if (DOS_harderr_state >= 0)
1592 sv_setiv(ST(0), DOS_harderr_state);
1593 DOS_harderr_state = RETVAL;
1598 static signed char DOS_suppression_state = -1;
1600 XS(XS_OS2_Errors2Drive)
1604 Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)");
1608 int suppress = SvOK(sv);
1609 char *s = suppress ? SvPV(sv, n_a) : NULL;
1610 char drive = (s ? *s : 0);
1613 if (suppress && !isALPHA(drive))
1614 Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive);
1615 if (CheckOSError(DosSuppressPopUps((suppress
1616 ? SPU_ENABLESUPPRESSION
1617 : SPU_DISABLESUPPRESSION),
1619 Perl_croak_nocontext("DosSuppressPopUps(%c) failed", drive);
1620 ST(0) = sv_newmortal();
1621 if (DOS_suppression_state > 0)
1622 sv_setpvn(ST(0), &DOS_suppression_state, 1);
1623 else if (DOS_suppression_state == 0)
1624 sv_setpvn(ST(0), "", 0);
1625 DOS_suppression_state = drive;
1630 static const char * const si_fields[QSV_MAX] = {
1632 "MAX_TEXT_SESSIONS",
1636 "DYN_PRI_VARIATION",
1654 "FOREGROUND_FS_SESSION",
1655 "FOREGROUND_PROCESS"
1662 Perl_croak_nocontext("Usage: OS2::SysInfo()");
1664 ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
1665 APIRET rc = NO_ERROR; /* Return code */
1668 if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
1669 QSV_MAX, /* information */
1672 Perl_croak_nocontext("DosQuerySysInfo() failed");
1673 EXTEND(SP,2*QSV_MAX);
1674 while (i < QSV_MAX) {
1675 ST(j) = sv_newmortal();
1676 sv_setpv(ST(j++), si_fields[i]);
1677 ST(j) = sv_newmortal();
1678 sv_setiv(ST(j++), si[i]);
1682 XSRETURN(2 * QSV_MAX);
1685 XS(XS_OS2_BootDrive)
1689 Perl_croak_nocontext("Usage: OS2::BootDrive()");
1691 ULONG si[1] = {0}; /* System Information Data Buffer */
1692 APIRET rc = NO_ERROR; /* Return code */
1695 if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
1696 (PVOID)si, sizeof(si))))
1697 Perl_croak_nocontext("DosQuerySysInfo() failed");
1698 ST(0) = sv_newmortal();
1699 c = 'a' - 1 + si[0];
1700 sv_setpvn(ST(0), &c, 1);
1709 Perl_croak_nocontext("Usage: OS2::MorphPM(serve)");
1711 bool serve = SvOK(ST(0));
1712 unsigned long pmq = perl_hmq_GET(serve);
1714 ST(0) = sv_newmortal();
1715 sv_setiv(ST(0), pmq);
1720 XS(XS_OS2_UnMorphPM)
1724 Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)");
1726 bool serve = SvOK(ST(0));
1728 perl_hmq_UNSET(serve);
1733 XS(XS_OS2_Serve_Messages)
1737 Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)");
1739 bool force = SvOK(ST(0));
1740 unsigned long cnt = Perl_Serve_Messages(force);
1742 ST(0) = sv_newmortal();
1743 sv_setiv(ST(0), cnt);
1748 XS(XS_OS2_Process_Messages)
1751 if (items < 1 || items > 2)
1752 Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])");
1754 bool force = SvOK(ST(0));
1761 (void)SvIV(sv); /* Force SvIVX */
1763 Perl_croak_nocontext("Can't upgrade count to IV");
1765 cnt = Perl_Process_Messages(force, &cntr);
1768 cnt = Perl_Process_Messages(force, NULL);
1770 ST(0) = sv_newmortal();
1771 sv_setiv(ST(0), cnt);
1776 XS(XS_Cwd_current_drive)
1780 Perl_croak_nocontext("Usage: Cwd::current_drive()");
1784 RETVAL = current_drive();
1785 ST(0) = sv_newmortal();
1786 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1791 XS(XS_Cwd_sys_chdir)
1795 Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)");
1798 char * path = (char *)SvPV(ST(0),n_a);
1801 RETVAL = sys_chdir(path);
1802 ST(0) = boolSV(RETVAL);
1803 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1808 XS(XS_Cwd_change_drive)
1812 Perl_croak_nocontext("Usage: Cwd::change_drive(d)");
1815 char d = (char)*SvPV(ST(0),n_a);
1818 RETVAL = change_drive(d);
1819 ST(0) = boolSV(RETVAL);
1820 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1825 XS(XS_Cwd_sys_is_absolute)
1829 Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)");
1832 char * path = (char *)SvPV(ST(0),n_a);
1835 RETVAL = sys_is_absolute(path);
1836 ST(0) = boolSV(RETVAL);
1837 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1842 XS(XS_Cwd_sys_is_rooted)
1846 Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)");
1849 char * path = (char *)SvPV(ST(0),n_a);
1852 RETVAL = sys_is_rooted(path);
1853 ST(0) = boolSV(RETVAL);
1854 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1859 XS(XS_Cwd_sys_is_relative)
1863 Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)");
1866 char * path = (char *)SvPV(ST(0),n_a);
1869 RETVAL = sys_is_relative(path);
1870 ST(0) = boolSV(RETVAL);
1871 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1880 Perl_croak_nocontext("Usage: Cwd::sys_cwd()");
1884 RETVAL = _getcwd2(p, MAXPATHLEN);
1885 ST(0) = sv_newmortal();
1886 sv_setpv((SV*)ST(0), RETVAL);
1891 XS(XS_Cwd_sys_abspath)
1894 if (items < 1 || items > 2)
1895 Perl_croak_nocontext("Usage: Cwd::sys_abspath(path, dir = NULL)");
1898 char * path = (char *)SvPV(ST(0),n_a);
1906 dir = (char *)SvPV(ST(1),n_a);
1908 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1912 if (_abspath(p, path, MAXPATHLEN) == 0) {
1918 /* Absolute with drive: */
1919 if ( sys_is_absolute(path) ) {
1920 if (_abspath(p, path, MAXPATHLEN) == 0) {
1925 } else if (path[0] == '/' || path[0] == '\\') {
1926 /* Rooted, but maybe on different drive. */
1927 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1928 char p1[MAXPATHLEN];
1930 /* Need to prepend the drive. */
1933 Copy(path, p1 + 2, strlen(path) + 1, char);
1935 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1940 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1946 /* Either path is relative, or starts with a drive letter. */
1947 /* If the path starts with a drive letter, then dir is
1949 a/b) it is absolute/x:relative on the same drive.
1950 c) path is on current drive, and dir is rooted
1951 In all the cases it is safe to drop the drive part
1953 if ( !sys_is_relative(path) ) {
1954 if ( ( ( sys_is_absolute(dir)
1955 || (isALPHA(dir[0]) && dir[1] == ':'
1956 && strnicmp(dir, path,1) == 0))
1957 && strnicmp(dir, path,1) == 0)
1958 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1959 && toupper(path[0]) == current_drive())) {
1961 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1962 RETVAL = p; goto done;
1964 RETVAL = NULL; goto done;
1968 /* Need to prepend the absolute path of dir. */
1969 char p1[MAXPATHLEN];
1971 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1974 if (p1[ l - 1 ] != '/') {
1978 Copy(path, p1 + l, strlen(path) + 1, char);
1979 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1991 ST(0) = sv_newmortal();
1992 sv_setpv((SV*)ST(0), RETVAL);
1996 typedef APIRET (*PELP)(PSZ path, ULONG type);
1998 /* Kernels after 2000/09/15 understand this too: */
1999 #ifndef LIBPATHSTRICT
2000 # define LIBPATHSTRICT 3
2004 ExtLIBPATH(ULONG ord, PSZ path, IV type)
2008 loadByOrd("doscalls",ord); /* Guarantied to load or die! */
2012 what = BEGIN_LIBPATH;
2014 what = LIBPATHSTRICT;
2015 return (*(PELP)ExtFCN[ord])(path, what);
2018 #define extLibpath(to,type) \
2019 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) )
2021 #define extLibpath_set(p,type) \
2022 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type))))
2024 XS(XS_Cwd_extLibpath)
2027 if (items < 0 || items > 1)
2028 Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
2041 to[0] = 1; to[1] = 0; /* Sometimes no error reported */
2042 RETVAL = extLibpath(to, type);
2043 if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
2044 Perl_croak_nocontext("panic Cwd::extLibpath parameter");
2045 ST(0) = sv_newmortal();
2046 sv_setpv((SV*)ST(0), RETVAL);
2051 XS(XS_Cwd_extLibpath_set)
2054 if (items < 1 || items > 2)
2055 Perl_croak_nocontext("Usage: Cwd::extLibpath_set(s, type = 0)");
2058 char * s = (char *)SvPV(ST(0),n_a);
2069 RETVAL = extLibpath_set(s, type);
2070 ST(0) = boolSV(RETVAL);
2071 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
2076 #define get_control87() _control87(0,0)
2077 #define set_control87 _control87
2079 XS(XS_OS2__control87)
2083 croak("Usage: OS2::_control87(new,mask)");
2085 unsigned new = (unsigned)SvIV(ST(0));
2086 unsigned mask = (unsigned)SvIV(ST(1));
2089 RETVAL = _control87(new, mask);
2090 ST(0) = sv_newmortal();
2091 sv_setiv(ST(0), (IV)RETVAL);
2096 XS(XS_OS2_get_control87)
2100 croak("Usage: OS2::get_control87()");
2104 RETVAL = get_control87();
2105 ST(0) = sv_newmortal();
2106 sv_setiv(ST(0), (IV)RETVAL);
2112 XS(XS_OS2_set_control87)
2115 if (items < 0 || items > 2)
2116 croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
2125 new = (unsigned)SvIV(ST(0));
2131 mask = (unsigned)SvIV(ST(1));
2134 RETVAL = set_control87(new, mask);
2135 ST(0) = sv_newmortal();
2136 sv_setiv(ST(0), (IV)RETVAL);
2144 char *file = __FILE__;
2148 if (_emx_env & 0x200) { /* OS/2 */
2149 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
2150 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
2151 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
2153 newXS("OS2::Error", XS_OS2_Error, file);
2154 newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
2155 newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
2156 newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
2157 newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
2158 newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
2159 newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
2160 newXS("OS2::Process_Messages", XS_OS2_Process_Messages, file);
2161 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
2162 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
2163 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
2164 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
2165 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
2166 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
2167 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
2168 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
2169 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
2170 newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
2171 newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
2172 newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
2173 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
2176 sv_setiv(GvSV(gv), 1);
2178 gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
2180 sv_setiv(GvSV(gv), _emx_rev);
2181 sv_setpv(GvSV(gv), _emx_vprt);
2183 gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
2185 sv_setiv(GvSV(gv), _emx_env);
2186 gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
2188 sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
2193 OS2_Perl_data_t OS2_Perl_data;
2196 Perl_OS2_init(char **env)
2202 OS2_Perl_data.xs_init = &Xs_OS2_init;
2203 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
2204 if (environ == NULL && env) {
2207 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
2208 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
2209 strcpy(PL_sh_path, SH_PATH);
2210 PL_sh_path[0] = shell[0];
2211 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
2212 int l = strlen(shell), i;
2213 if (shell[l-1] == '/' || shell[l-1] == '\\') {
2216 New(1304, PL_sh_path, l + 8, char);
2217 strncpy(PL_sh_path, shell, l);
2218 strcpy(PL_sh_path + l, "/sh.exe");
2219 for (i = 0; i < l; i++) {
2220 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
2223 MUTEX_INIT(&start_thread_mutex);
2224 os2_mytype = my_type(); /* Do it before morphing. Needed? */
2225 /* Some DLLs reset FP flags on load. We may have been linked with them */
2226 _control87(MCW_EM, MCW_EM);
2233 my_tmpnam (char *str)
2235 char *p = getenv("TMP"), *tpath;
2237 if (!p) p = getenv("TEMP");
2238 tpath = tempnam(p, "pltmp");
2252 if (s.st_mode & S_IWOTH) {
2255 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
2262 my_rmdir (__const__ char *s)
2264 char buf[MAXPATHLEN];
2265 STRLEN l = strlen(s);
2267 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
2278 my_mkdir (__const__ char *s, long perm)
2280 char buf[MAXPATHLEN];
2281 STRLEN l = strlen(s);
2283 if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
2288 return mkdir(s, perm);
2293 /* This code was contributed by Rocco Caputo. */
2295 my_flock(int handle, int o)
2297 FILELOCK rNull, rFull;
2298 ULONG timeout, handle_type, flag_word;
2300 int blocking, shared;
2301 static int use_my = -1;
2304 char *s = getenv("USE_PERL_FLOCK");
2310 if (!(_emx_env & 0x200) || !use_my)
2311 return flock(handle, o); /* Delegate to EMX. */
2314 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
2315 (handle_type & 0xFF))
2320 // set lock/unlock ranges
2321 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
2322 rFull.lRange = 0x7FFFFFFF;
2323 // set timeout for blocking
2324 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
2325 // shared or exclusive?
2326 shared = (o & LOCK_SH) ? 1 : 0;
2327 // do not block the unlock
2328 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
2329 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
2334 case ERROR_INVALID_HANDLE:
2337 case ERROR_SHARING_BUFFER_EXCEEDED:
2340 case ERROR_LOCK_VIOLATION:
2341 break; // not an error
2342 case ERROR_INVALID_PARAMETER:
2343 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2344 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2347 case ERROR_INTERRUPT:
2356 if (o & (LOCK_SH | LOCK_EX)) {
2357 // for blocking operations
2371 case ERROR_INVALID_HANDLE:
2374 case ERROR_SHARING_BUFFER_EXCEEDED:
2377 case ERROR_LOCK_VIOLATION:
2379 errno = EWOULDBLOCK;
2383 case ERROR_INVALID_PARAMETER:
2384 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
2385 case ERROR_READ_LOCKS_NOT_SUPPORTED:
2388 case ERROR_INTERRUPT:
2395 // give away timeslice
2404 static int pwent_cnt;
2405 static int _my_pwent = -1;
2410 if (_my_pwent == -1) {
2411 char *s = getenv("USE_PERL_PWENT");
2413 _my_pwent = atoi(s);
2427 if (!use_my_pwent()) {
2428 setpwent(); /* Delegate to EMX. */
2437 if (!use_my_pwent()) {
2438 endpwent(); /* Delegate to EMX. */
2446 if (!use_my_pwent())
2447 return getpwent(); /* Delegate to EMX. */
2449 return 0; // Return one entry only
2453 static int grent_cnt;
2470 return 0; // Return one entry only
2477 /* Too long to be a crypt() of anything, so it is not-a-valid pw_passwd. */
2478 static const char pw_p[] = "Jf0Wb/BzMFvk7K7lrzK";
2480 static struct passwd *
2481 passw_wrap(struct passwd *p)
2483 static struct passwd pw;
2486 if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */
2489 s = getenv("PW_PASSWD");
2491 s = (char*)pw_p; /* Make match impossible */
2498 my_getpwuid (uid_t id)
2500 return passw_wrap(getpwuid(id));
2504 my_getpwnam (__const__ char *n)
2506 return passw_wrap(getpwnam(n));