Context Navigation

DBBASE.PAS

Last change on this file was 7, checked in by RBRi, 19 years ago
+ sibyl staff
Property svn:eol-style set to `native`
File size: 215.9 KB

Line
1
2	{ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3	º º
4	º Sibyl Portable Component Classes º
5	º º
6	º Copyright (C) 1995,97 SpeedSoft Germany, All rights reserved. º
7	º º
8	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ}
9
10	Unit DBBase;
11
12
13	Interface
14
15
16	Uses Dos,SysUtils,Classes,Forms,Dialogs,DbLayer;
17
18	Type
19	TField=Class;
20	TDataSet=Class;
21	TDataSource=Class;
22
23	ESQLError=Class(Exception);
24
25	TDataChange=(dePositionChanged,deDataBaseChanged,deTableNameChanged);
26
27	TDataChangeEvent=Procedure(Sender:TObject;event:TDataChange) Of Object;
28
29
30	TDataLink=Class(TComponent)
31	Private
32	FDataSource:TDataSource;
33	FOnDataChange:TDataChangeEvent;
34	Procedure SetDataSource(NewValue:TDataSource);
35	Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
36	Procedure DataChange(event:TDataChange);
37	Protected
38	Procedure SetupComponent;Override;
39	Public
40	Destructor Destroy;Override;
41	Property DataSource:TDataSource Read FDataSource Write SetDataSource;
42	Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange;
43	End;
44
45
46	TTableDataLink=Class(TDataLink)
47	Private
48	Function GetColRowField(Col,Row:LongInt):TField;
49	Function GetNameRowField(Name:String;Row:LongInt):TField;
50	Function GetFieldCount:LongInt;
51	Function GetFieldName(Index:LongInt):String;
52	Protected
53	Procedure SetupComponent;Override;
54	Public
55	Property Fields[Col,Row:LongInt]:TField Read GetColRowField;
56	Property FieldsFromColumnName[Col:String;Row:LongInt]:TField Read GetNameRowField;
57	Property FieldCount:LongInt Read GetFieldCount;
58	Property FieldNames[Index:LongInt]:String read GetFieldName;
59	End;
60
61
62	TFieldDataLink=Class(TDataLink)
63	Private
64	FFieldName:PString;
65	Procedure SetFieldName(Const NewValue:String);
66	Function GetFieldName:String;
67	Function GetField:TField;
68	Protected
69	Procedure SetupComponent;Override;
70	Public
71	Destructor Destroy;Override;
72	Property FieldName:String Read GetFieldName Write SetFieldName;
73	Property field:TField Read GetField;
74	End;
75
76
77	TDataSource=Class(TComponent)
78	Private
79	FDataSet:TDataSet;
80	FOnDataChange:TDataChangeEvent;
81	Procedure SetDataSet(NewValue:TDataSet);
82	Procedure Notification(AComponent:TComponent;Operation:TOperation);Override;
83	Protected
84	Procedure SetupComponent;Override;
85	Procedure DataChange(event:TDataChange);Virtual;
86	Public
87	Destructor Destroy;Override;
88	Published
89	Property DataSet:TDataSet Read FDataSet Write SetDataSet;
90	Property OnDataChange:TDataChangeEvent Read FOnDataChange Write FOnDataChange;
91	End;
92
93
94	TFieldType=(ftUnknown,ftString,ftSmallInt,ftInteger,ftWord,ftBoolean,
95	ftFloat,ftCurrency,ftBCD,ftDate,ftTime,ftDateTime,ftBytes,
96	ftVarBytes,ftAutoInc,ftBlob,ftMemo,ftGraphic,ftFmtMemo,
97	ftTypedBinary,ftOLE);
98
99	EDataBaseError=Class(Exception);
100
101	TFieldDefs=Class;
102	TFieldDef=Class;
103
104	TOnFieldChange=Procedure(Sender:TField) Of Object;
105
106	TField=Class
107	Private
108	FSize:Longword; //store size of datatype (floatfield!)
109	FValue:Pointer;
110	FValueLen:LongWord;
111	FDataType:TFieldType;
112	FDataSet:TDataSet;
113	FFieldDef:TFieldDef;
114	FRequired:Boolean;
115	FRow:LongInt;
116	FCol:LongInt;
117	FReadOnly:Boolean;
118	FOnChange:TOnFieldChange;
119	Procedure FreeMemory;
120	Procedure GetMemory(Size:Longint);
121	Function GetFieldName:String;
122	Function GetIsNull:Boolean;
123	Procedure SetNewValue(Var NewValue;NewLen:LongInt);
124	Function GetAsVariant:Variant;Virtual;
125	Procedure SetAsVariant(NewValue:Variant);Virtual;
126	Function GetIsIndexField:Boolean;
127	Function GetCanModify:Boolean;
128	Function GetReadOnly:Boolean;
129	Protected
130	Procedure SetAsValue(Var Value;Len:LongInt);Virtual;
131	Function GetAsString:String;Virtual;
132	Procedure SetAsString(Const NewValue:String);Virtual;
133	Function GetAsAnsiString:AnsiString;Virtual;
134	Procedure SetAsAnsiString(NewValue:AnsiString);Virtual;
135	Function GetAsBoolean:Boolean;Virtual;
136	Procedure SetAsBoolean(NewValue:Boolean);Virtual;
137	Function GetAsDateTime:TDateTime;Virtual;
138	Procedure SetAsDateTime(NewValue:TDateTime);Virtual;
139	Function GetAsFloat:Extended;Virtual;
140	Procedure SetAsFloat(Const NewValue:Extended);Virtual;
141	Function GetAsInteger:LongInt;Virtual;
142	Procedure SetAsInteger(NewValue:LongInt);Virtual;
143	Procedure AccessError(Const TypeName:String);Virtual;
144	Procedure CheckInactive;
145	Public
146	Destructor Destroy;Override;
147	Procedure Clear;Virtual;
148	Procedure Assign(Field:TField);
149	Procedure SetData(Buffer:Pointer);
150	Property IsNull:Boolean Read GetIsNull;
151	Property ValueLen:LongWord Read FValueLen;
152	Property DataType:TFieldType Read FDataType;
153	Property Required:Boolean Read FRequired Write FRequired;
154	Property Row:LongInt read FRow write FRow;
155	Property Value:Variant read GetAsVariant write SetAsVariant;
156	Property IsIndexField:Boolean read GetIsIndexField;
157	Property CanModify:Boolean read GetCanModify;
158	Property DataSet:TDataSet read FDataSet;
159	Property DataSize:LongWord read FValueLen;
160	Property ReadOnly:boolean read GetReadOnly write FReadOnly;
161	Property Index:LongInt read FCol;
162	Published
163	Property FieldName:String Read GetFieldName;
164	Property AsString:String Read GetAsString Write SetAsString;
165	Property AsAnsiString:AnsiString Read GetAsAnsiString Write SetAsAnsiString;
166	Property AsBoolean:Boolean Read GetAsBoolean Write SetAsBoolean;
167	Property AsDateTime:TDateTime Read GetAsDateTime Write SetAsDateTime;
168	Property AsFloat:Extended Read GetAsFloat Write SetAsFloat;
169	Property AsInteger:LongInt Read GetAsInteger Write SetAsInteger;
170	Property OnChange:TOnFieldChange read FOnChange write FOnChange;
171	End;
172	TFieldClass=Class Of TField;
173
174
175	TStringField=Class(TField)
176	Protected
177	Function GetAsString:String;Override;
178	Procedure SetAsString(Const NewValue:String);Override;
179	Function GetAsAnsiString:AnsiString;Override;
180	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
181	Function GetAsBoolean:Boolean;Override;
182	Procedure SetAsBoolean(NewValue:Boolean);Override;
183	Function GetAsDateTime:TDateTime;Override;
184	Function GetAsFloat:Extended;Override;
185	Procedure SetAsFloat(Const NewValue:Extended);Override;
186	Function GetAsInteger:LongInt;Override;
187	Procedure SetAsInteger(NewValue:LongInt);Override;
188	Function GetAsVariant:Variant;Override;
189	Procedure SetAsVariant(NewValue:Variant);Override;
190	Public
191	Property Value:String Read GetAsString write SetAsString;
192	End;
193
194
195	TSmallintField=Class(TField)
196	Protected
197	Function GetAsBoolean:Boolean;Override;
198	Procedure SetAsBoolean(NewValue:Boolean);Override;
199	Function GetAsString:String;Override;
200	Procedure SetAsString(Const NewValue:String);Override;
201	Function GetAsAnsiString:AnsiString;Override;
202	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
203	Function GetAsSmallint:Integer;Virtual;
204	Procedure SetAsSmallInt(NewValue:Integer);Virtual;
205	Function GetAsFloat:Extended;Override;
206	Procedure SetAsFloat(Const NewValue:Extended);Override;
207	Function GetAsInteger:LongInt;Override;
208	Procedure SetAsInteger(NewValue:LongInt);Override;
209	Function GetAsVariant:Variant;Override;
210	Procedure SetAsVariant(NewValue:Variant);Override;
211	Public
212	Property Value:Integer Read GetAsSmallint Write SetAsSmallInt;
213	End;
214
215
216	TIntegerField=Class(TField)
217	Protected
218	Function GetAsBoolean:Boolean;Override;
219	Procedure SetAsBoolean(NewValue:Boolean);Override;
220	Function GetAsString:String;Override;
221	Procedure SetAsString(Const NewValue:String);Override;
222	Function GetAsAnsiString:AnsiString;Override;
223	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
224	Function GetAsFloat:Extended;Override;
225	Procedure SetAsFloat(Const NewValue:Extended);Override;
226	Function GetAsInteger:LongInt;Override;
227	Procedure SetAsInteger(NewValue:LongInt);Override;
228	Function GetAsVariant:Variant;Override;
229	Procedure SetAsVariant(NewValue:Variant);Override;
230	Public
231	Property Value:LongInt Read GetAsInteger Write SetAsInteger;
232	End;
233
234
235	TAutoIncField=Class(TIntegerField)
236	End;
237
238
239	TBooleanField=Class(TField)
240	Protected
241	Function GetAsBoolean:Boolean;Override;
242	Procedure SetAsBoolean(NewValue:Boolean);Override;
243	Function GetAsString:String;Override;
244	Procedure SetAsString(Const NewValue:String);Override;
245	Function GetAsAnsiString:AnsiString;Override;
246	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
247	Function GetAsFloat:Extended;Override;
248	Procedure SetAsFloat(Const NewValue:Extended);Override;
249	Function GetAsInteger:LongInt;Override;
250	Procedure SetAsInteger(NewValue:LongInt);Override;
251	Function GetAsVariant:Variant;Override;
252	Procedure SetAsVariant(NewValue:Variant);Override;
253	Public
254	Property Value:Boolean Read GetAsBoolean Write SetAsBoolean;
255	End;
256
257
258	TFloatField=Class(TField)
259	Private
260	FPrecision:Longint;
261	Procedure SetPrecision(Value:Longint);
262	Protected
263	Function GetAsString:String;Override;
264	Procedure SetAsString(Const NewValue:String);Override;
265	Function GetAsAnsiString:AnsiString;Override;
266	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
267	Function GetAsFloat:Extended;Override;
268	Procedure SetAsFloat(Const NewValue:Extended);Override;
269	Function GetAsInteger:LongInt;Override;
270	Procedure SetAsInteger(NewValue:LongInt);Override;
271	Function GetAsVariant:Variant;Override;
272	Procedure SetAsVariant(NewValue:Variant);Override;
273	Public
274	Constructor Create;
275	Property Value:Extended Read GetAsFloat Write SetAsFloat;
276	Property Precision:Longint Read FPrecision Write SetPrecision;
277	End;
278
279
280	TCurrencyField=Class(TFloatField)
281	Public
282	Constructor Create;
283	End;
284
285
286	TDateField=Class(TField)
287	Private
288	FDisplayFormat:PString;
289	Private
290	Function GetDisplayFormat:String;
291	Procedure SetDisplayFormat(Const NewValue:String);
292	Protected
293	Function GetAsString:String;Override;
294	Procedure SetAsString(Const NewValue:String);Override;
295	Function GetAsAnsiString:AnsiString;Override;
296	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
297	Function GetAsFloat:Extended;Override;
298	Function GetAsDateTime:TDateTime;Override;
299	Procedure SetAsDateTime(NewValue:TDateTime);Override;
300	Function GetAsVariant:Variant;Override;
301	Procedure SetAsVariant(NewValue:Variant);Override;
302	Destructor Destroy;Override;
303	Public
304	Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
305	Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
306	End;
307
308
309	TTimeField=Class(TField)
310	Private
311	FDisplayFormat:PString;
312	Private
313	Function GetDisplayFormat:String;
314	Procedure SetDisplayFormat(Const NewValue:String);
315	Protected
316	Function GetAsString:String;Override;
317	Procedure SetAsString(Const NewValue:String);Override;
318	Function GetAsAnsiString:AnsiString;Override;
319	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
320	Function GetAsFloat:Extended;Override;
321	Function GetAsDateTime:TDateTime;Override;
322	Procedure SetAsDateTime(NewValue:TDateTime);Override;
323	Function GetAsVariant:Variant;Override;
324	Procedure SetAsVariant(NewValue:Variant);Override;
325	Destructor Destroy;Override;
326	Public
327	Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
328	Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
329	End;
330
331
332	TDateTimeField=Class(TField)
333	Private
334	FDisplayFormat:PString;
335	Private
336	Function GetDisplayFormat:String;
337	Procedure SetDisplayFormat(Const NewValue:String);
338	Protected
339	Function GetAsString:String;Override;
340	Procedure SetAsString(Const NewValue:String);Override;
341	Function GetAsAnsiString:AnsiString;Override;
342	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
343	Function GetAsFloat:Extended;Override;
344	Function GetAsDateTime:TDateTime;Override;
345	Procedure SetAsDateTime(NewValue:TDateTime);Override;
346	Function GetAsVariant:Variant;Override;
347	Procedure SetAsVariant(NewValue:Variant);Override;
348	Destructor Destroy;Override;
349	Public
350	Property Value:TDateTime Read GetAsDateTime Write SetAsDateTime;
351	Property DisplayFormat:String read GetDisplayFormat write SetDisplayFormat;
352	End;
353
354
355	TBlobField=Class(TField)
356	Protected
357	Function GetAsString:String;Override;
358	Function GetAsAnsiString:AnsiString;Override;
359	Public
360	Procedure LoadFromStream(Stream:TStream);
361	Property Value:Pointer Read FValue;
362	End;
363
364
365	TMemoField=Class(TField)
366	Protected
367	Function GetAsString:String;Override;
368	Function GetAsAnsiString:AnsiString;Override;
369	Procedure SetAsAnsiString(NewValue:AnsiString);Override;
370	Public
371	Property Value:AnsiString Read GetAsAnsiString write SetAsAnsiString;
372	End;
373
374
375	TGraphicField=Class(TBlobField)
376	Protected
377	Function GetAsString:String;Override;
378	End;
379
380
381	TFieldList=Class(TList) //List Of Fields (TField entries)
382	Public
383	Procedure Clear;Override;
384	End;
385
386
387	TFieldDef=Class
388	Private
389	FFields:TList;
390	FOwner:TFieldDefs;
391	FName:String;
392	FRequired:Boolean;
393	FSize:Longword;
394	FPrecision:LongInt;
395	FDataType:TFieldType;
396	FFieldNo:Longint;
397	FPrimaryKey:Boolean;
398	FForeignKey:PString;
399	FTypeName:PString;
400	Function GetFieldClass:TFieldClass;
401	Function GetPrimaryKey:Boolean;
402	Procedure SetPrimaryKey(NewValue:Boolean);
403	Function GetForeignKey:String;
404	Procedure SetForeignKey(Const NewValue:String);
405	Function GetTypeName:String;
406	Procedure SetTypeName(Const NewValue:String);
407	Public
408	Constructor Create(aOwner:TFieldDefs; Const aName:String;
409	aDataType:TFieldType; aSize:Longword; aRequired:Boolean;
410	aFieldNo:Longint);
411	Destructor Destroy;Override;
412	Function CreateField(Owner:TComponent):TField;
413	Public
414	Property Fields:TList Read FFields;
415	Property DataType:TFieldType Read FDataType;
416	Property FieldClass:TFieldClass Read GetFieldClass;
417	Property FieldNo:Longint Read FFieldNo;
418	Property Name:String Read FName;
419	Property TypeName:String Read GetTypeName write SetTypeName;
420	Property Precision:Longint Read FPrecision Write FPrecision;
421	Property Required:Boolean Read FRequired;
422	Property Size:Longword Read FSize Write FSize;
423	Property PrimaryKey:Boolean read GetPrimaryKey write FPrimaryKey;
424	Property ForeignKey:String read GetForeignKey write SetForeignKey;
425	End;
426
427
428	TFieldDefs=Class
429	Private
430	FDataSet:TDataSet;
431	FItems:TList;
432	Function Rows:Longint;
433	Function GetCount:Longint;
434	Function GetItem(Index:Longint):TFieldDef;
435	Public
436	Constructor Create(DataSet:TDataSet);
437	Destructor Destroy;Override;
438	Procedure Clear;
439	Function Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef;
440	Procedure Update;
441	Procedure Assign(FieldDefs: TFieldDefs);
442	Function Find(Const Name: string): TFieldDef;
443	Function IndexOf(Const Name: string): LongInt;
444	Public
445	Property Count:Longint Read GetCount;
446	Property Items[Index:Longint]:TFieldDef Read GetItem; default
447	End;
448
449	TDataSetNotifyEvent=Procedure(DataSet:TDataSet) Of Object;
450
451	{$M+}
452	TLocateOptions=Set Of (loCaseInsensitive,loPartialKey);
453	{$M-}
454
455	{$M+}
456	TIndexOptions = Set of (ixPrimary, ixUnique, ixDescending,
457	ixCaseInsensitive, ixExpression);
458	{$M-}
459
460	TDataSet=Class(TComponent)
461	Private
462	FCurrentRow:LongInt;
463	FCurrentField:LongInt;
464	FRowIsInserted:Boolean;
465	FFieldDefs:TFieldDefs;
466	FActive:Boolean;
467	FOpened:Boolean;
468	FDBProcs:TDBProcs;
469	FServer:PString;
470	FDataBase:PString;
471	FDataSetLocked:Boolean;
472	FRefreshOnLoad:Boolean;
473	FSelect:TStrings;
474	FDataChangeLock:Boolean;
475	FMaxRows:LongInt;
476	FBeforeOpen:TDataSetNotifyEvent;
477	FAfterOpen:TDataSetNotifyEvent;
478	FBeforeClose:TDataSetNotifyEvent;
479	FAfterClose:TDataSetNotifyEvent;
480	FBeforeInsert:TDataSetNotifyEvent;
481	FAfterInsert:TDataSetNotifyEvent;
482	FBeforePost:TDataSetNotifyEvent;
483	FAfterPost:TDataSetNotifyEvent;
484	FBeforeCancel:TDataSetNotifyEvent;
485	FAfterCancel:TDataSetNotifyEvent;
486	FBeforeDelete:TDataSetNotifyEvent;
487	FAfterDelete:TDataSetNotifyEvent;
488	FReadOnly:Boolean;
489	Private
490	Function GetBOF:Boolean;
491	Function GetEOF:Boolean;
492	Function GetField(Index:LongInt):TField;
493	Function GetFieldCount:LongInt;
494	Function GetFieldName(Index:LongInt):String;
495	Function GetFieldType(Index:LongInt):TFieldType;
496	Procedure SetCurrentField(NewValue:LongInt);
497	Procedure SetCurrentRow(NewValue:LongInt);
498	Procedure UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt);
499	Function GetFieldFromColumnName(ColumnName:String):TField;
500	Procedure CheckRequiredFields;
501	Procedure SetFieldDefs(NewValue:TFieldDefs);
502	Procedure DesignerNotification(Var DNS:TDesignerNotifyStruct);
503	Function IsTable:Boolean;
504	Protected
505	Procedure SetupComponent;Override;
506	Procedure Loaded;Override;
507	Procedure DataChange(event:TDataChange);Virtual;
508	Procedure CheckInactive;Virtual;
509	Procedure SetActive(NewValue:Boolean);Virtual;
510	Procedure SetDataBaseName(Const NewValue:String);Virtual;
511	Function GetDataBaseName:String;Virtual;
512	Procedure SetServer(Const NewValue:String);Virtual;
513	Function GetServer:String;Virtual;
514	Function GetMaxRows:LongInt;Virtual;
515	Function GetResultColRow(Col,Row:LongInt):TField;Virtual;
516	Procedure CommitInsert(Commit:Boolean);Virtual;
517	Function UpdateFieldSelect(Field:TField):Boolean;Virtual;
518	Function GetFieldClass(FieldType:TFieldType):TFieldClass;Virtual;
519	Procedure InsertCurrentFields;
520	Procedure RemoveCurrentFields;
521	Procedure QueryTable;Virtual;
522	Procedure DoOpen;Virtual;
523	Procedure DoClose;Virtual;
524	Procedure DoPost;Virtual;
525	Procedure DoCancel;Virtual;
526	Procedure DoInsert;Virtual;
527	Procedure DoDelete;Virtual;
528	Property DataSetLocked:Boolean read FDataSetLocked write FDataSetLocked;
529	Public
530	Destructor Destroy;Override;
531	Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
532	Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
533	Procedure Open;
534	Procedure Close;
535	Procedure First;
536	Procedure Last;
537	Procedure Next;
538	Procedure Prior;
539	Procedure MoveBy(Distance:LongInt);
540	Procedure Refresh;
541	Procedure Post;Virtual;
542	Procedure Cancel;Virtual;
543	Procedure Insert;Virtual;
544	Procedure Append;Virtual;
545	Procedure Delete;Virtual;
546	Procedure GetFieldNames(List:TStrings);
547	Procedure GetDataSources(List:TStrings);Virtual;
548	Procedure GetStoredProcNames(List:TStrings);Virtual;
549	Procedure RefreshTable;Virtual;
550	Procedure AppendRecord(Const values:Array Of Const);
551	Procedure SetFields(Const values:Array Of Const);
552	Procedure InsertRecord(Const Values:Array Of Const);Virtual;
553	Function FieldByName(Const FieldName:String):TField;
554	Function FindField(Const FieldName:String):TField;
555	Function FindFirst: Boolean;
556	Function FindLast: Boolean;
557	Function FindNext: Boolean;
558	Function FindPrior: Boolean;
559	Procedure GetFieldList(List:TList;Const FieldNames:String);
560	Function Locate(Const KeyFields:String;Const KeyValues:Array Of Const;
561	Options:TLocateOptions):Boolean;Virtual;
562	Public
563	Property Bof:Boolean Read GetBOF;
564	Property Eof:Boolean Read GetEOF;
565	Property FieldCount:LongInt Read GetFieldCount;
566	Property Fields[Index:LongInt]:TField Read GetField;
567	Property FieldDefs:TFieldDefs read FFieldDefs write SetFieldDefs;
568	Property FieldNames[Index:LongInt]:String Read GetFieldName;
569	Property FieldTypes[Index:LongInt]:TFieldType Read GetFieldType;
570	Property CurrentField:LongInt Read FCurrentField Write SetCurrentField;
571	Property CurrentRow:LongInt Read FCurrentRow Write SetCurrentRow;
572	Property RowInserted:Boolean Read FRowIsInserted write FRowIsInserted;
573	Property FieldFromColumnName[ColumnName:String]:TField Read GetFieldFromColumnName;
574	Property DataChangeLock:Boolean Read FDataChangeLock Write FDataChangeLock;
575	Property MaxRows:LongInt read GetMaxRows;
576	Property RecordCount:Longint read GetMaxRows;
577	Property RecNo:Longint read FCurrentRow;
578	Property DataBaseName:String Read GetDataBaseName Write SetDataBaseName;
579	Published
580	Property Active:Boolean Read FActive Write SetActive;
581	Property Server:String Read GetServer Write SetServer;
582	Property DataBase:String Read GetDataBaseName Write SetDataBaseName;
583	Property ReadOnly:Boolean read FReadOnly write FReadOnly;
584	Property BeforeOpen:TDataSetNotifyEvent Read FBeforeOpen Write FBeforeOpen;
585	Property AfterOpen:TDataSetNotifyEvent Read FAfterOpen Write FAfterOpen;
586	Property BeforeClose:TDataSetNotifyEvent Read FBeforeClose Write FBeforeClose;
587	Property AfterClose:TDataSetNotifyEvent Read FAfterClose Write FAfterClose;
588	Property BeforeInsert:TDataSetNotifyEvent Read FBeforeInsert Write FBeforeInsert;
589	Property AfterInsert:TDataSetNotifyEvent Read FAfterInsert Write FAfterInsert;
590	Property BeforePost:TDataSetNotifyEvent Read FBeforePost Write FBeforePost;
591	Property AfterPost:TDataSetNotifyEvent Read FAfterPost Write FAfterPost;
592	Property BeforeCancel:TDataSetNotifyEvent Read FBeforeCancel Write FBeforeCancel;
593	Property AfterCancel:TDataSetNotifyEvent Read FAfterCancel Write FAfterCancel;
594	Property BeforeDelete:TDataSetNotifyEvent Read FBeforeDelete Write FBeforeDelete;
595	Property AfterDelete:TDataSetNotifyEvent Read FAfterDelete Write FAfterDelete;
596	End;
597
598	TLockType=(ltReadLock,ltWriteLock);
599
600	TIndexDefs=Class;
601
602	TIndexDef=Class
603	Private
604	FOwner: TIndexDefs;
605	FName:PString;
606	FFields:PString;
607	FOptions:TIndexOptions;
608	Function GetFields:String;
609	Function GetName:String;
610	Public
611	Constructor Create(Owner:TIndexDefs;Const Name, Fields:String;
612	Options:TIndexOptions);
613	Destructor Destroy; override;
614	Public
615	Property Fields:String read GetFields;
616	Property Name:String read GetName;
617	Property Options: TIndexOptions read FOptions;
618	End;
619
620	TIndexDefs=Class
621	Private
622	FDataSet:TDataSet;
623	FItems:TList;
624	FUpdated: Boolean;
625	Function GetCount:LongInt;
626	Function GetItem(Index:LongInt): TIndexDef;
627	Public
628	Constructor Create(DataSet:TDataSet);
629	Destructor Destroy;Override;
630	Function Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef;
631	Procedure Assign(IndexDefs:TIndexDefs);
632	Procedure Clear;
633	Function FindIndexForFields(Const Fields:String):TIndexDef;
634	Function GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef;
635	Function IndexOf(Const Name:String):LongInt;
636	Procedure Update;
637	Public
638	Property Count:LongInt read GetCount;
639	Property Items[Index:LongInt]:TIndexDef read GetItem;default;
640	Property Updated:Boolean read FUpdated write FUpdated;
641	End;
642
643	TTable=Class(TDataSet)
644	Private
645	FTableName:PString;
646	FMasterSource:TDataSource;
647	FTempMasterSource:TDataSource;
648	FMasterFields:PString;
649	FServants:TList; //Servants that are connected With This
650	FDataTypes:TStringList;
651	FIndexDefs:TIndexDefs;
652	FIndexFieldMap:TList;
653	Private
654	Function GetPassword:String;
655	Function GetUserId:String;
656	Procedure SetPassword(NewValue:String);
657	Procedure SetUserId(NewValue:String);
658	Procedure SetTableName(NewValue:String);
659	Function GetTableName:String;
660	Procedure SetTableLock(LockType:TLockType;Lock:Boolean);
661	Procedure SetMasterSource(NewValue:TDataSource);
662	Function GetMasterFields:String;
663	Procedure SetMasterFields(Const NewValue:String);
664	Procedure ConnectServant(Servant:TTable;Connect:Boolean);
665	Procedure CloseStmt;
666	Procedure GetNames(List:TStrings;Const Name:String);
667	Procedure GetKeys(List:TStrings;Primary:Boolean);
668	Function GetIndexFieldCount:LongInt;
669	Function GetIndexField(Index:LongInt):TField;
670	Procedure SetIndexField(Index:LongInt;NewValue:TField);
671	Function GetIndexDefs:TIndexDefs;
672	Protected
673	Procedure SetupComponent;Override;
674	Procedure SetActive(NewValue:Boolean);Override;
675	Function GetResultColRow(Col,Row:LongInt):TField;Override;
676	Procedure CommitInsert(Commit:Boolean);Override;
677	Function UpdateFieldSelect(Field:TField):Boolean;Override;
678	Procedure DataChange(event:TDataChange);Override;
679	Procedure QueryTable;Override;
680	Procedure DoOpen;Override;
681	Procedure DoClose;Override;
682	Procedure DoDelete;Override;
683	Procedure DoCancel;Override;
684	Procedure DoPost;Override;
685	Procedure Loaded;Override;
686	Procedure UpdateLinkList(Const PropertyName:String;LinkList:TList);Override;
687	Public
688	Procedure UpdateIndexDefs;Virtual;
689	Procedure UpdateFieldDefs;
690	Destructor Destroy;Override;
691	Procedure RefreshTable;Override;
692	Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
693	Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
694	Procedure GetDataSources(List:TStrings);Override;
695	Procedure GetStoredProcNames(List:TStrings);Override;
696	Procedure LockTable(LockType:TLockType);Virtual;
697	Procedure UnlockTable(LockType:TLockType);Virtual;
698	Procedure GetPrimaryKeys(List:TStrings);Virtual;
699	Procedure GetTableNames(List:TStrings);Virtual;
700	Procedure AddIndex(Const Name:String;Fields:String;Options:TIndexOptions);Virtual;
701	Procedure DeleteIndex(Const Name: string);Virtual;
702	Procedure CreateTable;Virtual;
703	Procedure DeleteTable;Virtual;
704	Procedure EmptyTable;Virtual;
705	Function FindKey(Const KeyValues:Array of Const):Boolean;Virtual;
706	Procedure GetIndexNames(List: TStrings);Virtual;
707	Procedure RenameTable(NewTableName:String);Virtual;
708	Procedure GetViewNames(List:TStrings);Virtual;
709	Procedure GetSystemTableNames(List:TStrings);Virtual;
710	Procedure GetSynonymNames(List:TStrings);Virtual;
711	Procedure GetDataTypes(List:TStrings);Virtual;
712	Procedure GetForeignKeys(List:TStrings);Virtual;
713	Function DataType2Name(DataType:TFieldType):String;
714	Public
715	Property IndexDefs:TIndexDefs read GetIndexDefs;
716	Property IndexFieldCount:LongInt read GetIndexFieldCount;
717	Property IndexFields[Index:LongInt]:TField read GetIndexField write SetIndexField;
718	Published
719	Property TableName:String Read GetTableName Write SetTableName;
720	Property Password:String Read GetPassword Write SetPassword;
721	Property UserId:String Read GetUserId Write SetUserId;
722	Property MasterSource:TDataSource Read FMasterSource Write SetMasterSource;
723	Property MasterFields:String Read GetMasterFields Write SetMasterFields;
724	End;
725
726
727	TQuery=Class(TTable)
728	Private
729	Property TableName;
730	Property MasterFields;
731	Property MasterSource;
732	Property ReadOnly;
733	Procedure SetSQL(NewValue:TStrings);
734	Protected
735	Procedure SetupComponent;Override;
736	Public
737	Procedure RefreshTable;Override;
738	Function WriteSCUResource(Stream:TResourceStream):Boolean;Override;
739	Procedure ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);Override;
740	Published
741	Property SQL:TStrings Read FSelect Write SetSQL;
742	End;
743
744	TParams = Class;
745
746	TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult, ptResultSet);
747
748	TParam = Class
749	Private
750	FParamList: TParams;
751	FData: Variant;
752	FName:PString;
753	FDataType: TFieldType;
754	FNull: Boolean;
755	FBound: Boolean;
756	FParamType: TParamType;
757	FResultNTS:CString;
758	FResultLongInt:LongInt;
759	FResultSmallInt:SmallInt;
760	FResultExtended:Extended;
761	FResultDate:Record
762	Year:Word;
763	Month:Word;
764	Day:Word;
765	End;
766	FResultTime:Record
767	Hour:WORD;
768	Minute:WORD;
769	Second:WORD;
770	End;
771	FResultDateTime:Record
772	Year:Word;
773	Month:Word;
774	Day:Word;
775	Hour:WORD;
776	Minute:WORD;
777	Second:WORD;
778	Fraction:LongWord;
779	End;
780	FOutLen:SQLINTEGER;
781	Private
782	Procedure SetAsBCD(Value: Currency);
783	Procedure SetAsBoolean(Value: Boolean);
784	Procedure SetAsCurrency(Value:Extended);
785	Procedure SetAsDate(Value: TDateTime);
786	Procedure SetAsDateTime(Value: TDateTime);
787	Procedure SetAsFloat(Const Value:Extended);
788	Procedure SetAsInteger(Value: Longint);
789	Procedure SetAsString(const Value: string);
790	Procedure SetAsSmallInt(Value: LongInt);
791	Procedure SetAsTime(Value: TDateTime);
792	Procedure SetAsVariant(Value: Variant);
793	Procedure SetAsWord(Value: LongInt);
794	Function GetName:String;
795	Procedure SetName(Const NewValue:String);
796	Protected
797	Function GetAsBCD: Currency;
798	Function GetAsBoolean: Boolean;
799	Function GetAsDateTime: TDateTime;
800	Function GetAsFloat:Extended;
801	Function GetAsInteger: Longint;
802	Function GetAsString: string;
803	Function GetAsVariant: Variant;
804	Function IsEqual(Value: TParam): Boolean;
805	Procedure SetDataType(Value: TFieldType);
806	Procedure SetText(Const Value:String);
807	Public
808	Constructor Create(AParamList: TParams; AParamType: TParamType);
809	Destructor Destroy;Override;
810	Procedure Assign(Param: TParam);
811	Procedure AssignField(Field: TField);
812	Procedure AssignFieldValue(Field:TField;Const Value: Variant);
813	Procedure Clear;
814	Public
815	Property AsBCD: Currency read GetAsBCD write SetAsBCD;
816	Property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
817	Property AsCurrency:Extended read GetAsFloat write SetAsCurrency;
818	Property AsDate: TDateTime read GetAsDateTime write SetAsDate;
819	Property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
820	Property AsFloat:Extended read GetAsFloat write SetAsFloat;
821	Property AsInteger: LongInt read GetAsInteger write SetAsInteger;
822	Property AsSmallInt: LongInt read GetAsInteger write SetAsSmallInt;
823	Property AsString:String read GetAsString write SetAsString;
824	Property AsTime: TDateTime read GetAsDateTime write SetAsTime;
825	Property AsWord: LongInt read GetAsInteger write SetAsWord;
826	Property Bound: Boolean read FBound write FBound;
827	Property DataType: TFieldType read FDataType write SetDataType;
828	Property IsNull: Boolean read FNull;
829	Property Name:String read GetName write SetName;
830	Property ParamType: TParamType read FParamType write FParamType;
831	Property Text:String read GetAsString write SetText;
832	Property Value: Variant read GetAsVariant write SetAsVariant;
833	End;
834
835	TParams=Class
836	Private
837	FItems: TList;
838	Function GetParam(Index: Word): TParam;
839	Function GetParamValue(Const ParamName:String):Variant;
840	Procedure SetParamValue(Const ParamName:String;Const Value: Variant);
841	Public
842	Constructor Create;Virtual;
843	Destructor Destroy;Override;
844	Procedure AddParam(Value: TParam);
845	Procedure RemoveParam(Value: TParam);
846	Function CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam;
847	Function Count:LongInt;
848	Procedure Clear;
849	Function IsEqual(Value:TParams): Boolean;
850	Function ParamByName(Const Value:String): TParam;
851	Property Items[Index: Word]: TParam read GetParam;default;
852	Property ParamValues[Const ParamName:String]: Variant read GetParamValue write SetParamValue;
853	End;
854
855	TStoredProc=Class(TTable)
856	Private
857	FPrepared:Boolean;
858	FParams:TParams;
859	FProcName:String;
860	Function GetParamCount:Word;
861	Procedure SetPrepared(NewValue:Boolean);
862	Procedure SetParams(NewValue:TParams);
863	Procedure SetStoredProcName(NewValue:String);
864	Property TableName;
865	Property MasterSource;
866	Property MasterFields;
867	Property ReadOnly;
868	Protected
869	Procedure Loaded;Override;
870	Procedure DoOpen;Override;
871	Procedure DoClose;Override;
872	Function UpdateFieldSelect(field:TField):Boolean;Override;
873	Public
874	Constructor Create(AOwner: TComponent);Override;
875	Destructor Destroy;Override;
876	Procedure Insert;Override;
877	Procedure Delete;Override;
878	Procedure InsertRecord(Const Values:Array Of Const);Override;
879	Procedure CopyParams(Value:TParams);
880	Procedure ExecProc;
881	Function ParamByName(Const Value:String):TParam;
882	Procedure Prepare;
883	Procedure UnPrepare;
884	Procedure SetDefaultParams;
885	Property ParamCount:Word read GetParamCount;
886	Property StmtHandle:SQLHStmt read FDBProcs.ahstmt;
887	Property Prepared: Boolean read FPrepared write SetPrepared;
888	Property Params:TParams read FParams write SetParams;
889	Published
890	Property StoredProcName:String read FProcName write SetStoredProcName;
891	End;
892
893
894	Function Field2String(field:TField):String;
895	Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String;
896
897	Procedure DatabaseError(Const Message:String);
898	Procedure SQLError(Const Message:String);
899
900
901
902	Implementation
903
904	Type
905	TGraphicHeader=Record
906	Count:Word; { Fixed at 1 }
907	HType:Word; { Fixed at $0100 }
908	Size:Longint; { Size not including header }
909	End;
910
911	Const SQLProcessCount:LongWord=0;
912
913	Procedure EnterSQLProcessing;
914	Begin
915	Screen.Cursor:=crSQLWait;
916	inc(SQLProcessCount);
917	End;
918
919	Procedure LeaveSQLProcessing;
920	Begin
921	If SQLProcessCount>0 Then dec(SQLProcessCount);
922	If SQLProcessCount=0 Then Screen.Cursor:=crDefault;
923	End;
924
925	Procedure DatabaseError(Const Message:String);
926	Begin
927	SQLProcessCount:=0;
928	LeaveSQLProcessing;
929	Raise EDataBaseError.Create(Message);
930	End;
931
932	Procedure SQLError(Const Message:String);
933	Begin
934	SQLProcessCount:=0;
935	LeaveSQLProcessing;
936	Raise ESQLError.Create(Message);
937	End;
938
939	{
940	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
941	º º
942	º Speed-Pascal/2 Version 2.0 º
943	º º
944	º Speed-Pascal Component Classes (SPCC) º
945	º º
946	º This section: TDataLink Class Implementation º
947	º º
948	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
949	º º
950	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
951	}
952
953	Procedure TDataLink.SetDataSource(NewValue:TDataSource);
954	Begin
955	If NewValue=FDataSource Then Exit;
956	If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove);
957	FDataSource:=NewValue;
958	If FDataSource<>Nil Then FDataSource.FreeNotification(Self);
959	DataChange(deDataBaseChanged);
960	End;
961
962	Procedure TDataLink.DataChange(event:TDataChange);
963	Begin
964	If OnDataChange<>Nil Then OnDataChange(Self,event);
965	End;
966
967	Procedure TDataLink.Notification(AComponent:TComponent;Operation:TOperation);
968	Begin
969	Inherited Notification(AComponent,Operation);
970
971	If AComponent=TComponent(FDataSource) Then If Operation=opRemove Then
972	Begin
973	FDataSource:=Nil;
974	DataChange(deDataBaseChanged);
975	End;
976	End;
977
978	Destructor TDataLink.Destroy;
979	Begin
980	If FDataSource<>Nil Then FDataSource.Notification(Self,opRemove);
981	FDataSource:=Nil;
982	DataChange(deDataBaseChanged);
983	Inherited Destroy;
984	End;
985
986	Procedure TDataLink.SetupComponent;
987	Begin
988	Inherited SetupComponent;
989
990	Name:='DataLink';
991	If Owner<>Nil Then SetDesigning(Owner.Designed);
992	End;
993
994	{
995	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
996	º º
997	º Speed-Pascal/2 Version 2.0 º
998	º º
999	º Speed-Pascal Component Classes (SPCC) º
1000	º º
1001	º This section: TTableDataLink Class Implementation º
1002	º º
1003	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1004	º º
1005	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1006	}
1007
1008	Function TTableDataLink.GetColRowField(Col,Row:LongInt):TField;
1009	Begin
1010	Result:=Nil;
1011	If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1012	Result:=FDataSource.DataSet.GetResultColRow(Col,Row);
1013	End;
1014
1015	Function TTableDataLink.GetNameRowField(Name:String;Row:LongInt):TField;
1016	Var Col:LongInt;
1017	S:String;
1018	T:LongInt;
1019	Label Ok;
1020	Begin
1021	Result:=Nil;
1022	If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1023
1024	UpcaseStr(Name);
1025	For T:=0 To FDataSource.DataSet.FieldCount-1 Do
1026	Begin
1027	S:=FDataSource.DataSet.FieldNames[T];
1028	UpcaseStr(S);
1029	If S=Name Then
1030	Begin
1031	Col:=T;
1032	Goto Ok;
1033	End;
1034	End;
1035	Exit;
1036	Ok:
1037	Result:=FDataSource.DataSet.GetResultColRow(Col,Row);
1038	End;
1039
1040	Procedure TTableDataLink.SetupComponent;
1041	Begin
1042	Inherited SetupComponent;
1043	Name:='TableDataLink';
1044	End;
1045
1046	Function TTableDataLink.GetFieldCount:LongInt;
1047	Begin
1048	Result:=0;
1049	If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1050	Result:=FDataSource.DataSet.FieldCount;
1051	End;
1052
1053	Function TTableDataLink.GetFieldName(Index:LongInt):String;
1054	Begin
1055	Result:='';
1056	If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)) Then Exit;
1057	Result:=FDataSource.DataSet.FieldNames[Index];
1058	End;
1059
1060	{
1061	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1062	º º
1063	º Speed-Pascal/2 Version 2.0 º
1064	º º
1065	º Speed-Pascal Component Classes (SPCC) º
1066	º º
1067	º This section: TFieldDataLink Class Implementation º
1068	º º
1069	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1070	º º
1071	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1072	}
1073
1074	Procedure TFieldDataLink.SetFieldName(Const NewValue:String);
1075	Begin
1076	If GetFieldName=NewValue Then exit;
1077
1078	AssignStr(FFieldName,NewValue);
1079	DataChange(deDataBaseChanged);
1080	End;
1081
1082	Function TFieldDataLink.GetFieldName:String;
1083	Begin
1084	Result:=FFieldName^;
1085	End;
1086
1087	Procedure TFieldDataLink.SetupComponent;
1088	Begin
1089	AssignStr(FFieldName,'');
1090
1091	Inherited SetupComponent;
1092
1093	Name:='FieldDataLink';
1094	End;
1095
1096	Function TFieldDataLink.GetField:TField;
1097	Var T:LongInt;
1098	S,s1:String;
1099	Begin
1100	Result:=Nil;
1101	S:=GetFieldName;
1102	If ((FDataSource=Nil)Or(FDataSource.DataSet=Nil)Or(S='')) Then Exit;
1103	UpcaseStr(S);
1104	For T:=0 To FDataSource.DataSet.FieldCount-1 Do
1105	Begin
1106	s1:=FDataSource.DataSet.FieldNames[T];
1107	UpcaseStr(s1);
1108	If S=s1 Then
1109	Begin
1110	Result:=FDataSource.DataSet.Fields[T];
1111	Exit;
1112	End;
1113	End;
1114	End;
1115
1116	Destructor TFieldDataLink.Destroy;
1117	Begin
1118	AssignStr(FFieldName,'');
1119
1120	Inherited Destroy;
1121	End;
1122
1123	{
1124	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1125	º º
1126	º Speed-Pascal/2 Version 2.0 º
1127	º º
1128	º Speed-Pascal Component Classes (SPCC) º
1129	º º
1130	º This section: TDataSource Class Implementation º
1131	º º
1132	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1133	º º
1134	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1135	}
1136
1137	//This tables DataSource changes, notify All Servants linked With MasterSource
1138	Procedure NotifyServants(Table:TTable);
1139	Var T:LongInt;
1140	Servant:TTable;
1141	Begin
1142	If Table.FServants<>Nil Then
1143	Begin
1144	//notify All Servants that their MasterSource Is invalid
1145	For T:=0 To Table.FServants.Count-1 Do
1146	Begin
1147	Servant:=Table.FServants[T];
1148	Servant.FMasterSource:=Nil;
1149	If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
1150	Servant.RefreshTable;
1151	End;
1152	Table.FServants.Clear;
1153	End;
1154	End;
1155
1156	Procedure TDataSource.SetDataSet(NewValue:TDataSet);
1157	Var Table,Servant:TTable;
1158	T:LongInt;
1159	Begin
1160	If FDataSet<>Nil Then
1161	Begin
1162	If FDataSet Is TTable Then
1163	Begin
1164	If Not (NewValue Is TTable) Then NotifyServants(TTable(FDataSet))
1165	Else If NewValue<>FDataSet Then
1166	Begin
1167	//New DataSet Is also A Table
1168	//Link All Servants Of This Table To the New one
1169	Table:=TTable(FDataSet);
1170	If Table.FServants<>Nil Then
1171	Begin
1172	For T:=0 To Table.FServants.Count-1 Do
1173	Begin
1174	Servant:=Table.FServants[T];
1175	TTable(NewValue).ConnectServant(Servant,True);
1176	End;
1177	Table.FServants.Clear;
1178	End;
1179	End;
1180	End;
1181
1182	FDataSet.Notification(Self,opRemove);
1183	End;
1184	FDataSet:=NewValue;
1185	If FDataSet<>Nil Then FDataSet.FreeNotification(Self);
1186	DataChange(deDataBaseChanged);
1187	End;
1188
1189	Destructor TDataSource.Destroy;
1190	Begin
1191	If FDataSet Is TTable Then NotifyServants(TTable(FDataSet));
1192	If FDataSet<>Nil Then FDataSet.Notification(Self,opRemove);
1193	FDataSet:=Nil;
1194	Inherited Destroy;
1195	End;
1196
1197	Procedure TDataSource.SetupComponent;
1198	Begin
1199	Include(ComponentState, csHandleLinks);
1200	Inherited SetupComponent;
1201
1202	// Include(DesignerState,dsDetail);
1203	Name:='DataSource';
1204	End;
1205
1206	Procedure TDataSource.DataChange(event:TDataChange);
1207	Var T:LongInt;
1208	Link:TDataLink;
1209	FLinkList:TList;
1210	Begin
1211	FLinkList:=FreeNotifyList;
1212	If FLinkList<>Nil Then For T:=0 To FLinkList.Count-1 Do
1213	Begin
1214	Link:=FLinkList.Items[T];
1215	If Link Is TDataLink Then Link.DataChange(event);
1216	End;
1217	End;
1218
1219	Procedure TDataSource.Notification(AComponent:TComponent;Operation:TOperation);
1220	Begin
1221	Inherited Notification(AComponent,Operation);
1222
1223	If AComponent=TComponent(FDataSet) Then If Operation=opRemove Then
1224	Begin
1225	FDataSet:=Nil;
1226	DataChange(deDataBaseChanged);
1227	If OnDataChange<>Nil Then OnDataChange(Self,deDataBaseChanged);
1228	End;
1229	End;
1230
1231	{
1232	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1233	º º
1234	º Speed-Pascal/2 Version 2.0 º
1235	º º
1236	º Speed-Pascal Component Classes (SPCC) º
1237	º º
1238	º This section: TField Class Implementation º
1239	º º
1240	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1241	º º
1242	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1243	}
1244
1245	Function TField.GetIsIndexField:Boolean;
1246	Var s,s1,s2:String;
1247	t:LongInt;
1248	IndexDef:TIndexDef;
1249	Begin
1250	Result:=False;
1251	If not (FDataSet Is TTable) Then exit;
1252	s:=FieldName;
1253	UpcaseStr(s);
1254	For t:=0 To TTable(FDataSet).IndexDefs.Count-1 Do
1255	Begin
1256	IndexDef:=TTable(FDataSet).IndexDefs[t];
1257	s1:=IndexDef.Fields;
1258	UpcaseStr(s1);
1259	While pos(';',s1)<>0 Do
1260	Begin
1261	s2:=Copy(s1,1,pos(';',s1)-1);
1262	Delete(s1,1,pos(';',s1));
1263	If s=s2 Then
1264	Begin
1265	Result:=True;
1266	exit;
1267	End;
1268	End;
1269	If s=s1 Then Result:=True;
1270	End;
1271	End;
1272
1273	Function TField.GetReadOnly:Boolean;
1274	Begin
1275	Result:=FReadOnly Or FDataSet.ReadOnly;
1276	End;
1277
1278	Function TField.GetCanModify:Boolean;
1279	Begin
1280	Result:=not ReadOnly;
1281	End;
1282
1283	Procedure TField.SetData(Buffer:Pointer);
1284	Begin
1285	If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1286
1287	If FValueLen > 0 Then
1288	Begin
1289	If FValue<>Nil Then FreeMem(FValue,FValueLen);
1290	FValue:=Nil;
1291	If Buffer<>Nil Then
1292	Begin
1293	GetMem(FValue,FValueLen);
1294	Move(Buffer^,FValue^,FValueLen);
1295	End;
1296	End;
1297	End;
1298
1299	Procedure TField.Assign(Field:TField);
1300	Begin
1301	If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1302
1303	If Field=Nil Then
1304	Begin
1305	Clear;
1306	If FValueLen<>0 Then FreeMem(FValue,FValueLen);
1307	FValueLen:=0;
1308	FValue:=Nil;
1309	exit;
1310	End;
1311
1312	Value:=Field.Value;
1313	End;
1314
1315	Function TField.GetAsVariant:Variant;
1316	Begin
1317	AccessError('Variant');
1318	End;
1319
1320	Procedure TField.SetAsVariant(NewValue:Variant);
1321	Begin
1322	AccessError('Variant');
1323	End;
1324
1325	Function TField.GetFieldName:String;
1326	Begin
1327	If FFieldDef <> Nil Then Result := FFieldDef.Name
1328	Else Result:='';
1329	End;
1330
1331	Function TField.GetIsNull:Boolean;
1332	Begin
1333	Result:=FValue=Nil;
1334	End;
1335
1336	Destructor TField.Destroy;
1337	Begin
1338	If FValue<>Nil Then
1339	If FValueLen>0 Then FreeMem(FValue,FValueLen);
1340	FValueLen:=0;
1341	FValue:=Nil;
1342
1343	Inherited Destroy;
1344	End;
1345
1346	Procedure TField.Clear;
1347	Var OldValue:Pointer;
1348	OldValueLen:LongInt;
1349	Begin
1350	//SetNewValue(Nil,0);
1351
1352	OldValue := FValue;
1353	OldValueLen := FValueLen;
1354	FValueLen := 0;
1355	FValue := Nil;
1356	FDataSet.UpdateField(Self,OldValue,OldValueLen);
1357	{wo wird der alte Speicher wieder freigegeben???}
1358	End;
1359
1360
1361	Procedure TField.FreeMemory;
1362	Begin
1363	If (FValue <> Nil) And (FValueLen > 0) Then FreeMem(FValue,FValueLen);
1364	FValueLen := 0;
1365	FValue := Nil;
1366	End;
1367
1368	Procedure TField.GetMemory(Size:Longint);
1369	Begin
1370	FValueLen := Size;
1371	GetMem(FValue,FValueLen);
1372	End;
1373
1374
1375	Procedure TField.AccessError(Const TypeName:String);
1376	Begin
1377	DatabaseError('Invalid type conversion to '+TypeName+' in field: '+FieldName);
1378	End;
1379
1380
1381	Procedure TField.CheckInactive;
1382	Begin
1383	If FDataSet <> Nil Then FDataSet.CheckInactive;
1384	End;
1385
1386
1387	{$HINTS OFF}
1388	Procedure TField.SetAsValue(Var Value;Len:LongInt);
1389	Begin
1390	SetNewValue(Value,Len);
1391	End;
1392
1393	Function TField.GetAsString:String;
1394	Begin
1395	AccessError('String');
1396	End;
1397
1398	Procedure TField.SetAsString(Const NewValue:String);
1399	Begin
1400	AccessError('String');
1401	End;
1402
1403	Function TField.GetAsAnsiString:AnsiString;
1404	Begin
1405	AccessError('AnsiString');
1406	End;
1407
1408	Procedure TField.SetAsAnsiString(NewValue:AnsiString);
1409	Begin
1410	AccessError('AnsiString');
1411	End;
1412
1413	Function TField.GetAsBoolean:Boolean;
1414	Begin
1415	AccessError('Boolean');
1416	End;
1417
1418	Procedure TField.SetAsBoolean(NewValue:Boolean);
1419	Begin
1420	AccessError('Boolean');
1421	End;
1422
1423	Function TField.GetAsDateTime:TDateTime;
1424	Begin
1425	AccessError('DateTime');
1426	End;
1427
1428	Procedure TField.SetAsDateTime(NewValue:TDateTime);
1429	Begin
1430	AccessError('DateTime');
1431	End;
1432
1433	Function TField.GetAsFloat:Extended;
1434	Begin
1435	AccessError('Float');
1436	End;
1437
1438	Procedure TField.SetAsFloat(Const NewValue:Extended);
1439	Begin
1440	AccessError('Float');
1441	End;
1442
1443	Function TField.GetAsInteger:LongInt;
1444	Begin
1445	AccessError('Integer');
1446	End;
1447
1448	Procedure TField.SetAsInteger(NewValue:LongInt);
1449	Begin
1450	AccessError('Integer');
1451	End;
1452	{$HINTS ON}
1453
1454	Procedure TField.SetNewValue(Var NewValue;NewLen:LongInt);
1455	Var OldValue:Pointer;
1456	OldValueLen:LongInt;
1457	Begin
1458	If ReadOnly Then DataBaseError('Cannot modify a readonly field !');
1459
1460	OldValue:=FValue;
1461	OldValueLen:=FValueLen;
1462	FValueLen:=NewLen;
1463	If FValueLen > 0 Then
1464	Begin
1465	GetMem(FValue,FValueLen);
1466	Move(NewValue,FValue^,FValueLen);
1467	End;
1468	FDataSet.UpdateField(Self,OldValue,OldValueLen);
1469	{wo wird der alte Speicher wieder freigegeben???}
1470	End;
1471
1472	{
1473	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1474	º º
1475	º Speed-Pascal/2 Version 2.0 º
1476	º º
1477	º Speed-Pascal Component Classes (SPCC) º
1478	º º
1479	º This section: TStringField Class Implementation º
1480	º º
1481	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1482	º º
1483	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1484	}
1485
1486	Function TStringField.GetAsVariant:Variant;
1487	Begin
1488	Result:=GetAsString;
1489	End;
1490
1491	Procedure TStringField.SetAsVariant(NewValue:Variant);
1492	Begin
1493	SetAsString(NewValue);
1494	End;
1495
1496	Function TStringField.GetAsString:String;
1497	Begin
1498	If FValue <> Nil Then
1499	Begin
1500	Result[0] := Chr(FValueLen);
1501	Move(FValue^,Result[1],Ord(Result[0]));
1502	If Result[Length(Result)]=#0 Then
1503	If length(Result)>0 Then Dec(Result[0]);
1504	End
1505	//Else Result:='NULL';
1506	Else Result := '';
1507	End;
1508
1509	Procedure TStringField.SetAsString(Const NewValue:String);
1510	Var C:CString;
1511	Begin
1512	If NewValue <> '' Then
1513	Begin
1514	C:=NewValue;
1515	SetNewValue(C,Length(NewValue)+1);
1516	End
1517	Else Clear;
1518	End;
1519
1520	Function TStringField.GetAsAnsiString:AnsiString;
1521	Begin
1522	If FValue<>Nil Then Result:=PChar(Value)^
1523	Else Result:='';
1524	End;
1525
1526	Procedure TStringField.SetAsAnsiString(NewValue:AnsiString);
1527	Begin
1528	If PChar(NewValue) = Nil Then NewValue:=#0;
1529	SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1)
1530	End;
1531
1532	Function TStringField.GetAsBoolean:Boolean;
1533	Var S:String;
1534	Begin
1535	S:=GetAsString;
1536	UpcaseStr(S);
1537	If ((S='TRUE')Or(S='YES')Or(S='1')) Then Result:=True
1538	Else Result:=False
1539	End;
1540
1541	Procedure TStringField.SetAsBoolean(NewValue:Boolean);
1542	Var S:String;
1543	Begin
1544	If NewValue Then S:='True'
1545	Else S:='False';
1546	SetAsString(S);
1547	End;
1548
1549	Function TStringField.GetAsDateTime:TDateTime;
1550	Begin
1551	Result:=StrToDateTime(GetAsString);
1552	End;
1553
1554	Function TStringField.GetAsFloat:Extended;
1555	Begin
1556	Result:=StrToFloat(GetAsString);
1557	End;
1558
1559	Procedure TStringField.SetAsFloat(Const NewValue:Extended);
1560	Begin
1561	SetAsString(FloatToStr(NewValue));
1562	End;
1563
1564	Function TStringField.GetAsInteger:LongInt;
1565	Begin
1566	Result:=StrToInt(GetAsString);
1567	End;
1568
1569	Procedure TStringField.SetAsInteger(NewValue:LongInt);
1570	Begin
1571	SetAsString(tostr(NewValue));
1572	End;
1573
1574	{
1575	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1576	º º
1577	º Speed-Pascal/2 Version 2.0 º
1578	º º
1579	º Speed-Pascal Component Classes (SPCC) º
1580	º º
1581	º This section: TSmallintField Class Implementation º
1582	º º
1583	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1584	º º
1585	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1586	}
1587
1588	Function TSmallIntField.GetAsVariant:Variant;
1589	Begin
1590	Result:=GetAsSmallInt;
1591	End;
1592
1593	Procedure TSmallIntField.SetAsVariant(NewValue:Variant);
1594	Begin
1595	SetAsSmallInt(NewValue);
1596	End;
1597
1598
1599	Function TSmallintField.GetAsString:String;
1600	Begin
1601	If FValue<>Nil Then Result:=tostr(Integer(FValue^))
1602	Else Result:='';
1603	End;
1604
1605	Procedure TSmallintField.SetAsString(Const NewValue:String);
1606	Var I,C:Integer;
1607	Begin
1608	If NewValue <> '' Then
1609	Begin
1610	Val(NewValue,I,C);
1611	If C=0 Then SetNewValue(I,SizeOf(Integer));
1612	End
1613	Else Clear;
1614	End;
1615
1616	Function TSmallintField.GetAsAnsiString:AnsiString;
1617	Begin
1618	Result:=GetAsString;
1619	End;
1620
1621	Procedure TSmallintField.SetAsAnsiString(NewValue:AnsiString);
1622	Begin
1623	SetAsString(NewValue);
1624	End;
1625
1626	Function TSmallintField.GetAsBoolean:Boolean;
1627	Var I:Integer;
1628	Begin
1629	I:=GetAsInteger;
1630	Result:=I<>0;
1631	End;
1632
1633	Procedure TSmallintField.SetAsBoolean(NewValue:Boolean);
1634	Begin
1635	If NewValue Then SetAsInteger(1)
1636	Else SetAsInteger(0);
1637	End;
1638
1639	Function TSmallintField.GetAsSmallint:Integer;
1640	Begin
1641	If FValue<>Nil Then Result:=Integer(FValue^)
1642	Else AccessError('Smallint');
1643	End;
1644
1645	Procedure TSmallintField.SetAsSmallInt(NewValue:Integer);
1646	Begin
1647	SetNewValue(NewValue,SizeOf(Integer));
1648	End;
1649
1650	Function TSmallintField.GetAsFloat:Extended;
1651	Begin
1652	If FValue<>Nil Then Result:=Integer(FValue^)
1653	Else AccessError('Float');
1654	End;
1655
1656	Procedure TSmallintField.SetAsFloat(Const NewValue:Extended);
1657	Begin
1658	SetAsSmallInt(Round(NewValue));
1659	End;
1660
1661	Function TSmallintField.GetAsInteger:LongInt;
1662	Begin
1663	If FValue<>Nil Then Result:=Integer(FValue^)
1664	Else AccessError('Integer');
1665	End;
1666
1667	Procedure TSmallintField.SetAsInteger(NewValue:LongInt);
1668	Begin
1669	SetAsSmallInt(NewValue);
1670	End;
1671
1672	{
1673	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1674	º º
1675	º Speed-Pascal/2 Version 2.0 º
1676	º º
1677	º Speed-Pascal Component Classes (SPCC) º
1678	º º
1679	º This section: TIntegerField Class Implementation º
1680	º º
1681	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1682	º º
1683	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1684	}
1685
1686
1687	Function TIntegerField.GetAsVariant:Variant;
1688	Begin
1689	Result:=GetAsInteger;
1690	End;
1691
1692	Procedure TIntegerField.SetAsVariant(NewValue:Variant);
1693	Begin
1694	SetAsInteger(NewValue);
1695	End;
1696
1697	Function TIntegerField.GetAsString:String;
1698	Begin
1699	If FValue<>Nil Then Result:=tostr(LongInt(FValue^))
1700	Else Result:='';
1701	End;
1702
1703	Procedure TIntegerField.SetAsString(Const NewValue:String);
1704	Var I:LongInt;
1705	C:Integer;
1706	Begin
1707	If NewValue <> '' Then
1708	Begin
1709	Val(NewValue,I,C);
1710	If C=0 Then SetNewValue(I,SizeOf(LongInt))
1711	Else AccessError('String');
1712	End
1713	Else Clear;
1714	End;
1715
1716	Function TIntegerField.GetAsAnsiString:AnsiString;
1717	Begin
1718	Result:=GetAsString;
1719	End;
1720
1721	Procedure TIntegerField.SetAsAnsiString(NewValue:AnsiString);
1722	Begin
1723	SetAsString(NewValue);
1724	End;
1725
1726	Function TIntegerField.GetAsBoolean:Boolean;
1727	Var I:Integer;
1728	Begin
1729	I:=GetAsInteger;
1730	Result:=I<>0;
1731	End;
1732
1733	Procedure TIntegerField.SetAsBoolean(NewValue:Boolean);
1734	Begin
1735	If NewValue Then SetAsInteger(1)
1736	Else SetAsInteger(0);
1737	End;
1738
1739	Function TIntegerField.GetAsFloat:Extended;
1740	Begin
1741	If FValue<>Nil Then Result:=LongInt(FValue^)
1742	Else AccessError('Float');
1743	End;
1744
1745	Procedure TIntegerField.SetAsFloat(Const NewValue:Extended);
1746	Begin
1747	SetAsInteger(Round(NewValue));
1748	End;
1749
1750	Function TIntegerField.GetAsInteger:LongInt;
1751	Begin
1752	If FValue<>Nil Then Result:=LongInt(FValue^)
1753	Else AccessError('Integer');
1754	End;
1755
1756	Procedure TIntegerField.SetAsInteger(NewValue:LongInt);
1757	Begin
1758	SetNewValue(NewValue,SizeOf(LongInt));
1759	End;
1760
1761	{
1762	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1763	º º
1764	º Speed-Pascal/2 Version 2.0 º
1765	º º
1766	º Speed-Pascal Component Classes (SPCC) º
1767	º º
1768	º This section: TBooleanField Class Implementation º
1769	º º
1770	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1771	º º
1772	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1773	}
1774
1775	Function TBooleanField.GetAsVariant:Variant;
1776	Begin
1777	Result:=GetAsBoolean;
1778	End;
1779
1780	Procedure TBooleanField.SetAsVariant(NewValue:Variant);
1781	Begin
1782	SetAsBoolean(NewValue);
1783	End;
1784
1785
1786	Function TBooleanField.GetAsString:String;
1787	Begin
1788	If FValue<>Nil Then
1789	Begin
1790	If Boolean(FValue^) Then Result:='True'
1791	Else Result:='False';
1792	End
1793	Else Result:='';
1794	End;
1795
1796	Procedure TBooleanField.SetAsString(Const NewValue:String);
1797	Var s:String;
1798	Begin
1799	If NewValue <> '' Then
1800	Begin
1801	s:=NewValue;
1802	UpcaseStr(s);
1803
1804	If ((s='TRUE')Or(s='YES')Or(s='T')Or(s='Y')Or(s='1')) Then SetAsBoolean(True)
1805	Else SetAsBoolean(False);
1806	End
1807	Else Clear;
1808	End;
1809
1810	Function TBooleanField.GetAsAnsiString:AnsiString;
1811	Begin
1812	Result:=GetAsString;
1813	End;
1814
1815	Procedure TBooleanField.SetAsAnsiString(NewValue:AnsiString);
1816	Begin
1817	SetAsString(NewValue);
1818	End;
1819
1820	Function TBooleanField.GetAsBoolean:Boolean;
1821	Begin
1822	If FValue<>Nil Then
1823	Begin
1824	Result := Boolean(FValue^);
1825	End
1826	Else Result:=False;
1827	End;
1828
1829	Procedure TBooleanField.SetAsBoolean(NewValue:Boolean);
1830	Begin
1831	SetNewValue(NewValue,SizeOf(Boolean))
1832	End;
1833
1834	Function TBooleanField.GetAsFloat:Extended;
1835	Begin
1836	If FValue<>Nil Then
1837	Begin
1838	If Boolean(FValue^) Then Result := 1
1839	Else Result := 0;
1840	End
1841	Else AccessError('Float');
1842	End;
1843
1844	Procedure TBooleanField.SetAsFloat(Const NewValue:Extended);
1845	Begin
1846	SetAsInteger(round(NewValue));
1847	End;
1848
1849	Function TBooleanField.GetAsInteger:LongInt;
1850	Begin
1851	If FValue<>Nil Then
1852	Begin
1853	If Boolean(FValue^) Then Result := 1
1854	Else Result := 0;
1855	End
1856	Else AccessError('Integer');
1857	End;
1858
1859	Procedure TBooleanField.SetAsInteger(NewValue:LongInt);
1860	Begin
1861	If NewValue = 0 Then SetAsBoolean(False)
1862	Else SetAsBoolean(True);
1863	End;
1864
1865
1866	{
1867	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
1868	º º
1869	º Speed-Pascal/2 Version 2.0 º
1870	º º
1871	º Speed-Pascal Component Classes (SPCC) º
1872	º º
1873	º This section: TFloatField Class Implementation º
1874	º º
1875	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
1876	º º
1877	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
1878	}
1879
1880	Constructor TFloatField.Create;
1881	Begin
1882	Inherited Create;
1883
1884	FPrecision := -1;
1885	End;
1886
1887	Function TFloatField.GetAsVariant:Variant;
1888	Begin
1889	Result:=GetAsFloat;
1890	End;
1891
1892	Procedure TFloatField.SetAsVariant(NewValue:Variant);
1893	Begin
1894	SetAsFloat(NewValue);
1895	End;
1896
1897
1898	Procedure TFloatField.SetPrecision(Value:Longint);
1899	Begin
1900	//If Value < 2 Then Value := 2;
1901	If Value > 15 Then Value := 15;
1902	FPrecision := Value;
1903	End;
1904
1905
1906	Function TFloatField.GetAsString:String;
1907	Var E:Extended;
1908	Begin
1909	If FValue <> Nil Then
1910	Begin
1911	E := GetAsFloat;
1912
1913	If Precision >= 0 Then
1914	Begin
1915	Result := Format('%.'+ tostr(Precision) +'f',[E]);
1916	If Precision = 0 Then
1917	If pos('.',Result) > 0 Then SubStr(Result,1,pos('.',Result)-1);
1918	End
1919	Else Result := FloatToStr(E);
1920	End
1921	Else Result := '';
1922	End;
1923
1924
1925	Procedure TFloatField.SetAsString(Const NewValue:String);
1926	Var E:Extended;
1927	C:Integer;
1928	p:Integer;
1929	aValue:String;
1930	Begin
1931	If NewValue <> '' Then
1932	Begin
1933	//replace , by .
1934	p := pos(',',NewValue);
1935	If p > 0 Then
1936	Begin
1937	aValue := NewValue;
1938	aValue[p] := '.';
1939	Val(aValue,E,C);
1940	End
1941	Else Val(NewValue,E,C);
1942
1943	If C=0 Then SetAsFloat(E)
1944	Else AccessError('String');
1945	End
1946	Else Clear;
1947	End;
1948
1949
1950	Function TFloatField.GetAsAnsiString:AnsiString;
1951	Begin
1952	Result:=GetAsString;
1953	End;
1954
1955	Procedure TFloatField.SetAsAnsiString(NewValue:AnsiString);
1956	Begin
1957	SetAsString(NewValue);
1958	End;
1959
1960	Function TFloatField.GetAsFloat:Extended;
1961	Begin
1962	If FValue<>Nil Then
1963	Begin
1964	Case FSize Of
1965	4:Result:=Single(FValue^);
1966	8:Result:=Double(FValue^);
1967	10:Result:=Extended(FValue^);
1968	Else AccessError('Float');
1969	End; {Case}
1970	End
1971	//Else AccessError('Float');
1972	Else Result := 0;
1973	End;
1974
1975
1976	Procedure TFloatField.SetAsFloat(Const NewValue:Extended);
1977	Var E:Extended;
1978	S:Single;
1979	D:Double;
1980	Begin
1981	Case FSize Of
1982	4:
1983	Begin
1984	S:=NewValue;
1985	SetNewValue(S,SizeOf(Single));
1986	End;
1987	8:
1988	Begin
1989	D:=NewValue;
1990	SetNewValue(D,SizeOf(Double));
1991	End;
1992	10:
1993	Begin
1994	E:=NewValue;
1995	SetNewValue(E,SizeOf(Extended));
1996	End;
1997	End;
1998	End;
1999
2000
2001	Function TFloatField.GetAsInteger:LongInt;
2002	Begin
2003	Result := Round(GetAsFloat);
2004	End;
2005
2006
2007	Procedure TFloatField.SetAsInteger(NewValue:LongInt);
2008	Var E:Extended;
2009	Begin
2010	E := NewValue;
2011	SetAsFloat(E);
2012	End;
2013
2014	{
2015	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2016	º º
2017	º Speed-Pascal/2 Version 2.0 º
2018	º º
2019	º Speed-Pascal Component Classes (SPCC) º
2020	º º
2021	º This section: TCurrencyField Class Implementation º
2022	º º
2023	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2024	º º
2025	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2026	}
2027
2028	Constructor TCurrencyField.Create;
2029	Begin
2030	Inherited Create;
2031
2032	FPrecision := 2;
2033	End;
2034
2035
2036	{
2037	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2038	º º
2039	º Speed-Pascal/2 Version 2.0 º
2040	º º
2041	º Speed-Pascal Component Classes (SPCC) º
2042	º º
2043	º This section: TDateField Class Implementation º
2044	º º
2045	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2046	º º
2047	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2048	}
2049
2050	Function TDateField.GetAsString:String;
2051	Var date:TDateTime;
2052	Begin
2053	If FValue <> Nil Then
2054	Begin
2055	date := GetAsDateTime;
2056	DateTimeToString(result,DisplayFormat,date);
2057	End
2058	Else Result := '';
2059	End;
2060
2061	Destructor TDateField.Destroy;
2062	Begin
2063	AssignStr(FDisplayFormat,'');
2064	Inherited Destroy;
2065	End;
2066
2067	Function TDateField.GetDisplayFormat:String;
2068	Begin
2069	If FDisplayFormat=Nil Then Result:=ShortDateFormat
2070	Else Result:=FDisplayFormat^;
2071	End;
2072
2073	Procedure TDateField.SetDisplayFormat(Const NewValue:String);
2074	Begin
2075	AssignStr(FDisplayFormat,NewValue);
2076	If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2077	End;
2078
2079	Function TDateField.GetAsVariant:Variant;
2080	Begin
2081	Result:=GetAsDateTime;
2082	End;
2083
2084	Procedure TDateField.SetAsVariant(NewValue:Variant);
2085	Begin
2086	SetAsDateTime(NewValue);
2087	End;
2088
2089
2090	Procedure TDateField.SetAsString(Const NewValue:String);
2091	Var dt:TDateTime;
2092	Valid:Boolean;
2093	Begin
2094	If NewValue <> '' Then
2095	Begin
2096	Try
2097	dt:=StrToDate(NewValue);
2098	Valid:=True;
2099	Except
2100	Valid:=False;
2101	End;
2102	If Valid Then SetAsDateTime(dt);
2103	End
2104	Else Clear;
2105	End;
2106
2107	Function TDateField.GetAsAnsiString:AnsiString;
2108	Begin
2109	Result:=GetAsString;
2110	End;
2111
2112	Procedure TDateField.SetAsAnsiString(NewValue:AnsiString);
2113	Begin
2114	SetAsString(NewValue);
2115	End;
2116
2117	Function TDateField.GetAsFloat:Extended;
2118	Begin
2119	If FValue<>Nil Then Result:=GetAsDateTime
2120	Else AccessError('Float');
2121	End;
2122
2123
2124	Function TDateField.GetAsDateTime:TDateTime;
2125	Var date:TODBCDate;
2126	Begin
2127	If FValue<>Nil Then
2128	Begin
2129	date:=TODBCDate(FValue^);
2130	Result:=EncodeDate(date.Year,date.Month,date.Day);
2131	End
2132	Else AccessError('DateTime');
2133	End;
2134
2135	Procedure TDateField.SetAsDateTime(NewValue:TDateTime);
2136	Var R:TODBCDate;
2137	Begin
2138	DecodeDate(NewValue,R.Year,R.Month,R.Day);
2139	SetNewValue(R,SizeOf(R));
2140	End;
2141
2142	{
2143	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2144	º º
2145	º Speed-Pascal/2 Version 2.0 º
2146	º º
2147	º Speed-Pascal Component Classes (SPCC) º
2148	º º
2149	º This section: TTimeField Class Implementation º
2150	º º
2151	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2152	º º
2153	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2154	}
2155
2156
2157	Procedure RoundDecodeTime(Time: TDateTime; Var Hour, Min, Sec: Word);
2158	Var MSec:Word;
2159	Begin
2160	DecodeTime(Time, Hour, Min, Sec, MSec);
2161
2162	If MSec > 500 Then
2163	Begin
2164	MSec := 0;
2165	inc(Sec);
2166	End;
2167	If Sec >= 60 Then
2168	Begin
2169	dec(Sec,60);
2170	inc(Min);
2171	End;
2172	If Min >= 60 Then
2173	Begin
2174	dec(Min,60);
2175	inc(Hour);
2176	End;
2177	End;
2178
2179
2180	Destructor TTimeField.Destroy;
2181	Begin
2182	AssignStr(FDisplayFormat,'');
2183	Inherited Destroy;
2184	End;
2185
2186	Function TTimeField.GetDisplayFormat:String;
2187	Begin
2188	If FDisplayFormat=Nil Then Result:=LongTimeFormat
2189	Else Result:=FDisplayFormat^;
2190	End;
2191
2192	Procedure TTimeField.SetDisplayFormat(Const NewValue:String);
2193	Begin
2194	AssignStr(FDisplayFormat,NewValue);
2195	If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2196	End;
2197
2198	Function TTimeField.GetAsVariant:Variant;
2199	Begin
2200	Result:=GetAsDateTime;
2201	End;
2202
2203	Procedure TTimeField.SetAsVariant(NewValue:Variant);
2204	Begin
2205	SetAsDateTime(NewValue);
2206	End;
2207
2208
2209	Function TTimeField.GetAsString:String;
2210	Var Time:TDateTime;
2211	Begin
2212	If FValue<>Nil Then
2213	Begin
2214	Time:=GetAsDateTime;
2215	DateTimeToString(Result,DisplayFormat,Time);
2216	End
2217	Else Result:='';
2218	End;
2219
2220	Procedure TTimeField.SetAsString(Const NewValue:String);
2221	Var dt:TDateTime;
2222	Valid:Boolean;
2223	Begin
2224	If NewValue <> '' Then
2225	Begin
2226	Try
2227	dt:=StrToTime(NewValue);
2228	Valid:=True;
2229	Except
2230	Valid:=False;
2231	End;
2232	If Valid Then SetAsDateTime(dt);
2233	End
2234	Else Clear;
2235	End;
2236
2237	Function TTimeField.GetAsAnsiString:AnsiString;
2238	Begin
2239	Result:=GetAsString;
2240	End;
2241
2242	Procedure TTimeField.SetAsAnsiString(NewValue:AnsiString);
2243	Begin
2244	SetAsString(NewValue);
2245	End;
2246
2247	Function TTimeField.GetAsFloat:Extended;
2248	Begin
2249	If FValue<>Nil Then Result:=GetAsDateTime
2250	Else AccessError('Float');
2251	End;
2252
2253
2254	Function TTimeField.GetAsDateTime:TDateTime;
2255	Var Time:TODBCTime;
2256	Begin
2257	If FValue<>Nil Then
2258	Begin
2259	Time:=TODBCTime(FValue^);
2260	Result:=EncodeTime(Time.Hour,Time.Minute,Time.Second,0);
2261	End
2262	Else AccessError('DateTime');
2263	End;
2264
2265	Procedure TTimeField.SetAsDateTime(NewValue:TDateTime);
2266	Var R:TODBCTime;
2267	Begin
2268	RoundDecodeTime(NewValue,R.Hour,R.Minute,R.Second);
2269	SetNewValue(R,SizeOf(R));
2270	End;
2271
2272	{
2273	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2274	º º
2275	º Speed-Pascal/2 Version 2.0 º
2276	º º
2277	º Speed-Pascal Component Classes (SPCC) º
2278	º º
2279	º This section: TDateTimeField Class Implementation º
2280	º º
2281	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2282	º º
2283	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2284	}
2285
2286
2287	Destructor TDateTimeField.Destroy;
2288	Begin
2289	AssignStr(FDisplayFormat,'');
2290	Inherited Destroy;
2291	End;
2292
2293	Function TDateTimeField.GetDisplayFormat:String;
2294	Begin
2295	If FDisplayFormat=Nil Then Result:=ShortDateFormat+' '+LongTimeFormat
2296	Else Result:=FDisplayFormat^;
2297	End;
2298
2299	Procedure TDateTimeField.SetDisplayFormat(Const NewValue:String);
2300	Begin
2301	AssignStr(FDisplayFormat,NewValue);
2302	If FDataSet<>Nil Then FDataSet.DataChange(deDataBaseChanged);
2303	End;
2304
2305	Function TDateTimeField.GetAsVariant:Variant;
2306	Begin
2307	Result:=GetAsDateTime;
2308	End;
2309
2310	Procedure TDateTimeField.SetAsVariant(NewValue:Variant);
2311	Begin
2312	SetAsDateTime(NewValue);
2313	End;
2314
2315
2316	Function TDateTimeField.GetAsString:String;
2317	Var DateTime:TDateTime;
2318	Begin
2319	If FValue<>Nil Then
2320	Begin
2321	DateTime:=GetAsDateTime;
2322	DateTimeToString(result,DisplayFormat,DateTime);
2323	End
2324	Else Result:='';
2325	End;
2326
2327	Procedure TDateTimeField.SetAsString(Const NewValue:String);
2328	Var dt:TDateTime;
2329	Valid:Boolean;
2330	Begin
2331	If NewValue <> '' Then
2332	Begin
2333	Try
2334	dt:=StrToDateTime(NewValue);
2335	Valid:=True;
2336	Except
2337	Valid:=False;
2338	End;
2339	If Valid Then SetAsDateTime(dt);
2340	End
2341	Else Clear;
2342	End;
2343
2344	Function TDateTimeField.GetAsAnsiString:AnsiString;
2345	Begin
2346	Result:=GetAsString;
2347	End;
2348
2349	Procedure TDateTimeField.SetAsAnsiString(NewValue:AnsiString);
2350	Begin
2351	SetAsString(NewValue);
2352	End;
2353
2354	Function TDateTimeField.GetAsFloat:Extended;
2355	Begin
2356	If FValue<>Nil Then Result:=GetAsDateTime
2357	Else AccessError('Float');
2358	End;
2359
2360	Function TDateTimeField.GetAsDateTime:TDateTime;
2361	Var dt:TODBCDateTime;
2362	Begin
2363	If FValue<>Nil Then
2364	Begin
2365	dt:=TODBCDateTime(FValue^);
2366	Result:=EncodeDate(dt.Date.Year,dt.Date.Month,dt.Date.Day) +
2367	EncodeTime(dt.Time.Hour,dt.Time.Minute,dt.Time.Second,0);
2368	End
2369	Else AccessError('DateTime');
2370	End;
2371
2372	Procedure TDateTimeField.SetAsDateTime(NewValue:TDateTime);
2373	Var R:TODBCDateTime;
2374	Begin
2375	DecodeDate(NewValue,R.Date.Year,R.Date.Month,R.Date.Day);
2376	RoundDecodeTime(NewValue,R.Time.Hour,R.Time.Minute,R.Time.Second);
2377	SetNewValue(R,SizeOf(R));
2378	End;
2379
2380	{
2381	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2382	º º
2383	º Speed-Pascal/2 Version 2.0 º
2384	º º
2385	º Speed-Pascal Component Classes (SPCC) º
2386	º º
2387	º This section: TBlobField Class Implementation º
2388	º º
2389	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2390	º º
2391	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2392	}
2393
2394	Function TBlobField.GetAsString:String;
2395	Begin
2396	If FValue <> Nil Then Result := '[Blob]'
2397	Else Result := '[BLOB]';
2398	End;
2399
2400	Function TBlobField.GetAsAnsiString:AnsiString;
2401	Begin
2402	Result := GetAsString;
2403	End;
2404
2405	Procedure TBlobField.LoadFromStream(Stream:TStream);
2406	Var prec:^Byte;
2407	Begin
2408	If Stream Is TStream Then
2409	Begin
2410	GetMem(prec, Stream.Size);
2411	Stream.Position := 0;
2412	Stream.Read(prec^,Stream.Size);
2413	SetAsValue(prec^, Stream.Size);
2414	FreeMem(prec, Stream.Size);
2415	End;
2416	End;
2417
2418	{
2419	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2420	º º
2421	º Speed-Pascal/2 Version 2.0 º
2422	º º
2423	º Speed-Pascal Component Classes (SPCC) º
2424	º º
2425	º This section: TMemoField Class Implementation º
2426	º º
2427	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2428	º º
2429	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2430	}
2431
2432	Function TMemoField.GetAsString:String;
2433	Begin
2434	If FValue <> Nil Then Result := '[Memo]'
2435	Else Result := '[MEMO]';
2436	End;
2437
2438	Function TMemoField.GetAsAnsiString:AnsiString;
2439	Begin
2440	If FValue = Nil Then Result := ''
2441	Else Result := PChar(FValue)^;
2442	End;
2443
2444	Procedure TMemoField.SetAsAnsiString(NewValue:AnsiString);
2445	Begin
2446	If NewValue <> '' Then
2447	Begin
2448	SetNewValue(PChar(NewValue)^,length(PChar(NewValue)^)+1);
2449	End
2450	Else Clear;
2451	End;
2452
2453	{
2454	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2455	º º
2456	º Speed-Pascal/2 Version 2.0 º
2457	º º
2458	º Speed-Pascal Component Classes (SPCC) º
2459	º º
2460	º This section: TGraphicField Class Implementation º
2461	º º
2462	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2463	º º
2464	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2465	}
2466
2467	Function TGraphicField.GetAsString:String;
2468	Begin
2469	If FValue<>Nil Then Result:='[Graphic]'
2470	Else Result:='[GRAPHIC]';
2471	End;
2472
2473	{
2474	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2475	º º
2476	º Speed-Pascal/2 Version 2.0 º
2477	º º
2478	º Speed-Pascal Component Classes (SPCC) º
2479	º º
2480	º This section: TFieldList Class Implementation º
2481	º º
2482	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2483	º º
2484	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2485	}
2486
2487	Procedure TFieldList.Clear;
2488	Var T:LongInt;
2489	field:TField;
2490	Begin
2491	For T:=0 To Count-1 Do
2492	Begin
2493	field:=Items[T];
2494	field.Destroy;
2495	End;
2496	Inherited Clear;
2497	End;
2498
2499
2500
2501	{
2502	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2503	º º
2504	º Speed-Pascal/2 Version 2.0 º
2505	º º
2506	º Speed-Pascal Component Classes (SPCC) º
2507	º º
2508	º This section: TIndexDef Class Implementation º
2509	º º
2510	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2511	º º
2512	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2513	}
2514
2515	Function TIndexDef.GetName:String;
2516	Begin
2517	If FName<>Nil Then Result:=FName^
2518	Else Result:='';
2519	End;
2520
2521	Function TIndexDef.GetFields:String;
2522	Begin
2523	If FFields<>Nil Then Result:=FFields^
2524	Else Result:='';
2525	End;
2526
2527	Constructor TIndexDef.Create(Owner:TIndexDefs;Const Name, Fields:String;Options:TIndexOptions);
2528	Begin
2529	Inherited Create;
2530
2531	If Owner <> Nil Then
2532	Begin
2533	Owner.FItems.Add(Self);
2534	FOwner:=Owner;
2535	End;
2536
2537	AssignStr(FName,Name);
2538	AssignStr(FFields,Fields);
2539	FOptions:=Options;
2540	End;
2541
2542	Destructor TIndexDef.Destroy;
2543	Begin
2544	If FOwner <> Nil Then FOwner.FItems.Remove(Self);
2545
2546	AssignStr(FName,'');
2547	AssignStr(FFields,'');
2548
2549	Inherited Destroy;
2550	End;
2551
2552	{
2553	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2554	º º
2555	º Speed-Pascal/2 Version 2.0 º
2556	º º
2557	º Speed-Pascal Component Classes (SPCC) º
2558	º º
2559	º This section: TIndexDefs Class Implementation º
2560	º º
2561	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2562	º º
2563	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2564	}
2565
2566	Function TIndexDefs.GetCount:LongInt;
2567	Begin
2568	Result:=FItems.Count;
2569	End;
2570
2571	Function TIndexDefs.GetItem(Index:LongInt):TIndexDef;
2572	Begin
2573	Result:=TIndexDef(FItems[Index]);
2574	End;
2575
2576	Constructor TIndexDefs.Create(DataSet:TDataSet);
2577	Begin
2578	Inherited Create;
2579	FDataSet:=DataSet;
2580	FItems.Create;
2581	End;
2582
2583	Destructor TIndexDefs.Destroy;
2584	Begin
2585	Clear;
2586	FItems.Destroy;
2587	Inherited Destroy;
2588	End;
2589
2590	Procedure TIndexDefs.Clear;
2591	Var IndexDef:TIndexDef;
2592	Begin
2593	While FItems.Count > 0 Do
2594	Begin
2595	IndexDef := TIndexDef(FItems[0]);
2596	IndexDef.Destroy; // auto removing from FItems
2597	End;
2598	End;
2599
2600	Function TIndexDefs.Add(Const Name,Fields:String;Options:TIndexOptions):TIndexDef;
2601	Begin
2602	//...check valid
2603	Result.Create(Self, Name, Fields,Options);
2604	End;
2605
2606	Procedure TIndexDefs.Assign(IndexDefs: TIndexDefs);
2607	Var IndexDef:TIndexDef;
2608	t:LongInt;
2609	Begin
2610	Clear;
2611	For t:=0 To IndexDefs.Count-1 Do
2612	Begin
2613	IndexDef:=IndexDefs.Items[t];
2614	Add(IndexDef.Name,IndexDef.Fields,IndexDef.Options);
2615	End;
2616	End;
2617
2618	Function TIndexDefs.FindIndexForFields(Const Fields:String):TIndexDef;
2619	Begin
2620	Result:=GetIndexForFields(Fields,False);
2621	If Result=Nil Then DataBaseError('No index for fields: '+Fields);
2622	End;
2623
2624	Function TIndexDefs.GetIndexForFields(Const Fields:String;CaseInsensitive:Boolean):TIndexDef;
2625	Var t:LongInt;
2626	s,s1:String;
2627	Begin
2628	s:=Fields;
2629	If CaseInsensitive Then UpcaseStr(s);
2630	Result:=Nil;
2631	For t:=0 To Count-1 Do
2632	Begin
2633	s1:=Items[t].Fields;
2634	If CaseInsensitive Then UpcaseStr(s1);
2635	If s=s1 Then
2636	Begin
2637	Result:=Items[t];
2638	exit;
2639	End;
2640	End;
2641	End;
2642
2643	Function TIndexDefs.IndexOf(Const Name:String):LongInt;
2644	Var t:LongInt;
2645	Begin
2646	Result:=-1;
2647	For t:=0 To Count-1 Do If Items[t].Name=Name Then
2648	Begin
2649	Result:=t;
2650	exit;
2651	End;
2652	End;
2653
2654	Procedure TIndexDefs.Update;
2655	Begin
2656	TTable(FDataSet).UpdateIndexDefs;
2657	End;
2658
2659	{
2660	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2661	º º
2662	º Speed-Pascal/2 Version 2.0 º
2663	º º
2664	º Speed-Pascal Component Classes (SPCC) º
2665	º º
2666	º This section: TFieldDef Class Implementation º
2667	º º
2668	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2669	º º
2670	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2671	}
2672
2673	Constructor TFieldDef.Create(aOwner:TFieldDefs; Const aName:String;
2674	aDataType:TFieldType; aSize:Longword; aRequired:Boolean; aFieldNo:Longint);
2675	Begin
2676	Inherited Create;
2677
2678	If aOwner <> Nil Then
2679	Begin
2680	aFieldNo := aOwner.FItems.Add(Self);
2681	FOwner := aOwner;
2682	End;
2683
2684	FName := aName;
2685	FDataType := aDataType;
2686	FSize := aSize;
2687	If aDataType = ftString Then Inc(FSize);
2688	FRequired := aRequired;
2689	FFieldNo := aFieldNo;
2690	FPrecision := -1;
2691	If FDataType In [ftWord,ftInteger,ftSmallInt] Then
2692	If not (FSize In [1,2,4]) Then FSize:=4; //LongInt
2693	If FDataType=ftFloat Then
2694	If not (FSize In [4,8,10]) Then FSize:=10; //Extended
2695	FFields.Create;
2696	End;
2697
2698	Function TFieldDef.GetTypeName:String;
2699	Begin
2700	If FTypeName=Nil Then
2701	Begin
2702	Result:='';
2703	If FOwner.FDataSet Is TTable Then
2704	Result:=TTable(FOwner.FDataSet).DataType2Name(FDataType);
2705	End
2706	Else Result:=FTypeName^;
2707	End;
2708
2709	Procedure TFieldDef.SetTypeName(Const NewValue:String);
2710	Begin
2711	AssignStr(FTypeName,NewValue);
2712	End;
2713
2714	Destructor TFieldDef.Destroy;
2715	Var i:Longint;
2716	Field:TField;
2717	Begin
2718	If FOwner <> Nil Then FOwner.FItems.Remove(Self);
2719
2720	If FFields <> Nil Then
2721	Begin
2722	For i := 0 To FFields.Count-1 Do
2723	Begin
2724	Field := TField(FFields[i]);
2725	If Field <> Nil Then Field.Destroy;
2726	End;
2727	End;
2728
2729	AssignStr(FForeignKey,'');
2730	AssignStr(FTypeName,'');
2731
2732	FFields.Destroy;
2733	FFields := Nil;
2734
2735	Inherited Destroy;
2736	End;
2737
2738
2739	Function TFieldDef.CreateField(Owner:TComponent):TField;
2740	Var FieldClass:TFieldClass;
2741	Begin
2742	FieldClass := GetFieldClass;
2743	If FieldClass = Nil Then DatabaseError('Unknown field type "'+Name+'"');
2744
2745	Result := FieldClass.Create;
2746	Try
2747	Result.FFieldDef := Self;
2748	Result.FRequired := Required;
2749	Result.FSize := Size;
2750	Result.FDataType := FDataType;
2751	If Result Is TFloatField Then
2752	Begin
2753	TFloatField(Result).FPrecision := Precision;
2754	If not (Size In [4,8]) Then
2755	Begin
2756	Size:=8;
2757	Result.FSize:=8;
2758	End;
2759	End;
2760	If FOwner <> Nil Then Result.FDataSet := FOwner.FDataSet;
2761	GetMem(Result.FValue,Size);
2762	Result.FValueLen := Size;
2763	Except;
2764	Result.Free;
2765	Raise;
2766	End;
2767	End;
2768
2769
2770	Function TFieldDef.GetFieldClass:TFieldClass;
2771	Begin
2772	Result := FOwner.FDataSet.GetFieldClass(FDataType);
2773	End;
2774
2775
2776	Function TFieldDef.GetPrimaryKey:Boolean;
2777	Var Keys:TStrings;
2778	t:LongInt;
2779	Begin
2780	If (Not (FOwner.FDataSet.IsTable)) Then
2781	DataBaseError('Cannot perform this action on a query or stored procedure');
2782
2783	Result:=False;
2784	If FOwner.FDataSet.Active Then
2785	Begin
2786	Keys.Create;
2787	TTable(FOwner.FDataSet).GetPrimaryKeys(Keys);
2788	For t:=0 To Keys.Count-1 Do
2789	If Keys[t]=Name Then
2790	Begin
2791	Keys.Destroy;
2792	Result:=True;
2793	exit;
2794	End;
2795	Keys.Destroy;
2796	End
2797	Else Result:=FPrimaryKey;
2798	End;
2799
2800	Procedure TFieldDef.SetPrimaryKey(NewValue:Boolean);
2801	Begin
2802	If (Not (FOwner.FDataSet.IsTable)) Then
2803	DataBaseError('Cannot perform this action on a query or stored procedure');
2804
2805	FPrimaryKey:=NewValue;
2806	If FOwner.FDataSet.Active Then //Modify table definition
2807	Begin
2808	End;
2809	End;
2810
2811	Function TFieldDef.GetForeignKey:String;
2812	Var Keys:TStrings;
2813	t:LongInt;
2814	s:String;
2815	Begin
2816	If (Not (FOwner.FDataSet.IsTable)) Then
2817	DataBaseError('Cannot perform this action on a query or stored procedure');
2818
2819	If FOwner.FDataSet.Active Then
2820	Begin
2821	Keys.Create;
2822	TTable(FOwner.FDataSet).GetForeignKeys(Keys);
2823	For t:=0 To Keys.Count-1 Do
2824	Begin
2825	s:=Keys[t];
2826	If Pos('>',s)<>0 Then s[0]:=chr(pos('>',s)-1);
2827	If s=Name Then
2828	Begin
2829	Keys.Destroy;
2830	s:=Keys[t];
2831	Delete(s,1,pos('>',s));
2832	Result:=s;
2833	exit;
2834	End;
2835	End;
2836	Keys.Destroy;
2837	End
2838	Else
2839	Begin
2840	If FForeignKey<>Nil Then Result:=FForeignKey^
2841	Else Result:='';
2842	End;
2843	End;
2844
2845	Procedure TFieldDef.SetForeignKey(Const NewValue:String);
2846	Begin
2847	If (Not (FOwner.FDataSet.IsTable)) Then
2848	DataBaseError('Cannot perform this action on a query or stored procedure');
2849
2850	AssignStr(FForeignKey,NewValue);
2851	If FOwner.FDataSet.Active Then //modify table definition
2852	Begin
2853	End;
2854	End;
2855
2856	{
2857	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2858	º º
2859	º Speed-Pascal/2 Version 2.0 º
2860	º º
2861	º Speed-Pascal Component Classes (SPCC) º
2862	º º
2863	º This section: TFieldDefs Class Implementation º
2864	º º
2865	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2866	º º
2867	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2868	}
2869
2870	Constructor TFieldDefs.Create(DataSet:TDataSet);
2871	Begin
2872	Inherited Create;
2873
2874	FDataSet := DataSet;
2875	FItems.Create;
2876	End;
2877
2878
2879	Destructor TFieldDefs.Destroy;
2880	Begin
2881	Clear;
2882	FItems.Destroy;
2883
2884	Inherited Destroy;
2885	End;
2886
2887
2888	Function TFieldDefs.Rows:LongInt;
2889	Var FieldDef:TFieldDef;
2890	Begin
2891	Result := 0;
2892	If Count = 0 Then Exit;
2893	FieldDef := Items[0];
2894	Result := FieldDef.Fields.Count;
2895	End;
2896
2897
2898	Procedure TFieldDefs.Clear;
2899	Var FieldDef:TFieldDef;
2900	Begin
2901	While FItems.Count > 0 Do
2902	Begin
2903	FieldDef := TFieldDef(FItems[0]);
2904	FieldDef.Destroy; // auto removing from FItems
2905	End;
2906	End;
2907
2908
2909	Function TFieldDefs.GetCount:Longint;
2910	Begin
2911	Result := FItems.Count;
2912	End;
2913
2914
2915	Function TFieldDefs.GetItem(Index:Longint):TFieldDef;
2916	Begin
2917	Result := FItems[Index];
2918	End;
2919
2920
2921	Function TFieldDefs.Add(Const Name:String; DataType:TFieldType; Size:Longint; Required:Boolean):TFieldDef;
2922	Begin
2923	//...check valid
2924	Result.Create(Self, Name, DataType, Size, Required, FItems.Count);
2925	End;
2926
2927	Procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
2928	Var FieldDef:TFieldDef;
2929	t:LongInt;
2930	Begin
2931	Clear;
2932	For t:=0 To FieldDefs.Count-1 Do
2933	Begin
2934	FieldDef:=Items[t];
2935	Add(FieldDef.Name,FieldDef.DataType,FieldDef.Size,FieldDef.Required);
2936	End;
2937	End;
2938
2939	Function TFieldDefs.Find(const Name: string): TFieldDef;
2940	Var Index:LongInt;
2941	Begin
2942	Index:=IndexOf(Name);
2943	If Index=-1 Then SQLError('Field not found: '+Name)
2944	Else Result:=Items[Index];
2945	End;
2946
2947	Function TFieldDefs.IndexOf(const Name: string): LongInt;
2948	Var t:LongInt;
2949	Begin
2950	Result:=-1;
2951	For t:=0 To Count-1 Do If Items[t].Name=Name Then
2952	Begin
2953	Result:=t;
2954	exit;
2955	End;
2956	End;
2957
2958	Procedure TFieldDefs.Update;
2959	Begin
2960	FDataSet.QueryTable;
2961	End;
2962
2963	{
2964	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
2965	º º
2966	º Speed-Pascal/2 Version 2.0 º
2967	º º
2968	º Speed-Pascal Component Classes (SPCC) º
2969	º º
2970	º This section: TDataSet Class Implementation º
2971	º º
2972	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
2973	º º
2974	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
2975	}
2976
2977	Const
2978	DefaultFieldClasses:Array[TFieldType] Of TFieldClass=
2979	(TBlobField, {ftUnknown}
2980	TStringField, {ftString}
2981	TSmallintField, {ftSmallInt}
2982	TIntegerField, {ftInteger}
2983	TBlobField, {ftWord}
2984	TBlobField, {ftBoolean}
2985	TFloatField, {ftFloat}
2986	TCurrencyField, {ftCurrency}
2987	TBlobField, {ftBCD}
2988	TDateField, {ftDate}
2989	TTimeField, {ftTime}
2990	TDateTimeField, {ftDateTime}
2991	TBlobField, {ftBytes}
2992	TBlobField, {ftVarBytes}
2993	TAutoIncField, {ftAutoInc}
2994	TBlobField, {ftBlob}
2995	TMemoField, {ftMemo}
2996	TGraphicField, {ftGraphic}
2997	TMemoField, {ftFmtMemo}
2998	TBlobField, {ftTypedBinary}
2999	TBlobField {ftOLE}
3000	);
3001
3002
3003	Procedure TDataSet.SetupComponent;
3004	Begin
3005	Include(ComponentState, csHandleLinks);
3006
3007	AssignStr(FDataBase,'');
3008	AssignStr(FServer,'');
3009
3010	Inherited SetupComponent;
3011
3012	Name:='DataSet';
3013	FFieldDefs.Create(Self);
3014	FSelect:=TStringList.Create;
3015	FCurrentRow:=-1;
3016	FCurrentField:=0;
3017	End;
3018
3019	Destructor TDataSet.Destroy;
3020	Begin
3021	FFieldDefs.Destroy;
3022	FFieldDefs:=Nil;
3023	AssignStr(FServer,'');
3024	AssignStr(FDataBase,'');
3025	FSelect.Destroy;
3026	FSelect:=Nil;
3027
3028	Inherited Destroy;
3029	End;
3030
3031
3032	Function TDataSet.GetFieldClass(FieldType:TFieldType):TFieldClass;
3033	Begin
3034	Result := DefaultFieldClasses[FieldType];
3035	End;
3036
3037
3038	Procedure TDataSet.DesignerNotification(Var DNS:TDesignerNotifyStruct);
3039	Var AForm:TForm;
3040	Begin
3041	AForm := TForm(Owner);
3042	If AForm <> Nil Then
3043	Begin
3044	While (AForm.Designed) And (AForm.Owner <> Nil) Do
3045	Begin
3046	AForm := TForm(AForm.Owner);
3047	End;
3048	End;
3049	If AForm <> Nil Then
3050	If AForm Is TForm Then AForm.DesignerNotification(DNS);
3051	End;
3052
3053
3054	Function TDataSet.Locate(Const KeyFields:String;Const KeyValues:Array Of Const;
3055	Options:TLocateOptions):Boolean;
3056	Begin
3057	Result := False;
3058	//???
3059	End;
3060
3061
3062	Procedure TDataSet.SetFieldDefs(NewValue:TFieldDefs);
3063	Begin
3064	FFieldDefs.Assign(NewValue);
3065	End;
3066
3067
3068	Procedure TDataSet.GetStoredProcNames(List:TStrings);
3069	Begin
3070	List.Clear;
3071	End;
3072
3073
3074	Procedure TDataSet.Open;
3075	Begin
3076	Active := True;
3077	End;
3078
3079
3080	Procedure TDataSet.Close;
3081	Begin
3082	Active := False;
3083	End;
3084
3085
3086	Procedure TDataSet.SetActive(NewValue:Boolean);
3087	Begin
3088	If FActive <> NewValue Then
3089	Begin
3090	FActive := NewValue;
3091	DataChange(deDataBaseChanged);
3092	End;
3093	End;
3094
3095
3096	Procedure TDataSet.SetCurrentRow(NewValue:LongInt);
3097	Begin
3098	MoveBy(NewValue-FCurrentRow);
3099	End;
3100
3101
3102	Procedure TDataSet.SetCurrentField(NewValue:LongInt);
3103	Begin
3104	If NewValue<0 Then NewValue:=0;
3105	If NewValue>FieldCount-1 Then NewValue:=FieldCount-1;
3106	FCurrentField:=NewValue;
3107	End;
3108
3109
3110	Function TDataSet.GetEOF:Boolean;
3111	Begin
3112	Result := GetResultColRow(0,FCurrentRow+1) = Nil;
3113	End;
3114
3115
3116	Function TDataSet.GetBOF:Boolean;
3117	Begin
3118	Result := FCurrentRow <= 0;
3119	End;
3120
3121
3122	Function TDataSet.GetMaxRows:LongInt;
3123	Begin
3124	Result := FMaxRows;
3125	If RowInserted Then inc(Result);
3126	End;
3127
3128
3129	Procedure TDataSet.Refresh;
3130	Begin
3131	DataChange(deDataBaseChanged);
3132	End;
3133
3134
3135	Procedure TDataSet.DataChange(event:TDataChange);
3136	Var I:LongInt;
3137	Source:TDataSource;
3138	FLinkList:TList;
3139	Begin
3140	If FDataChangeLock Then Exit;
3141
3142	FLinkList:=FreeNotifyList;
3143	If FLinkList<>Nil Then For I:=0 To FLinkList.Count-1 Do
3144	Begin
3145	Source:=FLinkList.Items[I];
3146	If Source Is TDataSource Then
3147	Begin
3148	Source.DataChange(event);
3149	If Source.OnDataChange<>Nil Then Source.OnDataChange(Source,event);
3150	End;
3151	End;
3152	End;
3153
3154
3155	Procedure TDataSet.First;
3156	Begin
3157	SetCurrentRow(0);
3158	End;
3159
3160
3161	Procedure TDataSet.Last;
3162	Begin
3163	SetCurrentRow(MaxRows-1);
3164	End;
3165
3166
3167	Procedure TDataSet.Next;
3168	Begin
3169	SetCurrentRow(FCurrentRow+1);
3170	End;
3171
3172
3173	Procedure TDataSet.Prior;
3174	Begin
3175	SetCurrentRow(FCurrentRow-1);
3176	End;
3177
3178
3179	Procedure TDataSet.MoveBy(Distance:LongInt);
3180	Var Field:TField;
3181	FieldDef:TFieldDef;
3182	Begin
3183	If Distance = 0 Then Exit;
3184	If FFieldDefs.Count = 0 Then exit;
3185
3186	If FRowIsInserted Then CommitInsert(True);
3187
3188	FCurrentRow := FCurrentRow + Distance;
3189	If FCurrentRow < 0 Then FCurrentRow := 0;
3190	If FCurrentRow >= MaxRows Then FCurrentRow := MaxRows-1;
3191
3192	Field := GetResultColRow(0,FCurrentRow);
3193
3194	FieldDef := FFieldDefs[0];
3195
3196	If FieldDef <> Nil Then
3197	Begin
3198	If FCurrentRow > FieldDef.Fields.Count-1
3199	Then FCurrentRow := FieldDef.Fields.Count-1;
3200	If FCurrentRow < 0 Then FCurrentRow := 0;
3201	End;
3202
3203	DataChange(dePositionChanged);
3204	End;
3205
3206
3207	Function TDataSet.WriteSCUResource(Stream:TResourceStream):Boolean;
3208	Var S:String;
3209	dll:String;
3210	P,p1:Pointer;
3211	len:LongInt;
3212	dbType:TDBTypes;
3213	dbOrd:LongInt;
3214	DriverName,Advanced,UID:String;
3215	Begin
3216	S:=Server;
3217	GetDBServerFromAlias(S,dll,dbType);
3218	dbOrd:=ord(dbType);
3219
3220	len:=Length(S)+1+Length(dll)+1+4;
3221	GetMem(P,len);
3222	p1:=P;
3223	Move(S,p1^,Length(S)+1);
3224	Inc(p1,Length(S)+1);
3225	Move(dll,p1^,Length(dll)+1);
3226	inc(p1,length(dll)+1);
3227	Move(dbOrd,p1^,4);
3228	Result:=Stream.NewResourceEntry(rnDBServer,P^,len);
3229	FreeMem(P,len);
3230	If Not Result Then Exit;
3231
3232	S:=DataBase;
3233	GetDBServerFromDBAlias(S,DriverName,Advanced,UID);
3234	len:=Length(S)+1+Length(Advanced)+1+length(UID)+1;
3235	GetMem(P,len);
3236	p1:=P;
3237	Move(S,p1^,Length(S)+1);
3238	Inc(p1,Length(S)+1);
3239	Move(Advanced,p1^,Length(Advanced)+1);
3240	Inc(p1,Length(Advanced)+1);
3241	Move(UID,p1^,Length(UID)+1);
3242	Result:=Stream.NewResourceEntry(rnDBDataBase,S,Length(S)+1);
3243	FreeMem(P,len);
3244	End;
3245
3246
3247	Procedure TDataSet.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
3248	Var
3249	S,dll:String;
3250	B:^Byte;
3251	dbType:TDBTypes;
3252	Advanced,UID:String;
3253	Begin
3254	If ResName = rnDBServer Then
3255	Begin
3256	dbType:=ODBC;
3257
3258	B:=@Data;
3259	Move(B^,S,B^+1);
3260	Inc(B,B^+1);
3261	Move(B^,dll,B^+1);
3262
3263	If DataLen>length(S)+1+length(dll)+1 Then //Sibyl FP3
3264	Begin
3265	inc(B,length(dll)+1);
3266	move(B^,dbType,sizeof(dbType));
3267	End;
3268
3269	AddServerAlias(S,dll,dbType);
3270	Server:=S;
3271	End;
3272
3273	If ResName = rnDBDataBase Then
3274	Begin
3275	Advanced:='';
3276	UID:='';
3277
3278	B:=@Data;
3279	Move(B^,S,B^+1);
3280	Inc(B,B^+1);
3281	If DataLen>length(S)+1 Then //Sibyl FP3
3282	Begin
3283	Move(B^,Advanced,B^+1);
3284	Inc(B,B^+1);
3285	Move(B^,UID,B^+1);
3286	End;
3287
3288	AddDataBaseAlias(S,Server,Advanced,UID);
3289	DataBase:=S;
3290	End;
3291	End;
3292
3293
3294	Function TDataSet.GetDataBaseName:String;
3295	Begin
3296	Result:=FDataBase^;
3297	End;
3298
3299
3300	Procedure TDataSet.SetDataBaseName(Const NewValue:String);
3301	Var Alias,Advanced,UID,DllName:String;
3302	DNS:TDesignerNotifyStruct;
3303	Begin
3304	If GetDataBaseName=NewValue Then Exit;
3305
3306	If FOpened Then
3307	If GetDataBaseName<>'' Then
3308	Begin
3309	ErrorBox(LoadNLSStr(SCannotPerformDBAction));
3310	Exit;
3311	End;
3312
3313	AssignStr(FDataBase,NewValue);
3314
3315	FreeDBProcs(FDBProcs);
3316	FDBProcs.DataBase:=NewValue;
3317
3318	GetDBServerFromDBAlias(NewValue,Alias,Advanced,UID);
3319	If Alias<>'' Then If Alias<>Server Then
3320	Begin
3321	AssignStr(FServer, Alias);
3322	FDBProcs.AliasName:=Alias;
3323	End;
3324	If ComponentState*[csReading]=[] Then FDBProcs.UID:=UID
3325	Else If FDBProcs.UID='' Then FDBProcs.UID:=UID;
3326	GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType);
3327
3328	Case FDBProcs.DBType Of
3329	Native_mSQL:
3330	Begin
3331	If ComponentState*[csReading]=[] Then FDBProcs.Host:=Advanced
3332	Else If FDBProcs.Host='' Then FDBProcs.Host:=Advanced;
3333	End;
3334	End;
3335
3336	If Self Is TTable Then If ComponentState*[csReading]=[] Then
3337	Begin
3338	TTable(Self).TableName:='';
3339	TTable(Self).UserId:='';
3340	TTable(Self).Password:='';
3341	End;
3342
3343	DNS.Sender := Self;
3344	DNS.Code := dncPropertyUpdate;
3345	DNS.return := 0;
3346	DesignerNotification(DNS);
3347	End;
3348
3349
3350	Function TDataSet.GetServer:String;
3351	Begin
3352	Result:=FServer^;
3353	End;
3354
3355
3356	Procedure TDataSet.SetServer(Const NewValue:String);
3357	Var WasLocked:Boolean;
3358	DllName:String;
3359	DNS:TDesignerNotifyStruct;
3360	Begin
3361	If GetServer=NewValue Then Exit;
3362
3363	If FOpened Then
3364	Begin
3365	ErrorBox(LoadNLSStr(SCannotPerformDBAction));
3366	Exit;
3367	End;
3368
3369	FreeDBProcs(FDBProcs);
3370
3371	AssignStr(FServer,NewValue);
3372
3373	FDBProcs.AliasName:=NewValue;
3374	GetDBServerFromAlias(FDBProcs.AliasName,DllName,FDBProcs.DBType);
3375
3376	WasLocked:=FDataSetLocked;
3377	FDataSetLocked:=True;
3378
3379	AssignStr(FDataBase,'');
3380
3381	If Self Is TTable Then AssignStr(TTable(Self).FTableName,'');
3382
3383	FDataSetLocked:=WasLocked;
3384
3385	If ComponentState*[csReading]=[] Then
3386	Begin
3387	FDBProcs.UID:='';
3388	FDBProcs.Host:='';
3389	End;
3390	DNS.Sender := Self;
3391	DNS.Code := dncPropertyUpdate;
3392	DNS.return := 0;
3393	DesignerNotification(DNS);
3394	End;
3395
3396
3397	Function TDataSet.GetFieldCount:LongInt;
3398	Begin
3399	Result:=FFieldDefs.Count;
3400	End;
3401
3402
3403	Function TDataSet.GetFieldName(Index:LongInt):String;
3404	Var FieldDef:TFieldDef;
3405	Begin
3406	Result:='';
3407	If ((Index<0)Or(Index>FieldCount-1)) Then Exit;
3408	FieldDef:=FFieldDefs[Index];
3409	Result:=FieldDef.Name;
3410	End;
3411
3412
3413	Function TDataSet.GetFieldType(Index:LongInt):TFieldType;
3414	Var FieldDef:TFieldDef;
3415	Begin
3416	Result:=ftUnknown;
3417	If ((Index<0)Or(Index>FieldCount-1)) Then Exit;
3418	FieldDef:=FFieldDefs[Index];
3419	Result:=FieldDef.DataType;
3420	End;
3421
3422
3423	Function TDataSet.GetFieldFromColumnName(ColumnName:String):TField;
3424	Var Index:LongInt;
3425	T:LongInt;
3426	FieldDef:TFieldDef;
3427	S:String;
3428	Begin
3429	Result:=Nil;
3430	Index:=-1;
3431	UpcaseStr(ColumnName);
3432	For T:=0 To FFieldDefs.Count-1 Do
3433	Begin
3434	FieldDef:=FFieldDefs[T];
3435	S:=FieldDef.Name;
3436	UpcaseStr(S);
3437	If S=ColumnName Then
3438	Begin
3439	Index:=T;
3440	break;
3441	End;
3442	End;
3443
3444	If Index<>-1 Then Result:=Fields[Index];
3445	End;
3446
3447
3448	Procedure TDataSet.CheckRequiredFields;
3449	Var Field:TField;
3450	i:Longint;
3451	Begin
3452	For i := 0 To FieldCount-1 Do
3453	Begin
3454	Field := GetResultColRow(i,FCurrentRow);
3455	If Field<>Nil Then
3456	If Field.Required And Field.IsNull Then
3457	Begin
3458	//Field.FocusControl;
3459	ErrorBox('Field '+ Field.FieldName +' is required');
3460	DatabaseError('Field '+ Field.FieldName +' is required');
3461	End;
3462	End;
3463	End;
3464
3465
3466	Function TDataSet.GetField(Index:LongInt):TField;
3467	Begin
3468	Result:=Nil;
3469	If ((Index<0)Or(Index>FieldCount-1)Or(FCurrentRow<0)) Then Exit;
3470	Result:=GetResultColRow(Index,FCurrentRow);
3471	End;
3472
3473
3474	Function TDataSet.GetResultColRow(Col,Row:LongInt):TField;
3475	Var FieldDef:TFieldDef;
3476	Begin
3477	Result := Nil;
3478	If Not FOpened Then Exit;
3479
3480	If Row < 0 Then Exit; //Row does Not exist
3481	If Row >= GetMaxRows Then Exit; //Row does Not exist
3482	If (Col < 0) Or (Col >= FieldDefs.Count) Then Exit; {Column does Not exist}
3483
3484	FieldDef := FieldDefs[Col];
3485	If Row <= FieldDef.Fields.Count-1
3486	Then Result := FieldDef.Fields.Items[Row];
3487	End;
3488
3489
3490	Procedure TDataSet.AppendRecord(Const values:Array Of Const);
3491	Begin
3492	InsertRecord(values);
3493	End;
3494
3495
3496	Procedure TDataSet.SetFields(Const values:Array Of Const);
3497	Var T:LongInt;
3498	rec:TVarRec;
3499	field:TField;
3500	Begin
3501	Try
3502	FDataChangeLock:=True;
3503	For T:=0 To High(values) Do
3504	Begin
3505	If T>FieldCount-1 Then Exit;
3506	Field:=Fields[T];
3507	If Field=Nil Then continue;
3508
3509	rec:=TVarRec(values[T]);
3510	Case rec.VType Of
3511	vtInteger:field.AsInteger:=rec.VInteger;
3512	vtBoolean:field.AsBoolean:=rec.VBoolean;
3513	vtChar:field.AsString:=rec.VChar;
3514	vtExtended:field.AsFloat:=rec.VExtended^;
3515	vtString:field.AsString:=rec.VString^;
3516	vtPointer:;
3517	vtPChar:field.AsString:=rec.VPChar^;
3518	vtAnsiString:field.AsString:=AnsiString(rec.VAnsiString);
3519	End; {Case}
3520	End;
3521	Finally
3522	FDataChangeLock:=False;
3523	Post;
3524	End;
3525	End;
3526
3527
3528	Procedure TDataSet.InsertRecord(Const values:Array Of Const);
3529	Begin
3530	Try
3531	FDataChangeLock:=True;
3532	Insert;
3533	Finally
3534	FDataChangeLock:=False;
3535	End;
3536	SetFields(values);
3537	End;
3538
3539
3540	Function TDataSet.FieldByName(Const FieldName:String):TField;
3541	Begin
3542	Result:=FindField(FieldName);
3543	If Result=Nil Then DatabaseError('Field '+FieldName+' not found');
3544	End;
3545
3546
3547	Function TDataSet.FindFirst:Boolean;
3548	Begin
3549	Result:=BOF;
3550	End;
3551
3552
3553	Function TDataSet.FindLast:Boolean;
3554	Begin
3555	Result:=EOF;
3556	End;
3557
3558
3559	Function TDataSet.FindNext:Boolean;
3560	Begin
3561	Result:=not EOF;
3562	End;
3563
3564
3565	Function TDataSet.FindPrior:Boolean;
3566	Begin
3567	Result:=not BOF;
3568	End;
3569
3570
3571	Function ExtractFieldName(Const Fields:String;Var Pos:LongInt):String;
3572	Var t:LongInt;
3573	Begin
3574	t:=Pos;
3575	While (t<=Length(Fields))And(Fields[t]<>';') Do Inc(t);
3576	Result:=Copy(Fields,Pos,t-Pos);
3577	If (t<=Length(Fields))And(Fields[t]=';') Then Inc(t);
3578	Pos:=t;
3579	End;
3580
3581
3582	Procedure TDataSet.GetFieldList(List:TList; const FieldNames: string);
3583	Var t:LongInt;
3584	Begin
3585	t:=1;
3586	While t<=Length(FieldNames) Do
3587	List.Add(FieldByName(ExtractFieldName(FieldNames,t)));
3588	End;
3589
3590
3591	Function TDataSet.FindField(Const FieldName:String):TField;
3592	Var T:LongInt;
3593	S,s1:String;
3594	Begin
3595	Result:=Nil;
3596	S:=FieldName;
3597	UpcaseStr(S);
3598	For T:=0 To FieldCount-1 Do
3599	Begin
3600	s1:=FieldNames[T];
3601	UpcaseStr(s1);
3602	If S=s1 Then
3603	Begin
3604	Result:=Fields[T];
3605	Exit;
3606	End;
3607	End;
3608	End;
3609
3610
3611	Procedure TDataSet.DoOpen;
3612	Begin
3613	FOpened := True;
3614	End;
3615
3616
3617	Procedure TDataSet.DoClose;
3618	Begin
3619	If FRowIsInserted Then CommitInsert(True);
3620	FMaxRows:=0;
3621	FCurrentRow := -1;
3622
3623	FOpened := False;
3624	End;
3625
3626
3627	Procedure TDataSet.RefreshTable;
3628	Begin
3629	End;
3630
3631
3632	Procedure TDataSet.GetDataSources(List:TStrings);
3633	Begin
3634	List.Clear;
3635	End;
3636
3637
3638	Procedure TDataSet.GetFieldNames(List:TStrings);
3639	Var T:LongInt;
3640	Begin
3641	List.Clear;
3642
3643	If FieldCount=0 Then
3644	Begin
3645	If ((Designed)And(Not FOpened)) Then
3646	Begin
3647	FActive:=True;
3648	DoOpen;
3649	If Not FOpened Then FActive:=False
3650	Else RefreshTable;
3651	End
3652	Else RefreshTable;
3653	End;
3654
3655	For T:=0 To FieldCount-1 Do List.Add(FieldNames[T]);
3656	End;
3657
3658
3659	Procedure TDataSet.Delete;
3660	Begin
3661	If Not FOpened Then Exit;
3662	If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3663
3664	Try
3665	If FBeforeDelete <> Nil Then FBeforeDelete(Self);
3666
3667	If FRowIsInserted Then CommitInsert(False)
3668	Else DoDelete;
3669
3670	DataChange(deDataBaseChanged);
3671
3672	If FAfterDelete <> Nil Then FAfterDelete(Self);
3673	Except
3674	Raise;
3675	End;
3676	End;
3677
3678
3679	Procedure TDataSet.DoDelete;
3680	Begin
3681	RemoveCurrentFields;
3682	End;
3683
3684
3685	Procedure TDataSet.Append;
3686	Begin
3687	Insert;
3688	End;
3689
3690
3691	Procedure TDataSet.Insert;
3692	Begin
3693	If Not FOpened Then Exit;
3694
3695	Try
3696	If FBeforeInsert <> Nil Then FBeforeInsert(Self);
3697
3698	If FRowIsInserted Then CommitInsert(True);
3699
3700	DoInsert;
3701
3702	DataChange(deDataBaseChanged);
3703
3704	If FAfterInsert <> Nil Then FAfterInsert(Self);
3705	Except
3706	Raise;
3707	End;
3708	End;
3709
3710
3711	Procedure TDataSet.DoInsert;
3712	Begin
3713	If FCurrentRow < 0 Then FCurrentRow := 0; //empty table
3714
3715	InsertCurrentFields;
3716
3717	FRowIsInserted := True;
3718	End;
3719
3720
3721	Procedure TDataSet.InsertCurrentFields;
3722	Var Col,Row:LongInt;
3723	FieldDef:TFieldDef;
3724	Field:TField;
3725	Begin
3726	For Col := 0 To FFieldDefs.Count-1 Do
3727	Begin
3728	FieldDef := FFieldDefs[Col];
3729	Field := FieldDef.CreateField(Nil);
3730	//Field.Clear;
3731	If Field.FValue<>Nil Then FreeMem(Field.FValue,Field.FValueLen);
3732	Field.FValue:=Nil;
3733	Field.FValueLen:=0;
3734	Field.FRow := FCurrentRow;
3735	Field.FCol := Col;
3736	FieldDef.Fields.Insert(FCurrentRow,Field);
3737
3738	For Row := FCurrentRow+1 To FieldDef.Fields.Count-1 Do
3739	Begin
3740	Field := FieldDef.Fields[Row];
3741	If Field <> Nil Then Inc(Field.FRow);
3742	End;
3743	End;
3744	End;
3745
3746
3747	Const Months:Array[1..12] Of String[4]=('Jan','Feb','Mar','Apr','May','Jun','Jul',
3748	'Aug','Sep','Oct','Nov','Dec');
3749
3750	Function Field2String(field:TField):String;
3751	Var
3752	dt:TDateTime;
3753	Year,Month,Day,Hour,Min,Sec:Word;
3754	s,s1,s2:String;
3755	Begin
3756	If field.IsNull Then
3757	Begin
3758	Result:='NULL';
3759	Exit;
3760	End;
3761
3762	Case field.DataType Of
3763	ftDate:
3764	Begin
3765	dt:=field.GetAsDateTime;
3766	DecodeDate(dt,Year,Month,Day);
3767	If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then
3768	Result:=tostr(Day)+'-'+Months[Month]+'-'+tostr(Year)
3769	Else
3770	Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day);
3771	End;
3772	ftTime:
3773	Begin
3774	dt:=field.GetAsDateTime;
3775	RoundDecodeTime(dt,Hour,Min,Sec);
3776	If Field.FDataSet.FDBProcs.DBType=Native_mSQL Then
3777	Result:=tostr(Hour)+':'+tostr(Min)+':'+tostr(Sec)
3778	Else
3779	Result:=tostr(Hour)+'.'+tostr(Min)+'.'+tostr(Sec);
3780	End;
3781	ftDateTime:
3782	Begin
3783	dt:=field.GetAsDateTime;
3784	DecodeDate(dt,Year,Month,Day);
3785	RoundDecodeTime(dt,Hour,Min,Sec);
3786	If Field.FDataSet.FDBProcs.DBType=Native_Oracle7 Then
3787	Begin
3788	s:=tostr(Year);
3789	While length(s)<4 Do s:='0'+s;
3790	s1:=tostr(Month);
3791	If length(s1)<2 Then s1:='0'+s1;
3792	s2:=tostr(Day);
3793	If length(s2)<2 Then s2:='0'+s2;
3794	Result:='TO_DATE('#39+s+'-'+s1+'-'+s2;
3795	s:=tostr(Hour);
3796	If length(s)<2 Then s:='0'+s;
3797	s1:=tostr(Min);
3798	If length(s1)<2 Then s1:='0'+s1;
3799	s2:=tostr(Sec);
3800	If length(s2)<2 Then s2:='0'+s2;
3801	Result:=Result+' '+s+'.'+s1+'.'+s2;
3802	Result:=Result+#39','#39'YYYY-MM-DD HH24.MI.SS'#39')';
3803	exit;
3804	End
3805	Else
3806	Begin
3807	Result:=tostr(Year)+'-'+tostr(Month)+'-'+tostr(Day);
3808	Result:=Result+'-'+tostr(Hour)+'.'+tostr(Min)+'.';
3809	Result:=Result+tostr(Sec)+'.00';
3810	End;
3811	End;
3812	ftMemo:
3813	Begin
3814	Result:=PChar(Field.FValue)^;
3815	End;
3816	ftFloat:
3817	Begin
3818	Result:=field.AsString;
3819	//eliminate decimal separator
3820	If pos(',',Result)<>0 Then Result[pos(',',Result)]:='.';
3821
3822	End;
3823	Else Result:=field.AsString;
3824	End; {Case}
3825
3826	If Not (field.DataType In [ftSmallInt,ftInteger,ftWord,ftFloat,ftCurrency]) Then
3827	Result:=#39+Result+#39;
3828	End;
3829
3830
3831	Procedure TDataSet.CommitInsert(Commit:Boolean);
3832	Begin
3833	End;
3834
3835
3836	Procedure TDataSet.RemoveCurrentFields;
3837	Var Col,Row:LongInt;
3838	Field:TField;
3839	FieldDef:TFieldDef;
3840	Begin
3841	FieldDef := Nil;
3842
3843	For Col := 0 To FFieldDefs.Count-1 Do
3844	Begin
3845	FieldDef := FFieldDefs[Col];
3846	Field := FieldDef.Fields[FCurrentRow];
3847	If Field <> Nil Then
3848	Begin
3849	FieldDef.Fields.Remove(Field);
3850	Field.Destroy;
3851	End;
3852
3853	For Row := FCurrentRow To FieldDef.Fields.Count-1 Do
3854	Begin
3855	Field := FieldDef.Fields[Row];
3856	If Field <> Nil Then Dec(Field.FRow);
3857	End;
3858	End;
3859
3860	If FieldDef <> Nil Then
3861	If FCurrentRow >= FieldDef.Fields.Count
3862	Then FCurrentRow := FieldDef.Fields.Count-1;
3863	End;
3864
3865
3866	Function TDataSet.UpdateFieldSelect(Field:TField):Boolean;
3867	Begin
3868	Result:=False;
3869	End;
3870
3871
3872	Procedure TDataSet.UpdateField(field:TField;OldValue:Pointer;OldValueLen:LongInt);
3873	Begin
3874	If Not FOpened Then Exit;
3875	If FSelect.Count=0 Then Exit; //Nothing To Select
3876	Try
3877	If Not UpdateFieldSelect(field) Then
3878	Begin
3879	FreeMem(field.FValue,field.FValueLen);
3880	field.FValue:=OldValue;
3881	field.FValueLen:=OldValueLen;
3882	End
3883	Else FreeMem(OldValue,OldValueLen);
3884	Except
3885	FreeMem(field.FValue,field.FValueLen);
3886	field.FValue:=OldValue;
3887	field.FValueLen:=OldValueLen;
3888	Raise;
3889	End;
3890	End;
3891
3892
3893	Procedure TDataSet.Post;
3894	Begin
3895	If Not FOpened Then Exit;
3896	If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3897
3898	Try
3899	CheckRequiredFields;
3900
3901	If FBeforePost <> Nil Then FBeforePost(Self);
3902
3903	If FRowIsInserted Then CommitInsert(True)
3904	Else DoPost;
3905
3906	DataChange(deDataBaseChanged);
3907
3908	If FAfterPost <> Nil Then FAfterPost(Self);
3909	Except
3910	Raise;
3911	End;
3912	End;
3913
3914
3915	Procedure TDataSet.DoPost;
3916	Begin
3917	End;
3918
3919
3920	Procedure TDataSet.Cancel;
3921	Begin
3922	If Not FOpened Then Exit;
3923	If (CurrentRow < 0) Or (CurrentRow >= RecordCount) Then exit;
3924
3925	Try
3926	If FBeforeCancel <> Nil Then FBeforeCancel(Self);
3927
3928	If FRowIsInserted Then CommitInsert(False)
3929	Else DoCancel;
3930
3931	DataChange(deDataBaseChanged);
3932
3933	If FAfterCancel <> Nil Then FAfterCancel(Self);
3934	Except
3935	Raise;
3936	End;
3937	End;
3938
3939
3940	Procedure TDataSet.DoCancel;
3941	Begin
3942	End;
3943
3944
3945	Procedure TDataSet.QueryTable;
3946	Begin
3947	End;
3948
3949
3950	Procedure TDataSet.Loaded;
3951	Begin
3952	Inherited Loaded;
3953
3954	If FRefreshOnLoad Then Active:=True;
3955	End;
3956
3957
3958	Procedure TDataSet.CheckInactive;
3959	Begin
3960	If Active Then
3961	Begin
3962	//Close;
3963	DatabaseError('Cannot perform this operation on active dataset !');
3964	End;
3965	End;
3966
3967
3968	Function TDataSet.IsTable:Boolean;
3969	Begin
3970	Result := (Self Is TTable) And (Not (Self Is TQuery)) And (Not (Self Is TStoredProc));
3971	End;
3972
3973
3974	{
3975	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
3976	º º
3977	º Speed-Pascal/2 Version 2.0 º
3978	º º
3979	º Speed-Pascal Component Classes (SPCC) º
3980	º º
3981	º This section: TTable Class Implementation º
3982	º º
3983	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
3984	º º
3985	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
3986	}
3987
3988	Procedure TTable.GetPrimaryKeys(List:TStrings);
3989	Begin
3990	GetKeys(List,True);
3991	End;
3992
3993	Function MapODBCType(colType:TFieldType):SQLSMALLINT;
3994	Begin
3995	Case colType Of
3996	ftString:Result:=SQL_VARCHAR;
3997	ftCurrency:Result:=SQL_NUMERIC;
3998	ftInteger:Result:=SQL_INTEGER;
3999	ftSmallInt:Result:=SQL_SMALLINT;
4000	ftFloat:Result:=SQL_DOUBLE;
4001	ftDate:Result:=SQL_DATE;
4002	ftTime:Result:=SQL_TIME;
4003	ftDateTime:Result:=SQL_TIMESTAMP;
4004	ftMemo:Result:=SQL_LONGVARCHAR;
4005	ftBlob:Result:=SQL_VARBINARY;
4006	ftGraphic:Result:=SQL_VARGRAPHIC;
4007	Else Result:=SQL_BLOB;
4008	End; {Case}
4009	End;
4010
4011	Function TTable.DataType2Name(DataType:TFieldType):String;
4012	Var List:TStringList;
4013	t:LongInt;
4014	Begin
4015	Result:='';
4016
4017	Case FDBProcs.DBType Of
4018	Native_Oracle7:
4019	Begin
4020	Case DataType Of
4021	ftString:Result:='VARCHAR2';
4022	ftSmallInt,ftInteger,ftWord:Result:='INT';
4023	ftBoolean:Result:='CHAR';
4024	ftFloat,ftCurrency:Result:='FLOAT';
4025	ftDate,ftTime,ftDateTime:Result:='DATE';
4026	ftBytes,ftBlob,ftMemo,ftGraphic,ftFmtMemo,
4027	ftTypedBinary:Result:='RAW';
4028	ftVarBytes:Result:='LONG RAW';
4029	End;
4030	End;
4031	Native_msql:
4032	Begin
4033	Case DataType Of
4034	ftString:Result:='CHAR';
4035	ftSmallInt,ftInteger,ftWord:Result:='INT';
4036	ftBoolean:Result:='CHAR';
4037	ftFloat,ftCurrency:Result:='REAL';
4038	ftDate:Result:='DATE';
4039	ftTime:Result:='TIME';
4040	ftMemo,ftFmtMemo:Result:='TEXT';
4041	End;
4042	End;
4043	Native_DBase:
4044	Begin
4045	Case DataType Of
4046	ftString: Result := 'CHAR';
4047	ftDate: Result := 'DATE';
4048	ftFloat,ftCurrency: Result := 'FLOAT';
4049	ftSmallInt,ftInteger,ftWord: Result := 'INT';
4050	ftBoolean: Result := 'BOOL';
4051	ftMemo: Result := 'TEXT';
4052	ftBlob: Result := 'BLOB';
4053	Else Result := '';
4054	End;
4055	End;
4056	Native_Paradox:
4057	Begin
4058	Case DataType Of
4059	ftString: Result := 'CHAR';
4060	ftDate: Result := 'DATE';
4061	ftSmallInt: Result := 'SINT';
4062	ftInteger: Result := 'INT';
4063	ftFloat: Result := 'FLOAT';
4064	ftCurrency: Result := 'MONEY';
4065	//ftInteger: Result := 'NUMBER';
4066	ftBoolean: Result := 'BOOL';
4067	ftMemo: Result := 'TEXT';
4068	ftBlob: Result := 'BLOB';
4069	ftFmtMemo: Result := 'FMTTEXT';
4070	ftTime: Result := 'TIME';
4071	ftDateTime: Result := 'DATETIME';
4072	ftAutoInc: Result := 'AUTOINC';
4073	ftBCD: Result := 'BCD';
4074	ftBytes: Result := 'BYTES';
4075	Else Result := '';
4076	End;
4077	End;
4078	Else
4079	Begin
4080	If FDataTypes=Nil Then
4081	Begin
4082	List.Create;
4083	GetDataTypes(List);
4084	List.Destroy;
4085	End;
4086
4087	Result:='';
4088	If FDataTypes=Nil Then exit;
4089	For t:=0 To FDataTypes.Count-1 Do
4090	If TFieldType(FDataTypes.Objects[t])=DataType Then
4091	Begin
4092	Result:=FDataTypes[t];
4093	exit;
4094	End;
4095	End;
4096	End; //case
4097	End;
4098
4099	Function TTable.GetIndexDefs:TIndexDefs;
4100	Begin
4101	If ((FIndexDefs=Nil)Or(FIndexDefs.Count=0)) Then UpdateIndexDefs;
4102	Result:=FIndexDefs;
4103	End;
4104
4105	Procedure UpdateIndexFieldMap(Table:TTable);
4106	Var t,Index:LongInt;
4107	IndexDef:TIndexDef;
4108	s,s1:String;
4109	Begin
4110	If Table.FIndexFieldMap<>Nil Then Table.FIndexFieldMap.Clear
4111	Else Table.FIndexFieldMap.Create;
4112
4113	For t:=0 To Table.IndexDefs.Count-1 Do
4114	Begin
4115	IndexDef:=Table.IndexDefs[t];
4116
4117	s:=IndexDef.Fields;
4118	While pos(';',s)<>0 Do
4119	Begin
4120	s1:=Copy(s,1,pos(';',s)-1);
4121	System.Delete(s,1,pos(';',s));
4122
4123	Index:=Table.FieldDefs.IndexOf(s1);
4124	If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then
4125	Table.FIndexFieldMap.Add(Pointer(Index));
4126	End;
4127	If s<>'' Then
4128	Begin
4129	Index:=Table.FieldDefs.IndexOf(s);
4130	If Index>=0 Then If Table.FIndexFieldMap.IndexOf(Pointer(Index))<0 Then
4131	Table.FIndexFieldMap.Add(Pointer(Index));
4132	End;
4133	End;
4134	End;
4135
4136	Function TTable.GetIndexFieldCount:LongInt;
4137	Begin
4138	If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self);
4139	Result:=FIndexFieldMap.Count
4140	End;
4141
4142	Function TTable.GetIndexField(Index:LongInt):TField;
4143	Begin
4144	If ((FIndexFieldMap=Nil)Or(FIndexFieldMap.Count=0)) Then UpdateIndexFieldMap(Self);
4145	Result:=Fields[LongInt(FIndexFieldMap[Index])]
4146	End;
4147
4148	Procedure TTable.SetIndexField(Index:LongInt;NewValue:TField);
4149	Begin
4150	GetIndexField(Index).Assign(NewValue);
4151	End;
4152
4153	Procedure TTable.AddIndex(Const Name:String;Fields:String;Options:TIndexOptions);
4154	Var OldActive,OldOpen:Boolean;
4155	S1,s2:String;
4156	ahstmt:SQLHSTMT;
4157	Begin
4158	If (Not IsTable) Then SQLError('Illegal operation');
4159
4160	OldActive:=FActive;
4161	OldOpen:=FOpened;
4162	If Not FOpened Then
4163	Begin
4164	FActive:=True;
4165	DoOpen;
4166	If Not FOpened Then Active:=False;
4167	End;
4168
4169	s1:='CREATE';
4170	If Options*[ixUnique]<>[] Then s1:=s1+' UNIQUE';
4171	s1:=s1+' INDEX '+Name+' ON '+TableName+'(';
4172	While pos(';',Fields)<>0 Do
4173	Begin
4174	s2:=Copy(Fields,1,pos(';',Fields)-1);
4175	System.Delete(Fields,1,pos(';',Fields));
4176	If s1[length(s1)]<>'(' Then s1:=s1+',';
4177	s1:=s1+s2;
4178	If FDBProcs.DBType<>Native_Msql Then
4179	Begin
4180	If Options*[ixDescending]<>[] Then s1:=s1+' DESC'
4181	Else s1:=s1+' ASC';
4182	End;
4183	End;
4184	If s1[length(s1)]<>'(' Then s1:=s1+',';
4185	s1:=s1+Fields;
4186	If FDBProcs.DBType<>Native_Msql Then
4187	Begin
4188	If Options*[ixDescending]<>[] Then s1:=s1+' DESC'
4189	Else s1:=s1+' ASC';
4190	End;
4191	s1:=s1+')';
4192
4193	If FOpened Then
4194	Begin
4195	EnterSQLProcessing;
4196	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4197
4198	If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4199	Begin
4200	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4201	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4202	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4203	End;
4204
4205	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4206	LeaveSQLProcessing;
4207	End;
4208
4209	DoPost;
4210	If not OldOpen Then DoClose;
4211	FActive:=OldActive;
4212	UpdateIndexDefs;
4213	End;
4214
4215	Procedure TTable.DeleteIndex(Const Name: string);
4216	Var OldActive,OldOpen:Boolean;
4217	S1:String;
4218	ahstmt:SQLHSTMT;
4219	Begin
4220	If (Not IsTable) Then SQLError('Illegal operation');
4221
4222	OldActive:=FActive;
4223	OldOpen:=FOpened;
4224	If Not FOpened Then
4225	Begin
4226	FActive:=True;
4227	DoOpen;
4228	If Not FOpened Then Active:=False;
4229	End;
4230
4231	If FOpened Then
4232	Begin
4233	EnterSQLProcessing;
4234	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4235
4236	s1:='DROP INDEX '+Name;
4237	If FDBProcs.DBType=Native_msql Then s1:=s1+' FROM '+TableName;
4238	If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4239	Begin
4240	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4241	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4242	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4243	End;
4244
4245	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4246	LeaveSQLProcessing;
4247	End;
4248
4249	DoPost;
4250	If not OldOpen Then DoClose;
4251	FActive:=OldActive;
4252	UpdateIndexDefs;
4253	End;
4254
4255
4256	Procedure TTable.CreateTable;
4257	Var s:AnsiString;
4258	s1:String;
4259	ahstmt:SQLHSTMT;
4260	t:LongInt;
4261	FieldDef:TFieldDef;
4262	OldActive:Boolean;
4263	Begin
4264	If (Not IsTable) Then SQLError('Illegal operation');
4265
4266	CheckInactive;
4267
4268	s:='CREATE TABLE '+TableName+'(';
4269
4270	For t:=0 To FieldDefs.Count-1 Do
4271	Begin
4272	FieldDef:=FieldDefs[t];
4273	s1:=FieldDef.TypeName;
4274	s:=s+FieldDef.Name+' '+s1;
4275	If ((FieldDef.DataType=ftString)Or(s1='LONG RAW')) Then
4276	s:=s+'('+tostr(FieldDef.Size)+')';
4277	If FieldDef.Required then s:=s+' NOT NULL';
4278	If FieldDef.PrimaryKey Then s:=s+' PRIMARY KEY';
4279	If FieldDef.ForeignKey<>'' Then s:=s+' REFERENCES '+FieldDef.ForeignKey;
4280	If t<>FieldDefs.Count-1 Then s:=s+',';
4281	End;
4282
4283	s:=s+')';
4284
4285	OldActive:=FActive;
4286	If Not FOpened Then
4287	Begin
4288	FActive:=True;
4289	DoOpen;
4290	If Not FOpened Then Active:=False;
4291	End;
4292
4293	If FOpened Then
4294	Begin
4295	EnterSQLProcessing;
4296	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4297
4298	If FDBProcs.SQLExecDirect(ahstmt,PChar(s)^,SQL_NTS)<>SQL_SUCCESS Then
4299	Begin
4300	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4301	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4302	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4303	End;
4304
4305	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4306	LeaveSQLProcessing;
4307	End;
4308	DoClose;
4309	FActive:=OldActive;
4310	End;
4311
4312
4313	Procedure TTable.DeleteTable;
4314	Var s1:String;
4315	ahstmt:SQLHSTMT;
4316	Begin
4317	If (Not IsTable) Then SQLError('Illegal operation');
4318	If Active Then DoClose;
4319
4320	If Not FOpened Then
4321	Begin
4322	FActive:=True;
4323	DoOpen;
4324	If Not FOpened Then Active:=False;
4325	End;
4326
4327	If FOpened Then
4328	Begin
4329	EnterSQLProcessing;
4330	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4331
4332	If FDBProcs.SQLExecDirect(ahstmt,'DROP TABLE '+TableName,SQL_NTS)<>SQL_SUCCESS Then
4333	Begin
4334	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4335	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4336	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4337	End;
4338
4339	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4340	LeaveSQLProcessing;
4341	End;
4342
4343	DoPost;
4344	DoClose;
4345	End;
4346
4347
4348	Procedure TTable.EmptyTable;
4349	Var OldActive,OldOpen:Boolean;
4350	S1:String;
4351	ahstmt:SQLHSTMT;
4352	Begin
4353	If (Not IsTable) Then SQLError('Illegal operation');
4354
4355	OldActive:=FActive;
4356	OldOpen:=FOpened;
4357	If Not FOpened Then
4358	Begin
4359	FActive:=True;
4360	DoOpen;
4361	If Not FOpened Then Active:=False;
4362	End;
4363
4364	If FOpened Then
4365	Begin
4366	EnterSQLProcessing;
4367	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4368
4369	If FDBProcs.SQLExecDirect(ahstmt,'DELETE * FROM '+TableName,SQL_NTS)<>SQL_SUCCESS Then
4370	Begin
4371	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4372	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4373	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4374	End;
4375
4376	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4377	LeaveSQLProcessing;
4378	End;
4379
4380	DoPost;
4381	If not OldOpen Then DoClose;
4382	FActive:=OldActive;
4383	End;
4384
4385
4386	Function TTable.FindKey(Const KeyValues:Array of Const):Boolean;
4387	Begin
4388	If (Not IsTable) Then SQLError('Illegal operation');
4389	Result:=False;
4390	//???
4391	End;
4392
4393	Procedure TTable.GetIndexNames(List: TStrings);
4394	Var t:LongInt;
4395	Begin
4396	List.Clear;
4397	For t:=0 To IndexDefs.Count-1 Do List.Add(IndexDefs[t].Name);
4398	End;
4399
4400	Procedure TTable.RenameTable(NewTableName:String);
4401	Var OldActive,OldOpen:Boolean;
4402	S1:String;
4403	ahstmt:SQLHSTMT;
4404	tn:String;
4405	Begin
4406	If (Not IsTable) Then SQLError('Illegal operation');
4407
4408	OldActive:=FActive;
4409	OldOpen:=FOpened;
4410	If Not FOpened Then
4411	Begin
4412	FActive:=True;
4413	DoOpen;
4414	If Not FOpened Then Active:=False;
4415	End;
4416
4417	If FOpened Then
4418	Begin
4419	EnterSQLProcessing;
4420	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4421
4422	tn:=TableName;
4423	If FDBProcs.DBType=Native_Oracle7 Then //no qualifiers !
4424	Begin
4425	If pos('.',NewTableName)<>0 Then
4426	System.Delete(NewTableName,1,pos('.',NewTableName));
4427
4428	If pos('.',tn)<>0 Then
4429	System.Delete(tn,1,pos('.',tn));
4430	End;
4431
4432	If FDBProcs.DBType=Native_Oracle7 Then s1:='RENAME '+tn+' TO '+NewTableName
4433	Else s1:='ALTER TABLE '+TableName+' RENAME '+NewTableName;
4434	If FDBProcs.SQLExecDirect(ahstmt,s1,SQL_NTS)<>SQL_SUCCESS Then
4435	Begin
4436	S1:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4437	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4438	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S1);
4439	End;
4440
4441	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4442	LeaveSQLProcessing;
4443	End;
4444
4445	DoPost;
4446	DoClose;
4447	TableName:=NewTableName;
4448	FActive:=OldActive;
4449	End;
4450
4451
4452	Procedure TTable.GetNames(List:TStrings;Const Name:String);
4453	Var
4454	ahstmt:SQLHSTMT;
4455	cols:SQLSMALLINT;
4456	I:LongInt;
4457	C:Array[0..4] Of cstring;
4458	OutLen:Array[0..4] Of SQLINTEGER;
4459	rc:SQLRETURN;
4460	S,S1:String;
4461	OldActive:Boolean;
4462	OldOpen:Boolean;
4463	Index:LongInt;
4464	Begin
4465	List.Clear;
4466
4467	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
4468	Begin
4469	OldActive:=FActive;
4470	OldOpen:=FOpened;
4471	If Not FOpened Then
4472	Begin
4473	FActive:=True;
4474	DoOpen;
4475	If Not FOpened Then Active:=False;
4476	End;
4477
4478	If FOpened Then
4479	Begin
4480	EnterSQLProcessing;
4481	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4482
4483	If FDBProcs.SQLTables(ahstmt,Nil,0,Nil,0,Nil,0,Name,SQL_NTS)=SQL_SUCCESS Then
4484	Begin
4485	FDBProcs.SQLNumResultCols(ahstmt,cols);
4486	If cols>5 Then cols:=5;
4487	For I := 0 To cols-1 Do
4488	FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
4489	rc:=FDBProcs.SQLFetch(ahstmt);
4490	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
4491	Begin
4492	If Cols=1 Then Index:=0 //msql
4493	Else Index:=2;
4494
4495	If OutLen[Index]<>SQL_NULL_DATA Then
4496	Begin
4497	Move(C[Index],S[1],OutLen[Index]);
4498	S[0]:=Chr(OutLen[Index]);
4499	If S[length(s)]=#0 Then
4500	If length(S)>0 Then dec(S[0]);
4501	If Cols>1 Then //get qualifier
4502	If OutLen[0]<>SQL_NULL_DATA Then
4503	Begin
4504	Move(C[0],S1[1],OutLen[0]);
4505	S1[0]:=Chr(OutLen[0]);
4506	If S1[length(S1)]=#0 Then
4507	If length(S1)>0 Then dec(S1[0]);
4508	If S1<>'' Then S:=S1+'.'+S;
4509	End;
4510	List.Add(S);
4511	End;
4512	rc:=FDBProcs.SQLFetch(ahstmt);
4513	End;
4514	End;
4515
4516	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4517	LeaveSQLProcessing;
4518	End;
4519
4520	If Not OldOpen Then DoClose;
4521	FActive:=OldActive;
4522	End;
4523
4524	End;
4525
4526	Procedure TTable.GetViewNames(List:TStrings);
4527	Begin
4528	GetNames(List,'VIEW');
4529	End;
4530
4531	Procedure TTable.GetSystemTableNames(List:TStrings);
4532	Begin
4533	GetNames(List,'SYSTEM TABLE');
4534	End;
4535
4536	Procedure TTable.GetSynonymNames(List:TStrings);
4537	Begin
4538	GetNames(List,'SYNONYM');
4539	End;
4540
4541	Function MapSQLType(colType:SQLSMALLINT):TFieldType;
4542	Begin
4543	Case colType Of
4544	SQL_CHAR:Result:=ftString;
4545	SQL_NUMERIC:Result:=ftFloat;
4546	SQL_DECIMAL:Result:=ftFloat;
4547	SQL_INTEGER:Result:=ftInteger;
4548	SQL_SMALLINT:Result:=ftSmallInt;
4549	SQL_FLOAT:Result:=ftFloat;
4550	SQL_REAL:Result:=ftFloat;
4551	SQL_DOUBLE:Result:=ftFloat;
4552	SQL_DATE:Result:=ftDate;
4553	SQL_TIME:Result:=ftTime;
4554	SQL_TIMESTAMP:Result:=ftDateTime;
4555	SQL_VARCHAR:Result:=ftString;
4556	SQL_LONGVARCHAR:Result:=ftMemo;
4557	SQL_BINARY:Result:=ftBlob;
4558	SQL_VARBINARY:Result:=ftBlob;
4559	SQL_LONGVARBINARY:Result:=ftBlob;
4560	{SQL_BIGINT =-5; /* Not supported */
4561	SQL_TINYINT =-6; /* Not supported */}
4562	SQL_BIT:Result:=ftBoolean;
4563	SQL_GRAPHIC:Result:=ftGraphic;
4564	SQL_VARGRAPHIC:Result:=ftGraphic;
4565	SQL_LONGVARGRAPHIC:Result:=ftGraphic;
4566	SQL_BLOB:Result:=ftBlob;
4567	SQL_CLOB:Result:=ftBlob;
4568	SQL_DBCLOB:Result:=ftBlob;
4569	Else Result:=ftUnknown;
4570	End; {Case}
4571	End;
4572
4573
4574	Procedure TTable.GetDataTypes(List:TStrings);
4575	Var
4576	OldActive:Boolean;
4577	OldOpen:Boolean;
4578	Index:LongInt;
4579
4580	Procedure GetType(Typ:SQLSMALLINT);
4581	Var cols:SQLSMALLINT;
4582	I:LongInt;
4583	C:cstring;
4584	OutLen:SQLINTEGER;
4585	rc:SQLRETURN;
4586	S,S1:String;
4587	ahstmt:SQLHSTMT;
4588	Begin
4589	EnterSQLProcessing;
4590	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4591
4592	If FDBProcs.SQLGetTypeInfo(ahstmt,Typ)=SQL_SUCCESS Then
4593	Begin
4594	FDBProcs.SQLNumResultCols(ahstmt,cols);
4595	If cols=0 Then exit;
4596	FDBProcs.SQLBindCol(ahstmt, 1, SQL_C_CHAR, C, 255, OutLen);
4597	rc:=FDBProcs.SQLFetch(ahstmt);
4598	If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then
4599	Begin
4600	If OutLen<>SQL_NULL_DATA Then
4601	Begin
4602	Move(C,S[1],OutLen);
4603	S[0]:=Chr(OutLen);
4604	If S[length(s)]=#0 Then
4605	If length(s)>0 Then dec(S[0]);
4606	UpcaseStr(S);
4607	If List.IndexOf(S)<0 Then List.AddObject(S,Pointer(MapSQLType(Typ)));
4608	End;
4609	End;
4610	End;
4611
4612	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4613	LeaveSQLProcessing;
4614	End;
4615
4616	Procedure ListAddObject(Const s:String;DataType:TFieldType);
4617	Begin
4618	List.AddObject(s,Pointer(DataType));
4619	End;
4620
4621	Begin
4622	List.Clear;
4623	Case FDBProcs.DBType Of
4624	Native_Oracle7:
4625	Begin
4626	ListAddObject('CHAR',ftString);
4627	ListAddObject('VARCHAR2',ftString);
4628	ListAddObject('FLOAT',ftFloat);
4629	ListAddObject('INT',ftInteger);
4630	ListAddObject('DATE',ftDateTime);
4631	ListAddObject('RAW',ftBlob);
4632	ListAddObject('LONG RAW',ftBlob);
4633	End;
4634	Native_msql:
4635	Begin
4636	ListAddObject('CHAR',ftString);
4637	ListAddObject('INT',ftInteger);
4638	ListAddObject('UINT',ftInteger);
4639	ListAddObject('REAL',ftFloat);
4640	ListAddObject('TEXT',ftMemo);
4641	ListAddObject('DATE',ftDate);
4642	ListAddObject('TIME',ftTime);
4643	ListAddObject('MONEY',ftInteger);
4644	End;
4645	Native_DBase:
4646	Begin
4647	ListAddObject('CHAR',ftString);
4648	ListAddObject('INT',ftInteger);
4649	ListAddObject('FLOAT',ftFloat);
4650	ListAddObject('TEXT',ftMemo);
4651	ListAddObject('DATE',ftDate);
4652	ListAddObject('BOOL',ftBoolean);
4653	ListAddObject('BLOB',ftBlob);
4654	End;
4655	Native_Paradox:
4656	Begin
4657	ListAddObject('CHAR',ftString);
4658	ListAddObject('DATE',ftDate);
4659	ListAddObject('SINT',ftSmallInt);
4660	ListAddObject('INT',ftInteger);
4661	ListAddObject('FLOAT',ftFloat);
4662	ListAddObject('MONEY',ftCurrency);
4663	ListAddObject('NUMBER',ftInteger);
4664	ListAddObject('BOOL',ftBoolean);
4665	ListAddObject('TEXT',ftMemo);
4666	ListAddObject('BLOB',ftBlob);
4667	ListAddObject('FMTTEXT',ftFmtMemo);
4668	ListAddObject('TIME',ftTime);
4669	ListAddObject('DATETIME',ftDateTime);
4670	ListAddObject('AUTOINC',ftAutoInc);
4671	ListAddObject('BCD',ftBCD);
4672	ListAddObject('BYTES',ftBytes);
4673	End;
4674	Else
4675	Begin
4676	If FDataTypes<>Nil Then
4677	Begin
4678	List.Assign(FDataTypes);
4679	exit;
4680	End;
4681
4682	If @FDBProcs.SQLGetTypeInfo=Nil Then exit;
4683	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
4684	Begin
4685	OldActive:=FActive;
4686	OldOpen:=FOpened;
4687	If Not FOpened Then
4688	Begin
4689	FActive:=True;
4690	DoOpen;
4691	If Not FOpened Then Active:=False;
4692	End;
4693
4694	If FOpened Then
4695	Begin
4696	GetType(SQL_BIGINT);
4697	GetType(SQL_BINARY);
4698	GetType(SQL_BIT);
4699	GetType(SQL_CHAR);
4700	GetType(SQL_DATE);
4701	GetType(SQL_DECIMAL);
4702	GetType(SQL_DOUBLE);
4703	GetType(SQL_FLOAT);
4704	GetType(SQL_INTEGER);
4705	GetType(SQL_LONGVARBINARY);
4706	GetType(SQL_LONGVARCHAR);
4707	GetType(SQL_NUMERIC);
4708	GetType(SQL_REAL);
4709	GetType(SQL_SMALLINT);
4710	GetType(SQL_TIME);
4711	GetType(SQL_TIMESTAMP);
4712	GetType(SQL_TINYINT);
4713	GetType(SQL_VARBINARY);
4714	GetType(SQL_VARCHAR);
4715	End;
4716
4717	If Not OldOpen Then DoClose;
4718	FActive:=OldActive;
4719
4720	If FDataTypes=Nil Then If List.Count>0 Then
4721	Begin
4722	FDataTypes.Create;
4723	FDataTypes.Assign(List);
4724	End;
4725	End;
4726	End;
4727	End;
4728	End;
4729
4730
4731	Procedure TTable.GetForeignKeys(List:TStrings);
4732	Begin
4733	GetKeys(List,False);
4734	End;
4735
4736
4737	Procedure TTable.GetTableNames(List:TStrings);
4738	Begin
4739	GetNames(List,'TABLE');
4740	End;
4741
4742
4743	Procedure TTable.SetTableLock(LockType:TLockType;Lock:Boolean);
4744	Var C:cstring;
4745	ahstmt:SQLHSTMT;
4746	S:String;
4747	Begin
4748	If Lock Then
4749	Begin
4750	C:='LOCK TABLE '+TableName+' IN ';
4751	If LockType=ltReadLock Then C:=C+'EXCLUSIVE'
4752	Else C:=C+'SHARE';
4753	C:=C+' MODE';
4754	End
4755	Else C:='ROLLBACK';
4756
4757	EnterSQLProcessing;
4758	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
4759
4760	If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
4761	Begin
4762	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
4763	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4764	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
4765	End;
4766
4767	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
4768	LeaveSQLProcessing;
4769	End;
4770
4771	Procedure TTable.LockTable(LockType:TLockType);
4772	Begin
4773	SetTableLock(LockType,True);
4774	End;
4775
4776	Procedure TTable.UnlockTable(LockType:TLockType);
4777	Begin
4778	SetTableLock(LockType,False);
4779	End;
4780
4781
4782	Procedure TTable.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
4783	Var S:String;
4784	Begin
4785	If ResName = rnDBTable Then
4786	Begin
4787	Move(Data,S,DataLen);
4788	TableName:=S;
4789	End
4790	Else Inherited ReadSCUResource(ResName,Data,DataLen);
4791	End;
4792
4793
4794	Function TTable.WriteSCUResource(Stream:TResourceStream):Boolean;
4795	Var S:String;
4796	Begin
4797	Result := False;
4798	If Inherited WriteSCUResource(Stream) Then
4799	Begin
4800	S:=TableName;
4801	Result:=Stream.NewResourceEntry(rnDBTable,S,Length(S)+1);
4802	End;
4803	End;
4804
4805
4806	Function TTable.GetTableName:String;
4807	Begin
4808	Result:=FTableName^;
4809	End;
4810
4811
4812	Procedure TTable.SetupComponent;
4813	Begin
4814	AssignStr(FTableName,'');
4815	AssignStr(FMasterFields,'');
4816
4817	Inherited SetupComponent;
4818
4819	Name:='Table';
4820	End;
4821
4822
4823	Procedure TTable.SetActive(NewValue:Boolean);
4824	Begin
4825	If FActive = NewValue Then exit;
4826
4827	Inherited SetActive(NewValue);
4828
4829	If FActive Then
4830	Begin
4831	RefreshTable;
4832	FActive := FOpened;
4833	End
4834	Else DoClose;
4835	End;
4836
4837
4838	Procedure TTable.RefreshTable;
4839	Begin
4840	If ((csReading In ComponentState) Or (FDataSetLocked)) Then
4841	Begin
4842	FRefreshOnLoad := FActive;
4843	Exit;
4844	End;
4845	DoOpen;
4846	If Not FOpened Then Exit;
4847	If TableName <> '' Then QueryTable;
4848	End;
4849
4850
4851	Procedure TTable.SetTableName(NewValue:String);
4852	Begin
4853	If GetTableName=NewValue Then Exit;
4854
4855	If FIndexDefs<>Nil Then FIndexDefs.Clear;
4856	AssignStr(FTableName,NewValue);
4857
4858	FSelect.Clear;
4859	NewValue:='SELECT * FROM '+ NewValue;
4860	FSelect.Add(NewValue);
4861
4862	If FActive Then
4863	Begin
4864	RefreshTable;
4865
4866	DataChange(deTableNameChanged);
4867	End;
4868	End;
4869
4870	Function TTable.GetPassword:String;
4871	Begin
4872	Result:=FDBProcs.pwd;
4873	End;
4874
4875	Function TTable.GetUserId:String;
4876	Begin
4877	Result:=FDBProcs.uid;
4878	End;
4879
4880	Procedure TTable.SetPassword(NewValue:String);
4881	Begin
4882	If FOpened Then
4883	Begin
4884	ErrorBox(LoadNLSStr(SCannotPerformDBAction));
4885	Exit;
4886	End;
4887	FDBProcs.pwd:=NewValue;
4888	End;
4889
4890	Procedure TTable.SetUserId(NewValue:String);
4891	Begin
4892	If FOpened Then
4893	Begin
4894	ErrorBox(LoadNLSStr(SCannotPerformDBAction));
4895	Exit;
4896	End;
4897	FDBProcs.uid:=NewValue;
4898	End;
4899
4900	Destructor TTable.Destroy;
4901	Begin
4902	DoClose;
4903	FreeDBProcs(FDBProcs);
4904	AssignStr(FTableName,'');
4905	If FServants<>Nil Then
4906	Begin
4907	NotifyServants(Self);
4908	FServants.Destroy;
4909	End;
4910	FServants:=Nil;
4911	If FDataTypes<>Nil Then
4912	Begin
4913	FDataTypes.Destroy;
4914	FDataTypes:=Nil;
4915	End;
4916	If FIndexDefs<>Nil Then
4917	Begin
4918	FIndexDefs.Destroy;
4919	FIndexDefs:=Nil;
4920	End;
4921	If FIndexFieldMap<>Nil Then
4922	Begin
4923	FIndexFieldMap.Destroy;
4924	FIndexFieldMap:=Nil;
4925	End;
4926	If FMasterSource<>Nil Then
4927	If FMasterSource.DataSet Is TTable Then
4928	TTable(FMasterSource.DataSet).ConnectServant(Self,False);
4929	AssignStr(FMasterFields,'');
4930
4931	Inherited Destroy;
4932	End;
4933
4934	Procedure TTable.Loaded;
4935	Begin
4936	If FTempMasterSource<>Nil Then
4937	If FTempMasterSource.DataSet Is TTable Then
4938	If FMasterSource=Nil Then MasterSource:=FTempMasterSource;
4939	Inherited Loaded;
4940	End;
4941
4942	{$HINTS OFF}
4943	Procedure TTable.UpdateLinkList(Const PropertyName:String;LinkList:TList);
4944	Var T:LongInt;
4945	DataSource:TDataSource;
4946	Begin
4947	For T:=LinkList.Count-1 DownTo 0 Do
4948	Begin
4949	DataSource:=TDataSource(LinkList[T]);
4950	If DataSource Is TDataSource Then
4951	Begin
4952	If DataSource.DataSet Is TTable Then
4953	Begin
4954	//no recursive elements !!
4955	If TTable(DataSource.DataSet)=Self Then LinkList.Remove(DataSource);
4956	End
4957	Else
4958	Begin
4959	//no DataSources that are Not linked To tables !
4960	LinkList.Remove(DataSource);
4961	End;
4962	End;
4963	End;
4964	End;
4965	{$HINTS ON}
4966
4967	Procedure TTable.SetMasterSource(NewValue:TDataSource);
4968	Var OldLocked:Boolean;
4969	IsLoaded:Boolean;
4970	Begin
4971	If NewValue=FMasterSource Then Exit;
4972	If NewValue<>Nil Then
4973	Begin
4974	If Not (NewValue.DataSet Is TTable) Then
4975	Begin
4976	IsLoaded:=((ComponentState*[csReading]=[])And(Not FDataSetLocked));
4977	If ((NewValue.DataSet=Nil)And(Not IsLoaded)) Then FTempMasterSource:=NewValue
4978	Else If ComponentState*[csDesigning]<>[] Then ErrorBox(LoadNLSStr(SDataSourceLinkError));
4979	Exit;
4980	End;
4981	If TTable(NewValue.DataSet)=Self Then
4982	Begin
4983	If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal recursive DataSource link');
4984	Exit;
4985	End;
4986	If ((FServants<>Nil)And(FServants.IndexOf(NewValue.DataSet)>=0)) Then
4987	Begin
4988	If ComponentState*[csDesigning]<>[] Then ErrorBox('Illegal circular DataSource link');
4989	Exit;
4990	End;
4991
4992	End;
4993
4994	//prevent call Of RefreshTable In ConnectServant
4995	OldLocked:=FDataSetLocked;
4996	FDataSetLocked:=True;
4997	If FMasterSource<>Nil Then
4998	If FMasterSource.DataSet Is TTable Then
4999	TTable(FMasterSource.DataSet).ConnectServant(Self,False);
5000	FMasterSource:=NewValue;
5001	FDataSetLocked:=OldLocked;
5002	If FMasterSource<>Nil Then
5003	Begin
5004	If FMasterSource.DataSet Is TTable Then
5005	TTable(FMasterSource.DataSet).ConnectServant(Self,True)
5006	Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5007	End
5008	Else If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5009	End;
5010
5011	Function TTable.GetMasterFields:String;
5012	Begin
5013	Result:=FMasterFields^;
5014	End;
5015
5016	Procedure TTable.SetMasterFields(Const NewValue:String);
5017	Begin
5018	If GetMasterFields=NewValue Then exit;
5019
5020	AssignStr(FMasterFields,NewValue);
5021	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then RefreshTable;
5022	End;
5023
5024	Procedure TTable.ConnectServant(Servant:TTable;Connect:Boolean);
5025	Begin
5026	If Connect Then
5027	Begin
5028	If FServants=Nil Then FServants.Create;
5029	FServants.Add(Servant);
5030	End
5031	Else If FServants<>Nil Then
5032	Begin
5033	If FServants.IndexOf(Servant)>=0 Then FServants.Remove(Servant);
5034	End;
5035
5036	If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
5037	Servant.RefreshTable;
5038	End;
5039
5040	Procedure TTable.DataChange(event:TDataChange);
5041	Var T:LongInt;
5042	Servant:TTable;
5043	Begin
5044	If FServants<>Nil Then For T:=0 To FServants.Count-1 Do
5045	Begin
5046	Servant:=FServants[T];
5047	If ((Servant.ComponentState*[csReading]=[])And(Not Servant.FDataSetLocked)) Then
5048	Servant.RefreshTable;
5049	End;
5050
5051	Inherited DataChange(event);
5052	End;
5053
5054
5055	Function TTable.GetResultColRow(Col,Row:LongInt):TField;
5056	Var FieldDef:TFieldDef;
5057	I,t:LongInt;
5058	field:TField;
5059	rc:SQLRETURN;
5060	OutLen:LongInt;
5061	Temp:Pointer;
5062	NewLen:LongInt;
5063	MapType:LongInt;
5064	S:String;
5065	ActRows:LongWord;
5066	RowStatus:Word;
5067	ExtFetchOk:Boolean;
5068	e:Extended;
5069	Header:TGraphicHeader;
5070	Label again,err;
5071	Begin
5072	Result := Nil;
5073	If Not FOpened Then Exit;
5074
5075	Result := Inherited GetResultColRow(Col,Row);
5076	If Result <> Nil Then exit;
5077
5078	If FDBProcs.ahstmt=0 Then Exit; {no previous Select Command Or no more Rows}
5079
5080	/* Store Result Row(S) */
5081	again:
5082	//Try if we are able to retrieve cursored rows !
5083	If Self Is TStoredProc Then //due to "Function sequence error"
5084	Begin
5085	rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
5086	ExtFetchOk:=False;
5087	End
5088	Else
5089	Begin
5090	rc:=FDBProcs.SQLExtendedFetch(FDBProcs.ahstmt,SQL_FETCH_ABSOLUTE,
5091	Row+1,ActRows,RowStatus);
5092	ExtFetchOk:=rc<>SQL_ERROR;
5093	If not ExtFetchOk Then rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt); //Driver not capable (DB2 !)
5094	End;
5095
5096	FieldDef:=FFieldDefs[0];
5097
5098	If ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Then
5099	Begin
5100	For I:=0 To FFieldDefs.Count-1 Do
5101	Begin
5102	FieldDef:=FFieldDefs[I];
5103	{Create Row}
5104	Field := FieldDef.CreateField(Nil);
5105	If ExtFetchOk Then Field.FRow:=Row+1
5106	Else Field.FRow:=FieldDef.Fields.Count;
5107	Field.FCol:=I;
5108
5109	Case FieldDef.DataType Of
5110	ftBytes,ftVarBytes,ftBlob,ftMemo,ftGraphic,
5111	ftFmtMemo,ftTypedBinary:MapType:=SQL_C_BINARY;
5112	ftFloat:
5113	Begin
5114	Case FieldDef.Size Of
5115	4:MapType:=SQL_C_FLOAT;
5116	Else MapType:=SQL_C_DOUBLE;
5117	End; //case
5118	End;
5119	Else MapType:=SQL_C_DEFAULT;
5120	End;
5121
5122	rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,field.FValue^,
5123	FieldDef.Size,OutLen);
5124	If rc<>SQL_ERROR Then
5125	Begin
5126	If ((rc=SQL_SUCCESS_WITH_INFO)And(OutLen>field.FValueLen)And
5127	(MapType=SQL_C_BINARY)) Then
5128	Begin
5129	NewLen:=OutLen-field.FValueLen;
5130	GetMem(Temp,OutLen);
5131	Move(Field.FValue^,Temp^,Field.FValueLen);
5132	FreeMem(Field.FValue,Field.FValueLen);
5133	Field.FValue:=Temp;
5134	Inc(Temp,field.FValueLen);
5135	Field.FValueLen:=OutLen;
5136	rc:=FDBProcs.SQLGetData(FDBProcs.ahstmt,I+1,MapType,Temp^,
5137	NewLen,OutLen);
5138	If rc=SQL_ERROR Then
5139	Begin
5140	Field.Destroy;
5141	Goto err;
5142	End;
5143	OutLen:=Field.FValueLen+1;
5144	End;
5145
5146	If OutLen=SQL_NULL_DATA Then
5147	Begin
5148	Field.FreeMemory; //TOM TEST
5149	End
5150	Else
5151	Begin
5152	If OutLen<=field.FValueLen Then
5153	Begin
5154	GetMem(Temp,OutLen);
5155	Move(Field.FValue^,Temp^,OutLen);
5156	FreeMem(Field.FValue,Field.FValueLen);
5157	Field.FValue:=Temp;
5158	Field.FValueLen:=OutLen;
5159	End;
5160	End;
5161
5162	If ExtFetchOk Then
5163	Begin
5164	If Row<=FieldDef.Fields.Count-1 Then
5165	Begin
5166	FieldDef.Fields[Row]:=Field;
5167	End
5168	Else
5169	Begin
5170	For t:=FieldDef.Fields.Count+1 To Row Do
5171	FieldDef.Fields.Add(Nil);
5172	FieldDef.Fields.Add(Field);
5173	End;
5174	End
5175	Else FieldDef.Fields.Add(Field);
5176	End
5177	Else
5178	Begin
5179	Field.Destroy;
5180	Goto err;
5181	End;
5182
5183	If Field Is TBlobField Then // check graphic header
5184	Begin
5185	If Field.FValueLen >= SizeOf(TGraphicHeader) Then
5186	Begin
5187	move(Field.FValue^, Header, SizeOf(TGraphicHeader));
5188	If (Header.Count = 1) And (Header.HType = $0100) And
5189	(Header.Size = Field.FValueLen - SizeOf(TGraphicHeader)) Then
5190	Begin
5191	GetMem(Temp, Header.Size);
5192	inc(Field.FValue, SizeOf(TGraphicHeader));
5193	Move(Field.FValue^,Temp^, Header.Size);
5194	dec(Field.FValue, SizeOf(TGraphicHeader));
5195	FreeMem(Field.FValue, Field.FValueLen);
5196	Field.FValue := Temp;
5197	Field.FValueLen := Header.Size;
5198	//Field.FBlobType := ftGraphic;
5199	End;
5200	End;
5201	End;
5202	End;
5203
5204	FieldDef:=FFieldDefs[Col];
5205
5206	If ((ExtFetchOk)Or(Row=FieldDef.Fields.Count-1)) Then
5207	Begin
5208	{result found}
5209	Result:=FieldDef.Fields.Items[Row];
5210	exit;
5211	End;
5212
5213	Goto again; {fetch Next Row}
5214	End
5215	Else
5216	Begin
5217	{no more Rows}
5218	If rc=SQL_ERROR Then
5219	Begin
5220	err:
5221	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
5222	CloseStmt;
5223	SQLError('Error fetching result row '+FieldDef.Name+#13#10+S);
5224	End;
5225
5226	CloseStmt;
5227	End;
5228	End;
5229
5230
5231	Procedure TTable.GetKeys(List:TStrings;Primary:Boolean);
5232	Var ahstmt:SQLHSTMT;
5233	cols:SQLSMALLINT;
5234	C:Array[0..8] Of cstring;
5235	cc:cstring;
5236	S,S1:String;
5237	I:LongInt;
5238	OutLen:Array[0..8] Of SQLINTEGER;
5239	rc:SQLRETURN;
5240	Offset,Offset1:LongInt;
5241	Begin
5242	If Primary Then
5243	Begin
5244	Offset:=0;
5245	Offset1:=0;
5246	End
5247	Else
5248	Begin
5249	Offset:=4;
5250	Offset1:=-4;
5251	End;
5252
5253	EnterSQLProcessing;
5254	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5255
5256	cc:=TableName;
5257	Try //Some DB2 Servers return a GPF here ...
5258	rc:=SQL_ERROR;
5259	If TableName<>'' Then
5260	Begin
5261	If Primary Then
5262	rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,cc,SQL_NTS)
5263	Else If @FDBProcs.SQLForeignKeys<>Nil Then
5264	rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,cc,SQL_NTS);
5265	End
5266	Else
5267	Begin
5268	If Primary Then
5269	rc:=FDBProcs.SQLPrimaryKeys(ahstmt,Nil,0,Nil,0,Nil,0)
5270	Else If @FDBProcs.SQLForeignKeys<>Nil Then
5271	rc:=FDBProcs.SQLForeignKeys(ahstmt,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0,Nil,0);
5272	End;
5273
5274	If rc=SQL_SUCCESS Then
5275	Begin
5276	FDBProcs.SQLNumResultCols(ahstmt,cols);
5277	If cols>8 Then cols:=8;
5278	For I := 0 To cols-1 Do
5279	FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5280	rc:=FDBProcs.SQLFetch(ahstmt);
5281	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5282	Begin
5283	If OutLen[3+Offset]<>SQL_NULL_DATA Then
5284	Begin
5285	Move(C[3+Offset],S[1],OutLen[3+Offset]);
5286	S[0]:=Chr(OutLen[3+Offset]);
5287	If S[Length(S)]=#0 Then
5288	If length(S)>0 Then dec(S[0]);
5289	If ((TableName='')Or(Not Primary)) Then
5290	Begin
5291	If OutLen[2+Offset+Offset1]<>SQL_NULL_DATA Then
5292	Begin
5293	Move(C[2+Offset+Offset1],S1[1],OutLen[2+Offset+Offset1]);
5294	S1[0]:=Chr(OutLen[2+Offset+Offset1]);
5295	If S1[Length(S1)]=#0 Then
5296	If length(S1)>0 Then dec(S1[0]);
5297	If not Primary Then
5298	Begin
5299	S:=S+'>'+S1;
5300	If OutLen[2+Offset+Offset1+1]<>SQL_NULL_DATA Then
5301	Begin
5302	Move(C[2+Offset+Offset1+1],S1[1],OutLen[2+Offset+Offset1+1]);
5303	S1[0]:=Chr(OutLen[2+Offset+Offset1+1]);
5304	If S1[Length(S1)]=#0 Then
5305	If length(S1)>0 Then dec(S1[0]);
5306	S:=S+'.'+S1;
5307	End;
5308	End
5309	Else S:=S1+'.'+S;
5310	End;
5311	End;
5312	List.Add(S);
5313	End;
5314	rc:=FDBProcs.SQLFetch(ahstmt);
5315	End;
5316	End;
5317	Except
5318	List.Clear;
5319	End;
5320
5321	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5322	LeaveSQLProcessing;
5323	End;
5324
5325
5326	Procedure TTable.DoOpen;
5327	Var rc:SQLRETURN;
5328	s:String;
5329	fmode:Longword;
5330	Begin
5331	If Not FActive Then Exit;
5332
5333	If Not FillDBProcs(FDBProcs) Then
5334	Begin
5335	LeaveSQLProcessing;
5336	ErrorBox(LoadNLSStr(SErrLoadingDB));
5337	Active:=False;
5338	Exit; {Error}
5339	End;
5340
5341	If Not FOpened Then
5342	Begin
5343	EnterSQLProcessing;
5344
5345	Try
5346	If FBeforeOpen<>Nil Then FBeforeOpen(Self);
5347
5348	FDBProcs.ahstmt:=0;
5349	FDBProcs.ahenv:=0;
5350	If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then
5351	Begin
5352	LeaveSQLProcessing;
5353	ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+
5354	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5355	Active:=False;
5356	Exit;
5357	End;
5358
5359	{Connect To Server}
5360	FDBProcs.ahdbc:=0;
5361	If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then
5362	Begin
5363	LeaveSQLProcessing;
5364	ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+
5365	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5366	DoClose;
5367	Exit;
5368	End;
5369
5370	{Set autocommit OFF}
5371	If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then
5372	Begin
5373	LeaveSQLProcessing;
5374	ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+
5375	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
5376	DoClose;
5377	Exit;
5378	End;
5379
5380	{Connect}
5381	Try
5382	If FDBProcs.uid='' Then
5383	Begin
5384	If FDBProcs.pwd='' Then
5385	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5386	Nil,0,Nil,0)
5387	Else
5388	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5389	Nil,0,FDBProcs.pwd,SQL_NTS);
5390	End
5391	Else If FDBProcs.pwd='' Then
5392	Begin
5393	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5394	FDBProcs.uid,SQL_NTS,Nil,0);
5395	End
5396	Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
5397	FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS);
5398	If rc<>SQL_SUCCESS Then
5399	Begin
5400	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0);
5401	DoClose;
5402	SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S);
5403	End;
5404	Except
5405	ON E:ESQLError Do
5406	Begin
5407	LeaveSQLProcessing;
5408	ErrorBox(E.Message);
5409	Exit;
5410	End;
5411	Else Raise;
5412	End;
5413
5414	FOpened:=True;
5415
5416	LeaveSQLProcessing;
5417	If FAfterOpen<>Nil Then AfterOpen(Self);
5418	Except
5419	LeaveSQLProcessing;
5420	Raise;
5421	End;
5422	End;
5423	End;
5424
5425
5426	Procedure TTable.DoClose;
5427	Begin
5428	Try
5429	If FBeforeClose<>Nil Then FBeforeClose(Self);
5430
5431	If FOpened Then
5432	Begin
5433	CloseStmt;
5434	Post; //Commit All transactions
5435	End;
5436
5437	FActive:=False;
5438	FDataSetLocked:=True;
5439	FFieldDefs.Clear;
5440	FDataSetLocked:=False;
5441
5442	If FDBProcs.ahdbc <> 0 Then
5443	Begin
5444	If FOpened Then
5445	If FDBProcs.SQLDisconnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then
5446	ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5447	If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc) <> SQL_SUCCESS Then
5448	ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5449	FDBProcs.ahdbc := 0;
5450	End;
5451
5452	If FDBProcs.ahenv <> 0 Then
5453	Begin
5454	If FDBProcs.SQLFreeEnv(FDBProcs.ahenv) <> SQL_SUCCESS Then
5455	ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
5456	FDBProcs.ahenv := 0;
5457	End;
5458
5459	Inherited DoClose;
5460
5461	DataChange(deDataBaseChanged);
5462
5463	If FAfterClose<>Nil Then FAfterClose(Self);
5464	Except
5465	Raise;
5466	End;
5467	End;
5468
5469
5470	Procedure TTable.GetStoredProcNames(List:TStrings);
5471	Var
5472	ahstmt:SQLHSTMT;
5473	cols:SQLSMALLINT;
5474	I:LongInt;
5475	C:Array[0..4] Of cstring;
5476	OutLen:Array[0..4] Of SQLINTEGER;
5477	rc:SQLRETURN;
5478	S,S1:String;
5479	OldActive:Boolean;
5480	OldOpen:Boolean;
5481	Begin
5482	Inherited GetStoredProcNames(List);
5483
5484	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5485	Begin
5486	OldActive:=FActive;
5487	OldOpen:=FOpened;
5488	If Designed Then
5489	If Not FOpened Then
5490	Begin
5491	FActive:=True;
5492	DoOpen;
5493	If Not FOpened Then Active:=False;
5494	End;
5495
5496	If FOpened Then
5497	Begin
5498	EnterSQLProcessing;
5499	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5500
5501	If FDBProcs.SQLProcedures(ahstmt,Nil,0,Nil,0,Nil,0)=SQL_SUCCESS Then
5502	Begin
5503	FDBProcs.SQLNumResultCols(ahstmt,cols);
5504	If cols>3 Then cols:=3;
5505	For I := 0 To cols-1 Do
5506	FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5507	rc:=FDBProcs.SQLFetch(ahstmt);
5508	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5509	Begin
5510	If OutLen[2]<>SQL_NULL_DATA Then
5511	Begin
5512	Move(C[2],S[1],OutLen[2]);
5513	S[0]:=Chr(OutLen[2]);
5514	If S[length(S)]=#0 Then
5515	If length(S)>0 Then dec(S[0]);
5516	If OutLen[0]<>SQL_NULL_DATA Then
5517	Begin
5518	Move(C[0],S1[1],OutLen[0]);
5519	S1[0]:=Chr(OutLen[0]);
5520	If S1[length(S1)]=#0 Then
5521	If length(S1)>0 Then dec(S1[0]);
5522	If S1<>'' Then S:=S1+'.'+S;
5523	End;
5524	List.Add(S);
5525	End;
5526	rc:=FDBProcs.SQLFetch(ahstmt);
5527	End;
5528	End
5529	Else List.Clear;
5530
5531	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5532	LeaveSQLProcessing;
5533	End;
5534
5535	If Designed Then
5536	Begin
5537	If Not OldOpen Then DoClose;
5538	FActive:=OldActive;
5539	End;
5540	End;
5541	End;
5542
5543
5544	Procedure TTable.GetDataSources(List:TStrings);
5545	Var
5546	AliasName,DriverName,Advanced,UID:String;
5547	t,Count:LongInt;
5548	Begin
5549	List.Clear;
5550
5551	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5552	Begin
5553	Count:=GetDbAliasNamesCount;
5554	For t:=0 To Count-1 Do
5555	Begin
5556	GetDBAlias(t,AliasName,DriverName,Advanced,UID);
5557	List.Add(AliasName);
5558	End;
5559	End;
5560	End;
5561
5562
5563	Procedure TTable.DoDelete;
5564	Var C,c1:cstring;
5565	ahstmt,ahstmt1:SQLHSTMT;
5566	S:String;
5567	resultCols:SQLSMALLINT;
5568	rc:SQLRETURN;
5569	T:LongInt;
5570	T1,RowId:LongInt;
5571	Res:SQLINTEGER;
5572	OracleRowId:CString;
5573	Begin
5574	If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5575
5576	If (Not IsTable) Then exit; //cannot update this result set...
5577
5578	EnterSQLProcessing;
5579	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5580
5581	Case FDBProcs.DBType Of
5582	Native_mSQL: C:='SELECT _rowid,'+Fields[0].FieldName+' FROM '+TableName;
5583	Native_Oracle7: C:='SELECT ROWID,'+Fields[0].FieldName+' FROM '+TableName+' FOR UPDATE'
5584	Else C:='SELECT * FROM '+TableName+' FOR UPDATE';
5585	End;
5586
5587	If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
5588	Begin
5589	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5590	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5591	SQLError('Error executing SELECT SQL statement: '+S);
5592	End;
5593
5594	FDBProcs.SQLNumResultCols(ahstmt,resultCols);
5595	If resultCols=0 Then //Not A Select statement
5596	Begin
5597	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5598	LeaveSQLProcessing;
5599	Exit;
5600	End;
5601
5602	If FDBProcs.DBType=Native_mSQL Then T1:=Fields[0].FRow-1
5603	Else T1:=Fields[0].FRow;
5604
5605	For T:=0 To T1 Do
5606	Begin
5607	rc:=FDBProcs.SQLFetch(ahstmt);
5608	If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then
5609	Begin
5610	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5611	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5612	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5613	End;
5614	End;
5615
5616	If FDBProcs.DBType=Native_mSQL Then
5617	Begin
5618	If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then
5619	Begin
5620	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5621	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5622	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5623	End;
5624	End;
5625
5626	If FDBProcs.DBType=Native_Oracle7 Then
5627	Begin
5628	If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then
5629	Begin
5630	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5631	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5632	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5633	End;
5634	End;
5635
5636	FillChar(c1,255,0);
5637	If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then
5638	Begin
5639	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5640	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5641	SQLError('Error executing SQLGetCursorName statement: '+S);
5642	End;
5643
5644	If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt
5645	Else
5646	Begin
5647	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5648	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1);
5649	End;
5650	S:='DELETE FROM '+TableName;
5651	Case FDBProcs.DBType Of
5652	Native_mSQL: S:=S+' WHERE _rowid='+tostr(RowId);
5653	Native_Oracle7: S:=S+' WHERE ROWID='+#39+OracleRowId+#39;
5654	Else S:=S+' WHERE CURRENT OF '+c1;
5655	End;
5656	C:=S;
5657
5658	If FDBProcs.SQLExecDirect(ahstmt1,C,SQL_NTS)<>SQL_SUCCESS Then
5659	Begin
5660	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1);
5661	FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5662	SQLError('Error executing SQL DELETE statement: '+S);
5663	End;
5664
5665	FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5666	LeaveSQLProcessing;
5667
5668	Inherited DoDelete;
5669	End;
5670
5671
5672	Procedure TTable.CommitInsert(Commit:Boolean);
5673	Var ahstmt:SQLHSTMT;
5674	Ansi:AnsiString;
5675	S:String;
5676	T:LongInt;
5677	Field:TField;
5678	i:LongInt;
5679	Begin
5680	Inherited CommitInsert(Commit);
5681
5682	If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5683
5684	If Commit Then
5685	Begin
5686	EnterSQLProcessing;
5687	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5688
5689	Ansi:='INSERT INTO '+TableName+' (';
5690	For T:=0 To FieldCount-1 Do
5691	Begin
5692	Ansi:=Ansi+FieldNames[T];
5693	If T<>FieldCount-1 Then Ansi:=Ansi+',';
5694	End;
5695
5696	Ansi:=Ansi+') VALUES(';
5697	For T:=0 To FieldCount-1 Do
5698	Begin
5699	Field:=Fields[T];
5700	If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39
5701	Else
5702	Begin
5703	S:=Field2String(field);
5704	Ansi:=Ansi+S;
5705	End;
5706	If T<>FieldCount-1 Then Ansi:=Ansi+',';
5707	End;
5708	Ansi:=Ansi+')';
5709
5710	//ErrorBox2(PChar(Ansi)^);
5711	If FDBProcs.SQLExecDirect(ahstmt,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then
5712	Begin
5713	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5714	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5715	SQLError('Error executing INSERT SQL statement: '+S);
5716	End;
5717
5718	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5719	LeaveSQLProcessing;
5720
5721	FRowIsInserted:=False;
5722	QueryTable;
5723	End
5724	Else
5725	Begin
5726	RemoveCurrentFields;
5727
5728	RowInserted := False;
5729	End;
5730	End;
5731
5732
5733	Function TTable.UpdateFieldSelect(Field:TField):Boolean;
5734	Var ahstmt,ahstmt1:SQLHSTMT;
5735	resultCols:SQLSMALLINT;
5736	C,c1:cstring;
5737	rc:SQLRETURN;
5738	S:String;
5739	T,T1,RowId:LongInt;
5740	Res:SQLINTEGER;
5741	Ansi:AnsiString;
5742	OracleRowId:CString;
5743	Begin
5744	Result:=False;
5745	If Not FOpened Then Exit;
5746	If ((field=Nil)Or(FSelect.Count=0)) Then Exit;
5747	If FRowIsInserted Then
5748	Begin
5749	Result:=True;
5750	Exit;
5751	End;
5752
5753	If ReadOnly Then SQLError('Cannot modify a readonly dataset!');
5754	If (Not IsTable) Then exit; //cannot update this result set...
5755
5756	EnterSQLProcessing;
5757	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5758
5759	Case FDBProcs.DBType Of
5760	Native_mSQL: C:='SELECT _rowid,'+Field.FieldName+' FROM '+TableName;
5761	Native_Oracle7: C:='SELECT ROWID,'+Field.FieldName+' FROM '+TableName+' FOR UPDATE';
5762	Else C:='SELECT * FROM '+TableName+' FOR UPDATE';
5763	End;
5764
5765	If FDBProcs.SQLExecDirect(ahstmt,C,SQL_NTS)<>SQL_SUCCESS Then
5766	Begin
5767	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5768	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5769	SQLError('Error executing SELECT SQL statement: '+S);
5770	End;
5771
5772	FDBProcs.SQLNumResultCols(ahstmt,resultCols);
5773	If resultCols=0 Then //Not A Select statement
5774	Begin
5775	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5776	LeaveSQLProcessing;
5777	Exit;
5778	End;
5779
5780	If FDBProcs.DBType=Native_mSQL Then T1:=Field.FRow-1
5781	Else T1:=Field.FRow;
5782
5783	For T:=0 To T1 Do
5784	Begin
5785	rc:=FDBProcs.SQLFetch(ahstmt);
5786	If ((rc=SQL_NO_DATA_FOUND)Or(rc=SQL_ERROR)) Then
5787	Begin
5788	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5789	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5790	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5791	End;
5792	End;
5793
5794	If FDBProcs.DBType=Native_mSQL Then
5795	Begin
5796	If FDBProcs.SQLGetData(ahstmt,1,SQL_INTEGER,RowId,4,Res)<>SQL_SUCCESS Then
5797	Begin
5798	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5799	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5800	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5801	End;
5802	End;
5803
5804	If FDBProcs.DBType=Native_Oracle7 Then
5805	Begin
5806	If FDBProcs.SQLGetData(ahstmt,1,SQL_C_CHAR,OracleRowId,255,Res)<>SQL_SUCCESS Then
5807	Begin
5808	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5809	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5810	SQLError(LoadNLSStr(SErrorFetchingSQLStatement)+': '+S);
5811	End;
5812	End;
5813
5814	FillChar(c1,255,0);
5815	If FDBProcs.SQLGetCursorName(ahstmt,c1,255,resultCols)<>SQL_SUCCESS Then
5816	Begin
5817	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5818	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5819	SQLError('Error executing SQLGetCursorName statement: '+S);
5820	End;
5821
5822	If FDBProcs.DBType=Native_Oracle7 Then ahstmt1:=ahstmt
5823	Else
5824	Begin
5825	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5826	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt1);
5827	End;
5828
5829	Ansi:='UPDATE '+TableName+' SET '+field.FieldName+'=';
5830	If Field.DataType=ftMemo Then Ansi:=Ansi+#39+PChar(Field.FValue)^+#39
5831	Else Ansi:=Ansi+Field2String(field);
5832
5833	Case FDBProcs.DBType Of
5834	Native_mSQL: Ansi:=Ansi+' WHERE _rowid='+tostr(RowId);
5835	Native_Oracle7: Ansi:=Ansi+' WHERE ROWID='+#39+OracleRowId+#39;
5836	Else Ansi:=Ansi+' WHERE CURRENT OF '+c1;
5837	End;
5838
5839	If FDBProcs.SQLExecDirect(ahstmt1,PChar(Ansi)^,SQL_NTS)<>SQL_SUCCESS Then
5840	Begin
5841	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt1);
5842	FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5843	SQLError('Error executing SQL UPDATE statement: '+S);
5844	End;
5845
5846	FDBProcs.SQLFreeStmt(ahstmt1,SQL_DROP);
5847	LeaveSQLProcessing;
5848	Result:=True;
5849	End;
5850
5851
5852	Procedure TTable.DoCancel;
5853	Begin
5854	FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_ROLLBACK);
5855	End;
5856
5857
5858	Procedure TTable.DoPost;
5859	Begin
5860	FDBProcs.SQLTransact(FDBProcs.ahenv,FDBProcs.ahdbc,SQL_COMMIT);
5861	End;
5862
5863
5864	Procedure TTable.CloseStmt;
5865	Var I:LongInt;
5866	Begin
5867	If Not FOpened Then Exit;
5868
5869	{Free statement Handle}
5870	If FDBProcs.ahstmt<>0 Then
5871	Begin
5872	FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
5873	FDBProcs.ahstmt:=0;
5874	End;
5875	End;
5876
5877
5878	Procedure TTable.UpdateIndexDefs;
5879	Var
5880	ahstmt:SQLHSTMT;
5881	cols:SQLSMALLINT;
5882	I:LongInt;
5883	C:Array[0..9] Of cstring;
5884	OutLen:Array[0..9] Of SQLINTEGER;
5885	rc:SQLRETURN;
5886	S,S1,Fields:String;
5887	OldActive:Boolean;
5888	OldOpen:Boolean;
5889	IndexDef:TIndexDef;
5890	Begin
5891	If FIndexDefs<>Nil Then FIndexDefs.Clear
5892	Else FIndexDefs.Create(Self);
5893	If FIndexFieldMap<>Nil Then FIndexFieldMap.Clear;
5894
5895	If (Not IsTable) Then SQLError('Illegal operation');
5896
5897	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
5898	Begin
5899	OldActive:=FActive;
5900	OldOpen:=FOpened;
5901	If Not FOpened Then
5902	Begin
5903	FActive:=True;
5904	DoOpen;
5905	If Not FOpened Then Active:=False;
5906	End;
5907
5908	If FOpened Then
5909	If @FDBProcs.SQLStatistics<>Nil Then
5910	Begin
5911	EnterSQLProcessing;
5912	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
5913
5914	If FDBProcs.SQLStatistics(ahstmt,Nil,0,Nil,0,TableName,SQL_NTS,SQL_INDEX_ALL,SQL_ENSURE)=SQL_SUCCESS Then
5915	Begin
5916	FDBProcs.SQLNumResultCols(ahstmt,cols);
5917	If cols>9 Then cols:=9;
5918	For I := 0 To cols-1 Do
5919	FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
5920
5921	rc:=FDBProcs.SQLFetch(ahstmt);
5922	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
5923	Begin
5924	If OutLen[5]<>SQL_NULL_DATA Then
5925	Begin
5926	Move(C[5],S[1],OutLen[5]);
5927	S[0]:=Chr(OutLen[5]);
5928	If S[length(s)]=#0 Then
5929	If length(S)>0 Then dec(S[0]);
5930	If OutLen[4]<>SQL_NULL_DATA Then
5931	Begin
5932	Move(C[4],S1[1],OutLen[4]);
5933	S1[0]:=Chr(OutLen[4]);
5934	If S1[length(S1)]=#0 Then
5935	If length(S1)>0 Then dec(S1[0]);
5936	If S1<>'' Then S:=S1+'.'+S;
5937	End;
5938
5939	//get column name
5940	If OutLen[8]<>SQL_NULL_DATA Then
5941	Begin
5942	Move(C[8],Fields[1],OutLen[8]);
5943	Fields[0]:=Chr(OutLen[8]);
5944	If Fields[length(Fields)]=#0 Then
5945	If length(Fields)>0 Then dec(Fields[0]);
5946	End;
5947
5948	If ((s<>'')And(Fields<>'')) Then
5949	Begin
5950	If FIndexDefs.IndexOf(s)>=0 Then
5951	Begin
5952	IndexDef:=FIndexDefs.Items[FIndexDefs.IndexOf(s)];
5953	AssignStr(IndexDef.FFields,IndexDef.Fields+';'+Fields);
5954	End
5955	Else FIndexDefs.Add(s,Fields,[]);
5956	End;
5957	End;
5958	rc:=FDBProcs.SQLFetch(ahstmt);
5959	End;
5960	End
5961	Else
5962	Begin
5963	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,ahstmt);
5964	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5965	DataBaseError(s);
5966	End;
5967
5968	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
5969	LeaveSQLProcessing;
5970	End;
5971
5972	If Not OldOpen Then DoClose;
5973	FActive:=OldActive;
5974	End;
5975	End;
5976
5977	Procedure TTable.UpdateFieldDefs;
5978	Begin
5979	QueryTable;
5980	End;
5981
5982	Procedure TTable.QueryTable;
5983	Var
5984	resultCols:SQLSMALLINT;
5985	colName:cstring;
5986	colNameLen:SQLSMALLINT;
5987	colType:SQLSMALLINT;
5988	Size:SQLUINTEGER;
5989	Scale:SQLSMALLINT;
5990	I:LongInt;
5991	S:String;
5992	Select:PChar;
5993	Temp:TStringList;
5994	t2:String;
5995	J,j1:String;
5996	First:Boolean;
5997	B:Byte;
5998	field:TField;
5999	MasterTable:TTable;
6000	rc:SQLRETURN;
6001	pfNullable:SQLSMALLINT;
6002	FieldDef:TFieldDef;
6003	Label lll;
6004	Begin
6005	If Not FOpened Then Exit;
6006
6007	//Erase All tables And Reset Object
6008	CloseStmt;
6009	FFieldDefs.Clear;
6010	FCurrentRow:=-1;
6011	FCurrentField:=0;
6012
6013	If ((Self Is TTable)And(TTable(Self).FMasterSource<>Nil)And
6014	(TTable(Self).FMasterSource.DataSet Is TTable)) Then
6015	Begin
6016	Temp.Create;
6017
6018	t2:=TTable(TTable(Self).FMasterSource.DataSet).TableName;
6019	Temp.Add('SELECT * FROM '+TableName);
6020
6021	S:=TTable(Self).MasterFields;
6022	First:=True;
6023	MasterTable:=TTable(TTable(Self).FMasterSource.DataSet);
6024	While S<>'' Do
6025	Begin
6026	B:=Pos(';',S);
6027	If B<>0 Then
6028	Begin
6029	J:=Copy(S,1,B-1);
6030	System.Delete(S,1,B);
6031	End
6032	Else
6033	Begin
6034	J:=S;
6035	S:='';
6036	End;
6037
6038	B:=Pos('=',J);
6039	If B<>0 Then
6040	Begin
6041	j1:=System.Copy(J,B+1,255);
6042	J[0]:=Chr(B-1);
6043	End
6044	Else j1:=J;
6045
6046	field:=MasterTable.FieldFromColumnName[j1];
6047	If field=Nil Then
6048	Begin
6049	Temp.Destroy;
6050	Goto lll;
6051	End;
6052
6053	j1:=Field2String(field);
6054
6055	If First Then Temp.Add('WHERE '+J+'='+j1)
6056	Else Temp.Add('AND '+J+'='+j1);
6057	First:=False;
6058	End;
6059	Select:=Temp.GetText;
6060
6061	Temp.Destroy;
6062	End
6063	Else
6064	Begin
6065	lll:
6066	Select:=FSelect.GetText;
6067	End;
6068
6069	If Select=Nil Then
6070	Begin
6071	DoClose;
6072	Exit;
6073	End;
6074
6075	While ((Select^<>'')And(Select^[length(Select^)-1] In [#13,#10])) Do
6076	Select^[length(Select^)-1]:=#0;
6077
6078	EnterSQLProcessing;
6079	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6080
6081	Try
6082	If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then
6083	Begin
6084	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6085	CloseStmt;
6086	DoClose;
6087	SQLError('Error executing SELECT statement: '+S);
6088	End;
6089
6090	{The driver determines the number of rows in the result set}
6091	rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
6092	FMaxRows:=0;
6093	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
6094	Begin
6095	inc(FMaxRows);
6096	rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
6097	End;
6098	FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
6099	FDBProcs.ahstmt:=0;
6100
6101	{The driver recreates the result set}
6102	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6103	FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN);
6104	If FDBProcs.SQLExecDirect(FDBProcs.ahstmt,Select^,SQL_NTS)<>SQL_SUCCESS Then
6105	Begin
6106	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6107	CloseStmt;
6108	DoClose;
6109	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
6110	End;
6111
6112	{The driver determines the result set columns}
6113	FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols);
6114	If resultCols=0 Then //Not A Select statement
6115	Begin
6116	CloseStmt;
6117	SQLError(LoadNLSStr(SEmptyResultSet));
6118	End
6119	Else
6120	Begin
6121	{Store Result Columns}
6122	For I := 0 To resultCols-1 Do
6123	Begin
6124	Size:=0;
6125	FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName,
6126	SizeOf(colName), colNameLen, colType, Size, Scale, pfNullable);
6127	If Size>65535 Then Size:=4096;
6128	S:=colName;
6129
6130	Case ColType Of
6131	SQL_REAL:Size:=4;
6132	SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8;
6133	End; //case
6134
6135	FFieldDefs.Add(S, MapSQLType(colType), Size, pfNullable=SQL_NO_NULLS);
6136
6137	FieldDef := FFieldDefs[I];
6138	FieldDef.Precision := Scale;
6139	End;
6140
6141	FCurrentRow:=0; {First Row}
6142	FCurrentField:=0; {First field}
6143	End;
6144
6145	Post; //Commit All transactions Until here
6146	StrDispose(Select);
6147	LeaveSQLProcessing;
6148	Except
6149	ON E:ESQLError Do
6150	Begin
6151	StrDispose(Select);
6152	CloseStmt;
6153	LeaveSQLProcessing;
6154	ErrorBox(E.Message);
6155	End;
6156	Else
6157	Begin
6158	StrDispose(Select);
6159	CloseStmt;
6160	LeaveSQLProcessing;
6161	Raise;
6162	End;
6163	End;
6164
6165	DataChange(deDataBaseChanged);
6166	End;
6167
6168
6169	{
6170	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6171	º º
6172	º Speed-Pascal/2 Version 2.0 º
6173	º º
6174	º Speed-Pascal Component Classes (SPCC) º
6175	º º
6176	º This section: TQuery Class Implementation º
6177	º º
6178	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6179	º º
6180	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6181	}
6182
6183	Procedure TQuery.RefreshTable;
6184	Begin
6185	If ((ComponentState*[csReading]<>[])Or(FDataSetLocked)) Then
6186	Begin
6187	FRefreshOnLoad:=FActive;
6188	Exit;
6189	End;
6190	DoOpen;
6191	If Not FOpened Then Exit;
6192	If FSelect.Count<>0 Then QueryTable;
6193	End;
6194
6195	Procedure TQuery.SetSQL(NewValue:TStrings);
6196	Begin
6197	If ((NewValue=FSelect)Or(NewValue.Equals(FSelect))) Then Exit; {!}
6198	FSelect.Assign(NewValue);
6199	If FActive Then RefreshTable;
6200	End;
6201
6202	Procedure TQuery.SetupComponent;
6203	Begin
6204	Inherited SetupComponent;
6205	ReadOnly:=True;
6206	Name:='Query';
6207	End;
6208
6209	Function TQuery.WriteSCUResource(Stream:TResourceStream):Boolean;
6210	Var aText:PChar;
6211	Begin
6212	Result:=Inherited WriteSCUResource(Stream);
6213	If Result=False Then Exit;
6214	aText:=FSelect.GetText;
6215	If aText<>Nil Then
6216	Begin
6217	Result:=Stream.NewResourceEntry(rnDBQuery,aText^,Length(aText^)+1);
6218	StrDispose(aText);
6219	End;
6220	End;
6221
6222	Procedure TQuery.ReadSCUResource(Const ResName:TResourceName;Var Data;DataLen:LongInt);
6223	Var aText:PChar;
6224	Begin
6225	If ResName = rnDBQuery Then
6226	Begin
6227	aText:=@Data;
6228	FSelect.SetText(aText);
6229	End
6230	Else Inherited ReadSCUResource(ResName,Data,DataLen)
6231	End;
6232
6233	{
6234	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6235	º º
6236	º Speed-Pascal/2 Version 2.0 º
6237	º º
6238	º Speed-Pascal Component Classes (SPCC) º
6239	º º
6240	º This section: TParam Class Implementation º
6241	º º
6242	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6243	º º
6244	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6245	}
6246
6247	Procedure TParam.SetAsBCD(Value: Currency);
6248	Begin
6249	FNull := False;
6250	FBound := True;
6251	FData:=Value;
6252	End;
6253
6254	Procedure TParam.SetAsBoolean(Value: Boolean);
6255	Begin
6256	FNull := False;
6257	FBound := True;
6258	FData:=Value;
6259	End;
6260
6261	Procedure TParam.SetAsCurrency(Value:Extended);
6262	Begin
6263	FNull := False;
6264	FBound := True;
6265	FData:=Value;
6266	End;
6267
6268	Procedure TParam.SetAsDate(Value: TDateTime);
6269	Begin
6270	FNull := False;
6271	FBound := True;
6272	FData:=Value;
6273	End;
6274
6275	Procedure TParam.SetAsDateTime(Value: TDateTime);
6276	Begin
6277	FNull := False;
6278	FBound := True;
6279	FData:=Value;
6280	End;
6281
6282	Procedure TParam.SetAsFloat(Const Value:Extended);
6283	Begin
6284	FNull := False;
6285	FBound := True;
6286	FData:=Value;
6287	End;
6288
6289	Procedure TParam.SetAsInteger(Value: Longint);
6290	Begin
6291	FNull := False;
6292	FBound := True;
6293	FData:=Value;
6294	End;
6295
6296	Procedure TParam.SetAsString(Const Value:String);
6297	Begin
6298	FNull := False;
6299	FBound := True;
6300	FData:=Value;
6301	End;
6302
6303	Procedure TParam.SetAsSmallInt(Value: LongInt);
6304	Begin
6305	FNull := False;
6306	FBound := True;
6307	FData:=Value;
6308	End;
6309
6310	Procedure TParam.SetAsTime(Value: TDateTime);
6311	Begin
6312	FNull := False;
6313	FBound := True;
6314	FData:=Value;
6315	End;
6316
6317	Procedure TParam.SetAsVariant(Value: Variant);
6318	Begin
6319	FNull := False;
6320	FBound := True;
6321	Case VarType(Value) Of
6322	varByte,varSmallint:DataType:=ftSmallInt;
6323	varInteger,varLongInt,varLongWord:DataType:=ftInteger;
6324	varCurrency:DataType:=ftBCD;
6325	varSingle,varDouble,varExtended:DataType:=ftFloat;
6326	varBoolean:DataType:=ftBoolean;
6327	varString:DataType:=ftString;
6328	Else DataType := ftUnknown;
6329	End;
6330	FData := Value;
6331	End;
6332
6333	Procedure TParam.SetAsWord(Value: LongInt);
6334	Begin
6335	FNull := False;
6336	FBound := True;
6337	FData:=Value;
6338	End;
6339
6340	Function TParam.GetAsBCD: Currency;
6341	Begin
6342	Result:=FData;
6343	End;
6344
6345	Function TParam.GetAsBoolean: Boolean;
6346	Begin
6347	Result:=FData;
6348	End;
6349
6350	Function TParam.GetAsDateTime: TDateTime;
6351	Begin
6352	Result:=FData;
6353	End;
6354
6355	Function TParam.GetAsFloat:Extended;
6356	Begin
6357	Result:=FData;
6358	End;
6359
6360	Function TParam.GetAsInteger: Longint;
6361	Begin
6362	Result:=FData;
6363	End;
6364
6365	Function TParam.GetAsString:String;
6366	Begin
6367	Result:=FData;
6368	End;
6369
6370	Function TParam.GetAsVariant: Variant;
6371	Begin
6372	Result:=FData;
6373	End;
6374
6375	Function TParam.IsEqual(Value: TParam): Boolean;
6376	Begin
6377	result:=False;
6378	If ParamType=Value.ParamType Then
6379	If Bound=Value.Bound Then
6380	If VarType(FData)=VarType(Value.FData) Then
6381	If Name=Value.Name Then
6382	If FData=Value.FData Then result:=True;
6383	End;
6384
6385	Procedure TParam.SetDataType(Value: TFieldType);
6386	Begin
6387	FData := 0;
6388	FDataType := Value;
6389	End;
6390
6391	Procedure TParam.SetText(Const Value:String);
6392	Begin
6393	FNull := False;
6394	FBound := True;
6395	If FDataType=ftUnknown Then DataType:=ftString;
6396	FData := Value;
6397	Case DataType of
6398	ftBoolean:FData:=Boolean(FData);
6399	ftInteger,ftSmallInt,ftWord: FData := Integer(FData);
6400	ftDateTime,ftTime,ftDate:FData:=Extended(FData);
6401	ftBCD:FData:=Currency(FData);
6402	ftCurrency,ftFloat:FData:=Extended(FData);
6403	End;
6404	End;
6405
6406	Constructor TParam.Create(AParamList:TParams;AParamType: TParamType);
6407	Begin
6408	FParamList:=AParamList;
6409	If FParamList<>Nil Then FParamList.AddParam(Self);
6410	FParamType := AParamType;
6411	DataType := ftUnknown;
6412	FBound := False;
6413	End;
6414
6415	Destructor TParam.Destroy;
6416	Begin
6417	If FParamList<>Nil Then FParamList.RemoveParam(Self);
6418	If FName<>Nil Then FreeMem(FName,length(FName^)+1);
6419	Inherited Destroy;
6420	End;
6421
6422	Function TParam.GetName:String;
6423	Begin
6424	If FName=Nil Then result:=''
6425	Else Result:=FName^;
6426	End;
6427
6428	Procedure TParam.SetName(Const NewValue:String);
6429	Begin
6430	If FName<>Nil Then FreeMem(FName,length(FName^)+1);
6431	GetMem(FName,length(NewValue)+1);
6432	FName^:=NewValue;
6433	End;
6434
6435	Procedure TParam.Assign(Param: TParam);
6436	Begin
6437	If Param=Nil Then exit;
6438	DataType:=Param.DataType;
6439	If not Param.IsNull Then
6440	Begin
6441	FNull := False;
6442	FBound := True;
6443	FData := Param.FData;
6444	End
6445	Else Clear;
6446	Name:=Param.Name;
6447	FBound:=Param.Bound;
6448	If FParamType=ptUnknown Then FParamType:=Param.ParamType;
6449	End;
6450
6451	Procedure TParam.AssignField(Field: TField);
6452	Begin
6453	If Field=Nil Then exit;
6454	DataType:=Field.DataType;
6455	If not Field.IsNull Then
6456	Begin
6457	FNull := False;
6458	FBound := True;
6459	FData := Field.AsString;
6460	End
6461	Else Clear;
6462	Name:=Field.FieldName;
6463	FBound:=True;
6464	End;
6465
6466	Procedure TParam.AssignFieldValue(Field:TField;Const Value: Variant);
6467	Begin
6468	If Field=Nil Then exit;
6469	DataType := Field.DataType;
6470	If VarIsNull(Value) Then Clear
6471	Else
6472	Begin
6473	FNull := False;
6474	FBound := True;
6475	FData := Value;
6476	End;
6477	FBound := True;
6478	End;
6479
6480	Procedure TParam.Clear;
6481	Begin
6482	FData:=0;
6483	FNull:=True;
6484	End;
6485
6486	{
6487	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6488	º º
6489	º Speed-Pascal/2 Version 2.0 º
6490	º º
6491	º Speed-Pascal Component Classes (SPCC) º
6492	º º
6493	º This section: TParams Class Implementation º
6494	º º
6495	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6496	º º
6497	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6498	}
6499
6500	Function TParams.GetParam(Index: Word): TParam;
6501	Begin
6502	result:=FItems[Index];
6503	End;
6504
6505	Function TParams.GetParamValue(Const ParamName:String): Variant;
6506	Var Param:TParam;
6507	Begin
6508	Param:=ParamByName(ParamName);
6509	If Param<>Nil Then Result:=Param.Value;
6510	End;
6511
6512	Procedure TParams.SetParamValue(Const ParamName:String;Const Value: Variant);
6513	Var Param:TParam;
6514	Begin
6515	Param:=ParamByName(ParamName);
6516	If Param<>Nil Then Param.Value:=Value;
6517	End;
6518
6519	Constructor TParams.Create;
6520	Begin
6521	Inherited Create;
6522	FItems.Create;
6523	End;
6524
6525	Destructor TParams.Destroy;
6526	Begin
6527	Clear;
6528	FItems.Destroy;
6529	Inherited Destroy;
6530	End;
6531
6532	Procedure TParams.AddParam(Value: TParam);
6533	Begin
6534	FItems.Add(Value);
6535	End;
6536
6537	Procedure TParams.RemoveParam(Value: TParam);
6538	Begin
6539	FItems.Remove(Value);
6540	If Value.FParamList=Self Then Value.FParamList:=Nil;
6541	End;
6542
6543	Function TParams.CreateParam(FldType:TFieldType;Const ParamName:String;ParamType: TParamType): TParam;
6544	Begin
6545	Result.Create(Self,ParamType);
6546	Result.Name:=ParamName;
6547	Result.DataType := FldType;
6548	End;
6549
6550	Function TParams.Count:LongInt;
6551	Begin
6552	Result:=FItems.Count;
6553	End;
6554
6555	Procedure TParams.Clear;
6556	Var t:LongInt;
6557	Param:TParam;
6558	Begin
6559	For t:=FItems.Count-1 DownTo 0 Do
6560	Begin
6561	Param:=FItems[t];
6562	Param.Destroy;
6563	End;
6564	End;
6565
6566	Function TParams.IsEqual(Value:TParams): Boolean;
6567	Var t:LongInt;
6568	Begin
6569	Result:=False;
6570	If FItems.Count=Value.Count Then
6571	For t:=0 To FItems.Count-1 Do If not Items[t].IsEqual(Value.Items[t]) Then exit;
6572	End;
6573
6574	Function TParams.ParamByName(Const Value:String):TParam;
6575	Var t:LongInt;
6576	Begin
6577	For t:=0 To FItems.Count - 1 Do
6578	Begin
6579	Result:=FItems[t];
6580	If Result.Name=Value Then Exit;
6581	End;
6582	DatabaseError('Invalid stored procedure parameter name: '+Value);
6583	End;
6584
6585
6586	{
6587	ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»
6588	º º
6589	º Speed-Pascal/2 Version 2.0 º
6590	º º
6591	º Speed-Pascal Component Classes (SPCC) º
6592	º º
6593	º This section: TStoredProc Class Implementation º
6594	º º
6595	º (C) 1995,97 SpeedSoft. All rights reserved. Disclosure probibited ! º
6596	º º
6597	ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ
6598	}
6599
6600	Function TStoredProc.GetParamCount:Word;
6601	Begin
6602	Result:=FParams.Count;
6603	End;
6604
6605	Procedure TStoredProc.SetDefaultParams;
6606	Var
6607	ahstmt:SQLHSTMT;
6608	cols:SQLSMALLINT;
6609	I,t:LongInt;
6610	C:Array[0..12] Of cstring;
6611	OutLen:Array[0..12] Of SQLINTEGER;
6612	si:SQLSMALLINT;
6613	rc:SQLRETURN;
6614	S:String;
6615	Cs:CString;
6616	OldActive:Boolean;
6617	OldOpen:Boolean;
6618	pt:TParamType;
6619	ft:TFieldType;
6620	cc:Integer;
6621	Names:TStringList;
6622	Types,Modes:TList;
6623	Label weiter;
6624	Begin
6625	//determine parameter from driver
6626	FParams.Clear;
6627
6628	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then
6629	If StoredProcName<>'' Then
6630	Begin
6631	OldActive:=FActive;
6632	OldOpen:=FOpened;
6633	If Designed Then
6634	If Not FOpened Then
6635	Begin
6636	FActive:=True;
6637	DoOpen;
6638	If Not FOpened Then Active:=False;
6639	End;
6640
6641	If FOpened Then
6642	Begin
6643	If FDBProcs.DBType=Native_Oracle7 Then
6644	Begin
6645	Names.Create;
6646	Types.Create;
6647	Modes.Create;
6648	If not FDBProcs.Oracle7GetProcParams(FProcName,@FDBProcs,Names,Types,Modes) Then
6649	Begin
6650	ErrorBox(SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt));
6651	End
6652	Else
6653	Begin
6654	For t:=0 To Names.Count-1 Do
6655	Begin
6656	i:=LongInt(Types[t]);
6657	ft:=MapSQLType(i);
6658	i:=LongInt(Modes[t]);
6659	If i>=16 Then pt:=ptResult
6660	Else Case i Of
6661	0:pt:=ptInput;
6662	1:pt:=ptOutput;
6663	Else pt:=ptInputOutput;
6664	End; //case
6665	FParams.CreateParam(ft,Names[t],pt);
6666	End;
6667	End;
6668	Names.Destroy;
6669	Types.Destroy;
6670	Modes.Destroy;
6671	End
6672	Else
6673	Begin
6674	EnterSQLProcessing;
6675	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,ahstmt);
6676
6677	Cs:=FProcName;
6678	If FDBProcs.SQLProcedureColumns(ahstmt,Nil,0,Nil,0,Cs,length(FProcName),Nil,0)=SQL_SUCCESS Then
6679	Begin
6680	FDBProcs.SQLNumResultCols(ahstmt,cols);
6681	If cols>13 Then cols:=13;
6682	For I := 0 To cols-1 Do
6683	FDBProcs.SQLBindCol(ahstmt, I + 1, SQL_C_CHAR, C[I], 255, OutLen[I]);
6684	rc:=FDBProcs.SQLFetch(ahstmt);
6685	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
6686	Begin
6687	If OutLen[3]<>SQL_NULL_DATA Then //Parameter name
6688	Begin
6689	Move(C[4],S[1],OutLen[4]); //Parameter type
6690	S[0]:=Chr(OutLen[4]);
6691	Val(S,si,cc);
6692	If cc<>0 Then goto weiter; //illegal
6693
6694	Case si Of
6695	SQL_PARAM_INPUT:pt:=ptInput;
6696	SQL_PARAM_OUTPUT:pt:=ptOutput;
6697	SQL_PARAM_INPUT_OUTPUT:pt:=ptInputOutput;
6698	SQL_RETURN_VALUE:pt:=ptResult;
6699	SQL_RESULT_COL:pt:=ptResultSet;
6700	Else pt:=ptUnknown;
6701	End;
6702
6703	Move(C[5],S[1],OutLen[5]); //Parameter data type
6704	S[0]:=Chr(OutLen[5]);
6705	Val(S,si,cc);
6706	If cc<>0 Then goto weiter; //illegal
6707
6708	ft:=MapSQLType(si);
6709
6710	Move(C[3],S[1],OutLen[3]);
6711	S[0]:=Chr(OutLen[3]);
6712
6713	FParams.CreateParam(ft,S,pt);
6714	End;
6715	weiter:
6716	rc:=FDBProcs.SQLFetch(ahstmt);
6717	End;
6718	End;
6719
6720	FDBProcs.SQLFreeStmt(ahstmt,SQL_DROP);
6721	LeaveSQLProcessing;
6722	End;
6723	End;
6724
6725	If Designed Then
6726	Begin
6727	If Not OldOpen Then DoClose;
6728	FActive:=OldActive;
6729	End;
6730	End;
6731	End;
6732
6733	Procedure TStoredProc.SetPrepared(NewValue:Boolean);
6734	Begin
6735	If not NewValue Then
6736	Begin
6737	FPrepared:=False;
6738	exit;
6739	End;
6740
6741	If ((ComponentState*[csReading]=[])And(Not FDataSetLocked)) Then DoOpen;
6742
6743	If FOpened Then FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
6744
6745	FPrepared:=True;
6746	End;
6747
6748	Procedure TStoredProc.SetParams(NewValue:TParams);
6749	Var t:LongInt;
6750	Begin
6751	FParams.Clear;
6752	For t:=0 To NewValue.Count-1 Do
6753	FParams.CreateParam(NewValue[t].DataType,NewValue[t].Name,NewValue[t].ParamType);
6754	End;
6755
6756	Procedure TStoredProc.SetStoredProcName(NewValue:String);
6757	Begin
6758	CheckInactive;
6759	FProcName:=NewValue;
6760	FParams.Clear;
6761	End;
6762
6763	Constructor TStoredProc.Create(AOwner: TComponent);
6764	Begin
6765	Inherited Create(AOwner);
6766	ReadOnly:=True;
6767	Name:='StoredProc';
6768	FParams.Create;
6769	End;
6770
6771	Destructor TStoredProc.Destroy;
6772	Begin
6773	FParams.Destroy;
6774	Inherited Destroy;
6775	End;
6776
6777	Procedure TStoredProc.CopyParams(Value:TParams);
6778	Begin
6779	Params:=Value;
6780	End;
6781
6782	Procedure TStoredProc.ExecProc;
6783	Var rc:SQLRETURN;
6784	ReturnsResultSet:Boolean;
6785	t:LongInt;
6786	Param:TParam;
6787	s:String;
6788	c:CString;
6789	resultCols:SQLSMALLINT;
6790	I:LongInt;
6791	Size:SQLUINTEGER;
6792	colName:CString;
6793	colNameLen:SQLSMALLINT;
6794	colType:SQLSMALLINT;
6795	Scale:SQLSMALLINT;
6796	FieldDef:TFieldDef;
6797
6798	ptsql,ctype,sqltype,Len:SQLSMALLINT;
6799	p:Pointer;
6800
6801	Function ExecSQL:SQLRETURN;
6802	Var s:String;
6803	c:CString;
6804	t:LongInt;
6805	Begin
6806	If FDBProcs.DBType=Native_Oracle7 Then s:=StoredProcName+'('
6807	Else s:='call '+StoredProcName+'(';
6808	For t:=0 To FParams.Count-1 Do
6809	Begin
6810	Param:=FParams[t];
6811	If Param.ParamType=ptResultSet Then
6812	Begin
6813	ReturnsResultSet:=True;
6814	continue;
6815	End;
6816
6817	If FDBProcs.DBType=Native_Oracle7 Then
6818	Begin
6819	If ((Param.ParamType=ptResult)And(s[1]<>':')) Then s:=':p0='+s
6820	Else
6821	Begin
6822	If s[length(s)]<>'(' Then s:=s+',';
6823	s:=s+':p'+tostr(t+1);
6824	End;
6825	End
6826	Else
6827	Begin
6828	If ((Param.ParamType=ptResult)And(s[1]<>'?')) Then s:='?='+s
6829	Else
6830	Begin
6831	If s[length(s)]<>'(' Then s:=s+',';
6832	s:=s+'?';
6833	End;
6834	End;
6835	End;
6836
6837	If FDBProcs.DBType=Native_Oracle7 Then
6838	s:='BEGIN'+#10+s+');'#10+'END;'
6839	Else
6840	s:='{'+s+')}';
6841	c:=s;
6842	Result:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS);
6843	End;
6844
6845	Procedure BindParameters;
6846	Var i:LongInt;
6847	Param:TParam;
6848	Begin
6849	For i:=0 To FParams.Count-1 Do
6850	Begin
6851	Param:=FParams[i];
6852
6853	Case Param.ParamType Of
6854	ptInput:ptsql:=SQL_PARAM_INPUT;
6855	ptOutput:ptsql:=SQL_PARAM_OUTPUT;
6856	ptResult:
6857	Begin
6858	If FDBProcs.DBType=Native_Oracle7 Then ptsql:=SQL_PARAM_RESULT
6859	Else ptsql:=SQL_PARAM_OUTPUT;
6860	End;
6861	ptInputOutput:ptsql:=SQL_PARAM_INPUT_OUTPUT;
6862	Else Continue; //Next Parameter
6863	End;
6864
6865	Case Param.DataType Of
6866	ftString:
6867	Begin
6868	sqlType:=SQL_CHAR;
6869	cType:=SQL_C_CHAR;
6870	p:=@Param.FResultNTS;
6871	Param.FResultNTS:=Param.AsString;
6872	Len:=Length(Param.FResultNTS);
6873	Param.FOutLen:=SQL_NTS;
6874	End;
6875	ftCurrency:
6876	Begin
6877	sqlType:=SQL_NUMERIC;
6878	cType:=SQL_C_FLOAT;
6879	Len:=10;
6880	p:=@Param.FResultExtended;
6881	Param.FResultExtended:=Param.AsFloat;
6882	Param.FOutLen:=10;
6883	End;
6884	ftInteger:
6885	Begin
6886	sqlType:=SQL_INTEGER;
6887	cType:=SQL_C_LONG;
6888	Len:=4;
6889	p:=@Param.FResultLongInt;
6890	Param.FResultLongInt:=Param.AsInteger;
6891	Param.FOutLen:=4;
6892	End;
6893	ftSmallInt:
6894	Begin
6895	sqlType:=SQL_SMALLINT;
6896	cType:=SQL_C_SHORT;
6897	Len:=2;
6898	p:=@Param.FResultSmallInt;
6899	Param.FResultSmallInt:=Param.AsSmallInt;
6900	Param.FOutLen:=2;
6901	End;
6902	ftFloat:
6903	Begin
6904	sqlType:=SQL_FLOAT;
6905	cType:=SQL_C_FLOAT;
6906	Len:=10;
6907	p:=@Param.FResultExtended;
6908	Param.FResultExtended:=Param.AsFloat;
6909	Param.FOutLen:=10;
6910	End;
6911	ftDate:
6912	Begin
6913	sqlType:=SQL_DATE;
6914	cType:=SQL_C_DATE;
6915	Len:=sizeof(Param.FResultDate);
6916	p:=@Param.FResultDate;
6917	DecodeDate(Param.AsDate,Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day);
6918	Param.FOutLen:=sizeof(Param.FResultDate);
6919	End;
6920	ftTime:
6921	Begin
6922	sqlType:=SQL_TIME;
6923	cType:=SQL_C_TIME;
6924	Len:=sizeof(Param.FResultTime);
6925	p:=@Param.FResultTime;
6926	RoundDecodeTime(Param.AsTime,Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second);
6927	Param.FOutLen:=sizeof(Param.FResultTime);
6928	End;
6929	ftDateTime:
6930	Begin
6931	sqlType:=SQL_TIMESTAMP;
6932	cType:=SQL_C_TIMESTAMP;
6933	Len:=sizeof(Param.FResultDateTime);
6934	p:=@Param.FResultDateTime;
6935	DecodeDate(Param.AsDate,Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day);
6936	RoundDecodeTime(Param.AsTime,Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second);
6937	Param.FOutLen:=sizeof(Param.FResultDateTime);
6938	End;
6939	ftMemo:
6940	Begin
6941	sqlType:=SQL_LONGVARCHAR;
6942	cType:=SQL_C_CHAR;
6943	Len:=0; //??
6944	p:=Nil; //???
6945	Param.FOutLen:=0; //?? current len
6946	End;
6947	ftBlob:
6948	Begin
6949	sqlType:=SQL_VARBINARY;
6950	cType:=SQL_C_BINARY;
6951	Len:=0; //??
6952	p:=Nil; //???
6953	Param.FOutLen:=0; //?? current len
6954	End;
6955	ftGraphic:
6956	Begin
6957	sqlType:=SQL_VARGRAPHIC;
6958	cType:=SQL_C_BINARY;
6959	Len:=0; //??
6960	p:=Nil; //???
6961	Param.FOutLen:=0; //?? current len
6962	End;
6963	End; //case
6964
6965	Try
6966	rc:=FDBProcs.SQLBindParameter(FDBProcs.ahstmt,i+1,ptsql,ctype,sqltype,Len,0,p^,Len,Param.FOutLen);
6967	If rc=SQL_ERROR Then
6968	Begin
6969	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
6970	CloseStmt;
6971	DoClose;
6972	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
6973	End;
6974
6975	Except
6976	ON E:ESQLError Do
6977	Begin
6978	CloseStmt;
6979	ErrorBox(E.Message);
6980	End;
6981	Else
6982	Begin
6983	CloseStmt;
6984	Raise;
6985	End;
6986	End;
6987	If FDBProcs.ahstmt=0 Then
6988	Begin
6989	DoClose;
6990	exit;
6991	End;
6992	End;
6993	End;
6994	Label err;
6995	Begin
6996	If not Prepared Then Prepare;
6997
6998	CloseStmt; //if previous proc returned a result set...
6999	FMaxRows:=0;
7000	If not FOpened Then DoOpen;
7001
7002	If FOpened Then
7003	Begin
7004	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
7005	If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN
7006	Begin
7007	//S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7008	//ErrorBox(S);
7009	End;
7010	End
7011	Else exit;
7012
7013	If FDBProcs.DBType=Native_Oracle7 Then
7014	Begin
7015	rc:=ExecSQL;
7016	If rc=SQL_ERROR Then goto err;
7017	End;
7018
7019	//Bind Parameters
7020	BindParameters;
7021	If FDBProcs.ahstmt=0 Then
7022	Begin
7023	DoClose;
7024	exit;
7025	End;
7026
7027	FFieldDefs.Clear;
7028	FCurrentRow:=-1;
7029	FCurrentField:=0;
7030
7031	ReturnsResultSet:=False;
7032
7033	EnterSQLProcessing;
7034	If FDBProcs.DBType<>Native_Oracle7 Then rc:=ExecSQL
7035	Else rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7036
7037	If rc<>SQL_ERROR Then
7038	Begin
7039	For i:=0 To FParams.Count-1 Do
7040	Begin
7041	Param:=FParams[i];
7042
7043	If Param.ParamType<>ptOutput Then
7044	If Param.ParamType<>ptInputOutput Then
7045	If Param.ParamType<>ptResult Then continue;
7046
7047	Case Param.DataType Of
7048	ftString:
7049	Begin
7050	Param.AsString:=Param.FResultNTS;
7051	End;
7052	ftCurrency:
7053	Begin
7054	Param.AsFloat:=Param.FResultExtended;
7055	End;
7056	ftInteger:
7057	Begin
7058	Param.AsInteger:=Param.FResultLongInt;
7059	End;
7060	ftSmallInt:
7061	Begin
7062	Param.AsSmallInt:=Param.FResultSmallInt;
7063	End;
7064	ftFloat:
7065	Begin
7066	Param.AsFloat:=Param.FResultExtended;
7067	End;
7068	ftDate:
7069	Begin
7070	Param.AsDate:=EncodeDate(Param.FResultDate.Year,Param.FResultDate.Month,Param.FResultDate.Day);
7071	End;
7072	ftTime:
7073	Begin
7074	Param.AsTime:=EncodeTime(Param.FResultTime.Hour,Param.FResultTime.Minute,Param.FResultTime.Second,0);
7075	End;
7076	ftDateTime:
7077	Begin
7078	Param.AsDateTime:=EncodeDate(Param.FResultDateTime.Year,Param.FResultDateTime.Month,Param.FResultDateTime.Day) +
7079	EncodeTime(Param.FResultDateTime.Hour,Param.FResultDateTime.Minute,Param.FResultDateTime.Second, 0);
7080	End;
7081	ftMemo:
7082	Begin
7083	End;
7084	ftBlob:
7085	Begin
7086	End;
7087	ftGraphic:
7088	Begin
7089	End;
7090	End; //case
7091	End; //for
7092
7093	If ReturnsResultSet Then
7094	Begin
7095	{The driver determines the number of rows in the result set}
7096	rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7097	FMaxRows:=0;
7098	While ((rc<>SQL_NO_DATA_FOUND)And(rc<>SQL_ERROR)) Do
7099	Begin
7100	inc(FMaxRows);
7101	rc:=FDBProcs.SQLFetch(FDBProcs.ahstmt);
7102	End;
7103	FDBProcs.SQLFreeStmt(FDBProcs.ahstmt,SQL_DROP);
7104	FDBProcs.ahstmt:=0;
7105
7106	{The driver recreates the result set}
7107	FDBProcs.SQLAllocStmt(FDBProcs.ahdbc,FDBProcs.ahstmt);
7108	If FDBProcs.SQLSetStmtOption(FDBProcs.ahstmt,SQL_CURSOR_TYPE,SQL_CURSOR_KEYSET_DRIVEN)=SQL_ERROR THEN
7109	Begin
7110	//S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7111	//ErrorBox(S);
7112	End;
7113	BindParameters;
7114	If FDBProcs.ahstmt=0 Then
7115	Begin
7116	DoClose;
7117	LeaveSQLProcessing;
7118	exit;
7119	End;
7120
7121	rc:=FDBProcs.SQLExecDirect(FDBProcs.ahstmt,c,SQL_NTS);
7122	If rc=SQL_ERROR Then goto err;
7123
7124	Try
7125	FDBProcs.SQLNumResultCols(FDBProcs.ahstmt,resultCols);
7126	If resultCols=0 Then //Not A Select statement
7127	Begin
7128	CloseStmt;
7129	SQLError(LoadNLSStr(SEmptyResultSet));
7130	End
7131	Else
7132	Begin
7133	{Store Result Columns}
7134	For I := 0 To resultCols-1 Do
7135	Begin
7136	Size:=0;
7137	FDBProcs.SQLDescribeCol(FDBProcs.ahstmt, I + 1, colName,
7138	SizeOf(colName), colNameLen, colType, Size, Scale, Nil);
7139	If Size>65535 Then Size:=4096;
7140	S:=colName;
7141
7142	Case ColType Of
7143	SQL_REAL:Size:=4;
7144	SQL_FLOAT,SQL_DOUBLE,SQL_NUMERIC:Size:=8;
7145	End; //case
7146
7147	FFieldDefs.Add(S, MapSQLType(colType), Size, False);
7148
7149	FieldDef := FFieldDefs[I];
7150	FieldDef.Precision := Scale;
7151	End;
7152
7153	FCurrentRow:=0; {First Row}
7154	FCurrentField:=0; {First field}
7155	End;
7156
7157	Post; //Commit All transactions Until here
7158	DataChange(deDataBaseChanged);
7159	Except
7160	ON E:ESQLError Do
7161	Begin
7162	CloseStmt;
7163	LeaveSQLProcessing;
7164	ErrorBox(E.Message);
7165	End;
7166	Else
7167	Begin
7168	CloseStmt;
7169	LeaveSQLProcessing;
7170	Raise;
7171	End;
7172	End;
7173
7174	//for result sets the statement must remain open...
7175	End
7176	Else CloseStmt;
7177
7178	LeaveSQLProcessing;
7179	End
7180	Else
7181	Begin
7182	err:
7183	LeaveSQLProcessing;
7184	Try
7185	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,FDBProcs.ahstmt);
7186	CloseStmt;
7187	SQLError(LoadNLSStr(SErrorExecutingSQLStatement)+': '+S);
7188	Except
7189	ON E:ESQLError Do
7190	Begin
7191	CloseStmt;
7192	ErrorBox(E.Message);
7193	End;
7194	Else
7195	Begin
7196	CloseStmt;
7197	Raise;
7198	End;
7199	End;
7200	End;
7201	End;
7202
7203	Function TStoredProc.ParamByName(Const Value:String):TParam;
7204	Begin
7205	Result := FParams.ParamByName(Value);
7206	End;
7207
7208	Procedure TStoredProc.Prepare;
7209	Begin
7210	If FParams.Count=0 Then SetDefaultParams;
7211	Prepared:=True;
7212	End;
7213
7214
7215	Procedure TStoredProc.UnPrepare;
7216	Begin
7217	Prepared:=False;
7218	End;
7219
7220
7221	Procedure TStoredProc.DoOpen;
7222	Var rc:SQLRETURN;
7223	S:String;
7224	Begin
7225	If Not FActive Then Exit;
7226
7227	If Not FillDBProcs(FDBProcs) Then
7228	Begin
7229	ErrorBox(LoadNLSStr(SErrLoadingDB));
7230	Active:=False;
7231	Exit; {Error}
7232	End;
7233	FDBProcs.IsStoredProc:=True;
7234
7235	If Not FOpened Then
7236	Begin
7237	Try
7238	If FBeforeOpen<>Nil Then FBeforeOpen(Self);
7239
7240	FDBProcs.ahstmt:=0;
7241	FDBProcs.ahenv:=0;
7242	If AllocateDBEnvironment(FDBProcs)<>SQL_SUCCESS Then
7243	Begin
7244	ErrorBox(LoadNLSStr(SErrAllocDBEnv)+'.'+
7245	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7246	Active:=False;
7247	Exit;
7248	End;
7249
7250	{Connect To Server}
7251	FDBProcs.ahdbc:=0;
7252	If FDBProcs.SQLAllocConnect(FDBProcs.ahenv,FDBProcs.ahdbc)<>SQL_SUCCESS Then
7253	Begin
7254	ErrorBox(LoadNLSStr(SErrAllocDBConnect)+'.'+
7255	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7256	DoClose;
7257	Exit;
7258	End;
7259
7260	{Set autocommit OFF}
7261	If FDBProcs.SQLSetConnectOption(FDBProcs.ahdbc,SQL_AUTOCOMMIT,SQL_AUTOCOMMIT_OFF)<>SQL_SUCCESS Then
7262	Begin
7263	ErrorBox(LoadNLSStr(SErrSettingDBOpts)+'.'+
7264	SQLErrorText(FDBProcs,FDBProcs.ahenv,0,0));
7265	DoClose;
7266	Exit;
7267	End;
7268
7269	{Connect}
7270	Try
7271	If FDBProcs.uid='' Then
7272	Begin
7273	If FDBProcs.pwd='' Then
7274	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7275	Nil,0,Nil,0)
7276	Else
7277	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7278	Nil,0,FDBProcs.pwd,SQL_NTS);
7279	End
7280	Else If FDBProcs.pwd='' Then
7281	Begin
7282	rc:=FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7283	FDBProcs.uid,SQL_NTS,Nil,0);
7284	End
7285	Else rc:= FDBProcs.SqlConnect(FDBProcs.ahdbc,FDBProcs.DataBase,SQL_NTS,
7286	FDBProcs.uid,SQL_NTS,FDBProcs.pwd,SQL_NTS);
7287	If rc<>SQL_SUCCESS Then
7288	Begin
7289	S:=SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0);
7290	DoClose;
7291	SQLError(LoadNLSStr(SErrorDBConnecting)+' "'+DataBase+'".'+#13#10+S);
7292	End;
7293	Except
7294	ON E:ESQLError Do
7295	Begin
7296	ErrorBox(E.Message);
7297	Exit;
7298	End;
7299	Else Raise;
7300	End;
7301
7302	FOpened:=True;
7303	If FAfterOpen<>Nil Then AfterOpen(Self);
7304
7305	If FParams.Count=0 Then SetDefaultParams;
7306	Except
7307	Raise;
7308	End;
7309	End;
7310	End;
7311
7312
7313	Procedure TStoredProc.DoClose;
7314	Var OldOpened:Boolean;
7315	Begin
7316	Try
7317	If FBeforeClose<>Nil Then FBeforeClose(Self);
7318
7319	OldOpened:=FOpened;
7320	TDataSet.DoClose;
7321	FOpened:=OldOpened;
7322
7323	If FOpened Then
7324	Begin
7325	CloseStmt;
7326	Post; //Commit All transactions
7327	End;
7328
7329	FActive:=False;
7330	FDataSetLocked:=True;
7331	FFieldDefs.Clear;
7332
7333	FDataSetLocked:=False;
7334
7335	If FDBProcs.ahdbc<>0 Then
7336	Begin
7337	If FOpened Then
7338	If FDBProcs.SQLDisconnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then
7339	ErrorBox('Disconnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7340	If FDBProcs.SQLFreeConnect(FDBProcs.ahdbc)<>SQL_SUCCESS Then
7341	ErrorBox('FreeConnect error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7342	FDBProcs.ahdbc:=0;
7343	End;
7344
7345	If FDBProcs.ahenv<>0 Then
7346	Begin
7347	If FDBProcs.SQLFreeEnv(FDBProcs.ahenv)<>SQL_SUCCESS Then
7348	ErrorBox('FreeEnv error '+SQLErrorText(FDBProcs,FDBProcs.ahenv,FDBProcs.ahdbc,0));
7349	FDBProcs.ahenv:=0;
7350	End;
7351
7352	FOpened:=False;
7353	DataChange(deDataBaseChanged);
7354
7355	If FAfterClose<>Nil Then FAfterClose(Self);
7356	Except
7357	Raise;
7358	End;
7359	End;
7360
7361
7362	Procedure TStoredProc.Loaded;
7363	Var OldOpen,OldActive:Boolean;
7364	Begin
7365	Inherited Loaded;
7366
7367	OldOpen:=FOpened;
7368	OldActive:=FActive;
7369	FActive:=True;
7370	DoOpen;
7371	If not OldOpen Then DoClose;
7372	FActive:=OldActive;
7373	End;
7374
7375
7376	Procedure TStoredProc.Delete;
7377	Begin
7378	End;
7379
7380
7381	Procedure TStoredProc.Insert;
7382	Begin
7383	End;
7384
7385
7386	Procedure TStoredProc.InsertRecord(Const values:Array Of Const);
7387	Begin
7388	Try
7389	FDataChangeLock:=True;
7390	Insert;
7391	Finally
7392	FDataChangeLock:=False;
7393	End;
7394	SetFields(values);
7395	End;
7396
7397
7398	Function TStoredProc.UpdateFieldSelect(field:TField):Boolean;
7399	Begin
7400	Result:=False;
7401	End;
7402
7403
7404
7405	Begin
7406	End.
7407

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format