kolibrios/programs/develop/fp/rtl/kos_stdio.inc
bw bafb2d78f4 [FP] changes in RTL, gfx example
git-svn-id: svn://kolibrios.org@666 a494cfbc-eb01-0410-851d-a64ba20cac60
2007-10-27 16:38:51 +00:00

392 lines
8.8 KiB
PHP
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{}
procedure OpenStdout(var f: TextRec); forward;
procedure WriteStdout(var f: TextRec); forward;
procedure FlushStdout(var f: TextRec); forward;
procedure CloseStdout(var f: TextRec); forward;
procedure OpenStdin(var f: TextRec); forward;
procedure ReadStdin(var f: TextRec); forward;
procedure CloseStdin(var f: TextRec); forward;
procedure AssignStdout(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdout;
Rewrite(f);
end;
procedure OpenStdout(var f: TextRec);
begin
TextRec(f).InOutFunc := @WriteStdout;
TextRec(f).FlushFunc := @FlushStdout;
TextRec(f).CloseFunc := @CloseStdout;
end;
procedure WriteStdout(var f: TextRec);
var
msg: String;
begin
msg := StrPas(PChar(f.bufptr));
SetLength(msg, f.bufpos);
f.bufpos := 0;
Konsole.Write(msg);
end;
procedure FlushStdout(var f: TextRec);
begin
WriteStdout(f);
Konsole.Flush;
end;
procedure CloseStdout(var f: TextRec);
begin
end;
procedure AssignStdin(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdin;
Reset(f);
end;
procedure OpenStdin(var f: TextRec);
begin
TextRec(f).InOutFunc := @ReadStdin;
TextRec(f).FlushFunc := nil;
TextRec(f).CloseFunc := @CloseStdin;
end;
procedure ReadStdin(var f: TextRec);
var
max, curpos: Longint;
c: Longint;
begin
max := f.bufsize - Length(LineEnding);
curpos := 0;
repeat
c := 13{l4_getc()};
case c of
13:
begin
{f.bufptr^[curpos] := LineEnding;}
Inc(curpos);
f.bufpos := 0;
f.bufend := curpos;
{l4_putc(Longint(LineEnding));}
break;
end;
32..126: if curpos < max then
begin
f.bufptr^[curpos] := Char(c);
Inc(curpos);
{l4_putc(c);}
end;
end;
until False;
end;
procedure CloseStdin(var f: TextRec);
begin
end;
{ TKonsole }
procedure KonsoleThreadMain(Console: PKonsole);
{<EFBFBD> ¡®ç¨© 横« ª®­á®«¨}
var
ThreadInfo: TKosThreadInfo;
Message: ShortString;
Event: DWord;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_IPC);
kos_threadinfo(@ThreadInfo);
Console^.FThreadSlot := kos_getthreadslot(ThreadInfo.ThreadID);
kos_initipc(Console^.FIPCBuffer, Console^.FIPCBufferSize);
{áࠧ㠮⮡ࠧ¨âì ¨  ªâ¨¢¨à®¢ âì ®ª­®}
Console^.Paint();
{$ifndef EMULATOR}
kos_setactivewindow(Console^.FThreadSlot);
{$endif}
{£®â®¢ ª ®¡à ¡®âª¥ ᮡë⨩}
Console^.FOpened := True;
while not Console^.FTerminate do
begin
Event := kos_getevent();
Console^.FOnAir := True;
if not Console^.FTerminate then
case Event of
SE_PAINT: Console^.Paint();
SE_KEYBOARD: Console^.ProcessKeyboard(kos_getkey());
SE_IPC: while Console^.ReceiveMessage(Message) do Console^.ProcessMessage(Message);
end;
Console^.FOnAir := False;
end;
Console^.FOpened := False;
end;
constructor TKonsole.Init(ACaption: String);
const
IPC_SIZE = 4096;
var
ThreadInfo: TKosThreadInfo;
begin
if ACaption <> '' then
FCaption := ACaption else
begin
kos_threadinfo(@ThreadInfo);
FCaption := StrPas(ThreadInfo.AppName);
end;
SetLength(FLines, 1);
FLines[0] := '';
FCursor.X := 1;
FCursor.Y := 0;
FMaxLines := 150;
FTerminate := False;
FOpened := False;
FOnAir := False;
FIPCBufferSize := SizeOf(TKosIPC) + IPC_SIZE;
FIPCBuffer := GetMem(FIPCBufferSize);
FIPCBuffer^.Lock := False;
FIPCBuffer^.Size := 0;
FThreadSlot := -1;
FThreadID := BeginThread(TThreadFunc(@KonsoleThreadMain), @Self);
if FThreadID <> 0 then
{XXX: ¬®¦¥â § ¢¨á­ãâì}
while not FOpened do ThreadSwitch;
end;
destructor TKonsole.Done();
begin
FTerminate := True;
if FOpened then begin Self.Write(#0); kos_delay(01); end;
if FOpened then begin Self.Write(#0); kos_delay(10); end;
if FOpened then begin Self.Write(#0); kos_delay(20); end;
if FOpened then
begin
FOpened := False;
FOnAir := False;
KillThread(FThreadID);
end;
{FreeMem(FIPCBuffer);
SetLength(FLines, 0);}
end;
function TKonsole.ReceiveMessage(var Message: ShortString): Boolean;
{ˆ§¢«¥çì ¯¥à¢®¥ á®®¡é¥­¨¥ ¨§ ¡ãä¥à }
var
PMsg: PKosMessage;
Size: Longword;
begin
FIPCBuffer^.Lock := True;
if FIPCBuffer^.Size > 0 then
begin
PMsg := Pointer(Longword(FIPCBuffer) + SizeOf(TKosIPC));
{TODO: ¯à®¢¥àª  PMsg^.SenderID}
{Size := PMsg^.Size;
Dec(FIPCBuffer^.Size, Size + SizeOf(TKosMessage));
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage))^, Message[1], Size);
if FIPCBuffer^.Size > 0 then
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage) + PMsg^.Size)^, PMsg^, FIPCBuffer^.Size);}
{XXX}
Size := FIPCBuffer^.Size;
Dec(FIPCBuffer^.Size, Size);
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(PMsg^, Message[1], Size);
Result := True;
end else
begin
Message := '';
Result := False;
end;
{FIXME: ¥á«¨ FIPCBuffer^.Size = 0, â® FIPCBuffer^.Lock ¢á¥ à ¢­® > 0}
FIPCBuffer^.Lock := False;
end;
procedure TKonsole.ProcessMessage(Message: ShortString);
{ ‚뢥á⨠ᮮ¡é¥­¨¥ ­  ª®­á®«ì }
var
OnlyBottomLine: Boolean = True;
procedure PutChar(C: Char);
var
LinesCount: Longint;
PLine: PShortString;
I: Longint;
begin
{ ¯¥à¥¢®¤ ª®à¥âª¨ ­  ¯®§¨æ¨î ¢«¥¢® }
if C = #8 then
begin
if FCursor.X > 1 then
Dec(FCursor.X);
end else
{ ¯¥à¥¢®¤ ª®à¥âª¨ ­  á«¥¤ãîéãî áâபã }
if C = #10 then
begin
OnlyBottomLine := False;
Inc(FCursor.Y);
LinesCount := Length(FLines);
while FCursor.Y >= FMaxLines do Dec(FCursor.Y, FMaxLines);
if FCursor.Y < LinesCount then FLines[FCursor.Y] := '';
while FCursor.Y >= LinesCount do
begin
SetLength(FLines, LinesCount + 1);
FLines[LinesCount] := '';
Inc(LinesCount);
end;
end else
{ ¯¥à¥¢®¤ ª®à¥âª¨ ¢ ­ ç «® áâப¨ }
if C = #13 then
FCursor.X := 1 else
{ ¯®¬¥é¥­¨¥ ᨬ¢®«  ¢ áâபã }
begin
if FCursor.X > 200 then
begin
PutChar(#13);
PutChar(#10);
end;
{ FIXME: …᫨ ¢ PascalMain ⮫쪮 ®¤¨­ Write/Ln, â® § ¢¨á®­.
á¬. FPC_DO_EXIT, InternalExit }
PLine := @FLines[FCursor.Y];
I := Length(PLine^);
if FCursor.X > I then
begin
SetLength(PLine^, FCursor.X);
Inc(I);
while I < FCursor.X do
begin
PLine^[I] := ' ';
Inc(I);
end;
end;
FLines[FCursor.Y][FCursor.X] := C;
Inc(FCursor.X);
end;
end;
var
I: Longint;
begin
for I := 1 to Length(Message) do
PutChar(Message[I]);
Paint(OnlyBottomLine);
end;
procedure TKonsole.ProcessKeyboard(Key: Word);
begin
FKeyPressed := Key;
end;
function TKonsole.GetRect(): TKosRect;
var
ThreadInfo: TKosThreadInfo;
begin
kos_threadinfo(@ThreadInfo, FThreadSlot);
Result := ThreadInfo.WindowRect;
end;
function TKonsole.GetKeyPressed(): Word;
begin
Result := FKeyPressed;
FKeyPressed := 0;
end;
procedure TKonsole.Paint(BottomRow: Boolean);
var
Buffer: array[Byte] of Char;
Rect: TKosRect;
J: Longint;
Width, Height, Row: Longint;
CaptionHeight, BorderWidth, FontWidth, FontHeight: Longint;
begin
CaptionHeight := 16;
BorderWidth := 5;
FontWidth := 6;
FontHeight := 9;
kos_begindraw();
if not BottomRow then
begin
{®âà¨á®¢ª  ®ª­ }
kos_definewindow(60, 60, 400, 400, $63000000);
{¢ë¢®¤ § £®«®¢ª }
Move(FCaption[1], Buffer, Length(FCaption));
Buffer[Length(FCaption)] := #0;
kos_setcaption(Buffer);
end;
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã áâப}
Rect := GetRect();
Dec(Rect.Width, BorderWidth * 2);
Dec(Rect.Height, CaptionHeight + BorderWidth * 2);
Width := Rect.Width div FontWidth;
Height := Rect.Height - FontHeight;
Row := FCursor.Y;
while Height > 0 do
begin
{¢ë¢®¤ ®¤­®© áâப¨}
J := Length(FLines[Row]);
if J > Width then J := Width;
kos_drawtext(0, Height, Copy(FLines[Row], 1, J), $00DD00, $FF000000);
{§ «¨¢ª  ®á⠢襣®áï ¯à®áâà ­á⢠ ¢ áâப¥}
J := J * FontWidth;
kos_drawrect(J, Height, Rect.Width - J + 1, FontHeight, $000000);
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã á«¥¤ãî饩 áâப¨}
Dec(Height, FontHeight);
Dec(Row);
if BottomRow or ((Row < 0) and (Length(FLines) < FMaxLines)) then Break;
while Row < 0 do Inc(Row, FMaxLines);
end;
if FCursor.X <= Width then
{®âà¨á®¢ª  ªãàá®à }
kos_drawrect((FCursor.X - 1) * FontWidth, Rect.Height - 2, FontWidth, 2, $FFFFFF);
if not BottomRow then
{§ «¨¢ª  ®á⠢襩áï ç á⨠®ª­ }
kos_drawrect(0, 0, Rect.Width + 1, Height + FontHeight, $000000);
kos_enddraw();
end;
procedure TKonsole.Write(Message: ShortString);
var
I: Integer;
begin
{XXX: ¢®§¬®¦­  á¨âã æ¨ï ¯à¨ ª®â®à®© á®®¡é¥­¨¥ ­¥ ¡ã¤¥â ®â¯à ¢«¥­®}
if FOpened then
begin
I := 100;
while (kos_sendmsg(FThreadID, @Message[1], Length(Message)) = 2) and (I > 0) do
begin
Dec(I);
ThreadSwitch;
end;
end;
end;
procedure TKonsole.Flush();
begin
while FOnAir do ThreadSwitch;
end;