1 files changed, 222 insertions, 0 deletions
diff --git a/sys/imio/imt/imxexpr.x b/sys/imio/imt/imxexpr.x
new file mode 100644
index 00000000..55c185ef
--- /dev/null
+++ b/sys/imio/imt/imxexpr.x
@@ -0,0 +1,222 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<error.h>
+include	<evexpr.h>
+include	<imset.h>
+include	<imhdr.h>
+include	<ctype.h>
+include	<lexnum.h>
+
+define	LEN_USERAREA	28800		# allow for the largest possible header
+define	SZ_IMAGENAME	63		# max size of an image name
+define	SZ_FIELDNAME	31		# max size of a field name
+
+define	DEBUG		FALSE
+
+
+
+# IMX_MATCHEXPR -- Match the open image descriptor against the expression.
+
+bool procedure imx_matchexpr (im, expr)
+
+pointer	im				#I image descriptor
+char    expr[ARB]           		#I expression string
+
+bool    stat
+char	val[SZ_LINE]
+pointer	o
+
+pointer	imt_im			# getop common
+char	imt_image[SZ_IMAGENAME]
+char	imt_field[SZ_FIELDNAME]
+common	/imtgop/ imt_im, imt_image, imt_field
+
+pointer	evexpr()
+extern	imx_getop()
+int	locpr()
+errchk	locpr, evexpr
+
+begin
+	call aclrc (val, SZ_LINE)
+	call aclrc (imt_image, SZ_IMAGENAME)
+	call aclrc (imt_field, SZ_FIELDNAME)
+
+	imt_im = im
+	if (expr[1] != EOS) {
+	    iferr {
+		o = evexpr (expr, locpr (imx_getop), 0)
+	    	call imx_encodeop (o, val, SZ_LINE)
+	    	stat = O_VALB(o)
+	    	call xev_freeop (o)
+	    	call mfree (o, TY_STRUCT)
+	    } then
+		stat = FALSE
+
+	    if (DEBUG) {
+		call eprintf ("expr = '%s'  %b\n")
+		    call pargstr (expr) ; call pargb (stat)
+	    }
+
+	    return (stat)
+	}
+
+	return (FALSE)
+end
+
+
+# IMX_SIFMATCH -- Check whether the file is a simple image matching the
+# expression.
+
+bool procedure imx_sifmatch (fname, expr)
+
+char    fname[ARB]           		#I image name
+char    expr[ARB]           		#I expression string
+
+pointer	im
+bool	stat
+
+pointer	immap()
+bool	imx_matchexpr (), streq()
+errchk	immap
+
+begin
+	if (expr[1] == EOS)
+	    return (TRUE)
+
+	iferr (im = immap (fname, READ_ONLY, 0)) {
+	    return (FALSE)
+	}
+
+	if (streq (expr, "yes"))
+	    stat = TRUE
+	else
+	    stat = imx_matchexpr (im, expr)
+	call imunmap (im)
+
+	return (stat)
+end
+
+
+# IMX_GETOP -- Satisfy an operand request from EVEXPR.  In this context,
+# operand names refer to the fields of the image header.  The following
+# special operand names are recognized:
+#
+#	.		a string literal, returned as the string "."
+#	$		the value of the current field
+#	$F		the name of the current field
+#	$I		the name of the current image
+#	$T		the current time, expressed as an integer
+#
+# The companion procedure HE_GETOPSETIMAGE is used to pass the image pointer
+# and image and field names.
+
+procedure imx_getop (operand, o)
+
+char	operand[ARB]		# operand name
+pointer	o			# operand (output)
+
+pointer	imt_im			# getop common
+char	imt_image[SZ_IMAGENAME]
+char	imt_field[SZ_FIELDNAME]
+common	/imtgop/ imt_im, imt_image, imt_field
+bool	streq()
+long	clktime()
+errchk	imx_getfield
+
+begin
+	if (streq (operand, ".")) {
+	    call xev_initop (o, 1, TY_CHAR)
+	    call strcpy (".", O_VALC(o), 1)
+
+	} else if (streq (operand, "$")) {
+	    call imx_getfield (imt_im, imt_field, o)
+	
+	} else if (streq (operand, "$F")) {
+	    call xev_initop (o, SZ_FIELDNAME, TY_CHAR)
+	    call strcpy (imt_field, O_VALC(o), SZ_FIELDNAME)
+
+	} else if (streq (operand, "$I")) {
+	    call xev_initop (o, SZ_IMAGENAME, TY_CHAR)
+	    call strcpy (imt_image, O_VALC(o), SZ_IMAGENAME)
+
+	} else if (streq (operand, "$T")) {
+	    # Assignment of long into int may fail on some systems.  Maybe
+	    # should use type string and let database convert to long...
+
+	    call xev_initop (o, 0, TY_INT)
+	    O_VALI(o) = clktime (long(0))
+
+	} else
+	    call imx_getfield (imt_im, operand, o)
+end
+
+
+# IMX_GETFIELD -- Return the value of the named field of the image header as
+# an EVEXPR type operand structure.
+
+procedure imx_getfield (im, field, o)
+
+pointer	im			# image descriptor
+char	field[ARB]		# name of field to be returned
+pointer	o			# pointer to output operand
+
+bool	imgetb()
+int	ftype, imgeti(), imgftype()
+real	imgetr()
+
+begin
+	iferr {
+	    ftype = imgftype (im, field)
+	} then {
+	    call xev_initop (o, SZ_LINE, TY_CHAR) 	# keyword not found
+	    call aclrc (O_VALC(o), SZ_LINE)
+	    return
+	}
+
+	switch (ftype) {
+	case TY_BOOL:
+	    call xev_initop (o, 0, TY_BOOL)
+	    O_VALB(o) = imgetb (im, field)
+
+	case TY_SHORT, TY_INT, TY_LONG:
+	    call xev_initop (o, 0, TY_INT)
+	    O_VALI(o) = imgeti (im, field)
+
+	case TY_REAL, TY_DOUBLE, TY_COMPLEX:
+	    call xev_initop (o, 0, TY_REAL)
+	    O_VALR(o) = imgetr (im, field)
+
+	default:
+	    call xev_initop (o, SZ_LINE, TY_CHAR)
+	    call imgstr (im, field, O_VALC(o), SZ_LINE)
+	}
+end
+
+
+# IMX_ENCODEOP -- Encode an operand as returned by EVEXPR as a string.  EVEXPR
+# operands are restricted to the datatypes bool, int, real, and string.
+
+procedure imx_encodeop (o, outstr, maxch)
+
+pointer	o			# operand to be encoded
+char	outstr[ARB]		# output string
+int	maxch			# max chars in outstr
+
+begin
+	switch (O_TYPE(o)) {
+	case TY_BOOL:
+	    call sprintf (outstr, maxch, "%b")
+		call pargb (O_VALB(o))
+	case TY_CHAR:
+	    call sprintf (outstr, maxch, "%s")
+		call pargstr (O_VALC(o))
+	case TY_INT:
+	    call sprintf (outstr, maxch, "%d")
+		call pargi (O_VALI(o))
+	case TY_REAL:
+	    call sprintf (outstr, maxch, "%g")
+		call pargr (O_VALR(o))
+	default:
+	    call error (1, "unknown expression datatype")
+	}
+end