--- Merging r24124 into '.':

U    packages/fcl-db/tests/dbftoolsunit.pas
U    packages/fcl-db/tests/testspecifictdbf.pas
--- Merging r24125 into '.':
G    packages/fcl-db/tests/testspecifictdbf.pas
G    packages/fcl-db/tests/dbftoolsunit.pas
--- Merging r24126 into '.':
G    packages/fcl-db/tests/dbftoolsunit.pas
--- Merging r24130 into '.':
U    packages/fcl-db/src/base/fields.inc
--- Merging r24136 into '.':
U    packages/fcl-db/src/dbase/dbf_struct.inc
U    packages/fcl-db/src/dbase/dbf.pas
U    packages/fcl-db/src/dbase/dbf_dbffile.pas
--- Merging r24139 into '.':
U    packages/fcl-db/src/dbase/dbf_str.pas
G    packages/fcl-db/src/dbase/dbf_struct.inc
U    packages/fcl-db/src/dbase/dbf_str_pt.pas
U    packages/fcl-db/src/dbase/dbf_str_ru.pas
U    packages/fcl-db/src/dbase/dbf_str.inc
U    packages/fcl-db/src/dbase/dbf_str_es.pas
U    packages/fcl-db/src/dbase/readme.txt
U    packages/fcl-db/src/dbase/dbf_lang.pas
U    packages/fcl-db/src/dbase/history.txt
G    packages/fcl-db/src/dbase/dbf_dbffile.pas
U    packages/fcl-db/src/dbase/dbf_str_fr.pas
U    packages/fcl-db/src/dbase/dbf_str_nl.pas
U    packages/fcl-db/src/dbase/dbf_str_pl.pas
U    packages/fcl-db/src/dbase/dbf_str_ita.pas
--- Merging r24141 into '.':
G    packages/fcl-db/src/dbase/history.txt
G    packages/fcl-db/tests/dbftoolsunit.pas
U    packages/fcl-db/tests/toolsunit.pas
--- Merging r24150 into '.':
G    packages/fcl-db/src/dbase/dbf_dbffile.pas
G    packages/fcl-db/src/dbase/dbf_struct.inc
--- Merging r24153 into '.':
U    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r24154 into '.':
G    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r24155 into '.':
U    packages/fcl-db/src/dbase/dbf_idxfile.pas
--- Merging r24156 into '.':
U    packages/fcl-db/src/dbase/dbf_fields.pas
G    packages/fcl-db/src/dbase/dbf.pas
--- Merging r24157 into '.':
G    packages/fcl-db/src/dbase/dbf_dbffile.pas
--- Merging r24158 into '.':
G    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r24159 into '.':
G    packages/fcl-db/src/dbase/dbf_fields.pas
G    packages/fcl-db/src/dbase/dbf_dbffile.pas
U    packages/fcl-db/src/dbase/dbf_memo.pas
G    packages/fcl-db/src/dbase/dbf_struct.inc
--- Merging r24160 into '.':
G    packages/fcl-db/tests/testspecifictdbf.pas
G    packages/fcl-db/src/dbase/dbf_fields.pas
--- Merging r24169 into '.':
G    packages/fcl-db/src/dbase/dbf_memo.pas
G    packages/fcl-db/src/dbase/dbf.pas
G    packages/fcl-db/src/dbase/dbf_dbffile.pas
G    packages/fcl-db/src/dbase/dbf_fields.pas
G    packages/fcl-db/src/dbase/readme.txt
U    packages/fcl-db/src/dbase/dbf_common.pas
G    packages/fcl-db/tests/dbftoolsunit.pas
U    packages/fcl-db/tests/database.ini.txt

