LazReport, implemented parameters for export filters, CSV exporter now output quoted values and is not based on object's interpolated position

git-svn-id: trunk@23076 -

.gitattributes

@@ -1365,6 +1365,7 @@ components/lazreport/source/lr_dsopt.lfm svneol=native#text/plain
 components/lazreport/source/lr_dsopt.lrs svneol=native#text/pascal
 components/lazreport/source/lr_dsopt.pas svneol=native#text/pascal
 components/lazreport/source/lr_e_csv.pas svneol=native#text/pascal
+components/lazreport/source/lr_e_gen.pas svneol=native#text/pascal
 components/lazreport/source/lr_e_htm.pas svneol=native#text/pascal
 components/lazreport/source/lr_e_txt.pas svneol=native#text/pascal
 components/lazreport/source/lr_edit.lfm svneol=native#text/plain

components/lazreport/source/lazreport.lpk

@@ -27,7 +27,7 @@ Lazarus Port: Olivier Guilbaud, Jesus Reyes A.
 See license.txt and license-lazreport.txt for details.
 "/>
     <Version Minor="9" Release="5"/>
-    <Files Count="64">
+    <Files Count="65">
       <Item1>
         <Filename Value="lr_class.pas"/>
         <UnitName Value="LR_Class"/>
@@ -285,6 +285,10 @@ See license.txt and license-lazreport.txt for details.
         <Filename Value="lr_e_csv.pas"/>
         <UnitName Value="LR_E_CSV"/>
       </Item64>
+      <Item65>
+        <Filename Value="lr_e_gen.pas"/>
+        <UnitName Value="lr_e_gen"/>
+      </Item65>
     </Files>
     <i18n>
       <EnableI18N Value="True"/>

components/lazreport/source/lazreport.pas

@@ -1,5 +1,5 @@
-{ This file was automatically created by Lazarus. do not edit!
-  This source is only used to compile and install the package.
+{ Este archivo ha sido creado automáticamente por Lazarus. ¡No lo edite!
+  Este fuente se utiliza sólo para compilar e instalar el paquete.
  }
 
 unit lazreport; 
@@ -11,7 +11,7 @@ uses
   LR_PGrid, LR_View, lr_expres, lr_funct_editor_unit, lr_funct_editor_unit1, 
   LR_Prntr, LR_Edit, LR_Pars, LR_fmted, LR_Const, LR_pgopt, LR_Dopt, LR_GEdit, 
   LR_Utils, LR_GrpEd, lr_propedit, LR_progr, LR_IFlds, SysUtilsAdds, LR_RRect, 
-  LR_Shape, LR_E_TXT, LR_E_HTM, LR_E_CSV, LazarusPackageIntf;
+  LR_Shape, LR_E_TXT, LR_E_HTM, LR_E_CSV, lr_e_gen, LazarusPackageIntf;
 
 implementation
 

components/lazreport/source/lr_class.pas

@@ -18,9 +18,7 @@ uses
   SysUtils, Classes, Controls, FileUtil,
   Forms, ComCtrls, Dialogs, Menus,
   Variants, DB,Graphics,Printers,osPrinters,XMLConf,
-  
-  LCLType,LCLIntf,TypInfo,LCLProc,
-  SysUtilsAdds,
+  LCLType,LCLIntf,TypInfo,LCLProc, SysUtilsAdds,
   LR_View, LR_Pars, LR_Intrp, LR_DSet, LR_DBSet, LR_DBRel, LR_Const;
 
 const
@@ -29,13 +27,17 @@ const
   flWordWrap               = 2;
   flWordBreak              = 4;
   flAutoSize               = 8;
-  flHideDuplicates         = 16;
+  flHideDuplicates         = $10;
+  flStartRecord            = $20;
+  flEndRecord              = $40;
+
   flBandNewPageAfter       = 2;
   flBandPrintifSubsetEmpty = 4;
   flBandPageBreak          = 8;
   flBandOnFirstPage        = $10;
   flBandOnLastPage         = $20;
   flBandRepeatHeader       = $40;
+
   flPictCenter             = 2;
   flPictRatio              = 4;
   flWantHook               = $8000;
@@ -66,6 +68,7 @@ type
                  btOverlay, btColumnHeader, btColumnFooter,
                  btGroupHeader, btGroupFooter,
                  btCrossHeader, btCrossData, btCrossFooter, btNone);
