style) then begin
W.Add('<');
W.AddShort(HTML[style]);
end;
end;
lst := style;
end;
procedure TTextWriterEscape.NewMarkdownLine;
label none;
var c: cardinal;
begin
if P=nil then
exit;
c := PCardinal(P)^;
if c and $ffffff=ord('`')+ord('`')shl 8+ord('`')shl 16 then begin
inc(P,3);
if lst=twlCode3 then begin
lst := twlCode4; // to close
NewMarkdownLine;
exit;
end;
SetLine(twlCode3);
end;
if lst=twlCode3 then
exit; // no prefix process within ``` code blocks
if c=$20202020 then begin
SetLine(twlCode4);
inc(P,4);
exit;
end;
P := GotoNextNotSpaceSameLine(P); // don't implement nested levels yet
case P^ of
'*','+','-':
if P[1]=' ' then
SetLine(twlUnorderedList) else
goto none;
'1'..'9': begin // first should be 1. then any ##. number to continue
B := P;
repeat inc(P) until not (P^ in ['0'..'9']);
if (P^='.') and ((lst=twlOrderedList) or (PWord(B)^=ord('1')+ord('.')shl 8)) then
SetLine(twlOrderedList) else begin
P := B;
none: if lst=twlParagraph then begin
c := PWord(P)^; // detect blank line to separate paragraphs
if c=$0a0d then
inc(P,2) else
if c and $ff=$0a then
inc(P) else begin
W.AddOnce(' ');
exit;
end;
end;
SetLine(twlParagraph);
exit;
end;
end;
'>':
if P[1]=' ' then
SetLine(twlBlockquote) else
goto none;
else
goto none;
end;
P := GotoNextNotSpaceSameLine(P+1);
end;
procedure TTextWriterEscape.AddHtmlEscapeWiki(dest: TTextWriter; src: PUTF8Char;
escape: TTextWriterHTMLEscape);
begin
Start(dest,src,escape);
SetLine(twlParagraph);
repeat
case ProcessText([0,10,13,ord('*'),ord('+'),ord('`'),ord('\'),ord(':')]) of
#0: break;
#10,#13: begin
EndOfParagraph;
SetLine(twlParagraph);
continue;
end;
'\': if P[1] in ['\','`','*','+'] then begin
inc(P);
W.Add(P^);
end else
W.Add('\');
'*':
Toggle(tweItalic);
'+':
Toggle(tweBold);
'`':
Toggle(tweCode);
'h': begin
ProcessHRef;
continue;
end;
':': begin
ProcessEmoji;
continue;
end;
end;
inc(P);
until false;
EndOfParagraph;
SetLine(twlNone);
end;
procedure TTextWriterEscape.AddHtmlEscapeMarkdown(dest: TTextWriter;
src: PUTF8Char; escape: TTextWriterHTMLEscape);
begin
Start(dest,src,escape);
NewMarkDownLine;
repeat
if lst>=twlCode4 then // no Markdown tags within code blocks
if ProcessText([0,10,13])=#0 then
break else begin
if PWord(P)^=$0a0d then
inc(P,2) else
inc(P);
W.AddCR; // keep LF within
NewMarkdownLine;
continue;
end else
case ProcessText([0,10,13,ord('*'),ord('_'),ord('`'),ord('\'),ord('['),ord('!'),ord(':')]) of
#0: break;
#10,#13: begin
EndOfParagraph;
NewMarkdownLine;
continue;
end;
'\': if P[1] in ['\','`','*','_','[',']','{','}','(',')','#','+','-','.','!'] then begin
inc(P);
W.Add(P^); // backslash escape
end else
W.Add('\');
'*','_':
if P[1]=P[0] then begin
inc(P); // **This text will be bold** or __This text will be bold__
Toggle(tweBold);
end else // *This text will be italic* or _This text will be italic_
Toggle(tweItalic);
'`':
Toggle(tweCode); // `This text will be code`
'[':
if ProcessLink then begin // [GitHub](https://github.com)
W.AddShort('') else
W.Add('"','>');
W.AddHtmlEscape(B2,P2-B2,fmt);
W.AddShort(''); // no continune -> need inc(P) over ending )
end else
W.Add('['); // not a true link -> just append
'!': begin
if P[1]='[' then begin
inc(P);
if ProcessLink then begin
W.AddShort(';
W.AddNoJSONEscape(B,P-B);
W.AddShort(')
');
inc(P);
continue;
end;
dec(P);
end;
W.Add('!'); // not a true image
end;
'h': begin
ProcessHRef;
continue;
end;
':': begin
ProcessEmoji;
continue;
end;
end;
inc(P);
until false;
EndOfParagraph;
SetLine(twlNone);
end;
function HtmlEscapeWiki(const wiki: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
var temp: TTextWriterStackBuffer;
W: TTextWriter;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
AddHtmlEscapeWiki(W,pointer(wiki),esc);
W.SetText(result);
finally
W.Free;
end;
end;
function HtmlEscapeMarkdown(const md: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
var temp: TTextWriterStackBuffer;
W: TTextWriter;
begin
W := TTextWriter.CreateOwnedStream(temp);
try
AddHtmlEscapeMarkdown(W,pointer(md),esc);
W.SetText(result);
finally
W.Free;
end;
end;
procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
var doesc: TTextWriterEscape;
begin
doesc.AddHtmlEscapeWiki(W,P,esc);
end;
procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
var doesc: TTextWriterEscape;
begin
doesc.AddHtmlEscapeMarkdown(W,P,esc);
end;
function EmojiFromText(P: PUTF8Char; len: PtrInt): TEmoji;
begin // RTTI has shortstrings in adjacent L1 cache lines -> faster than EMOJI_TEXT[]
result := TEmoji(FindShortStringListTrimLowerCase(EMOJI_RTTI,ord(high(TEmoji))-1,P,len)+1);
end;
function EmojiParseDots(var P: PUTF8Char; W: TTextWriter): TEmoji;
var c: PUTF8Char;
begin
result := eNone;
inc(P); // ignore trailing ':'
c := P;
if c[-2]<=' ' then begin
if (c[1]<=' ') and (c^ in ['('..'|']) then
result := EMOJI_AFTERDOTS[c^]; // e.g. :)
if result=eNone then begin
while c^ in ['a'..'z','A'..'Z','_'] do
inc(c);
if (c^=':') and (c[1]<=' ') then // try e.g. :joy_cat:
result := EmojiFromText(P,c-P);
end;
if result<>eNone then begin
P := c+1; // continue parsing after the Emoji text
if W<>nil then
W.AddNoJSONEscape(pointer(EMOJI_UTF8[result]),4);
exit;
end;
end;
if W<>nil then
W.Add(':');
end;
procedure EmojiToDots(P: PUTF8Char; W: TTextWriter);
var B: PUTF8Char;
c: cardinal;
begin
if (P<>nil) and (W<>nil) then
repeat
B := P;
while (P^<>#0) and (PWord(P)^<>$9ff0) do
inc(P);
W.AddNoJSONEscape(B,P-B);
if P^=#0 then
break;
B := P;
c := NextUTF8UCS4(P)-$1f5ff;
if c<=cardinal(high(TEmoji)) then
W.AddNoJSONEscapeUTF8(EMOJI_TAG[TEmoji(c)]) else
W.AddNoJSONEscape(B,P-B);
until P^=#0;
end;
function EmojiToDots(const text: RawUTF8): RawUTF8;
var W: TTextWriter;
tmp: TTextWriterStackBuffer;
begin
if PosExChar(#$f0,text)=0 then begin
result := text; // no UTF-8 smiley for sure
exit;
end;
W := TTextWriter.CreateOwnedStream(tmp);
try
EmojiToDots(pointer(text),W);
W.SetText(result);
finally
W.Free;
end;
end;
procedure EmojiFromDots(P: PUTF8Char; W: TTextWriter);
var B: PUTF8Char;
begin
if (P<>nil) and (W<>nil) then
repeat
B := P;
while not(P^ in [#0,':']) do
inc(P);
W.AddNoJSONEscape(B,P-B);
if P^=#0 then
break;
EmojiParseDots(P,W);
until P^=#0;
end;
function EmojiFromDots(const text: RawUTF8): RawUTF8;
var W: TTextWriter;
tmp: TTextWriterStackBuffer;
begin
W := TTextWriter.CreateOwnedStream(tmp);
try
EmojiFromDots(pointer(text),W);
W.SetText(result);
finally
W.Free;
end;
end;
{ ************ Command Line and Console process ************************** }
var
TextAttr: integer = ord(ccDarkGray);
{$I-}
{$ifdef MSWINDOWS}
procedure InitConsole;
begin
StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
if StdOut=INVALID_HANDLE_VALUE then
StdOut := 0;
end;
procedure TextColor(Color: TConsoleColor);
var oldAttr: integer;
begin
if StdOut=0 then
InitConsole;
oldAttr := TextAttr;
TextAttr := (TextAttr and $F0) or ord(Color);
if TextAttr<>oldAttr then
SetConsoleTextAttribute(StdOut,TextAttr);
end;
procedure TextBackground(Color: TConsoleColor);
var oldAttr: integer;
begin
if StdOut=0 then
InitConsole;
oldAttr := TextAttr;
TextAttr := (TextAttr and $0F) or (ord(Color) shl 4);
if TextAttr<>oldAttr then
SetConsoleTextAttribute(StdOut,TextAttr);
end;
function ConsoleKeyPressed(ExpectedKey: Word): Boolean;
var lpNumberOfEvents: DWORD;
lpBuffer: TInputRecord;
lpNumberOfEventsRead : DWORD;
nStdHandle: THandle;
begin
result := false;
nStdHandle := GetStdHandle(STD_INPUT_HANDLE);
lpNumberOfEvents := 0;
GetNumberOfConsoleInputEvents(nStdHandle,lpNumberOfEvents);
if lpNumberOfEvents<>0 then begin
PeekConsoleInput(nStdHandle,lpBuffer,1,lpNumberOfEventsRead);
if lpNumberOfEventsRead<>0 then
if lpBuffer.EventType=KEY_EVENT then
if lpBuffer.Event.KeyEvent.bKeyDown and
((ExpectedKey=0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode=ExpectedKey)) then
result := true else
FlushConsoleInputBuffer(nStdHandle) else
FlushConsoleInputBuffer(nStdHandle);
end;
end;
procedure ConsoleWaitForEnterKey;
{$ifdef DELPHI5OROLDER}
begin
readln;
end;
{$else}
var msg: TMsg;
begin
while not ConsoleKeyPressed(VK_RETURN) do begin
{$ifndef LVCL}
if GetCurrentThreadID=MainThreadID then
CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else
{$endif}
WaitMessage;
while PeekMessage(msg,0,0,0,PM_REMOVE) do
if Msg.Message=WM_QUIT then
exit else begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
{$endif DELPHI5OROLDER}
function Utf8ToConsole(const S: RawUTF8): RawByteString;
begin
result := TSynAnsiConvert.Engine(CP_OEMCP).UTF8ToAnsi(S);
end;
{$else MSWINDOWS}
// we bypass crt.pp since this unit cancels the SIGINT signal
procedure TextColor(Color: TConsoleColor);
const AnsiTbl : string[8]='04261537';
begin
{$ifdef FPC}{$ifdef Linux}
if not stdoutIsTTY then
exit;
{$endif}{$endif}
if ord(color)=TextAttr then
exit;
TextAttr := ord(color);
if ord(color)>=8 then
write(#27'[1;3',AnsiTbl[(ord(color) and 7)+1],'m') else
write(#27'[0;3',AnsiTbl[(ord(color) and 7)+1],'m');
ioresult;
end;
procedure TextBackground(Color: TConsoleColor);
begin // not implemented yet - but not needed either
end;
procedure ConsoleWaitForEnterKey;
var c: AnsiChar;
begin
{$ifdef FPC}
if IsMultiThread and (GetCurrentThreadID=MainThreadID) then
repeat
CheckSynchronize(100);
if UnixKeyPending then
repeat
c := #0;
if FpRead(StdInputHandle,c,1)<>1 then
break;
if c in [#10,#13] then
exit;
until false;
until false else
{$endif FPC}
ReadLn;
end;
function Utf8ToConsole(const S: RawUTF8): RawByteString;
begin
result := S; // expect a UTF-8 console under Linux/BSD
end;
{$endif MSWINDOWS}
function ConsoleReadBody: RawByteString;
var len, n: integer;
P: PByte;
{$ifndef FPC}StdInputHandle: THandle;{$endif}
begin
result := '';
{$ifdef MSWINDOWS}
{$ifndef FPC}StdInputHandle := GetStdHandle(STD_INPUT_HANDLE);{$endif}
if not PeekNamedPipe(StdInputHandle,nil,0,nil,@len,nil) then
{$else}
if fpioctl(StdInputHandle,FIONREAD,@len)<0 then
{$endif}
len := 0;
SetLength(result,len);
P := pointer(result);
while len>0 do begin
n := FileRead(StdInputHandle,P^,len);
if n<=0 then begin
result := ''; // read error
break;
end;
dec(len,n);
inc(P,n);
end;
end;
function StringToConsole(const S: string): RawByteString;
begin
result := Utf8ToConsole(StringToUTF8(S));
end;
procedure ConsoleWrite(const Text: RawUTF8; Color: TConsoleColor; NoLineFeed, NoColor: boolean);
begin
if not NoColor then
TextColor(Color);
write(Utf8ToConsole(Text));
if not NoLineFeed then
writeln;
ioresult;
end;
procedure ConsoleWrite(const Fmt: RawUTF8; const Args: array of const;
Color: TConsoleColor; NoLineFeed: boolean);
var tmp: RawUTF8;
begin
FormatUTF8(Fmt,Args,tmp);
ConsoleWrite(tmp,Color,NoLineFeed);
end;
procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean);
begin
ConsoleWrite(#13#10'Fatal exception ',cclightRed,true);
ConsoleWrite('%',[E.ClassName],ccWhite,true);
ConsoleWrite(' raised with message ',ccLightRed,true);
ConsoleWrite('%',[E.Message],ccLightMagenta);
TextColor(ccLightGray);
if WaitForEnterKey then begin
writeln(#13#10'Program will now abort');
{$ifndef LINUX}
writeln('Press [Enter] to quit');
if ioresult=0 then
Readln;
{$endif}
end;
ioresult;
end;
{$I+}
{$ifndef NOVARIANTS}
{ TCommandLine }
constructor TCommandLine.Create;
var i: integer;
p, sw: RawUTF8;
begin
inherited Create;
fValues.InitFast(ParamCount shr 1,dvObject);
for i := 1 to ParamCount do begin
p := StringToUTF8(ParamStr(i));
if p<>'' then
if p[1] in ['-','/'] then begin
if sw<>'' then
fValues.AddValue(sw,true); // -flag -switch value -> flag=true
sw := LowerCase(copy(p,2,100));
if sw='noprompt' then begin
fNoPrompt := true;
sw := '';
end;
end else
if sw<>'' then begin
fValues.AddValueFromText(sw,p,true);
sw := '';
end;
end;
if sw<>'' then
fValues.AddValue(sw,true); // trailing -flag
end;
constructor TCommandLine.Create(const switches: variant; aNoConsole: boolean);
begin
inherited Create;
fValues.InitCopy(switches,JSON_OPTIONS_FAST);
fNoPrompt := true;
fNoConsole := aNoConsole;
end;
constructor TCommandLine.Create(const NameValuePairs: array of const; aNoConsole: boolean);
begin
inherited Create;
fValues.InitObject(NameValuePairs,JSON_OPTIONS_FAST);
fNoPrompt := true;
fNoConsole := aNoConsole;
end;
constructor TCommandLine.CreateAsArray(firstParam: integer);
var i: integer;
begin
inherited Create;
fValues.InitFast(ParamCount,dvArray);
for i := firstParam to ParamCount do
fValues.AddItem(ParamStr(i));
end;
function TCommandLine.NoPrompt: boolean;
begin
result := fNoPrompt;
end;
function TCommandLine.ConsoleText(const LineFeed: RawUTF8): RawUTF8;
begin
result := RawUTF8ArrayToCSV(fLines,LineFeed);
end;
procedure TCommandLine.SetNoConsole(value: boolean);
begin
if value=fNoConsole then
exit;
if value then
fNoPrompt := true;
fNoConsole := false;
end;
procedure TCommandLine.TextColor(Color: TConsoleColor);
begin
if not fNoPrompt then
SynTable.TextColor(Color);
end;
procedure TCommandLine.Text(const Fmt: RawUTF8; const Args: array of const;
Color: TConsoleColor);
var msg: RawUTF8;
begin
FormatUTF8(Fmt,Args,msg);
{$I-}
if msg<>'' then begin
TextColor(Color);
AddRawUTF8(fLines,msg);
if not fNoConsole then
write(Utf8ToConsole(msg));
end;
if not fNoConsole then begin
writeln;
ioresult;
end;
{$I+}
end;
function TCommandLine.AsUTF8(const Switch, Default: RawUTF8;
const Prompt: string): RawUTF8;
var i: integer;
begin
i := fValues.GetValueIndex(Switch);
if i>=0 then begin // found
VariantToUTF8(fValues.Values[i],result);
fValues.Delete(i);
exit;
end;
result := Default;
if fNoPrompt or (Prompt='') then
exit;
TextColor(ccLightGray);
{$I-}
writeln(Prompt);
if ioresult<>0 then
exit; // no console -> no prompt
TextColor(ccCyan);
write(Switch);
if Default<>'' then
write(' [',Default,'] ');
write(': ');
TextColor(ccWhite);
readln(result);
writeln;
ioresult;
{$I+}
TextColor(ccLightGray);
result := trim(result);
if result='' then
result := Default;
end;
function TCommandLine.AsInt(const Switch: RawUTF8; Default: Int64;
const Prompt: string): Int64;
var res: RawUTF8;
begin
res := AsUTF8(Switch, Int64ToUtf8(Default), Prompt);
result := GetInt64Def(pointer(res),Default);
end;
function TCommandLine.AsDate(const Switch: RawUTF8; Default: TDateTime;
const Prompt: string): TDateTime;
var res: RawUTF8;
begin
res := AsUTF8(Switch, DateTimeToIso8601Text(Default), Prompt);
if res='0' then begin
result := 0;
exit;
end;
result := Iso8601ToDateTime(res);
if result=0 then
result := Default;
end;
function TCommandLine.AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer;
const Prompt: string): integer;
var res: RawUTF8;
begin
res := AsUTF8(Switch, Default, Prompt);
if not ToInteger(res,result) then
result := GetEnumNameValue(TypeInfo,pointer(res),length(res),true);
end;
function TCommandLine.AsArray: TRawUTF8DynArray;
begin
fValues.ToRawUTF8DynArray(result);
end;
function TCommandLine.AsJSON(Format: TTextWriterJSONFormat): RawUTF8;
begin
result := fValues.ToJSON('','',Format);
end;
function TCommandLine.AsString(const Switch: RawUTF8; const Default, Prompt: string): string;
begin
result := UTF8ToString(AsUTF8(Switch,StringToUTF8(Default),Prompt));
end;
{$endif NOVARIANTS}
procedure InitInternalTables;
var e: TEmoji;
begin
{$ifdef MSWINDOWS}
InitWindowsAPI;
{$else}
stdoutIsTTY := IsATTY(StdOutputHandle)=1;
{$endif MSWINDOWS}
SetLength(JSON_SQLDATE_MAGIC_TEXT,3);
PCardinal(pointer(JSON_SQLDATE_MAGIC_TEXT))^ := JSON_SQLDATE_MAGIC;
Assert(ord(high(TEmoji))=$4f+1);
EMOJI_RTTI := GetEnumName(TypeInfo(TEmoji),1); // ignore eNone=0
GetEnumTrimmedNames(TypeInfo(TEmoji),@EMOJI_TEXT);
EMOJI_TEXT[eNone] := '';
for e := succ(low(e)) to high(e) do begin
LowerCaseSelf(EMOJI_TEXT[e]);
EMOJI_TAG[e] := ':'+EMOJI_TEXT[e]+':';
SetLength(EMOJI_UTF8[e],4);
UCS4ToUTF8(ord(e)+$1f5ff,pointer(EMOJI_UTF8[e]));
end;
EMOJI_AFTERDOTS[')'] := eSmiley;
EMOJI_AFTERDOTS['('] := eFrowning;
EMOJI_AFTERDOTS['|'] := eExpressionless;
EMOJI_AFTERDOTS['/'] := eConfused;
EMOJI_AFTERDOTS['D'] := eLaughing;
EMOJI_AFTERDOTS['o'] := eOpen_mouth;
EMOJI_AFTERDOTS['O'] := eOpen_mouth;
EMOJI_AFTERDOTS['p'] := eYum;
EMOJI_AFTERDOTS['P'] := eYum;
EMOJI_AFTERDOTS['s'] := eScream;
EMOJI_AFTERDOTS['S'] := eScream;
DoIsValidUTF8 := IsValidUTF8Pas;
DoIsValidUTF8Len := IsValidUTF8LenPas;
{$ifdef ASMX64AVX}
if CpuFeatures * [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] =
[cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] then begin
// Haswell CPUs can use simdjson AVX2 asm for IsValidUtf8()
DoIsValidUTF8 := IsValidUTF8Avx2;
DoIsValidUTF8Len := IsValidUTF8LenAvx2;
end;
{$endif ASMX64AVX}
end;
initialization
Assert(SizeOf(TSynTableFieldType)=1); // as expected by TSynTableFieldProperties
Assert(SizeOf(TSynTableFieldOptions)=1);
{$ifndef NOVARIANTS}
Assert(SizeOf(TSynTableData)=SizeOf(TVarData));
{$endif NOVARIANTS}
Assert(SizeOf(THTab)=$40000*3); // 786,432 bytes
Assert(SizeOf(TSynUniqueIdentifierBits)=SizeOf(TSynUniqueIdentifier));
InitInternalTables;
TTextWriter.RegisterCustomJSONSerializerFromText([
TypeInfo(TDiskPartitions),
'name:RawUTF8 mounted:string size:QWord',
TypeInfo(TSystemUseDataDynArray),
'Timestamp:TDateTime Kernel,User:single WorkDB,VirtualKB:cardinal']);
end.