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

Pascal/Delphi Source File | 1988-06-05 | 17.0 KB | 508 lines

UNIT Mkey4;

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 *****}


  ColSeqType = RECORD
                 ColSeqSign : BYTE; { The signature byte }
                 ColSeqName : ARRAY[1..10] OF CHAR;
                 ColSeq : ARRAY[1..10] OF CHAR;
               END; {colseqtype}
  KeyDescrip = RECORD
                 Offset : INTEGER;
                 KEYLENGTH : WORD;
                 Flags : WORD;
                 KEYTYPE : KEY_TYPE;
                 EXTENSION : STRING[3];
                 UNIQUE : BOOLEAN;
                 UPSHIFT : BOOLEAN;
                 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;

  FileSpecType = RECORD
                   CASE BYTE OF
                     0 : (RecSize : WORD; { Record length in bytes }
                          PageSize : WORD; { Page size to use       }
                          Number_of_keys : WORD; { # of keys NOT segments }
                          NumRecs : LONGINT; { # of records in file }
                          FileFlags : WORD; { Bit flags for file     }
                          ReservedWord : WORD; { Fill with $0000        }
                          Allocation : WORD; { # pages to preallocate }
                          {Key : ARRAY[0..MaxKeys] OF KeySpecType;}
                          AltColSeq : ColSeqType); { Alternate col seq }
                     1 : (MinSize : ARRAY[1..128] OF BYTE);
                 END; {FileSpecType}
  File_Type = RECORD
                Name : STRING[60];
                PositionBlock : ARRAY[1..128] OF BYTE;
                IOERROR : BOOLEAN;
                REC_REF : LONGINT;
                DATA_FILE : DATAFILE;
                LastKeyUsed : WORD;
                Key : ARRAY[0..MaxKeys] OF KeyDescrip;
                PromptAttribute : INTEGER;
                GetAttribute : INTEGER;
                DisplayAttribute : INTEGER;
                HelpAttribute : INTEGER;
                NumOfFields : INTEGER;
                Field : ARRAY[1..MaxFields] OF DBField;
                FileSpec : FileSpecType;
              END;
VAR
  WORK_KEY : TaKeyStr;
  WORK_REC : ARRAY[0..MaxDataRecSize] OF CHAR;

FUNCTION KEYOFFSET(VAR R; VAR F) : INTEGER;
PROCEDURE CLOSE_FILE(VAR F : File_Type; VAR R);
PROCEDURE OPEN_FILE(VAR F : File_Type);
PROCEDURE DELETE_RECORD(VAR F : File_Type; VAR R);
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 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 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; VAR R);
    {Close database and all index files}
  VAR
    I : INTEGER;
  BEGIN
    WITH F DO
      BEGIN
        CloseFile(DATA_FILE);
        FOR I := 1 TO FileSpec.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 (FileSpec.Number_of_keys < 1) OR (FileSpec.Number_of_keys > MaxKeys) THEN
          BEGIN
            WRITELN('In file ', Name, ', ', FileSpec.Number_of_keys,
                    ' keys specified, 1.. ', MaxKeys, ' keys allowed');
            HALT;
          END;
        ALL_KEYS_OK := TRUE;
        IOERROR := FALSE;
        OpenFile(DATA_FILE, Name + '.DAT', FileSpec.RecSize);
        IF NOT OK THEN
          BEGIN
            MakeFile(DATA_FILE, Name + '.DAT', FileSpec.RecSize);
            FOR I := 1 TO FileSpec.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 FileSpec.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 FileSpec.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; VAR R);
    {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 FileSpec.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 > FileSpec.Number_of_keys) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', FileSpec.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 > FileSpec.Number_of_keys) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', FileSpec.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 > FileSpec.Number_of_keys) OR (K < 1) THEN
          BEGIN
            WRITELN('Key ', K, ' Referenced, Keys 1.. ', FileSpec.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 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 <= FileSpec.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 <= FileSpec.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.