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)
393 int rc, pass = 1, err;
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. */
433 if (err == ENOENT || err == ENOEXEC) {
434 /* No such file, or is a script. */
435 /* Try adding script extensions to the file name, and
437 char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
440 FILE *file = fopen(scr, "r");
446 if (!fgets(buf, sizeof buf, file)) {
450 if (fclose(file) != 0) { /* Failure */
452 warn("Error reading \"%s\": %s",
453 scr, Strerror(errno));
454 buf[0] = 0; /* Not #! */
460 } else if (buf[0] == 'e') {
461 if (strnEQ(buf, "extproc", 7)
464 } else if (buf[0] == 'E') {
465 if (strnEQ(buf, "EXTPROC", 7)
470 buf[0] = 0; /* Not #! */
478 /* Do better than pdksh: allow a few args,
479 strip trailing whitespace. */
489 while (*s && !isSPACE(*s))
496 warn("Too many args on %.*s line of \"%s\"",
506 if (!buf[0] && file) { /* File without magic */
507 /* In fact we tried all what pdksh would
508 try. There is no point in calling
509 pdksh, we may just emulate its logic. */
510 char *shell = getenv("EXECSHELL");
511 char *shell_opt = NULL;
517 shell = getenv("OS2_SHELL");
518 if (inicmd) { /* No spaces at start! */
520 while (*s && !isSPACE(*s)) {
522 inicmd = NULL; /* Cannot use */
530 /* Dosish shells will choke on slashes
531 in paths, fortunately, this is
532 important for zeroth arg only. */
539 /* If EXECSHELL is set, we do not set */
542 shell = ((_emx_env & 0x200)
545 nargs = shell_opt ? 2 : 1; /* shell file args */
546 exec_args[0] = shell;
547 exec_args[1] = shell_opt;
549 if (nargs == 2 && inicmd) {
550 /* Use the original cmd line */
551 /* XXXX This is good only until we refuse
552 quoted arguments... */
556 } else if (!buf[0] && inicmd) { /* No file */
557 /* Start with the original cmdline. */
558 /* XXXX This is good only until we refuse
559 quoted arguments... */
563 nargs = 2; /* shell -c */
566 while (a[1]) /* Get to the end */
568 a++; /* Copy finil NULL too */
569 while (a >= PL_Argv) {
570 *(a + nargs) = *a; /* PL_Argv was preallocated to be
575 PL_Argv[nargs] = argsp[nargs];
576 /* Enable pathless exec if #! (as pdksh). */
577 pass = (buf[0] == '#' ? 2 : 3);
581 /* Not found: restore errno */
584 } else if (rc < 0 && pass == 2 && err == ENOENT) { /* File not found */
585 char *no_dir = strrchr(PL_Argv[0], '/');
587 /* Do as pdksh port does: if not found with /, try without
590 PL_Argv[0] = no_dir + 1;
595 if (rc < 0 && PL_dowarn)
596 warn("Can't %s \"%s\": %s\n",
597 ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
599 PL_Argv[0], Strerror(err));
600 if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT)
601 && ((trueflag & 0xFF) == P_WAIT))
602 rc = 255 << 8; /* Emulate the fork(). */
609 do_aspawn(really,mark,sp)
618 int flag = P_WAIT, trueflag, err, secondtry = 0;
621 New(1301,PL_Argv, sp - mark + 3, char*);
624 if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
629 while (++mark <= sp) {
631 *a++ = SvPVx(*mark, PL_na);
637 rc = do_spawn_ve(really, flag, EXECF_SPAWN, NULL);
644 /* Try converting 1-arg form to (usually shell-less) multi-arg form. */
646 do_spawn2(cmd, execf)
653 char *shell, *copt, *news = NULL;
654 int rc, err, seenspace = 0;
655 char fullcmd[MAXNAMLEN + 1];
658 if ((shell = getenv("EMXSHELL")) != NULL)
660 else if ((shell = getenv("SHELL")) != NULL)
662 else if ((shell = getenv("COMSPEC")) != NULL)
667 /* Consensus on perl5-porters is that it is _very_ important to
668 have a shell which will not change between computers with the
669 same architecture, to avoid "action on a distance".
670 And to have simple build, this shell should be sh. */
675 while (*cmd && isSPACE(*cmd))
678 if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
679 STRLEN l = strlen(PL_sh_path);
681 New(1302, news, strlen(cmd) - 7 + l + 1, char);
682 strcpy(news, PL_sh_path);
683 strcpy(news + l, cmd + 7);
687 /* save an extra exec if possible */
688 /* see if there are shell metacharacters in it */
690 if (*cmd == '.' && isSPACE(cmd[1]))
693 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
696 for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
700 for (s = cmd; *s; s++) {
701 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
702 if (*s == '\n' && s[1] == '\0') {
705 } else if (*s == '\\' && !seenspace) {
706 continue; /* Allow backslashes in names */
708 /* We do not convert this to do_spawn_ve since shell
709 should be smart enough to start itself gloriously. */
711 if (execf == EXECF_TRUEEXEC)
712 rc = execl(shell,shell,copt,cmd,(char*)0);
713 else if (execf == EXECF_EXEC)
714 rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
715 else if (execf == EXECF_SPAWN_NOWAIT)
716 rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
718 /* In the ak code internal P_NOWAIT is P_WAIT ??? */
720 spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
721 if (rc < 0 && PL_dowarn)
722 warn("Can't %s \"%s\": %s",
723 (execf == EXECF_SPAWN ? "spawn" : "exec"),
724 shell, Strerror(errno));
725 if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
730 } else if (*s == ' ' || *s == '\t') {
735 /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */
736 New(1303,PL_Argv, (s - cmd + 11) / 2, char*);
737 PL_Cmd = savepvn(cmd, s-cmd);
739 for (s = PL_Cmd; *s;) {
740 while (*s && isSPACE(*s)) s++;
743 while (*s && !isSPACE(*s)) s++;
749 rc = do_spawn_ve(NULL, 0, execf, cmd);
762 return do_spawn2(cmd, EXECF_SPAWN);
769 return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
776 return do_spawn2(cmd, EXECF_EXEC);
783 return do_spawn2(cmd, EXECF_TRUEEXEC);
787 my_syspopen(cmd,mode)
794 register I32 this, that, newfd;
795 register I32 pid, rc;
799 /* `this' is what we use in the parent, `that' in the child. */
800 this = (*mode == 'w');
804 taint_proper("Insecure %s%s", "EXEC");
808 /* Now we need to spawn the child. */
809 newfd = dup(*mode == 'r'); /* Preserve std* */
810 if (p[that] != (*mode == 'r')) {
811 dup2(p[that], *mode == 'r');
814 /* Where is `this' and newfd now? */
815 fcntl(p[this], F_SETFD, FD_CLOEXEC);
816 fcntl(newfd, F_SETFD, FD_CLOEXEC);
817 pid = do_spawn_nowait(cmd);
818 if (newfd != (*mode == 'r')) {
819 dup2(newfd, *mode == 'r'); /* Return std* back. */
822 if (p[that] == (*mode == 'r'))
828 if (p[that] < p[this]) {
829 dup2(p[this], p[that]);
833 sv = *av_fetch(PL_fdpid,p[this],TRUE);
834 (void)SvUPGRADE(sv,SVt_IV);
836 PL_forkprocess = pid;
837 return PerlIO_fdopen(p[this], mode);
839 #else /* USE_POPEN */
845 res = popen(cmd, mode);
847 char *shell = getenv("EMXSHELL");
849 my_setenv("EMXSHELL", PL_sh_path);
850 res = popen(cmd, mode);
851 my_setenv("EMXSHELL", shell);
853 sv = *av_fetch(PL_fdpid, PerlIO_fileno(res), TRUE);
854 (void)SvUPGRADE(sv,SVt_IV);
855 SvIVX(sv) = -1; /* A cooky. */
858 #endif /* USE_POPEN */
862 /******************************************************************/
868 die(no_func, "Unsupported function fork");
874 /*******************************************************************/
875 /* not implemented in EMX 0.9a */
877 void * ctermid(x) { return 0; }
879 #ifdef MYTTYNAME /* was not in emx0.9a */
880 void * ttyname(x) { return 0; }
883 /******************************************************************/
884 /* my socket forwarders - EMX lib only provides static forwarders */
886 static HMODULE htcp = 0;
894 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
896 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
897 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
898 return (void *) ((void * (*)(void)) fcn) ();
903 tcp1(char *name, int arg)
908 if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
910 DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
911 if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
912 ((void (*)(int)) fcn) (arg);
915 void * gethostent() { return tcp0("GETHOSTENT"); }
916 void * getnetent() { return tcp0("GETNETENT"); }
917 void * getprotoent() { return tcp0("GETPROTOENT"); }
918 void * getservent() { return tcp0("GETSERVENT"); }
919 void sethostent(x) { tcp1("SETHOSTENT", x); }
920 void setnetent(x) { tcp1("SETNETENT", x); }
921 void setprotoent(x) { tcp1("SETPROTOENT", x); }
922 void setservent(x) { tcp1("SETSERVENT", x); }
923 void endhostent() { tcp0("ENDHOSTENT"); }
924 void endnetent() { tcp0("ENDNETENT"); }
925 void endprotoent() { tcp0("ENDPROTOENT"); }
926 void endservent() { tcp0("ENDSERVENT"); }
928 /*****************************************************************************/
929 /* not implemented in C Set++ */
932 int setuid(x) { errno = EINVAL; return -1; }
933 int setgid(x) { errno = EINVAL; return -1; }
936 /*****************************************************************************/
937 /* stat() hack for char/block device */
941 /* First attempt used DosQueryFSAttach which crashed the system when
942 used with 5.001. Now just look for /dev/. */
945 os2_stat(char *name, struct stat *st)
947 static int ino = SHRT_MAX;
949 if (stricmp(name, "/dev/con") != 0
950 && stricmp(name, "/dev/tty") != 0)
951 return stat(name, st);
953 memset(st, 0, sizeof *st);
954 st->st_mode = S_IFCHR|0666;
955 st->st_ino = (ino-- & 0x7FFF);
964 /* SBRK() emulation, mostly moved to malloc.c. */
967 sys_alloc(int size) {
969 APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
971 if (rc == ERROR_NOT_ENOUGH_MEMORY) {
973 } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
977 #endif /* USE_PERL_SBRK */
981 char *tmppath = TMPPATH1;
986 char *p = getenv("TMP"), *tpath;
989 if (!p) p = getenv("TEMP");
992 tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
995 strcpy(tpath + len + 1, TMPPATH1);
1001 XS(XS_File__Copy_syscopy)
1004 if (items < 2 || items > 3)
1005 croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
1007 char * src = (char *)SvPV(ST(0),PL_na);
1008 char * dst = (char *)SvPV(ST(1),PL_na);
1015 flag = (unsigned long)SvIV(ST(2));
1018 RETVAL = !CheckOSError(DosCopy(src, dst, flag));
1019 ST(0) = sv_newmortal();
1020 sv_setiv(ST(0), (IV)RETVAL);
1029 static char fname[9];
1030 int pos = 6, len, avlen;
1031 unsigned int sum = 0;
1036 if (!SvROK(sv)) croak("Not a reference given to mod2fname");
1038 if (SvTYPE(sv) != SVt_PVAV)
1039 croak("Not array reference given to mod2fname");
1041 avlen = av_len((AV*)sv);
1043 croak("Empty array reference given to mod2fname");
1045 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1046 strncpy(fname, s, 8);
1048 if (len < 6) pos = len;
1050 sum = 33 * sum + *(s++); /* Checksumming first chars to
1051 * get the capitalization into c.s. */
1054 while (avlen >= 0) {
1055 s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
1057 sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
1062 sum++; /* Avoid conflict of DLLs in memory. */
1064 fname[pos] = 'A' + (sum % 26);
1065 fname[pos + 1] = 'A' + (sum / 26 % 26);
1066 fname[pos + 2] = '\0';
1067 return (char *)fname;
1070 XS(XS_DynaLoader_mod2fname)
1074 croak("Usage: DynaLoader::mod2fname(sv)");
1079 RETVAL = mod2fname(sv);
1080 ST(0) = sv_newmortal();
1081 sv_setpv((SV*)ST(0), RETVAL);
1089 static char buf[300];
1092 if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
1095 if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
1096 sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
1103 perllib_mangle(char *s, unsigned int l)
1105 static char *newp, *oldp;
1106 static int newl, oldl, notfound;
1107 static char ret[STATIC_FILE_LENGTH+1];
1109 if (!newp && !notfound) {
1110 newp = getenv("PERLLIB_PREFIX");
1115 while (*newp && !isSPACE(*newp) && *newp != ';') {
1116 newp++; oldl++; /* Skip digits. */
1118 while (*newp && (isSPACE(*newp) || *newp == ';')) {
1119 newp++; /* Skip whitespace. */
1121 newl = strlen(newp);
1122 if (newl == 0 || oldl == 0) {
1123 die("Malformed PERLLIB_PREFIX");
1128 if (*s == '\\') *s = '/';
1141 if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
1144 if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
1145 die("Malformed PERLLIB_PREFIX");
1147 strcpy(ret + newl, s + oldl);
1151 extern void dlopen();
1152 void *fakedl = &dlopen; /* Pull in dynaloading part. */
1154 #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
1155 && ((path)[2] == '/' || (path)[2] == '\\'))
1156 #define sys_is_rooted _fnisabs
1157 #define sys_is_relative _fnisrel
1158 #define current_drive _getdrive
1160 #undef chdir /* Was _chdir2. */
1161 #define sys_chdir(p) (chdir(p) == 0)
1162 #define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
1164 XS(XS_Cwd_current_drive)
1168 croak("Usage: Cwd::current_drive()");
1172 RETVAL = current_drive();
1173 ST(0) = sv_newmortal();
1174 sv_setpvn(ST(0), (char *)&RETVAL, 1);
1179 XS(XS_Cwd_sys_chdir)
1183 croak("Usage: Cwd::sys_chdir(path)");
1185 char * path = (char *)SvPV(ST(0),PL_na);
1188 RETVAL = sys_chdir(path);
1189 ST(0) = boolSV(RETVAL);
1190 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1195 XS(XS_Cwd_change_drive)
1199 croak("Usage: Cwd::change_drive(d)");
1201 char d = (char)*SvPV(ST(0),PL_na);
1204 RETVAL = change_drive(d);
1205 ST(0) = boolSV(RETVAL);
1206 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1211 XS(XS_Cwd_sys_is_absolute)
1215 croak("Usage: Cwd::sys_is_absolute(path)");
1217 char * path = (char *)SvPV(ST(0),PL_na);
1220 RETVAL = sys_is_absolute(path);
1221 ST(0) = boolSV(RETVAL);
1222 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1227 XS(XS_Cwd_sys_is_rooted)
1231 croak("Usage: Cwd::sys_is_rooted(path)");
1233 char * path = (char *)SvPV(ST(0),PL_na);
1236 RETVAL = sys_is_rooted(path);
1237 ST(0) = boolSV(RETVAL);
1238 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1243 XS(XS_Cwd_sys_is_relative)
1247 croak("Usage: Cwd::sys_is_relative(path)");
1249 char * path = (char *)SvPV(ST(0),PL_na);
1252 RETVAL = sys_is_relative(path);
1253 ST(0) = boolSV(RETVAL);
1254 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1263 croak("Usage: Cwd::sys_cwd()");
1267 RETVAL = _getcwd2(p, MAXPATHLEN);
1268 ST(0) = sv_newmortal();
1269 sv_setpv((SV*)ST(0), RETVAL);
1274 XS(XS_Cwd_sys_abspath)
1277 if (items < 1 || items > 2)
1278 croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
1280 char * path = (char *)SvPV(ST(0),PL_na);
1288 dir = (char *)SvPV(ST(1),PL_na);
1290 if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
1294 if (_abspath(p, path, MAXPATHLEN) == 0) {
1300 /* Absolute with drive: */
1301 if ( sys_is_absolute(path) ) {
1302 if (_abspath(p, path, MAXPATHLEN) == 0) {
1307 } else if (path[0] == '/' || path[0] == '\\') {
1308 /* Rooted, but maybe on different drive. */
1309 if (isALPHA(dir[0]) && dir[1] == ':' ) {
1310 char p1[MAXPATHLEN];
1312 /* Need to prepend the drive. */
1315 Copy(path, p1 + 2, strlen(path) + 1, char);
1317 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1322 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1328 /* Either path is relative, or starts with a drive letter. */
1329 /* If the path starts with a drive letter, then dir is
1331 a/b) it is absolute/x:relative on the same drive.
1332 c) path is on current drive, and dir is rooted
1333 In all the cases it is safe to drop the drive part
1335 if ( !sys_is_relative(path) ) {
1338 if ( ( ( sys_is_absolute(dir)
1339 || (isALPHA(dir[0]) && dir[1] == ':'
1340 && strnicmp(dir, path,1) == 0))
1341 && strnicmp(dir, path,1) == 0)
1342 || ( !(isALPHA(dir[0]) && dir[1] == ':')
1343 && toupper(path[0]) == current_drive())) {
1345 } else if (_abspath(p, path, MAXPATHLEN) == 0) {
1346 RETVAL = p; goto done;
1348 RETVAL = NULL; goto done;
1352 /* Need to prepend the absolute path of dir. */
1353 char p1[MAXPATHLEN];
1355 if (_abspath(p1, dir, MAXPATHLEN) == 0) {
1358 if (p1[ l - 1 ] != '/') {
1362 Copy(path, p1 + l, strlen(path) + 1, char);
1363 if (_abspath(p, p1, MAXPATHLEN) == 0) {
1375 ST(0) = sv_newmortal();
1376 sv_setpv((SV*)ST(0), RETVAL);
1380 typedef APIRET (*PELP)(PSZ path, ULONG type);
1383 ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
1385 loadByOrd(ord); /* Guarantied to load or die! */
1386 return (*(PELP)ExtFCN[ord])(path, type);
1389 #define extLibpath(type) \
1390 (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
1391 : BEGIN_LIBPATH))) \
1394 #define extLibpath_set(p,type) \
1395 (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
1398 XS(XS_Cwd_extLibpath)
1401 if (items < 0 || items > 1)
1402 croak("Usage: Cwd::extLibpath(type = 0)");
1412 type = (int)SvIV(ST(0));
1415 RETVAL = extLibpath(type);
1416 ST(0) = sv_newmortal();
1417 sv_setpv((SV*)ST(0), RETVAL);
1422 XS(XS_Cwd_extLibpath_set)
1425 if (items < 1 || items > 2)
1426 croak("Usage: Cwd::extLibpath_set(s, type = 0)");
1428 char * s = (char *)SvPV(ST(0),PL_na);
1436 type = (int)SvIV(ST(1));
1439 RETVAL = extLibpath_set(s, type);
1440 ST(0) = boolSV(RETVAL);
1441 if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
1449 char *file = __FILE__;
1453 if (_emx_env & 0x200) { /* OS/2 */
1454 newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
1455 newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
1456 newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
1458 newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
1459 newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
1460 newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
1461 newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
1462 newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
1463 newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
1464 newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
1465 newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
1466 newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
1467 gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
1470 sv_setiv(GvSV(gv), 1);
1475 OS2_Perl_data_t OS2_Perl_data;
1478 Perl_OS2_init(char **env)
1484 OS2_Perl_data.xs_init = &Xs_OS2_init;
1485 if (environ == NULL) {
1488 if ( (shell = getenv("PERL_SH_DRIVE")) ) {
1489 New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
1490 strcpy(PL_sh_path, SH_PATH);
1491 PL_sh_path[0] = shell[0];
1492 } else if ( (shell = getenv("PERL_SH_DIR")) ) {
1493 int l = strlen(shell), i;
1494 if (shell[l-1] == '/' || shell[l-1] == '\\') {
1497 New(1304, PL_sh_path, l + 8, char);
1498 strncpy(PL_sh_path, shell, l);
1499 strcpy(PL_sh_path + l, "/sh.exe");
1500 for (i = 0; i < l; i++) {
1501 if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
1504 MUTEX_INIT(&start_thread_mutex);
1511 my_tmpnam (char *str)
1513 char *p = getenv("TMP"), *tpath;
1516 if (!p) p = getenv("TEMP");
1517 tpath = tempnam(p, "pltmp");
1531 if (s.st_mode & S_IWOTH) {
1534 return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
1540 /* This code was contributed by Rocco Caputo. */
1542 my_flock(int handle, int o)
1544 FILELOCK rNull, rFull;
1545 ULONG timeout, handle_type, flag_word;
1547 int blocking, shared;
1548 static int use_my = -1;
1551 char *s = getenv("USE_PERL_FLOCK");
1557 if (!(_emx_env & 0x200) || !use_my)
1558 return flock(handle, o); /* Delegate to EMX. */
1561 if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
1562 (handle_type & 0xFF))
1567 // set lock/unlock ranges
1568 rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
1569 rFull.lRange = 0x7FFFFFFF;
1570 // set timeout for blocking
1571 timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
1572 // shared or exclusive?
1573 shared = (o & LOCK_SH) ? 1 : 0;
1574 // do not block the unlock
1575 if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
1576 rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
1581 case ERROR_INVALID_HANDLE:
1584 case ERROR_SHARING_BUFFER_EXCEEDED:
1587 case ERROR_LOCK_VIOLATION:
1588 break; // not an error
1589 case ERROR_INVALID_PARAMETER:
1590 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1591 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1594 case ERROR_INTERRUPT:
1603 if (o & (LOCK_SH | LOCK_EX)) {
1604 // for blocking operations
1618 case ERROR_INVALID_HANDLE:
1621 case ERROR_SHARING_BUFFER_EXCEEDED:
1624 case ERROR_LOCK_VIOLATION:
1626 errno = EWOULDBLOCK;
1630 case ERROR_INVALID_PARAMETER:
1631 case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
1632 case ERROR_READ_LOCKS_NOT_SUPPORTED:
1635 case ERROR_INTERRUPT:
1642 // give away timeslice