# revisions: 24124,24125,24126,24130,24136,24139,24141,24150,24153,24154,24155,24156,24157,24158,24159,24160,24169
r24124 | reiniero | 2013-04-02 10:59:02 +0200 (Tue, 02 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/tests/dbftoolsunit.pas
   M /trunk/packages/fcl-db/tests/testspecifictdbf.pas

* fcl-db/tests: add dbf tablelevel test, option to retain dbfs after tests
r24125 | reiniero | 2013-04-02 12:34:27 +0200 (Tue, 02 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/tests/dbftoolsunit.pas
   M /trunk/packages/fcl-db/tests/testspecifictdbf.pas

* fcl-db/tests: test memorybacked dbf equals filebased dbf. Use memory dbfs because of speed.
r24126 | reiniero | 2013-04-02 12:35:23 +0200 (Tue, 02 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/tests/dbftoolsunit.pas

* fcl-db/tests: disable storing dbfs by default.
r24130 | lacak | 2013-04-02 13:40:43 +0200 (Tue, 02 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/base/fields.inc

fcl-db: fields: use new implemented FormatBCD function to format TFMTBCDField. Depends on rev.24128! Bug #24096
r24136 | reiniero | 2013-04-03 08:01:25 +0200 (Wed, 03 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_struct.inc

* fcl-db/dbase: cosmetic: use more constants, clarify structure
r24139 | reiniero | 2013-04-03 17:49:20 +0200 (Wed, 03 Apr 2013) | 9 lines
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_lang.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str.inc
   M /trunk/packages/fcl-db/src/dbase/dbf_str.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_es.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_fr.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_ita.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_nl.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_pl.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_pt.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_str_ru.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_struct.inc
   M /trunk/packages/fcl-db/src/dbase/history.txt
   M /trunk/packages/fcl-db/src/dbase/readme.txt

+ fcl-db/dbase: (Visual) FoxPro fixes:
+ initial read support for Visual FoxPro
* annotated file structures, constants etc
* better error reporting:
  different message for valid header but 
	invalid field definitions
* refactored some procedures for readability
r24141 | reiniero | 2013-04-03 18:26:25 +0200 (Wed, 03 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/history.txt
   M /trunk/packages/fcl-db/tests/dbftoolsunit.pas
   M /trunk/packages/fcl-db/tests/toolsunit.pas

* fcl-db/dbase: fix trace datasets for tests
r24150 | reiniero | 2013-04-04 15:16:41 +0200 (Thu, 04 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_struct.inc

* fcl-db/dbase: cosmetic: more file structure annotations, clarify comments
r24153 | michael | 2013-04-05 09:10:51 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Option to create less verbose error messages
r24154 | michael | 2013-04-05 11:05:23 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Default of verboseerrors set to true
r24155 | ludob | 2013-04-05 11:48:34 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_idxfile.pas

TDBF: fixed some unaligned memory accesses causing SIGBUS on ARM
r24156 | reiniero | 2013-04-05 11:59:27 +0200 (Fri, 05 Apr 2013) | 5 lines
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_fields.pas

fcl-db/dbase:
* attempt fix for mantis #10174: don't pass DBase size for ftBCD fields
  when creating FPC fields. to do: verify if we need to do this for other
	field types (ftWideString?)
* cosmetic clarifications
r24157 | ludob | 2013-04-05 12:46:43 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas

TDBF: fixed some unaligned memory accesses in dbf_dbfile.pas causing SIGBUS on ARM
r24158 | lacak | 2013-04-05 13:14:42 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

fcl-db: postgresql: centralize checking of connection status (repeated code) into separate method + formatting
r24159 | reiniero | 2013-04-05 15:21:54 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_fields.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_memo.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_struct.inc

* fcl-base/dbase: memo definitions clarified
r24160 | reiniero | 2013-04-05 16:49:50 +0200 (Fri, 05 Apr 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf_fields.pas
   M /trunk/packages/fcl-db/tests/testspecifictdbf.pas

* fcl-db/dbase: add memo, large string test cases
r24169 | reiniero | 2013-04-07 09:05:30 +0200 (Sun, 07 Apr 2013) | 7 lines
Changed paths:
   M /trunk/packages/fcl-db/src/dbase/dbf.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_common.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_dbffile.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_fields.pas
   M /trunk/packages/fcl-db/src/dbase/dbf_memo.pas
   M /trunk/packages/fcl-db/src/dbase/readme.txt
   M /trunk/packages/fcl-db/tests/database.ini.txt
   M /trunk/packages/fcl-db/tests/dbftoolsunit.pas

fcl-base/dbase:
* Version: 6.9.2=>7.0.0 because of FoxPro/Visual Foxpro support (needs more testing though)
* Visibility of FindNext etc matches ancestor now
* Fix for BCD field size; fix for missing FPC .SetAsBCD in tests (thanks, Ludo!)
* Fix for Foxpro 'B' double field: size & incorrectly treated as blob fields
* Link to more specs; clarification of FoxPro memo structure
* Added descriptive names for dbase tests in database template

git-svn-id: branches/fixes_2_6@24937 -

packages/fcl-db/src/base/fields.inc

@@ -2622,8 +2622,7 @@ begin
     else
       fmt := FEditFormat;
     if fmt<>'' then
-      TheText := BCDToStr(bcd)
-      //TheText := FormatBCD(fmt,bcd) //uncomment when formatBCD in fmtbcd.pp will be implemented
+      TheText := FormatBCD(fmt,bcd)
     else if fCurrency then begin
       if aDisplayText then
         TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2)

packages/fcl-db/src/dbase/dbf.pas

@@ -261,10 +261,6 @@ type
       {$ifdef SUPPORT_OVERLOAD} overload; {$endif} override; {virtual abstract}
 
     { virtual methods (mostly optional) }
-    function  FindFirst: Boolean; override;
-    function  FindLast: Boolean; override;
-    function  FindNext: Boolean; override;
-    function  FindPrior: Boolean; override;
     function  GetDataSource: TDataSource; {$ifndef VER1_0}override;{$endif}
     function  GetRecordCount: Integer; override; {virtual}
     function  GetRecNo: Integer; override; {virtual}
@@ -294,7 +290,7 @@ type
     { abstract methods }
     function GetFieldData(Field: TField; Buffer: Pointer): Boolean;
       {$ifdef SUPPORT_OVERLOAD} overload; {$endif} override; {virtual abstract}
-    { virtual methods (mostly optionnal) }
+    { virtual methods (mostly optional) }
     procedure Resync(Mode: TResyncMode); override;
     function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
 {$ifdef SUPPORT_NEW_TRANSLATE}
@@ -313,6 +309,11 @@ type
     function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
     procedure CheckDbfFieldDefs(ADbfFieldDefs: TDbfFieldDefs);
 
+    function  FindFirst: Boolean; override;
+    function  FindLast: Boolean; override;
+    function  FindNext: Boolean; override;
+    function  FindPrior: Boolean; override;
+
 {$ifdef VER1_0}
     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
 {$endif}
@@ -1064,17 +1065,22 @@ begin
       Inc(N);
       TempFieldDef.FieldName:=BaseName+IntToStr(N);
     end;
-    // add field
-    if TempFieldDef.FieldType in [ftString, ftBCD, ftBytes] then
-      FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, TempFieldDef.Size, false)
+    // add field, passing dbase native size if relevant
+    // TDbfFieldDef.Size indicates the number of bytes in the physical dbase file
+    // TFieldDef.Size is only meant to store size indicator for variable length fields
+    case TempFieldDef.FieldType of
+      ftString, ftBytes: FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, TempFieldDef.Size, false);
+      ftBCD:
+        begin
+          // todo: we should calculate number of digits after decimal place in some way, but how?
+          FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, 0, false);;;
+        end;
     else
       FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, 0, false);
+    end;
+
+    FieldDefs[I].Precision := TempFieldDef.Precision;
 
-    if TempFieldDef.FieldType = ftFloat then
-      begin
-      FieldDefs[I].Size := 0; // Size is not defined for float fields
-      FieldDefs[I].Precision := TempFieldDef.Size;
-      end;
 
 {$ifdef SUPPORT_FIELDDEF_ATTRIBUTES}
     // AutoInc fields are readonly
@@ -1257,7 +1263,7 @@ begin
 
   BindFields(true);
 
-  // create array of blobstreams to store memo's in. each field is a possible blob
+  // create array of blobstreams to store memos in. each field is a possible blob
   FBlobStreams := AllocMem(FieldDefs.Count * SizeOf(TDbfBlobStream));
 
   // check codepage settings
@@ -1631,6 +1637,8 @@ begin
           FieldName := lSrcField.FieldName;
         FieldType := lSrcField.DataType;
         Required := lSrcField.Required;
+
+        // Set up size/precision for all physical fields:
         if (1 <= lSrcField.FieldNo) 
             and (lSrcField.FieldNo <= lPhysFieldDefs.Count) then
         begin

packages/fcl-db/src/dbase/dbf_common.pas

@@ -16,9 +16,9 @@ uses
 
 
 const
-  TDBF_MAJOR_VERSION      = 6;
-  TDBF_MINOR_VERSION      = 9;
-  TDBF_SUB_MINOR_VERSION  = 2;
+  TDBF_MAJOR_VERSION      = 7;
+  TDBF_MINOR_VERSION      = 0;
+  TDBF_SUB_MINOR_VERSION  = 0;
 
   TDBF_TABLELEVEL_FOXPRO = 25;
   TDBF_TABLELEVEL_VISUALFOXPRO = 30; {Source: http://www.codebase.com/support/kb/?article=C01059}
@@ -87,15 +87,22 @@ procedure FindNextName(BaseName: string; var OutName: string; var Modifier: Inte
 function GetFreeMemory: Integer;
 {$endif}
 
+// Convert word to big endian
 function SwapWordBE(const Value: word): word;
+// Convert word to little endian
 function SwapWordLE(const Value: word): word;
+// Convert integer to big endian
 function SwapIntBE(const Value: dword): dword;
+// Convert integer to little endian
 function SwapIntLE(const Value: dword): dword;
 {$ifdef SUPPORT_INT64}
+// Convert int64 to big endian
 procedure SwapInt64BE(Value, Result: Pointer); register;
+// Convert int64 to little endian
 procedure SwapInt64LE(Value, Result: Pointer); register;
 {$endif}
 
+// Translate string between codepages
 function TranslateString(FromCP, ToCP: Cardinal; Src, Dest: PChar; Length: Integer): Integer;
 
 // Returns a pointer to the first occurence of Chr in Str within the first Length characters

packages/fcl-db/src/dbase/dbf_dbffile.pas

@@ -203,6 +203,7 @@ uses
 
 const
   sDBF_DEC_SEP = '.';
+  FIELD_DESCRIPTOR_ARRAY_TERMINATOR = $0D; // Marker at end of list of fields within header
 
 {$I dbf_struct.inc}
 
@@ -327,88 +328,59 @@ var
   I: Integer;
   deleteLink: Boolean;
   lModified: boolean;
-  LangStr: PChar;
-  version: byte;
-begin
-  // check if not already opened
-  if not Active then
-  begin
-    // open requested file
-    OpenFile;
 
-    // check if we opened an already existing file
-    lModified := false;
-    if not FileCreated then
-    begin
-      HeaderSize := sizeof(rDbfHdr); // temporary
-      // OH 2000-11-15 dBase7 support. I build dBase Tables with different
-      // BDE dBase Level (1. without Memo, 2. with Memo)
-      //                          Header Byte ($1d hex) (29 dec) -> Language driver ID.
-      //  $03,$83 xBaseIII        Header Byte $1d=$00, Float -> N($13.$04) DateTime C($1E)
-      //  $03,$8B xBaseIV/V       Header Byte $1d=$58, Float -> N($14.$04)
-      //  $04,$8C xBaseVII        Header Byte $1d=$00  Float -> O($08)     DateTime @($08)
-      //  $03,$F5 FoxPro Level 25 Header Byte $1d=$03, Float -> N($14.$04)
-      // Access 97
-      //  $03,$83 dBaseIII        Header Byte $1d=$00, Float -> N($13.$05) DateTime D($08)
-      //  $03,$8B dBaseIV/V       Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
-      //  $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
-
-      version := PDbfHdr(Header)^.VerDBF;
-      FDbfVersion := xUnknown;
-      // Some hardcode versions for Visual FoxPro; see MS documentation
-      // (including the correction at the bottom):
-      // http://msdn.microsoft.com/en-US/library/st4a0s68%28v=vs.80%29.aspx
-      case version of
-        $30, $31, $32: FDbfVersion:=xVisualFoxPro;
-        $F5: FDbfVersion:=xFoxPro;
-      end;
-      if FDbfVersion = xUnknown then
-      begin
-        case (version and $07) of
-          $03:
-            if LanguageID = 0 then
-              FDbfVersion := xBaseIII
-            else
-              FDbfVersion := xBaseIV;
-          $04:
-            FDbfVersion := xBaseVII;
-          $02, $05:
-            FDbfVersion := xFoxPro;
-        else
-          // todo: check visual foxpro, modify
-          if ((version and $FE) = $30) or (version = $F5) or (version = $FB) then
-          begin
-            FDbfVersion := xFoxPro;
-          end else begin
-            // not a valid DBF file
-            raise EDbfError.Create(STRING_INVALID_DBF_FILE);
-          end;
+  procedure GetVersion;
+  var
+    version: byte;
+  begin
+    // OH 2000-11-15 dBase7 support. I build dBase Tables with different
+    // BDE dBase Level (1. without Memo, 2. with Memo)
+    //                          Header Byte ($1d hex) (29 dec) -> Language driver ID.
+    //  $03,$83 xBaseIII        Header Byte $1d=$00, Float -> N($13.$04) DateTime C($1E)
+    //  $03,$8B xBaseIV/V       Header Byte $1d=$58, Float -> N($14.$04)
+    //  $04,$8C xBaseVII        Header Byte $1d=$00  Float -> O($08)     DateTime @($08)
+    //  $03,$F5 FoxPro Level 25 Header Byte $1d=$03, Float -> N($14.$04)
+    // Access 97
+    //  $03,$83 dBaseIII        Header Byte $1d=$00, Float -> N($13.$05) DateTime D($08)
+    //  $03,$8B dBaseIV/V       Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
+    //  $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
+
+    version := PDbfHdr(Header)^.VerDBF;
+    FDbfVersion := xUnknown;
+    // Some hardcode versions for Visual FoxPro; see MS documentation
+    // (including the correction at the bottom):
+    // http://msdn.microsoft.com/en-US/library/st4a0s68%28v=vs.80%29.aspx
+    case version of
+      $30, $31, $32: FDbfVersion:=xVisualFoxPro;
+      $F5, $FB: FDbfVersion:=xFoxPro;
+    end;
+    if FDbfVersion = xUnknown then
+      case (version and $07) of
+        $03:
+          if LanguageID = 0 then
+            FDbfVersion := xBaseIII
+          else
+            FDbfVersion := xBaseIV;
+        $04:
+          FDbfVersion := xBaseVII;
+        $02, $05:
+          FDbfVersion := xFoxPro;
+      else
+        begin
+          // not a valid DBF file
+          raise EDbfError.Create(STRING_INVALID_DBF_FILE);
         end;
       end;
-      FFieldDefs.DbfVersion := FDbfVersion;
-      RecordSize := PDbfHdr(Header)^.RecordSize;
-      HeaderSize := PDbfHdr(Header)^.FullHdrSize;
-      if (HeaderSize = 0) or (RecordSize = 0) then
-      begin
-        HeaderSize := 0;
-        RecordSize := 0;
-        RecordCount := 0;
-        FForceClose := true;
-        exit;
-      end;
-      // check if specified recordcount correct
-      if PDbfHdr(Header)^.RecordCount <> RecordCount then
-      begin
-        // This message was annoying
-        // and was not understood by most people
-        // ShowMessage('Invalid Record Count,'+^M+
-        //             'RecordCount in Hdr : '+IntToStr(PDbfHdr(Header).RecordCount)+^M+
-        //             'expected : '+IntToStr(RecordCount));
-        PDbfHdr(Header)^.RecordCount := RecordCount;
-        lModified := true;
-      end;
-      // determine codepage
-      if FDbfVersion >= xBaseVII then
+    FFieldDefs.DbfVersion := FDbfVersion;
+  end;
+
+  procedure GetCodePage;
+  var
+    LangStr: PChar;
+  begin
+    // determine codepage
+    case FDbfVersion of
+      xBaseVII:
       begin
         // cache language str
         LangStr := @PAfterHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
@@ -442,15 +414,53 @@ begin
           FFileCodePage := 0;
         end;
         FFileLangId := GetLangId_From_LangName(LanguageStr);
-      end else begin
-        // FDbfVersion <= xBaseV
+      end;
+    else
+      begin
+        // DBase II..V, FoxPro, Visual FoxPro
         FFileLangId := PDbfHdr(Header)^.Language;
         FFileCodePage := LangId_To_CodePage[FFileLangId];
       end;
-      // determine used codepage, if no codepage, then use default codepage
-      FUseCodePage := FFileCodePage;
-      if FUseCodePage = 0 then
-        FUseCodePage := DbfGlobals.DefaultOpenCodePage;
+    end;
+    // determine used codepage, if no codepage, then use default codepage
+    FUseCodePage := FFileCodePage;
+    if FUseCodePage = 0 then
+      FUseCodePage := DbfGlobals.DefaultOpenCodePage;
+  end;
+
+begin
+  // check if not already opened
+  if not Active then
+  begin
+    // open requested file
+    OpenFile;
+
+    // check if we opened an already existing file
+    lModified := false;
+    if not FileCreated then
+    begin
+      HeaderSize := sizeof(rDbfHdr); // temporary, required for getting version
+      GetVersion;
+
+      RecordSize := PDbfHdr(Header)^.RecordSize;
+      HeaderSize := PDbfHdr(Header)^.FullHdrSize;
+      if (HeaderSize = 0) or (RecordSize = 0) then
+      begin
+        HeaderSize := 0;
+        RecordSize := 0;
+        RecordCount := 0;
+        FForceClose := true;
+        exit;
+      end;
+
+      // check if specified recordcount is right; correct if not
+      if PDbfHdr(Header)^.RecordCount <> RecordCount then
+      begin
+        PDbfHdr(Header)^.RecordCount := RecordCount;
+        lModified := true;
+      end;
+
+      GetCodePage;
       // get list of fields
       ConstructFieldDefs;
       // open blob file if present
@@ -460,7 +470,7 @@ begin
         // open blob file
         if not FileExists(lMemoFileName) then
           MemoFileClass := TNullMemoFile
-        else if FDbfVersion in [xFoxPro,xVisualFoxPro]  then
+        else if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
           MemoFileClass := TFoxProMemoFile
         else
           MemoFileClass := TDbaseMemoFile;
@@ -613,16 +623,18 @@ begin
         63-32);
       lFieldDescPtr := @lFieldDescVII;
     end else begin
-      // version xBaseIII/IV/V without memo
+      // DBase III..V, (Visual) FoxPro without memo
       HeaderSize := SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
       RecordSize := SizeOf(rFieldDescIII);
       FillChar(Header^, HeaderSize, #0);
+      // Note: VerDBF may be changed later on depending on what features/fields are used
+      // (autoincrement etc)
       case FDbfVersion of
         xFoxPro: PDbfHdr(Header)^.VerDBF := $02; {FoxBASE}
-        xVisualFoxPro: PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro no autoincrement,no varchar} //todo: check autoincrement, Varchar, Varbinary, or Blob-enabled
+        xVisualFoxPro: PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro no autoincrement,no varchar}
         else PDbfHdr(Header)^.VerDBF := $03; {FoxBASE+/dBASE III PLUS, no memo!?}
       end;
-      // standard language WE, dBase III no language support
+      // standard language WE/Western Europe, dBase III no language support
       if FDbfVersion = xBaseIII then
         PDbfHdr(Header)^.Language := 0
       else
@@ -630,7 +642,7 @@ begin
       // init field ptr
       lFieldDescPtr := @lFieldDescIII;
     end;
-    // begin writing fields
+    // begin writing field definitions
     FFieldDefs.Clear;
     // deleted mark 1 byte
     lFieldOffset := 1;
@@ -661,6 +673,8 @@ begin
 {$endif}
         then
       begin
+        // Up to 32kb strings
+        // Stores high byte of size in precision, low in size
         lPrec := lSize shr 8;
         lSize := lSize and $FF;
       end;
@@ -681,8 +695,9 @@ begin
         lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
         lFieldDescIII.FieldSize := lSize;
         lFieldDescIII.FieldPrecision := lPrec;
-        if FDbfVersion in [xFoxPro,xVisualFoxPro] then
+        if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
           lFieldDescIII.FieldOffset := SwapIntLE(lFieldOffset);
+        // Adjust the version info if needed for supporting field types used:
         if (PDbfHdr(Header)^.VerDBF = $02) and (lFieldDef.NativeFieldType in ['0', 'Y', 'T', 'O', '+']) then
           PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro}
         if (PDbfHdr(Header)^.VerDBF = $30) and (lFieldDef.NativeFieldType = '+') then
@@ -701,8 +716,10 @@ begin
       WriteRecord(I, lFieldDescPtr);
       Inc(lFieldOffset, lFieldDef.Size);
     end;
-    // end of header
-    WriteChar($0D);
+    // end of field descriptor; ussually end of header -
+    // Visual Foxpro backlink info is part of the header but comes after the
+    // terminator
+    WriteChar(FIELD_DESCRIPTOR_ARRAY_TERMINATOR);
 
     // write memo bit
     if lHasBlob then
@@ -725,7 +742,7 @@ begin
       an associated database (.dbc) file, information. If the first byte is 0x00, 
       the file is not associated with a database. Therefore, database files always 
       contain 0x00. }
-    if FDbfVersion = xVisualFoxPro then
+    if (FDbfVersion = xVisualFoxPro) then
       Inc(PDbfHdr(Header)^.FullHdrSize, 263);
 
     // write dbf header to disk
@@ -741,7 +758,7 @@ begin
   if HasBlob and (FMemoFile=nil) then
   begin
     lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
-    if FDbfVersion in [xFoxPro,xVisualFoxPro] then
+    if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
       FMemoFile := TFoxProMemoFile.Create(Self)
     else
       FMemoFile := TDbaseMemoFile.Create(Self);
@@ -802,6 +819,7 @@ begin
 //  lDataHdr.RecordCount := RecordCount;
   inherited WriteHeader;
 
+  // Write terminator at the end of the file, after the records:
   EofTerminator := $1A;
   WriteBlock(@EofTerminator, 1, CalcPageOffset(RecordCount+1));
 end;
@@ -824,11 +842,12 @@ var
   lCurrentNullPosition: integer;
 begin
   FFieldDefs.Clear;
-  if DbfVersion >= xBaseVII then
+  if DbfVersion = xBaseVII then
   begin
     lHeaderSize := SizeOf(rAfterHdrVII) + SizeOf(rDbfHdr);
     lFieldSize := SizeOf(rFieldDescVII);
   end else begin
+    // DBase III..V, (Visual) FoxPro
     lHeaderSize := SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
     lFieldSize := SizeOf(rFieldDescIII);
   end;
@@ -845,10 +864,10 @@ begin
   lCurrentNullPosition := 0;
   lCanHoldNull := false;
   try
-    // there has to be minimum of one field
+    // Specs say there has to be at least one field, so use repeat:
     repeat
       // version field info?
-      if FDbfVersion >= xBaseVII then
+      if FDbfVersion = xBaseVII then
       begin
         ReadRecord(I, @lFieldDescVII);
         lFieldName := AnsiUpperCase(PChar(@lFieldDescVII.FieldName[0]));
@@ -859,6 +878,7 @@ begin
         if lNativeFieldType = '+' then
           FAutoIncPresent := true;
       end else begin
+        // DBase III..V, FoxPro, Visual FoxPro
         ReadRecord(I, @lFieldDescIII);
         lFieldName := AnsiUpperCase(PChar(@lFieldDescIII.FieldName[0]));
         lSize := lFieldDescIII.FieldSize;
@@ -873,10 +893,12 @@ begin
       // apply field transformation tricks
       if (lNativeFieldType = 'C') 
 {$ifndef USE_LONG_CHAR_FIELDS}
-          and (FDbfVersion in [xFoxPro,xVisualFoxPro])
+        and (FDbfVersion in [xFoxPro,xVisualFoxPro])
 {$endif}
-                then
+        then
       begin
+        // (V)FP uses the byte where precision is normally stored
+        // for the high byte of the field size
         lSize := lSize + lPrec shl 8;
         lPrec := 0;
       end;
@@ -904,7 +926,7 @@ begin
       //  2) known field type
       //  {3) no changes have to be made to precision or size}
       if (Length(lFieldName) = 0) or (TempFieldDef.FieldType = ftUnknown) then
-        raise EDbfError.Create(STRING_INVALID_DBF_FILE);
+        raise EDbfError.Create(STRING_INVALID_DBF_FILE_FIELDERROR);
 
       // determine if lock field present, if present, then store additional info
       if lFieldName = '_DBASELOCK' then
@@ -923,7 +945,7 @@ begin
 
       // continue until header termination character found
       // or end of header reached
-    until (I > lColumnCount) or (ReadChar = $0D);
+    until (I > lColumnCount) or (ReadChar = FIELD_DESCRIPTOR_ARRAY_TERMINATOR);
 
     // test if not too many fields
     if FFieldDefs.Count >= 4096 then
@@ -983,7 +1005,7 @@ begin
         end;
       end;
       // read custom properties...not implemented
-      // read RI properties...not implemented
+      // read RI/referential integrity properties...not implemented
     end;
   finally
     HeaderSize := PDbfHdr(Header)^.FullHdrSize;
@@ -1060,7 +1082,7 @@ begin
         PChar(pNormal)^ := '*';
         WriteRecord(iNormal, pNormal);
       end else begin
-        // Cannot found a record after iDel so iDel must be deleted
+        // Cannot find a record after iDel so iDel must be deleted
         dec(iDel);
         break;
       end;
@@ -1202,7 +1224,7 @@ begin
       begin
         // get minimum field length
         lFieldSize := Min(TempSrcDef.Precision, TempDstDef.Precision) +
-          Min(TempSrcDef.Size - TempSrcDef.Precision, 
+          Min(TempSrcDef.Size - TempSrcDef.Precision,
             TempDstDef.Size - TempDstDef.Precision);
         // if one has dec separator, but other not, we lose one digit
         if (TempDstDef.Precision > 0) xor 
@@ -1211,7 +1233,7 @@ begin
         // should not happen, but check nevertheless (maybe corrupt data)
         if lFieldSize < 0 then
           lFieldSize := 0;
-        srcOffset := TempSrcDef.Size - TempSrcDef.Precision - 
+        srcOffset := TempSrcDef.Size - TempSrcDef.Precision -
           (TempDstDef.Size - TempDstDef.Precision);
         if srcOffset < 0 then
         begin
@@ -1263,7 +1285,7 @@ begin
   else
     GetMem(pDestBuff, DestDbfFile.RecordSize);
 
-  // let the games begin!
+  // Go through record data:
   try
 {$ifdef USE_CACHE}
     BufferAhead := true;
@@ -1274,7 +1296,7 @@ begin
     begin
       // read record from original dbf
       ReadRecord(lRecNo, pBuff);
-      // copy record?
+      // copy record unless (deleted or user wants packing)
       if (ansichar(pBuff^) <> '*') or not Pack then
       begin
         // if restructure, initialize dest
@@ -1439,7 +1461,7 @@ var
   var wD, wM, wY, CenturyBase: Word;
 
 {$ifndef DELPHI_5}
-  // Delphi 3 standard-behavior no change possible
+  // Delphi 3 standard behavior, no change possible
   const TwoDigitYearCenturyWindow= 0;
 {$endif}
 
@@ -1501,23 +1523,23 @@ begin
       begin
         if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
         begin
-          Result := PDWord(Src)^ <> 0;
+          Result := Unaligned(PDWord(Src)^) <> 0;
           if Result and (Dst <> nil) then
           begin
-            PDWord(Dst)^ := SwapIntBE(PDWord(Src)^);
+            PDWord(Dst)^ := SwapIntBE(Unaligned(PDWord(Src)^));
             if Result then
               PInteger(Dst)^ := Integer(PDWord(Dst)^ xor $80000000);
           end;
         end else begin
           Result := true;
           if Dst <> nil then
-            PInteger(Dst)^ := SwapIntLE(PInteger(Src)^);
+            PInteger(Dst)^ := SwapIntLE(Unaligned(PInteger(Src)^));
         end;
       end;
     'O':
       begin
 {$ifdef SUPPORT_INT64}
-        Result := PInt64(Src)^ <> 0;
+        Result := Unaligned(PInt64(Src)^) <> 0;
         if Result and (Dst <> nil) then
         begin
           SwapInt64BE(Src, Dst);
@@ -1530,7 +1552,7 @@ begin
       end;
     '@':
       begin
-        Result := (PInteger(Src)^ <> 0) and (PInteger(PChar(Src)+4)^ <> 0);
+        Result := (Unaligned(PInteger(Src)^) <> 0) and (Unaligned(PInteger(PChar(Src)+4)^) <> 0);
         if Result and (Dst <> nil) then
         begin
           SwapInt64BE(Src, Dst);
@@ -1545,14 +1567,14 @@ begin
       begin
         // all binary zeroes -> empty datetime
 {$ifdef SUPPORT_INT64}        
-        Result := PInt64(Src)^ <> 0;
+        Result := Unaligned(PInt64(Src)^) <> 0;
 {$else}        
-        Result := (PInteger(Src)^ <> 0) or (PInteger(PChar(Src)+4)^ <> 0);
+        Result := (Unaligned(PInteger(Src)^) <> 0) or (Unaligned(PInteger(PChar(Src)+4)^) <> 0);
 {$endif}        
         if Result and (Dst <> nil) then
         begin
-          timeStamp.Date := SwapIntLE(PInteger(Src)^) - JulianDateDelta;
-          timeStamp.Time := SwapIntLE(PInteger(PChar(Src)+4)^);
+          timeStamp.Date := SwapIntLE(Unaligned(PInteger(Src)^)) - JulianDateDelta;
+          timeStamp.Time := SwapIntLE(Unaligned(PInteger(PChar(Src)+4)^));
           date := TimeStampToDateTime(timeStamp);
           SaveDateToDst;
         end;
@@ -1563,7 +1585,7 @@ begin
         Result := true;
         if Dst <> nil then
         begin
-          PInt64(Dst)^ := SwapIntLE(PInt64(Src)^);
+          PInt64(Dst)^ := SwapIntLE(Unaligned(PInt64(Src)^));
           if DataType = ftCurrency then
             PDouble(Dst)^ := PInt64(Dst)^ / 10000.0;
         end;
@@ -1571,11 +1593,11 @@ begin
       end;
     'B':    // Foxpro double
       begin
-        if FDbfVersion in [xFoxPro,xVisualFoxPro] then
+        if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
         begin
           Result := true;
           if Dst <> nil then
-            PInt64(Dst)^ := SwapIntLE(PInt64(Src)^);
+            PInt64(Dst)^ := SwapIntLE(Unaligned(PInt64(Src)^));
         end else
           asciiContents := true;
       end;
@@ -1583,9 +1605,9 @@ begin
       begin
         if FieldSize = 4 then
         begin
-          Result := PInteger(Src)^ <> 0;
+          Result := Unaligned(PInteger(Src)^) <> 0;
           if Dst <> nil then
-            PInteger(Dst)^ := SwapIntLE(PInteger(Src)^);
+            PInteger(Dst)^ := SwapIntLE(Unaligned(PInteger(Src)^));
         end else
           asciiContents := true;
       end;
@@ -1758,12 +1780,12 @@ begin
             IntValue := 0
           else
             IntValue := PDWord(Src)^ xor $80000000;
-          PDWord(Dst)^ := SwapIntBE(IntValue);
+          Unaligned(PDWord(Dst)^) := SwapIntBE(IntValue);
         end else begin
           if Src = nil then
-            PDWord(Dst)^ := 0
+            Unaligned(PDWord(Dst)^) := 0
           else
-            PDWord(Dst)^ := SwapIntLE(PDWord(Src)^);
+            Unaligned(PDWord(Dst)^) := SwapIntLE(PDWord(Src)^);
         end;
       end;
     'O':
@@ -1771,12 +1793,12 @@ begin
 {$ifdef SUPPORT_INT64}
         if Src = nil then
         begin
-          PInt64(Dst)^ := 0;
+          Unaligned(PInt64(Dst)^) := 0;
         end else begin
           if PDouble(Src)^ < 0 then
-            PInt64(Dst)^ := not PInt64(Src)^
+            Unaligned(PInt64(Dst)^) := not PInt64(Src)^
           else
-            PDouble(Dst)^ := (PDouble(Src)^) * -1;
+            Unaligned(PDouble(Dst)^) := (PDouble(Src)^) * -1;
           SwapInt64BE(Dst, Dst);
         end;
 {$endif}
@@ -1786,10 +1808,10 @@ begin
         if Src = nil then
         begin
 {$ifdef SUPPORT_INT64}
-          PInt64(Dst)^ := 0;
+          Unaligned(PInt64(Dst)^) := 0;
 {$else}          
-          PInteger(Dst)^ := 0;
-          PInteger(PChar(Dst)+4)^ := 0;
+          Unaligned(PInteger(Dst)^) := 0;
+          Unaligned(PInteger(PChar(Dst)+4)^) := 0;
 {$endif}
         end else begin
           LoadDateFromSrc;
@@ -1804,16 +1826,16 @@ begin
         if Src = nil then
         begin
 {$ifdef SUPPORT_INT64}
-          PInt64(Dst)^ := 0;
+          Unaligned(PInt64(Dst)^) := 0;
 {$else}          
-          PInteger(Dst)^ := 0;
-          PInteger(PChar(Dst)+4)^ := 0;
+          Unaligned(PInteger(Dst)^) := 0;
+          Unaligned(PInteger(PChar(Dst)+4)^) := 0;
 {$endif}          
         end else begin
           LoadDateFromSrc;
           timeStamp := DateTimeToTimeStamp(date);
-          PInteger(Dst)^ := SwapIntLE(timeStamp.Date + JulianDateDelta);
-          PInteger(PChar(Dst)+4)^ := SwapIntLE(timeStamp.Time);
+          Unaligned(PInteger(Dst)^) := SwapIntLE(timeStamp.Date + JulianDateDelta);
+          Unaligned(PInteger(PChar(Dst)+4)^) := SwapIntLE(timeStamp.Time);
         end;
       end;
     'Y':
@@ -1821,13 +1843,13 @@ begin
 {$ifdef SUPPORT_INT64}
         if Src = nil then
         begin
-          PInt64(Dst)^ := 0;
+          Unaligned(PInt64(Dst)^) := 0;
         end else begin
           case DataType of
             ftCurrency:
-              PInt64(Dst)^ := Trunc(PDouble(Src)^ * 10000);
+              Unaligned(PInt64(Dst)^) := Trunc(PDouble(Src)^ * 10000);
             ftBCD:
-              PCurrency(Dst)^ := PCurrency(Src)^;
+              Unaligned(PCurrency(Dst)^) := PCurrency(Src)^;
           end;
           SwapInt64LE(Dst, Dst);
         end;
@@ -1838,7 +1860,7 @@ begin
         if DbfVersion in [xFoxPro,xVisualFoxPro] then
         begin
           if Src = nil then
-            PDouble(Dst)^ := 0
+            Unaligned(PDouble(Dst)^) := 0
           else
             SwapInt64LE(Src, Dst);
         end else
@@ -1849,9 +1871,9 @@ begin
         if FieldSize = 4 then
         begin
           if Src = nil then
-            PInteger(Dst)^ := 0
+            Unaligned(PInteger(Dst)^) := 0
           else
-            PInteger(Dst)^ := SwapIntLE(PInteger(Src)^);
+            Unaligned(PInteger(Dst)^) := SwapIntLE(PInteger(Src)^);
         end else
           asciiContents := true;
       end;

packages/fcl-db/src/dbase/dbf_fields.pas

@@ -40,7 +40,9 @@ type
     procedure SetFieldType(lFieldType: TFieldType);
     procedure SetSize(lSize: Integer);
     procedure SetPrecision(lPrecision: Integer);
+    // Converts VCL/LCL field types to dbf native field type markers ('C' etc)
     procedure VCLToNative;
+    // Converts dbf native field type markers ('C' etc) to VCL/LCL field types
     procedure NativeToVCL;
     procedure FreeBuffers;
   protected
@@ -73,10 +75,14 @@ type
     property CopyFrom: Integer read FCopyFrom write FCopyFrom;
   published
     property FieldName: string     read FFieldName write FFieldName;
+    // VCL/LCL field type mapped to this field
     property FieldType: TFieldType read FFieldType write SetFieldType;
+    // Native dbf field type
     property NativeFieldType: TDbfFieldType read FNativeFieldType write SetNativeFieldType;
+    // Size in physical dbase file.
+    // Note: this often differs from the VCL field sizes
+    property Size: Integer         read FSize write SetSize;
     property NullPosition: integer read FNullPosition write FNullPosition;
-    property Size: Integer         read FSize      write SetSize;
     property Precision: Integer    read FPrecision write SetPrecision;
     property Required: Boolean     read FRequired  write FRequired;
   end;
@@ -85,7 +91,6 @@ type
   private
     FOwner: TPersistent;
     FDbfVersion: TXBaseVersion;
-
     function GetItem(Idx: Integer): TDbfFieldDef;
   protected
     function GetOwner: TPersistent; override;
@@ -110,12 +115,9 @@ uses
 
 {$I dbf_struct.inc}
 
-// I keep changing that fields...
-// Last time has been asked by Venelin Georgiev
-// Is he going to be the last ?
 const
 (*
-The theory until now was :
+The theory for Delphi/FPC is:
     ftSmallint  16 bits = -32768 to 32767
                           123456 = 6 digit max theorically
                           DIGITS_SMALLINT = 6;
@@ -127,20 +129,20 @@ The theory until now was :
                          DIGITS_LARGEINT = 20;
 
 But in fact if I accept 6 digits into a ftSmallInt then tDbf will not
-being able to handles fields with 999999 (6 digits).
+be able to handles fields with 999999 (6 digits).
 
-So I now oversize the field type in order to accept anithing coming from the
+So I oversize the field type in order to accept anything coming from the
 database.
     ftSmallint  16 bits = -32768 to 32767
-                           -999  to  9999
-                           4 digits max theorically
-                          DIGITS_SMALLINT = 4;
+    ... dbf supports:       -999 to  9999
+                           4 digits max in practice
+        therefore         DIGITS_SMALLINT = 4;
     ftInteger  32 bits = -2147483648 to 2147483647
-                           -99999999 to  999999999                                        12345678901 = 11 digits max
-                         DIGITS_INTEGER = 9;
+    ... dbf supports:      -99999999 to  999999999                                        12345678901 = 11 digits max
+        therefore        DIGITS_INTEGER = 9;
     ftLargeInt 64 bits = -9223372036854775808 to 9223372036854775807
-                           -99999999999999999 to  999999999999999999
-                         DIGITS_LARGEINT = 18;
+    ... dbf supports:      -99999999999999999 to  999999999999999999
+        therefore        DIGITS_LARGEINT = 18;
  *)
   DIGITS_SMALLINT = 4;
   DIGITS_INTEGER = 9;
@@ -247,7 +249,9 @@ begin
   // copy from Db.TFieldDef
   FFieldName := DbSource.Name;
   FFieldType := DbSource.DataType;
-  FSize := DbSource.Size;
+  // We do NOT copy over size if TFieldDef size is different from our native size
+  if not(DBSource.DataType in [ftBCD,ftCurrency]) then
+    FSize := DbSource.Size;
   FPrecision := DbSource.Precision;
   FRequired := DbSource.Required;
 {$ifdef SUPPORT_FIELDDEF_INDEX}
@@ -256,7 +260,7 @@ begin
   FIsLockField := false;
   // convert VCL fieldtypes to native DBF fieldtypes
   VCLToNative;
-  // for integer / float fields try fill in size/precision
+  // for integer / float fields try to fill in Size/precision
   if FSize = 0 then
     SetDefaultSize
   else
@@ -308,7 +312,7 @@ end;
 
 procedure TDbfFieldDef.SetNativeFieldType(lFieldType: tDbfFieldType);
 begin
-  // get uppercase field type
+  // convert lowercase to uppercase
   if (lFieldType >= 'a') and (lFieldType <= 'z') then
     lFieldType := Chr(Ord(lFieldType)-32);
   FNativeFieldType := lFieldType;
@@ -331,9 +335,7 @@ end;
 procedure TDbfFieldDef.NativeToVCL;
 begin
   case FNativeFieldType of
-// OH 2000-11-15 dBase7 support.
-// Add the new fieldtypes
-    '+' : 
+    '+' :
       if DbfVersion = xBaseVII then
         FFieldType := ftAutoInc;
     'I' : FFieldType := ftInteger;
@@ -380,10 +382,10 @@ begin
     {
     To do: add support for Visual Foxpro types
     http://msdn.microsoft.com/en-US/library/ww305zh2%28v=vs.80%29.aspx
-    P Picture (in at least Visual FoxPro)
-    V Varchar/varchar binary (in at least Visual FoxPro) 1 byte up to 255 bytes (or perhaps 254)
-    W Blob (in at least Visual FoxPro), 4 bytes in a table; stored in .fpt
-    Q Varbinary (in at least Visual Foxpro)
+    P Picture (perhaps also in FoxPro)
+    V Varchar/varchar binary (perhaps also in FoxPro) 1 byte up to 255 bytes (or perhaps 254)
+    W Blob (perhaps also in FoxPro), 4 bytes in a table; stored in .fpt
+    Q Varbinary (perhaps also in Foxpro)
     }
   else
     FNativeFieldType := #0;
@@ -434,7 +436,7 @@ end;
 
 procedure TDbfFieldDef.SetDefaultSize;
 begin
-  // choose default values for variable size fields
+  // choose default values for variable Size fields
   case FFieldType of
     ftFloat:
       begin
@@ -443,8 +445,9 @@ begin
       end;
     ftCurrency, ftBCD:
       begin
-        FSize := 8;
-        FPrecision := 4;
+        FSize := 8; // Stored in dbase as 8 bytes; up to 18 (or 20) characters including .-
+        // FPC ftBCD/ftCurrency TFieldDef.Size has max 4 which is 4 bytes after decimal
+        FPrecision := 4; //Total number of digits
       end;
     ftSmallInt, ftWord:
       begin
@@ -473,7 +476,7 @@ begin
       end;
   end; // case fieldtype
 
-  // set sizes for fields that are restricted to single size/precision
+  // set sizes for fields that are restricted to single Size/precision
   CheckSizePrecision;
 end;
 
@@ -482,14 +485,14 @@ begin
   case FNativeFieldType of
     'C': // Character
       begin
-        if FSize < 0 then 
+        if FSize < 0 then
           FSize := 0;
         if (DbfVersion = xFoxPro) or (DbfVersion = xVisualFoxPro) then
         begin
-          if FSize >= $FFFF then 
+          if FSize >= $FFFF then
             FSize := $FFFF;
         end else begin
-          if FSize >= $FF then 
+          if FSize >= $FF then
             FSize := $FF;
         end;
         FPrecision := 0;
@@ -501,9 +504,12 @@ begin
       end;
     'N','F': // Binary code decimal numeric, floating point binary numeric
       begin
+        // ftBCD: precision=total number of digits; Delphi supports max 32
+        // Note: this field can be stored as BCD or integer, depending on FPrecision;
+        // that's why we allow 0 precision
         if FSize < 1   then FSize := 1;
         if FSize >= 20 then FSize := 20;
-        if FPrecision > FSize-2 then FPrecision := FSize-2;
+        if FPrecision > FSize-2 then FPrecision := FSize-2; //Leave space for . and -
         if FPrecision < 0       then FPrecision := 0;
       end;
     'D': // Date
@@ -511,12 +517,17 @@ begin
         FSize := 8;
         FPrecision := 0;
       end;
-    'B': // Double
+    'B': // (Visual)Foxpro double, DBase binary
       begin
-        if (DbfVersion <> xFoxPro) and (DbfVersion <> xVisualFoxPro) then
+        if not(DbfVersion in [xFoxPro,xVisualFoxPro]) then
         begin
           FSize := 10;
           FPrecision := 0;
+        end
+        else
+        begin
+          FSize := 8; //Foxpro double
+          FPrecision := 0;
         end;
       end;
     'M','G': // Memo, general
@@ -571,7 +582,11 @@ end;
 
 function TDbfFieldDef.IsBlob: Boolean; {override;}
 begin
-  Result := FNativeFieldType in ['M','G','B'];
+  // 'B' is float in (V)FP
+  if (DbfVersion in [xFoxPro,xVisualFoxPro]) then
+    Result := FNativeFieldType in ['M','G']
+  else
+    Result := FNativeFieldType in ['M','G','B'];
 end;
 
 procedure TDbfFieldDef.FreeBuffers;
@@ -588,7 +603,7 @@ end;
 
 procedure TDbfFieldDef.AllocBuffers;
 begin
-  // size changed?
+  // Size changed?
   if FAllocSize <> FSize then
   begin
     // free old buffers
@@ -597,7 +612,7 @@ begin
     GetMem(FDefaultBuf, FSize*3);
     FMinBuf := FDefaultBuf + FSize;
     FMaxBuf := FMinBuf + FSize;
-    // store allocated size
+    // store allocated Size
     FAllocSize := FSize;
   end;
 end;

packages/fcl-db/src/dbase/dbf_idxfile.pas

@@ -1551,7 +1551,7 @@ end;
 
 function TMdx4Tag.GetHeaderPageNo: Integer;
 begin
-  Result := SwapIntLE(PMdx4Tag(Tag)^.HeaderPageNo);
+  Result := SwapIntLE(Unaligned(PMdx4Tag(Tag)^.HeaderPageNo));
 end;
 
 function TMdx4Tag.GetTagName: string;
@@ -1591,7 +1591,7 @@ end;
 
 procedure TMdx4Tag.SetHeaderPageNo(NewPageNo: Integer);
 begin
-  PMdx4Tag(Tag)^.HeaderPageNo := SwapIntLE(NewPageNo);
+  Unaligned(PMdx4Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
 end;
 
 procedure TMdx4Tag.SetTagName(NewName: string);
@@ -1636,7 +1636,7 @@ end;
 
 function TMdx7Tag.GetHeaderPageNo: Integer;
 begin
-  Result := SwapIntLE(PMdx7Tag(Tag)^.HeaderPageNo);
+  Result := SwapIntLE(Unaligned(PMdx7Tag(Tag)^.HeaderPageNo));
 end;
 
 function TMdx7Tag.GetTagName: string;
@@ -1676,7 +1676,7 @@ end;
 
 procedure TMdx7Tag.SetHeaderPageNo(NewPageNo: Integer);
 begin
-  PMdx7Tag(Tag)^.HeaderPageNo := SwapIntLE(NewPageNo);
+  Unaligned(PMdx7Tag(Tag)^.HeaderPageNo) := SwapIntLE(NewPageNo);
 end;
 
 procedure TMdx7Tag.SetTagName(NewName: string);

packages/fcl-db/src/dbase/dbf_lang.pas

@@ -21,10 +21,10 @@ const
 //*************************************************************************//
 
 // ...
-  FoxLangId_ENU_437       = $01;
-  FoxLangId_Intl_850      = $02;
-  FoxLangId_Windows_1252  = $03;
-  FoxLangId_Mac_10000     = $04;
+  FoxLangId_ENU_437       = $01; // DOS USA
+  FoxLangId_Intl_850      = $02; // DOS multilingual
+  FoxLangId_Windows_1252  = $03; // Windows ANSI
+  FoxLangId_Mac_10000     = $04; // Standard Macintosh
 // ...
   DbfLangId_DAN_865       = $08;
   DbfLangId_NLD_437       = $09;
@@ -70,58 +70,62 @@ const
   DbfLangId_WEurope_1252  = $58;
   DbfLangId_Spanish_1252  = $59;
 // ...
+// Additional FoxPro references:
+// http://msdn.microsoft.com/en-us/library/8t45x02s%28v=VS.80%29.aspx
+// http://www.clicketyclick.dk/databases/xbase/format/dbf.html#DBF_STRUCT
   FoxLangId_German_437    = $5E;
   FoxLangId_Nordic_437    = $5F;
   FoxLangId_Nordic_850    = $60;
   FoxLangId_German_1252   = $61;
   FoxLangId_Nordic_1252   = $62;
 // ...
-  FoxLangId_EEurope_852   = $64;
-  FoxLangId_Russia_866    = $65;
-  FoxLangId_Nordic_865    = $66;
-  FoxLangId_Iceland_861   = $67;
-  FoxLangId_Czech_895     = $68;
+  FoxLangId_EEurope_852   = $64; // DOS
+  FoxLangId_Russia_866    = $65; // DOS //todo: verify, MS docs say this is $66
+  FoxLangId_Nordic_865    = $66; // DOS //todo: verify, MS docs say this is $65
+  FoxLangId_Iceland_861   = $67; // DOS
+  FoxLangId_Czech_895     = $68; // DOS Kamenicky
 // ...
-  DbfLangId_POL_620       = $69;
+  DbfLangId_POL_620       = $69; // DOS Mazovia
 // ...
-  FoxLangId_Greek_737     = $6A;
-  FoxLangId_Turkish_857   = $6B;
+  FoxLangId_Greek_737     = $6A; // DOS (437G)
+  FoxLangId_Turkish_857   = $6B; // DOS
 // ...
-  FoxLangId_Taiwan_950    = $78;
-  FoxLangId_Korean_949    = $79;
-  FoxLangId_Chinese_936   = $7A;
-  FoxLangId_Japan_932     = $7B;
-  FoxLangId_Thai_874      = $7C;
-  FoxLangId_Hebrew_1255   = $7D;
-  FoxLangId_Arabic_1256   = $7E;
+  FoxLangId_Taiwan_950    = $78; // Windows
+  FoxLangId_Korean_949    = $79; // Windows
+  FoxLangId_Chinese_936   = $7A; // Windows Chinese simplified
+  FoxLangId_Japan_932     = $7B; // Windows
+  FoxLangId_Thai_874      = $7C; // Windows
+  FoxLangId_Hebrew_1255   = $7D; // Windows
+  FoxLangId_Arabic_1256   = $7E; // Windows
 // ...
   DbfLangId_Hebrew        = $85;
-  DbfLangId_ELL_437       = $86;    // greek, code page 737 (?)
+  DbfLangId_ELL_437       = $86; // greek, code page 737 (?)
   DbfLangId_SLO_852       = $87;
   DbfLangId_TRK_857       = $88;
 // ...
   DbfLangId_BUL_868       = $8E;
 // ...
-  FoxLangId_Russia_10007  = $96;
-  FoxLangId_EEurope_10029 = $97;
-  FoxLangId_Greek_10006   = $98;
+  FoxLangId_Russia_10007  = $96; // Macintosh
+  FoxLangId_EEurope_10029 = $97; // Macintosh
+  FoxLangId_Greek_10006   = $98; // Macintosh
 // ...
   FoxLangId_Czech_1250    = $9B;
-  FoxLangId_Czech_850     = $9C;    // DOS
+  FoxLangId_Czech_850     = $9C; // DOS
 // ...
-  FoxLangId_EEurope_1250  = $C8;
-  FoxLangId_Russia_1251   = $C9;
-  FoxLangId_Turkish_1254  = $CA;
-  FoxLangId_Greek_1253    = $CB;
+  FoxLangId_EEurope_1250  = $C8; // Windows
+  FoxLangId_Russia_1251   = $C9; // Windows
+  FoxLangId_Turkish_1254  = $CA; // Windows
+  FoxLangId_Greek_1253    = $CB; // Windows
 
 
 // special constants
-
   DbfLocale_NotFound   = $010000;
   DbfLocale_Bul868     = $020000;
 
 //*************************************************************************//
-// DB3/DB4/FoxPro Language ID to CodePage convert table
+// DB3/DB4/FoxPro/Visual Foxpro Language ID to CodePage convert table
+// Visual FoxPro docs call language ID "code page mark"
+// or "code page identifier"
 //*************************************************************************//
 
   LangId_To_CodePage: array[Byte] of Word =

packages/fcl-db/src/dbase/dbf_memo.pas

@@ -101,16 +101,23 @@ uses
 //=== Memo and binary fields support
 //====================================================================
 type
-
+  // DBase III+ dbt memo file
+  // (Visual) FoxPro note: integers are in Big Endian: high byte first
+  // http://msdn.microsoft.com/en-us/library/aa975374%28VS.71%29.aspx
   PDbtHdr = ^rDbtHdr;
   rDbtHdr = record
-    NextBlock : dword;
-    Dummy     : array [4..7] of Byte;
+    NextBlock : dword;                  // 0..3
+    // Dummy in DBaseIII; size of blocks in memo file; default 512 bytes
+    // (Visual) FoxPro: 4..5 unused; use only bytes 6..7
+    BlockSize : dword;                  // 4..7
+    // DBF file name without extension
     DbfFile   : array [0..7] of Byte;   // 8..15
+    // DBase III only: version number $03
     bVer      : Byte;                   // 16
-    Dummy2    : array [17..19] of Byte;
+    Dummy2    : array [17..19] of Byte; // 17..19
+    // Block length in bytes; DBaseIII: always $01
     BlockLen  : Word;                   // 20..21
-    Dummy3    : array [22..511] of Byte;
+    Dummy3    : array [22..511] of Byte;// 22..511 First block; garbage contents
   end;
 
   PFptHdr = ^rFptHdr;
@@ -121,10 +128,16 @@ type
     Dummy3    : array [8..511] of Byte;
   end;
 
+  // Header of a memo data block:
+  // (Visual) FoxPro note: integers are in Big Endian: high byte first
   PBlockHdr = ^rBlockHdr;
   rBlockHdr = record
-    MemoType  : Cardinal;
-    MemoSize  : Cardinal;
+    // DBase IV(+) identifier: $FF $FF $08 $00
+    // (Visual) FoxPro: $00 picture, $01 text/memo, $02 object
+    MemoType  : Cardinal; // 0..3
+    // Length of memo field
+    MemoSize  : Cardinal; // 4..7
+    // memo data             8..N
   end;
 
 
@@ -184,7 +197,8 @@ begin
     RecordSize := GetBlockLen;
     // checking for right blocksize not needed for foxpro?
     // mod 128 <> 0 <-> and 0x7F <> 0
-    if (RecordSize = 0) and ((FDbfVersion in [xFoxPro,xVisualFoxPro]) or ((RecordSize and $7F) <> 0)) then
+    if (RecordSize = 0) and
+      ((FDbfVersion in [xFoxPro,xVisualFoxPro]) or ((RecordSize and $7F) <> 0)) then
     begin
       SetBlockLen(512);
       RecordSize := 512;
@@ -271,15 +285,15 @@ begin
     // dbase III memo
     done := false;
     repeat
-      // scan for EOF
+      // scan for EOF marker
       endMemo := MemScan(FBuffer, $1A, RecordSize);
       // EOF found?
       if endMemo <> nil then
       begin
-        // really EOF?
-        if (endMemo-FBuffer < RecordSize - 1) and ((endMemo[1] = #$1A) or (endMemo[1] = #0)) then
+        // really EOF? expect another 1A or null character
+        if (endMemo-FBuffer < RecordSize - 1) and
+          ((endMemo[1] = #$1A) or (endMemo[1] = #0)) then
         begin
-          // yes, EOF found
           done := true;
           numBytes := endMemo - FBuffer;
         end else begin
@@ -344,7 +358,7 @@ begin
     begin
       bytesBefore := SizeOf(rBlockHdr);
       bytesAfter := 0;
-    end else begin                      // dBase3 type
+    end else begin                      // dBase3 type, Clipper?
       bytesBefore := 0;
       bytesAfter := 2;
     end;
@@ -383,7 +397,7 @@ begin
     repeat
       // read bytes, don't overwrite header
       readBytes := Src.Read(FBuffer[bytesBefore], RecordSize{PDbtHdr(Header).BlockLen}-bytesBefore);
-      // end of input data reached ? check if need to write block terminators
+      // end of input data reached? check if we need to write block terminators
       while (readBytes < RecordSize - bytesBefore) and (bytesAfter > 0) do
       begin
         FBuffer[readBytes] := #$1A;
@@ -428,7 +442,7 @@ end;
 
 function  TDbaseMemoFile.GetMemoSize: Integer;
 begin
-  // dBase4 memofiles contain small 'header'
+  // dBase4 memofiles contain a small 'header'
   if PInteger(@FBuffer[0])^ = Integer(SwapIntLE($0008FFFF)) then
     Result := SwapIntLE(PBlockHdr(FBuffer)^.MemoSize)-8
   else

packages/fcl-db/src/dbase/dbf_str.inc

@@ -8,6 +8,7 @@ var
   STRING_KEY_VIOLATION: string;
 
   STRING_INVALID_DBF_FILE: string;
+  STRING_INVALID_DBF_FILE_FIELDERROR: string;
   STRING_FIELD_TOO_LONG: string;
   STRING_INVALID_FIELD_COUNT: string;
   STRING_INVALID_FIELD_TYPE: string;

packages/fcl-db/src/dbase/dbf_str.pas

@@ -19,6 +19,7 @@ initialization
                                          'Index: %s'+#13+#10+'Record=%d Key=''%s''.';
 
   STRING_INVALID_DBF_FILE             := 'Invalid DBF file.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Invalid DBF file. Invalid field definition.';
   STRING_FIELD_TOO_LONG               := 'Value is too long: %d characters (it can''t be more than %d).';
   STRING_INVALID_FIELD_COUNT          := 'Invalid field count: %d (must be between 1 and 4095).';
   STRING_INVALID_FIELD_TYPE           := 'Invalid field type ''%s'' for field ''%s''.';

packages/fcl-db/src/dbase/dbf_str_es.pas

@@ -19,6 +19,7 @@ initialization
                                          'Indice: %s'+#13+#10+'Registro=%d Clave=''%s''.';
 
   STRING_INVALID_DBF_FILE             := 'Archivo DBF inválido.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Archivo DBF inválido. Tipo de campo inválido.'; //todo: check for correctness
   STRING_FIELD_TOO_LONG               := 'Valor demasiado largo: %d caracteres (no puede ser mayor de %d).';
   STRING_INVALID_FIELD_COUNT          := 'Cantidad de campos inválida: %d (debe estar entre 1 y 4095).';
   STRING_INVALID_FIELD_TYPE           := 'Tipo de campo inválido ''%s'' para el campo ''%s''.';

packages/fcl-db/src/dbase/dbf_str_fr.pas

@@ -12,6 +12,7 @@ var
   STRING_KEY_VIOLATION: string;
 
   STRING_INVALID_DBF_FILE: string;
+  STRING_INVALID_DBF_FILE_FIELDERROR: string;
   STRING_FIELD_TOO_LONG: string;
   STRING_INVALID_FIELD_COUNT: string;
   STRING_INVALID_FIELD_TYPE: string;
@@ -37,6 +38,7 @@ initialization
                                          'Index: %s'+#13+#10+'Enregistrement=%d Cle=''%s''';
 
   STRING_INVALID_DBF_FILE             := 'Fichier DBF invalide.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Fichier DBF invalide. Definition de champ invalide.'; //todo: verify field part
   STRING_FIELD_TOO_LONG               := 'Valeur trop longue: %d caractères (ne peut dépasser %d).';
   STRING_INVALID_FIELD_COUNT          := 'Nombre de champs non valide: %d (doit être entre 1 et 4095).';
   STRING_INVALID_FIELD_TYPE           := 'Type de champ ''%s'' invalide pour le champ %s.';

packages/fcl-db/src/dbase/dbf_str_ita.pas

@@ -16,6 +16,8 @@ initialization
   STRING_RECORD_LOCKED                := 'Record già in uso.';
 
   STRING_INVALID_DBF_FILE             := 'File DBF non valido.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'File DBF non valido. Definizione de campo non valido'; //todo: check field part
+
   STRING_FIELD_TOO_LONG               := 'Valore troppo elevato: %d caratteri (esso non può essere più di %d).';
   STRING_INVALID_FIELD_COUNT          := 'Campo non valido (count): %d (deve essere tra 1 e 4095).';
 

packages/fcl-db/src/dbase/dbf_str_nl.pas

@@ -18,6 +18,7 @@ initialization
                                          'Index: %s'+#13+#10+'Record=%d Sleutel=''%s''';
 
   STRING_INVALID_DBF_FILE             := 'Ongeldig DBF bestand.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Ongeldig DBF bestand. Ongeldige velddefinitie.';
   STRING_FIELD_TOO_LONG               := 'Waarde is te lang: %d karakters (maximum is %d).';
   STRING_INVALID_FIELD_COUNT          := 'Ongeldig aantal velden: %d (moet tussen 1 en 4095).';
   STRING_INVALID_FIELD_TYPE           := 'Veldtype ''%s'' is ongeldig voor veld ''%s''.';

packages/fcl-db/src/dbase/dbf_str_pl.pas

@@ -18,6 +18,7 @@ initialization
                                          'Indeks: %s'+#13+#10+'Rekord=%d Klucz=''%s''';
 
   STRING_INVALID_DBF_FILE             := 'Uszkodzony plik bazy.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Uszkodzony plik bazy. Uszkodzony pol.'; //todo: definitely check field part
   STRING_FIELD_TOO_LONG               := 'Dana za d³uga : %d znaków (dopuszczalne do %d).';
   STRING_INVALID_FIELD_COUNT          := 'Z³a liczba pól: %d (dozwolone 1 do 4095).';
   STRING_INVALID_FIELD_TYPE           := 'B³êdny typ pola ''%c'' dla pola ''%s''.';

packages/fcl-db/src/dbase/dbf_str_pt.pas

@@ -21,6 +21,7 @@ initialization
                                          'Índice: %s'+#13+#10+'Registro=%d Chave=''%s''.';
 
   STRING_INVALID_DBF_FILE             := 'Arquivo DBF inválido.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Arquivo DBF inválido. Tipo de campo inválido.'; //todo: check field part
   STRING_FIELD_TOO_LONG               := 'Valor muito grande: %d caracteres (não pode ser maior que %d).';
   STRING_INVALID_FIELD_COUNT          := 'Quantidade de campos inválida: %d (deve estar entre 1 e 4095).';
   STRING_INVALID_FIELD_TYPE           := 'Tipo de campo inválido ''%s'' para o campo ''%s''.';

packages/fcl-db/src/dbase/dbf_str_ru.pas

@@ -23,6 +23,7 @@ initialization
                                          'Индекс: %s'+#13+#10+'Запись (строка)=%d  Ключ="%s".';
 
   STRING_INVALID_DBF_FILE             := 'Файл DBF поврежден или его структура не DBF.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Файл DBF поврежден или его структура не DBF.'; //todo: add field error info
   STRING_FIELD_TOO_LONG               := 'Длина значения - %d символов, это больше максимума - %d.';
   STRING_INVALID_FIELD_COUNT          := 'Количество полей в таблице (%d) невозможно. Допустимо от 1 до 4095.';
   STRING_INVALID_FIELD_TYPE           := 'Тип значения "%s", затребованный полем "%s" невозможен.';

packages/fcl-db/src/dbase/dbf_struct.inc

@@ -19,20 +19,20 @@ type
   PDbfHdr = ^rDbfHdr;
   rDbfHdr = packed record
     VerDBF      : Byte;     // 0
-    Year        : Byte;     // 1
-    Month       : Byte;     // 2
-    Day         : Byte;     // 3
-    RecordCount : Integer;  // 4-7
+    Year        : Byte;     // 1 year last updated
+    Month       : Byte;     // 2 month last updated
+    Day         : Byte;     // 3 day last updated
+    RecordCount : Integer;  // 4-7 number of records in file
     FullHdrSize : Word;     // 8-9
-    RecordSize  : Word;     // 10-11
+    RecordSize  : Word;     // 10-11 sum of all field sizes, including delete flag
     Dummy1      : Word;     // 12-13
     IncTrans    : Byte;     // 14
-    Encrypt     : Byte;     // 15
+    Encrypt     : Byte;     // 15 DBase encryption flag
     MultiUse    : Integer;  // 16-19
     LastUserID  : Integer;  // 20-23
     Dummy2      : array[24..27] of Byte;
     MDXFlag     : Byte;     // 28
-    Language    : Byte;     // 29
+    Language    : Byte;     // 29 code page mark
     Dummy3      : Word;     // 30-31
   end;
 //====================================================================
@@ -46,15 +46,25 @@ type
     Dummy               : array[64..67] of Byte;
   end;
 //====================================================================
+// DBase III,IV,FoxPro,VisualFoxPro field description
   PFieldDescIII = ^rFieldDescIII;
   rFieldDescIII = packed record
     FieldName       : array[0..10] of Char;
-    FieldType       : Char;     // 11
-    FieldOffset     : Integer;  // 12..15   only applicable to foxpro databases
-    FieldSize       : Byte;     // 16
-    FieldPrecision  : Byte;     // 17
-    FoxProFlags	    : Byte;	// 18
-    Dummy2          : array[19..31] of Byte;
+    FieldType       : Char;    // 11
+    // FieldOffset only applicable to (visual) foxpro databases
+    // DBase III uses it for address in memory
+    FieldOffset     : Integer; // 12..15
+    FieldSize       : Byte;    // 16
+    FieldPrecision  : Byte;    // 17, also known as decimal count
+    FoxProFlags	    : Byte;	   // 18
+    Reserved1       : Byte;    // 19
+    WorkAreaID      : Byte;    // 20
+    // WorkAreaID only for DBase III, is always $01
+    Reserved2       : array[21..30] of Byte;
+    MDXIndexField   : Byte;    //31
+    // DBase IV:
+    // $00: no key for this field;
+    // $01: key exists for this field in MDX index file
   end;
 //====================================================================
 // OH 2000-11-15 dBase7 support. Header Update (add fields like Next AutoInc Value)

packages/fcl-db/src/dbase/history.txt

@@ -32,6 +32,9 @@ BUGS & WARNINGS
 
 
 FreePascal trunk:
+- initial read support for (Visual) FoxPro files (r24139)
+- annotated constants/file structure (r24139)
+- factored out get version/get codepage subprocedure for readability (r24139)
 - split out existing support for Visual FoxPro and Foxpro (r24109) 
   so future Visual FoxPro only features can be implemented
 - implemented FindFirst,FindNext,FindPrior,FindLast (r24107)

packages/fcl-db/src/dbase/readme.txt

@@ -18,4 +18,14 @@ Development notes/additions to end user documentation
 
 property RecNo: approximate record number. Does not take deleted records into account. Used mainly in grids.
 
+File format references:
+Visual FoxPro:
+http://msdn.microsoft.com/en-us/library/d863bcf2%28v=vs.80%29.aspx
 
+especially this for table structure:
+http://msdn.microsoft.com/en-US/library/st4a0s68%28v=vs.80%29.aspx
+note however that the file type/magic number at offset 0 is incorrect.
+A community member amended these. See bottom of page
+
+ftp://fship.com/pub/multisoft/flagship/docu/dbfspecs.txt
+Flagship/FoxPro/Clipper/DBase III..V .dbf file format description

packages/fcl-db/src/sqldb/postgres/pqconnection.pp

@@ -40,7 +40,7 @@ type
       STATEMENT_POSITION:string;
   end;
 
-  TTranConnection= class
+  TPQTranConnection = class
   protected
     FPGConn        : PPGConn;
     FTranActive    : boolean
@@ -50,11 +50,12 @@ type
 
   TPQConnection = class (TSQLConnection)
   private
-    FConnectionPool      : array of TTranConnection;
+    FConnectionPool      : array of TPQTranConnection;
     FCursorCount         : word;
     FConnectString       : string;
-    FSQLDatabaseHandle   : pointer;
     FIntegerDateTimes    : boolean;
+    FVerboseErrors       : Boolean;
+    procedure CheckConnectionStatus(var conn: PPGconn);
     procedure CheckResultError(var res: PPGresult; conn:PPGconn; ErrMsg: string);
     function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
     procedure ExecuteDirectPG(const Query : String);
@@ -94,6 +95,7 @@ type
     property LoginPrompt;
     property Params;
     property OnLogin;
+    Property VerboseErrors : Boolean Read FVerboseErrors Write FVerboseErrors default true;
   end;
 
   { TPQConnectionDef }
@@ -157,6 +159,7 @@ begin
   inherited;
   FConnOptions := FConnOptions + [sqSupportParams] + [sqEscapeRepeat] + [sqEscapeSlash];
   FieldNameQuoteChars:=DoubleQuotes;
+  VerboseErrors:=True;
 end;
 
 procedure TPQConnection.CreateDB;
@@ -175,7 +178,6 @@ procedure TPQConnection.ExecuteDirectPG(const query : string);
 
 var ASQLDatabaseHandle    : PPGConn;
     res                   : PPGresult;
-    msg                   : String;
 
 begin
   CheckDisConnected;
@@ -192,12 +194,7 @@ begin
 
   ASQLDatabaseHandle := PQconnectdb(pchar(FConnectString));
 
-  if (PQstatus(ASQLDatabaseHandle) = CONNECTION_BAD) then
-    begin
-    msg := PQerrorMessage(ASQLDatabaseHandle);
-    PQFinish(ASQLDatabaseHandle);
-    DatabaseError(sErrConnectionFailed + ' (PostgreSQL: ' + Msg + ')',self);
-    end;
+  CheckConnectionStatus(ASQLDatabaseHandle);
 
   res := PQexec(ASQLDatabaseHandle,pchar(query));
 
@@ -284,28 +281,23 @@ begin
   if i=length(FConnectionPool) then //create a new connection
     begin
     tr.PGConn := PQconnectdb(pchar(FConnectString));
-    if (PQstatus(tr.PGConn) = CONNECTION_BAD) then
-      begin
-      result := false;
-      PQFinish(tr.PGConn);
-      DatabaseError(SErrConnectionFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self);
-      end
-    else
-      begin
-      if CharSet <> '' then
-        PQsetClientEncoding(tr.PGConn, pchar(CharSet));
-      //store the new connection
-      SetLength(FConnectionPool,i+1);
-      FConnectionPool[i]:=TTranConnection.Create;
-      FConnectionPool[i].FPGConn:=tr.PGConn;
-      FConnectionPool[i].FTranActive:=true;
-      end;
+    CheckConnectionStatus(tr.PGConn);
+
+    if CharSet <> '' then
+      PQsetClientEncoding(tr.PGConn, pchar(CharSet));
+
+    //store the new connection
+    SetLength(FConnectionPool,i+1);
+    FConnectionPool[i]:=TPQTranConnection.Create;
+    FConnectionPool[i].FPGConn:=tr.PGConn;
+    FConnectionPool[i].FTranActive:=true;
     end
   else //re-use existing connection
     begin
     tr.PGConn:=FConnectionPool[i].FPGConn;
     FConnectionPool[i].FTranActive:=true;
     end;
+
   res := PQexec(tr.PGConn, 'BEGIN');
   CheckResultError(res,tr.PGConn,sErrTransactionFailed);
 
@@ -347,15 +339,13 @@ end;
 
 
 procedure TPQConnection.DoInternalConnect;
-
-var msg : string;
-
+var ASQLDatabaseHandle   : PPGConn;
 begin
 {$IfDef LinkDynamically}
   InitialisePostgres3;
 {$EndIf}
 
-  inherited dointernalconnect;
+  inherited DoInternalConnect;
 
   FConnectString := '';
   if (UserName <> '') then FConnectString := FConnectString + ' user=''' + UserName + '''';
@@ -364,20 +354,21 @@ begin
   if (DatabaseName <> '') then FConnectString := FConnectString + ' dbname=''' + DatabaseName + '''';
   if (Params.Text <> '') then FConnectString := FConnectString + ' '+Params.Text;
 
-  FSQLDatabaseHandle := PQconnectdb(pchar(FConnectString));
+  ASQLDatabaseHandle := PQconnectdb(pchar(FConnectString));
+  try
+    CheckConnectionStatus(ASQLDatabaseHandle);
+  except
+    DoInternalDisconnect;
+    raise;
+  end;
 
-  if (PQstatus(FSQLDatabaseHandle) = CONNECTION_BAD) then
-    begin
-    msg := PQerrorMessage(FSQLDatabaseHandle);
-    dointernaldisconnect;
-    DatabaseError(sErrConnectionFailed + ' (PostgreSQL: ' + msg + ')',self);
-    end;
-// This only works for pg>=8.0, so timestamps won't work with earlier versions of pg which are compiled with integer_datetimes on
+  // This only works for pg>=8.0, so timestamps won't work with earlier versions of pg which are compiled with integer_datetimes on
   if PQparameterStatus<>nil then
-    FIntegerDateTimes := PQparameterStatus(FSQLDatabaseHandle,'integer_datetimes') = 'on';
+    FIntegerDateTimes := PQparameterStatus(ASQLDatabaseHandle,'integer_datetimes') = 'on';
+
   SetLength(FConnectionPool,1);
-  FConnectionPool[0]:=TTranConnection.Create;
-  FConnectionPool[0].FPGConn:=FSQLDatabaseHandle;
+  FConnectionPool[0]:=TPQTranConnection.Create;
+  FConnectionPool[0].FPGConn:=ASQLDatabaseHandle;
   FConnectionPool[0].FTranActive:=false;
 end;
 
@@ -396,8 +387,37 @@ begin
 {$EndIf}
 end;
 
+procedure TPQConnection.CheckConnectionStatus(var conn: PPGconn);
+var sErr: string;
+    i: integer;
+begin
+  if (PQstatus(conn) = CONNECTION_BAD) then
+    begin
+    sErr := PQerrorMessage(conn);
+    //make connection available in pool
+    for i:=0 to length(FConnectionPool)-1 do
+      if FConnectionPool[i].FPGConn=conn then
+        begin
+        FConnectionPool[i].FPGConn:=nil;
+        FConnectionPool[i].FTranActive:=false;
+        break;
+        end;
+    PQfinish(conn);
+    DatabaseError(sErrConnectionFailed + ' (PostgreSQL: ' + sErr + ')', Self);
+    end;
+end;
+
 procedure TPQConnection.CheckResultError(var res: PPGresult; conn: PPGconn;
   ErrMsg: string);
+
+  Procedure MaybeAdd(Var S : String; Prefix,Msg : String);
+
+  begin
+    if (Msg='') then
+      exit;
+    S:=S+LineEnding+Prefix+': '+Msg;
+  end;
+
 var
   E: EPQDatabaseError;
   sErr: string;
@@ -418,14 +438,17 @@ begin
     MESSAGE_DETAIL:=PQresultErrorField(res,ord('D'));
     MESSAGE_HINT:=PQresultErrorField(res,ord('H'));
     STATEMENT_POSITION:=PQresultErrorField(res,ord('P'));
-    sErr:=PQresultErrorMessage(res)+
-      'Severity: '+ SEVERITY +LineEnding+
-      'SQL State: '+ SQLSTATE +LineEnding+
-      'Primary Error: '+ MESSAGE_PRIMARY +LineEnding+
-      'Error Detail: '+ MESSAGE_DETAIL +LineEnding+
-      'Hint: '+ MESSAGE_HINT +LineEnding+
-      'Character: '+ STATEMENT_POSITION +LineEnding;
-    if Self.Name = '' then CompName := Self.ClassName else CompName := Self.Name;
+    sErr:=PQresultErrorMessage(res);
+    if VerboseErrors then
+      begin
+      MaybeAdd(sErr,'Severity',SEVERITY);
+      MaybeAdd(sErr,'SQL State',SQLSTATE);
+      MaybeAdd(sErr,'Primary Error',MESSAGE_PRIMARY);
+      MaybeAdd(sErr,'Error Detail',MESSAGE_DETAIL);
+      MaybeAdd(sErr,'Hint',MESSAGE_HINT);
+      MaybeAdd(sErr,'Character',STATEMENT_POSITION);
+      end;
+    if (Self.Name='') then CompName := Self.ClassName else CompName := Self.Name;
     E:=EPQDatabaseError.CreateFmt('%s : %s  (PostgreSQL: %s)', [CompName, ErrMsg, sErr]);
     E.SEVERITY:=SEVERITY;
     E.SQLSTATE:=SQLSTATE;
@@ -800,17 +823,9 @@ begin
     PQreset(FConnectionPool[0].FPGConn)
   else
     FConnectionPool[0].FPGConn := PQconnectdb(pchar(FConnectString));
-  if (PQstatus(FConnectionPool[0].FPGConn) = CONNECTION_BAD) then
-    begin
-    result := nil;
-    PQFinish(FConnectionPool[0].FPGConn);
-    FConnectionPool[0].FPGConn:=nil;
-    FConnectionPool[0].FTranActive:=false;
-    DatabaseError(SErrConnectionFailed + ' (PostgreSQL: ' + PQerrorMessage(FConnectionPool[0].FPGConn) + ')',self);
-    end
-  else
-    if CharSet <> '' then
-      PQsetClientEncoding(FConnectionPool[0].FPGConn, pchar(CharSet));
+  CheckConnectionStatus(FConnectionPool[0].FPGConn);
+  if CharSet <> '' then
+    PQsetClientEncoding(FConnectionPool[0].FPGConn, pchar(CharSet));
   result:=FConnectionPool[0].FPGConn;
 end;
 

packages/fcl-db/tests/database.ini.txt

@@ -168,6 +168,24 @@ connector=dbf
 ; 30=Visual FoxPro
 connectorparams=4
 
+; TDBf: DBase/FoxPro database:
+[dbase7]
+connector=dbf
+; 7=Visual DBase 7 for Windows
+connectorparams=7
+
+; TDBf: DBase/FoxPro database:
+[foxpro]
+connector=dbf
+; 25=FoxPro
+connectorparams=25
+
+; TDBf: DBase/FoxPro database:
+[visualfoxpro]
+connector=dbf
+; 30=Visual FoxPro
+connectorparams=25
+
 ; MemDS in memory dataset:
 [memds]
 connector=memds

packages/fcl-db/tests/dbftoolsunit.pas

@@ -9,6 +9,9 @@ Because of this, we use file-backed dbfs instead of memory backed dbfs
   {$mode objfpc}{$H+}
 {$ENDIF}
 
+// If defined, do not delete the dbf files when done but print out location to stdout:
+{.$DEFINE KEEPDBFFILES}
+
 interface
 
 uses
@@ -24,41 +27,50 @@ type
     procedure CreateFieldDataset; override;
     procedure DropNDatasets; override;
     procedure DropFieldDataset; override;
+    // InternalGetNDataset reroutes to ReallyInternalGetNDataset
     function InternalGetNDataset(n: integer): TDataset; override;
     function InternalGetFieldDataset: TDataSet; override;
+    // GetNDataset allowing trace dataset if required;
+    // if trace is on, use a TDbfTraceDataset instead of TDBFAutoClean
+    function ReallyInternalGetNDataset(n: integer; Trace: boolean): TDataset;
   public
     function GetTraceDataset(AChange: boolean): TDataset; override;
   end;
 
-  { TDbfTraceDataset }
-
-  TDbfTraceDataset = class(Tdbf)
-  protected
-    procedure SetCurrentRecord(Index: longint); override;
-    procedure RefreshInternalCalcFields(Buffer: PChar); override;
-    procedure InternalInitFieldDefs; override;
-    procedure CalculateFields(Buffer: PChar); override;
-    procedure ClearCalcFields(Buffer: PChar); override;
-  end;
-
   { TDBFAutoClean }
   // DBF descendant that saves to a temp file and removes file when closed
   TDBFAutoClean = class(TDBF)
   private
-    function GetUserRequestedTableLevel: integer;
+    FBackingStream: TMemoryStream;
+    FCreatedBy: string;
   public
+    // Keeps track of which function created the dataset, useful for troubleshooting
+    property CreatedBy: string read FCreatedBy write FCreatedBy;
     constructor Create;
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
+    function UserRequestedTableLevel: integer;
   end;
 
-implementation
+  { TDbfTraceDataset }
+  TDbfTraceDataset = class(TdbfAutoClean)
+  protected
+    procedure SetCurrentRecord(Index: longint); override;
+    procedure RefreshInternalCalcFields(Buffer: PChar); override;
+    procedure InternalInitFieldDefs; override;
+    procedure CalculateFields(Buffer: PChar); override;
+    procedure ClearCalcFields(Buffer: PChar); override;
+  end;
 
 
+implementation
+
+uses
+  FmtBCD;
 
 { TDBFAutoClean }
 
-function TDBFAutoClean.GetUserRequestedTableLevel: integer;
+function TDBFAutoClean.UserRequestedTableLevel: integer;
   // User can specify table level as a connector param, e.g.:
   // connectorparams=4
   // If none given, default to DBase IV
@@ -66,8 +78,8 @@ var
   TableLevelProvided: integer;
 begin
   TableLevelProvided := StrToIntDef(dbconnectorparams, 4);
-  if not (TableLevelProvided in [3, 4, 5, 7, TDBF_TABLELEVEL_FOXPRO,
-    TDBF_TABLELEVEL_VISUALFOXPRO]) then
+  if not (TableLevelProvided in [3, 4, 5, 7, 
+    TDBF_TABLELEVEL_FOXPRO, TDBF_TABLELEVEL_VISUALFOXPRO]) then
   begin
     Result := -1; // hope this crashes the tests so user is alerted.
     //Invalid tablelevel specified in connectorparams= field. Aborting
@@ -77,15 +89,13 @@ begin
 end;
 
 constructor TDBFAutoClean.Create;
-var
-  DBFFileName: string;
-  TableLevelProvided: integer;
 begin
-  DBFFileName := GetTempFileName;
-  FilePathFull := ExtractFilePath(DBFFileName);
-  TableName := ExtractFileName(DBFFileName);
-  TableLevelProvided := GetUserRequestedTableLevel;
-  TableLevel := TableLevelProvided;
+  FBackingStream:=TMemoryStream.Create;
+  // Create a unique name:
+  TableName := FormatDateTime('hhnnssz',Now())+'/'+inttostr(random(32767));
+  TableLevel := UserRequestedTableLevel;
+  Storage:=stoMemory;
+  UserStream:=FBackingStream;
   CreateTable; //write out header to disk
 end;
 
@@ -96,12 +106,19 @@ begin
 end;
 
 destructor TDBFAutoClean.Destroy;
+{$IFDEF KEEPDBFFILES}
 var
   FileName: string;
+{$ENDIF}
 begin
-  FileName := AbsolutePath + TableName;
+  {$IFDEF KEEPDBFFILES}
+  Close;
+  FileName := GetTempFileName;
+  FBackingStream.SaveToFile(FileName);
+  writeln('TDBFAutoClean: file created by ',CreatedBy,' left file: ',FileName);
+  {$ENDIF}
   inherited Destroy;
-  deletefile(FileName);
+  FBackingStream.Free;
 end;
 
 
@@ -126,31 +143,8 @@ begin
 end;
 
 function TDBFDBConnector.InternalGetNDataset(n: integer): TDataset;
-var
-  countID: integer;
 begin
-  Result := (TDBFAutoClean.Create(nil) as TDataSet);
-  with (Result as TDBFAutoclean) do
-  begin
-    FieldDefs.Add('ID', ftInteger);
-    FieldDefs.Add('NAME', ftString, 50);
-    CreateTable;
-    Open;
-    if n > 0 then
-      for countId := 1 to n do
-      begin
-        Append;
-        FieldByName('ID').AsInteger := countID;
-        FieldByName('NAME').AsString := 'TestName' + IntToStr(countID);
-        // Explicitly call .post, since there could be a bug which disturbs
-        // the automatic call to post. (example: when TDataset.DataEvent doesn't
-        // work properly)
-        Post;
-      end;
-    if state = dsinsert then
-      Post;
-    Close;
-  end;
+  result:=ReallyInternalGetNDataset(n,false);
 end;
 
 function TDBFDBConnector.InternalGetFieldDataset: TDataSet;
@@ -160,6 +154,7 @@ begin
   Result := (TDbfAutoClean.Create(nil) as TDataSet);
   with (Result as TDBFAutoClean) do
   begin
+    CreatedBy:='InternalGetFieldDataset';
     FieldDefs.Add('ID', ftInteger);
     FieldDefs.Add('FSTRING', ftString, 10);
     FieldDefs.Add('FSMALLINT', ftSmallint);
@@ -167,12 +162,12 @@ begin
     FieldDefs.Add('FWORD', ftWord);
     FieldDefs.Add('FBOOLEAN', ftBoolean);
     FieldDefs.Add('FFLOAT', ftFloat);
+    // Field types only available in newer versions
     if (Result as TDBF).TableLevel >= 25 then
       FieldDefs.Add('FCURRENCY', ftCurrency);
     if (Result as TDBF).TableLevel >= 25 then
       FieldDefs.Add('FBCD', ftBCD);
     FieldDefs.Add('FDATE', ftDate);
-    //    FieldDefs.Add('FTIME',ftTime);
     FieldDefs.Add('FDATETIME', ftDateTime);
     FieldDefs.Add('FLARGEINT', ftLargeint);
     FieldDefs.Add('FMEMO', ftMemo);
@@ -187,6 +182,11 @@ begin
       FieldByName('FINTEGER').AsInteger := testIntValues[i];
       FieldByName('FBOOLEAN').AsBoolean := testBooleanValues[i];
       FieldByName('FFLOAT').AsFloat := testFloatValues[i];
+      if (Result as TDBF).TableLevel >= 25 then
+        FieldByName('FCURRENCY').AsCurrency := testCurrencyValues[i];
+      // work around missing TBCDField.AsBCD:
+      if (Result as TDBF).TableLevel >= 25 then
+        FieldByName('FBCD').AsFloat := StrToFLoat(testFmtBCDValues[i],Self.FormatSettings);
       FieldByName('FDATE').AsDateTime := StrToDate(testDateValues[i], 'yyyy/mm/dd', '-');
       FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i];
       Post;
@@ -195,15 +195,44 @@ begin
   end;
 end;
 
-function TDBFDBConnector.GetTraceDataset(AChange: boolean): TDataset;
+function TDBFDBConnector.ReallyInternalGetNDataset(n: integer; Trace: boolean): TDataset;
 var
-  ADS, AResDS: TDbf;
+  countID: integer;
+begin
+  if Trace then
+    Result := (TDbfTraceDataset.Create(nil) as TDataSet)
+  else
+    Result := (TDBFAutoClean.Create(nil) as TDataSet);
+  with (Result as TDBFAutoclean) do
+  begin
+    CreatedBy:='InternalGetNDataset('+inttostr(n)+')';
+    FieldDefs.Add('ID', ftInteger);
+    FieldDefs.Add('NAME', ftString, 50);
+    CreateTable;
+    Open;
+    if n > 0 then
+      for countId := 1 to n do
+      begin
+        Append;
+        FieldByName('ID').AsInteger := countID;
+        FieldByName('NAME').AsString := 'TestName' + IntToStr(countID);
+        // Explicitly call .post, since there could be a bug which disturbs
+        // the automatic call to post. (example: when TDataset.DataEvent doesn't
+        // work properly)
+        Post;
+      end;
+    if state = dsinsert then
+      Post;
+    Close;
+  end;
+end;
+
+function TDBFDBConnector.GetTraceDataset(AChange: boolean): TDataset;
 begin
-  ADS := GetNDataset(AChange, 15) as TDbf;
-  AResDS := TDbfTraceDataset.Create(nil);
-  AResDS.FilePath := ADS.FilePath;
-  AResDs.TableName := ADS.TableName;
-  Result := AResDS;
+  // Mimic TDBConnector.GetNDataset
+  if AChange then FChangedDatasets[NForTraceDataset] := True;
+  Result := ReallyInternalGetNDataset(NForTraceDataset,true);
+  FUsedDatasets.Add(Result);
 end;
 
 { TDbfTraceDataset }

packages/fcl-db/tests/testspecifictdbf.pas

@@ -1,7 +1,7 @@
 unit testspecifictdbf;
 
 {
-  Unit tests which are specific to the tdbf dbase units.
+  Unit tests which are specific to the tdbf dbase/foxpro units.
 }
 
 {$IFDEF FPC}
@@ -17,7 +17,7 @@ uses
   TestFramework,
 {$ENDIF FPC}
   Classes, SysUtils,
-  db, dbf, dbf_common, ToolsUnit, DBFToolsUnit;
+  ToolsUnit, dbf;
 
 type
 
@@ -30,6 +30,10 @@ type
     procedure SetUp; override;
     procedure TearDown; override;
   published
+    // Verifies that requested tablelevel is delivered:
+    procedure TestTableLevel;
+    // Verifies that writing to memory and writing to disk results in the same data
+    procedure TestMemoryDBFEqualsDiskDBF;
     // Create fields using indexdefs:
     procedure TestCreateDatasetFromFielddefs;
     // Specifying fields from field objects
@@ -47,6 +51,10 @@ type
     procedure TestFindNext;
     // Tests findprior
     procedure TestFindPrior;
+    // Tests writing and reading a memo field
+    procedure TestMemo;
+    // Tests string field with 254 characters (max for DBase IV)
+    procedure TestLargeString;
   end;
 
 
@@ -54,7 +62,8 @@ implementation
 
 uses
   variants,
-  FmtBCD;
+  FmtBCD,
+  db, dbf_common, DBFToolsUnit;
 
 { TTestSpecificTDBF }
 
@@ -63,6 +72,7 @@ procedure TTestSpecificTDBF.WriteReadbackTest(ADBFDataset: TDbf;
 var
   i  : integer;
 begin
+  // Add sample data
   for i := 1 to 10 do
     begin
     ADBFDataset.Append;
@@ -92,6 +102,77 @@ begin
   DBConnector.StopTest;
 end;
 
+procedure TTestSpecificTDBF.TestTableLevel;
+var
+  ds : TDBF;
+begin
+  ds := TDBFAutoClean.Create(nil);
+  DS.FieldDefs.Add('ID',ftInteger);
+  DS.CreateTable;
+  DS.Open;
+  CheckEquals((DS as TDBFAutoClean).UserRequestedTableLevel,DS.TableLevel,'User specified tablelevel should match dbf tablelevel.');
+  DS.Close;
+  ds.free;
+end;
+
+procedure TTestSpecificTDBF.TestMemoryDBFEqualsDiskDBF;
+var
+  dsfile: TDBF;
+  dsmem: TDBF;
+  backingstream: TMemoryStream;
+  FileName: string;
+  i: integer;
+  thefile: TMemoryStream;
+begin
+  backingstream:=TMemoryStream.Create;
+  thefile:=TMemoryStream.Create;
+  dsmem:=TDBF.Create(nil);
+  dsfile:=TDBF.Create(nil);
+  FileName:=GetTempFileName;
+  dsfile.FilePathFull:=ExtractFilePath(FileName);
+  dsfile.TableName:=ExtractFileName(FileName);
+  dsmem.TableName:=ExtractFileName(FileName);
+  dsmem.Storage:=stoMemory;
+  dsmem.UserStream:=backingstream;
+
+  // A small number of fields but should be enough
+  dsfile.FieldDefs.Add('ID',ftInteger);
+  dsmem.FieldDefs.Add('ID',ftInteger);
+  dsfile.FieldDefs.Add('NAME',ftString,50);
+  dsmem.FieldDefs.Add('NAME',ftString,50);
+  dsfile.CreateTable;
+  dsmem.CreateTable;
+  dsfile.Open;
+  dsmem.Open;
+  // Some sample data
+  for i := 1 to 101 do
+  begin
+    dsfile.Append;
+    dsmem.Append;
+    dsfile.FieldByName('ID').AsInteger := i;
+    dsmem.FieldByName('ID').AsInteger := i;
+    dsfile.FieldByName('NAME').AsString := 'TestName' + inttostr(i);
+    dsmem.FieldByName('NAME').AsString := 'TestName' + inttostr(i);
+    dsfile.Post;
+    dsmem.Post;
+  end;
+
+  // By closing, we update the number of records in the header
+  dsfile.close;
+  dsmem.close;
+  dsfile.free;
+
+  // Keep dsmem; load file into stream:
+  thefile.LoadfromFile(FileName);
+  deletefile(FileName);
+
+  CheckEquals(backingstream.size,thefile.size,'Memory backed dbf should have same size as file-backed dbf');
+  // Now compare stream contents - thereby comparing the file with backingstream
+  CheckEquals(true,comparemem(thefile.Memory,backingstream.Memory,thefile.size),'Memory backed dbf data should be the same as file-backed dbf');
+  backingstream.free;
+  thefile.free;
+end;
+
 procedure TTestSpecificTDBF.TestCreateDatasetFromFielddefs;
 var
   ds : TDBF;
@@ -112,6 +193,7 @@ var
   f: TField;
 begin
   ds := TDBFAutoClean.Create(nil);
+  DS.CreateTable;
   F := TIntegerField.Create(ds);
   F.FieldName:='ID';
   F.DataSet:=ds;
@@ -119,7 +201,7 @@ begin
   F.FieldName:='NAME';
   F.DataSet:=ds;
   F.Size:=50;
-  DS.CreateTable;
+
   DS.Open;
   ds.free;
 end;
@@ -153,20 +235,20 @@ begin
   //todo: find out which tablelevels support calculated/lookup fields
   ds := TDBFAutoClean.Create(nil);
   try
-    F := TIntegerField.Create(ds);
-    F.FieldName:='ID';
-    F.DataSet:=ds;
-
-    F := TStringField.Create(ds);
-    F.FieldName:='NAME';
-    F.DataSet:=ds;
-    F.Size:=50;
+    ds.FieldDefs.Add('ID',ftInteger);
+    ds.FieldDefs.Add('NAME',ftString,50);
+    ds.CreateTable;
+    for i:=0 to ds.FieldDefs.Count-1 do
+    begin
+      ds.FieldDefs[i].CreateField(ds); // make fields persistent
+    end;
 
     F := TStringField.Create(ds);
     F.FieldKind:=fkCalculated;
     F.FieldName:='NAME_CALC';
     F.DataSet:=ds;
     F.Size:=50;
+    F.ProviderFlags:=[];
 
     F := TStringField.Create(ds);
     F.FieldKind:=fkLookup;
@@ -178,7 +260,6 @@ begin
     F.DataSet:=ds;
     F.Size:=50;
 
-    DS.CreateTable;
     DS.Open;
     WriteReadbackTest(ds);
 
@@ -273,6 +354,58 @@ begin
   CheckEquals(NumRecs-1,DS.fieldbyname('ID').asinteger);
 end;
 
+procedure TTestSpecificTDBF.TestMemo;
+var
+  ds : TDBF;
+begin
+  ds := TDBFAutoClean.Create(nil);
+  DS.FieldDefs.Add('ID',ftInteger);
+  DS.FieldDefs.Add('NAME',ftMemo);
+  DS.CreateTable;
+  DS.Open;
+  WriteReadbackTest(ds);
+  DS.Close;
+  ds.free;
+end;
+
+procedure TTestSpecificTDBF.TestLargeString;
+var
+  ds : TDBF;
+  MaxStringSize: integer;
+  TestValue: string;
+begin
+  ds := TDBFAutoClean.Create(nil);
+  if (ds.TableLevel>=25) then
+    // (Visual) FoxPro supports 32K
+    MaxStringSize:=32767
+  else
+    // Dbase III..V,7
+    MaxStringSize:=254;
+  TestValue:=StringOfChar('a',MaxStringSize);
+
+  DS.FieldDefs.Add('ID',ftInteger);
+  DS.FieldDefs.Add('NAME',ftString,254);
+  DS.CreateTable;
+  DS.Open;
+
+  // Write & readback test
+  DS.Append;
+  DS.FieldByName('ID').AsInteger := 1;
+  DS.FieldByName('NAME').AsString := TestValue;
+  DS.Post;
+
+  DS.first;
+  CheckEquals(1,DS.fieldbyname('ID').asinteger,'ID field must match record number');
+  // If test fails, let's count the number of "a"s instead so we can report that instead of printing out the entire string
+  CheckEquals(length(TestValue),length(DS.fieldbyname('NAME').AsString),'NAME field length must match test value length');
+  CheckEquals(TestValue,DS.fieldbyname('NAME').AsString,'NAME field must match test value');
+  DS.next;
+  CheckTrue(DS.EOF,'Dataset EOF must be true');
+
+  DS.Close;
+  ds.free;
+end;
+
 
 
 initialization

packages/fcl-db/tests/toolsunit.pas

@@ -9,9 +9,12 @@ interface
 uses
   Classes, SysUtils, DB, testdecorator;
 
-// Number of "N" test datasets (as opposed to FieldDatasets) that will be created
-// The connectors should have these records prepared in their Create*Dataset procedures.
-Const MaxDataSet = 35;
+Const
+  // Number of "N" test datasets (as opposed to FieldDatasets) that will be created
+  // The connectors should have these records prepared in their Create*Dataset procedures.
+  MaxDataSet = 35;
+  // Number of records in a trace dataset:
+  NForTraceDataset = 15;
   
 type
 
@@ -19,11 +22,11 @@ type
   TDBConnectorClass = class of TDBConnector;
   TDBConnector = class(TPersistent)
      private
-       FChangedDatasets : array[0..MaxDataSet] of boolean;
        FFormatSettings: TFormatSettings;
-       FUsedDatasets : TFPList;
        FChangedFieldDataset : boolean;
      protected
+       FChangedDatasets : array[0..MaxDataSet] of boolean;
+       FUsedDatasets : TFPList;
        procedure SetTestUniDirectional(const AValue: boolean); virtual;
        function GetTestUniDirectional: boolean; virtual;
        // These methods should be implemented by all descendents
@@ -446,7 +449,7 @@ end;
 
 function TDBConnector.GetTraceDataset(AChange: Boolean): TDataset;
 begin
-  result := GetNDataset(AChange,15);
+  result := GetNDataset(AChange,NForTraceDataset);
 end;
 
 procedure TDBConnector.StartTest;