1 files changed, 303 insertions, 0 deletions
diff --git a/pkg/images/imutil/src/imheader.x b/pkg/images/imutil/src/imheader.x
new file mode 100644
index 00000000..57c496fe
--- /dev/null
+++ b/pkg/images/imutil/src/imheader.x
@@ -0,0 +1,303 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include	<error.h>
+include	<ctype.h>
+include	<imhdr.h>
+include	<imset.h>
+include	<imio.h>
+include	<time.h>
+
+define	SZ_DIMSTR	(IM_MAXDIM*4)
+define	SZ_MMSTR	40
+define	USER_AREA	Memc[($1+IMU-1)*SZ_STRUCT + 1]
+define	LMARGIN		0
+
+
+# IMHEADER -- Read contents of an image header and print on STDOUT.
+
+procedure t_imheader()
+
+int	list, nimages, errcode
+bool	long_format, user_fields
+pointer	sp, template, image, errmsg
+int	imtopen(), imtgetim(), imtlen(), clgeti(), errget()
+bool	clgetb()
+
+begin
+	call smark (sp)
+	call salloc (image, SZ_FNAME, TY_CHAR)
+	call salloc (errmsg, SZ_LINE, TY_CHAR)
+	call salloc (template, SZ_LINE, TY_CHAR)
+
+	if (clgeti ("$nargs") == 0)
+	    call clgstr ("imlist", Memc[template], SZ_LINE)
+	else
+	    call clgstr ("images", Memc[template], SZ_LINE)
+
+	list = imtopen (Memc[template])
+	long_format = clgetb ("longheader")
+	user_fields = clgetb ("userfields")
+	nimages = 0
+
+	if (imtlen (list) <= 0)
+	    call printf ("no images found\n")
+	else {
+	    while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {
+		nimages = nimages + 1
+		if (long_format && nimages > 1)
+		    call putci (STDOUT, '\n')
+		iferr {
+		    call imphdr (STDOUT,Memc[image],long_format,user_fields)
+		} then {
+		    errcode = errget (Memc[errmsg], SZ_LINE)
+		    call eprintf ("%s: %s\n")
+			call pargstr (Memc[image])
+			call pargstr (Memc[errmsg])
+		}
+		call flush (STDOUT)
+	    }
+	}
+
+	call imtclose (list)
+	call sfree (sp)
+end
+
+
+# IMPHDR -- Print the contents of an image header.
+
+procedure imphdr (fd, image, long_format, user_fields)
+
+int	fd
+char	image[ARB]
+bool	long_format
+bool	user_fields
+
+int	hi, i
+bool	pixfile_ok
+pointer	im, sp, ctime, mtime, ldim, pdim, title, lbuf, ip
+int	gstrcpy(), stropen(), getline(), strlen(), stridxs(), imstati()
+errchk	im_fmt_dimensions, immap, access, stropen, getline
+define	done_ 91
+pointer	immap()
+
+begin
+	# Allocate automatic buffers.
+	call smark (sp)
+	call salloc (ctime, SZ_TIME,   TY_CHAR)
+	call salloc (mtime, SZ_TIME,   TY_CHAR)
+	call salloc (ldim,  SZ_DIMSTR, TY_CHAR)
+	call salloc (pdim,  SZ_DIMSTR, TY_CHAR)
+	call salloc (title, SZ_LINE,   TY_CHAR)
+	call salloc (lbuf,  SZ_LINE,   TY_CHAR)
+
+	im = immap (image, READ_ONLY, 0)
+
+	# Format subscript strings, date strings, mininum and maximum
+	# pixel values.
+
+	call im_fmt_dimensions (im, Memc[ldim], SZ_DIMSTR, IM_LEN(im,1))
+	call im_fmt_dimensions (im, Memc[pdim], SZ_DIMSTR, IM_PHYSLEN(im,1))
+	call cnvtime (IM_CTIME(im), Memc[ctime], SZ_TIME)
+	call cnvtime (IM_MTIME(im), Memc[mtime], SZ_TIME)
+
+	# Strip any trailing whitespace from the title string.
+	ip = title + gstrcpy (IM_TITLE(im), Memc[title], SZ_LINE) - 1
+	while (ip >= title && IS_WHITE(Memc[ip]) || Memc[ip] == '\n')
+	    ip = ip - 1
+	Memc[ip+1] = EOS
+
+	# Begin printing image header.
+	call fprintf (fd, "%s%s[%s]: %s\n")
+	    call pargstr (IM_NAME(im))
+	    call pargstr (Memc[ldim])
+	    call pargtype (IM_PIXTYPE(im))
+	    call pargstr (Memc[title])
+
+	# All done if not long format.
+	if (! long_format)
+	    goto done_
+
+	call fprintf (fd, "%*w%s bad pixels, min=%s, max=%s%s\n")
+	    call pargi (LMARGIN)
+	    if (IM_NBPIX(im) == 0)			# num bad pixels
+		call pargstr ("No")
+	    else
+		call pargl (IM_NBPIX(im))
+
+	    if (IM_LIMTIME(im) == 0) {			# min,max pixel values
+		do i = 1, 2
+		    call pargstr ("unknown")
+		call pargstr ("")
+	    } else {
+		call pargr (IM_MIN(im))
+		call pargr (IM_MAX(im))
+		if (IM_LIMTIME(im) < IM_MTIME(im))
+		    call pargstr (" (old)")
+		else
+		    call pargstr ("")
+	    }
+
+	call fprintf (fd,
+	    "%*w%s storage mode, physdim %s, length of user area %d s.u.\n")
+	    call pargi (LMARGIN)
+	    call pargstr ("Line")
+	    call pargstr (Memc[pdim])
+	    call pargi (IM_HDRLEN(im) - LEN_IMHDR)
+
+	call fprintf (fd, "%*wCreated %s, Last modified %s\n")
+	    call pargi (LMARGIN)
+	    call pargstr (Memc[ctime])			# times
+	    call pargstr (Memc[mtime])
+
+	pixfile_ok = (imstati (im, IM_PIXFD) > 0)
+	if (!pixfile_ok) {
+	    ifnoerr (call imopsf (im))
+		pixfile_ok = (imstati (im, IM_PIXFD) > 0)
+	    if (pixfile_ok)
+		call close (imstati (im, IM_PIXFD))
+	}
+	if (pixfile_ok)
+	    call strcpy ("[ok]", Memc[lbuf], SZ_LINE)
+	else
+	    call strcpy ("[NO PIXEL FILE]", Memc[lbuf], SZ_LINE)
+
+	call fprintf (fd, "%*wPixel file \"%s\" %s\n")
+	    call pargi (LMARGIN)
+	    call pargstr (IM_PIXFILE(im))
+	    call pargstr (Memc[lbuf])
+
+	# Print the history records.
+	if (strlen (IM_HISTORY(im)) > 1) {
+	    hi = stropen (IM_HISTORY(im), ARB, READ_ONLY)
+	    while (getline (hi, Memc[lbuf]) != EOF) {
+		for (i=1;  i <= LMARGIN;  i=i+1)
+		    call putci (fd, ' ')
+		call putline (fd, Memc[lbuf])
+		if (stridxs ("\n", Memc[lbuf]) == 0)
+		    call putline (fd, "\n")
+	    }
+	    call close (hi)
+	}
+
+	if (user_fields)
+	    call imh_print_user_area (fd, im)
+
+done_
+	call imunmap (im)
+	call sfree (sp)
+end
+
+
+# IM_FMT_DIMENSIONS -- Format the image dimensions in the form of a subscript,
+# i.e., "[nx,ny,nz,...]".
+
+procedure im_fmt_dimensions (im, outstr, maxch, len_axes)
+
+pointer	im
+char	outstr[ARB]
+int	maxch, i, fd, stropen()
+long	len_axes[ARB]
+errchk	stropen, fprintf, pargl
+
+begin
+	fd = stropen (outstr, maxch, NEW_FILE)
+
+	if (IM_NDIM(im) == 0) {
+	    call fprintf (fd, "[0")
+	} else {
+	    call fprintf (fd, "[%d")
+	        call pargl (len_axes[1])
+	}
+
+	do i = 2, IM_NDIM(im) {
+	    call fprintf (fd, ",%d")
+		call pargl (len_axes[i])
+	}
+
+	call fprintf (fd, "]")
+	call close (fd)
+end
+
+
+# PARGTYPE -- Convert an integer type code into a string, and output the
+# string with PARGSTR to FMTIO.
+
+procedure pargtype (dtype)
+
+int	dtype
+
+begin
+	switch (dtype) {
+	case TY_UBYTE:
+	    call pargstr ("ubyte")
+	case TY_BOOL:
+	    call pargstr ("bool")
+	case TY_CHAR:
+	    call pargstr ("char")
+	case TY_SHORT:
+	    call pargstr ("short")
+	case TY_USHORT:
+	    call pargstr ("ushort")
+	case TY_INT:
+	    call pargstr ("int")
+	case TY_LONG:
+	    call pargstr ("long")
+	case TY_REAL:
+	    call pargstr ("real")
+	case TY_DOUBLE:
+	    call pargstr ("double")
+	case TY_COMPLEX:
+	    call pargstr ("complex")
+	case TY_POINTER:
+	    call pargstr ("pointer")
+	case TY_STRUCT:
+	    call pargstr ("struct")
+	default:
+	    call pargstr ("unknown datatype")
+	}
+end
+
+
+# IMH_PRINT_USER_AREA -- Print the user area of the image, if nonzero length
+# and it contains only ascii values.
+
+procedure imh_print_user_area (out, im)
+
+int	out			# output file
+pointer	im			# image descriptor
+
+pointer	sp, lbuf, ip
+int	in, ncols, min_lenuserarea, i
+int	stropen(), getline(), envgeti()
+errchk	stropen, envgeti, getline, putci, putline
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+
+	# Open user area in header.
+	min_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1
+	in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY)
+	ncols = envgeti ("ttyncols") - LMARGIN
+
+	# Copy header records to the output, stripping any trailing
+	# whitespace and clipping at the right margin.
+
+	while (getline (in, Memc[lbuf]) != EOF) {
+	    for (ip=lbuf;  Memc[ip] != EOS && Memc[ip] != '\n';  ip=ip+1)
+		;
+	    while (ip > lbuf && Memc[ip-1] == ' ')
+		ip = ip - 1
+	    if (ip - lbuf > ncols)
+		ip = lbuf + ncols 
+	    Memc[ip] = '\n'
+	    Memc[ip+1] = EOS
+	    
+	    for (i=1;  i <= LMARGIN;  i=i+1)
+		call putci (out, ' ')
+	    call putline (out, Memc[lbuf])
+	}
+
+	call close (in)
+	call sfree (sp)
+end