1 files changed, 353 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/keyselect/tab.x b/pkg/utilities/nttools/keyselect/tab.x
new file mode 100644
index 00000000..1e4dd769
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/tab.x
@@ -0,0 +1,353 @@
+include <imhdr.h>
+include <tbset.h>
+include "keyselect.h"
+
+#* HISTORY *
+#* B.Simon	12-Mar-92	Original
+
+# CPY_TABLE -- Copy keywords from header to table row
+
+procedure cpy_table (im, tp, colptr, keywords)
+
+pointer	im		# i: image descriptor
+pointer	tp		# i: table descriptor
+pointer	colptr		# i: pointer to array of column descriptors
+char	keywords	# i: list of header keywords
+#--
+char	cat, sep
+int	row, dtype, ic, jc, kc
+pointer	sp, cp, nlist, vlist, name, value
+
+data	cat	/ CONCAT_CHAR /
+data	sep	/ SEP_CHAR /
+ 
+string	nocolumn  "cpy_table: not enough columns to store keywords"
+
+int	tbpsta(), brk_list(), stridx(), gstrcpy()
+
+begin
+	call smark(sp)
+	call salloc (nlist, SZ_LINE, TY_CHAR)
+	call salloc (vlist, SZ_LINE, TY_CHAR)
+	call salloc (name, SZ_LINE, TY_CHAR)
+	call salloc (value, SZ_LINE, TY_CHAR)
+	
+	ic = 1
+	cp = colptr
+	row = tbpsta (tp, TBL_NROWS) + 1
+
+	# Extract each keyword from the list of keywords
+
+	while (brk_list (keywords, ic, sep, Memc[nlist], SZ_LINE) > 0) {
+
+	    # If the keyword is not a list of concatenated keywords
+	    # copy its value into a string
+
+	    if (stridx (cat, Memc[nlist]) == 0) {
+		call get_keyword (im, Memc[nlist], dtype, 
+				   Memc[vlist], SZ_LINE)
+
+	    # Otherwise break the list of concatenated keywords
+	    # and concatenate their values into a string
+
+	    } else {
+		jc = 1
+		kc = 0
+		while (brk_list (Memc[nlist], jc, cat, 
+				 Memc[name], SZ_LINE) > 0){
+
+		    call get_keyword (im, Memc[name], dtype, 
+				      Memc[value], SZ_LINE)
+
+		    if (dtype != 0) {
+			kc = kc + gstrcpy (Memc[value], Memc[vlist+kc], 
+					   SZ_LINE-kc)
+			Memc[vlist+kc] = SEP_CHAR
+			kc = kc + 1
+		    }
+		}
+		kc = max (kc, 1)
+		Memc[vlist+kc-1] = EOS
+	    }
+
+	    # Write the value into the table
+
+	    if (Memi[cp] == NULL)
+		call error (1, nocolumn)
+
+	    call tbeptt (tp, Memi[cp], row, Memc[vlist])
+	    cp = cp + 1
+	}
+
+	call sfree(sp)
+end
+
+# FMT_TABLE -- Retrieve column format from column description file
+
+procedure fmt_table (cd, col, units, fmt, dtype)
+
+int	cd		# i: file descriptor of column description file
+char	col[ARB]	# i: name of column to retrieve information for
+char	units[ARB]	# o: column units
+char	fmt[ARB]	# o: column format
+int	dtype		# o: column data type
+#--
+char	star, comment
+bool	match
+int	idx, junk, length, typevals[5]
+pointer	sp, line, input, name, type, ftnfmt, errmsg
+
+string	typestr  "rdibc"
+string	badtype  "Illegal datatype for column %s (%s)"
+string	badname  "Warning: column not found in column description file (%s)\n"
+
+data	star	 / '*' /
+data	comment  / '#' /
+data	typevals /TY_REAL, TY_DOUBLE, TY_INT, TY_BOOL, TY_CHAR /
+
+bool	streq()
+int	getline(), stridx(), ctoi
+
+begin
+	call smark (sp)
+	call salloc (line, SZ_LINE, TY_CHAR)
+	call salloc (input, SZ_COLNAME, TY_CHAR)
+	call salloc (name, SZ_COLNAME, TY_CHAR)
+	call salloc (type, SZ_COLFMT, TY_CHAR)
+	call salloc (ftnfmt, SZ_COLFMT, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	call strcpy (col, Memc[input], SZ_COLNAME)
+	call strlwr (Memc[input])
+
+	match = false
+	call seek (cd, BOF)
+	while (! match && getline (cd, Memc[line]) != EOF) {
+
+	    # Remove trailing comments from line
+
+	    idx = stridx (comment, Memc[line])
+	    if (idx > 0)
+		Memc[line+idx-1] = EOS
+
+	    # Column name is the first word on the line
+
+	    call sscan (Memc[line])
+	    call gargwrd (Memc[name], SZ_COLNAME)
+	    call strlwr (Memc[name])
+
+	    # If the name matches the procedure argument 
+	    # read the remaining fields on the line
+
+	    match = streq (Memc[input], Memc[name])
+	    if (match) {
+		call gargwrd (Memc[type], SZ_COLFMT)
+		call gargwrd (Memc[ftnfmt], SZ_COLFMT)
+		call gargwrd (units, SZ_COLUNITS)
+
+		call strlwr (Memc[type])
+		call tbbftp (Memc[ftnfmt], fmt)
+
+		# Convert the type string to the corresponding integer value
+
+		if (Memc[type] == EOS) {
+		    dtype = 0
+
+		} else {
+		    idx = stridx (Memc[type], typestr)
+		    if (idx == 0) {
+			call sprintf (Memc[errmsg], SZ_LINE, badtype)
+			call pargstr (Memc[name])
+			call pargstr (Memc[type])
+			call error (1, Memc[errmsg])
+		    }
+		    
+		    dtype = typevals[idx]
+		    if (dtype == TY_CHAR) {
+			idx = stridx (star, Memc[type])
+			if (idx > 0) {
+			    idx = idx + 1
+			    junk = ctoi (Memc[type], idx, length)
+			    if (length > 0)
+				dtype = - length
+			}
+		    }
+		}
+
+	    }
+	}
+
+	# Send warning message and set defaults if no match
+
+	if (! match) {
+	    dtype = 0
+	    fmt[1] = EOS
+	    units[1] = EOS
+
+	    call eprintf (badname)
+	    call pargstr (col)
+	}
+
+	call sfree (sp)
+end
+
+# OP_TABLE -- Open the output table
+
+pointer procedure op_table(im, output, keywords, columns, cdfile)
+
+pointer	im		# i: image descriptor
+char	output[ARB]	# i: table name
+char	keywords[ARB]	# i: list of header keywords
+char	columns[ARB]	# i: list of column names
+char	cdfile[ARB]	# i: optional column description file
+#--
+bool	append
+char	sep, cat
+int	ic, jc, dtype
+pointer	sp, tp, cp, cd, col, key, units, fmt, errmsg
+
+data	sep	/ SEP_CHAR /
+data	cat	/ CONCAT_CHAR /
+
+string	nocolumn  "Column not found in existing output table (%s)"
+string	nokeyword "op_table: no matching keyword for column"
+string	notfound  "Warning: keyword not found when creating table (%s)\n"
+
+bool	isblank()
+int	open(), stridx(), imgftype(), brk_list(), type_keyword()
+pointer	tbtopn()
+
+begin
+	call smark (sp)
+	call salloc (col, SZ_COLNAME, TY_CHAR)
+	call salloc (key, SZ_LINE, TY_CHAR)
+	call salloc (units, SZ_COLUNITS, TY_CHAR)
+	call salloc (fmt, SZ_COLFMT, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	# Open column description file
+
+	if (isblank (cdfile)) {
+	    cd = NULL
+	} else {
+	    cd = open (cdfile, READ_ONLY, TEXT_FILE)
+	}
+
+	# Append rows to the table if the table already exists
+	# otherwise create a new table
+
+	append = true
+	iferr (tp = tbtopn (output, READ_WRITE, NULL)) {
+	    append = false
+	    tp = tbtopn (output, NEW_FILE, NULL)
+	}
+
+	ic = 1
+	jc = 1
+	while (brk_list (columns, ic, sep, Memc[col], SZ_COLNAME) > 0) {
+
+	    if (brk_list (keywords, jc, sep, Memc[key], SZ_LINE) == 0)
+		call error (1, nokeyword)
+
+	    # Verify that the columns exist if we are in append mode
+	    # Define the new columns if we are not
+
+	    if (append) {
+		call tbcfnd (tp, Memc[col], cp, 1)
+		if (cp == NULL) {
+		    call sprintf (Memc[errmsg], SZ_LINE, nocolumn)
+		    call pargstr (Memc[col])
+		    call error (1, Memc[errmsg])
+		}
+
+	    } else {
+		# Get column characteristics from the column description file
+		# or use defaults and image header keyword type
+
+		if (cd != NULL)
+		    call fmt_table (cd, Memc[col], 
+				    Memc[units], Memc[fmt], dtype)
+
+		if (cd == NULL || dtype == 0) {
+		    Memc[units] = EOS
+		    Memc[fmt] = EOS
+
+		    if (stridx (cat, Memc[key]) != 0) {
+			dtype = - SZ_BIGCOL
+
+		    } else if (Memc[key] == '$'){
+			dtype = type_keyword (Memc[key])
+
+		    } else {
+			iferr {
+			    dtype = imgftype (im, Memc[key])
+			} then {
+			    dtype = 0
+			    call eprintf (notfound)
+			    call pargstr (Memc[key])
+			}
+		    }
+		}
+
+		if (dtype == 0 || dtype == TY_CHAR)
+		    dtype = - SZ_STRCOL
+		if (dtype == TY_SHORT || dtype == TY_LONG)
+		    dtype = TY_INT
+		if (dtype == TY_REAL)
+		    dtype = TY_DOUBLE
+
+		call tbcdef (tp, cp, Memc[col], Memc[units], Memc[fmt], 
+			     dtype, 1, 1)
+	    }
+	}
+
+	# Create the new table if not in append mode
+
+	if (! append)
+	    call tbtcre (tp)
+
+	call sfree (sp)
+	return (tp)
+end
+
+# RD_TABLE -- Create an array of column pointers from the list of column names
+
+procedure rd_table (columns, tp, colptr)
+
+char	columns[ARB]	# i: list of column names
+pointer	tp		# i: table descriptor
+pointer	colptr		# o: pointer to array of column names
+#--
+char	sep
+int	nptr, ic
+pointer	sp, cp, col, errmsg
+
+data	sep	/ SEP_CHAR /
+string	nocolumn "rd_table: column not found (%s)"
+
+int	cnt_list(), brk_list()
+
+begin
+	call smark (sp)
+	call salloc (col, SZ_LINE, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	nptr = cnt_list (columns) + 1
+	call malloc (colptr, nptr, TY_POINTER)
+
+	ic = 1
+	cp = colptr
+	while (brk_list (columns, ic, sep, Memc[col], SZ_LINE) > 0) {
+	    call tbcfnd (tp, Memc[col], Memi[cp], 1)
+	    if (cp == NULL) {
+		call sprintf (Memc[errmsg], SZ_LINE, nocolumn)
+		call pargstr (Memc[col])
+
+		call error (1, Memc[errmsg])
+	    }
+	    cp = cp + 1
+	}
+
+	Memi[cp] = NULL
+	call sfree(sp)
+end