+  TfrBandTypes = set of TfrBandType;
   TfrDataSetPosition = (psLocal, psGlobal);
   TfrValueType = (vtNotAssigned, vtDBField, vtOther, vtFRVar);
   TfrPageMode = (pmNormal, pmBuildList);
@@ -796,11 +799,20 @@ type
     property Count: Integer read GetCount;
   end;
 
+  { TfrExportFilter }
+
+  TExportFilterSetup = procedure(Sender: TfrExportFilter) of object;
+
   TfrExportFilter = class(TObject)
+  private
+    FOnSetup: TExportFilterSetup;
+    FBandTypes: TfrBandTypes;
+    FUseProgressBar: boolean;
   protected
     Stream: TStream;
     Lines: TFpList;
     procedure ClearLines;
+    procedure Setup; virtual;
   public
     constructor Create(AStream: TStream); virtual;
     destructor Destroy; override;
@@ -810,6 +822,10 @@ type
     procedure OnEndPage; virtual;
     procedure OnData(x, y: Integer; View: TfrView); virtual;
     procedure OnText(x, y: Integer; const text: String; View: TfrView); virtual;
+
+    property BandTypes: TfrBandTypes read FBandTypes write FBandTypes;
+    property UseProgressbar: boolean read FUseProgressBar write FUseProgressBar;
+    property OnSetup: TExportFilterSetup read FOnSetup write FOnSetup;
   end;
 
   TfrExportFilterClass = class of TfrExportFilter;
@@ -821,6 +837,7 @@ type
   TfrReport = class(TComponent)
   private
     FDataType: TfrDataType;
+    FOnExportFilterSetup: TExportFilterSetup;
     FPages: TfrPages;
     FEMFPages: TfrEMFPages;
     FReportAutor: string;
@@ -985,6 +1002,7 @@ type
     property OnBeginColumn: TBeginColumnEvent read FOnBeginColumn write FOnBeginColumn;
     property OnPrintColumn: TPrintColumnEvent read FOnPrintColumn write FOnPrintColumn;
     property OnManualBuild: TManualBuildEvent read FOnManualBuild write FOnManualBuild;
+    property OnExportFilterSetup: TExportFilterSetup read FOnExportFilterSetup write FOnExportFilterSetup;
   end;
 
   TfrCompositeReport = class(TfrReport)
@@ -1093,6 +1111,7 @@ type
     Text: String[255];
     FontName: String[32];
     FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer;
+    Typ: Byte;
   end;
 
   TfrAddInObjectInfo = record
@@ -4682,6 +4701,11 @@ begin
       DoSubReports;
       break;
     end;
+
+    t.Flags:=t.Flags and not (flStartRecord or flEndRecord);
+    if i=0 then               t.Flags := t.Flags or flStartRecord;
+    if i=Objects.Count-1 then t.Flags := t.Flags or flEndRecord;
+
     DrawObject(t);
     if MasterReport.Terminated then break;
   end;
@@ -8280,11 +8304,18 @@ var
 begin
   ExportStream := TFileStream.Create(UTF8ToSys(aFileName), fmCreate);
   FCurrentFilter := FilterClass.Create(ExportStream);
-  FCurrentFilter.OnBeginDoc;
 
   CurReport := Self;
   MasterReport := Self;
+
+  FCurrentFilter.OnSetup:=CurReport.OnExportFilterSetup;
+
+  FCurrentFilter.Setup;
+  FCurrentFilter.OnBeginDoc;
+
   SavedAllPages := EMFPages.Count;
