aboutsummaryrefslogtreecommitdiff
path: root/pkg/utilities/nttools/keyselect
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/utilities/nttools/keyselect')
-rw-r--r--pkg/utilities/nttools/keyselect/expr.x193
-rw-r--r--pkg/utilities/nttools/keyselect/keyselect.com9
-rw-r--r--pkg/utilities/nttools/keyselect/keyselect.h17
-rw-r--r--pkg/utilities/nttools/keyselect/keyselect.x122
-rw-r--r--pkg/utilities/nttools/keyselect/keyword.x253
-rw-r--r--pkg/utilities/nttools/keyselect/list.x215
-rw-r--r--pkg/utilities/nttools/keyselect/mkpkg15
-rw-r--r--pkg/utilities/nttools/keyselect/tab.x353
8 files changed, 1177 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/keyselect/expr.x b/pkg/utilities/nttools/keyselect/expr.x
new file mode 100644
index 00000000..fa7e5d31
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/expr.x
@@ -0,0 +1,193 @@
+include <evexpr.h>
+include "keyselect.h"
+
+#* HISTORY *
+#* B.Simon 12-Mar-1992 Original
+#* Phil Hodge 4-Mar-2002 Free memory allocated by evexpr.
+
+# EVAL_EXPR -- Evaluate a boolean expression using image header keywords
+
+bool procedure eval_expr (im, expr)
+
+pointer im # i: image descriptor
+char expr[ARB] # i: boolean expression
+#--
+include "keyselect.com"
+
+pointer op, sp, errmsg
+
+string badtype "Expression is not of boolean type"
+string badname "Warning: header keyword %s not found in %s\n"
+
+int errget()
+pointer evexpr(), locpr()
+extern fun_expr, var_expr
+
+begin
+ call smark (sp)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ img = im
+ iferr {
+ op = evexpr (expr, locpr(var_expr), locpr (fun_expr))
+
+ } then {
+ if (errget(Memc[errmsg], SZ_LINE) == ERR_SYNTAX) {
+ call xer_reset
+ call error (ERR_SYNTAX, Memc[errmsg])
+
+ } else {
+ call xer_reset
+ call eprintf ("Warning: %s\n")
+ call pargstr (Memc[errmsg])
+ call mfree (op, TY_STRUCT)
+
+ return (false)
+ }
+ }
+
+ if (O_TYPE(op) != TY_BOOL)
+ call error (ERR_SYNTAX, badtype)
+
+ call xev_freeop (op)
+ call mfree (op, TY_STRUCT)
+ call sfree (sp)
+ return (O_VALB(op))
+end
+
+# FMT_EXPR -- Format an expression to make it easier to parse
+
+procedure fmt_expr (expr)
+
+char expr[ARB] # i: expression
+#--
+int ic, jc
+
+begin
+ # Find first non-white character
+
+ for (ic = 1; expr[ic] != EOS; ic = ic + 1) {
+ if (expr[ic] > ' ')
+ break
+ }
+
+ # Copy remaining characters, replacing newlines with blanks
+
+ jc = 1
+ for ( ; expr[ic] != EOS; ic = ic + 1) {
+ if (expr[ic] == '\n') {
+ expr[jc] = ' '
+ } else if (jc < ic) {
+ expr[jc] = expr[ic]
+ }
+ jc = jc + 1
+ }
+
+ expr[jc] = EOS
+end
+
+# FUN_EXPR -- Evaluate non-standard functions used in expression
+
+procedure fun_expr (func, argptr, nargs, op)
+
+char func[ARB] # i: function name
+pointer argptr[ARB] # i: pointers to function arguments
+int nargs # i: number of function arguments
+pointer op # o: structure containing function value
+#--
+include "keyselect.com"
+
+int arg
+pointer sp, errmsg
+
+string flist "find"
+string badfun "Unknown function name (%s)"
+string badtyp "Invalid argument type for %s"
+
+int word_match(), imaccf()
+
+begin
+ call smark (sp)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ switch (word_match (func, flist)) {
+ case 0: # unrecognized function name
+ call sprintf (Memc[errmsg], SZ_LINE, badfun)
+ call pargstr (func)
+ call error (ERR_SYNTAX, Memc[errmsg])
+
+ case 1: # find keyword in header ?
+ call xev_initop (op, 0, TY_BOOL)
+ O_VALB(op) = true
+
+ do arg = 1, nargs {
+ if (O_TYPE(argptr[arg]) != TY_CHAR) {
+ call sprintf (Memc[errmsg], SZ_LINE, badtyp)
+ call pargstr (func)
+ call error (ERR_SYNTAX, Memc[errmsg])
+ }
+
+ if (imaccf (img, O_VALC(argptr[arg])) == NO)
+ O_VALB(op) = false
+ }
+ }
+
+ call sfree (sp)
+end
+
+# VAR_EXPR -- Retrieve keyword used in expression
+
+procedure var_expr (name, op)
+
+char name[ARB] # i: keyword name
+pointer op # o: structure containing value of variable
+#--
+include "keyselect.com"
+
+int ic, dtype, type, length, junk
+pointer sp, value
+
+string badname "Expression cannot be evaluated because keyword not found"
+
+bool streq()
+int ctoi(), ctor()
+
+begin
+ call smark(sp)
+ call salloc (value, SZ_BIGCOL, TY_CHAR)
+
+ # Retrieve keyword value from image header
+
+ call get_keyword (img, name, dtype, Memc[value], SZ_BIGCOL)
+
+ # Allocate structure to hold value
+
+ if (dtype == 0) {
+ call error (ERR_NOFIND, badname)
+ } else if (dtype < 0) {
+ type = TY_CHAR
+ length = - dtype
+ } else {
+ type = dtype
+ length = 0
+ }
+
+ call xev_initop (op, length, type)
+
+ # Copy value to structure
+
+ switch (type) {
+ case TY_BOOL:
+ O_VALB(op) = streq (Memc[value], "yes")
+ case TY_CHAR:
+ call strcpy (Memc[value], O_VALC(op), length)
+ case TY_SHORT,TY_INT,TY_LONG:
+ ic = 1
+ junk = ctoi (Memc[value], ic, O_VALI(op))
+ case TY_REAL,TY_DOUBLE:
+ ic = 1
+ junk = ctor (Memc[value], ic, O_VALR(op))
+ }
+
+ call sfree(sp)
+end
diff --git a/pkg/utilities/nttools/keyselect/keyselect.com b/pkg/utilities/nttools/keyselect/keyselect.com
new file mode 100644
index 00000000..fc0e63b5
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/keyselect.com
@@ -0,0 +1,9 @@
+# KEYSELECT.COM -- Global variables used by keyselect
+
+#* HISTORY *
+#* B.Simon 12-Mar-92 Original
+
+common /global/ hasgroup, img
+
+bool hasgroup # true if image has group parameters
+pointer img # image descriptor
diff --git a/pkg/utilities/nttools/keyselect/keyselect.h b/pkg/utilities/nttools/keyselect/keyselect.h
new file mode 100644
index 00000000..ef001849
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/keyselect.h
@@ -0,0 +1,17 @@
+# KEYSELECT.H -- Global constants used by keyselect
+
+#* HISTORY *
+#* B.Simon 12-Mar-92 Original
+
+define SZ_STRCOL 19
+define SZ_BIGCOL 63
+
+define ERR_SYNTAX 1
+define ERR_NOFIND 2
+
+define ASSIGN_CHAR '='
+define CONCAT_CHAR ':'
+define SEP_CHAR ','
+
+define IS_SEP ($1 <= ' ' || $1 == ',')
+
diff --git a/pkg/utilities/nttools/keyselect/keyselect.x b/pkg/utilities/nttools/keyselect/keyselect.x
new file mode 100644
index 00000000..2bc8a72e
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/keyselect.x
@@ -0,0 +1,122 @@
+# KEYSELECT -- Copy selected image header keywords to sdas table
+
+#* HISTORY *
+#* B.Simon 12-Mar-1992 Original
+# Phil Hodge 8-Apr-1999 Call tbfpri.
+
+procedure keyselect ()
+
+#--
+include "keyselect.com"
+
+pointer input # list of image names
+pointer output # sdas table name
+pointer cols # list of keyword and table column names
+pointer expr # boolean expression used to select images
+pointer cdfile # column description file
+
+bool first
+int ngroup
+int phu_copied # set by tbfpri and ignored
+pointer sp, keywords, columns, cluster, image
+pointer imlist, grplist, colptr, im, tp
+
+string noread "No images read. Output table not created."
+
+bool tp_fetch(), eval_expr()
+int imtgetim()
+pointer imtopen(), immap(), tp_open(), op_table()
+
+begin
+ # Allocate dynamic memory for strings
+
+ call smark(sp)
+ call salloc (input, SZ_FNAME, TY_CHAR)
+ call salloc (output, SZ_FNAME, TY_CHAR)
+ call salloc (cols, SZ_COMMAND, TY_CHAR)
+ call salloc (expr, SZ_COMMAND, TY_CHAR)
+ call salloc (cdfile, SZ_FNAME, TY_CHAR)
+
+ call salloc (keywords, SZ_COMMAND, TY_CHAR)
+ call salloc (columns, SZ_COMMAND, TY_CHAR)
+ call salloc (cluster, SZ_FNAME, TY_CHAR)
+ call salloc (image, SZ_FNAME, TY_CHAR)
+
+ # Read task parameters
+
+ call clgstr ("input", Memc[input], SZ_FNAME)
+ call clgstr ("output", Memc[output], SZ_FNAME)
+ call clgstr ("cols", Memc[cols], SZ_FNAME)
+ call clgstr ("expr", Memc[expr], SZ_FNAME)
+ call clgstr ("cdfile", Memc[cdfile], SZ_FNAME)
+
+ # If keyword list or expression is contained in a file, read the file
+
+ if (Memc[cols] == '@')
+ call rd_list (Memc[cols+1], Memc[cols], SZ_COMMAND)
+ call fmt_list (Memc[cols])
+
+ if (Memc[expr] == '@')
+ call rd_list (Memc[expr+1], Memc[expr], SZ_COMMAND)
+ call fmt_expr (Memc[expr])
+
+ # Separate out the header keyword and table column names
+
+ call sep_list (Memc[cols], Memc[keywords], Memc[columns], SZ_COMMAND)
+
+ # Loop over all images and all groups in image
+
+ first = true
+ imlist = imtopen (Memc[input])
+
+ while (imtgetim (imlist, Memc[cluster], SZ_FNAME) != EOF) {
+
+ # Hasgroup is set to true to get us through the loop the
+ # first time. It then is set to false, but can be set to
+ # true if either eval_expr() or cpy_table() accesses a
+ # group parameter.
+
+ hasgroup = true
+ grplist = tp_open (Memc[cluster], 0, ngroup)
+
+ while (hasgroup && tp_fetch (grplist, Memc[image])) {
+ im = immap (Memc[image], READ_ONLY, 0)
+ hasgroup = false
+
+ # Open output table first time through loop
+
+ if (first) {
+ first = false
+ call tbfpri (Memc[cluster], Memc[output], phu_copied)
+ tp = op_table (im, Memc[output], Memc[keywords],
+ Memc[columns], Memc[cdfile])
+ call rd_table (Memc[columns], tp, colptr)
+ }
+
+ # Copy keywords from header to table if expression is true
+
+ if (Memc[expr] == EOS) {
+ call cpy_table (im, tp, colptr, Memc[keywords])
+ } else if (eval_expr (im, Memc[expr])) {
+ call cpy_table (im, tp, colptr, Memc[keywords])
+ }
+
+ call imunmap (im)
+ }
+ call tp_close (grplist)
+ }
+
+ # Close files and release memory
+
+ call imtclose (imlist)
+ call sfree(sp)
+
+ if (first) {
+ call eprintf (noread)
+
+ } else {
+ call mfree (colptr, TY_POINTER)
+ call tbtclo (tp)
+ }
+
+end
diff --git a/pkg/utilities/nttools/keyselect/keyword.x b/pkg/utilities/nttools/keyselect/keyword.x
new file mode 100644
index 00000000..b360e7cd
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/keyword.x
@@ -0,0 +1,253 @@
+include <imio.h>
+include <imhdr.h>
+include "keyselect.h"
+
+#* HISTORY *
+#* B.Simon 12-Mar-92 Original
+
+# GET_KEYWORD -- Get the keyword from the image header
+
+procedure get_keyword (im, name, dtype, value, maxch)
+
+pointer im # i: image descriptor
+char name[ARB] # i: keyword name
+int dtype # o: keyword data type
+char value[ARB] # o: keyword value
+int maxch # i: maximum length of value string
+#--
+include "keyselect.com"
+
+string badname "Warning: header keyword %s not found in %s\n"
+
+int imgftype(), gf_gfind()
+
+begin
+ # Any name beginning with a $ is a special keyword
+
+ if (name[1] == '$') {
+ call spec_keyword (im, name, dtype, value, maxch)
+
+ } else {
+ # Get the data type of the header keyword
+ # If the keyword is not found set the data type to
+ # zero to indicate this and return
+
+ iferr {
+ dtype = imgftype (im, name)
+ } then {
+ call eprintf (badname)
+ call pargstr (name)
+ call pargstr (IM_HDRFILE(im))
+
+ dtype = 0
+ value[1] = EOS
+ return
+ }
+
+ if (dtype == TY_SHORT || dtype == TY_LONG)
+ dtype = TY_INT
+ if (dtype == TY_CHAR)
+ dtype = - maxch
+
+ # Read header keyword from image. This procedure sets hasgroup
+ # to true if asked to retrieve a group parameter
+
+ call imgstr (im, name, value, maxch)
+ if (dtype == TY_BOOL) {
+ if (value[1] == 'T') {
+ call strcpy ("yes", value, maxch)
+ } else {
+ call strcpy ("no", value, maxch)
+ }
+ }
+
+ if (gf_gfind (im, name) > 0)
+ hasgroup = true
+ }
+
+end
+
+# NAME_KEYWORD -- Retrieve the default column name for a special keyword
+
+procedure name_keyword (name, colname, maxch)
+
+char name[ARB] # i: keyword name
+char colname[ARB] # o: default column name
+int maxch # i: maximum length of column name
+#--
+int idx, junk
+pointer sp, errmsg
+
+string special "group,dir,ext,hdr,pix,root"
+string defaults "group,directory,extension,header_file,data_file,rootname"
+string badname "Name for special keyword not recognized (%s)"
+
+int word_match(), word_find()
+
+begin
+ call smark (sp)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ if (name[1] != '$') {
+ call strcpy (name, colname, maxch)
+ return
+ }
+
+ # Get the index of special keyword name in the list
+ # The find the corresponding name in the list of defaults
+
+ idx = word_match (name[2], special)
+ if (idx == 0) {
+ call sprintf (Memc[errmsg], SZ_LINE, badname)
+ call pargstr (name)
+ call error (1, Memc[errmsg])
+ } else {
+ junk = word_find (idx, defaults, colname, maxch)
+ }
+
+ call sfree (sp)
+end
+
+# SPEC_KEYWORD -- Get the value of a special keyword
+
+procedure spec_keyword (im, name, dtype, value, maxch)
+
+pointer im # i: image descriptor
+char name[ARB] # i: keyword name
+int dtype # o: keyword data type
+char value[ARB] # o: keyword value
+int maxch # i: maximum length of value string
+#--
+include "keyselect.com"
+
+int match, ival, junk
+pointer sp, image, ldir, root, errmsg, hdr, ext
+
+string int_special "group"
+string str_special "dir,ext,hdr,pix,root"
+
+string badname "Name for special keyword not recognized (%s)"
+string badimgext "Image extension not recognized (%s)"
+
+bool streq()
+int word_match(), fnldir(), fnroot(), itoc()
+
+begin
+ call smark (sp)
+ call salloc (image, SZ_FNAME, TY_CHAR)
+ call salloc (ldir, SZ_FNAME, TY_CHAR)
+ call salloc (root, SZ_FNAME, TY_CHAR)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ # Search lists for special keyword
+
+ match = - word_match (name[2], int_special)
+ if (match == 0)
+ match = word_match (name[2], str_special)
+
+ # Data type is determined from which list it is on
+
+ if (match < 0) {
+ dtype = TY_INT
+ } else if (match > 0) {
+ dtype = - maxch
+ } else {
+ call sprintf (Memc[errmsg], SZ_LINE, badname)
+ call pargstr (name)
+ call error (1, Memc[errmsg])
+ }
+
+ # Break image name into its component parts
+
+ if (match > 0) {
+ call imgcluster (IM_HDRFILE(im), Memc[image], SZ_FNAME)
+
+ hdr = image + fnldir (Memc[image], Memc[ldir], SZ_FNAME)
+ ext = hdr + 1 + fnroot (Memc[hdr], Memc[root], SZ_FNAME)
+ }
+
+
+ # Get value of special keyword
+
+ switch (match) {
+ case -1:
+ # group number $group
+ hasgroup = true
+ ival = max (1, IM_CLINDEX(im))
+ junk = itoc (ival, value, maxch)
+ case 0:
+ # (not used)
+ ;
+ case 1:
+ # directory name $dir
+ call strcpy (Memc[ldir], value, maxch)
+ case 2:
+ # extension $ext
+ call strcpy (Memc[ext], value, maxch)
+ case 3:
+ # header file name $hdr
+ call strcpy (Memc[hdr], value, maxch)
+ case 4:
+ # pixel file name $pix
+ if (Memc[ext+2] != 'h' || Memc[ext+3] != EOS) {
+ call sprintf (Memc[errmsg], SZ_LINE, badimgext)
+ call pargstr (Memc[hdr])
+ call error (1, Memc[errmsg])
+ }
+
+ call strcpy (Memc[root], value, maxch)
+ if (streq (Memc[ext], "imh")) {
+ call strcat (".pix", value, maxch)
+ } else {
+ Memc[ext+2] = 'd'
+ call strcat (".", value, maxch)
+ call strcat (Memc[ext], value, maxch)
+ }
+ case 5:
+ # root name $root
+ call strcpy (Memc[root], value, maxch)
+ }
+
+ call sfree (sp)
+end
+
+# TYPE_KEYWORD -- Retrieve the type of a special keyword
+
+int procedure type_keyword (name)
+
+char name[ARB] # i: special keyword name
+#--
+int dtype
+pointer sp, errmsg
+
+string int_special "group"
+string str_special "dir,ext,hdr,pix,root"
+string badname "Name for special keyword not recognized (%s)"
+
+int word_match()
+
+begin
+ call smark (sp)
+ call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+ if (name[1] != '$') {
+ call sprintf (Memc[errmsg], SZ_LINE, badname)
+ call pargstr (name)
+ call error (1, Memc[errmsg])
+
+ } else if (word_match (name[2], int_special) > 0) {
+ dtype = TY_INT
+
+ } else if (word_match (name[2], str_special) > 0) {
+ dtype = TY_CHAR
+
+ } else {
+ call sprintf (Memc[errmsg], SZ_LINE, badname)
+ call pargstr (name)
+ call error (1, Memc[errmsg])
+ }
+
+ call sfree (sp)
+ return (dtype)
+end
+
diff --git a/pkg/utilities/nttools/keyselect/list.x b/pkg/utilities/nttools/keyselect/list.x
new file mode 100644
index 00000000..b25e1a7e
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/list.x
@@ -0,0 +1,215 @@
+include "keyselect.h"
+
+#* HISTORY *
+#* B.Simon 12-Mar-92 Original
+
+# BRK_LIST -- Retrieve a string from the list
+
+int procedure brk_list (list, ic, sep, str, maxch)
+
+char list[ARB] # i: list of items
+int ic # u: index into list
+char sep # i: character separating strings in the list
+char str[ARB] # o: output string
+int maxch # i: maximum length of output string
+#--
+int jc
+
+begin
+ # Copy characters into output string until separation character
+ # or end of list is found
+
+ for (jc = 1; jc <= maxch; jc = jc + 1) {
+ str[jc] = list[ic]
+ ic = ic + 1
+
+ if (str[jc] == sep) {
+ break
+ } else if (str[jc] == EOS) {
+ ic = ic - 1 # back up to EOS character
+ break
+ }
+ }
+
+ str[jc] = EOS
+ return (jc-1)
+end
+
+# CNT_LIST -- Count the number of items in a list
+
+int procedure cnt_list (list)
+
+char list[ARB] # i: list of items
+#--
+int ic, count
+
+begin
+ # Number of items is number of separation characters plus one
+
+ count = 1
+ for (ic = 1; list[ic] != EOS; ic = ic + 1) {
+ if (list[ic] == SEP_CHAR)
+ count = count + 1
+ }
+
+ return (count)
+end
+
+# FMT_LIST -- Format a list into canonical form
+
+procedure fmt_list (list)
+
+char list[ARB] # u: list of keyword names
+#--
+bool tween
+int ic, jc
+
+begin
+ jc = 1
+ tween = true
+
+ # Eliminate consecutive separation characters between list items
+
+ for (ic = 1; list[ic] != EOS; ic = ic + 1) {
+ if (IS_SEP(list[ic])) {
+ if (! tween) {
+ tween = true
+ list[jc] = SEP_CHAR
+ jc = jc + 1
+ }
+
+ } else {
+ tween = false
+ if (jc < ic)
+ list[jc] = list[ic]
+ jc = jc + 1
+ }
+ }
+
+ # Eliminate trailing separation character
+
+ if (! tween || jc == 1) {
+ list[jc] = EOS
+ } else {
+ list[jc-1] = EOS
+ }
+
+end
+
+# RD_LIST -- Read values from a file into a list
+
+procedure rd_list (fname, list, maxch)
+
+char fname[ARB] # i: file containing list
+char list[ARB] # o: output list
+int maxch # i: maximum length of list
+#--
+int fd, ic, nc
+
+int open(), getline()
+
+begin
+ # Concatenate contents of the file into a single long string
+ # while preserving the newlines between them
+
+ fd = open (fname, READ_ONLY, TEXT_FILE)
+
+ for (ic = 1; ic < maxch; ic = ic + nc) {
+ nc = getline (fd, list[ic])
+ if (nc <= 0)
+ break
+ }
+
+ list[ic] = EOS
+ call close (fd)
+
+end
+
+# SEP_LIST -- Separate list into keywords and table column names
+
+procedure sep_list (list, keywords, columns, maxch)
+
+char list[ARB] # i: combined list of columns and keywords
+char keywords[ARB] # o: list of header keyword names
+char columns[ARB] # o: list of table column names
+int maxch # i: declared length of output strings
+#--
+char eq, sep, cat
+int ic, jc, kc, mc, nc
+pointer sp, word, key, col
+
+data eq / ASSIGN_CHAR /
+data sep / SEP_CHAR /
+data cat / CONCAT_CHAR /
+
+string nolist "List of header keywords is empty. No table created."
+
+int stridx(), gstrcpy(), brk_list()
+
+begin
+ call smark(sp)
+ call salloc (word, SZ_LINE, TY_CHAR)
+ call salloc (key, SZ_LINE, TY_CHAR)
+ call salloc (col, SZ_LINE, TY_CHAR)
+
+ ic = 1
+ jc = 1
+ kc = 1
+
+ # Extract the next item from the combined list of columns and keywords
+
+ while (brk_list (list, ic, sep, Memc[word], SZ_LINE) > 0) {
+
+ # Break the item into the column and keyword names
+ # If both are not given in the item assume they are the same
+
+ nc = stridx (eq, Memc[word])
+ if (nc > 0) {
+ Memc[word+nc-1] = EOS
+ call strcpy (Memc[word], Memc[col], SZ_LINE)
+ call strcpy (Memc[word+nc], Memc[key], SZ_LINE)
+
+ } else {
+ call strcpy (Memc[word], Memc[col], SZ_LINE)
+ call strcpy (Memc[word], Memc[key], SZ_LINE)
+
+ # Translate keyword names into their default column names
+ # and substitute underscores for the concatenation char
+
+ if (Memc[col] == '$') {
+ call name_keyword (Memc[col], Memc[col], SZ_LINE)
+
+ } else {
+ repeat {
+ mc = stridx (cat, Memc[col])
+ if (mc == 0)
+ break
+
+ Memc[col+mc-1] = '_'
+ }
+ }
+ }
+
+ # Append keyword and column name to output string
+
+ jc = jc + gstrcpy (Memc[key], keywords[jc], maxch-jc)
+ keywords[jc] = SEP_CHAR
+ jc = jc + 1
+
+ kc = kc + gstrcpy (Memc[col], columns[kc], maxch-kc)
+ columns[kc] = SEP_CHAR
+ kc = kc + 1
+ }
+
+ # Exit with error if either list is empty
+
+ if (jc == 1 || kc == 1)
+ call error (1, nolist)
+
+ # Eliminate trailing separation character
+
+ keywords[jc-1] = EOS
+ columns[kc-1] = EOS
+
+ call sfree(sp)
+end
diff --git a/pkg/utilities/nttools/keyselect/mkpkg b/pkg/utilities/nttools/keyselect/mkpkg
new file mode 100644
index 00000000..d22d2201
--- /dev/null
+++ b/pkg/utilities/nttools/keyselect/mkpkg
@@ -0,0 +1,15 @@
+# Update the keyselect application code in the ttools package library
+# Author: B.Simon, 12-Mar-92
+
+$checkout libpkg.a ../
+$update libpkg.a
+$checkin libpkg.a ../
+$exit
+
+libpkg.a:
+ expr.x <evexpr.h> "keyselect.h"
+ keyselect.x "keyselect.com"
+ keyword.x <imio.h> <imhdr.h> "keyselect.h" "keyselect.com"
+ list.x "keyselect.h"
+ tab.x <imhdr.h> <tbset.h> "keyselect.h"
+ ;
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
generated by cgit (git 2.34.1) at 2025-09-20 08:36:57 -0400