[INHERIT ('SYS$LIBRARY:STARLET', 'SYS$LIBRARY:PASCAL$LIB_ROUTINES')]
Module DB_VMS(Output);
{ OS specific routines (was DB_T10, DB_T20)
  Copyright © 1989,1991 Bruce Tanner - Cerritos College }

%Include 'DBType.PAS'

Const
  Wakeup_Const = 120;		{ Seconds to wait between checking for update }
  Re_Display_Const = 5;		{ Send '*' every Re_Display'th Wakeup from Wait_for_Wakeup }
				{ i.e. Do a SC_Wakeup every Wakeup * Re_Display seconds }
  Disable_Re_Display = 60;	{ Stop auto update for awhile after receiving a broadcast } 

Type
  $UBYTE = [BYTE] 0..255;
  $UWORD = [WORD] 0..65535;
  $UQUAD = [QUAD, UNSAFE] RECORD L0, L1: UNSIGNED; END;
  Itemlist3 = Packed Record
		Case Integer of
		1: (Length: $UWORD;
		    Code: $UWORD;
		    Address: UNSIGNED;
		    Ret: UNSIGNED);
		2: (Term: UNSIGNED)
		End;

Var
  Wakeup_Count: Integer;
  TT_Chan, MBX_Chan: [VOLATILE] $UWORD;
  Term_Initial, Term_Change: PACKED ARRAY [1..3] OF [VOLATILE, UNSAFE] INTEGER;
  AST_Output: [VOLATILE] Text;
  Screen_Length, Re_Display: [VOLATILE] Integer;
  TT_Valid: Boolean;

[ASYNCHRONOUS, EXTERNAL(SYS$QIOW)] FUNCTION $QIOX (
	%IMMED EFN : UNSIGNED := %IMMED 0;
	%IMMED CHAN : INTEGER;
	%IMMED FUNC : UNSIGNED;
	VAR IOSB : [VOLATILE] $UQUAD := %IMMED 0;
	%IMMED [UNBOUND, ASYNCHRONOUS] PROCEDURE ASTADR := %IMMED 0;
	%IMMED ASTPRM : UNSIGNED := %IMMED 0;
	%REF P1 : [UNSAFE] ARRAY [$l7..$u7:INTEGER] OF $UBYTE := %IMMED 0;
	%IMMED P2 : INTEGER := %IMMED 0;
	%IMMED P3 : INTEGER := %IMMED 0;
	%IMMED P4 : INTEGER := %IMMED 0;
	%REF P5 : [UNSAFE] ARRAY [$l11..$u11:INTEGER] OF $UBYTE := %IMMED 0;
	%IMMED P6 : INTEGER := %IMMED 0) : INTEGER; EXTERNAL;
 
[ASYNCHRONOUS, EXTERNAL(SYS$QIOW)] FUNCTION $QIOA (
	%IMMED EFN : UNSIGNED := %IMMED 0;
	%IMMED CHAN : INTEGER;
	%IMMED FUNC : UNSIGNED;
	VAR IOSB : [VOLATILE] $UQUAD := %IMMED 0;
        %IMMED TEMP : INTEGER := %IMMED 0;
        %IMMED TEMP2 : INTEGER := %IMMED 0;
        %IMMED [UNBOUND,ASYNCHRONOUS] PROCEDURE ASTADR := %IMMED 0;
	%IMMED P2 : INTEGER := %IMMED 0;
	%IMMED P3 : INTEGER := %IMMED 0;
	%IMMED P4 : INTEGER := %IMMED 0;
	%REF P5 : [UNSAFE] ARRAY [$l11..$u11:INTEGER] OF $UBYTE := %IMMED 0;
	%IMMED P6 : INTEGER := %IMMED 0) : INTEGER; EXTERNAL;

[ASYNCHRONOUS, EXTERNAL(MAIL$USER_BEGIN)] FUNCTION USER_BEGIN (
	VAR CONTXT : [VOLATILE] INTEGER := %IMMED 0;
	%REF ILIST : [UNSAFE] ARRAY [$l1..$u1:INTEGER] OF $UBYTE;
	%REF OLIST : [UNSAFE] ARRAY [$l2..$u2:INTEGER] OF $UBYTE
	) : INTEGER; EXTERNAL;
 
[ASYNCHRONOUS, EXTERNAL(MAIL$USER_END)] FUNCTION USER_END (
	VAR CONTXT : [VOLATILE] INTEGER := %IMMED 0;
	%REF ILIST : [UNSAFE] ARRAY [$l1..$u1:INTEGER] OF $UBYTE;
	%REF OLIST : [UNSAFE] ARRAY [$l2..$u2:INTEGER] OF $UBYTE
	) : INTEGER; EXTERNAL;

 
{ DB_FIO }
Function List_Current: Boolean; Extern;
Procedure Load_Handles; Extern;

{ DB_DB }
Procedure Purge(P_List: List_Type); Extern;

{ DB_DATE }
Function Parse_Date(PL: String; W_Date: D_Type; Var R_Date: D_Type): Boolean; Extern;

{ DB_TIO }
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_STR }
Function Read_PS(Var S: String): Boolean; Extern;

