#define SPU_DISABLESUPPRESSION 0
#define SPU_ENABLESUPPRESSION 1
#include <os2.h>
+#include "dlfcn.h"
#include <sys/uflags.h>
#include <process.h>
#include <fcntl.h>
+#define PERLIO_NOT_STDIO 0
+
#include "EXTERN.h"
#include "perl.h"
#define ORD_SET_ELP 1
struct PMWIN_entries_t PMWIN_entries;
+HMODULE
+loadModule(char *modname)
+{
+ HMODULE h = (HMODULE)dlopen(modname, 0);
+ if (!h)
+ Perl_croak_nocontext("Error loading module '%s': %s",
+ modname, dlerror());
+ return h;
+}
+
APIRET
loadByOrd(char *modname, ULONG ord)
{
if (ExtFCN[ord] == NULL) {
static HMODULE hdosc = 0;
- BYTE buf[20];
- PFN fcn;
+ PFN fcn = (PFN)-1;
APIRET rc;
- if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
- modname, &hdosc)))
- || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
- Perl_croak_nocontext("This version of OS/2 does not support %s.%i",
- modname, loadOrd[ord]);
+ if (!hdosc)
+ hdosc = loadModule(modname);
+ if (CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
+ Perl_croak_nocontext(
+ "This version of OS/2 does not support %s.%i",
+ modname, loadOrd[ord]);
ExtFCN[ord] = fcn;
}
if ((long)ExtFCN[ord] == -1)
918, /* PeekMsg */
915, /* GetMsg */
912, /* DispatchMsg */
+ 753, /* GetLastError */
+ 705, /* CancelShutdown */
};
BYTE buf[20];
int i = 0;
if (hpmwin)
return;
- if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
- Perl_croak_nocontext("This version of OS/2 does not support pmwin: error in %s", buf);
- while (i <= 5) {
+ hpmwin = loadModule("pmwin");
+ while (i < sizeof(ords)/sizeof(int)) {
if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
((PFN*)&PMWIN_entries)+i)))
Perl_croak_nocontext("This version of OS/2 does not support pmwin.%d", ords[i]);
static int
result(pTHX_ int flag, int pid)
{
- dTHR;
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
int
do_spawn_ve(pTHX_ SV *really, U32 flag, U32 execf, char *inicmd, U32 addflag)
{
- dTHR;
int trueflag = flag;
int rc, pass = 1;
char *tmps;
char *scr = find_script(PL_Argv[0], TRUE, NULL, 0);
if (scr) {
- FILE *file;
- char *s = 0, *s1;
+ PerlIO *file;
+ SSize_t rd;
+ char *s = 0, *s1, *s2;
int l;
l = strlen(scr);
Safefree(scr);
scr = scrbuf;
- file = fopen(scr, "r");
+ file = PerlIO_open(scr, "r");
PL_Argv[0] = scr;
if (!file)
goto panic_file;
- if (!fgets(buf, sizeof buf, file)) { /* Empty... */
+ rd = PerlIO_read(file, buf, sizeof buf-1);
+ buf[rd]='\0';
+ if ((s2 = strchr(buf, '\n')) != NULL) *++s2 = '\0';
+
+ if (!rd) { /* Empty... */
buf[0] = 0;
- fclose(file);
+ PerlIO_close(file);
/* Special case: maybe from -Zexe build, so
there is an executable around (contrary to
documentation, DosQueryAppType sometimes (?)
} else
goto longbuf;
}
- if (fclose(file) != 0) { /* Failure */
+ if (PerlIO_close(file) != 0) { /* Failure */
panic_file:
Perl_warner(aTHX_ WARN_EXEC, "Error reading \"%s\": %s",
scr, Strerror(errno));
int
do_spawn3(pTHX_ char *cmd, int execf, int flag)
{
- dTHR;
register char **a;
register char *s;
char flags[10];
int
os2_do_aspawn(pTHX_ SV *really, register SV **mark, register SV **sp)
{
- dTHR;
register char **a;
int rc;
int flag = P_WAIT, flag_set = 0;
int
os2_do_spawn(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_SPAWN, 0);
}
int
do_spawn_nowait(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_SPAWN_NOWAIT,0);
}
bool
Perl_do_exec(pTHX_ char *cmd)
{
- dTHR;
do_spawn3(aTHX_ cmd, EXECF_EXEC, 0);
return FALSE;
}
bool
os2exec(pTHX_ char *cmd)
{
- dTHR;
return do_spawn3(aTHX_ cmd, EXECF_TRUEEXEC, 0);
}
#endif
/*******************************************************************/
-/* not implemented in EMX 0.9a */
+/* not implemented in EMX 0.9d */
-void * ctermid(x) { return 0; }
+char * ctermid(char *s) { return 0; }
#ifdef MYTTYNAME /* was not in emx0.9a */
void * ttyname(x) { return 0; }
static void *
tcp0(char *name)
{
- static BYTE buf[20];
PFN fcn;
if (!(_emx_env & 0x200)) Perl_croak_nocontext("%s requires OS/2", name); /* Die if not OS/2. */
if (!htcp)
- DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
+ htcp = loadModule("tcp32dll");
if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
return (void *) ((void * (*)(void)) fcn) ();
return 0;
((void (*)(int)) fcn) (arg);
}
-void * gethostent() { return tcp0("GETHOSTENT"); }
-void * getnetent() { return tcp0("GETNETENT"); }
-void * getprotoent() { return tcp0("GETPROTOENT"); }
-void * getservent() { return tcp0("GETSERVENT"); }
+struct hostent * gethostent() { return tcp0("GETHOSTENT"); }
+struct netent * getnetent() { return tcp0("GETNETENT"); }
+struct protoent * getprotoent() { return tcp0("GETPROTOENT"); }
+struct servent * getservent() { return tcp0("GETSERVENT"); }
+
void sethostent(x) { tcp1("SETHOSTENT", x); }
void setnetent(x) { tcp1("SETNETENT", x); }
void setprotoent(x) { tcp1("SETPROTOENT", x); }
#ifdef USE_THREADS
sum++; /* Avoid conflict of DLLs in memory. */
#endif
- sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* */
+ /* We always load modules as *specific* DLLs, and with the full name.
+ When loading a specific DLL by its full name, one cannot get a
+ different DLL, even if a DLL with the same basename is loaded already.
+ Thus there is no need to include the version into the mangling scheme. */
+#if 0
+ sum += PERL_VERSION * 200 + PERL_SUBVERSION * 2; /* Up to 5.6.1 */
+#else
+# ifndef COMPATIBLE_VERSION_SUM /* Binary compatibility with the 5.00553 binary */
+# define COMPATIBLE_VERSION_SUM (5 * 200 + 53 * 2)
+# endif
+ sum += COMPATIBLE_VERSION_SUM;
+#endif
fname[pos] = 'A' + (sum % 26);
fname[pos + 1] = 'A' + (sum / 26 % 26);
fname[pos + 2] = '\0';
char *
os2_execname(pTHX)
{
- dTHR;
- char buf[300], *p;
+ char buf[300], *p, *o = PL_origargv[0], ok = 1;
if (_execname(buf, sizeof buf) != 0)
- return PL_origargv[0];
+ return o;
p = buf;
while (*p) {
if (*p == '\\')
*p = '/';
+ if (*p == '/') {
+ if (ok && *o != '/' && *o != '\\')
+ ok = 0;
+ } else if (ok && tolower(*o) != tolower(*p))
+ ok = 0;
p++;
+ o++;
+ }
+ if (ok) { /* PL_origargv[0] matches the real name. Use PL_origargv[0]: */
+ strcpy(buf, PL_origargv[0]); /* _execname() is always uppercased */
+ p = buf;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
}
p = savepv(buf);
SAVEFREEPV(p);
return Perl_hmq;
DosGetInfoBlocks(&tib, &pib);
Perl_os2_initial_mode = pib->pib_ultype;
- Perl_hmq_refcnt = 1;
/* Try morphing into a PM application. */
if (pib->pib_ultype != 3) /* 2 is VIO */
pib->pib_ultype = 3; /* 3 is PM */
Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
if (!Perl_hmq) {
static int cnt;
+
+ SAVEINT(cnt); /* Allow catch()ing. */
if (cnt++)
_exit(188); /* Panic can try to create a window. */
Perl_croak_nocontext("Cannot create a message queue, or morph to a PM application");
}
+ if (serve) {
+ if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */
+ && Perl_hmq_refcnt > 0 ) /* this was switched off before... */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0);
+ Perl_hmq_servers++;
+ } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
+ Perl_hmq_refcnt++;
return Perl_hmq;
}
int cnt = 0;
QMSG msg;
- if (Perl_hmq_servers && !force)
+ if (Perl_hmq_servers > 0 && !force)
return 0;
- if (!Perl_hmq_refcnt)
+ if (Perl_hmq_refcnt <= 0)
Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
cnt++;
{
QMSG msg;
- if (Perl_hmq_servers && !force)
+ if (Perl_hmq_servers > 0 && !force)
return 0;
- if (!Perl_hmq_refcnt)
+ if (Perl_hmq_refcnt <= 0)
Perl_croak_nocontext("No message queue");
while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
if (cntp)
PPIB pib;
PTIB tib;
- if (--Perl_hmq_refcnt == 0) {
+ if (serve)
+ Perl_hmq_servers--;
+ if (--Perl_hmq_refcnt <= 0) {
+ init_PMWIN_entries(); /* To be extra safe */
(*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
Perl_hmq = 0;
/* Try morphing back from a PM application. */
+ DosGetInfoBlocks(&tib, &pib);
if (pib->pib_ultype == 3) /* 3 is PM */
pib->pib_ultype = Perl_os2_initial_mode;
else
Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM",
pib->pib_ultype);
- }
+ } else if (serve && Perl_hmq_servers <= 0) /* Last server exited */
+ (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1);
}
-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
}
typedef APIRET (*PELP)(PSZ path, ULONG type);
+/* Kernels after 2000/09/15 understand this too: */
+#ifndef LIBPATHSTRICT
+# define LIBPATHSTRICT 3
+#endif
+
APIRET
-ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
+ExtLIBPATH(ULONG ord, PSZ path, IV type)
{
+ ULONG what;
+
loadByOrd("doscalls",ord); /* Guarantied to load or die! */
- return (*(PELP)ExtFCN[ord])(path, type);
+ if (type > 0)
+ what = END_LIBPATH;
+ else if (type == 0)
+ what = BEGIN_LIBPATH;
+ else
+ what = LIBPATHSTRICT;
+ return (*(PELP)ExtFCN[ord])(path, what);
}
-#define extLibpath(type) \
- (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))) \
- ? NULL : to )
+#define extLibpath(to,type) \
+ (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, (to), (type))) ? NULL : (to) )
#define extLibpath_set(p,type) \
- (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
- : BEGIN_LIBPATH))))
+ (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), (type))))
XS(XS_Cwd_extLibpath)
{
if (items < 0 || items > 1)
Perl_croak_nocontext("Usage: Cwd::extLibpath(type = 0)");
{
- bool type;
+ IV type;
char to[1024];
U32 rc;
char * RETVAL;
if (items < 1)
type = 0;
else {
- type = (int)SvIV(ST(0));
+ type = SvIV(ST(0));
}
- RETVAL = extLibpath(type);
+ to[0] = 1; to[1] = 0; /* Sometimes no error reported */
+ RETVAL = extLibpath(to, type);
+ if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0)
+ Perl_croak_nocontext("panic Cwd::extLibpath parameter");
ST(0) = sv_newmortal();
sv_setpv((SV*)ST(0), RETVAL);
}
{
STRLEN n_a;
char * s = (char *)SvPV(ST(0),n_a);
- bool type;
+ IV type;
U32 rc;
bool RETVAL;
if (items < 2)
type = 0;
else {
- type = (int)SvIV(ST(1));
+ type = SvIV(ST(1));
}
RETVAL = extLibpath_set(s, type);
XSRETURN(1);
}
+#define get_control87() _control87(0,0)
+#define set_control87 _control87
+
+XS(XS_OS2__control87)
+{
+ dXSARGS;
+ if (items != 2)
+ croak("Usage: OS2::_control87(new,mask)");
+ {
+ unsigned new = (unsigned)SvIV(ST(0));
+ unsigned mask = (unsigned)SvIV(ST(1));
+ unsigned RETVAL;
+
+ RETVAL = _control87(new, mask);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_get_control87)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: OS2::get_control87()");
+ {
+ unsigned RETVAL;
+
+ RETVAL = get_control87();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
+
+XS(XS_OS2_set_control87)
+{
+ dXSARGS;
+ if (items < 0 || items > 2)
+ croak("Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)");
+ {
+ unsigned new;
+ unsigned mask;
+ unsigned RETVAL;
+
+ if (items < 1)
+ new = MCW_EM;
+ else {
+ new = (unsigned)SvIV(ST(0));
+ }
+
+ if (items < 2)
+ mask = MCW_EM;
+ else {
+ mask = (unsigned)SvIV(ST(1));
+ }
+
+ RETVAL = set_control87(new, mask);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (IV)RETVAL);
+ }
+ XSRETURN(1);
+}
+
int
Xs_OS2_init(pTHX)
{
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);
+ newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
+ newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
+ newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
}
MUTEX_INIT(&start_thread_mutex);
os2_mytype = my_type(); /* Do it before morphing. Needed? */
+ /* Some DLLs reset FP flags on load. We may have been linked with them */
+ _control87(MCW_EM, MCW_EM);
}
#undef tmpnam
grants TMP. */
}
+#undef rmdir
+
+int
+my_rmdir (__const__ char *s)
+{
+ char buf[MAXPATHLEN];
+ STRLEN l = strlen(s);
+
+ if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX rmdir fails... */
+ strcpy(buf,s);
+ buf[l - 1] = 0;
+ s = buf;
+ }
+ return rmdir(s);
+}
+
+#undef mkdir
+
+int
+my_mkdir (__const__ char *s, long perm)
+{
+ char buf[MAXPATHLEN];
+ STRLEN l = strlen(s);
+
+ if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */
+ strcpy(buf,s);
+ buf[l - 1] = 0;
+ s = buf;
+ }
+ return mkdir(s, perm);
+}
+
#undef flock
/* This code was contributed by Rocco Caputo. */
projects / p5sagit/p5-mst-13.2.git / blobdiff