eric
/
mysticbbs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial import

This commit is contained in:
mysticbbs 2012-02-13 19:01:02 -05:00
parent d4c175e419
commit 47040b9885
8 changed files with 4611 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

492
mdl/m_menubox.pas Normal file
View File

@ -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.

693
mdl/m_menuform.pas Normal file
View File

@ -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.

418
mdl/m_menuinput.pas Normal file
View File

@ -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.

718
mdl/m_output_darwin.pas Normal file
View File

@ -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.

719
mdl/m_output_linux.pas Normal file
View File

@ -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.

733
mdl/m_output_windows.pas Normal file
View File

@ -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.

570
mdl/m_socket_class.pas Normal file
View File

@ -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.

268
mdl/m_socket_server.pas Normal file
View File

@ -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.