mirrors/doublecmd
2
0
Fork 0
mirror of https://github.com/doublecmd/doublecmd.git synced 2026-06-21 09:58:13 +00:00
Code Issues Projects Releases Packages Wiki Activity

ADD: New virtual terminal control

Browse source
This commit is contained in:
Alexander Koblov 2022-01-01 17:16:06 +03:00
commit 5b707edbdb
7 changed files with 3324 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

221
components/virtualterminal/source/unix/vtemupty.pas Normal file
View file

@ -0,0 +1,221 @@
{
Double Commander
-------------------------------------------------------------------------
Unix pseudoterminal device implementation
Copyright (C) 2021 Alexander Koblov (alexx2000@mail.ru)
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
}
unit VTEmuPty;
{$mode delphi}
interface
uses
Classes, SysUtils, BaseUnix, TermIO, InitC, VTEmuCtl;
// Under Linux and BSD forkpty is situated in libutil.so library
{$IF NOT DEFINED(DARWIN)}
{$LINKLIB util}
{$ENDIF}
type
{ TPtyDevice }
TPtyDevice = class(TCustomPtyDevice)
private
Fpty: LongInt;
FThread: TThread;
FChildPid: THandle;
FEventPipe: TFilDes;
FLength, FCols, FRows: Integer;
FBuffer: array[0..8191] of AnsiChar;
protected
procedure ReadySync;
procedure ReadThread;
procedure SetConnected(AValue: Boolean); override;
function CreatePseudoConsole(const cmd: String): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function WriteStr(const Str: string): Integer; override;
function SetCurrentDir(const Path: String): Boolean; override;
function SetScreenSize(aCols, aRows: Integer): Boolean; override;
end;
implementation
uses
Errors, DCOSUtils, DCStrUtils, DCUnix;
type
Pwinsize = ^winsize;
Ptermios = ^termios;
function forkpty(__amaster: Plongint; __name: Pchar; __termp: Ptermios; __winp: Pwinsize): longint;cdecl;external clib name 'forkpty';
function execl(__path: Pchar; __arg: Pchar): longint;cdecl;varargs;external clib name 'execl';
{ TPtyDevice }
procedure TPtyDevice.SetConnected(AValue: Boolean);
var
AShell: String;
Symbol: Byte = 0;
begin
if FConnected = AValue then Exit;
FConnected:= AValue;
if FConnected then
begin
AShell:= mbGetEnvironmentVariable('SHELL');
if Length(AShell) = 0 then AShell:= '/bin/sh';
FConnected:= CreatePseudoConsole(AShell);
if FConnected then
begin
FThread:= TThread.ExecuteInThread(ReadThread);
end;
end
else begin
if FChildPid > 0 then
begin
FpKill(FChildPid, SIGTERM);
end;
FileWrite(FEventPipe[1], Symbol, 1);
end;
end;
procedure TPtyDevice.ReadySync;
begin
if Assigned(FOnRxBuf) then
FOnRxBuf(Self, FBuffer, FLength);
end;
procedure TPtyDevice.ReadThread;
var
ret: cint;
symbol: byte = 0;
fds: array[0..1] of tpollfd;
begin
fds[0].fd:= FEventPipe[0];
fds[0].events:= POLLIN;
fds[1].fd:= Fpty;
fds[1].events:= POLLIN;
while FConnected do
begin
repeat
ret:= fpPoll(@fds[0], 2, -1);
until (ret <> -1) or (fpGetErrNo <> ESysEINTR);
if (ret = -1) then
begin
WriteLn(SysErrorMessage(fpGetErrNo));
Break;
end;
if (fds[0].events and fds[0].revents <> 0) then
begin
while FileRead(fds[0].fd, symbol, 1) <> -1 do;
Break;
end;
if (fds[1].events and fds[1].revents <> 0) then
begin
FLength:= FileRead(Fpty, FBuffer, SizeOf(FBuffer));
if (FLength > 0) then TThread.Synchronize(FThread, ReadySync);
end;
end;
end;
function TPtyDevice.CreatePseudoConsole(const cmd: String): Boolean;
var
ws: TWinSize;
begin
ws.ws_row:= FRows;
ws.ws_col:= FCols;
ws.ws_xpixel:= 0;
ws.ws_ypixel:= 0;
FChildPid:= forkpty(@Fpty, nil, nil, @ws);
if FChildPid = 0 then
begin
FileCloseOnExecAll;
setenv('TERM', 'xterm-256color', 1);
execl(PAnsiChar(cmd), PAnsiChar(cmd), nil);
Errors.PError('execl() failed. Command: '+ cmd, cerrno);
fpExit(127);
end;
Result:= (FChildPid > 0);
end;
constructor TPtyDevice.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if fpPipe(FEventPipe) < 0 then
WriteLn(SysErrorMessage(fpGetErrNo))
else begin
// Set both ends of pipe non blocking
FileCloseOnExec(FEventPipe[0]); FileCloseOnExec(FEventPipe[1]);
FpFcntl(FEventPipe[0], F_SetFl, FpFcntl(FEventPipe[0], F_GetFl) or O_NONBLOCK);
FpFcntl(FEventPipe[1], F_SetFl, FpFcntl(FEventPipe[1], F_GetFl) or O_NONBLOCK);
end;
end;
destructor TPtyDevice.Destroy;
begin
SetConnected(False);
inherited Destroy;
FileClose(FEventPipe[0]);
FileClose(FEventPipe[1]);
end;
function TPtyDevice.WriteStr(const Str: string): Integer;
begin
Result:= FileWrite(Fpty, Pointer(Str)^, Length(Str));
end;
function TPtyDevice.SetCurrentDir(const Path: String): Boolean;
begin
Result:= WriteStr(' cd ' + EscapeNoQuotes(Path) + #13) > 0;
end;
function TPtyDevice.SetScreenSize(aCols, aRows: Integer): Boolean;
var
ws: TWinSize;
begin
ws.ws_row:= aRows;
ws.ws_col:= aCols;
ws.ws_xpixel:= 0;
ws.ws_ypixel:= 0;
Result:= FpIOCtl(Fpty,TIOCSWINSZ,@ws) = 0;
if Result then
begin
FCols:= aCols;
FRows:= aRows;
end;
end;
end.

82
components/virtualterminal/source/vtcolortable.pas Normal file
View file

@ -0,0 +1,82 @@
unit VTColorTable;
{$mode delphi}
interface
uses
Classes, SysUtils, Graphics;
const
Color256Table: array[Byte] of TColor =
(
$0C0C0C, $1F0FC5, $0EA113, $009CC1,
$DA3700, $981788, $DD963A, $CCCCCC,
$767676, $5648E7, $0CC616, $A5F1F9,
$FF783B, $9E00B4, $D6D661, $F2F2F2,
$000000, $5F0000, $870000, $AF0000,
$D70000, $FF0000, $005F00, $5F5F00,
$875F00, $AF5F00, $D75F00, $FF5F00,
$008700, $5F8700, $878700, $AF8700,
$D78700, $FF8700, $00AF00, $5FAF00,
$87AF00, $AFAF00, $D7AF00, $FFAF00,
$00D700, $5FD700, $87D700, $AFD700,
$D7D700, $FFD700, $00FF00, $5FFF00,
$87FF00, $AFFF00, $D7FF00, $FFFF00,
$00005F, $5F005F, $87005F, $AF005F,
$D7005F, $FF005F, $005F5F, $5F5F5F,
$875F5F, $AF5F5F, $D75F5F, $FF5F5F,
$00875F, $5F875F, $87875F, $AF875F,
$D7875F, $FF875F, $00AF5F, $5FAF5F,
$87AF5F, $AFAF5F, $D7AF5F, $FFAF5F,
$00D75F, $5FD75F, $87D75F, $AFD75F,
$D7D75F, $FFD75F, $00FF5F, $5FFF5F,
$87FF5F, $AFFF5F, $D7FF5F, $FFFF5F,
$000087, $5F0087, $870087, $AF0087,
$D70087, $FF0087, $005F87, $5F5F87,
$875F87, $AF5F87, $D75F87, $FF5F87,
$008787, $5F8787, $878787, $AF8787,
$D78787, $FF8787, $00AF87, $5FAF87,
$87AF87, $AFAF87, $D7AF87, $FFAF87,
$00D787, $5FD787, $87D787, $AFD787,
$D7D787, $FFD787, $00FF87, $5FFF87,
$87FF87, $AFFF87, $D7FF87, $FFFF87,
$0000AF, $5F00AF, $8700AF, $AF00AF,
$D700AF, $FF00AF, $005FAF, $5F5FAF,
$875FAF, $AF5FAF, $D75FAF, $FF5FAF,
$0087AF, $5F87AF, $8787AF, $AF87AF,
$D787AF, $FF87AF, $00AFAF, $5FAFAF,
$87AFAF, $AFAFAF, $D7AFAF, $FFAFAF,
$00D7AF, $5FD7AF, $87D7AF, $AFD7AF,
$D7D7AF, $FFD7AF, $00FFAF, $5FFFAF,
$87FFAF, $AFFFAF, $D7FFAF, $FFFFAF,
$0000D7, $5F00D7, $8700D7, $AF00D7,
$D700D7, $FF00D7, $005FD7, $5F5FD7,
$875FD7, $AF5FD7, $D75FD7, $FF5FD7,
$0087D7, $5F87D7, $8787D7, $AF87D7,
$D787D7, $FF87D7, $00AFD7, $5FAFD7,
$87AFD7, $AFAFD7, $D7AFD7, $FFAFD7,
$00D7D7, $5FD7D7, $87D7D7, $AFD7D7,
$D7D7D7, $FFD7D7, $00FFD7, $5FFFD7,
$87FFD7, $AFFFD7, $D7FFD7, $FFFFD7,
$0000FF, $5F00FF, $8700FF, $AF00FF,
$D700FF, $FF00FF, $005FFF, $5F5FFF,
$875FFF, $AF5FFF, $D75FFF, $FF5FFF,
$0087FF, $5F87FF, $8787FF, $AF87FF,
$D787FF, $FF87FF, $00AFFF, $5FAFFF,
$87AFFF, $AFAFFF, $D7AFFF, $FFAFFF,
$00D7FF, $5FD7FF, $87D7FF, $AFD7FF,
$D7D7FF, $FFD7FF, $00FFFF, $5FFFFF,
$87FFFF, $AFFFFF, $D7FFFF, $FFFFFF,
$080808, $121212, $1C1C1C, $262626,
$303030, $3A3A3A, $444444, $4E4E4E,
$585858, $626262, $6C6C6C, $767676,
$808080, $8A8A8A, $949494, $9E9E9E,
$A8A8A8, $B2B2B2, $BCBCBC, $C6C6C6,
$D0D0D0, $DADADA, $E4E4E4, $EEEEEE
);
implementation
end.

1940
components/virtualterminal/source/vtemuctl.pas Normal file
View file

File diff suppressed because it is too large Load diff

534
components/virtualterminal/source/vtemuesc.pas Normal file
View file

@ -0,0 +1,534 @@
{
Double Commander
-------------------------------------------------------------------------
Virtual terminal emulator escape codes
Alexander Koblov, 2021
Based on ComPort Library
https://sourceforge.net/projects/comport
Author:
Dejan Crnila, 1998 - 2002
Maintainers:
Lars B. Dybdahl, 2003
License:
Public Domain
}
unit VTEmuEsc;
{$mode delphi}
interface
uses
Classes;
type
// terminal character result
TEscapeResult = (erChar, erCode, erNothing);
// terminal escape codes
TEscapeCode = (ecUnknown, ecNotCompleted, ecCursorUp, ecCursorDown,
ecCursorLeft, ecCursorRight, ecCursorHome, ecCursorEnd, ecCursorMove, ecCursorMoveX, ecCursorMoveY,
ecReverseLineFeed, ecAppCursorLeft, ecAppCursorRight, ecAppCursorUp, ecAppCursorDown,
ecAppCursorHome, ecAppCursorEnd, ecInsertKey, ecDeleteKey, ecPageUpKey, ecPageDownKey,
ecMouseDown, ecMouseUp, ecEraseLineLeft, ecEraseLineRight, ecEraseScreenFrom,
ecEraseLine, ecEraseScreen, ecEraseChar, ecSetTab, ecClearTab, ecClearAllTabs,
ecIdentify, ecIdentResponse, ecQueryDevice, ecReportDeviceOK,
ecReportDeviceFailure, ecQueryCursorPos, ecReportCursorPos,
ecAttributes, ecSetMode, ecResetMode, ecReset,
ecSaveCaretAndAttr, ecRestoreCaretAndAttr, ecSaveCaret, ecRestoreCaret,
ecTest, ecFuncKey, ecSetTextParams, ecScrollRegion, ecReverseIndex);
// terminal escape codes processor
TEscapeCodes = class
private
Fcharacter: Char;
FCode: TEscapeCode;
FData: string;
FParams: TStrings;
public
constructor Create;
destructor Destroy; override;
function ProcessChar(Ch: Char): TEscapeResult; virtual; abstract;
function EscCodeToStr(Code: TEscapeCode; AParams: TStrings): string; virtual; abstract;
function GetParam(Num: Integer; AParams: TStrings): Integer;
property Data: string read FData;
property Code: TEscapeCode read FCode;
property character: Char read Fcharacter;
property Params: TStrings read FParams;
end;
// VT52 escape codes
TEscapeCodesVT52 = class(TEscapeCodes)
private
FInSequence: Boolean;
function DetectCode(Str: string): TEscapeCode;
public
function ProcessChar(Ch: Char): TEscapeResult; override;
function EscCodeToStr(Code: TEscapeCode; AParams: TStrings): string; override;
end;
// ANSI/VT100 escape codes
TEscapeCodesVT100 = class(TEscapeCodes)
private
FInSequence: Boolean;
FInExtSequence: Boolean;
FInOscSequence: Boolean;
function DetectCode(Str: string): TEscapeCode;
function DetectExtCode(Str: string): TEscapeCode;
function DetectOscCode(Str: string): TEscapeCode;
public
function ProcessChar(Ch: Char): TEscapeResult; override;
function EscCodeToStr(Code: TEscapeCode; AParams: TStrings): string; override;
end;
implementation
uses
SysUtils;
(*****************************************
* TEscapeCodes class *
*****************************************)
constructor TEscapeCodes.Create;
begin
inherited Create;
FParams := TStringList.Create;
end;
destructor TEscapeCodes.Destroy;
begin
FParams.Free;
inherited Destroy;
end;
function TEscapeCodes.GetParam(Num: Integer; AParams: TStrings): Integer;
begin
if (AParams = nil) or (AParams.Count < Num) then
Result := 1
else
try
Result := StrToInt(AParams[Num - 1]);
except
Result := 1;
end;
end;
(*****************************************
* TEscapeCodesVT52 class *
*****************************************)
// process character
function TEscapeCodesVT52.ProcessChar(Ch: Char): TEscapeResult;
var
TempCode: TEscapeCode;
begin
Result := erNothing;
if not FInSequence then
begin
if Ch = #27 then
begin
FData := '';
FInSequence := True;
end
else begin
Fcharacter := Ch;
Result := erChar;
end;
end else
begin
FData := FData + Ch;
TempCode := DetectCode(FData);
if TempCode <> ecNotCompleted then
begin
FCode := TempCode;
FInSequence := False;
Result := erCode;
end;
end;
end;
// escape code to string
function TEscapeCodesVT52.EscCodeToStr(Code: TEscapeCode; AParams: TStrings): string;
begin
case Code of
ecCursorUp: Result := #27'A';
ecCursorDown: Result := #27'B';
ecCursorRight: Result := #27'C';
ecCursorLeft: Result := #27'D';
ecCursorHome: Result := #27'H';
ecReverseLineFeed: Result := #27'I';
ecEraseScreenFrom: Result := #27'J';
ecEraseLineRight: Result := #27'K';
ecIdentify: Result := #27'Z';
ecIdentResponse: Result := #27'/Z';
ecCursorMove: Result := #27'Y' +
Chr(GetParam(1, AParams) + 31) + Chr(GetParam(2, AParams) + 31);
else
Result := '';
end;
end;
// get escape code from string
function TEscapeCodesVT52.DetectCode(Str: string): TEscapeCode;
begin
Result := ecUnknown;
case Str[1] of
'A': Result := ecCursorUp;
'B': Result := ecCursorDown;
'C': Result := ecCursorRight;
'D': Result := ecCursorLeft;
'H': Result := ecCursorHome;
'I': Result := ecReverseLineFeed;
'J': Result := ecEraseScreenFrom;
'K': Result := ecEraseLineRight;
'Z': Result := ecIdentify;
'/': begin
if Length(Str) = 1 then
Result := ecNotCompleted
else
if (Length(Str) = 2) and (Str = '/Z') then
Result := ecIdentResponse;
end;
'Y': begin
if Length(Str) < 3 then
Result := ecNotCompleted
else
begin
Result := ecCursorMove;
FParams.Add(IntToStr(Ord(Str[3]) - 31));
FParams.Add(IntToStr(Ord(Str[2]) - 31));
end;
end;
end;
end;
(*****************************************
* TEscapeCodesVT100class *
*****************************************)
// process character
function TEscapeCodesVT100.ProcessChar(Ch: Char): TEscapeResult;
var
TempCode: TEscapeCode;
begin
Result := erNothing;
if not FInSequence then
begin
if Ch = #27 then
begin
FData := '';
FInSequence := True;
end
else begin
Fcharacter := Ch;
Result := erChar;
end;
end else
begin
FData := FData + Ch;
TempCode := ecNotCompleted;
if FInExtSequence then
TempCode := DetectExtCode(FData)
else if FInOscSequence then
TempCode := DetectOscCode(FData)
else
// character [ after ESC defines extended escape code
if FData[1] = '[' then
FInExtSequence := True
else if FData[1] = ']' then
FInOscSequence := True
else
TempCode := DetectCode(FData);
if TempCode <> ecNotCompleted then
begin
FCode := TempCode;
FInSequence := False;
FInExtSequence := False;
FInOscSequence := False;
Result := erCode;
end;
end;
end;
// escape code to string conversion
function TEscapeCodesVT100.EscCodeToStr(Code: TEscapeCode;
AParams: TStrings): string;
var
AKey: Integer;
begin
case Code of
ecIdentify: Result := #27'[c';
ecIdentResponse: Result := Format(#27'[?1;%dc', [GetParam(1, AParams)]);
ecQueryCursorPos: Result := #27'[6n';
ecReportCursorPos: Result := Format(#27'[%d;%dR', [GetParam(1, AParams), GetParam(2, AParams)]);
ecQueryDevice: Result := #27'[5n';
ecReportDeviceOK: Result := #27'[0n';
ecReportDeviceFailure: Result := #27'[3n';
ecCursorUp: Result := #27'[A';
ecCursorDown: Result := #27'[B';
ecCursorRight: Result := #27'[C';
ecAppCursorLeft: Result := #27'OD';
ecAppCursorUp: Result := #27'OA';
ecAppCursorDown: Result := #27'OB';
ecAppCursorRight: Result := #27'OC';
ecAppCursorHome: Result := #27'OH';
ecAppCursorEnd: Result := #27'OF';
ecCursorLeft: Result := #27'[D';
ecCursorHome: Result := #27'[H';
ecCursorEnd: Result := #27'[F';
ecCursorMove: Result := Format(#27'[%d;%df', [GetParam(1, AParams), GetParam(2, AParams)]);
ecEraseScreenFrom: Result := #27'[J';
ecEraseLineRight: Result := #27'[K';
ecEraseScreen: Result := #27'[2J';
ecEraseLine: Result := #27'[2K';
ecSetTab: Result := #27'H';
ecClearTab: Result := #27'[g';
ecClearAllTabs: Result := #27'[3g';
ecAttributes: Result := #27'[m'; // popravi
ecSetMode: Result := #27'[h';
ecResetMode: Result := #27'[l';
ecReset: Result := #27'c';
ecSaveCaret: Result := #27'[s';
ecRestoreCaret: Result := #27'[u';
ecSaveCaretAndAttr: Result := #27'7';
ecRestoreCaretAndAttr: Result := #27'8';
ecTest: Result := #27'#8';
ecFuncKey:
begin
AKey:= GetParam(1, AParams);
case AKey of
0: Result := #27'OP';
1: Result := #27'OQ';
2: Result := #27'OR';
3: Result := #27'OS';
4: Result := #27'[15~';
5: Result := #27'[17~';
6: Result := #27'[18~';
7: Result := #27'[19~';
8: Result := #27'[20~';
9: Result := #27'[21~';
10: Result := #27'[23~';
11: Result := #27'[24~';
end;
end;
ecInsertKey: Result := #27'[2~';
ecDeleteKey: Result := #27'[3~';
ecPageUpKey: Result := #27'[5~';
ecPageDownKey: Result := #27'[6~';
ecMouseDown:
Result := Format(#27'[<%d;%d;%dM', [GetParam(1, AParams), GetParam(2, AParams), GetParam(3, AParams)]);
ecMouseUp:
Result := Format(#27'[<%d;%d;%dm', [GetParam(1, AParams), GetParam(2, AParams), GetParam(3, AParams)]);
else
Result := '';
end;
end;
// get vt100 escape code from string
function TEscapeCodesVT100.DetectCode(Str: string): TEscapeCode;
begin
if Length(Str) = 1 then
case Str[1] of
'H': Result := ecSetTab;
'c': Result := ecReset;
'M': Result := ecReverseIndex;
'7': Result := ecSaveCaretAndAttr;
'8': Result := ecRestoreCaretAndAttr;
'#': Result := ecNotCompleted;
'O': Result := ecNotCompleted;
else
Result := ecUnknown;
end
else
begin
Result := ecUnknown;
if Str = '#8' then
Result := ecTest;
if Str[1] = 'O' then
case Str[2] of
'A': Result := ecAppCursorUp;
'B': Result := ecAppCursorDown;
'C': Result := ecAppCursorRight;
'D': Result := ecAppCursorLeft;
'H': Result := ecAppCursorHome;
'F': Result := ecAppCursorEnd;
end;
end;
end;
// get extended vt100 escape code from string
function TEscapeCodesVT100.DetectExtCode(Str: string): TEscapeCode;
var
LastCh: Char;
TempParams: TStrings;
procedure ParseParams(Str: string);
var
I: Integer;
TempStr: string;
begin
I := 1;
TempStr := '';
while I <= Length(Str) do
begin
if (Str[I] = ';') and (TempStr <> '') then
begin
TempParams.Add(TempStr);
TempStr := '';
end
else
TempStr := TempStr + Str[I];
Inc(I);
end;
if (TempStr <> '') then
TempParams.Add(TempStr);
end;
function CodeEraseScreen: TEscapeCode;
var
Str: string;
begin
if TempParams.Count = 0 then
Result := ecEraseScreenFrom
else
begin
Str := TempParams[0];
case Str[1] of
'0': Result := ecEraseScreenFrom;
'2': Result := ecEraseScreen;
else
Result := ecUnknown;
end;
end;
TempParams.Clear;
end;
function CodeEraseLine: TEscapeCode;
var
Str: string;
begin
if TempParams.Count = 0 then
Result := ecEraseLineRight
else
begin
Str := TempParams[0];
case Str[1] of
'0': Result := ecEraseLineRight;
'1': Result := ecEraseLineLeft;
'2': Result := ecEraseLine;
else
Result := ecUnknown;
end;
end;
TempParams.Clear;
end;
function CodeTab: TEscapeCode;
var
Str: string;
begin
if TempParams.Count = 0 then
Result := ecClearTab
else
begin
Str := TempParams[0];
case Str[1] of
'0': Result := ecClearTab;
'3': Result := ecClearAllTabs;
else
Result := ecUnknown;
end;
end;
TempParams.Clear;
end;
function CodeDevice: TEscapeCode;
var
Str: string;
begin
if TempParams.Count = 0 then
Result := ecUnknown
else
begin
Str := TempParams[0];
case Str[1] of
'5': Result := ecQueryDevice;
'0': Result := ecReportDeviceOK;
'3': Result := ecReportDeviceFailure;
'6': Result := ecQueryCursorPos;
else
Result := ecUnknown;
end;
end;
TempParams.Clear;
end;
function CodeIdentify: TEscapeCode;
begin
if (TempParams.Count = 0) or
((TempParams.Count = 1) and (TempParams[0] = '0'))
then
Result := ecIdentify
else
if (TempParams.Count = 2) and (TempParams[1] = '?1') then
Result := ecIdentResponse
else
Result := ecUnknown;
end;
begin
Result := ecNotCompleted;
LastCh := Str[Length(Str)];
{$IFDEF Unicode} if not CharInSet(LastCh,['A'..'Z', 'a'..'z']) then Exit;
{$ELSE} if not (LastCh in ['A'..'Z', 'a'..'z']) then Exit; {$ENDIF}
TempParams := TStringList.Create;
try
ParseParams(Copy(Str, 2, Length(Str) - 2));
case LastCh of
'A': Result := ecCursorUp;
'B': Result := ecCursorDown;
'C': Result := ecCursorRight;
'D': Result := ecCursorLeft;
'H': Result := ecCursorHome;
'F': Result := ecCursorEnd;
'f': Result := ecCursorMove;
'd': Result := ecCursorMoveY;
'G': Result := ecCursorMoveX;
'J': Result := CodeEraseScreen;
'K': Result := CodeEraseLine;
'X': Result := ecEraseChar;
'g': Result := CodeTab;
'm': Result := ecAttributes;
'h': Result := ecSetMode;
'l': Result := ecResetMode;
's': Result := ecSaveCaret;
'u': Result := ecRestoreCaret;
'n': Result := CodeDevice;
'c': Result := CodeIdentify;
'R': Result := ecReportCursorPos;
'r': Result := ecScrollRegion;
else
Result := ecUnknown;
end;
FParams.Assign(TempParams);
finally
TempParams.Free;
end;
end;
function TEscapeCodesVT100.DetectOscCode(Str: string): TEscapeCode;
var
LastCh: Char;
begin
Result := ecNotCompleted;
LastCh := Str[Length(Str)];
if (LastCh = #7) then
begin
Result:= ecSetTextParams;
end;
end;
end.

474
components/virtualterminal/source/win/vtemupty.pas Normal file
View file

@ -0,0 +1,474 @@
{
Double Commander
-------------------------------------------------------------------------
Windows pseudoterminal device implementation
Copyright (C) 2021 Alexander Koblov (alexx2000@mail.ru)
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
}
unit VTEmuPty;
{$mode delphi}
interface
uses
Classes, SysUtils, LCLProc, LCLType, Windows, VTEmuCtl;
type
{ TPtyDevice }
TPtyDevice = class(TCustomPtyDevice)
private
FPty: PVOID;
FSize: TCoord;
FLength: Integer;
FThread: TThread;
FPipeIn, FPipeOut: THandle;
FBuffer: array[0..8191] of AnsiChar;
protected
procedure ReadySync;
procedure ReadThread;
procedure DestroyPseudoConsole;
procedure SetConnected(AValue: Boolean); override;
function CreatePseudoConsole(const ACommand: String): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function WriteStr(const Str: string): Integer; override;
function SetCurrentDir(const Path: String): Boolean; override;
function SetScreenSize(aCols, aRows: Integer): Boolean; override;
end;
implementation
uses
CTypes, DCOSUtils, DCConvertEncoding;
type
TConsoleType = (ctNone, ctNative, ctEmulate);
var
ConsoleType: TConsoleType = ctNone;
procedure ClosePipe(var AHandle: THandle);
begin
if (AHandle <> INVALID_HANDLE_VALUE) then
begin
CloseHandle(AHandle);
AHandle:= INVALID_HANDLE_VALUE;
end;
end;
{
*******************************************************************************
Windows Pseudo Console (ConPTY), Windows 10 1809 and higher
*******************************************************************************
}
const
EXTENDED_STARTUPINFO_PRESENT = $00080000;
PROC_THREAD_ATTRIBUTE_PSEUDOCONSOLE = $00020016;
type
PHPCON = ^HPCON;
HPCON = type PVOID;
SIZE_T = type ULONG_PTR;
PSIZE_T = type PULONG_PTR;
LPPROC_THREAD_ATTRIBUTE_LIST = type PVOID;
STARTUPINFOEXW = record
StartupInfo: STARTUPINFOW;
lpAttributeList: LPPROC_THREAD_ATTRIBUTE_LIST;
end;
var
CreatePseudoConsole: function(size: COORD; hInput: HANDLE; hOutput: HANDLE;
dwFlags: DWORD; phPC: PHPCON): HRESULT; stdcall;
ClosePseudoConsole: procedure(hPC: HPCON); stdcall;
ResizePseudoConsole: function(hPC: HPCON; size: COORD): HRESULT; stdcall;
InitializeProcThreadAttributeList: function(lpAttributeList: LPPROC_THREAD_ATTRIBUTE_LIST;
dwAttributeCount: DWORD; dwFlags: DWORD;
lpSize: PSIZE_T): BOOL; stdcall;
UpdateProcThreadAttribute: function(lpAttributeList: LPPROC_THREAD_ATTRIBUTE_LIST;
dwFlags: DWORD; Attribute: DWORD_PTR;
lpValue: PVOID; cbSize: SIZE_T;
lpPreviousValue: PVOID; lpReturnSize: PSIZE_T): BOOL; stdcall;
DeleteProcThreadAttributeList: procedure(lpAttributeList: LPPROC_THREAD_ATTRIBUTE_LIST); stdcall;
function CreatePseudoConsoleNew(const ACommand: String; phPC: PPointer; phPipeIn, phPipeOut: PHandle; ASize: COORD): Boolean;
var
attrListSize: SIZE_T = 0;
startupInfo: STARTUPINFOEXW;
piClient: PROCESS_INFORMATION;
hPipePTYIn: HANDLE = INVALID_HANDLE_VALUE;
hPipePTYOut: HANDLE = INVALID_HANDLE_VALUE;
begin
startupInfo:= Default(STARTUPINFOEXW);
Result:= CreatePipe(hPipePTYIn, phPipeOut^, nil, 0) and
CreatePipe(phPipeIn^, hPipePTYOut, nil, 0);
if Result then
begin
Result:= CreatePseudoConsole(ASize, hPipePTYIn, hPipePTYOut, 0, phPC) = S_OK;
// We can close the handles here because they are duplicated in the ConHost
if Result then
begin
CloseHandle(hPipePTYIn);
CloseHandle(hPipePTYOut);
hPipePTYIn:= INVALID_HANDLE_VALUE;
hPipePTYOut:=INVALID_HANDLE_VALUE;
end;
end;
if Result then
begin
startupInfo.StartupInfo.cb:= SizeOf(STARTUPINFOEXW);
InitializeProcThreadAttributeList(nil, 1, 0, @attrListSize);
startupInfo.lpAttributeList:= GetMem(attrListSize);
Result:= Assigned(startupInfo.lpAttributeList);
if Result then
begin
// Initialize thread attribute list and set Pseudo Console attribute
Result:= InitializeProcThreadAttributeList(startupInfo.lpAttributeList, 1, 0, @attrListSize) and
UpdateProcThreadAttribute(startupInfo.lpAttributeList,0,
PROC_THREAD_ATTRIBUTE_PSEUDOCONSOLE,
phPC^, SizeOf(HPCON), nil, nil);
end;
end;
if Result then
begin
Result:= CreateProcessW(nil, PWideChar(CeUtf8ToUtf16(ACommand)),
nil, nil, False, EXTENDED_STARTUPINFO_PRESENT,
nil, nil, @startupInfo.StartupInfo, @piClient);
end;
if not Result then
begin
ClosePipe(phPipeIn^);
ClosePipe(phPipeOut^);
ClosePipe(hPipePTYIn);
ClosePipe(hPipePTYOut);
end;
// Cleanup attribute list
if Assigned(startupInfo.lpAttributeList) then
begin
DeleteProcThreadAttributeList(startupInfo.lpAttributeList);
FreeMem(startupInfo.lpAttributeList);
end;
end;
function InitializeNew: Boolean;
var
hModule: HINST;
begin
Result:= (Win32MajorVersion >= 10);
if Result then
begin
hModule:= GetModuleHandle(Kernel32);
CreatePseudoConsole:= GetProcAddress(hModule, 'CreatePseudoConsole');
Result:= Assigned(CreatePseudoConsole);
if Result then
begin
ClosePseudoConsole:= GetProcAddress(hModule, 'ClosePseudoConsole');
ResizePseudoConsole:= GetProcAddress(hModule, 'ResizePseudoConsole');
UpdateProcThreadAttribute:= GetProcAddress(hModule, 'UpdateProcThreadAttribute');
DeleteProcThreadAttributeList:= GetProcAddress(hModule, 'DeleteProcThreadAttributeList');
InitializeProcThreadAttributeList:= GetProcAddress(hModule, 'InitializeProcThreadAttributeList');
end;
end;
end;
{
*******************************************************************************
WinPTY
*******************************************************************************
}
const
WINPTY_MOUSE_MODE_AUTO = 1;
WINPTY_MOUSE_MODE_FORCE = 2;
// Agent RPC call: process creation
WINPTY_SPAWN_FLAG_AUTO_SHUTDOWN = 1;
WINPTY_SPAWN_FLAG_EXIT_AFTER_SHUTDOWN = 2;
// Configuration of a new agent
WINPTY_FLAG_CONERR = $01;
WINPTY_FLAG_PLAIN_OUTPUT = $02;
WINPTY_FLAG_COLOR_ESCAPES = $04;
WINPTY_FLAG_ALLOW_CURPROC_DESKTOP_CREATION = $08;
// Error codes
WINPTY_ERROR_SUCCESS = 0;
WINPTY_ERROR_OUT_OF_MEMORY = 1;
WINPTY_ERROR_SPAWN_CREATE_PROCESS_FAILED = 2;
WINPTY_ERROR_LOST_CONNECTION = 3;
WINPTY_ERROR_AGENT_EXE_MISSING = 4;
WINPTY_ERROR_UNSPECIFIED = 5;
WINPTY_ERROR_AGENT_DIED = 6;
WINPTY_ERROR_AGENT_TIMEOUT = 7;
WINPTY_ERROR_AGENT_CREATION_FAILED = 8;
type
winpty_t = record end;
Pwinpty_t = ^winpty_t;
winpty_result_t = type DWORD;
winpty_config_t = record end;
Pwinpty_config_t = ^winpty_config_t;
winpty_error_t = record end;
winpty_error_ptr_t = ^winpty_error_t;
Pwinpty_error_ptr_t = ^winpty_error_ptr_t;
winpty_spawn_config_t = record end;
Pwinpty_spawn_config_t = ^winpty_spawn_config_t;
var
winpty_config_new: function(agentFlags: UInt64; err: Pwinpty_error_ptr_t): Pwinpty_config_t; cdecl;
winpty_config_free: procedure(cfg: Pwinpty_config_t); cdecl;
winpty_config_set_initial_size: procedure(cfg: Pwinpty_config_t; cols, rows: cint); cdecl;
winpty_config_set_mouse_mode: procedure(cfg: Pwinpty_config_t; mouseMode: cint); cdecl;
winpty_open: function(const cfg: Pwinpty_config_t; err: Pwinpty_error_ptr_t): Pwinpty_t; cdecl;
winpty_free: procedure(wp: Pwinpty_t); cdecl;
winpty_error_code: function(err: winpty_error_ptr_t): winpty_result_t; cdecl;
winpty_error_msg: function(err: winpty_error_ptr_t): LPCWSTR; cdecl;
winpty_error_free: procedure(err: winpty_error_ptr_t); cdecl;
winpty_spawn_config_new: function(spawnFlags: UInt64; appname, cmdline, cwd,
env: LPCWSTR; err: Pwinpty_error_ptr_t): Pwinpty_spawn_config_t; cdecl;
winpty_spawn_config_free: procedure(cfg: Pwinpty_spawn_config_t); cdecl;
winpty_spawn: function(wp: Pwinpty_t; const cfg: Pwinpty_spawn_config_t;
process_handle, thread_handle: PHandle;
create_process_error: PDWORD; err: Pwinpty_error_ptr_t): BOOL; cdecl;
winpty_set_size: function(wp: Pwinpty_t; cols, rows: cint; err: Pwinpty_error_ptr_t): BOOL; cdecl;
winpty_conin_name: function(wp: Pwinpty_t): LPCWSTR; cdecl;
winpty_conout_name: function(wp: Pwinpty_t): LPCWSTR; cdecl;
winpty_conerr_name: function(wp: Pwinpty_t): LPCWSTR; cdecl;
function CreatePseudoConsoleOld(const ACommand: String; phPC: PPointer; phPipeIn, phPipeOut: PHandle; ASize: COORD): Boolean;
var
childHandle: HANDLE;
lastError: DWORD = 0;
agentCfg: Pwinpty_config_t;
spawnCfg: Pwinpty_spawn_config_t;
agentFlags: DWORD = WINPTY_FLAG_ALLOW_CURPROC_DESKTOP_CREATION;
begin
// SetEnvironmentVariableW('WINPTY_SHOW_CONSOLE', '1');
agentCfg:= winpty_config_new(agentFlags, nil);
Result:= Assigned(agentCfg);
if Result then
begin
winpty_config_set_initial_size(agentCfg, ASize.X, ASize.Y);
phPC^:= winpty_open(agentCfg, nil);
Result:= Assigned(phPC^);
winpty_config_free(agentCfg);
if Result then
begin
phPipeIn^:= CreateFileW(winpty_conout_name(phPC^), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
phPipeOut^:= CreateFileW(winpty_conin_name(phPC^), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
spawnCfg:= winpty_spawn_config_new(WINPTY_SPAWN_FLAG_AUTO_SHUTDOWN,
nil, PWideChar(CeUtf8ToUtf16(ACommand)), nil, nil, nil);
Result:= Assigned(spawnCfg);
if Result then
begin
Result:= winpty_spawn(phPC^, spawnCfg, @childHandle, nil, @lastError, nil);
winpty_spawn_config_free(spawnCfg);
end;
if not Result then
begin
ClosePipe(phPipeIn^);
ClosePipe(phPipeOut^);
winpty_free(phPC^);
end;
end;
end;
end;
var
libwinpty: HINST;
function InitializeOld: Boolean;
begin
libwinpty:= LoadLibrary('winpty.dll');
Result:= (libwinpty <> 0);
if Result then
begin
winpty_config_new:= GetProcAddress(libwinpty, 'winpty_config_new');
winpty_config_free:= GetProcAddress(libwinpty, 'winpty_config_free');
winpty_config_set_initial_size:= GetProcAddress(libwinpty, 'winpty_config_set_initial_size');
winpty_config_set_mouse_mode:= GetProcAddress(libwinpty, 'winpty_config_set_mouse_mode');
winpty_open:= GetProcAddress(libwinpty, 'winpty_open');
winpty_free:= GetProcAddress(libwinpty, 'winpty_free');
winpty_error_code:= GetProcAddress(libwinpty, 'winpty_error_code');
winpty_error_msg:= GetProcAddress(libwinpty, 'winpty_error_msg');
winpty_error_free:= GetProcAddress(libwinpty, 'winpty_error_free');
winpty_spawn_config_new:= GetProcAddress(libwinpty, 'winpty_spawn_config_new');
winpty_spawn_config_free:= GetProcAddress(libwinpty, 'winpty_spawn_config_free');
winpty_spawn:= GetProcAddress(libwinpty, 'winpty_spawn');
winpty_set_size:= GetProcAddress(libwinpty, 'winpty_set_size');
winpty_conin_name:= GetProcAddress(libwinpty, 'winpty_conin_name');
winpty_conout_name:= GetProcAddress(libwinpty, 'winpty_conout_name');
winpty_conerr_name:= GetProcAddress(libwinpty, 'winpty_conerr_name');
end;
end;
{ TPtyDevice }
procedure TPtyDevice.SetConnected(AValue: Boolean);
var
AShell: String;
begin
if FConnected = AValue then Exit;
FConnected:= AValue;
if FConnected then
begin
AShell:= mbGetEnvironmentVariable('ComSpec');
if Length(AShell) = 0 then AShell:= 'cmd.exe';
FConnected:= CreatePseudoConsole(AShell);
if FConnected then
begin
FThread:= TThread.ExecuteInThread(ReadThread);
end;
end
else begin
DestroyPseudoConsole;
end;
end;
procedure TPtyDevice.ReadySync;
begin
if Assigned(FOnRxBuf) then
FOnRxBuf(Self, FBuffer, FLength);
end;
procedure TPtyDevice.ReadThread;
begin
while FConnected do
begin
FLength:= FileRead(FPipeIn, FBuffer, SizeOf(FBuffer));
if (FLength > 0) then
begin
TThread.Synchronize(nil, ReadySync);
end;
end;
end;
procedure TPtyDevice.DestroyPseudoConsole;
begin
case ConsoleType of
ctNative: ClosePseudoConsole(FPty);
ctEmulate: winpty_free(FPty);
end;
FPty:= nil;
ClosePipe(FPipeIn);
ClosePipe(FPipeOut);
end;
function TPtyDevice.CreatePseudoConsole(const ACommand: String): Boolean;
begin
case ConsoleType of
ctNative: Result:= CreatePseudoConsoleNew(ACommand, @FPty, @FPipeIn, @FPipeOut, FSize);
ctEmulate: Result:= CreatePseudoConsoleOld(ACommand, @FPty, @FPipeIn, @FPipeOut, FSize);
ctNone: Result:= False;
end;
end;
constructor TPtyDevice.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSize.X:= 80;
FSize.Y:= 25;
FPipeIn:= INVALID_HANDLE_VALUE;
FPipeOut:= INVALID_HANDLE_VALUE;
end;
destructor TPtyDevice.Destroy;
begin
inherited Destroy;
SetConnected(False);
end;
function TPtyDevice.SetCurrentDir(const Path: String): Boolean;
begin
Result:= WriteStr('cd /D "' + Path + '"' + #13#10) > 0;
end;
function TPtyDevice.WriteStr(const Str: string): Integer;
begin
Result:= FileWrite(FPipeOut, Pointer(Str)^, Length(Str));
end;
function TPtyDevice.SetScreenSize(aCols, aRows: Integer): Boolean;
var
ASize: TCoord;
begin
if (FPty = nil) then Exit(False);
if (ConsoleType = ctEmulate) then
begin
Result:= winpty_set_size(FPty, aCols, aRows, nil);
end
else if (ConsoleType = ctNative) then
begin
ASize.Y:= aRows;
ASize.X:= aCols;
Result:= Succeeded(ResizePseudoConsole(FPty, ASize));
end;
if Result then
begin
FSize.Y:= aRows;
FSize.X:= aCols;
end;
end;
procedure Initialize;
begin
if InitializeNew then
ConsoleType:= ctNative
else if InitializeOld then
ConsoleType:= ctEmulate;
end;
initialization
Initialize;
end.

52
components/virtualterminal/virtualterminal.lpk Normal file
View file

@ -0,0 +1,52 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="5">
<PathDelim Value="\"/>
<Name Value="VirtualTerminal"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="source;source\$(SrcOS)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
</CompilerOptions>
<Files>
<Item>
<Filename Value="source\vtcolortable.pas"/>
<UnitName Value="VTColorTable"/>
</Item>
<Item>
<Filename Value="source\vtemuctl.pas"/>
<UnitName Value="VTEmuCtl"/>
</Item>
<Item>
<Filename Value="source\vtemuesc.pas"/>
<UnitName Value="VTEmuEsc"/>
</Item>
<Item>
<Filename Value="source\$(SrcOS)\vtemupty.pas"/>
<UnitName Value="VTEmuPty"/>
</Item>
</Files>
<RequiredPkgs>
<Item>
<PackageName Value="doublecmd_common"/>
</Item>
<Item>
<PackageName Value="LCL"/>
</Item>
<Item>
<PackageName Value="FCL"/>
</Item>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>

21
components/virtualterminal/virtualterminal.pas Normal file
View file

@ -0,0 +1,21 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit VirtualTerminal;
{$warn 5023 off : no warning about unused units}
interface
uses
VTColorTable, VTEmuCtl, VTEmuEsc, VTEmuPty, LazarusPackageIntf;
implementation
procedure Register;
begin
end;
initialization
RegisterPackage('VirtualTerminal', @Register);
end.