Hey all,
I have expanded Brainer's BBCode parser example so it is now in a working state
It handles these tag types: color, url, img. It can easily be expanded too..
I hope if is useful to someone else too
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);
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);
var
i: Integer;
begin
for i := 1 to Length(aMatchText) do
begin
if FCharacter <> aMatchText[i] then
Expected(aMatchText);
GetChar;
end;
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);
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.
The 'only' thing I might do is get rid of the events and make it return an array of tag and/or plain text bits in order to make it nicer to use IMO...
cheers,
Paul
Bookmarks