diff options
Diffstat (limited to 'sys/imio/iki/fxf/fxfopen.x')
| -rw-r--r-- | sys/imio/iki/fxf/fxfopen.x | 1014 |
1 files changed, 1014 insertions, 0 deletions
diff --git a/sys/imio/iki/fxf/fxfopen.x b/sys/imio/iki/fxf/fxfopen.x new file mode 100644 index 00000000..bceed618 --- /dev/null +++ b/sys/imio/iki/fxf/fxfopen.x @@ -0,0 +1,1014 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> +include <imhdr.h> +include <imio.h> +include <finfo.h> +include <fset.h> +include <mii.h> +include <mach.h> +include "fxf.h" + + +# FXF_OPEN -- Open/create a FITS format image with extensions. + +procedure fxf_open (kernel, im, o_im, root, extn, ksection, group, gc_arg, + acmode, status) + +int kernel #I IKI kernel +pointer im #I image descriptor +pointer o_im #I other descriptor for NEW_COPY image +char root[ARB] #I root image name +char extn[ARB] #I extension, if any +char ksection[ARB] #I [extname,extver,overwrite,append,inherit..] +int group #I index of group to be accessed +int gc_arg #I [NOT USED] +int acmode #I access mode +int status #O status flag to calling routine + +long fi[LEN_FINFO] +int newimage, i, gn, ksinh, type, fmode +pointer sp, path, fit_extn, ua, o_fit, fit +bool pre_read, fks_extn_or_ver, dyh, fsec, plio +int fxf_check_dup_extnv(), itoc(), strcmp(), strncmp() +int open(), access(), imgeti(), fstatl(), finfo(), fxf_header_size() +pointer pl_open() + +errchk fmkcopy, calloc, open, fxf_rheader, fxf_prhdr, fxf_gaccess +errchk fxf_fclobber, fxf_ksection, fxf_alloc, syserr, syserrs +errchk fxf_check_group +define duperr_ 91 +define err_ 92 + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + call salloc (fit_extn, FITS_LENEXTN, TY_CHAR) + call fxf_init() + ua = IM_USERAREA(im) + + fmode = acmode + + # Allocate internal FITS image descriptor. + call fxf_alloc (fit) + + IM_KDES(im) = fit + IM_HFD(im) = NULL + FIT_IM(fit) = im + call amovki (1, FIT_LENAXIS(fit,1), IM_MAXDIM) + + # Generate full header file name. + if (extn[1] == EOS) { + call fxf_gethdrextn (im, o_im, fmode, Memc[fit_extn], FITS_LENEXTN) + call iki_mkfname (root, Memc[fit_extn], Memc[path], SZ_PATHNAME) + call strcpy (Memc[fit_extn], extn, FITS_LENEXTN) + } else + call iki_mkfname (root, extn, Memc[path], SZ_PATHNAME) + + # Header and pixel filename are the same. + call strcpy (Memc[path], IM_HDRFILE(im), SZ_IMHDRFILE) + call strcpy (IM_HDRFILE(im), IM_PIXFILE(im), SZ_IMPIXFILE) + + newimage = NO + if (access (IM_HDRFILE(im), 0, 0) == NO) + newimage = YES + FIT_NEWIMAGE(fit) = newimage + + # Initialize kernel section default values. + call fxf_ksinit (fit) + + # For simplicity treat the APPEND mode as NEW_IMAGE. For the FK + # is the same. + + if (fmode == APPEND) + fmode = NEW_IMAGE + FIT_ACMODE(fit) = fmode + + # Read fkinit and ksection and check that the extension number + # specifications therein and the IMIO cluster index "group" are + # consistent. + + call fxf_check_group (im, ksection, fmode, group, ksinh) + + fks_extn_or_ver = FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit)) + + # Check if a file section is necessary. + fsec = (fks_extn_or_ver || group >= 0) + call fxf_gaccess (im, fsec) + + # The previous call could have changed FIT_NEWIMAGE; reset value. + newimage = FIT_NEWIMAGE(fit) + + if (fks_extn_or_ver) + FIT_GROUP(fit) = -1 + + # See if we want to write a dummy primary unit. + # + # For PLIO, if creating a new output file and we want to create a + # BINTABLE, create a dummy header. Otherwise see if a type is + # requested, in which case we would need to create a dummmy header + # if no file is present yet. + + type = 0 + if (FKS_SUBTYPE(fit) == FK_PLIO) + type = FK_PLIO + + dyh = false + if (newimage == YES && (fks_extn_or_ver || type > 0)) { + call fxf_dummy_header (im, status) + if (status == ERR) + goto err_ + newimage = NO + dyh = true + if (fmode == NEW_COPY && type == FK_PLIO) + FIT_PIXOFF(fit) = fxf_header_size(im) + FITS_BLOCK_CHARS + } + if (newimage == NO) { + if (finfo (IM_HDRFILE(im), fi) != ERR) + FIT_EOFSIZE(fit) = (FI_SIZE(fi)+SZB_CHAR-1)/SZB_CHAR + 1 + else + call syserrs (SYS_FOPEN, IM_HDRFILE(im)) + } + + if (newimage == YES) + FKS_OVERWRITE(fit) = NO + else + FIT_XTENSION(fit) = YES + + FIT_NEWIMAGE(fit) = newimage + + # If all these conditions are met then set the pre_read flag. + pre_read = (fks_extn_or_ver || + FKS_OVERWRITE(fit) == YES || FKS_INHERIT(fit) == YES) + + if (newimage == NO && fmode != READ_ONLY) { + # See that INHERIT makes sense if it has been set by + # 'fkinit' when reading a file with PHU (naxis != 0). + + if (FKS_INHERIT(fit) == YES && group != 0) { + gn = 0 + iferr (call fxf_prhdr (im, gn)) { + FKS_INHERIT(fit) = NO + + # Issue an error only if the inherit is in the filename. + if (fmode == NEW_COPY && ksinh == YES) + call syserr (SYS_FXFBADINH) + } else if (FIT_NAXIS(fit) != 0) + FKS_INHERIT(fit) = NO + + # Reset the pre_read flag. + pre_read = ((FKS_DUPNAME(fit) == NO && + FKS_INHERIT(fit) == YES) || FKS_OVERWRITE(fit) == YES) + } + + if (pre_read && fmode != NEW_COPY && !dyh) + call fxf_prhdr (im, group) + + if (access (IM_HDRFILE(im), fmode, 0) == NO) + call syserrs (SYS_FNOWRITEPERM, IM_HDRFILE(im)) + } + + switch (fmode) { + case NEW_IMAGE, APPEND: + if (newimage == NO) { + # Make sure the UA is empty when overwriting. + if (pre_read && FKS_OVERWRITE(fit) == YES) + Memc[ua] = EOS + + if (FKS_DUPNAME(fit) == NO) + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } else { + # See if it is necessary to invalidate the cache entry for the + # current filename. It could happen that the user has deleted + # the filename and a new file with the same is created. + + call fxf_check_old_name (im) + } + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) + IM_PL(im) = pl_open (NULL) + + case NEW_COPY: + # Completely new copy of an existing image. This could mean a + # new file or append a new image to an existing file. + + # Initialize a new copy of a PLIO image mask. + if (type == FK_PLIO) { + IM_PL(im) = pl_open (NULL) + if (IM_PL(o_im) != NULL) + call fxf_plpf (im) + } + + if (newimage == YES || FKS_APPEND(fit) == NO) + call fxf_check_old_name (im) + + # For a PLIO mask, make sure there are no SUBYTPE keywords in + # the UA since this will be rewritten by fxf_updhdr(). + + if (IM_PL(o_im) != NULL) + call fxf_clean_pl (im) + + if (IM_KDES(o_im) != NULL && IM_KERNEL(o_im) == IM_KERNEL(im)) { + o_fit = IM_KDES(o_im) + call strcpy (FIT_EXTTYPE(o_fit), FIT_EXTTYPE(fit), SZ_EXTTYPE) + call strcpy (FIT_EXTNAME(o_fit), FIT_EXTNAME(fit), LEN_CARD) + FIT_EXTVER(fit) = FIT_EXTVER(o_fit) + + # Reset the value of the keyword INHERIT in the new_copy + # image if the input has a no_inherit in the filename. + + FIT_INHERIT(fit) = NO + call fxf_filter_keyw (im, "INHERIT") + + # Change the value only if explicitly done in the output + # kernel section. + + if (FKS_INHERIT(fit) == YES) + FIT_INHERIT(fit) = YES + + } else { + # Reblock if old image is imh for example. + if (IM_UABLOCKED(im) != YES) + call fxf_reblock (im) + + # See if the old image have EXTNAME or EXTVER keywords. + # Notice that old image does not have to be of FITS type. + + iferr (call imgstr (o_im,"EXTNAME",FIT_EXTNAME(fit),LEN_CARD)) + FIT_EXTNAME(fit) = EOS + iferr (FIT_EXTVER(fit) = imgeti (o_im, "EXTVER")) + FIT_EXTVER(fit) = INDEFL + call strcpy ("IMAGE", FIT_EXTTYPE(fit), SZ_EXTTYPE) + } + + # Delete ORIGIN keyword, since we are going to put a new one. + call fxf_filter_keyw (im, "ORIGIN") + + # Now that we have a new_copy of the input FITS structure, + # initialize some of its members. + + FIT_HFD(fit) = NULL + FIT_NEWIMAGE(fit) = newimage + if (newimage == NO) + FIT_XTENSION(fit) = YES + FIT_ACMODE(fit) = fmode + if (FKS_APPEND(fit) != YES) + FIT_GROUP(fit) = group + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + + if (FKS_OVERWRITE(fit) == NO) { + if (FKS_EXTNAME(fit) == EOS) + call strcpy (FIT_EXTNAME(fit), FKS_EXTNAME(fit), LEN_CARD) + else + call imastr (im, "EXTNAME", FKS_EXTNAME(fit)) + + if (IS_INDEFL(FKS_EXTVER(fit))) + FKS_EXTVER(fit) = FIT_EXTVER(fit) + else + call imaddi (im, "EXTVER", FKS_EXTVER(fit)) + + # We need to pre_read extensions headers to check for + # duplicates with these extname and extver. + + if (FKS_EXTNAME(fit) != EOS ||!IS_INDEFL(FKS_EXTVER(fit))) + pre_read = true + } + + if (newimage == NO && !dyh) { + if (pre_read) { + iferr (call fxf_prhdr (im, group)) + ; + } + + # Check for duplicated EXTNAME and/or EXTVER if any of the + # following conditions are met. + + if (FKS_DUPNAME(fit) == NO && FKS_OVERWRITE(fit) == NO && + (fks_extn_or_ver || FIT_EXTNAME(fit) != EOS || + !IS_INDEFL(FIT_EXTVER(fit)))) { + if (fxf_check_dup_extnv (im, group) == YES) + goto duperr_ + } + } + + FIT_NAXIS(fit) = IM_NDIM(im) + do i = 1, IM_NDIM(im) + FIT_LENAXIS(fit,i) = IM_LEN(im,i) + + # Inherit datatype of input template image if specified, + # otherwise default datatype to real. + + if (IM_PIXTYPE(o_im) != NULL) + IM_PIXTYPE(im) = IM_PIXTYPE(o_im) + else + IM_PIXTYPE(im) = TY_REAL + + default: + # No Overwrite allowed in READ_ONLY or READ_WRITE. + FKS_OVERWRITE(fit) = NO + + # Check that we have single FITS file. + if (!fsec && group == -1) + group = 0 + + # Open an existing image. + iferr (call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME)) + goto err_ + if (fmode == READ_WRITE) + IM_HFD(im) = open (Memc[path], READ_WRITE, BINARY_FILE) + else + IM_HFD(im) = open (Memc[path], READ_ONLY, BINARY_FILE) + + iferr (call fxf_rheader (im, group, fmode)) { + call close (IM_HFD(im)) + call mfree (fit, TY_STRUCT) + call sfree (sp) + status = ERR + call erract (EA_ERROR) + } + + if (group == 0) + FIT_XTENSION(fit) = NO + else + FIT_XTENSION(fit) = YES + + # Some non-iraf fits files might have keywords that are + # imcompatible with our header. For example if hediting the header, + # make sure that they are eliminated. + + if (fmode == READ_WRITE) + call fxf_discard_keyw (im) + + FIT_EOFSIZE(fit) = fstatl (IM_HFD(im), F_FILESIZE) + 1 + + # PLIO. If we read the header of a PLIO_1 compressed image file + # then it is a PL file; now read the data. + + plio = (strncmp (FIT_EXTSTYPE(fit), "PLIO_1", 6) == 0) + if (plio) { + call fxf_plread (im) + + # We need to setup the IMIO descriptor if we need to write + # over a section; in particular IM_PFD needs to be defined. + + if (fmode == READ_WRITE) + call fxf_plpf (im) + } + + # Close the header file. + call close (IM_HFD(im)) + IM_HFD(im) = NULL + + # Do not allow the user to see any non_IMAGE extensions. + if (strcmp ("IMAGE", FIT_EXTTYPE(fit)) != 0 && + strcmp ("SIMPLE", FIT_EXTTYPE(fit)) != 0 && !plio) + call syserrs (SYS_IKIEXTN, IM_NAME(im)) + } + + FIT_HFD(fit) = IM_HFD(im) + status = OK + + call sfree (sp) + return +duperr_ + i = itoc (group, Memc[path], LEN_CARD) + call syserrs (SYS_FXFOPEXTNV, Memc[path]) +err_ + status = ERR + call mfree (fit, TY_STRUCT) + call sfree (sp) +end + + +# FXF_ALLOC -- Initialize memory for the FIT descriptor. + +procedure fxf_alloc (fit) + +pointer fit #I input fits descriptor + +errchk calloc + +begin + call calloc (fit, LEN_FITDES, TY_STRUCT) + + FIT_GROUP(fit) = -1 + FIT_PIXTYPE(fit) = NULL + FIT_BSCALE(fit) = 1.0d0 + FIT_BZERO(fit) = 0.0d0 + FIT_XTENSION(fit) = NO + FIT_INHERIT(fit) = NO + FIT_EOFSIZE(fit) = 0 + FIT_EXTNAME(fit) = EOS + FIT_EXTVER(fit) = INDEFL +end + + +# FXF_INIT -- Initialize any runtime FITS kernel descriptors to their +# process startup state. + +procedure fxf_init() + +int i +bool first_time +data first_time /true/ + +include "fxfcache.com" + +begin + # Disable the hdrcache until it is fully initialized in rfitshdr. + if (first_time) { + rf_cachesize = 0 + do i = 1, MAX_CACHE { + rf_fit[i] = 0 + } + + first_time = false + } +end + + +# FXF_KS_RDHDR -- Procedure to preread the FITS headers up to group +# 'group'. The idea is to have the offset pointers in memory since the +# can be overwritten or when no group (i.e. -1) is given and the extname or +# extver are specified. + +procedure fxf_prhdr (im, group) + +pointer im #I image descriptor +int group #I maximum group number to read + +int poff, extv +pointer fit, lim, lfit, sp, path +errchk fpathname, open, syserr, fxf_alloc, calloc +int open(), imgeti() + +begin + call smark (sp) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + # We will use a local temporary imio and fit structures. +# call calloc (lim, LEN_IMDES+LEN_IMHDR+MIN_LENUSERAREA, TY_STRUCT) + call calloc (lim, LEN_IMDES+IM_LENHDRMEM(im), TY_STRUCT) + + call fxf_alloc (lfit) + + IM_KDES(lim) = lfit + fit = IM_KDES(im) + + FIT_GROUP(lfit) = group + FIT_ACMODE(lfit) = FIT_ACMODE(fit) + call strcpy (FKS_EXTNAME(fit), FKS_EXTNAME(lfit), LEN_CARD) + FKS_EXTVER(lfit) = FKS_EXTVER(fit) + + iferr (extv = imgeti (im, "EXTVER")) + extv = INDEFL + + FKS_OVERWRITE(lfit) = FKS_OVERWRITE(fit) + FKS_DUPNAME(lfit) = FKS_DUPNAME(fit) + FKS_INHERIT(lfit) = FKS_INHERIT(fit) + FKS_CACHESIZE(lfit) = FKS_CACHESIZE(fit) + + # Open an existing image. + call strcpy (IM_HDRFILE(im), IM_HDRFILE(lim), SZ_PATHNAME) + call strcpy (IM_NAME(im), IM_NAME(lim), SZ_PATHNAME) + + call fpathname (IM_HDRFILE(im), Memc[path], SZ_PATHNAME) + IM_HFD(lim) = open (Memc[path], READ_ONLY, BINARY_FILE) + + IM_LENHDRMEM(lim) = IM_LENHDRMEM(im) + + # If we want to inherit the global header we need to read + # the group specified in the filename. + + iferr (call fxf_rfitshdr (lim, group, poff)) { + call close (IM_HFD(lim)) + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + call sfree (sp) + call erract (EA_ERROR) + + } else { + call close (IM_HFD(lim)) + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = FIT_GROUP(lfit) + group = FIT_GROUP(lfit) + + # Now set the offset pointers to the original 'fit' struct. + FIT_HDRPTR(fit) = FIT_HDRPTR(lfit) + FIT_PIXPTR(fit) = FIT_PIXPTR(lfit) + FIT_EXTEND(fit) = FIT_EXTEND(lfit) + + FIT_CACHEHDR(fit) = FIT_CACHEHDR(lfit) + FIT_CACHEHLEN(fit) = FIT_CACHEHLEN(lfit) + + FIT_NAXIS(fit) = FIT_NAXIS(lfit) + FIT_INHERIT(fit) = FIT_INHERIT(lfit) + FIT_PLMAXLEN(fit) = FIT_PLMAXLEN(lfit) + + IM_CTIME(im) = IM_CTIME(lim) + + call mfree (lfit, TY_STRUCT) + call mfree (lim, TY_STRUCT) + + if (extv != INDEFL) + call imaddi (im, "EXTVER", extv) + } +end + + +# FXF_DUMMY_HEADER -- Built a minimum Primary Fits header. This is +# necessary in case we are creating an IMAGE extension and we don't +# want to put any information in the PHU. + +procedure fxf_dummy_header (im, status) + +pointer im #I image descriptor +int status #O status flag + +char blank[1] +pointer sp, path, spp, mii, pn, n +int iso_cutover, fd, nblanks, size_rec + +int strlen(), open(), envgeti() +long clktime() + +begin + call smark (sp) + call salloc (spp, FITS_BLOCK_BYTES, TY_CHAR) + call salloc (mii, FITS_BLOCK_CHARS, TY_INT) + call salloc (path, SZ_PATHNAME, TY_CHAR) + + status = OK + + iferr { + call fpathname (IM_HDRFILE(IM), Memc[path], SZ_PATHNAME) + fd = open (Memc[path], NEW_FILE, BINARY_FILE) + } then { + call sfree (sp) + status = ERR + return + } + + pn = spp + call fxf_akwb ("SIMPLE", YES, "FITS STANDARD", pn) + call fxf_akwi ("BITPIX", 8, "Character information", pn) + call fxf_akwi ("NAXIS", 0, "No image data array present", pn) + call fxf_akwb ("EXTEND", YES, "File may contain extensions", pn) + call fxf_akwc ("ORIGIN", FITS_ORIGIN, + strlen(FITS_ORIGIN), "FITS file originator", pn) + + # Dates after iso_cutover use ISO format dates. + iferr (iso_cutover = envgeti (ENV_ISOCUTOVER)) + iso_cutover = DEF_ISOCUTOVER + + # Encode the DATE keyword. + call fxf_encode_date (clktime(long(0)), Memc[path], LEN_CARD, + "ISO", 2000) + call fxf_akwc ("DATE", Memc[path], + strlen(Memc[path]), "Date FITS file was generated", pn) + + blank[1] = ' ' + call amovkc (blank[1], Memc[pn], LEN_CARD) + call amovc ("END", Memc[pn], 3) + pn = pn + LEN_CARD + + n = pn - spp + size_rec = FITS_BLOCK_CHARS + nblanks = FITS_BLOCK_BYTES - n + call amovkc (blank[1], Memc[spp+n], nblanks) + call miipak (Memc[spp], Memi[mii], size_rec*2, TY_CHAR, MII_BYTE) + call write (fd, Memi[mii], size_rec) + + call close (fd) + + call sfree (sp) +end + + +# FXF_CHECK_DUP_EXTN_VER --- Function to check for a duplicate EXTNAME or +# EXTVER in the FITS file open with NEW_COPY mode. The filename specification +# does not have EXTNAME nor EXTVER in the ksection. +# Returns YES if there are duplicates. + +int procedure fxf_check_dup_extnv (im, group) + +pointer im #I image descriptor +int group #O extension number where there is a duplicate + +int cindx +pointer extn, extv, sp, hdrfile, fit, poff +int fxf_extnv_error() +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + fit = IM_KDES(im) + + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + extn = rf_pextn[cindx] + extv = rf_pextv[cindx] + poff = rf_pixp[cindx] # pixel offset -1 if EOF + group = 1 + + # Now compare the input image FIT_EXT(NAME,VER) with + # the cache values of the NEW_COPY images. + + while (Memc[extn+LEN_CARD*group] != EOS || + !IS_INDEFL(Memi[extv+group]) || Memi[poff+group] != -1) { + if (fxf_extnv_error (fit, group, extn, extv) == YES) { + call sfree (sp) + if (FKS_OVERWRITE(fit) == YES) + return (NO) + else + return (YES) + } else + group = group + 1 + } + } + } + + call sfree (sp) + return (NO) +end + + +# FXF_CHECK_OLD_NAME -- Check is the filename is already in cache for a +# NEWIMAGE == YES mode; if so, make the entry obsolete. + +procedure fxf_check_old_name (im) + +pointer im #I image descriptor + +int cindx +pointer sp, hdrfile, fit +bool streq() + +include "fxfcache.com" + +begin + call smark (sp) + call salloc (hdrfile, SZ_PATHNAME, TY_CHAR) + + call fpathname (IM_HDRFILE(im), Memc[hdrfile], SZ_PATHNAME) + + fit = IM_KDES(im) + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (Memc[hdrfile], rf_fname[1,cindx])) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + rf_mtime[cindx] = 0 # invalidate cache entry + rf_fname[1,cindx] = EOS + break + } + } + + call sfree (sp) +end + + +# FXF_REBLOCK -- If the user area is not blocked to fixed length records, e.g., +# as is possible in a new copy image, reblock it fixed length. + +procedure fxf_reblock (im) + +pointer im #I image descriptor + +pointer sp, lbuf, op, ua +int fd, spool, nlines, nchars, sz_userarea, len_hdrmem +errchk stropen, open, getline, putline, realloc, seek, fcopyo +int open(), stropen(), getline() + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], ARB, READ_ONLY) + spool = open ("rb_spool", READ_WRITE, SPOOL_FILE) + + # Reblock into a spool file, counting the lines. + for (nlines=0; ; nlines=nlines+1) { + nchars = getline (fd, Memc[lbuf]) + if (nchars <= 0) + break + + for (op=nchars; op <= LEN_CARD; op=op+1) + Memc[lbuf+op-1] = ' ' + Memc[lbuf+LEN_CARD] = '\n' + Memc[lbuf+LEN_CARD+1] = EOS + call putline (spool, Memc[lbuf]) + } + + call close (fd) + + # Reallocate header the right size. + sz_userarea = nlines * (LEN_CARD+1) + SZ_EXTRASPACE + + IM_HDRLEN(im) = LEN_IMHDR + + (sz_userarea - SZ_EXTRASPACE + SZ_MII_INT-1) / SZ_MII_INT + len_hdrmem = LEN_IMHDR + + (sz_userarea+1 + SZ_MII_INT-1) / SZ_MII_INT + + if (IM_LENHDRMEM(im) < len_hdrmem) { + IM_LENHDRMEM(im) = len_hdrmem + call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) + } + + # Move spooled data back to user area. + ua = IM_USERAREA(im) + fd = stropen (Memc[ua], sz_userarea, NEW_FILE) + call seek (spool, BOFL) + call fcopyo (spool, fd) + + IM_UABLOCKED(im) = YES + call close (fd) + call close (spool) + call sfree (sp) +end + + +# FXF_FCLOBBER -- Clobber an existing FITS file. We use the environment +# variable 'clobber' rather than 'imclobber' because is a file and not +# an image. + +procedure fxf_fclobber (file) + +char file #I input filename to delete + +int cindx +bool streq() +include "fxfcache.com" + +begin + iferr (call delete (file)) + call filerr (file, SYS_FCANTCLOB) + + # Remove the name from the cache. + do cindx=1, rf_cachesize { + if (rf_fit[cindx] == NULL) + next + + # Verify that we have the correct file. + if (streq (file, rf_fname[1,cindx])) { + if (rf_fit[cindx] != NULL) { + call mfree (rf_pextv[cindx], TY_INT) + call mfree (rf_pextn[cindx], TY_CHAR) + call mfree (rf_pixp[cindx], TY_INT) + call mfree (rf_hdrp[cindx], TY_INT) + call mfree (rf_fit[cindx], TY_STRUCT) + call mfree (rf_hdr[cindx], TY_CHAR) + rf_fit[cindx] = NULL + } + } + } +end + + +# FXF_ACCESS -- Check if a file section is necessary to access any +# particular extension. + +procedure fxf_gaccess (im, fsec) + +pointer im #I image descriptor +bool fsec #I true if extname,extver or group have values + +bool mef +int acmode, fit, newimage, group +bool envgetb(), fnullfile() +errchk syserr, syserrs, fxf_fclobber + +begin + fit = IM_KDES(im) + acmode = FIT_ACMODE(fit) + newimage = FIT_NEWIMAGE(fit) + + if (acmode == READ_ONLY || acmode == READ_WRITE) { + # If no file section then see if it is a MEF by prereading an + # extension. + + if (!fsec) { + group = 1 + mef = false + ifnoerr (call fxf_prhdr (im, group)) + mef = true + else { + # Flag error if the group does not exist and overwrite+. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + } + # Multi-extension file but no extension was specified. + if (mef) + call syserrs (SYS_FXFOPNOEXTNV, IM_NAME(im)) + FIT_GROUP(fit) = 0 + FIT_XTENSION(fit) = NO + } + } + + switch (acmode) { + case NEW_COPY, NEW_IMAGE, APPEND: + if (envgetb ("imclobber")) { + if (newimage == NO) { + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + # Clobber the file. + call fxf_fclobber (IM_HDRFILE(im)) + FIT_NEWIMAGE(fit) = YES + } + } + } else { + if (newimage == NO) + if (FKS_APPEND(fit) != YES && FKS_OVERWRITE(fit) != YES) { + if (!fnullfile (IM_HDRFILE(im))) + call syserrs (SYS_IKICLOB, IM_HDRFILE(im)) + } + } + default: + ; + } + +end + + +# FXF_CHECK_GROUP -- Check for group specification from fkinit, ksection +# and cluster index are equal when specifified and they are also compatible +# when (extname,extver) is in the kernel sections. + +procedure fxf_check_group (im, ksection, acmode, group, ksinh) + +pointer im #I imio descriptor +char ksection[ARB] #I kernel section +int acmode #I fits unit extension mode +int group #U extension number in the image section +int ksinh #O INHERIT value from the filename ksection + +pointer sp, ks, fit +bool fks_extn_or_ver, inherit_override +int igroup, kgroup, fgroup, tgroup, sv_inherit, newimage, append +bool fnullfile() +int envgets() + +errchk syserrs, fxf_ks_error + +begin + call smark (sp) + call salloc (ks, SZ_LINE, TY_CHAR) + + fit = IM_KDES(im) + newimage = FIT_NEWIMAGE(fit) + + # Set the FKINIT defaults; these override the builtin defaults. + fgroup = -1 + igroup = -1 + + FKS_APPEND(fit) = NO_KEYW + if (envgets (ENV_FKINIT, Memc[ks], SZ_LINE) != 0) + call fxf_ksection (Memc[ks], fit, igroup) + + append = FKS_APPEND(fit) + + sv_inherit = FKS_INHERIT(fit) + FKS_INHERIT(fit) = NO_KEYW + FKS_APPEND(fit) = NO_KEYW + + # Parse the kernel section. + call fxf_ksection (ksection, fit, kgroup) + ksinh = FKS_INHERIT(fit) + + # Check for various error conditions. + if (FKS_OVERWRITE(fit) == YES && FKS_APPEND(fit) == YES) + call syserrs (SYS_FXFKSNOVR, "append") + + if (append == NO_KEYW && FKS_APPEND(fit) == NO_KEYW) + FKS_APPEND(fit) = NO + else if (append != NO_KEYW) + FKS_APPEND(fit) = append + + if (append == YES && FKS_OVERWRITE(fit) == YES) + FKS_APPEND(fit) = NO + + if (group != -1) { + if (kgroup != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = group + } else if (kgroup != -1) { + if (group != -1 && group != kgroup) + call syserrs (SYS_FXFKSBADGR, IM_NAME(im)) + else if (igroup != -1 && group != igroup) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = kgroup + } else if (igroup != -1) { + if ((group != -1 && group != igroup) || + (kgroup != -1 && kgroup != igroup)) + call syserrs (SYS_FXFKSBADFKIG, IM_NAME(im)) + fgroup = igroup + } + group = fgroup + + # Pre-read the data header. This is done after processing the user + # ksection as we need to get the extname/extver if any. + # EXTNAME or EXTVER has priority when defined over group. + + fks_extn_or_ver = + (FKS_EXTNAME(fit) != EOS || !IS_INDEFL(FKS_EXTVER(fit))) + + tgroup = fgroup + if (fks_extn_or_ver) + tgroup = -1 + + if (newimage == NO && !fnullfile (IM_HDRFILE(im))) { + iferr (call fxf_prhdr (im, tgroup)) { + # If group does not exist and over+, it is an error. + if (FKS_OVERWRITE(fit) == YES) + call syserrs (SYS_FXFEXTNF, IM_NAME(im)) + else + call erract (EA_ERROR) + } + } + + if (fgroup != -1 && tgroup != fgroup && fks_extn_or_ver) + call syserrs (SYS_FXFKSBADEXN, IM_NAME(im)) + + if (fgroup == -1 && fks_extn_or_ver) + group = tgroup + + FIT_EXPAND(fit) = FKS_EXPAND(fit) + + # For overwrite we need to force group to be the kernel section + # extension number. + + if (FKS_OVERWRITE(fit) == YES) + FIT_GROUP(fit) = max(kgroup,group) + else + FIT_GROUP(fit) = group + + if (FKS_APPEND(fit) == YES) + FIT_GROUP(fit) = -1 + + # See if there are some error conditions with the ksection. + call fxf_ks_errors (fit, acmode) + + # Check to see if the user ksection sets the inherit flag. If so + # this overrides all the defaults, including the data header. + + inherit_override = (FKS_INHERIT(fit) != NO_KEYW) + if (!inherit_override) + FKS_INHERIT(fit) = sv_inherit + + # A data header has precedence over the more global fkinit. + # If inherit is disabled in the data header don't enable it here. + + if (!inherit_override && FIT_INHERIT(fit) == NO) + FKS_INHERIT(fit) = NO + + call sfree (sp) +end + + +# FXF_CLEAN_PL -- Filter PLIO keywords from the UA. + +procedure fxf_clean_pl (im) + +pointer im #I image descriptor + +begin + #### (This is incredibly inefficient...) + call fxf_filter_keyw (im, "TFORM1") + call fxf_filter_keyw (im, "TFIELDS") + call fxf_filter_keyw (im, "ZIMAGE") + call fxf_filter_keyw (im, "ZCMPTYPE") + call fxf_filter_keyw (im, "ZBITPIX") + call fxf_filter_keyw (im, "ZNAXIS") + call fxf_filter_keyw (im, "ZNAXIS1") + call fxf_filter_keyw (im, "ZNAXIS2") + call fxf_filter_keyw (im, "ZTILE1") + call fxf_filter_keyw (im, "ZTILE2") + call fxf_filter_keyw (im, "ZNAME1") + call fxf_filter_keyw (im, "ZVAL1") +end |