+
+  if FCurrentFilter.UseProgressbar then
   with frProgressForm do
   begin
     s := sReportPreparing;
@@ -8296,7 +8327,8 @@ begin
     Label1.Caption := FirstCaption + '  1';
     OnBeforeModal := @ExportBeforeModal;
     Show_Modal(Self);
-  end;
+  end else
+    ExportBeforeModal(nil);
 
   FreeAndNil(FCurrentFilter);
   ExportStream.Free;
@@ -8925,6 +8957,7 @@ begin
   inherited Create;
   Stream := AStream;
   Lines := TFpList.Create;
+  FBandTypes := [btMasterHeader, btMasterData];
 end;
 
 destructor TfrExportFilter.Destroy;
@@ -8952,6 +8985,12 @@ begin
   Lines.Clear;
 end;
 
+procedure TfrExportFilter.Setup;
+begin
+  if assigned(FOnSetup) then
+    FOnSetup(Self);
+end;
+
 procedure TfrExportFilter.OnBeginDoc;
 begin
 // abstract method

components/lazreport/source/lr_e_csv.pas

@@ -17,10 +17,12 @@ interface
 uses
   Classes, SysUtils, LResources,
   Graphics,GraphType, Controls, Forms, Dialogs,LR_E_TXT,
-  LCLType,LCLIntf,LR_Class;
+  LCLType,LCLIntf,lr_utils,lr_class;
 
 type
 
+  TfrQuoteType = (qtNone, qtQuoteChar);
+
   TfrCSVExport = class(TComponent) 
   public
     Constructor Create(aOwner : TComponent); override;
@@ -30,13 +32,22 @@ type
 
   TfrCSVExportFilter = class(TfrTextExportFilter)
   private
-    FIntervals: TFPList;
+    FQuoteChar: TUTF8Char;
+    FQuoteType: TfrQuoteType;
+    FSeparator: TUTF8Char;
+    FCurY     : Integer;
+  protected
+    procedure GetUsedFont; override;
   public
     constructor Create(AStream: TStream); override;
-    destructor Destroy; override;
     procedure OnBeginPage; override;
     procedure OnEndPage; override;
+    procedure OnData(x, y: Integer; View: TfrView); override;
     procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override;
+
+    property QuoteChar: TUTF8Char read FQuoteChar write FQuoteChar;
+    property QuoteType: TfrQuoteType read FQuoteType write FQuoteType;
+    property Separator: TUTF8Char read FSeparator write FSeparator;
   end;
 
 
@@ -47,22 +58,23 @@ uses LR_Const;
 const
   FIELD_GRAIN  = 32;  // granularity of fields when converting pixel positions
 
+procedure TfrCSVExportFilter.GetUsedFont;
+begin
+  // never ask usedfont dialog in CSV exporter
+end;
+
 constructor TfrCSVExportFilter.Create(AStream: TStream);
 begin
   inherited Create(AStream);
-  FIntervals := TFPList.Create;
-end;
-
-destructor TfrCSVExportFilter.Destroy;
-begin
-  FIntervals.Free;
-  inherited destroy;
+  FQuoteType := qtQuoteChar;
+  FQuoteChar := '"';
+  FSeparator := ';';
 end;
 
 procedure TfrCSVExportFilter.OnBeginPage;
 begin
   inherited OnBeginPage;
-  FIntervals.Clear;
+  FCurY := -1;
 end;
 
 function CompareIntervals(Item1, Item2: Pointer): Integer;
@@ -72,10 +84,25 @@ end;
 
 procedure TfrCSVExportFilter.OnEndPage;
 var
