+int
+async_mssleep(ULONG ms, int switch_priority) {
+ /* This is similar to DosSleep(), but has 8ms granularity in time-critical
+ threads even on Warp3. */
+ HEV hevEvent1 = 0; /* Event semaphore handle */
+ HTIMER htimerEvent1 = 0; /* Timer handle */
+ APIRET rc = NO_ERROR; /* Return code */
+ int ret = 1;
+ ULONG priority = 0, nesting; /* Shut down the warnings */
+ PPIB pib;
+ PTIB tib;
+ char *e = NULL;
+ APIRET badrc;
+
+ if (!(_emx_env & 0x200)) /* DOS */
+ return !_sleep2(ms);
+
+ os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */
+ &hevEvent1, /* Handle of semaphore returned */
+ DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */
+ FALSE), /* Semaphore is in RESET state */
+ "DosCreateEventSem");
+
+ if (ms >= switch_priority)
+ switch_priority = 0;
+ if (switch_priority) {
+ if (CheckOSError(DosGetInfoBlocks(&tib, &pib)))
+ switch_priority = 0;
+ else {
+ /* In Warp3, to switch scheduling to 8ms step, one needs to do
+ DosAsyncTimer() in time-critical thread. On laters versions,
+ more and more cases of wait-for-something are covered.
+
+ It turns out that on Warp3fp42 it is the priority at the time
+ of DosAsyncTimer() which matters. Let's hope that this works
+ with later versions too... XXXX
+ */
+ priority = (tib->tib_ptib2->tib2_ulpri);
+ if ((priority & 0xFF00) == 0x0300) /* already time-critical */
+ switch_priority = 0;
+ /* Make us time-critical. Just modifying TIB is not enough... */
+ /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/
+ /* We do not want to run at high priority if a signal causes us
+ to longjmp() out of this section... */
+ if (DosEnterMustComplete(&nesting))
+ switch_priority = 0;
+ else
+ DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0);
+ }
+ }
+
+ if ((badrc = DosAsyncTimer(ms,
+ (HSEM) hevEvent1, /* Semaphore to post */
+ &htimerEvent1))) /* Timer handler (returned) */
+ e = "DosAsyncTimer";
+
+ if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) {
+ /* Nobody switched priority while we slept... Ignore errors... */
+ /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */
+ if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0)))
+ rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0);
+ }
+ if (switch_priority)
+ rc = DosExitMustComplete(&nesting); /* Ignore errors */
+
+ /* The actual blocking call is made with "normal" priority. This way we
+ should not bother with DosSleep(0) etc. to compensate for us interrupting
+ higher-priority threads. The goal is to prohibit the system spending too
+ much time halt()ing, not to run us "no matter what". */
+ if (!e) /* Wait for AsyncTimer event */
+ badrc = DosWaitEventSem(hevEvent1, SEM_INDEFINITE_WAIT);
+
+ if (e) ; /* Do nothing */
+ else if (badrc == ERROR_INTERRUPT)
+ ret = 0;
+ else if (badrc)
+ e = "DosWaitEventSem";
+ if ((rc = DosCloseEventSem(hevEvent1)) && !e) { /* Get rid of semaphore */
+ e = "DosCloseEventSem";
+ badrc = rc;
+ }
+ if (e)
+ os2cp_croak(badrc, e);
+ return ret;
+}
+
+XS(XS_OS2_ms_sleep) /* for testing only... */
+{
+ dXSARGS;
+ ULONG ms, lim;
+
+ if (items > 2 || items < 1)
+ Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])");
+ ms = SvUV(ST(0));
+ lim = items > 1 ? SvUV(ST(1)) : ms + 1;
+ async_mssleep(ms, lim);
+ XSRETURN_YES;
+}
+
+ULONG (*pDosTmrQueryFreq) (PULONG);
+ULONG (*pDosTmrQueryTime) (unsigned long long *);
+
+XS(XS_OS2_Timer)
+{
+ dXSARGS;
+ static ULONG freq;
+ unsigned long long count;
+ ULONG rc;
+
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::Timer()");
+ if (!freq) {
+ *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0);
+ *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0);
+ MUTEX_LOCK(&perlos2_state_mutex);
+ if (!freq)
+ if (CheckOSError(pDosTmrQueryFreq(&freq)))
+ croak_with_os2error("DosTmrQueryFreq");
+ MUTEX_UNLOCK(&perlos2_state_mutex);
+ }
+ if (CheckOSError(pDosTmrQueryTime(&count)))
+ croak_with_os2error("DosTmrQueryTime");
+ {
+ dXSTARG;
+
+ XSprePUSH; PUSHn(((NV)count)/freq);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2_msCounter)
+{
+ dXSARGS;
+
+ if (items != 0)
+ Perl_croak_nocontext("Usage: OS2::msCounter()");
+ {
+ dXSTARG;
+
+ XSprePUSH; PUSHu(msCounter());
+ }
+ XSRETURN(1);
+}
+
+XS(XS_OS2__InfoTable)
+{
+ dXSARGS;
+ int is_local = 0;
+
+ if (items > 1)
+ Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])");
+ if (items == 1)
+ is_local = (int)SvIV(ST(0));
+ {
+ dXSTARG;
+
+ XSprePUSH; PUSHu(InfoTable(is_local));
+ }
+ XSRETURN(1);
+}
+
+static const char * const dc_fields[] = {
+ "FAMILY",
+ "IO_CAPS",
+ "TECHNOLOGY",
+ "DRIVER_VERSION",
+ "WIDTH",
+ "HEIGHT",
+ "WIDTH_IN_CHARS",
+ "HEIGHT_IN_CHARS",
+ "HORIZONTAL_RESOLUTION",
+ "VERTICAL_RESOLUTION",
+ "CHAR_WIDTH",
+ "CHAR_HEIGHT",
+ "SMALL_CHAR_WIDTH",
+ "SMALL_CHAR_HEIGHT",
+ "COLORS",
+ "COLOR_PLANES",
+ "COLOR_BITCOUNT",
+ "COLOR_TABLE_SUPPORT",
+ "MOUSE_BUTTONS",
+ "FOREGROUND_MIX_SUPPORT",
+ "BACKGROUND_MIX_SUPPORT",
+ "VIO_LOADABLE_FONTS",
+ "WINDOW_BYTE_ALIGNMENT",
+ "BITMAP_FORMATS",
+ "RASTER_CAPS",
+ "MARKER_HEIGHT",
+ "MARKER_WIDTH",
+ "DEVICE_FONTS",
+ "GRAPHICS_SUBSET",
+ "GRAPHICS_VERSION",
+ "GRAPHICS_VECTOR_SUBSET",
+ "DEVICE_WINDOWING",
+ "ADDITIONAL_GRAPHICS",
+ "PHYS_COLORS",
+ "COLOR_INDEX",
+ "GRAPHICS_CHAR_WIDTH",
+ "GRAPHICS_CHAR_HEIGHT",
+ "HORIZONTAL_FONT_RES",
+ "VERTICAL_FONT_RES",
+ "DEVICE_FONT_SIM",
+ "LINEWIDTH_THICK",
+ "DEVICE_POLYSET_POINTS",
+};
+
+enum {
+ DevCap_dc, DevCap_hwnd
+};
+
+HDC (*pWinOpenWindowDC) (HWND hwnd);
+HMF (*pDevCloseDC) (HDC hdc);
+HDC (*pDevOpenDC) (HAB hab, LONG lType, PCSZ pszToken, LONG lCount,
+ PDEVOPENDATA pdopData, HDC hdcComp);
+BOOL (*pDevQueryCaps) (HDC hdc, LONG lStart, LONG lCount, PLONG alArray);
+
+
+XS(XS_OS2_DevCap)
+{
+ dXSARGS;
+ if (items > 2)
+ Perl_croak_nocontext("Usage: OS2::DevCap()");
+ {
+ /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */
+ LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1];
+ int i = 0, j = 0, how = DevCap_dc;
+ HDC hScreenDC;
+ DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L};
+ ULONG rc1 = NO_ERROR;
+ HWND hwnd;
+ static volatile int devcap_loaded;
+
+ if (!devcap_loaded) {
+ *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0);
+ *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0);
+ *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0);
+ *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0);
+ devcap_loaded = 1;
+ }
+
+ if (items >= 2)
+ how = SvIV(ST(1));
+ if (!items) { /* Get device contents from PM */
+ hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0,
+ (PDEVOPENDATA)&doStruc, NULLHANDLE);
+ if (CheckWinError(hScreenDC))
+ croak_with_os2error("DevOpenDC() failed");
+ } else if (how == DevCap_dc)
+ hScreenDC = (HDC)SvIV(ST(0));
+ else { /* DevCap_hwnd */
+ if (!Perl_hmq)
+ Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM");
+ hwnd = (HWND)SvIV(ST(0));
+ hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */
+ if (CheckWinError(hScreenDC))
+ croak_with_os2error("WinOpenWindowDC() failed");
+ }
+ if (CheckWinError(pDevQueryCaps(hScreenDC,
+ CAPS_FAMILY, /* W3 documented caps */
+ CAPS_DEVICE_POLYSET_POINTS
+ - CAPS_FAMILY + 1,
+ si)))
+ rc1 = Perl_rc;
+ else {
+ EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1));
+ while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) {
+ ST(j) = sv_newmortal();
+ sv_setpv(ST(j++), dc_fields[i]);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), si[i]);
+ i++;
+ }
+ i = CAPS_DEVICE_POLYSET_POINTS + 1;
+ while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */
+ LONG l;
+
+ if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l)))
+ break;
+ EXTEND(SP, j + 2);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), i);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), l);
+ i++;
+ }
+ }
+ if (!items && CheckWinError(pDevCloseDC(hScreenDC)))
+ Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc));
+ if (rc1)
+ Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed");
+ XSRETURN(j);
+ }
+}
+
+LONG (*pWinQuerySysValue) (HWND hwndDesktop, LONG iSysValue);
+BOOL (*pWinSetSysValue) (HWND hwndDesktop, LONG iSysValue, LONG lValue);
+
+const char * const sv_keys[] = {
+ "SWAPBUTTON",
+ "DBLCLKTIME",
+ "CXDBLCLK",
+ "CYDBLCLK",
+ "CXSIZEBORDER",
+ "CYSIZEBORDER",
+ "ALARM",
+ "7",
+ "8",
+ "CURSORRATE",
+ "FIRSTSCROLLRATE",
+ "SCROLLRATE",
+ "NUMBEREDLISTS",
+ "WARNINGFREQ",
+ "NOTEFREQ",
+ "ERRORFREQ",
+ "WARNINGDURATION",
+ "NOTEDURATION",
+ "ERRORDURATION",
+ "19",
+ "CXSCREEN",
+ "CYSCREEN",
+ "CXVSCROLL",
+ "CYHSCROLL",
+ "CYVSCROLLARROW",
+ "CXHSCROLLARROW",
+ "CXBORDER",
+ "CYBORDER",
+ "CXDLGFRAME",
+ "CYDLGFRAME",
+ "CYTITLEBAR",
+ "CYVSLIDER",
+ "CXHSLIDER",
+ "CXMINMAXBUTTON",
+ "CYMINMAXBUTTON",
+ "CYMENU",
+ "CXFULLSCREEN",
+ "CYFULLSCREEN",
+ "CXICON",
+ "CYICON",
+ "CXPOINTER",
+ "CYPOINTER",
+ "DEBUG",
+ "CPOINTERBUTTONS",
+ "POINTERLEVEL",
+ "CURSORLEVEL",
+ "TRACKRECTLEVEL",
+ "CTIMERS",
+ "MOUSEPRESENT",
+ "CXALIGN",
+ "CYALIGN",
+ "DESKTOPWORKAREAYTOP",
+ "DESKTOPWORKAREAYBOTTOM",
+ "DESKTOPWORKAREAXRIGHT",
+ "DESKTOPWORKAREAXLEFT",
+ "55",
+ "NOTRESERVED",
+ "EXTRAKEYBEEP",
+ "SETLIGHTS",
+ "INSERTMODE",
+ "60",
+ "61",
+ "62",
+ "63",
+ "MENUROLLDOWNDELAY",
+ "MENUROLLUPDELAY",
+ "ALTMNEMONIC",
+ "TASKLISTMOUSEACCESS",
+ "CXICONTEXTWIDTH",
+ "CICONTEXTLINES",
+ "CHORDTIME",
+ "CXCHORD",
+ "CYCHORD",
+ "CXMOTIONSTART",
+ "CYMOTIONSTART",
+ "BEGINDRAG",
+ "ENDDRAG",
+ "SINGLESELECT",
+ "OPEN",
+ "CONTEXTMENU",
+ "CONTEXTHELP",
+ "TEXTEDIT",
+ "BEGINSELECT",
+ "ENDSELECT",
+ "BEGINDRAGKB",
+ "ENDDRAGKB",
+ "SELECTKB",
+ "OPENKB",
+ "CONTEXTMENUKB",
+ "CONTEXTHELPKB",
+ "TEXTEDITKB",
+ "BEGINSELECTKB",
+ "ENDSELECTKB",
+ "ANIMATION",
+ "ANIMATIONSPEED",
+ "MONOICONS",
+ "KBDALTERED",
+ "PRINTSCREEN", /* 97, the last one on one of the DDK header */
+ "LOCKSTARTINPUT",
+ "DYNAMICDRAG",
+ "100",
+ "101",
+ "102",
+ "103",
+ "104",
+ "105",
+ "106",
+ "107",
+/* "CSYSVALUES",*/
+ /* In recent DDK the limit is 108 */
+};
+
+XS(XS_OS2_SysValues)
+{
+ dXSARGS;
+ if (items > 2)
+ Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)");
+ {
+ int i = 0, j = 0, which = -1;
+ HWND hwnd = HWND_DESKTOP;
+ static volatile int sv_loaded;
+ LONG RETVAL;
+
+ if (!sv_loaded) {
+ *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0);
+ sv_loaded = 1;
+ }
+
+ if (items == 2)
+ hwnd = (HWND)SvIV(ST(1));
+ if (items >= 1)
+ which = (int)SvIV(ST(0));
+ if (which == -1) {
+ EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys));
+ while (i < C_ARRAY_LENGTH(sv_keys)) {
+ ResetWinError();
+ RETVAL = pWinQuerySysValue(hwnd, i);
+ if ( !RETVAL
+ && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9'
+ && i <= SV_PRINTSCREEN) ) {
+ FillWinError;
+ if (Perl_rc) {
+ if (i > SV_PRINTSCREEN)
+ break; /* May be not present on older systems */
+ croak_with_os2error("SysValues():");
+ }
+
+ }
+ ST(j) = sv_newmortal();
+ sv_setpv(ST(j++), sv_keys[i]);
+ ST(j) = sv_newmortal();
+ sv_setiv(ST(j++), RETVAL);
+ i++;
+ }
+ XSRETURN(2 * i);
+ } else {
+ dXSTARG;
+
+ ResetWinError();
+ RETVAL = pWinQuerySysValue(hwnd, which);
+ if (!RETVAL) {
+ FillWinError;
+ if (Perl_rc)
+ croak_with_os2error("SysValues():");
+ }
+ XSprePUSH; PUSHi((IV)RETVAL);
+ }
+ }
+}
+
+XS(XS_OS2_SysValues_set)
+{
+ dXSARGS;
+ if (items < 2 || items > 3)
+ Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)");
+ {
+ int which = (int)SvIV(ST(0));
+ LONG val = (LONG)SvIV(ST(1));
+ HWND hwnd = HWND_DESKTOP;
+ static volatile int svs_loaded;
+
+ if (!svs_loaded) {
+ *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0);
+ svs_loaded = 1;
+ }
+
+ if (items == 3)
+ hwnd = (HWND)SvIV(ST(2));
+ if (CheckWinError(pWinSetSysValue(hwnd, which, val)))
+ croak_with_os2error("SysValues_set()");
+ }
+ XSRETURN_YES;
+}
+
+#define QSV_MAX_WARP3 QSV_MAX_COMP_LENGTH
+
+static const char * const si_fields[] = {