paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-05 07:58:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

SynEdit: TSynEditExporter: implement methods that add formatting data immediately before and after each token, regardless of the formatting status of the previous token.

Browse Source 
git-svn-id: trunk@53335 -
This commit is contained in:
bart 2016-11-10 15:51:38 +00:00
parent 0a383ad832
commit e613c39896
2 changed files with 156 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
components/synedit/syneditexport.pas
View File

@ -50,7 +50,7 @@ uses
Classes,
SysUtils,
SynEditHighlighter, SynEditTextBase, SynEditTextBuffer,
FileUtil, LazUTF8, FPCAdds, LCLType,
FileUtil, LazUTF8, FPCAdds, LCLType, LCLProc,
Graphics, Clipbrd;
type
@ -65,10 +65,14 @@ type
to track the changes of token attributes, to export to the clipboard or to
save the output to a file. Descendant classes have to implement only the
actual formatting of tokens. }
{ TSynCustomExporter }
TSynCustomExporter = class(TComponent)
private
fBuffer: TMemoryStream;
fFirstAttribute: boolean;
fImmediateAttrWrite: Boolean;
procedure AssignFont(Value: TFont);
procedure SetFont(Value: TFont);
procedure SetHighlighter(Value: TSynCustomHighlighter);
@ -115,9 +119,19 @@ type
ForegroundChanged: boolean; FontStylesChanged: TFontStyles);
virtual; abstract;
{end} //mh 2000-10-10
{ The Format*Immediate methods apply formatting based entirely on the
current token attribute, they do not take the attribute of the previous
token into account }
procedure FormatBeforeFirstAttributeImmediate(BG, FG: TColor); virtual; abstract;
procedure FormatAfterLastAttributeImmediate; virtual; abstract;
procedure FormatAttributeInitImmediate(Attri: TSynHighlighterAttributes; IsSpace: Boolean); virtual; abstract;
procedure FormatAttributeDoneImmediate(Attri: TSynHighlighterAttributes; IsSpace: Boolean); virtual; abstract;
{ Has to be overridden in descendant classes to add the formatted text of
the actual token text to the output buffer. }
procedure FormatToken(Token: string); virtual;
procedure FormatTokenImmediate(Token: String; Attri: TSynHighlighterAttributes; IsSpace: Boolean);
{ Has to be overridden in descendant classes to add a newline in the output
format to the output buffer. }
procedure FormatNewLine; virtual; abstract;
@ -152,6 +166,7 @@ type
added to the output buffer. }
procedure SetTokenAttribute(IsSpace: boolean;
Attri: TSynHighlighterAttributes); virtual;
function ValidatedColor(AColor, ADefColor: TColor): TColor;
public
{ Creates an instance of the exporter. }
constructor Create(AOwner: TComponent); override;
@ -187,6 +202,7 @@ type
{ The highlighter to use for exporting. }
property Highlighter: TSynCustomHighlighter
read fHighlighter write SetHighlighter;
property ImmediateAttrWrite: Boolean read fImmediateAttrWrite write fImmediateAttrWrite default false;
{ The title to embedd into the output header. }
property Title: string read fTitle write SetTitle;
{ Use the token attribute background for the exporting. }
@ -322,6 +338,7 @@ begin
// export all the lines into fBuffer
fFirstAttribute := TRUE;
for i := Start.Y to Stop.Y do begin
Highlighter.StartAtLineIndex(i - 1);
X := 1;
@ -344,16 +361,28 @@ begin
end;
Token := ReplaceReservedChars(Token, IsSpace);
SetTokenAttribute(IsSpace, Attri);
FormatToken(Token);
if fImmediateAttrWrite then begin
if fFirstAttribute then begin
FormatBeforeFirstAttributeImmediate(fBackgroundColor, fFont.Color);
fFirstAttribute := False;
end;
FormatTokenImmediate(Token, Attri ,IsSpace);
end else begin
SetTokenAttribute(IsSpace, Attri);
FormatToken(Token);
end;
Highlighter.Next;
end;
FormatNewLine;
end;
if not fFirstAttribute then
FormatAfterLastAttribute;
if not fFirstAttribute then begin
if fImmediateAttrWrite then
FormatAfterLastAttributeImmediate
else
FormatAfterLastAttribute;
end;
// insert header
fBuffer.SetSize(integer(fBuffer.Position));
InsertData(0, GetHeader);
@ -373,6 +402,15 @@ begin
AddData(Token);
end;
procedure TSynCustomExporter.FormatTokenImmediate(Token: String;
Attri: TSynHighlighterAttributes; IsSpace: Boolean);
begin
debugln(['TSynCustomExporter.FormatTokenImmediate: Token = "', Token,'", IsSpace = ',IsSpace]);
FormatAttributeInitImmediate(Attri, IsSpace);
FormatToken(Token);
FormatAttributeDoneImmediate(Attri, IsSpace);
end;
function TSynCustomExporter.GetBufferSize: integer;
begin
Result := integer(fBuffer.Size);
@ -521,14 +559,6 @@ var
ChangedFG: boolean;
ChangedStyles: TFontStyles;
function ValidatedColor(AColor, ADefColor: TColor): TColor;
begin
if AColor = clNone then
Result := ADefColor
else
Result := AColor;
end;
begin
if fFirstAttribute then begin
fFirstAttribute := FALSE;
@ -570,5 +600,13 @@ begin
end;
end;
function TSynCustomExporter.ValidatedColor(AColor, ADefColor: TColor): TColor;
begin
if AColor = clNone then
Result := ADefColor
else
Result := AColor;
end;
end.

107
components/synedit/synexporthtml.pas
View File

