From abc1c6203fdbb9277407042b7c2d63124cadf217 Mon Sep 17 00:00:00 2001 From: christian_u Date: Tue, 20 Feb 2007 18:20:07 +0000 Subject: [PATCH] git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@69 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- components/tparadoxdataset/lazparadox.lpk | 54 ++ components/tparadoxdataset/paradox.pas | 666 ++++++++++++++++++++++ components/tparadoxdataset/paradoxreg.pas | 43 ++ components/tparadoxdataset/readme.txt | 16 + 4 files changed, 779 insertions(+) create mode 100644 components/tparadoxdataset/lazparadox.lpk create mode 100644 components/tparadoxdataset/paradox.pas create mode 100644 components/tparadoxdataset/paradoxreg.pas create mode 100644 components/tparadoxdataset/readme.txt diff --git a/components/tparadoxdataset/lazparadox.lpk b/components/tparadoxdataset/lazparadox.lpk new file mode 100644 index 000000000..a003fa485 --- /dev/null +++ b/components/tparadoxdataset/lazparadox.lpk @@ -0,0 +1,54 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/tparadoxdataset/paradox.pas b/components/tparadoxdataset/paradox.pas new file mode 100644 index 000000000..c6c04f94a --- /dev/null +++ b/components/tparadoxdataset/paradox.pas @@ -0,0 +1,666 @@ +unit paradox; + +{ TParadoxdataSet + Christian Ulrich christian@ullihome.de + License: LGPL +} + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, db, Forms, Objects, LclProc; + + +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 : pointer; + unknownPtr1A : 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 : ^pchar; + fldInfoPtr : PFldInfoRec; + writeProtected : byte; + fileVersionID : byte; + maxBlocks : word; + unknown3C : byte; + auxPasswords : byte; + unknown3Ex3F : array[$003E..$003F] of byte; + cryptInfoStartPtr : pointer; + cryptInfoEndPtr : 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; + +{ APdoxBlk = packed record + Next, + Prev, + Last: Word; + end;} + + {10-byte Blob Info Block} + APdoxBlob = packed record + Offset, + Length: LongWord; + ModNum: Word; + end; + + { TParadoxDataSet } + + TParadoxDataSet = class(TDataSet) + private + FActive : Boolean; + FStream : TFileStream; + FFileName: TFileName; + FHeader : PPxHeader; + FaRecord : Longword; + FaBlockstart : LongInt; + FaBlock : PDataBlock; + FaBlockIdx : word; + FBlockReaded : Boolean; + FBookmarkOfs :LongWord; + + procedure SetFileName(const AValue: TFileName); + function GetEncrypted: Boolean; + procedure ReadBlock; + procedure ReadNextBlockHeader; + procedure ReadPrevBlockHeader; + function GetVersion: real; + protected + procedure InternalOpen; override; + procedure InternalClose; override; + procedure InternalInitFieldDefs; override; + function AllocRecordBuffer: PChar; override; + procedure FreeRecordBuffer(var Buffer: PChar); override; + function GetRecordCount: Integer; override; + function IsCursorOpen: Boolean; override; + procedure InternalFirst; override; + procedure InternalHandleException; override; + procedure InternalInitRecord(Buffer: PChar); override; + procedure InternalLast; override; + procedure InternalPost; override; + procedure InternalEdit; override; + procedure InternalSetToRecord(Buffer: PChar); override; + procedure InternalGotoBookmark(ABookmark: Pointer); override; + procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; + procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; + function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; + procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; + function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; + function GetRecordSize: Word; override; + procedure SetFieldData(Field: TField; Buffer: Pointer); override; + function GetCanModify: Boolean;override; + procedure SetRecNo(Value: Integer); override; + function GetRecNo: Integer; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + property Encrypted : Boolean read GetEncrypted; + function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; + published + property TableName : TFileName read FFileName write SetFileName; + property TableLevel : real read GetVersion; + property FieldDefs; + property Active; + property AutoCalcFields; + 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 } + +procedure TParadoxDataSet.SetFileName(const AValue: TFileName); +begin + if Active then + Close; + FFilename := AValue; +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; + +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; + +function TParadoxDataSet.GetVersion: real; +begin + Result := 0; + 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.InternalOpen; +begin + FStream := TFileStream.Create(FFilename,fmOpenRead or fmShareDenyNone); + FHeader := AllocMem($800); + FStream.Position := 0; + if not FStream.Read(FHeader^, $800) = sizeof(FHeader^) then + DatabaseError('No valid Paradox file !'); + if not ((FHeader^.maxTableSize >= 1) and (FHeader^.maxTableSize <= 4)) then + DatabaseError('No valid Paradox file !'); + if (FHeader^.fileVersionID <= 4) or not (FHeader^.fileType in [0,2,3,5]) then + FHeader^.fldInfoPtr := addr(FHeader^.fieldInfo35) + else + FHeader^.fldInfoPtr := addr(FHeader^.fieldInfo); + if Encrypted then exit; + FaBlock := AllocMem(FHeader^.maxTableSize * $0400); + BookmarkSize := SizeOf(longword); + InternalFirst; + InternalInitFieldDefs; + if DefaultFields then CreateFields; + BindFields(True); + FActive := True; +end; + +procedure TParadoxDataSet.InternalClose; +begin + BindFields(FALSE); + if DefaultFields then // Destroy the TField + DestroyFields; + Freemem(FHeader); + Freemem(FaBlock); + FHeader := nil; + FActive := False; +end; + +procedure TParadoxDataSet.InternalInitFieldDefs; +var + i : integer; + F : PFldInfoRec; + FNamesStart : PChar; +begin + FieldDefs.Clear; + F := FHeader^.fldInfoPtr; { begin with the first field identifier } + FNamesStart := Pointer(F); + //anyone an better solution for this ? + inc(ptrrec(FNamesStart).ofs, sizeof(F^)*(FHeader^.numFields));//Jump over Fielddefs + inc(ptrrec(FNamesStart).ofs, sizeof(Pointer)); //over Tablenameptr + inc(ptrrec(FNamesStart).ofs, sizeof(PChar)*(FHeader^.numFields));//over Fieldnamepointers + inc(ptrrec(FNamesStart).ofs, Strlen(FnamesStart)+1); //over Tablename + while FnamesStart^ = char(0) do + inc(ptrrec(FNamesStart).ofs); //over Padding + For i := 1 to FHeader^.numFields do + begin + case F^.fType of + pxfAlpha: Fielddefs.Add(StrPas(FNamesStart),ftString,F^.fSize); + pxfDate: Fielddefs.Add(StrPas(FNamesStart),ftDate,F^.fSize); + pxfShort: Fielddefs.Add(StrPas(FNamesStart),ftSmallInt,F^.fSize); + pxfLong: Fielddefs.Add(StrPas(FNamesStart),ftInteger,F^.fSize); + pxfCurrency: Fielddefs.Add(StrPas(FNamesStart),ftFloat,F^.fSize); + pxfNumber: Fielddefs.Add(StrPas(FNamesStart),ftFloat,F^.fSize); + pxfLogical: Fielddefs.Add(StrPas(FNamesStart),ftBoolean,F^.fSize); + pxfMemoBLOb: Fielddefs.Add(StrPas(FNamesStart),ftMemo,F^.fSize); + pxfBLOb: Fielddefs.Add(StrPas(FNamesStart),ftBlob,F^.fSize); + pxfFmtMemoBLOb:Fielddefs.Add(StrPas(FNamesStart),ftMemo,F^.fSize); + pxfOLE: Fielddefs.Add(StrPas(FNamesStart),ftBlob,F^.fSize); + pxfGraphic: Fielddefs.Add(StrPas(FNamesStart),ftBlob,F^.fSize); + pxfTime: Fielddefs.Add(StrPas(FNamesStart),ftTime,F^.fSize); + pxfTimestamp:Fielddefs.Add(StrPas(FNamesStart),ftdateTime,F^.fSize); + pxfAutoInc: Fielddefs.Add(StrPas(FNamesStart),ftAutoInc,F^.fSize); + pxfBCD: Fielddefs.Add(StrPas(FNamesStart),ftBCD,F^.fSize); + pxfBytes: Fielddefs.Add(StrPas(FNamesStart),ftString,F^.fSize); + end; + inc(ptrrec(FNamesStart).ofs, Strlen(FnamesStart)+1); + inc(ptrrec(F).ofs, sizeof(F^)); + end; +end; + +function TParadoxDataSet.AllocRecordBuffer: PChar; +begin + if Assigned(Fheader) then + Result := AllocMem(GetRecordSize) + else + Result := nil; +end; + +procedure TParadoxDataSet.FreeRecordBuffer(var Buffer: PChar); +begin + if Assigned(Buffer) then + FreeMem(Buffer); +end; + +function TParadoxDataSet.GetRecordCount: Integer; +begin + if not Assigned(Fheader) then exit; + Result := FHeader^.numRecords; +end; + +function TParadoxDataSet.IsCursorOpen: Boolean; +begin + Result := FActive; +end; + +procedure TParadoxDataSet.InternalFirst; +begin + FaBlockIdx := FHeader^.firstBlock; + FaBlockstart := 0; + FaRecord := 0; + ReadBlock; +end; + +procedure TParadoxDataSet.InternalHandleException; +begin + Application.HandleException(Self); +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.InternalPost; +begin +end; + +procedure TParadoxDataSet.InternalEdit; +begin +end; + +procedure TParadoxDataSet.InternalSetToRecord(Buffer: PChar); +begin + if (State <> dsInsert) then + InternalGotoBookmark(@PRecInfo(Buffer + FHeader^.recordSize)^.RecordNumber); +end; + +procedure TParadoxDataSet.InternalGotoBookmark(ABookmark: Pointer); +begin + SetrecNo(PLongWord(ABookmark)^); +end; + +procedure TParadoxDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer); +begin + //TODO +end; + +function TParadoxDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; +begin + Result := PRecInfo(Buffer + FHeader^.recordSize)^.BookmarkFlag; +end; + +function TParadoxDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; +var + OK : Boolean; + L: Longword; +begin + Result := grOK; + case GetMode of + gmNext: + begin + inc(FaRecord); + if (FaBlockIdx = FHeader^.lastBlock) and (FaRecord > FaBlockStart+(FaBlock^.addDataSize div FHeader^.recordSize)+1) then + Result := grEOF + else + begin + if FaRecord > FaBlockStart+1+(FaBlock^.addDataSize div FHeader^.recordSize) then + ReadNextBlockHeader; + end; + end; + gmPrior: + begin + dec(FaRecord); + if (FaBlockIdx = FHeader^.firstBlock) and (FaRecord < 1) then + Result := grBOF + else + begin + if FaRecord <= FaBlockStart then + begin + ReadPrevBlockHeader; + FaRecord := FaBlockStart+(FaBlock^.addDataSize div FHeader^.recordSize)+1; + end; + end; + end; + gmCurrent: + begin + if (FaRecord > RecordCount) or (FaRecord < 1) then + result := grError; + end; + end; + if Result = grOK then + begin + if not FBlockreaded then + ReadBlock; + L := ((faRecord-(FaBlockstart+1))*FHeader^.recordSize)+6; + if (faRecord-(FaBlockstart+1)) >= 0 then + begin + Move(PChar(FaBlock)[L],Buffer[0],FHeader^.recordSize); + end + else + result := grError; + with PRecInfo(Buffer + FHeader^.recordSize)^ do + begin + BookmarkFlag := bfCurrent; + RecordNumber := FaRecord; + end; + end; +end; + +function TParadoxDataSet.GetRecordSize: Word; +begin + Result := FHeader^.recordSize + sizeof(TRecInfo); +end; + +procedure TParadoxDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); +begin + PRecInfo(Buffer + FHeader^.recordSize)^.BookmarkFlag := Value; +end; + +procedure TParadoxDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer); +begin + //TODO +end; + +procedure TParadoxDataSet.SetFieldData(Field: TField; Buffer: Pointer); +begin +end; + +function TParadoxDataSet.GetCanModify: Boolean; +begin + Result:=False; +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; + +function TParadoxDataSet.GetRecNo: Integer; +begin + Result := -1; + if Assigned(ActiveBuffer) then + Result := PRecInfo(ActiveBuffer + FHeader^.recordSize)^.RecordNumber; +end; + +function TParadoxDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; +type + TNRec= array[0..16] of byte; +var + b : Boolean; + 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; +begin + Result := False; + F := FHeader^.fldInfoPtr; { begin with the first field identifier } + p := ActiveBuffer; + For i := 1 to FHeader^.numFields do + begin + if i = Field.FieldNo then + break; + If F^.fType = pxfBCD then { BCD field size value not used for field size } + Inc(ptrrec(p).ofs, 17) + else + Inc(ptrrec(p).ofs, F^.fSize); + Inc(ptrrec(F).ofs, sizeof(F^)); + end; + If F^.fType = pxfBCD then { BCD field size value not used for field size } + size := 17 + else + size := F^.fSize; + if F^.fType in [pxfDate..pxfNumber, pxfTime..pxfAutoInc] then + begin + for i := 0 to pred(size) do + begin + s[pred(size-i)] := byte(p[i]); + end; + s[pred(size)] := s[pred(size)] xor $80; + end; + + case F^.fType of + pxfAlpha,pxfMemoBLOb,pxfFmtMemoBLOb: + begin + if (Buffer <> nil) then + StrLCopy(Buffer, p, Field.Size) + else + exit; + Result := True; + end; + pxfDate: + begin + i := int-693594; + Move(i,Buffer^,sizeof(Integer)); +// Result := True; + end; + pxfShort: + begin + i := si; + Move(i,Buffer^,sizeof(Integer)); + Result := True; + end; + pxfLong,pxfAutoInc: + begin + i := int; + Move(i,Buffer^,sizeof(Integer)); + Result := True; + end; + pxfCurrency,pxfNumber: + begin + Move(d,Buffer^,sizeof(d)); + Result := True; + end; + + pxfLogical: + begin +// b := (p^ = #80); +// Move(b,Buffer^,sizeof(Boolean)); +// Result := True; + end; + pxfTime: + begin + i := int-693594; + Move(i,Buffer^,sizeof(Integer)); +// Result := True; + end; + pxfTimestamp: + begin + end; + end; +end; + +constructor TParadoxDataSet.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FHeader := nil; +end; + +destructor TParadoxDataSet.Destroy; +begin + inherited Destroy; +end; + +end. + diff --git a/components/tparadoxdataset/paradoxreg.pas b/components/tparadoxdataset/paradoxreg.pas new file mode 100644 index 000000000..54195c3d6 --- /dev/null +++ b/components/tparadoxdataset/paradoxreg.pas @@ -0,0 +1,43 @@ +unit paradoxreg; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LResources, Paradox, LazarusPackageIntf, PropEdits; + +resourcestring + dbfsAllparadoxfiles = 'Paradox Files'; + +procedure Register; + +implementation + +type + + TParadoxFileNamePropertyEditor=class(TFileNamePropertyEditor) + protected + function GetFilter: String; override; + end; + +function TParadoxFileNamePropertyEditor.GetFilter: String; +begin + Result := dbfsAllParadoxFiles+' (*.db)|*.db;*.DB'; + Result:= Result+ '|'+ inherited GetFilter; +end; + +procedure RegisterUnitParadox; +begin + RegisterComponents('Data Access',[TParadoxDataSet]); + RegisterPropertyEditor(TypeInfo(AnsiString), TParadoxDataSet, 'TableName', TParadoxFileNamePropertyEditor); +end; + +procedure Register; +begin + RegisterUnit('paradox',@RegisterUnitParadox); +end; + +initialization + +end. diff --git a/components/tparadoxdataset/readme.txt b/components/tparadoxdataset/readme.txt new file mode 100644 index 000000000..501019274 --- /dev/null +++ b/components/tparadoxdataset/readme.txt @@ -0,0 +1,16 @@ +TParadox for Lazarus +current package can be found at : http://www.ullihome.de + +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ + +Alternatively, you may redistribute this library, use and/or modify it under the terms of the +GNU Lesser General Public License as published by the Free Software Foundation; +either version 2.1 of the License, or (at your option) any later version. +You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/. + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the +specific language governing rights and limitations under the License. +