trunk/runtime/IBDataOutput.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2017 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBDataOutput;

{$mode objfpc}{$H+}
{$codepage UTF8}

(*
     These are helper components, primarily for use with TIBXScript, but which are
     also used by TIBExtact (for formatting data as SQL Insert statements). Their
     purpose is to execute SQL SELECT statements and to format the results of the
     query. Data Output Formatters are currently available for:

     Block Format Output        (TIBBlockFormatOut)
     CSV Format                 (TIBCSVDataOut)
     SQL Insert Statements      (TIBInsertStmtsOut).
  *)
interface

uses
  Classes, SysUtils, IBSQL, IBDatabase, IB;

const
  MaxBlobText = 80;

  sTimeStampFormat = 'yyyy.mm.dd hh:nn:ss.zzz';
  sDateFormat      = 'yyyy.mm.dd';
  sTimeFormat      =  'hh:nn:ss.zzz';

type
  TPlanOptions = (poNoPlan,poIncludePlan, poPlanOnly);

  TAdd2Log = procedure(const Msg: string; IsError: boolean=true) of object;

  { TIBCustomDataOutput }

  TIBCustomDataOutput = class(TComponent)
  private
    FIBSQL: TIBSQL;
    FIncludeHeader: Boolean;
    FPlanOptions: TPlanOptions;
    FRowCount: integer;
    FShowPerformanceStats: boolean;
    function GetDatabase: TIBDatabase;
    function GetTransaction: TIBTransaction;
    procedure SetDatabase(AValue: TIBDatabase);
    procedure SetTransaction(AValue: TIBTransaction);
  protected
    procedure HeaderOut(Add2Log: TAdd2Log); virtual;
    procedure FormattedDataOut(Add2Log: TAdd2Log); virtual; abstract;
    procedure TrailerOut(Add2Log: TAdd2Log); virtual;
    property IncludeHeader: Boolean read FIncludeHeader write FIncludeHeader default true;
  public
    constructor Create(aOwner: TComponent); override;
    procedure Assign(Source: TPersistent); override;
    function DataOut(SelectQuery: string; Add2Log: TAdd2Log): boolean;
    procedure SetCommand(command, aValue, stmt: string; var Done: boolean); virtual;
    class procedure ShowPerfStats(Statement: IStatement; Add2Log: TAdd2Log);
  published
    property Database: TIBDatabase read GetDatabase write SetDatabase;
    property Transaction: TIBTransaction read GetTransaction write SetTransaction;
    property PlanOptions: TPlanOptions read FPlanOptions write FPlanOptions;
    property RowCount: integer read FRowCount write FRowCount;
    property ShowPerformanceStats: boolean read FShowPerformanceStats write FShowPerformanceStats;
 end;

  TDataOutputFormatter = class of TIBCustomDataOutput;

  { TIBCSVDataOut }

  TIBCSVDataOut = class(TIBCustomDataOutput)
  private
    FQuoteChar: char;
  protected
    procedure HeaderOut(Add2Log: TAdd2Log); override;
    procedure FormattedDataOut(Add2Log: TAdd2Log); override;
  public
    constructor Create(aOwner: TComponent); override;
  published
    property IncludeHeader;
    property QuoteChar: char read FQuoteChar write FQuoteChar default '''';
  end;

  { TIBInsertStmtsOut }

  TIBInsertStmtsOut = class(TIBCustomDataOutput)
  private
    FIncludeBlobsAndArrays: boolean;
    FInsertHeader: string;
  protected
    procedure HeaderOut(Add2Log: TAdd2Log); override;
    procedure FormattedDataOut(Add2Log: TAdd2Log); override;
  public
    constructor Create(aOwner: TComponent); override;
  published
    property IncludeBlobsAndArrays: boolean read FIncludeBlobsAndArrays
                                    write FIncludeBlobsAndArrays default true;
  end;

  TAlignments = (taLeft, taCentre, taRight);

  { TIBBlockFormatOut }

  TIBBlockFormatOut = class(TIBCustomDataOutput)
  private
    FColWidths: array of integer;
    FRowWidth: integer;
    function DashedLine: string;
    function TextAlign(s: string; ColWidth: integer; alignment: TAlignments
      ): string;
  protected
    procedure HeaderOut(Add2Log: TAdd2Log); override;
    procedure FormattedDataOut(Add2Log: TAdd2Log); override;
    procedure TrailerOut(Add2Log: TAdd2Log); override;
  published
    property IncludeHeader;
  end;

implementation

uses IBUtils, FBMessages, Math, IBXScript;

{ TIBBlockFormatOut }

function TIBBlockFormatOut.DashedLine: string;
var i: integer;
begin
  Setlength(Result,FRowWidth);
  for i := 1 to FRowWidth do
    Result[i] := '-';
end;

function TIBBlockFormatOut.TextAlign(s: string; ColWidth: integer;
  alignment: TAlignments): string;
begin
  SetLength(Result,ColWidth);
  FillChar(Result[1],ColWidth,' ');
  if Length(s) > ColWidth then
    s := LeftStr(s,ColWidth);
  case alignment of
  taLeft:
    Move(s[1],Result[1],Length(s));
  taCentre:
    Move(s[1],Result[(ColWidth - Length(s)) div 2 + 1],Length(s));
  taRight:
    Move(s[1],Result[ColWidth - Length(s) + 1],Length(s));
  end;
end;

procedure TIBBlockFormatOut.HeaderOut(Add2Log: TAdd2Log);
var i: integer;
    s: string;
begin
  with FIBSQL do
  begin
    {Calculate column Widths}
    SetLength(FColWidths,MetaData.Count);
    FRowWidth := 1; {assume leading '|'}
    for i := 0 to MetaData.Count - 1 do
    with MetaData[i] do
    begin
      case SQLType of
      SQL_VARYING, SQL_TEXT:
        FColWidths[i] := GetSize;

      SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
        FColWidths[i] := 18; {see http://www.freepascal.org/docs-html/rtl/sysutils/formatfloat.html}

      SQL_LONG:
        if Scale = 0 then
          FColWidths[i] := 12 {allow for minus sign}
        else
          FColWidths[i] := 13; {leave room for the decimal point}

      SQL_SHORT:
        if Scale = 0 then
          FColWidths[i] := 6 {allow for minus sign}
        else
          FColWidths[i] := 7; {leave room for the decimal point}

      SQL_INT64:
        if Scale = 0 then
          FColWidths[i] := 20 {allow for minus sign}
        else
          FColWidths[i] := 21; {leave room for the decimal point}

      SQL_TIMESTAMP:
        FColWidths[i] := 23;

      SQL_TYPE_DATE:
        FColWidths[i] := 10;

      SQL_TYPE_TIME:
        FColWidths[i] := 12;

      SQL_BLOB:
        if SQLSubType = 1 then
          FColWidths[i] := MaxBlobText
        else
          FColWidths[i] := length(SBlob);

      SQL_ARRAY:
        FColWidths[i] := length(SArray);

      SQL_BOOLEAN:
        FColWidths[i] := Max(Length(STrue),Length(SFalse));
      end;
      if FColWidths[i] < Length(Name) then
        FColWidths[i] := Length(Name);
      FRowWidth += FColWidths[i] + 1;
    end;

    {Now output the header}

    Add2Log(DashedLine);
    s := '|';
    for i := 0 to MetaData.Count - 1 do
      s += TextAlign(MetaData[i].Name,FColWidths[i],taCentre) + '|';
    Add2Log(s);
    Add2Log(DashedLine);
  end;
end;

procedure TIBBlockFormatOut.FormattedDataOut(Add2Log: TAdd2Log);

  function TruncateTextBlob(textStr: string): string;
  begin
    if Length(textStr) > MaxBlobText then
      Result := LeftStr(textStr,MaxBlobText-3) + '...'
    else
      Result := textStr;
  end;

var i: integer;
    s: string;
begin
  s := '|';
  for i := 0 to FIBSQL.Current.Count - 1 do
  with FIBSQL.Current[i] do
  begin
    if IsNull then
      s += TextAlign('NULL',FColWidths[i],taCentre)
    else
    case SQLType of
    SQL_VARYING, SQL_TEXT:
      s += TextAlign(AsString,FColWidths[i],taLeft);

    SQL_TIMESTAMP:
      s += TextAlign(FormatDateTime(sTimeStampFormat,AsDateTime),FColWidths[i],taLeft);

    SQL_TYPE_DATE:
      s += TextAlign(FormatDateTime(sDateFormat,AsDateTime),FColWidths[i],taLeft);

    SQL_TYPE_TIME:
      s += TextAlign(FormatDateTime(sTimeFormat,AsDateTime),FColWidths[i],taLeft);

    SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT,
    SQL_LONG, SQL_SHORT, SQL_INT64:
      s += TextAlign(AsString,FColWidths[i],taRight);

    SQL_BOOLEAN, SQL_ARRAY:
      s += TextAlign(AsString,FColWidths[i],taCentre);

    SQL_BLOB:
      if SQLSubType = 1 then
        s += TextAlign(TruncateTextBlob(AsString),FColWidths[i],taLeft)
      else
        s += TextAlign(sBlob,FColWidths[i],taCentre);
    end;
    s += '|';
  end;
  Add2Log(s);
  Add2Log(DashedLine);
end;

procedure TIBBlockFormatOut.TrailerOut(Add2Log: TAdd2Log);
begin
  Add2Log(DashedLine);
end;

{ TIBInsertStmtsOut }

procedure TIBInsertStmtsOut.HeaderOut(Add2Log: TAdd2Log);
var TableName: string;
    i,j: integer;
begin
  TableName := trim(FIBSQL.GetUniqueRelationName);
  if TableName = '' then
    IBError(ibxeUniqueRelationReqd,[nil]);

  Add2Log('');
  Add2Log('/* Inserting data into Table: ' + TableName + ' */');
  Add2Log('');

  FInsertHeader := 'INSERT INTO ' + QuoteIdentifier(Database.SQLDialect, TableName) + ' (';
  with FIBSQL do
  begin
    j := 0;
    for i := 0 to MetaData.Count - 1 do
    if IncludeBlobsAndArrays or
       ((MetaData[i].SQLTYPE <> SQL_BLOB) and (MetaData[i].SQLType <> SQL_ARRAY)) then
    begin
      if j <> 0 then FInsertHeader += ',';
      FInsertHeader += QuoteIdentifierIfNeeded(Database.SQLDialect,Trim(MetaData[i].getAliasName));
      Inc(j);
    end;
  end;
  FInsertHeader += ') VALUES(';
end;

procedure TIBInsertStmtsOut.FormattedDataOut(Add2Log: TAdd2Log);
const
  QuoteChar = '''';

