diff options
Diffstat (limited to 'pkg/utilities/nttools/copyone')
21 files changed, 1345 insertions, 0 deletions
diff --git a/pkg/utilities/nttools/copyone/addslash.x b/pkg/utilities/nttools/copyone/addslash.x new file mode 100644 index 00000000..6c5c2ded --- /dev/null +++ b/pkg/utilities/nttools/copyone/addslash.x @@ -0,0 +1,32 @@ +# ADDSLASH -- Convert a string by prefixing quote marks with backslashes +# +# B.Simon 30-Sep-87 First Code + +procedure addslash (str, maxch) + +char str[ARB] # String to be converted +int maxch # Maximum length of string + +int i, j +pointer sp, aux + +begin + call smark (sp) + call salloc (aux, maxch, TY_CHAR) + + j = 1 + for (i = 1; (str[i] != EOS) && (j <= maxch); i = i + 1) { + if (str[i] == '"') { + if (j == maxch) + break + Memc[aux+j-1] = '\\' + j = j + 1 + } + Memc[aux+j-1] = str[i] + j = j + 1 + } + + Memc[aux+j-1] = EOS + call strcpy (Memc[aux], str, maxch) + call sfree (sp) +end diff --git a/pkg/utilities/nttools/copyone/datatype.x b/pkg/utilities/nttools/copyone/datatype.x new file mode 100644 index 00000000..d35732f9 --- /dev/null +++ b/pkg/utilities/nttools/copyone/datatype.x @@ -0,0 +1,79 @@ +include <lexnum.h> + +# DATATYPE -- Determine the data type of a character string token +# +# B.Simon 13-Aug-87 First Code +# B.Simon 27-Jul-94 Distinguish between double and real +# B.Simon 15-Sep-94 Add check of token length for TY_CHAR +# B.Simon 15-Dec-94 Replace test for double + +int procedure datatype (token) + +char token[ARB] # i: Character string token +#-- +int ic, dtype, nchar, ndigit +pointer sp, utoken + + +bool streq() +int nowhite(), lexnum(), is_double() + +begin + # Convert token to upper case with no whitespace + + call smark (sp) + call salloc (utoken, SZ_LINE, TY_CHAR) + + nchar = nowhite (token, Memc[utoken], SZ_LINE) + call strupr (Memc[utoken]) + + # Determine if token is a number + + ic = 1 + switch (lexnum (Memc[utoken], ic, ndigit)) { + case LEX_OCTAL : + dtype = TY_INT + case LEX_DECIMAL : + dtype = TY_INT + case LEX_HEX : + dtype = TY_CHAR + case LEX_REAL : + dtype = TY_REAL + case LEX_NONNUM : + dtype = TY_CHAR + } + + # Check number of digits parsed against length of string + # if it is shorter, we have a character string that starts + # with a digit + + if (ndigit != nchar) + dtype = TY_CHAR + + # Determine if string is boolean + + switch (Memc[utoken]) { + case 'T': + if (streq (Memc[utoken],"T") || streq (Memc[utoken],"TRUE")) + dtype = TY_BOOL + case 'F': + if (streq (Memc[utoken],"F") || streq (Memc[utoken],"FALSE")) + dtype = TY_BOOL + case 'Y': + if (streq (Memc[utoken],"Y") || streq (Memc[utoken],"YES")) + dtype = TY_BOOL + case 'N': + if (streq (Memc[utoken],"N") || streq (Memc[utoken],"NO")) + dtype = TY_BOOL + } + + # Determine if datatype is real or double by the number of digits + # and / or the presence of "D" + + if (dtype == TY_REAL) + dtype = is_double (Memc[utoken]) + + call sfree (sp) + return (dtype) +end + diff --git a/pkg/utilities/nttools/copyone/filetype.h b/pkg/utilities/nttools/copyone/filetype.h new file mode 100644 index 00000000..b2d84cc6 --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.h @@ -0,0 +1,5 @@ +# Symbolic representation of file types supported by SDAS + +define UNKNOWN_FILE 0 +define IMAGE_FILE 1 +define TABLE_FILE 2 diff --git a/pkg/utilities/nttools/copyone/filetype.x b/pkg/utilities/nttools/copyone/filetype.x new file mode 100644 index 00000000..3424b5ea --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.x @@ -0,0 +1,28 @@ +include "filetype.h" + +# FILETYPE -- Determine filetype of file + +int procedure filetype (file) + +char file # i: file name +#-- +int flag + +int is_image() + +begin + # Is_image is in the selector sublibrary of tbtables + # and is the recommended procedure for determining file + # type + + switch (is_image(file)) { + case ERR: + flag = UNKNOWN_FILE + case NO: + flag = TABLE_FILE + case YES: + flag = IMAGE_FILE + } + + return (flag) +end diff --git a/pkg/utilities/nttools/copyone/filetype.x.OLD b/pkg/utilities/nttools/copyone/filetype.x.OLD new file mode 100644 index 00000000..65e30293 --- /dev/null +++ b/pkg/utilities/nttools/copyone/filetype.x.OLD @@ -0,0 +1,61 @@ +include "filetype.h" + +# FILETYPE -- Determine the file type from the file name. Say the file type +# is unknown if the file cannot be accessed or the name is ambiguous. +# +# B.Simon Aug-13-87 First Code +# B.Simon Jan-24-92 Added salloc for extension + +int procedure filetype (fname) + +char fname[ARB] # i: file name +#-- +int ftype +pointer sp, extension, cluster + +int fnextn(), imaccess(), tabaccess(), access() + +begin + call smark (sp) + call salloc (extension, SZ_FNAME, TY_CHAR) # Added (BPS 01.24.92) + call salloc (cluster, SZ_FNAME, TY_CHAR) + + ftype = UNKNOWN_FILE + call imgcluster (fname, Memc[cluster], SZ_FNAME) + + if (access (Memc[cluster], 0, 0) == YES) { + + # File exists with specified name + + if (imaccess (Memc[cluster], READ_ONLY) == YES && + imaccess (Memc[cluster], NEW_FILE) == YES ) + + ftype = IMAGE_FILE + + else if (tabaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = TABLE_FILE + + } else if (fnextn (Memc[cluster], Memc[extension], SZ_FNAME) == 0) { + + # File name does not contain an extension, + # try adding default extensions + + if (tabaccess (Memc[cluster], READ_ONLY) == YES && + imaccess (Memc[cluster], READ_ONLY) == YES ) + + ftype = UNKNOWN_FILE + + else if (imaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = IMAGE_FILE + + else if (tabaccess (Memc[cluster], READ_ONLY) == YES) + + ftype = TABLE_FILE + + } + + call sfree (sp) + return (ftype) +end diff --git a/pkg/utilities/nttools/copyone/getimghdr.x b/pkg/utilities/nttools/copyone/getimghdr.x new file mode 100644 index 00000000..03dc9ced --- /dev/null +++ b/pkg/utilities/nttools/copyone/getimghdr.x @@ -0,0 +1,35 @@ +# GETIMGHDR -- Read a keyword from an image header into a string +# +# B.Simon 13-Aug-87 First Code +# B.Simon 12-Dec-94 Added error check +# B.Simon 21-Jul-97 Add extra check to work around imgftype bug + +procedure getimghdr (hd, keyword, maxch, value, keytype) + +pointer hd # i: Image descriptor +char keyword[ARB] # i: Name of header keyword +int maxch # i: Maximum length of keyword value +char value[ARB] # o: Keyword value +int keytype # o: Type of header keyword +#-- +int imgftype() +errchk imgstr + +begin + # Read image header keyword and get datatype + + call imgstr (hd, keyword, value, maxch) + keytype = imgftype (hd, keyword) + + # If boolean, convert to the standard names + # The check on value[2] is to work around a + # bug in imgftype() + + if (value[2] == EOS && keytype == TY_BOOL) + if (value[1] == 'T') + call strcpy ("yes", value, maxch) + else + call strcpy ("no", value, maxch) + + return +end diff --git a/pkg/utilities/nttools/copyone/gettabdat.x b/pkg/utilities/nttools/copyone/gettabdat.x new file mode 100644 index 00000000..66a6c215 --- /dev/null +++ b/pkg/utilities/nttools/copyone/gettabdat.x @@ -0,0 +1,111 @@ +include <tbset.h> +define USRERR 1 + +# GETTABDAT -- Read an element from a table into a string +# +# B.Simon 17-Aug-1987 First Code +# Phil Hodge 15-May-2002 Add 'format' argument. ctowrd is a function. + +procedure gettabdat (hd, colname, rownum, maxch, format, value, undef, eltype) + +pointer hd # i: Table descriptor +char colname[ARB] # i: Table column name +int rownum # i: Table row number +int maxch # i: Maximum length of element value +bool format # i: Format the value using table print format? +char value[ARB] # o: Table element value +bool undef # o: Is table element undefined? +int eltype # o: Type of table element + +bool nullbuf[1] +int lendata, ip +pointer colptr[1] +pointer sp, errtxt, valbuf + +double dval[1] +real rval[1] +int ival[1] +bool bval[1] + +string badnamerr "Column name not found in table (%s)" +string unknown_type "Unknown data type in table" + +int tbcigi() +int junk, ctowrd() + +begin + # Allocate dynamic memory to hold strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + call salloc (valbuf, maxch, TY_CHAR) + + # Get the column pointer from the column name + + call tbcfnd (hd, colname, colptr, 1) + + # If the pointer is NULL, the column was not found + + if (colptr[1] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badnamerr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + } + + # Get the column data type. Store in eltype + + eltype = tbcigi (colptr[1], TBL_COL_DATATYPE) + if (eltype < 0) { + lendata = - eltype + eltype = TY_CHAR + } + + # Get the table element as a text string + + if (format || eltype == TY_CHAR) { + call tbrgtt (hd, colptr, Memc[valbuf], nullbuf, maxch, 1, rownum) + } else { + switch (eltype) { + case TY_BOOL : + call tbrgtb (hd, colptr, bval, nullbuf, 1, rownum) + if (bval[1]) + call strcpy ("yes", Memc[valbuf], maxch) + else + call strcpy ("no", Memc[valbuf], maxch) + case TY_SHORT,TY_INT : + call tbrgti (hd, colptr, ival, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%d") + call pargi (ival) + case TY_REAL : + call tbrgtr (hd, colptr, rval, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%15.7g") + call pargr (rval) + case TY_DOUBLE : + call tbrgtd (hd, colptr, dval, nullbuf, 1, rownum) + call sprintf (Memc[valbuf], maxch, "%25.16g") + call pargd (dval) + default : + call error (1, unknown_type) + } + } + + if (eltype == TY_CHAR) { + + # Just do a straight copy if the element is a string + + call strcpy (Memc[valbuf], value, maxch) + + } else{ + + # Otherwise, strip whitespace from element value + + ip = 1 + junk = ctowrd (Memc[valbuf], ip, value, maxch) + + } + + undef = nullbuf[1] + call sfree (sp) + + return +end diff --git a/pkg/utilities/nttools/copyone/gettabhdr.x b/pkg/utilities/nttools/copyone/gettabhdr.x new file mode 100644 index 00000000..4e9812bc --- /dev/null +++ b/pkg/utilities/nttools/copyone/gettabhdr.x @@ -0,0 +1,55 @@ +# GETTABHDR -- Read a keyword from an table header into a string +# +# B.Simon 14-Aug-87 First Code +# B.Simon 12-Dec-94 Added error check + +procedure gettabhdr (hd, keyword, maxch, value, keytype) + +pointer hd # i: Table descriptor +char keyword[ARB] # i: Name of header keyword +int maxch # i: Maximum length of keyword value +char value[ARB] # o: Keyword value +int keytype # o: Type of header keyword +#-- +int ip +pointer keyval, sp + +int tabhdrtyp() +errchk tbhgtt + +begin + call smark (sp) + call salloc (keyval, maxch, TY_CHAR) + + # Read table header keyword and get datatype + + call tbhgtt (hd, keyword, Memc[keyval], maxch) + keytype = tabhdrtyp (hd, keyword) + + if (keytype == TY_CHAR) { + + # Just do a straight copy if the keyword is a string + + call strcpy (Memc[keyval], value, maxch) + + } else{ + + # Otherwise, strip whitespace from keyword value + + ip = 1 + call ctowrd (Memc[keyval], ip, value, maxch) + + # If boolean, convert to the standard names + + if (keytype == TY_BOOL) { + + if (value[1] == '1') + call strcpy ("yes", value, maxch) + else + call strcpy ("no", value, maxch) + } + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/isdouble.x b/pkg/utilities/nttools/copyone/isdouble.x new file mode 100644 index 00000000..4ee128cc --- /dev/null +++ b/pkg/utilities/nttools/copyone/isdouble.x @@ -0,0 +1,37 @@ +include <ctype.h> +include <mach.h> + +# IS_DOUBLE -- Check to see if a real number is actually double precision +# +# B.Simon 15-Dec-94 First Code + +int procedure is_double (token) + +char token[ARB] # i: token containing number +#-- +int ic, ndigit + +begin + # Count number of digits in mantissa and look for D exponent + + ndigit = 0 + for (ic = 1; token[ic] != EOS; ic = ic + 1) { + if (token[ic] == 'D' || token[ic] == 'd') { + return (TY_DOUBLE) + + } else if (token[ic] == 'E' || token[ic] == 'e') { + break + } + + if (IS_DIGIT(token[ic])) + ndigit = ndigit + 1 + } + + # If no D exponent, set the type according to the number of digits + + if (ndigit > NDIGITS_RP) { + return (TY_DOUBLE) + } else { + return (TY_REAL) + } +end diff --git a/pkg/utilities/nttools/copyone/keypar.x b/pkg/utilities/nttools/copyone/keypar.x new file mode 100644 index 00000000..0a5c9423 --- /dev/null +++ b/pkg/utilities/nttools/copyone/keypar.x @@ -0,0 +1,109 @@ +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# KEYPAR -- Transfer header keyword to IRAF parameter +# +# B.Simon 14-Aug-87 First Code +# B.Simon 14-Dec-94 Added error checking + +procedure t_keypar() + +#-- +pointer input # Name of file containing header keyword +pointer keyword # Name of header keyword +bool silent # Don't print warning message +pointer value # IRAF parameter value + +bool found +int ftype, keytype, junk +pointer errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int filetype(), errget() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read input parameters + + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + silent = clgetb ("silent") + + ftype = filetype (Memc[input]) + + if (ftype == IMAGE_FILE) { + + # Read image header keyword and get datatype + + found = true + hd = immap (Memc[input], READ_ONLY, NULL) + iferr { + call getimghdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + + keytype = TY_CHAR + Memc[value] = EOS + found = false + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Read table header keyword and get datatype + + found = true + hd = tbtopn (Memc[input], READ_ONLY, NULL) + iferr { + call gettabhdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + + keytype = TY_CHAR + Memc[value] = EOS + found = false + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[input]) + call error (USRERR, Memc[errtxt]) + + } + + # Write output parameters and free string storage + + call addslash (Memc[value], SZ_KEYWORD) + call clpstr ("value", Memc[value]) + call clputb ("found", found) + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/keytab.x b/pkg/utilities/nttools/copyone/keytab.x new file mode 100644 index 00000000..38577404 --- /dev/null +++ b/pkg/utilities/nttools/copyone/keytab.x @@ -0,0 +1,113 @@ +include <tbset.h> +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# KEYTAB -- Transfer a header keyword to a table element +# +# B.Simon 17-Aug-87 First Code +# B.Simon 14-Dec-94 Added error checking + +procedure t_keytab () + +#-- +pointer input # Name of file containing header keyword +pointer keyword # Name of header keyword +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +bool silent # Don't print warning message + +bool undef +int ftype, keytype, junk +pointer value, errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int clgeti(), filetype(), errget() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read input parameters + + call clgstr ("input", Memc[input], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + silent = clgetb ("silent") + + undef = false + ftype = filetype (Memc[input]) + + if (ftype == IMAGE_FILE) { + + # Read image header keyword and get datatype + + hd = immap (Memc[input], READ_ONLY, NULL) + iferr { + call getimghdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + undef = true + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Read table header keyword and get datatype + + hd = tbtopn (Memc[input], READ_ONLY, NULL) + iferr { + call gettabhdr (hd, Memc[keyword], SZ_KEYWORD, + Memc[value], keytype) + } then { + junk = errget (Memc[errtxt], SZ_LINE) + call xer_reset + undef = true + + if (! silent) { + call eprintf ("Warning: %s\n") + call pargstr (Memc[errtxt]) + } + } + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[input]) + call error (USRERR, Memc[errtxt]) + + } + + # Write the table element according to its datatype + + hd = tbtopn (Memc[table], READ_WRITE, NULL) + call puttabdat (hd, Memc[column], row, Memc[value], undef, keytype) + call tbtclo (hd) + + # Free string storage + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/mkpkg b/pkg/utilities/nttools/copyone/mkpkg new file mode 100644 index 00000000..815e2d9d --- /dev/null +++ b/pkg/utilities/nttools/copyone/mkpkg @@ -0,0 +1,29 @@ +# Update the KEYPAR, KEYTAB, PARKEY, PARTAB, TABKEY, TABPAR task code +# in the ttools package library +# Author: B.Simon, 25-NOV-1987 + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + addslash.x + datatype.x <lexnum.h> + filetype.x filetype.h + getimghdr.x + gettabdat.x <tbset.h> + gettabhdr.x + isdouble.x <ctype.h> <mach.h> + keypar.x filetype.h + keytab.x <tbset.h> filetype.h + parkey.x filetype.h + partab.x <tbset.h> + putimghdr.x + puttabdat.x <tbset.h> + puttabhdr.x + tabaccess.x + tabhdrtyp.x <tbset.h> + tabkey.x <tbset.h> filetype.h + tabpar.x <tbset.h> + ; diff --git a/pkg/utilities/nttools/copyone/parkey.x b/pkg/utilities/nttools/copyone/parkey.x new file mode 100644 index 00000000..c473ee80 --- /dev/null +++ b/pkg/utilities/nttools/copyone/parkey.x @@ -0,0 +1,71 @@ +include "filetype.h" + +define SZ_KEYWORD 64 +define USRERR 1 + +# PARKEY -- Transfer IRAF parameter to header keyword +# +# B.Simon 14-Aug-87 First Code + +procedure t_parkey() + +pointer value # IRAF parameter value +pointer output # Name of file containing header keyword +pointer keyword # Name of header keyword +bool add # Is it OK to add a new keyword? + +int ftype, keytype +pointer errtxt, sp, hd + +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int filetype(), datatype() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Read parameters + + call clgstr ("value", Memc[value], SZ_KEYWORD) + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + add = clgetb("add") + + ftype = filetype (Memc[output]) + keytype = datatype (Memc[value]) + + if (ftype == IMAGE_FILE) { + + # Write image header keyword + + hd = immap (Memc[output], READ_WRITE, NULL) + call putimghdr (hd, Memc[keyword], Memc[value], keytype, add) + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Write table header keyword + + hd = tbtopn (Memc[output], READ_WRITE, NULL) + call puttabhdr (hd, Memc[keyword], Memc[value], keytype, add) + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[output]) + call error (USRERR, Memc[errtxt]) + + } + + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/partab.x b/pkg/utilities/nttools/copyone/partab.x new file mode 100644 index 00000000..19505049 --- /dev/null +++ b/pkg/utilities/nttools/copyone/partab.x @@ -0,0 +1,51 @@ +include <tbset.h> +define SZ_KEYWORD 64 + +# PARTAB -- Transfer an IRAF parameter value to a table element +# +# B.Simon 17-Aug-87 First Code + +procedure t_partab () + +pointer value # Value of table element +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table + +bool undef +int eltype +pointer sp, hd + +bool streq() +int clgeti(), datatype() +pointer tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + + # Read input parameters + + call clgstr ("value", Memc[value], SZ_KEYWORD) + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + + eltype = datatype (Memc[value]) + undef = streq (Memc[value], "INDEF") + + # Write the table element according to its datatype + + hd = tbtopn (Memc[table], READ_WRITE, NULL) + call puttabdat (hd, Memc[column], row, Memc[value], undef, eltype) + call tbtclo (hd) + + # Free string storage + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/putimghdr.x b/pkg/utilities/nttools/copyone/putimghdr.x new file mode 100644 index 00000000..bc0b34c6 --- /dev/null +++ b/pkg/utilities/nttools/copyone/putimghdr.x @@ -0,0 +1,118 @@ +define USRERR 1 + +# PUTIMGHDR -- Put a keyword given as a string in an image header +# +# B.Simon 14-Aug-87 First Code +# B.Simon 27-Jul-94 Fix bug in addition of double +# B.Simon 21-Jul-97 Workaround for imgftype bug + +procedure putimghdr (hd, keyword, value, keytype, add) + +pointer hd # i: Image descriptor +char keyword[ARB] # i: Keyword to put +char value[ARB] # i: Keyword value +int keytype # i: Keyword type +bool add # i: Is adding a new keyword legal? +#-- +bool bvalue +double dvalue +int ip, junk, hdrtype +pointer sp, rp, keyval, errtxt + +string badtyperr "Type mismatch in header keyword (%s)" +string notadderr "Keyword not found in header (%s)" + +int ctod(), idb_findrecord(), imgftype(), stridx() + +begin + + call smark (sp) + call salloc (keyval, SZ_FNAME, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Convert keyword value to a double + + ip = 1 + junk = ctod (value, ip, dvalue) + + # If keyword is already in the image header + + if (idb_findrecord (hd, keyword, rp) > 0) { + + hdrtype = imgftype (hd, keyword) + + # Extra test to work around bug in imgftype + + if (hdrtype == TY_BOOL) { + call imgstr(hd, keyword, Memc[keyval], SZ_FNAME) + if (Memc[keyval+1] != EOS) + hdrtype = TY_CHAR + } + + # Check for illegal type conversions + + if ((hdrtype == TY_BOOL && keytype != TY_BOOL) || + (!(hdrtype == keytype || hdrtype == TY_CHAR) && + (keytype == TY_BOOL || keytype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new keyword value + + switch (hdrtype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call imputb (hd, keyword, bvalue) + case TY_CHAR : + call impstr (hd, keyword, value) + case TY_SHORT : + call imputs (hd, keyword, short(dvalue)) + case TY_INT : + call imputi (hd, keyword, int(dvalue)) + case TY_LONG : + call imputl (hd, keyword, long(dvalue)) + case TY_REAL : + call imputr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call imputd (hd, keyword, dvalue) + } + + } else { + + # Check to see if it legal to add a new keyword + + if (! add) { + call sprintf (Memc[errtxt], SZ_LINE, notadderr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + # Create the new keyword and set its value + + switch (keytype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call imaddb (hd, keyword, bvalue) + case TY_CHAR : + call imastr (hd, keyword, value) + case TY_SHORT : + call imadds (hd, keyword, short(dvalue)) + case TY_INT : + call imaddi (hd, keyword, int(dvalue)) + case TY_LONG : + call imaddl (hd, keyword, long(dvalue)) + case TY_REAL : + call imaddr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call imaddd (hd, keyword, dvalue) + } + + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/puttabdat.x b/pkg/utilities/nttools/copyone/puttabdat.x new file mode 100644 index 00000000..b5742f98 --- /dev/null +++ b/pkg/utilities/nttools/copyone/puttabdat.x @@ -0,0 +1,106 @@ +include <tbset.h> +define USRERR 1 + +# PUTTABDAT -- Write a value passed as a string into a table element +# +# B.Simon 17-Aug-87 First Code + +procedure puttabdat (hd, colname, rownum, value, undef, eltype) + +pointer hd # i: Table descriptor +char colname[ARB] # i: Table column name +int rownum # i: Table row number +char value[ARB] # i: Table element value +bool undef # i: Is table element undefined? +int eltype # i: Type of table element + +bool bvalue[1] +double dvalue[1] +int ivalue[1] +pointer colptr[1] +real rvalue[1] + +int coltype, lendata, ip, junk, maxch +pointer sp, errtxt + +string badtyperr "Type mismatch in table column (%s)" +string badnamerr "Column name not found in table (%s)" + +int ctod() +int stridx(), strlen(), tbcigi() + +begin + # Allocate dynamic memory to hold strings + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Get the column pointer from the column name + + call tbcfnd (hd, colname, colptr, 1) + + # If the pointer is NULL, the column was not found + + if (colptr[1] == NULL) { + call sprintf (Memc[errtxt], SZ_LINE, badnamerr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + } + + # Get the column data type. Store in coltype + + coltype = tbcigi (colptr[1], TBL_COL_DATATYPE) + if (coltype < 0) { + lendata = - coltype + coltype = TY_CHAR + } + + if (undef) + + # Set table element to undefined + + call tbrudf (hd, colptr, 1, rownum) + + else { + + # Convert element value to a double + + ip = 1 + junk = ctod (value, ip, dvalue[1]) + + # Check for illegal type conversions + + if ((coltype == TY_BOOL && eltype != TY_BOOL) || + (!(coltype == eltype || coltype == TY_CHAR) && + (eltype == TY_BOOL || eltype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (colname) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new element value + + switch (coltype) { + case TY_BOOL : + bvalue[1] = stridx (value[1], "TtYy") > 0 + call tbrptb (hd, colptr, bvalue, 1, rownum) + case TY_CHAR : + maxch = strlen (value) + 1 + call tbrptt (hd, colptr, value, maxch, 1, rownum) + case TY_SHORT,TY_INT,TY_LONG : + ivalue[1] = int (dvalue[1]) + call tbrpti (hd, colptr, ivalue, 1, rownum) + case TY_REAL : + rvalue[1] = real (dvalue[1]) + call tbrptr (hd, colptr, rvalue, 1, rownum) + case TY_DOUBLE : + call tbrptd (hd, colptr, dvalue, 1, rownum) + } + } + + call sfree (sp) + + return +end diff --git a/pkg/utilities/nttools/copyone/puttabhdr.x b/pkg/utilities/nttools/copyone/puttabhdr.x new file mode 100644 index 00000000..ffcb6643 --- /dev/null +++ b/pkg/utilities/nttools/copyone/puttabhdr.x @@ -0,0 +1,104 @@ +define USRERR 1 + +# PUTTABHDR -- Put a keyword given as a string in a table header +# +# B.Simon 14-Aug-87 First Code +# B.Simon 27-Jul-94 Fix bug in addition of double +# B.Simon 10-Nov-95 Add check for history keyword + +procedure puttabhdr (hd, keyword, value, keytype, add) + +pointer hd # i: Table descriptor +char keyword[ARB] # i: Keyword to put +char value[ARB] # i: Keyword value +int keytype # i: Keyword type +bool add # i: Is adding a new keyword legal? +#-- +bool bvalue +double dvalue +int ip, junk, hdrtype, keynum +pointer sp, errtxt + +string badtyperr "Type mismatch in header keyword (%s)" +string notadderr "Keyword not found in header (%s)" + +bool tbhisc() +int ctod(), tabhdrtyp(), stridx() + +begin + + call smark (sp) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + # Convert keyword value to a double + + ip = 1 + junk = ctod (value, ip, dvalue) + + # If keyword is not already in the table header + # or this is a history keyword + + call tbhfkw (hd, keyword, keynum) + if ( keynum == 0 || tbhisc (keyword)) { + + # Check to see if it legal to add a new keyword + + if (! add) { + call sprintf (Memc[errtxt], SZ_LINE, notadderr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + # Create the new keyword and set its value + + switch (keytype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call tbhadb (hd, keyword, bvalue) + case TY_CHAR : + call tbhadt (hd, keyword, value) + case TY_SHORT,TY_INT,TY_LONG : + call tbhadi (hd, keyword, int(dvalue)) + case TY_REAL : + call tbhadr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call tbhadd (hd, keyword, dvalue) + } + + } else { + + hdrtype = tabhdrtyp (hd, keyword) + + # Check for illegal type conversions + + if ((hdrtype == TY_BOOL && keytype != TY_BOOL) || + (!(hdrtype == keytype || hdrtype == TY_CHAR) && + (keytype == TY_BOOL || keytype == TY_CHAR) ) ) { + + call sprintf (Memc[errtxt], SZ_LINE, badtyperr) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + + } + + # Use the proper procedure to write the new keyword value + + switch (hdrtype) { + case TY_BOOL : + bvalue = stridx (value[1], "TtYy") > 0 + call tbhptb (hd, keyword, bvalue) + case TY_CHAR : + call tbhptt (hd, keyword, value) + case TY_SHORT,TY_INT,TY_LONG : + call tbhpti (hd, keyword, int(dvalue)) + case TY_REAL : + call tbhptr (hd, keyword, real(dvalue)) + case TY_DOUBLE : + call tbhptd (hd, keyword, dvalue) + } + + } + + call sfree (sp) + return +end diff --git a/pkg/utilities/nttools/copyone/tabaccess.x b/pkg/utilities/nttools/copyone/tabaccess.x new file mode 100644 index 00000000..93c93337 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabaccess.x @@ -0,0 +1,19 @@ +# TABACCESS -- Test to see if an table is accessible with the given access +# mode. Return the result of the test as YES or NO. +# +# B.Simon 12-Aug-87 First Code +# B.Simon 19-Jun-95 Revised to use tbtacc + +int procedure tabaccess (tablename, acmode) + +char tablename[ARB] # i: table file name +int acmode # i: access mode +#-- +int tbtacc() + +begin + if (acmode == NEW_FILE || acmode == NEW_COPY) + return (YES) + + return (tbtacc (tablename)) +end diff --git a/pkg/utilities/nttools/copyone/tabhdrtyp.x b/pkg/utilities/nttools/copyone/tabhdrtyp.x new file mode 100644 index 00000000..7d65e89f --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabhdrtyp.x @@ -0,0 +1,34 @@ +include <tbset.h> +define USRERR 1 + +# TABHDRTYP -- Return the type of a table header keyword +# +# B. Simon 12-Aug-87 First Code +# Phil Hodge 9-Mar-89 Change to itype in calling sequence of tbhfkr. + +int procedure tabhdrtyp (tp, keyword) + +pointer tp # i: Table descriptor +char keyword[ARB] # i: Header keyword +#-- +int parnum, itype +pointer sp, keyval, errtxt + +string nokeyfnd "Keyword not found (%s)" + +begin + call smark (sp) + call salloc (keyval, SZ_PARREC, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) + + call tbhfkr (tp, keyword, itype, Memc[keyval], parnum) + + if (parnum == 0) { + call sprintf (Memc[errtxt], SZ_LINE, nokeyfnd) + call pargstr (keyword) + call error (USRERR, Memc[errtxt]) + } + + call sfree (sp) + return (itype) +end diff --git a/pkg/utilities/nttools/copyone/tabkey.x b/pkg/utilities/nttools/copyone/tabkey.x new file mode 100644 index 00000000..9efd2329 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabkey.x @@ -0,0 +1,94 @@ +include <tbset.h> +include "filetype.h" +define SZ_KEYWORD 64 +define USRERR 1 + +# TABKEY -- Transfer a table element to a header keyword +# +# B.Simon 17-Aug-87 First Code +# B.Simon 24-Jan-92 Added salloc for errtxt +# Phil Hodge 15-May-2002 Add 'format' argument to gettabdat. + +procedure t_tabkey () + +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +pointer output # Name of file containing header keyword +pointer keyword # Name of header keyword +bool add # Is it OK to add a new keyword? + +bool undef +bool format # Format the value using table print format? +int ftype, eltype +pointer sp, hd, value, errtxt + +string undeferr "Table element is undefined" +string unfilerr "Header file name not found or ambiguous (%s)" + +bool clgetb() +int clgeti(), filetype() +pointer immap(), tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (keyword, SZ_KEYWORD, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + call salloc (errtxt, SZ_LINE, TY_CHAR) # Added (BPS 01.24.92) + + # Read input parameters + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + call clgstr ("output", Memc[output], SZ_FNAME) + call clgstr ("keyword", Memc[keyword], SZ_KEYWORD) + add = clgetb("add") + + # Read the table element as a character string + + format = false + hd = tbtopn (Memc[table], READ_ONLY, NULL) + call gettabdat (hd, Memc[column], row, SZ_KEYWORD, format, + Memc[value], undef, eltype) + call tbtclo (hd) + + # It is an error to try to write an undefined value to the header + + if (undef) + call error (USRERR, undeferr) + + ftype = filetype (Memc[output]) + + if (ftype == IMAGE_FILE) { + + # Write image header keyword + + hd = immap (Memc[output], READ_WRITE, NULL) + call putimghdr (hd, Memc[keyword], Memc[value], eltype, add) + call imunmap (hd) + + } else if (ftype == TABLE_FILE) { + + # Write table header keyword + + hd = tbtopn (Memc[output], READ_WRITE, NULL) + call puttabhdr (hd, Memc[keyword], Memc[value], eltype, add) + call tbtclo (hd) + + } else { + + call sprintf (Memc[errtxt], SZ_LINE, unfilerr) + call pargstr (Memc[output]) + call error (USRERR, Memc[errtxt]) + + } + + call sfree(sp) + return +end diff --git a/pkg/utilities/nttools/copyone/tabpar.x b/pkg/utilities/nttools/copyone/tabpar.x new file mode 100644 index 00000000..a4f452c3 --- /dev/null +++ b/pkg/utilities/nttools/copyone/tabpar.x @@ -0,0 +1,54 @@ +include <tbset.h> +define SZ_KEYWORD 64 + +# TABPAR -- Transfer a table element to an IRAF parameter +# +# B.Simon 17-Aug-1987 First Code +# Phil Hodge 15-May-2002 Add 'format' parameter. + +procedure t_tabpar () + +pointer table # Name of table +pointer column # Name of column +int row # Row number of element in the table +bool format # Format the value using table print format? +pointer value # Value of table element +bool undef # Is table element undefined? + +int eltype +pointer sp, hd + +bool clgetb() +int clgeti() +pointer tbtopn() + +begin + # Allocate storage for character strings + + call smark (sp) + call salloc (table, SZ_FNAME, TY_CHAR) + call salloc (column, SZ_COLNAME, TY_CHAR) + call salloc (value, SZ_KEYWORD, TY_CHAR) + + # Read input parameters + + call clgstr ("table", Memc[table], SZ_FNAME) + call clgstr ("column", Memc[column], SZ_COLNAME) + row = clgeti ("row") + format = clgetb ("format") + + # Read the table element as a character string + + hd = tbtopn (Memc[table], READ_ONLY, NULL) + call gettabdat (hd, Memc[column], row, SZ_KEYWORD, format, + Memc[value], undef, eltype) + call tbtclo (hd) + + # Write output parameters and free string storage + + call addslash (Memc[value], SZ_KEYWORD) + call clpstr ("value", Memc[value]) + call clputb ("undef", undef) + call sfree (sp) + return +end |