1 files changed, 257 insertions, 0 deletions
diff --git a/pkg/tbtables/tbzwrt.x b/pkg/tbtables/tbzwrt.x
new file mode 100644
index 00000000..dcb19da4
--- /dev/null
+++ b/pkg/tbtables/tbzwrt.x
@@ -0,0 +1,257 @@
+include <ctype.h>
+include <tbset.h>
+include "tbtables.h"
+include "tbltext.h"
+
+define	COLWIDTH	10	# width for holding print format for a column
+
+# tbzwrt -- write data values to a text file
+# The table data are written from memory to a temporary file, the original
+# text table is deleted, and then the temp file is renamed to the name
+# of the original text table.  The file is closed by this routine, and
+# TB_FILE(tp) is set to NULL.  If the output file is STDOUT or STDERR,
+# however, the data are just written to that fd.
+# A string will be enclosed in quotes if the string contains a blank or tab
+# or if it begins with a number or plus or minus.  The latter is necessary
+# in case the table rows are reordered, putting this string in the first
+# row, because without quotes it would appear to be a numeric column.
+#
+# If no change has been made to the table, this routine returns without
+# doing anything.
+#
+# Phil Hodge, 25-Mar-1992  Subroutine created.
+# Phil Hodge, 20-Jul-1992  Don't quote string just because it begins with digit.
+# Phil Hodge, 25-Nov-1994  Don't quote if only leading or trailing blanks.
+# Phil Hodge,  2-Dec-1994  Include test on pform longer than SZ_OBUF.
+# Phil Hodge,  3-Apr-1995  Check TB_MODIFIED.
+# Phil Hodge,  2-Jan-1996  Quote blank strings; write INDEFI for undefined int.
+# Phil Hodge, 14-Apr-1998  Use COL_FMT directly, instead of calling tbcftg.
+# Phil Hodge, 12-Apr-1999  Check for STDERR, in addition to STDOUT.
+# Phil Hodge, 21-Apr-1999  Print each column one at a time, rather than
+#		using one fprintf with all the print formats concatenated;
+#		this is to avoid the line length limit imposed by SZ_OBUF.
+# Phil Hodge, 15-Jun-1999  Modify for table with explicit column definitions.
+
+procedure tbzwrt (tp)
+
+pointer tp			# i: pointer to table descriptor
+#--
+pointer sp
+pointer temp			# scratch for name of temporary table
+pointer cbuf			# buffer for output string
+pointer colname			# for comparing column name with "c<n>"
+pointer cp			# pointer to column descriptor
+int	fd			# fd for temporary table
+int	key			# loop index for keyword number
+int	row_1			# row number minus one
+int	ncols			# number of columns
+int	colnum			# column number
+int	lenstr			# length of a string table element
+int	ip			# offset for extracting a string in Memc
+int	i			# loop index
+int	istart, iend		# limits on i when looking for embedded blanks
+bool	to_stdout		# is output file STDOUT?
+bool	quote			# whitespace in string?  then enclose in quotes
+char	blank			# ' ', as an argument to stridx
+int	stridx()
+int	strlen(), open()
+bool	streq()
+
+begin
+	if (!TB_MODIFIED(tp))
+	    return
+
+	blank = ' '
+
+	call smark (sp)
+	call salloc (temp, SZ_FNAME, TY_CHAR)
+	call salloc (cbuf, SZ_LINE, TY_CHAR)
+
+	ncols = TB_NCOLS(tp)
+
+	# If the output file is STDOUT or STDERR, we just write to it.
+	if (streq (TB_NAME(tp), "STDOUT")) {
+	    to_stdout = true
+	    fd = STDOUT
+	} else if (streq (TB_NAME(tp), "STDERR")) {
+	    to_stdout = true
+	    fd = STDERR
+	} else {
+	    to_stdout = false
+	    # Create temporary table (text file).
+	    call mktemp ("tmp$texttbl", Memc[temp], SZ_FNAME)
+	    fd = open (Memc[temp], NEW_FILE, TEXT_FILE)
+	}
+
+	# Check whether the table has been "converted" from simple format
+	# to explicit, by setting a column name or units.  If any column
+	# name differs from "c<N>" (case insensitive; any N, not just the
+	# current column number), or if units have been specified for any
+	# column, the table subtype will be reset to explicit column def.
+	if (TB_SUBTYPE(tp) != TBL_SUBTYPE_EXPLICIT) {
+	    call salloc (colname, SZ_COLNAME, TY_CHAR)
+	    do colnum = 1, TB_NCOLS(tp) {
+		cp = TB_COLINFO(tp,colnum)
+		if (COL_UNITS(cp) != EOS) {
+		    TB_SUBTYPE(tp) = TBL_SUBTYPE_EXPLICIT
+		    break
+		}
+		call strcpy (COL_NAME(cp), Memc[colname], SZ_COLNAME)
+		call strlwr (Memc[colname])
+		if (Memc[colname] != 'c') {
+		    TB_SUBTYPE(tp) = TBL_SUBTYPE_EXPLICIT
+		    break
+		} else if (Memc[colname+1] == EOS || Memc[colname+1] == '0') {
+		    # A column name for a simple text table is never just "c"
+		    # without a number, and the number never begins with "0".
+		    TB_SUBTYPE(tp) = TBL_SUBTYPE_EXPLICIT
+		    break
+		} else {
+		    do i = 2, SZ_COLNAME {
+			if (Memc[colname+i-1] == EOS)
+			    break
+			if (!IS_DIGIT(Memc[colname+i-1])) {
+			    TB_SUBTYPE(tp) = TBL_SUBTYPE_EXPLICIT
+			    break
+			}
+		    }
+		}
+	    }
+	}
+
+	# If the table has explicit column definitions, write them.
+	if (TB_SUBTYPE(tp) == TBL_SUBTYPE_EXPLICIT) {
+
+	    do colnum = 1, TB_NCOLS(tp) {
+
+		cp = TB_COLINFO(tp,colnum)
+
+		call fprintf (fd, "#c ")
+
+		quote = (stridx (blank, COL_NAME(cp)) > 0)
+		if (quote) {
+		    call fprintf (fd, "\"%s\"")
+		} else {
+		    call fprintf (fd, "%s")
+		}
+		    call pargstr (COL_NAME(cp))
+
+		if (COL_DTYPE(cp) == TBL_TY_DOUBLE) {
+		    call fprintf (fd, " d")
+		} else if (COL_DTYPE(cp) == TBL_TY_INT) {
+		    call fprintf (fd, " i")
+		} else if (COL_DTYPE(cp) < 0) {
+		    call fprintf (fd, " ch*%d")
+			call pargi (-COL_DTYPE(cp))
+		} else {
+		    call fprintf (fd, " ch*1024")
+		}
+
+		call fprintf (fd, " %s")
+		    call pargstr (COL_FMT(cp))
+
+		quote = (stridx (blank, COL_UNITS(cp)) > 0)
+		if (quote) {
+		    call fprintf (fd, " \"%s\"")
+		} else {
+		    call fprintf (fd, " %s")
+		}
+		    call pargstr (COL_UNITS(cp))
+		call fprintf (fd, "\n")
+	    }
+	}
+
+	# If there are keywords, write them.
+	if (TB_KEYLIST_PTR(tp) != NULL) {
+	    do key = 1, TB_NPAR(tp) {
+		call fprintf (fd, "%s\n")
+		    call pargstr (Memc[TB_KEYWORD(tp,key)])
+	    }
+	}
+
+	# Write the comment buffer to the output file.
+	if (TB_COMMENT(tp) != NULL) {
+	    if (Memc[TB_COMMENT(tp)] != EOS)
+		call putline (fd, Memc[TB_COMMENT(tp)])
+	}
+
+	# Print each row to the file.
+	do row_1 = 0, TB_NROWS(tp) - 1 {		# zero indexed
+
+	    # Print each column in the current row.
+	    do colnum = 1, ncols {
+
+		cp = TB_COLINFO(tp,colnum)
+
+		if (colnum > 1)			# separator between columns
+		    call fprintf (fd, " ")
+
+		call fprintf (fd, COL_FMT(cp))		# use this format
+
+		# Now call the appropriate parg routine.
+		if (COL_DTYPE(cp) == TY_DOUBLE) {
+
+		    call pargd (Memd[COL_OFFSET(cp) + row_1])
+
+		} else if (COL_DTYPE(cp) == TY_INT) {
+
+		    if (IS_INDEFI (Memi[COL_OFFSET(cp) + row_1]))
+			call pargstr ("INDEFI")
+		    else
+			call pargi (Memi[COL_OFFSET(cp) + row_1])
+
+		} else {				# string
+
+		    lenstr = -COL_DTYPE(cp) + 1		# one for EOS
+		    ip = row_1 * lenstr			# offset to element
+
+		    # Check for embedded whitespace.
+		    quote = false			# initial value
+
+		    # istart and iend are zero indexed
+		    istart = 0
+		    while (IS_WHITE(Memc[COL_OFFSET(cp)+ip+istart]))
+			istart = istart + 1		# skip leading blanks
+		    iend = strlen (Memc[COL_OFFSET(cp)+ip]) - 1
+		    if (istart > iend)
+			quote = true			# null or all blank
+		    while (iend > istart &&
+			    IS_WHITE(Memc[COL_OFFSET(cp)+ip+iend])) {
+			iend = iend - 1			# skip trailing blanks
+		    }
+
+		    do i = istart, iend {		# zero indexed
+			if (IS_WHITE(Memc[COL_OFFSET(cp)+ip+i])) {
+			    quote = true
+			    break
+			}
+		    }
+
+		    if (quote) {
+			Memc[cbuf] = '"'
+			Memc[cbuf+1] = EOS
+			call strcat (Memc[COL_OFFSET(cp)+ip], Memc[cbuf],
+					SZ_LINE)
+			call strcat ("\"", Memc[cbuf], SZ_LINE)
+			call pargstr (Memc[cbuf])
+		    } else {
+			call pargstr (Memc[COL_OFFSET(cp)+ip])
+		    }
+		}
+	    }
+	    call fprintf (fd, "\n")
+	}
+
+	call close (fd)
+
+	if (!to_stdout) {
+	    # Close and delete the original text table, and rename the
+	    # new (temporary) file back to the name of the original.
+	    call close (TB_FILE(tp))
+	    call delete (TB_NAME(tp))
+	    call rename (Memc[temp], TB_NAME(tp))
+	}
+	TB_FILE(tp) = NULL			# to indicate that it's closed
+
+	call sfree (sp)
+end