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

* Some improvements to lazreport converter, add diagnostic output, sample conversion program

Browse Source 
git-svn-id: trunk@38927 -
This commit is contained in:
michael 2018-05-06 09:08:32 +00:00
parent f836094e3d
commit 117f9f2c64
4 changed files with 343 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2662,6 +2662,8 @@ packages/fcl-report/demos/fonts/LiberationSerif-Bold.ttf -text
packages/fcl-report/demos/fonts/LiberationSerif-BoldItalic.ttf -text
packages/fcl-report/demos/fonts/LiberationSerif-Italic.ttf -text
packages/fcl-report/demos/fonts/LiberationSerif-Regular.ttf -text
packages/fcl-report/demos/laz2fpreport.lpi svneol=native#text/plain
packages/fcl-report/demos/laz2fpreport.pp svneol=native#text/plain
packages/fcl-report/demos/pictures/man01.png -text svneol=unset#image/png
packages/fcl-report/demos/pictures/man02.png -text svneol=unset#image/png
packages/fcl-report/demos/pictures/man03.png -text svneol=unset#image/png

57
packages/fcl-report/demos/laz2fpreport.lpi Normal file
View File

@ -0,0 +1,57 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasScaledStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="LazReport to FPReport Converter"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="laz2fpreport.pp"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="laz2fpreport"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../src"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

125
packages/fcl-report/demos/laz2fpreport.pp Normal file
View File

@ -0,0 +1,125 @@
program laz2fpreport;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, CustApp, fpjson, fpreport, fplazreport, fpreportstreamer;
type
{ TLazToFPReport }
TLazToFPReport = class(TCustomApplication)
Private
FLazReport : TFPLazReport;
FInputFile,
FOutputFile : String;
FFormatOutput : Boolean;
FVerbose : Boolean;
procedure Convert;
procedure DoVerbose(Sender: TOBject; const Msg: String);
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp(Const aMsg :String); virtual;
end;
{ TLazToFPReport }
procedure TLazToFPReport.DoRun;
var
ErrorMsg: String;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hi:o:vf', ['help','input:','output:','verbose','format']);
if (ErrorMsg<>'') or HasOption('h','help') then
WriteHelp(ErrorMsg);
FInputFile:=GetOptionValue('i','input');
if FInputFile='' then
WriteHelp('No input file specified.');
FOutputFile:=GetOptionValue('o','output');
If FOutputFile='' then
FOutputFile:=ChangeFileExt(FinputFile,'.json');
FFormatOutput:=HasOption('f','format');
FVerbose:=HasOption('v','verbose');
if FVerbose then
FLazReport.OnLog:=@DoVerbose;
Convert;
Terminate;
end;
procedure TLazToFPReport.Convert;
Var
S : TFPReportJSONStreamer;
F : TFileStream;
J : TJSONStringType;
begin
FLazReport.LoadFromFile(FInputFile);
F:=Nil;
S:=TFPReportJSONStreamer.Create(Self);
try
FLazReport.WriteElement(S);
if FFormatOutput then
J:=S.JSON.FormatJSON()
else
J:=S.JSON.AsJSON;
F:=TFileStream.Create(FOutputFile,fmCreate);
F.Write(J[1],Length(J)); // Single byte type.
finally
F.Free;
S.Free;
end;
end;
procedure TLazToFPReport.DoVerbose(Sender: TOBject; const Msg: String);
begin
if FVerbose then
Writeln(StdErr,Msg);
end;
constructor TLazToFPReport.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
FLazReport:=TFPLazReport.Create(Self);
end;
destructor TLazToFPReport.Destroy;
begin
FreeAndNil(FLazReport);
inherited Destroy;
end;
procedure TLazToFPReport.WriteHelp(const aMsg: String);
begin
if (aMsg<>'') then
Writeln('Error : ',aMsg);
writeln('Usage: ', ExeName, ' [options] -i filename');
Writeln('Where options are: ');
Writeln('-f --format Write formatted JSON to output file');
Writeln('-h --help This help message');
Writeln('-i --input=filename input file name, must be a .lrf file, in XML format.');
Writeln('-o --output=filename output file name.');
Writeln(' If not specified, input file with extension changed to .json is used.');
Writeln('-v --verbose Print some diagnostic information');
Halt(Ord(aMsg<>''));
end;
var
Application: TLazToFPReport;
begin
Application:=TLazToFPReport.Create(nil);
Application.Title:='LazReport to FPReport Converter';
Application.Run;
Application.Free;
end.

