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

Pascal/Delphi Source File | 1987-12-31 | 20.7 KB | 592 lines

Unit Mulkey4;

{This is the MULKEY shell routines written by Edwin Floyd, rewritten
 by James C Walker <Cap'n> 72255,1616. Please refer to the original
 for programming instructions}

Interface

Uses TPCrt, 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);
  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 Record
                                             Offset : Integer;
                                             KEYLENGTH : Word;
                                             EXTENSION : String[3];
                                             UNIQUE : Boolean;
                                             UPSHIFT : Boolean;
                                             KEYTYPE : KEY_TYPE;
                                             INDEX_FILE : IndexFile;
                                           End;
                PromptAttribute : Integer;
                GetAttribute : Integer;
                DisplayAttribute : Integer;
                HelpAttribute : Integer;
                NumOfFields : Integer;
                Field : Array[1..MaxFields] Of Record
                                                 XCoord : Integer;
                                                 YCoord : Integer;
                                                 FieldData : ^String;
                                                 FieldType : Field_Type;
                                                 FieldLength : Integer;
                                                 LegalChars : String[80];
                                                 ScreenPrompt : String[80];
                                                 HelpPrompt : String[80];
                                               End;
              End;
  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;
    GoToXY(1, 1); ClrEol;
  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
            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.
    }
  Var
    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;
        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;
      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.