Initial commit

1 files changed, 611 insertions, 0 deletions

diff --git a/noao/imred/dtoi/database.x b/noao/imred/dtoi/database.x
new file mode 100644
index 00000000..cb501472
--- /dev/null
+++ b/noao/imred/dtoi/database.x
@@ -0,0 +1,611 @@
+include	<time.h>
+include	<ctype.h>
+include	<ctotok.h>
+include	<finfo.h>
+
+# DATABASE.X -- This file contains source for the database utilities used by
+# the DTOI package.  They are based on Frank Valdes's dtext utilities.
+
+# Definition for dbtext structure.
+
+define	DT_LEN		5
+
+define	DT		Memi[$1]	# FIO channel
+define	DT_NRECS	Memi[$1+1]	# Number of records
+define	DT_OFFSETS	Memi[$1+2]	# Pointer to record offsets
+define	DT_NAMES	Memi[$1+3]	# Pointer to name indices
+define	DT_MAP		Memi[$1+4]	# Pointer to record names
+
+define	DT_OFFSET	Meml[DT_OFFSETS($1)+$2-1]
+define	DT_NAMEI	Memi[DT_NAMES($1)+$2-1]
+define	DT_NAME		Memc[DT_MAP($1)+DT_NAMEI($1,$2)]
+
+define	DT_ALLOC	20		# Allocation block size
+
+
+# DDB_MAP -- Map the database.
+
+pointer procedure ddb_map (database, mode)
+
+char	database[ARB]			# Database file
+int	mode				# FIO mode
+
+int	i, nrec
+int	dt_alloc1, dt_alloc2
+pointer	db, str
+
+int	open(), fscan(), strlen()
+bool	streq()
+long	note()
+errchk	delete, open
+
+begin
+	call calloc (db, DT_LEN, TY_STRUCT)
+
+	if (mode == NEW_FILE)
+	    iferr (call delete (database))
+		;
+
+	DT(db) = open (database, mode, TEXT_FILE)
+
+	if (mode != READ_ONLY)
+	    return (db)
+
+	dt_alloc1 = DT_ALLOC
+	dt_alloc2 = DT_ALLOC * SZ_LINE
+	call malloc (DT_OFFSETS(db), dt_alloc1, TY_LONG)
+	call malloc (DT_NAMES(db), dt_alloc1, TY_INT)
+	call malloc (DT_MAP(db), dt_alloc2, TY_CHAR)
+	call malloc (str, SZ_LINE, TY_CHAR)
+
+	nrec = 1
+	DT_NRECS(db) = 0
+	DT_NAMEI(db, nrec) = 0
+
+	while (fscan (DT(db)) != EOF) {
+	    call gargwrd (DT_NAME(db, nrec), SZ_LINE)
+
+	    if (streq (DT_NAME(db, nrec), "begin")) {
+		call gargstr (Memc[str], SZ_LINE)
+		for (i=str; IS_WHITE(Memc[i]); i=i+1)
+		    ;
+		call strcpy (Memc[i], DT_NAME(db, nrec), SZ_LINE)
+
+		for (i = 1; i < nrec; i = i + 1)
+		    if (streq (DT_NAME(db, i), DT_NAME(db, nrec)))
+			break
+
+		if (i < nrec)
+		    DT_OFFSET(db, i) = note (DT(db))
+		else {
+		    DT_NRECS(db) = nrec
+		    DT_OFFSET(db, nrec) = note (DT(db))
+		    DT_NAMEI(db, nrec+1) = DT_NAMEI(db, nrec) +
+		        strlen (DT_NAME(db, nrec)) + 1
+		    nrec = nrec + 1
+		}
+
+		if (nrec == dt_alloc1) {
+		    dt_alloc1 = dt_alloc1 + DT_ALLOC
+		    call realloc (DT_OFFSETS(db), dt_alloc1, TY_LONG)
+		    call realloc (DT_NAMES(db), dt_alloc1, TY_INT)
+	        }
+
+	        if (DT_NAMEI(db, nrec) + SZ_LINE >= dt_alloc2) {
+		    dt_alloc2 = dt_alloc2 + DT_ALLOC * SZ_LINE
+		    call realloc (DT_MAP(db), dt_alloc2, TY_CHAR)
+		}
+	    }
+	}
+
+	call realloc (DT_MAP(db), DT_NAMEI(db, nrec), TY_CHAR)
+	call realloc (DT_OFFSETS(db), DT_NRECS(db), TY_LONG)
+	call realloc (DT_NAMES(db), DT_NRECS(db), TY_INT)
+
+	return (db)
+end
+
+
+# DDB_UNMAP -- Unmap the database.
+
+procedure ddb_unmap (db)
+
+pointer	db				# Database file descriptor
+
+begin
+	call close (DT(db))
+	call mfree (DT_MAP(db), TY_CHAR)
+	call mfree (DT_OFFSETS(db), TY_LONG)
+	call mfree (DT_NAMES(db), TY_INT)
+	call mfree (db, TY_STRUCT)
+end
+
+
+# DDB_PREC -- Write a record to the database.
+
+procedure ddb_prec (db, record)
+
+pointer	db		# Pointer to database
+char	record[ARB]	# Name of record to enter
+
+pointer	sp, entry
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "begin\t%s\n")
+	    call pargstr (record)
+
+	call fprintf (DT(db), Memc[entry])
+
+	call sfree (sp)
+end
+
+
+# DDB_PUTR -- Write a real valued field into the current record.
+
+procedure ddb_putr (db, field, value)
+
+pointer	db		# Pointer to database
+char	field[ARB]	# Format string
+real	value		# Real value to output
+
+pointer	sp, entry
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%g\n")
+	    call pargstr (field)
+	    call pargr (value)
+	
+	call fprintf (DT(db), Memc[entry])
+
+	call sfree (sp)
+end
+
+# DDB_PUTD -- Write a double valued field into the current record.
+
+procedure ddb_putd (db, field, value)
+
+pointer	db		# Pointer to database
+char	field[ARB]	# Format string
+double	value		# Real value to output
+
+pointer	sp, entry
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%g\n")
+	    call pargstr (field)
+	    call pargd (value)
+	
+	call fprintf (DT(db), Memc[entry])
+
+	call sfree (sp)
+end
+
+
+# DDB_PUTI -- Write an integer valued field into the current record.
+
+procedure ddb_puti (db, field, value)
+
+pointer	db		# Pointer to database
+char	field[ARB]	# Format string
+int	value		# Integer value to output
+
+pointer	sp, entry
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%d\n")
+	    call pargstr (field)
+	    call pargi (value)
+	
+	call fprintf (DT(db), Memc[entry])
+
+	call sfree (sp)
+end
+
+
+# DDB_PSTR -- Write a string valued field into the current record.
+
+procedure ddb_pstr (db, field, value)
+
+pointer	db		# Pointer to database
+char	field[ARB]	# Format string
+char	value[ARB]	# String field
+
+pointer	sp, entry
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%s\n")
+	    call pargstr (field)
+	    call pargstr (value)
+	
+	call fprintf (DT(db), Memc[entry])
+
+	call sfree (sp)
+end
+
+
+# DDB_PAR -- Put an array of real values into a field in the current record.
+
+procedure ddb_par (db, field, array, nvals)
+
+pointer	db		# Pointer to database structure
+char	field[ARB]	# Name of field to be added
+real	array[nvals]	# Array of real values 
+int	nvals		# Number of values in array
+
+pointer	sp, entry
+int	i
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%d\n")
+	    call pargstr (field)
+	    call pargi (nvals)
+
+	call fprintf (DT(db), Memc[entry])
+
+	do i = 1, nvals {
+	    call sprintf (Memc[entry], SZ_LINE, "\t\t%g\n")
+		call pargr (array[i])
+	    
+	    call fprintf (DT(db), Memc[entry])
+	}
+
+	call sfree (sp)
+end
+
+
+# DDB_PAD -- Put an array of double values into a field in the current record.
+
+procedure ddb_pad (db, field, array, nvals)
+
+pointer	db		# Pointer to database structure
+char	field[ARB]	# Name of field to be added
+double	array[nvals]	# Array of double values 
+int	nvals		# Number of values in array
+
+pointer	sp, entry
+int	i
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%d\n")
+	    call pargstr (field)
+	    call pargi (nvals)
+
+	call fprintf (DT(db), Memc[entry])
+
+	do i = 1, nvals {
+	    call sprintf (Memc[entry], SZ_LINE, "\t\t%g\n")
+		call pargd (array[i])
+	    
+	    call fprintf (DT(db), Memc[entry])
+	}
+
+	call sfree (sp)
+end
+
+
+# DDB_PAI -- Put an array of integer values into a field in the current 
+# record.
+
+procedure ddb_pai (db, field, array, nvals)
+
+pointer	db		# Pointer to database structure
+char	field[ARB]	# Name of field to be added
+int	array[nvals]	# Array of integer values 
+int	nvals		# Number of values in array
+
+pointer	sp, entry
+int	i
+
+begin
+	call smark (sp)
+	call salloc (entry, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[entry], SZ_LINE, "\t%s\t%d\n")
+	    call pargstr (field)
+	    call pargi (nvals)
+
+	call fprintf (DT(db), Memc[entry])
+
+	do i = 1, nvals {
+	    call sprintf (Memc[entry], SZ_LINE, "\t\t%d\n")
+		call pargi (array[i])
+	    
+	    call fprintf (DT(db), Memc[entry])
+	}
+
+	call sfree (sp)
+end
+
+
+# DDB_LOCATE -- Locate a database record.
+
+int procedure ddb_locate (db, name)
+
+pointer	db				# DTTEXT pointer
+char	name[ARB]			# Record name
+
+int	i
+
+bool	streq()
+pointer	sp, err_string
+
+begin
+	do i = 1, DT_NRECS(db) {
+	    if (streq (name, DT_NAME(db, i)))
+		return (i)
+	}
+
+	# The record was not found
+
+	call smark (sp)
+	call salloc (err_string, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[err_string], SZ_LINE, 
+	    "DDB_LOCATE: Database record '%s' not found")
+	        call pargstr (name)
+
+	call error (21, Memc[err_string])
+	call sfree (sp)
+end
+
+
+# DDB_GSTR -- Get a string field
+
+procedure ddb_gstr (db, record, field, str, maxchar)
+
+pointer	db				# Database file descriptor
+int	record				# Database index
+char	field[ARB]			# Database field
+char	str[maxchar]			# String value
+int	maxchar				# Maximum characters for string
+
+char	name[SZ_LINE]
+
+pointer	sp, esp
+int	i, fscan()
+bool	streq()
+
+begin
+	if ((record < 1) || (record > DT_NRECS(db)))
+	    call error (22, "Database record request out of bounds")
+
+	call seek (DT(db), DT_OFFSET(db, record))
+
+	while (fscan (DT(db)) != EOF) {
+	    call gargwrd (name, SZ_LINE)
+
+	    if (streq (name, "begin"))
+		break
+	    else if (streq (name, field)) {
+		call gargstr (str, maxchar)
+		for (i=1; IS_WHITE(str[i]); i=i+1)
+		    ;
+		if (i>1)
+		    call strcpy (str[i], str, maxchar)
+		return
+	    }
+	}
+
+	call smark (sp)
+	call salloc (esp, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[esp], SZ_LINE, 
+	    "DDB_GSTR: Database field '%s' not found")
+		call pargstr (field)
+
+	call error (23, Memc[esp])
+	call sfree (sp)
+end
+
+
+# DDB_GETI -- Get an integer field.
+
+int procedure ddb_geti (db, record, field)
+
+pointer	db				# DTTEXT pointer
+int	record				# Database index
+char	field[ARB]			# Database field
+
+real	rval
+bool    fp_equalr()
+real	ddb_getr()
+
+errchk	ddb_getr
+
+begin
+	rval = ddb_getr (db, record, field)
+
+	if (fp_equalr (rval, INDEFR))
+	    return (INDEFI)
+	else 
+	    return (int (rval))
+end
+
+
+# DDB_GETR -- Get an real field
+
+real procedure ddb_getr (db, record, field)
+
+pointer	db				# DTTEXT pointer
+int	record				# Database index
+char	field[ARB]			# Database field
+
+pointer	sp, esp
+real	rval
+char	name[SZ_LINE]
+
+int	fscan(), nscan()
+bool	streq()
+
+begin
+	if ((record < 1) || (record > DT_NRECS(db)))
+	    call error (24, "Database record request out of bounds")
+
+	call seek (DT(db), DT_OFFSET(db, record))
+
+	while (fscan (DT(db)) != EOF) {
+	    call gargwrd (name, SZ_LINE)
+
+	    if (streq (name, "begin"))
+		break
+	    else if (streq (name, field)) {
+		call gargr (rval)
+		if (nscan() == 2)
+		   return (rval)
+		else
+		   call error (25, "Error in database field value")
+	    }
+	}
+
+	call smark (sp)
+	call salloc (esp, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[esp], SZ_LINE, 
+	    "DDB_GET: Database field '%s' not found")
+		call pargstr (field)
+
+	call error (26, Memc[esp])
+	call sfree (sp)
+end
+
+
+# DDB_GAR -- Get a real array field
+
+procedure ddb_gar (db, record, field, array, len_array, npts)
+
+pointer	db				# DTTEXT pointer
+int	record				# Database index
+char	field[ARB]			# Database field
+real	array[len_array]		# Array values
+int	len_array			# Length of array
+int	npts				# Number of values in the field
+
+int	i
+double	tmp
+pointer	sp, dubble
+bool	fp_equald()
+
+begin
+	call smark (sp)
+	call salloc (dubble, npts, TY_DOUBLE)
+
+	call ddb_gad (db, record, field, Memd[dubble], len_array, npts)
+	do i = 1, npts {
+	    tmp = Memd[dubble+i-1]
+	    if (fp_equald (tmp, INDEFD))
+		array[i] = INDEFR
+	    else
+		array[i] = real (tmp)
+	}
+
+	call sfree (sp)
+end
+
+
+# DDB_GAD -- Get a double array field
+
+procedure ddb_gad (db, record, field, array, len_array, npts)
+
+pointer	db				# DTTEXT pointer
+int	record				# Database index
+char	field[ARB]			# Database field
+double	array[len_array]		# Array values
+int	len_array			# Length of array
+int	npts				# Number of points in the array
+
+pointer	sp, esp
+char	name[SZ_LINE]
+int	i
+
+int	fscan(), nscan()
+bool	streq()
+
+begin
+	if ((record < 1) || (record > DT_NRECS(db)))
+	    call error (27, "Database record request out of bounds")
+
+	call seek (DT(db), DT_OFFSET(db, record))
+
+	while (fscan (DT(db)) != EOF) {
+	    call gargwrd (name, SZ_LINE)
+
+	    if (streq (name, "begin"))
+		break
+	    else if (streq (name, field)) {
+		call gargi (npts)
+		if (nscan() != 2)
+		    call error (28, "Error in database field value")
+
+		npts = min (npts, len_array)
+		for (i = 1; i <= npts; i = i + 1) {
+		    if (fscan (DT(db)) == EOF)
+		        call error (29, "Error in database field value")
+
+		    call gargd (array[i])
+		    if (nscan() != 1)
+		        call error (30, "Error in database field value")
+		}
+		return
+	    }
+	}
+
+	call smark (sp)
+	call salloc (esp, SZ_LINE, TY_CHAR)
+
+	call sprintf (Memc[esp], SZ_LINE, 
+	    "DDB_GA: Database field '%s' not found")
+	        call pargstr (field)
+
+	call error (31, Memc[esp])
+	call sfree (sp)
+end
+
+
+# DDB_PTIME -- Put a time string with a comment
+
+procedure ddb_ptime (db)
+
+pointer	db				# DTTEXT pointer
+
+char	timestr[SZ_TIME]
+long	time, clktime()
+
+begin
+	time = clktime (0)
+	call cnvtime (time, timestr, SZ_TIME)
+	call fprintf (DT(db), "# %s\n")
+	    call pargstr (timestr)
+end
+
+
+# DDB_SCAN -- Scan a line from the database.
+
+int procedure ddb_scan (db)
+
+pointer	db			# DDB pointer
+int	fscan()
+
+begin
+	return (fscan (DT(db)))
+end