var s: string;
    i, j: integer;
    ar: IArray;
begin
  s := FInsertHeader;
  with FIBSQL do
  begin
    j := 0;
    for i := 0 to Current.Count - 1 do
    if IncludeBlobsAndArrays or
       ((Current[i].SQLTYPE <> SQL_BLOB) and (Current[i].SQLType <> SQL_ARRAY)) then
    begin
      if j <> 0 then s += ',';
      if Current[i].IsNull then
        s += 'NULL'
      else
      case Current[i].SQLType of
      SQL_BLOB:
        if Current[i].SQLSubType = 1 then
        begin
          if Current[i].getCharSetID = 1 {octets} then
            s += Format('x''%s''',[StringToHex(Current[i].AsString)])
          else
            s += QuoteChar + SQLSafeString(Current[i].AsString) + QuoteChar
        end
        else
          s += TIBXMLProcessor.FormatBlob(Current[i]);

      SQL_ARRAY:
        begin
          ar := Current[i].AsArray;
          if ar = nil then
            s += 'NULL'
          else
            s += TIBXMLProcessor.FormatArray(Database,ar);
        end;

      SQL_TEXT, SQL_VARYING:
        if Current[i].getCharSetID = 1 {octets} then
          s += Format('x''%s''',[StringToHex(Current[i].AsString)])
        else
          s += QuoteChar + SQLSafeString(Current[i].AsString) + QuoteChar;

      SQL_TIMESTAMP:
        s += QuoteChar + FormatDateTime(sTimeStampFormat,Current[i].AsDateTime) + QuoteChar;

      SQL_TYPE_DATE:
        s += QuoteChar + FormatDateTime(sDateFormat,Current[i].AsDateTime) + QuoteChar;

      SQL_TYPE_TIME:
        s += QuoteChar + FormatDateTime(sTimeFormat,Current[i].AsDateTime) + QuoteChar;

      else
        s += Current[i].AsString;
      end;
      Inc(j);
    end;
  end;
  s += ');';
  Add2Log(s);