-  i, j, k, n, tc1, tc2: Integer;
-  MaxCols: Integer;
-  p, q: PfrTextRec;
-  s,str: String;
+  i,n: Integer;
+  p: PfrTextRec;
+  s: String;
+
+  procedure AddStr(aStr: string);
+  begin
+    if QuoteType=qtNone then begin
+      if s = '' then
+        s := aStr
+      else
+        s := aStr + Separator + aStr;
+    end else begin
+      if s = '' then
+        s := UTF8Quotedstr(aStr, QuoteChar)
+      else
+        s := s + Separator + UTF8Quotedstr(aStr, QuoteChar);
+    end;
+  end;
+
 begin
 
   n := Lines.Count - 1;
@@ -85,47 +112,83 @@ begin
     Dec(n);
   end;
 
-  if FIntervals.Count = 0 then
-    exit;
-
-  FIntervals.Sort(@CompareIntervals);
-
   for i := 0 to n do
   begin
-    p := PfrTextRec(Lines[i]);
-    if p = nil then
-      continue;
-
     s := '';
-    for j := 0 to FIntervals.Count-1 do
-    begin
-
-      if (P <> nil) and ((P^.X div FIELD_GRAIN) = PtrInt(FIntervals[j])) then
-      begin
-        Str := p^.Text;
-        p := p^.Next;
-      end else
-        Str := '';
-
-      if j=0 then
-        s := str
-      else
-        s := s + ';' + str;
-
+    p := PfrTextRec(Lines[i]);
+    while p<>nil do begin
+      if P^.Typ in [gtMemo,gtAddin] then
+        AddStr(P^.Text);
+      p := p^.Next;
     end;
-
     s := s + LineEnding;
     Stream.Write(s[1], Length(s));
   end;
 end;
 
+procedure TfrCSVExportFilter.OnData(x, y: Integer; View: TfrView);
+var
+  p, p1, p2: PfrTextRec;
+  i: Integer;
+  s: string;
+begin
+
+  if (View = nil) or not (View.ParentBandType in BandTypes) then
+    exit;
+  if View.Flags and flStartRecord<>0 then
+    Inc(FCurY);
+
+  p1 := PfrTextRec(Lines[FCurY]);
+
+  GetMem(p, SizeOf(TfrTextRec));
+  FillChar(p^, SizeOf(TfrTextRec), 0);
+  p^.Next := nil;
+  p^.X := X;
+  P^.Typ := View.Typ;
+  p^.Text := '';
+  for i:=0 to View.Memo.Count-1 do begin
+    P^.Text := P^.Text + View.Memo[i];
+    if i<>View.Memo.Count-1 then
+      P^.Text := P^.Text + LineEnding;
+  end;
+  if View is TfrMemoView then
+    with View as TfrMemoView do
+    begin
+      p^.FontName := Font.Name;
+      p^.FontSize := Font.Size;
+      p^.FontStyle := frGetFontStyle(Font.Style);
+      p^.FontColor := Font.Color;
+      p^.FontCharset := Font.Charset;
+    end;
+  p^.FillColor := View.FillColor;
+
+  if p1 = nil then
+    Lines[FCurY] := TObject(p)
+  else
+  begin
+    p2 := p1;
+    while (p1 <> nil) and (p1^.X < p^.X) do
+    begin
+      p2 := p1;
+      p1 := p1^.Next;
+    end;
+    if p2 <> p1 then
+    begin
+      p2^.Next := p;
+      p^.Next := p1;
+    end
+    else
+    begin
+      Lines[FCurY] := TObject(p);
+      p^.Next := p1;
+    end;
+  end;
+end;
+
 procedure TfrCSVExportFilter.OnText(X, Y: Integer; const Text: String;
   View: TfrView);
 begin
-  inherited OnText(X, Y, Text, View);
-  x := x div FIELD_GRAIN;
-  if FIntervals.IndexOf(pointer(ptrint(x)))<0 then
-    FIntervals.Add(pointer(ptrint(x)));
+  //
 end;
 
 constructor TfrCSVExport.Create(aOwner: TComponent);

