diff --git a/mdl/m_menubox.pas b/mdl/m_menubox.pas new file mode 100644 index 0000000..64926e6 --- /dev/null +++ b/mdl/m_menubox.pas @@ -0,0 +1,492 @@ +{$I M_OPS.PAS} + +Unit m_MenuBox; + +Interface + +Uses + m_Types, + m_Input, + m_Output; + +Type + TMenuBox = Class + Console : TOutput; + Image : TConsoleImageRec; + HideImage : ^TConsoleImageRec; + FrameType : Byte; + BoxAttr : Byte; + Box3D : Boolean; + BoxAttr2 : Byte; + BoxAttr3 : Byte; + BoxAttr4 : Byte; + Shadow : Boolean; + ShadowAttr : Byte; + HeadAttr : Byte; + HeadType : Byte; + Header : String; + WasOpened : Boolean; + + Constructor Create (Var Screen: TOutput); + Destructor Destroy; Override; + Procedure Open (X1, Y1, X2, Y2: Byte); + Procedure Close; + Procedure Hide; + Procedure Show; + End; + + TMenuListStatusProc = Procedure (Num: Word; Str: String); + + TMenuListBoxRec = Record + Name : String; + Tagged : Byte; { 0 = false, 1 = true, 2 = never } + End; + + TMenuList = Class + Screen : TOutput; + List : Array[1..65535] of ^TMenuListBoxRec; + Box : TMenuBox; + InKey : TInput; + HiAttr : Byte; + LoAttr : Byte; + PosBar : Boolean; + Format : Byte; + LoChars : String; + HiChars : String; + ExitCode : Char; + Picked : Integer; + TopPage : Integer; + NoWindow : Boolean; + ListMax : Integer; + AllowTag : Boolean; + TagChar : Char; + TagKey : Char; + TagPos : Byte; + TagAttr : Byte; + Marked : Word; + StatusProc : TMenuListStatusProc; + Width : Integer; + Length : Integer; + X1 : Byte; + Y1 : Byte; + NoInput : Boolean; + + Constructor Create (Var S: TOutput); + Destructor Destroy; Override; + Procedure Open (BX1, BY1, BX2, BY2: Byte); + Procedure Close; + Procedure Add (Str: String; B: Byte); + Procedure Get (Num: Word; Var Str: String; Var B: Boolean); + Procedure SetStatusProc (P: TMenuListStatusProc); + Procedure Clear; + Procedure Delete (RecPos : Word); +{ Procedure Focus (Num: Word);} + Procedure Update; + End; + +Implementation + +Uses + m_Strings; + +Constructor TMenuBox.Create (Var Screen: TOutput); +Begin + Inherited Create; + + Console := Screen; + Shadow := True; + ShadowAttr := 0; + Header := ''; + FrameType := 6; + Box3D := True; + BoxAttr := 15 + 7 * 16; + BoxAttr2 := 8 + 7 * 16; + BoxAttr3 := 15 + 7 * 16; + BoxAttr4 := 8 + 7 * 16; + HeadAttr := 15 + 1 * 16; + HeadType := 0; + HideImage := NIL; + WasOpened := False; + + FillChar(Image, SizeOf(TConsoleImageRec), 0); + + Console.BufFlush; +End; + +Destructor TMenuBox.Destroy; +Begin + Inherited Destroy; +End; + +Procedure TMenuBox.Open (X1, Y1, X2, Y2: Byte); +Const + BF : Array[1..8] of String[8] = + ('ÚÄ¿³³ÀÄÙ', + 'ÉÍ»ººÈͼ', + 'ÖÄ·ººÓĽ', + 'Õ͸³³Ô;', + 'ÛßÛÛÛÛÜÛ', + 'ÛßÜÛÛßÜÛ', + ' ', + '.-.||`-'''); +Var + A : Integer; + B : Integer; + Ch : Char; +Begin + If Not WasOpened Then + If Shadow Then + Console.GetScreenImage(X1, Y1, X2 + 2{3}, Y2 + 1, Image) + Else + Console.GetScreenImage(X1, Y1, X2, Y2, Image); + + WasOpened := True; + + B := X2 - X1 - 1; + + If Not Box3D Then Begin + BoxAttr2 := BoxAttr; + BoxAttr3 := BoxAttr; + BoxAttr4 := BoxAttr; + End; + + Console.WriteXY (X1, Y1, BoxAttr, BF[FrameType][1] + strRep(BF[FrameType][2], B)); + Console.WriteXY (X2, Y1, BoxAttr4, BF[FrameType][3]); + + For A := Y1 + 1 To Y2 - 1 Do Begin + Console.WriteXY (X1, A, BoxAttr, BF[FrameType][4] + strRep(' ', B)); + Console.WriteXY (X2, A, BoxAttr2, BF[FrameType][5]); + End; + + Console.WriteXY (X1, Y2, BoxAttr3, BF[FrameType][6]); + Console.WriteXY (X1+1, Y2, BoxAttr2, strRep(BF[FrameType][7], B) + BF[FrameType][8]); + + If Header <> '' Then + Case HeadType of + 0 : Console.WriteXY (X1 + 1 + (B - Length(Header)) DIV 2, Y1, HeadAttr, Header); + 1 : Console.WriteXY (X1 + 1, Y1, HeadAttr, Header); + 2 : Console.WriteXY (X2 - Length(Header), Y1, HeadAttr, Header); + End; + + If Shadow Then Begin + For A := Y1 + 1 to Y2 + 1 Do + For B := X2 to X2 + 1 Do Begin + Ch := Console.ReadCharXY(B, A); + Console.WriteXY (B + 1, A, ShadowAttr, Ch); + End; + + A := Y2 + 1; + For B := (X1 + 2) To (X2 + 2) Do Begin + Ch := Console.ReadCharXY(B, A); + Console.WriteXY (B, A, ShadowAttr, Ch); + End; + End; +End; + +Procedure TMenuBox.Close; +Begin + If WasOpened Then Console.PutScreenImage(Image); +End; + +Procedure TMenuBox.Hide; +Begin + If Assigned(HideImage) Then FreeMem(HideImage, SizeOf(TConsoleImageRec)); + + GetMem (HideImage, SizeOf(TConsoleImageRec)); + + Console.GetScreenImage (Image.X1, Image.Y1, Image.X2, Image.Y2, HideImage^); + Console.PutScreenImage (Image); +End; + +Procedure TMenuBox.Show; +Begin + If Assigned (HideImage) Then Begin + Console.PutScreenImage(HideImage^); + FreeMem (HideImage, SizeOf(TConsoleImageRec)); + HideImage := NIL; + End; +End; + +Constructor TMenuList.Create (Var S: TOutput); +Begin + Inherited Create; + + Screen := S; + Box := TMenuBox.Create(S); + InKey := TInput.Create; + ListMax := 0; + HiAttr := 15 + 1 * 16; + LoAttr := 1 + 7 * 16; + PosBar := True; + Format := 0; + LoChars := #13#27; + HiChars := ''; + NoWindow := False; + AllowTag := False; + TagChar := '*'; + TagKey := #32; + TagPos := 0; + TagAttr := 15 + 7 * 16; + Marked := 0; + Picked := 1; + NoInput := False; + StatusProc := NIL; + + Screen.BufFlush; +End; + +Procedure TMenuList.Clear; +Var + A : Word; +Begin + For A := 1 to ListMax Do Dispose(List[A]); + ListMax := 0; + Marked := 0; +End; + +(* +Procedure TMenuList.Focus (Num: Word); +Var + NewPicked : Word; + NewTopPage : Word; + Count : Word; +Begin + If Num > ListMax Then Exit; + + Picked := 1; + ListMax := + + For Count := 1 to ListMax Do + + If Picked < ListMax Then Inc (Picked); + If Picked > TopPage + Length - 1 Then Inc (TopPage); +End; +*) + +Procedure TMenuList.Delete (RecPos : Word); +Var + Count : Word; +Begin + If List[RecPos] <> NIL Then Begin + Dispose (List[RecPos]); + + For Count := RecPos To ListMax - 1 Do + List[Count] := List[Count + 1]; + + Dec (ListMax); + End; +End; + +Destructor TMenuList.Destroy; +Begin + Box.Free; + InKey.Free; + + Clear; + + Inherited Destroy; +End; + +Procedure TMenuList.Update; +Var + A : LongInt; + S : String; + B : Integer; + C : Integer; +Begin + For A := 0 to Length - 1 Do Begin + C := TopPage + A; + If C <= ListMax Then Begin + S := ' ' + List[C]^.Name + ' '; + Case Format of + 0 : S := strPadR (S, Width, ' '); + 1 : S := strPadL (S, Width, ' '); + 2 : S := strPadC (S, Width, ' '); + End; + End Else + S := strRep(' ', Width); + + If C = Picked Then B := HiAttr Else B := LoAttr; + + Screen.WriteXY (X1 + 1, Y1 + 1 + A, B, S); + If PosBar Then + Screen.WriteXY (X1 + Width + 1, Y1 + 1 + A, Box.BoxAttr2, '°'); + + If AllowTag Then + If (C <= ListMax) and (List[C]^.Tagged = 1) Then + Screen.WriteXY (TagPos, Y1 + 1 + A, TagAttr, TagChar) + Else + Screen.WriteXY (TagPos, Y1 + 1 + A, TagAttr, ' '); + End; + + If PosBar Then + If (ListMax > 0) and (Length > 0) Then Begin + A := (Picked * Length) DIV ListMax; + If Picked >= ListMax Then A := Pred(Length); + If (A < 0) or (Picked = 1) Then A := 0; + Screen.WriteXY (X1 + Width + 1, Y1 + 1 + A, Box.BoxAttr2, '²'); + End; +End; + +Procedure TMenuList.Open (BX1, BY1, BX2, BY2 : Byte); +Var + Ch : Char; + A : Word; + sPos : Word; + ePos : Word; + First : Boolean; +Begin + If Not NoWindow Then + Box.Open (BX1, BY1, BX2, BY2); + + X1 := BX1; + Y1 := BY1; + + If (Picked < TopPage) or (Picked < 1) or (Picked > ListMax) or (TopPage < 1) or (TopPage > ListMax) Then Begin + Picked := 1; + TopPage := 1; + End; + + Width := BX2 - X1 - 1; + Length := BY2 - Y1 - 1; + TagPos := X1 + 1; + + If NoInput Then Exit; + + Repeat + Update; + + If Assigned(StatusProc) Then + If ListMax > 0 Then + StatusProc(Picked, List[Picked]^.Name) + Else + StatusProc(Picked, ''); + + Ch := InKey.ReadKey; + Case Ch of + #00 : Begin + Ch := InKey.ReadKey; + Case Ch of + #71 : Begin { home } + Picked := 1; + TopPage := 1; + End; + #72 : Begin { up arrow } + If Picked > 1 Then Dec (Picked); + If Picked < TopPage Then Dec (TopPage); + End; + #73 : Begin { page up } + If Picked - Length > 1 Then Dec (Picked, Length) Else Picked := 1; + If TopPage - Length < 1 Then TopPage := 1 Else Dec(TopPage, Length); + End; + #79 : Begin { end } + If ListMax > Length Then TopPage := ListMax - Length + 1; + Picked := ListMax; + End; + #80 : Begin { down arrow } + If Picked < ListMax Then Inc (Picked); + If Picked > TopPage + Length - 1 Then Inc (TopPage); + End; + #81 : If ListMax > 0 Then Begin { page down } + If ListMax > Length Then Begin + If Picked + Length > ListMax Then + Picked := ListMax + Else + Inc (Picked, Length); + Inc (TopPage, Length); + If TopPage + Length > ListMax Then TopPage := ListMax - Length + 1; + End Else Begin + Picked := ListMax; + End; + End; + Else + If Pos(Ch, HiChars) > 0 Then Begin + ExitCode := Ch; + Exit; + End; + End; + End; + Else + If AllowTag and (Ch = TagKey) and (List[Picked]^.Tagged <> 2) Then Begin + If (List[Picked]^.Tagged = 1) Then Begin + Dec (List[Picked]^.Tagged); + Dec (Marked); + End Else Begin + List[Picked]^.Tagged := 1; + Inc (Marked); + End; + If Picked < ListMax Then Inc (Picked); + If Picked > TopPage + Length - 1 Then Inc (TopPage); + End Else + If Pos(Ch, LoChars) > 0 Then Begin + ExitCode := Ch; + Exit; + End Else Begin + Ch := UpCase(Ch); + First := True; + sPos := Picked + 1; + ePos := ListMax; + + If sPos > ListMax Then sPos := 1; + + A := sPos; + + While (A <= ePos) Do Begin + If UpCase(List[A]^.Name[1]) = Ch Then Begin + While A <> Picked Do Begin + If Picked < A Then Begin + If Picked < ListMax Then Inc (Picked); + If Picked > TopPage + Length - 1 Then Inc (TopPage); + End Else + If Picked > A Then Begin + If Picked > 1 Then Dec (Picked); + If Picked < TopPage Then Dec (TopPage); + End; + End; + Break; + End; + If (A = ListMax) and First Then Begin + A := 0; + sPos := 1; + ePos := Picked - 1; + First := False; + End; + + Inc (A); + End; + End; + End; + Until False; +End; + +Procedure TMenuList.Close; +Begin + If Not NoWindow Then Box.Close; +End; + +Procedure TMenuList.Add (Str : String; B : Byte); +Begin + Inc (ListMax); + New (List[ListMax]); + List[ListMax]^.Name := Str; + List[ListMax]^.Tagged := B; + + If B = 1 Then Inc(Marked); +End; + +Procedure TMenuList.Get (Num : Word; Var Str : String; Var B : Boolean); +Begin + Str := ''; + B := False; + If Num <= ListMax Then Begin + Str := List[Num]^.Name; + B := List[Num]^.Tagged = 1; + End; +End; + +Procedure TMenuList.SetStatusProc (P : TMenuListStatusProc); +Begin + StatusProc := P; +End; + +End. diff --git a/mdl/m_menuform.pas b/mdl/m_menuform.pas new file mode 100644 index 0000000..abb70b7 --- /dev/null +++ b/mdl/m_menuform.pas @@ -0,0 +1,693 @@ +{$I M_OPS.PAS} + +Unit m_MenuForm; + +Interface + +Uses + m_Types, + m_MenuInput, + m_Output; + +Const + FormMaxItems = 50; + +Const + YesNoStr : Array[False..True] of String[03] = ('No', 'Yes'); + +Type + FormItemType = ( + ItemNone, + ItemString, + ItemBoolean, + ItemByte, + ItemWord, + ItemLong, + ItemToggle, + ItemPath, + ItemChar, + ItemAttr, + ItemFlags, + ItemDate, + ItemPass, + ItemPipe, + ItemCaps, + ItemBits + ); + + FormItemPTR = ^FormItemRec; + FormItemRec = Record + HotKey : Char; + Desc : String[60]; + Help : String[120]; + DescX : Byte; + DescY : Byte; + DescSize : Byte; + FieldX : Byte; + FieldY : Byte; + FieldSize : Byte; + ItemType : FormItemType; + MaxSize : Byte; + MinNum : LongInt; + MaxNum : LongInt; + S : ^String; + O : ^Boolean; + B : ^Byte; + W : ^Word; + L : ^LongInt; + C : ^Char; + F : ^TMenuFormFlagsRec; + Toggle : String[68]; + End; + + TMenuFormHelpProc = Procedure; // tested + TMenuFormDrawProc = Procedure (Hi: Boolean); // not functional + TMenuFormDataProc = Procedure; // not functional + + TMenuForm = Class + Private + Function GetColorAttr (C: Byte) : Byte; + Function DrawAccessFlags (Var Flags: TMenuFormFlagsRec) : String; + Procedure EditAccessFlags (Var Flags: TMenuFormFlagsRec); + Procedure AddBasic (HK: Char; D: String; X, Y, FX, FY, DS, FS, MS: Byte; I: FormItemType; P: Pointer; H: String); + Procedure BarON; + Procedure BarOFF (RecPos: Word); + Procedure FieldWrite (RecPos : Word); + Procedure EditOption; + Public + Screen : TOutput; + Input : TMenuInput; + HelpProc : TMenuFormHelpProc; + DrawProc : TMenuFormDrawProc; + DataProc : TMenuFormDataProc; + ItemData : Array[1..FormMaxItems] of FormItemPTR; + Items : Word; + ItemPos : Word; + Changed : Boolean; + ExitOnFirst : Boolean; + ExitOnLast : Boolean; + WasHiExit : Boolean; + WasFirstExit: Boolean; + WasLastExit : Boolean; + LoExitChars : String[30]; + HiExitChars : String[30]; + HelpX : Byte; + HelpY : Byte; + HelpSize : Byte; + HelpColor : Byte; + cLo : Byte; + cHi : Byte; + cData : Byte; + cLoKey : Byte; + cHiKey : Byte; + cField1 : Byte; + cField2 : Byte; + + Constructor Create (Var Con: TOutput); + Destructor Destroy; Override; + + Procedure Clear; + Procedure AddNone (HK: Char; D: String; X, Y, DS: Byte; H: String); + Procedure AddStr (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); + Procedure AddPipe (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); + Procedure AddPath (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); + Procedure AddPass (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); + Procedure AddBol (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; P: Pointer; H: String); + Procedure AddByte (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: Byte; P: Pointer; H: String); + Procedure AddWord (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: Word; P: Pointer; H: String); + Procedure AddLong (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: LongInt; P: Pointer; H: String); + Procedure AddTog (HK: Char; D: String; X, Y, FX, FY, DS, FS, MN, MX: Byte; TG: String; P: Pointer; H: String); + Procedure AddChar (HK: Char; D: String; X, Y, FX, FY, DS, MN, MX: Byte; P: Pointer; H: String); + Procedure AddAttr (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); + Procedure AddFlag (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); + Procedure AddDate (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); + Procedure AddCaps (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); + Procedure AddBits (HK: Char; D: String; X, Y, FX, FY, DS: Byte; Flag: LongInt; P: Pointer; H: String); + Function Execute : Char; + End; + +Implementation + +Uses + m_FileIO, + m_Strings, + m_MenuBox; + +Constructor TMenuForm.Create (Var Con: TOutput); +Begin + Inherited Create; + + Screen := Con; + HelpProc := NIL; + DrawProc := NIL; + DataProc := NIL; + cLo := 0 + 7 * 16; + cHi := 11 + 1 * 16; + cData := 1 + 7 * 16; + cLoKey := 15 + 7 * 16; + cHiKey := 15 + 1 * 16; + cField1 := 15 + 1 * 16; + cField2 := 7 + 1 * 16; + HelpX := 5; + HelpY := 25; + HelpColor := 15; + HelpSize := 75; + WasHiExit := False; + WasFirstExit := False; + ExitOnFirst := False; + WasLastExit := False; + ExitOnLast := False; + + Input := TMenuInput.Create(Screen); + + Clear; +End; + +Destructor TMenuForm.Destroy; +Begin + Clear; + + Input.Free; + + Inherited Destroy; +End; + +Procedure TMenuForm.Clear; +Var + Count : Word; +Begin + For Count := 1 to Items Do + Dispose(ItemData[Count]); + + Items := 0; + ItemPos := 1; + Changed := False; +End; + +Function TMenuForm.DrawAccessFlags (Var Flags: TMenuFormFlagsRec) : String; +Var + S : String; + Ch : Char; +Begin + S := ''; + + For Ch := 'A' to 'Z' Do + If Ord(Ch) - 64 in Flags Then S := S + Ch Else S := S + '-'; + + DrawAccessFlags := S; +End; + +Procedure TMenuForm.EditAccessFlags (Var Flags: TMenuFormFlagsRec); +Var + Box : TMenuBox; + Ch : Char; +Begin + Box := TMenuBox.Create(Screen); + + Box.Open (25, 11, 56, 14); + + Screen.WriteXY (28, 13, 113, 'A-Z to toggle, ESC to Quit'); + + Repeat + Screen.WriteXY (28, 12, 112, DrawAccessFlags(Flags)); + + Ch := UpCase(Input.ReadKey); + + Case Ch of + #00 : Input.ReadKey; + #27 : Break; + 'A'.. + 'Z' : Begin + If Ord(Ch) - 64 in Flags Then + Flags := Flags - [Ord(Ch) - 64] + Else + Flags := Flags + [Ord(Ch) - 64]; + + Changed := True; + End; + End; + Until False; + + Box.Close; + Box.Free; +End; + +Function TMenuForm.GetColorAttr (C: Byte) : Byte; +Var + FG : Byte; + BG : Byte; + Box : TMenuBox; + A : Byte; + B : Byte; +Begin + FG := C AND $F; + BG := (C SHR 4) AND 7; + + Box := TMenuBox.Create(Screen); + + Box.Header := ' Select color '; + + Box.Open (30, 7, 51, 18); + + Repeat + For A := 0 to 9 Do + Screen.WriteXY (31, 8 + A, Box.BoxAttr, ' '); + + For A := 0 to 7 Do + For B := 0 to 15 Do + Screen.WriteXY (33 + B, 9 + A, B + A * 16, 'þ'); + + Screen.WriteXY (37, 18, FG + BG * 16, ' Sample '); + + Screen.WriteXYPipe (31 + FG, 8 + BG, 15, 5, 'Û|23ßßß|08Ü'); + Screen.WriteXYPipe (31 + FG, 9 + BG, 15, 5, 'Û|23 |08Û'); + Screen.WriteXYPipe (31 + FG, 10 + BG, 15, 5, '|23ß|08ÜÜÜ|08Û'); + Screen.WriteXY (33 + FG, 9 + BG, FG + BG * 16, 'þ'); + + Case Input.ReadKey of + #00 : Case Input.ReadKey of + #72 : If BG > 0 Then Dec(BG); + #75 : If FG > 0 Then Dec(FG); + #77 : If FG < 15 Then Inc(FG); + #80 : If BG < 7 Then Inc(BG); + End; + #13 : Begin + GetColorAttr := FG + BG * 16; + Break; + End; + #27 : Begin + GetColorAttr := C; + Break; + End; + End; + Until False; + + Box.Close; + Box.Free; +End; + +Procedure TMenuForm.AddBasic (HK: Char; D: String; X, Y, FX, FY, DS, FS, MS: Byte; I: FormItemType; P: Pointer; H: String); +Begin + Inc (Items); + + New (ItemData[Items]); + + With ItemData[Items]^ Do Begin + HotKey := HK; + Desc := D; + DescX := X; + DescY := Y; + DescSize := DS; + Help := H; + ItemType := I; + FieldSize := FS; + MaxSize := MS; + FieldX := FX; + FieldY := FY; + + Case ItemType of + ItemCaps, + ItemPipe, + ItemPass, + ItemDate, + ItemPath, + ItemString : S := P; + ItemBoolean : O := P; + ItemAttr, + ItemToggle, + ItemByte : B := P; + ItemWord : W := P; + ItemBits, + ItemLong : L := P; + ItemChar : C := P; + ItemFlags : F := P; + End; + End; +End; + +Procedure TMenuForm.AddNone (HK: Char; D: String; X, Y, DS: Byte; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, 0, 0, DS, 0, 0, ItemNone, NIL, H); +End; + +Procedure TMenuForm.AddChar (HK: Char; D: String; X, Y, FX, FY, DS, MN, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, 1, 1, ItemChar, P, H); + + ItemData[Items]^.MinNum := MN; + ItemData[Items]^.MaxNum := MX; +End; + +Procedure TMenuForm.AddStr (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemString, P, H); +End; + +Procedure TMenuForm.AddPipe (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemPipe, P, H); +End; + +Procedure TMenuForm.AddCaps (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemCaps, P, H); +End; + +Procedure TMenuForm.AddPass (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemPass, P, H); +End; + +Procedure TMenuForm.AddPath (HK: Char; D: String; X, Y, FX, FY, DS, FS, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemPath, P, H); +End; + +Procedure TMenuForm.AddBol (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, 3, ItemBoolean, P, H); +End; + +Procedure TMenuForm.AddBits (HK: Char; D: String; X, Y, FX, FY, DS: Byte; Flag: LongInt; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, 3, 3, ItemBits, P, H); + + ItemData[Items]^.MaxNum := Flag; +End; + +Procedure TMenuForm.AddByte (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, Length(strI2S(MX)), ItemByte, P, H); + + ItemData[Items]^.MinNum := MN; + ItemData[Items]^.MaxNum := MX; +End; + +Procedure TMenuForm.AddWord (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: Word; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, Length(strI2S(MX)), ItemWord, P, H); + + ItemData[Items]^.MinNum := MN; + ItemData[Items]^.MaxNum := MX; +End; + +Procedure TMenuForm.AddLong (HK: Char; D: String; X, Y, FX, FY, DS, FS: Byte; MN, MX: LongInt; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, Length(strI2S(MX)), ItemLong, P, H); + + ItemData[Items]^.MinNum := MN; + ItemData[Items]^.MaxNum := MX; +End; + +Procedure TMenuForm.AddTog (HK: Char; D: String; X, Y, FX, FY, DS, FS, MN, MX: Byte; TG: String; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, FS, MX, ItemToggle, P, H); + + ItemData[Items]^.Toggle := TG; + ItemData[Items]^.MinNum := MN; +End; + +Procedure TMenuForm.AddAttr (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, 8, 8, ItemAttr, P, H); +End; + +Procedure TMenuForm.AddFlag (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, 26, 26, ItemFlags, P, H); +End; + +Procedure TMenuForm.AddDate (HK: Char; D: String; X, Y, FX, FY, DS: Byte; P: Pointer; H: String); +Begin + If Items = FormMaxItems Then Exit; + + AddBasic (HK, D, X, Y, FX, FY, DS, 8, 8, ItemDate, P, H); +End; + +Procedure TMenuForm.BarON; +Var + A : Byte; +Begin + If ItemPos = 0 Then Exit; + + With ItemData[ItemPos]^ Do Begin + Screen.WriteXY (DescX, DescY, cHi, strPadR(Desc, DescSize, ' ')); + + A := Pos(HotKey, strUpper(Desc)); + If A > 0 Then + Screen.WriteXY (DescX + A - 1, DescY, cHiKey, Desc[A]); + + If HelpSize > 0 Then + If Assigned(HelpProc) Then + HelpProc + Else + Screen.WriteXYPipe (HelpX, HelpY, HelpColor, HelpSize, Help); + End; +End; + +Procedure TMenuForm.BarOFF (RecPos: Word); +Var + A : Byte; +Begin + If RecPos = 0 Then Exit; + + With ItemData[RecPos]^ Do Begin + Screen.WriteXY (DescX, DescY, cLo, strPadR(Desc, DescSize, ' ')); + + A := Pos(HotKey, strUpper(Desc)); + If A > 0 Then + Screen.WriteXY (DescX + A - 1, DescY, cLoKey, Desc[A]); + End; +End; + +Procedure TMenuForm.FieldWrite (RecPos : Word); +Begin + With ItemData[RecPos]^ Do Begin + Case ItemType of + ItemPass : Screen.WriteXY (FieldX, FieldY, cData, strPadR(strRep('*', Length(S^)), FieldSize, ' ')); + ItemCaps, + ItemDate, + ItemPath, + ItemString : Screen.WriteXY (FieldX, FieldY, cData, strPadR(S^, FieldSize, ' ')); + ItemBoolean : Screen.WriteXY (FieldX, FieldY, cData, strPadR(YesNoStr[O^], FieldSize, ' ')); + ItemByte : Screen.WriteXY (FieldX, FieldY, cData, strPadR(strI2S(B^), FieldSize, ' ')); + ItemWord : Screen.WriteXY (FieldX, FieldY, cData, strPadR(strI2S(W^), FieldSize, ' ')); + ItemLong : Screen.WriteXY (FieldX, FieldY, cData, strPadR(strI2S(L^), FieldSize, ' ')); + ItemToggle : Screen.WriteXY (FieldX, FieldY, cData, StrPadR(strWordGet(B^ + 1 - MinNum, Toggle, ' '), FieldSize, ' ')); + ItemChar : Screen.WriteXY (FieldX, FieldY, cData, C^); + ItemAttr : Screen.WriteXY (FieldX, FieldY, B^, ' Sample '); + ItemFlags : Screen.WriteXY (FieldX, FieldY, cData, DrawAccessFlags(F^)); + ItemPipe : Screen.WriteXYPipe (FieldX, FieldY, 7, FieldSize, S^); + ItemBits : Screen.WriteXY (FieldX, FieldY, cData, strPadR(YesNoStr[L^ AND MaxNum <> 0], FieldSize, ' ')); + End; + End; +End; + +Procedure TMenuForm.EditOption; +Var + TempStr : String; + TempByte : Byte; + TempLong : LongInt; +Begin + With ItemData[ItemPos]^ Do + Case ItemType of + ItemCaps : S^ := Input.GetStr(FieldX, FieldY, FieldSize, MaxSize, 2, S^); + ItemDate : S^ := Input.GetStr(FieldX, FieldY, FieldSize, MaxSize, 3, S^); + ItemPass, + ItemPipe, + ItemString : S^ := Input.GetStr(FieldX, FieldY, FieldSize, MaxSize, 1, S^); + ItemBoolean : Begin + O^ := Not O^; + Changed := True; + End; + ItemByte : B^ := Byte(Input.GetNum(FieldX, FieldY, FieldSize, MaxSize, MinNum, MaxNum, B^)); + ItemWord : W^ := Word(Input.GetNum(FieldX, FieldY, FieldSize, MaxSize, MinNum, MaxNum, W^)); + ItemLong : L^ := LongInt(Input.GetNum(FieldX, FieldY, FieldSize, MaxSize, MinNum, MaxNum, L^)); + ItemToggle : Begin + If B^ < MaxSize Then Inc(B^) Else B^ := MinNum; + Changed := True; + End; + ItemPath : S^ := DirSlash(Input.GetStr(FieldX, FieldY, FieldSize, MaxSize, 1, S^)); + ItemChar : Begin + TempStr := Input.GetStr(FieldX, FieldY, FieldSize, MaxSize, 1, C^); + Changed := TempStr[1] <> C^; + C^ := TempStr[1]; + End; + ItemAttr : Begin + TempByte := GetColorAttr(B^); + Changed := TempByte <> B^; + B^ := TempByte; + End; + ItemFlags : EditAccessFlags(F^); + ItemBits : Begin + Changed := True; + TempLong := L^; + TempLong := TempLong XOR MaxNum; + L^ := TempLong; + End; + End; + + FieldWrite (ItemPos); + + Changed := Changed or Input.Changed; +End; + +Function TMenuForm.Execute : Char; +Var + Count : Word; + Ch : Char; + NewPos : Word; + NewXPos : Word; +Begin + WasHiExit := False; + + Input.Attr := cField1; + Input.FillAttr := cField2; + + For Count := 1 to Items Do Begin + BarOFF(Count); + FieldWrite(Count); + End; + + BarON; + + Repeat + Changed := Changed OR Input.Changed; + + Ch := UpCase(Input.ReadKey); + + Case Ch of + #00 : Begin + Ch := Input.ReadKey; + + If Pos(Ch, HiExitChars) > 0 Then Begin + WasHiExit := True; + Execute := Ch; + Break; + End; + + Case Ch of + #72 : If ItemPos > 1 Then Begin + BarOFF(ItemPos); + Dec(ItemPos); + BarON; + End Else + If ExitOnFirst Then Begin + WasFirstExit := True; + Execute := Ch; + Break; + End; + #75 : Begin + NewPos := 0; + NewXPos := 0; + + For Count := 1 to Items Do + If (ItemData[Count]^.DescY = ItemData[ItemPos]^.DescY) and + (ItemData[Count]^.DescX < ItemData[ItemPos]^.DescX) and + (ItemData[Count]^.DescX > NewXPos) Then Begin + NewXPos := ItemData[Count]^.DescX; + NewPos := Count; + End; + + If NewPos > 0 Then Begin + BarOFF(ItemPos); + ItemPos := NewPos; + BarON; + End; + End; + #77 : Begin + NewPos := 0; + NewXPos := 80; + + For Count := 1 to Items Do + If (ItemData[Count]^.DescY = ItemData[ItemPos]^.DescY) and + (ItemData[Count]^.DescX > ItemData[ItemPos]^.DescX) and + (ItemData[Count]^.DescX < NewXPos) Then Begin + NewXPos := ItemData[Count]^.DescX; + NewPos := Count; + End; + + If NewPos > 0 Then Begin + BarOFF(ItemPos); + ItemPos := NewPos; + BarON; + End; + End; + #80 : If ItemPos < Items Then Begin + BarOFF(ItemPos); + Inc(ItemPos); + BarON; + End Else + If ExitOnLast Then Begin + WasLastExit := True; + Execute := Ch; + Break; + End; + End; + End; + #13 : If ItemPos > 0 Then + If ItemData[ItemPos]^.ItemType = ItemNone Then Begin + Execute := ItemData[ItemPos]^.HotKey; + Break; + End Else + EditOption; + #27 : Begin + Execute := #27; + Break; + End; + Else + If Pos(Ch, LoExitChars) > 0 Then Begin + Execute := Ch; + Break; + End; + + For Count := 1 to Items Do + If ItemData[Count]^.HotKey = Ch Then Begin + BarOFF(ItemPos); + ItemPos := Count; + BarON; + + If ItemData[ItemPos]^.ItemType = ItemNone Then Begin + Execute := ItemData[ItemPos]^.HotKey; + BarOFF(ItemPos); + Exit; + End Else + EditOption; + End; + End; + Until False; + + BarOFF(ItemPos); +End; + +End. diff --git a/mdl/m_menuinput.pas b/mdl/m_menuinput.pas new file mode 100644 index 0000000..f1e0248 --- /dev/null +++ b/mdl/m_menuinput.pas @@ -0,0 +1,418 @@ +{$I M_OPS.PAS} + +Unit m_MenuInput; + +Interface + +Uses + m_Strings, + m_Input, + m_Output; + +Type + TMenuInput = Class + Private + Console : TOutput; + Public + Key : TInput; + HiChars : String; + LoChars : String; + ExitCode : Char; + Attr : Byte; + FillChar : Char; + FillAttr : Byte; + Changed : Boolean; + + Constructor Create (Var Screen: TOutput); + Destructor Destroy; Override; + Function GetStr (X, Y, Field, Len, Mode: Byte; Default: String) : String; + Function GetNum (X, Y, Field, Len: Byte; Min, Max, Default: LongInt) : LongInt; + Function GetChar (X, Y : Byte; Default: Char) : Char; + Function GetEnter (X, Y, Len: Byte; Default : String) : Boolean; + Function GetYN (X, Y : Byte; Default: Boolean) : Boolean; + + Function KeyWaiting : Boolean; + Function ReadKey : Char; + End; + +Implementation + +Constructor TMenuInput.Create (Var Screen: TOutput); +Begin + Inherited Create; + + Console := Screen; + Key := TInput.Create; + LoChars := #13; + HiChars := ''; + Attr := 15 + 1 * 16; + FillAttr := 7 + 1 * 16; + FillChar := '°'; + Changed := False; +End; + +Destructor TMenuInput.Destroy; +Begin + Key.Free; + + Inherited Destroy; +End; + +Function TMenuInput.GetYN (X, Y : Byte; Default: Boolean) : Boolean; +Var + Ch : Char; + Res : Boolean; + YS : Array[False..True] of String[3] = ('No ', 'Yes'); +Begin + ExitCode := #0; + Changed := False; + + Console.CursorXY (X, Y); + + Res := Default; + + Repeat + Console.WriteXY (X, Y, Attr, YS[Res]); + + Ch := ReadKey; + Case Ch of + #00 : Begin + Ch := ReadKey; + If Pos(Ch, HiChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + #13, + #32 : Res := Not Res; + Else + If Pos(Ch, LoChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + Until False; + + Changed := (Res <> Default); + GetYN := Res; +End; + +Function TMenuInput.GetChar (X, Y : Byte; Default: Char) : Char; +Var + Ch : Char; + Res : Char; +Begin + ExitCode := #0; + Changed := False; + Res := Default; + + Console.CursorXY (X, Y); + + Repeat + Console.WriteXY (X, Y, Attr, Res); + + Ch := ReadKey; + + Case Ch of + #00 : Begin + Ch := ReadKey; + If Pos(Ch, HiChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + Else + If Ch = #27 Then Res := Default; + + If Pos(Ch, LoChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + + If Ord(Ch) > 31 Then Res := Ch; + End; + Until False; + + GetChar := Res; +End; + +Function TMenuInput.GetEnter (X, Y, Len: Byte; Default : String) : Boolean; +Var + Ch : Char; + Res : Boolean; +Begin + ExitCode := #0; + Changed := False; + + Console.WriteXY (X, Y, Attr, strPadR(Default, Len, ' ')); + Console.CursorXY (X, Y); + + Repeat + Ch := ReadKey; + Res := Ch = #13; + Case Ch of + #00 : Begin + Ch := ReadKey; + If Pos(Ch, HiChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + Else + If Pos(Ch, LoChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + Until Res; + + Changed := Res; + GetEnter := Res; +End; + +Function TMenuInput.GetStr (X, Y, Field, Len, Mode : Byte; Default : String) : String; +{ mode options: } +{ 0 = numbers only } +{ 1 = as typed } +{ 2 = all caps } +{ 3 = date input } +Var + Ch : Char; + Str : String; + StrPos : Integer; + Junk : Integer; + CurPos : Integer; + + Procedure ReDraw; + Var + T : String; + Begin + T := Copy(Str, Junk, Field); + + Console.WriteXY (X, Y, Attr, T); + Console.WriteXY (X + Length(T), Y, FillAttr, strRep(FillChar, Field - Length(T))); + Console.CursorXY (X + CurPos - 1, Console.CursorY); + End; + + Procedure ReDrawPart; + Var + T : String; + Begin + T := Copy(Str, StrPos, Field - CurPos + 1); + + Console.WriteXY (Console.CursorX, Y, Attr, T); + Console.WriteXY (Console.CursorX + Length(T), Y, FillAttr, strRep(FillChar, (Field - CurPos + 1) - Length(T))); + Console.CursorXY (X + CurPos - 1, Y); + End; + + Procedure ScrollRight; + Begin + Inc (Junk); + If Junk > Length(Str) Then Junk := Length(Str); + If Junk > Len then Junk := Len; + CurPos := StrPos - Junk + 1; + ReDraw; + End; + + Procedure ScrollLeft; + Begin + If Junk > 1 Then Begin + Dec (Junk); + CurPos := StrPos - Junk + 1; + ReDraw; + End; + End; + + Procedure Add_Char (Ch : Char); + Begin + If Length(Str) >= Len Then Exit; + + If (CurPos >= Field) and (Field <> Len) Then ScrollRight; + + Insert (Ch, Str, StrPos); + If StrPos < Length(Str) Then ReDrawPart; + + Inc (StrPos); + Inc (CurPos); + + Console.WriteXY (Console.CursorX, Console.CursorY, Attr, Ch); + Console.CursorXY (Console.CursorX + 1, Console.CursorY); + End; + +Begin + Changed := False; + Str := Default; + StrPos := Length(Str) + 1; + Junk := Length(Str) - Field + 1; + If Junk < 1 Then Junk := 1; + CurPos := StrPos - Junk + 1; + + Console.CursorXY (X, Y); + Console.TextAttr := Attr; + + ReDraw; + + Repeat + Ch := Key.ReadKey; + Case Ch of + #00 : Begin + Ch := Key.ReadKey; + Case Ch of + #77 : If StrPos < Length(Str) + 1 Then Begin + If (CurPos = Field) and (StrPos < Length(Str)) Then ScrollRight; + Inc (CurPos); + Inc (StrPos); + Console.CursorXY (Console.CursorX + 1, Console.CursorY); + End; + #75 : If StrPos > 1 Then Begin + If CurPos = 1 Then ScrollLeft; + Dec (StrPos); + Dec (CurPos); + Console.CursorXY (Console.CursorX - 1, Console.CursorY); + End; + #71 : If StrPos > 1 Then Begin + StrPos := 1; + Junk := 1; + CurPos := 1; + ReDraw; + End; + #79 : Begin + StrPos := Length(Str) + 1; + Junk := Length(Str) - Field + 1; + If Junk < 1 Then Junk := 1; + CurPos := StrPos - Junk + 1; + ReDraw; + End; + #83 : If (StrPos <= Length(Str)) and (Length(Str) > 0) Then Begin + Delete (Str, StrPos, 1); + ReDrawPart; + End; + #115: Begin + If (StrPos > 1) and (Str[StrPos] = ' ') or (Str[StrPos - 1] = ' ') Then Begin + If CurPos = 1 Then ScrollLeft; + Dec(StrPos); + Dec(CurPos); + + While (StrPos > 1) and (Str[StrPos] = ' ') Do Begin + If CurPos = 1 Then ScrollLeft; + Dec(StrPos); + Dec(CurPos); + End; + End; + + While (StrPos > 1) and (Str[StrPos] <> ' ') Do Begin + If CurPos = 1 Then ScrollLeft; + Dec(StrPos); + Dec(CurPos); + End; + + While (StrPos > 1) and (Str[StrPos] <> ' ') Do Begin + If CurPos = 1 Then ScrollLeft; + Dec(StrPos); + Dec(CurPos); + End; + + If (Str[StrPos] = ' ') and (StrPos > 1) Then Begin + Inc(StrPos); + Inc(CurPos); + End; + + ReDraw; + End; + #116: Begin + While StrPos < Length(Str) + 1 Do Begin + If (CurPos = Field) and (StrPos < Length(Str)) Then ScrollRight; + Inc (CurPos); + Inc (StrPos); + + If Str[StrPos] = ' ' Then Begin + If StrPos < Length(Str) + 1 Then Begin + If (CurPos = Field) and (StrPos < Length(Str)) Then ScrollRight; + Inc (CurPos); + Inc (StrPos); + End; + Break; + End; + End; + Console.CursorXY (X + CurPos - 1, Y); + End; + Else + If Pos(Ch, HiChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + End; + #08 : If StrPos > 1 Then Begin + Dec (StrPos); + Delete (Str, StrPos, 1); + If CurPos = 1 Then + ScrollLeft + Else Begin + Console.CursorXY (Console.CursorX - 1, Console.CursorY); + Dec (CurPos); + ReDrawPart; + End; + End; + ^Y : Begin + Str := ''; + StrPos := 1; + Junk := 1; + CurPos := 1; + ReDraw; + End; + #32.. + #254: Case Mode of + 0 : If Ch in ['0'..'9', '-'] Then Add_Char(Ch); + 1 : Add_Char (Ch); + 2 : Add_Char (UpCase(Ch)); + 3 : If (Ch > '/') and (Ch < ':') Then + Case StrPos of + 2,5 : Begin + Add_Char (Ch); + Add_Char ('/'); + End; + 3,6 : Begin + Add_Char ('/'); + Add_Char (Ch); + End; + Else + Add_Char (Ch); + End; + End; + Else + If Pos(Ch, LoChars) > 0 Then Begin + ExitCode := Ch; + Break; + End; + End; + Until False; + + Changed := (Str <> Default); + Result := Str; +End; + +Function TMenuInput.GetNum (X, Y, Field, Len: Byte; Min, Max, Default: LongInt) : LongInt; +Var + N : LongInt; +Begin + N := Default; + N := strS2I(Self.GetStr(X, Y, Field, Len, 0, strI2S(N))); + + If N < Min Then N := Min; + If N > Max Then N := Max; + + GetNum := N; +End; + +Function TMenuInput.KeyWaiting : Boolean; +Begin + Result := Key.KeyPressed; +End; + +Function TMenuInput.ReadKey : Char; +Begin + Result := Key.ReadKey; +End; + +End. diff --git a/mdl/m_output_darwin.pas b/mdl/m_output_darwin.pas new file mode 100644 index 0000000..706517a --- /dev/null +++ b/mdl/m_output_darwin.pas @@ -0,0 +1,718 @@ +{$I M_OPS.PAS} + +Unit m_Output_Darwin; + +Interface + +Uses + TermIO, + BaseUnix, + m_Types; + +Const + ConIn = 0; + ConOut = 1; + ConBufSize = 4096; + +Type + TOutputDarwin = Class + Private + TermInfo : TermIos; + TermInRaw : Boolean; + TermOutRaw : Boolean; + OutBuffer : Array[1..ConBufSize] of Char; + FTextAttr : Byte; + FWinTop : Byte; + FCursorX : Byte; + FCursorY : Byte; + + Procedure SetTextAttr (Attr: Byte); + Public + OutBufPos : Word; + ScreenSize : Byte; + Buffer : TConsoleScreenRec; + Active : Boolean; + SavedTerm : TermIOS; + FWinBot : Byte; + + Function AttrToAnsi (Attr: Byte) : String; + Procedure BufFlush; + Procedure BufAddStr (Str: String); + Procedure SaveRawSettings (Var TIo: TermIos); + Procedure RestoreRawSettings (TIo: TermIos); + Procedure SetRawMode (SetOn: Boolean); + Procedure WriteXY (X, Y, A: Byte; Text: String); + Procedure WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); + Procedure GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); + Procedure PutScreenImage (Image: TConsoleImageRec); + Procedure LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); + + Constructor Create (A: Boolean); + Destructor Destroy; Override; + Procedure ClearScreen; Virtual; + Procedure ScrollWindow; Virtual; + Procedure ClearEOL; + Procedure CursorXY (X, Y: Byte); + Procedure SetWindow (X1, Y1, X2, Y2: Byte; Home: Boolean); + Procedure SetScreenSize (Mode: Byte); + Procedure SetWindowTitle (Str: String); + Procedure WriteChar (Ch: Char); + Procedure WriteLine (Str: String); + Procedure WriteLineRec (YPos: Integer; Line: TConsoleLineRec); + Procedure WriteStr (Str: String); + Procedure RawWriteStr (Str: String); + Function ReadCharXY (X, Y: Byte) : Char; + Function ReadAttrXY (X, Y: Byte) : Byte; + Procedure ShowBuffer; + + Property TextAttr : Byte Read FTextAttr Write SetTextAttr; + Property CursorX : Byte Read FCursorX; + Property CursorY : Byte Read FCursorY; + End; + +Implementation + +Uses + m_Strings; + +Procedure TOutputDarwin.WriteLineRec (YPos: Integer; Line: TConsoleLineRec); +Var + Count : LongInt; +Begin + CursorXY(1, YPos); + + For Count := 1 to 80 Do + BufAddStr(AttrToAnsi(Line[Count].Attributes) + Line[Count].UnicodeChar); + + BufFlush; + +// For Count := 1 to 80 Do Begin +// FTextAttr := Line[Count].Attributes; +// WriteChar(Line[Count].UnicodeChar); +// End; + + Buffer[YPos] := Line; +End; + +Constructor TOutputDarwin.Create (A: Boolean); +Begin + Inherited Create; + +// SaveRawSettings(SavedTerm); + + SetRawMode(True); + + Active := A; + OutBufPos := 0; + FTextAttr := 7; + FWinTop := 1; + FWinBot := 25; + ScreenSize := 25; + + RawWriteStr (#27 + '(U' + #27 + '[0m'); + + ClearScreen; +End; + +Destructor TOutputDarwin.Destroy; +Begin + WriteLine(''); + + BufFlush; + +// RestoreRawSettings(SavedTerm); + SetRawMode(False); + + Inherited Destroy; +End; + +Const + AnsiTable : String[8] = '04261537'; + +Function TOutputDarwin.AttrToAnsi (Attr: Byte) : String; +Var + Str : String[16]; + OldFG : LongInt; + OldBG : LongInt; + FG : LongInt; + BG : LongInt; + + Procedure AddSep (Ch: Char); + Begin + If Length(Str) > 0 Then + Str := Str + ';'; + Str := Str + Ch; + End; + +Begin + If Attr = FTextAttr Then Begin + AttrToAnsi := ''; + Exit; + End; + + Str := ''; + FG := Attr and $F; + BG := Attr shr 4; + OldFG := FTextAttr and $F; + OldBG := FTextAttr shr 4; + + If (OldFG <> 7) or (FG = 7) or ((OldFG > 7) and (FG < 8)) or ((OldBG > 7) and (BG < 8)) Then Begin + Str := '0'; + OldFG := 7; + OldBG := 0; + End; + + If (FG > 7) and (OldFG < 8) Then Begin + AddSep('1'); + OldFG := OldFG or 8; + End; + + If (BG and 8) <> (OldBG and 8) Then Begin + AddSep('5'); + OldBG := OldBG or 8; + End; + + If (FG <> OldFG) Then Begin + AddSep('3'); + Str := Str + AnsiTable[(FG and 7) + 1]; + End; + + If (BG <> OldBG) Then Begin + AddSep('4'); + Str := Str + AnsiTable[(BG and 7) + 1]; + End; + + FTextAttr := FG + BG * 16; + AttrToAnsi := #27 + '[' + Str + 'm'; +End; + +Procedure TOutputDarwin.BufFlush; +Begin + If OutBufPos > 0 Then Begin + If Active Then fpWrite (ConOut, OutBuffer[1], OutBufPos); + OutBufPos := 0; + End; +End; + +Procedure TOutputDarwin.BufAddStr (Str: String); +Var + Count : LongInt; +Begin + For Count := 1 to Length(Str) Do Begin + Inc (OutBufPos); + OutBuffer[OutBufPos] := Str[Count]; + If OutBufPos = ConBufSize Then BufFlush; + End; +End; + +Procedure TOutputDarwin.SetTextAttr (Attr: Byte); +Begin + If Attr = FTextAttr Then Exit; + + BufAddStr(AttrToAnsi(Attr)); + + FTextAttr := Attr; +End; + +Procedure TOutputDarwin.CursorXY (X, Y: Byte); +Begin + If (Y < 1) Then Y := 1 Else +// If (Y > FWinBot) Then Y := FWinBot; {changed 109a4} + If (Y > ScreenSize) Then Y := ScreenSize; + If (X < 1) Then X := 1 Else + If (X > 80) Then X := 80; + + BufAddStr(#27 + '[' + strI2S(Y) + ';' + strI2S(X) + 'H'); + BufFlush; + + FCursorX := X; + FCursorY := Y; +End; + +Procedure TOutputDarwin.ClearScreen; +Var + Fill : TCharInfo; + Count : Byte; +Begin + BufFlush; + + Fill.Attributes := FTextAttr; + Fill.UnicodeChar := ' '; + + If (FWinTop = 1) and (FWinBot = {25}ScreenSize) Then Begin + BufAddStr(#27 + '[2J'); + FillWord (Buffer, SizeOf(Buffer) DIV 2, Word(Fill)); + End Else Begin + For Count := FWinTop to FWinBot Do Begin + BufAddStr (#27 + '[' + strI2S(Count) + ';1H' + #27 + '[K'); + FillWord (Buffer[Count][1], SizeOf(TConsoleLineRec) DIV 2, Word(Fill)); + End; + End; + + CursorXY (1, FWinTop); +End; + +Procedure TOutputDarwin.SetScreenSize (Mode: Byte); +Begin + FWinBot := Mode; + ScreenSize := Mode; + + BufFlush; + RawWriteStr(#27 + '[8;' + strI2S(Mode) + ';80t'); + SetWindow(1, 1, 80, Mode, False); +//need to figure this out. + +//esc[8;h;w +End; + +Procedure TOutputDarwin.SetWindow (X1, Y1, X2, Y2: Byte; Home: Boolean); +Begin + // X1 and X2 are ignored in Darwin and are only here for compatibility + // reasons. + + FWinTop := Y1; + FWinBot := Y2; + + BufAddStr (#27 + '[' + strI2S(Y1) + ';' + strI2S(Y2) + 'r'); + BufFlush; + + If Home Then CursorXY (1, Y1); + + If (FCursorY > Y2) Then CursorXY (CursorX, Y2); + +// If Home or (FCursorY < Y1) or (FCursorY > Y2) Then CursorXY(1, Y1); + { this home thing is shady. compare it to win. going from 50 to 25 } + { will screw up the buffers - this has to be more elegant. } +End; + +Procedure TOutputDarwin.SetWindowTitle (Str: String); +Begin + RawWriteStr (#27 + ']0;' + Str + #07); +End; + +Procedure TOutputDarwin.ClearEOL; +Var + Fill : TCharInfo; +Begin + BufAddStr(#27 + '[K'); + + Fill.Attributes := 7; + Fill.UnicodeChar := ' '; + + FillWord (Buffer[CursorY][CursorX], (80 - CursorX) * 2, Word(Fill)); +End; + +Procedure TOutputDarwin.ScrollWindow; +Begin + Move (Buffer[2][1], Buffer[1][1], SizeOf(TConsoleLineRec) * (FWinBot - 1)); + FillChar(Buffer[FWinBot][1], SizeOf(TConsoleLineRec), 0); +End; + +Procedure TOutputDarwin.WriteChar (Ch: Char); +Var + A : Byte; +Begin + If Ch <> #10 Then BufAddStr(Ch); + + Case Ch of + #08 : If FCursorX > 1 Then + Dec(FCursorX); + #10 : Begin + If FCursorY < FWinBot Then Begin + BufAddStr(Ch); + Inc (FCursorY) + End Else Begin + A := FTextAttr; + SetTextAttr(7); + BufAddStr(Ch); + ScrollWindow; + SetTextAttr(A); + End; + + FCursorX := 1; + CursorXY(FCursorX, FCursorY); + + BufFlush; + End; + #13 : FCursorX := 1; + Else + Buffer[FCursorY][FCursorX].Attributes := FTextAttr; + Buffer[FCursorY][FCursorX].UnicodeChar := Ch; + + If FCursorX < 80 Then + Inc (FCursorX) + Else Begin + FCursorX := 1; + + If FCursorY < FWinBot Then + Inc (FCursorY) + Else + ScrollWindow; + + BufFlush; + End; + End; +End; + +Procedure TOutputDarwin.WriteStr (Str: String); +Var + Count : Byte; +Begin + For Count := 1 to Length(Str) Do + WriteChar(Str[Count]); + + BufFlush; +End; + +Procedure TOutputDarwin.WriteLine (Str: String); +Var + Count : Byte; +Begin + Str := Str + #13#10; + + For Count := 1 To Length(Str) Do + WriteChar(Str[Count]); + + BufFlush; +End; + +Procedure TOutputDarwin.RawWriteStr (Str: String); +Begin + fpWrite (ConOut, Str[1], Length(Str)); +End; + +Procedure TOutputDarwin.SaveRawSettings (Var TIo: TermIos); +Begin + With TIo Do Begin + TermInRaw := + ((c_iflag and (IGNBRK or BRKINT or PARMRK or ISTRIP or + INLCR or IGNCR or ICRNL or IXON)) = 0) and + ((c_lflag and (ECHO or ECHONL or ICANON or ISIG or IEXTEN)) = 0); + TermOutRaw := + ((c_oflag and OPOST) = 0) and + ((c_cflag and (CSIZE or PARENB)) = 0) and + ((c_cflag and CS8) <> 0); + End; +End; + +Procedure TOutputDarwin.RestoreRawSettings (TIo: TermIos); +Begin + With TIo Do Begin + If TermInRaw Then Begin + c_iflag := c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or + INLCR or IGNCR or ICRNL or IXON)); + c_lflag := c_lflag and + (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN)); + End; + + If TermOutRaw Then Begin + c_oflag := c_oflag and not(OPOST); + c_cflag := c_cflag and not(CSIZE or PARENB) or CS8; + End; + End; +End; + +Procedure TOutputDarwin.SetRawMode (SetOn: Boolean); +Var + Tio : TermIos; +Begin + If SetOn Then Begin + TCGetAttr(1, Tio); + SaveRawSettings(Tio); + TermInfo := Tio; + CFMakeRaw(Tio); + End Else Begin + RestoreRawSettings(TermInfo); + Tio := TermInfo; + End; + + TCSetAttr(1, TCSANOW, Tio); +End; + +Function TOutputDarwin.ReadCharXY (X, Y: Byte) : Char; +Begin + ReadCharXY := Buffer[Y][X].UnicodeChar; +End; + +Function TOutputDarwin.ReadAttrXY (X, Y: Byte) : Byte; +Begin + ReadAttrXY := Buffer[Y][X].Attributes; +End; + +Procedure TOutputDarwin.WriteXY (X, Y, A: Byte; Text: String); +Var + OldAttr : Byte; + OldX : Byte; + OldY : Byte; + Count : Byte; +Begin + If X > 80 Then Exit; + + OldAttr := FTextAttr; + OldX := FCursorX; + OldY := FCursorY; + + CursorXY (X, Y); + SetTextAttr (A); + + For Count := 1 to Length(Text) Do + If FCursorX <= 80 Then Begin + Buffer[FCursorY][FCursorX].Attributes := FTextAttr; + Buffer[FCursorY][FCursorX].UnicodeChar := Text[Count]; + + Inc (FCursorX); + + BufAddStr(Text[Count]); + End Else + Break; + + SetTextAttr(OldAttr); + CursorXY (OldX, OldY); + + BufFlush; +End; + +Procedure TOutputDarwin.WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); + + Procedure AddChar (Ch: Char); + Begin + If CursorX > 80 Then Exit; + + Buffer[CursorY][CursorX].Attributes := FTextAttr; + Buffer[CursorY][CursorX].UnicodeChar := Ch; + + BufAddStr(Ch); + + Inc (FCursorX); + End; + +Var + Count : Byte; + Code : String[2]; + CodeNum : Byte; + OldAttr : Byte; + OldX : Byte; + OldY : Byte; +Begin + OldAttr := FTextAttr; + OldX := FCursorX; + OldY := FCursorY; + + CursorXY (X, Y); + SetTextAttr (Attr); + + Count := 1; + + While Count <= Length(Text) Do Begin + If Text[Count] = '|' Then Begin + Code := Copy(Text, Count + 1, 2); + CodeNum := strS2I(Code); + + If (Code = '00') or ((CodeNum > 0) and (CodeNum < 24) and (Code[1] <> '&') and (Code[1] <> '$')) Then Begin + Inc (Count, 2); + If CodeNum in [00..15] Then + SetTextAttr (CodeNum + ((FTextAttr SHR 4) AND 7) * 16) + Else + SetTextAttr ((FTextAttr AND $F) + (CodeNum - 16) * 16); + End Else Begin + AddChar(Text[Count]); + Dec (Pad); + End; + End Else Begin + AddChar(Text[Count]); + Dec (Pad); + End; + + If Pad = 0 Then Break; + + Inc (Count); + End; + + While Pad > 0 Do Begin + AddChar(' '); + Dec(Pad); + End; + + SetTextAttr(OldAttr); + CursorXY (OldX, OldY); + + BufFlush; +End; + +Procedure TOutputDarwin.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +Var + Count : Byte; +Begin +// If X2 > 80 Then X2 := 80; +// If Y2 > FWinBot Then Y2 := FWinBot; + + FillChar(Image, SizeOf(Image), #0); + + Image.Data := Buffer; +// For Count := Y1 to Y2 Do Begin +// Image.Data[Count] := Buffer[Count]; + + Image.CursorX := FCursorX; + Image.CursorY := FCursorY; + Image.CursorA := FTextAttr; + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; +End; + +Procedure TOutputDarwin.PutScreenImage (Image: TConsoleImageRec); +Var + CountX : Byte; + CountY : Byte; +Begin + For CountY := Image.Y1 to Image.Y2 Do Begin + CursorXY (Image.X1, CountY); + + For CountX := Image.X1 to Image.X2 Do Begin + SetTextAttr(Image.Data[CountY][CountX].Attributes); + If Image.Data[CountY][CountX].UnicodeChar = #0 Then BufAddStr(' ') Else BufAddStr(Image.Data[CountY][CountX].UnicodeChar); + // the above is a placeholder until we properly fill the buffers. #0 does not work in ITERM2 + Buffer[CountY][CountX] := Image.Data[CountY][CountX]; + End; + End; + + SetTextAttr (Image.CursorA); + CursorXY (Image.CursorX, Image.CursorY); + + BufFlush; +End; + +(* +Procedure TOutputDarwin.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +Var + Count : Byte; + Line : Byte; + Temp : TConsoleLineRec; +Begin + Line := 1; + + If X2 > 80 Then X2 := 80; + If Y2 > FWinBot Then Y2 := FWinBot; + + FillChar(Image, SizeOf(Image), #0); + + For Count := Y1 to Y2 Do Begin + Move (Buffer[Count][X1], Image.Data[Line][1], (X2 - X1 + 1) * SizeOf(TCharInfo)); + Inc (Line); + End; + + Image.CursorX := FCursorX; + Image.CursorY := FCursorY; + Image.CursorA := FTextAttr; + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; +End; + +Procedure TOutputDarwin.PutScreenImage (Var Image: TConsoleImageRec); +Var + CountX : Byte; + CountY : Byte; +Begin + For CountY := 1 to (Image.Y2 - Image.Y1 + 1) Do Begin + CursorXY (Image.X1, CountY + Image.Y1 - 1); + + Move (Image.Data[CountY][1], Buffer[CountY + Image.Y1 - 1][Image.X1], (Image.X2 - Image.X1 + 1) * SizeOf(TCharInfo)); + + For CountX := 1 to (Image.X2 - Image.X1 + 1) Do Begin + SetTextAttr(Image.Data[CountY][CountX].Attributes); + BufAddStr(Image.Data[CountY][CountX].UnicodeChar); + End; + End; + + SetTextAttr (Image.CursorA); + CursorXY (Image.CursorX, Image.CursorY); + + BufFlush; +End; +*) + +Procedure TOutputDarwin.LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); +Var + Image : TConsoleImageRec; + Data : Array[1..8000] of Byte Absolute DataPtr; + PosX : Word; + PosY : Byte; + Attrib : Byte; + Count : Word; + A : Byte; + B : Byte; + C : Byte; +Begin + PosX := 1; + PosY := 1; + Attrib := 7; + Count := 1; + + FillChar(Image.Data, SizeOf(Image.Data), #0); + + While (Count <= Len) Do begin + Case Data[Count] of + 00.. + 15 : Attrib := Data[Count] + ((Attrib SHR 4) and 7) * 16; + 16.. + 23 : Attrib := (Attrib And $F) + (Data[Count] - 16) * 16; + 24 : Begin + Inc (PosY); + PosX := 1; + End; + 25 : Begin + Inc (Count); + + For A := 0 to Data[Count] Do Begin + Image.Data[PosY][PosX].UnicodeChar := ' '; + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 26 : Begin + A := Data[Count + 1]; + B := Data[Count + 2]; + + Inc (Count, 2); + + For C := 0 to A Do Begin + Image.Data[PosY][PosX].UnicodeChar := Char(B); + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 27.. + 31 : ; + Else + Image.Data[PosY][PosX].UnicodeChar := Char(Data[Count]); + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + + Inc(Count); + End; + + If PosY > ScreenSize Then PosY := ScreenSize; + + Image.CursorX := PosX; + Image.CursorY := PosY; + Image.CursorA := Attrib; + Image.X1 := X; + Image.X2 := Width; + Image.Y1 := Y; + Image.Y2 := PosY; + + PutScreenImage(Image); +End; + +Procedure TOutputDarwin.ShowBuffer; +Begin +End; + +End. diff --git a/mdl/m_output_linux.pas b/mdl/m_output_linux.pas new file mode 100644 index 0000000..a45390d --- /dev/null +++ b/mdl/m_output_linux.pas @@ -0,0 +1,719 @@ +{$I M_OPS.PAS} + +Unit m_Output_Linux; + +Interface + +Uses + TermIO, + BaseUnix, + m_Types; + +Const + ConIn = 0; + ConOut = 1; + ConBufSize = 4096; + +Type + TOutputLinux = Class + Private + TermInfo : TermIos; + TermInRaw : Boolean; + TermOutRaw : Boolean; + OutBuffer : Array[1..ConBufSize] of Char; + FTextAttr : Byte; + FWinTop : Byte; + FCursorX : Byte; + FCursorY : Byte; + + Procedure SetTextAttr (Attr: Byte); + Public + OutBufPos : Word; + ScreenSize : Byte; + Buffer : TConsoleScreenRec; + Active : Boolean; + SavedTerm : TermIOS; + FWinBot : Byte; + + Function AttrToAnsi (Attr: Byte) : String; + Procedure BufFlush; + Procedure BufAddStr (Str: String); + Procedure SaveRawSettings (Var TIo: TermIos); + Procedure RestoreRawSettings (TIo: TermIos); + Procedure SetRawMode (SetOn: Boolean); + Procedure WriteXY (X, Y, A: Byte; Text: String); + Procedure WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); + Procedure GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); + Procedure PutScreenImage (Image: TConsoleImageRec); + Procedure LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); + + Constructor Create (A: Boolean); + Destructor Destroy; Override; + Procedure ClearScreen; Virtual; + Procedure ScrollWindow; Virtual; + Procedure ClearEOL; + Procedure CursorXY (X, Y: Byte); + Procedure SetWindow (X1, Y1, X2, Y2: Byte; Home: Boolean); + Procedure SetScreenSize (Mode: Byte); + Procedure SetWindowTitle (Str: String); + Procedure WriteChar (Ch: Char); + Procedure WriteLine (Str: String); + Procedure WriteLineRec (YPos: Integer; Line: TConsoleLineRec); + Procedure WriteStr (Str: String); + Procedure RawWriteStr (Str: String); + Function ReadCharXY (X, Y: Byte) : Char; + Function ReadAttrXY (X, Y: Byte) : Byte; + Procedure ShowBuffer; + + Property TextAttr : Byte Read FTextAttr Write SetTextAttr; + Property CursorX : Byte Read FCursorX; + Property CursorY : Byte Read FCursorY; + End; + +Implementation + +Uses + m_Strings; + +Procedure TOutputLinux.WriteLineRec (YPos: Integer; Line: TConsoleLineRec); +Var + Count : LongInt; +Begin + CursorXY(1, YPos); + + For Count := 1 to 80 Do + BufAddStr(AttrToAnsi(Line[Count].Attributes) + Line[Count].UnicodeChar); + + BufFlush; + +// For Count := 1 to 80 Do Begin +// FTextAttr := Line[Count].Attributes; +// WriteChar(Line[Count].UnicodeChar); +// End; + + Buffer[YPos] := Line; +End; + +Constructor TOutputLinux.Create (A: Boolean); +Begin + Inherited Create; + +// SaveRawSettings(SavedTerm); + + SetRawMode(True); + + Active := A; + OutBufPos := 0; + FTextAttr := 7; + FWinTop := 1; + FWinBot := 25; + ScreenSize := 25; + + RawWriteStr (#27 + '(U' + #27 + '[0m'); + + ClearScreen; +End; + +Destructor TOutputLinux.Destroy; +Begin + WriteLine(''); + + BufFlush; + +// RestoreRawSettings(SavedTerm); + SetRawMode(False); + + Inherited Destroy; +End; + +Const + AnsiTable : String[8] = '04261537'; + +Function TOutputLinux.AttrToAnsi (Attr: Byte) : String; +Var + Str : String[16]; + OldFG : LongInt; + OldBG : LongInt; + FG : LongInt; + BG : LongInt; + + Procedure AddSep (Ch: Char); + Begin + If Length(Str) > 0 Then + Str := Str + ';'; + Str := Str + Ch; + End; + +Begin + If Attr = FTextAttr Then Begin + AttrToAnsi := ''; + Exit; + End; + + Str := ''; + FG := Attr and $F; + BG := Attr shr 4; + OldFG := FTextAttr and $F; + OldBG := FTextAttr shr 4; + + If (OldFG <> 7) or (FG = 7) or ((OldFG > 7) and (FG < 8)) or ((OldBG > 7) and (BG < 8)) Then Begin + Str := '0'; + OldFG := 7; + OldBG := 0; + End; + + If (FG > 7) and (OldFG < 8) Then Begin + AddSep('1'); + OldFG := OldFG or 8; + End; + + If (BG and 8) <> (OldBG and 8) Then Begin + AddSep('5'); + OldBG := OldBG or 8; + End; + + If (FG <> OldFG) Then Begin + AddSep('3'); + Str := Str + AnsiTable[(FG and 7) + 1]; + End; + + If (BG <> OldBG) Then Begin + AddSep('4'); + Str := Str + AnsiTable[(BG and 7) + 1]; + End; + + FTextAttr := FG + BG * 16; + AttrToAnsi := #27 + '[' + Str + 'm'; +End; + +Procedure TOutputLinux.BufFlush; +Begin + If OutBufPos > 0 Then Begin + If Active Then fpWrite (ConOut, OutBuffer[1], OutBufPos); + OutBufPos := 0; + End; +End; + +Procedure TOutputLinux.BufAddStr (Str: String); +Var + Count : LongInt; +Begin + For Count := 1 to Length(Str) Do Begin + Inc (OutBufPos); + OutBuffer[OutBufPos] := Str[Count]; + If OutBufPos = ConBufSize Then BufFlush; + End; +End; + +Procedure TOutputLinux.SetTextAttr (Attr: Byte); +Begin + If Attr = FTextAttr Then Exit; + + BufAddStr(AttrToAnsi(Attr)); + + FTextAttr := Attr; +End; + +Procedure TOutputLinux.CursorXY (X, Y: Byte); +Begin + If (Y < 1) Then Y := 1 Else +// If (Y > FWinBot) Then Y := FWinBot; {changed 109a4} + If (Y > ScreenSize) Then Y := ScreenSize; + If (X < 1) Then X := 1 Else + If (X > 80) Then X := 80; + + BufAddStr(#27 + '[' + strI2S(Y) + ';' + strI2S(X) + 'H'); + BufFlush; + + FCursorX := X; + FCursorY := Y; +End; + +Procedure TOutputLinux.ClearScreen; +Var + Fill : TCharInfo; + Count : Byte; +Begin + BufFlush; + + Fill.Attributes := FTextAttr; + Fill.UnicodeChar := ' '; + + If (FWinTop = 1) and (FWinBot = {25}ScreenSize) Then Begin + BufAddStr(#27 + '[2J'); + FillWord (Buffer, SizeOf(Buffer) DIV 2, Word(Fill)); + End Else Begin + For Count := FWinTop to FWinBot Do Begin + BufAddStr (#27 + '[' + strI2S(Count) + ';1H' + #27 + '[K'); + FillWord (Buffer[Count][1], SizeOf(TConsoleLineRec) DIV 2, Word(Fill)); + End; + End; + + CursorXY (1, FWinTop); +End; + +Procedure TOutputLinux.SetScreenSize (Mode: Byte); +Begin + FWinBot := Mode; + ScreenSize := Mode; + + BufFlush; + RawWriteStr(#27 + '[8;' + strI2S(Mode) + ';80t'); + SetWindow(1, 1, 80, Mode, False); +//need to figure this out. + +//esc[8;h;w +End; + +Procedure TOutputLinux.SetWindow (X1, Y1, X2, Y2: Byte; Home: Boolean); +Begin + // X1 and X2 are ignored in Linux and are only here for compatibility + // reasons. + + FWinTop := Y1; + FWinBot := Y2; + + BufAddStr (#27 + '[' + strI2S(Y1) + ';' + strI2S(Y2) + 'r'); + BufFlush; + + If Home Then CursorXY (1, Y1); + + If (FCursorY > Y2) Then CursorXY (CursorX, Y2); + +// If Home or (FCursorY < Y1) or (FCursorY > Y2) Then CursorXY(1, Y1); + { this home thing is shady. compare it to win. going from 50 to 25 } + { will screw up the buffers - this has to be more elegant. } +End; + +Procedure TOutputLinux.SetWindowTitle (Str: String); +Begin + RawWriteStr (#27 + ']0;' + Str + #07); +End; + +Procedure TOutputLinux.ClearEOL; +Var + Fill : TCharInfo; +Begin + BufAddStr(#27 + '[K'); + + Fill.Attributes := 7; + Fill.UnicodeChar := ' '; + + FillWord (Buffer[CursorY][CursorX], (80 - CursorX) * 2, Word(Fill)); +End; + +Procedure TOutputLinux.ScrollWindow; +Begin + Move (Buffer[2][1], Buffer[1][1], SizeOf(TConsoleLineRec) * (FWinBot - 1)); + FillChar(Buffer[FWinBot][1], SizeOf(TConsoleLineRec), 0); +End; + +Procedure TOutputLinux.WriteChar (Ch: Char); +Var + A : Byte; +Begin + If Ch <> #10 Then BufAddStr(Ch); + + Case Ch of + #08 : If FCursorX > 1 Then + Dec(FCursorX); + #10 : Begin + If FCursorY < FWinBot Then Begin + BufAddStr(Ch); + Inc (FCursorY) + End Else Begin + A := FTextAttr; + SetTextAttr(7); + BufAddStr(Ch); + ScrollWindow; + SetTextAttr(A); + End; + + FCursorX := 1; + CursorXY(FCursorX, FCursorY); + + BufFlush; + End; + #13 : FCursorX := 1; + Else + Buffer[FCursorY][FCursorX].Attributes := FTextAttr; + Buffer[FCursorY][FCursorX].UnicodeChar := Ch; + + If FCursorX < 80 Then + Inc (FCursorX) + Else Begin + FCursorX := 1; + + If FCursorY < FWinBot Then + Inc (FCursorY) + Else + ScrollWindow; + + BufFlush; + End; + End; +End; + +Procedure TOutputLinux.WriteStr (Str: String); +Var + Count : Byte; +Begin + For Count := 1 to Length(Str) Do + WriteChar(Str[Count]); + + BufFlush; +End; + +Procedure TOutputLinux.WriteLine (Str: String); +Var + Count : Byte; +Begin + Str := Str + #13#10; + + For Count := 1 To Length(Str) Do + WriteChar(Str[Count]); + + BufFlush; +End; + +Procedure TOutputLinux.RawWriteStr (Str: String); +Begin + fpWrite (ConOut, Str[1], Length(Str)); +End; + +Procedure TOutputLinux.SaveRawSettings (Var TIo: TermIos); +Begin + With TIo Do Begin + TermInRaw := + ((c_iflag and (IGNBRK or BRKINT or PARMRK or ISTRIP or + INLCR or IGNCR or ICRNL or IXON)) = 0) and + ((c_lflag and (ECHO or ECHONL or ICANON or ISIG or IEXTEN)) = 0); + TermOutRaw := + ((c_oflag and OPOST) = 0) and + ((c_cflag and (CSIZE or PARENB)) = 0) and + ((c_cflag and CS8) <> 0); + End; +End; + +Procedure TOutputLinux.RestoreRawSettings (TIo: TermIos); +Begin + With TIo Do Begin + If TermInRaw Then Begin + c_iflag := c_iflag and (not (IGNBRK or BRKINT or PARMRK or ISTRIP or + INLCR or IGNCR or ICRNL or IXON)); + c_lflag := c_lflag and + (not (ECHO or ECHONL or ICANON or ISIG or IEXTEN)); + End; + + If TermOutRaw Then Begin + c_oflag := c_oflag and not(OPOST); + c_cflag := c_cflag and not(CSIZE or PARENB) or CS8; + End; + End; +End; + +Procedure TOutputLinux.SetRawMode (SetOn: Boolean); +Var + Tio : TermIos; +Begin + If SetOn Then Begin + TCGetAttr(1, Tio); + SaveRawSettings(Tio); + TermInfo := Tio; + CFMakeRaw(Tio); + End Else Begin + RestoreRawSettings(TermInfo); + Tio := TermInfo; + End; + + TCSetAttr(1, TCSANOW, Tio); +End; + +Function TOutputLinux.ReadCharXY (X, Y: Byte) : Char; +Begin + ReadCharXY := Buffer[Y][X].UnicodeChar; +End; + +Function TOutputLinux.ReadAttrXY (X, Y: Byte) : Byte; +Begin + ReadAttrXY := Buffer[Y][X].Attributes; +End; + +Procedure TOutputLinux.WriteXY (X, Y, A: Byte; Text: String); +Var + OldAttr : Byte; + OldX : Byte; + OldY : Byte; + Count : Byte; +Begin + If X > 80 Then Exit; + + OldAttr := FTextAttr; + OldX := FCursorX; + OldY := FCursorY; + + CursorXY (X, Y); + SetTextAttr (A); + + For Count := 1 to Length(Text) Do + If FCursorX <= 80 Then Begin + Buffer[FCursorY][FCursorX].Attributes := FTextAttr; + Buffer[FCursorY][FCursorX].UnicodeChar := Text[Count]; + + Inc (FCursorX); + + BufAddStr(Text[Count]); + End Else + Break; + + SetTextAttr(OldAttr); + CursorXY (OldX, OldY); + + BufFlush; +End; + +Procedure TOutputLinux.WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); + + Procedure AddChar (Ch: Char); + Begin + If CursorX > 80 Then Exit; + + Buffer[CursorY][CursorX].Attributes := FTextAttr; + Buffer[CursorY][CursorX].UnicodeChar := Ch; + + BufAddStr(Ch); + + Inc (FCursorX); + End; + +Var + Count : Byte; + Code : String[2]; + CodeNum : Byte; + OldAttr : Byte; + OldX : Byte; + OldY : Byte; +Begin + OldAttr := FTextAttr; + OldX := FCursorX; + OldY := FCursorY; + + CursorXY (X, Y); + SetTextAttr (Attr); + + Count := 1; + + While Count <= Length(Text) Do Begin + If Text[Count] = '|' Then Begin + Code := Copy(Text, Count + 1, 2); + CodeNum := strS2I(Code); + + If (Code = '00') or ((CodeNum > 0) and (CodeNum < 24) and (Code[1] <> '&') and (Code[1] <> '$')) Then Begin + Inc (Count, 2); + If CodeNum in [00..15] Then + SetTextAttr (CodeNum + ((FTextAttr SHR 4) AND 7) * 16) + Else + SetTextAttr ((FTextAttr AND $F) + (CodeNum - 16) * 16); + End Else Begin + AddChar(Text[Count]); + Dec (Pad); + End; + End Else Begin + AddChar(Text[Count]); + Dec (Pad); + End; + + If Pad = 0 Then Break; + + Inc (Count); + End; + + While Pad > 0 Do Begin + AddChar(' '); + Dec(Pad); + End; + + SetTextAttr(OldAttr); + CursorXY (OldX, OldY); + + BufFlush; +End; + +Procedure TOutputLinux.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +//Var +// Count : Byte; +Begin +// If X2 > 80 Then X2 := 80; +// If Y2 > FWinBot Then Y2 := FWinBot; + + FillChar(Image, SizeOf(Image), #0); + + Image.Data := Buffer; +// For Count := Y1 to Y2 Do Begin +// Image.Data[Count] := Buffer[Count]; + + Image.CursorX := FCursorX; + Image.CursorY := FCursorY; + Image.CursorA := FTextAttr; + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; +End; + +Procedure TOutputLinux.PutScreenImage (Image: TConsoleImageRec); +Var + CountX : Byte; + CountY : Byte; +Begin + For CountY := Image.Y1 to Image.Y2 Do Begin + CursorXY (Image.X1, CountY); + +// Move (Image.Data[CountY][Image.X1], Buffer[CountY + Image.Y1 - 1][Image.X1], (Image.X2 - Image.X1 + 1) * SizeOf(TCharInfo)); + + For CountX := Image.X1 to Image.X2 Do Begin + SetTextAttr(Image.Data[CountY][CountX].Attributes); + BufAddStr(Image.Data[CountY][CountX].UnicodeChar); + Buffer[CountY][CountX] := Image.Data[CountY][CountX]; + End; + End; + + SetTextAttr (Image.CursorA); + CursorXY (Image.CursorX, Image.CursorY); + + BufFlush; +End; + +(* +Procedure TOutputLinux.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +Var + Count : Byte; + Line : Byte; + Temp : TConsoleLineRec; +Begin + Line := 1; + + If X2 > 80 Then X2 := 80; + If Y2 > FWinBot Then Y2 := FWinBot; + + FillChar(Image, SizeOf(Image), #0); + + For Count := Y1 to Y2 Do Begin + Move (Buffer[Count][X1], Image.Data[Line][1], (X2 - X1 + 1) * SizeOf(TCharInfo)); + Inc (Line); + End; + + Image.CursorX := FCursorX; + Image.CursorY := FCursorY; + Image.CursorA := FTextAttr; + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; +End; + +Procedure TOutputLinux.PutScreenImage (Var Image: TConsoleImageRec); +Var + CountX : Byte; + CountY : Byte; +Begin + For CountY := 1 to (Image.Y2 - Image.Y1 + 1) Do Begin + CursorXY (Image.X1, CountY + Image.Y1 - 1); + + Move (Image.Data[CountY][1], Buffer[CountY + Image.Y1 - 1][Image.X1], (Image.X2 - Image.X1 + 1) * SizeOf(TCharInfo)); + + For CountX := 1 to (Image.X2 - Image.X1 + 1) Do Begin + SetTextAttr(Image.Data[CountY][CountX].Attributes); + BufAddStr(Image.Data[CountY][CountX].UnicodeChar); + End; + End; + + SetTextAttr (Image.CursorA); + CursorXY (Image.CursorX, Image.CursorY); + + BufFlush; +End; +*) + +Procedure TOutputLinux.LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); +Var + Image : TConsoleImageRec; + Data : Array[1..8000] of Byte Absolute DataPtr; + PosX : Word; + PosY : Byte; + Attrib : Byte; + Count : Word; + A : Byte; + B : Byte; + C : Byte; +Begin + PosX := 1; + PosY := 1; + Attrib := 7; + Count := 1; + + FillChar(Image.Data, SizeOf(Image.Data), #0); + + While (Count <= Len) Do begin + Case Data[Count] of + 00.. + 15 : Attrib := Data[Count] + ((Attrib SHR 4) and 7) * 16; + 16.. + 23 : Attrib := (Attrib And $F) + (Data[Count] - 16) * 16; + 24 : Begin + Inc (PosY); + PosX := 1; + End; + 25 : Begin + Inc (Count); + + For A := 0 to Data[Count] Do Begin + Image.Data[PosY][PosX].UnicodeChar := ' '; + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 26 : Begin + A := Data[Count + 1]; + B := Data[Count + 2]; + + Inc (Count, 2); + + For C := 0 to A Do Begin + Image.Data[PosY][PosX].UnicodeChar := Char(B); + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 27.. + 31 : ; + Else + Image.Data[PosY][PosX].UnicodeChar := Char(Data[Count]); + Image.Data[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + + Inc(Count); + End; + + If PosY > ScreenSize Then PosY := ScreenSize; + + Image.CursorX := PosX; + Image.CursorY := PosY; + Image.CursorA := Attrib; + Image.X1 := X; + Image.X2 := Width; + Image.Y1 := Y; + Image.Y2 := PosY; + + PutScreenImage(Image); +End; + +Procedure TOutputLinux.ShowBuffer; +Begin +End; + +End. diff --git a/mdl/m_output_windows.pas b/mdl/m_output_windows.pas new file mode 100644 index 0000000..73e1044 --- /dev/null +++ b/mdl/m_output_windows.pas @@ -0,0 +1,733 @@ +{$I M_OPS.PAS} + +Unit m_Output_Windows; + +Interface + +Uses + Windows, + m_Types; + +Type + TOutputWindows = Class + Private + ConOut : THandle; + Cursor : TCoord; + Public + ScreenSize : Byte; + Active : Boolean; + TextAttr : Byte; + Buffer : TConsoleScreenRec; + LineBuf : TConsoleLineRec; + Window : TSmallRect; + + Constructor Create (A: Boolean); + Destructor Destroy; Override; + Procedure ClearScreen; Virtual; + Procedure ClearScreenNoUpdate; + Procedure ScrollWindow; Virtual; + Procedure ClearEOL; + Procedure CursorXY (X, Y: Byte); + Function CursorX : Byte; + Function CursorY : Byte; + Procedure SetScreenSize (Mode: Byte); + Procedure SetWindowTitle (Title: String); + Procedure SetWindow (X1, Y1, X2, Y2: Byte; Home: Boolean); + Procedure GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); + Procedure PutScreenImage (Var Image: TConsoleImageRec); + Procedure LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); + Procedure WriteXY (X, Y, A: Byte; Text: String); + Procedure WriteXYNoUpdate (X, Y, A: Byte; Text: String); + Procedure WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); + Procedure WriteLineRec (YPos: Integer; Line: TConsoleLineRec); + Function ReadCharXY (X, Y: Byte) : Char; + Function ReadAttrXY (X, Y: Byte) : Byte; + Procedure WriteChar (Ch: Char); + Procedure WriteLine (Str: String); + Procedure WriteStr (Str: String); + Procedure ShowBuffer; + Procedure BufFlush; // Linux compatibility only + +// Property ScreenSize : Byte Read FScreenSize; +// Property TextAttr : Byte Read FTextAttr Write FTextAttr; + End; + +Implementation + +Uses + m_Strings; + +Procedure TOutputWindows.WriteLineRec (YPos: Integer; Line: TConsoleLineRec); +Var + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; +Begin + BufSize.X := 80; + BufSize.Y := 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := 0; + Region.Top := YPos - 1; + Region.Right := 79; + Region.Bottom := YPos - 1; + + WriteConsoleOutput(ConOut, @Line, BufSize, BufCoord, Region); +End; + +Procedure TOutputWindows.SetWindow (X1, Y1, X2, Y2 : Byte; Home: Boolean); +Begin + If (X1 > X2) or (X2 > 80) or + (Y1 > Y2) or (Y2 > ScreenSize) Then Exit; + + Window.Left := X1 - 1; + Window.Top := Y1 - 1; + Window.Right := X2 - 1; + Window.Bottom := Y2 - 1; + + If Home Then CursorXY (X1, Y1) Else CursorXY (Cursor.X + 1, Cursor.Y + 1); +End; + +Constructor TOutputWindows.Create (A: Boolean); +Var + ScreenMode : TConsoleScreenBufferInfo; + CursorInfo : TConsoleCursorInfo; +Begin + Inherited Create; + + Active := A; + ConOut := GetStdHandle(STD_OUTPUT_HANDLE); + + GetConsoleScreenBufferInfo(ConOut, ScreenMode); + + Case ScreenMode.dwSize.Y of + 25 : ScreenSize := 25; + 50 : ScreenSize := 50; + Else + SetScreenSize(25); + ScreenSize := 25; + End; + + CursorInfo.bVisible := True; + CursorInfo.dwSize := 15; + + SetConsoleCursorInfo(ConOut, CursorInfo); + + Window.Top := 0; + Window.Left := 0; + Window.Right := 79; + Window.Bottom := ScreenSize - 1; + + TextAttr := 7; + + ClearScreen; +End; + +Destructor TOutputWindows.Destroy; +Begin + Inherited Destroy; +End; + +Procedure TOutputWindows.SetScreenSize (Mode: Byte); +Var + Size : TCoord; +Begin + If (Mode = ScreenSize) Or Not (Mode in [25, 50]) Then Exit; + + Size.X := 80; + Size.Y := Mode; + + Window.Top := 0; + Window.Left := 0; + Window.Right := Size.X - 1; + Window.Bottom := Size.Y - 1; + + SetConsoleScreenBufferSize (ConOut, Size); + SetConsoleWindowInfo (ConOut, True, Window); + SetConsoleScreenBufferSize (ConOut, Size); + + ScreenSize := Mode; +End; + +Procedure TOutputWindows.CursorXY (X, Y: Byte); +Begin + // don't move to x/y coordinate outside of window + + Cursor.X := X - 1; + Cursor.Y := Y - 1; + + If Cursor.X < Window.Left Then Cursor.X := Window.Left Else + If Cursor.X > Window.Right Then Cursor.X := Window.Right; + If Cursor.Y < Window.Top Then Cursor.Y := Window.Top Else + If Cursor.Y > Window.Bottom Then Cursor.Y := Window.Bottom; + + If Active Then + SetConsoleCursorPosition(ConOut, Cursor); +End; + +Procedure TOutputWindows.ClearEOL; +Var + Buf : Array[1..80] of TCharInfo; + Count : Byte; + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; +Begin + Count := 0; + + While Count <= Window.Right - Cursor.X Do Begin + Inc (Count); + Buf[Count].Attributes := TextAttr; + Buf[Count].UnicodeChar := ' '; + End; + + Move(Buf[1], Buffer[Cursor.Y + 1][Cursor.X + 1], Count); + + If Active Then Begin + BufSize.X := Count; + BufSize.Y := 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := Cursor.X; + Region.Top := Cursor.Y; + Region.Right := Cursor.X + Count - 1; + Region.Bottom := Cursor.Y; + + WriteConsoleOutput(ConOut, @Buf, BufSize, BufCoord, Region); + End; +End; + +Procedure TOutputWindows.ClearScreenNoUpdate; +Var + Res : ULong; + Count : Byte; + Size : Byte; + Cell : TCharInfo; +Begin + Size := Window.Right - Window.Left + 1; + Cursor.X := Window.Left; + Cell.Attributes := TextAttr; + Cell.UnicodeChar := ' '; + + For Count := Window.Top To Window.Bottom Do Begin + Cursor.Y := Count; + + FillConsoleOutputAttribute(ConOut, Cell.Attributes, Size, Cursor, Res); + FillConsoleOutputCharacter(ConOut, ' ', Size, Cursor, Res); + End; +End; + +Procedure TOutputWindows.ClearScreen; +Var + Res : ULong; + Count : Byte; + Size : Byte; + Cell : TCharInfo; +Begin + Size := Window.Right - Window.Left + 1; + Cursor.X := Window.Left; + Cell.Attributes := TextAttr; + Cell.UnicodeChar := ' '; + + If Active Then Begin + For Count := Window.Top To Window.Bottom Do Begin + Cursor.Y := Count; + + FillConsoleOutputAttribute(ConOut, Cell.Attributes, Size, Cursor, Res); + FillConsoleOutputCharacter(ConOut, ' ', Size, Cursor, Res); + End; + End; + + FillChar (Buffer, SizeOf(Buffer), 0); + + CursorXY (Window.Left + 1, Window.Top + 1); +End; + +Procedure TOutputWindows.SetWindowTitle (Title: String); +Begin + Title := Title + #0; + SetConsoleTitle(@Title[1]); +End; + +Procedure TOutputWindows.WriteXY (X, Y, A: Byte; Text: String); +Var + Buf : Array[1..80] of TCharInfo; + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; + Count : Byte; +Begin + Count := 1; + + While Count <= Length(Text) Do Begin + Buf[Count].Attributes := A; + Buf[Count].UnicodeChar := Text[Count]; + Inc (Count); + End; + + // add to screen buffer + Move (Buf[1], Buffer[Y][X], (Count - 1) * SizeOf(TCharInfo)); + + If Active Then Begin + BufSize.X := Count - 1; + BufSize.Y := 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := X - 1; + Region.Top := Y - 1; + Region.Right := X + Count - 1; + Region.Bottom := Y - 1; + + If Region.Right > 79 Then Region.Right := 79; + + WriteConsoleOutput(ConOut, @Buf, BufSize, BufCoord, Region); + End; +End; + +Procedure TOutputWindows.WriteXYNoUpdate (X, Y, A: Byte; Text: String); +Var + Buf : Array[1..80] of TCharInfo; + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; + Count : Byte; +Begin + Count := 1; + + While Count <= Length(Text) Do Begin + Buf[Count].Attributes := A; + Buf[Count].UnicodeChar := Text[Count]; + Inc (Count); + End; + + BufSize.X := Count - 1; + BufSize.Y := 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := X - 1; + Region.Top := Y - 1; + Region.Right := X + Count - 1; + Region.Bottom := Y - 1; + + If Region.Right > 79 Then Region.Right := 79; + + WriteConsoleOutput(ConOut, @Buf, BufSize, BufCoord, Region); +End; + +Procedure TOutputWindows.WriteXYPipe (X, Y, Attr, Pad: Integer; Text: String); +Var + Buf : Array[1..80] of TCharInfo; + BufPos : Byte; + Count : Byte; + Code : String[2]; + CodeNum : Byte; + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; + + Procedure AddChar; + Begin + Inc (BufPos); + + Buf[BufPos].Attributes := Attr; + Buf[BufPos].UnicodeChar := Text[Count]; + End; + +Begin + FillChar(Buf, SizeOf(Buf), #0); + + Count := 1; + BufPos := 0; + + While Count <= Length(Text) Do Begin + If Text[Count] = '|' Then Begin + Code := Copy(Text, Count + 1, 2); + CodeNum := strS2I(Code); + + If (Code = '00') or ((CodeNum > 0) and (CodeNum < 24) and (Code[1] <> '$') and (Code[1] <> '&')) Then Begin + Inc (Count, 2); + If CodeNum in [00..15] Then + Attr := CodeNum + ((Attr SHR 4) AND 7) * 16 + Else + Attr := (Attr AND $F) + (CodeNum - 16) * 16; + End Else + AddChar; + End Else + AddChar; + + If BufPos = Pad Then Break; + + Inc (Count); + End; + + Text[1] := #32; + Count := 1; + + While BufPos < Pad Do AddChar; + + BufSize.X := Pad; + BufSize.Y := 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := X - 1; + Region.Top := Y - 1; + Region.Right := X + Pad; + Region.Bottom := Y - 1; + + If Region.Right > 79 Then Region.Right := 79; + + Move (Buf[1], Buffer[Y][X], BufSize.X * SizeOf(TCharInfo)); + + If Active Then + WriteConsoleOutput(ConOut, @Buf, BufSize, BufCoord, Region); +End; + +Function TOutputWindows.CursorX : Byte; +Begin + CursorX := Cursor.X + 1; +End; + +Function TOutputWindows.CursorY : Byte; +Begin + CursorY := Cursor.Y + 1; +End; + +Procedure TOutputWindows.WriteChar (Ch: Char); +Var + BufferSize, + BufferCoord : TCoord; + WriteRegion : TSmallRect; + OneCell : TCharInfo; +Begin + Case Ch of + #08 : If Cursor.X > Window.Left Then Begin + Dec(Cursor.X); + If Active Then SetConsoleCursorPosition(ConOut, Cursor); + End; + #10 : Begin + If Cursor.Y = Window.Bottom Then + ScrollWindow + Else Begin + Inc (Cursor.Y); + Cursor.X := Window.Left; + End; + + If Active Then SetConsoleCursorPosition(ConOut, Cursor); + End; + #13 : Cursor.X := Window.Left; + Else + If Active Then Begin + OneCell.UnicodeChar := Ch; + OneCell.Attributes := TextAttr; + + BufferSize.X := 1; + BufferSize.Y := 1; + BufferCoord.X := 0; + BufferCoord.Y := 0; + + WriteRegion.Left := Cursor.X; + WriteRegion.Top := Cursor.Y; + WriteRegion.Right := Cursor.X; + WriteRegion.Bottom := Cursor.Y; + + WriteConsoleOutput (ConOut, @OneCell, BufferSize, BufferCoord, WriteRegion); + End; + + Buffer[Cursor.Y + 1][Cursor.X + 1].UnicodeChar := Ch; + Buffer[Cursor.Y + 1][Cursor.X + 1].Attributes := TextAttr; + + If Cursor.X < Window.Right Then + Inc (Cursor.X) + Else Begin + If (Cursor.X = Window.Right) And (Cursor.Y = Window.Bottom - 1) Then Begin + Inc (Cursor.X); + Exit; + End; + + Cursor.X := Window.Left; + + If Cursor.Y = Window.Bottom Then + ScrollWindow + Else + Inc (Cursor.Y); + End; + + If Active Then SetConsoleCursorPosition(ConOut, Cursor); + End; +End; + +Procedure TOutputWindows.WriteLine (Str: String); +Var + Count : Byte; +Begin + Str := Str + #13#10; + + For Count := 1 to Length(Str) Do WriteChar(Str[Count]); +End; + +Procedure TOutputWindows.WriteStr (Str: String); +Var + Count : Byte; +Begin + For Count := 1 to Length(Str) Do WriteChar(Str[Count]); +End; + +Procedure TOutputWindows.ScrollWindow; +Var + ClipRect, + ScrollRect : TSmallRect; + DestCoord : TCoord; + Fill : TCharInfo; +Begin + Fill.UnicodeChar := ' '; +// Fill.Attributes := TextAttr; + Fill.Attributes := 7; + + ScrollRect.Left := Window.Left; + ScrollRect.Top := Window.Top; + ScrollRect.Right := Window.Right; + ScrollRect.Bottom := Window.Bottom; + + // might not need cliprect... might be able to pass scrollrect twice + + ClipRect := ScrollRect; + + DestCoord.X := Window.Left; + DestCoord.Y := Window.Top - 1; + + If Active Then + ScrollConsoleScreenBuffer(ConOut, ScrollRect, ClipRect, DestCoord, PCharInfo(@Fill)^); + + Move (Buffer[2][1], Buffer[1][1], SizeOf(TConsoleLineRec) * 49); + FillChar(Buffer[Window.Bottom + 1][1], SizeOf(TConsoleLineRec), #0); +End; + +Procedure TOutputWindows.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +Var + CountY : Byte; + CountX : Byte; + BufPos : Integer; + NewBuf : Array[1..SizeOf(TConsoleScreenRec) DIV 2] of Word Absolute Image.Data; +Begin + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; + Image.CursorX := CursorX; + Image.CursorY := CursorY; + Image.CursorA := TextAttr; + + BufPos := 1; + + For CountY := Y1 to Y2 Do Begin + For CountX := X1 to X2 Do Begin + NewBuf[BufPos] := Word(Buffer[CountY][CountX].UnicodeChar); + NewBuf[BufPos+1] := Buffer[CountY][CountX].Attributes; + Inc (BufPos, 2); + End; + End; +End; + +(* +Procedure TOutputWindows.GetScreenImage (X1, Y1, X2, Y2: Byte; Var Image: TConsoleImageRec); +Var + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; +// x,y,cx,cy:byte; +Begin + BufSize.X := X2 - X1 + 1; + BufSize.Y := Y2 - Y1 + 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := X1 - 1; + Region.Top := Y1 - 1; + Region.Right := X2 - 1; + Region.Bottom := Y2 - 1; + Image.X1 := X1; + Image.X2 := X2; + Image.Y1 := Y1; + Image.Y2 := Y2; + Image.CursorX := CursorX; + Image.CursorY := CursorY; + Image.CursorA := TextAttr; + + If Active Then + ReadConsoleOutput (ConOut, @Image.Data[1][1], BufSize, BufCoord, Region) + Else + Image.Data := Buffer; +End; +*) + +Procedure TOutputWindows.ShowBuffer; +Var + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; +Begin + BufSize.X := 80; + BufSize.Y := ScreenSize; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := 0; + Region.Top := 0; + Region.Right := 79; + Region.Bottom := ScreenSize - 1; + + WriteConsoleOutput (ConOut, @Buffer[1][1], BufSize, BufCoord, Region); + + CursorXY (Cursor.X + 1, Cursor.Y + 1); +End; + +Procedure TOutputWindows.PutScreenImage (Var Image: TConsoleImageRec); +Var + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; + + CountX : Byte; + CountY : Byte; + BufPos : Integer; + TempBuf : Array[1..SizeOf(TConsoleScreenRec) DIV 4] of LongInt Absolute Image.Data; +Begin + BufSize.X := Image.X2 - Image.X1 + 1; + BufSize.Y := Image.Y2 - Image.Y1 + 1; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := Image.X1 - 1; + Region.Top := Image.Y1 - 1; + Region.Right := Image.X2 - 1; + Region.Bottom := Image.Y2 - 1; + + WriteConsoleOutput (ConOut, @Image.Data[1][1], BufSize, BufCoord, Region); + + BufPos := 1; + + For CountY := Image.Y1 to Image.Y2 Do + For CountX := Image.X1 to Image.X2 Do Begin + Buffer[CountY][CountX] := TCharInfo(TempBuf[BufPos]); + Inc(BufPos); + End; + + CursorXY (Image.CursorX, Image.CursorY); + + TextAttr := Image.CursorA; +End; + +Procedure TOutputWindows.LoadScreenImage (Var DataPtr; Len, Width, X, Y: Integer); +Var + Screen : TConsoleScreenRec; + Data : Array[1..8000] of Byte Absolute DataPtr; + PosX : Word; + PosY : Byte; + Attrib : Byte; + Count : Word; + A : Byte; + B : Byte; + C : Byte; + BufSize : TCoord; + BufCoord : TCoord; + Region : TSmallRect; +Begin + PosX := 1; + PosY := 1; + Attrib := 7; + Count := 1; + + FillChar(Screen, SizeOf(Screen), #0); + + While (Count <= Len) Do Begin + Case Data[Count] of + 00.. + 15 : Attrib := Data[Count] + ((Attrib SHR 4) and 7) * 16; + 16.. + 23 : Attrib := (Attrib And $F) + (Data[Count] - 16) * 16; + 24 : Begin + Inc (PosY); + PosX := 1; + End; + 25 : Begin + Inc (Count); + For A := 0 to Data[Count] Do Begin + Screen[PosY][PosX].UnicodeChar := ' '; + Screen[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 26 : Begin + A := Data[Count + 1]; + B := Data[Count + 2]; + + Inc (Count, 2); + + For C := 0 to A Do Begin + Screen[PosY][PosX].UnicodeChar := Char(B); + Screen[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + End; + 27.. + 31 : ; + Else + Screen[PosY][PosX].UnicodeChar := Char(Data[Count]); + Screen[PosY][PosX].Attributes := Attrib; + + Inc (PosX); + End; + + Inc (Count); + End; + + //If PosY > ScreenSize Then PosY := ScreenSize; + + BufSize.Y := PosY - (Y - 1); + BufSize.X := Width; + BufCoord.X := 0; + BufCoord.Y := 0; + Region.Left := X - 1; + Region.Top := Y - 1; + Region.Right := Width - 1; + Region.Bottom := PosY - 1; + + WriteConsoleOutput (ConOut, @Screen[1][1], BufSize, BufCoord, Region); + + CursorXY(PosX, PosY); +End; + +Function TOutputWindows.ReadCharXY (X, Y: Byte) : Char; +//Var +// Coord : TCoord; +// WasRead : ULong; +Begin +// Coord.X := X; +// Coord.Y := Y - 1; + + // should use buffer instead + +// ReadConsoleOutputCharacter(ConOut, @Result, 1, Coord, WasRead); + + Result := Buffer[Y][X].UnicodeChar; +End; + +Function TOutputWindows.ReadAttrXY (X, Y: Byte) : Byte; +//Var +// Coord : TCoord; +// WasRead : ULong; +Begin +// Coord.X := X; +// Coord.Y := Y - 1; + + // should use buffer instead + + Result := Buffer[Y][X].Attributes; + +// ReadConsoleOutputAttribute(ConOut, @Result, 1, Coord, WasRead); +End; + +Procedure TOutputWindows.BufFlush; +Begin +End; + +End. diff --git a/mdl/m_socket_class.pas b/mdl/m_socket_class.pas new file mode 100644 index 0000000..c30d906 --- /dev/null +++ b/mdl/m_socket_class.pas @@ -0,0 +1,570 @@ +{$I M_OPS.PAS} + +Unit m_Socket_Class; + +Interface + +Uses + {$IFDEF WIN32} + Windows, + Winsock2, + {$ENDIF} + {$IFDEF UNIX} + BaseUnix, + cNetDB, + {$ENDIF} + Sockets, + Classes, + m_DateTime, + m_Strings; + +Const + TSocketBufferSize = 8 * 1024 - 1; + +Type + TSocketBuffer = Array[0..TSocketBufferSize] of Char; + + TSocketClass = Class + SocketStatus : TStringList; + StatusUpdated : Boolean; + FSocketHandle : LongInt; + FPort : LongInt; + FPeerName : String; + FPeerIP : String; + FHostIP : String; + FInBuf : TSocketBuffer; + FInBufPos : LongInt; + FInBufEnd : LongInt; + FOutBuf : TSocketBuffer; + FOutBufPos : LongInt; + FTelnetState : Byte; + FTelnetReply : Array[1..14] of Char; + FTelnetCmd : Char; + FTelnetSubCmd : Char; + FTelnetLen : Byte; + FTelnetEcho : Boolean; + FTelnetSubData : String; + FTelnetClient : Boolean; + FTelnetServer : Boolean; + + Constructor Create; + Destructor Destroy; Override; + Procedure Disconnect; + Function DataWaiting : Boolean; + Function WriteBuf (Var Buf; Len: LongInt) : LongInt; + Procedure BufFlush; + Procedure BufWriteChar (Ch: Char); + Procedure BufWriteStr (Str: String); + Function WriteLine (Str: String) : LongInt; + Function WriteStr (Str: String) : LongInt; + Function WriteFile (Str: String) : Boolean; + Procedure ProcessBuf (Var Buf: TSocketBuffer; Var Len: LongInt); + Function ReadBuf (Var Buf; Len: LongInt) : LongInt; + Function ReadLine (Var Str: String) : LongInt; + Function SetBlocking (Block: Boolean): LongInt; + Function WaitForData (TimeOut: LongInt) : LongInt; + Function Connect (Address: String; Port: Word) : Boolean; + Function ResolveAddress (Host: String) : LongInt; + Procedure WaitInit (Port: Word); + Function WaitConnection : TSocketClass; + + Procedure PurgeInputData; + Function ReadChar : Char; + Function WriteChar (Ch: Char) : LongInt; + + Procedure Status (Str: String); + + Property SocketHandle : LongInt READ FSocketHandle WRITE FSocketHandle; + Property PeerPort : LongInt READ FPort WRITE FPort; + Property PeerName : String READ FPeerName WRITE FPeerName; + Property PeerIP : String READ FPeerIP WRITE FPeerIP; + Property HostIP : String READ FHostIP WRITE FHostIP; + End; + +Implementation + +{ TELNET NEGOTIATION CONSTANTS } + +Const + Telnet_IAC = #255; + Telnet_DONT = #254; + Telnet_DO = #253; + Telnet_WONT = #252; + Telnet_WILL = #251; + Telnet_SB = #250; + Telnet_BINARY = #000; + Telnet_ECHO = #001; + Telnet_SE = #240; + Telnet_TERM = #24; + Telnet_SGA = #003; + + FPSENDOPT = 0; + FPRECVOPT = 0; + +Constructor TSocketClass.Create; +Begin + Inherited Create; + + FSocketHandle := -1; + FPort := 0; + FPeerName := 'Unknown'; + FPeerIP := FPeerName; + FInBufPos := 0; + FInBufEnd := 0; + FOutBufPos := 0; + FTelnetState := 0; + FTelnetEcho := False; + FTelnetClient := False; + FTelnetServer := False; +{ FHostIP := '127.0.0.1';} + FHostIP := ''; + StatusUpdated := False; + + SocketStatus := TStringList.Create; +End; + +Destructor TSocketClass.Destroy; +Begin + Disconnect; + + SocketStatus.Free; + + Inherited Destroy; +End; + +Procedure TSocketClass.PurgeInputData; +Var + Buf : Array[1..1024] of Char; +Begin + If FSocketHandle = -1 Then Exit; + + If DataWaiting Then + Repeat + Until ReadBuf(Buf, SizeOf(Buf)) <> 1024; +End; + +Procedure TSocketClass.Disconnect; +Begin + If FSocketHandle <> -1 Then Begin + fpShutdown(FSocketHandle, 2); + CloseSocket(FSocketHandle); + + FSocketHandle := -1; + End; +End; + +Function TSocketClass.DataWaiting : Boolean; +Begin + Result := (FInBufPos < FInBufEnd) or (WaitForData(0) > 0); +End; + +Function TSocketClass.WriteBuf (Var Buf; Len: LongInt) : LongInt; +Begin + Result := fpSend(FSocketHandle, @Buf, Len, FPSENDOPT); +End; + +Procedure TSocketClass.BufFlush; +Begin + If FOutBufPos > 0 Then Begin + WriteBuf (FOutBuf, FOutBufPos); + FOutBufPos := 0; + End; +End; + +Procedure TSocketClass.BufWriteChar (Ch: Char); +Begin + FOutBuf[FOutBufPos] := Ch; + Inc(FOutBufPos); + + If FOutBufPos > TSocketBufferSize Then Begin + WriteBuf (FOutBuf, FOutBufPos - 1); + FOutBufPos := 0; + End; +End; + +Procedure TSocketClass.BufWriteStr (Str: String); +Var + Count : LongInt; +Begin + For Count := 1 to Length(Str) Do + BufWriteChar(Str[Count]); +End; + +Function TSocketClass.WriteLine (Str: String) : LongInt; +Begin + Str := Str + #13#10; + Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT); +End; + +Function TSocketClass.WriteChar (Ch: Char) : LongInt; +Begin + Result := fpSend(FSocketHandle, @Ch, 1, FPSENDOPT); +End; + +Function TSocketClass.WriteStr (Str: String) : LongInt; +Begin + Result := fpSend(FSocketHandle, @Str[1], Length(Str), FPSENDOPT); +End; + +Function TSocketClass.WriteFile (Str: String) : Boolean; +Var + Buf : Array[1..4096] of Char; + Size : LongInt; + F : File; +Begin + Result := False; + + FileMode := 66; + + Assign (F, Str); + Reset (F, 1); + + If IoResult <> 0 Then Exit; + + Repeat + BlockRead (F, Buf, SizeOf(Buf), Size); + + If Size = 0 Then Break; + + If Buf[Size] = #26 Then Dec(Size); + + WriteBuf (Buf, Size); + Until Size <> SizeOf(Buf); + + Result := True; +End; + +Procedure TSocketClass.ProcessBuf (Var Buf: TSocketBuffer; Var Len: LongInt); + + Procedure SendCommand (YesNo, CmdType: Char); + Var + Reply : String[3]; + Begin + Reply[1] := Telnet_IAC; + Reply[2] := Char(YesNo); {DO/DONT, WILL/WONT} + Reply[3] := CmdType; + + fpSend (FSocketHandle, @Reply[1], 3, FPSENDOPT); + End; + + Procedure SendData (CmdType: Char; Data: String); + Var + Reply : String; + DataLen : Byte; + Begin + DataLen := Length(Data); + Reply[1] := Telnet_IAC; + Reply[2] := Telnet_SB; + Reply[3] := CmdType; + Reply[4] := #0; + + Move (Data[1], Reply[5], DataLen); + + Reply[5 + DataLen] := #0; + Reply[6 + DataLen] := Telnet_IAC; + Reply[7 + DataLen] := Telnet_SE; + + fpSend (FSocketHandle, @Reply[1], 7 + DataLen, FPSENDOPT); + End; + +Var + Count : LongInt; + TempPos : LongInt; + Temp : TSocketBuffer; + ReplyGood : Char; + ReplyBad : Char; +Begin + TempPos := 0; + + For Count := 0 to Len - 1 Do Begin + Case FTelnetState of + 1 : If Buf[Count] = Telnet_IAC Then Begin + FTelnetState := 0; + Temp[TempPos] := Telnet_IAC; + Inc (TempPos); + End Else Begin + Inc (FTelnetState); + FTelnetCmd := Buf[Count]; + End; + 2 : Begin + FTelnetState := 0; + + Case FTelnetCmd of + Telnet_WONT : Begin +// FTelnetSubCmd := Telnet_DONT; +// SockSend(FSocketHandle, FTelnetSubCmd, 1, 0); + End; + Telnet_DONT : Begin +// FTelnetSubCmd := Telnet_WONT; +// SockSend(FSocketHandle, FTelnetSubCmd, 1, 0); + End; + Telnet_SB : Begin + FTelnetState := 3; + FTelnetSubCmd := Buf[Count]; + End; + Telnet_WILL, + Telnet_DO : Begin + If FTelnetCmd = Telnet_DO Then Begin + ReplyGood := Telnet_WILL; + ReplyBad := Telnet_WONT; + End Else Begin + ReplyGood := Telnet_DO; + ReplyBad := Telnet_DONT; + End; + + If FTelnetClient Then Begin + Case Buf[Count] of + Telnet_BINARY, + Telnet_ECHO, + Telnet_SGA, + Telnet_TERM : SendCommand(ReplyGood, Buf[Count]) + Else + SendCommand(ReplyBad, Buf[Count]); + End; + + If Buf[Count] = Telnet_Echo Then + FTelnetEcho := (FTelnetCmd = Telnet_DO); + End Else Begin + Case Buf[Count] of + Telnet_ECHO : FTelnetEcho := True; + Telnet_SGA : ; + Else + SendCommand(ReplyBad, Buf[Count]); + End; + End; + End; + End; + End; + 3 : If Buf[Count] = Telnet_SE Then Begin + If FTelnetClient Then + Case FTelnetSubCmd of + Telnet_TERM : SendData(Telnet_TERM, 'vt100'); + End; + + FTelnetState := 0; + FTelnetSubData := ''; + End Else + FTelnetSubData := FTelnetSubData + Buf[Count]; + Else + If Buf[Count] = Telnet_IAC Then Begin + Inc (FTelnetState); + End Else Begin + Temp[TempPos] := Buf[Count]; + Inc (TempPos); + End; + End; + End; + + Buf := Temp; + Len := TempPos; +End; + +Function TSocketClass.ReadChar : Char; +Var + Ch : Char; +Begin + ReadBuf(Ch, 1); + Result := Ch; +End; + +Function TSocketClass.ReadBuf (Var Buf; Len: LongInt) : LongInt; +Begin + If FInBufPos = FInBufEnd Then Begin + FInBufEnd := fpRecv(FSocketHandle, @FInBuf, TSocketBufferSize, FPRECVOPT); + FInBufPos := 0; + If FInBufEnd <= 0 Then Begin + FInBufEnd := 0; + Result := -1; + Exit; + End; + + If FTelnetClient or FTelnetServer Then ProcessBuf(FInBuf, FInBufEnd); + End; + + If Len > FInBufEnd - FInBufPos Then Len := FInBufEnd - FInBufPos; + + Move (FInBuf[FInBufPos], Buf, Len); + Inc (FInBufPos, Len); + + Result := Len; +End; + +Function TSocketClass.ReadLine (Var Str: String) : LongInt; +Var + Ch : Char; + Res : LongInt; +Begin + Str := ''; + Res := 0; + + Repeat + If FInBufPos = FInBufEnd Then Res := ReadBuf(Ch, 0); + + Ch := FInBuf[FInBufPos]; + Inc (FInBufPos); + If (Ch <> #10) And (Ch <> #13) And (FInBufEnd > 0) Then Str := Str + Ch; + Until (Ch = #10) Or (Res < 0) Or (FInBufEnd = 0); + + If Res < 0 Then Result := -1 Else Result := Length(Str); +End; + +Function TSocketClass.SetBlocking (Block: Boolean): LongInt; +//Var +// Data : DWord; +Begin + If FSocketHandle = -1 Then Begin + Result := FSocketHandle; + Exit; + End; + +// Data := Ord(Not Block); +// Result := ioctlSocket(FSocketHandle, FIONBIO, Data); +End; + +Function TSocketClass.WaitForData (TimeOut: LongInt) : LongInt; +Var + T : TTimeVal; + rFDSET, + wFDSET, + eFDSET : TFDSet; +Begin + T.tv_sec := 0; + T.tv_usec := TimeOut * 1000; + + {$IFDEF UNIX} + fpFD_Zero(rFDSET); + fpFD_Zero(wFDSET); + fpFD_Zero(eFDSET); + fpFD_Set(FSocketHandle, rFDSET); + Result := fpSelect(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T); + {$ELSE} + FD_Zero(rFDSET); + FD_Zero(wFDSET); + FD_Zero(eFDSET); + FD_Set(FSocketHandle, rFDSET); + Result := Select(FSocketHandle + 1, @rFDSET, @wFDSET, @eFDSET, @T); + {$ENDIF} +End; + +Function TSocketClass.ResolveAddress (Host: String) : LongInt; +Var + HostEnt : PHostEnt; +Begin + Host := Host + #0; + HostEnt := GetHostByName(@Host[1]); + + If Assigned(HostEnt) Then + Result := PInAddr(HostEnt^.h_addr_list^)^.S_addr + Else + Result := LongInt(StrToNetAddr(Host)); +// Result := NetAddrToStr(@Host[1]); +End; + +Function TSocketClass.Connect (Address: String; Port: Word) : Boolean; +Var + Sin : TINetSockAddr; +Begin + Result := False; + FSocketHandle := fpSocket(PF_INET, SOCK_STREAM, 0); + + If FSocketHandle = -1 Then Exit; + + FPeerName := Address; + + FillChar(Sin, SizeOf(Sin), 0); + + Sin.sin_Family := PF_INET; + Sin.sin_Port := htons(Port); + Sin.sin_Addr.S_Addr := ResolveAddress(Address); + + FPeerIP := NetAddrToStr(Sin.Sin_Addr); + Result := fpConnect(FSocketHandle, @Sin, SizeOf(Sin)) = 0; +End; + +Procedure TSocketClass.WaitInit (Port: Word); +Var + SIN : TINetSockAddr; +Begin + FSocketHandle := fpSocket(PF_INET, SOCK_STREAM, 0); + + SIN.sin_family := PF_INET; + SIN.sin_addr.s_addr := 0; + SIN.sin_port := htons(Port); + + fpBind(FSocketHandle, @SIN, SizeOf(SIN)); + + SetBlocking(True); +End; + +Function TSocketClass.WaitConnection : TSocketClass; +Var + Sock : LongInt; + Client : TSocketClass; + PHE : PHostEnt; + SIN : TINetSockAddr; + Temp : LongInt; +Begin + Result := NIL; + + If fpListen(FSocketHandle, 5) = -1 Then Exit; + + Temp := SizeOf(SIN); + Sock := fpAccept(FSocketHandle, @SIN, @Temp); + + If Sock = -1 Then Exit; + + FPeerIP := NetAddrToStr(SIN.sin_addr); + + PHE := GetHostByAddr(@SIN.sin_addr, 4, PF_INET); + If Not Assigned(PHE) Then + FPeerName := 'Unknown' + Else + FPeerName := StrPas(PHE^.h_name); + + fpGetSockName(FSocketHandle, @SIN, SizeOf(SIN)); + + FHostIP := NetAddrToStr(SIN.sin_addr); + Client := TSocketClass.Create; + + Client.SocketHandle := Sock; + Client.PeerName := FPeerName; + Client.PeerIP := FPeerIP; + Client.PeerPort := FPort; + Client.HostIP := FHostIP; + Client.FTelnetServer := FTelnetServer; + Client.FTelnetClient := FTelnetClient; + + If FTelnetServer Then + Client.WriteStr(#255#251#001#255#251#003); // IAC WILL ECHO + + Result := Client; +End; + +Procedure TSocketClass.Status (Str: String); +Var + Res : String; +Begin + Try + If SocketStatus.Count > 20 Then + SocketStatus.Delete(0); + + Res := '(' + Copy(DateDos2Str(CurDateDos, 1), 1, 5) + ' ' + TimeDos2Str(CurDateDos, False) + ') ' + Str; + + If Length(Res) > 74 Then Begin + SocketStatus.Add(Copy(Res, 1, 74)); + + If SocketStatus.Count > 20 Then + SocketStatus.Delete(0); + + SocketStatus.Add(strRep(' ', 14) + Copy(Res, 75, 255)); + End Else + SocketStatus.Add(Res); + Except + { ignore exceptions here -- happens when socketstatus is NIL} + { need to review criticals now that they are in FP's RTL} + End; + + StatusUpdated := True; +End; + +End. diff --git a/mdl/m_socket_server.pas b/mdl/m_socket_server.pas new file mode 100644 index 0000000..a41d0f5 --- /dev/null +++ b/mdl/m_socket_server.pas @@ -0,0 +1,268 @@ +{$I M_OPS.PAS} + +Unit m_Socket_Server; + +Interface + +Uses + Classes, + m_Socket_Class; + +Type + TServerManager = Class; + TServerClient = Class; + TServerCreateProc = Function (Manager: TServerManager; Client: TSocketClass): TServerClient; + + TServerManager = Class(TThread) + Server : TSocketClass; + ClientList : TList; + NewClientProc : TServerCreateProc; + ClientMax : LongInt; + ClientMaxIPs : LongInt; + ClientRefused : LongInt; + ClientBlocked : LongInt; + ClientTotal : LongInt; + ClientActive : LongInt; + Port : LongInt; + TextPath : String[80]; + + Constructor Create (PortNum, Max: Word; CreateProc: TServerCreateProc); + Destructor Destroy; Override; + Procedure Execute; Override; + Function CheckIP (IP, Mask: String) : Boolean; + Function IsBlockedIP (Var Client: TSocketClass) : Boolean; + Function DuplicateIPs (Var Client: TSocketClass) : Byte; +// Procedure Status (Str: String); + End; + + TServerClient = Class(TThread) + Client : TSocketClass; + Manager : TServerManager; + + Constructor Create (Owner: TServerManager; CliSock: TSocketClass); + Destructor Destroy; Override; + End; + + //TServerTextClient = Class(TServerClient) + //End; + +Implementation + +Uses + m_Strings, + m_DateTime; + +Constructor TServerManager.Create (PortNum, Max: Word; CreateProc: TServerCreateProc); +Var + Count : Byte; +Begin + Inherited Create(False); + + Port := PortNum; + ClientMax := Max; + ClientRefused := 0; + ClientBlocked := 0; + ClientTotal := 0; + ClientActive := 0; + ClientMaxIPs := 0; + NewClientProc := CreateProc; + Server := TSocketClass.Create; + ClientList := TList.Create; + TextPath := ''; + + For Count := 1 to ClientMax Do + ClientList.Add(NIL); + + FreeOnTerminate := False; +End; + +(* +Procedure TServerManager.Status (Str: String); +Begin + If Server.SocketStatus = NIL Then + While Server.SocketStatus = NIL Do Begin + WriteLn('ITS NIL'); + End; + + Server.Status(Str); +End; +*) + +Function TServerManager.CheckIP (IP, Mask: String) : Boolean; +Var + A : Byte; + Count : Byte; + Str : String; + Str2 : String; + EndIt : Byte; +Begin + Result := True; + + For Count := 1 to 4 Do Begin + If Count < 4 Then Begin + Str := Copy(IP, 1, Pos('.', IP) - 1); + Str2 := Copy(Mask, 1, Pos('.', Mask) - 1); + Delete (IP, 1, Pos('.', IP)); + Delete (Mask, 1, Pos('.', Mask)); + End Else Begin + Str := Copy(IP, 1, Length(IP)); + Str2 := Copy(Mask, 1, Length(Mask)); + End; + + For A := 1 to Length(Str) Do + If Str2[A] = '*' Then + Break + Else + If Str[A] <> Str2[A] Then Begin + Result := False; + Break; + End; + + If Not Result Then Break; + End; +End; + +Function TServerManager.IsBlockedIP (Var Client: TSocketClass) : Boolean; +Var + TF : Text; + Str : String; +Begin + Result := False; + FileMode := 66; + + Assign (TF, TextPath + 'badip.txt'); + Reset (TF); + + If IoResult <> 0 Then Exit; + + While Not Eof(TF) Do Begin + ReadLn (TF, Str); + If CheckIP (Client.PeerIP, Str) Then Begin + Result := True; + Break; + End; + End; + + Close (TF); +End; + +Function TServerManager.DuplicateIPs (Var Client: TSocketClass) : Byte; +Var + Count : Byte; +Begin + Result := 0; + + For Count := 0 to ClientMax - 1 Do + If ClientList[Count] <> NIL Then + If Client.PeerIP = TSocketClass(ClientList[Count]).PeerIP Then + Inc(Result); +End; + +Procedure TServerManager.Execute; +Var + NewClient : TSocketClass; +Begin + Repeat Until Server <> NIL; // Synchronize with server class + Repeat Until Server.SocketStatus <> NIL; // Syncronize with status class + + Server.WaitInit(Port); + + If Terminated Then Exit; + + Server.Status('Opening server socket on port ' + strI2S(Port)); + + Repeat + NewClient := Server.WaitConnection; + + If NewClient = NIL Then Break; // time to shutdown the server... + + If (ClientMax > 0) And (ClientActive >= ClientMax) Then Begin + Inc (ClientRefused); + Server.Status ('BUSY: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'busy.txt') Then NewClient.WriteLine('BUSY'); + NewClient.Free; + End Else + If IsBlockedIP(NewClient) Then Begin + Inc (ClientBlocked); + Server.Status('BLOCK: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'blocked.txt') Then NewClient.WriteLine('BLOCKED'); + NewClient.Free; + End Else + If (ClientMaxIPs > 0) and (DuplicateIPs(NewClient) > ClientMaxIPs) Then Begin + Inc (ClientRefused); + Server.Status('MULTI: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + If Not NewClient.WriteFile(TextPath + 'dupeip.txt') Then NewClient.WriteLine('Only ' + strI2S(ClientMaxIPs) + ' connection(s) per user'); + NewClient.Free; + End Else Begin + Inc (ClientTotal); + Inc (ClientActive); + Server.Status ('Connect: ' + NewClient.PeerIP + ' (' + NewClient.PeerName + ')'); + NewClientProc(Self, NewClient); + End; + Until Terminated; + + Server.Status ('Shutting down server...'); +End; + +Destructor TServerManager.Destroy; +Var + Count : LongInt; + Angry : Byte; +Begin + Angry := 20; // about 5 seconds before we get mad at thread... + + ClientList.Pack; + + While (ClientList.Count > 0) and (Angry > 0) Do Begin + For Count := 0 To ClientList.Count - 1 Do + If ClientList[Count] <> NIL Then Begin + TServerClient(ClientList[Count]).Client.Disconnect; + TServerClient(ClientList[Count]).Terminate; + End; + + WaitMS(250); + + Dec (Angry); + + ClientList.Pack; + End; + + ClientList.Free; + Server.Free; + + Inherited Destroy; +End; + +Constructor TServerClient.Create (Owner: TServerManager; CliSock: TSocketClass); +Var + Count : Byte; +Begin + Manager := Owner; + Client := CliSock; + + For Count := 0 to Manager.ClientMax - 1 Do + If Manager.ClientList[Count] = NIL Then Begin + Manager.ClientList[Count] := Self; + Break; + End; + + Inherited Create(False); + + FreeOnTerminate := True; +End; + +Destructor TServerClient.Destroy; +Begin + Client.Free; + + Manager.ClientList[Manager.ClientList.IndexOf(Self)] := NIL; + + If Manager.Server <> NIL Then + Manager.Server.StatusUpdated := True; + + Dec (Manager.ClientActive); + + Inherited Destroy; +End; + +End.