1 files changed, 266 insertions, 0 deletions
diff --git a/sys/imio/iki/stf/stfrfits.x b/sys/imio/iki/stf/stfrfits.x
new file mode 100644
index 00000000..8ec9e9b0
--- /dev/null
+++ b/sys/imio/iki/stf/stfrfits.x
@@ -0,0 +1,266 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<syserr.h>
+include	<ctype.h>
+include	<imhdr.h>
+include	<imio.h>
+include	<finfo.h>
+include	<fset.h>
+include	"stf.h"
+
+# STF_RFITSHDR -- Read a STF FITS image header, processing all reserved GPB
+# definition keywords into the STF descriptor in the image descriptor, and
+# saving the remaining cards (excluding cards which GPB keyword names) in
+# in a save buffer.
+# 
+# This routine implements a simple cache of FITS headers.  If a given header
+# is already in the cache and the cached entry is up to date, the cached
+# spool file containing the user FITS cards and the saved STF descriptor are
+# returned immediately without need to access the header file on disk.
+# Otherwise, the new header is read into the oldest cache slot and the cached
+# entry returned in the usual fashion.  Any modifications to the header file
+# which affect the file modify date will invalidate the cached entry.  Note
+# that multiple processes may cache the same header, so it is not permitted
+# to modify the cached entry once the header file has been read.
+# 
+# The following reserved keywords are recognized:
+# 
+# 	SIMPLE BITPIX DATATYPE NAXIS* GROUPS GCOUNT PCOUNT PSIZE 
+# 	PTYPE* PDTYPE* PSIZE* 
+# 
+# All unrecognized cards, including HISTORY and COMMENT cards, blank lines,
+# and any other garbage in the header, are preserved in the user area of the
+# IMIO descriptor (i.e., in the spoolfile).  Certain of the standard reserved
+# cards (GROUPS, GCOUNT, etc.) are saved in the IMIO user area for the sake
+# of the user, although the real values of these parameters are maintained only
+# in the STF descriptor.
+
+procedure stf_rfitshdr (im, fits, fitslen)
+
+pointer	im				#I image descriptor
+pointer	fits				#O pointer to saved FITS cards
+int	fitslen				#O length of FITS save area
+
+long	fi[LEN_FINFO]
+pointer	sp, pp, stf, o_stf, lbuf, op, hdrfile
+int	in, index, nchars, spool, slot, user, i
+
+bool	streq()
+long	clktime(), fstatl()
+int	envgeti(), stf_ctype(), finfo(), getline(), open(), stropen()
+errchk	getline, putline, syserrs, open, seek, calloc, realloc
+errchk	fpathname, malloc, stf_copyfits
+
+bool	initialized			# CACHE definitions...
+bool	reload				# reload cache
+int	rf_refcount			# reference count
+int	rf_cachesize			# number of cache slots
+pointer	rf_stf[MAX_CACHE]		# STF descriptor
+int	rf_lru[MAX_CACHE]		# lowest value is oldest slot
+long	rf_time[MAX_CACHE]		# time when entry was cached
+long	rf_mtime[MAX_CACHE]		# modify time of file in cache
+int	rf_fits[MAX_CACHE]		# FITS data
+int	rf_fitslen[MAX_CACHE]		# size of data area
+char	rf_fname[SZ_PATHNAME,MAX_CACHE]	# header file pathname
+data	initialized /false/
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+	call salloc (hdrfile, SZ_PATHNAME, TY_CHAR)
+
+	# Initialize the header file cache on the first call.
+	if (!initialized) {
+	    rf_refcount = 0
+	    do i = 1, MAX_CACHE
+		rf_stf[i] = 0
+
+	    iferr (rf_cachesize = envgeti (ENV_STFCACHE))
+		rf_cachesize = DEF_CACHE
+	    if (rf_cachesize > MAX_CACHE) {
+		call eprintf ("A maximum of %d STF headers may be cached\n")
+		    call pargi (MAX_CACHE)
+		rf_cachesize = MAX_CACHE
+	    } else if (rf_cachesize <= 0)
+		rf_cachesize = 0
+		
+	    initialized = true
+	}
+
+	rf_refcount = rf_refcount + 1
+	o_stf = IM_KDES(im)
+	reload = false
+	slot = 1
+
+	# Get file system info on the desired header file.
+	call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME)
+	if (finfo (Memc[hdrfile], fi) == ERR)
+	    call syserrs (SYS_FOPEN, IM_HDRFILE(im))
+
+	repeat {
+	    # Search the header file cache for the named image.
+	    do i = 1, max(1,rf_cachesize) {
+		if (rf_stf[i] == NULL) {
+		    slot = i
+		    next
+		}
+
+		if (streq (Memc[hdrfile], rf_fname[1,i])) {
+		    # File is in cache; is cached entry still valid?
+		    if (FI_MTIME(fi) != rf_mtime[i]) {
+			# File modify date has changed, reuse slot.
+			slot = i
+			break
+
+		    } else if (!reload && clktime(rf_time[i]) < 2) {
+			# The file modify date has not changed, but the cache
+			# was loaded within the last clock "tick" (second),
+			# so we cannot be sure that the file was not modified.
+			# The cache must be reloaded, but set a flag so that
+			# rf_time is not changed, so that when the cache entry
+			# ages sufficiently it will be considered valid.
+
+			reload = true
+			slot = i
+			break
+
+		    } else {
+			# Return the cached header.
+			rf_lru[i] = rf_refcount
+			call amovi (STF_CACHE(rf_stf[i]), STF_CACHE(o_stf),
+			    STF_CACHELEN(rf_stf[i]))
+			fits = rf_fits[i]
+			fitslen = rf_fitslen[i]
+
+			# Invalidate entry if cache is disabled.
+			if (rf_cachesize <= 0)
+			    rf_time[i] = 0
+
+			call sfree (sp)
+			return 				# IN CACHE
+		    }
+
+		} else {
+		    # Keep track of least recently used slot.
+		    if (rf_lru[i] < rf_lru[slot])
+			slot = i
+		}
+	    }
+
+	    # Either the image header is not in the cache, or the cached
+	    # entry is invalid.  Prepare the given cache slot and read the
+	    # header into it.
+
+	    # Free old save buffer and descriptor.
+	    if (rf_stf[slot] != NULL) {
+		call mfree (rf_stf[slot], TY_STRUCT)
+		call mfree (rf_fits[slot], TY_CHAR)
+	    }
+
+	    # Open the header file.
+	    if (IM_HFD(im) == NULL)
+		in = open (Memc[hdrfile], READ_ONLY, TEXT_FILE)
+	    else {
+		in = IM_HFD(im)
+		call seek (in, BOFL)
+	    }
+
+	    # Allocate a spool file for the FITS data.
+	    call sprintf (rf_fname[1,slot], SZ_PATHNAME, "STFHC#%d")
+		call pargi (slot)
+	    spool = open (rf_fname[1,slot], READ_WRITE, SPOOL_FILE)
+	    call fseti (spool, F_BUFSIZE, FI_SIZE(fi))
+
+	    # Allocate cache version of STF descriptor.
+	    call calloc (stf, LEN_STFDES, TY_STRUCT)
+
+	    # Initialize the cache entry.
+	    call strcpy (Memc[hdrfile], rf_fname[1,slot], SZ_PATHNAME)
+	    rf_stf[slot] = stf
+	    rf_lru[slot] = rf_refcount
+	    rf_mtime[slot] = FI_MTIME(fi)
+	    if (!reload)
+		rf_time[slot] = clktime (0)
+	    reload = true
+
+	    # Read successive lines of the FITS header.  Process reserved
+	    # keywords into the STF descriptor and spool the remaining cards
+	    # to the fits spool file.
+
+	    repeat {
+		# Get the next input line.
+		nchars = getline (in, Memc[lbuf])
+		if (nchars == EOF)
+		    break
+
+		# Block it out to 80 chars (plus newline) if it is not already.
+		if (nchars != FITS_RECLEN + 1) {
+		    for (op=nchars;  op <= FITS_RECLEN;  op=op+1)
+			Memc[lbuf+op-1] = ' '
+		    Memc[lbuf+FITS_RECLEN]   = '\n'
+		    Memc[lbuf+FITS_RECLEN+1] = EOS
+		}
+		    
+		# Process the header card.
+		switch (stf_ctype (Memc[lbuf], index)) {
+		case KW_BITPIX:
+		    call stf_geti (Memc[lbuf], STF_BITPIX(stf))
+		case KW_DATATYPE:
+		    call stf_gets (Memc[lbuf], STF_DATATYPE(stf), SZ_DATATYPE)
+		case KW_END:
+		    break
+		case KW_GCOUNT:
+		    call stf_geti (Memc[lbuf], STF_GCOUNT(stf))
+		case KW_GROUPS:
+		    call stf_getb (Memc[lbuf], STF_GROUPS(stf))
+		case KW_NAXIS:
+		    call stf_geti (Memc[lbuf], STF_NAXIS(stf))
+		case KW_NAXISN:
+		    call stf_geti (Memc[lbuf], STF_LENAXIS(stf,index))
+		case KW_PCOUNT:
+		    call stf_geti (Memc[lbuf], STF_PCOUNT(stf))
+		case KW_PDTYPE:
+		    pp = STF_PDES(stf,min(index,MAX_PCOUNT))
+		    call stf_gets (Memc[lbuf], P_PDTYPE(pp), SZ_PDTYPE)
+		case KW_PSIZE:
+		    call stf_geti (Memc[lbuf], STF_PSIZE(stf))
+		case KW_PSIZEN:
+		    pp = STF_PDES(stf,min(index,MAX_PCOUNT))
+		    call stf_geti (Memc[lbuf], P_PSIZE(pp))
+		case KW_PTYPE:
+		    pp = STF_PDES(stf,min(index,MAX_PCOUNT))
+		    call stf_gets (Memc[lbuf], P_PTYPE(pp), SZ_PTYPE)
+		    call stf_getcmt (Memc[lbuf], P_COMMENT(pp), SZ_COMMENT)
+		case KW_SIMPLE:
+		    ;
+		default:
+		    call putline (spool, Memc[lbuf])
+		}
+	    }
+
+	    # Close the header file if opened locally.
+	    if (IM_HFD(im) == NULL)
+		call close (in)
+
+	    # Free any unneeded space in the STF descriptor.
+	    if (STF_PCOUNT(stf) > 0) {
+		call realloc (stf,
+		    LEN_STFBASE + STF_PCOUNT(stf)*LEN_PDES, TY_STRUCT)
+		rf_stf[slot] = stf
+	    }
+
+	    # Filter the spooled FITS cards to delete any cards which redefine
+	    # GPB keywords.  Store the filtered FITS data in the cache.
+
+	    call seek (spool, BOFL)
+	    nchars = fstatl (spool, F_FILESIZE)
+	    call malloc (fits, nchars, TY_CHAR)
+	    user = stropen (Memc[fits], nchars, NEW_FILE)
+	    call stf_copyfits (stf, spool, NULL, user)
+
+	    rf_fits[slot] = fits
+	    rf_fitslen[slot] = fstatl (user, F_FILESIZE)
+	    call close (user)
+	    call close (spool)
+	}
+end