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,&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. */
967 sum++; /* Avoid conflict of DLLs in memory. */
969 fname[pos] = 'A' + (sum % 26);
970 fname[pos + 1] = 'A' + (sum / 26 % 26);
971 fname[pos + 2] = '\0';
972 return (char *)fname;
975 XS(XS_DynaLoader_mod2fname)
979 croak("Usage: DynaLoader::mod2fname(sv)");
984 RETVAL = mod2fname(sv);
985 ST(0) = sv_newmortal();
986 sv_setpv((SV*)ST(0), RETVAL);
994 static char buf[300];
997 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1000 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1001 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1008 perllib_mangle(char *s, unsigned int l)
1010 static char *newp, *oldp;
1011 static int newl, oldl, notfound;
1012 static char ret[STATIC_FILE_LENGTH+1];
1014 if (!newp && !notfound) {
1015 newp = getenv("PERLLIB_PREFIX");
1020 while (*newp && !isSPACE(*newp) && *newp != ';') {
1021 newp++; oldl++; /* Skip digits. */
1023 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1024 newp++; /* Skip whitespace. */
1026 newl = strlen(newp);
1027 if (newl == 0 || oldl == 0) {
1028 die("Malformed PERLLIB_PREFIX");
1033 if (*s == '\\') *s = '/';
1046 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1049 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1050 die("Malformed PERLLIB_PREFIX");
1052 strcpy(ret + newl, s + oldl);
1056 extern void dlopen();
1057 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1059 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1060 && ((path)[2] == '/' || (path)[2] == '\\'))
1061 #define sys_is_rooted _fnisabs
1062 #define sys_is_relative _fnisrel
1063 #define current_drive _getdrive
1065 #undef chdir /* Was _chdir2. */
1066 #define sys_chdir(p) (chdir(p) == 0)
1067 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1069 XS(XS_Cwd_current_drive)
1073 croak("Usage: Cwd::current_drive()");
1077 RETVAL = current_drive();
1078 ST(0) = sv_newmortal();
1079 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1084 XS(XS_Cwd_sys_chdir)
1088 croak("Usage: Cwd::sys_chdir(path)");
1090 char * path = (char *)SvPV(ST(0),na);
1093 RETVAL = sys_chdir(path);
1094 ST(0) = boolSV(RETVAL);
1095 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1100 XS(XS_Cwd_change_drive)
1104 croak("Usage: Cwd::change_drive(d)");
1106 char d = (char)*SvPV(ST(0),na);
1109 RETVAL = change_drive(d);
1110 ST(0) = boolSV(RETVAL);
1111 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1116 XS(XS_Cwd_sys_is_absolute)
1120 croak("Usage: Cwd::sys_is_absolute(path)");
1122 char * path = (char *)SvPV(ST(0),na);
1125 RETVAL = sys_is_absolute(path);
1126 ST(0) = boolSV(RETVAL);
1127 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1132 XS(XS_Cwd_sys_is_rooted)
1136 croak("Usage: Cwd::sys_is_rooted(path)");
1138 char * path = (char *)SvPV(ST(0),na);
1141 RETVAL = sys_is_rooted(path);
1142 ST(0) = boolSV(RETVAL);
1143 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1148 XS(XS_Cwd_sys_is_relative)
1152 croak("Usage: Cwd::sys_is_relative(path)");
1154 char * path = (char *)SvPV(ST(0),na);
1157 RETVAL = sys_is_relative(path);
1158 ST(0) = boolSV(RETVAL);
1159 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1168 croak("Usage: Cwd::sys_cwd()");
1172 RETVAL = _getcwd2(p, MAXPATHLEN);
1173 ST(0) = sv_newmortal();
1174 sv_setpv((SV*)ST(0), RETVAL);
1179 XS(XS_Cwd_sys_abspath)
1182 if (items < 1 || items > 2)
1183 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1185 char * path = (char *)SvPV(ST(0),na);
1193 dir = (char *)SvPV(ST(1),na);
1195 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1199 if (_abspath(p, path, MAXPATHLEN) == 0) {
1205 /* Absolute with drive: */
1206 if ( sys_is_absolute(path) ) {
1207 if (_abspath(p, path, MAXPATHLEN) == 0) {
1212 } else if (path[0] == '/' || path[0] == '\\') {
1213 /* Rooted, but maybe on different drive. */
1214 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1215 char p1[MAXPATHLEN];
1217 /* Need to prepend the drive. */
1220 Copy(path, p1 + 2, strlen(path) + 1, char);
1222 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1227 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1233 /* Either path is relative, or starts with a drive letter. */
1234 /* If the path starts with a drive letter, then dir is
1236 a/b) it is absolute/x:relative on the same drive.
1237 c) path is on current drive, and dir is rooted
1238 In all the cases it is safe to drop the drive part
1240 if ( !sys_is_relative(path) ) {
1243 if ( ( ( sys_is_absolute(dir)
1244 || (isALPHA(dir[0]) && dir[1] == ':'
1245 && strnicmp(dir, path,1) == 0))
1246 && strnicmp(dir, path,1) == 0)
1247 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1248 && toupper(path[0]) == current_drive())) {
1250 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1251 RETVAL = p; goto done;
1253 RETVAL = NULL; goto done;
1257 /* Need to prepend the absolute path of dir. */
1258 char p1[MAXPATHLEN];
1260 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1263 if (p1[ l - 1 ] != '/') {
1267 Copy(path, p1 + l, strlen(path) + 1, char);
1268 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1280 ST(0) = sv_newmortal();
1281 sv_setpv((SV*)ST(0), RETVAL);
1285 typedef APIRET (*PELP)(PSZ path, ULONG type);
1288 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1290 loadByOrd(ord); /* Guarantied to load or die! */
1291 return (*(PELP)ExtFCN[ord])(path, type);
1294 #define extLibpath(type) \
1295 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1296 : BEGIN_LIBPATH))) \
1299 #define extLibpath_set(p,type) \
1300 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1303 XS(XS_Cwd_extLibpath)
1306 if (items < 0 || items > 1)
1307 croak("Usage: Cwd::extLibpath(type = 0)");
1317 type = (int)SvIV(ST(0));
1320 RETVAL = extLibpath(type);
1321 ST(0) = sv_newmortal();
1322 sv_setpv((SV*)ST(0), RETVAL);
1327 XS(XS_Cwd_extLibpath_set)
1330 if (items < 1 || items > 2)
1331 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1333 char * s = (char *)SvPV(ST(0),na);
1341 type = (int)SvIV(ST(1));
1344 RETVAL = extLibpath_set(s, type);
1345 ST(0) = boolSV(RETVAL);
1346 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1354 char *file = __FILE__;
1358 if (_emx_env & 0x200) { /* OS/2 */
1359 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1360 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1361 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1363 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1364 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1365 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1366 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1367 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1368 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1369 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1370 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1371 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1372 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1375 sv_setiv(GvSV(gv), 1);
1380 OS2_Perl_data_t OS2_Perl_data;
1383 Perl_OS2_init(char **env)
1389 OS2_Perl_data.xs_init = &Xs_OS2_init;
1390 if (environ == NULL) {
1393 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1394 New(1304, sh_path, strlen(SH_PATH) + 1, char);
1395 strcpy(sh_path, SH_PATH);
1396 sh_path[0] = shell[0];
1397 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1398 int l = strlen(shell), i;
1399 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1402 New(1304, sh_path, l + 8, char);
1403 strncpy(sh_path, shell, l);
1404 strcpy(sh_path + l, "/sh.exe");
1405 for (i = 0; i < l; i++) {
1406 if (sh_path[i] == '\\') sh_path[i] = '/';
1409 MUTEX_INIT(&start_thread_mutex);
1416 my_tmpnam (char *str)
1418 char *p = getenv("TMP"), *tpath;
1421 if (!p) p = getenv("TEMP");
1422 tpath = tempnam(p, "pltmp");
1436 if (s.st_mode & S_IWOTH) {
1439 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1445 /* This code was contributed by Rocco Caputo. */
1447 my_flock(int handle, int o)
1449 FILELOCK rNull, rFull;
1450 ULONG timeout, handle_type, flag_word;
1452 int blocking, shared;
1453 static int use_my = -1;
1456 char *s = getenv("USE_PERL_FLOCK");
1462 if (!(_emx_env & 0x200) || !use_my)
1463 return flock(handle, o); /* Delegate to EMX. */
1466 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1467 (handle_type & 0xFF))
1472 // set lock/unlock ranges
1473 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1474 rFull.lRange = 0x7FFFFFFF;
1475 // set timeout for blocking
1476 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1477 // shared or exclusive?
1478 shared = (o & LOCK_SH) ? 1 : 0;
1479 // do not block the unlock
1480 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1481 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1486 case ERROR_INVALID_HANDLE:
1489 case ERROR_SHARING_BUFFER_EXCEEDED:
1492 case ERROR_LOCK_VIOLATION:
1493 break; // not an error
1494 case ERROR_INVALID_PARAMETER:
1495 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1496 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1499 case ERROR_INTERRUPT:
1508 if (o & (LOCK_SH | LOCK_EX)) {
1509 // for blocking operations
1523 case ERROR_INVALID_HANDLE:
1526 case ERROR_SHARING_BUFFER_EXCEEDED:
1529 case ERROR_LOCK_VIOLATION:
1531 errno = EWOULDBLOCK;
1535 case ERROR_INVALID_PARAMETER:
1536 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1537 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1540 case ERROR_INTERRUPT:
1547 // give away timeslice