runtime/nongui/IBUpdateSQL.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    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 at http://www.Inprise.com/IPL.html }
{    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 Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011 - 2018                                               }
{                                                                        }
{************************************************************************}

unit IBUpdateSQL;

{$Mode Delphi}

interface

uses SysUtils, Classes, DB, IB, IBCustomDataSet, IBSQL;

type
{ TIBUpdateSQL }

  TIBUpdateSQL = class(TIBDataSetUpdateObject)
  private
    FDataSet: TIBCustomDataSet;
    FLastUpdateKind :TUpdateKind;
    FQueries: array[TUpdateKind] of TIBSQL;
    FSQLText: array[TUpdateKind] of TStrings;
    function GetQuery(UpdateKind: TUpdateKind): TIBSQL;
    function GetSQLIndex(Index: Integer): TStrings;
    procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
    procedure SetSQLIndex(Index: Integer; Value: TStrings);
  protected
    procedure InternalPrepare(UpdateKind: TUpdateKind);
    function GetSQL(UpdateKind: TUpdateKind): TStrings; override;
    function GetDataSet: TIBCustomDataSet; override;
    procedure SetDataSet(ADataSet: TIBCustomDataSet); override;
    procedure SQLChanged(Sender: TObject);
    procedure Apply(UpdateKind: TUpdateKind; buff: PChar); override;
    procedure ExecSQL(UpdateKind: TUpdateKind; buff: PChar);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetRowsAffected(var SelectCount, InsertCount, UpdateCount,
      DeleteCount: integer): boolean; override;
    property DataSet;
    property Query[UpdateKind: TUpdateKind]: TIBSQL read GetQuery;
    property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
  published
    property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
    property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
    property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
  end;

implementation

uses Variants;

{ TIBUpdateSQL }

constructor TIBUpdateSQL.Create(AOwner: TComponent);
var
  UpdateKind: TUpdateKind;
begin
  inherited Create(AOwner);
  for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
  begin
    FSQLText[UpdateKind] := TStringList.Create;
    TStringList(FSQLText[UpdateKind]).OnChange := SQLChanged;
  end;
end;

destructor TIBUpdateSQL.Destroy;
var
  UpdateKind: TUpdateKind;
begin
  if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then
    FDataSet.UpdateObject := nil;
  for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
    FSQLText[UpdateKind].Free;
  inherited Destroy;
end;

function TIBUpdateSQL.GetRowsAffected(var SelectCount, InsertCount,
                                 UpdateCount, DeleteCount: integer): boolean;
begin
  if Query[FLastUpdateKind].Statement <> nil  then
    Result := Query[FLastUpdateKind].Statement.GetRowsAffected(SelectCount, InsertCount,  UpdateCount, DeleteCount)
  else
    Result := inherited;
end;

procedure TIBUpdateSQL.ExecSQL(UpdateKind: TUpdateKind; buff: PChar);
begin
  InternalPrepare(UpdateKind);
  with Query[UpdateKind] do
  begin
    ExecQuery;
//    if RowsAffected <> 1 then IBError(ibxeUpdateFailed, [nil]);
// Commented out in release 1.2
    if FieldCount > 0 then  {Has RETURNING Clause}
      UpdateRecordFromQuery(UpdateKind,Current,Buff);
  end;
end;

function TIBUpdateSQL.GetQuery(UpdateKind: TUpdateKind): TIBSQL;
begin
  if not Assigned(FQueries[UpdateKind]) then
  begin
    FQueries[UpdateKind] := TIBSQL.Create(Self);
    FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
    if (FDataSet is TIBCustomDataSet) then
    begin
      FQueries[UpdateKind].Database := TIBCustomDataSet(FDataSet).DataBase;
      FQueries[UpdateKind].Transaction := TIBCustomDataSet(FDataSet).Transaction;
    end;
  end;
  Result := FQueries[UpdateKind];
end;

function TIBUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings;
begin
  Result := FSQLText[UpdateKind];
end;

function TIBUpdateSQL.GetSQLIndex(Index: Integer): TStrings;
begin
  Result := FSQLText[TUpdateKind(Index)];
