ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBUpdate.pas
Revision: 291
Committed: Fri Apr 17 10:26:08 2020 UTC (3 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 12285 byte(s)
Log Message:
Changed for 2.3.4 merged into public release

File Contents

# 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) 2015 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26
27 unit IBUpdate;
28
29 {$mode objfpc}{$H+}
30
31 interface
32
33 uses
34 Classes, SysUtils, IBCustomDataSet, DB, IB, IBDatabase, IBExternals, IBMessages;
35
36 type
37
38 TOnApplyUpdates = procedure(Sender: TObject; UpdateKind: TUpdateKind; Params: ISQLParams) of object;
39
40 { TIBUpdate}
41
42 TIBUpdate = class(TIBDataSetUpdateObject)
43 private
44 FDataSet: TIBCustomDataSet;
45 FDummySQL: TStrings;
46 FOnApplyUpdates: TOnApplyUpdates;
47 protected
48 function GetSQL(UpdateKind: TUpdateKind): TStrings; override;
49 function GetDataSet: TIBCustomDataSet; override;
50 procedure SetDataSet(ADataSet: TIBCustomDataSet); override;
51 procedure Apply(UpdateKind: TUpdateKind; buff: PChar); override;
52 public
53 constructor Create(AOwner: TComponent); override;
54 destructor Destroy; override;
55 property DataSet;
56 published
57 property OnApplyUpdates: TOnApplyUpdates read FOnApplyUpdates write FOnApplyUpdates;
58 end;
59
60
61 implementation
62
63 uses variants;
64
65 type
66
67 { TParamListIntf }
68
69 TParamListIntf = class(TInterfacedObject,ISQLParams)
70 private
71 type TParamRec = record
72 Name: string;
73 Value: variant;
74 Modified: boolean;
75 end;
76 private
77 FDatabase: TIBDatabase;
78 FModified: boolean;
79 FParams: array of TParamRec;
80 procedure SetParam(index: integer; aValue: variant);
81 public
82 constructor Create(aFields: TFields; aDatabase: TIBDatabase);
83 destructor Destroy; override;
84 property Database: TIBDatabase read FDatabase;
85 public
86 {ISQLParams}
87 function getCount: integer;
88 function getSQLParam(index: integer): ISQLParam;
89 function ByName(Idx: AnsiString): ISQLParam ;
90 function GetModified: Boolean;
91 function GetHasCaseSensitiveParams: Boolean;
92 end;
93
94 { TParamIntf }
95
96 TParamIntf = class(TInterfacedObject,ISQLParam)
97 private
98 FIndex: integer;
99 FOwner: TParamListIntf;
100 public
101 constructor Create(aOwner: TParamListIntf; aIndex: integer);
102 function GetIndex: integer;
103 function GetSQLType: cardinal;
104 function GetSQLTypeName: AnsiString;
105 function getSubtype: integer;
106 function getName: AnsiString;
107 function getScale: integer;
108 function getCharSetID: cardinal;
109 function getCodePage: TSystemCodePage;
110 function getIsNullable: boolean;
111 function GetSize: cardinal;
112 function GetAsBoolean: boolean;
113 function GetAsCurrency: Currency;
114 function GetAsInt64: Int64;
115 function GetAsDateTime: TDateTime;
116 function GetAsDouble: Double;
117 function GetAsFloat: Float;
118 function GetAsLong: Long;
119 function GetAsPointer: Pointer;
120 function GetAsQuad: TISC_QUAD;
121 function GetAsShort: short;
122 function GetAsString: AnsiString;
123 function GetIsNull: boolean;
124 function GetAsVariant: Variant;
125 function GetAsBlob: IBlob;
126 function GetAsArray: IArray;
127 procedure Clear;
128 function GetModified: boolean;
129 procedure SetAsBoolean(AValue: boolean);
130 procedure SetAsCurrency(aValue: Currency);
131 procedure SetAsInt64(aValue: Int64);
132 procedure SetAsDate(aValue: TDateTime);
133 procedure SetAsLong(aValue: Long);
134 procedure SetAsTime(aValue: TDateTime);
135 procedure SetAsDateTime(aValue: TDateTime);
136 procedure SetAsDouble(aValue: Double);
137 procedure SetAsFloat(aValue: Float);
138 procedure SetAsPointer(aValue: Pointer);
139 procedure SetAsShort(aValue: Short);
140 procedure SetAsString(aValue: AnsiString);
141 procedure SetAsVariant(aValue: Variant);
142 procedure SetIsNull(aValue: Boolean);
143 procedure SetAsBlob(aValue: IBlob);
144 procedure SetAsArray(anArray: IArray);
145 procedure SetAsQuad(aValue: TISC_QUAD);
146 procedure SetCharSetID(aValue: cardinal);
147 end;
148
149 { TParamIntf }
150
151 constructor TParamIntf.Create(aOwner: TParamListIntf; aIndex: integer);
152 begin
153 FOwner := aOwner;
154 FIndex := aIndex;
155 end;
156
157 function TParamIntf.GetIndex: integer;
158 begin
159 Result := Findex;
160 end;
161
162 function TParamIntf.GetSQLType: cardinal;
163 begin
164 IBError(ibxeNotSupported,[]);
165 end;
166
167 function TParamIntf.GetSQLTypeName: AnsiString;
168 begin
169 IBError(ibxeNotSupported,[]);
170 end;
171
172 function TParamIntf.getSubtype: integer;
173 begin
174 IBError(ibxeNotSupported,[]);
175 end;
176
177 function TParamIntf.getName: AnsiString;
178 begin
179 Result := FOwner.FParams[FIndex].Name;
180 end;
181
182 function TParamIntf.getScale: integer;
183 begin
184 IBError(ibxeNotSupported,[]);
185 end;
186
187 function TParamIntf.getCharSetID: cardinal;
188 var id: integer;
189 begin
190 FOwner.Database.Attachment.CodePage2CharSetID(StringCodePage(FOwner.FParams[FIndex].Value),id);
191 Result := id;
192 end;
193
194 function TParamIntf.getCodePage: TSystemCodePage;
195 begin
196 Result := StringCodePage(FOwner.FParams[FIndex].Value);
197 end;
198
199 function TParamIntf.getIsNullable: boolean;
200 begin
201 Result := true;
202 end;
203
204 function TParamIntf.GetSize: cardinal;
205 begin
206 IBError(ibxeNotSupported,[]);
207 end;
208
209 function TParamIntf.GetAsBoolean: boolean;
210 begin
211 Result := FOwner.FParams[FIndex].Value;
212 end;
213
214 function TParamIntf.GetAsCurrency: Currency;
215 begin
216 Result := FOwner.FParams[FIndex].Value;
217 end;
218
219 function TParamIntf.GetAsInt64: Int64;
220 begin
221 Result := FOwner.FParams[FIndex].Value;
222 end;
223
224 function TParamIntf.GetAsDateTime: TDateTime;
225 begin
226 Result := FOwner.FParams[FIndex].Value;
227 end;
228
229 function TParamIntf.GetAsDouble: Double;
230 begin
231 Result := FOwner.FParams[FIndex].Value;
232 end;
233
234 function TParamIntf.GetAsFloat: Float;
235 begin
236 Result := FOwner.FParams[FIndex].Value;
237 end;
238
239 function TParamIntf.GetAsLong: Long;
240 begin
241 Result := FOwner.FParams[FIndex].Value;
242 end;
243
244 function TParamIntf.GetAsPointer: Pointer;
245 begin
246 IBError(ibxeNotSupported,[]);
247 end;
248
249 function TParamIntf.GetAsQuad: TISC_QUAD;
250 begin
251 IBError(ibxeNotSupported,[]);
252 end;
253
254 function TParamIntf.GetAsShort: short;
255 begin
256 Result := FOwner.FParams[FIndex].Value;
257 end;
258
259 function TParamIntf.GetAsString: AnsiString;
260 var v: variant;
261 begin
262 v := FOwner.FParams[FIndex].Value;
263 Case varType(v) of
264 varEmpty,
265 varNull:
266 Result := '';
267 varShortInt,
268 varSmallint,
269 varInteger,
270 varInt64,
271 varByte,
272 varWord,
273 varDecimal,
274 varLongWord,
275 varQWord,
276 varSingle:
277 Result := IntToStr(v);
278 varCurrency,
279 varDouble:
280 Result := FloatToStr(v);
281 varDate:
282 Result := DateTimeToStr(v);
283 varStrArg,
284 varString:
285 Result := v;
286 varBoolean:
287 if v then
288 Result := 'true'
289 else
290 Result := 'false';
291 varVariant:
292 Result := v;
293 else
294 Result := v;
295 end;
296 end;
297
298 function TParamIntf.GetIsNull: boolean;
299 begin
300 Result := VarIsNull(FOwner.FParams[FIndex].Value);
301 end;
302
303 function TParamIntf.GetAsVariant: Variant;
304 begin
305 Result := FOwner.FParams[FIndex].Value;
306 end;
307
308 function TParamIntf.GetAsBlob: IBlob;
309 begin
310 IBError(ibxeNotSupported,[]);
311 end;
312
313 function TParamIntf.GetAsArray: IArray;
314 begin
315 IBError(ibxeNotSupported,[]);
316 end;
317
318 procedure TParamIntf.Clear;
319 begin
320 FOwner.SetParam(FIndex,NULL);
321 end;
322
323 function TParamIntf.GetModified: boolean;
324 begin
325 Result := FOwner.FParams[FIndex].Modified;
326 end;
327
328 procedure TParamIntf.SetAsBoolean(AValue: boolean);
329 begin
330 FOwner.SetParam(FIndex,AValue);
331 end;
332
333 procedure TParamIntf.SetAsCurrency(aValue: Currency);
334 begin
335 FOwner.SetParam(FIndex,AValue);
336 end;
337
338 procedure TParamIntf.SetAsInt64(aValue: Int64);
339 begin
340 FOwner.SetParam(FIndex,AValue);
341 end;
342
343 procedure TParamIntf.SetAsDate(aValue: TDateTime);
344 begin
345 FOwner.SetParam(FIndex,AValue);
346 end;
347
348 procedure TParamIntf.SetAsLong(aValue: Long);
349 begin
350 FOwner.SetParam(FIndex,AValue);
351 end;
352
353 procedure TParamIntf.SetAsTime(aValue: TDateTime);
354 begin
355 FOwner.SetParam(FIndex,AValue);
356 end;
357
358 procedure TParamIntf.SetAsDateTime(aValue: TDateTime);
359 begin
360 FOwner.SetParam(FIndex,AValue);
361 end;
362
363 procedure TParamIntf.SetAsDouble(aValue: Double);
364 begin
365 FOwner.SetParam(FIndex,AValue);
366 end;
367
368 procedure TParamIntf.SetAsFloat(aValue: Float);
369 begin
370 FOwner.SetParam(FIndex,AValue);
371 end;
372
373 procedure TParamIntf.SetAsPointer(aValue: Pointer);
374 begin
375 IBError(ibxeNotSupported,[]);
376 end;
377
378 procedure TParamIntf.SetAsShort(aValue: Short);
379 begin
380 FOwner.SetParam(FIndex,AValue);
381 end;
382
383 procedure TParamIntf.SetAsString(aValue: AnsiString);
384 begin
385 FOwner.SetParam(FIndex,AValue);
386 end;
387
388 procedure TParamIntf.SetAsVariant(aValue: Variant);
389 begin
390 FOwner.SetParam(FIndex,AValue);
391 end;
392
393 procedure TParamIntf.SetIsNull(aValue: Boolean);
394 begin
395 if aValue then
396 FOwner.SetParam(FIndex,NULL)
397 end;
398
399 procedure TParamIntf.SetAsBlob(aValue: IBlob);
400 begin
401 IBError(ibxeNotSupported,[]);
402 end;
403
404 procedure TParamIntf.SetAsArray(anArray: IArray);
405 begin
406 IBError(ibxeNotSupported,[]);
407 end;
408
409 procedure TParamIntf.SetAsQuad(aValue: TISC_QUAD);
410 begin
411 IBError(ibxeNotSupported,[]);
412 end;
413
414 procedure TParamIntf.SetCharSetID(aValue: cardinal);
415 var s: RawByteString;
416 codepage: TSystemCodePage;
417 str: string;
418 begin
419 str := FOwner.FParams[FIndex].Value;
420 s := str;
421 if FOwner.Database.Attachment.CharSetID2CodePage(aValue,codepage) then
422 SetCodePage(s,codepage,codepage <> cp_none);
423 end;
424
425 { TParamListIntf }
426
427 procedure TParamListIntf.SetParam(index: integer; aValue: variant);
428 begin
429 FParams[index].Value := aValue;
430 FParams[index].Modified := true;
431 FModified := true;
432 end;
433
434 constructor TParamListIntf.Create(aFields: TFields; aDatabase: TIBDatabase);
435 var i,j: integer;
436 begin
437 inherited Create;
438 FDatabase := aDatabase;
439 SetLength(FParams,aFields.Count*2);
440 j := 0;
441 {set up both current and "OLD" parameters from Field Names}
442 for i := 0 to aFields.Count - 1 do
443 if aFields[i].FieldKind = fkData then
444 begin
445 FParams[j].Name := aFields[i].FieldName;
446 FParams[j].Value := NULL;
447 FParams[j].Modified := false;
448 Inc(j);
449 FParams[j].Name := 'OLD_' + aFields[i].FieldName;
450 FParams[j].Value := NULL;
451 FParams[j].Modified := false;
452 Inc(j);
453 end;
454 SetLength(FParams,j);
455 end;
456
457 destructor TParamListIntf.Destroy;
458 begin
459 SetLength(FParams,0);
460 inherited Destroy;
461 end;
462
463 function TParamListIntf.getCount: integer;
464 begin
465 Result := Length(FParams);
466 end;
467
468 function TParamListIntf.getSQLParam(index: integer): ISQLParam;
469 begin
470 if (index < 0) or (index >= getCount) then
471 IBError(ibxeInvalidColumnIndex,[nil]);
472 Result := TParamIntf.Create(self,index);
473 end;
474
475 function TParamListIntf.ByName(Idx: AnsiString): ISQLParam;
476 var i: integer;
477 begin
478 Result := nil;
479 for i := 0 to getCount - 1 do
480 if CompareText(FParams[i].Name,Idx) = 0 then
481 begin
482 Result := getSQLParam(i);
483 Exit;
484 end;
485 end;
486
487 function TParamListIntf.GetModified: Boolean;
488 begin
489 Result := FModified;
490 end;
491
492 function TParamListIntf.GetHasCaseSensitiveParams: Boolean;
493 begin
494 Result := false;
495 end;
496
497 { TIBUpdate }
498
499 function TIBUpdate.GetSQL(UpdateKind: TUpdateKind): TStrings;
500 begin
501 Result := FDummySQL; {non empty result}
502 end;
503
504 function TIBUpdate.GetDataSet: TIBCustomDataSet;
505 begin
506 Result := FDataSet;
507 end;
508
509 procedure TIBUpdate.SetDataSet(ADataSet: TIBCustomDataSet);
510 begin
511 FDataSet := ADataset;
512 end;
513
514 procedure TIBUpdate.Apply(UpdateKind: TUpdateKind; buff: PChar);
515 var Params: ISQLParams;
516 begin
517 Params := TParamListIntf.Create(Dataset.Fields,(DataSet.Database as TIBDatabase));
518 InternalSetParams(Params,buff);
519 if assigned(FOnApplyUpdates) then
520 OnApplyUpdates(self,UpdateKind,Params);
521 end;
522
523 constructor TIBUpdate.Create(AOwner: TComponent);
524 begin
525 inherited Create(AOwner);
526 FDummySQL := TStringList.Create;
527 FDummySQL.Text := '*';
528 end;
529
530 destructor TIBUpdate.Destroy;
531 begin
532 if assigned(FDummySQL) then FDummySQL.Free;
533 inherited Destroy;
534 end;
535
536 end.
537