[INHERIT ('SYS$LIBRARY:STARLET')]
Module DB_FIO(Output);
{ File I/O routines
  Copyright © 1989,1991 Bruce Tanner - Cerritos College }

%Include 'DBType.PAS'

Const
%Include 'SYS$Library:PASStatus.PAS/Nolist'

Type
  Cal_Type = File of Cal_Rec;

Var
  Cal_File, CF2: Cal_Type;
  Cal_Name: String;
  Holiday_File: File of Holiday_Rec;
  Sequence_Number: Integer;	{ Used by H_List_Current }
  Default_Calendar_Name, Alternate_Calendar_Name: String;
  File_Current, Multiple_Alt, Have_Holidays: Boolean;
  FAB_Status: Integer;		{ Set in User_Open }
  Read_Only_Status: Boolean;

{ DB_TIO }
Procedure Clear_Screen; Extern;
Procedure Rev_On; Extern;
Procedure Rev_Off; Extern;
Procedure Write1(S: Varying [L] of Char); Extern;
Procedure Writeln1(S: Varying [L] of Char); Extern;

{ DB_VMS }
Procedure Sleep(Length: Real); Extern;
Procedure Wakeup; Extern;
Procedure Get_Directory(Var Dir_Name: String); Extern;
Procedure Get_Log_Name(Log_Name: String; Ind: Integer; Var Name: String); Extern;

{ DB_DB }
Procedure Make_Handle(Var Handle: H_Rec; Rec: Cal_Rec; H_Key: ID_Type); Extern;
Procedure Store(List: List_Type; Handle: H_Rec); Extern;
Procedure Clean_Handle(Var Handle: H_Rec); Extern;
Procedure Purge(List: List_Type); Extern;

{ DB_Str }
Procedure Clear(Var S: String); Extern;
Function Get_Num(S: String; Var Ind: Integer; Var Got_Num: Boolean):Integer; Extern;
Function Read_PS(Var S: String): Boolean; Extern;
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;

{ Replacement procedures for Resetk, Findk, Get that check for the record being locked }

Function Check_File(File_Status: Integer): Boolean;
Begin
  If File_Status = 74 then
    Sleep(0.5)
  else If File_Status > 0 then Begin
    Writeln('Datebook found a file status of ', File_Status);
    Halt
    End;
  Check_File := (File_Status <= 0)
End;


Procedure ResetkX(Key: Integer);
Begin
  Repeat
    Resetk(Cal_File, Key, Error := Continue)
  Until Check_File(Status(Cal_File))
End;

Procedure FindkX(Key: Integer; Value: Varying [L] of Char);
Begin
  Repeat
    Findk(Cal_File, Key, Value, Error := Continue);
    If EOF(Cal_File) then Begin
      Cal_File^.Date_Time := '3000000000000000';
      Cal_File^.Check := '*'
      End
  Until Check_File(Status(Cal_File))
End;

Procedure Findk_NxtX(Key: Integer; Value: Varying [L] of Char);
Begin
  Repeat
    Findk(Cal_File, Key, Value, NXTEQL, Error := Continue);
    If EOF(Cal_File) then Begin
      Cal_File^.Date_Time := '3000000000000000';
      Cal_File^.Check := '*'
      End
  Until Check_File(Status(Cal_File))
End;

Procedure GetX;
Begin
  Repeat
    Get(Cal_File, Error := Continue);
    If EOF(Cal_File) then Begin
      Cal_File^.Date_Time := '3000000000000000';
      Cal_File^.Check := '*'
      End;
    If UFB(Cal_File) then Begin
      Cal_File^.Date_Time := '3000000000000000';
      Cal_File^.Check := '*'
      End
  Until Check_File(Status(Cal_File))
End;

[Global]Procedure Get_Name(Var Name: String);
Var
  Ind: Integer;
  State: (Scan, Copy, Stop);

Begin
  State := Scan;
  Ind := 1;
  Name := '';
  While (State in [Scan, Copy]) and (Ind <= Cal_Name.Length) do Begin
    Case Cal_Name[Ind] of
      '[', '<': State := Copy;
      ']', '>': State := Stop;
      Otherwise
        If State = Copy then Name := Name + Cal_Name[Ind]
      End;
    Ind := Ind + 1
    End
End;