end;

function TIBUpdateSQL.GetDataSet: TIBCustomDataSet;
begin
  Result := FDataSet;
end;

procedure TIBUpdateSQL.SetDataSet(ADataSet: TIBCustomDataSet);
begin
  FDataSet := ADataSet;
end;

procedure TIBUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
begin
  FSQLText[UpdateKind].Assign(Value);
end;

procedure TIBUpdateSQL.SetSQLIndex(Index: Integer; Value: TStrings);
begin
  SetSQL(TUpdateKind(Index), Value);
end;

procedure TIBUpdateSQL.InternalPrepare(UpdateKind: TUpdateKind);
begin
  with Query[UpdateKind] do
  begin
    with Transaction do
      if not InTransaction then StartTransaction;
    if not Prepared then Prepare;
  end;
end;

procedure TIBUpdateSQL.SQLChanged(Sender: TObject);
var
  UpdateKind: TUpdateKind;
begin
  for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
    if Sender = FSQLText[UpdateKind] then
    begin
      if Assigned(FQueries[UpdateKind]) then
        FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
      Break;
    end;
end;

procedure TIBUpdateSQL.Apply(UpdateKind: TUpdateKind; buff: PChar);
begin
  if not Assigned(FDataSet) then Exit;
  InternalPrepare(UpdateKind);
  InternalSetParams(Query[UpdateKind].Params,buff);
  ExecSQL(UpdateKind,buff);
  FLastUpdateKind := UpdateKind;
end;

