From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001
From: Joseph Hunkeler <jhunkeler@gmail.com>
Date: Wed, 8 Jul 2015 20:46:52 -0400
Subject: Initial commit

---
 sys/imio/dbc/imputextf.x | 185 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 185 insertions(+)
 create mode 100644 sys/imio/dbc/imputextf.x

(limited to 'sys/imio/dbc/imputextf.x')

diff --git a/sys/imio/dbc/imputextf.x b/sys/imio/dbc/imputextf.x
new file mode 100644
index 00000000..151f13e4
--- /dev/null
+++ b/sys/imio/dbc/imputextf.x
@@ -0,0 +1,185 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	<imhdr.h>
+include	<imio.h>
+include	"idbc.h"
+
+define	LEN_HISTSTR	71	# length of a history string on a FITS card
+define  CLEN            81
+
+# IMPUTXTF -- Insert a text file in the user area with HISTORY card.
+# The file cannot have control characters in it; only the FITS standard
+# character set is supported.  The text is broken in records long enough
+# to fit words; i.e. it tries not to split words. The file can have 
+# imbedded tabs and they will be expanded.
+
+procedure imputextf (im, file, pkey, baf)
+
+pointer	im			#I image descriptor
+char	file[ARB]		#I the text file to be inserted and appended
+char    pkey[ARB]               #I Pivot keyword to insert 'key'
+int     baf                     #I Insert BEFORE or AFTER
+
+pointer	ua, rp, piv, ip, op
+int	max_lenuserarea, curlen, buflen, jump, nlines
+int	old_curlen, k, nshift
+char    blk
+
+int	strlen(), idb_findrecord()
+errchk	syserrs
+
+begin
+	# FITS format requires that the keyword name be upper case.
+
+	ua = IM_USERAREA(im)
+	curlen = strlen (Memc[ua])
+	buflen = LEN_IMDES + IM_LENHDRMEM(im)
+	max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1
+
+	# Determine the number of lines before inserting into the UA
+	call imrartxt (ua, file, nlines, NO)
+
+        old_curlen=curlen
+        curlen = curlen + nlines*CLEN
+        if (curlen+81 >= max_lenuserarea) {
+            IM_HDRLEN(im)  = LEN_IMHDR  +
+                    (curlen + 10*36*CLEN + SZ_STRUCT-1) / SZ_STRUCT
+            IM_LENHDRMEM(im) = IM_HDRLEN(im)  + (SZ_UAPAD / SZ_STRUCT)
+            call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT)
+            buflen = LEN_IMDES + IM_LENHDRMEM(im)
+            max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1
+	    ua = IM_USERAREA(im)
+        }
+
+	blk=' '
+	# Find pivot keyword 
+        if (idb_findrecord (im, pkey, rp) == 0) {
+            # Keyw not found. Append the new keywords.
+            piv = ua + old_curlen
+        } else {
+            # Shift cards after or before pivot.
+            if (baf == AFTER)
+                piv = rp + CLEN
+            else
+                piv = rp 
+        
+            jump=nlines*CLEN
+
+	    # Shift cards down from the pivot point. 
+	    nshift = (ua+old_curlen - piv)/CLEN 
+	    ip = ua + old_curlen 
+            do k = 1, nshift {
+	        ip = ip - CLEN
+		op = jump + ip
+		call amovc (Memc[ip], Memc[op], CLEN)
+	    }
+        }
+
+	# Append the HISTORY records to the user area.
+	call imrartxt (piv, file, nlines, YES)
+
+end
+
+
+# IMRARTXT -- Internal routines to count the number of lines transfered to the
+# UA as HISTORY records.
+
+procedure imrartxt (piv, fname, nlines, insert)
+
+pointer piv	#I UA address to start inserting kw
+char	fname[ARB]
+int	nlines
+int	insert
+
+char	line[IDB_RECLEN+1], blk, lf
+pointer	sp, ln, buf, urp
+int 	ip, op, fd, in_last_blank, out_last_blank, blen, len, w, k
+int	save_ip
+int	open(), getline(), strlen()
+
+begin
+	call smark(sp)
+	call salloc (ln, SZ_LINE, TY_CHAR)
+	call salloc (buf, SZ_LINE, TY_CHAR)
+
+	fd = open(fname, READ_ONLY, TEXT_FILE)
+        nlines= 0
+	blk=' '
+	lf='\12'
+	call strcpy ("HISTORY  ", Memc[buf], 9)
+	Memc[buf+IDB_LENSTRINGRECORD]='\n'
+	Memc[buf+IDB_LENSTRINGRECORD+1]=EOS
+        urp = piv
+	while(getline(fd, Memc[ln]) != EOF) {
+		for (ip=1;  Memc[ln+ip-1] != EOS;  ) {
+		    # If no blanks are found in HISTORY string, make sure
+		    # all of it gets output anyway.
+
+		    in_last_blank = ip + LEN_HISTSTR - 1
+		    out_last_blank = LEN_HISTSTR
+
+		    # Copy the string to the output buffer, marking the
+		    # last blank found.
+
+		    for (op=1; op <= LEN_HISTSTR; op=op+1) {
+			if (Memc[ln+ip-1] == lf) {
+			    ip=ip+1
+			}    
+			if (IS_WHITE (Memc[ln+ip-1])) {
+			    # Detab input text.
+			    if (Memc[ln+ip-1] == '\t') {
+				if(ip-save_ip == 1)
+				   w=8
+				else
+				   w=9-op+(op/9)*8
+				for(k=0;k<w;k=k+1) {
+				    line[op+k] = blk
+				}
+				save_ip=ip
+				op = op + w - 1
+				ip = ip + 1
+				in_last_blank = ip
+				out_last_blank = op
+				next
+			    }
+			    in_last_blank = ip
+			    out_last_blank = op
+			} else if (Memc[ln+ip-1] == EOS) 
+			    break
+			line[op] = Memc[ln+ip-1]
+			ip = ip + 1
+		    }
+		    # The output string is full; close it off properly
+		    # and get ready for the next round (if any).
+		    line[op] = EOS
+		    if (Memc[ln+ip-1] != EOS) {
+			# Break at last word boundary if in a word.
+			if (!IS_WHITE (Memc[ln+ip-1])) {
+			    line[out_last_blank+1] = EOS
+			    ip = in_last_blank + 1
+			}
+
+			# Skip leading whitespace on next line.
+			while (IS_WHITE(Memc[ln+ip-1]))
+			    ip = ip + 1
+		    }
+		    nlines = nlines + 1
+
+		    if (insert == YES) {
+			# Write out the FITS HISTORY card.
+			len = strlen(line)
+			blen = IDB_LENSTRINGRECORD - len - 9 
+			call amovc (line, Memc[buf+9], len)
+			call amovkc (blk, Memc[buf+9+len], blen)
+
+			call amovc (Memc[buf], Memc[urp], IDB_RECLEN+1)
+			urp = urp + IDB_RECLEN + 1
+		    }
+		}
+	}
+
+        call close(fd)
+        call sfree(sp)
+end
-- 
cgit