fpPS4/sys/sys_crt.pas

unit sys_crt;

{$mode ObjFPC}{$H+}

interface

uses
 windows,
 sys_pthread;

var
 StdWrn:Text;

Procedure sys_crt_init;
Procedure CrtOutWriteDirect(T:PText;data:Pointer;len:SizeInt);

implementation

uses
 sys_kernel,
 sys_signal;

var
 StdOutLock:TRTLCriticalSection;
 StdOutColor:Word;

const
 StdErrColor=FOREGROUND_RED;
 StdWrnColor=14;

function GetConsoleTextAttribute(hConsoleOutput:HANDLE;var wAttributes:WORD):WINBOOL;
var
 info:CONSOLE_SCREEN_BUFFER_INFO;
begin
 Result:=GetConsoleScreenBufferInfo(hConsoleOutput,@info);
 if Result then
 begin
  wAttributes:=info.wAttributes
 end;
end;

function GetConsoleCursorPosition(hConsoleOutput:HANDLE;var dwCursorPosition:COORD):WINBOOL;
var
 info:CONSOLE_SCREEN_BUFFER_INFO;
begin
 Result:=GetConsoleScreenBufferInfo(hConsoleOutput,@info);
 if Result then
 begin
  dwCursorPosition:=info.dwCursorPosition;
 end;
end;

Procedure _CrtOutWrite(var t:TextRec;data:Pointer;len:SizeInt);
var
 n:DWORD;
Begin
 if (data=nil) or (len=0) then exit;
 n:=0;

 _sig_lock(SL_NOINTRRUP);

 if Boolean(t.UserData[2]) then //IsChar
 begin
  EnterCriticalSection(StdOutLock);
  //Text
   SetConsoleTextAttribute(t.Handle,t.UserData[1]);
   WriteConsole(t.Handle,
                data,
                len,
                @n,
                nil);
   SetConsoleTextAttribute(t.Handle,StdOutColor);
  //Text
  LeaveCriticalSection(StdOutLock);
 end else
 begin
  WriteFile(t.Handle,
            data^,
            len,
            n,
            nil);
 end;

 _sig_unlock(SL_NOINTRRUP);
end;

Procedure CrtOutWrite(var t:TextRec);
Begin
 _CrtOutWrite(t,t.Bufptr,t.BufPos);
 t.BufPos:=0;
end;

Procedure CrtOutWriteDirect(T:PText;data:Pointer;len:SizeInt);
begin
 if (T=nil) then Exit;
 _CrtOutWrite(TextRec(T^),data,len);
end;

Procedure CrtClose(Var F:TextRec);
Begin
 F.Mode:=fmClosed;
end;

Procedure CrtOpenOut(Var F:TextRec);
var
 _type:Shortint;
 IsChar:Boolean;
Begin
 _type:=Shortint(TextRec(F).UserData[2]);

 TextRec(F).Handle:=GetStdHandle(_type);

 IsChar:=SwGetFileType(TextRec(F).Handle)=FILE_TYPE_CHAR;
 TextRec(F).UserData[2]:=ord(IsChar);

 TextRec(F).InOutFunc:=@CrtOutWrite;
 TextRec(F).FlushFunc:=@CrtOutWrite;
 TextRec(F).CloseFunc:=@CrtClose;
end;

procedure AssignCrt(var F:Text;_type:DWORD;clr:Byte);
begin
 Assign(F,'');
 TextRec(F).OpenFunc:=@CrtOpenOut;
 TextRec(F).UserData[1]:=clr;
 TextRec(F).UserData[2]:=Shortint(Integer(_type));
end;

Procedure sys_crt_init;
begin
 tcb_thread:=nil; //need zero tcb

 AssignCrt(Output   ,STD_OUTPUT_HANDLE,StdOutColor);
 AssignCrt(StdOut   ,STD_OUTPUT_HANDLE,StdOutColor);
 AssignCrt(ErrOutput,STD_ERROR_HANDLE ,StdErrColor);
 AssignCrt(StdErr   ,STD_ERROR_HANDLE ,StdErrColor);

 Rewrite(Output);
 Rewrite(StdOut);
 Rewrite(ErrOutput);
 Rewrite(StdErr);
end;

Procedure _sys_crt_init;
var
 F:Thandle;
begin
 StdOutColor:=7;
 F:=GetStdHandle(STD_OUTPUT_HANDLE);
 if (SwGetFileType(F)=FILE_TYPE_CHAR) then
 begin
  GetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),StdOutColor);
 end;
 //
 AssignCrt(StdWrn,STD_OUTPUT_HANDLE,StdWrnColor);
 Rewrite(StdWrn);
end;

procedure _sys_crt_fini;
var
 F:Thandle;
begin
 F:=GetStdHandle(STD_OUTPUT_HANDLE);
 if (SwGetFileType(F)=FILE_TYPE_CHAR) then
 begin
  SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),StdOutColor);
 end;
end;

initialization
 AddExitProc(@_sys_crt_fini);
 InitCriticalSection(StdOutLock);
 _sys_crt_init;

end.