pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

richmemo: add mlparse example

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4534 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
skalogryz
2016-03-08 14:50:21 +00:00
parent 0fc1e4c933
commit 5f7b4e338a
5 changed files with 519 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
components/richmemo/samples/mlparse/mlparsers.lpi Normal file
View File

@ -0,0 +1,89 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="mlparsers"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="richmemopackage"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="mlparsers.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
<Unit2>
<Filename Value="richmemoml.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="RichMemoML"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="mlparsers"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
components/richmemo/samples/mlparse/mlparsers.lpr Normal file
View File

@ -0,0 +1,21 @@
program mlparsers;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1, richmemoml
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

254
components/richmemo/samples/mlparse/richmemoml.pas Normal file
View File

@ -0,0 +1,254 @@
{
richmemoutils.pas
Author: Dmitry 'skalogryz' Boyarintsev
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
unit RichMemoML;
{$mode delphi}{$H+}
interface
uses
Classes, SysUtils, RichMemo, RichMemoUtils;
type
TMarkupFormatHandler = procedure (Sender: TObject;
var tag: string; tagattr: TStrings;
var font: TFontParams; var txt: string; var tagCloses: Boolean ) of object;
TMarkupEntityReplace = procedure (Sender: TObject; var txt: string; tagsStack: TStrings) of object;
{ TFormatStack }
TFormatStack = class(Tobject)
public
tagName : string;
fmt : TFontParams;
constructor Create(const atag: string; afmt: TFontParams);
end;
{ TMarkupHandler }
TMarkupHandler = class(TObject)
private
fOnMarkup : TMarkupFormatHandler;
fOnReplace : TMarkupEntityReplace;
fStack : TList;
fStackNames : TStrings;
fRichMemo : TRichMemo;
procedure Append(const s: string; const fmt: TFontParams);
procedure EntityReplace(var s: string);
procedure GetTagFmt(var atag: string; st: TStrings; var fmt: TFontParams; var AText: string; var toBeClosed: Boolean);
procedure AddStack(const atag: string; const fmt: TFontParams);
procedure PopStack(const atag: string; var fmt: TFontParams);
procedure Clear;
public
DefParams: TFontParams;
constructor Create;
destructor Destroy; override;
procedure Parse(ARichMemo: TRichMemo; const atext: string);
property OnFormatSelect: TMarkupFormatHandler read fOnMarkup write fOnMarkup;
property OnEntityReplace: TMarkupEntityReplace read fOnReplace write fOnReplace;
end;
procedure Parse(const atext: string; ADstMemo: TRichMemo; AFormat: TMarkupFormatHandler; AReplace: TMarkupEntityReplace = nil);
implementation
procedure Parse(const atext: string; ADstMemo: TRichMemo; AFormat: TMarkupFormatHandler; AReplace: TMarkupEntityReplace);
var
h : TMarkupHandler;
begin
if not Assigned(ADstMemo) or (atext='') then Exit;
h := TMarkupHandler.Create;
try
h.OnFormatSelect:=AFormat;
h.OnEntityReplace:=AReplace;
h.DefParams:=GetFontParams(ADstMemo.Font);
h.Parse(ADstMemo, atext);
finally
h.Free;
end;
end;
{ TFormatStack }
constructor TFormatStack.Create(const atag: string; afmt: TFontParams);
begin
inherited Create;
tagName:=atag;
fmt:=afmt;
end;
{ TMarkupHandler }
procedure TMarkupHandler.Append(const s: string; const fmt: TFontParams);
begin
InsertFontText(fRichMemo, s, fmt);
end;
procedure TMarkupHandler.EntityReplace(var s: string);
var
i : integer;
begin
//todo: more effecient?
fStackNames.Clear;
for i:=0 to fStack.Count-1 do
fStackNames.Add( TFormatStack(fStack[i]).tagName );
if Assigned(OnEntityReplace) then OnEntityReplace(Self, s, fStackNames);
end;
procedure TMarkupHandler.GetTagFmt(var atag: string; st: TStrings;
var fmt: TFontParams; var AText: string; var toBeClosed: Boolean);
begin
if Assigned(OnFormatSelect) then
OnFormatSelect(Self, atag, st, fmt, atext, toBeClosed);
end;
procedure TMarkupHandler.AddStack(const atag: string; const fmt: TFontParams);
begin
fStack.Add(TFormatStack.Create(atag, fmt));
end;
procedure TMarkupHandler.PopStack(const atag: string; var fmt: TFontParams);
var
i : integer;
j : integer;
fs : TFormatStack;
begin
i:=fStack.Count-1;
while i>=0 do begin
fs:=TFormatStack(fStack[i]);
if fs.tagName=atag then begin
for j:=fStack.Count-1 downto i do begin
TFormatStack(fStack[j]).Free;
fStack[j]:=nil;
end;
fStack.Pack;
dec(i);
if i>=0 then fmt:=TFormatStack(fStack[i]).fmt
else fmt:=DefParams;
Exit;
end else
dec(i);
end;
// do nothing. unknown closing tag
end;
procedure TMarkupHandler.Clear;
var
i : Integer;
begin
for i:=0 to fStack.Count-1 do
TFormatStack(fStack[i]).free;
fStack.Clear;
end;
constructor TMarkupHandler.Create;
begin
inherited;
fStack:=TList.Create;
fStackNames:=TStringList.Create;
end;
destructor TMarkupHandler.Destroy;
begin
Clear;
fStackNames.Free;
fStack.Free;
inherited Destroy;
end;
procedure TMarkupHandler.Parse(ARichMemo: TRichMemo; const atext: string);
var
i : integer;
j : integer;
sb : string;
fmt : TFontParams;
newfmt : TFontParams;
tag : string;
openTag : Boolean;
tagAttr: TStringList;
tobeClosed : Boolean;
begin
if not Assigned(ARichMemo) then Exit;
Clear;
fmt:=DefParams;
i:=1;
j:=1;
fRichMemo:=ARichMemo;
fRichMemo.Lines.BeginUpdate;
tagAttr:=TStringList.Create;
try
while i<=length(atext) do begin
if atext[i]='<' then begin
tagattr.Clear;
if j<i then begin
sb:=Copy(atext, j, i-j);
EntityReplace(sb);
Append(sb, fmt);
end;
inc(i);
j:=i;
while (i<=length(atext)) and (atext[i]<>'>') do inc(i);
if (i>j+1) and (i<=length(atext)) and (atext[j]='/') then begin
openTag:=false;
inc(j);
end else begin
openTag:=true;
end;
tag:=Copy(atext, j, i-j);
tag:=AnsiLowerCase(tag);
if openTag then begin
tobeClosed:=true;
sb:='';
newfmt:=fmt;
GetTagFmt(tag, tagattr, newfmt, sb, tobeClosed);
if sb<>'' then Append(sb, newfmt);
if tobeClosed then fmt:=newfmt;
AddStack(tag, fmt);
end else begin
PopStack(tag, fmt);
end;
inc(i);
j:=i;
// parsing tag!
end else
inc(i);
end;
i:=length(atext)+1;
if j<i then begin
sb:=Copy(atext, j, i-j);
Append( sb, fmt );
end;
finally
fRichMemo.Lines.EndUpdate;
tagAttr.Free;
end;
end;
end.

78
components/richmemo/samples/mlparse/unit1.lfm Normal file
View File

@ -0,0 +1,78 @@
object Form1: TForm1
Left = 556
Height = 393
Top = 212
Width = 580
Caption = 'ML Parsing Example'
ClientHeight = 393
ClientWidth = 580
LCLVersion = '1.7'
object Button1: TButton
Left = 16
Height = 25
Top = 8
Width = 75
Caption = 'Convert'
OnClick = Button1Click
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Height = 353
Top = 40
Width = 580
Align = alBottom
Anchors = [akTop, akLeft, akRight, akBottom]
BevelOuter = bvNone
ClientHeight = 353
ClientWidth = 580
TabOrder = 1
object RichMemo1: TRichMemo
Left = 304
Height = 353
Top = 0
Width = 276
Align = alClient
HideSelection = False
Lines.Strings = (
'RichMemo1'
)
TabOrder = 0
ZoomFactor = 1
end
object Memo1: TMemo
Left = 0
Height = 353
Top = 0
Width = 299
Align = alLeft
Lines.Strings = (
'<h1>Big Header</h1>'
''
'<h2>Small Header</h2>'
''
'Hello world, let me <b>stress</b> how '
'<i>happy</i> this component is.'
'Infact, <b><u>any</u> user</b> could use it.'
''
'Just refer to the code and see how TagFormat handler '
'is working'
'<pre>'
'begin'
' if a &lt; b then '
' writeln(''hello world'');'
'end;'
'</pre>'
''
'Really easy! Right?'
)
TabOrder = 1
end
object Splitter1: TSplitter
Left = 299
Height = 353
Top = 0
Width = 5
end
end
end

77
components/richmemo/samples/mlparse/unit1.pas Normal file
View File

@ -0,0 +1,77 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, RichMemo, richmemoml;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Panel1: TPanel;
RichMemo1: TRichMemo;
Splitter1: TSplitter;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
procedure TagFormat(Sender: TObject; var atagName: string; tagattr: TStrings;
var afont: TFontParams; var txt: string; var tagCloses: Boolean );
procedure EntReplace(Sender: TObject; var txt: string; tagsStack: TStrings);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
RichMemo1.Clear;
Parse(Memo1.Text, RichMemo1, @TagFormat, @EntReplace);
end;
procedure TForm1.TagFormat(Sender: TObject; var atagName: string; tagattr: TStrings;
var afont: TFontParams; var txt: string; var tagCloses: Boolean);
begin
if atagName='b' then
Include(afont.Style, fsBold)
else if atagName='i' then
Include(afont.Style, fsItalic)
else if atagName='s' then
Include(afont.Style, fsStrikeOut)
else if atagName='u' then
Include(afont.Style, fsUnderline)
else if atagName='h1' then begin
Include(afont.Style, fsBold);
afont.Size:=afont.Size*2;
end else if atagName='h2' then begin
Include(afont.Style, fsBold);
afont.Size:=round(afont.Size*1.5)
end else if atagName='pre' then begin
afont.Name:='Courier New'
end;
end;
procedure TForm1.EntReplace(Sender: TObject; var txt: string;
tagsStack: TStrings);
begin
txt:=StringReplace(txt, '&lt;', '<', [rfReplaceAll, rfIgnoreCase]);
txt:=StringReplace(txt, '&gt;', '>', [rfReplaceAll, rfIgnoreCase]);
txt:=StringReplace(txt, '&quot;', '"', [rfReplaceAll, rfIgnoreCase]);
end;
end.