paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-30 16:00:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Merging revisions r43489 from trunk:

Browse Source 
------------------------------------------------------------------------
    r43489 | michael | 2019-11-16 12:30:37 +0100 (Sat, 16 Nov 2019) | 1 line
    
    * Fix bug ID #0035296: need to handle really long words for memos
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@43719 -
This commit is contained in:
michael 2019-12-23 13:24:15 +00:00
parent 067a40c68e
commit c561c43c32
2 changed files with 95 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
packages/fcl-report/src/fpreport.pp
View File

@ -142,6 +142,7 @@ type
moResetAggregateOnColumn
);
TFPReportMemoOptions = set of TFPReportMemoOption;
TFPReportWordWrapOverflow = (wwoTruncate,wwoOverflow,wwoSplit);
TFPReportSections = set of rsPage..rsColumn;
@ -1929,12 +1930,13 @@ type
ExpressionNodes: array of TExprNodeInfoRec;
FFont: TFPReportFont;
FUseParentFont: Boolean;
FWordWrapOverflow: TFPReportWordWrapOverflow;
function GetParentFont: TFPReportFont;
procedure HandleFontChange(Sender: TObject);
procedure SetCullThreshold(AValue: TFPReportCullThreshold);
procedure SetText(AValue: TFPReportString);
procedure SetUseParentFont(AValue: Boolean);
procedure WrapText(const AText: String; var ALines: TStrings; const ALineWidth: TFPReportUnits; out AHeight: TFPReportUnits);
procedure SetWordWrapOverflow(AValue: TFPReportWordWrapOverflow);
procedure ApplyHorzTextAlignment;
procedure ApplyVertTextAlignment;
function GetTextLines: TStrings;
@ -1958,6 +1960,7 @@ type
procedure SetFont(const AValue: TFPReportFont);
procedure CullTextOutOfBounds;
protected
procedure WrapText(const AText: String; var ALines: TStrings; const ALineWidth: TFPReportUnits; out AHeight: TFPReportUnits); virtual;
procedure ReassignParentFont;
procedure ParentFontChanged; override;
function CreateTextAlignment: TFPReportTextAlignment; virtual;
@ -1981,6 +1984,7 @@ type
property UseParentFont: Boolean read FUseParentFont write SetUseParentFont default True;
{ % of line height that should be visible, otherwise it's culled if StretchMode = smDontStretch. Valid range is 1-100% and default is 75%}
property CullThreshold: TFPReportCullThreshold read FCullThreshold write SetCullThreshold default 75;
Property WordWrapOverflow : TFPReportWordWrapOverflow read FWordWrapOverflow write SetWordWrapOverflow;
protected
// *****************************
// This block is made Protected simply for Unit Testing purposes.
@ -2022,6 +2026,7 @@ type
property LineSpacing;
property LinkColor;
property Options;
Property WordWrapOverflow;
property StretchMode;
property Text;
property TextAlignment;
@ -3921,6 +3926,13 @@ begin
Changed;
end;
procedure TFPReportCustomMemo.SetWordWrapOverflow(AValue: TFPReportWordWrapOverflow);
begin
if FWordWrapOverflow=AValue then Exit;
FWordWrapOverflow:=AValue;
Changed;
end;
procedure TFPReportCustomMemo.WrapText(const AText: String; var ALines: TStrings; const ALineWidth: TFPReportUnits; out
AHeight: TFPReportUnits);
var
@ -3959,25 +3971,31 @@ var
s3 := s2; // we might need the value of s2 later again
// are we in the middle of a word. If so find the beginning of word.
while (m > 0) and (Copy(s2, m, m+1) <> ' ') do
begin
while (m > 0) and (s2[m] <> ' ') do
Dec(m);
s2 := Copy(s,1,m);
end;
s2 := Copy(s,1,m);
if s2 = '' then
begin
s2 := s3;
m := Length(s2);
{ We reached the beginning of the line without finding a word that fits the maxw.
So we are forced to use a longer than maxw word. We were in the middle of
a word, so now find the end of the current word. }
while (m < Length(s)) and (Copy(s2, m, m+1) <> ' ') do
begin
Inc(m);
s2 := Copy(s,1,m);
end;
end;
// Single word does not fit. S3 is max word that fits.
s2 := s3;
Case WordWrapOverflow of
wwoOverflow:
begin
{ We reached the beginning of the line without finding a word that fits the maxw.
So we are forced to use a longer than maxw word. We were in the middle of
a word, so now find the end of the current word. }
m := Length(s2);
while (m < Length(s)) and (s[m]<> ' ') do
Inc(m);
s2:=Copy(s,1,m);
end;
wwoTruncate:
m:=Length(S); // Discard the remainder of the word.
wwoSplit:
m:=Length(S3); // S3 was the longest possible part of the word. Split after
end;
end;
ALines.Add(s2);
s := Copy(s, m+1, Length(s));
s2 := s;
@ -5124,6 +5142,7 @@ begin
TextAlignment.Assign(E.TextAlignment);
Options := E.Options;
Original := E;
WordWrapOverflow:= E.WordWrapOverflow;
end;
end;

60
packages/fcl-report/test/tcbasereport.pp
View File

@ -461,6 +461,8 @@ type
end;
{ TTestReportMemo }
TTestReportMemo = class(TTestCase)
private
FMemo: TFPReportMemo;
@ -473,6 +475,9 @@ type
procedure TestPrepareTextBlocks;
procedure TestPrepareTextBlocks_multiline_data;
procedure TestPrepareTextBlocks_multiline_wraptext;
procedure TestPrepareTextBlocks_multiline_wraptext_oneword;
procedure TestPrepareTextBlocks_multiline_wraptext_oneword_overflow;
procedure TestPrepareTextBlocks_multiline_wraptext_oneword_split;
procedure TestRGBToReportColor;
procedure TestHTMLColorToReportColor_length7;
procedure TestHTMLColorToReportColor_length6;
@ -3404,6 +3409,61 @@ begin
AssertEquals('Failed on 2', 2, FMemo.TextLines.Count);
end;
procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword;
begin
gTTFontCache.Clear;
gTTFontCache.SearchPath.Text := 'fonts';
gTTFontCache.BuildFontCache;
FMemo.Layout.Width := 10;
FMemo.Text := 'abc123';
FMemo.UseParentFont := False;
FMemo.Font.Name := 'Calibri';
FMemo.StretchMode := smActualHeight;
TMemoFriend(FMemo).CreateRTLayout;
TMemoFriend(FMemo).RecalcLayout;
AssertEquals('Failed on 1', 1, FMemo.TextLines.Count);
// The length of abc1 fits.
AssertEquals('Failed on 1', 'abc1', FMemo.TextLines[0]);
end;
procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword_overflow;
begin
gTTFontCache.Clear;
gTTFontCache.SearchPath.Text := 'fonts';
gTTFontCache.BuildFontCache;
FMemo.Layout.Width := 10;
FMemo.Text := 'abc123';
FMemo.UseParentFont := False;
FMemo.Font.Name := 'Calibri';
FMemo.StretchMode := smActualHeight;
TMemoFriend(FMemo).WordWrapOverflow:=wwoOverflow;
TMemoFriend(FMemo).CreateRTLayout;
TMemoFriend(FMemo).RecalcLayout;
AssertEquals('Failed on 1', 1, FMemo.TextLines.Count);
AssertEquals('Failed on 1', 'abc123', FMemo.TextLines[0]);
end;
procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword_split;
begin
gTTFontCache.Clear;
gTTFontCache.SearchPath.Text := 'fonts';
gTTFontCache.BuildFontCache;
FMemo.Layout.Width := 10;
FMemo.Text := 'abc123';
FMemo.UseParentFont := False;
FMemo.Font.Name := 'Calibri';
FMemo.StretchMode := smActualHeight;
TMemoFriend(FMemo).WordWrapOverflow:=wwoSplit;
TMemoFriend(FMemo).CreateRTLayout;
TMemoFriend(FMemo).RecalcLayout;
AssertEquals('Failed on 1', 2, FMemo.TextLines.Count);
AssertEquals('Failed on 2', 'abc1', FMemo.TextLines[0]);
AssertEquals('Failed on 3', '23', FMemo.TextLines[1]);
end;
procedure TTestReportMemo.TestRGBToReportColor;
var
c: TFPReportColor;