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;
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 FILE *file = fopen(scr, "r");
557 if (!fgets(buf, sizeof buf, file)) { /* Empty... */
562 /* Special case: maybe from -Zexe build, so
563 there is an executable around (contrary to
564 documentation, DosQueryAppType sometimes (?)
565 does not append ".exe", so we could have
566 reached this place). */
567 if (l + 5 < 512) { /* size of buffer in find_script */
568 strcpy(scr + l, ".exe");
569 if (PerlLIO_stat(scr,&PL_statbuf) >= 0
570 && !S_ISDIR(PL_statbuf.st_mode)) {
580 if (fclose(file) != 0) { /* Failure */
582 warn("Error reading \"%s\": %s",
583 scr, Strerror(errno));
584 buf[0] = 0; /* Not #! */
590 } else if (buf[0] == 'e') {
591 if (strnEQ(buf, "extproc", 7)
594 } else if (buf[0] == 'E') {
595 if (strnEQ(buf, "EXTPROC", 7)
600 buf[0] = 0; /* Not #! */
608 /* Do better than pdksh: allow a few args,
609 strip trailing whitespace. */
619 while (*s && !isSPACE(*s))
626 warn("Too many args on %.*s line of \"%s\"",
637 || (!buf[0] && file)) { /* File without magic */
638 /* In fact we tried all what pdksh would
639 try. There is no point in calling
640 pdksh, we may just emulate its logic. */
641 char *shell = getenv("EXECSHELL");
642 char *shell_opt = NULL;
648 shell = getenv("OS2_SHELL");
649 if (inicmd) { /* No spaces at start! */
651 while (*s && !isSPACE(*s)) {
653 inicmd = NULL; /* Cannot use */
661 /* Dosish shells will choke on slashes
662 in paths, fortunately, this is
663 important for zeroth arg only. */
670 /* If EXECSHELL is set, we do not set */
673 shell = ((_emx_env & 0x200)
676 nargs = shell_opt ? 2 : 1; /* shell file args */
677 exec_args[0] = shell;
678 exec_args[1] = shell_opt;
680 if (nargs == 2 && inicmd) {
681 /* Use the original cmd line */
682 /* XXXX This is good only until we refuse
683 quoted arguments... */
687 } else if (!buf[0] && inicmd) { /* No file */
688 /* Start with the original cmdline. */
689 /* XXXX This is good only until we refuse
690 quoted arguments... */
694 nargs = 2; /* shell -c */
697 while (a[1]) /* Get to the end */
699 a++; /* Copy finil NULL too */
700 while (a >= PL_Argv) {
701 *(a + nargs) = *a; /* PL_Argv was preallocated to be
706 PL_Argv[nargs] = argsp[nargs];
707 /* Enable pathless exec if #! (as pdksh). */
708 pass = (buf[0] == '#' ? 2 : 3);
712 /* Not found: restore errno */
716 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
717 char *no_dir = strrchr(PL_Argv[0], '/');
719 /* Do as pdksh port does: if not found with /, try without
722 PL_Argv[0] = no_dir + 1;
727 if (rc < 0 && PL_dowarn)
728 warn("Can't %s \"%s\": %s\n",
729 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
731 PL_Argv[0], Strerror(errno));
732 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
733 && ((trueflag & 0xFF) == P_WAIT))
734 rc = 255 << 8; /* Emulate the fork(). */
741 do_aspawn(really,mark,sp)
750 int flag = P_WAIT, trueflag, err, secondtry = 0;
753 New(1301,PL_Argv, sp - mark + 3, char*);
756 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
761 while (++mark <= sp) {
763 *a++ = SvPVx(*mark, PL_na);
769 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
776 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
778 do_spawn2(cmd, execf)
785 char *shell, *copt, *news = NULL;
786 int rc, err, seenspace = 0;
787 char fullcmd[MAXNAMLEN + 1];
790 if ((shell = getenv("EMXSHELL")) != NULL)
792 else if ((shell = getenv("SHELL")) != NULL)
794 else if ((shell = getenv("COMSPEC")) != NULL)
799 /* Consensus on perl5-porters is that it is _very_ important to
800 have a shell which will not change between computers with the
801 same architecture, to avoid "action on a distance".
802 And to have simple build, this shell should be sh. */
807 while (*cmd && isSPACE(*cmd))
810 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
811 STRLEN l = strlen(PL_sh_path);
813 New(1302, news, strlen(cmd) - 7 + l + 1, char);
814 strcpy(news, PL_sh_path);
815 strcpy(news + l, cmd + 7);
819 /* save an extra exec if possible */
820 /* see if there are shell metacharacters in it */
822 if (*cmd == '.' && isSPACE(cmd[1]))
825 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
828 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
832 for (s = cmd; *s; s++) {
833 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
834 if (*s == '\n' && s[1] == '\0') {
837 } else if (*s == '\\' && !seenspace) {
838 continue; /* Allow backslashes in names */
840 /* We do not convert this to do_spawn_ve since shell
841 should be smart enough to start itself gloriously. */
843 if (execf == EXECF_TRUEEXEC)
844 rc = execl(shell,shell,copt,cmd,(char*)0);
845 else if (execf == EXECF_EXEC)
846 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
847 else if (execf == EXECF_SPAWN_NOWAIT)
848 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
850 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
852 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
853 if (rc < 0 && PL_dowarn)
854 warn("Can't %s \"%s\": %s",
855 (execf == EXECF_SPAWN ? "spawn" : "exec"),
856 shell, Strerror(errno));
857 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
862 } else if (*s == ' ' || *s == '\t') {
867 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
868 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
869 PL_Cmd = savepvn(cmd, s-cmd);
871 for (s = PL_Cmd; *s;) {
872 while (*s && isSPACE(*s)) s++;
875 while (*s && !isSPACE(*s)) s++;
881 rc = do_spawn_ve(NULL, 0, execf, cmd);
894 return do_spawn2(cmd, EXECF_SPAWN);
901 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
908 do_spawn2(cmd, EXECF_EXEC);
916 return do_spawn2(cmd, EXECF_TRUEEXEC);
920 my_syspopen(cmd,mode)
927 register I32 this, that, newfd;
928 register I32 pid, rc;
932 /* `this' is what we use in the parent, `that' in the child. */
933 this = (*mode == 'w');
937 taint_proper("Insecure %s%s", "EXEC");
941 /* Now we need to spawn the child. */
942 newfd = dup(*mode == 'r'); /* Preserve std* */
943 if (p[that] != (*mode == 'r')) {
944 dup2(p[that], *mode == 'r');
947 /* Where is `this' and newfd now? */
948 fcntl(p[this], F_SETFD, FD_CLOEXEC);
949 fcntl(newfd, F_SETFD, FD_CLOEXEC);
950 pid = do_spawn_nowait(cmd);
951 if (newfd != (*mode == 'r')) {
952 dup2(newfd, *mode == 'r'); /* Return std* back. */
955 if (p[that] == (*mode == 'r'))
961 if (p[that] < p[this]) {
962 dup2(p[this], p[that]);
966 sv = *av_fetch(PL_fdpid,p[this],TRUE);
967 (void)SvUPGRADE(sv,SVt_IV);
969 PL_forkprocess = pid;
970 return PerlIO_fdopen(p[this], mode);
972 #else /* USE_POPEN */
978 res = popen(cmd, mode);
980 char *shell = getenv("EMXSHELL");
982 my_setenv("EMXSHELL", PL_sh_path);
983 res = popen(cmd, mode);
984 my_setenv("EMXSHELL", shell);
986 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
987 (void)SvUPGRADE(sv,SVt_IV);
988 SvIVX(sv) = -1; /* A cooky. */
991 #endif /* USE_POPEN */
995 /******************************************************************/
1001 die(no_func, "Unsupported function fork");
1007 /*******************************************************************/
1008 /* not implemented in EMX 0.9a */
1010 void * ctermid(x) { return 0; }
1012 #ifdef MYTTYNAME /* was not in emx0.9a */
1013 void * ttyname(x) { return 0; }
1016 /******************************************************************/
1017 /* my socket forwarders - EMX lib only provides static forwarders */
1019 static HMODULE htcp = 0;
1024 static BYTE buf[20];
1027 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1029 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1030 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1031 return (void *) ((void * (*)(void)) fcn) ();
1036 tcp1(char *name, int arg)
1038 static BYTE buf[20];
1041 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
1043 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
1044 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
1045 ((void (*)(int)) fcn) (arg);
1048 void * gethostent() { return tcp0("GETHOSTENT"); }
1049 void * getnetent() { return tcp0("GETNETENT"); }
1050 void * getprotoent() { return tcp0("GETPROTOENT"); }
1051 void * getservent() { return tcp0("GETSERVENT"); }
1052 void sethostent(x) { tcp1("SETHOSTENT", x); }
1053 void setnetent(x) { tcp1("SETNETENT", x); }
1054 void setprotoent(x) { tcp1("SETPROTOENT", x); }
1055 void setservent(x) { tcp1("SETSERVENT", x); }
1056 void endhostent() { tcp0("ENDHOSTENT"); }
1057 void endnetent() { tcp0("ENDNETENT"); }
1058 void endprotoent() { tcp0("ENDPROTOENT"); }
1059 void endservent() { tcp0("ENDSERVENT"); }
1061 /*****************************************************************************/
1062 /* not implemented in C Set++ */
1065 int setuid(x) { errno = EINVAL; return -1; }
1066 int setgid(x) { errno = EINVAL; return -1; }
1069 /*****************************************************************************/
1070 /* stat() hack for char/block device */
1074 /* First attempt used DosQueryFSAttach which crashed the system when
1075 used with 5.001. Now just look for /dev/. */
1078 os2_stat(char *name, struct stat *st)
1080 static int ino = SHRT_MAX;
1082 if (stricmp(name, "/dev/con") != 0
1083 && stricmp(name, "/dev/tty") != 0)
1084 return stat(name, st);
1086 memset(st, 0, sizeof *st);
1087 st->st_mode = S_IFCHR|0666;
1088 st->st_ino = (ino-- & 0x7FFF);
1095 #ifdef USE_PERL_SBRK
1097 /* SBRK() emulation, mostly moved to malloc.c. */
1100 sys_alloc(int size) {
1102 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
1104 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
1106 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
1110 #endif /* USE_PERL_SBRK */
1114 char *tmppath = TMPPATH1;
1119 char *p = getenv("TMP"), *tpath;
1122 if (!p) p = getenv("TEMP");
1125 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
1128 strcpy(tpath + len + 1, TMPPATH1);
1134 XS(XS_File__Copy_syscopy)
1137 if (items < 2 || items > 3)
1138 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1140 char * src = (char *)SvPV(ST(0),PL_na);
1141 char * dst = (char *)SvPV(ST(1),PL_na);
1148 flag = (unsigned long)SvIV(ST(2));
1151 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1152 ST(0) = sv_newmortal();
1153 sv_setiv(ST(0), (IV)RETVAL);
1158 #include "patchlevel.h"
1164 static char fname[9];
1165 int pos = 6, len, avlen;
1166 unsigned int sum = 0;
1171 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1173 if (SvTYPE(sv) != SVt_PVAV)
1174 croak("Not array reference given to mod2fname");
1176 avlen = av_len((AV*)sv);
1178 croak("Empty array reference given to mod2fname");
1180 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1181 strncpy(fname, s, 8);
1183 if (len < 6) pos = len;
1185 sum = 33 * sum + *(s++); /* Checksumming first chars to
1186 * get the capitalization into c.s. */
1189 while (avlen >= 0) {
1190 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1192 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1197 sum++; /* Avoid conflict of DLLs in memory. */
1199 sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
1200 fname[pos] = 'A' + (sum % 26);
1201 fname[pos + 1] = 'A' + (sum / 26 % 26);
1202 fname[pos + 2] = '\0';
1203 return (char *)fname;
1206 XS(XS_DynaLoader_mod2fname)
1210 croak("Usage: DynaLoader::mod2fname(sv)");
1215 RETVAL = mod2fname(sv);
1216 ST(0) = sv_newmortal();
1217 sv_setpv((SV*)ST(0), RETVAL);
1225 static char buf[300];
1228 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1231 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1232 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1235 if (len > 0 && buf[len - 1] == '\n')
1236 buf[len - 1] = '\0';
1237 if (len > 1 && buf[len - 2] == '\r')
1238 buf[len - 2] = '\0';
1239 if (len > 2 && buf[len - 3] == '.')
1240 buf[len - 3] = '\0';
1245 perllib_mangle(char *s, unsigned int l)
1247 static char *newp, *oldp;
1248 static int newl, oldl, notfound;
1249 static char ret[STATIC_FILE_LENGTH+1];
1251 if (!newp && !notfound) {
1252 newp = getenv("PERLLIB_PREFIX");
1257 while (*newp && !isSPACE(*newp) && *newp != ';') {
1258 newp++; oldl++; /* Skip digits. */
1260 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1261 newp++; /* Skip whitespace. */
1263 newl = strlen(newp);
1264 if (newl == 0 || oldl == 0) {
1265 die("Malformed PERLLIB_PREFIX");
1270 if (*s == '\\') *s = '/';
1283 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1286 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1287 die("Malformed PERLLIB_PREFIX");
1289 strcpy(ret + newl, s + oldl);
1293 extern void dlopen();
1294 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1296 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1297 && ((path)[2] == '/' || (path)[2] == '\\'))
1298 #define sys_is_rooted _fnisabs
1299 #define sys_is_relative _fnisrel
1300 #define current_drive _getdrive
1302 #undef chdir /* Was _chdir2. */
1303 #define sys_chdir(p) (chdir(p) == 0)
1304 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1306 XS(XS_Cwd_current_drive)
1310 croak("Usage: Cwd::current_drive()");
1314 RETVAL = current_drive();
1315 ST(0) = sv_newmortal();
1316 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1321 XS(XS_Cwd_sys_chdir)
1325 croak("Usage: Cwd::sys_chdir(path)");
1327 char * path = (char *)SvPV(ST(0),PL_na);
1330 RETVAL = sys_chdir(path);
1331 ST(0) = boolSV(RETVAL);
1332 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1337 XS(XS_Cwd_change_drive)
1341 croak("Usage: Cwd::change_drive(d)");
1343 char d = (char)*SvPV(ST(0),PL_na);
1346 RETVAL = change_drive(d);
1347 ST(0) = boolSV(RETVAL);
1348 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1353 XS(XS_Cwd_sys_is_absolute)
1357 croak("Usage: Cwd::sys_is_absolute(path)");
1359 char * path = (char *)SvPV(ST(0),PL_na);
1362 RETVAL = sys_is_absolute(path);
1363 ST(0) = boolSV(RETVAL);
1364 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1369 XS(XS_Cwd_sys_is_rooted)
1373 croak("Usage: Cwd::sys_is_rooted(path)");
1375 char * path = (char *)SvPV(ST(0),PL_na);
1378 RETVAL = sys_is_rooted(path);
1379 ST(0) = boolSV(RETVAL);
1380 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1385 XS(XS_Cwd_sys_is_relative)
1389 croak("Usage: Cwd::sys_is_relative(path)");
1391 char * path = (char *)SvPV(ST(0),PL_na);
1394 RETVAL = sys_is_relative(path);
1395 ST(0) = boolSV(RETVAL);
1396 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1405 croak("Usage: Cwd::sys_cwd()");
1409 RETVAL = _getcwd2(p, MAXPATHLEN);
1410 ST(0) = sv_newmortal();
1411 sv_setpv((SV*)ST(0), RETVAL);
1416 XS(XS_Cwd_sys_abspath)
1419 if (items < 1 || items > 2)
1420 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1422 char * path = (char *)SvPV(ST(0),PL_na);
1430 dir = (char *)SvPV(ST(1),PL_na);
1432 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1436 if (_abspath(p, path, MAXPATHLEN) == 0) {
1442 /* Absolute with drive: */
1443 if ( sys_is_absolute(path) ) {
1444 if (_abspath(p, path, MAXPATHLEN) == 0) {
1449 } else if (path[0] == '/' || path[0] == '\\') {
1450 /* Rooted, but maybe on different drive. */
1451 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1452 char p1[MAXPATHLEN];
1454 /* Need to prepend the drive. */
1457 Copy(path, p1 + 2, strlen(path) + 1, char);
1459 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1464 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1470 /* Either path is relative, or starts with a drive letter. */
1471 /* If the path starts with a drive letter, then dir is
1473 a/b) it is absolute/x:relative on the same drive.
1474 c) path is on current drive, and dir is rooted
1475 In all the cases it is safe to drop the drive part
1477 if ( !sys_is_relative(path) ) {
1480 if ( ( ( sys_is_absolute(dir)
1481 || (isALPHA(dir[0]) && dir[1] == ':'
1482 && strnicmp(dir, path,1) == 0))
1483 && strnicmp(dir, path,1) == 0)
1484 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1485 && toupper(path[0]) == current_drive())) {
1487 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1488 RETVAL = p; goto done;
1490 RETVAL = NULL; goto done;
1494 /* Need to prepend the absolute path of dir. */
1495 char p1[MAXPATHLEN];
1497 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1500 if (p1[ l - 1 ] != '/') {
1504 Copy(path, p1 + l, strlen(path) + 1, char);
1505 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1517 ST(0) = sv_newmortal();
1518 sv_setpv((SV*)ST(0), RETVAL);
1522 typedef APIRET (*PELP)(PSZ path, ULONG type);
1525 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1527 loadByOrd(ord); /* Guarantied to load or die! */
1528 return (*(PELP)ExtFCN[ord])(path, type);
1531 #define extLibpath(type) \
1532 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1533 : BEGIN_LIBPATH))) \
1536 #define extLibpath_set(p,type) \
1537 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1540 XS(XS_Cwd_extLibpath)
1543 if (items < 0 || items > 1)
1544 croak("Usage: Cwd::extLibpath(type = 0)");
1554 type = (int)SvIV(ST(0));
1557 RETVAL = extLibpath(type);
1558 ST(0) = sv_newmortal();
1559 sv_setpv((SV*)ST(0), RETVAL);
1564 XS(XS_Cwd_extLibpath_set)
1567 if (items < 1 || items > 2)
1568 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1570 char * s = (char *)SvPV(ST(0),PL_na);
1578 type = (int)SvIV(ST(1));
1581 RETVAL = extLibpath_set(s, type);
1582 ST(0) = boolSV(RETVAL);
1583 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1591 char *file = __FILE__;
1595 if (_emx_env & 0x200) { /* OS/2 */
1596 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1597 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1598 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1600 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1601 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1602 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1603 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1604 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1605 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1606 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1607 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1608 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1609 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1612 sv_setiv(GvSV(gv), 1);
1617 OS2_Perl_data_t OS2_Perl_data;
1620 Perl_OS2_init(char **env)
1626 OS2_Perl_data.xs_init = &Xs_OS2_init;
1627 if (environ == NULL) {
1630 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1631 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1632 strcpy(PL_sh_path, SH_PATH);
1633 PL_sh_path[0] = shell[0];
1634 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1635 int l = strlen(shell), i;
1636 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1639 New(1304, PL_sh_path, l + 8, char);
1640 strncpy(PL_sh_path, shell, l);
1641 strcpy(PL_sh_path + l, "/sh.exe");
1642 for (i = 0; i < l; i++) {
1643 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1646 MUTEX_INIT(&start_thread_mutex);
1647 os2_mytype = my_type(); /* Do it before morphing. Needed? */
1654 my_tmpnam (char *str)
1656 char *p = getenv("TMP"), *tpath;
1659 if (!p) p = getenv("TEMP");
1660 tpath = tempnam(p, "pltmp");
1674 if (s.st_mode & S_IWOTH) {
1677 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1683 /* This code was contributed by Rocco Caputo. */
1685 my_flock(int handle, int o)
1687 FILELOCK rNull, rFull;
1688 ULONG timeout, handle_type, flag_word;
1690 int blocking, shared;
1691 static int use_my = -1;
1694 char *s = getenv("USE_PERL_FLOCK");
1700 if (!(_emx_env & 0x200) || !use_my)
1701 return flock(handle, o); /* Delegate to EMX. */
1704 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1705 (handle_type & 0xFF))
1710 // set lock/unlock ranges
1711 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1712 rFull.lRange = 0x7FFFFFFF;
1713 // set timeout for blocking
1714 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1715 // shared or exclusive?
1716 shared = (o & LOCK_SH) ? 1 : 0;
1717 // do not block the unlock
1718 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1719 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1724 case ERROR_INVALID_HANDLE:
1727 case ERROR_SHARING_BUFFER_EXCEEDED:
1730 case ERROR_LOCK_VIOLATION:
1731 break; // not an error
1732 case ERROR_INVALID_PARAMETER:
1733 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1734 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1737 case ERROR_INTERRUPT:
1746 if (o & (LOCK_SH | LOCK_EX)) {
1747 // for blocking operations
1761 case ERROR_INVALID_HANDLE:
1764 case ERROR_SHARING_BUFFER_EXCEEDED:
1767 case ERROR_LOCK_VIOLATION:
1769 errno = EWOULDBLOCK;
1773 case ERROR_INVALID_PARAMETER:
1774 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1775 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1778 case ERROR_INTERRUPT:
1785 // give away timeslice