Repatch (from linux) of OSX IRAF

1 files changed, 587 insertions, 0 deletions

diff --git a/pkg/xtools/xtextns.x b/pkg/xtools/xtextns.x
new file mode 100644
index 00000000..3c95e4f9
--- /dev/null
+++ b/pkg/xtools/xtextns.x
@@ -0,0 +1,587 @@
+include	<error.h>
+include	<pkg/mef.h>
+include	<imhdr.h>
+
+
+define	SZ_RANGE	100		# Size of range list
+
+
+# XT_EXTNS -- Expand template of files into a list of extensions.
+#
+# This supports all MEF extension types.  If IMAGE type or any type is
+# requested this will also return non-FITS images as well.
+#
+# This differs from XT_EXTNS1 in that extension zero is not returned
+# unless it is a simple image and, in that case, the extension is removed.
+
+int procedure xt_extns (files, exttype, index, extname, extver, lindex, lname,
+	lver, dataless, ikparams, err, imext)
+
+char	files[ARB]		#I List of MEF files
+char	exttype[ARB]		#I Extension type (or null for all)
+char	index[ARB]		#I Range list of extension indexes
+char	extname[ARB]		#I Patterns for extension names
+char	extver[ARB]		#I Range list of extension versions
+int	lindex			#I List index number?
+int	lname			#I List extension name?
+int	lver			#I List extension version?
+int	dataless		#I Include dataless image headers?
+char	ikparams[ARB]		#I Image kernel parameters
+int	err			#I Print errors?
+int	imext			#O Image extensions?
+int	list			#O Image list
+
+int	i, j, nphu, nextns, fd
+pointer	sp, temp, patbuf, fname, image, im, immap()
+int	xt_extns1(), patmake(), gpatmatch(), imtopen(), imtgetim(), open()
+errchk	xt_extns1, open, immap, delete
+
+begin
+	call smark (sp)
+	call salloc (temp, SZ_FNAME, TY_CHAR)
+	call salloc (patbuf, SZ_FNAME, TY_CHAR)
+	call salloc (fname, SZ_FNAME, TY_CHAR)
+	call salloc (image, SZ_FNAME, TY_CHAR)
+
+	# Get the list.
+	list = xt_extns1 (files, exttype, index, extname, extver, lindex,
+	    lname, lver, ikparams, err)
+
+	# Check and edit the list.
+	i = patmake ("\[[01]\]", Memc[patbuf], SZ_FNAME)
+	nphu = 0
+	nextns = 0
+	call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME)
+	fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE)
+	while (imtgetim (list, Memc[fname], SZ_FNAME) != EOF) {
+	    if (dataless == NO) {
+		iferr (im = immap (Memc[fname], READ_ONLY, 0))
+		    im = NULL
+		if (im != NULL) {
+		    if (IM_NDIM(im) == 0 || IM_LEN(im,1) == 0) {
+			call imunmap (im)
+			next
+		    }
+		    call imunmap (im)
+		}
+	    }
+	    if (gpatmatch (Memc[fname], Memc[patbuf], i, j) > 0) {
+	        call strcpy (Memc[fname], Memc[image], SZ_FNAME)
+		call strcpy (Memc[image+j], Memc[image+i-1], SZ_FNAME)
+		ifnoerr (im = immap (Memc[image], READ_ONLY, 0)) {
+		    call strcpy (Memc[image], Memc[fname], SZ_FNAME)
+		    call imunmap (im)
+		    nphu = nphu + 1
+		}
+	    }
+	    nextns = nextns + 1
+	    call fprintf (fd, "%s\n")
+		call pargstr (Memc[fname])
+	}
+	call close (fd)
+
+	# Return new list and extension flag.
+	imext = YES
+	if (nphu == nextns)
+	    imext = NO
+	call imtclose (list)
+	list = imtopen (Memc[temp])
+	call delete (Memc[temp+1])
+	call sfree (sp)
+	return (list)
+end
+
+
+# XT_IMEXTNS -- Expand a template of MEF files into a list of image extensions.
+
+int procedure xt_imextns (files, index, extname, extver, lindex, lname, lver,
+	ikparams, err)
+
+char	files[ARB]		#I List of MEF files
+char	index[ARB]		#I Range list of extension indexes
+char	extname[ARB]		#I Patterns for extension names
+char	extver[ARB]		#I Range list of extension versions
+int	lindex			#I List index number?
+int	lname			#I List extension name?
+int	lver			#I List extension version?
+char	ikparams[ARB]		#I Image kernel parameters
+int	err			#I Print errors?
+int	list			#O Image list
+
+int	xt_extns1()
+errchk	xt_extns1
+
+begin
+	list = xt_extns1 (files, "IMAGE", index, extname, extver, lindex,
+	    lname, lver, ikparams, err)
+	return (list)
+end
+
+
+# XT_EXTNS1 -- Expand a template of MEFs into a list of extensions.
+
+int procedure xt_extns1 (files, exttype, index, extname, extver, lindex,
+	lname, lver, ikparams, err)
+
+char	files[ARB]		#I List of MEFs
+char	exttype[ARB]		#I Desired extension type (or null for all)
+char	index[ARB]		#I Range list of extension indexes
+char	extname[ARB]		#I Patterns for extension names
+char	extver[ARB]		#I Range list of extension versions
+int	lindex			#I List index number?
+int	lname			#I List extension name?
+int	lver			#I List extension version?
+char	ikparams[ARB]		#I Image kernel parameters
+int	err			#I Print errors?
+int	list			#O Image list
+
+int	i, fd
+pointer	sp, temp, fname, rindex, rextver, ikp, str
+int	imtopen(), imtgetim()
+int	ix_decode_ranges(), decode_ranges(), nowhite(), open()
+errchk	open, xt_extn, delete
+
+begin
+	call smark (sp)
+	call salloc (temp, SZ_FNAME, TY_CHAR)
+	call salloc (fname, SZ_FNAME, TY_CHAR)
+	call salloc (ikp, SZ_LINE, TY_CHAR)
+	call salloc (str, SZ_LINE, TY_CHAR)
+
+	# Expand parameters.
+	list = imtopen (files)
+	call salloc (rindex, 3*SZ_RANGE, TY_INT)
+	if (ix_decode_ranges (index, Memi[rindex], SZ_RANGE, i) == ERR)
+	    call error (1, "Bad index range list")
+
+	rextver = NULL
+	if (nowhite (extver, Memc[str], SZ_LINE) > 0) {
+	    call salloc (rextver, 3*SZ_RANGE, TY_INT)
+	    if (decode_ranges (Memc[str], Memi[rextver], SZ_RANGE, i)==ERR)
+		call error (1, "Bad extension version range list")
+	}
+	i = nowhite (ikparams, Memc[ikp], SZ_LINE)
+
+	# Expand MEFs into list of extensions in a temp file.
+	call mktemp ("@tmp$iraf", Memc[temp], SZ_FNAME)
+	fd = open (Memc[temp+1], NEW_FILE, TEXT_FILE)
+	while (imtgetim (list, Memc[fname], SZ_FNAME) != EOF) {
+	    call xt_extn (fd, Memc[fname], exttype, rindex, extname,
+	    	rextver, lindex, lname, lver, Memc[ikp], err)
+	}
+	call imtclose (list)
+	call close (fd)
+
+	# Return list.
+	list = imtopen (Memc[temp])
+	call delete (Memc[temp+1])
+	call sfree (sp)
+	return (list)
+end
+
+
+# XT_EXTN -- Expand a single MEF into a list of extensions.
+# The extensions are written to the input file descriptor.
+
+procedure xt_extn (fd, fname, exttype, indices, extname, extver, lindex,
+	lname, lver, ikparams, err)
+
+int	fd			#I File descriptor for list 
+char	fname[SZ_FNAME]		#I File name
+char	exttype[ARB]		#I Extension type (or null for all)
+pointer	indices			#I Range list of extension indexes
+char	extname[ARB]		#I Pattern for extension names
+pointer	extver			#I Range list of extension versions
+int	lindex			#I List index number?
+int	lname			#I List extension name?
+int	lver			#I List extension version?
+char	ikparams[ARB]		#I Image kernel parameters
+int	err			#I Print errors?
+
+int	i, j, n, index, ver, stat
+pointer	sp, clust, ksec, imsec, name, str
+pointer	mef, im
+
+bool	streq(), is_in_range(), xt_extmatch()
+int	mef_rdhdr_exnv(), mef_rdhdr_gn(), ix_get_next_number()
+pointer	mefopen(), immap()
+errchk	mefopen, mef_rdhdr_exnv, mef_rdhdr_gn, immap
+
+begin
+	call smark (sp)
+	call salloc (clust, SZ_FNAME, TY_CHAR)
+	call salloc (ksec, SZ_FNAME, TY_CHAR)
+	call salloc (imsec, SZ_FNAME, TY_CHAR)
+	call salloc (name, SZ_LINE, TY_CHAR)
+	call salloc (str, SZ_LINE, TY_CHAR)
+
+	# Parse the file name syntax.
+	call imparse (fname, Memc[clust], SZ_FNAME, Memc[ksec],
+	    SZ_FNAME, Memc[imsec], SZ_FNAME, index, ver)
+
+	# Open the file and check the error status.
+	iferr (mef = mefopen (Memc[clust], READ_ONLY, 0)) {
+	    if (exttype[1] == EOS || !streq (exttype, "IMAGE"))
+	        call fprintf (fd, fname)
+	    else if (streq (exttype, "IMAGE")) {
+		ifnoerr (im = immap (fname, READ_ONLY, 0)) {
+		    call imunmap (im)
+		    call fprintf (fd, fname)
+		}
+	    }
+	    return
+	}
+
+	# Loop through extensions.
+	if (Memc[ksec] != EOS || index >= 0)
+	    n = 1
+	else
+	    n = ARB
+	j = index
+	do i = 1, n {
+	    iferr {
+		# If a kernel section is given look for the extension/extver.
+		if (Memc[ksec] != EOS) {
+		    call mef_ksection (Memc[ksec], Memc[name], ver)
+		    stat = mef_rdhdr_exnv (mef, Memc[name], ver)
+
+		# If an index is given then look for the indexed extension
+		} else if (j >= 0)
+		    stat = mef_rdhdr_gn (mef, j)
+
+		# If neither is given look for list of indices.
+		else {
+		    stat = ix_get_next_number (Memi[indices], index)
+		    if (stat != EOF)
+			stat = mef_rdhdr_gn (mef, index)
+		}
+	    } then {
+	        # Check if file is an IRAF image.
+		if (exttype[1] == EOS || !streq (exttype, "IMAGE"))
+			call fprintf (fd, fname)
+		else if (streq (exttype, "IMAGE")) {
+		    ifnoerr (im = immap (fname, READ_ONLY, 0)) {
+			call imunmap (im)
+			call fprintf (fd, fname)
+		    }
+		}
+	        stat = EOF
+	    }
+
+	    # Finish if EOF is encountered in either indices or file.
+	    if (stat == EOF)
+	        break
+
+	    # Check the extension type.
+	    if (exttype[1] != EOS && !streq (exttype, MEF_EXTTYPE(mef))) {
+		if (!streq (exttype, "IMAGE") ||
+		    !streq (MEF_EXTTYPE(mef), "SIMPLE")) {
+		    # Check for PLIO mask which is a kind of image.
+		    if (streq (MEF_EXTTYPE(mef), "BINTABLE")) {
+		        call sprintf (Memc[str], SZ_LINE, "%s[%d]")
+			    call pargstr (Memc[clust])
+			    call pargi (MEF_CGROUP(mef))
+			iferr (im = immap (Memc[str], READ_ONLY, 0))
+			    im = NULL
+			if (im == NULL)
+			    next
+			else
+			    call imunmap (im)
+		    }
+		}
+	    }
+
+	    # Check the extension name.
+	    if (!xt_extmatch (MEF_EXTNAME(mef), extname))
+		next
+
+	    # Check the extension version.
+	    if (extver != NULL) {
+	        if (IS_INDEFI(MEF_EXTVER(mef)))
+		    next
+		if (!is_in_range (Memi[extver], MEF_EXTVER(mef)))
+		    next
+	    }
+
+	    # Set the extension name and version.
+	    if (lname == YES)
+	        call strcpy (MEF_EXTNAME(mef), Memc[name], SZ_LINE)
+	    else
+		Memc[name] = EOS
+	    if (lver == YES)
+	        ver = MEF_EXTVER(mef)
+	    else
+		ver = INDEFI
+
+	    # Output the file name with the desired elements.
+	    call fprintf (fd, Memc[clust])
+	    if (lindex == YES || (Memc[name] == EOS && IS_INDEFI(ver))) {
+		call fprintf (fd, "[%d]")
+		    call pargi (MEF_CGROUP(mef))
+	    }
+	    if (Memc[name] != EOS) {
+		call fprintf (fd, "[%s")
+		    call pargstr (Memc[name])
+		if (!IS_INDEFI(ver)) {
+		    call fprintf (fd, ",%d")
+			call pargi (ver)
+		}
+		if (ikparams[1] != EOS) {
+		    call fprintf (fd, ",%s")
+			call pargstr (ikparams)
+		}
+		call fprintf (fd, "]")
+	    } else if (!IS_INDEFI(ver)) {
+		call fprintf (fd, "[extver=%d")
+		    call pargi (ver)
+		if (ikparams[1] != EOS) {
+		    call fprintf (fd, ",%s")
+			call pargstr (ikparams)
+		}
+		call fprintf (fd, "]")
+	    } else if (ikparams[1] != EOS) {
+		call fprintf (fd, "[%s]")
+		    call pargstr (ikparams)
+	    }
+	    if (Memc[imsec] != EOS) {
+		call fprintf (fd, "%s")
+		    call pargstr (Memc[imsec])
+	    }
+	    call fprintf (fd, "\n")
+	}
+
+	# Finish up.
+	call mefclose (mef)
+	call sfree (sp)
+end
+
+
+include	<mach.h>
+include	<ctype.h>
+
+define	FIRST	0		# Default starting range
+define	LAST	MAX_INT		# Default ending range
+define	STEP	1		# Default step
+define	EOLIST	-1		# End of list
+
+# IX_DECODE_RANGES -- Parse a string containing a list of integer numbers or
+# ranges, delimited by either spaces or commas.  Return as output a list
+# of ranges defining a list of numbers, and the count of list numbers.
+# Range limits must be positive nonnegative integers.  ERR is returned as
+# the function value if a conversion error occurs.  The list of ranges is
+# delimited by EOLIST.
+
+int procedure ix_decode_ranges (range_string, ranges, max_ranges, nvalues)
+
+char	range_string[ARB]	# Range string to be decoded
+int	ranges[3, max_ranges]	# Range array
+int	max_ranges		# Maximum number of ranges
+int	nvalues			# The number of values in the ranges
+
+int	ip, nrange, first, last, step, ctoi()
+
+begin
+	ip = 1
+	nvalues = 0
+
+	do nrange = 1, max_ranges - 1 {
+	    # Defaults to all nonnegative integers
+	    first = FIRST
+	    last = LAST
+	    step = STEP
+
+	    # Skip delimiters
+	    while (IS_WHITE(range_string[ip]) || range_string[ip] == ',')
+		ip = ip + 1
+
+	    # Get first limit.
+	    # Must be a number, '-', 'x', or EOS.  If not return ERR.
+	    if (range_string[ip] == EOS) {			# end of list
+		if (nrange == 1) {
+		    # Null string defaults
+		    ranges[1, 1] = first
+		    ranges[2, 1] = last
+		    ranges[3, 1] = step
+		    ranges[1, 2] = EOLIST
+	    	    nvalues = MAX_INT
+		    return (OK)
+		} else {
+		    ranges[1, nrange] = EOLIST
+		    return (OK)
+		}
+	    } else if (range_string[ip] == '-')
+		;
+	    else if (range_string[ip] == 'x')
+		;
+	    else if (IS_DIGIT(range_string[ip])) {		# ,n..
+		if (ctoi (range_string, ip, first) == 0)
+		    return (ERR)
+	    } else
+		return (ERR)
+
+	    # Skip delimiters
+	    while (IS_WHITE(range_string[ip]) || range_string[ip] == ',')
+		ip = ip + 1
+
+	    # Get last limit
+	    # Must be '-', or 'x' otherwise last = first.
+	    if (range_string[ip] == 'x')
+		;
+	    else if (range_string[ip] == '-') {
+		ip = ip + 1
+	        while (IS_WHITE(range_string[ip]) || range_string[ip] == ',')
+		    ip = ip + 1
+		if (range_string[ip] == EOS)
+		    ;
+		else if (IS_DIGIT(range_string[ip])) {
+		    if (ctoi (range_string, ip, last) == 0)
+		        return (ERR)
+		} else if (range_string[ip] == 'x')
+		    ;
+		else
+		    return (ERR)
+	    } else
+		last = first
+
+	    # Skip delimiters
+	    while (IS_WHITE(range_string[ip]) || range_string[ip] == ',')
+		ip = ip + 1
+
+	    # Get step.
+	    # Must be 'x' or assume default step.
+	    if (range_string[ip] == 'x') {
+		ip = ip + 1
+	        while (IS_WHITE(range_string[ip]) || range_string[ip] == ',')
+		    ip = ip + 1
+		if (range_string[ip] == EOS)
+		    ;
+		else if (IS_DIGIT(range_string[ip])) {
+		    if (ctoi (range_string, ip, step) == 0)
+		        ;
+		    if (step == 0)
+			return (ERR)
+		} else if (range_string[ip] == '-')
+		    ;
+		else
+		    return (ERR)
+	    }
+
+	    # Output the range triple.
+	    ranges[1, nrange] = first
+	    ranges[2, nrange] = last
+	    ranges[3, nrange] = step
+	    nvalues = nvalues + abs (last-first) / step + 1
+	}
+
+	return (ERR)					# ran out of space
+end
+
+
+# IX_GET_NEXT_NUMBER -- Given a list of ranges and the current file number,
+# find and return the next file number.  Selection is done in such a way
+# that list numbers are always returned in monotonically increasing order,
+# regardless of the order in which the ranges are given.  Duplicate entries
+# are ignored.  EOF is returned at the end of the list.
+
+int procedure ix_get_next_number (ranges, number)
+
+int	ranges[ARB]		# Range array
+int	number			# Both input and output parameter
+
+int	ip, first, last, step, next_number, remainder
+
+begin
+	# If number+1 is anywhere in the list, that is the next number,
+	# otherwise the next number is the smallest number in the list which
+	# is greater than number+1.
+
+	number = number + 1
+	next_number = MAX_INT
+
+	for (ip=1;  ranges[ip] != EOLIST;  ip=ip+3) {
+	    first = min (ranges[ip], ranges[ip+1])
+	    last = max (ranges[ip], ranges[ip+1])
+	    step = ranges[ip+2]
+	    if (step == 0)
+		call error (1, "Step size of zero in range list")
+	    if (number >= first && number <= last) {
+		remainder = mod (number - first, step)
+		if (remainder == 0)
+		    return (number)
+		if (number - remainder + step <= last)
+		    next_number = number - remainder + step
+	    } else if (first > number)
+		next_number = min (next_number, first)
+	}
+
+	if (next_number == MAX_INT)
+	    return (EOF)
+	else {
+	    number = next_number
+	    return (number)
+	}
+end
+
+
+# XT_EXTMATCH -- Match extname against a comma-delimited list of patterns.
+
+bool procedure xt_extmatch (extname, patterns)
+
+char	extname[ARB]		#I Extension name to match
+char	patterns[ARB]		#I Comma-delimited list of patterns
+bool	stat			#O Match?
+
+int	i, j, k, sz_pat, strlen(), patmake(), patmatch(), nowhite()
+pointer	sp, patstr, patbuf
+
+begin
+	if (patterns[1] == EOS)
+	    return (true)
+
+	stat = false
+
+	sz_pat = strlen (patterns)
+	if (sz_pat == 0)
+	    return (stat)
+	sz_pat = sz_pat + SZ_LINE
+
+	call smark (sp)
+	call salloc (patstr, sz_pat, TY_CHAR)
+	call salloc (patbuf, sz_pat, TY_CHAR)
+
+	i = nowhite (patterns, Memc[patstr], sz_pat)
+	if (i == 0)
+	    stat = true
+	else if (i == 1 && Memc[patstr] == '*')
+	    stat = true
+	else {
+	    i = 1
+	    for (j=i;; j=j+1) {
+		if (patterns[j] != ',' && patterns[j] != EOS)
+		    next
+		if (j > 0 && patterns[j] == ',' && patterns[j-1] == '\\')
+		    next
+		if (j - i > 0) {
+		    if (j-i == 1 && patterns[i] == '*') {
+			stat = true
+			break
+		    }
+		    call strcpy (patterns[i], Memc[patstr+1], j-i)
+		    Memc[patstr] = '^'
+		    Memc[patstr+j-i+1] = '$'
+		    Memc[patstr+j-i+2] = EOS
+		    k = patmake (Memc[patstr], Memc[patbuf], sz_pat)
+		    if (patmatch (extname, Memc[patbuf]) > 0) {
+			stat = true
+			break
+		    }
+		}
+		if (patterns[j] == EOS)
+		    break
+		i = j + 1
+	    }
+	}
+
+	call sfree (sp)
+	return (stat)
+end