Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MKEY4.ZIP/MULKEY4.PAS

Pascal/Delphi Source File | 1988-04-19 | 20.6 KB | 626 lines

UNIT Mulkey4;

INTERFACE

USES Crt, taccess;

  {$I-}

CONST
  MaxKeys = 5;
  MaxFields = 25;

TYPE
  KEY_TYPE = (KEY_INTEGER, KEY_CHAR, KEY_STRING, KEY_REAL);
  Field_Type = (Valid_Date_Field, Date_Field, Integer_Field,
                Real_Field, String_Field, Non_Blank, Memo_Field);

                {***** All Date Fields must be a STRING of at LEAST
                       Length 10. Memo fields must be LongInts. All
                       other fields are STRINGS of appropriate lengths *****}


  KeyDescrip = RECORD
                 Offset : INTEGER;
                 KEYLENGTH : WORD;
                 EXTENSION : STRING[3];
                 UNIQUE : BOOLEAN;
                 UPSHIFT : BOOLEAN;
                 KEYTYPE : KEY_TYPE;
                 INDEX_FILE : IndexFile;
               END;
  DBField = RECORD
              XCoord : INTEGER;
              YCoord : INTEGER;
              FieldData : ^STRING;
              FieldType : Field_Type;
              FieldLength : INTEGER;
              LegalChars : STRING[80];
              ScreenPrompt : STRING[80];
              HelpPrompt : STRING[80];
            END;
  File_Type = RECORD
                Name : STRING[60];
                RecSize : INTEGER;
                IOERROR : BOOLEAN;
                REC_REF : LONGINT;
                DATA_FILE : DataFile;
                NUMBER_OF_KEYS : BYTE;
                Key : ARRAY[1..MaxKeys] OF KeyDescrip;
                PromptAttribute : INTEGER;
                GetAttribute : INTEGER;
                DisplayAttribute : INTEGER;
                HelpAttribute : INTEGER;
                NumOfFields : INTEGER;
                Field : ARRAY[1..MaxFields] OF DBField;
              END;
  DBFile = ^File_Type;
  Word2 = STRING[254];

VAR
  WORK_KEY : TaKeyStr;
  WORK_REC : ARRAY[0..MaxDataRecSize] OF CHAR;

FUNCTION WILDMATCH(FirstStr, SecondStr : Word2) : BOOLEAN;
FUNCTION KEYOFFSET(VAR R; VAR F) : INTEGER;
PROCEDURE KEY_TO_STRING(VAR Key; Len : BYTE; TYP : KEY_TYPE; UP : BOOLEAN);
PROCEDURE CLOSE_FILE(VAR F : File_Type);
PROCEDURE OPEN_FILE(VAR F : File_Type);
PROCEDURE DELETE_RECORD(VAR F : File_Type);
PROCEDURE READ_RECORD(VAR F : File_Type; K : INTEGER; VAR R);
PROCEDURE NEXT_RECORD(VAR F : File_Type; K : INTEGER; VAR R);
PROCEDURE PREVIOUS_RECORD(VAR F : File_Type; K : INTEGER; VAR R);
PROCEDURE SEARCH_PARTIAL(VAR F : File_Type; K : INTEGER; Templat : Word2;
                         VAR R);
PROCEDURE ADD_RECORD(VAR F : File_Type; VAR R);
PROCEDURE UPDATE_RECORD(VAR F : File_Type; VAR R);


