3 #define INCL_DOSFILEMGR
9 * Various Unix compatibility functions for OS/2
23 typedef void (*emx_startroutine)(void *);
24 typedef void* (*pthreads_startroutine)(void *);
33 const char *pthreads_states[] = {
44 enum pthreads_state state;
47 thread_join_t *thread_join_data;
48 int thread_join_count;
49 perl_mutex start_thread_mutex;
52 pthread_join(perl_os_thread tid, void **status)
54 MUTEX_LOCK(&start_thread_mutex);
55 switch (thread_join_data[tid].state) {
56 case pthreads_st_exited:
57 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
58 MUTEX_UNLOCK(&start_thread_mutex);
59 *status = thread_join_data[tid].status;
61 case pthreads_st_waited:
62 MUTEX_UNLOCK(&start_thread_mutex);
63 croak("join with a thread with a waiter");
66 thread_join_data[tid].state = pthreads_st_waited;
67 COND_INIT(&thread_join_data[tid].cond);
68 MUTEX_UNLOCK(&start_thread_mutex);
69 COND_WAIT(&thread_join_data[tid].cond, NULL);
70 COND_DESTROY(&thread_join_data[tid].cond);
71 thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */
72 *status = thread_join_data[tid].status;
75 MUTEX_UNLOCK(&start_thread_mutex);
76 croak("join: unknown thread state: '%s'",
77 pthreads_states[thread_join_data[tid].state]);
84 pthread_startit(void *arg)
86 /* Thread is already started, we need to transfer control only */
87 pthreads_startroutine start_routine = *((pthreads_startroutine*)arg);
88 int tid = pthread_self();
91 arg = ((void**)arg)[1];
92 if (tid >= thread_join_count) {
93 int oc = thread_join_count;
95 thread_join_count = tid + 5 + tid/5;
96 if (thread_join_data) {
97 Renew(thread_join_data, thread_join_count, thread_join_t);
98 Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t);
100 Newz(1323, thread_join_data, thread_join_count, thread_join_t);
103 if (thread_join_data[tid].state != pthreads_st_none)
104 croak("attempt to reuse thread id %i", tid);
105 thread_join_data[tid].state = pthreads_st_run;
106 /* Now that we copied/updated the guys, we may release the caller... */
107 MUTEX_UNLOCK(&start_thread_mutex);
108 thread_join_data[tid].status = (*start_routine)(arg);
109 switch (thread_join_data[tid].state) {
110 case pthreads_st_waited:
111 COND_SIGNAL(&thread_join_data[tid].cond);
114 thread_join_data[tid].state = pthreads_st_exited;
120 pthread_create(perl_os_thread *tid, const pthread_attr_t *attr,
121 void *(*start_routine)(void*), void *arg)
125 args[0] = (void*)start_routine;
128 MUTEX_LOCK(&start_thread_mutex);
129 *tid = _beginthread(pthread_startit, /*stack*/ NULL,
130 /*stacksize*/ 10*1024*1024, (void*)args);
131 MUTEX_LOCK(&start_thread_mutex);
132 MUTEX_UNLOCK(&start_thread_mutex);
133 return *tid ? 0 : EINVAL;
137 pthread_detach(perl_os_thread tid)
139 MUTEX_LOCK(&start_thread_mutex);
140 switch (thread_join_data[tid].state) {
141 case pthreads_st_waited:
142 MUTEX_UNLOCK(&start_thread_mutex);
143 croak("detach on a thread with a waiter");
145 case pthreads_st_run:
146 thread_join_data[tid].state = pthreads_st_detached;
147 MUTEX_UNLOCK(&start_thread_mutex);
150 MUTEX_UNLOCK(&start_thread_mutex);
151 croak("detach: unknown thread state: '%s'",
152 pthreads_states[thread_join_data[tid].state]);
158 /* This is a very bastardized version: */
160 os2_cond_wait(perl_cond *c, perl_mutex *m)
163 if ((rc = DosResetEventSem(*c,&PL_na)) && (rc != ERROR_ALREADY_RESET))
164 croak("panic: COND_WAIT-reset: rc=%i", rc);
165 if (m) MUTEX_UNLOCK(m);
166 if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT))
167 && (rc != ERROR_INTERRUPT))
168 croak("panic: COND_WAIT: rc=%i", rc);
169 if (rc == ERROR_INTERRUPT)
171 if (m) MUTEX_LOCK(m);
175 /*****************************************************************************/
176 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
177 static PFN ExtFCN[2]; /* Labeled by ord below. */
178 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
179 #define ORD_QUERY_ELP 0
180 #define ORD_SET_ELP 1
185 if (ExtFCN[ord] == NULL) {
186 static HMODULE hdosc = 0;
191 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
192 "doscalls", &hdosc)))
193 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
194 die("This version of OS/2 does not support doscalls.%i",
198 if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
202 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
204 #define QSS_INI_BUFFER 1024
207 get_sysinfo(ULONG pid, ULONG flags)
210 ULONG rc, buf_len = QSS_INI_BUFFER;
212 New(1322, pbuffer, buf_len, char);
213 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
214 rc = QuerySysState(flags, pid, pbuffer, buf_len);
215 while (rc == ERROR_BUFFER_OVERFLOW) {
216 Renew(pbuffer, buf_len *= 2, char);
217 rc = QuerySysState(flags, pid, pbuffer, buf_len);
224 return (PQTOPLEVEL)pbuffer;
227 #define PRIO_ERR 0x1111
235 psi = get_sysinfo(pid, QSS_PROCESS);
239 if (pid != psi->procdata->pid) {
241 croak("panic: wrong pid in sysinfo");
243 prio = psi->procdata->threads->priority;
249 setpriority(int which, int pid, int val)
254 prio = sys_prio(pid);
256 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
257 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
258 /* Do not change class. */
259 return CheckOSError(DosSetPriority((pid < 0)
260 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
262 (32 - val) % 32 - (prio & 0xFF),
265 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
266 /* Documentation claims one can change both class and basevalue,
267 * but I find it wrong. */
268 /* Change class, but since delta == 0 denotes absolute 0, correct. */
269 if (CheckOSError(DosSetPriority((pid < 0)
270 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
271 priors[(32 - val) >> 5] + 1,
275 if ( ((32 - val) % 32) == 0 ) return 0;
276 return CheckOSError(DosSetPriority((pid < 0)
277 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
283 /* else return CheckOSError(DosSetPriority((pid < 0) */
284 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
285 /* priors[(32 - val) >> 5] + 1, */
286 /* (32 - val) % 32 - (prio & 0xFF), */
292 getpriority(int which /* ignored */, int pid)
298 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
299 /* DosGetInfoBlocks has old priority! */
300 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
301 /* if (pid != pib->pib_ulpid) { */
303 if (ret == PRIO_ERR) {
307 /* ret = tib->tib_ptib2->tib2_ulpri; */
308 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
311 /*****************************************************************************/
314 /* There is no big sense to make it thread-specific, since signals
315 are delivered to thread 1 only. XXXX Maybe make it into an array? */
316 static int spawn_pid;
317 static int spawn_killed;
320 spawn_sighandler(int sig)
322 /* Some programs do not arrange for the keyboard signals to be
323 delivered to them. We need to deliver the signal manually. */
324 /* We may get a signal only if
325 a) kid does not receive keyboard signal: deliver it;
326 b) kid already died, and we get a signal. We may only hope
327 that the pid number was not reused.
331 sig = SIGKILL; /* Try harder. */
332 kill(spawn_pid, sig);
337 result(int flag, int pid)
340 Signal_t (*ihand)(); /* place to save signal during system() */
341 Signal_t (*qhand)(); /* place to save signal during system() */
347 if (pid < 0 || flag != 0)
353 ihand = rsignal(SIGINT, &spawn_sighandler);
354 qhand = rsignal(SIGQUIT, &spawn_sighandler);
356 r = wait4pid(pid, &status, 0);
357 } while (r == -1 && errno == EINTR);
358 rsignal(SIGINT, ihand);
359 rsignal(SIGQUIT, qhand);
361 PL_statusvalue = (U16)status;
364 return status & 0xFFFF;
366 ihand = rsignal(SIGINT, SIG_IGN);
367 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
368 rsignal(SIGINT, ihand);
369 PL_statusvalue = res.codeResult << 8 | res.codeTerminate;
372 return PL_statusvalue;
376 #define EXECF_SPAWN 0
378 #define EXECF_TRUEEXEC 2
379 #define EXECF_SPAWN_NOWAIT 3
381 /* const char* const ptypes[] = { "FS", "DOS", "VIO", "PM", "DETACH" }; */
390 if (!(_emx_env & 0x200)) return 1; /* not OS/2. */
391 if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
394 return (pib->pib_ultype);
398 file_type(char *path)
403 if (!(_emx_env & 0x200))
404 croak("file_type not implemented on DOS"); /* not OS/2. */
405 if (CheckOSError(DosQueryAppType(path, &apptype))) {
407 case ERROR_FILE_NOT_FOUND:
408 case ERROR_PATH_NOT_FOUND:
410 case ERROR_ACCESS_DENIED: /* Directory with this name found? */
412 default: /* Found, but not an
413 executable, or some other
421 static ULONG os2_mytype;
423 /* Spawn/exec a program, revert to shell if needed. */
424 /* global PL_Argv[] contains arguments. */
427 do_spawn_ve(really, flag, execf, inicmd)
437 char buf[256], *s = 0, scrbuf[280];
439 static char * fargs[4]
440 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
441 char **argsp = fargs;
449 if (strEQ(PL_Argv[0],"/bin/sh"))
450 PL_Argv[0] = PL_sh_path;
452 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
453 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
454 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
455 ) /* will spawnvp use PATH? */
456 TAINT_ENV(); /* testing IFS here is overkill, probably */
457 /* We should check PERL_SH* and PERLLIB_* as well? */
458 if (!really || !*(tmps = SvPV(really, PL_na)))
463 if (_emx_env & 0x200) { /* OS/2. */
464 int type = file_type(tmps);
466 if (type == -1) { /* Not found */
471 else if (type == -2) { /* Not an EXE */
476 else if (type == -3) { /* Is a directory? */
477 /* Special-case this */
479 int l = strlen(tmps);
481 if (l + 5 <= sizeof tbuf) {
483 strcpy(tbuf + l, ".exe");
484 type = file_type(tbuf);
494 /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */
495 case FAPPTYP_WINDOWAPI:
497 if (os2_mytype != 3) { /* not PM */
498 if (flag == P_NOWAIT)
500 else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION)
501 warn("Starting PM process with flag=%d, mytype=%d",
506 case FAPPTYP_NOTWINDOWCOMPAT:
508 if (os2_mytype != 0) { /* not full screen */
509 if (flag == P_NOWAIT)
511 else if ((flag & 7) != P_SESSION)
512 warn("Starting Full Screen process with flag=%d, mytype=%d",
517 case FAPPTYP_NOTSPEC:
518 /* Let the shell handle this... */
526 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
528 if (execf == EXECF_TRUEEXEC)
529 rc = execvp(tmps,PL_Argv);
530 else if (execf == EXECF_EXEC)
531 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
532 else if (execf == EXECF_SPAWN_NOWAIT)
533 rc = spawnvp(flag,tmps,PL_Argv);
534 else /* EXECF_SPAWN */
535 rc = result(trueflag,
536 spawnvp(flag,tmps,PL_Argv));
538 if (rc < 0 && pass == 1
539 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
544 if (err == ENOENT || err == ENOEXEC) {
545 /* No such file, or is a script. */
546 /* Try adding script extensions to the file name, and
548 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
551 if (l >= sizeof scrbuf) {
554 croak("Size of scriptname too big: %d", l);
561 FILE *file = fopen(scr, "r");
567 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
571 /* Special case: maybe from -Zexe build, so
572 there is an executable around (contrary to
573 documentation, DosQueryAppType sometimes (?)
574 does not append ".exe", so we could have
575 reached this place). */
576 if (l + 5 < sizeof scrbuf) {
577 strcpy(scrbuf + l, ".exe");
578 if (PerlLIO_stat(scrbuf,&PL_statbuf) >= 0
579 && !S_ISDIR(PL_statbuf.st_mode)) {
589 if (fclose(file) != 0) { /* Failure */
591 warn("Error reading \"%s\": %s",
592 scr, Strerror(errno));
593 buf[0] = 0; /* Not #! */
599 } else if (buf[0] == 'e') {
600 if (strnEQ(buf, "extproc", 7)
603 } else if (buf[0] == 'E') {
604 if (strnEQ(buf, "EXTPROC", 7)
609 buf[0] = 0; /* Not #! */
617 /* Do better than pdksh: allow a few args,
618 strip trailing whitespace. */
628 while (*s && !isSPACE(*s))
635 warn("Too many args on %.*s line of \"%s\"",
646 || (!buf[0] && file)) { /* File without magic */
647 /* In fact we tried all what pdksh would
648 try. There is no point in calling
649 pdksh, we may just emulate its logic. */
650 char *shell = getenv("EXECSHELL");
651 char *shell_opt = NULL;
657 shell = getenv("OS2_SHELL");
658 if (inicmd) { /* No spaces at start! */
660 while (*s && !isSPACE(*s)) {
662 inicmd = NULL; /* Cannot use */
670 /* Dosish shells will choke on slashes
671 in paths, fortunately, this is
672 important for zeroth arg only. */
679 /* If EXECSHELL is set, we do not set */
682 shell = ((_emx_env & 0x200)
685 nargs = shell_opt ? 2 : 1; /* shell file args */
686 exec_args[0] = shell;
687 exec_args[1] = shell_opt;
689 if (nargs == 2 && inicmd) {
690 /* Use the original cmd line */
691 /* XXXX This is good only until we refuse
692 quoted arguments... */
696 } else if (!buf[0] && inicmd) { /* No file */
697 /* Start with the original cmdline. */
698 /* XXXX This is good only until we refuse
699 quoted arguments... */
703 nargs = 2; /* shell -c */
706 while (a[1]) /* Get to the end */
708 a++; /* Copy finil NULL too */
709 while (a >= PL_Argv) {
710 *(a + nargs) = *a; /* PL_Argv was preallocated to be
715 PL_Argv[nargs] = argsp[nargs];
716 /* Enable pathless exec if #! (as pdksh). */
717 pass = (buf[0] == '#' ? 2 : 3);
721 /* Not found: restore errno */
725 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
726 char *no_dir = strrchr(PL_Argv[0], '/');
728 /* Do as pdksh port does: if not found with /, try without
731 PL_Argv[0] = no_dir + 1;
736 if (rc < 0 && PL_dowarn)
737 warn("Can't %s \"%s\": %s\n",
738 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
740 PL_Argv[0], Strerror(errno));
741 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
742 && ((trueflag & 0xFF) == P_WAIT))
743 rc = 255 << 8; /* Emulate the fork(). */
750 do_aspawn(really,mark,sp)
759 int flag = P_WAIT, trueflag, err, secondtry = 0;
762 New(1301,PL_Argv, sp - mark + 3, char*);
765 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
770 while (++mark <= sp) {
772 *a++ = SvPVx(*mark, PL_na);
778 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
785 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
787 do_spawn2(cmd, execf)
794 char *shell, *copt, *news = NULL;
795 int rc, err, seenspace = 0;
796 char fullcmd[MAXNAMLEN + 1];
799 if ((shell = getenv("EMXSHELL")) != NULL)
801 else if ((shell = getenv("SHELL")) != NULL)
803 else if ((shell = getenv("COMSPEC")) != NULL)
808 /* Consensus on perl5-porters is that it is _very_ important to
809 have a shell which will not change between computers with the
810 same architecture, to avoid "action on a distance".
811 And to have simple build, this shell should be sh. */
816 while (*cmd && isSPACE(*cmd))
819 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
820 STRLEN l = strlen(PL_sh_path);
822 New(1302, news, strlen(cmd) - 7 + l + 1, char);
823 strcpy(news, PL_sh_path);
824 strcpy(news + l, cmd + 7);
828 /* save an extra exec if possible */
829 /* see if there are shell metacharacters in it */
831 if (*cmd == '.' && isSPACE(cmd[1]))
834 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
837 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
841 for (s = cmd; *s; s++) {
842 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
843 if (*s == '\n' && s[1] == '\0') {
846 } else if (*s == '\\' && !seenspace) {
847 continue; /* Allow backslashes in names */
849 /* We do not convert this to do_spawn_ve since shell
850 should be smart enough to start itself gloriously. */
852 if (execf == EXECF_TRUEEXEC)
853 rc = execl(shell,shell,copt,cmd,(char*)0);
854 else if (execf == EXECF_EXEC)
855 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
856 else if (execf == EXECF_SPAWN_NOWAIT)
857 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
859 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
861 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
862 if (rc < 0 && PL_dowarn)
863 warn("Can't %s \"%s\": %s",
864 (execf == EXECF_SPAWN ? "spawn" : "exec"),
865 shell, Strerror(errno));
866 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
871 } else if (*s == ' ' || *s == '\t') {
876 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
877 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
878 PL_Cmd = savepvn(cmd, s-cmd);
880 for (s = PL_Cmd; *s;) {
881 while (*s && isSPACE(*s)) s++;
884 while (*s && !isSPACE(*s)) s++;
890 rc = do_spawn_ve(NULL, 0, execf, cmd);
903 return do_spawn2(cmd, EXECF_SPAWN);
910 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
917 do_spawn2(cmd, EXECF_EXEC);
925 return do_spawn2(cmd, EXECF_TRUEEXEC);
929 my_syspopen(cmd,mode)
936 register I32 this, that, newfd;
937 register I32 pid, rc;
941 /* `this' is what we use in the parent, `that' in the child. */
942 this = (*mode == 'w');
946 taint_proper("Insecure %s%s", "EXEC");
950 /* Now we need to spawn the child. */
951 newfd = dup(*mode == 'r'); /* Preserve std* */
952 if (p[that] != (*mode == 'r')) {
953 dup2(p[that], *mode == 'r');
956 /* Where is `this' and newfd now? */
957 fcntl(p[this], F_SETFD, FD_CLOEXEC);
958 fcntl(newfd, F_SETFD, FD_CLOEXEC);
959 pid = do_spawn_nowait(cmd);
960 if (newfd != (*mode == 'r')) {
961 dup2(newfd, *mode == 'r'); /* Return std* back. */
964 if (p[that] == (*mode == 'r'))
970 if (p[that] < p[this]) {
971 dup2(p[this], p[that]);
975 sv = *av_fetch(PL_fdpid,p[this],TRUE);
976 (void)SvUPGRADE(sv,SVt_IV);
978 PL_forkprocess = pid;
979 return PerlIO_fdopen(p[this], mode);
981 #else /* USE_POPEN */
987 res = popen(cmd, mode);
989 char *shell = getenv("EMXSHELL");
991 my_setenv("EMXSHELL", PL_sh_path);
992 res = popen(cmd, mode);
993 my_setenv("EMXSHELL", shell);
995 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
996 (void)SvUPGRADE(sv,SVt_IV);
997 SvIVX(sv) = -1; /* A cooky. */
1000 #endif /* USE_POPEN */
1004 /******************************************************************/
1010 die(no_func, "Unsupported function fork");
1016 /*******************************************************************/
1017 /* not implemented in EMX 0.9a */
1019 void * ctermid(x) { return 0; }
1021 #ifdef MYTTYNAME /* was not in emx0.9a */
1022 void * ttyname(x) { return 0; }
1025 /******************************************************************/
1026 /* my socket forwarders - EMX lib only provides static forwarders */
1028 static HMODULE htcp = 0;
1033 static BYTE buf[20];
1036 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1038 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1039 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1040 return (void *) ((void * (*)(void)) fcn) ();
1045 tcp1(char *name, int arg)
1047 static BYTE buf[20];
1050 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1052 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1053 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1054 ((void (*)(int)) fcn) (arg);
1057 void * gethostent() { return tcp0("GETHOSTENT"); }
1058 void * getnetent() { return tcp0("GETNETENT"); }
1059 void * getprotoent() { return tcp0("GETPROTOENT"); }
1060 void * getservent() { return tcp0("GETSERVENT"); }
1061 void sethostent(x) { tcp1("SETHOSTENT", x); }
1062 void setnetent(x) { tcp1("SETNETENT", x); }
1063 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1064 void setservent(x) { tcp1("SETSERVENT", x); }
1065 void endhostent() { tcp0("ENDHOSTENT"); }
1066 void endnetent() { tcp0("ENDNETENT"); }
1067 void endprotoent() { tcp0("ENDPROTOENT"); }
1068 void endservent() { tcp0("ENDSERVENT"); }
1070 /*****************************************************************************/
1071 /* not implemented in C Set++ */
1074 int setuid(x) { errno = EINVAL; return -1; }
1075 int setgid(x) { errno = EINVAL; return -1; }
1078 /*****************************************************************************/
1079 /* stat() hack for char/block device */
1083 /* First attempt used DosQueryFSAttach which crashed the system when
1084 used with 5.001. Now just look for /dev/. */
1087 os2_stat(char *name, struct stat *st)
1089 static int ino = SHRT_MAX;
1091 if (stricmp(name, "/dev/con") != 0
1092 && stricmp(name, "/dev/tty") != 0)
1093 return stat(name, st);
1095 memset(st, 0, sizeof *st);
1096 st->st_mode = S_IFCHR|0666;
1097 st->st_ino = (ino-- & 0x7FFF);
1104 #ifdef USE_PERL_SBRK
1106 /* SBRK() emulation, mostly moved to malloc.c. */
1109 sys_alloc(int size) {
1111 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1113 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1115 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
1119 #endif /* USE_PERL_SBRK */
1123 char *tmppath = TMPPATH1;
1128 char *p = getenv("TMP"), *tpath;
1131 if (!p) p = getenv("TEMP");
1134 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1137 strcpy(tpath + len + 1, TMPPATH1);
1143 XS(XS_File__Copy_syscopy)
1146 if (items < 2 || items > 3)
1147 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1149 char * src = (char *)SvPV(ST(0),PL_na);
1150 char * dst = (char *)SvPV(ST(1),PL_na);
1157 flag = (unsigned long)SvIV(ST(2));
1160 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1161 ST(0) = sv_newmortal();
1162 sv_setiv(ST(0), (IV)RETVAL);
1167 #include "patchlevel.h"
1173 static char fname[9];
1174 int pos = 6, len, avlen;
1175 unsigned int sum = 0;
1180 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1182 if (SvTYPE(sv) != SVt_PVAV)
1183 croak("Not array reference given to mod2fname");
1185 avlen = av_len((AV*)sv);
1187 croak("Empty array reference given to mod2fname");
1189 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1190 strncpy(fname, s, 8);
1192 if (len < 6) pos = len;
1194 sum = 33 * sum + *(s++); /* Checksumming first chars to
1195 * get the capitalization into c.s. */
1198 while (avlen >= 0) {
1199 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1201 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1206 sum++; /* Avoid conflict of DLLs in memory. */
1208 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
1209 fname[pos] = 'A' + (sum % 26);
1210 fname[pos + 1] = 'A' + (sum / 26 % 26);
1211 fname[pos + 2] = '\0';
1212 return (char *)fname;
1215 XS(XS_DynaLoader_mod2fname)
1219 croak("Usage: DynaLoader::mod2fname(sv)");
1224 RETVAL = mod2fname(sv);
1225 ST(0) = sv_newmortal();
1226 sv_setpv((SV*)ST(0), RETVAL);
1234 static char buf[300];
1237 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1240 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1241 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1244 if (len > 0 && buf[len - 1] == '\n')
1245 buf[len - 1] = '\0';
1246 if (len > 1 && buf[len - 2] == '\r')
1247 buf[len - 2] = '\0';
1248 if (len > 2 && buf[len - 3] == '.')
1249 buf[len - 3] = '\0';
1254 perllib_mangle(char *s, unsigned int l)
1256 static char *newp, *oldp;
1257 static int newl, oldl, notfound;
1258 static char ret[STATIC_FILE_LENGTH+1];
1260 if (!newp && !notfound) {
1261 newp = getenv("PERLLIB_PREFIX");
1266 while (*newp && !isSPACE(*newp) && *newp != ';') {
1267 newp++; oldl++; /* Skip digits. */
1269 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1270 newp++; /* Skip whitespace. */
1272 newl = strlen(newp);
1273 if (newl == 0 || oldl == 0) {
1274 die("Malformed PERLLIB_PREFIX");
1279 if (*s == '\\') *s = '/';
1292 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1295 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1296 die("Malformed PERLLIB_PREFIX");
1298 strcpy(ret + newl, s + oldl);
1302 extern void dlopen();
1303 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1305 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1306 && ((path)[2] == '/' || (path)[2] == '\\'))
1307 #define sys_is_rooted _fnisabs
1308 #define sys_is_relative _fnisrel
1309 #define current_drive _getdrive
1311 #undef chdir /* Was _chdir2. */
1312 #define sys_chdir(p) (chdir(p) == 0)
1313 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1315 XS(XS_Cwd_current_drive)
1319 croak("Usage: Cwd::current_drive()");
1323 RETVAL = current_drive();
1324 ST(0) = sv_newmortal();
1325 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1330 XS(XS_Cwd_sys_chdir)
1334 croak("Usage: Cwd::sys_chdir(path)");
1336 char * path = (char *)SvPV(ST(0),PL_na);
1339 RETVAL = sys_chdir(path);
1340 ST(0) = boolSV(RETVAL);
1341 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1346 XS(XS_Cwd_change_drive)
1350 croak("Usage: Cwd::change_drive(d)");
1352 char d = (char)*SvPV(ST(0),PL_na);
1355 RETVAL = change_drive(d);
1356 ST(0) = boolSV(RETVAL);
1357 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1362 XS(XS_Cwd_sys_is_absolute)
1366 croak("Usage: Cwd::sys_is_absolute(path)");
1368 char * path = (char *)SvPV(ST(0),PL_na);
1371 RETVAL = sys_is_absolute(path);
1372 ST(0) = boolSV(RETVAL);
1373 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1378 XS(XS_Cwd_sys_is_rooted)
1382 croak("Usage: Cwd::sys_is_rooted(path)");
1384 char * path = (char *)SvPV(ST(0),PL_na);
1387 RETVAL = sys_is_rooted(path);
1388 ST(0) = boolSV(RETVAL);
1389 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1394 XS(XS_Cwd_sys_is_relative)
1398 croak("Usage: Cwd::sys_is_relative(path)");
1400 char * path = (char *)SvPV(ST(0),PL_na);
1403 RETVAL = sys_is_relative(path);
1404 ST(0) = boolSV(RETVAL);
1405 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1414 croak("Usage: Cwd::sys_cwd()");
1418 RETVAL = _getcwd2(p, MAXPATHLEN);
1419 ST(0) = sv_newmortal();
1420 sv_setpv((SV*)ST(0), RETVAL);
1425 XS(XS_Cwd_sys_abspath)
1428 if (items < 1 || items > 2)
1429 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1431 char * path = (char *)SvPV(ST(0),PL_na);
1439 dir = (char *)SvPV(ST(1),PL_na);
1441 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1445 if (_abspath(p, path, MAXPATHLEN) == 0) {
1451 /* Absolute with drive: */
1452 if ( sys_is_absolute(path) ) {
1453 if (_abspath(p, path, MAXPATHLEN) == 0) {
1458 } else if (path[0] == '/' || path[0] == '\\') {
1459 /* Rooted, but maybe on different drive. */
1460 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1461 char p1[MAXPATHLEN];
1463 /* Need to prepend the drive. */
1466 Copy(path, p1 + 2, strlen(path) + 1, char);
1468 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1473 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1479 /* Either path is relative, or starts with a drive letter. */
1480 /* If the path starts with a drive letter, then dir is
1482 a/b) it is absolute/x:relative on the same drive.
1483 c) path is on current drive, and dir is rooted
1484 In all the cases it is safe to drop the drive part
1486 if ( !sys_is_relative(path) ) {
1489 if ( ( ( sys_is_absolute(dir)
1490 || (isALPHA(dir[0]) && dir[1] == ':'
1491 && strnicmp(dir, path,1) == 0))
1492 && strnicmp(dir, path,1) == 0)
1493 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1494 && toupper(path[0]) == current_drive())) {
1496 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1497 RETVAL = p; goto done;
1499 RETVAL = NULL; goto done;
1503 /* Need to prepend the absolute path of dir. */
1504 char p1[MAXPATHLEN];
1506 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1509 if (p1[ l - 1 ] != '/') {
1513 Copy(path, p1 + l, strlen(path) + 1, char);
1514 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1526 ST(0) = sv_newmortal();
1527 sv_setpv((SV*)ST(0), RETVAL);
1531 typedef APIRET (*PELP)(PSZ path, ULONG type);
1534 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1536 loadByOrd(ord); /* Guarantied to load or die! */
1537 return (*(PELP)ExtFCN[ord])(path, type);
1540 #define extLibpath(type) \
1541 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1542 : BEGIN_LIBPATH))) \
1545 #define extLibpath_set(p,type) \
1546 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1549 XS(XS_Cwd_extLibpath)
1552 if (items < 0 || items > 1)
1553 croak("Usage: Cwd::extLibpath(type = 0)");
1563 type = (int)SvIV(ST(0));
1566 RETVAL = extLibpath(type);
1567 ST(0) = sv_newmortal();
1568 sv_setpv((SV*)ST(0), RETVAL);
1573 XS(XS_Cwd_extLibpath_set)
1576 if (items < 1 || items > 2)
1577 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1579 char * s = (char *)SvPV(ST(0),PL_na);
1587 type = (int)SvIV(ST(1));
1590 RETVAL = extLibpath_set(s, type);
1591 ST(0) = boolSV(RETVAL);
1592 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1600 char *file = __FILE__;
1604 if (_emx_env & 0x200) { /* OS/2 */
1605 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1606 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1607 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1609 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1610 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1611 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1612 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1613 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1614 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1615 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1616 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1617 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1618 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1621 sv_setiv(GvSV(gv), 1);
1626 OS2_Perl_data_t OS2_Perl_data;
1629 Perl_OS2_init(char **env)
1635 OS2_Perl_data.xs_init = &Xs_OS2_init;
1636 if (environ == NULL) {
1639 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1640 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1641 strcpy(PL_sh_path, SH_PATH);
1642 PL_sh_path[0] = shell[0];
1643 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1644 int l = strlen(shell), i;
1645 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1648 New(1304, PL_sh_path, l + 8, char);
1649 strncpy(PL_sh_path, shell, l);
1650 strcpy(PL_sh_path + l, "/sh.exe");
1651 for (i = 0; i < l; i++) {
1652 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1655 MUTEX_INIT(&start_thread_mutex);
1656 os2_mytype = my_type(); /* Do it before morphing. Needed? */
1663 my_tmpnam (char *str)
1665 char *p = getenv("TMP"), *tpath;
1668 if (!p) p = getenv("TEMP");
1669 tpath = tempnam(p, "pltmp");
1683 if (s.st_mode & S_IWOTH) {
1686 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1692 /* This code was contributed by Rocco Caputo. */
1694 my_flock(int handle, int o)
1696 FILELOCK rNull, rFull;
1697 ULONG timeout, handle_type, flag_word;
1699 int blocking, shared;
1700 static int use_my = -1;
1703 char *s = getenv("USE_PERL_FLOCK");
1709 if (!(_emx_env & 0x200) || !use_my)
1710 return flock(handle, o); /* Delegate to EMX. */
1713 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1714 (handle_type & 0xFF))
1719 // set lock/unlock ranges
1720 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1721 rFull.lRange = 0x7FFFFFFF;
1722 // set timeout for blocking
1723 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1724 // shared or exclusive?
1725 shared = (o & LOCK_SH) ? 1 : 0;
1726 // do not block the unlock
1727 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1728 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1733 case ERROR_INVALID_HANDLE:
1736 case ERROR_SHARING_BUFFER_EXCEEDED:
1739 case ERROR_LOCK_VIOLATION:
1740 break; // not an error
1741 case ERROR_INVALID_PARAMETER:
1742 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1743 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1746 case ERROR_INTERRUPT:
1755 if (o & (LOCK_SH | LOCK_EX)) {
1756 // for blocking operations
1770 case ERROR_INVALID_HANDLE:
1773 case ERROR_SHARING_BUFFER_EXCEEDED:
1776 case ERROR_LOCK_VIOLATION:
1778 errno = EWOULDBLOCK;
1782 case ERROR_INVALID_PARAMETER:
1783 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1784 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1787 case ERROR_INTERRUPT:
1794 // give away timeslice