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 /* Spawn/exec a program, revert to shell if needed. */
382 /* global PL_Argv[] contains arguments. */
385 do_spawn_ve(really, flag, execf, inicmd)
395 char buf[256], *s = 0;
397 static char * fargs[4]
398 = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", };
399 char **argsp = fargs;
406 if (strEQ(PL_Argv[0],"/bin/sh"))
407 PL_Argv[0] = PL_sh_path;
409 if (PL_Argv[0][0] != '/' && PL_Argv[0][0] != '\\'
410 && !(PL_Argv[0][0] && PL_Argv[0][1] == ':'
411 && (PL_Argv[0][2] == '/' || PL_Argv[0][2] != '\\'))
412 ) /* will spawnvp use PATH? */
413 TAINT_ENV(); /* testing IFS here is overkill, probably */
414 /* We should check PERL_SH* and PERLLIB_* as well? */
415 if (!really || !*(tmps = SvPV(really, PL_na)))
418 rc = result(trueflag, spawnvp(flag,tmps,PL_Argv));
420 if (execf == EXECF_TRUEEXEC)
421 rc = execvp(tmps,PL_Argv);
422 else if (execf == EXECF_EXEC)
423 rc = spawnvp(trueflag | P_OVERLAY,tmps,PL_Argv);
424 else if (execf == EXECF_SPAWN_NOWAIT)
425 rc = spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv);
426 else /* EXECF_SPAWN */
427 rc = result(trueflag,
428 spawnvp(trueflag | P_NOWAIT,tmps,PL_Argv));
430 if (rc < 0 && pass == 1
431 && (tmps == PL_Argv[0])) { /* Cannot transfer `really' via shell. */
434 if (err == ENOENT || err == ENOEXEC) {
435 /* No such file, or is a script. */
436 /* Try adding script extensions to the file name, and
438 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
441 FILE *file = fopen(scr, "r");
447 if (!fgets(buf, sizeof buf, file)) {
451 if (fclose(file) != 0) { /* Failure */
453 warn("Error reading \"%s\": %s",
454 scr, Strerror(errno));
455 buf[0] = 0; /* Not #! */
461 } else if (buf[0] == 'e') {
462 if (strnEQ(buf, "extproc", 7)
465 } else if (buf[0] == 'E') {
466 if (strnEQ(buf, "EXTPROC", 7)
471 buf[0] = 0; /* Not #! */
479 /* Do better than pdksh: allow a few args,
480 strip trailing whitespace. */
490 while (*s && !isSPACE(*s))
497 warn("Too many args on %.*s line of \"%s\"",
507 if (!buf[0] && file) { /* File without magic */
508 /* In fact we tried all what pdksh would
509 try. There is no point in calling
510 pdksh, we may just emulate its logic. */
511 char *shell = getenv("EXECSHELL");
512 char *shell_opt = NULL;
518 shell = getenv("OS2_SHELL");
519 if (inicmd) { /* No spaces at start! */
521 while (*s && !isSPACE(*s)) {
523 inicmd = NULL; /* Cannot use */
531 /* Dosish shells will choke on slashes
532 in paths, fortunately, this is
533 important for zeroth arg only. */
540 /* If EXECSHELL is set, we do not set */
543 shell = ((_emx_env & 0x200)
546 nargs = shell_opt ? 2 : 1; /* shell file args */
547 exec_args[0] = shell;
548 exec_args[1] = shell_opt;
550 if (nargs == 2 && inicmd) {
551 /* Use the original cmd line */
552 /* XXXX This is good only until we refuse
553 quoted arguments... */
557 } else if (!buf[0] && inicmd) { /* No file */
558 /* Start with the original cmdline. */
559 /* XXXX This is good only until we refuse
560 quoted arguments... */
564 nargs = 2; /* shell -c */
567 while (a[1]) /* Get to the end */
569 a++; /* Copy finil NULL too */
570 while (a >= PL_Argv) {
571 *(a + nargs) = *a; /* PL_Argv was preallocated to be
576 PL_Argv[nargs] = argsp[nargs];
577 /* Enable pathless exec if #! (as pdksh). */
578 pass = (buf[0] == '#' ? 2 : 3);
582 /* Not found: restore errno */
585 } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */
586 char *no_dir = strrchr(PL_Argv[0], '/');
588 /* Do as pdksh port does: if not found with /, try without
591 PL_Argv[0] = no_dir + 1;
596 if (rc < 0 && PL_dowarn)
597 warn("Can't %s \"%s\": %s\n",
598 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
600 PL_Argv[0], Strerror(errno));
601 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
602 && ((trueflag & 0xFF) == P_WAIT))
603 rc = 255 << 8; /* Emulate the fork(). */
610 do_aspawn(really,mark,sp)
619 int flag = P_WAIT, trueflag, err, secondtry = 0;
622 New(1301,PL_Argv, sp - mark + 3, char*);
625 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
630 while (++mark <= sp) {
632 *a++ = SvPVx(*mark, PL_na);
638 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
645 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
647 do_spawn2(cmd, execf)
654 char *shell, *copt, *news = NULL;
655 int rc, err, seenspace = 0;
656 char fullcmd[MAXNAMLEN + 1];
659 if ((shell = getenv("EMXSHELL")) != NULL)
661 else if ((shell = getenv("SHELL")) != NULL)
663 else if ((shell = getenv("COMSPEC")) != NULL)
668 /* Consensus on perl5-porters is that it is _very_ important to
669 have a shell which will not change between computers with the
670 same architecture, to avoid "action on a distance".
671 And to have simple build, this shell should be sh. */
676 while (*cmd && isSPACE(*cmd))
679 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
680 STRLEN l = strlen(PL_sh_path);
682 New(1302, news, strlen(cmd) - 7 + l + 1, char);
683 strcpy(news, PL_sh_path);
684 strcpy(news + l, cmd + 7);
688 /* save an extra exec if possible */
689 /* see if there are shell metacharacters in it */
691 if (*cmd == '.' && isSPACE(cmd[1]))
694 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
697 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
701 for (s = cmd; *s; s++) {
702 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
703 if (*s == '\n' && s[1] == '\0') {
706 } else if (*s == '\\' && !seenspace) {
707 continue; /* Allow backslashes in names */
709 /* We do not convert this to do_spawn_ve since shell
710 should be smart enough to start itself gloriously. */
712 if (execf == EXECF_TRUEEXEC)
713 rc = execl(shell,shell,copt,cmd,(char*)0);
714 else if (execf == EXECF_EXEC)
715 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
716 else if (execf == EXECF_SPAWN_NOWAIT)
717 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
719 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
721 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
722 if (rc < 0 && PL_dowarn)
723 warn("Can't %s \"%s\": %s",
724 (execf == EXECF_SPAWN ? "spawn" : "exec"),
725 shell, Strerror(errno));
726 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
731 } else if (*s == ' ' || *s == '\t') {
736 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
737 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
738 PL_Cmd = savepvn(cmd, s-cmd);
740 for (s = PL_Cmd; *s;) {
741 while (*s && isSPACE(*s)) s++;
744 while (*s && !isSPACE(*s)) s++;
750 rc = do_spawn_ve(NULL, 0, execf, cmd);
763 return do_spawn2(cmd, EXECF_SPAWN);
770 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
777 return do_spawn2(cmd, EXECF_EXEC);
784 return do_spawn2(cmd, EXECF_TRUEEXEC);
788 my_syspopen(cmd,mode)
795 register I32 this, that, newfd;
796 register I32 pid, rc;
800 /* `this' is what we use in the parent, `that' in the child. */
801 this = (*mode == 'w');
805 taint_proper("Insecure %s%s", "EXEC");
809 /* Now we need to spawn the child. */
810 newfd = dup(*mode == 'r'); /* Preserve std* */
811 if (p[that] != (*mode == 'r')) {
812 dup2(p[that], *mode == 'r');
815 /* Where is `this' and newfd now? */
816 fcntl(p[this], F_SETFD, FD_CLOEXEC);
817 fcntl(newfd, F_SETFD, FD_CLOEXEC);
818 pid = do_spawn_nowait(cmd);
819 if (newfd != (*mode == 'r')) {
820 dup2(newfd, *mode == 'r'); /* Return std* back. */
823 if (p[that] == (*mode == 'r'))
829 if (p[that] < p[this]) {
830 dup2(p[this], p[that]);
834 sv = *av_fetch(PL_fdpid,p[this],TRUE);
835 (void)SvUPGRADE(sv,SVt_IV);
837 PL_forkprocess = pid;
838 return PerlIO_fdopen(p[this], mode);
840 #else /* USE_POPEN */
846 res = popen(cmd, mode);
848 char *shell = getenv("EMXSHELL");
850 my_setenv("EMXSHELL", PL_sh_path);
851 res = popen(cmd, mode);
852 my_setenv("EMXSHELL", shell);
854 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
855 (void)SvUPGRADE(sv,SVt_IV);
856 SvIVX(sv) = -1; /* A cooky. */
859 #endif /* USE_POPEN */
863 /******************************************************************/
869 die(no_func, "Unsupported function fork");
875 /*******************************************************************/
876 /* not implemented in EMX 0.9a */
878 void * ctermid(x) { return 0; }
880 #ifdef MYTTYNAME /* was not in emx0.9a */
881 void * ttyname(x) { return 0; }
884 /******************************************************************/
885 /* my socket forwarders - EMX lib only provides static forwarders */
887 static HMODULE htcp = 0;
895 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
897 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
898 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
899 return (void *) ((void * (*)(void)) fcn) ();
904 tcp1(char *name, int arg)
909 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
911 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
912 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
913 ((void (*)(int)) fcn) (arg);
916 void * gethostent() { return tcp0("GETHOSTENT"); }
917 void * getnetent() { return tcp0("GETNETENT"); }
918 void * getprotoent() { return tcp0("GETPROTOENT"); }
919 void * getservent() { return tcp0("GETSERVENT"); }
920 void sethostent(x) { tcp1("SETHOSTENT", x); }
921 void setnetent(x) { tcp1("SETNETENT", x); }
922 void setprotoent(x) { tcp1("SETPROTOENT", x); }
923 void setservent(x) { tcp1("SETSERVENT", x); }
924 void endhostent() { tcp0("ENDHOSTENT"); }
925 void endnetent() { tcp0("ENDNETENT"); }
926 void endprotoent() { tcp0("ENDPROTOENT"); }
927 void endservent() { tcp0("ENDSERVENT"); }
929 /*****************************************************************************/
930 /* not implemented in C Set++ */
933 int setuid(x) { errno = EINVAL; return -1; }
934 int setgid(x) { errno = EINVAL; return -1; }
937 /*****************************************************************************/
938 /* stat() hack for char/block device */
942 /* First attempt used DosQueryFSAttach which crashed the system when
943 used with 5.001. Now just look for /dev/. */
946 os2_stat(char *name, struct stat *st)
948 static int ino = SHRT_MAX;
950 if (stricmp(name, "/dev/con") != 0
951 && stricmp(name, "/dev/tty") != 0)
952 return stat(name, st);
954 memset(st, 0, sizeof *st);
955 st->st_mode = S_IFCHR|0666;
956 st->st_ino = (ino-- & 0x7FFF);
965 /* SBRK() emulation, mostly moved to malloc.c. */
968 sys_alloc(int size) {
970 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
972 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
974 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
978 #endif /* USE_PERL_SBRK */
982 char *tmppath = TMPPATH1;
987 char *p = getenv("TMP"), *tpath;
990 if (!p) p = getenv("TEMP");
993 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
996 strcpy(tpath + len + 1, TMPPATH1);
1002 XS(XS_File__Copy_syscopy)
1005 if (items < 2 || items > 3)
1006 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1008 char * src = (char *)SvPV(ST(0),PL_na);
1009 char * dst = (char *)SvPV(ST(1),PL_na);
1016 flag = (unsigned long)SvIV(ST(2));
1019 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1020 ST(0) = sv_newmortal();
1021 sv_setiv(ST(0), (IV)RETVAL);
1030 static char fname[9];
1031 int pos = 6, len, avlen;
1032 unsigned int sum = 0;
1037 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1039 if (SvTYPE(sv) != SVt_PVAV)
1040 croak("Not array reference given to mod2fname");
1042 avlen = av_len((AV*)sv);
1044 croak("Empty array reference given to mod2fname");
1046 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1047 strncpy(fname, s, 8);
1049 if (len < 6) pos = len;
1051 sum = 33 * sum + *(s++); /* Checksumming first chars to
1052 * get the capitalization into c.s. */
1055 while (avlen >= 0) {
1056 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1058 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1063 sum++; /* Avoid conflict of DLLs in memory. */
1065 fname[pos] = 'A' + (sum % 26);
1066 fname[pos + 1] = 'A' + (sum / 26 % 26);
1067 fname[pos + 2] = '\0';
1068 return (char *)fname;
1071 XS(XS_DynaLoader_mod2fname)
1075 croak("Usage: DynaLoader::mod2fname(sv)");
1080 RETVAL = mod2fname(sv);
1081 ST(0) = sv_newmortal();
1082 sv_setpv((SV*)ST(0), RETVAL);
1090 static char buf[300];
1093 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1096 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1097 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1104 perllib_mangle(char *s, unsigned int l)
1106 static char *newp, *oldp;
1107 static int newl, oldl, notfound;
1108 static char ret[STATIC_FILE_LENGTH+1];
1110 if (!newp && !notfound) {
1111 newp = getenv("PERLLIB_PREFIX");
1116 while (*newp && !isSPACE(*newp) && *newp != ';') {
1117 newp++; oldl++; /* Skip digits. */
1119 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1120 newp++; /* Skip whitespace. */
1122 newl = strlen(newp);
1123 if (newl == 0 || oldl == 0) {
1124 die("Malformed PERLLIB_PREFIX");
1129 if (*s == '\\') *s = '/';
1142 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1145 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1146 die("Malformed PERLLIB_PREFIX");
1148 strcpy(ret + newl, s + oldl);
1152 extern void dlopen();
1153 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1155 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1156 && ((path)[2] == '/' || (path)[2] == '\\'))
1157 #define sys_is_rooted _fnisabs
1158 #define sys_is_relative _fnisrel
1159 #define current_drive _getdrive
1161 #undef chdir /* Was _chdir2. */
1162 #define sys_chdir(p) (chdir(p) == 0)
1163 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1165 XS(XS_Cwd_current_drive)
1169 croak("Usage: Cwd::current_drive()");
1173 RETVAL = current_drive();
1174 ST(0) = sv_newmortal();
1175 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1180 XS(XS_Cwd_sys_chdir)
1184 croak("Usage: Cwd::sys_chdir(path)");
1186 char * path = (char *)SvPV(ST(0),PL_na);
1189 RETVAL = sys_chdir(path);
1190 ST(0) = boolSV(RETVAL);
1191 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1196 XS(XS_Cwd_change_drive)
1200 croak("Usage: Cwd::change_drive(d)");
1202 char d = (char)*SvPV(ST(0),PL_na);
1205 RETVAL = change_drive(d);
1206 ST(0) = boolSV(RETVAL);
1207 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1212 XS(XS_Cwd_sys_is_absolute)
1216 croak("Usage: Cwd::sys_is_absolute(path)");
1218 char * path = (char *)SvPV(ST(0),PL_na);
1221 RETVAL = sys_is_absolute(path);
1222 ST(0) = boolSV(RETVAL);
1223 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1228 XS(XS_Cwd_sys_is_rooted)
1232 croak("Usage: Cwd::sys_is_rooted(path)");
1234 char * path = (char *)SvPV(ST(0),PL_na);
1237 RETVAL = sys_is_rooted(path);
1238 ST(0) = boolSV(RETVAL);
1239 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1244 XS(XS_Cwd_sys_is_relative)
1248 croak("Usage: Cwd::sys_is_relative(path)");
1250 char * path = (char *)SvPV(ST(0),PL_na);
1253 RETVAL = sys_is_relative(path);
1254 ST(0) = boolSV(RETVAL);
1255 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1264 croak("Usage: Cwd::sys_cwd()");
1268 RETVAL = _getcwd2(p, MAXPATHLEN);
1269 ST(0) = sv_newmortal();
1270 sv_setpv((SV*)ST(0), RETVAL);
1275 XS(XS_Cwd_sys_abspath)
1278 if (items < 1 || items > 2)
1279 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1281 char * path = (char *)SvPV(ST(0),PL_na);
1289 dir = (char *)SvPV(ST(1),PL_na);
1291 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1295 if (_abspath(p, path, MAXPATHLEN) == 0) {
1301 /* Absolute with drive: */
1302 if ( sys_is_absolute(path) ) {
1303 if (_abspath(p, path, MAXPATHLEN) == 0) {
1308 } else if (path[0] == '/' || path[0] == '\\') {
1309 /* Rooted, but maybe on different drive. */
1310 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1311 char p1[MAXPATHLEN];
1313 /* Need to prepend the drive. */
1316 Copy(path, p1 + 2, strlen(path) + 1, char);
1318 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1323 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1329 /* Either path is relative, or starts with a drive letter. */
1330 /* If the path starts with a drive letter, then dir is
1332 a/b) it is absolute/x:relative on the same drive.
1333 c) path is on current drive, and dir is rooted
1334 In all the cases it is safe to drop the drive part
1336 if ( !sys_is_relative(path) ) {
1339 if ( ( ( sys_is_absolute(dir)
1340 || (isALPHA(dir[0]) && dir[1] == ':'
1341 && strnicmp(dir, path,1) == 0))
1342 && strnicmp(dir, path,1) == 0)
1343 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1344 && toupper(path[0]) == current_drive())) {
1346 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1347 RETVAL = p; goto done;
1349 RETVAL = NULL; goto done;
1353 /* Need to prepend the absolute path of dir. */
1354 char p1[MAXPATHLEN];
1356 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1359 if (p1[ l - 1 ] != '/') {
1363 Copy(path, p1 + l, strlen(path) + 1, char);
1364 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1376 ST(0) = sv_newmortal();
1377 sv_setpv((SV*)ST(0), RETVAL);
1381 typedef APIRET (*PELP)(PSZ path, ULONG type);
1384 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1386 loadByOrd(ord); /* Guarantied to load or die! */
1387 return (*(PELP)ExtFCN[ord])(path, type);
1390 #define extLibpath(type) \
1391 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1392 : BEGIN_LIBPATH))) \
1395 #define extLibpath_set(p,type) \
1396 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1399 XS(XS_Cwd_extLibpath)
1402 if (items < 0 || items > 1)
1403 croak("Usage: Cwd::extLibpath(type = 0)");
1413 type = (int)SvIV(ST(0));
1416 RETVAL = extLibpath(type);
1417 ST(0) = sv_newmortal();
1418 sv_setpv((SV*)ST(0), RETVAL);
1423 XS(XS_Cwd_extLibpath_set)
1426 if (items < 1 || items > 2)
1427 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1429 char * s = (char *)SvPV(ST(0),PL_na);
1437 type = (int)SvIV(ST(1));
1440 RETVAL = extLibpath_set(s, type);
1441 ST(0) = boolSV(RETVAL);
1442 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1450 char *file = __FILE__;
1454 if (_emx_env & 0x200) { /* OS/2 */
1455 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1456 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1457 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1459 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1460 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1461 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1462 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1463 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1464 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1465 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1466 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1467 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1468 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1471 sv_setiv(GvSV(gv), 1);
1476 OS2_Perl_data_t OS2_Perl_data;
1479 Perl_OS2_init(char **env)
1485 OS2_Perl_data.xs_init = &Xs_OS2_init;
1486 if (environ == NULL) {
1489 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1490 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1491 strcpy(PL_sh_path, SH_PATH);
1492 PL_sh_path[0] = shell[0];
1493 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1494 int l = strlen(shell), i;
1495 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1498 New(1304, PL_sh_path, l + 8, char);
1499 strncpy(PL_sh_path, shell, l);
1500 strcpy(PL_sh_path + l, "/sh.exe");
1501 for (i = 0; i < l; i++) {
1502 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1505 MUTEX_INIT(&start_thread_mutex);
1512 my_tmpnam (char *str)
1514 char *p = getenv("TMP"), *tpath;
1517 if (!p) p = getenv("TEMP");
1518 tpath = tempnam(p, "pltmp");
1532 if (s.st_mode & S_IWOTH) {
1535 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1541 /* This code was contributed by Rocco Caputo. */
1543 my_flock(int handle, int o)
1545 FILELOCK rNull, rFull;
1546 ULONG timeout, handle_type, flag_word;
1548 int blocking, shared;
1549 static int use_my = -1;
1552 char *s = getenv("USE_PERL_FLOCK");
1558 if (!(_emx_env & 0x200) || !use_my)
1559 return flock(handle, o); /* Delegate to EMX. */
1562 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1563 (handle_type & 0xFF))
1568 // set lock/unlock ranges
1569 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1570 rFull.lRange = 0x7FFFFFFF;
1571 // set timeout for blocking
1572 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1573 // shared or exclusive?
1574 shared = (o & LOCK_SH) ? 1 : 0;
1575 // do not block the unlock
1576 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1577 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1582 case ERROR_INVALID_HANDLE:
1585 case ERROR_SHARING_BUFFER_EXCEEDED:
1588 case ERROR_LOCK_VIOLATION:
1589 break; // not an error
1590 case ERROR_INVALID_PARAMETER:
1591 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1592 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1595 case ERROR_INTERRUPT:
1604 if (o & (LOCK_SH | LOCK_EX)) {
1605 // for blocking operations
1619 case ERROR_INVALID_HANDLE:
1622 case ERROR_SHARING_BUFFER_EXCEEDED:
1625 case ERROR_LOCK_VIOLATION:
1627 errno = EWOULDBLOCK;
1631 case ERROR_INVALID_PARAMETER:
1632 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1633 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1636 case ERROR_INTERRUPT:
1643 // give away timeslice