components/lazreport/source/lr_e_gen.pas

@@ -0,0 +1,127 @@
+unit lr_e_gen;
+
+interface
+
+{$I lr_vers.inc}
+
+uses
+  Classes, SysUtils, LResources,
+  Graphics,GraphType, Controls, Forms, Dialogs,LR_E_TXT,
+  LCLType,LCLIntf,LR_Class, LCLProc;
+
+type
+
+  { TfrDBGExport }
+
+  TfrDBGExport = class(TComponent)
+  public
+    Constructor Create(aOwner : TComponent); override;
+  end;
+
+  { TfrDBGExportFilter }
+
+  TfrDBGExportFilter = class(TfrExportFilter)
+  public
+    constructor Create(AStream: TStream); override;
+    destructor Destroy; override;
+    procedure OnBeginPage; override;
+    procedure OnEndPage; override;
+    procedure OnData(x, y: Integer; View: TfrView); override;
+    procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override;
+  end;
+
+implementation
+
+{ TfrDBGExport }
+
+constructor TfrDBGExport.Create(aOwner: TComponent);
+begin
+  inherited Create(aOwner);
+  frRegisterExportFilter(TfrDBGExportFilter, 'Debug Export Filter (*.dbg)', '*.dbg');
+end;
+
+{ TfrDBGExportFilter }
+
+constructor TfrDBGExportFilter.Create(AStream: TStream);
+begin
+  inherited Create(AStream);
+  WriteLn('DebugExportFilter: Created');
+end;
+
+destructor TfrDBGExportFilter.Destroy;
+begin
+  inherited Destroy;
+  WriteLn('DebugExportFilter: Destroyed');
+end;
+
+procedure TfrDBGExportFilter.OnBeginPage;
+begin
+  WriteLn(' DebugExportFilter: OnBeginPage');
+end;
+
+procedure TfrDBGExportFilter.OnEndPage;
+begin
+  WriteLn(' DebugExportFilter: OnEndPage');
+end;
+
+function TypToStr(Typ:Integer):string;
+begin
+  case Typ of
+    gtMemo                   : result := 'gtMemo';
+    gtPicture                : result := 'gtPicture';
+    gtBand                   : result := 'gtBand';
+    gtSubReport              : result := 'gtSubReport';
+    gtLine                   : result := 'gtLine';
+    gtAddIn                  : result := 'gtAddIn';
+    else                       result := 'gt?????????';
+  end;
+end;
+function BandToStr(Bt: TfrBandType): string;
+begin
+  case bt of
+    btReportTitle       : result := 'btReportTitle';
+    btReportSummary     : result := 'btReportSummary';
+    btPageHeader        : result := 'btPageHeader';
+    btPageFooter        : result := 'btPageFooter';
+    btMasterHeader      : result := 'btMasterHeader';
+    btMasterData        : result := 'btMasterData';
+    btMasterFooter      : result := 'btMasterFooter';
+    btDetailHeader      : result := 'btDetailHeader';
+    btDetailData        : result := 'btDetailData';
+    btDetailFooter      : result := 'btDetailFooter';
+    btSubDetailHeader   : result := 'btSubDetailHeader';
+    btSubDetailData     : result := 'btSubDetailData';
+    btSubDetailFooter   : result := 'btSubDetailFooter';
+    btOverlay           : result := 'btOverlay';
+    btColumnHeader      : result := 'btColumnHeader';
+    btColumnFooter      : result := 'btColumnFooter';
+    btGroupHeader       : result := 'btGroupHeader';
+    btGroupFooter       : result := 'btGroupFooter';
+    btCrossHeader       : result := 'btCrossHeader';
+    btCrossData         : result := 'btCrossData';
+    btCrossFooter       : result := 'btCrossFooter';
+    btNone              : result := 'btNone';
+  else
+    result := 'Band?????';
+  end;
+
+end;
+
+procedure TfrDBGExportFilter.OnData(x, y: Integer; View: TfrView);
+begin
+  Write('   OnData [');
+  if View.Flags and flStartRecord <>0 then Write(' StartRecord');
+  if View.Flags and flEndRecord <>0 then Write(' EndRecord');
+  Write('] X=',x,' Y=',Y,' View=',View.Name,':',View.ClassName,' Typ=',TypToStr(View.Typ));
+  Write(' ParentBand=',BandToStr(View.ParentBandType));
+  Writeln(' Memo=',dbgstr(View.Memo.Text));
+end;
+
+procedure TfrDBGExportFilter.OnText(X, Y: Integer; const Text: String;
+  View: TfrView);
+begin
+  writeLn('     OnText X=',X,' Y=',Y,' View=',View.Name,':',View.ClassName,' text=',dbgstr(Text));
+end;
+
+end.
+