end;

constructor TIBInsertStmtsOut.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FIncludeBlobsAndArrays := true;
end;

{ TIBCSVDataOut }

procedure TIBCSVDataOut.HeaderOut(Add2Log: TAdd2Log);
var i: integer;
    s: string;
begin
  s := '';
  for i := 0 to FIBSQL.MetaData.Count - 1 do
  begin
    if i <> 0 then s += ',';
    s += FIBSQL.MetaData[i].getAliasName;
  end;
  Add2Log(s);
end;

procedure TIBCSVDataOut.FormattedDataOut(Add2Log: TAdd2Log);
var i: integer;
    s: string;
begin
  s := '';
  with FIBSQL do
  begin
    for i := 0 to Current.Count - 1 do
    with Current[i] do
    begin
      if i <> 0 then s += ',';
      case SQLType of
      SQL_BLOB:
        if SQLSubType <> 1 then
          s += sBlob
        else
          s += QuoteChar + Current[i].AsString + QuoteChar;

      SQL_VARYING,SQL_TEXT,
      SQL_TIMESTAMP,SQL_TYPE_DATE,SQL_TYPE_TIME:
        s += QuoteChar + Current[i].AsString + QuoteChar;

      else
        s += Current[i].AsString;
      end;
    end;
  end;
  Add2Log(s);
end;

