Hi all,
there was a slight bug where the Match() routine was chopping off any spaces after the closing tag character ']'.
I have modified that routine now to make skipping white spaces optional (see the changes below)
Code:
unit unit_BBCode;
{$ifdef fpc}
{$mode Delphi}
{$endif}
{+H}
interface
uses
SysUtils,
Classes;
const
cBeginTagChar = '[';
cEndTagChar = ']';
cClosingTagChar = '/';
cColorTagIdent = 'color';
cURLTagIdent = 'url';
cImageTagIdent = 'img';
type
TCharSet = set of AnsiChar;
BBCodeParseException = class(Exception);
TBBCodeTagType = (tagUnknown,tagColor,tagURL,tagImage);
const
cBBCodeTagType: array[TBBCodeTagType] of AnsiString = (
'unknown',
'color',
'url',
'img'
);
type
TTagEvent = procedure(Tag: TBBCodeTagType; const Attribute: AnsiString) of object;
TTextEvent = procedure(c: AnsiChar) of object;
TBBCodeParser = class(TObject)
private
FErrorMsg: AnsiString;
FBuffer: AnsiString;
FIndex: Integer;
FCharacter: AnsiChar;
FOnBeginTag: TTagEvent;
FOnEndTag: TTagEvent;
FOnTextCharacter: TTextEvent;
FParsingTag: Boolean;
procedure Error(aErrorMsg: AnsiString);
procedure Expected(aExpectedMsg: AnsiString);
procedure GetChar;
procedure SkipWhiteSpaces;
function GetInteger: AnsiString;
function GetIdentifier: AnsiString;
function GetHexNumber: AnsiString;
function ReadUntil(chars: TCharSet): AnsiString;
procedure Match(aMatchText: AnsiString; aDoSkipWhiteSpaces: Boolean = True);
function IsWhiteSpace(c: AnsiChar): Boolean;
function IsDigit(c: AnsiChar): Boolean;
function IsAlpha(c: AnsiChar): Boolean;
function IsHex(c: AnsiChar): Boolean;
function GetColorTagAttributes: AnsiString;
function GetURLTagAttributes: AnsiString;
procedure ParseTag;
procedure ParseText;
public
{ Public declarations }
constructor Create;
function Parse(aTextToParse: AnsiString): Boolean;
property ErrorMsg: AnsiString read FErrorMsg;
property OnBeginTag: TTagEvent read FOnBeginTag write FOnBeginTag;
property OnEndTag: TTagEvent read FOnEndTag write FOnEndTag;
property OnTextCharacter: TTextEvent read FOnTextCharacter write FOnTextCharacter;
end;
implementation
constructor TBBCodeParser.Create;
begin
inherited Create;
FOnBeginTag := nil;
FOnEndTag := nil;
FOnTextCharacter := nil;
FErrorMsg := '';
end;
procedure TBBCodeParser.GetChar;
begin
if FIndex <= Length(FBuffer) then
begin
FCharacter := FBuffer[FIndex];
Inc(FIndex);
end
else
FCharacter := #0;
end;
procedure TBBCodeParser.SkipWhiteSpaces;
begin
while IsWhiteSpace(FCharacter) do
GetChar;
end;
function TBBCodeParser.GetInteger: AnsiString;
begin
Result := '';
if not IsDigit(FCharacter) then
Error('Expected Integer');
while IsDigit(FCharacter) do
begin
Result := Result + FCharacter;
GetChar;
end;
SkipWhiteSpaces;
end;
function TBBCodeParser.GetIdentifier: AnsiString;
begin
Result := '';
if not IsAlpha(FCharacter) then
Error('Expected Identifier');
while IsAlpha(FCharacter) do
begin
Result := Result + FCharacter;
GetChar;
end;
SkipWhiteSpaces;
end;
function TBBCodeParser.GetHexNumber: AnsiString;
begin
Result := '';
if not IsHex(FCharacter) then
Error('Expected Hexadecimal Number');
while IsHex(FCharacter) do
begin
Result := Result + FCharacter;
GetChar;
end;
SkipWhiteSpaces;
end;
function TBBCodeParser.ReadUntil(chars: TCharSet): AnsiString;
begin
Result := '';
while (FCharacter <> #0) and not(FCharacter in chars) do
begin
Result := Result + FCharacter;
GetChar;
end;
end;
function TBBCodeParser.IsWhiteSpace(c: AnsiChar): Boolean;
begin
Result := c in[' ',^I,#10,#13];
end;
function TBBCodeParser.IsDigit(c: AnsiChar): Boolean;
begin
Result := c in['0'..'9'];
end;
function TBBCodeParser.IsAlpha(c: AnsiChar): Boolean;
begin
Result := c in['a'..'z','A'..'Z'];
end;
function TBBCodeParser.IsHex(c: AnsiChar): Boolean;
begin
Result := c in['a'..'f','A'..'F','0'..'9'];
end;
procedure TBBCodeParser.Error(aErrorMsg: AnsiString);
begin
FErrorMsg := aErrorMsg + ' at character index: '+IntToStr(FIndex);
raise BBCodeParseException.Create(aErrorMsg);
end;
procedure TBBCodeParser.Expected(aExpectedMsg: AnsiString);
begin
Error('Expected: "'+aExpectedMsg+'"');
end;
procedure TBBCodeParser.Match(aMatchText: AnsiString; aDoSkipWhiteSpaces: Boolean = True);
var
i: Integer;
begin
for i := 1 to Length(aMatchText) do
begin
if FCharacter <> aMatchText[i] then
Expected(aMatchText);
GetChar;
end;
if aDoSkipWhiteSpaces then
SkipWhiteSpaces;
end;
function TBBCodeParser.GetColorTagAttributes: AnsiString;
begin
Match('=');
Result := ReadUntil([cEndTagChar,cClosingTagChar]);
end;
function TBBCodeParser.GetURLTagAttributes: AnsiString;
begin
Result := '';
if FCharacter = '=' then
begin
Match('=');
Result := ReadUntil([cEndTagChar,cClosingTagChar]);
end;
end;
procedure TBBCodeParser.ParseTag;
var
TagIdent: AnsiString;
TagType: TBBCodeTagType;
TagAttributes: AnsiString;
IsEndTag: Boolean;
begin
FParsingTag := True;
IsEndTag := False;
TagType := tagUnknown;
Match(cBeginTagChar);
// check if tag is end tag
if FCharacter = cClosingTagChar then
begin
GetChar;
IsEndTag := True;
end;
TagIdent := LowerCase(GetIdentifier);
TagAttributes := '';
// read tag information
if TagIdent = cColorTagIdent then
TagType := tagColor
else
if TagIdent = cUrlTagIdent then
TagType := tagUrl
else
if TagIdent = cImageTagIdent then
TagType := tagImage
else
Error('Unknown tag "'+TagIdent+'"');
if not IsEndTag then
begin
case TagType of
tagColor : TagAttributes := GetColorTagAttributes;
tagUrl : TagAttributes := GetUrlTagAttributes;
else
end;
end;
Match(cEndTagChar,False);
if not IsEndTag and Assigned(FOnBeginTag) then
FOnBeginTag(TagType,TagAttributes)
else
if IsEndTag and Assigned(FOnEndTag) then
FOnEndTag(TagType,TagAttributes);
FParsingTag := False;
end;
procedure TBBCodeParser.ParseText;
begin
if Assigned(FOnTextCharacter) then
FOnTextCharacter(FCharacter);
GetChar;
end;
function TBBCodeParser.Parse(aTextToParse: AnsiString): Boolean;
begin
FParsingTag := False;
FBuffer := aTextToParse;
FIndex := 1;
GetChar;
try
while FCharacter <> #0 do
begin
if not FParsingTag and (FCharacter = cBeginTagChar) then
ParseTag
else
ParseText;
end;
Result := True;
except
Result := False;
end;
end;
end.
I can now read in my credits text file successfully using the above parser (including the BBCode colour formatting) and build up my coloured credit parts! Yay!
See the attachment file credits.txt to see the formatting.
As I receive text character by character from the parser, I build up a text string.
Depending on the tag I receive, I add the concatenated text string to the list using the current colour from a colour stack, and then push the received colour onto the stack or pop a colour off the stack.
See the code snippet below:
Code:
procedure TDocumentLine.OnBeginTag(Tag: TBBCodeTagType; const Attribute: AnsiString);
begin
// add any plain text element that is there using the current colour to the list
if FBBCodeText <> '' then
begin
AddText(FBBCodeFont,FBBCodeText,Cardinal(FBBCodeColorStack.Peek));
FBBCodeText := '';
end;
if Tag = tagColor then
FBBCodeColorStack.Push(Pointer(GetHGEColorByName(Attribute)));
end;
procedure TDocumentLine.OnEndTag(Tag: TBBCodeTagType; const Attribute: AnsiString);
begin
// add any plain text element that is there using the current colour to the list
if FBBCodeText <> '' then
begin
AddText(FBBCodeFont,FBBCodeText,Cardinal(FBBCodeColorStack.Peek));
FBBCodeText := '';
end;
if Tag = tagColor then
FBBCodeColorStack.Pop;
end;
procedure TDocumentLine.OnText(c: AnsiChar);
begin
FBBCodeText := FBBCodeText + c;
end;
function TDocumentLine.ParseBBCodeText(aFont: Integer; aBBCodeText: AnsiString; var aErrorMsg: AnsiString): Boolean;
var
BBCodeParser: TBBCodeParser;
begin
BBCodeParser := TBBCodeParser.Create;
FBBCodeColorStack := TStack.Create;
try
FBBCodeText := '';
FBBCodeFont := aFont;
BBCodeParser.OnBeginTag := OnBeginTag;
BBCodeParser.OnEndTag := OnEndTag;
BBCodeParser.OnTextCharacter := OnText;
// add default starting colour
FBBCodeColorStack.Push(Pointer(White));
Result := BBCodeParser.Parse(aBBCodeText);
if not Result then
aErrorMsg := BBCodeParser.ErrorMsg
else
begin
// add any plain text element that is there using the current colour to the list
if FBBCodeText <> '' then
begin
AddText(FBBCodeFont,FBBCodeText,Cardinal(FBBCodeColorStack.Peek));
FBBCodeText := '';
end;
end;
finally
BBCodeParser.Free;
FBBCodeColorStack.Free;
end;
end;
cheers,
Paul
Bookmarks