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, 3 months ago) by tony
Content type:	text/x-pascal
File size:	16466 byte(s)
Log Message:	Fixes merged into public release
#	Content
1	(*
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	function DataOut(SelectQuery: string; Add2Log: TAdd2Log): boolean;
80	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	s += TIBXMLProcessor.FormatArray(Database,ar);
373	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	function TIBCustomDataOutput.DataOut(SelectQuery: string; Add2Log: TAdd2Log
508	): boolean;
509	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	if IncludeHeader and not FIBSQL.EOF then
523	HeaderOut(Add2Log);
524	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	Result := Count > 0;
535	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	Add2Log(Format('Current memory = %f',[stats[psCurrentMemory]]));
604	Add2Log(Format('Delta memory = %f',[stats[psDeltaMemory]]));
605	Add2Log(Format('Max memory = %f',[stats[psMaxMemory]]));
606	Add2Log('Elapsed time= ' + FormatFloat('#0.000',stats[psRealTime]/1000) +' sec');
607	Add2Log('Cpu = ' + FormatFloat('#0.000',stats[psUserTime]/1000) + ' sec');
608	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	end;
613	end;
614
615	end.
616