components/lazreport/source/lr_e_txt.pas

@@ -28,12 +28,21 @@ type
     Constructor Create(aOwner : TComponent); override;
   end;
 
+  { TfrTextExportFilter }
+
   TfrTextExportFilter = class(TfrExportFilter)
+  private
+    FUsedFont: Integer;
+  protected
+    procedure GetUsedFont; virtual;
+    procedure Setup; override;
   public
     constructor Create(AStream: TStream); override;
     procedure OnEndPage; override;
     procedure OnBeginPage; override;
     procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override;
+
+    property UsedFont: integer read FUsedFont write FUsedFont;
   end;
 
 
@@ -42,17 +51,28 @@ implementation
 uses LR_Utils, LR_Const;
 
 
-var
-  UsedFont: Integer = 16;
-
-constructor TfrTextExportFilter.Create(AStream: TStream);
+procedure TfrTextExportFilter.GetUsedFont;
 var
   s: String;
   n: Integer;
+begin
+  s := InputBox(sFilter, sFilterParam, '10');
+  Val(s, FUsedFont, n);
+  if n<>0 then
+    FUsedFont := 10;
+end;
+
+procedure TfrTextExportFilter.Setup;
+begin
+  inherited Setup;
+  if FUsedFont<=0 then
+    GetUsedFont;
+end;
+
+constructor TfrTextExportFilter.Create(AStream: TStream);
 begin
   inherited;
-  s := InputBox(sFilter, sFilterParam, '16');
-  Val(s, UsedFont, n);
+  FUsedFont := 10;
 end;
 
 procedure TfrTextExportFilter.OnEndPage;

components/lazreport/source/lr_utils.pas

@@ -59,6 +59,7 @@ function UTF8Char(S:string; index:Integer; Desc:string): TUTF8Char;
 function UTF8Range(S:string; index,count:Integer; Desc:String):string;
 function UTF8Index(S:string; index:integer; desc:string): Integer;
 function UTF8CharIn(ch:TUTF8Char; const arrstr:array of string): boolean;
+function UTF8QuotedStr(s:string; Quote: TUTF8Char; desc:string=''): string;
 
 implementation
 
@@ -628,4 +629,30 @@ begin
     end;
 end;
 
+// converted from FPC AnsiQuotedStr()
+function UTF8QuotedStr(s: string; Quote: TUTF8Char; desc:string=''): string;
+var
+    i, j, count: integer;
+begin
+  result := '' + Quote;
+  if desc='' then
+    count := UTF8Desc(s, desc)
+  else
+    count := length(s);
+
+  i := 0;
+  j := 0;
+  while i < count do begin
+    i := i + 1;
+    if UTF8Char(s,i,desc) = Quote then begin
+      result := result + UTF8Range(S, 1 + j, i - j, desc) + Quote;
+      j := i;
+    end;
+  end;
+
+  if i <> j then
+    result := result + UTF8Range(S, 1 + j, i - j, desc);
+  result := result + Quote;
+end ;
+
 end.