paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 20:39:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: ClipBoard HTML functions:

Browse Source 
- Add file clipbrd_html.inc to package LCLBase
- Don't clear the clipboard inside SetAsHtml
- Always add a Windows specific clipheader when on Windows
- Make sure the HTML has matching <html><body> and </body></html>, insert them if not present.
- Add an overloaded SetAsHtml that does not also set a plaintext value on the clipboard.
- Update comments
- Add some debug code

git-svn-id: trunk@50965 -
This commit is contained in:
bart 2015-12-21 19:45:48 +00:00
parent b5434dee75
commit 99eff01e21
4 changed files with 111 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lcl/clipbrd.pp
View File

@ -215,7 +215,8 @@ type
function HasPictureFormat: boolean; function HasPictureFormat: boolean;
procedure Open; procedure Open;
//procedure SetAsHandle(Format: integer; Value: THandle); //procedure SetAsHandle(Format: integer; Value: THandle);
procedure SetAsHtml(const Html: String; const PlainText: String; {%H-}AddWindowsHeader: Boolean); procedure SetAsHtml(Html: String);
procedure SetAsHtml(Html: String; const PlainText: String);
function SetComponent(Component: TComponent): Boolean; function SetComponent(Component: TComponent): Boolean;
function SetComponentAsText(Component: TComponent): Boolean; function SetComponentAsText(Component: TComponent): Boolean;
function SetFormat(FormatID: TClipboardFormat; Stream: TStream): Boolean; function SetFormat(FormatID: TClipboardFormat; Stream: TStream): Boolean;

98
lcl/include/clipbrd.inc
View File

