1 unit dbf;
2
3 { design info in dbf_reg.pas }
4
5 interface
6
7 {$I dbf_common.inc}
8
9 uses
10 Classes,
11 Db,
12 dbf_common,
13 dbf_dbffile,
14 dbf_parser,
15 dbf_prsdef,
16 dbf_cursor,
17 dbf_fields,
18 dbf_pgfile,
19 dbf_idxfile;
20 {$ifndef fpc}
21 // If you got a compilation error here or asking for dsgnintf.pas, then just add
22 // this file in your project:
23 // dsgnintf.pas in 'C: \Program Files\Borland\Delphi5\Source\Toolsapi\dsgnintf.pas'
24 {$endif}
25
26 type
27
28 //====================================================================
29 pBookmarkData = ^TBookmarkData;
30 TBookmarkData = record
31 PhysicalRecNo: Integer;
32 end;
33
34 pDbfRecord = ^TDbfRecordHeader;
35 TDbfRecordHeader = record
36 BookmarkData: TBookmarkData;
37 BookmarkFlag: TBookmarkFlag;
38 SequentialRecNo: Integer;
39 DeletedFlag: Char;
40 end;
41 //====================================================================
42 TDbf = class;
43 //====================================================================
44 TDbfStorage = (stoMemory,stoFile);
45 TDbfOpenMode = (omNormal,omAutoCreate,omTemporary);
46 TDbfLanguageAction = (laReadOnly, laForceOEM, laForceANSI, laDefault);
47 TDbfTranslationMode = (tmNoneAvailable, tmNoneNeeded, tmSimple, tmAdvanced);
48 TDbfFileName = (dfDbf, dfMemo, dfIndex);
49 //====================================================================
50 TDbfFileNames = set of TDbfFileName;
51 //====================================================================
52 TCompareRecordEvent = procedure(Dbf: TDbf; var Accept: Boolean) of object;
bfnull53 TTranslateEvent = function(Dbf: TDbf; Src, Dest: PChar; ToOem: Boolean): Integer of object;
54 TLanguageWarningEvent = procedure(Dbf: TDbf; var Action: TDbfLanguageAction) of object;
55 TConvertFieldEvent = procedure(Dbf: TDbf; DstField, SrcField: TField) of object;
56 TBeforeAutoCreateEvent = procedure(Dbf: TDbf; var DoCreate: Boolean) of object;
57 //====================================================================
58 // TDbfBlobStream keeps a reference count to number of references to
59 // this instance. Only if FRefCount reaches zero, then the object will be
60 // destructed. AddReference `clones' a reference.
61 // This allows the VCL to use Free on the object to `free' that
62 // particular reference.
63
64 TDbfBlobStream = class(TMemoryStream)
65 private
66 FBlobField: TBlobField;
67 FMode: TBlobStreamMode;
68 FDirty: boolean; { has possibly modified data, needs to be written }
69 FMemoRecNo: Integer;
70 { -1 : invalid contents }
71 { 0 : clear, no contents }
72 { >0 : data from page x }
73 FReadSize: Integer;
74 FRefCount: Integer;
75
GetTransliteratenull76 function GetTransliterate: Boolean;
77 procedure Translate(ToOem: Boolean);
78 procedure SetMode(NewMode: TBlobStreamMode);
79 public
80 constructor Create(FieldVal: TField);
81 destructor Destroy; override;
82
AddReferencenull83 function AddReference: TDbfBlobStream;
84 procedure FreeInstance; override;
85
86 procedure Cancel;
87 procedure Commit;
88
89 property Dirty: boolean read FDirty;
90 property Transliterate: Boolean read GetTransliterate;
91 property MemoRecNo: Integer read FMemoRecNo write FMemoRecNo;
92 property ReadSize: Integer read FReadSize write FReadSize;
93 property Mode: TBlobStreamMode write SetMode;
94 property BlobField: TBlobField read FBlobField;
95 end;
96 //====================================================================
97 TDbfIndexDefs = class(TCollection)
98 public
99 FOwner: TDbf;
100 private
GetItemnull101 function GetItem(N: Integer): TDbfIndexDef;
102 procedure SetItem(N: Integer; Value: TDbfIndexDef);
103 protected
GetOwnernull104 function GetOwner: TPersistent; override;
105 public
106 constructor Create(AOwner: TDbf);
107
Addnull108 function Add: TDbfIndexDef;
GetIndexByNamenull109 function GetIndexByName(const Name: string): TDbfIndexDef;
GetIndexByFieldnull110 function GetIndexByField(const Name: string): TDbfIndexDef;
111 procedure Update; {$ifdef SUPPORT_REINTRODUCE} reintroduce; {$endif}
112
113 property Items[N: Integer]: TDbfIndexDef read GetItem write SetItem; default;
114 end;
115 //====================================================================
116 TDbfMasterLink = class(TDataLink)
117 private
118 FDetailDataSet: TDbf;
119 FParser: TDbfParser;
120 FFieldNames: string;
121 FValidExpression: Boolean;
122 FOnMasterChange: TNotifyEvent;
123 FOnMasterDisable: TNotifyEvent;
124
GetFieldsValnull125 function GetFieldsVal: TRecordBuffer;
126
127 procedure SetFieldNames(const Value: string);
128 protected
129 procedure ActiveChanged; override;
130 procedure CheckBrowseMode; override;
131 procedure LayoutChanged; override;
132 procedure RecordChanged(Field: TField); override;
133
134 public
135 constructor Create(ADataSet: TDbf);
136 destructor Destroy; override;
137
138 property FieldNames: string read FFieldNames write SetFieldNames;
139 property ValidExpression: Boolean read FValidExpression write FValidExpression;
140 property FieldsVal: TRecordBuffer read GetFieldsVal;
141 property Parser: TDbfParser read FParser;
142
143 property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
144 property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
145 end;
146 //====================================================================
147 PDbfBlobList = ^TDbfBlobList;
148 TDbfBlobList = array[0..MaxListSize-1] of TDbfBlobStream;
149 //====================================================================
150 TDbf = class(TDataSet)
151 private
152 FDbfFile: TDbfFile;
153 FCursor: TVirtualCursor;
154 FOpenMode: TDbfOpenMode;
155 FStorage: TDbfStorage;
156 FMasterLink: TDbfMasterLink;
157 FParser: TDbfParser;
158 FBlobStreams: PDbfBlobList;
159 FUserIndexStream: TStream;
160 FUserStream: TStream; // user stream to open
161 FUserMemoStream: TStream; // user-provided/expected stream backing memo file storage
162 FTableName: string; // table path and file name
163 FRelativePath: string;
164 FAbsolutePath: string;
165 FIndexName: string;
166 FReadOnly: Boolean;
167 FFilterBuffer: TRecordBuffer;
168 FTempBuffer: TRecordBuffer;
169 FEditingRecNo: Integer;
170 {$ifdef SUPPORT_VARIANTS}
171 FLocateRecNo: Integer;
172 {$endif}
173 FBackLink: String;
174 FLanguageID: Byte;
175 FTableLevel: Integer;
176 FExclusive: Boolean;
177 FShowDeleted: Boolean;
178 FPosting: Boolean;
179 FDisableResyncOnPost: Boolean;
180 FTempExclusive: Boolean;
181 FInCopyFrom: Boolean;
182 FStoreDefs: Boolean;
183 FCopyDateTimeAsString: Boolean;
184 FFindRecordFilter: Boolean;
185 FIndexFile: TIndexFile;
186 FDateTimeHandling: TDateTimeHandling;
187 FTranslationMode: TDbfTranslationMode;
188 FIndexDefs: TDbfIndexDefs;
189 FBeforeAutoCreate: TBeforeAutoCreateEvent;
190 FOnTranslate: TTranslateEvent;
191 FOnLanguageWarning: TLanguageWarningEvent;
192 FOnLocaleError: TDbfLocaleErrorEvent;
193 FOnIndexMissing: TDbfIndexMissingEvent;
194 FOnCompareRecord: TNotifyEvent;
195 FOnCopyDateTimeAsString: TConvertFieldEvent;
196
GetIndexNamenull197 function GetIndexName: string;
GetVersionnull198 function GetVersion: string;
GetPhysicalRecNonull199 function GetPhysicalRecNo: Integer;
GetLanguageStrnull200 function GetLanguageStr: string;
GetCodePagenull201 function GetCodePage: Cardinal;
GetExactRecordCountnull202 function GetExactRecordCount: Integer;
GetPhysicalRecordCountnull203 function GetPhysicalRecordCount: Integer;
GetKeySizenull204 function GetKeySize: Integer;
GetMasterFieldsnull205 function GetMasterFields: string;
FieldDefsStorednull206 function FieldDefsStored: Boolean;
207 procedure SetBackLink(NewBackLink: String);
208
209 procedure SetIndexName(AIndexName: string);
210 procedure SetDbfIndexDefs(const Value: TDbfIndexDefs);
211 procedure SetFilePath(const Value: string);
212 procedure SetTableName(const S: string);
213 procedure SetVersion(const S: string);
214 procedure SetLanguageID(NewID: Byte);
215 procedure SetDataSource(Value: TDataSource);
216 procedure SetMasterFields(const Value: string);
217 procedure SetTableLevel(const NewLevel: Integer);
218 procedure SetPhysicalRecNo(const NewRecNo: Integer);
219
220 procedure MasterChanged(Sender: TObject);
221 procedure MasterDisabled(Sender: TObject);
222 procedure DetermineTranslationMode;
223 procedure UpdateRange;
224 procedure SetShowDeleted(Value: Boolean);
225 procedure GetFieldDefsFromDbfFieldDefs;
226 procedure InitDbfFile(FileOpenMode: TPagedFileMode);
ParseIndexNamenull227 function ParseIndexName(const AIndexName: string): string;
228 procedure ParseFilter(const AFilter: string);
GetDbfFieldDefsnull229 function GetDbfFieldDefs: TDbfFieldDefs;
ReadCurrentRecordnull230 function ReadCurrentRecord(Buffer: TRecordBuffer; var Acceptable: Boolean): TGetResult;
SearchKeyBuffernull231 function SearchKeyBuffer(Buffer: PChar; SearchType: TSearchKeyType): Boolean;
232 procedure SetRangeBuffer(LowRange: PChar; HighRange: PChar);
233
234 protected
235 { abstract methods }
AllocRecordBuffernull236 function AllocRecordBuffer: TRecordBuffer; override; {virtual abstract}
237 procedure ClearCalcFields(Buffer: TRecordBuffer); override;
238 procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override; {virtual abstract}
239 procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; {virtual abstract}
GetBookmarkFlagnull240 function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override; {virtual abstract}
GetRecordnull241 function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; {virtual abstract}
GetRecordSizenull242 function GetRecordSize: Word; override; {virtual abstract}
243 procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override; {virtual abstract}
244 procedure InternalClose; override; {virtual abstract}
245 procedure InternalDelete; override; {virtual abstract}
246 procedure InternalFirst; override; {virtual abstract}
247 procedure InternalGotoBookmark(ABookmark: Pointer); override; {virtual abstract}
248 procedure InternalHandleException; override; {virtual abstract}
249 procedure InternalInitFieldDefs; override; {virtual abstract}
250 procedure InternalInitRecord(Buffer: TRecordBuffer); override; {virtual abstract}
251 procedure InternalLast; override; {virtual abstract}
252 procedure InternalOpen; override; {virtual abstract}
253 procedure InternalEdit; override; {virtual}
254 procedure InternalCancel; override; {virtual}
255 {$ifndef FPC}
256 {$ifndef DELPHI_3}
257 procedure InternalInsert; override; {virtual}
258 {$endif}
259 {$endif}
260 procedure InternalPost; override; {virtual abstract}
261 procedure InternalSetToRecord(Buffer: TRecordBuffer); override; {virtual abstract}
262 procedure InitFieldDefs; override;
IsCursorOpennull263 function IsCursorOpen: Boolean; override; {virtual abstract}
264 procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override; {virtual abstract}
265 procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; {virtual abstract}
266 procedure SetFieldData(Field: TField; Buffer: Pointer);
267 {$ifdef SUPPORT_OVERLOAD} overload; {$endif} override; {virtual abstract}
268
269 { virtual methods (mostly optional) }
GetDataSourcenull270 function GetDataSource: TDataSource; {$ifndef VER1_0}override;{$endif}
GetRecordCountnull271 function GetRecordCount: Integer; override; {virtual}
GetRecNonull272 function GetRecNo: Integer; override; {virtual}
GetCanModifynull273 function GetCanModify: Boolean; override; {virtual}
274 procedure SetRecNo(Value: Integer); override; {virual}
275 procedure SetFiltered(Value: Boolean); override; {virtual;}
276 procedure SetFilterText(const Value: String); override; {virtual;}
277 {$ifdef SUPPORT_DEFCHANGED}
278 procedure DefChanged(Sender: TObject); override;
279 {$endif}
FindRecordnull280 function FindRecord(Restart, GoForward: Boolean): Boolean; override;
281
GetIndexFieldNamesnull282 function GetIndexFieldNames: string; {virtual;}
283 procedure SetIndexFieldNames(const Value: string); {virtual;}
284
285 {$ifdef SUPPORT_VARIANTS}
LocateRecordLinearnull286 function LocateRecordLinear(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean;
LocateRecordIndexnull287 function LocateRecordIndex(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean;
LocateRecordnull288 function LocateRecord(const KeyFields: String; const KeyValues: Variant; Options: TLocateOptions): Boolean;
289 {$endif}
290
291 procedure DoFilterRecord(var Acceptable: Boolean);
292 public
293 constructor Create(AOwner: TComponent); override;
294 destructor Destroy; override;
295
296 { abstract methods }
GetFieldDatanull297 function GetFieldData(Field: TField; Buffer: Pointer): Boolean;
298 {$ifdef SUPPORT_OVERLOAD} overload; {$endif} override; {virtual abstract}
299 { virtual methods (mostly optional) }
300 procedure Resync(Mode: TResyncMode); override;
CreateBlobStreamnull301 function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
302 {$ifdef SUPPORT_NEW_TRANSLATE}
Translatenull303 function Translate(Src, Dest: PChar; ToOem: Boolean): Integer; override; {virtual}
304 {$else}
305 procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
306 {$endif}
307
308 {$ifdef SUPPORT_OVERLOAD}
GetFieldDatanull309 function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean;
310 {$ifdef SUPPORT_BACKWARD_FIELDDATA} overload; override; {$else} reintroduce; overload; {$endif}
311 procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean);
312 {$ifdef SUPPORT_BACKWARD_FIELDDATA} overload; override; {$else} reintroduce; overload; {$endif}
313 {$endif}
314
CompareBookmarksnull315 function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
316 procedure CheckDbfFieldDefs(ADbfFieldDefs: TDbfFieldDefs);
317
FindFirstnull318 function FindFirst: Boolean; override;
FindLastnull319 function FindLast: Boolean; override;
FindNextnull320 function FindNext: Boolean; override;
FindPriornull321 function FindPrior: Boolean; override;
322
323 {$ifdef VER1_0}
324 procedure DataEvent(Event: TDataEvent; Info: Longint); override;
325 {$endif}
326
327 // my own methods and properties
328 // most look like ttable functions but they are not tdataset related
329 // I (try to) use the same syntax to facilitate the conversion between bde and TDbf
330
331 // index support (use same syntax as ttable but is not related)
332 {$ifdef SUPPORT_DEFAULT_PARAMS}
333 procedure AddIndex(const AIndexName, AFields: String; Options: TIndexOptions; const DescFields: String='');
334 {$else}
335 procedure AddIndex(const AIndexName, AFields: String; Options: TIndexOptions);
336 {$endif}
337 procedure RegenerateIndexes;
338
339 procedure CancelRange;
340 procedure CheckMasterRange;
341 {$ifdef SUPPORT_VARIANTS}
SearchKeynull342 function SearchKey(Key: Variant; SearchType: TSearchKeyType; KeyIsANSI: boolean
343 {$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif}): Boolean;
344 procedure SetRange(LowRange: Variant; HighRange: Variant; KeyIsANSI: boolean
345 {$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif});
346 {$endif}
PrepareKeynull347 function PrepareKey(Buffer: Pointer; BufferType: TExpressionType): PChar;
SearchKeyPCharnull348 function SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType; KeyIsANSI: boolean
349 {$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif}): Boolean;
350 procedure SetRangePChar(LowRange: PChar; HighRange: PChar; KeyIsANSI: boolean
351 {$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif});
GetCurrentBuffernull352 function GetCurrentBuffer: TRecordBuffer;
353 procedure ExtractKey(KeyBuffer: PChar);
354 procedure UpdateIndexDefs; override;
355 procedure GetFileNames(Strings: TStrings; Files: TDbfFileNames); {$ifdef SUPPORT_DEFAULT_PARAMS} overload; {$endif}
356 {$ifdef SUPPORT_DEFAULT_PARAMS}
GetFileNamesnull357 function GetFileNames(Files: TDbfFileNames = [dfDbf] ): string; overload;
358 {$else}
GetFileNamesStringnull359 function GetFileNamesString(Files: TDbfFileNames (* = [dfDbf] *) ): string;
360 {$endif}
361 procedure GetIndexNames(Strings: TStrings);
362 procedure GetAllIndexFiles(Strings: TStrings);
363
364 procedure TryExclusive;
365 procedure EndExclusive;
LockTablenull366 function LockTable(const Wait: Boolean): Boolean;
367 procedure UnlockTable;
368 procedure OpenIndexFile(IndexFile: string);
369 procedure DeleteIndex(const AIndexName: string);
370 procedure CloseIndexFile(const AIndexName: string);
371 procedure RepageIndexFile(const AIndexFile: string);
372 procedure CompactIndexFile(const AIndexFile: string);
373
374 {$ifdef SUPPORT_VARIANTS}
Lookupnull375 function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;
Locatenull376 function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override;
377 {$endif}
378
IsDeletednull379 function IsDeleted: Boolean;
380 procedure Undelete;
381 // Call this after setting up fielddefs in order to store the definitions into a table
382 procedure CreateTable;
383 procedure CreateTableEx(ADbfFieldDefs: TDbfFieldDefs);
384 procedure CopyFrom(DataSet: TDataSet; FileName: string; DateTimeAsString: Boolean; Level: Integer);
385 procedure RestructureTable(ADbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
386 procedure PackTable;
387 procedure EmptyTable;
388 procedure Zap;
389
390 {$ifndef SUPPORT_INITDEFSFROMFIELDS}
391 procedure InitFieldDefsFromFields;
392 {$endif}
393
394 property AbsolutePath: string read FAbsolutePath;
395 property DbfFieldDefs: TDbfFieldDefs read GetDbfFieldDefs;
396 property PhysicalRecNo: Integer read GetPhysicalRecNo write SetPhysicalRecNo;
397 // Visual Foxpro: relative path to .dbc database file containing
398 // long field names and other metadata
399 // Empty if this is a "free table", not linked to a .dbc file
400 // Setting this with a FoxPro tablelevel will auto-upgrade to Visual Foxpro
401 // Unsupported for other versions
402 property BackLink: String read FBackLink write SetBackLink;
403 property LanguageID: Byte read FLanguageID write SetLanguageID;
404 property LanguageStr: String read GetLanguageStr;
405 property CodePage: Cardinal read GetCodePage;
406 property ExactRecordCount: Integer read GetExactRecordCount;
407 property PhysicalRecordCount: Integer read GetPhysicalRecordCount;
408 property KeySize: Integer read GetKeySize;
409 property DbfFile: TDbfFile read FDbfFile;
410 // Storage for data file if using memory storage
411 property UserStream: TStream read FUserStream write FUserStream;
412 // Storage for index file - if any - when using memory storage
413 property UserIndexStream: TStream read FUserIndexStream write FUserIndexStream;
414 // Storage for memo file - if any - when using memory storage
415 property UserMemoStream: TStream read FUserMemoStream write FUserMemoStream;
416 property DisableResyncOnPost: Boolean read FDisableResyncOnPost write FDisableResyncOnPost;
417 published
418 property DateTimeHandling: TDateTimeHandling
419 read FDateTimeHandling write FDateTimeHandling default dtBDETimeStamp;
420 property Exclusive: Boolean read FExclusive write FExclusive default false;
421 property FilePath: string read FRelativePath write SetFilePath;
422 property FilePathFull: string read FAbsolutePath write SetFilePath stored false;
423 property Indexes: TDbfIndexDefs read FIndexDefs write SetDbfIndexDefs stored false;
424 property IndexDefs: TDbfIndexDefs read FIndexDefs write SetDbfIndexDefs;
425 property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames stored false;
426 property IndexName: string read GetIndexName write SetIndexName;
427 property MasterFields: string read GetMasterFields write SetMasterFields;
428 property MasterSource: TDataSource read GetDataSource write SetDataSource;
429 property OpenMode: TDbfOpenMode read FOpenMode write FOpenMode default omNormal;
430 property ReadOnly: Boolean read FReadOnly write FReadonly default false;
431 property ShowDeleted: Boolean read FShowDeleted write SetShowDeleted default false;
432 property Storage: TDbfStorage read FStorage write FStorage default stoFile;
433 property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;
434 property TableName: string read FTableName write SetTableName;
435 property TableLevel: Integer read FTableLevel write SetTableLevel;
436 property Version: string read GetVersion write SetVersion stored false;
437 property BeforeAutoCreate: TBeforeAutoCreateEvent read FBeforeAutoCreate write FBeforeAutoCreate;
438 property OnCompareRecord: TNotifyEvent read FOnCompareRecord write FOnCompareRecord;
439 property OnLanguageWarning: TLanguageWarningEvent read FOnLanguageWarning write FOnLanguageWarning;
440 property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
441 property OnIndexMissing: TDbfIndexMissingEvent read FOnIndexMissing write FOnIndexMissing;
442 property OnCopyDateTimeAsString: TConvertFieldEvent read FOnCopyDateTimeAsString write FOnCopyDateTimeAsString;
443 property OnTranslate: TTranslateEvent read FOnTranslate write FOnTranslate;
444
445 // redeclared data set properties
446 property Active;
447 property FieldDefs stored FieldDefsStored;
448 property Filter;
449 property Filtered;
450 property FilterOptions;
451 property BeforeOpen;
452 property AfterOpen;
453 property BeforeClose;
454 property AfterClose;
455 property BeforeInsert;
456 property AfterInsert;
457 property BeforeEdit;
458 property AfterEdit;
459 property BeforePost;
460 property AfterPost;
461 property BeforeCancel;
462 property AfterCancel;
463 property BeforeDelete;
464 property AfterDelete;
465 {$ifdef SUPPORT_REFRESHEVENTS}
466 property BeforeRefresh;
467 property AfterRefresh;
468 {$endif}
469 property BeforeScroll;
470 property AfterScroll;
471 property OnCalcFields;
472 property OnDeleteError;
473 property OnEditError;
474 property OnFilterRecord;
475 property OnNewRecord;
476 property OnPostError;
477 end;
478
479 TDbf_GetBasePathFunction = function: string;
480
481 var
482 DbfBasePath: TDbf_GetBasePathFunction;
483
implementationnull484 implementation
485
486 uses
487 SysUtils,
488 {$ifndef FPC}
489 DBConsts,
490 {$endif}
491 {$ifdef WINDOWS}
492 Windows,
493 {$else}
494 {$ifdef KYLIX}
495 Libc,
496 {$endif}
497 Types,
498 dbf_wtil,
499 {$endif}
500 {$ifdef SUPPORT_SEPARATE_VARIANTS_UNIT}
501 Variants,
502 {$endif}
503 dbf_idxcur,
504 dbf_memo,
505 dbf_str;
506
507 {$ifdef FPC}
508 const
509 // TODO: move these to DBConsts
510 SNotEditing = 'Dataset not in edit or insert mode';
511 SCircularDataLink = 'Circular datalinks are not allowed';
512 {$endif}
513
TableLevelToDbfVersionnull514 function TableLevelToDbfVersion(TableLevel: integer): TXBaseVersion;
515 begin
516 case TableLevel of
517 3: Result := xBaseIII;
518 7: Result := xBaseVII;
519 TDBF_TABLELEVEL_FOXPRO: Result := xFoxPro;
520 TDBF_TABLELEVEL_VISUALFOXPRO: Result := xVisualFoxPro;
521 else
522 {4:} Result := xBaseIV;
523 end;
524 end;
525
526 //==========================================================
527 //============ TDbfBlobStream
528 //==========================================================
529 constructor TDbfBlobStream.Create(FieldVal: TField);
530 begin
531 FBlobField := FieldVal as TBlobField;
532 FReadSize := 0;
533 FMemoRecNo := 0;
534 FRefCount := 1;
535 FDirty := false;
536 end;
537
538 destructor TDbfBlobStream.Destroy;
539 begin
540 // only continue destroy if all references released
541 if FRefCount = 1 then
542 begin
543 // this is the last reference
544 inherited
545 end else begin
546 // fire event when dirty, and the last "user" is freeing it's reference
547 // tdbf always has the last reference
548 if FDirty and (FRefCount = 2) then
549 begin
550 // a second referer to instance has changed the data, remember modified
551 // TDbf(FBlobField.DataSet).SetModified(true);
552 // is following better? seems to provide notification for user (from VCL)
553 if not (FBlobField.DataSet.State in [dsCalcFields, dsFilter, dsNewValue]) then
554 TDbf(FBlobField.DataSet).DataEvent(deFieldChange, PtrInt(FBlobField));
555 end;
556 end;
557 Dec(FRefCount);
558 end;
559
560 procedure TDbfBlobStream.FreeInstance;
561 begin
562 // only continue freeing if all references released
563 if FRefCount = 0 then
564 inherited;
565 end;
566
567 procedure TDbfBlobStream.SetMode(NewMode: TBlobStreamMode);
568 begin
569 FMode := NewMode;
570 FDirty := FDirty or (NewMode = bmWrite) or (NewMode = bmReadWrite);
571 end;
572
573 procedure TDbfBlobStream.Cancel;
574 begin
575 FDirty := false;
576 FMemoRecNo := -1;
577 end;
578
579 procedure TDbfBlobStream.Commit;
580 var
581 Dbf: TDbf;
582 begin
583 if FDirty then
584 begin
585 Size := Position; // Strange but it leaves tailing trash bytes if I do not write that.
586 Dbf := TDbf(FBlobField.DataSet);
587 Translate(true);
588 Dbf.FDbfFile.MemoFile.WriteMemo(FMemoRecNo, FReadSize, Self);
589 Dbf.FDbfFile.SetFieldData(FBlobField.FieldNo-1, ftInteger, @FMemoRecNo,
590 @pDbfRecord(TDbf(FBlobField.DataSet).ActiveBuffer)^.DeletedFlag, false);
591 FDirty := false;
592 end;
593 end;
594
AddReferencenull595 function TDbfBlobStream.AddReference: TDbfBlobStream;
596 begin
597 Inc(FRefCount);
598 Result := Self;
599 end;
600
GetTransliteratenull601 function TDbfBlobStream.GetTransliterate: Boolean;
602 begin
603 Result := FBlobField.Transliterate;
604 end;
605
606 procedure TDbfBlobStream.Translate(ToOem: Boolean);
607 var
608 bytesToDo, numBytes: Integer;
609 bufPos: PChar;
610 saveChar: Char;
611 begin
612 if (Transliterate) and (Size > 0) then
613 begin
614 // get number of bytes to be translated
615 bytesToDo := Size;
616 // make space for final null-terminator
617 Size := Size + 1;
618 bufPos := Memory;
619 repeat
620 // process blocks of 512 bytes
621 numBytes := bytesToDo;
622 if numBytes > 512 then
623 numBytes := 512;
624 // null-terminate memory
625 saveChar := bufPos[numBytes];
626 bufPos[numBytes] := #0;
627 // translate memory
628 TDbf(FBlobField.DataSet).Translate(bufPos, bufPos, ToOem);
629 // restore char
630 bufPos[numBytes] := saveChar;
631 // numBytes bytes translated
632 Dec(bytesToDo, numBytes);
633 Inc(bufPos, numBytes);
634 until bytesToDo = 0;
635 // cut ending null-terminator
636 Size := Size - 1;
637 end;
638 end;
639
640 //====================================================================
641 // TDbf = TDataset Descendant.
642 //====================================================================
643 constructor TDbf.Create(AOwner: TComponent); {override;}
644 begin
645 inherited;
646
647 if DbfGlobals = nil then
648 DbfGlobals := TDbfGlobals.Create;
649
650 BookmarkSize := sizeof(TBookmarkData);
651 FIndexDefs := TDbfIndexDefs.Create(Self);
652 FMasterLink := TDbfMasterLink.Create(Self);
653 FMasterLink.OnMasterChange := MasterChanged;
654 FMasterLink.OnMasterDisable := MasterDisabled;
655 FDateTimeHandling := dtBDETimeStamp;
656 FStorage := stoFile;
657 FOpenMode := omNormal;
658 FParser := nil;
659 FPosting := false;
660 FReadOnly := false;
661 FExclusive := false;
662 FDisableResyncOnPost := false;
663 FTempExclusive := false;
664 FCopyDateTimeAsString := false;
665 FInCopyFrom := false;
666 FFindRecordFilter := false;
667 FEditingRecNo := -1;
668 FTableLevel := 4;
669 FIndexName := EmptyStr;
670 FilePath := EmptyStr;
671 FTempBuffer := nil;
672 FFilterBuffer := nil;
673 FIndexFile := nil;
674 FOnTranslate := nil;
675 FOnCopyDateTimeAsString := nil;
676 end;
677
678 destructor TDbf.Destroy; {override;}
679 var
680 I: Integer;
681 begin
682 inherited Destroy;
683
684 if FIndexDefs <> nil then
685 begin
686 for I := FIndexDefs.Count - 1 downto 0 do
687 TDbfIndexDef(FIndexDefs.Items[I]).Free;
688 FIndexDefs.Free;
689 end;
690 FMasterLink.Free;
691 end;
692
AllocRecordBuffernull693 function TDbf.AllocRecordBuffer: TRecordBuffer; {override virtual abstract from TDataset}
694 begin
695 GetMem(Result, SizeOf(TDbfRecordHeader)+FDbfFile.RecordSize+CalcFieldsSize+1);
696 end;
697
698 procedure TDbf.FreeRecordBuffer(var Buffer: TRecordBuffer); {override virtual abstract from TDataset}
699 begin
700 FreeMemAndNil(Pointer(Buffer));
701 end;
702
703 procedure TDbf.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); {override virtual abstract from TDataset}
704 begin
705 pBookmarkData(Data)^ := pDbfRecord(Buffer)^.BookmarkData;
706 end;
707
GetBookmarkFlagnull708 function TDbf.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; {override virtual abstract from TDataset}
709 begin
710 Result := pDbfRecord(Buffer)^.BookmarkFlag;
711 end;
712
GetCurrentBuffernull713 function TDbf.GetCurrentBuffer: TRecordBuffer;
714 begin
715 case State of
716 dsFilter: Result := FFilterBuffer;
717 dsCalcFields: Result := CalcBuffer;
718 // dsSetKey: Result := FKeyBuffer; // TO BE Implemented
719 else
720 if IsEmpty then
721 begin
722 Result := nil;
723 end else begin
724 Result := ActiveBuffer;
725 end;
726 end;
727 if Result <> nil then
728 Result := @PDbfRecord(Result)^.DeletedFlag;
729 end;
730
731 // we don't want converted data formats, we want native :-)
732 // it makes coding easier in TDbfFile.GetFieldData
733 // ftCurrency:
734 // Delphi 3,4: BCD array
735 // ftBCD:
736 // ftDateTime is more difficult though
737
GetFieldDatanull738 function TDbf.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {override virtual abstract from TDataset}
739 {$ifdef SUPPORT_OVERLOAD}
740 begin
741 { calling through 'old' delphi 3 interface, use compatible/'native' format }
742 Result := GetFieldData(Field, Buffer, true);
743 end;
744
GetFieldDatanull745 function TDbf.GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; {overload; override;}
746 {$else}
747 const
748 { no overload => delphi 3 => use compatible/'native' format }
749 NativeFormat = true;
750 {$endif}
751 var
752 Src: TRecordBuffer;
753 begin
754 Src := GetCurrentBuffer;
755 if Src = nil then
756 begin
757 Result := false;
758 exit;
759 end;
760
761 if Field.FieldNo>0 then
762 begin
763 Result := FDbfFile.GetFieldData(Field.FieldNo-1, Field.DataType, Src, Buffer, NativeFormat);
764 end else begin { weird calculated fields voodoo (from dbtables).... }
765 Inc(PChar(Src), Field.Offset + GetRecordSize);
766 Result := Boolean(Src[0]);
767 if Result and (Buffer <> nil) then
768 Move(Src[1], Buffer^, Field.DataSize);
769 end;
770 end;
771
772 procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
773 {$ifdef SUPPORT_OVERLOAD}
774 begin
775 { calling through 'old' delphi 3 interface, use compatible/'native' format }
776 SetFieldData(Field, Buffer, true);
777 end;
778
FindFirstnull779 function TDbf.FindFirst: Boolean;
780 begin
ifnull781 // Use inherited function; if failed use FindRecord
782 Result:=inherited FindFirst or FindRecord(True, True);
783 end;
784
FindLastnull785 function TDbf.FindLast: Boolean;
786 begin
ifnull787 // Use inherited function; if failed use FindRecord
788 Result:=inherited FindLast or FindRecord(True, False);
789 end;
790
TDbf.FindNextnull791 function TDbf.FindNext: Boolean;
792 begin
ifnull793 // Use inherited function; if failed use FindRecord
794 Result:=inherited FindNext or FindRecord(False, True);
795 end;
796
TDbf.FindPriornull797 function TDbf.FindPrior: Boolean;
798 begin
ifnull799 // Use inherited function; if failed use FindRecord
800 Result:=inherited FindPrior or FindRecord(False, False);
801 end;
802
803 procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); {overload; override;}
804 {$else}
805 const
806 { no overload => delphi 3 => use compatible/'native' format }
807 NativeFormat = true;
808 {$endif}
809 var
810 Dst: PChar;
811 begin
812 if (Field.FieldNo >= 0) then
813 begin
814 if State in [dsEdit, dsInsert, dsNewValue] then
815 Field.Validate(Buffer);
816 Dst := @PDbfRecord(ActiveBuffer)^.DeletedFlag;
817 FDbfFile.SetFieldData(Field.FieldNo - 1, Field.DataType, Buffer, Dst, NativeFormat);
818 end else begin { ***** fkCalculated, fkLookup ***** }
819 Dst := @PDbfRecord(CalcBuffer)^.DeletedFlag;
820 Inc(PChar(Dst), RecordSize + Field.Offset);
821 Boolean(Dst[0]) := Buffer <> nil;
822 if Buffer <> nil then
823 Move(Buffer^, Dst[1], Field.DataSize)
824 end; { end of ***** fkCalculated, fkLookup ***** }
825 if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
826 DataEvent(deFieldChange, PtrInt(Field));
827 end;
828 end;
829
830 procedure TDbf.DoFilterRecord(var Acceptable: Boolean);
831 begin
832 // check filtertext
833 if Length(Filter) > 0 then
834 begin
835 {$ifndef VER1_0}
836 Acceptable := Boolean((FParser.ExtractFromBuffer(GetCurrentBuffer))^);
837 {$else}
838 // strange problem
839 // dbf.pas(716,19) Error: Incompatible types: got "CHAR" expected "BOOLEAN"
840 Acceptable := not ((FParser.ExtractFromBuffer(GetCurrentBuffer))^ = #0);
841 {$endif}
842 end;
843
844 // check user filter
845 if Acceptable and Assigned(OnFilterRecord) then
846 OnFilterRecord(Self, Acceptable);
847 end;
848
ReadCurrentRecordnull849 function TDbf.ReadCurrentRecord(Buffer: TRecordBuffer; var Acceptable: Boolean): TGetResult;
850 var
851 lPhysicalRecNo: Integer;
852 pRecord: pDbfRecord;
853 begin
854 lPhysicalRecNo := FCursor.PhysicalRecNo;
855 if (lPhysicalRecNo = 0) or not FDbfFile.IsRecordPresent(lPhysicalRecNo) then
856 begin
857 Result := grError;
858 Acceptable := false;
859 end else begin
860 Result := grOK;
861 pRecord := pDbfRecord(Buffer);
862 FDbfFile.ReadRecord(lPhysicalRecNo, @pRecord^.DeletedFlag);
863 Acceptable := (FShowDeleted or (pRecord^.DeletedFlag <> '*'))
864 end;
865 end;
866
GetRecordnull867 function TDbf.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; {override virtual abstract from TDataset}
868 var
869 pRecord: pDbfRecord;
870 acceptable: Boolean;
871 SaveState: TDataSetState;
872 // s: string;
873 begin
874 if FCursor = nil then
875 begin
876 Result := grEOF;
877 exit;
878 end;
879
880 pRecord := pDbfRecord(Buffer);
881 acceptable := false;
882 repeat
883 Result := grOK;
884 case GetMode of
885 gmNext :
886 begin
887 Acceptable := FCursor.Next;
888 if Acceptable then begin
889 Result := grOK;
890 end else begin
891 Result := grEOF
892 end;
893 end;
894 gmPrior :
895 begin
896 Acceptable := FCursor.Prev;
897 if Acceptable then begin
898 Result := grOK;
899 end else begin
900 Result := grBOF
901 end;
902 end;
903 end;
904
905 if (Result = grOK) then
906 Result := ReadCurrentRecord(Buffer, acceptable);
907
908 if (Result = grOK) and acceptable then
909 begin
910 pRecord^.BookmarkData.PhysicalRecNo := FCursor.PhysicalRecNo;
911 pRecord^.BookmarkFlag := bfCurrent;
912 pRecord^.SequentialRecNo := FCursor.SequentialRecNo;
913 GetCalcFields(Buffer);
914
915 if Filtered or FFindRecordFilter then
916 begin
917 FFilterBuffer := Buffer;
918 SaveState := SetTempState(dsFilter);
919 DoFilterRecord(acceptable);
920 RestoreState(SaveState);
921 end;
922 end;
923
924 if (GetMode = gmCurrent) and not acceptable then
925 Result := grError;
926 until (Result <> grOK) or acceptable;
927
928 if Result <> grOK then
929 pRecord^.BookmarkData.PhysicalRecNo := -1;
930 end;
931
GetRecordSizenull932 function TDbf.GetRecordSize: Word; {override virtual abstract from TDataset}
933 begin
934 Result := FDbfFile.RecordSize;
935 end;
936
937 procedure TDbf.InternalAddRecord(Buffer: Pointer; AAppend: Boolean); {override virtual abstract from TDataset}
isnull938 // this function is called from TDataSet.InsertRecord and TDataSet.AppendRecord
939 // goal: add record with Edit...Set Fields...Post all in one step
940 var
941 pRecord: pDbfRecord;
942 newRecord: integer;
943 begin
944 // if InternalAddRecord is called, we know we are active
945 pRecord := Buffer;
946
947 // we can not insert records in DBF files, only append
948 // ignore Append parameter
949 newRecord := FDbfFile.Insert(@pRecord^.DeletedFlag);
950 if newRecord > 0 then
951 FCursor.PhysicalRecNo := newRecord;
952
953 // set flag that TDataSet is about to post...so we can disable resync
954 FPosting := true;
955 end;
956
957 procedure TDbf.InternalClose; {override virtual abstract from TDataset}
958 var
959 lIndex: TDbfIndexDef;
960 I: Integer;
961 begin
962 // clear automatically added MDX index entries
963 I := 0;
964 while I < FIndexDefs.Count do
965 begin
966 // is this an MDX index?
967 lIndex := FIndexDefs.Items[I];
968 if (Length(ExtractFileExt(lIndex.IndexFile)) = 0) and
969 TDbfIndexDef(FIndexDefs.Items[I]).Temporary then
970 begin
971 {$ifdef SUPPORT_DEF_DELETE}
972 // delete this entry
973 FIndexDefs.Delete(I);
974 {$else}
975 // does this work? I hope so :-)
976 FIndexDefs.Items[I].Free;
977 {$endif}
978 end else begin
979 // NDX entry -> goto next
980 Inc(I);
981 end;
982 end;
983
984 // free blobs
985 if FBlobStreams <> nil then
986 begin
987 for I := 0 to Pred(FieldDefs.Count) do
988 FBlobStreams^[I].Free;
989 FreeMemAndNil(Pointer(FBlobStreams));
990 end;
991 FreeRecordBuffer(FTempBuffer);
992 // disconnect field objects
993 BindFields(false);
994 // Destroy field object (if not persistent)
995 if DefaultFields then
996 DestroyFields;
997
998 if FParser <> nil then
999 FreeAndNil(FParser);
1000 FreeAndNil(FCursor);
1001 if FDbfFile <> nil then
1002 FreeAndNil(FDbfFile);
1003 end;
1004
1005 procedure TDbf.InternalCancel;
1006 var
1007 I: Integer;
1008 begin
1009 // cancel blobs
1010 for I := 0 to Pred(FieldDefs.Count) do
1011 if Assigned(FBlobStreams^[I]) then
1012 FBlobStreams^[I].Cancel;
1013 // if we have locked a record, unlock it
1014 if FEditingRecNo >= 0 then
1015 begin
1016 FDbfFile.UnlockPage(FEditingRecNo);
1017 FEditingRecNo := -1;
1018 end;
1019 end;
1020
1021 procedure TDbf.InternalDelete; {override virtual abstract from TDataset}
1022 var
1023 lRecord: pDbfRecord;
1024 begin
1025 // start editing
1026 InternalEdit;
1027 SetState(dsEdit);
1028 // get record pointer
1029 lRecord := pDbfRecord(ActiveBuffer);
1030 // flag we deleted this record
1031 lRecord^.DeletedFlag := '*';
1032 // notify indexes this record is deleted
1033 FDbfFile.RecordDeleted(FEditingRecNo, @lRecord^.DeletedFlag);
1034 // done!
1035 InternalPost;
1036 end;
1037
1038 procedure TDbf.InternalFirst; {override virtual abstract from TDataset}
1039 begin
1040 FCursor.First;
1041 end;
1042
1043 procedure TDbf.InternalGotoBookmark(ABookmark: Pointer); {override virtual abstract from TDataset}
1044 begin
1045 with PBookmarkData(ABookmark)^ do
1046 begin
1047 if (PhysicalRecNo = 0) then begin
1048 First;
1049 end else
1050 if (PhysicalRecNo = MaxInt) then begin
1051 Last;
1052 end else begin
1053 if FCursor.PhysicalRecNo <> PhysicalRecNo then
1054 FCursor.PhysicalRecNo := PhysicalRecNo;
1055 end;
1056 end;
1057 end;
1058
1059 procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
1060 begin
1061 SysUtils.ShowException(ExceptObject, ExceptAddr);
1062 end;
1063
1064 procedure TDbf.GetFieldDefsFromDbfFieldDefs;
1065 var
1066 I: Integer;
1067 TempFieldDef: TDbfFieldDef;
1068 TempMdxFile: TIndexFile;
1069 lIndexName: string;
1070 lFieldDefCount: integer; //Counter for destination fielddefs
1071
1072 procedure FixDuplicateNames;
1073 var
1074 BaseName: string;
1075 N: Integer;
1076 begin
1077 N := 1;
1078 BaseName := TempFieldDef.FieldName;
1079 while FieldDefs.IndexOf(TempFieldDef.FieldName)>=0 do
1080 begin
1081 Inc(N);
1082 TempFieldDef.FieldName:=BaseName+IntToStr(N);
1083 end;
1084 end;
1085
1086 begin
1087 FieldDefs.Clear;
1088
1089 // get all fields
1090 lFieldDefCount:=-1; //will be fixed by first addition
1091 for I := 0 to FDbfFile.FieldDefs.Count - 1 do
1092 begin
1093 TempFieldDef := FDbfFile.FieldDefs.Items[I];
1094 // handle duplicate field names:
1095 FixDuplicateNames;
1096 // add field, passing dbase native size if relevant
1097 // TDbfFieldDef.Size indicates the number of bytes in the physical dbase file
1098 // TFieldDef.Size is only meant to store size indicator for variable length fields
1099 case TempFieldDef.FieldType of
1100 ftString, ftBytes, ftVarBytes: FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, TempFieldDef.Size, false);
1101 ftBCD:
1102 begin
1103 FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, 0, false);;;
1104 end;
1105 else
1106 FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, 0, false);
1107 end;
1108 lFieldDefCount:=lFieldDefCount+1;
1109
1110 FieldDefs[lFieldDefCount].Precision := TempFieldDef.Precision;
1111
1112 {$ifdef SUPPORT_FIELDDEF_ATTRIBUTES}
1113 // AutoInc fields are readonly
1114 if TempFieldDef.FieldType = ftAutoInc then
1115 FieldDefs[lFieldDefCount].Attributes := [Db.faReadOnly];
1116
1117 // if table has dbase lock field, then hide it
1118 if TempFieldDef.IsLockField then
1119 FieldDefs[lFieldDefCount].Attributes := [Db.faHiddenCol];
1120
1121 // Hide system/hidden fields (e.g. VFP's _NULLFLAGS)
1122 if TempFieldDef.IsSystemField then
1123 FieldDefs[lFieldDefCount].Attributes := [Db.faHiddenCol];
1124 {$else}
1125 // Poor man's way of hiding fields that shouldn't be shown/modified:
1126 // Note: Visual Foxpro seems to allow adding another _NULLFLAGS field.
1127 // todo: test this with lockfield, then add this (TempFieldDef.IsLockField)
1128 if (TempFieldDef.IsSystemField) then
1129 begin
1130 FieldDefs.Delete(lFieldDefCount);
1131 lFieldDefCount:=lFieldDefCount-1;
1132 end;
1133 {$endif}
1134 end;
1135
1136 // get all (new) MDX index defs
1137 TempMdxFile := FDbfFile.MdxFile;
1138 for I := 0 to FDbfFile.IndexNames.Count - 1 do
1139 begin
1140 // is this an MDX index?
1141 lIndexName := FDbfFile.IndexNames.Strings[I];
1142 if FDbfFile.IndexNames.Objects[I] = TempMdxFile then
1143 if FIndexDefs.GetIndexByName(lIndexName) = nil then
1144 TempMdxFile.GetIndexInfo(lIndexName, FIndexDefs.Add);
1145 end;
1146 end;
1147
1148 procedure TDbf.InitFieldDefs;
1149 begin
1150 InternalInitFieldDefs;
1151 end;
1152
1153 procedure TDbf.InitDbfFile(FileOpenMode: TPagedFileMode);
1154 const
1155 FileModeToMemMode: array[TPagedFileMode] of TPagedFileMode =
1156 (pfNone, pfMemoryCreate, pfMemoryOpen, pfMemoryCreate, pfMemoryOpen,
1157 pfMemoryCreate, pfMemoryOpen, pfMemoryOpen);
1158 begin
1159 FDbfFile := TDbfFile.Create;
1160 if FStorage = stoMemory then
1161 begin
1162 FDbfFile.Stream := FUserStream;
1163 FDbfFile.MemoStream := FUserMemoStream;
1164 FDbfFile.IndexStream := FUserIndexStream;
1165 FDbfFile.Mode := FileModeToMemMode[FileOpenMode];
1166 end else begin
1167 FDbfFile.FileName := FAbsolutePath + FTableName;
1168 FDbfFile.Mode := FileOpenMode;
1169 end;
1170 FDbfFile.AutoCreate := false;
1171 FDbfFile.DateTimeHandling := FDateTimeHandling;
1172 FDbfFile.OnLocaleError := FOnLocaleError;
1173 FDbfFile.OnIndexMissing := FOnIndexMissing;
1174 end;
1175
1176 procedure TDbf.InternalInitFieldDefs; {override virtual abstract from TDataset}
1177 var
1178 MustReleaseDbfFile: Boolean;
1179 begin
1180 MustReleaseDbfFile := false;
1181 with FieldDefs do
1182 begin
1183 if FDbfFile = nil then
1184 begin
1185 // do not AutoCreate file
1186 InitDbfFile(pfReadOnly);
1187 FDbfFile.Open;
1188 MustReleaseDbfFile := true;
1189 end;
1190 GetFieldDefsFromDbfFieldDefs;
1191 if MustReleaseDbfFile then
1192 FreeAndNil(FDbfFile);
1193 end;
1194 end;
1195
1196 procedure TDbf.InternalInitRecord(Buffer: TRecordBuffer); {override virtual abstract from TDataset}
1197 var
1198 pRecord: pDbfRecord;
1199 begin
1200 pRecord := pDbfRecord(Buffer);
1201 pRecord^.BookmarkData.PhysicalRecNo := 0;
1202 pRecord^.BookmarkFlag := bfCurrent;
1203 pRecord^.SequentialRecNo := 0;
1204 // Init Record with zero and set autoinc field with next value
1205 FDbfFile.InitRecord(@pRecord^.DeletedFlag);
1206 end;
1207
1208 procedure TDbf.InternalLast; {override virtual abstract from TDataset}
1209 begin
1210 FCursor.Last;
1211 end;
1212
1213 procedure TDbf.DetermineTranslationMode;
1214 var
1215 lCodePage: Cardinal;
1216 begin
1217 lCodePage := FDbfFile.UseCodePage;
1218 if lCodePage = GetACP then
1219 FTranslationMode := tmNoneNeeded
1220 else
1221 if lCodePage = GetOEMCP then
1222 FTranslationMode := tmSimple
1223 // check if this code page, although non default, is installed
1224 else
1225 if DbfGlobals.CodePageInstalled(lCodePage) then
1226 FTranslationMode := tmAdvanced
1227 else
1228 FTranslationMode := tmNoneAvailable;
1229 end;
1230
1231 procedure TDbf.InternalOpen; {override virtual abstract from TDataset}
1232 const
1233 DbfOpenMode: array[Boolean, Boolean] of TPagedFileMode =
1234 ((pfReadWriteOpen, pfExclusiveOpen), (pfReadOnly, pfReadOnly));
1235 var
1236 lIndex: TDbfIndexDef;
1237 lIndexName: string;
1238 LanguageAction: TDbfLanguageAction;
1239 doCreate: Boolean;
1240 I: Integer;
1241 begin
1242 // close current file
1243 FreeAndNil(FDbfFile);
1244
1245 // does file not exist? -> create
1246 if ((FStorage = stoFile) and
1247 not FileExists(FAbsolutePath + FTableName) and
1248 (FOpenMode in [omAutoCreate, omTemporary])) or
1249 ((FStorage = stoMemory) and (FUserStream = nil)) then
1250 begin
1251 doCreate := true;
1252 if Assigned(FBeforeAutoCreate) then
1253 FBeforeAutoCreate(Self, doCreate);
1254 if doCreate then
1255 CreateTable
1256 else
1257 exit;
1258 end;
1259
1260 // now we know for sure the file exists
1261 InitDbfFile(DbfOpenMode[FReadOnly, FExclusive]);
1262 FDbfFile.Open;
1263
1264 // fail open?
1265 {$ifndef FPC}
1266 if FDbfFile.ForceClose then
1267 Abort;
1268 {$endif}
1269
1270 // determine dbf version
1271 case FDbfFile.DbfVersion of
1272 xBaseIII: FTableLevel := 3;
1273 xBaseIV: FTableLevel := 4;
1274 xBaseVII: FTableLevel := 7;
1275 xFoxPro: FTableLevel := TDBF_TABLELEVEL_FOXPRO;
1276 xVisualFoxPro: FTableLevel := TDBF_TABLELEVEL_VISUALFOXPRO;
1277 end;
1278 FBackLink := FDbfFile.BackLink;
1279 FLanguageID := FDbfFile.LanguageID;
1280
1281 // build VCL fielddef list from native DBF FieldDefs
1282 (*
1283 if (FDbfFile.HeaderSize = 0) or (FDbfFile.FieldDefs.Count = 0) then
1284 begin
1285 if FieldDefs.Count > 0 then
1286 begin
1287 CreateTableFromFieldDefs;
1288 end else begin
1289 CreateTableFromFields;
1290 end;
1291 end else begin
1292 *)
1293 // GetFieldDefsFromDbfFieldDefs;
1294 // end;
1295
1296 {$ifdef SUPPORT_FIELDDEFS_UPDATED}
1297 FieldDefs.Updated := False;
1298 FieldDefs.Update;
1299 {$else}
1300 InternalInitFieldDefs;
1301 {$endif}
1302
1303 // create the fields dynamically
1304 if DefaultFields then
1305 CreateFields; // Create fields from fielddefs.
1306
1307 BindFields(true);
1308
1309 // create array of blobstreams to store memos in. each field is a possible blob
1310 FBlobStreams := AllocMem(FieldDefs.Count * SizeOf(TDbfBlobStream));
1311
1312 // check codepage settings
1313 DetermineTranslationMode;
1314 if FTranslationMode = tmNoneAvailable then
1315 begin
1316 // no codepage available? ask user
1317 LanguageAction := laReadOnly;
1318 if Assigned(FOnLanguageWarning) then
1319 FOnLanguageWarning(Self, LanguageAction);
1320 case LanguageAction of
1321 laReadOnly: FTranslationMode := tmNoneAvailable;
1322 laForceOEM:
1323 begin
1324 FDbfFile.UseCodePage := GetOEMCP;
1325 FTranslationMode := tmSimple;
1326 end;
1327 laForceANSI:
1328 begin
1329 FDbfFile.UseCodePage := GetACP;
1330 FTranslationMode := tmNoneNeeded;
1331 end;
1332 laDefault:
1333 begin
1334 FDbfFile.UseCodePage := DbfGlobals.DefaultOpenCodePage;
1335 DetermineTranslationMode;
1336 end;
1337 end;
1338 end;
1339
1340 // allocate a record buffer for temporary data
1341 FTempBuffer := AllocRecordBuffer;
1342
1343 // open indexes
1344 for I := 0 to FIndexDefs.Count - 1 do
1345 begin
1346 lIndex := FIndexDefs.Items[I];
1347 lIndexName := ParseIndexName(lIndex.IndexFile);
1348 // if index does not exist -> create, if it does exist -> open only
1349 FDbfFile.OpenIndex(lIndexName, lIndex.SortField, false, lIndex.Options);
1350 end;
1351
1352 // parse filter expression
1353 try
1354 ParseFilter(Filter);
1355 except
1356 // oops, a problem with parsing, clear filter for now
1357 on E: EDbfError do Filter := EmptyStr;
1358 end;
1359
1360 SetIndexName(FIndexName);
1361
1362 // SetIndexName will have made the cursor for us if no index selected :-)
1363 // if FCursor = nil then FCursor := TDbfCursor.Create(FDbfFile);
1364
1365 if FMasterLink.Active and Assigned(FIndexFile) then
1366 CheckMasterRange;
1367 InternalFirst;
1368
1369 // FDbfFile.SetIndex(FIndexName);
1370 // FDbfFile.FIsCursorOpen := true;
1371 end;
1372
GetCodePagenull1373 function TDbf.GetCodePage: Cardinal;
1374 begin
1375 if FDbfFile <> nil then
1376 Result := FDbfFile.UseCodePage
1377 else
1378 Result := 0;
1379 end;
1380
GetLanguageStrnull1381 function TDbf.GetLanguageStr: string;
1382 begin
1383 if FDbfFile <> nil then
1384 Result := FDbfFile.LanguageStr;
1385 end;
1386
LockTablenull1387 function TDbf.LockTable(const Wait: Boolean): Boolean;
1388 begin
1389 CheckActive;
1390 Result := FDbfFile.LockAllPages(Wait);
1391 end;
1392
1393 procedure TDbf.UnlockTable;
1394 begin
1395 CheckActive;
1396 FDbfFile.UnlockAllPages;
1397 end;
1398
1399 procedure TDbf.InternalEdit;
1400 var
1401 I: Integer;
1402 begin
1403 // store recno we are editing
1404 FEditingRecNo := FCursor.PhysicalRecNo;
1405 // reread blobs, execute cancel -> clears remembered memo pageno,
1406 // causing it to reread the x contents
1407 for I := 0 to Pred(FieldDefs.Count) do
1408 if Assigned(FBlobStreams^[I]) then
1409 FBlobStreams^[I].Cancel;
1410 // try to lock this record
1411 FDbfFile.LockRecord(FEditingRecNo, @pDbfRecord(ActiveBuffer)^.DeletedFlag);
1412 // succeeded!
1413 end;
1414
1415 {$ifndef FPC}
1416 {$ifndef DELPHI_3}
1417
1418 procedure TDbf.InternalInsert; {override virtual from TDataset}
1419 begin
1420 CursorPosChanged;
1421 end;
1422
1423 {$endif}
1424 {$endif}
1425
1426 procedure TDbf.InternalPost; {override virtual abstract from TDataset}
1427 var
1428 pRecord: pDbfRecord;
1429 I, newRecord: Integer;
1430 begin
1431 // check required fields
1432 inherited;
1433 // if internalpost is called, we know we are active
1434 pRecord := pDbfRecord(ActiveBuffer);
1435 // commit blobs
1436 for I := 0 to Pred(FieldDefs.Count) do
1437 if Assigned(FBlobStreams^[I]) then
1438 FBlobStreams^[I].Commit;
1439 if State = dsEdit then
1440 begin
1441 // write changes
1442 FDbfFile.UnlockRecord(FEditingRecNo, @pRecord^.DeletedFlag);
1443 // not editing anymore
1444 FEditingRecNo := -1;
1445 end else begin
1446 // insert
1447 newRecord := FDbfFile.Insert(@pRecord^.DeletedFlag);
1448 if newRecord > 0 then
1449 FCursor.PhysicalRecNo := newRecord;
1450 end;
1451 // set flag that TDataSet is about to post...so we can disable resync
1452 FPosting := true;
1453 end;
1454
1455 procedure TDbf.Resync(Mode: TResyncMode);
1456 begin
1457 // try to increase speed
1458 if not FDisableResyncOnPost or not FPosting then
1459 inherited;
1460 // clear post flag
1461 FPosting := false;
1462 end;
1463
1464
1465 {$ifndef SUPPORT_INITDEFSFROMFIELDS}
1466
1467 procedure TDbf.InitFieldDefsFromFields;
1468 var
1469 I: Integer;
1470 F: TField;
1471 begin
1472 { create fielddefs from persistent fields if needed }
1473 for I := 0 to FieldCount - 1 do
1474 begin
1475 F := Fields[I];
1476 with F do
1477 if FieldKind = fkData then begin
1478 FieldDefs.Add(FieldName,DataType,Size,Required);
1479 end;
1480 end;
1481 end;
1482
1483 {$endif}
1484
1485 procedure TDbf.CreateTable;
1486 begin
1487 CreateTableEx(nil);
1488 end;
1489
1490 procedure TDbf.CheckDbfFieldDefs(ADbfFieldDefs: TDbfFieldDefs);
1491 var
1492 I: Integer;
1493 TempDef: TDbfFieldDef;
1494
1495 function FieldTypeStr(const FieldType: char): string;
1496 begin
1497 if FieldType = #0 then
1498 Result := 'NULL'
1499 else if FieldType > #127 then
1500 Result := 'ASCII '+IntToStr(Byte(FieldType))
1501 else
1502 Result := ' "'+fieldType+'" ';
1503 Result := ' ' + Result + '(#'+IntToHex(Byte(FieldType),SizeOf(FieldType))+') '
1504 end;
1505
1506 begin
1507 if ADbfFieldDefs = nil then exit;
1508
1509 for I := 0 to ADbfFieldDefs.Count - 1 do
1510 begin
1511 // check dbffielddefs for errors
1512 TempDef := ADbfFieldDefs.Items[I];
1513 if FTableLevel < 7 then
1514 if not (TempDef.NativeFieldType in ['C', 'F', 'N', 'D', 'L', 'M']) then
1515 raise EDbfError.CreateFmt(STRING_INVALID_FIELD_TYPE,
1516 [FieldTypeStr(TempDef.NativeFieldType), TempDef.FieldName]);
1517 end;
1518 end;
1519
1520 procedure TDbf.CreateTableEx(ADbfFieldDefs: TDbfFieldDefs);
1521 var
1522 I: Integer;
1523 lIndex: TDbfIndexDef;
1524 lIndexName: string;
1525 tempFieldDefs: Boolean;
1526 begin
1527 CheckInactive;
1528 tempFieldDefs := ADbfFieldDefs = nil;
1529 try
1530 try
1531 if tempFieldDefs then
1532 begin
1533 ADbfFieldDefs := TDbfFieldDefs.Create(Self);
1534 ADbfFieldDefs.DbfVersion := TableLevelToDbfVersion(FTableLevel);
1535
1536 // get fields -> fielddefs if no fielddefs
1537 {$ifndef FPC_VERSION}
1538 if FieldDefs.Count = 0 then
1539 InitFieldDefsFromFields;
1540 {$endif}
1541
1542 // fielddefs -> dbffielddefs
1543 for I := 0 to FieldDefs.Count - 1 do
1544 begin
1545 with ADbfFieldDefs.AddFieldDef do
1546 begin
1547 FieldName := FieldDefs.Items[I].Name;
1548 FieldType := FieldDefs.Items[I].DataType;
1549 if FieldDefs.Items[I].Size > 0 then
1550 begin
1551 Size := FieldDefs.Items[I].Size;
1552 Precision := FieldDefs.Items[I].Precision;
1553 end else begin
1554 SetDefaultSize;
1555 end;
1556 end;
1557 end;
1558 end;
1559
1560 InitDbfFile(pfExclusiveCreate);
1561 FDbfFile.CopyDateTimeAsString := FInCopyFrom and FCopyDateTimeAsString;
1562 FDbfFile.DbfVersion := TableLevelToDbfVersion(FTableLevel);
1563 FDbfFile.BackLink := FBackLink;
1564 FDbfFile.FileLangID := FLanguageID;
1565 FDbfFile.Open;
1566 // Default memo blocklength for FoxPro/VisualFoxpro is 64 (not 512 as specs say)
1567 if FDbfFile.DbfVersion in [xFoxPro,xVisualFoxPro] then
1568 FDbfFile.FinishCreate(ADbfFieldDefs, 64)
1569 else
1570 FDbfFile.FinishCreate(ADbfFieldDefs, 512);
1571
1572 // if creating memory table, use user-designated stream
1573 if FStorage = stoMemory then
1574 begin
1575 FUserStream := FDbfFile.Stream;
1576 FUserIndexStream := FDBfFile.IndexStream;
1577 FUserMemoStream := FDbfFile.MemoStream;
1578 end;
1579
1580 // create all indexes
1581 for I := 0 to FIndexDefs.Count-1 do
1582 begin
1583 lIndex := FIndexDefs.Items[I];
1584 lIndexName := ParseIndexName(lIndex.IndexFile);
1585 FDbfFile.OpenIndex(lIndexName, lIndex.SortField, true, lIndex.Options);
1586 end;
1587 except
1588 // dbf file created?
1589 if (FDbfFile <> nil) and (FStorage = stoFile) then
1590 begin
1591 FreeAndNil(FDbfFile);
1592 SysUtils.DeleteFile(FAbsolutePath+FTableName);
1593 end;
1594 raise;
1595 end;
1596 finally
1597 // free temporary fielddefs
1598 if tempFieldDefs and Assigned(ADbfFieldDefs) then
1599 ADbfFieldDefs.Free;
1600 FreeAndNil(FDbfFile);
1601 end;
1602 end;
1603
1604 procedure TDbf.EmptyTable;
1605 begin
1606 Zap;
1607 end;
1608
1609 procedure TDbf.Zap;
1610 begin
1611 // are we active?
1612 CheckActive;
1613 FDbfFile.Zap;
1614 end;
1615
1616 procedure TDbf.RestructureTable(ADbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
1617 begin
1618 CheckInactive;
1619
1620 // check field defs for errors
1621 CheckDbfFieldDefs(ADbfFieldDefs);
1622
1623 // open dbf file
1624 InitDbfFile(pfExclusiveOpen);
1625 FDbfFile.Open;
1626
1627 // do restructure
1628 try
1629 FDbfFile.RestructureTable(ADbfFieldDefs, Pack);
1630 finally
1631 // close file
1632 FreeAndNil(FDbfFile);
1633 end;
1634 end;
1635
1636 procedure TDbf.PackTable;
1637 var
1638 oldIndexName: string;
1639 begin
1640 CheckBrowseMode;
1641 // deselect any index while packing
1642 oldIndexName := IndexName;
1643 IndexName := EmptyStr;
1644 // pack
1645 FDbfFile.RestructureTable(nil, true);
1646 // reselect index
1647 IndexName := oldIndexName;
1648 end;
1649
1650 procedure TDbf.CopyFrom(DataSet: TDataSet; FileName: string; DateTimeAsString: Boolean; Level: Integer);
1651 var
1652 lPhysFieldDefs, lFieldDefs: TDbfFieldDefs;
1653 lSrcField, lDestField: TField;
1654 I: integer;
1655 begin
1656 FInCopyFrom := true;
1657 lFieldDefs := TDbfFieldDefs.Create(nil);
1658 lPhysFieldDefs := TDbfFieldDefs.Create(nil);
1659 try
1660 if Active then
1661 Close;
1662 FilePath := ExtractFilePath(FileName);
1663 TableName := ExtractFileName(FileName);
1664 FCopyDateTimeAsString := DateTimeAsString;
1665 TableLevel := Level;
1666 if not DataSet.Active then
1667 DataSet.Open;
1668 DataSet.FieldDefs.Update;
1669 // first get a list of physical field defintions
1670 // we need it for numeric precision in case source is tdbf
1671 if DataSet is TDbf then
1672 begin
1673 lPhysFieldDefs.Assign(TDbf(DataSet).DbfFieldDefs);
1674 IndexDefs.Assign(TDbf(DataSet).IndexDefs);
1675 end else begin
1676 {$ifdef SUPPORT_FIELDDEF_TPERSISTENT}
1677 lPhysFieldDefs.Assign(DataSet.FieldDefs);
1678 {$endif}
1679 IndexDefs.Clear;
1680 end;
1681 // convert list of tfields into a list of tdbffielddefs
1682 // so that our tfields will correspond to the source tfields
1683 for I := 0 to Pred(DataSet.FieldCount) do
1684 begin
1685 lSrcField := DataSet.Fields[I];
1686 with lFieldDefs.AddFieldDef do
1687 begin
1688 if Length(lSrcField.Name) > 0 then
1689 FieldName := lSrcField.Name
1690 else
1691 FieldName := lSrcField.FieldName;
1692 FieldType := lSrcField.DataType;
1693 Required := lSrcField.Required;
1694
1695 // Set up size/precision for all physical fields:
1696 if (1 <= lSrcField.FieldNo)
1697 and (lSrcField.FieldNo <= lPhysFieldDefs.Count) then
1698 begin
1699 Size := lPhysFieldDefs.Items[lSrcField.FieldNo-1].Size;
1700 Precision := lPhysFieldDefs.Items[lSrcField.FieldNo-1].Precision;
1701 end;
1702 end;
1703 end;
1704
1705 CreateTableEx(lFieldDefs);
1706 Open;
1707 DataSet.First;
1708 {$ifdef USE_CACHE}
1709 FDbfFile.BufferAhead := true;
1710 if DataSet is TDbf then
1711 TDbf(DataSet).DbfFile.BufferAhead := true;
1712 {$endif}
1713 while not DataSet.EOF do
1714 begin
1715 Append;
1716 for I := 0 to Pred(FieldCount) do
1717 begin
1718 lSrcField := DataSet.Fields[I];
1719 lDestField := Fields[I];
1720 if not lSrcField.IsNull then
1721 begin
1722 if lSrcField.DataType = ftDateTime then
1723 begin
1724 if FCopyDateTimeAsString then
1725 begin
1726 lDestField.AsString := lSrcField.AsString;
1727 if Assigned(FOnCopyDateTimeAsString) then
1728 FOnCopyDateTimeAsString(Self, lDestField, lSrcField)
1729 end else
1730 lDestField.AsDateTime := lSrcField.AsDateTime;
1731 end else
1732 lDestField.Assign(lSrcField);
1733 end;
1734 end;
1735 Post;
1736 DataSet.Next;
1737 end;
1738 Close;
1739 finally
1740 {$ifdef USE_CACHE}
1741 if (DataSet is TDbf) and (TDbf(DataSet).DbfFile <> nil) then
1742 TDbf(DataSet).DbfFile.BufferAhead := false;
1743 {$endif}
1744 FInCopyFrom := false;
1745 lFieldDefs.Free;
1746 lPhysFieldDefs.Free;
1747 end;
1748 end;
1749
FindRecordnull1750 function TDbf.FindRecord(Restart, GoForward: Boolean): Boolean;
1751 var
1752 oldRecNo: Integer;
1753 begin
1754 CheckBrowseMode;
1755 DoBeforeScroll;
1756 Result := false;
1757 UpdateCursorPos;
1758 oldRecNo := RecNo;
1759 try
1760 FFindRecordFilter := true;
1761 if GoForward then
1762 begin
1763 if Restart then FCursor.First;
1764 Result := GetRecord(FTempBuffer, gmNext, false) = grOK;
1765 end else begin
1766 if Restart then FCursor.Last;
1767 Result := GetRecord(FTempBuffer, gmPrior, false) = grOK;
1768 end;
1769 finally
1770 FFindRecordFilter := false;
1771 if not Result then
1772 begin
1773 RecNo := oldRecNo;
1774 end else begin
1775 CursorPosChanged;
1776 Resync([]);
1777 DoAfterScroll;
1778 end;
1779 end;
1780 end;
1781
1782 {$ifdef SUPPORT_VARIANTS}
1783
Lookupnull1784 function TDbf.Lookup(const KeyFields: string; const KeyValues: Variant;
1785 const ResultFields: string): Variant;
1786 var
1787 // OldState: TDataSetState;
1788 saveRecNo: integer;
1789 saveState: TDataSetState;
1790 begin
1791 Result := Null;
1792 if (FCursor = nil) or VarIsNull(KeyValues) then exit;
1793
1794 saveRecNo := FCursor.SequentialRecNo;
1795 try
1796 if LocateRecord(KeyFields, KeyValues, []) then
1797 begin
1798 // FFilterBuffer contains record buffer
1799 saveState := SetTempState(dsCalcFields);
1800 try
1801 CalculateFields(FFilterBuffer);
1802 if KeyValues = FieldValues[KeyFields] then
1803 Result := FieldValues[ResultFields];
1804 finally
1805 RestoreState(saveState);
1806 end;
1807 end;
1808 finally
1809 FCursor.SequentialRecNo := saveRecNo;
1810 end;
1811 end;
1812
Locatenull1813 function TDbf.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean;
1814 var
1815 saveRecNo: integer;
1816 begin
1817 if FCursor = nil then
1818 begin
1819 CheckActive;
1820 Result := false;
1821 exit;
1822 end;
1823
1824 DoBeforeScroll;
1825 saveRecNo := FCursor.SequentialRecNo;
1826 FLocateRecNo := -1;
1827 Result := LocateRecord(KeyFields, KeyValues, Options);
1828 CursorPosChanged;
1829 if Result then
1830 begin
1831 if FLocateRecNo <> -1 then
1832 FCursor.PhysicalRecNo := FLocateRecNo;
1833 Resync([]);
1834 DoAfterScroll;
1835 end else
1836 FCursor.SequentialRecNo := saveRecNo;
1837 end;
1838
LocateRecordLinearnull1839 function TDbf.LocateRecordLinear(const KeyFields: String; const KeyValues: Variant;
1840 Options: TLocateOptions): Boolean;
1841 var
1842 lstKeys : TList;
1843 iIndex : Integer;
1844 Field : TField;
1845 bMatchedData : Boolean;
1846 bVarIsArray : Boolean;
1847 varCompare : Variant;
1848
1849 function CompareValues: Boolean;
1850 var
1851 sCompare: String;
1852 begin
1853 if (Field.DataType in [ftString,ftWideString]) then
1854 begin
1855 sCompare := VarToStr(varCompare);
1856 if loCaseInsensitive in Options then
1857 begin
1858 Result := AnsiCompareText(Field.AsString,sCompare) = 0;
1859 if not Result and (iIndex = lstKeys.Count - 1) and (loPartialKey in Options) and
1860 (Length(sCompare) < Length(Field.AsString)) then
1861 begin
1862 if Length(sCompare) = 0 then
1863 Result := true
1864 else
1865 Result := AnsiCompareText (Copy (Field.AsString,1,Length (sCompare)),sCompare) = 0;
1866 end;
1867 end else begin
1868 Result := Field.AsString = sCompare;
1869 if not Result and (iIndex = lstKeys.Count - 1) and (loPartialKey in Options) and
1870 (Length (sCompare) < Length (Field.AsString)) then
1871 begin
1872 if Length (sCompare) = 0 then
1873 Result := true
1874 else
1875 Result := Copy(Field.AsString, 1, Length(sCompare)) = sCompare;
1876 end;
1877 end;
1878 end
1879 else
1880 // Not a string; could be date, integer etc.
1881 // Follow e.g. FPC bufdataset by searching for equal
1882 Result := Field.Value = varCompare;
1883 end;
1884
1885 var
1886 SaveState: TDataSetState;
1887 lPhysRecNo: integer;
1888 begin
1889 Result := false;
1890 bVarIsArray := false;
1891 lstKeys := TList.Create;
1892 FFilterBuffer := TempBuffer;
1893 SaveState := SetTempState(dsFilter);
1894 try
1895 GetFieldList(lstKeys, KeyFields);
1896 if VarArrayDimCount(KeyValues) = 0 then
1897 bMatchedData := lstKeys.Count = 1
1898 else if VarArrayDimCount (KeyValues) = 1 then
1899 begin
1900 bMatchedData := VarArrayHighBound (KeyValues,1) + 1 = lstKeys.Count;
1901 bVarIsArray := true;
1902 end else
1903 bMatchedData := false;
1904 if bMatchedData then
1905 begin
1906 FCursor.First;
1907 while not Result and FCursor.Next do
1908 begin
1909 lPhysRecNo := FCursor.PhysicalRecNo;
1910 if (lPhysRecNo = 0) or not FDbfFile.IsRecordPresent(lPhysRecNo) then
1911 break;
1912
1913 FDbfFile.ReadRecord(lPhysRecNo, @PDbfRecord(FFilterBuffer)^.DeletedFlag);
1914 Result := FShowDeleted or (PDbfRecord(FFilterBuffer)^.DeletedFlag <> '*');
1915 if Result and Filtered then
1916 DoFilterRecord(Result);
1917
1918 iIndex := 0;
1919 while Result and (iIndex < lstKeys.Count) Do
1920 begin
1921 Field := TField (lstKeys [iIndex]);
1922 if bVarIsArray then
1923 varCompare := KeyValues [iIndex]
1924 else
1925 varCompare := KeyValues;
1926 Result := CompareValues;
1927 Inc(iIndex);
1928 end;
1929 end;
1930 end;
1931 finally
1932 lstKeys.Free;
1933 RestoreState(SaveState);
1934 end;
1935 end;
1936
LocateRecordIndexnull1937 function TDbf.LocateRecordIndex(const KeyFields: String; const KeyValues: Variant;
1938 Options: TLocateOptions): Boolean;
1939 var
1940 searchFlag: TSearchKeyType;
1941 matchRes: Integer;
1942 lTempBuffer: array [0..100] of Char;
1943 acceptable, checkmatch: boolean;
1944 begin
1945 // Only honor loPartialKey for string types; for others, search for equal
1946 if (loPartialKey in Options) and
1947 (TIndexCursor(FCursor).IndexFile.KeyType='C') then
1948 searchFlag := stGreaterEqual
1949 else
1950 searchFlag := stEqual;
1951 if TIndexCursor(FCursor).VariantToBuffer(KeyValues, @lTempBuffer[0]) = etString then
1952 Translate(@lTempBuffer[0], @lTempBuffer[0], true);
1953 Result := FIndexFile.SearchKey(@lTempBuffer[0], searchFlag);
1954 if not Result then
1955 exit;
1956
1957 checkmatch := false;
1958 repeat
1959 if ReadCurrentRecord(TempBuffer, acceptable) = grError then
1960 begin
1961 Result := false;
1962 exit;
1963 end;
1964 if acceptable then break;
1965 checkmatch := true;
1966 FCursor.Next;
1967 until false;
1968
1969 if checkmatch then
1970 begin
1971 matchRes := TIndexCursor(FCursor).IndexFile.MatchKey(@lTempBuffer[0]);
1972 if loPartialKey in Options then
1973 Result := matchRes <= 0
1974 else
1975 Result := matchRes = 0;
1976 end;
1977
1978 FFilterBuffer := TempBuffer;
1979 end;
1980
LocateRecordnull1981 function TDbf.LocateRecord(const KeyFields: String; const KeyValues: Variant;
1982 Options: TLocateOptions): Boolean;
1983 var
1984 lCursor, lSaveCursor: TVirtualCursor;
1985 lSaveIndexName, lIndexName: string;
1986 lIndexDef: TDbfIndexDef;
1987 lIndexFile, lSaveIndexFile: TIndexFile;
1988 begin
1989 lCursor := nil;
1990 lSaveCursor := nil;
1991 lIndexFile := nil;
1992 lSaveIndexFile := FIndexFile;
1993 if (FCursor is TIndexCursor)
1994 and (TIndexCursor(FCursor).IndexFile.Expression = KeyFields) then
1995 begin
1996 lCursor := FCursor;
1997 end else begin
1998 lIndexDef := FIndexDefs.GetIndexByField(KeyFields);
1999 if lIndexDef <> nil then
2000 begin
2001 lIndexName := ParseIndexName(lIndexDef.IndexFile);
2002 lIndexFile := FDbfFile.GetIndexByName(lIndexName);
2003 if lIndexFile <> nil then
2004 begin
2005 lSaveCursor := FCursor;
2006 lCursor := TIndexCursor.Create(lIndexFile);
2007 lSaveIndexName := lIndexFile.IndexName;
2008 lIndexFile.IndexName := lIndexName;
2009 FIndexFile := lIndexFile;
2010 end;
2011 end;
2012 end;
2013 if lCursor <> nil then
2014 begin
2015 FCursor := lCursor;
2016 Result := LocateRecordIndex(KeyFields, KeyValues, Options);
2017 if lSaveCursor <> nil then
2018 begin
2019 FCursor.Free;
2020 FCursor := lSaveCursor;
2021 end;
2022 if lIndexFile <> nil then
2023 begin
2024 FLocateRecNo := FIndexFile.PhysicalRecNo;
2025 lIndexFile.IndexName := lSaveIndexName;
2026 FIndexFile := lSaveIndexFile;
2027 end;
2028 end else
2029 Result := LocateRecordLinear(KeyFields, KeyValues, Options);
2030 end;
2031
2032 {$endif}
2033
2034 procedure TDbf.TryExclusive;
2035 begin
2036 // are we active?
2037 if Active then
2038 begin
2039 // already in exclusive mode?
2040 FDbfFile.TryExclusive;
2041 // update file mode
2042 FExclusive := not FDbfFile.IsSharedAccess;
2043 FReadOnly := FDbfFile.Mode = pfReadOnly;
2044 end else begin
2045 // just set exclusive to true
2046 FExclusive := true;
2047 FReadOnly := false;
2048 end;
2049 end;
2050
2051 procedure TDbf.EndExclusive;
2052 begin
2053 if Active then
2054 begin
2055 // call file handler
2056 FDbfFile.EndExclusive;
2057 // update file mode
2058 FExclusive := not FDbfFile.IsSharedAccess;
2059 FReadOnly := FDbfFile.Mode = pfReadOnly;
2060 end else begin
2061 // just set exclusive to false
2062 FExclusive := false;
2063 end;
2064 end;
2065
CreateBlobStreamnull2066 function TDbf.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; {override virtual}
2067 var
2068 MemoPageNo: Integer;
2069 MemoFieldNo: Integer;
2070 lBlob: TDbfBlobStream;
2071 begin
2072 // check if in editing mode if user wants to write
2073 if (Mode = bmWrite) or (Mode = bmReadWrite) then
2074 if not (State in [dsEdit, dsInsert]) then
2075 {$ifdef DELPHI_3}
2076 DatabaseError(SNotEditing);
2077 {$else}
2078 DatabaseError(SNotEditing, Self);
2079 {$endif}
2080 // already created a `placeholder' blob for this field?
2081 MemoFieldNo := Field.FieldNo - 1;
2082 if FBlobStreams^[MemoFieldNo] = nil then
2083 FBlobStreams^[MemoFieldNo] := TDbfBlobStream.Create(Field);
2084 lBlob := FBlobStreams^[MemoFieldNo].AddReference;
2085 // update pageno of blob <-> location where to read/write in memofile
2086 if FDbfFile.GetFieldData(Field.FieldNo-1, ftInteger, GetCurrentBuffer, @MemoPageNo, false) then
2087 begin
2088 // read blob? different blob?
2089 if (Mode = bmRead) or (Mode = bmReadWrite) then
2090 begin
2091 if MemoPageNo <> lBlob.MemoRecNo then
2092 begin
2093 FDbfFile.MemoFile.ReadMemo(MemoPageNo, lBlob);
2094 lBlob.ReadSize := lBlob.Size;
2095 lBlob.Translate(false);
2096 end;
2097 end else begin
2098 lBlob.Size := 0;
2099 lBlob.ReadSize := 0;
2100 end;
2101 lBlob.MemoRecNo := MemoPageNo;
2102 end else
2103 if not lBlob.Dirty or (Mode = bmWrite) then
2104 begin
2105 // reading and memo is empty and not written yet, or rewriting
2106 lBlob.Size := 0;
2107 lBlob.ReadSize := 0;
2108 lBlob.MemoRecNo := 0;
2109 end;
2110 { this is a hack, we actually need to know per user who's modifying, and who is not }
2111 { Mode is more like: the mode of the last "creation" }
2112 { if create/free is nested, then everything will be alright, I think ;-) }
2113 lBlob.Mode := Mode;
2114 { this is a hack: we actually need to know per user what its position is }
2115 lBlob.Position := 0;
2116 Result := lBlob;
2117 end;
2118
2119 {$ifdef SUPPORT_NEW_TRANSLATE}
2120
Translatenull2121 function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
2122 var
2123 FromCP, ToCP: Cardinal;
2124 begin
2125 if (Src <> nil) and (Dest <> nil) then
2126 begin
2127 if Assigned(FOnTranslate) then
2128 begin
2129 Result := FOnTranslate(Self, Src, Dest, ToOem);
2130 if Result = -1 then
2131 Result := StrLen(Dest);
2132 end else begin
2133 if FTranslationMode <> tmNoneNeeded then
2134 begin
2135 if ToOem then
2136 begin
2137 FromCP := GetACP;
2138 ToCP := FDbfFile.UseCodePage;
2139 end else begin
2140 FromCP := FDbfFile.UseCodePage;
2141 ToCP := GetACP;
2142 end;
2143 end else begin
2144 FromCP := GetACP;
2145 ToCP := FromCP;
2146 end;
2147 Result := TranslateString(FromCP, ToCP, Src, Dest, -1);
2148 end;
2149 end else
2150 Result := 0;
2151 end;
2152
2153 {$else}
2154
2155 procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
2156 var
2157 FromCP, ToCP: Cardinal;
2158 begin
2159 if (Src <> nil) and (Dest <> nil) then
2160 begin
2161 if Assigned(FOnTranslate) then
2162 begin
2163 FOnTranslate(Self, Src, Dest, ToOem);
2164 end else begin
2165 if FTranslationMode <> tmNoneNeeded then
2166 begin
2167 if ToOem then
2168 begin
2169 FromCP := GetACP;
2170 ToCP := FDbfFile.UseCodePage;
2171 end else begin
2172 FromCP := FDbfFile.UseCodePage;
2173 ToCP := GetACP;
2174 end;
2175 TranslateString(FromCP, ToCP, Src, Dest, -1);
2176 end;
2177 end;
2178 end;
2179 end;
2180
2181 {$endif}
2182
2183 procedure TDbf.ClearCalcFields(Buffer: TRecordBuffer);
2184 var
2185 lRealBuffer, lCalcBuffer: PChar;
2186 begin
2187 lRealBuffer := @pDbfRecord(Buffer)^.DeletedFlag;
2188 lCalcBuffer := lRealBuffer + FDbfFile.RecordSize;
2189 FillChar(lCalcBuffer^, CalcFieldsSize, 0);
2190 end;
2191
2192 procedure TDbf.InternalSetToRecord(Buffer: TRecordBuffer); {override virtual abstract from TDataset}
2193 var
2194 pRecord: pDbfRecord;
2195 begin
2196 if Buffer <> nil then
2197 begin
2198 pRecord := pDbfRecord(Buffer);
2199 if pRecord^.BookmarkFlag = bfInserted then
2200 begin
2201 // do what ???
2202 end else begin
2203 FCursor.SequentialRecNo := pRecord^.SequentialRecNo;
2204 end;
2205 end;
2206 end;
2207
TDbf.IsCursorOpennull2208 function TDbf.IsCursorOpen: Boolean; {override virtual abstract from TDataset}
2209 begin
2210 Result := FCursor <> nil;
2211 end;
2212
FieldDefsStorednull2213 function TDbf.FieldDefsStored: Boolean;
2214 begin
2215 Result := StoreDefs and (FieldDefs.Count > 0);
2216 end;
2217
2218 procedure TDbf.SetBackLink(NewBackLink: String);
2219 begin
2220 // Only supported in Visual Foxpro but allow auto-upgrade from Foxpro
2221 // as well as resetting existing backlinks in any tablelevel
2222 if (NewBackLink<>'') and
2223 (not(Tablelevel in [TDBF_TABLELEVEL_FOXPRO,TDBF_TABLELEVEL_VISUALFOXPRO])) then
2224 raise EDbfError.CreateFmt(STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL,
2225 [Tablelevel]);
2226 CheckInactive;
2227
2228 FBackLink := NewBackLink;
2229 end;
2230
2231 procedure TDbf.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); {override virtual abstract from TDataset}
2232 begin
2233 pDbfRecord(Buffer)^.BookmarkFlag := Value;
2234 end;
2235
2236 procedure TDbf.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); {override virtual abstract from TDataset}
2237 begin
2238 pDbfRecord(Buffer)^.BookmarkData := pBookmarkData(Data)^;
2239 end;
2240
countsnull2241 // this function counts real number of records: skip deleted records, filter, etc.
2242 // warning: is very slow, compared to GetRecordCount
2243 function TDbf.GetExactRecordCount: Integer;
2244 var
2245 prevRecNo: Integer;
2246 getRes: TGetResult;
2247 begin
2248 // init vars
2249 Result := 0;
2250
2251 // check if FCursor open
2252 if FCursor = nil then
2253 exit;
2254
2255 // store current position
2256 prevRecNo := FCursor.SequentialRecNo;
2257 FCursor.First;
2258 repeat
2259 // repeatedly retrieve next record until eof encountered
2260 getRes := GetRecord(FTempBuffer, gmNext, true);
2261 if getRes = grOk then
2262 inc(Result);
2263 until getRes <> grOk;
2264 // restore current position
2265 FCursor.SequentialRecNo := prevRecNo;
2266 end;
2267
2268 // this functions returns the physical number of records present in file
TDbf.GetPhysicalRecordCountnull2269 function TDbf.GetPhysicalRecordCount: Integer;
2270 begin
2271 if FDbfFile <> nil then
2272 Result := FDbfFile.RecordCount
2273 else
2274 Result := 0
2275 end;
2276
isnull2277 // this function is just for the grid scrollbars
2278 // it doesn't have to be perfectly accurate, but fast.
2279 function TDbf.GetRecordCount: Integer; {override virtual}
2280 begin
2281 if FCursor <> nil then
2282 Result := FCursor.SequentialRecordCount
2283 else
2284 Result := 0
2285 end;
2286
2287 // this function is just for the grid scrollbars
2288 // it doesn't have to be perfectly accurate, but fast.
GetRecNonull2289 function TDbf.GetRecNo: Integer; {override virtual}
2290 var
2291 pBuffer: pointer;
2292 begin
2293 if FCursor <> nil then
2294 begin
2295 case State of
2296 dsFilter: pBuffer := FFilterBuffer;
2297 dsCalcFields: pBuffer := CalcBuffer;
2298 else
2299 pBuffer := ActiveBuffer;
2300 end;
2301 Result := pDbfRecord(pBuffer)^.SequentialRecNo;
2302 end else
2303 Result := 0;
2304 end;
2305
2306 procedure TDbf.SetRecNo(Value: Integer); {override virtual}
2307 begin
2308 CheckBrowseMode;
2309 if Value = RecNo then
2310 exit;
2311
2312 DoBeforeScroll;
2313 FCursor.SequentialRecNo := Value;
2314 CursorPosChanged;
2315 Resync([]);
2316 DoAfterScroll;
2317 end;
2318
GetCanModifynull2319 function TDbf.GetCanModify: Boolean; {override;}
2320 begin
2321 if FReadOnly or (csDesigning in ComponentState) then
2322 Result := false
2323 else
2324 Result := FTranslationMode > tmNoneAvailable;
2325 end;
2326
2327 {$ifdef SUPPORT_DEFCHANGED}
2328
2329 procedure TDbf.DefChanged(Sender: TObject);
2330 begin
2331 StoreDefs := true;
2332 end;
2333
2334 {$endif}
2335
2336 procedure TDbf.ParseFilter(const AFilter: string);
2337 begin
2338 // parser created?
2339 if Length(AFilter) > 0 then
2340 begin
2341 if (FParser = nil) and (FDbfFile <> nil) then
2342 begin
2343 FParser := TDbfParser.Create(FDbfFile);
2344 // we need truncated, translated (to ANSI) strings
2345 FParser.StringFieldMode := smAnsiTrim;
2346 end;
2347 // have a parser now?
2348 if FParser <> nil then
2349 begin
2350 // set options
2351 FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
2352 FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
2353 // parse expression
2354 FParser.ParseExpression(AFilter);
2355 end;
2356 end;
2357 end;
2358
2359 procedure TDbf.SetFilterText(const Value: String);
2360 begin
2361 if Value = Filter then
2362 exit;
2363
2364 // parse
2365 ParseFilter(Value);
2366
2367 // call dataset method
2368 inherited;
2369
2370 // refilter dataset if filtered
2371 if (FDbfFile <> nil) and Filtered then Refresh;
2372 end;
2373
2374 procedure TDbf.SetFiltered(Value: Boolean); {override;}
2375 begin
2376 if Value = Filtered then
2377 exit;
2378
2379 // pass on to ancestor
2380 inherited;
2381
2382 // only refresh if active
2383 if FCursor <> nil then
2384 Refresh;
2385 end;
2386
2387 procedure TDbf.SetFilePath(const Value: string);
2388 begin
2389 CheckInactive;
2390
2391 FRelativePath := Value;
2392 if Length(FRelativePath) > 0 then
2393 FRelativePath := IncludeTrailingPathDelimiter(FRelativePath);
2394
2395 if IsFullFilePath(Value) then
2396 begin
2397 FAbsolutePath := IncludeTrailingPathDelimiter(Value);
2398 end else begin
2399 FAbsolutePath := GetCompletePath(DbfBasePath(), FRelativePath);
2400 end;
2401 end;
2402
2403 procedure TDbf.SetTableName(const S: string);
2404 var
2405 lPath: string;
2406 begin
2407 FTableName := ExtractFileName(s);
2408 lPath := ExtractFilePath(s);
2409 if (Length(lPath) > 0) then
2410 FilePath := lPath;
2411 // force IDE to reread fielddefs when a different file is opened
2412 {$ifdef SUPPORT_FIELDDEFS_UPDATED}
2413 FieldDefs.Updated := false;
2414 {$else}
2415 // TODO ... ??
2416 {$endif}
2417 end;
2418
2419 procedure TDbf.SetDbfIndexDefs(const Value: TDbfIndexDefs);
2420 begin
2421 FIndexDefs.Assign(Value);
2422 end;
2423
2424 procedure TDbf.SetLanguageID(NewID: Byte);
2425 begin
2426 CheckInactive;
2427
2428 FLanguageID := NewID;
2429 end;
2430
2431 procedure TDbf.SetTableLevel(const NewLevel: Integer);
2432 begin
2433 if NewLevel <> FTableLevel then
2434 begin
2435 // check validity
2436 if not (NewLevel in [3,4,7,TDBF_TABLELEVEL_FOXPRO,TDBF_TABLELEVEL_VISUALFOXPRO]) then
2437 exit;
2438
2439 // can only assign tablelevel if table is closed
2440 CheckInactive;
2441 FTableLevel := NewLevel;
2442 end;
2443 end;
2444
GetIndexNamenull2445 function TDbf.GetIndexName: string;
2446 begin
2447 Result := FIndexName;
2448 end;
2449
CompareBookmarksnull2450 function TDbf.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
2451 const
2452 RetCodes: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
2453 var
2454 b1,b2: Integer;
2455 begin
2456 // Check for uninitialized bookmarks
2457 Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
2458 if (Result = 2) then
2459 begin
2460 b1 := PInteger(Bookmark1)^;
2461 b2 := PInteger(Bookmark2)^;
2462 if b1 < b2 then Result := -1
2463 else if b1 > b2 then Result := 1
2464 else Result := 0;
2465 end;
2466 end;
2467
GetVersionnull2468 function TDbf.GetVersion: string;
2469 begin
2470 Result := Format('%d.%02d', [TDBF_MAJOR_VERSION, TDBF_MINOR_VERSION]);
2471 end;
2472
2473 procedure TDbf.SetVersion(const S: string);
2474 begin
2475 // What an idea...
2476 end;
2477
ParseIndexNamenull2478 function TDbf.ParseIndexName(const AIndexName: string): string;
2479 begin
2480 // if no ext, then it is a MDX tag, get complete only if it is a filename
2481 // MDX: get first 10 characters only
2482 if Length(ExtractFileExt(AIndexName)) > 0 then
2483 Result := GetCompleteFileName(FAbsolutePath, AIndexName)
2484 else
2485 Result := AIndexName;
2486 end;
2487
2488 procedure TDbf.RegenerateIndexes;
2489 begin
2490 CheckBrowseMode;
2491 FDbfFile.RegenerateIndexes;
2492 end;
2493
2494 {$ifdef SUPPORT_DEFAULT_PARAMS}
2495 procedure TDbf.AddIndex(const AIndexName, AFields: String; Options: TIndexOptions; const DescFields: String='');
2496 {$else}
2497 procedure TDbf.AddIndex(const AIndexName, AFields: String; Options: TIndexOptions);
2498 {$endif}
2499 var
2500 lIndexFileName: string;
2501 begin
2502 CheckActive;
2503 lIndexFileName := ParseIndexName(AIndexName);
2504 FDbfFile.OpenIndex(lIndexFileName, AFields, true, Options);
2505
2506 // refresh our indexdefs
2507 InternalInitFieldDefs;
2508 end;
2509
2510 procedure TDbf.SetIndexName(AIndexName: string);
2511 var
2512 lRecNo: Integer;
2513 begin
2514 FIndexName := AIndexName;
2515 if FDbfFile = nil then
2516 exit;
2517
2518 // get accompanying index file
2519 AIndexName := ParseIndexName(Trim(AIndexName));
2520 FIndexFile := FDbfFile.GetIndexByName(AIndexName);
2521 // store current lRecNo
2522 if FCursor = nil then
2523 begin
2524 lRecNo := 1;
2525 end else begin
2526 UpdateCursorPos;
2527 lRecNo := FCursor.PhysicalRecNo;
2528 end;
2529 // select new cursor
2530 FreeAndNil(FCursor);
2531 if FIndexFile <> nil then
2532 begin
2533 FCursor := TIndexCursor.Create(FIndexFile);
2534 // select index
2535 FIndexFile.IndexName := AIndexName;
2536 // check if can activate master link
2537 CheckMasterRange;
2538 end else begin
2539 FCursor := TDbfCursor.Create(FDbfFile);
2540 FIndexName := EmptyStr;
2541 end;
2542 // reset previous lRecNo
2543 FCursor.PhysicalRecNo := lRecNo;
2544 // refresh records
2545 if State = dsBrowse then
2546 Resync([]);
2547 // warn user if selecting non-existing index
2548 if (FCursor = nil) and (AIndexName <> EmptyStr) then
2549 raise EDbfError.CreateFmt(STRING_INDEX_NOT_EXIST, [AIndexName]);
2550 end;
2551
TDbf.GetIndexFieldNamesnull2552 function TDbf.GetIndexFieldNames: string;
2553 var
2554 lIndexDef: TDbfIndexDef;
2555 begin
2556 lIndexDef := FIndexDefs.GetIndexByName(IndexName);
2557 if lIndexDef = nil then
2558 Result := EmptyStr
2559 else
2560 Result := lIndexDef.SortField;
2561 end;
2562
2563 procedure TDbf.SetIndexFieldNames(const Value: string);
2564 var
2565 lIndexDef: TDbfIndexDef;
2566 begin
2567 // Exception if index not found?
2568 lIndexDef := FIndexDefs.GetIndexByField(Value);
2569 if lIndexDef = nil then
2570 IndexName := EmptyStr
2571 else
2572 IndexName := lIndexDef.IndexFile;
2573 end;
2574
2575 procedure TDbf.DeleteIndex(const AIndexName: string);
2576 var
2577 lIndexFileName: string;
2578 begin
2579 // extract absolute path if NDX file
2580 lIndexFileName := ParseIndexName(AIndexName);
2581 // try to delete index
2582 FDbfFile.DeleteIndex(lIndexFileName);
2583
2584 // refresh index defs
2585 InternalInitFieldDefs;
2586 end;
2587
2588 procedure TDbf.OpenIndexFile(IndexFile: string);
2589 var
2590 lIndexFileName: string;
2591 begin
2592 CheckActive;
2593 // make absolute path
2594 lIndexFileName := GetCompleteFileName(FAbsolutePath, IndexFile);
2595 // open index
2596 FDbfFile.OpenIndex(lIndexFileName, '', false, []);
2597 end;
2598
2599 procedure TDbf.CloseIndexFile(const AIndexName: string);
2600 var
2601 lIndexFileName: string;
2602 begin
2603 CheckActive;
2604 // make absolute path
2605 lIndexFileName := GetCompleteFileName(FAbsolutePath, AIndexName);
2606 // close this index
2607 FDbfFile.CloseIndex(lIndexFileName);
2608 end;
2609
2610 procedure TDbf.RepageIndexFile(const AIndexFile: string);
2611 begin
2612 if FDbfFile <> nil then
2613 FDbfFile.RepageIndex(ParseIndexName(AIndexFile));
2614 end;
2615
2616 procedure TDbf.CompactIndexFile(const AIndexFile: string);
2617 begin
2618 if FDbfFile <> nil then
2619 FDbfFile.CompactIndex(ParseIndexName(AIndexFile));
2620 end;
2621
2622 procedure TDbf.GetFileNames(Strings: TStrings; Files: TDbfFileNames);
2623 var
2624 I: Integer;
2625 begin
2626 Strings.Clear;
2627 if FDbfFile <> nil then
2628 begin
2629 if dfDbf in Files then
2630 Strings.Add(FDbfFile.FileName);
2631 if (dfMemo in Files) and (FDbfFile.MemoFile <> nil) then
2632 Strings.Add(FDbfFile.MemoFile.FileName);
2633 if dfIndex in Files then
2634 for I := 0 to Pred(FDbfFile.IndexFiles.Count) do
2635 Strings.Add(TPagedFile(FDbfFile.IndexFiles.Items[I]).FileName);
2636 end else
2637 Strings.Add(IncludeTrailingPathDelimiter(FilePathFull) + TableName);
2638 end;
2639
2640 {$ifdef SUPPORT_DEFAULT_PARAMS}
GetFileNamesnull2641 function TDbf.GetFileNames(Files: TDbfFileNames (* = [dfDbf] *) ): string;
2642 {$else}
TDbf.GetFileNamesStringnull2643 function TDbf.GetFileNamesString(Files: TDbfFileNames ): string;
2644 {$endif}
2645 var
2646 sl: TStrings;
2647 begin
2648 sl := TStringList.Create;
2649 try
2650 GetFileNames(sl, Files);
2651 Result := sl.Text;
2652 finally
2653 sl.Free;
2654 end;
2655 end;
2656
2657
2658
2659 procedure TDbf.GetIndexNames(Strings: TStrings);
2660 begin
2661 CheckActive;
2662 Strings.Assign(DbfFile.IndexNames)
2663 end;
2664
2665 procedure TDbf.GetAllIndexFiles(Strings: TStrings);
2666 var
2667 SR: TSearchRec;
2668 begin
2669 CheckActive;
2670 Strings.Clear;
2671 if SysUtils.FindFirst(IncludeTrailingPathDelimiter(ExtractFilePath(FDbfFile.FileName))
2672 + '*.NDX', faAnyFile, SR) = 0 then
2673 begin
2674 repeat
2675 Strings.Add(SR.Name);
2676 until SysUtils.FindNext(SR)<>0;
2677 SysUtils.FindClose(SR);
2678 end;
2679 end;
2680
TDbf.GetPhysicalRecNonull2681 function TDbf.GetPhysicalRecNo: Integer;
2682 var
2683 pBuffer: pointer;
2684 begin
2685 // check if active, test state: if inserting, then -1
2686 if (FCursor <> nil) and (State <> dsInsert) then
2687 begin
2688 if State = dsCalcFields then
2689 pBuffer := CalcBuffer
2690 else
2691 pBuffer := ActiveBuffer;
2692 Result := pDbfRecord(pBuffer)^.BookmarkData.PhysicalRecNo;
2693 end else
2694 Result := -1;
2695 end;
2696
2697 procedure TDbf.SetPhysicalRecNo(const NewRecNo: Integer);
2698 begin
2699 // editing?
2700 CheckBrowseMode;
2701 DoBeforeScroll;
2702 FCursor.PhysicalRecNo := NewRecNo;
2703 CursorPosChanged;
2704 Resync([]);
2705 DoAfterScroll;
2706 end;
2707
TDbf.GetDbfFieldDefsnull2708 function TDbf.GetDbfFieldDefs: TDbfFieldDefs;
2709 begin
2710 if FDbfFile <> nil then
2711 Result := FDbfFile.FieldDefs
2712 else
2713 Result := nil;
2714 end;
2715
2716 procedure TDbf.SetShowDeleted(Value: Boolean);
2717 begin
2718 // test if changed
2719 if Value <> FShowDeleted then
2720 begin
2721 // store new value
2722 FShowDeleted := Value;
2723 // refresh view only if active
2724 if FCursor <> nil then
2725 Refresh;
2726 end;
2727 end;
2728
TDbf.IsDeletednull2729 function TDbf.IsDeleted: Boolean;
2730 var
2731 src: TRecordBuffer;
2732 begin
2733 src := GetCurrentBuffer;
2734 IsDeleted := (src=nil) or (AnsiChar(src^) = '*')
2735 end;
2736
2737 procedure TDbf.Undelete;
2738 var
2739 src: TRecordBuffer;
2740 begin
2741 if State <> dsEdit then
2742 inherited Edit;
2743 // get active buffer
2744 src := GetCurrentBuffer;
2745 if (src <> nil) and (AnsiChar(src^) = '*') then
2746 begin
2747 // notify indexes record is about to be recalled
2748 FDbfFile.RecordRecalled(FCursor.PhysicalRecNo, src);
2749 // recall record
2750 src^ := TRecordBufferBaseType(' ');
2751 FDbfFile.WriteRecord(FCursor.PhysicalRecNo, src);
2752 end;
2753 end;
2754
2755 procedure TDbf.CancelRange;
2756 begin
2757 if FIndexFile = nil then
2758 exit;
2759
2760 // disable current range if any
2761 FIndexFile.CancelRange;
2762 // reretrieve previous and next records
2763 Refresh;
2764 end;
2765
2766 procedure TDbf.SetRangeBuffer(LowRange: PChar; HighRange: PChar);
2767 begin
2768 if FIndexFile = nil then
2769 exit;
2770
2771 FIndexFile.SetRange(LowRange, HighRange);
2772 // go to first in this range
2773 if Active then
2774 inherited First;
2775 end;
2776
2777 {$ifdef SUPPORT_VARIANTS}
2778
2779 procedure TDbf.SetRange(LowRange: Variant; HighRange: Variant; KeyIsANSI: boolean);
2780 var
2781 LowBuf, HighBuf: array[0..100] of Char;
2782 begin
2783 if (FIndexFile = nil) or VarIsNull(LowRange) or VarIsNull(HighRange) then
2784 exit;
2785
2786 // convert variants to index key type
2787 if (TIndexCursor(FCursor).VariantToBuffer(LowRange, @LowBuf[0]) = etString) and KeyIsANSI then
2788 Translate(@LowBuf[0], @LowBuf[0], true);
2789 if (TIndexCursor(FCursor).VariantToBuffer(HighRange, @HighBuf[0]) = etString) and KeyIsANSI then
2790 Translate(@HighBuf[0], @HighBuf[0], true);
2791 SetRangeBuffer(@LowBuf[0], @HighBuf[0]);
2792 end;
2793
2794 {$endif}
2795
2796 procedure TDbf.SetRangePChar(LowRange: PChar; HighRange: PChar; KeyIsANSI: boolean);
2797 var
2798 LowBuf, HighBuf: array [0..100] of Char;
2799 LowPtr, HighPtr: PChar;
2800 begin
2801 if FIndexFile = nil then
2802 exit;
2803
2804 // convert to pchars
2805 if KeyIsANSI then
2806 begin
2807 Translate(LowRange, @LowBuf[0], true);
2808 Translate(HighRange, @HighBuf[0], true);
2809 LowRange := @LowBuf[0];
2810 HighRange := @HighBuf[0];
2811 end;
2812 LowPtr := TIndexCursor(FCursor).CheckUserKey(LowRange, @LowBuf[0]);
2813 HighPtr := TIndexCursor(FCursor).CheckUserKey(HighRange, @HighBuf[0]);
2814 SetRangeBuffer(LowPtr, HighPtr);
2815 end;
2816
2817 procedure TDbf.ExtractKey(KeyBuffer: PChar);
2818 begin
2819 if FIndexFile <> nil then
2820 StrCopy(FIndexFile.ExtractKeyFromBuffer(GetCurrentBuffer), KeyBuffer)
2821 else
2822 KeyBuffer[0] := #0;
2823 end;
2824
TDbf.GetKeySizenull2825 function TDbf.GetKeySize: Integer;
2826 begin
2827 if FCursor is TIndexCursor then
2828 Result := TIndexCursor(FCursor).IndexFile.KeyLen
2829 else
2830 Result := 0;
2831 end;
2832
2833 {$ifdef SUPPORT_VARIANTS}
2834
SearchKeynull2835 function TDbf.SearchKey(Key: Variant; SearchType: TSearchKeyType; KeyIsANSI: boolean): Boolean;
2836 var
2837 TempBuffer: array [0..100] of Char;
2838 begin
2839 if (FIndexFile = nil) or VarIsNull(Key) then
2840 begin
2841 Result := false;
2842 exit;
2843 end;
2844
2845 // FIndexFile <> nil -> FCursor as TIndexCursor <> nil
2846 if (TIndexCursor(FCursor).VariantToBuffer(Key, @TempBuffer[0]) = etString) and KeyIsANSI then
2847 Translate(@TempBuffer[0], @TempBuffer[0], true);
2848 Result := SearchKeyBuffer(@TempBuffer[0], SearchType);
2849 end;
2850
2851 {$endif}
2852
PrepareKeynull2853 function TDbf.PrepareKey(Buffer: Pointer; BufferType: TExpressionType): PChar;
2854 begin
2855 if FIndexFile = nil then
2856 begin
2857 Result := nil;
2858 exit;
2859 end;
2860
2861 Result := TIndexCursor(FCursor).IndexFile.PrepareKey(Buffer, BufferType);
2862 end;
2863
TDbf.SearchKeyPCharnull2864 function TDbf.SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType; KeyIsANSI: boolean): Boolean;
2865 var
2866 StringBuf: array [0..100] of Char;
2867 begin
2868 if FCursor = nil then
2869 begin
2870 Result := false;
2871 exit;
2872 end;
2873
2874 if KeyIsANSI then
2875 begin
2876 Translate(Key, @StringBuf[0], true);
2877 Key := @StringBuf[0];
2878 end;
2879 Result := SearchKeyBuffer(TIndexCursor(FCursor).CheckUserKey(Key, @StringBuf[0]), SearchType);
2880 end;
2881
SearchKeyBuffernull2882 function TDbf.SearchKeyBuffer(Buffer: PChar; SearchType: TSearchKeyType): Boolean;
2883 var
2884 matchRes: Integer;
2885 begin
2886 if FIndexFile = nil then
2887 begin
2888 Result := false;
2889 exit;
2890 end;
2891
2892 CheckBrowseMode;
2893 Result := FIndexFile.SearchKey(Buffer, SearchType);
2894 { if found, then retrieve new current record }
2895 if Result then
2896 begin
2897 CursorPosChanged;
2898 Resync([]);
2899 UpdateCursorPos;
2900 { recno could have been changed due to deleted record, check if still matches }
2901 matchRes := TIndexCursor(FCursor).IndexFile.MatchKey(Buffer);
2902 case SearchType of
2903 stEqual: Result := matchRes = 0;
2904 stGreater: Result := (not Eof) and (matchRes < 0);
2905 stGreaterEqual: Result := (not Eof) and (matchRes <= 0);
2906 end;
2907 end;
2908 end;
2909
2910 procedure TDbf.UpdateIndexDefs;
2911 begin
2912 FieldDefs.Update;
2913 end;
2914
2915 // A hack to upgrade method visibility, only necessary for FPC 1.0.x
2916
2917 {$ifdef VER1_0}
2918
2919 procedure TDbf.DataEvent(Event: TDataEvent; Info: Longint);
2920 begin
2921 inherited;
2922 end;
2923
2924 {$endif}
2925
2926 { Master / Detail }
2927
2928 procedure TDbf.CheckMasterRange;
2929 begin
2930 if FMasterLink.Active and FMasterLink.ValidExpression and (FIndexFile <> nil) then
2931 UpdateRange;
2932 end;
2933
2934 procedure TDbf.UpdateRange;
2935 var
2936 fieldsVal: TRecordBuffer;
2937 tempBuffer: array[0..300] of char;
2938 begin
2939 fieldsVal := FMasterLink.FieldsVal;
2940 if (TDbf(FMasterLink.DataSet).DbfFile.UseCodePage <> FDbfFile.UseCodePage)
2941 and (FMasterLink.Parser.ResultType = etString) then
2942 begin
2943 FMasterLink.DataSet.Translate(pansichar(fieldsVal), @tempBuffer[0], false);
2944 fieldsVal := @tempBuffer[0];
2945 Translate(pansichar(fieldsVal), pansichar(fieldsVal), true);
2946 end;
2947 // preparekey, setrangebuffer and updatekeyfrom* are functions which arguments
2948 // are not entirely classified in pchar<>trecordbuffer terms.
2949 // so we typecast for now.
2950 fieldsVal := TRecordBuffer(TIndexCursor(FCursor).IndexFile.PrepareKey((fieldsVal), FMasterLink.Parser.ResultType));
2951 SetRangeBuffer(pansichar(fieldsVal), pansichar(fieldsVal));
2952 end;
2953
2954 procedure TDbf.MasterChanged(Sender: TObject);
2955 begin
2956 CheckBrowseMode;
2957 CheckMasterRange;
2958 end;
2959
2960 procedure TDbf.MasterDisabled(Sender: TObject);
2961 begin
2962 CancelRange;
2963 end;
2964
GetDataSourcenull2965 function TDbf.GetDataSource: TDataSource;
2966 begin
2967 Result := FMasterLink.DataSource;
2968 end;
2969
2970 procedure TDbf.SetDataSource(Value: TDataSource);
2971 begin
2972 {$ifndef FPC}
2973 if IsLinkedTo(Value) then
2974 begin
2975 {$ifdef DELPHI_4}
2976 DatabaseError(SCircularDataLink, Self);
2977 {$else}
2978 DatabaseError(SCircularDataLink);
2979 {$endif}
2980 end;
2981 {$endif}
2982 FMasterLink.DataSource := Value;
2983 end;
2984
TDbf.GetMasterFieldsnull2985 function TDbf.GetMasterFields: string;
2986 begin
2987 Result := FMasterLink.FieldNames;
2988 end;
2989
2990 procedure TDbf.SetMasterFields(const Value: string);
2991 begin
2992 FMasterLink.FieldNames := Value;
2993 end;
2994
2995 //==========================================================
2996 //============ TDbfIndexDefs
2997 //==========================================================
2998 constructor TDbfIndexDefs.Create(AOwner: TDbf);
2999 begin
3000 inherited Create(TDbfIndexDef);
3001 FOwner := AOwner;
3002 end;
3003
Addnull3004 function TDbfIndexDefs.Add: TDbfIndexDef;
3005 begin
3006 Result := TDbfIndexDef(inherited Add);
3007 end;
3008
3009 procedure TDbfIndexDefs.SetItem(N: Integer; Value: TDbfIndexDef);
3010 begin
3011 inherited SetItem(N, Value);
3012 end;
3013
GetItemnull3014 function TDbfIndexDefs.GetItem(N: Integer): TDbfIndexDef;
3015 begin
3016 Result := TDbfIndexDef(inherited GetItem(N));
3017 end;
3018
TDbfIndexDefs.GetOwnernull3019 function TDbfIndexDefs.GetOwner: tpersistent;
3020 begin
3021 Result := FOwner;
3022 end;
3023
GetIndexByNamenull3024 function TDbfIndexDefs.GetIndexByName(const Name: string): TDbfIndexDef;
3025 var
3026 I: Integer;
3027 lIndex: TDbfIndexDef;
3028 begin
3029 for I := 0 to Count-1 do
3030 begin
3031 lIndex := Items[I];
3032 if lIndex.IndexFile = Name then
3033 begin
3034 Result := lIndex;
3035 exit;
3036 end
3037 end;
3038 Result := nil;
3039 end;
3040
GetIndexByFieldnull3041 function TDbfIndexDefs.GetIndexByField(const Name: string): TDbfIndexDef;
3042 var
3043 lIndex: TDbfIndexDef;
3044 searchStr: string;
3045 i: integer;
3046 begin
3047 searchStr := AnsiUpperCase(Trim(Name));
3048 Result := nil;
3049 if searchStr = EmptyStr then
3050 exit;
3051
3052 for I := 0 to Count-1 do
3053 begin
3054 lIndex := Items[I];
3055 if AnsiUpperCase(Trim(lIndex.SortField)) = searchStr then
3056 begin
3057 Result := lIndex;
3058 exit;
3059 end
3060 end;
3061 end;
3062
3063 procedure TDbfIndexDefs.Update;
3064 begin
3065 if Assigned(FOwner) then
3066 FOwner.UpdateIndexDefs;
3067 end;
3068
3069 //==========================================================
3070 //============ TDbfMasterLink
3071 //==========================================================
3072
3073 constructor TDbfMasterLink.Create(ADataSet: TDbf);
3074 begin
3075 inherited Create;
3076
3077 FDetailDataSet := ADataSet;
3078 FParser := TDbfParser.Create(nil);
3079 FValidExpression := false;
3080 end;
3081
3082 destructor TDbfMasterLink.Destroy;
3083 begin
3084 FParser.Free;
3085
3086 inherited;
3087 end;
3088
3089 procedure TDbfMasterLink.ActiveChanged;
3090 begin
3091 if Active and (FFieldNames <> EmptyStr) then
3092 begin
3093 FValidExpression := false;
3094 FParser.DbfFile := (DataSet as TDbf).DbfFile;
3095 FParser.ParseExpression(FFieldNames);
3096 FValidExpression := true;
3097 end else begin
3098 FParser.ClearExpressions;
3099 FValidExpression := false;
3100 end;
3101
3102 if FDetailDataSet.Active and not (csDestroying in FDetailDataSet.ComponentState) then
3103 if Active then
3104 begin
3105 if Assigned(FOnMasterChange) then FOnMasterChange(Self);
3106 end else
3107 if Assigned(FOnMasterDisable) then FOnMasterDisable(Self);
3108 end;
3109
3110 procedure TDbfMasterLink.CheckBrowseMode;
3111 begin
3112 if FDetailDataSet.Active then
3113 FDetailDataSet.CheckBrowseMode;
3114 end;
3115
3116 procedure TDbfMasterLink.LayoutChanged;
3117 begin
3118 ActiveChanged;
3119 end;
3120
3121 procedure TDbfMasterLink.RecordChanged(Field: TField);
3122 begin
3123 if (DataSource.State <> dsSetKey) and FDetailDataSet.Active and Assigned(FOnMasterChange) then
3124 FOnMasterChange(Self);
3125 end;
3126
3127 procedure TDbfMasterLink.SetFieldNames(const Value: string);
3128 begin
3129 if FFieldNames <> Value then
3130 begin
3131 FFieldNames := Value;
3132 ActiveChanged;
3133 end;
3134 end;
3135
TDbfMasterLink.GetFieldsValnull3136 function TDbfMasterLink.GetFieldsVal: TRecordBuffer;
3137 begin
3138 Result := TRecordBuffer(FParser.ExtractFromBuffer(@pDbfRecord(TDbf(DataSet).ActiveBuffer)^.DeletedFlag));
3139 end;
3140
3141 ////////////////////////////////////////////////////////////////////////////
3142
ApplicationPathnull3143 function ApplicationPath: string;
3144 begin
3145 Result := ExtractFilePath(ParamStr(0));
3146 end;
3147
3148
3149 ////////////////////////////////////////////////////////////////////////////
3150
3151 initialization
3152
3153 DbfBasePath := ApplicationPath;
3154
3155 end.
3156
3157