Repatch (from linux) of OSX IRAF

5 files changed, 449 insertions, 0 deletions

diff --git a/pkg/utilities/nttools/threed/tscopy/mkpkg b/pkg/utilities/nttools/threed/tscopy/mkpkg
new file mode 100644
index 00000000..21136d98
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/mkpkg
@@ -0,0 +1,14 @@
+# Update the tcopy application code in the threed package library.
+# Author: I.Busko, 21-Nov-1996
+
+$checkout libpkg.a ../
+$update   libpkg.a
+$checkin  libpkg.a ../
+$exit
+
+libpkg.a:
+	tscopy.x	<error.h>
+	tcpyone.x	<tbset.h>
+	tcpyrow.x	<tbset.h>
+	;
+
diff --git a/pkg/utilities/nttools/threed/tscopy/tbracket.x b/pkg/utilities/nttools/threed/tscopy/tbracket.x
new file mode 100644
index 00000000..5c9364c4
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/tbracket.x
@@ -0,0 +1,105 @@
+#* HISTORY *
+#* B.Simon	07-Nov-94	original
+
+# TBRACKET -- Break a table name into bracket delimeted substrings
+
+procedure tbracket (table, root, rowselect, colselect, maxch)
+
+char	table[ARB]		# i: Table name
+char	root[ARB]		# o: Name minus bracketed sections
+char	rowselect[ARB]		# o: Row selector section
+char	colselect[ARB]		# o: Column selector section
+int	maxch			# i: Maximum length of output strings
+#--
+bool	found
+char	eq
+int	ic, nc
+
+data	eq  / '=' /
+
+errchk	tsplitter
+bool	tsplitter()
+int	stridx()
+
+begin
+	# Search for the first unescaped bracket
+
+	for (ic = 1; table[ic] != EOS; ic = ic + 1) {
+	    if (table[ic] == '\\' && table[ic+1] != EOS) {
+		ic = ic + 1
+	    } else if (table[ic] == '['){
+		break
+	    }
+	}
+
+	nc = min (ic-1, maxch)
+	call strcpy (table, root, nc)
+
+	# Get bracketed sections from table name. If there is only 
+	# a single section, disambiguate by looking for an equals 
+	# sign, which indicates a row selector.
+
+	found = tsplitter (table, ic, rowselect, maxch)
+
+	if (! tsplitter (table, ic, colselect, maxch)) {
+	    if (stridx (eq, rowselect) == 0) {
+		call strcpy (rowselect, colselect, maxch)
+		rowselect[1] = EOS
+	    }
+	}
+
+end
+
+# TSPLITTER -- Splits table filename into sections
+
+bool procedure tsplitter (table, ic, section, maxch)
+
+char	table[ARB]	# i: table name
+int	ic		# u: index to char within name
+char	section[ARB]	# o: section extracted from name
+int	maxch		# i: maximum length of section
+#--
+int	jc, level
+pointer	sp, errmsg
+
+string	badsect  "No closing bracket (%s)"
+
+begin
+	if (table[ic] != '[') {
+	    section[1] = EOS
+	    return (false)
+	} else {
+	    level = 1
+	    ic = ic + 1
+	}
+
+	call smark (sp)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	jc = 1
+	while (level > 0 && table[ic] != EOS) {
+	    if (table[ic] == '[' && table[ic-1] != '\\') {
+		level = level + 1
+	    } else if (table[ic] == ']' && table[ic-1] != '\\') {
+		level = level - 1
+	    }
+
+	    if (level > 0 && jc <= maxch) {
+		section[jc] = table[ic]
+		jc = jc + 1
+	    }
+
+	    ic = ic + 1
+	}
+
+	section[jc] = EOS
+
+	if (level > 0) {
+	    call sprintf (Memc[errmsg], SZ_LINE, badsect)
+	    call pargstr (table)
+	    call error (1, Memc[errmsg])
+	}
+
+	call sfree (sp)
+	return (true)
+end
diff --git a/pkg/utilities/nttools/threed/tscopy/tcpyone.x b/pkg/utilities/nttools/threed/tscopy/tcpyone.x
new file mode 100644
index 00000000..23c86316
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/tcpyone.x
@@ -0,0 +1,141 @@
+include	<tbset.h>
+
+#* HISTORY *
+#* B.Simon	07-Nov-1994	original
+#  Phil Hodge	 8-Apr-1999	call tbfpri
+
+# TCPYONE -- Copy a single table to the output table
+
+procedure tcpyone (input, output)
+
+char	input[ARB]	# i: input table name
+char	output[ARB]	# i: output table name
+#--
+int     numrow, numcol, numptr, type, iptr, irow, jrow
+int     colnum, datatype, lendata, lenfmt
+int	phu_copied	# returned by tbfpri and ignored
+pointer	sp, root, extend, rowselect, colselect, colname, colunits, colfmt
+pointer errmsg, icp, ocp, itp, otp, colptr, newcol, pcode
+
+string	nosect  "Sections not permitted on output table name (%s)"
+string	nocols  "Column names not found (%s)"
+
+errchk	tbfpri, tbtopn, tctexp, tbracket, trsopen, trseval
+
+bool	trseval(), streq()
+int	tbpsta(), tcs_totsize()
+pointer	tbtopn(), tcs_column, trsopen()
+
+begin
+	# Allocate memory for temporary strings
+
+	call smark (sp)
+	call salloc (root, SZ_FNAME, TY_CHAR)
+	call salloc (extend, SZ_FNAME, TY_CHAR)
+	call salloc (rowselect, SZ_FNAME, TY_CHAR)
+	call salloc (colselect, SZ_FNAME, TY_CHAR)
+        call salloc (colname, SZ_COLNAME, TY_CHAR)
+        call salloc (colunits, SZ_COLUNITS, TY_CHAR)
+        call salloc (colfmt, SZ_COLFMT, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+	# Check output table name for sections
+
+#	call getsects (output, Memc[root], Memc[extend], Memc[rowselect], 
+#		       Memc[colselect], SZ_FNAME)
+
+call rdselect (output, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME)
+
+	if (Memc[rowselect] != EOS || Memc[colselect] != EOS) {
+	    call sprintf (Memc[errmsg], SZ_LINE, nosect)
+	    call pargstr (output)
+	    call error (1, Memc[errmsg])
+	}
+
+	# Break input file names into bracketed sections
+
+#	call getsects (input, Memc[root], Memc[extend], Memc[rowselect], 
+#		       Memc[colselect], SZ_FNAME)
+
+call rdselect (input, Memc[root], Memc[rowselect], Memc[colselect], SZ_FNAME)
+
+	if (Memc[rowselect] == EOS && Memc[colselect] == EOS) {
+	    # Perform straight file copy if no sections on input name
+
+	    call tbfpri (input, output, phu_copied)
+	    call tbtcpy (input, output)
+
+	} else {
+            # Open the tables and set output table type
+
+#	    call strcat (Memc[extend], Memc[root], SZ_FNAME)
+
+            itp = tbtopn (Memc[root], READ_ONLY, NULL)
+	    call tbfpri (Memc[root], output, phu_copied)
+            otp = tbtopn (output, NEW_FILE, NULL)
+
+            type = tbpsta (itp, TBL_WHTYPE)
+	    # Support for ASCII output (11/20/96, IB)
+	    if (streq (output, "STDOUT"))
+	        type = TBL_TYPE_TEXT
+            call tbpset (otp, TBL_WHTYPE, type)
+
+            # Create an array of column pointers from the column template
+
+	    numrow = tbpsta (itp, TBL_NROWS)
+            numcol = tbpsta (itp, TBL_NCOLS)
+
+            call salloc (colptr, numcol, TY_INT)
+	    call salloc (newcol, numcol, TY_INT)
+
+	    call tcs_open (itp, Memc[colselect], Memi[colptr], numptr, numcol)
+
+	    # Take an error exit if no columns were matched
+
+            if (numptr == 0) {
+		call sprintf (Memc[errmsg], SZ_LINE, nocols)
+		call pargstr (input)
+		call error (1, Memc[errmsg])
+	    }
+
+	    # Copy column information from the input table to the output table
+
+	    do iptr = 1, numptr {
+		icp = tcs_column (Memi[colptr+iptr-1])
+		call tbcinf (icp, colnum, Memc[colname], Memc[colunits], 
+			     Memc[colfmt], datatype, lendata, lenfmt)
+
+		if (lendata > 1)
+		    lendata = tcs_totsize (Memi[colptr+iptr-1])
+
+		call tbcdef (otp, ocp, Memc[colname], Memc[colunits], 
+			     Memc[colfmt], datatype, lendata, 1)
+		Memi[newcol+iptr-1] = ocp    
+	    }
+
+	    # Copy header keywords
+
+	    call tbtcre (otp)
+	    call tbhcal (itp, otp)
+
+	    # Copy selected rows from input to output table
+
+	    jrow = 1
+	    pcode = trsopen (itp, Memc[rowselect])
+
+	    do irow = 1, numrow {
+		if (trseval (itp, irow, pcode)) {
+		    call tcpyrow (itp, otp, Memi[colptr], Memi[newcol], 
+				  irow, jrow, numptr)
+		    jrow = jrow + 1
+		}
+	    }
+
+	    call trsclose (pcode)
+	    call tcs_close (Memi[colptr], numptr)
+            call tbtclo (itp)
+            call tbtclo (otp)
+	}
+
+	call sfree (sp)
+end
diff --git a/pkg/utilities/nttools/threed/tscopy/tcpyrow.x b/pkg/utilities/nttools/threed/tscopy/tcpyrow.x
new file mode 100644
index 00000000..3eeb8c99
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/tcpyrow.x
@@ -0,0 +1,79 @@
+include <tbset.h>
+
+# TCPYROW -- Copy a single row from the input to output table
+ 
+procedure tcpyrow (itp, otp, icp, ocp, irow, orow, ncols)
+
+pointer itp		# i: pointer to descriptor of input table
+pointer otp		# i: pointer to descriptor of output table
+pointer icp[ncols]	# i: array of pointers for input columns
+pointer ocp[ncols]	# i: array of pointers for output columns
+int	irow		# i: row number in input table
+int	orow		# i: row number in output table
+int	ncols		# i: number of columns to be copied
+#--
+int	icol, dlen, dtype, maxch, nbuf
+pointer	sp, buf, errmsg, colname
+
+string	badtype  "Unsupported column data type (%s)"
+
+int	tcs_intinfo(), tcs_totsize()
+
+begin
+	do icol = 1, ncols {
+	    # Determine the length and datatype of the table column
+	    # and allocate a buffer to match
+
+	    dlen = tcs_totsize (icp[icol])
+	    dtype = tcs_intinfo (icp[icol], TBL_COL_DATATYPE)
+
+	    maxch = 1
+	    if (dtype < 0) {
+		maxch = - dtype
+		dtype = TY_CHAR
+	    }
+
+	    call smark (sp)
+	    call salloc (buf, dlen*(maxch + 1), dtype)
+	    
+	    # Read the data from the input table and write it 
+	    # to the output table
+
+	    switch (dtype) {
+	    case TY_BOOL:
+		call tcs_rdaryb (itp, icp[icol], irow, dlen, nbuf, Memb[buf])
+		call tbaptb (otp, ocp[icol], orow, Memb[buf], 1, nbuf)
+	    case TY_CHAR:
+		call tcs_rdaryt (itp, icp[icol], irow, maxch, dlen, 
+				 nbuf, Memc[buf])
+		call tbaptt (otp, ocp[icol], orow, Memc[buf], maxch, 1, nbuf)
+	    case TY_SHORT:
+		call tcs_rdarys (itp, icp[icol], irow, dlen, nbuf, Mems[buf])
+		call tbapts (otp, ocp[icol], orow, Mems[buf], 1, nbuf)
+	    case TY_INT, TY_LONG:
+		call tcs_rdaryi (itp, icp[icol], irow, dlen, nbuf, Memi[buf])
+		call tbapti (otp, ocp[icol], orow, Memi[buf], 1, nbuf)
+	    case TY_REAL:
+		call tcs_rdaryr (itp, icp[icol], irow, dlen, nbuf, Memr[buf])
+		call tbaptr (otp, ocp[icol], orow, Memr[buf], 1, nbuf)
+	    case TY_DOUBLE:
+		call tcs_rdaryd (itp, icp[icol], irow, dlen, nbuf, Memd[buf])
+		call tbaptd (otp, ocp[icol], orow, Memd[buf], 1, nbuf)
+	    default:
+		# Unsupported type, write error message
+
+		call salloc (colname, SZ_COLNAME, TY_CHAR)
+		call salloc (errmsg, SZ_LINE, TY_CHAR)
+
+		call tcs_txtinfo (icp[icol], TBL_COL_NAME, 
+				  Memc[colname], SZ_COLNAME)
+
+		call sprintf (Memc[errmsg], SZ_LINE, badtype)
+		call pargstr (Memc[colname])
+
+		call error (1, Memc[errmsg])
+	    }
+
+	    call sfree (sp)
+	}
+end
diff --git a/pkg/utilities/nttools/threed/tscopy/tscopy.x b/pkg/utilities/nttools/threed/tscopy/tscopy.x
new file mode 100644
index 00000000..30629f6c
--- /dev/null
+++ b/pkg/utilities/nttools/threed/tscopy/tscopy.x
@@ -0,0 +1,110 @@
+include	<error.h>
+
+# tcopy -- Copy table(s)
+
+# The input tables are given by an filename template list.  The output
+# is either a matching list of tables or a directory.  The number of
+# input tables may be either one or match the number of output tables.
+# This is based on the t_imcopy procedure.
+#
+# Phil Hodge, 21-Aug-87  Task created.
+# Phil Hodge,  7-Sep-88  Change parameter names for tables.
+# Phil Hodge, 28-Dec-89  Use iferr with call to tbtcpy.
+# Phil Hodge, 26-Mar-92  Remove calls to tbtext.
+# B.Simon,    04-Nov-94  Replace call to tbtcpy with tcpyone
+# I.Busko,    20-Nov-95  Add support for ASCII output.
+
+procedure t_tcopy()
+
+char	tablist1[SZ_LINE]		# Input table list
+char	tablist2[SZ_LINE]		# Output table list
+bool	verbose				# Print operations?
+
+char	table1[SZ_PATHNAME]		# Input table name
+char	table2[SZ_PATHNAME]		# Output table name
+char	dirname1[SZ_PATHNAME]		# Directory name
+char	dirname2[SZ_PATHNAME]		# Directory name
+
+int	list1, list2, root_len
+pointer	sp
+
+int	imtopen(), imtgetim(), imtlen()
+int	fnldir(), isdirectory()
+bool	clgetb(), streq()
+
+begin
+	# Get input and output table template lists.
+
+	call clgstr ("intable", tablist1, SZ_LINE)
+	call clgstr ("outtable", tablist2, SZ_LINE)
+	verbose = clgetb ("verbose")
+
+	# Check if the output string is a directory.
+
+	if (isdirectory (tablist2, dirname2, SZ_PATHNAME) > 0 &&
+                !streq (tablist2, "STDOUT")) {
+	    list1 = imtopen (tablist1)	
+	    while (imtgetim (list1, table1, SZ_PATHNAME) != EOF) {
+		call smark (sp)
+
+		# Place the input table name without a directory in
+		# string dirname1.
+
+		call get_root (table1, table2, SZ_PATHNAME)
+		root_len = fnldir (table2, dirname1, SZ_PATHNAME)
+		call strcpy (table2[root_len + 1], dirname1, SZ_PATHNAME)
+
+		call strcpy (dirname2, table2, SZ_PATHNAME)
+		call strcat (dirname1, table2, SZ_PATHNAME)
+
+		if (verbose) {
+		    call eprintf ("%s -> %s\n")
+			call pargstr (table1)
+			call pargstr (table2)
+		}
+		iferr (call tcpyone (table1, table2))
+		    call erract (EA_WARN)
+
+		call sfree (sp)
+	    }
+	    call imtclose (list1)
+
+	} else {
+	    # Expand the input and output table lists.
+
+	    list1 = imtopen (tablist1)
+	    list2 = imtopen (tablist2)
+
+	    if (imtlen (list1) != imtlen (list2)) {
+	        call imtclose (list1)
+	        call imtclose (list2)
+	        call error (1, "Number of input and output tables not the same")
+	    }
+
+	    # Copy each table.
+
+	    while ((imtgetim (list1, table1, SZ_PATHNAME) != EOF) &&
+		   (imtgetim (list2, table2, SZ_PATHNAME) != EOF)) {
+
+		call smark (sp)
+
+		if (streq (table1, table2)) {
+		    call eprintf ("can't copy table to itself:  %s\n")
+			call pargstr (table1)
+		    next
+		}
+		if (verbose) {
+		    call eprintf ("%s -> %s\n")
+			call pargstr (table1)
+			call pargstr (table2)
+		}
+		iferr (call tcpyone (table1, table2))
+		    call erract (EA_WARN)
+
+		call sfree (sp)
+	    }
+
+	    call imtclose (list1)
+	    call imtclose (list2)
+	}
+end