216
packages/fcl-report/src/fplazreport.pp
View File

@ -20,14 +20,15 @@ unit fplazreport;
interface
uses
Classes, SysUtils, fpreport, fpjsonreport, DOM, XMLRead,
FPReadPNG,FPimage,FPCanvas,fpreportdb;
Classes, SysUtils, fpreport, DOM, FPCanvas, fpTTF, fpreportdb;
Type
TCustomPropEvent = procedure(Sender: TObject;Data : TDOMNode) of object;
TConvertLogEvent = Procedure(Sender: TOBject;Const Msg : String) of Object;
TNameConvertEvent = Procedure(Sender: TOBject;Const aName : UnicodeString; Var aNewName : String) of Object;
TFontSubstitutionEvent = Procedure(Sender: TOBject;Const aFontName : String; Const aBold,aItalic: Boolean; var aFont : TFPFontCacheItem) of Object;
{ TFPLazReport }
TFPLazReport = class(TFPReport)
private
FData: TComponent;
@ -36,24 +37,32 @@ Type
FDetailFooter : TFPReportDataFooterBand;
FDetailBand: TFPReportDataBand;
FMemoClass: TFPReportElementClass;
FOnConvertName: TNameConvertEvent;
FOnLog: TConvertLogEvent;
FOnSetCustomProps: TCustomPropEvent;
FOnSubstituteFont: TFontSubstitutionEvent;
FCounter : Integer;
Protected
class function Red(rgb: Integer): BYTE; virtual;
class function Green(rgb: Integer): BYTE; virtual;
class function Blue(rgb: Integer): BYTE; virtual;
class function FindBand(aPage: TFPReportCustomPage; aTop: double): TFPReportCustomBand; virtual;
class function GetProperty(aNode: TDOMNode; aName: string; aValue: string='Value'): string; virtual;
class function GetProperty(aNode: TDOMNode; const aName: String; const aValue: string='Value'): UTF8String; virtual;
function ApplyFrame(aDataNode: TDOMNode; aFrame: TFPReportFrame): Boolean; virtual;
procedure ApplyObjectProperties(ObjNode: TDOMNode; aObj: TFPReportElement); virtual;
procedure ConvertPageProperties(aPage: TFPReportPage; aPageNode: TDOMNode); virtual;
procedure SetData(AValue: TComponent);virtual;
procedure SizeToLayout(aDataNode: TDOMNode; aObj: TFPReportElement);virtual;
Function ConvertComponentName(Const aName : UnicodeString;Const AClassName : String) : String; virtual;
function ConvertFont(aDataNode: TDomNode): TFPFontCacheItem; virtual;
function ConvertBand(aBandNode: TDomNode;aPage: TFPReportCustomPage): TFPReportCustomBand; virtual;
function ConvertMemo(ObjNode: TDOMNode; aPage: TFPReportCustomPage): TFPReportMemo; virtual;
function ConvertPage(aPageNode: TDOMNode): TFPReportPage; virtual;
function ConvertLine(ObjNode: TDOMNode; APage: TFPReportCustomPage): TFPReportShape; virtual;
function ConvertImage(ObjNode: TDOMNode; APage: TFPReportCustomPage): TFPReportImage; virtual;
Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Procedure DoLog(Const Msg : String);
Procedure DoLog(Const Fmt : String; Const Args : Array of const);
Public
constructor Create(AOwner: TComponent); override;
function FixDataFields(aFieldName : string) : string;
@ -63,6 +72,9 @@ Type
Published
property DataContainer : TComponent read FData write SetData;
property OnSetCustomproperties : TCustomPropEvent read FOnSetCustomProps write FOnSetCustomProps;
Property OnLog : TConvertLogEvent Read FOnLog Write FOnLog;
Property OnSubstituteFont : TFontSubstitutionEvent Read FOnSubstituteFont Write FOnSubstituteFont;
Property OnConvertName : TNameConvertEvent Read FOnConvertName Write FOnConvertName;
end;
function MMToPixels(Const Dist: double) : Integer;
@ -70,7 +82,15 @@ Type
implementation
uses fpTTF,dateutils,base64,FPReadGif,FPReadJPEG;
uses dateutils, XMLRead,FPReadPNG,FPimage,FPReadGif,FPReadJPEG;
Resourcestring
SLogUnknownClass = 'Ignoring unknown lazreport class type for object "%s": "%s".';
SErrUnknownBandType = 'Unknown band type: "%s", substituting child band';
SErrWrongEncoding = 'Unknown image encoding at pos %d : %s';
SFontSubstitution = 'FontSubstitution';
SErrUnknownImageType = 'Unknown image type encountered: "%s"';
SWarnConvertName = 'Name conversion: "%s" to "%s"';
function PixelsToMM(Const Dist: double) : TFPReportUnits;
begin
@ -106,6 +126,27 @@ begin
FData:=Nil;
end;
procedure TFPLazReport.DoLog(const Msg: String);
begin
If Assigned(FOnLog) then
FOnLog(Self,Msg);
end;
procedure TFPLazReport.DoLog(const Fmt: String; const Args: array of const);
Var
S : String;
begin
try
S:=Format(Fmt,Args);
except
on E : Exception do
S:=Format('Failed to format error message "%s" with %d arguments',[Fmt,Length(Args)]);
end;
DoLog(S);
end;
constructor TFPLazReport.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
@ -114,9 +155,10 @@ begin
end;
function TFPLazReport.FixDataFields(aFieldName: string): string;
var
k : Integer = 0;
atmp : string;
begin
Result := aFieldName;
if Assigned(FData) then
@ -149,7 +191,6 @@ procedure TFPLazReport.LoadFromXML(LazReport: TXMLDocument);
var
i: Integer;
j: Integer;
BaseNode,lPages : TDOMNode;
aPage: TFPReportPage;
@ -170,15 +211,17 @@ begin
end;
end;
Class function TFPLazReport.GetProperty(aNode : TDOMNode;aName : string;aValue : string = 'Value') : string;
Class function TFPLazReport.GetProperty(aNode : TDOMNode;Const aName : String; Const aValue : string = 'Value') : UTF8String;
var
bNode: TDOMNode;
begin
Result := '';
bNode := aNode.FindNode(aName);
if Assigned(bNode) then
if Assigned(bNode.Attributes.GetNamedItem(aValue)) then
Result := bNode.Attributes.GetNamedItem(aValue).NodeValue;
Result := UTF8Encode(bNode.Attributes.GetNamedItem(aValue).NodeValue);
end;
Class function TFPLazReport.FindBand(aPage : TFPReportCustomPage;aTop : double) : TFPReportCustomBand;
@ -259,7 +302,7 @@ begin
if Assigned(FDetailBand) then
TFPReportDataHeaderBand(aBand).Data := FDetailBand.Data
else
FDetailHeader := TFPReportDataHeaderBand(Self);
FDetailHeader:=TFPReportDataHeaderBand(aBand);
end;
'btDetailFooter':
begin
@ -285,7 +328,10 @@ begin
'btGroupFooter':
aBand := TFPReportGroupFooterBand.Create(Self);
else
aBand := TFPReportCustomBand.Create(Self);
begin
DoLog(SErrUnknownBandType,[Tmp]);
aBand := TFPReportChildBand.Create(Self);
end;
end;
if Assigned(aBand) then
begin
@ -295,13 +341,66 @@ begin
Result:=aBand;
end;
Function TFPLazReport.ConvertFont(aDataNode : TDomNode) : TFPFontCacheItem;
Var
i : Integer;
FontFound, aBold, aItalic : Boolean;
aFont : TFPFontCacheItem;
RealFont,FontName : String;
begin
aBold := pos('fsBold',GetProperty(aDataNode,'Style'))>0;
aItalic := pos('fsItalic',GetProperty(aDataNode,'Style'))>0;
FontName:=GetProperty(aDataNode,'Name');
aFont := gTTFontCache.Find(FontName,aBold,aItalic);
FontFound := not Assigned(aFont);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('LiberationSans',aBold,aItalic);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('Arial',aBold,aItalic);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('DejaVu',aBold,aItalic);
with gTTFontCache do
begin
i:=0;
While (aFont=Nil) and (i<Count) do
begin
aFont := Items[i];
if Not ((pos('sans',lowercase(aFont.FamilyName)) > 0) and (aFont.IsItalic = AItalic)
and (aFont.IsBold = ABold)) then
aFont:=nil;
Inc(i);
end;
end;
if Not FontFound then
begin
// Allow user to override
If Assigned(FOnSubstituteFont) then
FOnSubstituteFont(Self,FontName,aBold,aItalic,aFont);
// Log it
if Assigned(FOnLog) then
begin
if Assigned(aFont) then
RealFont:=aFont.FamilyName
else
RealFont:='<nil>';
if aBold then
RealFont:=RealFont+'[Bold]';
if aItalic then
RealFont:=RealFont+'[Italic]';
DoLog(SFontSubstitution,[FOntName,RealFont]);
end;
end;
Result:=aFont;
end;
Function TFPLazReport.ConvertMemo(ObjNode : TDOMNode;aPage : TFPReportCustomPage) : TFPReportMemo;
Var
aDataNode: TDOMNode;
aBand: TFPReportCustomBand;
i,aColor,aSize,aFlag : Integer;
FontFound, aBold, aItalic : Boolean;
aColor,aSize,aFlag : Integer;
aFont: TFPFontCacheItem;
begin
@ -331,32 +430,8 @@ begin
Result.Text:=FixDataFields(GetProperty(aDataNode,'Memo'));
Result.UseParentFont := False;
aDataNode := ObjNode.FindNode('Font');
aBold := pos('fsBold',GetProperty(aDataNode,'Style'))>0;
aItalic := pos('fsItalic',GetProperty(aDataNode,'Style'))>0;
aFont := gTTFontCache.Find(GetProperty(aDataNode,'Name'),aBold,aItalic);
FontFound := not Assigned(aFont);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('LiberationSans',aBold,aItalic);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('Arial',aBold,aItalic);
if not Assigned(aFont) then
aFont := gTTFontCache.Find('DejaVu',aBold,aItalic);
with gTTFontCache do
begin
i:=0;
While (aFont=Nil) and (i<Count) do
begin
aFont := Items[i];
if Not ((pos('sans',lowercase(aFont.FamilyName)) > 0) and (aFont.IsItalic = AItalic)
and (aFont.IsBold = ABold)) then
aFont:=nil;
Inc(i);
end;
end;
{$ifdef UNIX}
if (not FontFound) and Assigned(aFont) then
writeln('using Font "'+aFont.FamilyName+'" instead "'+GetProperty(aDataNode,'Name')+'"');
{$endif}
if Assigned(aDataNode) then
aFont:=ConvertFont(aDataNode);
if Assigned(aFont) then
Result.Font.Name:=aFont.PostScriptName
else
@ -389,7 +464,7 @@ Function TFPLazReport.ConvertImage(ObjNode : TDOMNode; APage : TFPReportCustomPa
Var
aDataNode: TDOMNode;
aBand: TFPReportCustomBand;
tmp : String;
tmp,e : String;
SS: TStream;
aReaderClass : TFPCustomImageReaderClass;
B : Byte;
@ -401,13 +476,17 @@ begin
Result := TFPReportImage.Create(aBand);
aDataNode := ObjNode.FindNode('Picture');
aReaderClass:=nil;
case lowercase(GetProperty(aDataNode,'Type','Ext')) of
tmp:=lowercase(GetProperty(aDataNode,'Type','Ext'));
case tmp of
'jpeg','jpg': aReaderClass := TFPReaderJPEG;
'png': aReaderClass := TFPReaderPNG;
'gif': aReaderClass := TFPReaderGif;
end;
if Not Assigned(aReaderClass) then
begin
DoLog(SErrUnknownImageType,[tmp]);
exit;
end;
tmp:=GetProperty(aDataNode,'Data');
if Tmp='' then
Exit;
@ -415,7 +494,10 @@ begin
try
for i:=1 to (system.length(tmp) div 2) do
begin
Val('$'+tmp[i*2-1]+tmp[i*2], B, cd);
e:=tmp[i*2-1]+tmp[i*2];
Val('$'+E, B, cd);
if cd<>0 then
DoLog(SErrWrongEncoding,[i*2-1,E]);
ss.Write(B, 1);
end;
ss.Position:=0;
@ -449,6 +531,24 @@ begin
end;
end;
function TFPLazReport.ConvertComponentName(const aName: UnicodeString; const AClassName: String): String;
begin
if IsValidIdent(aName) then
Result:=aName
else
begin
Repeat
Inc(FCounter);
Result:=aClassName+IntToStr(FCounter);
Until FindComponent(Result)=Nil;
if Assigned(FOnConvertName) then
FOnConvertName(Self,aName,Result);
DoLog(SWarnConvertName,[aName,Result]);
end;
end;
Function TFPLazReport.ApplyFrame(aDataNode : TDOMNode; aFrame: TFPReportFrame) : Boolean;
Var
@ -489,7 +589,7 @@ Var
aColor : Integer;
begin
aObj.Name:=GetProperty(ObjNode,'Name');
aObj.Name:=ConvertComponentName(GetProperty(ObjNode,'Name'),aObj.ClassName);
aDataNode := ObjNode.FindNode('Size');
if Assigned(aDataNode) then
SizeToLayout(aDataNode,aObj);
@ -514,7 +614,7 @@ begin
end;
end;
Procedure TFPLazReport.ConvertPageProperties(aPage : TFPReportPage; aPageNode : TDOMNode) ;
procedure TFPLazReport.ConvertPageProperties(aPage: TFPReportPage; aPageNode: TDOMNode);
Var
aDataNode: TDOMNode;
@ -540,9 +640,10 @@ Function TFPLazReport.ConvertPage(aPageNode : TDOMNode) : TFPReportPage;
var
aPage: TFPReportPage;
nPage, lPages,ObjNode,BaseNode, aDataNode: TDOMNode;
ObjNode : TDOMNode;
aObj: TFPReportElement;
J : Integer;
NodeName,CT : String;
begin
FMasterData := nil;
@ -555,9 +656,11 @@ begin
for j := 0 to aPageNode.ChildNodes.Count-1 do
begin
ObjNode:=aPageNode.ChildNodes.Item[j];
if copy(ObjNode.NodeName,0,6)='Object' then
NodeName:=ObjNode.NodeName;
if (copy(NodeName,0,6)='Object') and (NodeName<>'ObjectCount') then
begin
case GetProperty(ObjNode,'ClassName') of
CT:=GetProperty(ObjNode,'ClassName');
case CT of
'TfrBandView':
aObj:=ConvertBand(ObjNode,aPage);
'TfrMemoView':
@ -567,6 +670,7 @@ begin
'TfrPictureView':
aObj:=ConvertImage(ObjNode,aPage);
else
DoLog(SLogUnknownClass,[NodeName,CT]);
aObj:=Nil;
end;
if Assigned(aObj) then
@ -577,19 +681,17 @@ end;
procedure TFPLazReport.LoadFromFile(const aFileName: String);
var
LazReport: TXMLDocument;
begin
if lowercase(ExtractFileExt(aFileName)) = '.lrf' then
begin
ReadXMLFile(LazReport, aFileName);
try
LoadFromXML(LazReport);
finally
LazReport.Free;
end;
end
else inherited;
ReadXMLFile(LazReport, aFileName);
try
LoadFromXML(LazReport);
finally
LazReport.Free;
end;
end;
end.