This is a patch to add ualarm capability for older VMS systems (pre 7.0)
that lack it. It is implemented with standard VMS system calls, and
so is likely (although unverified) that it will work on VMS systems
back to version 4 or 3.
diff -uBb ext/Time/HiRes/HiRes.xs-orig ext/Time/HiRes/HiRes.xs
--- ext/Time/HiRes/HiRes.xs-orig Sat Oct 27 01:07:43 2001
+++ ext/Time/HiRes/HiRes.xs Sat Oct 27 01:07:35 2001
@@ -324,6 +324,205 @@
}
#endif
+#if !defined(HAS_UALARM) && defined(VMS)
+#define HAS_UALARM
+#define ualarm vms_ualarm
+
+#include <lib$routines.h>
+#include <ssdef.h>
+#include <starlet.h>
+#include <descrip.h>
+#include <signal.h>
+#include <jpidef.h>
+#include <psldef.h>
+
+#define VMSERR(s) (!((s)&1))
+
+static void
+us_to_VMS(useconds_t mseconds, unsigned long v[])
+{
+ int iss;
+ unsigned long qq[2];
+
+ qq[0] = mseconds;
+ qq[1] = 0;
+ v[0] = v[1] = 0;
+
+ iss = lib$addx(qq,qq,qq);
+ if (VMSERR(iss)) lib$signal(iss);
+ iss = lib$subx(v,qq,v);
+ if (VMSERR(iss)) lib$signal(iss);
+ iss = lib$addx(qq,qq,qq);
+ if (VMSERR(iss)) lib$signal(iss);
+ iss = lib$subx(v,qq,v);
+ if (VMSERR(iss)) lib$signal(iss);
+ iss = lib$subx(v,qq,v);
+ if (VMSERR(iss)) lib$signal(iss);
+}
+
+static int
+VMS_to_us(unsigned long v[])
+{
+ int iss;
+ unsigned long div=10,quot, rem;
+
+ iss = lib$ediv(&div,v,",&rem);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ return quot;
+}
+
+typedef unsigned short word;
+typedef struct _ualarm {
+ int function;
+ int repeat;
+ unsigned long delay[2];
+ unsigned long interval[2];
+ unsigned long remain[2];
+} Alarm;
+
+
+static int alarm_ef;
+static Alarm *a0, alarm_base;
+#define UAL_NULL 0
+#define UAL_SET 1
+#define UAL_CLEAR 2
+#define UAL_ACTIVE 4
+static void ualarm_AST(Alarm *a);
+
+static int
+vms_ualarm(int mseconds, int interval)
+{
+ Alarm *a, abase;
+ struct item_list3 {
+ word length;
+ word code;
+ void *bufaddr;
+ void *retlenaddr;
+ } ;
+ static struct item_list3 itmlst[2];
+ static int first = 1;
+ unsigned long asten;
+ int iss, enabled;
+
+ if (first) {
+ first = 0;
+ itmlst[0].code = JPI$_ASTEN;
+ itmlst[0].length = sizeof(asten);
+ itmlst[0].retlenaddr = NULL;
+ itmlst[1].code = 0;
+ itmlst[1].length = 0;
+ itmlst[1].bufaddr = NULL;
+ itmlst[1].retlenaddr = NULL;
+
+ iss = lib$get_ef(&alarm_ef);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ a0 = &alarm_base;
+ a0->function = UAL_NULL;
+ }
+ itmlst[0].bufaddr = &asten;
+
+ iss = sys$getjpiw(0,0,0,itmlst,0,0,0);
+ if (VMSERR(iss)) lib$signal(iss);
+ if (!(asten&0x08)) return -1;
+
+ a = &abase;
+ if (mseconds) {
+ a->function = UAL_SET;
+ } else {
+ a->function = UAL_CLEAR;
+ }
+
+ us_to_VMS(mseconds, a->delay);
+ if (interval) {
+ us_to_VMS(interval, a->interval);
+ a->repeat = 1;
+ } else
+ a->repeat = 0;
+
+ iss = sys$clref(alarm_ef);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ iss = sys$dclast(ualarm_AST,a,0);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ iss = sys$waitfr(alarm_ef);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ if (a->function == UAL_ACTIVE)
+ return VMS_to_us(a->remain);
+ else
+ return 0;
+}
+
+
+
+static void
+ualarm_AST(Alarm *a)
+{
+ int iss;
+ unsigned long now[2];
+
+ iss = sys$gettim(now);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ if (a->function == UAL_SET || a->function == UAL_CLEAR) {
+ if (a0->function == UAL_ACTIVE) {
+ iss = sys$cantim(a0,PSL$C_USER);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ iss = lib$subx(a0->remain, now, a->remain);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ if (a->remain[1] & 0x80000000)
+ a->remain[0] = a->remain[1] = 0;
+ }
+
+ if (a->function == UAL_SET) {
+ a->function = a0->function;
+ a0->function = UAL_ACTIVE;
+ a0->repeat = a->repeat;
+ if (a0->repeat) {
+ a0->interval[0] = a->interval[0];
+ a0->interval[1] = a->interval[1];
+ }
+ a0->delay[0] = a->delay[0];
+ a0->delay[1] = a->delay[1];
+
+ iss = lib$subx(now, a0->delay, a0->remain);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ iss = sys$setimr(0,a0->delay,ualarm_AST,a0);
+ if (VMSERR(iss)) lib$signal(iss);
+ } else {
+ a->function = a0->function;
+ a0->function = UAL_NULL;
+ }
+ iss = sys$setef(alarm_ef);
+ if (VMSERR(iss)) lib$signal(iss);
+ } else if (a->function == UAL_ACTIVE) {
+ if (a->repeat) {
+ iss = lib$subx(now, a->interval, a->remain);
+ if (VMSERR(iss)) lib$signal(iss);
+
+ iss = sys$setimr(0,a->interval,ualarm_AST,a);
+ if (VMSERR(iss)) lib$signal(iss);
+ } else {
+ a->function = UAL_NULL;
+ }
+ iss = sys$wake(0,0);
+ if (VMSERR(iss)) lib$signal(iss);
+ lib$signal(SS$_ASTFLT);
+ } else {
+ lib$signal(SS$_BADPARAM);
+ }
+}
+
+#endif /* !HAS_UALARM && VMS */
+
+
+
#ifdef HAS_GETTIMEOFDAY
static int
--
Drexel University \V --Chuck Lane
======]---------->--------*------------<-------[===========
(215) 895-1545 _/ \ Particle Physics
FAX: (215) 895-5934 /\ /~~~~~~~~~~~ [EMAIL PROTECTED]