constructor TIBCSVDataOut.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FQuoteChar := '''';
end;

{ TIBCustomDataOutput }

function TIBCustomDataOutput.GetDatabase: TIBDatabase;
begin
  Result := FIBSQL.Database;
end;

function TIBCustomDataOutput.GetTransaction: TIBTransaction;
begin
  Result := FIBSQL.Transaction;
end;

procedure TIBCustomDataOutput.SetDatabase(AValue: TIBDatabase);
begin
  FIBSQL.Database := AValue;
end;

procedure TIBCustomDataOutput.SetTransaction(AValue: TIBTransaction);
begin
  FIBSQL.Transaction := AValue;
end;

procedure TIBCustomDataOutput.HeaderOut(Add2Log: TAdd2Log);
begin
  //stub
end;

procedure TIBCustomDataOutput.TrailerOut(Add2Log: TAdd2Log);
begin
  //stub
end;

constructor TIBCustomDataOutput.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FIBSQL := TIBSQL.Create(self);
  FIncludeHeader := true;
end;

procedure TIBCustomDataOutput.Assign(Source: TPersistent);
begin
  if Source is TIBCustomDataOutput then
  begin
    IncludeHeader := TIBCustomDataOutput(Source).IncludeHeader;
    RowCount := TIBCustomDataOutput(Source).RowCount;
    ShowPerformanceStats := TIBCustomDataOutput(Source).ShowPerformanceStats;
    PlanOptions := TIBCustomDataOutput(Source).PlanOptions;
  end;
end;

function TIBCustomDataOutput.DataOut(SelectQuery: string; Add2Log: TAdd2Log
  ): boolean;
var Count: integer;
begin
  FIBSQL.SQL.Text := SelectQuery;
  FIBSQL.Prepare;
  FIBSQL.Statement.EnableStatistics(ShowPerformanceStats);
  if PlanOptions <> poNoPlan then
    Add2Log(FIBSQL.Plan);
  if PlanOptions = poPlanOnly then
    Exit;

  Count := 0;
  FIBSQL.ExecQuery;
  try
    if IncludeHeader and not FIBSQL.EOF then
      HeaderOut(Add2Log);
    while (not FIBSQL.EOF) and ((FRowCount = 0) or (Count < FRowCount)) do
    begin
      FormattedDataOut(Add2Log);
      FIBSQL.Next;
      Inc(Count);
    end;
    ShowPerfStats(FIBSQL.Statement,Add2Log);
  finally
    FIBSQL.Close;
  end;
  Result := Count > 0;
end;

procedure TIBCustomDataOutput.SetCommand(command, aValue, stmt: string;
  var Done: boolean);

  function Toggle(aValue: string): boolean;
  begin
    aValue := AnsiUpperCase(aValue);
    if aValue = 'ON' then
      Result := true
    else
    if aValue = 'OFF' then
      Result := false
    else
      raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
  end;

begin
  done := true;
  if command = 'HEADING' then
    FIncludeHeader := ((aValue = '') and not FIncludeHeader) or
                      ((aValue <> '') and Toggle(aValue))
  else
  if command = 'ROWCOUNT' then
    FRowCount := StrToInt(aValue)
  else
  if command = 'PLAN' then
  begin
    if aValue = '' then
    begin
      if FPlanOptions <>  poIncludePlan then
        FPlanOptions := poIncludePlan
      else
        FPlanOptions := poNoPlan;
    end
    else
    if Toggle(aValue) then
      FPlanOptions := poIncludePlan
    else
      FPlanOptions := poNoPlan;
  end
  else
  if command = 'PLANONLY' then
  begin
    if aValue = '' then
    begin
      if FPlanOptions <>  poPlanOnly then
        FPlanOptions := poPlanOnly
      else
        FPlanOptions := poNoPlan;
    end
    else
    if Toggle(aValue) then
      FPlanOptions := poPlanOnly
    else
    if FPlanOptions <> poIncludePlan then
      FPlanOptions := poNoPlan;
  end
  else
    done := false;
end;

class procedure TIBCustomDataOutput.ShowPerfStats(Statement: IStatement;
  Add2Log: TAdd2Log);
var stats: TPerfCounters;
begin
  if Statement.GetPerfStatistics(stats) then
  begin
    Add2Log(Format('Current memory = %f',[stats[psCurrentMemory]]));
    Add2Log(Format('Delta memory = %f',[stats[psDeltaMemory]]));
    Add2Log(Format('Max memory = %f',[stats[psMaxMemory]]));
    Add2Log('Elapsed time= ' + FormatFloat('#0.000',stats[psRealTime]/1000) +' sec');
    Add2Log('Cpu = ' + FormatFloat('#0.000',stats[psUserTime]/1000) + ' sec');
    Add2Log(Format('Buffers = %f',[stats[psBuffers]]));
    Add2Log(Format('Reads = %f',[stats[psReads]]));
    Add2Log(Format('Writes = %f',[stats[psWrites]]));
    Add2Log(Format('Fetches = %f',[stats[psFetches]]));
 end;
end;

end.

Revision:	80
Committed:	Mon Jan 1 11:31:07 2018 UTC (6 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	16466 byte(s)
Log Message:	Fixes merged into public release
#	User	Rev	Content
1	tony	47	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2017 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26			unit IBDataOutput;
27
28			{$mode objfpc}{$H+}
29			{$codepage UTF8}
30
31			(*
32			These are helper components, primarily for use with TIBXScript, but which are
33			also used by TIBExtact (for formatting data as SQL Insert statements). Their
34			purpose is to execute SQL SELECT statements and to format the results of the
35			query. Data Output Formatters are currently available for:
36
37			Block Format Output (TIBBlockFormatOut)
38			CSV Format (TIBCSVDataOut)
39			SQL Insert Statements (TIBInsertStmtsOut).
40			*)
41			interface
42
43			uses
44			Classes, SysUtils, IBSQL, IBDatabase, IB;
45
46			const
47			MaxBlobText = 80;
48
49			sTimeStampFormat = 'yyyy.mm.dd hh:nn:ss.zzz';
50			sDateFormat = 'yyyy.mm.dd';
51			sTimeFormat = 'hh:nn:ss.zzz';
52
53			type
54			TPlanOptions = (poNoPlan,poIncludePlan, poPlanOnly);
55
56			TAdd2Log = procedure(const Msg: string; IsError: boolean=true) of object;
57
58			{ TIBCustomDataOutput }
59
60			TIBCustomDataOutput = class(TComponent)
61			private
62			FIBSQL: TIBSQL;
63			FIncludeHeader: Boolean;
64			FPlanOptions: TPlanOptions;
65			FRowCount: integer;
66			FShowPerformanceStats: boolean;
67			function GetDatabase: TIBDatabase;
68			function GetTransaction: TIBTransaction;
69			procedure SetDatabase(AValue: TIBDatabase);
70			procedure SetTransaction(AValue: TIBTransaction);
71			protected
72			procedure HeaderOut(Add2Log: TAdd2Log); virtual;
73			procedure FormattedDataOut(Add2Log: TAdd2Log); virtual; abstract;
74			procedure TrailerOut(Add2Log: TAdd2Log); virtual;
75			property IncludeHeader: Boolean read FIncludeHeader write FIncludeHeader default true;
76			public
77			constructor Create(aOwner: TComponent); override;
78			procedure Assign(Source: TPersistent); override;
79	tony	49	function DataOut(SelectQuery: string; Add2Log: TAdd2Log): boolean;
80	tony	47	procedure SetCommand(command, aValue, stmt: string; var Done: boolean); virtual;
81			class procedure ShowPerfStats(Statement: IStatement; Add2Log: TAdd2Log);
82			published
83			property Database: TIBDatabase read GetDatabase write SetDatabase;
84			property Transaction: TIBTransaction read GetTransaction write SetTransaction;
85			property PlanOptions: TPlanOptions read FPlanOptions write FPlanOptions;
86			property RowCount: integer read FRowCount write FRowCount;
87			property ShowPerformanceStats: boolean read FShowPerformanceStats write FShowPerformanceStats;
88			end;
89
90			TDataOutputFormatter = class of TIBCustomDataOutput;
91
92			{ TIBCSVDataOut }
93
94			TIBCSVDataOut = class(TIBCustomDataOutput)
95			private
96			FQuoteChar: char;
97			protected
98			procedure HeaderOut(Add2Log: TAdd2Log); override;
99			procedure FormattedDataOut(Add2Log: TAdd2Log); override;
100			public
101			constructor Create(aOwner: TComponent); override;
102			published
103			property IncludeHeader;
104			property QuoteChar: char read FQuoteChar write FQuoteChar default '''';
105			end;
106
107			{ TIBInsertStmtsOut }
108
109			TIBInsertStmtsOut = class(TIBCustomDataOutput)
110			private
111			FIncludeBlobsAndArrays: boolean;
112			FInsertHeader: string;
113			protected
114			procedure HeaderOut(Add2Log: TAdd2Log); override;
115			procedure FormattedDataOut(Add2Log: TAdd2Log); override;
116			public
117			constructor Create(aOwner: TComponent); override;
118			published
119			property IncludeBlobsAndArrays: boolean read FIncludeBlobsAndArrays
120			write FIncludeBlobsAndArrays default true;
121			end;
122
123			TAlignments = (taLeft, taCentre, taRight);
124
125			{ TIBBlockFormatOut }
126
127			TIBBlockFormatOut = class(TIBCustomDataOutput)
128			private
129			FColWidths: array of integer;
130			FRowWidth: integer;
131			function DashedLine: string;
132			function TextAlign(s: string; ColWidth: integer; alignment: TAlignments
133			): string;
134			protected
135			procedure HeaderOut(Add2Log: TAdd2Log); override;
136			procedure FormattedDataOut(Add2Log: TAdd2Log); override;
137			procedure TrailerOut(Add2Log: TAdd2Log); override;
138			published
139			property IncludeHeader;
140			end;
141
142			implementation
143
144			uses IBUtils, FBMessages, Math, IBXScript;
145
146			{ TIBBlockFormatOut }
147
148			function TIBBlockFormatOut.DashedLine: string;
149			var i: integer;
150			begin
151			Setlength(Result,FRowWidth);
152			for i := 1 to FRowWidth do
153			Result[i] := '-';
154			end;
155
156			function TIBBlockFormatOut.TextAlign(s: string; ColWidth: integer;
157			alignment: TAlignments): string;
158			begin
159			SetLength(Result,ColWidth);
160			FillChar(Result[1],ColWidth,' ');
161			if Length(s) > ColWidth then
162			s := LeftStr(s,ColWidth);
163			case alignment of
164			taLeft:
165			Move(s[1],Result[1],Length(s));
166			taCentre:
167			Move(s[1],Result[(ColWidth - Length(s)) div 2 + 1],Length(s));
168			taRight:
169			Move(s[1],Result[ColWidth - Length(s) + 1],Length(s));
170			end;
171			end;
172
173			procedure TIBBlockFormatOut.HeaderOut(Add2Log: TAdd2Log);
174			var i: integer;
175			s: string;
176			begin
177			with FIBSQL do
178			begin
179			{Calculate column Widths}
180			SetLength(FColWidths,MetaData.Count);
181			FRowWidth := 1; {assume leading '\|'}
182			for i := 0 to MetaData.Count - 1 do
183			with MetaData[i] do
184			begin
185			case SQLType of
186			SQL_VARYING, SQL_TEXT:
187			FColWidths[i] := GetSize;
188
189			SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT:
190			FColWidths[i] := 18; {see http://www.freepascal.org/docs-html/rtl/sysutils/formatfloat.html}
191
192			SQL_LONG:
193			if Scale = 0 then
194			FColWidths[i] := 12 {allow for minus sign}
195			else
196			FColWidths[i] := 13; {leave room for the decimal point}
197
198			SQL_SHORT:
199			if Scale = 0 then
200			FColWidths[i] := 6 {allow for minus sign}
201			else
202			FColWidths[i] := 7; {leave room for the decimal point}
203
204			SQL_INT64:
205			if Scale = 0 then
206			FColWidths[i] := 20 {allow for minus sign}
207			else
208			FColWidths[i] := 21; {leave room for the decimal point}
209
210			SQL_TIMESTAMP:
211			FColWidths[i] := 23;
212
213			SQL_TYPE_DATE:
214			FColWidths[i] := 10;
215
216			SQL_TYPE_TIME:
217			FColWidths[i] := 12;
218
219			SQL_BLOB:
220			if SQLSubType = 1 then
221			FColWidths[i] := MaxBlobText
222			else
223			FColWidths[i] := length(SBlob);
224
225			SQL_ARRAY:
226			FColWidths[i] := length(SArray);
227
228			SQL_BOOLEAN:
229			FColWidths[i] := Max(Length(STrue),Length(SFalse));
230			end;
231			if FColWidths[i] < Length(Name) then
232			FColWidths[i] := Length(Name);
233			FRowWidth += FColWidths[i] + 1;
234			end;
235
236			{Now output the header}
237
238			Add2Log(DashedLine);
239			s := '\|';
240			for i := 0 to MetaData.Count - 1 do
241			s += TextAlign(MetaData[i].Name,FColWidths[i],taCentre) + '\|';
242			Add2Log(s);
243			Add2Log(DashedLine);
244			end;
245			end;
246
247			procedure TIBBlockFormatOut.FormattedDataOut(Add2Log: TAdd2Log);
248
249			function TruncateTextBlob(textStr: string): string;
250			begin
251			if Length(textStr) > MaxBlobText then
252			Result := LeftStr(textStr,MaxBlobText-3) + '...'
253			else
254			Result := textStr;
255			end;
256
257			var i: integer;
258			s: string;
259			begin
260			s := '\|';
261			for i := 0 to FIBSQL.Current.Count - 1 do
262			with FIBSQL.Current[i] do
263			begin
264			if IsNull then
265			s += TextAlign('NULL',FColWidths[i],taCentre)
266			else
267			case SQLType of
268			SQL_VARYING, SQL_TEXT:
269			s += TextAlign(AsString,FColWidths[i],taLeft);
270
271			SQL_TIMESTAMP:
272			s += TextAlign(FormatDateTime(sTimeStampFormat,AsDateTime),FColWidths[i],taLeft);
273
274			SQL_TYPE_DATE:
275			s += TextAlign(FormatDateTime(sDateFormat,AsDateTime),FColWidths[i],taLeft);
276
277			SQL_TYPE_TIME:
278			s += TextAlign(FormatDateTime(sTimeFormat,AsDateTime),FColWidths[i],taLeft);
279
280			SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT,
281			SQL_LONG, SQL_SHORT, SQL_INT64:
282			s += TextAlign(AsString,FColWidths[i],taRight);
283
284			SQL_BOOLEAN, SQL_ARRAY:
285			s += TextAlign(AsString,FColWidths[i],taCentre);
286
287			SQL_BLOB:
288			if SQLSubType = 1 then
289			s += TextAlign(TruncateTextBlob(AsString),FColWidths[i],taLeft)
290			else
291			s += TextAlign(sBlob,FColWidths[i],taCentre);
292			end;
293			s += '\|';
294			end;
295			Add2Log(s);
296			Add2Log(DashedLine);
297			end;
298
299			procedure TIBBlockFormatOut.TrailerOut(Add2Log: TAdd2Log);
300			begin
301			Add2Log(DashedLine);
302			end;
303
304			{ TIBInsertStmtsOut }
305
306			procedure TIBInsertStmtsOut.HeaderOut(Add2Log: TAdd2Log);
307			var TableName: string;
308			i,j: integer;
309			begin
310			TableName := trim(FIBSQL.GetUniqueRelationName);
311			if TableName = '' then
312			IBError(ibxeUniqueRelationReqd,[nil]);
313
314			Add2Log('');
315			Add2Log('/* Inserting data into Table: ' + TableName + ' */');
316			Add2Log('');
317
318			FInsertHeader := 'INSERT INTO ' + QuoteIdentifier(Database.SQLDialect, TableName) + ' (';
319			with FIBSQL do
320			begin
321			j := 0;
322			for i := 0 to MetaData.Count - 1 do
323			if IncludeBlobsAndArrays or
324			((MetaData[i].SQLTYPE <> SQL_BLOB) and (MetaData[i].SQLType <> SQL_ARRAY)) then
325			begin
326			if j <> 0 then FInsertHeader += ',';
327			FInsertHeader += QuoteIdentifierIfNeeded(Database.SQLDialect,Trim(MetaData[i].getAliasName));
328			Inc(j);
329			end;
330			end;
331			FInsertHeader += ') VALUES(';
332			end;
333
334			procedure TIBInsertStmtsOut.FormattedDataOut(Add2Log: TAdd2Log);
335			const
336			QuoteChar = '''';
337
338			var s: string;
339			i, j: integer;
340			ar: IArray;
341			begin
342			s := FInsertHeader;
343			with FIBSQL do
344			begin
345			j := 0;
346			for i := 0 to Current.Count - 1 do
347			if IncludeBlobsAndArrays or
348			((Current[i].SQLTYPE <> SQL_BLOB) and (Current[i].SQLType <> SQL_ARRAY)) then
349			begin
350			if j <> 0 then s += ',';
351			if Current[i].IsNull then
352			s += 'NULL'
353			else
354			case Current[i].SQLType of
355			SQL_BLOB:
356			if Current[i].SQLSubType = 1 then
357			begin
358			if Current[i].getCharSetID = 1 {octets} then
359			s += Format('x''%s''',[StringToHex(Current[i].AsString)])
360			else
361			s += QuoteChar + SQLSafeString(Current[i].AsString) + QuoteChar
362			end
363			else
364			s += TIBXMLProcessor.FormatBlob(Current[i]);
365
366			SQL_ARRAY:
367			begin
368			ar := Current[i].AsArray;
369			if ar = nil then
370			s += 'NULL'
371			else
372	tony	60	s += TIBXMLProcessor.FormatArray(Database,ar);
373	tony	47	end;
374
375			SQL_TEXT, SQL_VARYING:
376			if Current[i].getCharSetID = 1 {octets} then
377			s += Format('x''%s''',[StringToHex(Current[i].AsString)])
378			else
379			s += QuoteChar + SQLSafeString(Current[i].AsString) + QuoteChar;
380
381			SQL_TIMESTAMP:
382			s += QuoteChar + FormatDateTime(sTimeStampFormat,Current[i].AsDateTime) + QuoteChar;
383
384			SQL_TYPE_DATE:
385			s += QuoteChar + FormatDateTime(sDateFormat,Current[i].AsDateTime) + QuoteChar;
386
387			SQL_TYPE_TIME:
388			s += QuoteChar + FormatDateTime(sTimeFormat,Current[i].AsDateTime) + QuoteChar;
389
390			else
391			s += Current[i].AsString;
392			end;
393			Inc(j);
394			end;
395			end;
396			s += ');';
397			Add2Log(s);
398			end;
399
400			constructor TIBInsertStmtsOut.Create(aOwner: TComponent);
401			begin
402			inherited Create(aOwner);
403			FIncludeBlobsAndArrays := true;
404			end;
405
406			{ TIBCSVDataOut }
407
408			procedure TIBCSVDataOut.HeaderOut(Add2Log: TAdd2Log);
409			var i: integer;
410			s: string;
411			begin
412			s := '';
413			for i := 0 to FIBSQL.MetaData.Count - 1 do
414			begin
415			if i <> 0 then s += ',';
416			s += FIBSQL.MetaData[i].getAliasName;
417			end;
418			Add2Log(s);
419			end;
420
421			procedure TIBCSVDataOut.FormattedDataOut(Add2Log: TAdd2Log);
422			var i: integer;
423			s: string;
424			begin
425			s := '';
426			with FIBSQL do
427			begin
428			for i := 0 to Current.Count - 1 do
429			with Current[i] do
430			begin
431			if i <> 0 then s += ',';
432			case SQLType of
433			SQL_BLOB:
434			if SQLSubType <> 1 then
435			s += sBlob
436			else
437			s += QuoteChar + Current[i].AsString + QuoteChar;
438
439			SQL_VARYING,SQL_TEXT,
440			SQL_TIMESTAMP,SQL_TYPE_DATE,SQL_TYPE_TIME:
441			s += QuoteChar + Current[i].AsString + QuoteChar;
442
443			else
444			s += Current[i].AsString;
445			end;
446			end;
447			end;
448			Add2Log(s);
449			end;
450
451			constructor TIBCSVDataOut.Create(aOwner: TComponent);
452			begin
453			inherited Create(aOwner);
454			FQuoteChar := '''';
455			end;
456
457			{ TIBCustomDataOutput }
458
459			function TIBCustomDataOutput.GetDatabase: TIBDatabase;
460			begin
461			Result := FIBSQL.Database;
462			end;
463
464			function TIBCustomDataOutput.GetTransaction: TIBTransaction;
465			begin
466			Result := FIBSQL.Transaction;
467			end;
468
469			procedure TIBCustomDataOutput.SetDatabase(AValue: TIBDatabase);
470			begin
471			FIBSQL.Database := AValue;
472			end;
473
474			procedure TIBCustomDataOutput.SetTransaction(AValue: TIBTransaction);
475			begin
476			FIBSQL.Transaction := AValue;
477			end;
478
479			procedure TIBCustomDataOutput.HeaderOut(Add2Log: TAdd2Log);
480			begin
481			//stub
482			end;
483
484			procedure TIBCustomDataOutput.TrailerOut(Add2Log: TAdd2Log);
485			begin
486			//stub
487			end;
488
489			constructor TIBCustomDataOutput.Create(aOwner: TComponent);
490			begin
491			inherited Create(aOwner);
492			FIBSQL := TIBSQL.Create(self);
493			FIncludeHeader := true;
494			end;
495
496			procedure TIBCustomDataOutput.Assign(Source: TPersistent);
497			begin
498			if Source is TIBCustomDataOutput then
499			begin
500			IncludeHeader := TIBCustomDataOutput(Source).IncludeHeader;
501			RowCount := TIBCustomDataOutput(Source).RowCount;
502			ShowPerformanceStats := TIBCustomDataOutput(Source).ShowPerformanceStats;
503			PlanOptions := TIBCustomDataOutput(Source).PlanOptions;
504			end;
505			end;
506
507	tony	49	function TIBCustomDataOutput.DataOut(SelectQuery: string; Add2Log: TAdd2Log
508			): boolean;
509	tony	47	var Count: integer;
510			begin
511			FIBSQL.SQL.Text := SelectQuery;
512			FIBSQL.Prepare;
513			FIBSQL.Statement.EnableStatistics(ShowPerformanceStats);
514			if PlanOptions <> poNoPlan then
515			Add2Log(FIBSQL.Plan);
516			if PlanOptions = poPlanOnly then
517			Exit;
518
519			Count := 0;
520			FIBSQL.ExecQuery;
521			try
522	tony	49	if IncludeHeader and not FIBSQL.EOF then
523			HeaderOut(Add2Log);
524	tony	47	while (not FIBSQL.EOF) and ((FRowCount = 0) or (Count < FRowCount)) do
525			begin
526			FormattedDataOut(Add2Log);
527			FIBSQL.Next;
528			Inc(Count);
529			end;
530			ShowPerfStats(FIBSQL.Statement,Add2Log);
531			finally
532			FIBSQL.Close;
533			end;
534	tony	49	Result := Count > 0;
535	tony	47	end;
536
537			procedure TIBCustomDataOutput.SetCommand(command, aValue, stmt: string;
538			var Done: boolean);
539
540			function Toggle(aValue: string): boolean;
541			begin
542			aValue := AnsiUpperCase(aValue);
543			if aValue = 'ON' then
544			Result := true
545			else
546			if aValue = 'OFF' then
547			Result := false
548			else
549			raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
550			end;
551
552			begin
553			done := true;
554			if command = 'HEADING' then
555			FIncludeHeader := ((aValue = '') and not FIncludeHeader) or
556			((aValue <> '') and Toggle(aValue))
557			else
558			if command = 'ROWCOUNT' then
559			FRowCount := StrToInt(aValue)
560			else
561			if command = 'PLAN' then
562			begin
563			if aValue = '' then
564			begin
565			if FPlanOptions <> poIncludePlan then
566			FPlanOptions := poIncludePlan
567			else
568			FPlanOptions := poNoPlan;
569			end
570			else
571			if Toggle(aValue) then
572			FPlanOptions := poIncludePlan
573			else
574			FPlanOptions := poNoPlan;
575			end
576			else
577			if command = 'PLANONLY' then
578			begin
579			if aValue = '' then
580			begin
581			if FPlanOptions <> poPlanOnly then
582			FPlanOptions := poPlanOnly
583			else
584			FPlanOptions := poNoPlan;
585			end
586			else
587			if Toggle(aValue) then
588			FPlanOptions := poPlanOnly
589			else
590			if FPlanOptions <> poIncludePlan then
591			FPlanOptions := poNoPlan;
592			end
593			else
594			done := false;
595			end;
596
597			class procedure TIBCustomDataOutput.ShowPerfStats(Statement: IStatement;
598			Add2Log: TAdd2Log);
599			var stats: TPerfCounters;
600			begin
601			if Statement.GetPerfStatistics(stats) then
602			begin
603	tony	80	Add2Log(Format('Current memory = %f',[stats[psCurrentMemory]]));
604			Add2Log(Format('Delta memory = %f',[stats[psDeltaMemory]]));
605			Add2Log(Format('Max memory = %f',[stats[psMaxMemory]]));
606	tony	47	Add2Log('Elapsed time= ' + FormatFloat('#0.000',stats[psRealTime]/1000) +' sec');
607			Add2Log('Cpu = ' + FormatFloat('#0.000',stats[psUserTime]/1000) + ' sec');
608	tony	80	Add2Log(Format('Buffers = %f',[stats[psBuffers]]));
609			Add2Log(Format('Reads = %f',[stats[psReads]]));
610			Add2Log(Format('Writes = %f',[stats[psWrites]]));
611			Add2Log(Format('Fetches = %f',[stats[psFetches]]));
612	tony	47	end;
613			end;
614
615			end.
616