unit Parser.BBCode;
interface
uses
Vcl.Graphics, System.SysUtils, System.Generics.Collections;
type
TTextPart =
class
private
FFont: TFont;
FText:
string;
public
constructor Create( AFont: TFont;
const AText:
string );
property Font: TFont
read FFont;
property Text:
string read FText;
end;
TBBCodeParser =
class
private type
TState =
procedure( AChar: Char )
of object;
private
FParts: TList<TTextPart>;
FCommandStack: TList<
string>;
FDefaultFont: TFont;
FState: TState;
FFont: TFont;
FTextBuffer: TStringBuilder;
FCommandBuffer: TStringBuilder;
procedure InitParser;
procedure ParseText( AChar: Char );
procedure ParseCommand( AChar: Char );
procedure ParseCloseCommand( AChar: Char );
procedure HandleTextBuffer;
procedure HandleCommandBuffer( Closing: Boolean = False );
public
constructor Create( ADefaultFont: TFont );
destructor Destroy;
override;
procedure Parse( AText:
string );
property Parts: TList<TTextPart>
read FParts;
end;
implementation
uses
System.StrUtils;
{ TBBCodeParser }
constructor TBBCodeParser.Create( ADefaultFont: TFont );
begin
inherited Create;
FDefaultFont := ADefaultFont;
FFont := TFont.Create;
FTextBuffer := TStringBuilder.Create;
FCommandBuffer := TStringBuilder.Create;
FParts := TObjectList<TTextPart>.Create;
FCommandStack := TList<
string>.Create;
end;
destructor TBBCodeParser.Destroy;
begin
FFont.Free;
FTextBuffer.Free;
FCommandBuffer.Free;
FParts.Free;
FCommandStack.Free;
inherited;
end;
procedure TBBCodeParser.HandleCommandBuffer( Closing: Boolean );
const
FontStyle:
array [TFontStyle]
of string = ( '
fsBold', '
fsItalic', '
fsUnderline', '
fsStrikeOut' );
var
LCommand:
string;
LIdx: Integer;
begin
LCommand := FCommandBuffer.ToString;
FCommandBuffer.Clear;
if Closing
then
begin
// von hinten aus dem Stack nehmen
for LIdx := FCommandStack.Count - 1
downto 0
do
if FCommandStack[LIdx] = LCommand
then
begin
FCommandStack.Delete( LIdx );
Break;
end;
end
else
// Einfach an den Stack anhängen
FCommandStack.Add( LCommand );
// Font einstellen
FFont.Assign( FDefaultFont );
for LCommand
in FCommandStack
do
begin
LIdx := IndexText( LCommand, FontStyle );
if LIdx >= 0
then
FFont.Style := FFont.Style + [TFontStyle( LIdx )];
if LCommand.StartsWith( '
cl', True )
then
FFont.Color := StringToColor( LCommand );
end;
end;
procedure TBBCodeParser.HandleTextBuffer;
begin
if FTextBuffer.Length > 0
then
begin
FParts.Add( TTextPart.Create( FFont, FTextBuffer.ToString ) );
FTextBuffer.Clear;
end;
end;
procedure TBBCodeParser.InitParser;
begin
FFont.Assign( FDefaultFont );
FTextBuffer.Clear;
FCommandBuffer.Clear;
FCommandStack.Clear;
FParts.Clear;
FState := ParseText;
end;
procedure TBBCodeParser.Parse( AText:
string );
var
LChar: Char;
begin
InitParser;
for LChar
in AText
do
FState( LChar );
HandleTextBuffer;
end;
procedure TBBCodeParser.ParseCloseCommand( AChar: Char );
begin
case AChar
of
'
]':
begin
HandleTextBuffer;
HandleCommandBuffer( True );
FState := ParseText;
end;
else
FCommandBuffer.Append( AChar );
end;
end;
procedure TBBCodeParser.ParseCommand( AChar: Char );
begin
case AChar
of
'
]':
begin
HandleTextBuffer;
HandleCommandBuffer( False );
FState := ParseText;
end;
'
/':
FState := ParseCloseCommand;
else
FCommandBuffer.Append( AChar );
end;
end;
procedure TBBCodeParser.ParseText( AChar: Char );
begin
case AChar
of
'
[':
FState := ParseCommand;
else
FTextBuffer.Append( AChar );
end;
end;
{ TTextPart }
constructor TTextPart.Create( AFont: TFont;
const AText:
string );
begin
inherited Create;
FFont := TFont.Create;
FFont.Assign( AFont );
FText := AText;
end;
end.