+
+#ifdef USE_PERL_SBRK
+
+/* SBRK() emulation, mostly moved to malloc.c. */
+
+void *
+sys_alloc(int size) {
+ void *got;
+ APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
+
+ if (rc == ERROR_NOT_ENOUGH_MEMORY) {
+ return (void *) -1;
+ } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
+ return got;
+}
+
+#endif /* USE_PERL_SBRK */
+
+/* tmp path */
+
+char *tmppath = TMPPATH1;
+
+void
+settmppath()
+{
+ char *p = getenv("TMP"), *tpath;
+ int len;
+
+ if (!p) p = getenv("TEMP");
+ if (!p) return;
+ len = strlen(p);
+ tpath = (char *)malloc(len + strlen(TMPPATH1) + 2);
+ strcpy(tpath, p);
+ tpath[len] = '/';
+ strcpy(tpath + len + 1, TMPPATH1);
+ tmppath = tpath;
+}
+
+#include "XSUB.h"
+
+XS(XS_File__Copy_syscopy)
+{
+ dXSARGS;
+ if (items < 2 || items > 3)
+ croak("Usage: File::Copy::syscopy(src,dst,flag=0)");
+ {
+ char * src = (char *)SvPV(ST(0),PL_na);
+ char * dst = (char *)SvPV(ST(1),PL_na);
+ U32 flag;
+ int RETVAL, rc;
+
+ if (items < 3)
+ flag = 0;
+ else {
+ flag = (unsigned long)SvIV(ST(2));
+ }
+
+ RETVAL = !CheckOSError(DosCopy(src, dst, flag));
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+#include "patchlevel.h"
+
+char *
+mod2fname(sv)
+ SV *sv;
+{
+ static char fname[9];
+ int pos = 6, len, avlen;
+ unsigned int sum = 0;
+ AV *av;
+ SV *svp;
+ char *s;
+
+ if (!SvROK(sv)) croak("Not a reference given to mod2fname");
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_PVAV)
+ croak("Not array reference given to mod2fname");
+
+ avlen = av_len((AV*)sv);
+ if (avlen < 0)
+ croak("Empty array reference given to mod2fname");
+
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
+ strncpy(fname, s, 8);
+ len = strlen(s);
+ if (len < 6) pos = len;
+ while (*s) {
+ sum = 33 * sum + *(s++); /* Checksumming first chars to
+ * get the capitalization into c.s. */
+ }
+ avlen --;
+ while (avlen >= 0) {
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), PL_na);
+ while (*s) {
+ sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
+ }
+ avlen --;
+ }
+#ifdef USE_THREADS
+ sum++; /* Avoid conflict of DLLs in memory. */
+#endif
+ sum += PATCHLEVEL * 200 + SUBVERSION * 2; /* */
+ fname[pos] = 'A' + (sum % 26);
+ fname[pos + 1] = 'A' + (sum / 26 % 26);
+ fname[pos + 2] = '\0';
+ return (char *)fname;
+}
+
+XS(XS_DynaLoader_mod2fname)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: DynaLoader::mod2fname(sv)");
+ {
+ SV * sv = ST(0);
+ char * RETVAL;
+
+ RETVAL = mod2fname(sv);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+char *
+os2error(int rc)
+{
+ static char buf[300];
+ ULONG len;
+
+ if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
+ if (rc == 0)
+ return NULL;
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
+ sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
+ else
+ buf[len] = '\0';
+ if (len > 0 && buf[len - 1] == '\n')
+ buf[len - 1] = '\0';
+ if (len > 1 && buf[len - 2] == '\r')
+ buf[len - 2] = '\0';
+ if (len > 2 && buf[len - 3] == '.')
+ buf[len - 3] = '\0';
+ return buf;
+}
+
+char *
+perllib_mangle(char *s, unsigned int l)
+{
+ static char *newp, *oldp;
+ static int newl, oldl, notfound;
+ static char ret[STATIC_FILE_LENGTH+1];
+
+ if (!newp && !notfound) {
+ newp = getenv("PERLLIB_PREFIX");
+ if (newp) {
+ char *s;
+
+ oldp = newp;
+ while (*newp && !isSPACE(*newp) && *newp != ';') {
+ newp++; oldl++; /* Skip digits. */
+ }
+ while (*newp && (isSPACE(*newp) || *newp == ';')) {
+ newp++; /* Skip whitespace. */
+ }
+ newl = strlen(newp);
+ if (newl == 0 || oldl == 0) {
+ die("Malformed PERLLIB_PREFIX");
+ }
+ strcpy(ret, newp);
+ s = ret;
+ while (*s) {
+ if (*s == '\\') *s = '/';
+ s++;
+ }
+ } else {
+ notfound = 1;
+ }
+ }
+ if (!newp) {
+ return s;
+ }
+ if (l == 0) {
+ l = strlen(s);
+ }
+ if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
+ return s;
+ }
+ if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
+ die("Malformed PERLLIB_PREFIX");
+ }
+ strcpy(ret + newl, s + oldl);
+ return ret;
+}
+
+extern void dlopen();
+void *fakedl = &dlopen; /* Pull in dynaloading part. */
+
+#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
+ && ((path)[2] == '/' || (path)[2] == '\\'))
+#define sys_is_rooted _fnisabs
+#define sys_is_relative _fnisrel
+#define current_drive _getdrive
+
+#undef chdir /* Was _chdir2. */
+#define sys_chdir(p) (chdir(p) == 0)
+#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
+
+XS(XS_Cwd_current_drive)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: Cwd::current_drive()");
+ {
+ char RETVAL;
+
+ RETVAL = current_drive();
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), (char *)&RETVAL, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_chdir)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_chdir(path)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_na);
+ bool RETVAL;
+
+ RETVAL = sys_chdir(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_change_drive)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::change_drive(d)");
+ {
+ char d = (char)*SvPV(ST(0),PL_na);
+ bool RETVAL;
+
+ RETVAL = change_drive(d);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_absolute)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_absolute(path)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_na);
+ bool RETVAL;
+
+ RETVAL = sys_is_absolute(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_rooted)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_rooted(path)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_na);
+ bool RETVAL;
+
+ RETVAL = sys_is_rooted(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_relative)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_relative(path)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_na);
+ bool RETVAL;
+
+ RETVAL = sys_is_relative(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_cwd)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: Cwd::sys_cwd()");
+ {
+ char p[MAXPATHLEN];
+ char * RETVAL;
+ RETVAL = _getcwd2(p, MAXPATHLEN);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_abspath)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ {
+ char * path = (char *)SvPV(ST(0),PL_na);
+ char * dir;
+ char p[MAXPATHLEN];
+ char * RETVAL;
+
+ if (items < 2)
+ dir = NULL;
+ else {
+ dir = (char *)SvPV(ST(1),PL_na);
+ }
+ if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
+ path += 2;
+ }
+ if (dir == NULL) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Absolute with drive: */
+ if ( sys_is_absolute(path) ) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (path[0] == '/' || path[0] == '\\') {
+ /* Rooted, but maybe on different drive. */
+ if (isALPHA(dir[0]) && dir[1] == ':' ) {
+ char p1[MAXPATHLEN];
+
+ /* Need to prepend the drive. */
+ p1[0] = dir[0];
+ p1[1] = dir[1];
+ Copy(path, p1 + 2, strlen(path) + 1, char);
+ RETVAL = p;
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Either path is relative, or starts with a drive letter. */
+ /* If the path starts with a drive letter, then dir is
+ relevant only if
+ a/b) it is absolute/x:relative on the same drive.
+ c) path is on current drive, and dir is rooted
+ In all the cases it is safe to drop the drive part
+ of the path. */
+ if ( !sys_is_relative(path) ) {
+ int is_drived;
+
+ if ( ( ( sys_is_absolute(dir)
+ || (isALPHA(dir[0]) && dir[1] == ':'
+ && strnicmp(dir, path,1) == 0))
+ && strnicmp(dir, path,1) == 0)
+ || ( !(isALPHA(dir[0]) && dir[1] == ':')
+ && toupper(path[0]) == current_drive())) {
+ path += 2;
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p; goto done;
+ } else {
+ RETVAL = NULL; goto done;
+ }
+ }
+ {
+ /* Need to prepend the absolute path of dir. */
+ char p1[MAXPATHLEN];
+
+ if (_abspath(p1, dir, MAXPATHLEN) == 0) {
+ int l = strlen(p1);
+
+ if (p1[ l - 1 ] != '/') {
+ p1[ l ] = '/';
+ l++;
+ }
+ Copy(path, p1 + l, strlen(path) + 1, char);
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ RETVAL = NULL;
+ }
+ }
+ done:
+ }
+ }
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+typedef APIRET (*PELP)(PSZ path, ULONG type);
+
+APIRET
+ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
+{
+ loadByOrd(ord); /* Guarantied to load or die! */
+ return (*(PELP)ExtFCN[ord])(path, type);
+}
+
+#define extLibpath(type) \
+ (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
+ : BEGIN_LIBPATH))) \
+ ? NULL : to )
+
+#define extLibpath_set(p,type) \
+ (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
+ : BEGIN_LIBPATH))))
+
+XS(XS_Cwd_extLibpath)
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ croak("Usage: Cwd::extLibpath(type = 0)");
+ {
+ bool type;
+ char to[1024];
+ U32 rc;
+ char * RETVAL;
+
+ if (items < 1)
+ type = 0;
+ else {
+ type = (int)SvIV(ST(0));
+ }
+
+ RETVAL = extLibpath(type);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_extLibpath_set)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ croak("Usage: Cwd::extLibpath_set(s, type = 0)");
+ {
+ char * s = (char *)SvPV(ST(0),PL_na);
+ bool type;
+ U32 rc;
+ bool RETVAL;
+
+ if (items < 2)
+ type = 0;
+ else {
+ type = (int)SvIV(ST(1));
+ }
+
+ RETVAL = extLibpath_set(s, type);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+int
+Xs_OS2_init()
+{
+ char *file = __FILE__;
+ {
+ GV *gv;
+
+ if (_emx_env & 0x200) { /* OS/2 */
+ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
+ newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
+ }
+ newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
+ newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
+ newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
+ newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
+ newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
+ newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
+ newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
+ newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
+ newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
+ gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+#ifdef PERL_IS_AOUT
+ sv_setiv(GvSV(gv), 1);
+#endif
+ }
+}
+
+OS2_Perl_data_t OS2_Perl_data;
+
+void
+Perl_OS2_init(char **env)
+{
+ char *shell;
+
+ MALLOC_INIT;
+ settmppath();
+ OS2_Perl_data.xs_init = &Xs_OS2_init;
+ if (environ == NULL) {
+ environ = env;
+ }
+ if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ New(1304, PL_sh_path, strlen(SH_PATH) + 1, char);
+ strcpy(PL_sh_path, SH_PATH);
+ PL_sh_path[0] = shell[0];
+ } else if ( (shell = getenv("PERL_SH_DIR")) ) {
+ int l = strlen(shell), i;
+ if (shell[l-1] == '/' || shell[l-1] == '\\') {
+ l--;
+ }
+ New(1304, PL_sh_path, l + 8, char);
+ strncpy(PL_sh_path, shell, l);
+ strcpy(PL_sh_path + l, "/sh.exe");
+ for (i = 0; i < l; i++) {
+ if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/';
+ }
+ }
+ MUTEX_INIT(&start_thread_mutex);
+ os2_mytype = my_type(); /* Do it before morphing. Needed? */
+}
+
+#undef tmpnam
+#undef tmpfile
+
+char *
+my_tmpnam (char *str)
+{
+ char *p = getenv("TMP"), *tpath;
+ int len;
+
+ if (!p) p = getenv("TEMP");
+ tpath = tempnam(p, "pltmp");
+ if (str && tpath) {
+ strcpy(str, tpath);
+ return str;
+ }
+ return tpath;
+}
+
+FILE *
+my_tmpfile ()
+{
+ struct stat s;
+
+ stat(".", &s);
+ if (s.st_mode & S_IWOTH) {
+ return tmpfile();
+ }
+ return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
+ grants TMP. */
+}
+
+#undef flock
+
+/* This code was contributed by Rocco Caputo. */
+int
+my_flock(int handle, int o)
+{
+ FILELOCK rNull, rFull;
+ ULONG timeout, handle_type, flag_word;
+ APIRET rc;
+ int blocking, shared;
+ static int use_my = -1;
+
+ if (use_my == -1) {
+ char *s = getenv("USE_PERL_FLOCK");
+ if (s)
+ use_my = atoi(s);
+ else
+ use_my = 1;
+ }
+ if (!(_emx_env & 0x200) || !use_my)
+ return flock(handle, o); /* Delegate to EMX. */
+
+ // is this a file?
+ if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
+ (handle_type & 0xFF))
+ {
+ errno = EBADF;
+ return -1;
+ }
+ // set lock/unlock ranges
+ rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
+ rFull.lRange = 0x7FFFFFFF;
+ // set timeout for blocking
+ timeout = ((blocking = !(o & LOCK_NB))) ? 100 : 1;
+ // shared or exclusive?
+ shared = (o & LOCK_SH) ? 1 : 0;
+ // do not block the unlock
+ if (o & (LOCK_UN | LOCK_SH | LOCK_EX)) {
+ rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ break; // not an error
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ // lock may block
+ if (o & (LOCK_SH | LOCK_EX)) {
+ // for blocking operations
+ for (;;) {
+ rc =
+ DosSetFileLocks(
+ handle,
+ &rNull,
+ &rFull,
+ timeout,
+ shared
+ );
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ if (!blocking) {
+ errno = EWOULDBLOCK;
+ return -1;
+ }
+ break;
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ // give away timeslice
+ DosSleep(1);
+ }
+ }
+
+ errno = 0;
+ return 0;