@ -46,7 +46,7 @@ interface
uses
Classes,
LCLIntf, LCLType, Graphics, ClipBrd,
SynEditExport, LCLProc, LazUtf8;
SynEditHighlighter, SynEditExport, LCLProc, LazUtf8;
type
THTMLFontSize = (fs01, fs02, fs03, fs04, fs05, fs06, fs07, fsDefault); //eb 2000-10-12
@ -66,10 +66,11 @@ type
private
fOptions: TExportHtmlOptions;
fFontSize: THTMLFontSize;
function ColorToHTML(AColor: TColor): string;
procedure SetExportHtmlOptions(Value: TExportHtmlOptions);
function GetCreateHTMLFragment: Boolean;
procedure SetCreateHTMLFragment(Value: Boolean);
function MakeFontSpan(FG, BG: TColor): String;
function StyleToHtml(AStyle: TFontStyles; IsSpace, DoSet: Boolean): String;
protected
procedure FormatAfterLastAttribute; override;
procedure FormatAttributeDone(BackgroundChanged, ForegroundChanged: boolean;
@ -80,6 +81,11 @@ type
procedure FormatBeforeFirstAttribute(BackgroundChanged,
ForegroundChanged: boolean; FontStylesChanged: TFontStyles); override;
{end} //mh 2000-10-10
procedure FormatBeforeFirstAttributeImmediate(BG, FG: TColor); override;
procedure FormatAfterLastAttributeImmediate; override;
procedure FormatAttributeInitImmediate(Attri: TSynHighlighterAttributes; IsSpace: Boolean); override;
procedure FormatAttributeDoneImmediate(Attri: TSynHighlighterAttributes; IsSpace: Boolean); override;
procedure FormatNewLine; override;
function GetFooter: string; override;
function GetFormatName: string; override;
@ -87,6 +93,7 @@ type
procedure SetExportAsText(Value: boolean); override;
public
constructor Create(AOwner: TComponent); override;
function ColorToHTML(AColor: TColor): string;
published
property Color;
property CreateHTMLFragment: boolean read GetCreateHTMLFragment
@ -351,6 +358,72 @@ begin
AddData('<strike>');
end;
end;
procedure TSynExporterHTML.FormatBeforeFirstAttributeImmediate(BG, FG: TColor);
var
Span: String;
begin
debugln(['TSynExporterHTML.FormatBeforeFirstAttributeImmediate']);
// if not heoFragmentOnly this is handled in GetHeader
if (heoFragmentOnly in Options) then
begin
Span := MakeFontSpan(FG, BG);
AddData(Span);
end;
end;
procedure TSynExporterHTML.FormatAfterLastAttributeImmediate;
begin
debugln(['TSynExporterHTML.FormatAfterLastAttributeImmediate']);
if (heoFragmentOnly in Options) then
AddData('</span>');
end;
procedure TSynExporterHTML.FormatAttributeInitImmediate(
Attri: TSynHighlighterAttributes; IsSpace: Boolean);
var
Span, StyleStr: String;
FG, BG: TColor;
begin
debugln(['TSynExporterHTML.FormatAttributeInitImmediate']);
FG := ValidatedColor(Attri.Foreground, fFont.Color);
BG := ValidatedColor(Attri.Background, fBackgroundColor);
if (not IsSpace and (FG <> fFont.Color)) or
(UseBackGround and (BG <> fbackGroundColor)) then
begin
Span := MakeFontSpan(FG, BG);
AddData(Span);
end;
if (Attri.Style <> []) then
begin
StyleStr := StyleToHtml(Attri.Style, IsSpace, True);
AddData(StyleStr);
end;
end;
procedure TSynExporterHTML.FormatAttributeDoneImmediate(
Attri: TSynHighlighterAttributes; IsSpace: Boolean);
var
FG, BG: TColor;
StyleStr: String;
begin
debugln(['TSynExporterHTML.FormatAttributeDoneImmediate']);
//reversed order compared to FormatAttributeInitImmediate
if (Attri.Style <> []) then
begin
StyleStr := StyleToHtml(Attri.Style, IsSpace, False);
AddData(StyleStr);
end;
FG := ValidatedColor(Attri.Foreground, fFont.Color);
BG := ValidatedColor(Attri.Background, fBackgroundColor);
if (not IsSpace and (FG <> fFont.Color)) or
(UseBackGround and (BG <> fbackGroundColor)) then
begin
AddData('</span>');
end;
end;
{end} //mh 2000-10-10
procedure TSynExporterHTML.FormatNewLine;
@ -475,5 +548,35 @@ begin
end;
end;
function TSynExporterHTML.MakeFontSpan(FG, BG: TColor): String;
begin
Result := '<span style="color: ';
FG := ValidatedColor(FG, fFont.Color);
Result := Result + AnsiDequotedStr(ColorToHtml(FG), '"');
BG := ValidatedColor(BG, fBackgroundColor);
if UseBackGround then
begin
Result := Result + '; background-color: ' + AnsiDequotedStr(ColorToHtml(BG), '"');
end;
Result := Result + ';">';
end;
function TSynExporterHTML.StyleToHtml(AStyle: TFontStyles; IsSpace, DoSet: Boolean): String;
begin
Result := '';
if not IsSpace then
begin
if (fsBold in AStyle) then
if DoSet then Result := Result + '<b>' else Result := Result + '</b>';
if (fsItalic in AStyle) then
if DoSet then Result := Result + '<i>' else Result := Result + '</i>';
if (fsUnderline in AStyle) then
if DoSet then Result := Result + '<u>' else Result := Result + '</u>';
end;
//the only style that actually is applied to whitespace in HTML
if (fsStrikeOut in AStyle) then
if DoSet then Result := Result + '<strike>' else Result := Result + '</strike>';
end;
end.