dbf_dbffile.pas 80 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779
  1. unit dbf_dbffile;
  2. interface
  3. {$I dbf_common.inc}
  4. uses
  5. Classes, SysUtils,
  6. {$ifdef SUPPORT_MATH_UNIT}
  7. Math,
  8. {$endif}
  9. {$ifdef WIN32}
  10. Windows,
  11. {$else}
  12. {$ifdef KYLIX}
  13. Libc,
  14. {$endif}
  15. Types, dbf_wtil,
  16. {$endif}
  17. Db,
  18. dbf_common,
  19. dbf_cursor,
  20. dbf_pgfile,
  21. dbf_fields,
  22. dbf_memo,
  23. dbf_idxfile;
  24. //====================================================================
  25. //=== Dbf support (first part)
  26. //====================================================================
  27. // TxBaseVersion = (xUnknown,xClipper,xBaseIII,xBaseIV,xBaseV,xFoxPro,xVisualFoxPro);
  28. // TPagedFileMode = (pfOpen,pfCreate);
  29. // TDbfGetMode = (xFirst,xPrev,xCurrent, xNext, xLast);
  30. // TDbfGetResult = (xOK, xBOF, xEOF, xError);
  31. type
  32. //====================================================================
  33. TDbfIndexMissingEvent = procedure(var DeleteLink: Boolean) of object;
  34. TUpdateNullField = (unClear, unSet);
  35. //====================================================================
  36. TDbfGlobals = class;
  37. //====================================================================
  38. TDbfFile = class(TPagedFile)
  39. protected
  40. FMdxFile: TIndexFile;
  41. FMemoFile: TMemoFile;
  42. FFieldDefs: TDbfFieldDefs;
  43. FIndexNames: TStringList;
  44. FIndexFiles: TList;
  45. FDbfVersion: TXBaseVersion;
  46. FPrevBuffer: PChar;
  47. FDefaultBuffer: PChar;
  48. FRecordBufferSize: Integer;
  49. FLockUserLen: DWORD;
  50. FFileCodePage: Cardinal;
  51. FUseCodePage: Cardinal;
  52. FFileLangId: Byte;
  53. FCountUse: Integer;
  54. FCurIndex: Integer;
  55. FForceClose: Boolean;
  56. FLockField: TDbfFieldDef;
  57. FNullField: TDbfFieldDef;
  58. FAutoIncPresent: Boolean;
  59. FCopyDateTimeAsString: Boolean;
  60. FDateTimeHandling: TDateTimeHandling;
  61. FOnLocaleError: TDbfLocaleErrorEvent;
  62. FOnIndexMissing: TDbfIndexMissingEvent;
  63. function HasBlob: Boolean;
  64. function GetMemoExt: string;
  65. function GetLanguageId: Integer;
  66. function GetLanguageStr: string;
  67. function GetUseFloatFields: Boolean;
  68. procedure SetUseFloatFields(NewUse: Boolean);
  69. protected
  70. procedure ConstructFieldDefs;
  71. procedure InitDefaultBuffer;
  72. procedure UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef; Action: TUpdateNullField);
  73. procedure WriteLockInfo(Buffer: PChar);
  74. public
  75. constructor Create;
  76. destructor Destroy; override;
  77. procedure Open;
  78. procedure Close;
  79. procedure Zap;
  80. procedure FinishCreate(FieldDefs: TDbfFieldDefs; MemoSize: Integer);
  81. function GetIndexByName(AIndexName: string): TIndexFile;
  82. procedure SetRecordSize(NewSize: Integer); override;
  83. procedure TryExclusive; override;
  84. procedure EndExclusive; override;
  85. procedure OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
  86. function DeleteIndex(const AIndexName: string): Boolean;
  87. procedure CloseIndex(AIndexName: string);
  88. procedure RepageIndex(AIndexFile: string);
  89. procedure CompactIndex(AIndexFile: string);
  90. function Insert(Buffer: PChar): integer;
  91. procedure WriteHeader; override;
  92. procedure ApplyAutoIncToBuffer(DestBuf: PChar); // dBase7 support. Writeback last next-autoinc value
  93. procedure FastPackTable;
  94. procedure RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
  95. procedure Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
  96. function GetFieldInfo(FieldName: string): TDbfFieldDef;
  97. function GetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer): Boolean;
  98. function GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
  99. procedure SetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer);
  100. procedure InitRecord(DestBuf: PChar);
  101. procedure PackIndex(lIndexFile: TIndexFile; AIndexName: string);
  102. procedure RegenerateIndexes;
  103. procedure LockRecord(RecNo: Integer; Buffer: PChar);
  104. procedure UnlockRecord(RecNo: Integer; Buffer: PChar);
  105. procedure RecordDeleted(RecNo: Integer; Buffer: PChar);
  106. procedure RecordRecalled(RecNo: Integer; Buffer: PChar);
  107. property MemoFile: TMemoFile read FMemoFile;
  108. property FieldDefs: TDbfFieldDefs read FFieldDefs;
  109. property IndexNames: TStringList read FIndexNames;
  110. property IndexFiles: TList read FIndexFiles;
  111. property MdxFile: TIndexFile read FMdxFile;
  112. property LanguageId: Integer read GetLanguageId;
  113. property LanguageStr: string read GetLanguageStr;
  114. property FileCodePage: Cardinal read FFileCodePage;
  115. property UseCodePage: Cardinal read FUseCodePage write FUseCodePage;
  116. property FileLangId: Byte read FFileLangId write FFileLangId;
  117. property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
  118. property PrevBuffer: PChar read FPrevBuffer;
  119. property ForceClose: Boolean read FForceClose;
  120. property CopyDateTimeAsString: Boolean read FCopyDateTimeAsString write FCopyDateTimeAsString;
  121. property UseFloatFields: Boolean read GetUseFloatFields write SetUseFloatFields;
  122. property DateTimeHandling: TDateTimeHandling read FDateTimeHandling write FDateTimeHandling;
  123. property OnIndexMissing: TDbfIndexMissingEvent read FOnIndexMissing write FOnIndexMissing;
  124. property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
  125. end;
  126. //====================================================================
  127. TDbfCursor = class(TVirtualCursor)
  128. protected
  129. FPhysicalRecNo: Integer;
  130. public
  131. constructor Create(DbfFile: TDbfFile);
  132. function Next: Boolean; override;
  133. function Prev: Boolean; override;
  134. procedure First; override;
  135. procedure Last; override;
  136. function GetPhysicalRecNo: Integer; override;
  137. procedure SetPhysicalRecNo(RecNo: Integer); override;
  138. function GetSequentialRecordCount: Integer; override;
  139. function GetSequentialRecNo: Integer; override;
  140. procedure SetSequentialRecNo(RecNo: Integer); override;
  141. end;
  142. //====================================================================
  143. TDbfGlobals = class
  144. protected
  145. FCodePages: TList;
  146. FCurrencyAsBCD: Boolean;
  147. FDefaultOpenCodePage: Integer;
  148. FDefaultCreateLangId: Byte;
  149. FUserName: string;
  150. FUserNameLen: DWORD;
  151. function GetDefaultCreateCodePage: Integer;
  152. procedure SetDefaultCreateCodePage(NewCodePage: Integer);
  153. procedure InitUserName;
  154. public
  155. constructor Create;
  156. destructor Destroy; override;
  157. function CodePageInstalled(ACodePage: Integer): Boolean;
  158. property CurrencyAsBCD: Boolean read FCurrencyAsBCD write FCurrencyAsBCD;
  159. property DefaultOpenCodePage: Integer read FDefaultOpenCodePage write FDefaultOpenCodePage;
  160. property DefaultCreateCodePage: Integer read GetDefaultCreateCodePage write SetDefaultCreateCodePage;
  161. property DefaultCreateLangId: Byte read FDefaultCreateLangId write FDefaultCreateLangId;
  162. property UserName: string read FUserName;
  163. property UserNameLen: DWORD read FUserNameLen;
  164. end;
  165. var
  166. DbfGlobals: TDbfGlobals;
  167. implementation
  168. uses
  169. {$ifndef WIN32}
  170. {$ifndef FPC}
  171. RTLConsts,
  172. {$else}
  173. BaseUnix,
  174. {$endif}
  175. {$endif}
  176. dbf_str, dbf_lang;
  177. const
  178. sDBF_DEC_SEP = '.';
  179. {$I dbf_struct.inc}
  180. //====================================================================
  181. // International separator
  182. // thanks to Bruno Depero from Italy
  183. // and Andreas Wöllenstein from Denmark
  184. //====================================================================
  185. function DbfStrToFloat(const Src: PChar; const Size: Integer): Extended;
  186. var
  187. iPos: PChar;
  188. eValue: extended;
  189. endChar: Char;
  190. begin
  191. // temp null-term string
  192. endChar := (Src + Size)^;
  193. (Src + Size)^ := #0;
  194. // we only have to convert if decimal separator different
  195. if DecimalSeparator <> sDBF_DEC_SEP then
  196. begin
  197. // search dec sep
  198. iPos := StrScan(Src, sDBF_DEC_SEP);
  199. // replace
  200. if iPos <> nil then
  201. iPos^ := DecimalSeparator;
  202. end else
  203. iPos := nil;
  204. // convert to double
  205. if TextToFloat(Src, eValue {$ifndef VER1_0}, fvExtended{$endif}) then
  206. Result := eValue
  207. else
  208. Result := 0;
  209. // restore dec sep
  210. if iPos <> nil then
  211. iPos^ := sDBF_DEC_SEP;
  212. // restore Char of null-term
  213. (Src + Size)^ := endChar;
  214. end;
  215. procedure FloatToDbfStr(const Val: Extended; const Size, Precision: Integer; const Dest: PChar);
  216. var
  217. Buffer: array [0..24] of Char;
  218. resLen: Integer;
  219. iPos: PChar;
  220. begin
  221. // convert to temporary buffer
  222. resLen := FloatToText(@Buffer[0], Val, {$ifndef FPC_VERSION}fvExtended,{$endif} ffFixed, Size, Precision);
  223. // prevent overflow in destination buffer
  224. if resLen > Size then
  225. resLen := Size;
  226. // null-terminate buffer
  227. Buffer[resLen] := #0;
  228. // we only have to convert if decimal separator different
  229. if DecimalSeparator <> sDBF_DEC_SEP then
  230. begin
  231. iPos := StrScan(@Buffer[0], DecimalSeparator);
  232. if iPos <> nil then
  233. iPos^ := sDBF_DEC_SEP;
  234. end;
  235. // fill destination with spaces
  236. FillChar(Dest^, Size, ' ');
  237. // now copy right-aligned to destination
  238. Move(Buffer[0], Dest[Size-resLen], resLen);
  239. end;
  240. function GetIntFromStrLength(Src: Pointer; Size: Integer; Default: Integer): Integer;
  241. var
  242. endChar: Char;
  243. Code: Integer;
  244. begin
  245. // save Char at pos term. null
  246. endChar := (PChar(Src) + Size)^;
  247. (PChar(Src) + Size)^ := #0;
  248. // convert
  249. Val(PChar(Src), Result, Code);
  250. // check success
  251. if Code <> 0 then
  252. Result := Default;
  253. // restore prev. ending Char
  254. (PChar(Src) + Size)^ := endChar;
  255. end;
  256. //====================================================================
  257. // TDbfFile
  258. //====================================================================
  259. constructor TDbfFile.Create;
  260. begin
  261. // init variables first
  262. FFieldDefs := TDbfFieldDefs.Create(nil);
  263. FIndexNames := TStringList.Create;
  264. FIndexFiles := TList.Create;
  265. // now initialize inherited
  266. inherited;
  267. end;
  268. destructor TDbfFile.Destroy;
  269. var
  270. I: Integer;
  271. begin
  272. // close file
  273. Close;
  274. // free files
  275. for I := 0 to Pred(FIndexFiles.Count) do
  276. TPagedFile(FIndexFiles.Items[I]).Free;
  277. // free lists
  278. FreeAndNil(FIndexFiles);
  279. FreeAndNil(FIndexNames);
  280. FreeAndNil(FFieldDefs);
  281. // call ancestor
  282. inherited;
  283. end;
  284. function TDbfFile.GetUseFloatFields: Boolean;
  285. begin
  286. Result := FFieldDefs.UseFloatFields;
  287. end;
  288. procedure TDbfFile.SetUseFloatFields(NewUse: Boolean);
  289. begin
  290. FFieldDefs.UseFloatFields := NewUse;
  291. end;
  292. procedure TDbfFile.Open;
  293. var
  294. lMemoFileName: string;
  295. lMdxFileName: string;
  296. MemoFileClass: TMemoFileClass;
  297. I: Integer;
  298. deleteLink: Boolean;
  299. lModified: boolean;
  300. LangStr: PChar;
  301. version: byte;
  302. begin
  303. // check if not already opened
  304. if not Active then
  305. begin
  306. // open requested file
  307. OpenFile;
  308. // check if we opened an already existing file
  309. lModified := false;
  310. if not FileCreated then
  311. begin
  312. HeaderSize := sizeof(rDbfHdr); // temporary
  313. // OH 2000-11-15 dBase7 support. I build dBase Tables with different
  314. // BDE dBase Level (1. without Memo, 2. with Memo)
  315. // Header Byte ($1d hex) (29 dec) -> Language driver ID.
  316. // $03,$83 xBaseIII Header Byte $1d=$00, Float -> N($13.$04) DateTime C($1E)
  317. // $03,$8B xBaseIV/V Header Byte $1d=$58, Float -> N($14.$04)
  318. // $04,$8C xBaseVII Header Byte $1d=$00 Float -> O($08) DateTime @($08)
  319. // $03,$F5 FoxPro Level 25 Header Byte $1d=$03, Float -> N($14.$04)
  320. // Access 97
  321. // $03,$83 dBaseIII Header Byte $1d=$00, Float -> N($13.$05) DateTime D($08)
  322. // $03,$8B dBaseIV/V Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
  323. // $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
  324. version := PDbfHdr(Header)^.VerDBF;
  325. case (version and $07) of
  326. $03:
  327. if LanguageID = 0 then
  328. FDbfVersion := xBaseIII
  329. else
  330. FDbfVersion := xBaseIV;
  331. $04:
  332. FDbfVersion := xBaseVII;
  333. $02, $05:
  334. FDbfVersion := xFoxPro;
  335. else
  336. // check visual foxpro
  337. if ((version and $FE) = $30) or (version = $F5) or (version = $FB) then
  338. begin
  339. FDbfVersion := xFoxPro;
  340. end else begin
  341. // not a valid DBF file
  342. raise EDbfError.Create(STRING_INVALID_DBF_FILE);
  343. end;
  344. end;
  345. FFieldDefs.DbfVersion := FDbfVersion;
  346. RecordSize := PDbfHdr(Header)^.RecordSize;
  347. HeaderSize := PDbfHdr(Header)^.FullHdrSize;
  348. if (HeaderSize = 0) or (RecordSize = 0) then
  349. begin
  350. HeaderSize := 0;
  351. RecordSize := 0;
  352. RecordCount := 0;
  353. FForceClose := true;
  354. exit;
  355. end;
  356. // check if specified recordcount correct
  357. if PDbfHdr(Header)^.RecordCount <> RecordCount then
  358. begin
  359. // This message was annoying
  360. // and was not understood by most people
  361. // ShowMessage('Invalid Record Count,'+^M+
  362. // 'RecordCount in Hdr : '+IntToStr(PDbfHdr(Header).RecordCount)+^M+
  363. // 'expected : '+IntToStr(RecordCount));
  364. PDbfHdr(Header)^.RecordCount := RecordCount;
  365. lModified := true;
  366. end;
  367. // determine codepage
  368. if FDbfVersion >= xBaseVII then
  369. begin
  370. // cache language str
  371. LangStr := @PAfterHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
  372. // VdBase 7 Language strings
  373. // 'DBWIN...' -> Charset 1252 (ansi)
  374. // 'DB999...' -> Code page 999, 9 any digit
  375. // 'DBHEBREW' -> Code page 1255 ??
  376. // 'FOX..999' -> Code page 999, 9 any digit
  377. // 'FOX..WIN' -> Charset 1252 (ansi)
  378. if (LangStr[0] = 'D') and (LangStr[1] = 'B') then
  379. begin
  380. if StrLComp(LangStr+2, 'WIN', 3) = 0 then
  381. FFileCodePage := 1252
  382. else
  383. if StrLComp(LangStr+2, 'HEBREW', 6) = 0 then
  384. begin
  385. FFileCodePage := 1255;
  386. end else begin
  387. FFileCodePage := GetIntFromStrLength(LangStr+2, 3, 0);
  388. if (Ord(LangStr[5]) >= Ord('0')) and (Ord(LangStr[5]) <= Ord('9')) then
  389. FFileCodePage := FFileCodePage * 10 + Ord(LangStr[5]) - Ord('0');
  390. end;
  391. end else
  392. if StrLComp(LangStr, 'FOX', 3) = 0 then
  393. begin
  394. if StrLComp(LangStr+5, 'WIN', 3) = 0 then
  395. FFileCodePage := 1252
  396. else
  397. FFileCodePage := GetIntFromStrLength(LangStr+5, 3, 0)
  398. end else begin
  399. FFileCodePage := 0;
  400. end;
  401. FFileLangId := GetLangId_From_LangName(LanguageStr);
  402. end else begin
  403. // FDbfVersion <= xBaseV
  404. FFileLangId := PDbfHdr(Header)^.Language;
  405. FFileCodePage := LangId_To_CodePage[FFileLangId];
  406. end;
  407. // determine used codepage, if no codepage, then use default codepage
  408. FUseCodePage := FFileCodePage;
  409. if FUseCodePage = 0 then
  410. FUseCodePage := DbfGlobals.DefaultOpenCodePage;
  411. // get list of fields
  412. ConstructFieldDefs;
  413. // open blob file if present
  414. lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
  415. if HasBlob then
  416. begin
  417. // open blob file
  418. if not FileExists(lMemoFileName) then
  419. MemoFileClass := TNullMemoFile
  420. else if FDbfVersion = xFoxPro then
  421. MemoFileClass := TFoxProMemoFile
  422. else
  423. MemoFileClass := TDbaseMemoFile;
  424. FMemoFile := MemoFileClass.Create(Self);
  425. FMemoFile.FileName := lMemoFileName;
  426. FMemoFile.Mode := Mode;
  427. FMemoFile.AutoCreate := false;
  428. FMemoFile.MemoRecordSize := 0;
  429. FMemoFile.DbfVersion := FDbfVersion;
  430. FMemoFile.Open;
  431. // set header blob flag corresponding to field list
  432. if FDbfVersion <> xFoxPro then
  433. begin
  434. PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80;
  435. lModified := true;
  436. end;
  437. end else
  438. if FDbfVersion <> xFoxPro then
  439. begin
  440. PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF and $7F;
  441. lModified := true;
  442. end;
  443. // check if mdx flagged
  444. if (FDbfVersion <> xFoxPro) and (PDbfHdr(Header)^.MDXFlag <> 0) then
  445. begin
  446. // open mdx file if present
  447. lMdxFileName := ChangeFileExt(FileName, '.mdx');
  448. if FileExists(lMdxFileName) then
  449. begin
  450. // open file
  451. FMdxFile := TIndexFile.Create(Self);
  452. FMdxFile.FileName := lMdxFileName;
  453. FMdxFile.Mode := Mode;
  454. FMdxFile.AutoCreate := false;
  455. FMdxFile.OnLocaleError := FOnLocaleError;
  456. FMdxFile.CodePage := UseCodePage;
  457. FMdxFile.Open;
  458. // is index ready for use?
  459. if not FMdxFile.ForceClose then
  460. begin
  461. FIndexFiles.Add(FMdxFile);
  462. // get index tag names known
  463. FMdxFile.GetIndexNames(FIndexNames);
  464. end else begin
  465. // asked to close! close file
  466. FreeAndNil(FMdxFile);
  467. end;
  468. end else begin
  469. // ask user
  470. deleteLink := true;
  471. if Assigned(FOnIndexMissing) then
  472. FOnIndexMissing(deleteLink);
  473. // correct flag
  474. if deleteLink then
  475. begin
  476. PDbfHdr(Header)^.MDXFlag := 0;
  477. lModified := true;
  478. end else
  479. FForceClose := true;
  480. end;
  481. end;
  482. end;
  483. // record changes
  484. if lModified then
  485. WriteHeader;
  486. // open indexes
  487. for I := 0 to FIndexFiles.Count - 1 do
  488. TIndexFile(FIndexFiles.Items[I]).Open;
  489. end;
  490. end;
  491. procedure TDbfFile.Close;
  492. var
  493. MdxIndex, I: Integer;
  494. begin
  495. if Active then
  496. begin
  497. // close index files first
  498. MdxIndex := -1;
  499. for I := 0 to FIndexFiles.Count - 1 do
  500. begin
  501. TIndexFile(FIndexFiles.Items[I]).Close;
  502. if TIndexFile(FIndexFiles.Items[I]) = FMdxFile then
  503. MdxIndex := I;
  504. end;
  505. // free memo file if any
  506. FreeAndNil(FMemoFile);
  507. // now we can close physical dbf file
  508. CloseFile;
  509. // free FMdxFile, remove it from the FIndexFiles and Names lists
  510. if MdxIndex >= 0 then
  511. FIndexFiles.Delete(MdxIndex);
  512. I := 0;
  513. while I < FIndexNames.Count do
  514. begin
  515. if FIndexNames.Objects[I] = FMdxFile then
  516. begin
  517. FIndexNames.Delete(I);
  518. end else begin
  519. Inc(I);
  520. end;
  521. end;
  522. FreeAndNil(FMdxFile);
  523. FreeMemAndNil(Pointer(FPrevBuffer));
  524. FreeMemAndNil(Pointer(FDefaultBuffer));
  525. // reset variables
  526. FFileLangId := 0;
  527. end;
  528. end;
  529. procedure TDbfFile.FinishCreate(FieldDefs: TDbfFieldDefs; MemoSize: Integer);
  530. var
  531. lFieldDescIII: rFieldDescIII;
  532. lFieldDescVII: rFieldDescVII;
  533. lFieldDescPtr: Pointer;
  534. lFieldDef: TDbfFieldDef;
  535. lMemoFileName: string;
  536. I, lFieldOffset, lSize, lPrec: Integer;
  537. lHasBlob: Boolean;
  538. lLocaleID: LCID;
  539. begin
  540. try
  541. // first reset file
  542. RecordCount := 0;
  543. lHasBlob := false;
  544. // determine codepage & locale
  545. if FFileLangId = 0 then
  546. FFileLangId := DbfGlobals.DefaultCreateLangId;
  547. FFileCodePage := LangId_To_CodePage[FFileLangId];
  548. lLocaleID := LangId_To_Locale[FFileLangId];
  549. FUseCodePage := FFileCodePage;
  550. // prepare header size
  551. if FDbfVersion = xBaseVII then
  552. begin
  553. // version xBaseVII without memo
  554. HeaderSize := SizeOf(rDbfHdr) + SizeOf(rAfterHdrVII);
  555. RecordSize := SizeOf(rFieldDescVII);
  556. FillChar(Header^, HeaderSize, #0);
  557. PDbfHdr(Header)^.VerDBF := $04;
  558. // write language string
  559. StrPLCopy(
  560. @PAfterHdrVII(PChar(Header)+SizeOf(rDbfHdr))^.LanguageDriverName[32],
  561. ConstructLangName(FFileCodePage, lLocaleID, false),
  562. 63-32);
  563. lFieldDescPtr := @lFieldDescVII;
  564. end else begin
  565. // version xBaseIII/IV/V without memo
  566. HeaderSize := SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
  567. RecordSize := SizeOf(rFieldDescIII);
  568. FillChar(Header^, HeaderSize, #0);
  569. if FDbfVersion = xFoxPro then
  570. begin
  571. PDbfHdr(Header)^.VerDBF := $02
  572. end else
  573. PDbfHdr(Header)^.VerDBF := $03;
  574. // standard language WE, dBase III no language support
  575. if FDbfVersion = xBaseIII then
  576. PDbfHdr(Header)^.Language := 0
  577. else
  578. PDbfHdr(Header)^.Language := FFileLangId;
  579. // init field ptr
  580. lFieldDescPtr := @lFieldDescIII;
  581. end;
  582. // begin writing fields
  583. FFieldDefs.Clear;
  584. // deleted mark 1 byte
  585. lFieldOffset := 1;
  586. for I := 1 to FieldDefs.Count do
  587. begin
  588. lFieldDef := FieldDefs.Items[I-1];
  589. // check if datetime conversion
  590. if FCopyDateTimeAsString then
  591. if lFieldDef.FieldType = ftDateTime then
  592. begin
  593. // convert to string
  594. lFieldDef.FieldType := ftString;
  595. lFieldDef.Size := 22;
  596. end;
  597. // update source
  598. lFieldDef.FieldName := AnsiUpperCase(lFieldDef.FieldName);
  599. lFieldDef.Offset := lFieldOffset;
  600. lHasBlob := lHasBlob or lFieldDef.IsBlob;
  601. // apply field transformation tricks
  602. lSize := lFieldDef.Size;
  603. lPrec := lFieldDef.Precision;
  604. if (lFieldDef.NativeFieldType = 'C')
  605. {$ifndef USE_LONG_CHAR_FIELDS}
  606. and (FDbfVersion = xFoxPro)
  607. {$endif}
  608. then
  609. begin
  610. lPrec := lSize shr 8;
  611. lSize := lSize and $FF;
  612. end;
  613. // update temp field props
  614. if FDbfVersion = xBaseVII then
  615. begin
  616. FillChar(lFieldDescVII, SizeOf(lFieldDescVII), #0);
  617. StrPLCopy(lFieldDescVII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescVII.FieldName)-1);
  618. lFieldDescVII.FieldType := lFieldDef.NativeFieldType;
  619. lFieldDescVII.FieldSize := lSize;
  620. lFieldDescVII.FieldPrecision := lPrec;
  621. // TODO: bug-endianness
  622. lFieldDescVII.NextAutoInc := lFieldDef.AutoInc;
  623. //lFieldDescVII.MDXFlag := ???
  624. end else begin
  625. FillChar(lFieldDescIII, SizeOf(lFieldDescIII), #0);
  626. StrPLCopy(lFieldDescIII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescIII.FieldName)-1);
  627. lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
  628. lFieldDescIII.FieldSize := lSize;
  629. lFieldDescIII.FieldPrecision := lPrec;
  630. // TODO: bug-endianness
  631. if FDbfVersion = xFoxPro then
  632. lFieldDescIII.FieldOffset := lFieldOffset;
  633. if (PDbfHdr(Header)^.VerDBF = $02) and (lFieldDef.NativeFieldType in ['0', 'Y', 'T', 'O', '+']) then
  634. PDbfHdr(Header)^.VerDBF := $30;
  635. if (PDbfHdr(Header)^.VerDBF = $30) and (lFieldDef.NativeFieldType = '+') then
  636. PDbfHdr(Header)^.VerDBF := $31;
  637. end;
  638. // update our field list
  639. with FFieldDefs.AddFieldDef do
  640. begin
  641. Assign(lFieldDef);
  642. Offset := lFieldOffset;
  643. AutoInc := 0;
  644. end;
  645. // save field props
  646. WriteRecord(I, lFieldDescPtr);
  647. Inc(lFieldOffset, lFieldDef.Size);
  648. end;
  649. // end of header
  650. WriteChar($0D);
  651. // write memo bit
  652. if lHasBlob then
  653. begin
  654. if FDbfVersion = xBaseIII then
  655. PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80
  656. else
  657. if FDbfVersion = xFoxPro then
  658. begin
  659. if PDbfHdr(Header)^.VerDBF = $02 then
  660. PDbfHdr(Header)^.VerDBF := $F5;
  661. end else
  662. PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $88;
  663. end;
  664. // update header
  665. PDbfHdr(Header)^.RecordSize := lFieldOffset;
  666. PDbfHdr(Header)^.FullHdrSize := HeaderSize + RecordSize * FieldDefs.Count + 1;
  667. // add empty "back-link" info, whatever it is:
  668. { A 263-byte range that contains the backlink, which is the relative path of
  669. an associated database (.dbc) file, information. If the first byte is 0x00,
  670. the file is not associated with a database. Therefore, database files always
  671. contain 0x00. }
  672. if FDbfVersion = xFoxPro then
  673. Inc(PDbfHdr(Header)^.FullHdrSize, 263);
  674. // write dbf header to disk
  675. inherited WriteHeader;
  676. finally
  677. RecordSize := PDbfHdr(Header)^.RecordSize;
  678. HeaderSize := PDbfHdr(Header)^.FullHdrSize;
  679. // write full header to disk (dbf+fields)
  680. WriteHeader;
  681. end;
  682. if HasBlob and (FMemoFile=nil) then
  683. begin
  684. lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
  685. if FDbfVersion = xFoxPro then
  686. FMemoFile := TFoxProMemoFile.Create(Self)
  687. else
  688. FMemoFile := TDbaseMemoFile.Create(Self);
  689. FMemoFile.FileName := lMemoFileName;
  690. FMemoFile.Mode := Mode;
  691. FMemoFile.AutoCreate := AutoCreate;
  692. FMemoFile.MemoRecordSize := MemoSize;
  693. FMemoFile.DbfVersion := FDbfVersion;
  694. FMemoFile.Open;
  695. end;
  696. end;
  697. function TDbfFile.HasBlob: Boolean;
  698. var
  699. I: Integer;
  700. begin
  701. Result := false;
  702. for I := 0 to FFieldDefs.Count-1 do
  703. if FFieldDefs.Items[I].IsBlob then
  704. Result := true;
  705. end;
  706. function TDbfFile.GetMemoExt: string;
  707. begin
  708. if FDbfVersion = xFoxPro then
  709. Result := '.fpt'
  710. else
  711. Result := '.dbt';
  712. end;
  713. procedure TDbfFile.Zap;
  714. begin
  715. // make recordcount zero
  716. RecordCount := 0;
  717. // update recordcount
  718. PDbfHdr(Header)^.RecordCount := RecordCount;
  719. // update disk header
  720. WriteHeader;
  721. // update indexes
  722. RegenerateIndexes;
  723. end;
  724. procedure TDbfFile.WriteHeader;
  725. var
  726. SystemTime: TSystemTime;
  727. lDataHdr: PDbfHdr;
  728. EofTerminator: Byte;
  729. begin
  730. if (HeaderSize=0) then
  731. exit;
  732. //FillHeader(0);
  733. lDataHdr := PDbfHdr(Header);
  734. GetLocalTime(SystemTime);
  735. lDataHdr^.Year := SystemTime.wYear - 1900;
  736. lDataHdr^.Month := SystemTime.wMonth;
  737. lDataHdr^.Day := SystemTime.wDay;
  738. // lDataHdr.RecordCount := RecordCount;
  739. inherited WriteHeader;
  740. EofTerminator := $1A;
  741. WriteBlock(@EofTerminator, 1, CalcPageOffset(RecordCount+1));
  742. end;
  743. procedure TDbfFile.ConstructFieldDefs;
  744. var
  745. {lColumnCount,}lHeaderSize,lFieldSize: Integer;
  746. lPropHdrOffset, lFieldOffset: Integer;
  747. lFieldDescIII: rFieldDescIII;
  748. lFieldDescVII: rFieldDescVII;
  749. lFieldPropsHdr: rFieldPropsHdr;
  750. lStdProp: rStdPropEntry;
  751. TempFieldDef: TDbfFieldDef;
  752. lSize,lPrec,I, lColumnCount: Integer;
  753. lAutoInc: Cardinal;
  754. dataPtr: PChar;
  755. lNativeFieldType: Char;
  756. lFieldName: string;
  757. lCanHoldNull: boolean;
  758. lCurrentNullPosition: integer;
  759. begin
  760. FFieldDefs.Clear;
  761. if DbfVersion >= xBaseVII then
  762. begin
  763. lHeaderSize := SizeOf(rAfterHdrVII) + SizeOf(rDbfHdr);
  764. lFieldSize := SizeOf(rFieldDescVII);
  765. end else begin
  766. lHeaderSize := SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
  767. lFieldSize := SizeOf(rFieldDescIII);
  768. end;
  769. HeaderSize := lHeaderSize;
  770. RecordSize := lFieldSize;
  771. FLockField := nil;
  772. FNullField := nil;
  773. FAutoIncPresent := false;
  774. lColumnCount := (PDbfHdr(Header)^.FullHdrSize - lHeaderSize) div lFieldSize;
  775. lFieldOffset := 1;
  776. lAutoInc := 0;
  777. I := 1;
  778. lCurrentNullPosition := 0;
  779. lCanHoldNull := false;
  780. try
  781. // there has to be minimum of one field
  782. repeat
  783. // version field info?
  784. if FDbfVersion >= xBaseVII then
  785. begin
  786. ReadRecord(I, @lFieldDescVII);
  787. lFieldName := AnsiUpperCase(PChar(@lFieldDescVII.FieldName[0]));
  788. lSize := lFieldDescVII.FieldSize;
  789. lPrec := lFieldDescVII.FieldPrecision;
  790. lNativeFieldType := lFieldDescVII.FieldType;
  791. // TODO: big-endianness
  792. lAutoInc := lFieldDescVII.NextAutoInc;
  793. if lNativeFieldType = '+' then
  794. FAutoIncPresent := true;
  795. end else begin
  796. ReadRecord(I, @lFieldDescIII);
  797. lFieldName := AnsiUpperCase(PChar(@lFieldDescIII.FieldName[0]));
  798. lSize := lFieldDescIII.FieldSize;
  799. lPrec := lFieldDescIII.FieldPrecision;
  800. lNativeFieldType := lFieldDescIII.FieldType;
  801. lCanHoldNull := (FDbfVersion = xFoxPro) and
  802. ((lFieldDescIII.FoxProFlags and $2) <> 0) and
  803. (lFieldName <> '_NULLFLAGS');
  804. end;
  805. // apply field transformation tricks
  806. if (lNativeFieldType = 'C')
  807. {$ifdef USE_LONG_CHAR_FIELDS}
  808. and (FDbfVersion = xFoxPro)
  809. {$endif}
  810. then
  811. begin
  812. lSize := lSize + lPrec shl 8;
  813. lPrec := 0;
  814. end;
  815. // add field
  816. TempFieldDef := FFieldDefs.AddFieldDef;
  817. with TempFieldDef do
  818. begin
  819. FieldName := lFieldName;
  820. Offset := lFieldOffset;
  821. Size := lSize;
  822. Precision := lPrec;
  823. AutoInc := lAutoInc;
  824. NativeFieldType := lNativeFieldType;
  825. if lCanHoldNull then
  826. begin
  827. NullPosition := lCurrentNullPosition;
  828. inc(lCurrentNullPosition);
  829. end else
  830. NullPosition := -1;
  831. end;
  832. // check valid field:
  833. // 1) non-empty field name
  834. // 2) known field type
  835. // {3) no changes have to be made to precision or size}
  836. if (Length(lFieldName) = 0) or (TempFieldDef.FieldType = ftUnknown) then
  837. raise EDbfError.Create(STRING_INVALID_DBF_FILE);
  838. // determine if lock field present, if present, then store additional info
  839. if lFieldName = '_DBASELOCK' then
  840. begin
  841. FLockField := TempFieldDef;
  842. FLockUserLen := lSize - 8;
  843. if FLockUserLen > DbfGlobals.UserNameLen then
  844. FLockUserLen := DbfGlobals.UserNameLen;
  845. end else
  846. if UpperCase(lFieldName) = '_NULLFLAGS' then
  847. FNullField := TempFieldDef;
  848. // goto next field
  849. Inc(lFieldOffset, lSize);
  850. Inc(I);
  851. // continue until header termination character found
  852. // or end of header reached
  853. until (I > lColumnCount) or (ReadChar = $0D);
  854. // test if not too many fields
  855. if FFieldDefs.Count >= 4096 then
  856. raise EDbfError.CreateFmt(STRING_INVALID_FIELD_COUNT, [FFieldDefs.Count]);
  857. // do not check FieldOffset = PDbfHdr(Header).RecordSize because additional
  858. // data could be present in record
  859. // get current position
  860. lPropHdrOffset := Stream.Position;
  861. // dBase 7 -> read field properties, test if enough space, maybe no header
  862. if (FDbfVersion = xBaseVII) and (lPropHdrOffset + Sizeof(lFieldPropsHdr) <
  863. PDbfHdr(Header)^.FullHdrSize) then
  864. begin
  865. // read in field properties header
  866. ReadBlock(@lFieldPropsHdr, SizeOf(lFieldPropsHdr), lPropHdrOffset);
  867. // read in standard properties
  868. lFieldOffset := lPropHdrOffset + lFieldPropsHdr.StartStdProps;
  869. for I := 0 to lFieldPropsHdr.NumStdProps - 1 do
  870. begin
  871. // read property data
  872. ReadBlock(@lStdProp, SizeOf(lStdProp), lFieldOffset+I*SizeOf(lStdProp));
  873. // is this a constraint?
  874. if lStdProp.FieldOffset = 0 then
  875. begin
  876. // this is a constraint...not implemented
  877. end else if lStdProp.FieldOffset <= FFieldDefs.Count then begin
  878. // get fielddef for this property
  879. TempFieldDef := FFieldDefs.Items[lStdProp.FieldOffset-1];
  880. // allocate space to store data
  881. TempFieldDef.AllocBuffers;
  882. // dataPtr = nil -> no data to retrieve
  883. dataPtr := nil;
  884. // store data
  885. case lStdProp.PropType of
  886. FieldPropType_Required: TempFieldDef.Required := true;
  887. FieldPropType_Default:
  888. begin
  889. dataPtr := TempFieldDef.DefaultBuf;
  890. TempFieldDef.HasDefault := true;
  891. end;
  892. FieldPropType_Min:
  893. begin
  894. dataPtr := TempFieldDef.MinBuf;
  895. TempFieldDef.HasMin := true;
  896. end;
  897. FieldPropType_Max:
  898. begin
  899. dataPtr := TempFieldDef.MaxBuf;
  900. TempFieldDef.HasMax := true;
  901. end;
  902. end;
  903. // get data for this property
  904. if dataPtr <> nil then
  905. ReadBlock(dataPtr, lStdProp.DataSize, lPropHdrOffset + lStdProp.DataOffset);
  906. end;
  907. end;
  908. // read custom properties...not implemented
  909. // read RI properties...not implemented
  910. end;
  911. finally
  912. HeaderSize := PDbfHdr(Header)^.FullHdrSize;
  913. RecordSize := PDbfHdr(Header)^.RecordSize;
  914. end;
  915. end;
  916. function TDbfFile.GetLanguageId: Integer;
  917. begin
  918. Result := PDbfHdr(Header)^.Language;
  919. end;
  920. function TDbfFile.GetLanguageStr: String;
  921. begin
  922. if FDbfVersion >= xBaseVII then
  923. Result := PAfterHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
  924. end;
  925. {
  926. I fill the holes with the last records.
  927. now we can do an 'in-place' pack
  928. }
  929. procedure TDbfFile.FastPackTable;
  930. var
  931. iDel,iNormal: Integer;
  932. pDel,pNormal: PChar;
  933. function FindFirstDel: Boolean;
  934. begin
  935. while iDel<=iNormal do
  936. begin
  937. ReadRecord(iDel, pDel);
  938. if (PChar(pDel)^ <> ' ') then
  939. begin
  940. Result := true;
  941. exit;
  942. end;
  943. Inc(iDel);
  944. end;
  945. Result := false;
  946. end;
  947. function FindLastNormal: Boolean;
  948. begin
  949. while iNormal>=iDel do
  950. begin
  951. ReadRecord(iNormal, pNormal);
  952. if (PChar(pNormal)^= ' ') then
  953. begin
  954. Result := true;
  955. exit;
  956. end;
  957. dec(iNormal);
  958. end;
  959. Result := false;
  960. end;
  961. begin
  962. if RecordSize < 1 then Exit;
  963. GetMem(pNormal, RecordSize);
  964. GetMem(pDel, RecordSize);
  965. try
  966. iDel := 1;
  967. iNormal := RecordCount;
  968. while FindFirstDel do
  969. begin
  970. // iDel is definitely deleted
  971. if FindLastNormal then
  972. begin
  973. // but is not anymore
  974. WriteRecord(iDel, pNormal);
  975. PChar(pNormal)^ := '*';
  976. WriteRecord(iNormal, pNormal);
  977. end else begin
  978. // Cannot found a record after iDel so iDel must be deleted
  979. dec(iDel);
  980. break;
  981. end;
  982. end;
  983. // FindFirstDel failed means than iDel is full
  984. RecordCount := iDel;
  985. RegenerateIndexes;
  986. // Pack Memofields
  987. finally
  988. FreeMem(pNormal);
  989. FreeMem(pDel);
  990. end;
  991. end;
  992. procedure TDbfFile.Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
  993. var
  994. lIndexFileNames: TStrings;
  995. lIndexFile: TIndexFile;
  996. NewBaseName: string;
  997. I: integer;
  998. begin
  999. // get memory for index file list
  1000. lIndexFileNames := TStringList.Create;
  1001. try
  1002. // save index filenames
  1003. for I := 0 to FIndexFiles.Count - 1 do
  1004. begin
  1005. lIndexFile := TIndexFile(IndexFiles[I]);
  1006. lIndexFileNames.Add(lIndexFile.FileName);
  1007. // prepare changing the dbf file name, needs changes in index files
  1008. lIndexFile.PrepareRename(NewIndexFileNames[I]);
  1009. end;
  1010. // close file
  1011. Close;
  1012. if DeleteFiles then
  1013. begin
  1014. SysUtils.DeleteFile(DestFileName);
  1015. SysUtils.DeleteFile(ChangeFileExt(DestFileName, GetMemoExt));
  1016. end else begin
  1017. I := 0;
  1018. FindNextName(DestFileName, NewBaseName, I);
  1019. SysUtils.RenameFile(DestFileName, NewBaseName);
  1020. SysUtils.RenameFile(ChangeFileExt(DestFileName, GetMemoExt),
  1021. ChangeFileExt(NewBaseName, GetMemoExt));
  1022. end;
  1023. // delete old index files
  1024. for I := 0 to NewIndexFileNames.Count - 1 do
  1025. SysUtils.DeleteFile(NewIndexFileNames.Strings[I]);
  1026. // rename the new dbf files
  1027. SysUtils.RenameFile(FileName, DestFileName);
  1028. SysUtils.RenameFile(ChangeFileExt(FileName, GetMemoExt),
  1029. ChangeFileExt(DestFileName, GetMemoExt));
  1030. // rename new index files
  1031. for I := 0 to NewIndexFileNames.Count - 1 do
  1032. SysUtils.RenameFile(lIndexFileNames.Strings[I], NewIndexFileNames.Strings[I]);
  1033. finally
  1034. lIndexFileNames.Free;
  1035. end;
  1036. end;
  1037. type
  1038. TRestructFieldInfo = record
  1039. SourceOffset: Integer;
  1040. DestOffset: Integer;
  1041. Size: Integer;
  1042. end;
  1043. { assume nobody has more than 8192 fields, otherwise possibly range check error }
  1044. PRestructFieldInfo = ^TRestructFieldInfoArray;
  1045. TRestructFieldInfoArray = array[0..8191] of TRestructFieldInfo;
  1046. procedure TDbfFile.RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
  1047. var
  1048. DestDbfFile: TDbfFile;
  1049. TempIndexDef: TDbfIndexDef;
  1050. TempIndexFile: TIndexFile;
  1051. DestFieldDefs: TDbfFieldDefs;
  1052. TempDstDef, TempSrcDef: TDbfFieldDef;
  1053. OldIndexFiles: TStrings;
  1054. IndexName, NewBaseName: string;
  1055. I, lRecNo, lFieldNo, lFieldSize, lBlobRecNo, lWRecNo, srcOffset, dstOffset: Integer;
  1056. pBuff, pDestBuff: PChar;
  1057. pBlobRecNoBuff: array[1..11] of Char;
  1058. RestructFieldInfo: PRestructFieldInfo;
  1059. BlobStream: TMemoryStream;
  1060. begin
  1061. // nothing to do?
  1062. if (RecordSize < 1) or ((DbfFieldDefs = nil) and not Pack) then
  1063. exit;
  1064. // if no exclusive access, terrible things can happen!
  1065. CheckExclusiveAccess;
  1066. // make up some temporary filenames
  1067. lRecNo := 0;
  1068. FindNextName(FileName, NewBaseName, lRecNo);
  1069. // select final field definition list
  1070. if DbfFieldDefs = nil then
  1071. begin
  1072. DestFieldDefs := FFieldDefs;
  1073. end else begin
  1074. DestFieldDefs := DbfFieldDefs;
  1075. // copy autoinc values
  1076. for I := 0 to DbfFieldDefs.Count - 1 do
  1077. begin
  1078. lFieldNo := DbfFieldDefs.Items[I].CopyFrom;
  1079. if (lFieldNo >= 0) and (lFieldNo < FFieldDefs.Count) then
  1080. DbfFieldDefs.Items[I].AutoInc := FFieldDefs.Items[lFieldNo].AutoInc;
  1081. end;
  1082. end;
  1083. // create temporary dbf
  1084. DestDbfFile := TDbfFile.Create;
  1085. DestDbfFile.FileName := NewBaseName;
  1086. DestDbfFile.AutoCreate := true;
  1087. DestDbfFile.Mode := pfExclusiveCreate;
  1088. DestDbfFile.UseFloatFields := UseFloatFields;
  1089. DestDbfFile.OnIndexMissing := FOnIndexMissing;
  1090. DestDbfFile.OnLocaleError := FOnLocaleError;
  1091. DestDbfFile.DbfVersion := FDbfVersion;
  1092. DestDbfFile.FileLangId := FileLangId;
  1093. DestDbfFile.Open;
  1094. // create dbf header
  1095. if FMemoFile <> nil then
  1096. DestDbfFile.FinishCreate(DestFieldDefs, FMemoFile.RecordSize)
  1097. else
  1098. DestDbfFile.FinishCreate(DestFieldDefs, 512);
  1099. // adjust size and offsets of fields
  1100. GetMem(RestructFieldInfo, sizeof(TRestructFieldInfo)*DestFieldDefs.Count);
  1101. for lFieldNo := 0 to DestFieldDefs.Count - 1 do
  1102. begin
  1103. TempDstDef := DestFieldDefs.Items[lFieldNo];
  1104. if TempDstDef.CopyFrom >= 0 then
  1105. begin
  1106. TempSrcDef := FFieldDefs.Items[TempDstDef.CopyFrom];
  1107. if TempDstDef.NativeFieldType in ['F', 'N'] then
  1108. begin
  1109. // get minimum field length
  1110. lFieldSize := Min(TempSrcDef.Precision, TempDstDef.Precision) +
  1111. Min(TempSrcDef.Size - TempSrcDef.Precision,
  1112. TempDstDef.Size - TempDstDef.Precision);
  1113. // if one has dec separator, but other not, we lose one digit
  1114. if (TempDstDef.Precision > 0) xor
  1115. ((TempSrcDef.NativeFieldType in ['F', 'N']) and (TempSrcDef.Precision > 0)) then
  1116. Dec(lFieldSize);
  1117. // should not happen, but check nevertheless (maybe corrupt data)
  1118. if lFieldSize < 0 then
  1119. lFieldSize := 0;
  1120. srcOffset := TempSrcDef.Size - TempSrcDef.Precision -
  1121. (TempDstDef.Size - TempDstDef.Precision);
  1122. if srcOffset < 0 then
  1123. begin
  1124. dstOffset := -srcOffset;
  1125. srcOffset := 0;
  1126. end else begin
  1127. dstOffset := 0;
  1128. end;
  1129. end else begin
  1130. lFieldSize := Min(TempSrcDef.Size, TempDstDef.Size);
  1131. srcOffset := 0;
  1132. dstOffset := 0;
  1133. end;
  1134. with RestructFieldInfo[lFieldNo] do
  1135. begin
  1136. Size := lFieldSize;
  1137. SourceOffset := TempSrcDef.Offset + srcOffset;
  1138. DestOffset := TempDstDef.Offset + dstOffset;
  1139. end;
  1140. end;
  1141. end;
  1142. // add indexes
  1143. TempIndexDef := TDbfIndexDef.Create(nil);
  1144. for I := 0 to FIndexNames.Count - 1 do
  1145. begin
  1146. // get length of extension -> determines MDX or NDX
  1147. IndexName := FIndexNames.Strings[I];
  1148. TempIndexFile := TIndexFile(FIndexNames.Objects[I]);
  1149. TempIndexFile.GetIndexInfo(IndexName, TempIndexDef);
  1150. if Length(ExtractFileExt(IndexName)) > 0 then
  1151. begin
  1152. // NDX index, get unique file name
  1153. lRecNo := 0;
  1154. FindNextName(IndexName, IndexName, lRecNo);
  1155. end;
  1156. // add this index
  1157. DestDbfFile.OpenIndex(IndexName, TempIndexDef.SortField, true, TempIndexDef.Options);
  1158. end;
  1159. TempIndexDef.Free;
  1160. // get memory for record buffers
  1161. GetMem(pBuff, RecordSize);
  1162. BlobStream := TMemoryStream.Create;
  1163. OldIndexFiles := TStringList.Create;
  1164. // if restructure, we need memory for dest buffer, otherwise use source
  1165. if DbfFieldDefs = nil then
  1166. pDestBuff := pBuff
  1167. else
  1168. GetMem(pDestBuff, DestDbfFile.RecordSize);
  1169. // let the games begin!
  1170. try
  1171. {$ifdef USE_CACHE}
  1172. BufferAhead := true;
  1173. DestDbfFile.BufferAhead := true;
  1174. {$endif}
  1175. lWRecNo := 1;
  1176. for lRecNo := 1 to RecordCount do
  1177. begin
  1178. // read record from original dbf
  1179. ReadRecord(lRecNo, pBuff);
  1180. // copy record?
  1181. if (pBuff^ <> '*') or not Pack then
  1182. begin
  1183. // if restructure, initialize dest
  1184. if DbfFieldDefs <> nil then
  1185. begin
  1186. DestDbfFile.InitRecord(pDestBuff);
  1187. // copy deleted mark (the first byte)
  1188. pDestBuff^ := pBuff^;
  1189. end;
  1190. if (DbfFieldDefs <> nil) or (FMemoFile <> nil) then
  1191. begin
  1192. // copy fields
  1193. for lFieldNo := 0 to DestFieldDefs.Count-1 do
  1194. begin
  1195. TempDstDef := DestFieldDefs.Items[lFieldNo];
  1196. // handle blob fields differently
  1197. // don't try to copy new blob fields!
  1198. // DbfFieldDefs = nil -> pack only
  1199. // TempDstDef.CopyFrom >= 0 -> copy existing (blob) field
  1200. if TempDstDef.IsBlob and ((DbfFieldDefs = nil) or (TempDstDef.CopyFrom >= 0)) then
  1201. begin
  1202. // get current blob blockno
  1203. GetFieldData(lFieldNo, ftString, pBuff, @pBlobRecNoBuff[1]);
  1204. lBlobRecNo := StrToIntDef(pBlobRecNoBuff, -1);
  1205. // valid blockno read?
  1206. if lBlobRecNo >= 0 then
  1207. begin
  1208. BlobStream.Clear;
  1209. FMemoFile.ReadMemo(lBlobRecNo, BlobStream);
  1210. BlobStream.Position := 0;
  1211. // always append
  1212. DestDbfFile.FMemoFile.WriteMemo(lBlobRecNo, 0, BlobStream);
  1213. end;
  1214. // write new blockno
  1215. DestDbfFile.SetFieldData(lFieldNo, ftInteger, @lBlobRecNo, pDestBuff);
  1216. end else if (DbfFieldDefs <> nil) and (TempDstDef.CopyFrom >= 0) then
  1217. begin
  1218. // copy content of field
  1219. with RestructFieldInfo[lFieldNo] do
  1220. Move(pBuff[SourceOffset], pDestBuff[DestOffset], Size);
  1221. end;
  1222. end;
  1223. end;
  1224. // write record
  1225. DestDbfFile.WriteRecord(lWRecNo, pDestBuff);
  1226. // update indexes
  1227. for I := 0 to DestDbfFile.IndexFiles.Count - 1 do
  1228. TIndexFile(DestDbfFile.IndexFiles.Items[I]).Insert(lWRecNo, pDestBuff);
  1229. // go to next record
  1230. Inc(lWRecNo);
  1231. end;
  1232. end;
  1233. {$ifdef USE_CACHE}
  1234. BufferAhead := false;
  1235. DestDbfFile.BufferAhead := false;
  1236. {$endif}
  1237. // save index filenames
  1238. for I := 0 to FIndexFiles.Count - 1 do
  1239. OldIndexFiles.Add(TIndexFile(IndexFiles[I]).FileName);
  1240. // close dbf
  1241. Close;
  1242. // if restructure -> rename the old dbf files
  1243. // if pack only -> delete the old dbf files
  1244. DestDbfFile.Rename(FileName, OldIndexFiles, DbfFieldDefs = nil);
  1245. // we have to reinit fielddefs if restructured
  1246. Open;
  1247. // crop deleted records
  1248. RecordCount := lWRecNo - 1;
  1249. // update date/time stamp, recordcount
  1250. PDbfHdr(Header)^.RecordCount := RecordCount;
  1251. WriteHeader;
  1252. finally
  1253. // close temporary file
  1254. FreeAndNil(DestDbfFile);
  1255. // free mem
  1256. FreeAndNil(OldIndexFiles);
  1257. FreeMem(pBuff);
  1258. FreeAndNil(BlobStream);
  1259. FreeMem(RestructFieldInfo);
  1260. if DbfFieldDefs <> nil then
  1261. FreeMem(pDestBuff);
  1262. end;
  1263. end;
  1264. procedure TDbfFile.RegenerateIndexes;
  1265. var
  1266. lIndexNo: Integer;
  1267. begin
  1268. // recreate every index in every file
  1269. for lIndexNo := 0 to FIndexFiles.Count-1 do
  1270. begin
  1271. PackIndex(TIndexFile(FIndexFiles.Items[lIndexNo]), EmptyStr);
  1272. end;
  1273. end;
  1274. function TDbfFile.GetFieldInfo(FieldName: string): TDbfFieldDef;
  1275. var
  1276. I: Integer;
  1277. lfi: TDbfFieldDef;
  1278. begin
  1279. FieldName := AnsiUpperCase(FieldName);
  1280. for I := 0 to FFieldDefs.Count-1 do
  1281. begin
  1282. lfi := TDbfFieldDef(FFieldDefs.Items[I]);
  1283. if lfi.fieldName = FieldName then
  1284. begin
  1285. Result := lfi;
  1286. exit;
  1287. end;
  1288. end;
  1289. Result := nil;
  1290. end;
  1291. // NOTE: Dst may be nil!
  1292. function TDbfFile.GetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer): Boolean;
  1293. var
  1294. TempFieldDef: TDbfFieldDef;
  1295. begin
  1296. TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
  1297. Result := GetFieldDataFromDef(TempFieldDef, DataType, Src, Dst);
  1298. end;
  1299. // NOTE: Dst may be nil!
  1300. function TDbfFile.GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
  1301. var
  1302. FieldOffset, FieldSize: Integer;
  1303. // s: string;
  1304. ldd, ldm, ldy, lth, ltm, lts: Integer;
  1305. date: TDateTime;
  1306. timeStamp: TTimeStamp;
  1307. asciiContents: boolean;
  1308. {$ifdef SUPPORT_INT64}
  1309. function GetInt64FromStrLength(Src: Pointer; Size: Integer; Default: Int64): Int64;
  1310. var
  1311. endChar: Char;
  1312. Code: Integer;
  1313. begin
  1314. // save Char at pos term. null
  1315. endChar := (PChar(Src) + Size)^;
  1316. (PChar(Src) + Size)^ := #0;
  1317. // convert
  1318. Val(PChar(Src), Result, Code);
  1319. // check success
  1320. if Code <> 0 then Result := Default;
  1321. // restore prev. ending Char
  1322. (PChar(Src) + Size)^ := endChar;
  1323. end;
  1324. {$endif}
  1325. procedure CorrectYear(var wYear: Integer);
  1326. var wD, wM, wY, CenturyBase: Word;
  1327. {$ifndef DELPHI_5}
  1328. // Delphi 3 standard-behavior no change possible
  1329. const TwoDigitYearCenturyWindow= 0;
  1330. {$endif}
  1331. begin
  1332. if wYear >= 100 then
  1333. Exit;
  1334. DecodeDate(Date, wY, wm, wD);
  1335. // use Delphi-Date-Window
  1336. CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
  1337. Inc(wYear, CenturyBase div 100 * 100);
  1338. if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
  1339. Inc(wYear, 100);
  1340. end;
  1341. procedure SaveDateToDst;
  1342. begin
  1343. {$ifdef SUPPORT_NEW_FIELDDATA}
  1344. // Delphi 5 requests a TDateTime
  1345. PDateTime(Dst)^ := date;
  1346. {$else}
  1347. // Delphi 3 and 4 request a TDateTimeRec
  1348. // date is TTimeStamp.date
  1349. // datetime = msecs == BDE timestamp as we implemented it
  1350. if DataType = ftDateTime then
  1351. begin
  1352. PDateTimeRec(Dst)^.DateTime := date;
  1353. end else begin
  1354. PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
  1355. end;
  1356. {$endif}
  1357. end;
  1358. begin
  1359. // test if non-nil source (record buffer)
  1360. if Src = nil then
  1361. begin
  1362. Result := false;
  1363. exit;
  1364. end;
  1365. // check Dst = nil, called with dst = nil to check empty field
  1366. if (FNullField <> nil) and (Dst = nil) and (AFieldDef.NullPosition >= 0) then
  1367. begin
  1368. // go to byte with null flag of this field
  1369. Src := PChar(Src) + FNullField.Offset + (AFieldDef.NullPosition shr 3);
  1370. Result := (PByte(Src)^ and (1 shl (AFieldDef.NullPosition and $7))) <> 0;
  1371. exit;
  1372. end;
  1373. FieldOffset := AFieldDef.Offset;
  1374. FieldSize := AFieldDef.Size;
  1375. Src := PChar(Src) + FieldOffset;
  1376. asciiContents := false;
  1377. // field types that are binary and of which the fieldsize should not be truncated
  1378. case AFieldDef.NativeFieldType of
  1379. '+', 'I':
  1380. begin
  1381. if FDbfVersion <> xFoxPro then
  1382. begin
  1383. Result := PDWord(Src)^ <> 0;
  1384. if Result and (Dst <> nil) then
  1385. begin
  1386. PDWord(Dst)^ := SwapInt(PDWord(Src)^);
  1387. if Result then
  1388. PInteger(Dst)^ := Integer(PDWord(Dst)^ xor $80000000);
  1389. end;
  1390. end else begin
  1391. Result := true;
  1392. if Dst <> nil then
  1393. PInteger(Dst)^ := PInteger(Src)^;
  1394. end;
  1395. end;
  1396. 'O':
  1397. begin
  1398. {$ifdef SUPPORT_INT64}
  1399. Result := (PInt64(Src)^ <> 0);
  1400. if Result and (Dst <> nil) then
  1401. begin
  1402. SwapInt64(Src, Dst);
  1403. if PInt64(Dst)^ > 0 then
  1404. PInt64(Dst)^ := not PInt64(Dst)^
  1405. else
  1406. PDouble(Dst)^ := PDouble(Dst)^ * -1;
  1407. end;
  1408. {$endif}
  1409. end;
  1410. '@':
  1411. begin
  1412. Result := (PInteger(Src)^ <> 0) and (PInteger(PChar(Src)+4)^ <> 0);
  1413. if Result and (Dst <> nil) then
  1414. begin
  1415. SwapInt64(Src, Dst);
  1416. if FDateTimeHandling = dtBDETimeStamp then
  1417. date := BDETimeStampToDateTime(PDouble(Dst)^)
  1418. else
  1419. date := PDateTime(Dst)^;
  1420. SaveDateToDst;
  1421. end;
  1422. end;
  1423. 'T':
  1424. begin
  1425. // all binary zeroes -> empty datetime
  1426. Result := (PInteger(Src)^ <> 0) or (PInteger(PChar(Src)+4)^ <> 0);
  1427. if Result and (Dst <> nil) then
  1428. begin
  1429. timeStamp.Date := PInteger(Src)^ - 1721425;
  1430. timeStamp.Time := PInteger(PChar(Src)+4)^;
  1431. date := TimeStampToDateTime(timeStamp);
  1432. SaveDateToDst;
  1433. end;
  1434. end;
  1435. 'Y':
  1436. begin
  1437. {$ifdef SUPPORT_INT64}
  1438. Result := true;
  1439. if Dst <> nil then
  1440. begin
  1441. // TODO: data is little endian;
  1442. case DataType of
  1443. ftCurrency:
  1444. begin
  1445. PDouble(Dst)^ := PInt64(Src)^ / 10000.0;
  1446. end;
  1447. ftBCD:
  1448. begin
  1449. PCurrency(Dst)^ := PCurrency(Src)^;
  1450. end;
  1451. end;
  1452. end;
  1453. {$endif}
  1454. end;
  1455. 'B': // foxpro double
  1456. begin
  1457. Result := true;
  1458. if Dst <> nil then
  1459. PDouble(Dst)^ := PDouble(Src)^;
  1460. end;
  1461. 'M':
  1462. begin
  1463. if FieldSize = 4 then
  1464. begin
  1465. Result := PInteger(Src)^ <> 0;
  1466. if Dst <> nil then
  1467. PInteger(Dst)^ := PInteger(Src)^;
  1468. end else
  1469. asciiContents := true;
  1470. end;
  1471. else
  1472. asciiContents := true;
  1473. end;
  1474. if asciiContents then
  1475. begin
  1476. // SetString(s, PChar(Src) + FieldOffset, FieldSize );
  1477. // s := {TrimStr(s)} TrimRight(s);
  1478. // truncate spaces at end by shortening fieldsize
  1479. while (FieldSize > 0) and ((PChar(Src) + FieldSize - 1)^ = ' ') do
  1480. dec(FieldSize);
  1481. // if not string field, truncate spaces at beginning too
  1482. if DataType <> ftString then
  1483. while (FieldSize > 0) and (PChar(Src)^ = ' ') do
  1484. begin
  1485. inc(PChar(Src));
  1486. dec(FieldSize);
  1487. end;
  1488. // return if field is empty
  1489. Result := FieldSize > 0;
  1490. if Result and (Dst <> nil) then // data not needed if Result= false or Dst=nil
  1491. case DataType of
  1492. ftBoolean:
  1493. begin
  1494. // in DBase- FileDescription lowercase t is allowed too
  1495. // with asking for Result= true s must be longer then 0
  1496. // else it happens an AV, maybe field is NULL
  1497. if (PChar(Src)^ = 'T') or (PChar(Src)^ = 't') then
  1498. PWord(Dst)^ := 1
  1499. else
  1500. PWord(Dst)^ := 0;
  1501. end;
  1502. ftSmallInt:
  1503. PSmallInt(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
  1504. {$ifdef SUPPORT_INT64}
  1505. ftLargeInt:
  1506. PLargeInt(Dst)^ := GetInt64FromStrLength(Src, FieldSize, 0);
  1507. {$endif}
  1508. ftInteger:
  1509. PInteger(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
  1510. ftFloat, ftCurrency:
  1511. PDouble(Dst)^ := DbfStrToFloat(Src, FieldSize);
  1512. ftDate, ftDateTime:
  1513. begin
  1514. // get year, month, day
  1515. ldy := GetIntFromStrLength(PChar(Src) + 0, 4, 1);
  1516. ldm := GetIntFromStrLength(PChar(Src) + 4, 2, 1);
  1517. ldd := GetIntFromStrLength(PChar(Src) + 6, 2, 1);
  1518. //if (ly<1900) or (ly>2100) then ly := 1900;
  1519. //Year from 0001 to 9999 is possible
  1520. //everyting else is an error, an empty string too
  1521. //Do DateCorrection with Delphis possibillities for one or two digits
  1522. if (ldy < 100) and (PChar(Src)[0] = #32) and (PChar(Src)[1] = #32) then
  1523. CorrectYear(ldy);
  1524. try
  1525. date := EncodeDate(ldy, ldm, ldd);
  1526. except
  1527. date := 0;
  1528. end;
  1529. // time stored too?
  1530. if (AFieldDef.FieldType = ftDateTime) and (DataType = ftDateTime) then
  1531. begin
  1532. // get hour, minute, second
  1533. lth := GetIntFromStrLength(PChar(Src) + 8, 2, 1);
  1534. ltm := GetIntFromStrLength(PChar(Src) + 10, 2, 1);
  1535. lts := GetIntFromStrLength(PChar(Src) + 12, 2, 1);
  1536. // encode
  1537. try
  1538. date := date + EncodeTime(lth, ltm, lts, 0);
  1539. except
  1540. date := 0;
  1541. end;
  1542. end;
  1543. SaveDateToDst;
  1544. end;
  1545. ftString:
  1546. StrLCopy(Dst, Src, FieldSize);
  1547. end else begin
  1548. case DataType of
  1549. ftString:
  1550. if Dst <> nil then
  1551. PChar(Dst)[0] := #0;
  1552. end;
  1553. end;
  1554. end;
  1555. end;
  1556. procedure TDbfFile.UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef;
  1557. Action: TUpdateNullField);
  1558. var
  1559. NullDst: pbyte;
  1560. Mask: byte;
  1561. begin
  1562. // this field has null setting capability
  1563. NullDst := PByte(PChar(Buffer) + FNullField.Offset + (AFieldDef.NullPosition shr 3));
  1564. Mask := 1 shl (AFieldDef.NullPosition and $7);
  1565. if Action = unSet then
  1566. begin
  1567. // clear the field, set null flag
  1568. NullDst^ := NullDst^ or Mask;
  1569. end else begin
  1570. // set field data, clear null flag
  1571. NullDst^ := NullDst^ and not Mask;
  1572. end;
  1573. end;
  1574. procedure TDbfFile.SetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer);
  1575. const
  1576. IsBlobFieldToPadChar: array[Boolean] of Char = (#32, '0');
  1577. SrcNilToUpdateNullField: array[boolean] of TUpdateNullField = (unClear, unSet);
  1578. var
  1579. FieldSize,FieldPrec: Integer;
  1580. TempFieldDef: TDbfFieldDef;
  1581. Len: Integer;
  1582. IntValue: dword;
  1583. year, month, day: Word;
  1584. hour, minute, sec, msec: Word;
  1585. date: TDateTime;
  1586. timeStamp: TTimeStamp;
  1587. asciiContents: boolean;
  1588. procedure LoadDateFromSrc;
  1589. begin
  1590. {$ifdef SUPPORT_NEW_FIELDDATA}
  1591. // Delphi 5 passes a TDateTime
  1592. date := PDateTime(Src)^;
  1593. {$else}
  1594. // Delphi 3 and 4 pass a TDateTimeRec with a time stamp
  1595. // date = integer
  1596. // datetime = msecs == BDETimeStampToDateTime as we implemented it
  1597. if DataType = ftDateTime then
  1598. begin
  1599. date := PDouble(Src)^;
  1600. end else begin
  1601. timeStamp.Time := 0;
  1602. timeStamp.Date := PLongInt(Src)^;
  1603. date := TimeStampToDateTime(timeStamp);
  1604. end;
  1605. {$endif}
  1606. end;
  1607. begin
  1608. TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
  1609. FieldSize := TempFieldDef.Size;
  1610. FieldPrec := TempFieldDef.Precision;
  1611. // if src = nil then write empty field
  1612. // symmetry with above
  1613. // foxpro has special _nullfield for flagging fields as `null'
  1614. if (FNullField <> nil) and (TempFieldDef.NullPosition >= 0) then
  1615. UpdateNullField(Dst, TempFieldDef, SrcNilToUpdateNullField[Src = nil]);
  1616. // copy field data to record buffer
  1617. Dst := PChar(Dst) + TempFieldDef.Offset;
  1618. asciiContents := false;
  1619. case TempFieldDef.NativeFieldType of
  1620. '+', 'I':
  1621. begin
  1622. if FDbfVersion <> xFoxPro then
  1623. begin
  1624. if Src = nil then
  1625. IntValue := 0
  1626. else
  1627. IntValue := PDWord(Src)^ xor $80000000;
  1628. PDWord(Dst)^ := SwapInt(IntValue);
  1629. end else begin
  1630. if Src = nil then
  1631. PDWord(Dst)^ := 0
  1632. else
  1633. PDWord(Dst)^ := PDWord(Src)^;
  1634. end;
  1635. end;
  1636. 'O':
  1637. begin
  1638. {$ifdef SUPPORT_INT64}
  1639. if Src = nil then
  1640. begin
  1641. PInt64(Dst)^ := 0;
  1642. end else begin
  1643. if PDouble(Src)^ < 0 then
  1644. PLargeInt(Dst)^ := not PLargeInt(Src)^
  1645. else
  1646. PDouble(Dst)^ := (PDouble(Src)^) * -1;
  1647. SwapInt64(Dst, Dst);
  1648. end;
  1649. {$endif}
  1650. end;
  1651. '@':
  1652. begin
  1653. if Src = nil then
  1654. begin
  1655. PInteger(Dst)^ := 0;
  1656. PInteger(PChar(Dst)+4)^ := 0;
  1657. end else begin
  1658. LoadDateFromSrc;
  1659. if FDateTimeHandling = dtBDETimeStamp then
  1660. date := DateTimeToBDETimeStamp(date);
  1661. SwapInt64(@date, Dst);
  1662. end;
  1663. end;
  1664. 'T':
  1665. begin
  1666. // all binary zeroes -> empty datetime
  1667. if Src = nil then
  1668. begin
  1669. PInteger(Dst)^ := 0;
  1670. PInteger(PChar(Dst)+4)^ := 0;
  1671. end else begin
  1672. LoadDateFromSrc;
  1673. timeStamp := DateTimeToTimeStamp(date);
  1674. PInteger(Dst)^ := timeStamp.Date + 1721425;
  1675. PInteger(PChar(Dst)+4)^ := timeStamp.Time;
  1676. end;
  1677. end;
  1678. 'Y':
  1679. begin
  1680. {$ifdef SUPPORT_INT64}
  1681. if Src = nil then
  1682. begin
  1683. PInt64(Dst)^ := 0
  1684. end else begin
  1685. case DataType of
  1686. ftCurrency:
  1687. PInt64(Dst)^ := Trunc(PDouble(Src)^ * 10000);
  1688. ftBCD:
  1689. PCurrency(Dst)^ := PCurrency(Src)^;
  1690. end;
  1691. end;
  1692. // TODO: data is little endian
  1693. {$endif}
  1694. end;
  1695. 'B':
  1696. begin
  1697. if Src = nil then
  1698. PDouble(Dst)^ := 0
  1699. else
  1700. PDouble(Dst)^ := PDouble(Src)^;
  1701. end;
  1702. 'M':
  1703. begin
  1704. if FieldSize = 4 then
  1705. begin
  1706. if Src = nil then
  1707. PInteger(Dst)^ := 0
  1708. else
  1709. PInteger(Dst)^ := PInteger(Src)^;
  1710. end else
  1711. asciiContents := true;
  1712. end;
  1713. else
  1714. asciiContents := true;
  1715. end;
  1716. if asciiContents then
  1717. begin
  1718. if Src = nil then
  1719. begin
  1720. FillChar(Dst^, FieldSize, ' ');
  1721. end else begin
  1722. case DataType of
  1723. ftBoolean:
  1724. begin
  1725. if PWord(Src)^ <> 0 then
  1726. PChar(Dst)^ := 'T'
  1727. else
  1728. PChar(Dst)^ := 'F';
  1729. end;
  1730. ftSmallInt:
  1731. GetStrFromInt_Width(PSmallInt(Src)^, FieldSize, PChar(Dst), #32);
  1732. {$ifdef SUPPORT_INT64}
  1733. ftLargeInt:
  1734. GetStrFromInt64_Width(PLargeInt(Src)^, FieldSize, PChar(Dst), #32);
  1735. {$endif}
  1736. ftFloat, ftCurrency:
  1737. FloatToDbfStr(PDouble(Src)^, FieldSize, FieldPrec, PChar(Dst));
  1738. ftInteger:
  1739. GetStrFromInt_Width(PInteger(Src)^, FieldSize, PChar(Dst),
  1740. IsBlobFieldToPadChar[TempFieldDef.IsBlob]);
  1741. ftDate, ftDateTime:
  1742. begin
  1743. LoadDateFromSrc;
  1744. // decode
  1745. DecodeDate(date, year, month, day);
  1746. // format is yyyymmdd
  1747. GetStrFromInt_Width(year, 4, PChar(Dst), '0');
  1748. GetStrFromInt_Width(month, 2, PChar(Dst)+4, '0');
  1749. GetStrFromInt_Width(day, 2, PChar(Dst)+6, '0');
  1750. // do time too if datetime
  1751. if DataType = ftDateTime then
  1752. begin
  1753. DecodeTime(date, hour, minute, sec, msec);
  1754. // format is hhmmss
  1755. GetStrFromInt_Width(hour, 2, PChar(Dst)+8, '0');
  1756. GetStrFromInt_Width(minute, 2, PChar(Dst)+10, '0');
  1757. GetStrFromInt_Width(sec, 2, PChar(Dst)+12, '0');
  1758. end;
  1759. end;
  1760. ftString:
  1761. begin
  1762. // copy data
  1763. Len := StrLen(Src);
  1764. if Len > FieldSize then
  1765. Len := FieldSize;
  1766. Move(Src^, Dst^, Len);
  1767. // fill remaining space with spaces
  1768. FillChar((PChar(Dst)+Len)^, FieldSize - Len, ' ');
  1769. end;
  1770. end; // case datatype
  1771. end;
  1772. end;
  1773. end;
  1774. procedure TDbfFile.InitDefaultBuffer;
  1775. var
  1776. lRecordSize: integer;
  1777. TempFieldDef: TDbfFieldDef;
  1778. I: Integer;
  1779. begin
  1780. lRecordSize := PDbfHdr(Header)^.RecordSize;
  1781. // clear buffer (assume all string, fix specific fields later)
  1782. // note: Self.RecordSize is used for reading fielddefs too
  1783. GetMem(FDefaultBuffer, lRecordSize+1);
  1784. FillChar(FDefaultBuffer^, lRecordSize, ' ');
  1785. // set nullflags field so that all fields are null
  1786. if FNullField <> nil then
  1787. FillChar(PChar(FDefaultBuffer+FNullField.Offset)^, FNullField.Size, $FF);
  1788. // check binary and default fields
  1789. for I := 0 to FFieldDefs.Count-1 do
  1790. begin
  1791. TempFieldDef := FFieldDefs.Items[I];
  1792. // binary field? (foxpro memo fields are binary, but dbase not)
  1793. if (TempFieldDef.NativeFieldType in ['I', 'O', '@', '+', '0', 'Y'])
  1794. or ((TempFieldDef.NativeFieldType = 'M') and (TempFieldDef.Size = 4)) then
  1795. FillChar(PChar(FDefaultBuffer+TempFieldDef.Offset)^, TempFieldDef.Size, 0);
  1796. // copy default value?
  1797. if TempFieldDef.HasDefault then
  1798. begin
  1799. Move(TempFieldDef.DefaultBuf[0], FDefaultBuffer[TempFieldDef.Offset], TempFieldDef.Size);
  1800. // clear the null flag, this field has a value
  1801. if FNullField <> nil then
  1802. UpdateNullField(FDefaultBuffer, TempFieldDef, unClear);
  1803. end;
  1804. end;
  1805. end;
  1806. procedure TDbfFile.InitRecord(DestBuf: PChar);
  1807. begin
  1808. if FDefaultBuffer = nil then
  1809. InitDefaultBuffer;
  1810. Move(FDefaultBuffer^, DestBuf^, RecordSize);
  1811. end;
  1812. procedure TDbfFile.ApplyAutoIncToBuffer(DestBuf: PChar);
  1813. var
  1814. TempFieldDef: TDbfFieldDef;
  1815. I, NextVal, lAutoIncOffset: {LongWord} Cardinal; {Delphi 3 does not know LongWord?}
  1816. begin
  1817. if FAutoIncPresent then
  1818. begin
  1819. // if shared, reread header to find new autoinc values
  1820. if NeedLocks then
  1821. begin
  1822. // lock header so nobody else can use this value
  1823. LockPage(0, true);
  1824. end;
  1825. // find autoinc fields
  1826. for I := 0 to FFieldDefs.Count-1 do
  1827. begin
  1828. TempFieldDef := FFieldDefs.Items[I];
  1829. if (TempFieldDef.NativeFieldType = '+') then
  1830. begin
  1831. // read current auto inc, from header or field, depending on sharing
  1832. lAutoIncOffset := sizeof(rDbfHdr) + sizeof(rAfterHdrVII) +
  1833. FieldDescVII_AutoIncOffset + I * sizeof(rFieldDescVII);
  1834. // TODO: big-endianness
  1835. if NeedLocks then
  1836. ReadBlock(@NextVal, 4, lAutoIncOffset)
  1837. else
  1838. NextVal := TempFieldDef.AutoInc;
  1839. // store to buffer, positive = high bit on, so flip it
  1840. PCardinal(DestBuf+TempFieldDef.Offset)^ := SwapInt(NextVal or $80000000);
  1841. // increase
  1842. Inc(NextVal);
  1843. TempFieldDef.AutoInc := NextVal;
  1844. // write new value to header buffer
  1845. PCardinal(FHeader+lAutoIncOffset)^ := NextVal;
  1846. end;
  1847. end;
  1848. // write modified header (new autoinc values) to file
  1849. WriteHeader;
  1850. // release lock if locked
  1851. if NeedLocks then
  1852. UnlockPage(0);
  1853. end;
  1854. end;
  1855. procedure TDbfFile.TryExclusive;
  1856. var
  1857. I: Integer;
  1858. begin
  1859. inherited;
  1860. // exclusive succeeded? open index & memo exclusive too
  1861. if Mode in [pfMemoryCreate..pfExclusiveOpen] then
  1862. begin
  1863. // indexes
  1864. for I := 0 to FIndexFiles.Count - 1 do
  1865. TPagedFile(FIndexFiles[I]).TryExclusive;
  1866. // memo
  1867. if FMemoFile <> nil then
  1868. FMemoFile.TryExclusive;
  1869. end;
  1870. end;
  1871. procedure TDbfFile.EndExclusive;
  1872. var
  1873. I: Integer;
  1874. begin
  1875. // end exclusive on index & memo too
  1876. for I := 0 to FIndexFiles.Count - 1 do
  1877. TPagedFile(FIndexFiles[I]).EndExclusive;
  1878. // memo
  1879. if FMemoFile <> nil then
  1880. FMemoFile.EndExclusive;
  1881. // dbf file
  1882. inherited;
  1883. end;
  1884. procedure TDbfFile.OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
  1885. //
  1886. // assumes IndexName is not empty
  1887. //
  1888. const
  1889. // memcr, memop, excr, exopen, rwcr, rwopen, rdonly
  1890. IndexOpenMode: array[boolean, pfMemoryCreate..pfReadOnly] of TPagedFileMode =
  1891. ((pfMemoryCreate, pfMemoryCreate, pfExclusiveOpen, pfExclusiveOpen, pfReadWriteOpen, pfReadWriteOpen,
  1892. pfReadOnly),
  1893. (pfMemoryCreate, pfMemoryCreate, pfExclusiveCreate, pfExclusiveCreate, pfReadWriteCreate, pfReadWriteCreate,
  1894. pfReadOnly));
  1895. var
  1896. lIndexFile: TIndexFile;
  1897. lIndexFileName: string;
  1898. createMdxFile: Boolean;
  1899. addedIndexFile: Integer;
  1900. addedIndexName: Integer;
  1901. begin
  1902. // init
  1903. addedIndexFile := -1;
  1904. addedIndexName := -1;
  1905. createMdxFile := false;
  1906. // index already opened?
  1907. lIndexFile := GetIndexByName(IndexName);
  1908. if (lIndexFile <> nil) and (lIndexFile = FMdxFile) and CreateIndex then
  1909. begin
  1910. // index already exists in MDX file
  1911. // delete it to save space, this causes a repage
  1912. FMdxFile.DeleteIndex(IndexName);
  1913. // index no longer exists
  1914. lIndexFile := nil;
  1915. end;
  1916. if (lIndexFile = nil) and (IndexName <> EmptyStr) then
  1917. begin
  1918. // check if no extension, then create MDX index
  1919. if Length(ExtractFileExt(IndexName)) = 0 then
  1920. begin
  1921. // check if mdx index already opened
  1922. if FMdxFile <> nil then
  1923. begin
  1924. lIndexFileName := EmptyStr;
  1925. lIndexFile := FMdxFile;
  1926. end else begin
  1927. lIndexFileName := ChangeFileExt(FileName, '.mdx');
  1928. createMdxFile := true;
  1929. end;
  1930. end else begin
  1931. lIndexFileName := IndexName;
  1932. end;
  1933. // do we need to open / create file?
  1934. if lIndexFileName <> EmptyStr then
  1935. begin
  1936. // try to open / create the file
  1937. lIndexFile := TIndexFile.Create(Self);
  1938. lIndexFile.FileName := lIndexFileName;
  1939. lIndexFile.Mode := IndexOpenMode[CreateIndex, Mode];
  1940. lIndexFile.AutoCreate := CreateIndex or (Length(IndexField) > 0);
  1941. lIndexFile.CodePage := UseCodePage;
  1942. lIndexFile.OnLocaleError := FOnLocaleError;
  1943. lIndexFile.Open;
  1944. // index file ready for use?
  1945. if not lIndexFile.ForceClose then
  1946. begin
  1947. // if we had to create the index, store that info
  1948. CreateIndex := lIndexFile.FileCreated;
  1949. // check if trying to create empty index
  1950. if CreateIndex and (IndexField = EmptyStr) then
  1951. begin
  1952. FreeAndNil(lIndexFile);
  1953. CreateIndex := false;
  1954. createMdxFile := false;
  1955. end else begin
  1956. // add new index file to list
  1957. addedIndexFile := FIndexFiles.Add(lIndexFile);
  1958. end;
  1959. // created accompanying mdx file?
  1960. if createMdxFile then
  1961. FMdxFile := lIndexFile;
  1962. end else begin
  1963. // asked to close! close file
  1964. FreeAndNil(lIndexFile);
  1965. end;
  1966. end;
  1967. // check if file succesfully opened
  1968. if lIndexFile <> nil then
  1969. begin
  1970. // add index to list
  1971. addedIndexName := FIndexNames.AddObject(IndexName, lIndexFile);
  1972. end;
  1973. end;
  1974. // create it or open it?
  1975. if lIndexFile <> nil then
  1976. begin
  1977. if not CreateIndex then
  1978. if lIndexFile = FMdxFile then
  1979. CreateIndex := lIndexFile.IndexOf(IndexName) < 0;
  1980. if CreateIndex then
  1981. begin
  1982. // try get exclusive mode
  1983. if IsSharedAccess then TryExclusive;
  1984. // always uppercase index expression
  1985. IndexField := AnsiUpperCase(IndexField);
  1986. try
  1987. // create index if asked
  1988. lIndexFile.CreateIndex(IndexField, IndexName, Options);
  1989. // add all records
  1990. PackIndex(lIndexFile, IndexName);
  1991. // if we wanted to open index readonly, but we created it, then reopen
  1992. if Mode = pfReadOnly then
  1993. begin
  1994. lIndexFile.CloseFile;
  1995. lIndexFile.Mode := pfReadOnly;
  1996. lIndexFile.OpenFile;
  1997. end;
  1998. // if mdx file just created, write changes to dbf header
  1999. // set MDX flag to true
  2000. PDbfHdr(Header)^.MDXFlag := 1;
  2001. WriteHeader;
  2002. except
  2003. // :-( need to undo 'damage'....
  2004. // remove index from list(s) if just added
  2005. if addedIndexFile >= 0 then
  2006. FIndexFiles.Delete(addedIndexFile);
  2007. if addedIndexName >= 0 then
  2008. FIndexNames.Delete(addedIndexName);
  2009. // delete index file itself
  2010. lIndexFile.DeleteIndex(IndexName);
  2011. // if no file created, do not destroy!
  2012. if addedIndexFile >= 0 then
  2013. begin
  2014. lIndexFile.Close;
  2015. Sysutils.DeleteFile(lIndexFileName);
  2016. if FMdxFile = lIndexFile then
  2017. FMdxFile := nil;
  2018. lIndexFile.Free;
  2019. end;
  2020. end;
  2021. // return to previous mode
  2022. if TempMode <> pfNone then EndExclusive;
  2023. end;
  2024. end;
  2025. end;
  2026. procedure TDbfFile.PackIndex(lIndexFile: TIndexFile; AIndexName: string);
  2027. var
  2028. prevMode: TIndexUpdateMode;
  2029. prevIndex: string;
  2030. cur, last: Integer;
  2031. {$ifdef USE_CACHE}
  2032. prevCache: Integer;
  2033. {$endif}
  2034. begin
  2035. // save current mode in case we change it
  2036. prevMode := lIndexFile.UpdateMode;
  2037. prevIndex := lIndexFile.IndexName;
  2038. // check if index specified
  2039. if Length(AIndexName) > 0 then
  2040. begin
  2041. // only pack specified index, not all
  2042. lIndexFile.IndexName := AIndexName;
  2043. lIndexFile.ClearIndex;
  2044. lIndexFile.UpdateMode := umCurrent;
  2045. end else begin
  2046. lIndexFile.IndexName := EmptyStr;
  2047. lIndexFile.Clear;
  2048. lIndexFile.UpdateMode := umAll;
  2049. end;
  2050. // prepare update
  2051. cur := 1;
  2052. last := RecordCount;
  2053. {$ifdef USE_CACHE}
  2054. BufferAhead := true;
  2055. prevCache := lIndexFile.CacheSize;
  2056. lIndexFile.CacheSize := GetFreeMemory;
  2057. if lIndexFile.CacheSize < 16384 * 1024 then
  2058. lIndexFile.CacheSize := 16384 * 1024;
  2059. {$endif}
  2060. while cur <= last do
  2061. begin
  2062. ReadRecord(cur, FPrevBuffer);
  2063. lIndexFile.Insert(cur, FPrevBuffer);
  2064. inc(cur);
  2065. end;
  2066. // restore previous mode
  2067. {$ifdef USE_CACHE}
  2068. BufferAhead := false;
  2069. lIndexFile.BufferAhead := true;
  2070. {$endif}
  2071. lIndexFile.Flush;
  2072. {$ifdef USE_CACHE}
  2073. lIndexFile.BufferAhead := false;
  2074. lIndexFile.CacheSize := prevCache;
  2075. {$endif}
  2076. lIndexFile.UpdateMode := prevMode;
  2077. lIndexFile.IndexName := prevIndex;
  2078. end;
  2079. procedure TDbfFile.RepageIndex(AIndexFile: string);
  2080. var
  2081. lIndexNo: Integer;
  2082. begin
  2083. // DBF MDX index?
  2084. if Length(AIndexFile) = 0 then
  2085. begin
  2086. if FMdxFile <> nil then
  2087. begin
  2088. // repage attached mdx
  2089. FMdxFile.RepageFile;
  2090. end;
  2091. end else begin
  2092. // search index file
  2093. lIndexNo := FIndexNames.IndexOf(AIndexFile);
  2094. // index found?
  2095. if lIndexNo >= 0 then
  2096. TIndexFile(FIndexNames.Objects[lIndexNo]).RepageFile;
  2097. end;
  2098. end;
  2099. procedure TDbfFile.CompactIndex(AIndexFile: string);
  2100. var
  2101. lIndexNo: Integer;
  2102. begin
  2103. // DBF MDX index?
  2104. if Length(AIndexFile) = 0 then
  2105. begin
  2106. if FMdxFile <> nil then
  2107. begin
  2108. // repage attached mdx
  2109. FMdxFile.CompactFile;
  2110. end;
  2111. end else begin
  2112. // search index file
  2113. lIndexNo := FIndexNames.IndexOf(AIndexFile);
  2114. // index found?
  2115. if lIndexNo >= 0 then
  2116. TIndexFile(FIndexNames.Objects[lIndexNo]).CompactFile;
  2117. end;
  2118. end;
  2119. procedure TDbfFile.CloseIndex(AIndexName: string);
  2120. var
  2121. lIndexNo: Integer;
  2122. lIndex: TIndexFile;
  2123. begin
  2124. // search index file
  2125. lIndexNo := FIndexNames.IndexOf(AIndexName);
  2126. // don't close mdx file
  2127. if (lIndexNo >= 0) then
  2128. begin
  2129. // get index pointer
  2130. lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
  2131. if (lIndex <> FMdxFile) then
  2132. begin
  2133. // close file
  2134. lIndex.Free;
  2135. // remove from lists
  2136. FIndexFiles.Remove(lIndex);
  2137. FIndexNames.Delete(lIndexNo);
  2138. // was this the current index?
  2139. if (FCurIndex = lIndexNo) then
  2140. begin
  2141. FCurIndex := -1;
  2142. //FCursor := FDbfCursor;
  2143. end;
  2144. end;
  2145. end;
  2146. end;
  2147. function TDbfFile.DeleteIndex(const AIndexName: string): Boolean;
  2148. var
  2149. lIndexNo: Integer;
  2150. lIndex: TIndexFile;
  2151. lFileName: string;
  2152. begin
  2153. // search index file
  2154. lIndexNo := FIndexNames.IndexOf(AIndexName);
  2155. Result := lIndexNo >= 0;
  2156. // found index?
  2157. if Result then
  2158. begin
  2159. // can only delete indexes from MDX files
  2160. lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
  2161. if lIndex = FMdxFile then
  2162. begin
  2163. lIndex.DeleteIndex(AIndexName);
  2164. // remove it from the list
  2165. FIndexNames.Delete(lIndexNo);
  2166. // no more MDX indexes?
  2167. lIndexNo := FIndexNames.IndexOfObject(FMdxFile);
  2168. if lIndexNo = -1 then
  2169. begin
  2170. // no MDX indexes left
  2171. lIndexNo := FIndexFiles.IndexOf(FMdxFile);
  2172. if lIndexNo >= 0 then
  2173. FIndexFiles.Delete(lIndexNo);
  2174. lFileName := FMdxFile.FileName;
  2175. FreeAndNil(FMdxFile);
  2176. // erase file
  2177. Sysutils.DeleteFile(lFileName);
  2178. // clear mdx flag
  2179. PDbfHdr(Header)^.MDXFlag := 0;
  2180. WriteHeader;
  2181. end;
  2182. end else begin
  2183. // close index first
  2184. CloseIndex(AIndexName);
  2185. // delete file from disk
  2186. SysUtils.DeleteFile(AIndexName);
  2187. end;
  2188. end;
  2189. end;
  2190. function TDbfFile.Insert(Buffer: PChar): integer;
  2191. var
  2192. newRecord: Integer;
  2193. lIndex: TIndexFile;
  2194. error: Boolean;
  2195. procedure RollBackIndexesAndRaise(HighIndex: Integer; IndexError: Boolean);
  2196. var
  2197. errorMsg: string;
  2198. I: Integer;
  2199. begin
  2200. // rollback committed indexes
  2201. error := IndexError;
  2202. for I := 0 to HighIndex do
  2203. begin
  2204. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2205. lIndex.Delete(newRecord, Buffer);
  2206. if lIndex.WriteError then
  2207. begin
  2208. lIndex.ResetError;
  2209. error := true;
  2210. end;
  2211. end;
  2212. // reset any dbf file error
  2213. ResetError;
  2214. // if part of indexes committed -> always index error msg
  2215. // if error while rolling back index -> index error msg
  2216. if error then
  2217. errorMsg := STRING_WRITE_INDEX_ERROR
  2218. else
  2219. errorMsg := STRING_WRITE_ERROR;
  2220. raise EDbfWriteError.Create(errorMsg);
  2221. end;
  2222. var
  2223. I: Integer;
  2224. begin
  2225. // get new record index
  2226. Result := 0;
  2227. newRecord := RecordCount+1;
  2228. // lock record so we can write data
  2229. while not LockPage(newRecord, false) do
  2230. Inc(newRecord);
  2231. // write autoinc value
  2232. ApplyAutoIncToBuffer(Buffer);
  2233. // check indexes -> possible key violation
  2234. I := 0; error := false;
  2235. while (I < FIndexFiles.Count) and not error do
  2236. begin
  2237. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2238. error := lIndex.CheckKeyViolation(Buffer);
  2239. Inc(I);
  2240. end;
  2241. // error occured while inserting? -> abort
  2242. if error then
  2243. begin
  2244. UnlockPage(newRecord);
  2245. lIndex.InsertError;
  2246. // don't have to exit -- unreachable code
  2247. end;
  2248. // no key violation, insert record into index(es)
  2249. for I := 0 to FIndexFiles.Count-1 do
  2250. begin
  2251. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2252. lIndex.Insert(newRecord, Buffer);
  2253. if lIndex.WriteError then
  2254. begin
  2255. // if there's an index write error, I shouldn't
  2256. // try to write the dbf header and the new record,
  2257. // but raise an exception right away
  2258. RollBackIndexesAndRaise(I, True);
  2259. end;
  2260. end;
  2261. // indexes ok -> continue inserting
  2262. // update header record count
  2263. LockPage(0, true);
  2264. // read current header
  2265. ReadHeader;
  2266. // increase current record count
  2267. Inc(PDbfHdr(Header)^.RecordCount);
  2268. // write header to disk
  2269. WriteHeader;
  2270. // done with header
  2271. UnlockPage(0);
  2272. if WriteError then
  2273. begin
  2274. // couldn't write header, so I shouldn't
  2275. // even try to write the record.
  2276. //
  2277. // At this point I should "roll back"
  2278. // the already written index records.
  2279. // if this fails, I'm in deep trouble!
  2280. RollbackIndexesAndRaise(FIndexFiles.Count-1, False);
  2281. end;
  2282. // write locking info
  2283. if FLockField <> nil then
  2284. WriteLockInfo(Buffer);
  2285. // write buffer to disk
  2286. WriteRecord(newRecord, Buffer);
  2287. // done updating, unlock
  2288. UnlockPage(newRecord);
  2289. // error occurred while writing?
  2290. if WriteError then
  2291. begin
  2292. // -- Tobias --
  2293. // The record couldn't be written, so
  2294. // the written index records and the
  2295. // change to the header have to be
  2296. // rolled back
  2297. LockPage(0, true);
  2298. ReadHeader;
  2299. Dec(PDbfHdr(Header)^.RecordCount);
  2300. WriteHeader;
  2301. UnlockPage(0);
  2302. // roll back indexes too
  2303. RollbackIndexesAndRaise(FIndexFiles.Count-1, False);
  2304. end else
  2305. Result := newRecord;
  2306. end;
  2307. procedure TDbfFile.WriteLockInfo(Buffer: PChar);
  2308. //
  2309. // *) assumes FHasLockField = true
  2310. //
  2311. var
  2312. year, month, day, hour, minute, sec, msec: Word;
  2313. lockoffset: integer;
  2314. begin
  2315. // increase change count
  2316. lockoffset := FLockField.Offset;
  2317. Inc(PWord(Buffer+lockoffset)^);
  2318. // set time
  2319. DecodeDate(Now(), year, month, day);
  2320. DecodeTime(Now(), hour, minute, sec, msec);
  2321. Buffer[lockoffset+2] := Char(hour);
  2322. Buffer[lockoffset+3] := Char(minute);
  2323. Buffer[lockoffset+4] := Char(sec);
  2324. // set date
  2325. Buffer[lockoffset+5] := Char(year - 1900);
  2326. Buffer[lockoffset+6] := Char(month);
  2327. Buffer[lockoffset+7] := Char(day);
  2328. // set name
  2329. FillChar(Buffer[lockoffset+8], FLockField.Size-8, ' ');
  2330. Move(DbfGlobals.UserName[1], Buffer[lockoffset+8], FLockUserLen);
  2331. end;
  2332. procedure TDbfFile.LockRecord(RecNo: Integer; Buffer: PChar);
  2333. begin
  2334. if LockPage(RecNo, false) then
  2335. begin
  2336. // reread data
  2337. ReadRecord(RecNo, Buffer);
  2338. // store previous data for updating indexes
  2339. Move(Buffer^, FPrevBuffer^, RecordSize);
  2340. // lock succeeded, update lock info, if field present
  2341. if FLockField <> nil then
  2342. begin
  2343. // update buffer
  2344. WriteLockInfo(Buffer);
  2345. // write to disk
  2346. WriteRecord(RecNo, Buffer);
  2347. end;
  2348. end else
  2349. raise EDbfError.Create(STRING_RECORD_LOCKED);
  2350. end;
  2351. procedure TDbfFile.UnlockRecord(RecNo: Integer; Buffer: PChar);
  2352. var
  2353. I: Integer;
  2354. lIndex: TIndexFile;
  2355. begin
  2356. // update indexes, possible key violation
  2357. for I := 0 to FIndexFiles.Count - 1 do
  2358. begin
  2359. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2360. lIndex.Update(RecNo, FPrevBuffer, Buffer);
  2361. end;
  2362. // write new record buffer, all keys ok
  2363. WriteRecord(RecNo, Buffer);
  2364. // done updating, unlock
  2365. UnlockPage(RecNo);
  2366. end;
  2367. procedure TDbfFile.RecordDeleted(RecNo: Integer; Buffer: PChar);
  2368. var
  2369. I: Integer;
  2370. lIndex: TIndexFile;
  2371. begin
  2372. // notify indexes: record deleted
  2373. for I := 0 to FIndexFiles.Count - 1 do
  2374. begin
  2375. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2376. lIndex.RecordDeleted(RecNo, Buffer);
  2377. end;
  2378. end;
  2379. procedure TDbfFile.RecordRecalled(RecNo: Integer; Buffer: PChar);
  2380. var
  2381. I: Integer;
  2382. lIndex: TIndexFile;
  2383. begin
  2384. // notify indexes: record recalled
  2385. for I := 0 to FIndexFiles.Count - 1 do
  2386. begin
  2387. lIndex := TIndexFile(FIndexFiles.Items[I]);
  2388. lIndex.RecordRecalled(RecNo, Buffer);
  2389. end;
  2390. end;
  2391. procedure TDbfFile.SetRecordSize(NewSize: Integer);
  2392. begin
  2393. if NewSize <> RecordSize then
  2394. begin
  2395. if FPrevBuffer <> nil then
  2396. FreeMemAndNil(Pointer(FPrevBuffer));
  2397. if NewSize > 0 then
  2398. GetMem(FPrevBuffer, NewSize);
  2399. end;
  2400. inherited;
  2401. end;
  2402. function TDbfFile.GetIndexByName(AIndexName: string): TIndexFile;
  2403. var
  2404. I: Integer;
  2405. begin
  2406. I := FIndexNames.IndexOf(AIndexName);
  2407. if I >= 0 then
  2408. Result := TIndexFile(FIndexNames.Objects[I])
  2409. else
  2410. Result := nil;
  2411. end;
  2412. //====================================================================
  2413. // TDbfCursor
  2414. //====================================================================
  2415. constructor TDbfCursor.Create(DbfFile: TDbfFile);
  2416. begin
  2417. inherited Create(DbfFile);
  2418. end;
  2419. function TDbfCursor.Next: Boolean;
  2420. begin
  2421. if TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo) then
  2422. begin
  2423. inc(FPhysicalRecNo);
  2424. Result := TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo);
  2425. end else begin
  2426. FPhysicalRecNo := TDbfFile(PagedFile).CachedRecordCount + 1;
  2427. Result := false;
  2428. end;
  2429. end;
  2430. function TDbfCursor.Prev: Boolean;
  2431. begin
  2432. if FPhysicalRecNo > 0 then
  2433. dec(FPhysicalRecNo)
  2434. else
  2435. FPhysicalRecNo := 0;
  2436. Result := FPhysicalRecNo > 0;
  2437. end;
  2438. procedure TDbfCursor.First;
  2439. begin
  2440. FPhysicalRecNo := 0;
  2441. end;
  2442. procedure TDbfCursor.Last;
  2443. var
  2444. max: Integer;
  2445. begin
  2446. max := TDbfFile(PagedFile).RecordCount;
  2447. if max = 0 then
  2448. FPhysicalRecNo := 0
  2449. else
  2450. FPhysicalRecNo := max + 1;
  2451. end;
  2452. function TDbfCursor.GetPhysicalRecNo: Integer;
  2453. begin
  2454. Result := FPhysicalRecNo;
  2455. end;
  2456. procedure TDbfCursor.SetPhysicalRecNo(RecNo: Integer);
  2457. begin
  2458. FPhysicalRecNo := RecNo;
  2459. end;
  2460. function TDbfCursor.GetSequentialRecordCount: Integer;
  2461. begin
  2462. Result := TDbfFile(PagedFile).RecordCount;
  2463. end;
  2464. function TDbfCursor.GetSequentialRecNo: Integer;
  2465. begin
  2466. Result := FPhysicalRecNo;
  2467. end;
  2468. procedure TDbfCursor.SetSequentialRecNo(RecNo: Integer);
  2469. begin
  2470. FPhysicalRecNo := RecNo;
  2471. end;
  2472. // codepage enumeration procedure
  2473. var
  2474. TempCodePageList: TList;
  2475. // LPTSTR = PChar ok?
  2476. function CodePagesProc(CodePageString: PChar): Cardinal; stdcall;
  2477. begin
  2478. // add codepage to list
  2479. TempCodePageList.Add(Pointer(GetIntFromStrLength(CodePageString, StrLen(CodePageString), -1)));
  2480. // continue enumeration
  2481. Result := 1;
  2482. end;
  2483. //====================================================================
  2484. // TDbfGlobals
  2485. //====================================================================
  2486. constructor TDbfGlobals.Create;
  2487. begin
  2488. FCodePages := TList.Create;
  2489. FDefaultOpenCodePage := GetACP;
  2490. // the following sets FDefaultCreateLangId
  2491. DefaultCreateCodePage := GetACP;
  2492. FCurrencyAsBCD := true;
  2493. // determine which code pages are installed
  2494. TempCodePageList := FCodePages;
  2495. EnumSystemCodePages(@CodePagesProc, {CP_SUPPORTED} CP_INSTALLED);
  2496. TempCodePageList := nil;
  2497. InitUserName;
  2498. end;
  2499. procedure TDbfGlobals.InitUserName;
  2500. {$ifdef FPC}
  2501. {$ifndef WIN32}
  2502. var
  2503. TempName: UTSName;
  2504. {$endif}
  2505. {$endif}
  2506. begin
  2507. {$ifdef WIN32}
  2508. FUserNameLen := MAX_COMPUTERNAME_LENGTH+1;
  2509. SetLength(FUserName, FUserNameLen);
  2510. // Windows.GetUserName(@FUserName[0], FUserNameLen);
  2511. Windows.GetComputerName(PChar(FUserName), FUserNameLen);
  2512. SetLength(FUserName, FUserNameLen);
  2513. {$else}
  2514. {$ifdef FPC}
  2515. FpUname(TempName);
  2516. FUserName := TempName.machine;
  2517. FUserNameLen := Length(FUserName);
  2518. {$endif}
  2519. {$endif}
  2520. end;
  2521. destructor TDbfGlobals.Destroy; {override;}
  2522. begin
  2523. FCodePages.Free;
  2524. end;
  2525. function TDbfGlobals.GetDefaultCreateCodePage: Integer;
  2526. begin
  2527. Result := LangId_To_CodePage[FDefaultCreateLangId];
  2528. end;
  2529. procedure TDbfGlobals.SetDefaultCreateCodePage(NewCodePage: Integer);
  2530. begin
  2531. FDefaultCreateLangId := ConstructLangId(NewCodePage, GetUserDefaultLCID, false);
  2532. end;
  2533. function TDbfGlobals.CodePageInstalled(ACodePage: Integer): Boolean;
  2534. begin
  2535. Result := FCodePages.IndexOf(Pointer(ACodePage)) >= 0;
  2536. end;
  2537. initialization
  2538. finalization
  2539. FreeAndNil(DbfGlobals);
  2540. (*
  2541. Stuffs non implemented yet
  2542. TFoxCDXHeader = Record
  2543. PointerRootNode : Integer;
  2544. PointerFreeList : Integer;
  2545. Reserved_8_11 : Cardinal;
  2546. KeyLength : Word;
  2547. IndexOption : Byte;
  2548. IndexSignature : Byte;
  2549. Reserved_Null : TFoxReservedNull;
  2550. SortOrder : Word;
  2551. TotalExpressionLen : Word;
  2552. ForExpressionLen : Word;
  2553. Reserved_506_507 : Word;
  2554. KeyExpressionLen : Word;
  2555. KeyForExpression : TKeyForExpression;
  2556. End;
  2557. PFoxCDXHeader = ^TFoxCDXHeader;
  2558. TFoxCDXNodeCommon = Record
  2559. NodeAttributes : Word;
  2560. NumberOfKeys : Word;
  2561. PointerLeftNode : Integer;
  2562. PointerRightNode : Integer;
  2563. End;
  2564. TFoxCDXNodeNonLeaf = Record
  2565. NodeCommon : TFoxCDXNodeCommon;
  2566. TempBlock : Array [12..511] of Byte;
  2567. End;
  2568. PFoxCDXNodeNonLeaf = ^TFoxCDXNodeNonLeaf;
  2569. TFoxCDXNodeLeaf = Packed Record
  2570. NodeCommon : TFoxCDXNodeCommon;
  2571. BlockFreeSpace : Word;
  2572. RecordNumberMask : Integer;
  2573. DuplicateCountMask : Byte;
  2574. TrailByteCountMask : Byte;
  2575. RecNoBytes : Byte;
  2576. DuplicateCountBytes : Byte;
  2577. TrailByteCountBytes : Byte;
  2578. HoldingByteCount : Byte;
  2579. DataBlock : TDataBlock;
  2580. End;
  2581. PFoxCDXNodeLeaf = ^TFoxCDXNodeLeaf;
  2582. *)
  2583. end.