From: Ilya Zakharevich Date: Sun, 15 Nov 1998 20:25:50 +0000 (-0500) Subject: OS/2 events get closer to Perl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4bfbfac5c6d9a0ecc663cdd23fe31fc59ee7bab3;p=p5sagit%2Fp5-mst-13.2.git OS/2 events get closer to Perl Message-Id: <199811160125.UAA05268@monk.mps.ohio-state.edu> p4raw-id: //depot/perl@2340 --- diff --git a/os2/Changes b/os2/Changes index c9e0a29..dbd721f 100644 --- a/os2/Changes +++ b/os2/Changes @@ -212,3 +212,76 @@ after 5.005_02: 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. + diff --git a/os2/os2.c b/os2/os2.c index 008eda3..15a6392 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -180,9 +180,10 @@ static PFN ExtFCN[2]; /* Labeled by ord below. */ 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; @@ -191,15 +192,46 @@ loadByOrd(ULONG ord) 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. */ @@ -1009,7 +1041,7 @@ char *mode; int fork(void) { - die(PL_no_func, "Unsupported function fork"); + croak(PL_no_func, "Unsupported function fork"); errno = EINVAL; return -1; } @@ -1114,7 +1146,8 @@ sys_alloc(int size) { 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; } @@ -1273,7 +1306,7 @@ perllib_mangle(char *s, unsigned int l) } newl = strlen(newp); if (newl == 0 || oldl == 0) { - die("Malformed PERLLIB_PREFIX"); + croak("Malformed PERLLIB_PREFIX"); } strcpy(ret, newp); s = ret; @@ -1295,12 +1328,102 @@ perllib_mangle(char *s, unsigned int l) 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. */ @@ -1314,6 +1437,205 @@ 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; @@ -1535,7 +1857,7 @@ typedef APIRET (*PELP)(PSZ path, ULONG type); 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); } @@ -1608,6 +1930,14 @@ Xs_OS2_init() 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); @@ -1622,6 +1952,17 @@ Xs_OS2_init() #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); } } diff --git a/os2/os2.sym b/os2/os2.sym index 4bd97c9..7724e56 100644 --- a/os2/os2.sym +++ b/os2/os2.sym @@ -28,3 +28,10 @@ XS_Cwd_sys_is_relative XS_Cwd_sys_is_rooted XS_DynaLoader_mod2fname XS_File__Copy_syscopy +Perl_Register_MQ +Perl_Deregister_MQ +Perl_Serve_Messages +Perl_Process_Messages +init_PMWIN_entries +PMWIN_entries +Perl_hab_GET diff --git a/os2/os2ish.h b/os2/os2ish.h index 586f75b..20b2196 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -292,6 +292,10 @@ typedef struct OS2_Perl_data { 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; @@ -305,6 +309,42 @@ 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. */ @@ -319,11 +359,6 @@ extern OS2_Perl_data_t OS2_Perl_data; 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