[CHECK(ALL)] Module DB_DB;
{ Database management routines
  Copyright © 1989,1990 Bruce Tanner - Cerritos College }

%Include 'DBType.PAS'

Var
  { Chains }
  Recur_List,		{ Recurring entries are kept here }
  Current,		{ All handles for current date + recur entries }
  Last_C, Last_R: H_Ptr;
  Null_Date: D_Type;
  Dump: Text;

{ DB_Str }
Function Decode(PKey: PK_Type; Field: Integer): Integer; Extern;
Procedure Encode(Var PKey: PK_Type; Field: Integer; V: Integer); Extern;
Function Decode_Date(PKey: PK_Type): D_Type; Extern;
Procedure Encode_Date(Var PKey: PK_Type; V: D_Type); Extern;

{ DB_Date }
Function Parse_Date(PL: String; W_Date: D_Type; Var R_Date: D_Type): Boolean; Extern;
Function Same_Date(Date1, Date2: D_Type): Boolean; Extern;
Function LE_Time(Time1, Time2: T_Type): Boolean; Extern;

{ DB_FIO }
Procedure First_Date(Var Handle: H_Rec; Date: D_Type); Extern;
Procedure Next_Date(Var Handle: H_Rec); Extern;
Procedure Unlock_Cal_File; Extern;

[Global] Procedure DB_Dump; Forward;