@ -177,6 +177,7 @@ begin
BeginUpdate; BeginUpdate;
end; end;
procedure TClipboard.Close; procedure TClipboard.Close;
begin begin
EndUpdate; EndUpdate;
@ -779,58 +780,68 @@ end;
In case of Windows, the MS header is automatically removed.} In case of Windows, the MS header is automatically removed.}
function TClipboard.GetAsHtml(ExtractFragmentOnly: Boolean): String; function TClipboard.GetAsHtml(ExtractFragmentOnly: Boolean): String;
var var
stream: TMemoryStream; Stream: TMemoryStream;
bom: TBOM; bom: TBOM;
US: UnicodeString; US: UnicodeString;
begin begin
//debugln(['TClipboard.GetAsHtml: ExtractFragmentOnly = ',ExtractFragmentOnly]);
Result := ''; Result := '';
if (CF_HTML = 0) or not HasFormat(CF_HTML) then if (CF_HTML = 0) or not HasFormat(CF_HTML) then
begin
//debugln(['TClipboard.GetAsHtml: CF_HTML= ',CF_HTML,' HasFormat(CF_HTML) = ',HasFormat(CF_HTML)]);
exit; exit;
end;
stream := TMemoryStream.Create; Stream := TMemoryStream.Create;
try try
if not GetFormat(CF_HTML, stream) then if not GetFormat(CF_HTML, Stream) then
begin
//debugln(['TClipboard.GetAsHtml: GetFormat(CF_HTML, stream) = False']);
exit; exit;
end;
Stream.Write(#0#0, Length(#0#0));
stream.Write(#0#0, Length(#0#0)); bom := GetBomFromStream(Stream);
bom := GetBomFromStream(stream);
case Bom of case Bom of
bomUtf8: bomUtf8:
begin begin
stream.Position := 3; Stream.Position := 3;
SetLength(Result, stream.Size - 3); SetLength(Result, Stream.Size - 3);
stream.Read(Result, stream.Size - 3); Stream.Read(Result, Stream.Size - 3);
//ClipBoard may return a larger stream than the size of the string //ClipBoard may return a larger Stream than the size of the string
//this gets rid of it, since the string will end in a #0 (wide)char //this gets rid of it, since the string will end in a #0 (wide)char
Result := PAnsiChar(Result); Result := PAnsiChar(Result);
//debugln(['TClipboard.GetAsHtml: Found bomUtf8']);
end; end;
bomUTF16LE: bomUTF16LE:
begin begin
stream.Position := 2; Stream.Position := 2;
SetLength(US, stream.Size - 2); SetLength(US, Stream.Size - 2);
stream.Read(US[1], stream.Size - 2); Stream.Read(US[1], Stream.Size - 2);
//ClipBoard may return a larger stream than the size of the string //ClipBoard may return a larger Stream than the size of the string
//this gets rid of it, since the string will end in a #0 (wide)char //this gets rid of it, since the string will end in a #0 (wide)char
US := PWideChar(US); US := PWideChar(US);
Result := Utf16ToUtf8(US); Result := Utf16ToUtf8(US);
//debugln(['TClipboard.GetAsHtml: FoundbomUtf16LE']);
end; end;
bomUtf16BE: bomUtf16BE:
begin begin
//this may need swapping of WideChars???? //this may need swapping of WideChars????
stream.Position := 2; Stream.Position := 2;
SetLength(US, stream.Size - 2); SetLength(US, Stream.Size - 2);
stream.Read(US[1], stream.Size - 2); Stream.Read(US[1], Stream.Size - 2);
//ClipBoard may return a larger stream than the size of the string //ClipBoard may return a larger Stream than the size of the string
//this gets rid of it, since the string will end in a #0 (wide)char //this gets rid of it, since the string will end in a #0 (wide)char
US := PWideChar(US); US := PWideChar(US);
Result := Utf16ToUtf8(US); Result := Utf16ToUtf8(US);
//debugln(['TClipboard.GetAsHtml: Found bomUtf16BE']);
end; end;
bomUndefined: bomUndefined:
begin begin
//assume the first byte is part of the string and it is some AnsiString //assume the first byte is part of the string and it is some AnsiString
//CF_HTML returns a string encoded as UTF-8 on Windows //CF_HTML returns a string encoded as UTF-8 on Windows
Result := PAnsiChar(Stream.Memory); Result := PAnsiChar(Stream.Memory);
//debugln(['TClipboard.GetAsHtml: Found bomUndefined']);
end; end;
end; end;
@ -844,44 +855,53 @@ begin
end; end;
finally finally
stream.Free; Stream.Free;
end; end;
end; end;
{ Adds html-formatted text to the clipboard. The main Office applications in { Adds html-formatted text to the clipboard. The main Office applications in
Windows and Linux require a valid and complete html text (i.e. with <html> Windows and Linux require a valid and complete html text (i.e. with <html>
and <body> tags). and <body> tags), therefore we insert them if they are not present.
In case of Windows, a specific header must be added (AddWindowsHeader = true), In case of Windows, a specific header will be added,
otherwise the format will not be recognized by the clipboard. } otherwise the format will not be recognized by the clipboard.
procedure TClipboard.SetAsHtml(const Html: String; const PlainText: String; {%H-}AddWindowsHeader: Boolean); }
procedure TClipboard.SetAsHtml(Html: String; const PlainText: String);
var var
stream: TStream; Stream: TStream;
IsValid: Boolean;
begin begin
if CF_HTML = 0 then if CF_HTML = 0 then
exit; exit;
//If the HTML does not have correct <html><body> and closing </body></html> insert them
MaybeInsertHtmlAndBodyTags(HTML, IsValid);
if not IsValid then
exit;
{$IFDEF WINDOWS} {$IFDEF WINDOWS}
if AddWindowsHeader then Stream := TStringStream.Create(InsertClipHeader(Html));
stream := TStringStream.Create(InsertClipHeader(Html)) else
stream := TStringStream.Create(Html);
{$ELSE} {$ELSE}
stream := TStringStream.Create(Html); Stream := TStringStream.Create(Html);
{$ENDIF} {$ENDIF}
try try
//Clear the clipboard before adding Html to it, Stream.Position := 0;
//otherwise external applications will only ever see the first copy. Clipboard.AddFormat(CF_HTML, Stream);
ClipBoard.Clear;
stream.Position := 0;
Clipboard.AddFormat(CF_HTML, stream);
if (PlainText <> '') then if (PlainText <> '') then
begin begin
stream.Size := 0; Stream.Size := 0;
stream.Position := 0; Stream.Position := 0;
stream.WriteAnsiString(PlainText); Stream.WriteBuffer(Pointer(PlainText)^, Length(PlainText)+1); //Also write terminating zero
stream.Position := 0; Stream.Position := 0;
ClipBoard.AddFormat(CF_TEXT, stream); ClipBoard.AddFormat(CF_TEXT, Stream);
end; end;
finally finally
stream.Free; Stream.Free;
end; end;
end; end;
procedure TClipboard.SetAsHtml(Html: String);
begin
SetAsHtml(Html, '');
end;

45
lcl/include/clipbrd_html.inc
View File

@ -88,6 +88,50 @@ begin
FEndTagPos := FParser.CurrentPos - Length(ActualTag) + 1; FEndTagPos := FParser.CurrentPos - Length(ActualTag) + 1;
end; end;
procedure MaybeInsertHtmlAndBodyTags(var HTML: String; out IsValid: Boolean);
var
tagFinder: THTMLTagFinder;
HS, HE, BS, BE: Boolean;
pHS, pHE, pBS, pBE: Integer;
begin
tagFinder := THTMLTagFinder.Create(HTML, 'BODY');
try
pBS := tagFinder.StartTagPos ;
pBE := tagFinder.EndTagPos;
BS := (pBS > -1);
BE := (pBE > -1);
finally
tagFinder.Free;
end;
tagFinder := THTMLTagFinder.Create(HTML, 'HTML');
try
pHS := tagFinder.StartTagPos;
pHE := tagFinder.EndTagPos;
HS := (pHS > -1);
HE := (pHE > -1);
finally
tagFinder.Free;
end;
IsValid := ((HS and HE) or (not HS and not HE)) and
((BS and BE) or (not BS and not BE));
//Do not fix malformed HTML e.i. unmatched <html> or <body> tags
if not IsValid then
exit;
if not BS then
begin
if HS then
begin
Insert('<body>',HTML,pHS+1);
Insert('</body>',HTML,pHE+1+Length('<body>'));
end
else
HTML := '<body>' + HTML + '</body>';
end;
if not HS then HTML := '<html>' + HTML + '</html>';
end;
{$IFDEF WINDOWS} {$IFDEF WINDOWS}
function InsertClipHeader(HTML: String): String; function InsertClipHeader(HTML: String): String;
var var
@ -102,6 +146,7 @@ begin
try try
fragStart := tagFinder.StartTagPos; fragStart := tagFinder.StartTagPos;
fragEnd := tagFinder.EndTagPos; fragEnd := tagFinder.EndTagPos;
//this should not happen, since we added them in SetAsHtml
if (fragStart = -1) or (fragEnd = -1) then if (fragStart = -1) or (fragEnd = -1) then
exit; exit;
finally finally

6
lcl/lclbase.lpk
View File

@ -27,7 +27,7 @@
<License Value="modified LGPL-2 <License Value="modified LGPL-2
"/> "/>
<Version Major="1" Minor="7"/> <Version Major="1" Minor="7"/>
<Files Count="284"> <Files Count="285">
<Item1> <Item1>
<Filename Value="checklst.pas"/> <Filename Value="checklst.pas"/>
<UnitName Value="CheckLst"/> <UnitName Value="CheckLst"/>
@ -1168,6 +1168,10 @@
<Filename Value="include/customflowpanel.inc"/> <Filename Value="include/customflowpanel.inc"/>
<Type Value="Include"/> <Type Value="Include"/>
</Item284> </Item284>
<Item285>
<Filename Value="include/clipbrd_html.inc"/>
<Type Value="Include"/>
</Item285>
</Files> </Files>
<LazDoc Paths="../docs/xml/lcl"/> <LazDoc Paths="../docs/xml/lcl"/>
<i18n> <i18n>