3 #define INCL_DOSFILEMGR
8 #include <sys/uflags.h>
11 * Various Unix compatibility functions for OS/2
25 typedef void (*emx_startroutine)(void *);
26 typedef void* (*pthreads_startroutine)(void *);
35 const char *pthreads_states[] = {
46 enum pthreads_state state;
49 thread_join_t *thread_join_data;
50 int thread_join_count;
51 perl_mutex start_thread_mutex;
54 pthread_join(perl_os_thread tid, void **status)
56 MUTEX_LOCK(&start_thread_mutex);
57 switch (thread_join_data[tid].state) {
58 case pthreads_st_exited:
59 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
60 MUTEX_UNLOCK(&start_thread_mutex);
61 *status = thread_join_data[tid].status;
63 case pthreads_st_waited:
64 MUTEX_UNLOCK(&start_thread_mutex);
65 croak("join with a thread with a waiter");
68 thread_join_data[tid].state = pthreads_st_waited;
69 COND_INIT(&thread_join_data[tid].cond);
70 MUTEX_UNLOCK(&start_thread_mutex);
71 COND_WAIT(&thread_join_data[tid].cond, NULL);
72 COND_DESTROY(&thread_join_data[tid].cond);
73 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
74 *status = thread_join_data[tid].status;
77 MUTEX_UNLOCK(&start_thread_mutex);
78 croak("join: unknown thread state: '%s'",
79 pthreads_states[thread_join_data[tid].state]);
86 pthread_startit(void *arg)
88 /* Thread is already started, we need to transfer control only */
89 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
90 int tid = pthread_self();
93 arg = ((void**)arg)[1];
94 if (tid >= thread_join_count) {
95 int oc = thread_join_count;
97 thread_join_count = tid + 5 + tid/5;
98 if (thread_join_data) {
99 Renew(thread_join_data, thread_join_count, thread_join_t);
100 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
102 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
105 if (thread_join_data[tid].state != pthreads_st_none)
106 croak("attempt to reuse thread id %i", tid);
107 thread_join_data[tid].state = pthreads_st_run;
108 /* Now that we copied/updated the guys, we may release the caller... */
109 MUTEX_UNLOCK(&start_thread_mutex);
110 thread_join_data[tid].status = (*start_routine)(arg);
111 switch (thread_join_data[tid].state) {
112 case pthreads_st_waited:
113 COND_SIGNAL(&thread_join_data[tid].cond);
116 thread_join_data[tid].state = pthreads_st_exited;
122 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
123 void *(*start_routine)(void*), void *arg)
127 args[0] = (void*)start_routine;
130 MUTEX_LOCK(&start_thread_mutex);
131 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
132 /*stacksize*/ 10*1024*1024, (void*)args);
133 MUTEX_LOCK(&start_thread_mutex);
134 MUTEX_UNLOCK(&start_thread_mutex);
135 return *tid ? 0 : EINVAL;
139 pthread_detach(perl_os_thread tid)
141 MUTEX_LOCK(&start_thread_mutex);
142 switch (thread_join_data[tid].state) {
143 case pthreads_st_waited:
144 MUTEX_UNLOCK(&start_thread_mutex);
145 croak("detach on a thread with a waiter");
147 case pthreads_st_run:
148 thread_join_data[tid].state = pthreads_st_detached;
149 MUTEX_UNLOCK(&start_thread_mutex);
152 MUTEX_UNLOCK(&start_thread_mutex);
153 croak("detach: unknown thread state: '%s'",
154 pthreads_states[thread_join_data[tid].state]);
160 /* This is a very bastardized version: */
162 os2_cond_wait(perl_cond *c, perl_mutex *m)
165 if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET))
166 croak("panic: COND_WAIT-reset: rc=%i", rc);
167 if (m) MUTEX_UNLOCK(m);
168 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
169 && (rc != ERROR_INTERRUPT))
170 croak("panic: COND_WAIT: rc=%i", rc);
171 if (rc == ERROR_INTERRUPT)
173 if (m) MUTEX_LOCK(m);
177 /*****************************************************************************/
178 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
179 static PFN ExtFCN[2]; /* Labeled by ord below. */
180 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
181 #define ORD_QUERY_ELP 0
182 #define ORD_SET_ELP 1
187 if (ExtFCN[ord] == NULL) {
188 static HMODULE hdosc = 0;
193 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
194 "doscalls", &hdosc)))
195 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
196 die("This version of OS/2 does not support doscalls.%i",
200 if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
204 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
206 #define QSS_INI_BUFFER 1024
209 get_sysinfo(ULONG pid, ULONG flags)
212 ULONG rc, buf_len = QSS_INI_BUFFER;
214 New(1322, pbuffer, buf_len, char);
215 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
216 rc = QuerySysState(flags, pid, pbuffer, buf_len);
217 while (rc == ERROR_BUFFER_OVERFLOW) {
218 Renew(pbuffer, buf_len *= 2, char);
219 rc = QuerySysState(flags, pid, pbuffer, buf_len);
226 return (PQTOPLEVEL)pbuffer;
229 #define PRIO_ERR 0x1111
237 psi = get_sysinfo(pid, QSS_PROCESS);
241 if (pid != psi->procdata->pid) {
243 croak("panic: wrong pid in sysinfo");
245 prio = psi->procdata->threads->priority;
251 setpriority(int which, int pid, int val)
256 prio = sys_prio(pid);
258 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
259 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
260 /* Do not change class. */
261 return CheckOSError(DosSetPriority((pid < 0)
262 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
264 (32 - val) % 32 - (prio & 0xFF),
267 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
268 /* Documentation claims one can change both class and basevalue,
269 * but I find it wrong. */
270 /* Change class, but since delta == 0 denotes absolute 0, correct. */
271 if (CheckOSError(DosSetPriority((pid < 0)
272 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
273 priors[(32 - val) >> 5] + 1,
277 if ( ((32 - val) % 32) == 0 ) return 0;
278 return CheckOSError(DosSetPriority((pid < 0)
279 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
285 /* else return CheckOSError(DosSetPriority((pid < 0) */
286 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
287 /* priors[(32 - val) >> 5] + 1, */
288 /* (32 - val) % 32 - (prio & 0xFF), */
294 getpriority(int which /* ignored */, int pid)
300 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
301 /* DosGetInfoBlocks has old priority! */
302 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
303 /* if (pid != pib->pib_ulpid) { */
305 if (ret == PRIO_ERR) {
309 /* ret = tib->tib_ptib2->tib2_ulpri; */
310 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
313 /*****************************************************************************/
316 /* There is no big sense to make it thread-specific, since signals
317 are delivered to thread 1 only. XXXX Maybe make it into an array? */
318 static int spawn_pid;
319 static int spawn_killed;
322 spawn_sighandler(int sig)
324 /* Some programs do not arrange for the keyboard signals to be
325 delivered to them. We need to deliver the signal manually. */
326 /* We may get a signal only if
327 a) kid does not receive keyboard signal: deliver it;
328 b) kid already died, and we get a signal. We may only hope
329 that the pid number was not reused.
333 sig = SIGKILL; /* Try harder. */
334 kill(spawn_pid, sig);
339 result(int flag, int pid)
342 Signal_t (*ihand)(); /* place to save signal during system() */
343 Signal_t (*qhand)(); /* place to save signal during system() */
349 if (pid < 0 || flag != 0)
355 ihand = rsignal(SIGINT, &spawn_sighandler);
356 qhand = rsignal(SIGQUIT, &spawn_sighandler);
358 r = wait4pid(pid, &status, 0);
359 } while (r == -1 && errno == EINTR);
360 rsignal(SIGINT, ihand);
361 rsignal(SIGQUIT, qhand);
363 PL_statusvalue = (U16)status;
366 return status & 0xFFFF;
368 ihand = rsignal(SIGINT, SIG_IGN);
369 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
370 rsignal(SIGINT, ihand);
371 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
374 return PL_statusvalue;
378 #define EXECF_SPAWN 0
380 #define EXECF_TRUEEXEC 2
381 #define EXECF_SPAWN_NOWAIT 3
383 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
392 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
393 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
396 return (pib->pib_ultype);
400 file_type(char *path)
405 if (!(_emx_env & 0x200))
406 croak("file_type not implemented on DOS"); /* not OS/2. */
407 if (CheckOSError(DosQueryAppType(path, &apptype))) {
409 case ERROR_FILE_NOT_FOUND:
410 case ERROR_PATH_NOT_FOUND:
412 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
414 default: /* Found, but not an
415 executable, or some other
423 static ULONG os2_mytype;
425 /* Spawn/exec a program, revert to shell if needed. */
426 /* global PL_Argv[] contains arguments. */
429 do_spawn_ve(really, flag, execf, inicmd)
439 char buf[256], *s = 0, scrbuf[280];
441 static char * fargs[4]
442 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
443 char **argsp = fargs;
451 if (strEQ(PL_Argv[0],"/bin/sh"))
452 PL_Argv[0] = PL_sh_path;
454 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
455 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
456 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
457 ) /* will spawnvp use PATH? */
458 TAINT_ENV(); /* testing IFS here is overkill, probably */
459 /* We should check PERL_SH* and PERLLIB_* as well? */
460 if (!really || !*(tmps = SvPV(really, PL_na)))
465 if (_emx_env & 0x200) { /* OS/2. */
466 int type = file_type(tmps);
468 if (type == -1) { /* Not found */
473 else if (type == -2) { /* Not an EXE */
478 else if (type == -3) { /* Is a directory? */
479 /* Special-case this */
481 int l = strlen(tmps);
483 if (l + 5 <= sizeof tbuf) {
485 strcpy(tbuf + l, ".exe");
486 type = file_type(tbuf);
496 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
497 case FAPPTYP_WINDOWAPI:
499 if (os2_mytype != 3) { /* not PM */
500 if (flag == P_NOWAIT)
502 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
503 warn("Starting PM process with flag=%d, mytype=%d",
508 case FAPPTYP_NOTWINDOWCOMPAT:
510 if (os2_mytype != 0) { /* not full screen */
511 if (flag == P_NOWAIT)
513 else if ((flag & 7) != P_SESSION)
514 warn("Starting Full Screen process with flag=%d, mytype=%d",
519 case FAPPTYP_NOTSPEC:
520 /* Let the shell handle this... */
528 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
530 if (execf == EXECF_TRUEEXEC)
531 rc = execvp(tmps,PL_Argv);
532 else if (execf == EXECF_EXEC)
533 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
534 else if (execf == EXECF_SPAWN_NOWAIT)
535 rc = spawnvp(flag,tmps,PL_Argv);
536 else /* EXECF_SPAWN */
537 rc = result(trueflag,
538 spawnvp(flag,tmps,PL_Argv));
540 if (rc < 0 && pass == 1
541 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
546 if (err == ENOENT || err == ENOEXEC) {
547 /* No such file, or is a script. */
548 /* Try adding script extensions to the file name, and
550 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
553 if (l >= sizeof scrbuf) {
556 croak("Size of scriptname too big: %d", l);
563 FILE *file = fopen(scr, "r");
569 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
573 /* Special case: maybe from -Zexe build, so
574 there is an executable around (contrary to
575 documentation, DosQueryAppType sometimes (?)
576 does not append ".exe", so we could have
577 reached this place). */
578 if (l + 5 < sizeof scrbuf) {
579 strcpy(scrbuf + l, ".exe");
580 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
581 && !S_ISDIR(PL_statbuf.st_mode)) {
591 if (fclose(file) != 0) { /* Failure */
593 warn("Error reading \"%s\": %s",
594 scr, Strerror(errno));
595 buf[0] = 0; /* Not #! */
601 } else if (buf[0] == 'e') {
602 if (strnEQ(buf, "extproc", 7)
605 } else if (buf[0] == 'E') {
606 if (strnEQ(buf, "EXTPROC", 7)
611 buf[0] = 0; /* Not #! */
619 /* Do better than pdksh: allow a few args,
620 strip trailing whitespace. */
630 while (*s && !isSPACE(*s))
637 warn("Too many args on %.*s line of \"%s\"",
648 || (!buf[0] && file)) { /* File without magic */
649 /* In fact we tried all what pdksh would
650 try. There is no point in calling
651 pdksh, we may just emulate its logic. */
652 char *shell = getenv("EXECSHELL");
653 char *shell_opt = NULL;
659 shell = getenv("OS2_SHELL");
660 if (inicmd) { /* No spaces at start! */
662 while (*s && !isSPACE(*s)) {
664 inicmd = NULL; /* Cannot use */
672 /* Dosish shells will choke on slashes
673 in paths, fortunately, this is
674 important for zeroth arg only. */
681 /* If EXECSHELL is set, we do not set */
684 shell = ((_emx_env & 0x200)
687 nargs = shell_opt ? 2 : 1; /* shell file args */
688 exec_args[0] = shell;
689 exec_args[1] = shell_opt;
691 if (nargs == 2 && inicmd) {
692 /* Use the original cmd line */
693 /* XXXX This is good only until we refuse
694 quoted arguments... */
698 } else if (!buf[0] && inicmd) { /* No file */
699 /* Start with the original cmdline. */
700 /* XXXX This is good only until we refuse
701 quoted arguments... */
705 nargs = 2; /* shell -c */
708 while (a[1]) /* Get to the end */
710 a++; /* Copy finil NULL too */
711 while (a >= PL_Argv) {
712 *(a + nargs) = *a; /* PL_Argv was preallocated to be
717 PL_Argv[nargs] = argsp[nargs];
718 /* Enable pathless exec if #! (as pdksh). */
719 pass = (buf[0] == '#' ? 2 : 3);
723 /* Not found: restore errno */
727 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
728 char *no_dir = strrchr(PL_Argv[0], '/');
730 /* Do as pdksh port does: if not found with /, try without
733 PL_Argv[0] = no_dir + 1;
738 if (rc < 0 && PL_dowarn)
739 warn("Can't %s \"%s\": %s\n",
740 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
742 PL_Argv[0], Strerror(errno));
743 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
744 && ((trueflag & 0xFF) == P_WAIT))
745 rc = 255 << 8; /* Emulate the fork(). */
752 do_aspawn(really,mark,sp)
761 int flag = P_WAIT, trueflag, err, secondtry = 0;
764 New(1301,PL_Argv, sp - mark + 3, char*);
767 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
772 while (++mark <= sp) {
774 *a++ = SvPVx(*mark, PL_na);
780 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
787 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
789 do_spawn2(cmd, execf)
796 char *shell, *copt, *news = NULL;
797 int rc, err, seenspace = 0;
798 char fullcmd[MAXNAMLEN + 1];
801 if ((shell = getenv("EMXSHELL")) != NULL)
803 else if ((shell = getenv("SHELL")) != NULL)
805 else if ((shell = getenv("COMSPEC")) != NULL)
810 /* Consensus on perl5-porters is that it is _very_ important to
811 have a shell which will not change between computers with the
812 same architecture, to avoid "action on a distance".
813 And to have simple build, this shell should be sh. */
818 while (*cmd && isSPACE(*cmd))
821 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
822 STRLEN l = strlen(PL_sh_path);
824 New(1302, news, strlen(cmd) - 7 + l + 1, char);
825 strcpy(news, PL_sh_path);
826 strcpy(news + l, cmd + 7);
830 /* save an extra exec if possible */
831 /* see if there are shell metacharacters in it */
833 if (*cmd == '.' && isSPACE(cmd[1]))
836 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
839 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
843 for (s = cmd; *s; s++) {
844 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
845 if (*s == '\n' && s[1] == '\0') {
848 } else if (*s == '\\' && !seenspace) {
849 continue; /* Allow backslashes in names */
851 /* We do not convert this to do_spawn_ve since shell
852 should be smart enough to start itself gloriously. */
854 if (execf == EXECF_TRUEEXEC)
855 rc = execl(shell,shell,copt,cmd,(char*)0);
856 else if (execf == EXECF_EXEC)
857 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
858 else if (execf == EXECF_SPAWN_NOWAIT)
859 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
861 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
863 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
864 if (rc < 0 && PL_dowarn)
865 warn("Can't %s \"%s\": %s",
866 (execf == EXECF_SPAWN ? "spawn" : "exec"),
867 shell, Strerror(errno));
868 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
873 } else if (*s == ' ' || *s == '\t') {
878 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
879 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
880 PL_Cmd = savepvn(cmd, s-cmd);
882 for (s = PL_Cmd; *s;) {
883 while (*s && isSPACE(*s)) s++;
886 while (*s && !isSPACE(*s)) s++;
892 rc = do_spawn_ve(NULL, 0, execf, cmd);
905 return do_spawn2(cmd, EXECF_SPAWN);
912 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
919 do_spawn2(cmd, EXECF_EXEC);
927 return do_spawn2(cmd, EXECF_TRUEEXEC);
931 my_syspopen(cmd,mode)
938 register I32 this, that, newfd;
939 register I32 pid, rc;
943 /* `this' is what we use in the parent, `that' in the child. */
944 this = (*mode == 'w');
948 taint_proper("Insecure %s%s", "EXEC");
952 /* Now we need to spawn the child. */
953 newfd = dup(*mode == 'r'); /* Preserve std* */
954 if (p[that] != (*mode == 'r')) {
955 dup2(p[that], *mode == 'r');
958 /* Where is `this' and newfd now? */
959 fcntl(p[this], F_SETFD, FD_CLOEXEC);
960 fcntl(newfd, F_SETFD, FD_CLOEXEC);
961 pid = do_spawn_nowait(cmd);
962 if (newfd != (*mode == 'r')) {
963 dup2(newfd, *mode == 'r'); /* Return std* back. */
966 if (p[that] == (*mode == 'r'))
972 if (p[that] < p[this]) {
973 dup2(p[this], p[that]);
977 sv = *av_fetch(PL_fdpid,p[this],TRUE);
978 (void)SvUPGRADE(sv,SVt_IV);
980 PL_forkprocess = pid;
981 return PerlIO_fdopen(p[this], mode);
983 #else /* USE_POPEN */
989 res = popen(cmd, mode);
991 char *shell = getenv("EMXSHELL");
993 my_setenv("EMXSHELL", PL_sh_path);
994 res = popen(cmd, mode);
995 my_setenv("EMXSHELL", shell);
997 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
998 (void)SvUPGRADE(sv,SVt_IV);
999 SvIVX(sv) = -1; /* A cooky. */
1002 #endif /* USE_POPEN */
1006 /******************************************************************/
1012 die(PL_no_func, "Unsupported function fork");
1018 /*******************************************************************/
1019 /* not implemented in EMX 0.9a */
1021 void * ctermid(x) { return 0; }
1023 #ifdef MYTTYNAME /* was not in emx0.9a */
1024 void * ttyname(x) { return 0; }
1027 /******************************************************************/
1028 /* my socket forwarders - EMX lib only provides static forwarders */
1030 static HMODULE htcp = 0;
1035 static BYTE buf[20];
1038 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1040 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1041 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1042 return (void *) ((void * (*)(void)) fcn) ();
1047 tcp1(char *name, int arg)
1049 static BYTE buf[20];
1052 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1054 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1055 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1056 ((void (*)(int)) fcn) (arg);
1059 void * gethostent() { return tcp0("GETHOSTENT"); }
1060 void * getnetent() { return tcp0("GETNETENT"); }
1061 void * getprotoent() { return tcp0("GETPROTOENT"); }
1062 void * getservent() { return tcp0("GETSERVENT"); }
1063 void sethostent(x) { tcp1("SETHOSTENT", x); }
1064 void setnetent(x) { tcp1("SETNETENT", x); }
1065 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1066 void setservent(x) { tcp1("SETSERVENT", x); }
1067 void endhostent() { tcp0("ENDHOSTENT"); }
1068 void endnetent() { tcp0("ENDNETENT"); }
1069 void endprotoent() { tcp0("ENDPROTOENT"); }
1070 void endservent() { tcp0("ENDSERVENT"); }
1072 /*****************************************************************************/
1073 /* not implemented in C Set++ */
1076 int setuid(x) { errno = EINVAL; return -1; }
1077 int setgid(x) { errno = EINVAL; return -1; }
1080 /*****************************************************************************/
1081 /* stat() hack for char/block device */
1085 /* First attempt used DosQueryFSAttach which crashed the system when
1086 used with 5.001. Now just look for /dev/. */
1089 os2_stat(char *name, struct stat *st)
1091 static int ino = SHRT_MAX;
1093 if (stricmp(name, "/dev/con") != 0
1094 && stricmp(name, "/dev/tty") != 0)
1095 return stat(name, st);
1097 memset(st, 0, sizeof *st);
1098 st->st_mode = S_IFCHR|0666;
1099 st->st_ino = (ino-- & 0x7FFF);
1106 #ifdef USE_PERL_SBRK
1108 /* SBRK() emulation, mostly moved to malloc.c. */
1111 sys_alloc(int size) {
1113 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1115 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1117 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
1121 #endif /* USE_PERL_SBRK */
1125 char *tmppath = TMPPATH1;
1130 char *p = getenv("TMP"), *tpath;
1133 if (!p) p = getenv("TEMP");
1136 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1139 strcpy(tpath + len + 1, TMPPATH1);
1145 XS(XS_File__Copy_syscopy)
1148 if (items < 2 || items > 3)
1149 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1151 char * src = (char *)SvPV(ST(0),PL_na);
1152 char * dst = (char *)SvPV(ST(1),PL_na);
1159 flag = (unsigned long)SvIV(ST(2));
1162 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1163 ST(0) = sv_newmortal();
1164 sv_setiv(ST(0), (IV)RETVAL);
1169 #include "patchlevel.h"
1175 static char fname[9];
1176 int pos = 6, len, avlen;
1177 unsigned int sum = 0;
1182 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1184 if (SvTYPE(sv) != SVt_PVAV)
1185 croak("Not array reference given to mod2fname");
1187 avlen = av_len((AV*)sv);
1189 croak("Empty array reference given to mod2fname");
1191 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1192 strncpy(fname, s, 8);
1194 if (len < 6) pos = len;
1196 sum = 33 * sum + *(s++); /* Checksumming first chars to
1197 * get the capitalization into c.s. */
1200 while (avlen >= 0) {
1201 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1203 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1208 sum++; /* Avoid conflict of DLLs in memory. */
1210 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
1211 fname[pos] = 'A' + (sum % 26);
1212 fname[pos + 1] = 'A' + (sum / 26 % 26);
1213 fname[pos + 2] = '\0';
1214 return (char *)fname;
1217 XS(XS_DynaLoader_mod2fname)
1221 croak("Usage: DynaLoader::mod2fname(sv)");
1226 RETVAL = mod2fname(sv);
1227 ST(0) = sv_newmortal();
1228 sv_setpv((SV*)ST(0), RETVAL);
1236 static char buf[300];
1239 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1242 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1243 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1246 if (len > 0 && buf[len - 1] == '\n')
1247 buf[len - 1] = '\0';
1248 if (len > 1 && buf[len - 2] == '\r')
1249 buf[len - 2] = '\0';
1250 if (len > 2 && buf[len - 3] == '.')
1251 buf[len - 3] = '\0';
1256 perllib_mangle(char *s, unsigned int l)
1258 static char *newp, *oldp;
1259 static int newl, oldl, notfound;
1260 static char ret[STATIC_FILE_LENGTH+1];
1262 if (!newp && !notfound) {
1263 newp = getenv("PERLLIB_PREFIX");
1268 while (*newp && !isSPACE(*newp) && *newp != ';') {
1269 newp++; oldl++; /* Skip digits. */
1271 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1272 newp++; /* Skip whitespace. */
1274 newl = strlen(newp);
1275 if (newl == 0 || oldl == 0) {
1276 die("Malformed PERLLIB_PREFIX");
1281 if (*s == '\\') *s = '/';
1294 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1297 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1298 die("Malformed PERLLIB_PREFIX");
1300 strcpy(ret + newl, s + oldl);
1304 extern void dlopen();
1305 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1307 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1308 && ((path)[2] == '/' || (path)[2] == '\\'))
1309 #define sys_is_rooted _fnisabs
1310 #define sys_is_relative _fnisrel
1311 #define current_drive _getdrive
1313 #undef chdir /* Was _chdir2. */
1314 #define sys_chdir(p) (chdir(p) == 0)
1315 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1317 XS(XS_Cwd_current_drive)
1321 croak("Usage: Cwd::current_drive()");
1325 RETVAL = current_drive();
1326 ST(0) = sv_newmortal();
1327 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1332 XS(XS_Cwd_sys_chdir)
1336 croak("Usage: Cwd::sys_chdir(path)");
1338 char * path = (char *)SvPV(ST(0),PL_na);
1341 RETVAL = sys_chdir(path);
1342 ST(0) = boolSV(RETVAL);
1343 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1348 XS(XS_Cwd_change_drive)
1352 croak("Usage: Cwd::change_drive(d)");
1354 char d = (char)*SvPV(ST(0),PL_na);
1357 RETVAL = change_drive(d);
1358 ST(0) = boolSV(RETVAL);
1359 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1364 XS(XS_Cwd_sys_is_absolute)
1368 croak("Usage: Cwd::sys_is_absolute(path)");
1370 char * path = (char *)SvPV(ST(0),PL_na);
1373 RETVAL = sys_is_absolute(path);
1374 ST(0) = boolSV(RETVAL);
1375 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1380 XS(XS_Cwd_sys_is_rooted)
1384 croak("Usage: Cwd::sys_is_rooted(path)");
1386 char * path = (char *)SvPV(ST(0),PL_na);
1389 RETVAL = sys_is_rooted(path);
1390 ST(0) = boolSV(RETVAL);
1391 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1396 XS(XS_Cwd_sys_is_relative)
1400 croak("Usage: Cwd::sys_is_relative(path)");
1402 char * path = (char *)SvPV(ST(0),PL_na);
1405 RETVAL = sys_is_relative(path);
1406 ST(0) = boolSV(RETVAL);
1407 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1416 croak("Usage: Cwd::sys_cwd()");
1420 RETVAL = _getcwd2(p, MAXPATHLEN);
1421 ST(0) = sv_newmortal();
1422 sv_setpv((SV*)ST(0), RETVAL);
1427 XS(XS_Cwd_sys_abspath)
1430 if (items < 1 || items > 2)
1431 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1433 char * path = (char *)SvPV(ST(0),PL_na);
1441 dir = (char *)SvPV(ST(1),PL_na);
1443 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1447 if (_abspath(p, path, MAXPATHLEN) == 0) {
1453 /* Absolute with drive: */
1454 if ( sys_is_absolute(path) ) {
1455 if (_abspath(p, path, MAXPATHLEN) == 0) {
1460 } else if (path[0] == '/' || path[0] == '\\') {
1461 /* Rooted, but maybe on different drive. */
1462 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1463 char p1[MAXPATHLEN];
1465 /* Need to prepend the drive. */
1468 Copy(path, p1 + 2, strlen(path) + 1, char);
1470 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1475 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1481 /* Either path is relative, or starts with a drive letter. */
1482 /* If the path starts with a drive letter, then dir is
1484 a/b) it is absolute/x:relative on the same drive.
1485 c) path is on current drive, and dir is rooted
1486 In all the cases it is safe to drop the drive part
1488 if ( !sys_is_relative(path) ) {
1491 if ( ( ( sys_is_absolute(dir)
1492 || (isALPHA(dir[0]) && dir[1] == ':'
1493 && strnicmp(dir, path,1) == 0))
1494 && strnicmp(dir, path,1) == 0)
1495 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1496 && toupper(path[0]) == current_drive())) {
1498 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1499 RETVAL = p; goto done;
1501 RETVAL = NULL; goto done;
1505 /* Need to prepend the absolute path of dir. */
1506 char p1[MAXPATHLEN];
1508 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1511 if (p1[ l - 1 ] != '/') {
1515 Copy(path, p1 + l, strlen(path) + 1, char);
1516 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1528 ST(0) = sv_newmortal();
1529 sv_setpv((SV*)ST(0), RETVAL);
1533 typedef APIRET (*PELP)(PSZ path, ULONG type);
1536 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1538 loadByOrd(ord); /* Guarantied to load or die! */
1539 return (*(PELP)ExtFCN[ord])(path, type);
1542 #define extLibpath(type) \
1543 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1544 : BEGIN_LIBPATH))) \
1547 #define extLibpath_set(p,type) \
1548 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1551 XS(XS_Cwd_extLibpath)
1554 if (items < 0 || items > 1)
1555 croak("Usage: Cwd::extLibpath(type = 0)");
1565 type = (int)SvIV(ST(0));
1568 RETVAL = extLibpath(type);
1569 ST(0) = sv_newmortal();
1570 sv_setpv((SV*)ST(0), RETVAL);
1575 XS(XS_Cwd_extLibpath_set)
1578 if (items < 1 || items > 2)
1579 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1581 char * s = (char *)SvPV(ST(0),PL_na);
1589 type = (int)SvIV(ST(1));
1592 RETVAL = extLibpath_set(s, type);
1593 ST(0) = boolSV(RETVAL);
1594 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1602 char *file = __FILE__;
1606 if (_emx_env & 0x200) { /* OS/2 */
1607 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1608 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1609 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1611 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1612 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1613 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1614 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1615 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1616 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1617 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1618 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1619 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1620 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1623 sv_setiv(GvSV(gv), 1);
1628 OS2_Perl_data_t OS2_Perl_data;
1631 Perl_OS2_init(char **env)
1637 OS2_Perl_data.xs_init = &Xs_OS2_init;
1638 _uflags (_UF_SBRK_MODEL, _UF_SBRK_ARBITRARY);
1639 if (environ == NULL) {
1642 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1643 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1644 strcpy(PL_sh_path, SH_PATH);
1645 PL_sh_path[0] = shell[0];
1646 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1647 int l = strlen(shell), i;
1648 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1651 New(1304, PL_sh_path, l + 8, char);
1652 strncpy(PL_sh_path, shell, l);
1653 strcpy(PL_sh_path + l, "/sh.exe");
1654 for (i = 0; i < l; i++) {
1655 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1658 MUTEX_INIT(&start_thread_mutex);
1659 os2_mytype = my_type(); /* Do it before morphing. Needed? */
1666 my_tmpnam (char *str)
1668 char *p = getenv("TMP"), *tpath;
1671 if (!p) p = getenv("TEMP");
1672 tpath = tempnam(p, "pltmp");
1686 if (s.st_mode & S_IWOTH) {
1689 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1695 /* This code was contributed by Rocco Caputo. */
1697 my_flock(int handle, int o)
1699 FILELOCK rNull, rFull;
1700 ULONG timeout, handle_type, flag_word;
1702 int blocking, shared;
1703 static int use_my = -1;
1706 char *s = getenv("USE_PERL_FLOCK");
1712 if (!(_emx_env & 0x200) || !use_my)
1713 return flock(handle, o); /* Delegate to EMX. */
1716 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1717 (handle_type & 0xFF))
1722 // set lock/unlock ranges
1723 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1724 rFull.lRange = 0x7FFFFFFF;
1725 // set timeout for blocking
1726 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1727 // shared or exclusive?
1728 shared = (o & LOCK_SH) ? 1 : 0;
1729 // do not block the unlock
1730 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1731 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1736 case ERROR_INVALID_HANDLE:
1739 case ERROR_SHARING_BUFFER_EXCEEDED:
1742 case ERROR_LOCK_VIOLATION:
1743 break; // not an error
1744 case ERROR_INVALID_PARAMETER:
1745 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1746 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1749 case ERROR_INTERRUPT:
1758 if (o & (LOCK_SH | LOCK_EX)) {
1759 // for blocking operations
1773 case ERROR_INVALID_HANDLE:
1776 case ERROR_SHARING_BUFFER_EXCEEDED:
1779 case ERROR_LOCK_VIOLATION:
1781 errno = EWOULDBLOCK;
1785 case ERROR_INVALID_PARAMETER:
1786 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1787 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1790 case ERROR_INTERRUPT:
1797 // give away timeslice