7bf92d7867
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7101 8e941d3f-bd1b-0410-a28a-d453659cc2b4
957 lines
27 KiB
ObjectPascal
957 lines
27 KiB
ObjectPascal
unit paradoxds;
|
|
|
|
{ TParadoxdataSet
|
|
Christian Ulrich christian@ullihome.de
|
|
License: LGPL
|
|
}
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, db, lconvencoding, bufdataset_parser;
|
|
|
|
|
|
const
|
|
{ Paradox codes for field types }
|
|
pxfAlpha = $01;
|
|
pxfDate = $02;
|
|
pxfShort = $03;
|
|
pxfLong = $04;
|
|
pxfCurrency = $05;
|
|
pxfNumber = $06;
|
|
pxfLogical = $09;
|
|
pxfMemoBLOb = $0C;
|
|
pxfBLOb = $0D;
|
|
pxfFmtMemoBLOb = $0E;
|
|
pxfOLE = $0F;
|
|
pxfGraphic = $10;
|
|
pxfTime = $14;
|
|
pxfTimestamp = $15;
|
|
pxfAutoInc = $16;
|
|
pxfBCD = $17;
|
|
pxfBytes = $18;
|
|
|
|
|
|
type
|
|
{Internal Record information}
|
|
PRecInfo = ^TRecInfo;
|
|
TRecInfo = packed record
|
|
RecordNumber: PtrInt;
|
|
BookmarkFlag: TBookmarkFlag;
|
|
end;
|
|
|
|
PLongWord = ^Longword;
|
|
|
|
{ field information record used in TPxHeader below }
|
|
PFldInfoRec = ^TFldInfoRec;
|
|
TFldInfoRec = packed record
|
|
fType: byte;
|
|
fSize: byte;
|
|
end;
|
|
|
|
PPxHeader = ^TPxHeader;
|
|
TPxHeader = packed record
|
|
recordSize : word;
|
|
headerSize : word;
|
|
fileType : byte;
|
|
maxTableSize : byte;
|
|
numRecords : longint;
|
|
nextBlock : word;
|
|
fileBlocks : word;
|
|
firstBlock : word;
|
|
lastBlock : word;
|
|
unknown12x13 : word;
|
|
modifiedFlags1 : byte;
|
|
indexFieldNumber : byte;
|
|
primaryIndexWorkspace : longint; // currently not used; cast to "pointer"
|
|
unknownPtr1A : longint; // not used; cast to pointer;
|
|
unknown1Ex20 : array[$001E..$0020] of byte;
|
|
numFields : smallint;
|
|
primaryKeyFields : smallint;
|
|
encryption1 : longint;
|
|
sortOrder : byte;
|
|
modifiedFlags2 : byte;
|
|
unknown2Bx2C : array[$002B..$002C] of byte;
|
|
changeCount1 : byte;
|
|
changeCount2 : byte;
|
|
unknown2F : byte;
|
|
tableNamePtrPtr : longint; // must be cast to ^pchar
|
|
fldInfo : longint; // use FFieldInfoPtr instead
|
|
writeProtected : byte;
|
|
fileVersionID : byte;
|
|
maxBlocks : word;
|
|
unknown3C : byte;
|
|
auxPasswords : byte;
|
|
unknown3Ex3F : array[$003E..$003F] of byte;
|
|
cryptInfoStartPtr : longint; // not used; cast to pointer
|
|
cryptInfoEndPtr : longint; // not used; cast to pointer
|
|
unknown48 : byte;
|
|
autoIncVal : longint;
|
|
unknown4Dx4E : array[$004D..$004E] of byte;
|
|
indexUpdateRequired : byte;
|
|
unknown50x54 : array[$0050..$0054] of byte;
|
|
refIntegrity : byte;
|
|
unknown56x57 : array[$0056..$0057] of byte;
|
|
case smallint of
|
|
3: (fieldInfo35 : array[1..255] of TFldInfoRec);
|
|
4: (fileVerID2 : smallint;
|
|
fileVerID3 : smallint;
|
|
encryption2 : longint;
|
|
fileUpdateTime : longint; { 4.0 only }
|
|
hiFieldID : word;
|
|
hiFieldIDinfo : word;
|
|
sometimesNumFields:smallint;
|
|
dosCodePage : word;
|
|
unknown6Cx6F : array[$006C..$006F] of byte;
|
|
changeCount4 : smallint;
|
|
unknown72x77 : array[$0072..$0077] of byte;
|
|
fieldInfo : array[1..255] of TFldInfoRec);
|
|
|
|
{ This is only the first part of the file header. The last field
|
|
is described as an array of 255 elements, but its size is really
|
|
determined by the number of fields in the table. The actual
|
|
table header has more information that follows. }
|
|
end;
|
|
|
|
{Paradox Data Block Header}
|
|
PDataBlock = ^TDataBlock;
|
|
TDataBlock = packed RECORD
|
|
nextBlock : word;
|
|
prevBlock : word;
|
|
addDataSize : smallint;
|
|
//fileData : array[0..$0FF9] of byte;
|
|
{ fileData size varies according to maxTableSize }
|
|
end;
|
|
|
|
TPxField = record
|
|
Info: PFldInfoRec;
|
|
Offset: LongInt;
|
|
Name: String;
|
|
end;
|
|
|
|
{10-byte Blob Info Block}
|
|
TPxBlobInfo = packed record
|
|
FileLoc: LongWord;
|
|
Length: LongWord;
|
|
ModCount: Word;
|
|
end;
|
|
|
|
{Blob Pointer Array Entry}
|
|
TPxBlobIndex = packed record
|
|
Offset: Byte;
|
|
Len16: Byte;
|
|
ModCount: Word;
|
|
Len: Byte;
|
|
end;
|
|
|
|
|
|
{ TParadoxDataset }
|
|
|
|
TParadoxDataset = class(TDataset)
|
|
private
|
|
FActive: Boolean;
|
|
FStream: TStream;
|
|
FBlobStream: TStream;
|
|
FFileName: TFileName;
|
|
FHeader: PPxHeader;
|
|
FaRecord: LongInt; // was: LongWord;
|
|
FaBlockstart: LongInt;
|
|
FaBlock: PDataBlock;
|
|
FaBlockIdx: word;
|
|
FBlockReaded: Boolean;
|
|
FFieldInfoPtr: PFldInfoRec;
|
|
FTableNameLen: Integer;
|
|
FInputEncoding: String;
|
|
FTargetEncoding: String;
|
|
FPxFields: Array of TPxField;
|
|
FFilterBuffer : TRecordBuffer;
|
|
FParser: TBufDatasetParser;
|
|
function GetEncrypted: Boolean;
|
|
function GetInputEncoding: String; inline;
|
|
function GetPrimaryKeyFieldCount: Integer;
|
|
function GetTargetEncoding: String; inline;
|
|
function GetVersion: String;
|
|
function IsStoredTargetEncoding: Boolean;
|
|
function PxFilterRecord(Buffer: TRecordBuffer): Boolean;
|
|
function PxGetActiveBuffer(var Buffer: TRecordBuffer): Boolean;
|
|
procedure ReadBlock;
|
|
procedure ReadNextBlockHeader;
|
|
procedure ReadPrevBlockHeader;
|
|
procedure SetFileName(const AValue: TFileName);
|
|
procedure SetTargetEncoding(AValue: String);
|
|
protected
|
|
function AllocRecordBuffer: PChar; override;
|
|
procedure FreeRecordBuffer(var Buffer: PChar); override;
|
|
procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
|
|
function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
|
|
function GetCanModify: Boolean;override;
|
|
function GetRecNo: Integer; override;
|
|
function GetRecord(Buffer: PChar; GetMode: TGetMode; {%H-}DoCheck: Boolean): TGetResult; override;
|
|
function GetRecordCount: Integer; override;
|
|
function GetRecordSize: Word; override;
|
|
procedure InternalClose; override;
|
|
procedure InternalEdit; override;
|
|
procedure InternalFirst; override;
|
|
procedure InternalGotoBookmark(ABookmark: Pointer); override;
|
|
// procedure InternalHandleException; override;
|
|
procedure InternalInitFieldDefs; override;
|
|
procedure InternalInitRecord(Buffer: PChar); override;
|
|
procedure InternalLast; override;
|
|
procedure InternalOpen; override;
|
|
procedure InternalPost; override;
|
|
procedure InternalSetToRecord(Buffer: PChar); override;
|
|
function IsCursorOpen: Boolean; override;
|
|
procedure ParseFilter(const AFilter: string);
|
|
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
|
|
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
|
|
procedure SetFiltered(Value: Boolean); override;
|
|
procedure SetFilterText(const Value: String); override;
|
|
procedure SetRecNo(Value: Integer); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
function BookmarkValid(ABookmark: TBookmark): Boolean; override;
|
|
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override;
|
|
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
|
|
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
|
|
procedure SetFieldData({%H-}Field: TField; {%H-}Buffer: Pointer); override;
|
|
property Encrypted: Boolean read GetEncrypted;
|
|
property PrimaryKeyFieldCount: Integer read GetPrimaryKeyFieldCount;
|
|
published
|
|
property TableName: TFileName read FFileName write SetFileName;
|
|
property TableLevel: String read GetVersion;
|
|
property InputEncoding: String read FInputEncoding;
|
|
property TargetEncoding: String read FTargetEncoding write SetTargetEncoding stored IsStoredTargetEncoding;
|
|
property Active;
|
|
property AutoCalcFields;
|
|
property FieldDefs;
|
|
property Filter;
|
|
property Filtered;
|
|
property BeforeOpen;
|
|
property AfterOpen;
|
|
property BeforeClose;
|
|
property AfterClose;
|
|
// property BeforeInsert;
|
|
// property AfterInsert;
|
|
// property BeforeEdit;
|
|
// property AfterEdit;
|
|
// property BeforePost;
|
|
// property AfterPost;
|
|
// property BeforeCancel;
|
|
// property AfterCancel;
|
|
// property BeforeDelete;
|
|
// property AfterDelete;
|
|
property BeforeScroll;
|
|
property AfterScroll;
|
|
// property BeforeRefresh;
|
|
// property AfterRefresh;
|
|
property OnCalcFields;
|
|
// property OnDeleteError;
|
|
// property OnEditError;
|
|
property OnFilterRecord;
|
|
// property OnNewRecord;
|
|
// property OnPostError;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
{ TParadoxDataset }
|
|
|
|
constructor TParadoxDataset.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FHeader := nil;
|
|
FTargetEncoding := Uppercase(EncodingUTF8);
|
|
FInputEncoding := '';
|
|
BookmarkSize := SizeOf(LongInt);
|
|
end;
|
|
|
|
function TParadoxDataset.AllocRecordBuffer: PChar;
|
|
begin
|
|
if Assigned(Fheader) then
|
|
Result := AllocMem(GetRecordSize)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TParadoxDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
|
|
begin
|
|
Result := Assigned(ABookmark) and (Length(ABookmark) <> 0);
|
|
end;
|
|
|
|
function TParadoxDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
|
|
var
|
|
idx1, idx2: LongWord;
|
|
begin
|
|
idx1 := PLongWord(Bookmark1)^;
|
|
idx2 := PLongWord(Bookmark2)^;
|
|
if idx1 > idx2 then
|
|
Result := +1
|
|
else
|
|
if idx1 = idx2 then
|
|
Result := 0
|
|
else
|
|
Result := -1
|
|
end;
|
|
|
|
function TParadoxDataset.CreateBlobStream(Field: TField;
|
|
Mode: TBlobStreamMode): TStream;
|
|
var
|
|
memStream: TMemoryStream;
|
|
p: PChar;
|
|
header: PAnsiChar;
|
|
idx: Byte;
|
|
loc: Integer;
|
|
s: String;
|
|
blobInfo: TPxBlobInfo;
|
|
blobIndex: TPxBlobIndex;
|
|
begin
|
|
memStream := TMemoryStream.Create;
|
|
Result := memStream;
|
|
|
|
if (Mode <> bmRead) then
|
|
exit;
|
|
|
|
p := ActiveBuffer + FPxFields[Field.FieldNo - 1].Offset;
|
|
header := p + Field.Size - SizeOf(TPxBlobInfo);
|
|
Move(header^, blobInfo{%H-}, SizeOf(blobInfo));
|
|
if blobInfo.Length = 0 then
|
|
exit;
|
|
|
|
if Integer(blobInfo.Length) > Field.Size - SizeOf(TPxBlobInfo) then
|
|
begin
|
|
if Assigned(FBlobStream) then begin
|
|
idx := blobInfo.FileLoc and $FF;
|
|
loc := blobInfo.FileLoc and $FFFFFF00;
|
|
if idx = $FF then begin
|
|
// Read from a single blob block
|
|
FBlobStream.Seek(loc + 9, soFromBeginning);
|
|
if Field.DataType = ftMemo then begin
|
|
SetLength(s, blobInfo.Length);
|
|
FBlobStream.Read(s[1], blobInfo.Length);
|
|
s := ConvertEncoding(s, GetInputEncoding, GetTargetEncoding);
|
|
memStream.Write(s[1], Length(s));
|
|
end else
|
|
begin
|
|
if Field.DataType = ftGraphic then begin
|
|
memstream.WriteAnsiString('bmp'); // Assuming that Paradox can store only bmp as ftGraphic... Wrong?
|
|
FBlobStream.Position := FBlobStream.Position + 8;
|
|
end;
|
|
memStream.CopyFrom(FBlobStream, blobInfo.Length);
|
|
end;
|
|
end else begin
|
|
// Read from a suballocated block
|
|
FBlobStream.Seek(loc + 12 + 5*idx, soFromBeginning);
|
|
FBlobStream.Read(blobIndex{%H-}, SizeOf(TPxBlobIndex));
|
|
FBlobStream.Seek(loc + 16*blobIndex.Offset, soFromBeginning);
|
|
if Field.DataType = ftMemo then begin
|
|
SetLength(s, blobInfo.Length);
|
|
FBlobStream.Read(s[1], blobInfo.Length);
|
|
s := ConvertEncoding(s, GetInputEncoding, GetTargetEncoding);
|
|
memStream.Write(s[1], Length(s));
|
|
end else
|
|
memStream.CopyFrom(FBlobStream, blobInfo.Length);
|
|
end;
|
|
end;
|
|
end else
|
|
if Field.DataType = ftMemo then begin
|
|
SetLength(s, blobInfo.Length);
|
|
Move(p^, s[1], blobInfo.Length);
|
|
s := ConvertEncoding(s, GetInputEncoding, GetTargetEncoding);
|
|
memStream.Write(s[1], Length(s));
|
|
end else
|
|
memStream.Write(p, blobInfo.Length);
|
|
|
|
memStream.Position := 0;
|
|
end;
|
|
|
|
procedure TParadoxDataset.FreeRecordBuffer(var Buffer: PChar);
|
|
begin
|
|
if Assigned(Buffer) then
|
|
FreeMem(Buffer);
|
|
end;
|
|
|
|
procedure TParadoxDataset.GetBookmarkData(Buffer: PChar; Data: Pointer);
|
|
begin
|
|
PLongWord(Data)^ := PRecInfo(Buffer + FHeader^.RecordSize)^.RecordNumber;
|
|
end;
|
|
|
|
function TParadoxDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
|
|
begin
|
|
Result := PRecInfo(Buffer + FHeader^.RecordSize)^.BookmarkFlag;
|
|
end;
|
|
|
|
function TParadoxDataset.GetCanModify: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TParadoxDataset.GetEncrypted: Boolean;
|
|
begin
|
|
if not Assigned(FHeader) then exit;
|
|
If (FHeader^.fileVersionID <= 4) or not (FHeader^.fileType in [0,2,3,5]) then
|
|
Result := (FHeader^.encryption1 <> 0)
|
|
else
|
|
Result := (FHeader^.encryption2 <> 0)
|
|
end;
|
|
|
|
function TParadoxDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
|
|
var
|
|
b: WordBool;
|
|
F: PFldInfoRec;
|
|
i: Integer;
|
|
size: Integer;
|
|
p: PChar;
|
|
s: array[0..7] of byte;
|
|
si: SmallInt absolute s;
|
|
int: LongInt absolute s;
|
|
d: Double absolute s;
|
|
str: String;
|
|
buf: TRecordBuffer = nil;
|
|
begin
|
|
Result := False;
|
|
if (RecordCount = 0) then
|
|
exit;
|
|
|
|
PXGetActiveBuffer(Buf);
|
|
p := buf + FPxFields[Field.FieldNo - 1].Offset;
|
|
F := FPxFields[Field.FieldNo - 1].Info;
|
|
size := F^.fSize;
|
|
|
|
// These numeric fields are stored as big endian --> swap bytes
|
|
if F^.fType in [pxfDate..pxfNumber, pxfTime..pxfAutoInc] then begin
|
|
for i := 0 to pred(size) do
|
|
s[pred(size-i)] := byte(p[i]);
|
|
s[pred(size)] := s[pred(size)] xor $80;
|
|
end;
|
|
|
|
case F^.fType of
|
|
pxfAlpha:
|
|
if (Buffer <> nil) then begin
|
|
str := ConvertEncoding(StrPas(p), GetInputEncoding, GetTargetEncoding);
|
|
if str <> '' then begin
|
|
StrLCopy(Buffer, PChar(str), Length(str));
|
|
Result := true;
|
|
end;
|
|
end;
|
|
pxfBytes:
|
|
if Buffer <> nil then begin
|
|
StrLCopy(Buffer, PAnsiChar(p), F^.fSize);
|
|
Result := true;
|
|
end;
|
|
pxfDate:
|
|
if int <> $FFFFFFFF80000000 then begin // This transforms to Dec/12/9999 and probably is NULL
|
|
Move(int, Buffer^, SizeOf(LongInt));
|
|
Result := True;
|
|
end;
|
|
pxfShort:
|
|
begin
|
|
Move(si, Buffer^, SizeOf(SmallInt));
|
|
Result := True;
|
|
end;
|
|
pxfLong, pxfAutoInc:
|
|
begin
|
|
Move(int, Buffer^, SizeOf(LongInt));
|
|
Result := True;
|
|
end;
|
|
pxfCurrency, pxfNumber, pxfTimeStamp:
|
|
begin
|
|
Move(d, Buffer^, SizeOf(d));
|
|
Result := True;
|
|
end;
|
|
pxfLogical:
|
|
begin
|
|
b := not ((p^ = #$80) or (p^ = #0));
|
|
if Assigned(Buffer) then
|
|
Move(b, Buffer^, SizeOf(b));
|
|
Result := true; // Keep outside "if Assigned" otherwise checkboxes will be wrong.
|
|
end;
|
|
pxfTime:
|
|
begin
|
|
Move(int, Buffer^, SizeOf(LongInt));
|
|
Result := True;
|
|
end;
|
|
pxfGraphic:
|
|
Result := ActiveBuffer <> nil;
|
|
end;
|
|
end;
|
|
|
|
function TParadoxDataset.GetInputEncoding: String;
|
|
begin
|
|
if FInputEncoding = '' then
|
|
Result := GetDefaultTextEncoding
|
|
else
|
|
Result := FInputEncoding;
|
|
end;
|
|
|
|
function TParadoxDataset.GetPrimaryKeyFieldCount: Integer;
|
|
begin
|
|
if FHeader <> nil then
|
|
Result := FHeader^.primaryKeyFields
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TParadoxDataset.GetRecNo: Integer;
|
|
begin
|
|
Result := -1;
|
|
if Assigned(ActiveBuffer) then
|
|
Result := PRecInfo(ActiveBuffer + FHeader^.recordSize)^.RecordNumber;
|
|
end;
|
|
|
|
function TParadoxDataset.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
|
|
var
|
|
L: Longword;
|
|
accepted: Boolean;
|
|
begin
|
|
Result := grOK;
|
|
accepted := false;
|
|
|
|
repeat
|
|
case GetMode of
|
|
gmNext:
|
|
begin
|
|
inc(FaRecord);
|
|
if (FaBlockIdx = FHeader^.lastBlock) and
|
|
(FaRecord > FaBlockStart + FaBlock^.addDataSize div FHeader^.recordSize + 1)
|
|
then
|
|
Result := grEOF
|
|
else
|
|
if FaRecord > FaBlockStart+1+(FaBlock^.addDataSize div FHeader^.recordSize) then
|
|
ReadNextBlockHeader;
|
|
end;
|
|
gmPrior:
|
|
begin
|
|
dec(FaRecord);
|
|
if (FaBlockIdx = FHeader^.firstBlock) and (FaRecord < 1) then
|
|
Result := grBOF
|
|
else
|
|
if FaRecord <= FaBlockStart then
|
|
begin
|
|
ReadPrevBlockHeader;
|
|
FaRecord := FaBlockStart+(FaBlock^.addDataSize div FHeader^.recordSize)+1;
|
|
end;
|
|
end;
|
|
gmCurrent:
|
|
if (FaRecord > RecordCount) or (FaRecord < 1) then
|
|
result := grError;
|
|
end;
|
|
|
|
if Result = grOK then begin
|
|
if not FBlockReaded then
|
|
ReadBlock;
|
|
L := ((faRecord - (FaBlockstart + 1))*FHeader^.recordSize) + 6;
|
|
if (faRecord - (FaBlockstart + 1)) >= 0 then
|
|
Move(PChar(FaBlock)[L],Buffer[0],FHeader^.recordSize)
|
|
else
|
|
Result := grError;
|
|
with PRecInfo(Buffer + FHeader^.recordSize)^ do begin
|
|
BookmarkFlag := bfCurrent;
|
|
RecordNumber := FaRecord;
|
|
end;
|
|
|
|
// Filtering
|
|
if Filtered then
|
|
accepted := PXFilterRecord(Buffer)
|
|
else
|
|
accepted := True;
|
|
if (GetMode = gmCurrent) and not accepted then
|
|
Result := grError;
|
|
end;
|
|
until (Result <> grOK) or Accepted;
|
|
end;
|
|
|
|
function TParadoxDataset.GetRecordCount: Integer;
|
|
begin
|
|
if Assigned(FHeader) then
|
|
Result := FHeader^.numRecords
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TParadoxDataset.GetRecordSize: Word;
|
|
begin
|
|
Result := FHeader^.recordSize + sizeof(TRecInfo);
|
|
end;
|
|
|
|
function TParadoxDataset.GetTargetEncoding: String;
|
|
begin
|
|
if (FTargetEncoding = '') or SameText(FTargetEncoding, 'utf-8') then
|
|
Result := EncodingUTF8
|
|
else
|
|
Result := FTargetEncoding;
|
|
end;
|
|
|
|
function TParadoxDataset.GetVersion: String;
|
|
begin
|
|
Result := '';
|
|
if not FActive then
|
|
exit;
|
|
if not Assigned(FHeader) then
|
|
exit;
|
|
case FHeader^.fileVersionID of
|
|
$3 : Result := '3.0';
|
|
$4 : Result := '3.5';
|
|
$5..$9 : Result := '4.0';
|
|
$a..$b : Result := '5.0';
|
|
$c : Result := '7.0';
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalClose;
|
|
begin
|
|
FInputEncoding := '';
|
|
BindFields(FALSE);
|
|
if DefaultFields then // Destroy the TField
|
|
DestroyFields;
|
|
FreeMem(FHeader);
|
|
FreeMem(FaBlock);
|
|
FreeAndNil(FParser);
|
|
FreeAndNil(FBlobStream);
|
|
FreeAndNil(FStream);
|
|
FActive := False;
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalEdit;
|
|
begin
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalFirst;
|
|
begin
|
|
FaBlockIdx := FHeader^.firstBlock;
|
|
FaBlockstart := 0;
|
|
FaRecord := 0;
|
|
ReadBlock;
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalGotoBookmark(ABookmark: Pointer);
|
|
begin
|
|
if BookmarkValid(ABookmark) then
|
|
SetRecNo(PLongWord(ABookmark)^);
|
|
end;
|
|
|
|
{
|
|
procedure TParadoxDataset.InternalHandleException;
|
|
begin
|
|
Application.HandleException(Self);
|
|
end;
|
|
}
|
|
procedure TParadoxDataset.InternalInitFieldDefs;
|
|
var
|
|
i: integer;
|
|
F: PFldInfoRec;
|
|
FNamesStart: PChar;
|
|
fname: String;
|
|
offs: LongInt;
|
|
begin
|
|
FieldDefs.Clear;
|
|
F := FFieldInfoPtr; { begin with the first field identifier }
|
|
FNamesStart := Pointer(F);
|
|
inc(FNamesStart, SizeOf(F^)*(FHeader^.numFields)); //Jump over FieldDefs
|
|
inc(FNamesStart, SizeOf(LongInt)); //over TableName pointer
|
|
inc(FNamesStart, SizeOf(LongInt)*(FHeader^.numFields)); //over FieldName pointers
|
|
inc(FNamesStart, FTableNameLen); // over Tablename and padding
|
|
|
|
SetLength(FPxFields, FHeader^.NumFields);
|
|
offs := 0;
|
|
|
|
for i := 1 to FHeader^.NumFields do
|
|
begin
|
|
fname := ConvertEncoding(StrPas(FNamesStart), GetInputEncoding, GetTargetEncoding);
|
|
case F^.fType of
|
|
pxfAlpha: FieldDefs.Add(fname, ftString, F^.fSize);
|
|
pxfDate: FieldDefs.Add(fname, ftDate, 0);
|
|
pxfShort: FieldDefs.Add(fname, ftSmallInt, F^.fSize);
|
|
pxfLong: FieldDefs.Add(fname, ftInteger, F^.fSize);
|
|
pxfCurrency: FieldDefs.Add(fname, ftCurrency, F^.fSize);
|
|
pxfNumber: FieldDefs.Add(fname, ftFloat, F^.fSize);
|
|
pxfLogical: FieldDefs.Add(fname, ftBoolean, 0); //F^.fSize);
|
|
pxfMemoBLOb: FieldDefs.Add(fname, ftMemo, F^.fSize);
|
|
pxfBLOb: FieldDefs.Add(fname, ftBlob, F^.fSize);
|
|
pxfFmtMemoBLOb: FieldDefs.Add(fname, ftMemo, F^.fSize);
|
|
pxfOLE: FieldDefs.Add(fname, ftBlob, F^.fSize);
|
|
pxfGraphic: FieldDefs.Add(fname, ftGraphic, F^.fSize); // was: ftBlob
|
|
pxfTime: FieldDefs.Add(fname, ftTime, 0); //F^.fSize);
|
|
pxfTimestamp: FieldDefs.Add(fname, ftDateTime, 0);
|
|
pxfAutoInc: FieldDefs.Add(fname, ftAutoInc, F^.fSize);
|
|
pxfBCD: FieldDefs.Add(fname, ftBCD, F^.fSize);
|
|
pxfBytes: FieldDefs.Add(fname, ftBytes, F^.fSize); // was: ftString
|
|
end;
|
|
with FPxFields[i-1] do begin
|
|
Name := fname;
|
|
Info := F;
|
|
Offset := offs;
|
|
end;
|
|
offs := offs + F^.fSize;
|
|
inc(FNamesStart, Length(fname)+1);
|
|
inc(F);
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalInitRecord(Buffer: PChar);
|
|
begin
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalLast;
|
|
begin
|
|
while FaBlockIdx <> FHeader^.lastBlock do
|
|
ReadNextBlockHeader;
|
|
inc(FaRecord,(FaBlock^.addDataSize div FHeader^.RecordSize)+1);
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalOpen;
|
|
var
|
|
hdrSize: Word;
|
|
blobfn: String;
|
|
cp: Word;
|
|
begin
|
|
if FFileName = '' then
|
|
DatabaseError('Tablename is not set');
|
|
if not FileExists(FFileName) then
|
|
DatabaseError(Format('Paradox file "%" does not exist.', [FFileName]));
|
|
|
|
FStream := TFileStream.Create(FFilename,fmOpenRead or fmShareDenyNone);
|
|
FStream.Position := 2;
|
|
hdrSize := FStream.ReadWord;
|
|
FHeader := AllocMem(hdrSize);
|
|
FStream.Position := 0;
|
|
if not FStream.Read(FHeader^, hdrSize) = hdrSize then
|
|
DatabaseError('No valid Paradox file !');
|
|
if not ((FHeader^.maxTableSize >= 1) and (FHeader^.maxTableSize <= 32)) then
|
|
DatabaseError('No valid Paradox file !');
|
|
|
|
if (FHeader^.fileVersionID >= 12) then
|
|
FTableNameLen := 261
|
|
else
|
|
FTableNameLen := 79;
|
|
|
|
if (FHeader^.fileVersionID <= 4) or not (FHeader^.FileType in [0,2,3,5]) then
|
|
FFieldInfoPtr := @FHeader^.FieldInfo35
|
|
else begin
|
|
FFieldInfoPtr := @FHeader^.FieldInfo;
|
|
cp := FHeader^.DosCodePage;
|
|
FInputEncoding := 'CP' + IntToStr(cp);
|
|
end;
|
|
|
|
if Encrypted then
|
|
exit;
|
|
|
|
FBlobStream := nil;
|
|
blobfn := ChangeFileExt(FFileName, '.mb');
|
|
if FileExists(blobfn) then
|
|
FBlobStream := TFileStream.Create(blobfn, fmOpenRead + fmShareDenyNone)
|
|
else begin
|
|
blobfn := ChangeFileExt(FFileName, '.MB');
|
|
if FileExists(blobfn) then
|
|
FBlobStream := TFileStream.Create(blobfn, fmOpenRead + fmShareDenyNone);
|
|
end;
|
|
|
|
FaBlock := AllocMem(FHeader^.maxTableSize * $0400);
|
|
BookmarkSize := SizeOf(longword);
|
|
InternalFirst;
|
|
InternalInitFieldDefs;
|
|
if DefaultFields then CreateFields;
|
|
BindFields(True);
|
|
FActive := True;
|
|
|
|
try
|
|
ParseFilter(Filter);
|
|
except
|
|
on E: Exception do
|
|
Filter := '';
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalPost;
|
|
begin
|
|
end;
|
|
|
|
procedure TParadoxDataset.InternalSetToRecord(Buffer: PChar);
|
|
var
|
|
bm: LongWord;
|
|
begin
|
|
if (State <> dsInsert) then begin
|
|
bm := PRecInfo(Buffer + FHeader^.RecordSize)^.RecordNumber;
|
|
InternalGotoBookmark(@bm);
|
|
end;
|
|
end;
|
|
|
|
function TParadoxDataset.IsCursorOpen: Boolean;
|
|
begin
|
|
Result := FActive;
|
|
end;
|
|
|
|
function TParadoxDataset.IsStoredTargetEncoding: Boolean;
|
|
begin
|
|
Result := not SameText(FTargetEncoding, EncodingUTF8);
|
|
end;
|
|
|
|
procedure TParadoxDataset.ParseFilter(const AFilter: string);
|
|
begin
|
|
if Length(AFilter) > 0 then
|
|
begin
|
|
if (FParser = nil) and IsCursorOpen then
|
|
FParser := TBufDatasetParser.Create(Self);
|
|
if FParser <> nil then
|
|
begin
|
|
FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
|
|
FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
|
|
FParser.ParseExpression(AFilter);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TParadoxDataset.PxFilterRecord(Buffer: TRecordBuffer): Boolean;
|
|
var
|
|
SaveState: TDatasetState;
|
|
begin
|
|
Result := True;
|
|
if not Assigned(OnFilterRecord) and not Filtered then
|
|
Exit;
|
|
SaveState := SetTempState(dsFilter);
|
|
Try
|
|
FFilterBuffer := Buffer;
|
|
If Assigned(OnFilterRecord) then
|
|
OnFilterRecord(Self, Result);
|
|
If Result and Filtered and (Filter <> '') then
|
|
Result := Boolean((FParser.ExtractFromBuffer(FFilterBuffer))^);
|
|
Finally
|
|
RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
function TParadoxDataset.PxGetActiveBuffer(var Buffer: TRecordBuffer): Boolean;
|
|
begin
|
|
case State of
|
|
dsBrowse:
|
|
if IsEmpty then
|
|
Buffer := nil
|
|
else
|
|
Buffer := ActiveBuffer;
|
|
dsEdit,
|
|
dsInsert:
|
|
Buffer := ActiveBuffer;
|
|
dsFilter:
|
|
Buffer := FFilterBuffer;
|
|
else
|
|
Buffer := nil;
|
|
end;
|
|
Result := (Buffer <> nil);
|
|
end;
|
|
|
|
procedure TParadoxDataset.ReadBlock;
|
|
var
|
|
L : longint;
|
|
begin
|
|
L := FaBlockIdx-1;
|
|
L := (L * FHeader^.maxTableSize * $0400) + FHeader^.headerSize;
|
|
FStream.Position := L;
|
|
FStream.Read(FaBlock^, FHeader^.maxTableSize * $0400);
|
|
FBlockReaded := True;
|
|
end;
|
|
|
|
procedure TParadoxDataset.ReadNextBlockHeader;
|
|
var
|
|
L : longint;
|
|
begin
|
|
if FaBlock^.nextBlock = 0 then exit; //last block
|
|
//Increment Blockstart
|
|
FaBlockStart := FaBlockStart+(FaBlock^.addDataSize div FHeader^.recordSize)+1;
|
|
FaRecord := FaBlockStart+1;
|
|
L := FaBlock^.nextBlock-1;
|
|
L := (L * FHeader^.maxTableSize * $0400) + FHeader^.headerSize;
|
|
FaBlockIdx := FaBlock^.nextBlock;
|
|
FBlockReaded := False;
|
|
FStream.Position := L;
|
|
FStream.Read(FaBlock^,6); //read only Block header
|
|
end;
|
|
|
|
procedure TParadoxDataset.ReadPrevBlockHeader;
|
|
var
|
|
L: LongWord;
|
|
begin
|
|
L := FaBlock^.prevBlock-1;
|
|
L := (L * FHeader^.maxTableSize * $0400) + FHeader^.headerSize;
|
|
FaBlockIdx := FaBlock^.prevBlock;
|
|
FBlockReaded := False;
|
|
FStream.Position := L;
|
|
FStream.Read(FaBlock^,6); //read only Block header
|
|
//decrement Blockstart
|
|
L := ((FaBlock^.addDataSize div FHeader^.recordSize)+1);
|
|
FaBlockStart := FaBlockStart-L;
|
|
FaRecord := FaBlockStart+1;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
|
|
begin
|
|
// The BookMarkData is the RecNo: no need to set nothing;
|
|
{
|
|
if Data <> nil then
|
|
PRecInfo(Buffer + FHeader^.RecordSize)^.RecordNumber := PLongWord(Data)^
|
|
else
|
|
PRecInfo(Buffer + FHeader^.RecordSize)^.RecordNumber := 0;
|
|
}
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
|
|
begin
|
|
PRecInfo(Buffer + FHeader^.RecordSize)^.BookmarkFlag := Value;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetFieldData(Field: TField; Buffer: Pointer);
|
|
begin
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetFileName(const AValue: TFileName);
|
|
begin
|
|
if Active then
|
|
Close;
|
|
FFilename := AValue;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetFiltered(Value: Boolean);
|
|
begin
|
|
if (Value <> Filtered) then begin
|
|
inherited;
|
|
if IsCursorOpen then
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetFilterText(const Value: String);
|
|
begin
|
|
if (Value <> Filter) then begin
|
|
ParseFilter(Value);
|
|
inherited;
|
|
if IsCursorOpen and Filtered then
|
|
Refresh;
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetRecNo(Value: Integer);
|
|
begin
|
|
if Value < FaRecord then
|
|
begin
|
|
while (Value <= FaBlockstart) do
|
|
ReadPrevBlockHeader;
|
|
FaRecord := Value;
|
|
end else
|
|
begin
|
|
while (Value > FaBlockstart+((FaBlock^.addDataSize div FHeader^.recordSize)+1)) do
|
|
ReadNextBlockHeader;
|
|
FaRecord := Value;
|
|
end;
|
|
end;
|
|
|
|
procedure TParadoxDataset.SetTargetEncoding(AValue: String);
|
|
begin
|
|
if AValue = FTargetEncoding then exit;
|
|
FTargetEncoding := Uppercase(AValue);
|
|
end;
|
|
|
|
|
|
end.
|
|
|