From:	CSBVAX::MRGATE!ijah400%ivax.decnet@gold.bacs.indiana.edu@SMTP 16-AUG-1988 22:13
To:	ARISIA::EVERHART
Subj:	lzcomp/lzdcmp part 5 of 6.


Date: 16 Aug 88 15:28:00 EST
From: "IVAX::IJAH400" <ijah400%ivax.decnet@gold.bacs.indiana.edu>
Subject: lzcomp/lzdcmp part 5 of 6.
To: "everhart%arisia.decnet" <everhart%arisia.decnet@ge-crd.arpa>

$Part5:
$ File_is="LZCMP2.C"
$ Check_Sum_is=1634966692
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X/*
X *`009`009l z c m p 2 . c
X *
X * Actually do compression.  Terminology (and algorithm):
X *
X * Assume the input string is "abcd", we have just processed "ab" and
X * read 'c'.  At this point, a "prefix code" will be assigned to "ab".
X * Search in the prefix:character memory (either the "fast memory" or
X * the hash-code table) for the code followed by this character.  If
X * found, assign the code found to the "prefix code" and read the
X * next character.  If not found, output the current prefix code,
X * generate a new prefix code and store "old_prefix:char" in the
X * table with "new_prefix" as its definition.
X *
X * Naming conventions:
X *   code`009a variable containing a prefix code
X *   c or char`009a variable containing a character
X *
X * There are three tables that are searched (dependent on compile-time
X * and execution time considerations):
X *   fast`009Direct table-lookup -- requires a huge amount of physical
X *`009`009(non-paged) memory, but is very fast.
X *   hash`009Hash-coded table-lookup.
X *   cache`009A "look-ahead" cache for the hash table that optimizes
X *`009`009searching for the most frequent character.  This considerably
X *`009`009speeds up processing for raster-images (for example) at
X *`009`009a modest amount of memory.
X * Structures are used to hold the actual tables to simplify organization
X * of the program.
X *
X * Subroutines:
X *    compress()`009performs data compression on an input datastream.
X *    init_compress()`009called by the output routine to clear tables.
X */
X
X#include`009"lz.h"
X
X/*
X * General variables
X * Cleared by init_compress on a "hard initialization"
X * outputcode() in lzcmp3.c refers to next_code.
X */
X
Xlong int`009in_count;`009`009/* Length of input`009`009*/
Xlong int`009out_count;`009`009/* Bytes written to output file`009*/
Xstatic flag`009first_clear = TRUE;`009/* Don't zero first time`009*/
Xcode_int`009next_code;`009`009/* Next output code`009`009*/
Xstatic count_int checkpoint = CHECK_GAP; /* When to test ratio again`009*/
Xstatic long`009ratio = 0;`009`009/* Ratio for last segment`009*/
X
X/*
X * These global parameters are set by mainline code.  Unchanged here.
X */
Xextern short`009maxbits;`009`009/* Settable max # bits/code`009*/
Xextern short`009block_compress;`009`009/* For old-style compatibility`009*/
Xextern code_int`009maxmaxcode;`009`009/* Actual maximum output code`009*/
Xextern long`009tot_incount;`009`009/* Total input count`009`009*/
Xextern long`009tot_outcount;`009`009/* Total output count`009`009*/
Xextern code_int`009hsize;`009`009`009/* Actual hash table size`009*/
X
X#ifdef XENIX_16
Xstatic count_int htab0[8192];
Xstatic count_int htab1[8192];
Xstatic count_int htab2[8192];
Xstatic count_int htab3[8192];
Xstatic count_int htab4[8192];
Xstatic count_int htab5[8192];
Xstatic count_int htab6[8192];
Xstatic count_int htab7[8192];
Xstatic count_int htab8[HSIZE - 65536];
Xstatic count_int *hashtab[9] = {
X    htab0, htab1, htab2, htab3, htab4, htab5, htab6, htab7, htab8
X};
X
Xstatic U_short code0[16384];
Xstatic U_short code1[16384];
Xstatic U_short code2[16384];
Xstatic U_short code3[16384];
Xstatic U_short code4[HSIZE - 65536];
Xstatic U_short *codetab[5] = {
X    code0, code1, code3, code3, code4
X}
X
X#define HASH(i)`009`009(hashtab[((unsigned) (i)) >> 13][(i) & 0x1FFF])
X#define CODE(i)`009`009(codetab[((unsigned) (i)) >> 14][(i) & 0x3FFF])
X
X#else
Xcount_int`009hashtab[HSIZE];
XU_short`009`009codetab[HSIZE];
X
X#define HASH(i)`009`009hashtab[i]
X#define CODE(i)`009`009codetab[i]
X#endif
X`012
X/*
X * compress a datastream
X *
X * Algorithm:  on large machines, for maxbits <= FBITS, use fast direct table
X * lookup on the prefix code / next character combination.  For smaller code
X * size, use open addressing modular division double hashing (no chaining), ala
X * Knuth vol. 3, sec. 6.4 Algorithm D, along with G. Knott's relatively-prime
X * secondary probe.  Do block compression with an adaptive reset, whereby the
X * code table is cleared when the compression ratio decreases, but after the
X * table fills.  The variable-length output codes are re-sized at this point,
X * and a special LZ_CLEAR code is generated for the decompressor.  For the
X * megamemory version, the sparse array is cleared indirectly through a
X * "shadow" output code history.  Late additions: for the hashing code,
X * construct the table according to file size for noticeable speed improvement
X * on small files.  Also detect and cache codes associated with the most
X * common character to bypass hash calculation on these codes (a characteristic
X * of highly-compressable raster images).  Please direct questions about this
X * implementation to ames!jaw.
X */
X
Xcompress(in)
XSTREAM`009`009*in;`009`009/* Input stream structure`009`009*/
X/*
X * Compress driver.  Global fsize is the size of the entire datastream
X * (from LZ_STX or LZ_SOH to the terminating LZ_ETX).  You must
X * force a reinitialization -- by calling outputcode() with a new header --
X * if size is changed.  If the "newer" output format is chosen (with
X * data streams delimited by LZ_SOH/LZ_STX, init_compress will be
X * called automatically.  Otherwise, you must call init_compress(TRUE)
X * before calling compress() for the first time.
X */
X{
X`009register long`009`009hash_code;`009/* What we look for`009*/
X`009register code_int`009i;`009`009/* Index into vectors`009*/
X`009register int`009`009c;`009`009/* Current input char`009*/
X`009register code_int`009code;`009`009/* Substring code`009*/
X`009register int`009`009displacement;`009/* For secondary hash`009*/
X`009register code_int`009hsize_reg;`009/* Size of hash table`009*/
X`009register int`009`009hshift;`009`009/* For xor hasher`009*/
X
X`009if ((code = GET(in)) == EOF)
X`009    return;
X`009in_count++;
X`009hsize_reg = hsize;
X`009/*
X`009 * Set hash code range bound
X`009 */
X`009hshift = 0;
X`009for (hash_code = (long) hsize; hash_code < 65536L; hash_code <<= 1)
X`009    hshift++;
X`009hshift = 8 - hshift;
X`009while ((c = GET(in)) != (unsigned) EOF) {
X`009    in_count++;
X`009    hash_code = (long) (((long) c << maxbits) + code);
X`009    i = (c << hshift) ^ code;`009`009/* XOR hashing`009`009*/
X`009    if (HASH(i) == hash_code) {`009`009/* Found at first slot?`009*/
X`009`009code = CODE(i);
X`009`009continue;
X`009    }
X`009    else if ((long) HASH(i) < 0)`009/* empty slot`009`009*/
X`009`009goto nomatch;
X`009    displacement = hsize_reg - i;`009/* secondary hash`009*/
X`009    if (i == 0)
X`009`009displacement = 1;
Xprobe:
X`009    if ((i -= displacement) < 0)`009/* Wrap around?`009`009*/
X`009`009i += hsize_reg;
X`009    if (HASH(i) == hash_code) {`009`009/* Found in hash table?`009*/
X`009`009code = CODE(i);`009`009`009/* Set new prefix code`009*/
X`009`009continue;`009`009`009/* Read next input char`009*/
X`009    }
X`009    else if ((long) HASH(i) > 0)`009/* If slot is occupied`009*/
X`009`009goto probe;`009`009`009/* Look somewhere else`009*/
Xnomatch:
X`009    /*
X`009     * Output the current prefix and designate a new prefix.
X`009     * If the input character was the "hog", save it in the
X`009     * look-ahead cache table.  Then, save in the hash table.
X`009     */
X`009    outputcode((code_int) code);`009/* No match, put prefix`009*/
X#if SIGNED_COMPARE_SLOW
X`009    if ((unsigned) next_code < (unsigned) maxmaxcode) {
X#else
X`009    if (next_code < maxmaxcode) {
X#endif
X`009`009CODE(i) = next_code++;`009`009/* code -> hashtable`009*/
X`009`009HASH(i) = hash_code;
X`009    }
X`009    else if (block_compress
X`009`009  && (count_int) in_count >= checkpoint) {
X`009`009clear();
X`009    }
X`009    code = c;`009`009`009`009/* Start new substring`009*/
X`009}
X`009/*
X`009 * At EOF, put out the final code.
X`009 */
X`009outputcode((code_int) code);
X}
X`012
Xclear()
X/*
X * Check the compression ratio to see whether it is going up
X * or staying the same.  If it is going down, the internal
X * statistics of the file have changed, so clear out our
X * tables and start over.  Inform the decompressor of the
X * change by sending out a LZ_CLEAR code.
X */
X{
X`009register long int`009rat;
X
X`009checkpoint = in_count + CHECK_GAP;
X#if DEBUG
X`009if (verbose > 2) {
X`009    divout("at clear() test",  in_count, out_count, "");
X`009    fprintf(stderr, ", ratio at entry: %ld.%02ld, gap %d\n",
X`009`009rat / 256L, ((rat & 255L) * 100L) / 256L, CHECK_GAP);
X`009}
X#endif
X`009if (in_count > 0x007FFFFL) {`009`009/* Shift will overflow`009*/
X`009    rat = out_count >> 8;
X`009    if (rat == 0)
X`009`009rat = 0x7FFFFFFFL;
X`009    else {
X`009`009rat = in_count / rat;
X`009    }
X`009}
X`009else {
X`009    rat = (in_count << 8) / out_count;
X`009}
X`009if (rat > ratio)
X`009    ratio = rat;
X`009else {
X#if DEBUG
X`009    if (verbose > 0) {
X`009`009fprintf(stderr, "Resetting compression, in %ld, out %ld\n",
X`009`009    in_count, out_count);
X`009`009fprintf(stderr, "Old ratio: %ld == (%ld.%02ld)",
X`009`009    ratio, ratio / 256L, ((ratio & 255L) * 100L) / 256L);
X`009`009fprintf(stderr, ", test ratio: %ld = (%ld.%02ld), gap %d\n",
X`009`009    rat, rat / 256L, ((rat & 255L) * 100L) / 256L, CHECK_GAP);
X`009    }
X#endif
X`009    outputcode((code_int) LZ_CLEAR);`009/* Calls init_compress`009*/
X`009}
X}
X`012
Xinit_compress(full_init)
Xflag`009`009full_init;`009/* TRUE for full initialization`009`009*/
X/*
X * Clear the tables.  Called by outputcode() on LZ_SOH, LZ_STX
X * (full_init TRUE) or on LZ_CLEAR (full_init FALSE).
X * init_compress() is not called on LZ_EOR.
X */
X{
X#ifdef XENIX_16
X`009register count_int`009*hp;
X`009register int`009`009n;
X`009register int`009`009j;
X`009register code_int`009k;
X
X`009k = hsize;
X`009for (j = 0; k > 0; k -= 8192) {
X`009    i = (k < 8192) ? k : 8192;
X`009    hp = hashtab[j++];
X`009    n = i >> 4;
X`009    switch (i & 15) {
X`009    case 15:`009*hp++ = -1;
X`009    case 14:`009*hp++ = -1;
X`009    case 13:`009*hp++ = -1;
X`009    case 12:`009*hp++ = -1;
X`009    case 11:`009*hp++ = -1;
X`009    case 10:`009*hp++ = -1;
X`009    case  9:`009*hp++ = -1;
X`009    case  8:`009*hp++ = -1;
X`009    case  7:`009*hp++ = -1;
X`009    case  6:`009*hp++ = -1;
X`009    case  5:`009*hp++ = -1;
X`009    case  4:`009*hp++ = -1;
X`009    case  3:`009*hp++ = -1;
X`009    case  2:`009*hp++ = -1;
X`009    case  1:`009*hp++ = -1;
X`009    }
X`009    while (--n >= 0) {
X`009`009*hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009`009*hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009`009*hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009`009*hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009   }
X`009}
X#else
X`009register count_int`009*hp;
X`009register code_int`009n;
X
X`009hp = &hashtab[0];
X`009n = hsize >> 4;`009`009`009/* divide by 16`009`009`009*/
X`009switch (hsize & 15) {
X`009case 15:`009*hp++ = -1;
X`009case 14:`009*hp++ = -1;
X`009case 13:`009*hp++ = -1;
X`009case 12:`009*hp++ = -1;
X`009case 11:`009*hp++ = -1;
X`009case 10:`009*hp++ = -1;
X`009case  9:`009*hp++ = -1;
X`009case  8:`009*hp++ = -1;
X`009case  7:`009*hp++ = -1;
X`009case  6:`009*hp++ = -1;
X`009case  5:`009*hp++ = -1;
X`009case  4:`009*hp++ = -1;
X`009case  3:`009*hp++ = -1;
X`009case  2:`009*hp++ = -1;
X`009case  1:`009*hp++ = -1;
X`009}
X`009while (--n >= 0) {
X`009    *hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009    *hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009    *hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009    *hp++ = -1; *hp++ = -1; *hp++ = -1; *hp++ = -1;
X`009}
X#endif
X`009if (full_init) {
X`009    tot_incount += in_count;
X`009    tot_outcount += out_count;
X`009    in_count = 0;
X`009    out_count = 0;
X`009    ratio = 0;
X`009}
X`009first_clear = FALSE;
X`009next_code = firstcode;
X}
$ GoSub Convert_File
$ File_is="LZVIO.C"
$ Check_Sum_is=1412600256
$ Copy SYS$Input VMS_SHAR_DUMMY.DUMMY
X/*
X *`009`009`009l z v i o . c
X * For VMS V4 only.
X */
X
X/*
X * Problems:
X *`009If you open a second input file (getting rms attributes)
X *`009it aborts with an internal "fatal" error (15820C LIB-F-FATERRLIB)
X */
X
X/*
X * Make TESTING_FDLIO non-zero to enable test code.
X *
X * Edit History
X */
X#ifndef`009TESTING_FDLIO
X#define`009TESTING_FDLIO`0090
X#endif
X
X/*
X * RMS/FDL record level i/o routines for Vax-11 C V4 or greater only.
X * Rather crude.
X *
X * The following are provided:
X *
X *`009#define`009FDLSTUFF`009char
X *`009#include descrip
X *
X *`009FDLSTUFF *
X *`009fdl_open(filename, fdl_descriptor)
X *`009char`009`009`009*filename;
X *`009struct`009dsc$descriptor`009*fdl_descriptor;
X *`009`009Initializes internal buffers and opens this existing
X *`009`009file for input.  The filename may not contain wildcards.
X *`009`009On (successful) return, fdl_descriptor will point to
X *`009`009an initialized fdl specification.  The description
X *`009`009string will be in malloc'ed memory.  The caller does not
X *`009`009initialize the fdl_descriptor.  Returns NULL on error.
X *`009`009(Note an error will be returned if the file is not
X *`009`009block-oriented.)
X *
X *`009`009When you don't need the fdl_descriptor information
X *`009`009any more, free it by calling
X *`009`009    fdl_free(fdl_descriptor);
X *`009`009if fdl_descriptor is NULL on entry, the file is opened
X *`009`009normally (fdl information is not collected).
X *
X *`009FDLSTUFF *
X *`009fdl_create(fdl_descriptor, override_filename)
X *`009struct`009dsc$descriptor`009*fdl_descriptor;
X *`009char`009`009`009*override_filename;
X *`009`009Creates a file using the fdl specification.
X *`009`009If override_filename is not NULL and not equal to "",
X *`009`009it will override the filename specified in the fdl.
X *`009`009fdl_write() is used to write data to the file.
X *`009`009Returns NULL on error.
X *
X *`009`009if fdl_descriptor is NULL, the file is created using
X *`009`009the name in override_filename (which must be present).
X *`009`009The file is created in "undefined" record format.
X *
X *`009fdl_free(fdl_descriptor)
X *`009struct`009dsc$descriptor`009*fdl_descriptor;
X *`009`009Releases the fdl descriptor block.
X *
X *`009int
X *`009fdl_read(buffer, buffer_length, r)
X *`009char`009`009*buffer;
X *`009int`009`009buffer_length;
X *`009FDLSTUFF`009*r;
X *`009`009Read buffer_length bytes from the file (using SYS$READ).
X *`009`009No expansion or interpretation.  buffer_length had
X *`009`009better be even or you're asking for trouble.  Returns
X *`009`009the actual number of bytes read.  The file has been
X *`009`009opened by fdl_open.
X *
X *`009int
X *`009fdl_write(buffer, buffer_length, r)
X *`009char`009`009*buffer;
X *`009int`009`009buffer_length;
X *`009FDLSTUFF`009*r;
X *`009`009Write buffer_length bytes to the file (using SYS$WRITE).
X *`009`009No expansion or interpretation.  buffer_length had
X *`009`009better be even or you're asking for trouble.  Returns
X *`009`009the actual number of bytes written.  The file was opened
X *`009`009by fdl_create();
X *
X *`009fdl_getname(r, buffer)
X *`009FDLSTUFF`009*r;
X *`009char`009`009*buffer;
X *`009`009Copies the currently open file's name to the caller's
X *`009`009data buffer buffer.
X *
X *`009long
X *`009fdl_fsize(r)
X *`009`009Returns the size in bytes of the opened file.
X *
X *`009fdl_dump(fdl_descriptor, fd)
X *`009struct`009dsc$descriptor`009*fdl_descriptor;
X *`009FILE`009`009`009*fd;
X *`009`009Writes the fdl info to the indicated file with
X *`009`009line breaks in appropriate places.
X *
X *`009fdl_message(r, why)
X *`009FDLSTUFF`009*r;
X *`009char`009`009*why;
X *`009`009All system-level routines set a global value, fdl_status.
X *`009`009fdl_message() prints the error message text corresponding
X *`009`009to the current value of fdl_status.  The message printed
X *`009`009has the format:
X *`009`009`009why current_filename: error_message.
X *`009`009If why is NULL, only the error_message is printed.
X */
X`012
X#include "lz.h"
X#if VMS_V4
X#include rms
X#include ssdef
X#include descrip
X#include devdef
X#ifndef`009FDL$M_FDL_SIGNAL
X#define FDL$M_FDL_SIGNAL`0091`009/* Signal errors if set`009`009*/
X#endif
X#ifndef`009FDL$M_FDL_STRING
X#define FDL$M_FDL_STRING`0092`009/* Use string for fdl text`009*/
X#endif
X#if TESTING_FDLIO
X#define`009SIGNAL_ON_ERROR`009FDL$M_FDL_SIGNAL
X#else
X#define`009SIGNAL_ON_ERROR`0090
X#endif
X
X#define`009TRUE`0091
X#define`009FALSE`0090
X#define`009EOS`0090
X
Xtypedef struct FDLSTUFF {
X`009struct`009RAB`009rab;`009`009/* Record access buffer`009`009*/
X`009struct`009FAB`009fab;`009`009/* File access buffer`009`009*/
X`009struct`009NAM`009nam;`009`009/* File name buffer`009`009*/
X`009struct`009XABFHC`009xab;`009`009/* Extended attributes block`009*/
X`009char`009`009starname[NAM$C_MAXRSS + 1]; /* Wild file name`009*/
X`009char`009`009filename[NAM$C_MAXRSS + 1]; /* Open file name`009*/
X} FDLSTUFF;
X
Xint`009`009fdl_status;`009`009/* Set to last rms call status`009*/
X
Xstatic FDLSTUFF *
Xfail(r, why, name)
XFDLSTUFF`009*r;`009`009`009/* Buffer`009`009`009*/
Xchar`009`009*why;`009`009`009/* A little commentary`009`009*/
Xchar`009`009*name;`009`009`009/* Argument to perror`009`009*/
X/*
X * Problem exit routine
X */
X{
X#if TESTING_FDLIO
X`009if (name == NULL && r != NULL)
X`009    name = r->fab.fab$l_fna;
X`009message(r, why, name);
X#endif
X`009if (r != NULL)
X`009    free(r);
X`009return (NULL);
X}
X`012
XFDLSTUFF *
Xfdl_open(filename,  fdl_descriptor)
Xchar`009`009`009*filename;`009`009/* What to open`009`009*/
Xstruct`009dsc$descriptor`009*fdl_descriptor;`009/* Result descriptor`009*/
X/*
X * Open the file.  Returns NULL on failure, else a pointer to RMS stuff.
X * Which is equivalently a pointer to the RAB. (Note that the RAB points
X * in turn to the FAB.)
X *
X * Return the file's fdl descriptor in the user-supplied (uninitialized)
X * descriptor.
X */
X{
X`009register FDLSTUFF`009*r;
X`009int`009`009`009retlen;
X`009int`009`009`009badblk;
X`009struct FAB`009`009*fab_add;
X`009struct RAB`009`009*rab_add;
X`009static int`009`009flags = (FDL$M_FDL_STRING | SIGNAL_ON_ERROR);
X`009extern FDLSTUFF`009`009*fdl_setup();
X
X`009if ((r = fdl_setup(filename)) == NULL)
X`009    return (NULL);
X`009/*
X`009 * Now open the file.
X`009 */
X`009r->fab.fab$b_fac = FAB$M_GET | FAB$M_BIO; /* Block I/O only`009*/
X`009if ((fdl_status = sys$open(&r->fab)) != RMS$_NORMAL) {
X`009    return (fail(r, "opening file", NULL));
X`009}
X`009if ((r->fab.fab$l_dev & DEV$M_REC) != 0) {
X`009    fail(r, "Record only device");
X`009    fdl_close(r);
X`009    return (NULL);
X`009}
X`009r->rab.rab$l_rop = RAB$M_BIO;`009`009/* Block I/O only`009*/
X`009if ((fdl_status = sys$connect(&r->rab)) != RMS$_NORMAL)
X`009    return (fail(r, "connecting after open", NULL));
X`009if (fdl_descriptor != NULL) {
X`009    /*
X`009     * Now, get the file attributes
X`009     */
X`009    fdl_descriptor->dsc$w_length = 4096;
X`009    fdl_descriptor->dsc$b_dtype = DSC$K_DTYPE_VT;
X`009    fdl_descriptor->dsc$b_class = DSC$K_CLASS_D;
X`009    fdl_descriptor->dsc$a_pointer = malloc(4096);
X`009    fab_add = &r->fab;
X`009    rab_add = &r->rab;
X`009    if ((fdl_status = fdl$generate(
X`009`009    &flags,
X`009`009    &fab_add,
X`009`009    &rab_add,
X`009`009    0, 0,
X`009`009    fdl_descriptor,
X`009`009    &badblk,
X`009`009    &retlen)) != SS$_NORMAL) {
X`009`009fdl_free(fdl_descriptor);
X`009`009sys$close(&r->fab);
X`009`009return(fail(r, "getting fdl info", NULL));
X`009    }
X`009    /*
X`009     * Success, null-terminate fdl info and squeeze the block.
X`009     */
X`009    fdl_descriptor->dsc$a_pointer[retlen] = EOS;
X`009    fdl_descriptor->dsc$a_pointer
X`009`009= realloc(fdl_descriptor->dsc$a_pointer, retlen + 1);
X`009    fdl_descriptor->dsc$w_length = retlen;
X`009}
X`009return (r);
X}
X`012
XFDLSTUFF *
Xfdl_create(fdl_descriptor, override_filename)
Xstruct`009dsc$descriptor`009*fdl_descriptor;`009/* Result descriptor`009*/
Xchar`009`009`009*override_filename;`009/* What to open`009`009*/
X/*
X * Create the file, Returns NULL on failure, else a pointer to RMS stuff.
X * Which is equivalently a pointer to the RAB. (Note that the RAB points
X * in turn to the FAB.)  The file is open for writing using fdl_write.
X *
X * Uses the filename in the descriptor block, or the override filename
X * if supplied (non-NULL and not == "");
X *
X * If fdl_descriptor is NULL, the override_filename is opened normally.
X */
X{
X`009register FDLSTUFF`009*r;
X`009int`009`009`009retlen;
X`009int`009`009`009badblk;
X`009static int`009`009flags = (FDL$M_FDL_STRING | SIGNAL_ON_ERROR);
X`009struct`009dsc$descriptor`009newname;
X`009struct`009dsc$descriptor`009*newname_ptr;
X`009int`009`009`009fid_block[3];
X`009char`009`009`009created_name[NAM$C_MAXRSS + 1];
X`009struct`009dsc$descriptor`009created_name_des = {
X`009`009`009`009    NAM$C_MAXRSS,
X`009`009`009`009    DSC$K_DTYPE_T,
X`009`009`009`009    DSC$K_CLASS_S,
X`009`009`009`009    &created_name[0]
X`009`009`009`009};
X`009extern FDLSTUFF`009`009*fdl_setup();
X
X`009if (fdl_descriptor == NULL) {
X`009    if ((r = fdl_setup(override_filename)) == NULL)
X`009`009return (NULL);
X`009    r->fab.fab$b_fac = FAB$M_PUT | FAB$M_BIO; /* Block I/O only`009*/
X`009    r->fab.fab$l_fop |= (FAB$M_NAM | FAB$M_SQO | FAB$M_BIO);
X`009    r->fab.fab$b_org = FAB$C_SEQ;`009/* Sequential only`009*/
X`009    r->fab.fab$b_rfm = FAB$C_UDF;`009/* Undefined format`009*/
X`009    if ((fdl_status = sys$create(&r->fab)) & 01 == 0)
X`009`009return (fail(r, "creating (sys$create)"));
X`009    goto exit;
X`009}
X`009if (override_filename == NULL || override_filename[0] == '\0')
X`009    newname_ptr = NULL;
X`009else {
X`009    newname_ptr = &newname;
X`009    newname.dsc$w_length = strlen(override_filename);
X`009    newname.dsc$b_dtype = DSC$K_DTYPE_T;
X`009    newname.dsc$b_class = DSC$K_CLASS_S;
X`009    newname.dsc$a_pointer = override_filename;
X`009}
X`009if ((fdl_status = fdl$create(fdl_descriptor,
X`009`009newname_ptr,`009`009/* New file name if any`009`009*/
X`009`0090,`009`009`009/* Default filename`009`009*/
X`009`009&created_name_des,`009/* Resultant filename`009`009*/
X`009`009&fid_block[0],`009`009/* File ID block`009`009*/
X`009`009&flags,`009`009`009/* FDL flag bits`009`009*/
X`009`0090,`009`009`009/* Statement number`009`009*/
X`009`009&retlen,`009`009/* Created name length`009`009*/
X`009`0090, 0)`009`009`009/* Create status, stv`009`009*/
X`009`009) & 01 == 0) {
X`009    return(fail(NULL, "creating (fdl$create)", NULL));
X`009}
X`009created_name[retlen] = '\0';
X`009if ((r = fdl_setup(created_name)) == NULL)
X`009    return (NULL);
X`009/*
X`009 * Now, open the file for output.
X`009 */
X`009r->fab.fab$b_fac = FAB$M_PUT | FAB$M_BIO; /* Block I/O only`009*/
X`009if ((fdl_status = sys$open(&r->fab)) != RMS$_NORMAL) {
X`009    return (fail(r, "opening created file", NULL));
X`009}
Xexit:`009if ((r->fab.fab$l_dev & DEV$M_REC) != 0) {
X`009    fail(r, "Record only device");
X`009    fdl_close(r);
X`009    return (NULL);
X`009}
X`009r->rab.rab$l_rop = RAB$M_BIO;`009`009/* Block I/O only`009*/
X`009if ((fdl_status = sys$connect(&r->rab)) != RMS$_NORMAL)
X`009    return (fail(r, "connecting after create", NULL));
X`009return (r);
X}
X`012
Xstatic FDLSTUFF *
Xfdl_setup(filename)
Xchar`009`009*filename;
X/*
X * Initializes rms blocks and parses file name.  Returns the
X * FDL data block on success, NULL on error.
X */
X{
X`009register FDLSTUFF`009*r;
X
X`009if ((r = (char *)malloc(sizeof (FDLSTUFF))) == NULL)
X`009    return (NULL);
X`009r->fab = cc$rms_fab;`009`009`009/* Preset fab,`009`009*/
X`009r->nam = cc$rms_nam;`009`009`009/*   name block`009`009*/
X`009r->rab = cc$rms_rab;`009`009`009/*   and record block`009*/
X`009r->xab = cc$rms_xabfhc;`009`009`009/*   file header block`009*/
X`009r->fab.fab$l_nam = &r->nam;`009`009/* fab -> name block`009*/
X`009r->fab.fab$l_xab = &r->xab;`009`009/* fab -> file header`009*/
X`009r->fab.fab$l_fna = filename;`009`009/* Argument filename`009*/
X`009r->fab.fab$b_fns = strlen(filename);`009/* ... size`009`009*/
X`009r->rab.rab$l_fab = &r->fab;`009`009/* rab -> fab`009`009*/
X`009`009`009`009`009`009/* Stuff the name block`009*/
X`009r->nam.nam$l_esa = r->starname;`009`009/* Expanded filename`009*/
X`009r->nam.nam$b_ess = NAM$C_MAXRSS + 1;`009/* ... size`009`009*/
X`009r->nam.nam$b_rss = NAM$C_MAXRSS + 1;`009/* ... max size`009`009*/
X`009if ((fdl_status = sys$parse(&r->fab)) != RMS$_NORMAL) {
X`009    return (fail(r, "parsing", filename));
X`009}
X`009((char *)r->nam.nam$l_esa)[r->nam.nam$b_esl] = EOS;
X`009r->fab.fab$l_fna = r->nam.nam$l_esa;`009/* File name`009`009*/
X`009r->fab.fab$b_fns = r->nam.nam$b_esl;`009/* Length`009`009*/
X`009r->fab.fab$l_fop |= FAB$M_NAM;`009`009/* Use name block`009*/
X`009return (r);
X}
X`012
Xfdl_free(fdl_descriptor)
Xstruct`009dsc$descriptor`009*fdl_descriptor;
X/*
X * Release the descriptor
X */
X{
X`009if (fdl_descriptor->dsc$a_pointer != NULL) {
X`009    free(fdl_descriptor->dsc$a_pointer);
X`009    fdl_descriptor->dsc$a_pointer = NULL;
X`009}
X}
X
Xfdl_close(r)
Xregister FDLSTUFF`009*r;
X{
X`009if ((fdl_status = sys$close(&r->fab)) != RMS$_NORMAL)
X`009    return(fail(r, "close", NULL));
X`009free(r);
X}
X`012
Xint
Xfdl_read(buffer, buffer_length, r)
Xchar`009`009*buffer;`009`009/* Record`009`009`009*/
Xint`009`009buffer_length;`009`009/* Record length`009`009*/
Xregister FDLSTUFF *r;`009`009`009/* Record info.`009`009`009*/
X/*
X * Read the next record from the file.  Returns number of bytes read or
X * -1 on any error. fdl_status has the status.
X */
X{
X`009r->rab.rab$l_ubf = buffer;
X`009r->rab.rab$w_usz = buffer_length;
X`009r->rab.rab$l_bkt = 0;
X`009if ((fdl_status = sys$read(&r->rab)) != RMS$_NORMAL) {
X#if TESTING_FDLIO
X`009    if (fdl_status != RMS$_EOF) {
X`009`009fdl_message(r, "error return from sys$read");
X`009`009sleep(1);
X`009    }
X#endif
X`009    return (-1);
X`009}
X`009return (r->rab.rab$w_rsz);
X}
X`012
Xint
Xfdl_write(buffer, buffer_length, r)
Xchar`009`009*buffer;`009`009/* Record`009`009`009*/
Xint`009`009buffer_length;`009`009/* Record length`009`009*/
Xregister FDLSTUFF *r;`009`009`009/* Record info.`009`009`009*/
X/*
X * Write the next record to the file.  Returns number of bytes written or
X * -1 on any error. fdl_status has the status.
X */
X{
X`009r->rab.rab$l_rbf = buffer;
X`009r->rab.rab$w_rsz = buffer_length;
X`009r->rab.rab$l_bkt = 0;
X`009if ((fdl_status = sys$write(&r->rab)) != RMS$_NORMAL) {
X#if TESTING_FDLIO
X`009    fdl_message(r, "error return from sys$write");
X`009    sleep(1);
X#endif
X`009    return (-1);
X`009}
X`009return (r->rab.rab$w_rsz);
X}
X`012
Xfdl_getname(r, buffer)
XFDLSTUFF`009*r;`009`009`009/* File pointer`009`009`009*/
Xchar`009`009*buffer;`009`009/* Where to put it`009`009*/
X/*
X * Return current file name
X */
X{
X`009strcpy(buffer, r->fab.fab$l_fna);
X`009return (buffer);
X}
X
Xlong
Xfdl_fsize(r)
XFDLSTUFF`009*r;`009`009`009/* File pointer`009`009`009*/
X/*
X * Return current file size
X */
X{
X`009return (((long) r->xab.xab$l_ebk * 512) + r->xab.xab$w_ffb);
X}
X
Xfdl_message(r, why)
XFDLSTUFF`009*r;
Xchar`009`009*why;
X/*
X * Print error message
X */
X{
X`009extern char`009*vms_etext();
X
X`009if (why == NULL) {
X`009    fprintf(stderr, "\n%s\n\n", vms_etext(fdl_status));
X`009}
X`009else {
X`009    fprintf(stderr, "\n%s%s%s: %s\n\n",
X`009`009why,
X`009`009(why[0] == EOS) ? "" : " ",
X`009`009(r == NULL) ? "" : r->fab.fab$l_fna,
X`009`009vms_etext(fdl_status));
X`009}
X}
X
Xstatic char`009`009errname[257];`009/* Error text stored here`009*/
Xstatic $DESCRIPTOR(err, errname);`009/* descriptor for error text`009*/
X
Xstatic char *
Xvms_etext(errorcode)
Xint`009`009errorcode;
X{
X`009char`009`009*bp;
X`009short`009`009errlen;`009`009/* Actual text length`009`009*/
X
X`009lib$sys_getmsg(&errorcode, &errlen, &err, &15);
X`009/*
X`009 * Trim trailing junk.
X`009 */
X`009for (bp = &errname[errlen]; --bp >= errname;) {
X`009    if (isgraph(*bp) && *bp != ' ')
X`009`009break;
X`009}
X`009bp[1] = EOS;
X`009return(errname);
X}
X
Xstatic
Xmessage(r, why, name)
XFDLSTUFF`009*r;`009`009`009/* Buffer`009`009`009*/
Xchar`009`009*why;`009`009`009/* A little commentary`009`009*/
Xchar`009`009*name;`009`009`009/* File name`009`009`009*/
X/*
X * Print error message
X */
X{
X`009fprintf(stderr, "\nRMS error %x when %s %s\n",
X`009    fdl_status, why, (name == NULL) ? "" : name);
X`009fprintf(stderr, "\"%s\"\n", vms_etext(fdl_status));
X}
X`012
Xfdl_dump(fdl_descriptor, fd)
Xstruct`009dsc$descriptor`009*fdl_descriptor;
XFILE`009`009`009*fd;
X/*
X * Dump the descriptor to fd.
X */
X{
X`009register char`009*tp, *end;
X
X`009tp = fdl_descriptor->dsc$a_pointer;
X`009end = tp + fdl_descriptor->dsc$w_length;
X`009while (tp < end) {
X`009    if (*tp == '"') {
X`009`009do {
X`009`009    putc(*tp++, fd);
X`009`009} while (*tp != '"');
X`009    }
X`009    putc(*tp, fd);
X`009    if (*tp++ == ';')
X`009`009putc('\n', fd);
X`009}
X}
X
X`012
X#if`009TESTING_FDLIO
X/*
X * Test program for rms io
X */
X#include <stdio.h>
X
Xchar`009`009`009line[133];
Xchar`009`009`009filename[133];
Xchar`009`009`009buffer[2048];
X
Xmain(argc, argv)
Xint`009`009argc;
Xchar`009`009*argv[];
X{
X`009FDLSTUFF`009*old;
X`009FDLSTUFF`009*new;
X`009int`009`009size, total, nrecords;
X`009struct`009dsc$descriptor`009fdl_info;`009/* Result descriptor`009*/
X
X`009for (;;) {
X`009    fprintf(stderr, "Old file name: ");
X`009    fflush(stdout);
X`009    if (gets(line) == NULL)
X`009`009break;
X`009    if (line[0] == EOS)
X`009`009continue;
X`009    if ((old = fdl_open(line, &fdl_info)) == NULL) {
X`009`009fprintf(stderr, "open failed\n");
X`009`009continue;
X`009    }
X`009    fprintf(stderr, "New file name: ");
X`009    if (gets(line) == NULL)
X`009`009break;
X`009    if ((new = fdl_create(&fdl_info, line)) == NULL) {
X`009`009fprintf(stderr, "create failed\n");
X`009`009fdl_free(&fdl_info);
X`009`009continue;
X`009    }
X`009    fdl_getname(old, buffer);
X`009    fprintf(stderr, "Fdl for \"%s\", size %ld\n",
X`009`009buffer, fdl_fsize(old));
X`009    fdl_dump(&fdl_info, stderr);
X`009    total = nrecords = 0;
X`009    while ((size = fdl_read(buffer, sizeof buffer, old)) > 0) {
X`009`009fdl_write(buffer, size, new);
X`009`009nrecords++;
X`009`009total += size;
X`009    }
X`009    fdl_close(old);
X`009    fdl_close(new);
X`009    fprintf(stderr, "copied %d records, %d bytes total\n",
X`009`009nrecords, total);
X`009    fdl_free(&fdl_info);
X`009}
X}
X
X#endif
X#endif
$ GoSub Convert_File
$ Goto Part6