end.
Revision:	362
Committed:	Tue Dec 7 13:27:39 2021 UTC (3 years ago) by tony
Content type:	text/x-pascal
File size:	7399 byte(s)
Log Message:	initiate test release
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 - 2018 }
31	{ }
32	{************************************************************************}
33
34	unit IBUpdateSQL;
35
36	{$Mode Delphi}
37
38	interface
39
40	uses SysUtils, Classes, DB, IB, IBCustomDataSet, IBSQL;
41
42	type
43	{ TIBUpdateSQL }
44
45	TIBUpdateSQL = class(TIBDataSetUpdateObject)
46	private
47	FDataSet: TIBCustomDataSet;
48	FLastUpdateKind :TUpdateKind;
49	FQueries: array[TUpdateKind] of TIBSQL;
50	FSQLText: array[TUpdateKind] of TStrings;
51	function GetQuery(UpdateKind: TUpdateKind): TIBSQL;
52	function GetSQLIndex(Index: Integer): TStrings;
53	procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
54	procedure SetSQLIndex(Index: Integer; Value: TStrings);
55	protected
56	procedure InternalPrepare(UpdateKind: TUpdateKind);
57	function GetSQL(UpdateKind: TUpdateKind): TStrings; override;
58	function GetDataSet: TIBCustomDataSet; override;
59	procedure SetDataSet(ADataSet: TIBCustomDataSet); override;
60	procedure SQLChanged(Sender: TObject);
61	procedure Apply(UpdateKind: TUpdateKind; buff: PChar); override;
62	procedure ExecSQL(UpdateKind: TUpdateKind; buff: PChar);
63	public
64	constructor Create(AOwner: TComponent); override;
65	destructor Destroy; override;
66	function GetRowsAffected(var SelectCount, InsertCount, UpdateCount,
67	DeleteCount: integer): boolean; override;
68	property DataSet;
69	property Query[UpdateKind: TUpdateKind]: TIBSQL read GetQuery;
70	property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL;
71	published
72	property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex;
73	property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex;
74	property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex;
75	end;
76
77	implementation
78
79	uses Variants;
80
81	{ TIBUpdateSQL }
82
83	constructor TIBUpdateSQL.Create(AOwner: TComponent);
84	var
85	UpdateKind: TUpdateKind;
86	begin
87	inherited Create(AOwner);
88	for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
89	begin
90	FSQLText[UpdateKind] := TStringList.Create;
91	TStringList(FSQLText[UpdateKind]).OnChange := SQLChanged;
92	end;
93	end;
94
95	destructor TIBUpdateSQL.Destroy;
96	var
97	UpdateKind: TUpdateKind;
98	begin
99	if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then
100	FDataSet.UpdateObject := nil;
101	for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
102	FSQLText[UpdateKind].Free;
103	inherited Destroy;
104	end;
105
106	function TIBUpdateSQL.GetRowsAffected(var SelectCount, InsertCount,
107	UpdateCount, DeleteCount: integer): boolean;
108	begin
109	if Query[FLastUpdateKind].Statement <> nil then
110	Result := Query[FLastUpdateKind].Statement.GetRowsAffected(SelectCount, InsertCount, UpdateCount, DeleteCount)
111	else
112	Result := inherited;
113	end;
114
115	procedure TIBUpdateSQL.ExecSQL(UpdateKind: TUpdateKind; buff: PChar);
116	begin
117	InternalPrepare(UpdateKind);
118	with Query[UpdateKind] do
119	begin
120	ExecQuery;
121	// if RowsAffected <> 1 then IBError(ibxeUpdateFailed, [nil]);
122	// Commented out in release 1.2
123	if FieldCount > 0 then {Has RETURNING Clause}
124	UpdateRecordFromQuery(UpdateKind,Current,Buff);
125	end;
126	end;
127
128	function TIBUpdateSQL.GetQuery(UpdateKind: TUpdateKind): TIBSQL;
129	begin
130	if not Assigned(FQueries[UpdateKind]) then
131	begin
132	FQueries[UpdateKind] := TIBSQL.Create(Self);
133	FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
134	if (FDataSet is TIBCustomDataSet) then
135	begin
136	FQueries[UpdateKind].Database := TIBCustomDataSet(FDataSet).DataBase;
137	FQueries[UpdateKind].Transaction := TIBCustomDataSet(FDataSet).Transaction;
138	end;
139	end;
140	Result := FQueries[UpdateKind];
141	end;
142
143	function TIBUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings;
144	begin
145	Result := FSQLText[UpdateKind];
146	end;
147
148	function TIBUpdateSQL.GetSQLIndex(Index: Integer): TStrings;
149	begin
150	Result := FSQLText[TUpdateKind(Index)];
151	end;
152
153	function TIBUpdateSQL.GetDataSet: TIBCustomDataSet;
154	begin
155	Result := FDataSet;
156	end;
157
158	procedure TIBUpdateSQL.SetDataSet(ADataSet: TIBCustomDataSet);
159	begin
160	FDataSet := ADataSet;
161	end;
162
163	procedure TIBUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings);
164	begin
165	FSQLText[UpdateKind].Assign(Value);
166	end;
167
168	procedure TIBUpdateSQL.SetSQLIndex(Index: Integer; Value: TStrings);
169	begin
170	SetSQL(TUpdateKind(Index), Value);
171	end;
172
173	procedure TIBUpdateSQL.InternalPrepare(UpdateKind: TUpdateKind);
174	begin
175	with Query[UpdateKind] do
176	begin
177	with Transaction do
178	if not InTransaction then StartTransaction;
179	if not Prepared then Prepare;
180	end;
181	end;
182
183	procedure TIBUpdateSQL.SQLChanged(Sender: TObject);
184	var
185	UpdateKind: TUpdateKind;
186	begin
187	for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do
188	if Sender = FSQLText[UpdateKind] then
189	begin
190	if Assigned(FQueries[UpdateKind]) then
191	FQueries[UpdateKind].SQL.Assign(FSQLText[UpdateKind]);
192	Break;
193	end;
194	end;
195
196	procedure TIBUpdateSQL.Apply(UpdateKind: TUpdateKind; buff: PChar);
197	begin
198	if not Assigned(FDataSet) then Exit;
199	InternalPrepare(UpdateKind);
200	InternalSetParams(Query[UpdateKind].Params,buff);
201	ExecSQL(UpdateKind,buff);
202	FLastUpdateKind := UpdateKind;
203	end;
204
205	end.