From 5f7b4e338aa852df83429ef6eee7776f7503df40 Mon Sep 17 00:00:00 2001 From: skalogryz Date: Tue, 8 Mar 2016 14:50:21 +0000 Subject: [PATCH] richmemo: add mlparse example git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4534 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../richmemo/samples/mlparse/mlparsers.lpi | 89 ++++++ .../richmemo/samples/mlparse/mlparsers.lpr | 21 ++ .../richmemo/samples/mlparse/richmemoml.pas | 254 ++++++++++++++++++ components/richmemo/samples/mlparse/unit1.lfm | 78 ++++++ components/richmemo/samples/mlparse/unit1.pas | 77 ++++++ 5 files changed, 519 insertions(+) create mode 100644 components/richmemo/samples/mlparse/mlparsers.lpi create mode 100644 components/richmemo/samples/mlparse/mlparsers.lpr create mode 100644 components/richmemo/samples/mlparse/richmemoml.pas create mode 100644 components/richmemo/samples/mlparse/unit1.lfm create mode 100644 components/richmemo/samples/mlparse/unit1.pas diff --git a/components/richmemo/samples/mlparse/mlparsers.lpi b/components/richmemo/samples/mlparse/mlparsers.lpi new file mode 100644 index 000000000..75fc79afa --- /dev/null +++ b/components/richmemo/samples/mlparse/mlparsers.lpi @@ -0,0 +1,89 @@ + + + + + + + + + + <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> diff --git a/components/richmemo/samples/mlparse/mlparsers.lpr b/components/richmemo/samples/mlparse/mlparsers.lpr new file mode 100644 index 000000000..53989dc2a --- /dev/null +++ b/components/richmemo/samples/mlparse/mlparsers.lpr @@ -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. + diff --git a/components/richmemo/samples/mlparse/richmemoml.pas b/components/richmemo/samples/mlparse/richmemoml.pas new file mode 100644 index 000000000..e0f9962ec --- /dev/null +++ b/components/richmemo/samples/mlparse/richmemoml.pas @@ -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. + diff --git a/components/richmemo/samples/mlparse/unit1.lfm b/components/richmemo/samples/mlparse/unit1.lfm new file mode 100644 index 000000000..652350174 --- /dev/null +++ b/components/richmemo/samples/mlparse/unit1.lfm @@ -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 < 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 diff --git a/components/richmemo/samples/mlparse/unit1.pas b/components/richmemo/samples/mlparse/unit1.pas new file mode 100644 index 000000000..5f3f8d2ae --- /dev/null +++ b/components/richmemo/samples/mlparse/unit1.pas @@ -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, '<', '<', [rfReplaceAll, rfIgnoreCase]); + txt:=StringReplace(txt, '>', '>', [rfReplaceAll, rfIgnoreCase]); + txt:=StringReplace(txt, '"', '"', [rfReplaceAll, rfIgnoreCase]); +end; + +end. +