{ ############################## }
[Global]Function Get_Holiday(T_Date: D_Type; Var S: String): Boolean;
Var
  Ind, Length: Integer;
  HS: String;

Begin
  If Have_Holidays then Begin
    Findk(Holiday_File, 0, DEC(T_Date.Year, 4)
                         + DEC(T_Date.Month, 2) + DEC(T_Date.Day, 2));
    If Not UFB(Holiday_File) then Begin
      HS := Holiday_File^.Description;
      Length := 0;
      For Ind := 1 to 20 do
        If HS[Ind] > ' ' then Length := Ind;
      HS.Length := Length;
      S := S + ' - ' + HS;
      End;
    Get_Holiday := Not UFB(Holiday_File)		{ #P }
    End
  else
    Get_Holiday := False
End; { Get_Holiday }


{ ############################## }
[Global]Procedure Select_Alternate(Var Which_Cal: Whose_Cal; Var Dir: String; Entry: Integer);
Var
  Line, Name: String;
  Line_Num, Num, Ind: Integer;
  PS_Ind: Integer;
  Got_Num, EOF: Boolean;

Begin
  Get_Log_Name(Dir, 2, Name);	{ Is there more than one name? }
  If Name.Length = 0 then Begin	{ No }
    Num := 1;			{ Get dir number 1 }
    Got_Num := True
    End
  else Begin
    Multiple_Alt := True;
    If Entry >= 0 then Begin
      Num := Entry;		{ Get the right entry }
      Got_Num := True;
      End
    else Begin
      Clear_Screen;
      Line_Num := 1;
      Write(' 0  ');
      Get_Directory(Name);	{ Item 0 is our directory }
      Writeln1(Name);
      Got_Num := False;
      Ind := 1;
      Get_Log_Name(Dir, Ind, Name);

      While (Name.Length > 0) and Not Got_Num do Begin	{ Loop for all dirs }
        Write(Ind:2, '  ');
        Writeln1(Name);
        Line_Num := Line_Num+1;
        Ind := Ind+1;
        Get_Log_Name(Dir, Ind, Name);
        If Line_Num > 20 then Begin			{ Stop every 20 lines }
          Writeln1('');
          Writeln1('Enter item number of alternate calendar directory');
          Write1('or press return to see some more: ');
          EOF := Read_PS(Line);
          Line_Num := 1;
          PS_Ind := 1;
          Num := Get_Num(Line, PS_Ind, Got_Num);
          Clear_Screen
          End { If }
        End { While }
      End { Else don't have Entry }
    End; { Mult dirs }

  If Not Got_Num then Begin			{ If a number wasn't given }
    Writeln1('');
    Write1('Enter item number of alternate calendar directory: [0] ');
    EOF := Read_PS(Line);
    PS_Ind := 1;
    Num := Get_Num(Line, PS_Ind, Got_Num);
    If Not Got_Num then
      Num := 0				{ Default 0 }
    End;
  If Num = 0 then Begin
    Get_Directory(Name);		{ 0 means use own dir }
    Which_Cal := Own_Cal
    End
  else
    Get_Log_Name(Dir, Num, Name);	{ Get right alt dir }
  Dir := Name				{ Return dir name in Dir }
End; { Select_Alternate }

{ ############################## #P 5.0 - Make a unique Primary Key }
Procedure Make_Key(Var PKey: ID_Type; Checkit: Boolean);
Var
  Curr_Time: Packed Array [1..11] of Char;

Begin
  If Checkit then
    Repeat
      Sleep(0.1);
      Time(Curr_Time);
      PKey[1] := Curr_Time[1]; PKey[2] := Curr_Time[2];
      PKey[3] := Curr_Time[4]; PKey[4] := Curr_Time[5];
      PKey[5] := Curr_Time[7]; PKey[6] := Curr_Time[8];
      PKey[7] := Curr_Time[10]; PKey[8] := Curr_Time[11];	{ Form HHMMSSCC }
      FindkX(0, PKey);
    Until UFB(Cal_File)			{ We want to find an undefined key }
  else Begin
    Sleep(0.05);
    Time(Curr_Time);
    PKey[1] := Curr_Time[1]; PKey[2] := Curr_Time[2];
    PKey[3] := Curr_Time[4]; PKey[4] := Curr_Time[5];
    PKey[5] := Curr_Time[7]; PKey[6] := Curr_Time[8];
    PKey[7] := Curr_Time[10]; PKey[8] := Curr_Time[11];	{ Form HHMMSSCC }
    End
End;

{ ############################## }
[Global]Function Multiple_Alternates: Boolean;
Begin
  Multiple_Alternates := Multiple_Alt
End;

{ ############################## }
Function User_Open(Var FAB: FAB$TYPE; Var RAB: RAB$TYPE; Var F: Cal_Type): Integer;
Begin
  FAB.FAB$V_DFW := False;   		{ Turn off deferred write }
  Read_Only_Status := False;
  FAB_Status := $OPEN(FAB);
  If FAB_Status = RMS$_PRV then Begin	{ If file is read-only }
    $CLOSE(FAB);
    FAB.FAB$B_FAC := FAB$M_GET;		{ Set Get file access only }
    Read_Only_Status := True;			{ Remember that this file is read-only }
    FAB_Status := $OPEN(FAB);
    End;
  If Odd(FAB_Status) then
    FAB_Status := $CONNECT(RAB);
  User_Open := FAB_Status;
End;

{ ############################## }
[Global]Function Open_Calendar(Var Which_Cal: Whose_Cal; Entry: Integer): Boolean;
Var
  Ind: Integer;
  Dir_Name: String;
  File_Status: Integer;
  Result: Boolean;

Begin
  Case Which_Cal of
    Default_Cal: Begin
      Dir_Name := Default_Calendar_Name;
      Select_Alternate(Which_Cal, Dir_Name, Entry)
      End;
    Alternate_Cal: Begin
      Dir_Name := Alternate_Calendar_Name;
      Select_Alternate(Which_Cal, Dir_Name, Entry)
      End;
    Own_Cal:
      Get_Directory(Dir_Name)		{ 4.9 - Get directory name }
    End; { Case }

  Result := False;			{ Assume the file didn't open }
  If Dir_Name.Length > 0 then Begin
    Cal_Name := Dir_Name + Calendar_Name;
    Open(Cal_File, Cal_Name,
         Access_Method := Keyed, Organization := Indexed, History := Old,
	 Sharing := ReadWrite, Error := Continue, User_Action := User_Open);
    File_Status := Status(Cal_File);
    If (File_Status = PAS$K_FILNOTFOU) and (Which_Cal = Own_Cal) then Begin
      Open(Cal_File, Cal_Name,
           Access_Method := Keyed, Organization := Indexed, History := New,
	   Sharing := ReadWrite);
      Rewrite(Cal_File);			{ Make an empty file for Update }
      Cal_File^.Check := 'X';			{ 4.5 - Always put in first record }
      Cal_File^.UK := '00000000';
      Cal_File^.Date_Time := '0000000000000000';
      Cal_File^.ID := File_Version;
      Cal_File^.Stuno := '';
      Cal_File^.Message := '';
      Put(Cal_File);
      Close(Cal_File);
      Open(Cal_File, Cal_Name,
           Access_Method := Keyed, Organization := Indexed, History := Old,
	   Sharing := ReadWrite, User_Action := User_Open);
      Write(Chr(7), Chr(7));
      Rev_On;
      Writeln1('[Creating new calendar file]');
      Rev_Off;
      Sleep(3.0)
      End;
    File_Status := Status(Cal_File);
    If (File_Status = PAS$K_SUCCESS) then Begin
      ResetkX(0);	{ Just check to see if the file opens OK }
      Result := Not EOF(Cal_File);	{ Not EOF = opened OK }
      If Not Result then		{ Shouldn't ever be empty }
        Close(Cal_File)			{ Just close it }
      End
    End;
  Open_Calendar := Result	{ True if calendar status = 0 and non-empty }
End; { Open_Calendar }


{ ############################## }
[Global]Procedure FIO_Init;
Var
  Name: String;

Begin
  { Allow use of old TOPS-20 style logical names }
  Get_Log_Name(Alt_Dir_Logical1, 1, Name);
  If Name.Length > 0 then			{ If ALTERNATE-CALENDAR exists, }
    Alternate_Calendar_Name := Alt_Dir_Logical1	{ Use it }
  else
    Alternate_Calendar_Name := Alt_Dir_Logical2; { Use DATEBOOK_ALTERNATE_CALENDAR }

  Get_Log_Name(Default_Dir_Logical1, 1, Name);
  If Name.Length > 0 then			{ If DEFAULT-CALENDAR exists, }
    Default_Calendar_Name := Default_Dir_Logical1 { Use it }
  else
    Default_Calendar_Name := Default_Dir_Logical2; { Use DATEBOOK_DEFAULT_CALENDAR }

  Get_Log_Name(Alternate_Calendar_Name, 2, Name);
  Multiple_Alt := (Name.Length > 0);		{ Is there more than one alternate? }
  Open(Holiday_File, Holiday_Name,
         Access_Method := Keyed, Organization := Indexed, History := ReadOnly,
	 Sharing := ReadOnly, Error := Continue);
  Have_Holidays := (Status(Holiday_File) = PAS$K_SUCCESS);
  If Have_Holidays then
    Reset(Holiday_File);
End;


{ ############################## }
{ Make sure that File is current; return True if it is }
[Global]Function List_Current: Boolean;
Begin
  FindkX(2, 'X');
  List_Current := (Cal_File^.Check[1] = 'X')
                and (Decode(Cal_File^.Date_Time, Start_Time) = Sequence_Number)
		and File_Current;
  Unlock(Cal_File)
End;


{ ############################## }
{ Indicate that Cal_File has been updated }

[Global]Procedure Upd_File;
Var
  F_Seq: Integer;

Begin
  FindkX(2, 'X');
  If Cal_File^.Check[1] = 'X' then Begin
    F_Seq := Decode(Cal_File^.Date_Time, Start_Time);
    File_Current := (Sequence_Number = F_Seq);	{ Account for buried update }
    F_Seq := F_Seq+1;
    If F_Seq > 2000 then		{ 4.5 - Don't overflow field }
      F_Seq := 0;
    Sequence_Number := F_Seq;		{  WE already know about the update }
    Encode(Cal_File^.Date_Time, Start_Time, F_Seq);
    Update(Cal_File);			{ 4.5 - Update record 0 }
    End;
  Unlock(Cal_File)
End;


{ ############################## }
{ 4.0 - Be consistant for externs }

[Global]Procedure Close_File;
Begin
  Close(Cal_File)
End;


{ ############################## }
{ Open the Cal_File, set up Lists -- #P this is all system dependent }

[Global]Procedure Load_Handles;
Var
  Our_Key: ID_Type;
  Handle: H_Rec;

Begin
  FindkX(2, 'X');		{ Read the X record }
  If Cal_File^.ID <> File_Version then Begin
    Write(Chr(7));
    Writeln('[ File format is ', Cal_File^.ID,
            ' it should be ', File_Version, ' ]');
    Writeln1('');
    Sleep(5.0)
    End;
  If Cal_File^.Check[1] = 'X' then Begin
    Sequence_Number := Decode(Cal_File^.Date_Time, Start_Time);	{ 4.5 - Store sequence number }
    File_Current := True;
    End;

  Findk_NxtX(2, 'R');		{ Read all type R records }
  While Cal_File^.Check[1] = 'R' do Begin
    Our_Key := Cal_File^.UK;
    If Our_Key = Null_ID then Begin		{ If it's null, make one }
      Writeln1('[Null Key found in Load_Handles]');
      Make_Key(Cal_File^.UK, False);
      Our_Key := Cal_File^.UK
      End;

    If Cal_File^.ID = Null_ID then		{ Give it to the ID field }
      Cal_File^.ID := Our_Key;			{ This shouldn't happen? }
    
    Make_Handle(Handle, Cal_File^, Our_Key);	{ Make a handle }
    Store(R_List, Handle);			{ Store record in R_List }
    GetX			{ 3.4 - move Get to the end of While loop }
    End; { While }
  Unlock(Cal_File)		{ 5.0 - Make sure no record is locked }
End; { Load_Handles }


{ ############################## }
{ 5.4 - Make new copy of Cal_File sans deleted records }
[Global]Procedure Crunch_Cal_File;
Var
  Which_Cal: Whose_Cal;
  File_Status, Records: Integer;

Begin
  Open(CF2, Cal_Name, Access_Method := Keyed, Organization := Indexed,
       History := New, Error := Continue);
  If (Status(CF2) <= 0) then Begin	{ Open will fail if version_limit = 1 }
    Write1('Copying');			{ Say we're reloading }
    Records := 0;
    Rewrite(CF2);			{ Make an empty file for Update }
    ResetkX(0);				{ Read Cal_File via primary key }
    While Not EOF(Cal_File) do Begin
      CF2^ := Cal_File^;
      Put(CF2);
      Records := Records + 1;
      If Records mod 100 = 0 then Write1('.');
      GetX
      End;
    Close_File;
    Close(CF2);
    Which_Cal := Own_Cal;
    If Not Open_Calendar(Which_Cal, -1) then	{ Open the new calendar }
      Writeln1('Calendar disappeared!');
    End; { If good CF2 }
  Purge(C_List);				{ Clear the decks for the new file }
  Purge(R_List);
  Load_Handles
End; { Crunch_Cal_File }


{ ############################## }
{ 3.3 - move common code to update the check field here }

[Global]Procedure Upd_Check(Var Handle: H_Rec; Flag: Char);
Begin
  Upd_File;
  FindkX(0, Handle.UK);	{ #P get record }
  If UFB(Cal_File) then Begin
    Write1('Cannot find calendar entry ');
    Writeln1(Handle.UK)
    End
  else Begin
    Handle.Check := Flag;
    Cal_File^.Check := Flag;
    Update(Cal_File)		{ #P Update record }
    End;
  Unlock(Cal_File)		{ #P 5.0 - Make sure no record is locked }
End;


{ ############################## }
[Global]Procedure Write_Handle(Var Handle: H_Rec);
Var
  H_Key: Integer;

Begin
  Upd_File;
  Make_Key(Handle.UK, True);  { So Put doesn't fail }
  If Handle.ID = Null_ID then { Consistancy check }
    Handle.ID := Handle.UK;
  Cal_file^.UK := Handle.UK;
  Cal_File^.ID := Handle.ID;
  Cal_File^.Stuno := Handle.Stuno;
  Cal_File^.Check := Handle.Check + Handle.Match;
  Cal_File^.Message := Handle.Message;
  Encode_Date(Cal_File^.Date_Time, Handle.Date);
  Encode(Cal_File^.Date_Time, Start_Time, Handle.Start_Time);
  Encode(Cal_File^.Date_Time, End_Time, Handle.End_Time);
  Put(Cal_File);              { 3.4 - Write the record }
  Unlock(Cal_File)            { #P 5.0 - Make sure no record is locked }
End; { Write_Handle }


{ ############################## }
[Global]Procedure Upd_Msg(Handle: H_Rec);
Begin
  Upd_File;
  FindkX(0, Handle.UK);
  If UFB(Cal_File) then Begin
    Write1('Cannot find calendar entry ');
    Writeln1(Handle.UK)
    End
  else Begin
    Cal_File^.Check := Handle.Check + Handle.Match;
    Encode_Date(Cal_File^.Date_Time, Handle.Date);
    Encode(Cal_File^.Date_Time, Start_Time, Handle.Start_Time);
    Encode(Cal_File^.Date_Time, End_Time, Handle.End_Time);
    Cal_File^.Message := Handle.Message;
    Update(Cal_File)          { #P Update record }
    End;
  Unlock(Cal_File)            { #P 5.0 - Make sure no record is locked }
End; { Upd_Msg }


{ ############################## }
[Global]Procedure Upd_Dat(Handle: H_Rec; Date: D_Type);
Begin
  Upd_File;
  FindkX(0, Handle.UK);       { #P get record }
  If UFB(Cal_File) then Begin
    Write1('Cannot find calendar entry ');
    Writeln1(Handle.UK)
    End
  else Begin
    Encode_Date(Cal_File^.Date_Time, Date);   { New date }
    Update(Cal_File)          { #P Update record }
    End;
  Unlock(Cal_File)            { #P 5.0 - Make sure no record is locked }
End; { Upd_Dat }


[Global]Procedure Delete_Key(Handle: H_Rec);	{ 5.0 }
Begin
  Upd_File;
  FindkX(0, Handle.UK);
  If UFB(Cal_File) then Begin
    Write1('Cannot find calendar entry ');
    Writeln1(Handle.UK)
    End
  else
    Delete(Cal_File);
  Unlock(Cal_File)
End; { Delete_Key }


[Global]Procedure Delete_Current;	{ 5.6 }
Begin
  Delete(Cal_File);
End; { Delete_Current }


[Global]Procedure First_Date(Var Handle: H_Rec; T_Date: D_Type);
Var
  PK: PK_Type;

Begin
  Encode_Date(PK, T_Date);
  Encode(PK, Start_Time, 0);
  Encode(PK, End_Time, 0);
  Findk_NxtX(1, PK);
  Make_Handle(Handle, Cal_File^, Cal_File^.UK);
End; { First_Date }


[Global]Procedure Next_Date(Var Handle: H_Rec);
Begin
  GetX;
  Make_Handle(Handle, Cal_File^, Cal_File^.UK);
End; { Next_Date }


[Global]Procedure Unlock_Cal_File;
Begin
  Unlock(Cal_File)
End; { Unlock_Cal_File }


[Global]Procedure Get_User(User: Integer);
Var
  Handle: H_Rec;

Begin
  Purge(C_List);
  Findk_NxtX(2, DEC(User, 1));
  Repeat
    Make_Handle(Handle, Cal_File^, Cal_File^.UK);
    If Handle.Check = DEC(User, 1) then Begin
      Store(C_List, Handle);
      GetX
      End
  Until Handle.Check <> DEC(User, 1);
  Unlock(Cal_File)
End; { Get_User }

[Global]Function Read_Only: Boolean;
Begin
  Read_Only := Read_Only_Status
End;

End.