{ ############################## }

[Global] Procedure DB_Init;
Begin
  Null_Date.Year := 0;			{ Make record type constants }
  Null_Date.Month := 0;
  Null_Date.Day := 0;

  Current := Nil;
  Last_C := Nil;			{ Have to init all the global pointers }
  Recur_List := Nil;
  Last_R := Nil;

End; { DB_Init }


{ ############################## }

Function Date_Match(S: M_String; T_Date: D_Type): Boolean;
Var
  R_Date, X_Date: D_Type;
  PS: String;
  Ind: Integer;
  Match_Flag, Good: Boolean;

Begin
  PS := S;
  Good := Parse_Date(PS, T_Date, R_Date);
  Match_Flag := (Same_Date(T_Date, R_Date) and Good);
  Ind := 2;
  X_Date := T_Date;
  If Not Match_Flag and (Length(S) >= 2) then
    Repeat
      { What we're really trying to find out is if an offset was applied in PS }
      { that pushed us over a month boundary.  If so, check that month also. }
      { Example: T_Date is the last day of the month; PS is "1 -1". }
      { We should get a match, but don't because we need to calc the 1st of next month. }
      If S[Ind] in ['-', '+'] then Begin
        If S[Ind] = '-' then X_Date.Month := T_Date.Month+1;
        If S[Ind] = '+' then X_Date.Month := T_Date.Month-1;
        If X_Date.Month > 12 then Begin X_Date.Month := 1; X_Date.Year := X_Date.Year+1 End;
        If X_Date.Month < 1 then Begin X_Date.Month := 12; X_Date.Year := X_Date.Year-1 End;
        Good := Parse_Date(PS, X_Date, R_Date);
        Match_Flag := Match_Flag or (Same_Date(T_Date, R_Date) and Good);
	Ind := String_Len
	End;
      Ind := Ind+1
    Until Ind > Length(S);
  Date_Match := Match_Flag
End;


{ ############################## }

[Global] Function First(LT: List_Type): H_Ptr;
Begin
  Case LT of
    C_List: First := Current;
    R_List: First := Recur_List;
    Otherwise First := Nil
  End
End;


{ ############################## }
{ Return the next handle for the list }
{ LT is not used now, but will be if lists use different structures }

[Global] Function Next(LT: List_Type; Ptr: H_Ptr): H_Ptr;
Begin
  If Ptr = Nil then
    Next := Nil
  else
    Next := Ptr^.Next_Ptr
End;


{ ############################## }
{  Purge a list of handles }

[Global] Procedure Purge(List: List_Type);
Var
  Ptr, Next_Ptr: H_Ptr;

Begin
  Case List of
    C_List: Ptr := Current;
    R_List: Ptr := Recur_List;
  End;
  While Ptr <> Nil do Begin
    Next_Ptr := Ptr^.Next_Ptr;
    Dispose(Ptr);
    Ptr := Next_Ptr
    End;
  Case List of
    C_List: Begin
      Current := Nil;
      Last_C := Nil
      End;
    R_List: Begin
      Recur_List := Nil;
      Last_R := Nil
      End
  End
End; { Purge }


{ ############################## }
{ Create a new handle and insert in starttime order }

[Global] Procedure Store(List: List_Type; Handle: H_Rec);
Var
  New_Ptr, Prev_Ptr, P: H_Ptr;
  Continue, ID_Equ: Boolean;
  
Sanity: Integer;

Begin
  New(New_Ptr);
  New_Ptr^ := Handle;
  Prev_Ptr := Nil;
  Case List of
    C_List:
      If Handle.Check = 'R' then
        P := Current		{ Recurring entries go through whole list }
      else P := Last_C;		{ Others just go at end }
    R_List: P := Last_R;
  End; { Case }
  Continue := True;
  ID_Equ := False;	{ ID_Equ is on if trying to put recur where it's deleted }
  Sanity := 0;
  While (P <> Nil) and Continue do Begin
    Case List of
      C_List: Begin
        ID_Equ := (P^.ID = Handle.ID)
                  and (Handle.Check in [' ', 'F', 'R'])
                  and (P^.Check in [' ', 'F', 'S', 'T']);
        { 3.5 - Special case of Move'ing a Recur (now .Check = ' ') to a
          date where it was deleted.  At least show it there. }
        If ID_Equ and (Handle.Check in [' ', 'F']) and (P^.Check = 'T') then
          ID_Equ := False;
        Continue := LE_Time(P^.Start_Time, Handle.Start_Time)
                      and Not ID_Equ
        End;
      R_List: Begin { Go until Nil }
        Sanity := Sanity + 1;
        If Sanity > 1000 then Begin
          DB_Dump;
          Halt
          End;
        End;
    End; { Case }
    If Continue then Begin
      Prev_Ptr := P;
      P := P^.Next_Ptr
      End
    End; { While }
  If ID_Equ then
    Dispose(New_Ptr)	{ S or T is taking the place of an R - quit }
  else Begin
    Case List of
      C_List: Last_C := New_Ptr;
      R_List: Last_R := New_Ptr
    End;
    If P = Nil then Begin		{ at end of chain }
      New_Ptr^.Next_Ptr := Nil;
      New_Ptr^.Prev_Ptr := Prev_Ptr;
      End
    else Begin
      New_Ptr^.Next_Ptr := P;
      New_Ptr^.Prev_Ptr := P^.Prev_Ptr;
      P^.Prev_Ptr := New_Ptr
      End;
    If New_Ptr^.Prev_Ptr = Nil then		{ This is the start of the chain }
      Case List of
        C_List: Current := New_Ptr;
        R_List: Recur_List := New_Ptr
      End { Case }
    else
      New_Ptr^.Prev_Ptr^.Next_Ptr := New_Ptr;
  End
End; { Store }


{ ############################## }

[Global] Procedure Store_Cal(T_Date: D_Type);
Var
  Ptr: H_Ptr;
  Handle: H_Rec;

Begin
  Purge(C_List);
  First_Date(Handle, T_Date);		{ Read all T_Date's entries }
  While Same_Date(Handle.Date, T_Date) do Begin
    Store(C_List, Handle);		{ Store them in current list }
    Next_Date(Handle)
    End;
  Unlock_Cal_File;			{ Free last locked record }
  Ptr := Recur_List;			{ Merge in recurring entries }
  While (Ptr <> Nil) do Begin		{ Search through all the recur entries }
    If Date_Match(Ptr^.Match, T_Date) then	{ If recur belongs in T_Date }
      Store(C_List, Ptr^);			{ Store it in Current list }
    Ptr := Ptr^.Next_Ptr
    End
End; { Store_Cal }


{ ############################## }
{ Dump the contents of a handle }

[Global] Procedure Dmp_Rec(LT: List_Type; Ptr: H_Ptr);
Var
  S: String;
  X: Record Case Boolean of
       True: (P: H_Ptr);
       False: (I: Integer)
     End;

Begin
  X.P := Ptr;
  Write(Dump, X.I:6, ' ', Ptr^.Check, ' ', Ptr^.Match:15, ' ');
  Write(Dump, Ptr^.Date.Year:4, Ptr^.Date.Month:2, Ptr^.Date.Day:2, ' ');
  Write(Dump, Ptr^.Start_Time:4, ' ', Ptr^.End_Time:4, ' ');
  X.P := Ptr^.Prev_Ptr;
  Write(Dump, X.I:6, ' ');
  X.P := Ptr^.Next_Ptr;
  Write(Dump, X.I:6, ' ', Ptr^.UK:8, ' ', Ptr^.ID:8, ' ');
  Writeln(Dump, Ptr^.Message)
End; { Dmp_Rec }


{ ############################## }
{ Dump the contents of a list }

[Global] Procedure Dmp_List(LT: List_Type);
Var
  Ptr: H_Ptr;
  Sanity: Integer;

Begin
  Writeln(Dump);
  Ptr := First(LT);
  Sanity := 0;
  While (Ptr <> Nil) and (Sanity < 100) do Begin
    Sanity := Sanity + 1;
    Dmp_Rec(LT, Ptr);
    Ptr := Next(LT, Ptr)
    End;
  Writeln(Dump)
End; { Dmp_List }


{ ############################## }
{ Dump the contents of the data base }

{[Global]} Procedure DB_Dump;
Begin
  Open(Dump, 'DATEBOOK.DUMP');
  Rewrite(Dump);
  Writeln(Dump, 'Addr Check  Match            Date/Time      Prev    Next    Key       ID  ');
  Writeln(Dump);
  Writeln(Dump, 'Current List');
  Dmp_List(C_List);
  Writeln(Dump, 'Recurr List');
  Dmp_List(R_List);
  Close(Dump)
End; { DB_Dump }


{ ############################## }
{ Remove a handle from a list }

[Global] Procedure Remove(List: List_Type; HP: H_Ptr);
Begin
  If HP^.Prev_Ptr <> Nil then
    HP^.Prev_Ptr^.Next_Ptr := HP^.Next_Ptr	{ Remove Handle from list }
  else	{ We just lost the start of a list }
    Case List of
      C_List: Current := HP^.Next_Ptr;
      R_List: Recur_List := HP^.Next_Ptr
    End;
  If HP^.Next_Ptr <> Nil then
    HP^.Next_Ptr^.Prev_Ptr := HP^.Prev_Ptr;
  Dispose(HP)
End; { Remove }


{ ############################## }
{ Find the Entry'th element of List and return pointer to it }

[Global] Function Find_Entry(Entry: Integer; List: List_Type): H_Ptr;
Var
  Count: Integer;
  Ptr: H_Ptr;

Begin
  Case List of
    C_List: Ptr := Current;
    R_List: Ptr := Recur_List;
  End;
  Count := 1;
  While (Ptr <> Nil) and (Count < Entry) do Begin
    Count := Count+1;
    Ptr := Ptr^.Next_Ptr
    End;
  Find_Entry := Ptr
End; { Find_Entry }


{ ############################## }
{ Take a Cal_Rec and a Key and put them on Handle_List }

[Global] Procedure Make_Handle(Var Handle: H_Rec; Rec: Cal_Rec; XKey: ID_Type);
Var
  Ind, Length: Integer;

Begin
  Handle.Check := Rec.Check[1];
  Handle.Match := Substr(Rec.Check, 2, 20);
  Handle.Match.Length := 20;
  Length := 0;
  For Ind := 1 to Match_Len do
    If Handle.Match[Ind] > ' ' then
      Length := Ind;
  Handle.Match.Length := Length;
  If Handle.Match = Null_Match then
    Handle.Match := '';
  Handle.Date := Decode_Date(Rec.Date_Time);
  Handle.Stuno := Rec.Stuno;
  Handle.ID := Rec.ID;
  Handle.Start_Time := Decode(Rec.Date_Time, Start_Time);
  Handle.End_Time := Decode(Rec.Date_Time, End_Time);
  Handle.UK := XKey;
  Handle.Message := Rec.Message;
  Handle.Next_Ptr := Nil;
  Handle.Prev_Ptr := Nil;
End; { Make_Handle }


{ ############################## }
{ Wipe out a handle. (Was Clear_Handle, but global Clear. was multi-defined) }

[Global] Procedure Clean_Handle(Var Handle: H_Rec);
Begin
  Handle.Check := ' ';
  Handle.Match := '';
  Handle.UK := '';
  Handle.ID := '';
  Handle.Stuno := '';
  Handle.Message := '';
  Handle.Next_Ptr := Nil;
  Handle.Prev_Ptr := Nil;
  Handle.Start_Time := 0;
  Handle.End_Time := 0;
  Handle.Date := Null_Date;
End; { Clean_Handle }

End.