{ ############################## }
{ 5.5 - Check all those QIOs and system service calls }
[Global, Asynchronous] Procedure Assert(Result: Integer);
Begin
  If Not Odd(Result) then
    LIB$SIGNAL(Result)
End;


{ ############################## }
{ 3.3 - Sleep for n seconds }

[Global] Procedure Sleep(Length: Real);
Begin
  LIB$WAIT(Length);
End;


{ ############################## }
{ If there is no logical name, Name will return empty }
[Global] Procedure Get_Log_Name(Log_Name: String; Ind: Integer;
				Var Name: [VOLATILE] String);
Var
  Item_List: Array [1..3] of Itemlist3;

Begin
  Ind := Ind-1;		{ $TRNLNM is origin 0, Get_Log_Name is origin 1 }

  Item_List[1].Code := LNM$_INDEX;
  Item_List[1].Length := 4;
  Item_List[1].Address := IAddress(Ind);
  Item_List[1].Ret := 0;
  Item_List[2].Code := LNM$_STRING;
  Item_List[2].Length := String_Len;
  Item_List[2].Address := IAddress(Name.Body);
  Item_List[2].Ret := IAddress(Name.Length);
  Item_List[3].Term := 0;

  Name := '';
  $TRNLNM(ATTR := LNM$M_CASE_BLIND, TABNAM := 'LNM$DCL_LOGICAL',
		 LOGNAM := Log_Name, ITMLST := Item_List);
End; { Get_Log_Name }


{ ############################## }
{ Called asynchronously on receipt of a broadcast }
[ASYNCHRONOUS, UNBOUND] Procedure AST_Routine;
Type
  Mes_type = Record
    Mestype: $UWORD;
    Unit_number: $UWORD;
    Cnt_strng: CHAR;
    Control_name: Packed Array [1..3] of Char;
    Filler: Packed Array [1..12] of Char;
    Brd_length: $UWORD;
    Messreturn: Packed Array [1..255] of Char;
  End;

Var
  Length, Row, Ind, Count: Integer;
  MBXData: mes_type;
  Msg: Varying [255] of Char;

Begin
  Assert($QIOW(Chan := MBX_Chan, Func := IO$_READVBLK, P1 := MBXData,
	 P2 := 255));
  Assert($QIOA(Chan := MBX_Chan, Func := IO$_SETMODE+IO$M_WRTATTN,
	 ASTadr := AST_Routine));
  Msg := MBXData.Messreturn;
  Msg.Length := MBXData.Brd_length;
  If (Msg.Length < 1) or (Msg.Length > 255) then
    Writeln(AST_Output, 'AST got message of length ', Msg.Length:1,
      Chr(13), Chr(10))
  else Begin
    If Msg[1] = Chr(13) then Msg[1] := Chr(0);
    If Msg[2] = Chr(10) then Msg[2] := Chr(0);		{ Clear leading CRLF }
    While Msg[Msg.Length] in [Chr(13), Chr(10)] do
      Msg.Length := Msg.Length - 1;			{ Trim trailing CRLF }
    Row := Screen_Length;
    Count := 0;
    For Ind := 1 to Msg.Length do Begin
      Count := Count + 1;
      If (Msg[Ind] = Chr(10)) or (Count > 80) then Begin
        Count := 0;
        Row := Row - 1				{ Count lines in message }
        End
      End;
    Writeln(AST_Output, Chr(27), '[', Row:1, ';1H', Chr(27), '[J'); { Clear out Msg area }
    Writeln(AST_Output, Msg);				{ Write message }
    Row := Screen_Length - 1;
    Writeln(AST_Output, Chr(27), '[', Row:1, ';1H');	{ Reset cursor }
    Re_Display := Disable_Re_Display;			{ Leave the broadcast on the screen }
    End
End;


{ ############################## }
[Global] Procedure OS_Init;
Var
  TT_Name: String;

Begin
  Open(Output, Carriage_Control := None);	{ Regular output channel, turn off buffering }
  Screen_Length := 24; { Default if not TT_Valid }
  Get_Log_Name('TT', 1, TT_Name);
  TT_Valid := (TT_Name <> '_NLA0:');
  If TT_Valid then Begin
    Open(AST_Output, 'TT', Carriage_Control := None);	{ AST output channel }
    Rewrite(AST_Output);
    Assert(LIB$ASN_WTH_MBX('TT', 0, 0, TT_Chan, MBX_Chan)); { Set up Term and MBX channels }
    Assert($QIOW(Chan := TT_Chan, Func := IO$_SENSEMODE, P1 := Term_Initial,
	 P2 := 12));
    Screen_Length := Term_Initial[2] DIV %x1000000;
    Term_Change := Term_Initial;
    Term_Change[2] := UOR(UOR(TT$M_NOBRDCST,TT$M_MBXDSABL),Term_Change[2]);
    Term_Change[3] := UOR(Term_Change[3],TT2$M_BRDCSTMBX);
    Assert($QIOW(Chan := TT_Chan, Func := IO$_SETMODE, P1 := Term_Change,
	 P2 := 12));
    Assert($QIOA(Chan := MBX_Chan, Func := IO$_SETMODE+IO$M_WRTATTN,
	 ASTadr := AST_Routine))
    End
End;


{ ############################## }
[GLOBAL] Procedure OS_Terminate;
Begin
  If TT_Valid then Assert($QIOW(Chan := TT_Chan, Func := IO$_SETMODE, 
	 P1 := Term_Initial, P2 := 12))
End;


{ ############################## }
{ Check to see if there is any mail }
[Global] Function Mail_Call: Boolean;
Var
  Item_List, Null_List: Packed Array [1..2] of Itemlist3;
  Context, Mail_Count: Integer;

Begin
  Null_List[1].Length := 0;
  Null_List[1].Code := 0;
  Null_List[1].Address := 0;
  Null_List[1].Ret := 0;
  Null_List[2].Term := 0;
  Context := 0;
  Mail_Count := 0;
  Item_List[1].Length := 2;
  Item_List[1].Code := MAIL$_USER_NEW_MESSAGES;
  Item_List[1].Address := IAddress(mail_count);
  Item_List[1].Ret := 0;
  Item_List[2].Term := 0;

  Assert(User_Begin(Context, Null_List, Item_List));
  Assert(User_End(Context, Null_List, Null_List));
  Mail_Call := (Mail_Count > 0)
End;


{ ############################## }
{ 3.3 - Wait for timer or line of input; Return input or '*' if update }

[Global] Procedure Wait_For_Update(Var Response: String);
Var
  TT_IOSB: [VOLATILE] $UQUAD;
  Ind: Integer;
  EOF: Boolean;

Begin
  { Hibernate until a line of input is ready, or we get an update }
  Wakeup_Count := 0;
  Re_Display := Re_Display_Const;
  If TT_Valid then Begin
    Response := '';
    Repeat
      Assert($QIOX(Chan := TT_Chan, Func := IO$_READVBLK+IO$M_TIMED,
		 IOSB := TT_IOSB, P1 := Response.Body, P2 := String_Len, 
		 P3 := Wakeup_Const));
      If TT_IOSB.L0 = SS$_TIMEOUT then Begin
        Wakeup_Count := Wakeup_Count+1;
        If Not List_Current or Mail_Call or (Wakeup_Count = Re_Display) then
          Response := '*'	{ Send '*' as command }
        End
    Until (Response = '*') or ODD(TT_IOSB.L0);

    Response.Length := String_Len;
    If Response[1] = Chr(26) then { Response was a ^Z }
      Response := 'QUIT'
    else Begin
      Ind := 0;   { Find Response.Length }
      While Ind < String_Len do Begin
        Ind := Ind + 1;
        If Response[Ind] < Chr(32) then Begin
          Response.Length := Ind - 1;
          Ind := String_Len  { break; }
          End
        End
      End
    End { If TT_Valid }
  else
    EOF := Read_PS(Response);

  If Not List_Current then Begin	{ Someone else updated the calendar }
    { 4.12 - Reload might alter the index for the following commands }
    If Response <> '' then
      If Response[1] in ['D','d','U','u','C','c','F','f','M','m','R','r'] then Begin
        Rev_On;
        Write(Chr(7), ' Please review your command -- ');
        Rev_Off;
        Sleep(2.0);
        Response := '*';		{ Fake a '*' the easy way }
        End;
    Write(Chr(7));			{ 4.15 - Note that calendar changed }
    Rev_On; Write1('Wait'); Rev_Off;	{ Say we're reloading }
    Purge(C_List);
    Purge(R_List);
    Load_Handles
    End
End;


{ ############################## }
[Global] Procedure Get_Today(Var Todays_Date: D_Type);
Var
  S_Date: Packed Array[1..11] of Char;
  D_Date: D_Type;

Begin
  Date(S_Date);
  D_Date.Year := 0;
  D_Date.Month := 0;
  D_Date.Day := 0;
  IF Not Parse_Date(S_Date, D_Date, Todays_Date) { Calculate Todays date }
    then Writeln('Error in todays Date!');
End;


{ ############################## }
{ Return minutes since midnight }
[Global] Function Get_Now: Integer;
Var
  STime: Packed Array [1..11] of Char;
  Now: Integer;

Begin
  Time(STime);
  Readv(Substr(STime, 1, 2) + Substr(STime, 4, 2), Now);
  Get_Now := Now
End; { Get_Now }


{ ############################## }
{ 4.9 - This returns 'POBOX:<logged in directory>' for DB_FIO }
[Global] Procedure Get_Directory(VAR Dir: String);
Begin
  Get_Log_Name('SYS$LOGIN', 1, Dir)
End; { Get_Directory }


{ ############################## }
[Global]Procedure Get_Screen(Var Length: Integer);
Begin
  Length := Screen_Length
End; { Get_Screen }

End.