extension-full-name and Perl-version mangling work in the
same set ot 576 possible keys, this may lead to clashes).
$^E was reset on the second read, and contained ".\r\n" at the end.
+
+after 5.005_53:
+ warning-test for getpriority() might lock the system hard on
+ pre-fixpak22 configuration (calling getpriority() on
+ non-existing process triggers a system-wide bug).
+
+ Variable $OS2::emx_rev implemented (string and numberic values
+ are the same as C variables _emx_rev and _emx_vprt).
+ Variable $OS2::emx_env implemented (same as C variable _emx_env).
+ Variable $OS2::os_ver implemented (_osmajor + 0.001 * _osminor).
+
+ Improved centralized management of HAB and HMQ. To get Perl's
+ HAB, call perl_hab_GET(). (After the initial call one
+ can use Perl_hab instead.) To require Perl's HMQ,
+ call perl_hmq_GET(), to release it call perl_hmq_UNSET(),
+ to obtain it between these calls use Perl_hmq.
+ HMQ management is refcounted, and the program will morph
+ itself into/from PM if required.
+ If perl.h cannot be included, hab may be obtained by Perl_hab_GET().
+
+ New function OS2::Error(do_harderror,do_exception). Returns
+ undef if it was not called yet, otherwise bit 1 is
+ set if on previous call do_harderror was enabled, bit
+ 2 is set if if on previous call do_exception was enabled.
+ This function enables/disables error popups associated with
+ hardware errors (Disk not ready etc.) and software exceptions.
+
+ New function OS2::Errors2Drive(drive). Returns undef if it was
+ not called yet, otherwise return false if Errors were
+ not requested to be written to a hard drive, or the
+ drive letter if this was requested.
+ This function may redirect error popups associated with
+ hardware errors (Disk not ready etc.) and software exceptions
+ to the file POPUPLOG.OS2 at the root directory of the
+ specified drive. Overrides OS2::Error() specified by
+ individual programs. Given argument undef will
+ disable redirection. Has global effect, persists
+ after the application exits.
+
+ New function OS2::SysInfo(). Returns a hash with system information.
+ The keys of the hash are
+
+ MAX_PATH_LENGTH, MAX_TEXT_SESSIONS, MAX_PM_SESSIONS,
+ MAX_VDM_SESSIONS, BOOT_DRIVE, DYN_PRI_VARIATION,
+ MAX_WAIT, MIN_SLICE, MAX_SLICE, PAGE_SIZE,
+ VERSION_MAJOR, VERSION_MINOR, VERSION_REVISION,
+ MS_COUNT, TIME_LOW, TIME_HIGH, TOTPHYSMEM, TOTRESMEM,
+ TOTAVAILMEM, MAXPRMEM, MAXSHMEM, TIMER_INTERVAL,
+ MAX_COMP_LENGTH, FOREGROUND_FS_SESSION,
+ FOREGROUND_PROCESS
+
+ New function OS2::BootDrive(force). Returns a letter without colon.
+
+ New functions OS2::MorphPM(serve)/OS2::UnMorphPM(serve). Transforms
+ the current application into a PM application and back.
+ The argument true means that a real message loop is
+ going to be performed.
+ OS2::MorphPM() returns the PM message queue handle as an integer.
+
+ New function OS2::Serve_Messages(force). Fake on-demand
+ retrieval of outstanding PM messages. If force is false,
+ will not dispatch messages if a real message loop is known to
+ be present. Returns number of messages retrieved.
+ Dies with "QUITing..." if WM_QUIT message is obtained.
+
+ New function OS2::Process_Messages(force [, cnt]). Retrieval
+ of PM messages until window creation/destruction.
+ If force is false, will not dispatch messages
+ if a real message loop is known to be present.
+ Returns change in number of windows. If cnt is given,
+ it is incremented by the number of messages retrieved.
+ Dies with "QUITing..." if WM_QUIT message is obtained.
+
static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
#define ORD_QUERY_ELP 0
#define ORD_SET_ELP 1
+struct PMWIN_entries_t PMWIN_entries;
APIRET
-loadByOrd(ULONG ord)
+loadByOrd(char *modname, ULONG ord)
{
if (ExtFCN[ord] == NULL) {
static HMODULE hdosc = 0;
APIRET rc;
if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
- "doscalls", &hdosc)))
+ modname, &hdosc)))
|| CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
- die("This version of OS/2 does not support doscalls.%i",
- loadOrd[ord]);
+ croak("This version of OS/2 does not support %s.%i",
+ modname, loadOrd[ord]);
ExtFCN[ord] = fcn;
}
- if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
+ if ((long)ExtFCN[ord] == -1)
+ croak("panic queryaddr");
}
+void
+init_PMWIN_entries(void)
+{
+ static HMODULE hpmwin = 0;
+ static const int ords[] = {
+ 763, /* Initialize */
+ 716, /* CreateMsgQueue */
+ 726, /* DestroyMsgQueue */
+ 918, /* PeekMsg */
+ 915, /* GetMsg */
+ 912, /* DispatchMsg */
+ };
+ BYTE buf[20];
+ int i = 0;
+ unsigned long rc;
+
+ if (hpmwin)
+ return;
+
+ if (CheckOSError(DosLoadModule(buf, sizeof buf, "pmwin", &hpmwin)))
+ croak("This version of OS/2 does not support pmwin: error in %s", buf);
+ while (i <= 5) {
+ if (CheckOSError(DosQueryProcAddr(hpmwin, ords[i], NULL,
+ ((PFN*)&PMWIN_entries)+i)))
+ croak("This version of OS/2 does not support pmwin.%d", ords[i]);
+ i++;
+ }
+}
+
+
/* priorities */
static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
self inverse. */
int
fork(void)
{
- die(PL_no_func, "Unsupported function fork");
+ croak(PL_no_func, "Unsupported function fork");
errno = EINVAL;
return -1;
}
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
- } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
+ } else if ( rc )
+ croak("Got an error from DosAllocMem: %li", (long)rc);
return got;
}
}
newl = strlen(newp);
if (newl == 0 || oldl == 0) {
- die("Malformed PERLLIB_PREFIX");
+ croak("Malformed PERLLIB_PREFIX");
}
strcpy(ret, newp);
s = ret;
return s;
}
if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
- die("Malformed PERLLIB_PREFIX");
+ croak("Malformed PERLLIB_PREFIX");
}
strcpy(ret + newl, s + oldl);
return ret;
}
+unsigned long
+Perl_hab_GET() /* Needed if perl.h cannot be included */
+{
+ return perl_hab_GET();
+}
+
+HMQ
+Perl_Register_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ if (Perl_os2_initial_mode++)
+ 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 */
+ init_PMWIN_entries();
+ /* 64 messages if before OS/2 3.0, ignored otherwise */
+ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64);
+ if (!Perl_hmq) {
+ static int cnt;
+ if (cnt++)
+ _exit(188); /* Panic can try to create a window. */
+ croak("Cannot create a message queue, or morph to a PM application");
+ }
+ return Perl_hmq;
+}
+
+int
+Perl_Serve_Messages(int force)
+{
+ int cnt = 0;
+ QMSG msg;
+
+ if (Perl_hmq_servers && !force)
+ return 0;
+ if (!Perl_hmq_refcnt)
+ croak("No message queue");
+ while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) {
+ cnt++;
+ if (msg.msg == WM_QUIT)
+ croak("QUITing...");
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ }
+ return cnt;
+}
+
+int
+Perl_Process_Messages(int force, I32 *cntp)
+{
+ QMSG msg;
+
+ if (Perl_hmq_servers && !force)
+ return 0;
+ if (!Perl_hmq_refcnt)
+ croak("No message queue");
+ while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) {
+ if (cntp)
+ (*cntp)++;
+ (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg);
+ if (msg.msg == WM_DESTROY)
+ return -1;
+ if (msg.msg == WM_CREATE)
+ return +1;
+ }
+ croak("QUITing...");
+}
+
+void
+Perl_Deregister_MQ(int serve)
+{
+ PPIB pib;
+ PTIB tib;
+
+ if (--Perl_hmq_refcnt == 0) {
+ (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq);
+ Perl_hmq = 0;
+ /* Try morphing back from a PM application. */
+ if (pib->pib_ultype == 3) /* 3 is PM */
+ pib->pib_ultype = Perl_os2_initial_mode;
+ else
+ warn("Unexpected program mode %d when morphing back from PM",
+ pib->pib_ultype);
+ }
+}
+
extern void dlopen();
void *fakedl = &dlopen; /* Pull in dynaloading part. */
#define sys_chdir(p) (chdir(p) == 0)
#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
+static int DOS_harderr_state = -1;
+
+XS(XS_OS2_Error)
+{
+ dXSARGS;
+ if (items != 2)
+ croak("Usage: OS2::Error(harderr, exception)");
+ {
+ int arg1 = SvIV(ST(0));
+ int arg2 = SvIV(ST(1));
+ int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR)
+ | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION));
+ int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0));
+ unsigned long rc;
+
+ if (CheckOSError(DosError(a)))
+ croak("DosError(%d) failed", a);
+ ST(0) = sv_newmortal();
+ if (DOS_harderr_state >= 0)
+ sv_setiv(ST(0), DOS_harderr_state);
+ DOS_harderr_state = RETVAL;
+ }
+ XSRETURN(1);
+}
+
+static signed char DOS_suppression_state = -1;
+
+XS(XS_OS2_Errors2Drive)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: OS2::Errors2Drive(drive)");
+ {
+ SV *sv = ST(0);
+ int suppress = SvOK(sv);
+ char *s = suppress ? SvPV(sv, PL_na) : NULL;
+ char drive = (s ? *s : 0);
+ unsigned long rc;
+
+ if (suppress && !isALPHA(drive))
+ croak("Non-char argument '%c' to OS2::Errors2Drive()", drive);
+ if (CheckOSError(DosSuppressPopUps((suppress
+ ? SPU_ENABLESUPPRESSION
+ : SPU_DISABLESUPPRESSION),
+ drive)))
+ croak("DosSuppressPopUps(%c) failed", drive);
+ ST(0) = sv_newmortal();
+ if (DOS_suppression_state > 0)
+ sv_setpvn(ST(0), &DOS_suppression_state, 1);
+ else if (DOS_suppression_state == 0)
+ sv_setpvn(ST(0), "", 0);
+ DOS_suppression_state = drive;
+ }
+ XSRETURN(1);
+}
+
+static const char * const si_fields[QSV_MAX] = {
+ "MAX_PATH_LENGTH",
+ "MAX_TEXT_SESSIONS",
+ "MAX_PM_SESSIONS",
+ "MAX_VDM_SESSIONS",
+ "BOOT_DRIVE",
+ "DYN_PRI_VARIATION",
+ "MAX_WAIT",
+ "MIN_SLICE",
+ "MAX_SLICE",
+ "PAGE_SIZE",
+ "VERSION_MAJOR",
+ "VERSION_MINOR",
+ "VERSION_REVISION",
+ "MS_COUNT",
+ "TIME_LOW",
+ "TIME_HIGH",
+ "TOTPHYSMEM",
+ "TOTRESMEM",
+ "TOTAVAILMEM",
+ "MAXPRMEM",
+ "MAXSHMEM",
+ "TIMER_INTERVAL",
+ "MAX_COMP_LENGTH",
+ "FOREGROUND_FS_SESSION",
+ "FOREGROUND_PROCESS"
+};
+
+XS(XS_OS2_SysInfo)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: OS2::SysInfo()");
+ {
+ ULONG si[QSV_MAX] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ int i = 0, j = 0;
+
+ if (CheckOSError(DosQuerySysInfo(1L, /* Request all available system */
+ QSV_MAX, /* information */
+ (PVOID)si,
+ sizeof(si))))
+ croak("DosQuerySysInfo() failed");
+ EXTEND(SP,2*QSV_MAX);
+ while (i < QSV_MAX) {
+ ST(j) = sv_newmortal();
+ sv_setpv(ST(j++), si_fields[i]);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), si[i]);
+ i++;
+ }
+ }
+ XSRETURN(2 * QSV_MAX);
+}
+
+XS(XS_OS2_BootDrive)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: OS2::BootDrive()");
+ {
+ ULONG si[1] = {0}; /* System Information Data Buffer */
+ APIRET rc = NO_ERROR; /* Return code */
+ char c;
+
+ if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE,
+ (PVOID)si, sizeof(si))))
+ croak("DosQuerySysInfo() failed");
+ ST(0) = sv_newmortal();
+ c = 'a' - 1 + si[0];
+ sv_setpvn(ST(0), &c, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_MorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: OS2::MorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+ unsigned long pmq = perl_hmq_GET(serve);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), pmq);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_UnMorphPM)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: OS2::UnMorphPM(serve)");
+ {
+ bool serve = SvOK(ST(0));
+
+ perl_hmq_UNSET(serve);
+ }
+ XSRETURN(0);
+}
+
+XS(XS_OS2_Serve_Messages)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: OS2::Serve_Messages(force)");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt = Perl_Serve_Messages(force);
+
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), cnt);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_Process_Messages)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ croak("Usage: OS2::Process_Messages(force [, cnt])");
+ {
+ bool force = SvOK(ST(0));
+ unsigned long cnt;
+ I32 *cntp = NULL;
+
+ if (items == 2) {
+ SV *sv = ST(1);
+ int fake = SvIV(sv); /* Force SvIVX */
+
+ if (!SvIOK(sv))
+ croak("Can't upgrade count to IV");
+ cntp = &SvIVX(sv);
+ }
+ cnt = Perl_Process_Messages(force, cntp);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), cnt);
+ }
+ XSRETURN(1);
+}
+
XS(XS_Cwd_current_drive)
{
dXSARGS;
APIRET
ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
{
- loadByOrd(ord); /* Guarantied to load or die! */
+ loadByOrd("doscalls",ord); /* Guarantied to load or die! */
return (*(PELP)ExtFCN[ord])(path, type);
}
newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
}
+ newXS("OS2::Error", XS_OS2_Error, file);
+ newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file);
+ newXS("OS2::SysInfo", XS_OS2_SysInfo, file);
+ newXS("OS2::BootDrive", XS_OS2_BootDrive, file);
+ newXS("OS2::MorphPM", XS_OS2_MorphPM, file);
+ newXS("OS2::UnMorphPM", XS_OS2_UnMorphPM, file);
+ newXS("OS2::Serve_Messages", XS_OS2_Serve_Messages, file);
+ newXS("OS2::Process_Messages", XS_OS2_Process_Messages, 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);
#ifdef PERL_IS_AOUT
sv_setiv(GvSV(gv), 1);
#endif
+ gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_rev);
+ sv_setpv(GvSV(gv), _emx_vprt);
+ SvIOK_on(GvSV(gv));
+ gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), _emx_env);
+ gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor);
}
}
int (*xs_init)();
unsigned long rc;
unsigned long severity;
+ unsigned long phmq; /* Handle to message queue */
+ unsigned long phmq_refcnt;
+ unsigned long phmq_servers;
+ unsigned long initial_mode; /* VIO etc. mode we were started in */
} OS2_Perl_data_t;
extern OS2_Perl_data_t OS2_Perl_data;
#define Perl_HAB_set (OS2_Perl_flags & Perl_HAB_set_f)
#define set_Perl_HAB_f (OS2_Perl_flags |= Perl_HAB_set_f)
#define set_Perl_HAB(h) (set_Perl_HAB_f, Perl_hab = h)
+#define _obtain_Perl_HAB (init_PMWIN_entries(), \
+ Perl_hab = (*PMWIN_entries.Initialize)(0), \
+ set_Perl_HAB_f, Perl_hab)
+#define perl_hab_GET() (Perl_HAB_set ? Perl_hab : _obtain_Perl_HAB)
+#define Acquire_hab() perl_hab_GET()
+#define Perl_hmq ((HMQ)OS2_Perl_data.phmq)
+#define Perl_hmq_refcnt (OS2_Perl_data.phmq_refcnt)
+#define Perl_hmq_servers (OS2_Perl_data.phmq_servers)
+#define Perl_os2_initial_mode (OS2_Perl_data.initial_mode)
+
+unsigned long Perl_hab_GET();
+unsigned long Perl_Register_MQ(int serve);
+void Perl_Deregister_MQ(int serve);
+int Perl_Serve_Messages(int force);
+/* Cannot prototype with I32 at this point. */
+int Perl_Process_Messages(int force, long *cntp);
+
+struct _QMSG;
+struct PMWIN_entries_t {
+ unsigned long (*Initialize)( unsigned long fsOptions );
+ unsigned long (*CreateMsgQueue)(unsigned long hab, long cmsg);
+ int (*DestroyMsgQueue)(unsigned long hmq);
+ int (*PeekMsg)(unsigned long hab, struct _QMSG *pqmsg,
+ unsigned long hwndFilter, unsigned long msgFilterFirst,
+ unsigned long msgFilterLast, unsigned long fl);
+ int (*GetMsg)(unsigned long hab, struct _QMSG *pqmsg,
+ unsigned long hwndFilter, unsigned long msgFilterFirst,
+ unsigned long msgFilterLast);
+ void * (*DispatchMsg)(unsigned long hab, struct _QMSG *pqmsg);
+};
+extern struct PMWIN_entries_t PMWIN_entries;
+void init_PMWIN_entries(void);
+
+#define perl_hmq_GET(serve) Perl_Register_MQ(serve);
+#define perl_hmq_UNSET(serve) Perl_Deregister_MQ(serve);
+
#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
/* The expressions below return true on error. */
/* INCL_DOSERRORS needed. rc should be declared outside. */
errno = errno_isOS2, \
Perl_severity = ERRORIDSEV(Perl_rc), \
Perl_rc = ERRORIDERROR(Perl_rc))
-#define Acquire_hab() if (!Perl_HAB_set) { \
- Perl_hab = WinInitialize(0); \
- if (!Perl_hab) die("WinInitialize failed"); \
- set_Perl_HAB_f; \
- }
#define STATIC_FILE_LENGTH 127
projects / p5sagit/p5-mst-13.2.git / commitdiff