IMPLEMENTATION

  {$I-}
  {=========================================================================}
  {These are the MULKEY Routines themselves}
  {=========================================================================}

  FUNCTION WILDMATCH {(FirstStr, SecondStr : Word2) : Boolean} ;
    {- search forward to find a given variable or scope}
    {- return true if something was found}
  CONST
    maxwrdchr2 = 255;
    any = '* ';
    one = '?';
    termchar = '$$';
    termchar1 = '$';

    PROCEDURE simptemp(VAR t : Word2);
      {- simplify the template by removing adjacent * 's}
    VAR
      I, J : INTEGER;
    BEGIN
      I := 1; J := 1;
      WHILE t[I] <> termchar1 DO
        BEGIN
          IF ((t[I] = any) AND (t[SUCC(I)] = any)) THEN
            FOR J := SUCC(I) TO PRED(maxwrdchr2) DO t[J] := t[SUCC(J)]
          ELSE
            I := SUCC(I);
        END;
    END;           {simptemp}

    FUNCTION Match(S, t : Word2) : BOOLEAN;
      {- return true if this is a match}
      {- s is the test string, t is the match template}
    LABEL 1;
    VAR
      tp, tpon, spsav, Sp : INTEGER;
      On : BOOLEAN;
    BEGIN
      Sp := 1; tp := 1;
      On := FALSE;
      Match := FALSE;
      WHILE ((S[Sp] <> termchar1) OR (t[tp] <> termchar1)) DO
        BEGIN
          WHILE t[tp] = one DO
            BEGIN {pass over '?' keeping t and s sync'ed}
              IF S[Sp] = termchar1 THEN GOTO 1; {ran out of string needing a ? match}
              Sp := SUCC(Sp);
              tp := SUCC(tp);
            END;
          IF t[tp] = any THEN
            BEGIN {'* ' was found}
              On := TRUE;
              tpon := SUCC(tp); {save the next template position beyond *}
              spsav := Sp; {save string position}
              tp := SUCC(tp); {move to next template check}
              IF t[tp] = termchar1 THEN
                BEGIN {last template character was '* '}
                  Match := TRUE; {any more string chars must match}
                  GOTO 1;
                END;
            END;
          IF t[tp] = S[Sp] THEN
            BEGIN {if match found proceed to next comparison}
              Sp := SUCC(Sp);
              tp := SUCC(tp);
            END
          ELSE
            BEGIN {otherwise....}
              IF (NOT On) THEN GOTO 1 {fatal mismatch - no backup from *}
              ELSE
                BEGIN {non- fatal mismatch}
                  spsav := SUCC(spsav); {account for mismatched char with the *}
                  IF S[spsav] = termchar1
                  THEN GOTO 1; {end of string without fitting template}
                  Sp := spsav;
                  tp := tpon; {try the template constraint just
                              following the * again}
                END;
            END;
        END; {of both strings reached}
      Match := TRUE;
1:
    END;              {match}

  BEGIN
    WILDMATCH := FALSE;
    FirstStr := FirstStr + '$';
    SecondStr := SecondStr + '$';
    simptemp(SecondStr);
    IF Match(FirstStr, SecondStr) THEN
      WILDMATCH := TRUE
    ELSE
      WILDMATCH := FALSE;
  END;

  FUNCTION KEYOFFSET {(VAR R; VAR F) : Integer} ;
  BEGIN
    {Use to compute the OFFSET parameter of a key}
    KEYOFFSET := (OFS(F) + $8000) - (OFS(R) + $8000);
  END;

  PROCEDURE KEY_TO_STRING {(VAR Key; LEN : Byte; TYP : KEY_TYPE; UP : Boolean)} ;
    {Converts a key of the designated type to a string in WORK_KEY for Turbo
    Index storage}
  VAR
    INTEGER_KEY : INTEGER ABSOLUTE Key;
    CHAR_KEY : ARRAY[1..MaxKeyLen] OF CHAR ABSOLUTE Key;
    STRING_KEY : STRING[MaxKeyLen] ABSOLUTE Key;
    REAL_KEY : REAL ABSOLUTE Key;
    I : INTEGER;
  BEGIN
    CASE TYP OF
      KEY_INTEGER :
        BEGIN
          I := INTEGER_KEY + $8000;
          WORK_KEY := CHR(Hi(I)) + CHR(Lo(I));
        END;
      KEY_CHAR :
        BEGIN
          IF Len > MaxKeyLen THEN Len := MaxKeyLen;
          WORK_KEY[0] := CHR(Len);
          IF Len > 0 THEN MOVE(Key, WORK_KEY[1], Len);
        END;
      KEY_STRING : WORK_KEY := STRING_KEY;
      KEY_REAL : STR(REAL_KEY:16, WORK_KEY);
    END;
    IF UP AND ((TYP = KEY_CHAR) OR (TYP = KEY_STRING)) THEN
      FOR I := 1 TO LENGTH(WORK_KEY) DO
        WORK_KEY[I] := UPCASE(WORK_KEY[I]);
  END;

  PROCEDURE CLOSE_FILE {(VAR F : File_Type)} ;
    {Close database and all index files}
  VAR
    I : INTEGER;
  BEGIN
    WITH F DO
      BEGIN
        CloseFile(DATA_FILE);
        FOR I := 1 TO NUMBER_OF_KEYS DO
          BEGIN
            WITH Key[I] DO CloseIndex(INDEX_FILE);
          END;
      END;
  END;

  PROCEDURE OPEN_FILE {(VAR F : File_Type)} ;
    {Opens a multi- key database and all index files, re- builds missing index
    file(s) and database freespace chain}
  VAR
    I, Dup : INTEGER;
    FLAG : INTEGER ABSOLUTE WORK_REC;
    KEY_FILE_OK : ARRAY[1..MaxKeys] OF BOOLEAN;
    ALL_KEYS_OK : BOOLEAN;
  BEGIN
    WITH F DO
      BEGIN
        IF (NUMBER_OF_KEYS < 1) OR (NUMBER_OF_KEYS > MaxKeys) THEN
          BEGIN
            WRITELN('In file ', Name, ', ', NUMBER_OF_KEYS,
                    ' keys specified, 1.. ', MaxKeys, ' keys allowed');
            HALT;
          END;
        ALL_KEYS_OK := TRUE;
        IOERROR := FALSE;
        OpenFile(DATA_FILE, Name + '.DAT', RecSize);
        IF NOT OK THEN
          BEGIN
            MakeFile(DATA_FILE, Name + '.DAT', RecSize);
            FOR I := 1 TO NUMBER_OF_KEYS DO
              BEGIN
                WITH Key[I] DO
                  BEGIN
                    IF UNIQUE THEN Dup := 0 ELSE Dup := 1;
                    MakeIndex(INDEX_FILE, Name + '.' + EXTENSION, KEYLENGTH, Dup);
                    ClearKey(INDEX_FILE);
                  END;
              END;
          END
        ELSE
          BEGIN
            FOR I := 1 TO NUMBER_OF_KEYS DO
              BEGIN
                WITH Key[I] DO
                  BEGIN
                    IF Offset < 2 THEN
                      BEGIN
                        WRITELN('Key Offset for key ', I, ' is ', Offset,
                                ', Minimum is 2 for file ', Name);
                        HALT;
                      END;
                    IF (KEYTYPE = KEY_CHAR)
                    AND ((KEYLENGTH < 1) OR (KEYLENGTH > MaxKeyLen)) THEN
                      BEGIN
                        WRITELN('KeyLength for key ', I, ' is ', KEYLENGTH,
                                ', it must be between 1 and ', MaxKeyLen, ' in file ',
                                Name);
                        HALT;
                      END;
                    IF UNIQUE THEN Dup := 0 ELSE Dup := 1;
                    OpenIndex(INDEX_FILE, Name + '.' + EXTENSION, KEYLENGTH, Dup);
                    IF NOT OK THEN
                      BEGIN
                        MakeIndex(INDEX_FILE, Name + '.' + EXTENSION, KEYLENGTH,
                                  Dup);
                        ALL_KEYS_OK := FALSE;
                        KEY_FILE_OK[I] := FALSE;
                      END
                    ELSE
                      KEY_FILE_OK[I] := TRUE;
                    ClearKey(INDEX_FILE);
                  END;
              END;
          END;
        IF NOT ALL_KEYS_OK THEN
          BEGIN
            GoToXY(1, 1);
            WRITELN('Please wait, rebuilding index file(s) in ', Name, ' for ',
                    FileLen(DATA_FILE), ' records');
            REC_REF := 1;
            WITH DATA_FILE DO
              BEGIN
                FirstFree := - 1;
                NumberFree := 0;
              END;
            WHILE REC_REF < FileLen(DATA_FILE) DO
              BEGIN
                GetRec(DATA_FILE, REC_REF, WORK_REC);
                IF FLAG = 0 THEN
                  BEGIN
                    FOR I := 1 TO NUMBER_OF_KEYS DO
                      IF NOT KEY_FILE_OK[I] THEN WITH Key[I] DO
                        BEGIN
                          KEY_TO_STRING(WORK_REC[Offset], KEYLENGTH, KEYTYPE,
                                        UPSHIFT);
                          AddKey(INDEX_FILE, REC_REF, WORK_KEY);
                          IF NOT OK THEN IOERROR := TRUE;
                        END;
                  END
                ELSE
                  BEGIN
                    WITH DATA_FILE DO
                      BEGIN
                        IF FLAG <> FirstFree THEN
                          BEGIN
                            FLAG := FirstFree;
                            PutRec(DATA_FILE, REC_REF, WORK_REC);
                            FirstFree := REC_REF;
                          END;
                        NumberFree := SUCC(NumberFree);
                      END;
                  END;
                REC_REF := SUCC(REC_REF);
              END;
          END;
        REC_REF := 0;
      END;
  END;

  PROCEDURE DELETE_RECORD {(VAR F : File_Type)} ;
    {Delete the last record retrieved from the database and all its keys.
    IOERROR indicates no valid last record retrieved.}
  VAR
    K : INTEGER;
  BEGIN
    WITH F DO IF REC_REF <> 0 THEN
      BEGIN
        GetRec(DATA_FILE, REC_REF, WORK_REC);
        DeleteRec(DATA_FILE, REC_REF);
        FOR K := 1 TO NUMBER_OF_KEYS DO WITH Key[K] DO
          BEGIN
            KEY_TO_STRING(WORK_REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
            DeleteKey(INDEX_FILE, REC_REF, WORK_KEY);
          END;
        IOERROR := FALSE;
        REC_REF := 0;
      END
      ELSE
        IOERROR := TRUE;
  END;

  PROCEDURE READ_RECORD {(VAR F : File_Type; K : Integer; VAR R)} ;
    {Read a record from the database with a key equal to or higher than that
    indicated by key field K in record R. IOERROR indicates search key was
    higher than any in the index.}
  VAR
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    REF : LONGINT;
  BEGIN
    WITH F DO
      BEGIN
        IF (K > NUMBER_OF_KEYS) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', NUMBER_OF_KEYS,
                    ' Defined in file ', Name);
            HALT;
          END;
        WITH Key[K] DO
          BEGIN
            Ref := 0;
            KEY_TO_STRING(REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
            SearchKey(INDEX_FILE, REF, WORK_KEY);
            IF OK THEN GetRec(DATA_FILE, REF, REC);
            IF OK THEN REC_REF := REF;
            IOERROR := NOT OK;
          END;
      END;
  END;

  PROCEDURE NEXT_RECORD {(VAR F : File_Type; K : Integer; VAR R)} ;
    {Read the next record by key K from the database. IOERROR indicates end of
    file by key K.}
  VAR
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    REF : LONGINT;
  BEGIN
    WITH F DO
      BEGIN
        IF (K > NUMBER_OF_KEYS) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', NUMBER_OF_KEYS,
                    ' Defined in file ', Name);
            HALT;
          END;
        WITH Key[K] DO
          BEGIN
            NextKey(INDEX_FILE, REF, WORK_KEY);
            IF OK THEN GetRec(DATA_FILE, REF, REC);
            IF OK THEN REC_REF := REF;
            IOERROR := NOT OK;
            IF NOT OK THEN
              BEGIN
                NextKey(INDEX_FILE, REF, WORK_KEY);
                IF OK THEN GetRec(DATA_FILE, REF, REC);
                IF OK THEN REC_REF := REF;
              END;
          END;
      END;
  END;

  PROCEDURE PREVIOUS_RECORD {(VAR F : File_Type; K : Integer; VAR R)} ;
    {Read the previous record by key K from the database. IOERROR indicates start
    of file by key K.}
  VAR
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    REF : LONGINT;
  BEGIN
    WITH F DO
      BEGIN
        IF (K > NUMBER_OF_KEYS) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', NUMBER_OF_KEYS,
                    ' Defined in file', Name);
            HALT;
          END;
        WITH Key[K] DO
          BEGIN
            PrevKey(INDEX_FILE, REF, WORK_KEY);
            IF OK THEN GetRec(DATA_FILE, REF, REC);
            IF OK THEN REC_REF := REF;
            IOERROR := NOT OK;
            IF NOT OK THEN
              BEGIN
                PrevKey(INDEX_FILE, REF, WORK_KEY);
                IF OK THEN GetRec(DATA_FILE, REF, REC);
                IF OK THEN REC_REF := REF;
              END;
          END;
      END;
  END;

  PROCEDURE SEARCH_PARTIAL {(VAR F : File_Type; K : Integer; Templat : Word2;
                           VAR R)} ;
    {-- This procedure is to allow a wildcard match of an index field.
    Acceptable wildcards are * and ?. Templat must be a string, no
    greater than 254 characters. Careful attention must be paid that
    the search starts from the Work_Key you specify. To start the search
    from the beginning set the Work_Key to blank, to pick up the
    search from the last point, return Work_Key to the value it had
    after this procedure}
  VAR
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    REF : LONGINT;
    Foundit : BOOLEAN;
  BEGIN
    WITH F DO
      BEGIN
        IF (K > NUMBER_OF_KEYS) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', NUMBER_OF_KEYS,
                    ' Defined in file ', Name);
            HALT;
          END;
        WITH Key[K] DO
          BEGIN
            REF := REC_REF;
            SearchKey(INDEX_FILE, REF, WORK_KEY);
            NextKey(INDEX_FILE, REF, WORK_KEY);
            IF NOT OK THEN
              BEGIN
                ClearKey(INDEX_FILE);
                NextKey(INDEX_FILE, REF, WORK_KEY);
              END;
            WHILE OK AND NOT WILDMATCH(WORK_KEY, Templat) DO
              BEGIN
                NextKey(INDEX_FILE, REF, WORK_KEY);
              END;    {while}
            REC_REF := REF;
            GetRec(DATA_FILE, REC_REF, REC);
            IOERROR := NOT OK;
          END;       {With K}
      END;           {With F}
  END;               {Search}

  PROCEDURE ADD_RECORD {(VAR F : File_Type; VAR R)} ;
    {
    Add record R to the database and update all index files. IOERROR usually
    indicates a duplicate key in a unique key index.
    }
  LABEL
    DemoExit;
  VAR
    Ch : CHAR;
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    FLAG : INTEGER ABSOLUTE R;
    REF : LONGINT;
    K : INTEGER;
  BEGIN
    WITH F DO
      BEGIN
        IOERROR := FALSE;
        FLAG := 0;
        {$IFDEF DEMO}
        IF UsedRecs(DATA_FILE) > 11 THEN
          BEGIN
            GoToXY(1, 1);
            WRITELN('Only 10 records allowed in demo version');
            Ch := ReadKey;
            GOTO DemoExit;
          END;
        {$ENDIF}
        AddRec(DATA_FILE, REF, REC);
        FlushFile(DATA_FILE);
        K := 1;
        WHILE (K <= NUMBER_OF_KEYS) AND NOT IOERROR DO
          BEGIN
            WITH Key[K] DO
              BEGIN
                KEY_TO_STRING(REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
                AddKey(INDEX_FILE, REF, WORK_KEY);
                FlushIndex(INDEX_FILE);
                IOERROR := NOT OK;
              END;
            K := SUCC(K);
          END;
        IF IOERROR THEN
          BEGIN
            K := PRED(PRED(K));
            WHILE K > 0 DO
              BEGIN
                WITH Key[K] DO
                  BEGIN
                    KEY_TO_STRING(REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
                    DeleteKey(INDEX_FILE, REF, WORK_KEY);
                  END;
                K := PRED(K);
              END;
            DeleteRec(DATA_FILE, REF);
          END
        ELSE
          REC_REF := REF;
DemoExit:
      END;
  END;

  PROCEDURE UPDATE_RECORD {(VAR F : File_Type; VAR R)} ;
    {
    Update the last retrieved record with data from record R and update any
    index files whose keys were changed. IOERROR usually indicates a duplicate
    key in a unique key index.
    }
  VAR
    REC : ARRAY[0..MaxDataRecSize] OF CHAR ABSOLUTE R;
    FLAG : INTEGER ABSOLUTE R;
    S : STRING[MaxKeyLen];
    K : INTEGER;
  BEGIN
    WITH F DO
      BEGIN
        IOERROR := FALSE;
        IF REC_REF <> 0 THEN
          BEGIN
            FLAG := 0;
            GetRec(DATA_FILE, REC_REF, WORK_REC);
            K := 1;
            WHILE (K <= NUMBER_OF_KEYS) AND NOT IOERROR DO
              BEGIN
                WITH Key[K] DO
                  BEGIN
                    KEY_TO_STRING(WORK_REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
                    S := WORK_KEY;
                    KEY_TO_STRING(REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
                    IF S <> WORK_KEY THEN
                      BEGIN
                        DeleteKey(INDEX_FILE, REC_REF, S);
                        AddKey(INDEX_FILE, REC_REF, WORK_KEY);
                        FlushIndex(INDEX_FILE);
                        IOERROR := NOT OK;
                        IF IOERROR THEN AddKey(INDEX_FILE, REC_REF, S);
                      END;
                    K := SUCC(K);
                  END;
              END;
            IF IOERROR THEN
              BEGIN
                K := PRED(PRED(K));
                WHILE K > 0 DO
                  BEGIN
                    WITH Key[K] DO
                      BEGIN
                        KEY_TO_STRING(WORK_REC[Offset], KEYLENGTH, KEYTYPE,
                                      UPSHIFT);
                        S := WORK_KEY;
                        KEY_TO_STRING(REC[Offset], KEYLENGTH, KEYTYPE, UPSHIFT);
                        IF S <> WORK_KEY THEN
                          BEGIN
                            DeleteKey(INDEX_FILE, REC_REF, WORK_KEY);
                            AddKey(INDEX_FILE, REC_REF, S);
                          END;
                      END;
                    K := PRED(K);
                  END;
              END
            ELSE
              BEGIN
                PutRec(DATA_FILE, REC_REF, REC);
                FlushFile(DATA_FILE);
              END;
          END
        ELSE
          IOERROR := TRUE;
      END;
  END;
  {End of MULTIKEY routines}
END.