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 pthread_mutex_t start_thread_mutex;
52 pthread_join(pthread_t 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(pthread_t *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(pthread_t 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(pthread_cond_t *c, pthread_mutex_t *m)
163 if ((rc = DosResetEventSem(*c,&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 croak("panic: COND_WAIT: rc=%i", rc);
168 if (m) MUTEX_LOCK(m);
172 /*****************************************************************************/
173 /* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
174 static PFN ExtFCN[2]; /* Labeled by ord below. */
175 static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
176 #define ORD_QUERY_ELP 0
177 #define ORD_SET_ELP 1
182 if (ExtFCN[ord] == NULL) {
183 static HMODULE hdosc = 0;
188 if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
189 "doscalls", &hdosc)))
190 || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
191 die("This version of OS/2 does not support doscalls.%i",
195 if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
199 static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
201 #define QSS_INI_BUFFER 1024
204 get_sysinfo(ULONG pid, ULONG flags)
207 ULONG rc, buf_len = QSS_INI_BUFFER;
209 New(1322, pbuffer, buf_len, char);
210 /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
211 rc = QuerySysState(flags, pid, pbuffer, buf_len);
212 while (rc == ERROR_BUFFER_OVERFLOW) {
213 Renew(pbuffer, buf_len *= 2, char);
214 rc = QuerySysState(flags, pid, pbuffer, buf_len);
221 return (PQTOPLEVEL)pbuffer;
224 #define PRIO_ERR 0x1111
232 psi = get_sysinfo(pid, QSS_PROCESS);
236 if (pid != psi->procdata->pid) {
238 croak("panic: wrong pid in sysinfo");
240 prio = psi->procdata->threads->priority;
246 setpriority(int which, int pid, int val)
251 prio = sys_prio(pid);
253 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
254 if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
255 /* Do not change class. */
256 return CheckOSError(DosSetPriority((pid < 0)
257 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
259 (32 - val) % 32 - (prio & 0xFF),
262 } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
263 /* Documentation claims one can change both class and basevalue,
264 * but I find it wrong. */
265 /* Change class, but since delta == 0 denotes absolute 0, correct. */
266 if (CheckOSError(DosSetPriority((pid < 0)
267 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
268 priors[(32 - val) >> 5] + 1,
272 if ( ((32 - val) % 32) == 0 ) return 0;
273 return CheckOSError(DosSetPriority((pid < 0)
274 ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
280 /* else return CheckOSError(DosSetPriority((pid < 0) */
281 /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
282 /* priors[(32 - val) >> 5] + 1, */
283 /* (32 - val) % 32 - (prio & 0xFF), */
289 getpriority(int which /* ignored */, int pid)
295 if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
296 /* DosGetInfoBlocks has old priority! */
297 /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
298 /* if (pid != pib->pib_ulpid) { */
300 if (ret == PRIO_ERR) {
304 /* ret = tib->tib_ptib2->tib2_ulpri; */
305 return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
308 /*****************************************************************************/
310 typedef void (*Sigfunc) _((int));
313 result(int flag, int pid)
316 Signal_t (*ihand)(); /* place to save signal during system() */
317 Signal_t (*qhand)(); /* place to save signal during system() */
323 if (pid < 0 || flag != 0)
327 ihand = rsignal(SIGINT, SIG_IGN);
328 qhand = rsignal(SIGQUIT, SIG_IGN);
330 r = wait4pid(pid, &status, 0);
331 } while (r == -1 && errno == EINTR);
332 rsignal(SIGINT, ihand);
333 rsignal(SIGQUIT, qhand);
335 statusvalue = (U16)status;
338 return status & 0xFFFF;
340 ihand = rsignal(SIGINT, SIG_IGN);
341 r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
342 rsignal(SIGINT, ihand);
343 statusvalue = res.codeResult << 8 | res.codeTerminate;
350 #define EXECF_SPAWN 0
352 #define EXECF_TRUEEXEC 2
353 #define EXECF_SPAWN_NOWAIT 3
355 /* Spawn/exec a program, revert to shell if needed. */
356 /* global Argv[] contains arguments. */
359 do_aspawn(really, flag, execf)
366 int rc, secondtry = 0, err;
368 char buf[256], *s = 0;
370 static char * fargs[4]
371 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
372 char **argsp = fargs;
379 if (strEQ(Argv[0],"/bin/sh"))
382 if (Argv[0][0] != '/' && Argv[0][0] != '\\'
383 && !(Argv[0][0] && Argv[0][1] == ':'
384 && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
385 ) /* will swawnvp use PATH? */
386 TAINT_ENV(); /* testing IFS here is overkill, probably */
387 /* We should check PERL_SH* and PERLLIB_* as well? */
388 if (!really || !*(tmps = SvPV(really, na)))
391 rc = result(trueflag, spawnvp(flag,tmps,Argv));
393 if (execf == EXECF_TRUEEXEC)
394 rc = execvp(tmps,Argv);
395 else if (execf == EXECF_EXEC)
396 rc = spawnvp(trueflag | P_OVERLAY,tmps,Argv);
397 else if (execf == EXECF_SPAWN_NOWAIT)
398 rc = spawnvp(trueflag | P_NOWAIT,tmps,Argv);
399 else /* EXECF_SPAWN */
400 rc = result(trueflag,
401 spawnvp(trueflag | P_NOWAIT,tmps,Argv));
403 if (rc < 0 && secondtry == 0
404 && (tmps == Argv[0])) { /* Cannot transfer `really' via shell. */
406 if (err == ENOENT) { /* No such file. */
407 /* One reason may be that EMX added .exe. We suppose
408 that .exe-less files are automatically shellable.
409 It might have also been .cmd file without
412 (no_dir = strrchr(Argv[0], '/'))
413 || (no_dir = strrchr(Argv[0], '\\'))
414 || (no_dir = Argv[0]);
415 if (!strchr(no_dir, '.')) {
417 if (stat(Argv[0], &buffer) != -1) { /* File exists. */
418 /* Maybe we need to specify the full name here? */
421 /* Try adding script extensions to the file name */
423 if ((scr = find_script(Argv[0], TRUE, NULL, 0))) {
424 FILE *file = fopen(scr, "r");
430 if (!fgets(buf, sizeof buf, file)) {
434 if (fclose(file) != 0) { /* Failure */
436 warn("Error reading \"%s\": %s",
437 scr, Strerror(errno));
443 } else if (buf[0] == 'e') {
444 if (strnEQ(buf, "extproc", 7)
447 } else if (buf[0] == 'E') {
448 if (strnEQ(buf, "EXTPROC", 7)
467 while (*s && !isSPACE(*s))
474 warn("Too many args on %.*s line of \"%s\"",
485 } else if (err == ENOEXEC) { /* Need to send to shell. */
490 while (a[1]) /* Get to the end */
493 *(a + nargs) = *a; /* Argv was preallocated to be
498 Argv[nargs] = argsp[nargs];
504 if (rc < 0 && dowarn)
505 warn("Can't %s \"%s\": %s\n",
506 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
508 Argv[0], Strerror(err));
509 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
510 && ((trueflag & 0xFF) == P_WAIT))
511 rc = 255 << 8; /* Emulate the fork(). */
517 do_aspawn(really,mark,sp)
526 int flag = P_WAIT, trueflag, err, secondtry = 0;
529 New(1301,Argv, sp - mark + 3, char*);
532 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
537 while (++mark <= sp) {
539 *a++ = SvPVx(*mark, na);
545 rc = do_spawn_ve(really, flag, EXECF_SPAWN);
552 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
554 do_spawn2(cmd, execf)
561 char *shell, *copt, *news = NULL;
562 int rc, added_shell = 0, err, seenspace = 0;
563 char fullcmd[MAXNAMLEN + 1];
566 if ((shell = getenv("EMXSHELL")) != NULL)
568 else if ((shell = getenv("SHELL")) != NULL)
570 else if ((shell = getenv("COMSPEC")) != NULL)
575 /* Consensus on perl5-porters is that it is _very_ important to
576 have a shell which will not change between computers with the
577 same architecture, to avoid "action on a distance".
578 And to have simple build, this shell should be sh. */
583 while (*cmd && isSPACE(*cmd))
586 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
587 STRLEN l = strlen(sh_path);
589 New(1302, news, strlen(cmd) - 7 + l + 1, char);
590 strcpy(news, sh_path);
591 strcpy(news + l, cmd + 7);
596 /* save an extra exec if possible */
597 /* see if there are shell metacharacters in it */
599 if (*cmd == '.' && isSPACE(cmd[1]))
602 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
605 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
609 for (s = cmd; *s; s++) {
610 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
611 if (*s == '\n' && s[1] == '\0') {
614 } else if (*s == '\\' && !seenspace) {
615 continue; /* Allow backslashes in names */
617 /* We do not convert this to do_spawn_ve since shell
618 should be smart enough to start itself gloriously. */
620 if (execf == EXECF_TRUEEXEC)
621 return execl(shell,shell,copt,cmd,(char*)0);
622 else if (execf == EXECF_EXEC)
623 return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
624 else if (execf == EXECF_SPAWN_NOWAIT)
625 return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
626 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
628 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
629 if (rc < 0 && dowarn)
630 warn("Can't %s \"%s\": %s",
631 (execf == EXECF_SPAWN ? "spawn" : "exec"),
632 shell, Strerror(errno));
633 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
634 if (news) Safefree(news);
636 } else if (*s == ' ' || *s == '\t') {
641 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
642 New(1303,Argv, (s - cmd + 11) / 2, char*);
643 Cmd = savepvn(cmd, s-cmd);
646 while (*s && isSPACE(*s)) s++;
649 while (*s && !isSPACE(*s)) s++;
655 rc = do_spawn_ve(NULL, 0, execf);
658 if (news) Safefree(news);
667 return do_spawn2(cmd, EXECF_SPAWN);
674 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
681 return do_spawn2(cmd, EXECF_EXEC);
688 return do_spawn2(cmd, EXECF_TRUEEXEC);
692 my_syspopen(cmd,mode)
699 register I32 this, that, newfd;
700 register I32 pid, rc;
704 /* `this' is what we use in the parent, `that' in the child. */
705 this = (*mode == 'w');
709 taint_proper("Insecure %s%s", "EXEC");
713 /* Now we need to spawn the child. */
714 newfd = dup(*mode == 'r'); /* Preserve std* */
715 if (p[that] != (*mode == 'r')) {
716 dup2(p[that], *mode == 'r');
719 /* Where is `this' and newfd now? */
720 fcntl(p[this], F_SETFD, FD_CLOEXEC);
721 fcntl(newfd, F_SETFD, FD_CLOEXEC);
722 pid = do_spawn_nowait(cmd);
723 if (newfd != (*mode == 'r')) {
724 dup2(newfd, *mode == 'r'); /* Return std* back. */
727 if (p[that] == (*mode == 'r'))
733 if (p[that] < p[this]) {
734 dup2(p[this], p[that]);
738 sv = *av_fetch(fdpid,p[this],TRUE);
739 (void)SvUPGRADE(sv,SVt_IV);
742 return PerlIO_fdopen(p[this], mode);
744 #else /* USE_POPEN */
750 res = popen(cmd, mode);
752 char *shell = getenv("EMXSHELL");
754 my_setenv("EMXSHELL", sh_path);
755 res = popen(cmd, mode);
756 my_setenv("EMXSHELL", shell);
758 sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
759 (void)SvUPGRADE(sv,SVt_IV);
760 SvIVX(sv) = -1; /* A cooky. */
763 #endif /* USE_POPEN */
767 /******************************************************************/
773 die(no_func, "Unsupported function fork");
779 /*******************************************************************/
780 /* not implemented in EMX 0.9a */
782 void * ctermid(x) { return 0; }
784 #ifdef MYTTYNAME /* was not in emx0.9a */
785 void * ttyname(x) { return 0; }
788 /******************************************************************/
789 /* my socket forwarders - EMX lib only provides static forwarders */
791 static HMODULE htcp = 0;
799 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
801 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
802 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
803 return (void *) ((void * (*)(void)) fcn) ();
808 tcp1(char *name, int arg)
813 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
815 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
816 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
817 ((void (*)(int)) fcn) (arg);
820 void * gethostent() { return tcp0("GETHOSTENT"); }
821 void * getnetent() { return tcp0("GETNETENT"); }
822 void * getprotoent() { return tcp0("GETPROTOENT"); }
823 void * getservent() { return tcp0("GETSERVENT"); }
824 void sethostent(x) { tcp1("SETHOSTENT", x); }
825 void setnetent(x) { tcp1("SETNETENT", x); }
826 void setprotoent(x) { tcp1("SETPROTOENT", x); }
827 void setservent(x) { tcp1("SETSERVENT", x); }
828 void endhostent() { tcp0("ENDHOSTENT"); }
829 void endnetent() { tcp0("ENDNETENT"); }
830 void endprotoent() { tcp0("ENDPROTOENT"); }
831 void endservent() { tcp0("ENDSERVENT"); }
833 /*****************************************************************************/
834 /* not implemented in C Set++ */
837 int setuid(x) { errno = EINVAL; return -1; }
838 int setgid(x) { errno = EINVAL; return -1; }
841 /*****************************************************************************/
842 /* stat() hack for char/block device */
846 /* First attempt used DosQueryFSAttach which crashed the system when
847 used with 5.001. Now just look for /dev/. */
850 os2_stat(char *name, struct stat *st)
852 static int ino = SHRT_MAX;
854 if (stricmp(name, "/dev/con") != 0
855 && stricmp(name, "/dev/tty") != 0)
856 return stat(name, st);
858 memset(st, 0, sizeof *st);
859 st->st_mode = S_IFCHR|0666;
860 st->st_ino = (ino-- & 0x7FFF);
869 /* SBRK() emulation, mostly moved to malloc.c. */
872 sys_alloc(int size) {
874 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
876 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
878 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
882 #endif /* USE_PERL_SBRK */
886 char *tmppath = TMPPATH1;
891 char *p = getenv("TMP"), *tpath;
894 if (!p) p = getenv("TEMP");
897 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
900 strcpy(tpath + len + 1, TMPPATH1);
906 XS(XS_File__Copy_syscopy)
909 if (items < 2 || items > 3)
910 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
912 char * src = (char *)SvPV(ST(0),na);
913 char * dst = (char *)SvPV(ST(1),na);
920 flag = (unsigned long)SvIV(ST(2));
923 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
924 ST(0) = sv_newmortal();
925 sv_setiv(ST(0), (IV)RETVAL);
934 static char fname[9];
935 int pos = 6, len, avlen;
936 unsigned int sum = 0;
941 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
943 if (SvTYPE(sv) != SVt_PVAV)
944 croak("Not array reference given to mod2fname");
946 avlen = av_len((AV*)sv);
948 croak("Empty array reference given to mod2fname");
950 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
951 strncpy(fname, s, 8);
953 if (len < 6) pos = len;
955 sum = 33 * sum + *(s++); /* Checksumming first chars to
956 * get the capitalization into c.s. */
960 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
962 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
966 fname[pos] = 'A' + (sum % 26);
967 fname[pos + 1] = 'A' + (sum / 26 % 26);
968 fname[pos + 2] = '\0';
969 return (char *)fname;
972 XS(XS_DynaLoader_mod2fname)
976 croak("Usage: DynaLoader::mod2fname(sv)");
981 RETVAL = mod2fname(sv);
982 ST(0) = sv_newmortal();
983 sv_setpv((SV*)ST(0), RETVAL);
991 static char buf[300];
994 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
997 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
998 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1005 perllib_mangle(char *s, unsigned int l)
1007 static char *newp, *oldp;
1008 static int newl, oldl, notfound;
1009 static char ret[STATIC_FILE_LENGTH+1];
1011 if (!newp && !notfound) {
1012 newp = getenv("PERLLIB_PREFIX");
1017 while (*newp && !isSPACE(*newp) && *newp != ';') {
1018 newp++; oldl++; /* Skip digits. */
1020 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1021 newp++; /* Skip whitespace. */
1023 newl = strlen(newp);
1024 if (newl == 0 || oldl == 0) {
1025 die("Malformed PERLLIB_PREFIX");
1030 if (*s == '\\') *s = '/';
1043 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1046 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1047 die("Malformed PERLLIB_PREFIX");
1049 strcpy(ret + newl, s + oldl);
1053 extern void dlopen();
1054 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1056 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1057 && ((path)[2] == '/' || (path)[2] == '\\'))
1058 #define sys_is_rooted _fnisabs
1059 #define sys_is_relative _fnisrel
1060 #define current_drive _getdrive
1062 #undef chdir /* Was _chdir2. */
1063 #define sys_chdir(p) (chdir(p) == 0)
1064 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1066 XS(XS_Cwd_current_drive)
1070 croak("Usage: Cwd::current_drive()");
1074 RETVAL = current_drive();
1075 ST(0) = sv_newmortal();
1076 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1081 XS(XS_Cwd_sys_chdir)
1085 croak("Usage: Cwd::sys_chdir(path)");
1087 char * path = (char *)SvPV(ST(0),na);
1090 RETVAL = sys_chdir(path);
1091 ST(0) = boolSV(RETVAL);
1092 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1097 XS(XS_Cwd_change_drive)
1101 croak("Usage: Cwd::change_drive(d)");
1103 char d = (char)*SvPV(ST(0),na);
1106 RETVAL = change_drive(d);
1107 ST(0) = boolSV(RETVAL);
1108 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1113 XS(XS_Cwd_sys_is_absolute)
1117 croak("Usage: Cwd::sys_is_absolute(path)");
1119 char * path = (char *)SvPV(ST(0),na);
1122 RETVAL = sys_is_absolute(path);
1123 ST(0) = boolSV(RETVAL);
1124 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1129 XS(XS_Cwd_sys_is_rooted)
1133 croak("Usage: Cwd::sys_is_rooted(path)");
1135 char * path = (char *)SvPV(ST(0),na);
1138 RETVAL = sys_is_rooted(path);
1139 ST(0) = boolSV(RETVAL);
1140 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1145 XS(XS_Cwd_sys_is_relative)
1149 croak("Usage: Cwd::sys_is_relative(path)");
1151 char * path = (char *)SvPV(ST(0),na);
1154 RETVAL = sys_is_relative(path);
1155 ST(0) = boolSV(RETVAL);
1156 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1165 croak("Usage: Cwd::sys_cwd()");
1169 RETVAL = _getcwd2(p, MAXPATHLEN);
1170 ST(0) = sv_newmortal();
1171 sv_setpv((SV*)ST(0), RETVAL);
1176 XS(XS_Cwd_sys_abspath)
1179 if (items < 1 || items > 2)
1180 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1182 char * path = (char *)SvPV(ST(0),na);
1190 dir = (char *)SvPV(ST(1),na);
1192 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1196 if (_abspath(p, path, MAXPATHLEN) == 0) {
1202 /* Absolute with drive: */
1203 if ( sys_is_absolute(path) ) {
1204 if (_abspath(p, path, MAXPATHLEN) == 0) {
1209 } else if (path[0] == '/' || path[0] == '\\') {
1210 /* Rooted, but maybe on different drive. */
1211 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1212 char p1[MAXPATHLEN];
1214 /* Need to prepend the drive. */
1217 Copy(path, p1 + 2, strlen(path) + 1, char);
1219 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1224 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1230 /* Either path is relative, or starts with a drive letter. */
1231 /* If the path starts with a drive letter, then dir is
1233 a/b) it is absolute/x:relative on the same drive.
1234 c) path is on current drive, and dir is rooted
1235 In all the cases it is safe to drop the drive part
1237 if ( !sys_is_relative(path) ) {
1240 if ( ( ( sys_is_absolute(dir)
1241 || (isALPHA(dir[0]) && dir[1] == ':'
1242 && strnicmp(dir, path,1) == 0))
1243 && strnicmp(dir, path,1) == 0)
1244 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1245 && toupper(path[0]) == current_drive())) {
1247 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1248 RETVAL = p; goto done;
1250 RETVAL = NULL; goto done;
1254 /* Need to prepend the absolute path of dir. */
1255 char p1[MAXPATHLEN];
1257 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1260 if (p1[ l - 1 ] != '/') {
1264 Copy(path, p1 + l, strlen(path) + 1, char);
1265 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1277 ST(0) = sv_newmortal();
1278 sv_setpv((SV*)ST(0), RETVAL);
1282 typedef APIRET (*PELP)(PSZ path, ULONG type);
1285 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1287 loadByOrd(ord); /* Guarantied to load or die! */
1288 return (*(PELP)ExtFCN[ord])(path, type);
1291 #define extLibpath(type) \
1292 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1293 : BEGIN_LIBPATH))) \
1296 #define extLibpath_set(p,type) \
1297 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1300 XS(XS_Cwd_extLibpath)
1303 if (items < 0 || items > 1)
1304 croak("Usage: Cwd::extLibpath(type = 0)");
1314 type = (int)SvIV(ST(0));
1317 RETVAL = extLibpath(type);
1318 ST(0) = sv_newmortal();
1319 sv_setpv((SV*)ST(0), RETVAL);
1324 XS(XS_Cwd_extLibpath_set)
1327 if (items < 1 || items > 2)
1328 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1330 char * s = (char *)SvPV(ST(0),na);
1338 type = (int)SvIV(ST(1));
1341 RETVAL = extLibpath_set(s, type);
1342 ST(0) = boolSV(RETVAL);
1343 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1351 char *file = __FILE__;
1355 if (_emx_env & 0x200) { /* OS/2 */
1356 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1357 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1358 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1360 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1361 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1362 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1363 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1364 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1365 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1366 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1367 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1368 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1369 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1372 sv_setiv(GvSV(gv), 1);
1377 OS2_Perl_data_t OS2_Perl_data;
1380 Perl_OS2_init(char **env)
1386 OS2_Perl_data.xs_init = &Xs_OS2_init;
1387 if (environ == NULL) {
1390 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1391 New(1304, sh_path, strlen(SH_PATH) + 1, char);
1392 strcpy(sh_path, SH_PATH);
1393 sh_path[0] = shell[0];
1394 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1395 int l = strlen(shell), i;
1396 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1399 New(1304, sh_path, l + 8, char);
1400 strncpy(sh_path, shell, l);
1401 strcpy(sh_path + l, "/sh.exe");
1402 for (i = 0; i < l; i++) {
1403 if (sh_path[i] == '\\') sh_path[i] = '/';
1406 MUTEX_INIT(&start_thread_mutex);
1413 my_tmpnam (char *str)
1415 char *p = getenv("TMP"), *tpath;
1418 if (!p) p = getenv("TEMP");
1419 tpath = tempnam(p, "pltmp");
1433 if (s.st_mode & S_IWOTH) {
1436 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1442 /* This code was contributed by Rocco Caputo. */
1444 my_flock(int handle, int o)
1446 FILELOCK rNull, rFull;
1447 ULONG timeout, handle_type, flag_word;
1449 int blocking, shared;
1450 static int use_my = -1;
1453 char *s = getenv("USE_PERL_FLOCK");
1459 if (!(_emx_env & 0x200) || !use_my)
1460 return flock(handle, o); /* Delegate to EMX. */
1463 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1464 (handle_type & 0xFF))
1469 // set lock/unlock ranges
1470 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1471 rFull.lRange = 0x7FFFFFFF;
1472 // set timeout for blocking
1473 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1474 // shared or exclusive?
1475 shared = (o & LOCK_SH) ? 1 : 0;
1476 // do not block the unlock
1477 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1478 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1483 case ERROR_INVALID_HANDLE:
1486 case ERROR_SHARING_BUFFER_EXCEEDED:
1489 case ERROR_LOCK_VIOLATION:
1490 break; // not an error
1491 case ERROR_INVALID_PARAMETER:
1492 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1493 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1496 case ERROR_INTERRUPT:
1505 if (o & (LOCK_SH | LOCK_EX)) {
1506 // for blocking operations
1520 case ERROR_INVALID_HANDLE:
1523 case ERROR_SHARING_BUFFER_EXCEEDED:
1526 case ERROR_LOCK_VIOLATION:
1528 errno = EWOULDBLOCK;
1532 case ERROR_INVALID_PARAMETER:
1533 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1534 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1537 case ERROR_INTERRUPT:
1544 // give away timeslice