dbf.pas 76 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896
  1. unit dbf;
  2. {===============================================================================
  3. || TDbf Component || http://tdbf.netfirms.com ||
  4. ===============================================================================}
  5. interface
  6. uses
  7. {$ifdef fpc}
  8. SysUtils, Classes, db;
  9. {$else}
  10. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  11. Db, DsgnIntf, ExptIntf;
  12. {$endif}
  13. // If you got a compilation error here or asking for dsgntf.pas, then just add
  14. // this file in your project:
  15. // dsgnintf.pas in 'C:\Program Files\Borland\Delphi5\Source\Toolsapi\dsgnintf.pas'
  16. const
  17. _MAJOR_VERSION = 3;
  18. _MINOR_VERSION = 007;
  19. {$ifdef VER100} // Delphi 3
  20. {$define DELPHI_3}
  21. {$endif}
  22. {$ifdef VER110} // CBuilder 3
  23. {$define DELPHI_3}
  24. {$endif}
  25. {$ifdef linux}
  26. DirSeparator = '/';
  27. {$else}
  28. DirSeparator = '\';
  29. {$endif}
  30. //====================================================================
  31. // Delphi is a bit to permissive for me, I mean protected doesn't work within
  32. // one unit. So i decided that convention:
  33. // private member begins by '_'
  34. // It's forbidden to access any '_something' except from the class where it
  35. // is defined. To check that, I just have to look for '._' anywhere in the code.
  36. //====================================================================
  37. type
  38. //====================================================================
  39. //=== Common exceptions and constants
  40. //====================================================================
  41. EBinaryDataSetError = class (Exception);
  42. EFieldToLongError = class (Exception);
  43. xBaseVersion = (xBaseIII,xBaseIV,xBaseV);
  44. //====================================================================
  45. //=== Utility classes
  46. //====================================================================
  47. TPagedFile = class(TObject)
  48. protected
  49. Stream : TStream;
  50. HeaderSize : Integer;
  51. RecordSize : Integer;
  52. _cntuse:integer;
  53. _Filename:string;
  54. public
  55. constructor Create(const FileName: string; Mode: Word);
  56. destructor Destroy; override;
  57. procedure Release;
  58. function CalcRecordCount:Integer;
  59. procedure _Seek(page:Integer);
  60. procedure ReadRecord(IntRecNum:Integer;Buffer:Pointer);
  61. procedure WriteRecord(IntRecNum:Integer;Buffer:Pointer);
  62. end;
  63. //====================================================================
  64. //=== Dbf support (first part)
  65. //====================================================================
  66. rDbfHdr = record
  67. VerDBF : byte; // 0
  68. Year : byte; // 1
  69. Month : byte; // 2
  70. Day : byte; // 3
  71. RecordCount : Integer; // 4-7
  72. FullHdrSize : word; // 8-9
  73. RecordSize : word; // 10-11
  74. Dummy1 : Word; // 12-13
  75. IncTrans : byte; // 14
  76. Encrypt : byte; // 15
  77. Dummy2 : Integer; // 16-19
  78. Dummy3 : array[20..27] of byte; // 20-27
  79. MDXFlag : char; // 28
  80. Language : char; // 29
  81. dummy4 : word; // 30-31
  82. end;
  83. //====================================================================
  84. TMyFieldInfo = class
  85. public
  86. FieldName:string;
  87. Size:Integer;
  88. Prec:Integer;
  89. Offset:Integer;
  90. end;
  91. //====================================================================
  92. TDbfFile = class(TPagedFile)
  93. protected
  94. _RecordBufferSize:integer;
  95. _DataHdr : rDbfHdr;
  96. _DbfVersion : xBaseVersion;
  97. _MyFieldInfos: TList;
  98. public
  99. constructor Create(const FileName: string; Mode: Word);
  100. destructor Destroy; override;
  101. function RecordCount:integer;
  102. procedure CreateFieldDefs(FieldDefs:TFieldDefs);
  103. procedure ClearMyFieldInfos;
  104. procedure DbfFile_CreateTable(FieldDefs:TFieldDefs);
  105. procedure DbfFile_PackTable;
  106. function GetFieldInfo(FieldName:string):TMyFieldInfo;
  107. function GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst: Pointer): Boolean;
  108. procedure SetFieldData(Column:integer;DataType:TFieldType; Src,Dst: Pointer);
  109. procedure WriteHeader;
  110. end;
  111. //====================================================================
  112. //=== Index support
  113. //====================================================================
  114. TIndex = class;
  115. //====================================================================
  116. rNdxHdr = record
  117. startpage : Integer; // 0..3
  118. nbPage : Integer; // 4..7
  119. keyformat: Char; //8
  120. keytype : char; //9
  121. dummy : Word; // 10..11
  122. keylen : Word; // 12..13
  123. nbkey : Word; // 14..15
  124. skeytype : Word; // 16..17
  125. keyreclen : Word; // 18..19
  126. dummy2 : Word; // 20..21
  127. dummy3 : Byte; // 22
  128. Unique : Byte; // 23
  129. KeyDesc : array[0..255] of char; // 24...
  130. end;
  131. rMdxTag = record
  132. pageno : Integer; // 0..3
  133. tagname : array [0..11] of char; // 4..14
  134. keyformat : byte; // 15
  135. forwardTag1 : char; // 16
  136. forwardTag2 : byte; // 17
  137. backwardTag : byte; // 18
  138. dummy : byte; // 19
  139. keytype : byte; // 20
  140. end;
  141. NdxKeyType = (N,C);
  142. PNdxPage = ^rNdxPage;
  143. rNdxPage = record
  144. NbEntries : longint; // 0..3 lower page
  145. Entries : ARRAY [0..507] OF char;
  146. end;
  147. PNdxentry = ^rNdxentry;
  148. rNdxentry = record
  149. _LowerPage : longint; // 0..3 lower page
  150. RecNo : Longint; // 4..7 recno
  151. case NdxKeyType of
  152. N: ( NKey: double);
  153. C: ( CKey: array [0..503] of char);
  154. end;
  155. //====================================================================
  156. rMdxHdr = record
  157. MdxHdr : byte; // 0
  158. Year : byte; // 1
  159. Month : byte; // 2
  160. Day : byte; // 3
  161. FileName : array[0..15] of char; // 4..19 of byte
  162. BlockSize : word; // 20 21
  163. BlockAdder : word; // 22 23
  164. IndexFlag : byte; // 24
  165. NoTag : byte; // 25
  166. TagSize : byte; // 26
  167. Dummy1 : byte; // 27
  168. TagUsed : word; // 28..29
  169. Dummy2 : word; // 30..31
  170. NbPage : Integer; // 32..35
  171. FreePage : Integer; // 36..39
  172. BlockFree : Integer; // 40..43
  173. UpdYear : byte; // 44
  174. UpdMonth : byte; // 45
  175. UpdDay : byte; // 46
  176. end;
  177. //====================================================================
  178. TIndexFile = class(TPagedFile)
  179. protected
  180. _IndexVersion : xBaseVersion;
  181. _MdxHdr : rMdxHdr;
  182. public
  183. constructor Create(const FileName: string; Mode: Word);
  184. destructor Destroy; override;
  185. end;
  186. //====================================================================
  187. PIndexPosInfo = ^TIndexPage;
  188. TIndexPage = class
  189. protected
  190. _Index : TIndex;
  191. _PageNo : Integer;
  192. _EntryNo : Integer;
  193. Entry : PNdxentry;
  194. _LowerLevel : TIndexPage;
  195. _UpperLevel : TIndexPage;
  196. _PageBuff:rNdxPage;
  197. procedure LocalFirst;
  198. procedure LocalLast;
  199. function LocalPrev:boolean;
  200. function LocalNext:boolean;
  201. function LastEntryNo:integer;
  202. function LocalInsert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
  203. function LocalDelete:boolean;
  204. function GetPEntry(EntryNo:integer):PNdxEntry;
  205. procedure First;
  206. procedure Last;
  207. function Prev:boolean;
  208. function Next:boolean;
  209. procedure Write;
  210. procedure AddNewLevel;
  211. public
  212. constructor Create(Parent:TIndex);
  213. destructor Destroy; override;
  214. procedure SetPageNo(page:Integer);
  215. procedure SetEntryNo(entryno:Integer);
  216. procedure WritePage(Page:integer);
  217. function FindNearest(Recno:integer; Key:PChar):integer;
  218. function Insert(Recno:integer; Buffer:pchar; LowerPage:integer):boolean;
  219. procedure SetEntry(Recno:integer; key:pchar; LowerPage:integer);
  220. function Delete:boolean;
  221. function LowerLevel : TIndexPage;
  222. end;
  223. //====================================================================
  224. TIndex = class(TObject)
  225. protected
  226. _IndexFile:TIndexFile;
  227. _NdxHdr:rNdxHdr;
  228. _Root:TIndexPage;
  229. _TagPosition:Integer;
  230. _FieldPos : integer;
  231. _FieldLen : integer;
  232. _NbLevel : integer;
  233. _RootPage: integer;
  234. function Pos:TIndexPage;
  235. public
  236. IndexRecNo:integer;
  237. function Prev:boolean;
  238. function Next:boolean;
  239. procedure First;
  240. procedure Last;
  241. function Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
  242. procedure Insert(Recno:integer; Buffer:PChar);
  243. function Delete:boolean;
  244. procedure GotoKey(Recno:integer; Buffer:PChar);
  245. procedure Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
  246. // procedure ResyncInd;
  247. function GetRealRecNo: Integer;
  248. constructor Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
  249. procedure InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
  250. destructor Destroy; override;
  251. // optionnal
  252. function GuessRecordCount: Integer;
  253. function GuessRecNo: Integer;
  254. end;
  255. //====================================================================
  256. //=== Memo and binary fields support
  257. //====================================================================
  258. rDbtHdr = record
  259. NextBlock:Longint;
  260. Dummy : array [4..7] of byte;
  261. _dbfFile : array [0..7] of Byte; //8..15
  262. bVer : Byte; //16
  263. Dummy2 : array [17..19] of byte;
  264. BlockLen: Word;
  265. end;
  266. //====================================================================
  267. TDbtFile = class(TPagedFile)
  268. protected
  269. _DbtVersion:xBaseVersion;
  270. _MemoHdr:rDbtHdr;
  271. public
  272. constructor Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
  273. procedure ReadMemo(recno:Integer;Dst:TStream);
  274. procedure WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
  275. end;
  276. //====================================================================
  277. TMyBlobFile = class(TMemoryStream)
  278. public
  279. Mode: TBlobStreamMode;
  280. Field:TField;
  281. MemoRecno:Integer;
  282. ReadSize:Integer;
  283. constructor Create(ModeVal:TBlobStreamMode; FieldVal:TField);
  284. destructor destroy; override;
  285. end;
  286. //====================================================================
  287. //=== Dbf support 2
  288. //====================================================================
  289. rFieldHdrIII = record
  290. FieldName : array[0..10] of char;
  291. FieldType : char; // 11
  292. Dummy : array[12..15] of byte;
  293. FieldSize : byte; // 16
  294. FieldPrecision : byte; //17
  295. dummy2 : array[18..31] of byte;
  296. end;
  297. //====================================================================
  298. rFieldHdrV = record
  299. FieldName : array[0..10] of char;
  300. Dummy0 : array[11..31] of byte;
  301. FieldType : char; // 32
  302. FieldSize : byte; // 33
  303. FieldPrecision : byte; //34
  304. dummy2 : array[35..47] of byte;
  305. end;
  306. //====================================================================
  307. PBookMarkData = ^rBookMarkData;
  308. rBookmarkData = record
  309. RecNo:longint;
  310. end;
  311. //====================================================================
  312. rBeforeRecord = record
  313. BookmarkData: rBookmarkData;
  314. BookmarkFlag: TBookmarkFlag;
  315. //... record come here
  316. end;
  317. //====================================================================
  318. pDbfRecord = ^rDbfRecord;
  319. rDbfRecord = record
  320. BookmarkData: rBookmarkData;
  321. BookmarkFlag: TBookmarkFlag;
  322. DeletedFlag : char;
  323. Fields : array[0..4000] of char;
  324. end;
  325. //====================================================================
  326. PRecInfo = ^TRecInfo;
  327. TRecInfo = record
  328. Bookmark: Longint;
  329. IdxBookmark: Longint;
  330. BookmarkFlag: TBookmarkFlag;
  331. end;
  332. //====================================================================
  333. pRecordHdr = ^tRecordHdr;
  334. tRecordHdr = record
  335. DeletedFlag : char;
  336. end;
  337. // and at LEAST the most useful class : TDbf
  338. //====================================================================
  339. TDbf = class(TDataSet)
  340. private
  341. _ShowDeleted:boolean;
  342. _TableName: string; // table path and file name
  343. _RunTimePath: string; // table path and file name
  344. _DesignTimePath: string; // table path and file name
  345. _ReadOnly : Boolean;
  346. _FilterBuffer:pchar;
  347. _PrevBuffer:pchar;
  348. _IndexFiles:TStrings;
  349. protected
  350. function _FullRecordSize:integer;
  351. function _FilterRecord(Buffer: PChar): Boolean;
  352. procedure _OpenFiles(CreateIt:boolean);
  353. procedure _CloseFiles;
  354. procedure _ResyncIndexes(Buffer: PChar);
  355. function _GetIndexName: string;
  356. procedure _SetIndexName(const Value: string);
  357. function _GetIndex(filename:string):TIndex;
  358. function _GetPath:string;
  359. function _ComponentInfo:string;
  360. public
  361. { my own methods and properties}
  362. { most looks like ttable functions but they are not tdataset related
  363. I use the same syntax to facilitate the conversion between bde and tdbf }
  364. easyfilter:string;
  365. procedure CreateTable; //(FieldDefs:TFieldDefs);
  366. procedure DeleteIndex(const AName: string);
  367. property IndexName: string read _GetIndexName write _SetIndexName;
  368. {$ifdef DELPHI_3}
  369. procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
  370. {$else}
  371. {$ifndef FPC}
  372. procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
  373. {$else}
  374. procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);
  375. procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);
  376. {$endif}
  377. {$endif}
  378. procedure CloseIndexFile(const IndexFileName: string);
  379. procedure OpenIndexFile(AnIndexName:string);
  380. procedure PackTable;
  381. public
  382. { abstract methods }
  383. function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; {virtual abstract}
  384. {virtual methods (mostly optionnal) }
  385. function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
  386. {$ifdef DELPHI_3}
  387. procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
  388. {$else}
  389. {$ifdef fpc}
  390. procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
  391. {$else}
  392. function Translate(Src, Dest: PChar; ToOem: Boolean): Integer; override; {virtual}
  393. {$endif}
  394. {$endif}
  395. procedure ClearCalcFields(Buffer : PChar); override;
  396. protected
  397. { abstract methods }
  398. function AllocRecordBuffer: PChar; override; {virtual abstract}
  399. procedure FreeRecordBuffer(var Buffer: PChar); override; {virtual abstract}
  400. procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
  401. function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; {virtual abstract}
  402. function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; {virtual abstract}
  403. function GetRecordSize: Word; override; {virtual abstract}
  404. procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override; {virtual abstract}
  405. procedure InternalClose; override; {virtual abstract}
  406. procedure InternalDelete; override; {virtual abstract}
  407. procedure InternalFirst; override; {virtual abstract}
  408. procedure InternalGotoBookmark(ABookmark: Pointer); override; {virtual abstract}
  409. procedure InternalHandleException; override; {virtual abstract}
  410. procedure InternalInitFieldDefs; override; {virtual abstract}
  411. procedure InternalInitRecord(Buffer: PChar); override; {virtual abstract}
  412. procedure InternalLast; override; {virtual abstract}
  413. procedure InternalOpen; override; {virtual abstract}
  414. procedure InternalPost; override; {virtual abstract}
  415. procedure InternalSetToRecord(Buffer: PChar); override; {virtual abstract}
  416. function IsCursorOpen: Boolean; override; {virtual abstract}
  417. procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; {virtual abstract}
  418. procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
  419. procedure SetFieldData(Field: TField; Buffer: Pointer); override; {virtual abstract}
  420. {virtual methods (mostly optionnal) }
  421. function GetRecordCount: Integer; override; {virtual}
  422. function GetRecNo: Integer; override; {virtual}
  423. procedure SetRecNo(Value: Integer); override; {virual}
  424. public
  425. constructor Create(AOwner: TComponent); override;
  426. destructor Destroy; override;
  427. published
  428. property ComponentInfo: string read _ComponentInfo;
  429. property TableName: string read _TableName write _TableName;
  430. property RunTimePath: string read _RunTimePath write _RunTimePath;
  431. property DesignTimePath: string read _DesignTimePath write _DesignTimePath;
  432. property ReadOnly : Boolean read _ReadOnly write _Readonly default False;
  433. property ShowDeleted:boolean read _ShowDeleted write _ShowDeleted;
  434. // redeclared data set properties
  435. property Active;
  436. property Filtered;
  437. property BeforeOpen;
  438. property AfterOpen;
  439. property BeforeClose;
  440. property AfterClose;
  441. property BeforeInsert;
  442. property AfterInsert;
  443. property BeforeEdit;
  444. property AfterEdit;
  445. property BeforePost;
  446. property AfterPost;
  447. property BeforeCancel;
  448. property AfterCancel;
  449. property BeforeDelete;
  450. property AfterDelete;
  451. property BeforeScroll;
  452. property AfterScroll;
  453. property OnCalcFields;
  454. property OnDeleteError;
  455. property OnEditError;
  456. property OnFilterRecord;
  457. property OnNewRecord;
  458. property OnPostError;
  459. //my datas....
  460. protected
  461. _IsCursorOpen:boolean;
  462. _PhysicalRecno:integer;
  463. _CurIndex: TIndex;
  464. _Indexes:TList; // index
  465. _indexFile : TIndexFile;
  466. _dbtFile : TDbtFile;
  467. public
  468. _dbfFile:TDbfFile;
  469. property PhysicalRecno:integer read _PhysicalRecno;
  470. function _RecordDataSize:integer;
  471. end;
  472. {$ifndef fpc}
  473. procedure Register;
  474. {$endif}
  475. var
  476. tDbf_TrimFields : boolean;
  477. implementation
  478. var
  479. _PagedFiles : TList;
  480. //====================================================================
  481. // Some types and consts which are not useful in the interface.
  482. //====================================================================
  483. (*
  484. * tSmallint 16 bits = -32768 to 32767
  485. * 123456 = 6 digit max
  486. * ftInteger 32 bits = -2147483648 to 2147483647
  487. * 12345678901 = 11 digits max
  488. * ftLargeInt 64 bits = -9223372036854775808 to 9223372036854775807
  489. * 12345678901234567890 = 20 digits max
  490. *)
  491. const
  492. DIGITS_SMALLINT = 6;
  493. DIGITS_INTEGER = 11;
  494. DIGITS_LARGEINT = 20;
  495. sDBF_DEC_SEP= '.';
  496. type
  497. rAfterHdrIII = record // Empty
  498. end;
  499. rAfterHdrV = record
  500. Dummy : array[32..67] of byte;
  501. end;
  502. PMdxTag = ^rMdxTag;
  503. rMdxTagHdr = record
  504. RootPage : longint;// 0..3
  505. FilePages : longint;// 4..7
  506. KeyFormat : byte; // 8
  507. KeyType : char; // 9
  508. dummy : word; // 10..11
  509. IndexKeyLength : word; // 12..13
  510. MaxNbKeys : word; // 14..15
  511. SecondKeyType : word; // 16..17
  512. IndexKeyItemLen : word; // 18..19
  513. dummy2 : array [20..22] of byte;
  514. UniqueFlag : byte; // 23
  515. end;
  516. rAfterHdrV3 = record
  517. Dummy : array[12..31] of byte;
  518. end;
  519. rAfterHdrV4 = record
  520. Dummy : array[12..67] of byte;
  521. end;
  522. rFieldHdrV3 = record
  523. FieldName : array[0..10] of char;
  524. FieldType : char; // 11
  525. Dummy : array[12..15] of byte;
  526. FieldSize : byte; // 16
  527. FieldPrecision : byte; //17
  528. dummy2 : array[18..31] of byte;
  529. end;
  530. rFieldHdrV4 = record
  531. FieldName : array[0..10] of char;
  532. Dummy0 : array[11..31] of byte;
  533. FieldType : char; // 32
  534. FieldSize : byte; // 33
  535. FieldPrecision : byte; //34
  536. dummy2 : array[35..47] of byte;
  537. end;
  538. PDouble = ^double;
  539. //====================================================================
  540. // Now some common functions and procedure
  541. //====================================================================
  542. // ****************************************************************************
  543. // International separator
  544. // thanks to Bruno Depero from Italy
  545. // and Andreas Wöllenstein from Denmark
  546. function DbfStrToFloat(s: string): Extended;
  547. var iPos: integer;
  548. eValue: extended;
  549. begin
  550. iPos:= Pos(sDBF_DEC_SEP, s);
  551. if iPos> 0 then
  552. s[iPos]:= DecimalSeparator;
  553. {$ifndef fpc}
  554. if TextToFloat(pchar(s), eValue, fvExtended) then
  555. {$else}
  556. Val(s,eValue,Ipos);
  557. If Ipos=0 then
  558. {$endif}
  559. Result:= eValue
  560. else Result:= 0;
  561. end;
  562. function FloatToDbfStr(f: Extended; size, prec: integer): string;
  563. var iPos: integer;
  564. begin
  565. Result:= FloatToStrF(f, ffFixed, Size, prec);
  566. iPos:= Pos(DecimalSeparator, Result);
  567. if iPos> 0 then
  568. Result[iPos]:= sDBF_DEC_SEP;
  569. end;
  570. procedure MyMove(Source, Dest:PChar; Count: Integer);
  571. var
  572. c:char;
  573. i:integer;
  574. begin
  575. i:=0;
  576. while i<Count do begin
  577. c:=PChar(Source)[i];
  578. if c=#0 then break;
  579. PChar(Dest)[i]:=c;
  580. Inc(i);
  581. end;
  582. while i<Count do begin
  583. PChar(Dest)[i]:=' ';
  584. Inc(i);
  585. end;
  586. end;
  587. //====================================================================
  588. // TPagedFile
  589. //====================================================================
  590. function GetPagedFile(FileName: string):TPagedFile;
  591. var
  592. idx:integer;
  593. idf:TPagedFile;
  594. begin
  595. FileName:=LowerCase(FileName);
  596. for idx:=0 to _PagedFiles.Count-1 do begin
  597. idf:= TPagedFile(_PagedFiles[idx]);
  598. if idf._FileName=FileName then begin
  599. result:=idf;
  600. exit;
  601. end;
  602. end;
  603. result:=nil;
  604. end;
  605. procedure TPagedFile.Release;
  606. begin
  607. dec(_cntuse);
  608. if _cntuse<=0 then begin
  609. _PagedFiles.Delete(_PagedFiles.IndexOf(self));
  610. Free;
  611. end;
  612. end;
  613. function TPagedFile.CalcRecordCount:Integer;
  614. begin
  615. if RecordSize = 0 then Result:=0
  616. else Result:=(Stream.Size - HeaderSize) div RecordSize;
  617. end;
  618. constructor TPagedFile.Create(const FileName: string; Mode: Word);
  619. begin
  620. if filename='' then Stream:=TMemoryStream.Create()
  621. else begin
  622. Stream:=TFileStream.Create(FileName,Mode);
  623. end;
  624. HeaderSize:=0;
  625. RecordSize:=0;
  626. _cntuse:=0;
  627. _filename:=lowercase(filename);
  628. _PagedFiles.Add(Self);
  629. end;
  630. destructor TPagedFile.Destroy;
  631. begin
  632. Stream.Free;
  633. Stream:=nil;
  634. inherited;
  635. end;
  636. procedure TPagedFile._Seek(page:Integer);
  637. var
  638. p:Integer;
  639. begin
  640. p:=HeaderSize + (RecordSize * page );
  641. Stream.Position := p;
  642. end;
  643. Procedure TPagedFile.ReadRecord(IntRecNum:Integer; Buffer:Pointer);
  644. begin
  645. _Seek(IntRecNum);
  646. Stream.Read(Buffer^,RecordSize);
  647. end;
  648. procedure TPagedFile.WriteRecord(IntRecNum:Integer; Buffer:Pointer);
  649. begin
  650. _Seek(IntRecNum);
  651. Stream.Write(Buffer^, RecordSize);
  652. end;
  653. //====================================================================
  654. // TDbfFile
  655. //====================================================================
  656. constructor TDbfFile.Create(const FileName: string; Mode: Word);
  657. var
  658. lRecordCount:Integer;
  659. begin
  660. _MyFieldInfos:=TList.Create;
  661. // check if the file exists
  662. inherited Create(Filename, Mode);
  663. if Mode = fmCreate then begin
  664. FillChar(_DataHdr,sizeof(_DataHdr),0);
  665. HeaderSize:=0;
  666. RecordSize:=0;
  667. _DataHdr.VerDBF:=$03; // Default version xBaseIV without memo
  668. _DataHdr.Language:='X';
  669. end else begin
  670. Stream.Seek(0,soFromBeginning);
  671. Stream.ReadBuffer (_DataHdr, SizeOf(_DataHdr));
  672. case _DataHdr.VerDBF of
  673. $03,$83: _DbfVersion:=xBaseIII;
  674. $04,$8B,$8E,$7B: _DbfVersion:=xBaseIV;
  675. $05 : _DbfVersion:=xbaseV;
  676. else
  677. _DbfVersion:=xBaseIV; // My favorite...
  678. end;
  679. HeaderSize:=_DataHdr.FullHdrSize;
  680. RecordSize:=_DataHdr.RecordSize;
  681. lRecordCount:=CalcRecordCount;
  682. if _DataHdr.RecordCount <> lRecordCount then begin
  683. {$ifndef fpc}
  684. ShowMessage('Invalid Record Count,'+^M+
  685. 'RecordCount in Hdr : '+IntToStr(_DataHdr.RecordCount)+^M+
  686. 'expected : '+IntToStr(lRecordCount));
  687. {$endif}
  688. _DataHdr.RecordCount := lRecordCount;
  689. end;
  690. end;
  691. end;
  692. destructor TDbfFile.Destroy;
  693. begin
  694. inherited;
  695. ClearMyFieldInfos;
  696. _MyFieldInfos.Free;
  697. _MyFieldInfos:=nil;
  698. end;
  699. function TDbfFile.RecordCount:integer;
  700. begin
  701. if RecordSize=0 then result:=0
  702. else result:=(Stream.Size - HeaderSize) div RecordSize;
  703. if result<0 then result:=0;
  704. end;
  705. procedure TDbfFile.ClearMyFieldInfos;
  706. var
  707. i:Integer;
  708. begin
  709. for i:=0 to _MyFieldInfos.Count-1 do begin
  710. TMyFieldInfo(_MyFieldInfos.Items[i]).Free;
  711. end;
  712. _MyFieldInfos.Clear;
  713. end;
  714. procedure TDbfFile.CreateFieldDefs(FieldDefs:TFieldDefs);
  715. var
  716. lColumnCount,lHeaderSize,lFieldSize:Integer;
  717. Il : Integer;
  718. lFieldOffset : Integer;
  719. fn:string;
  720. ft:TFieldType;
  721. fs,nfs,fd:Integer;
  722. MyFieldInfo:TMyFieldInfo;
  723. lFieldHdrIII:rFieldHdrIII;
  724. lFieldHdrV:rFieldHdrV;
  725. function ToFieldType(dbasetype:char;fs,fd:Integer):TFieldType;
  726. begin
  727. case dbasetype of
  728. 'C' :
  729. begin
  730. Result:=ftString;
  731. end;
  732. 'L' :
  733. begin
  734. Result:=ftBoolean;
  735. end;
  736. 'F' :
  737. begin
  738. Result:=ftFloat;
  739. end;
  740. 'N' :
  741. begin
  742. if fd=0 then begin
  743. if fs <= DIGITS_SMALLINT then begin
  744. Result:=ftSmallInt;
  745. end else begin
  746. {$ifdef DELPHI_3}
  747. Result:=ftInteger;
  748. {$else}
  749. if fs <= DIGITS_INTEGER then Result:=ftInteger
  750. else Result:=ftLargeInt;
  751. {$endif}
  752. end;
  753. end else begin
  754. Result:=ftFloat;
  755. end;
  756. end;
  757. 'D' :
  758. begin
  759. Result:=ftDate;
  760. end;
  761. 'M' :
  762. begin
  763. Result:=ftMemo;
  764. end;
  765. else
  766. begin
  767. Result:=ftString;
  768. end;
  769. end; //case
  770. end;
  771. begin
  772. ClearMyFieldInfos;
  773. if _DbfVersion>=xBaseV then begin
  774. lHeaderSize:=SizeOf(rAfterHdrV) + SizeOf(rDbfHdr);
  775. lFieldSize:=SizeOf(rFieldHdrV);
  776. end else begin
  777. lHeaderSize:=SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
  778. lFieldSize:=SizeOf(rFieldHdrIII);
  779. end;
  780. lColumnCount:= (_DataHdr.FullHdrSize - lHeaderSize) div lFieldSize;
  781. if (lColumnCount <= 0) or (lColumnCount > 255) then
  782. Raise eBinaryDataSetError.Create('Invalid field count : ' + IntToStr(lColumnCount) + ' (must be between 1 and 255)');
  783. lFieldOffset := 1;
  784. Stream.Position := lHeaderSize;
  785. for Il:=0 to lColumnCount-1 do begin
  786. if _DbfVersion>=xBaseV then begin
  787. Stream.ReadBuffer(lFieldHdrV,SizeOf(lFieldHdrV));
  788. fn:=PCHAR(@lFieldHdrV.FieldName[0]);
  789. fs:=lFieldHdrV.FieldSize;
  790. fd:=lFieldHdrV.FieldPrecision;
  791. nfs:=fs;
  792. ft:=ToFieldType(lFieldHdrV.FieldType,nfs,fd);
  793. end else begin
  794. Stream.ReadBuffer(lFieldHdrIII,SizeOf(lFieldHdrIII));
  795. fn:=PCHAR(@lFieldHdrIII.FieldName[0]);
  796. fs:=lFieldHdrIII.FieldSize;
  797. fd:=lFieldHdrIII.FieldPrecision;
  798. nfs:=fs;
  799. ft:=ToFieldType(lFieldHdrIII.FieldType,nfs,fd);
  800. end;
  801. // first create the bde field
  802. if ft in [ftString,ftBCD] then fieldDefs.Add(fn,ft,fs,false)
  803. else fieldDefs.Add(fn,ft,0,false);
  804. // then create the for our own fieldinfo
  805. MyFieldInfo:=TMyFieldInfo.Create;
  806. MyFieldInfo.Offset:=lFieldOffset;
  807. MyFieldInfo.Size:=fs;
  808. MyFieldInfo.Prec:=fd;
  809. MyFieldInfo.FieldName:=lowercase(fn);
  810. _MyFieldInfos.Add(MyFieldInfo);
  811. Inc(lFieldOffset,fs);
  812. end;
  813. if (lFieldOffset <> _DataHdr.RecordSize) then begin
  814. {$ifndef fpc}
  815. ShowMessage('Invalid Record Size,'+^M+
  816. 'Record Size in Hdr : '+IntToStr(_DataHdr.RecordSize)+^M+
  817. 'Expected : '+IntToStr(lFieldOffset));
  818. {$endif}
  819. _DataHdr.RecordSize := lFieldOffset;
  820. end;
  821. end;
  822. procedure TDbfFile.DbfFile_CreateTable(FieldDefs:TFieldDefs);
  823. var
  824. ix:Integer;
  825. lFieldHdrIII:rFieldHdrIII;
  826. lType:Char;
  827. lSize,lPrec:Integer;
  828. Offs:Integer;
  829. lterminator:Byte;
  830. begin
  831. // first reset file.
  832. Stream.Size:= 0;
  833. Stream.Position:=SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
  834. Offs:=1; // deleted mark count 1.
  835. for Ix:=0 to FieldDefs.Count-1 do
  836. begin
  837. with FieldDefs.Items[Ix] do
  838. begin
  839. FillChar(lFieldHdrIII,SizeOf(lFieldHdrIII),#0);
  840. lPrec:=0;
  841. case DataType of
  842. ftString:
  843. begin
  844. ltype:='C';
  845. lSize := Size;
  846. end;
  847. ftBoolean:
  848. begin
  849. ltype:='L';
  850. lSize := 1;
  851. end;
  852. ftSmallInt:
  853. begin
  854. ltype:='N';
  855. lSize := 6;
  856. end;
  857. ftInteger:
  858. begin
  859. ltype:='N';
  860. lSize := 11;
  861. end;
  862. ftCurrency:
  863. begin
  864. ltype:='N';
  865. lSize := 20;
  866. lPrec := 2;
  867. end;
  868. {$ifndef DELPHI_3}
  869. ftLargeInt:
  870. begin
  871. ltype:='N';
  872. lSize := 20;
  873. lPrec := 0;
  874. end;
  875. {$endif}
  876. ftFloat:
  877. begin
  878. ltype:='N';
  879. lSize := 20;
  880. lPrec := 4;
  881. end;
  882. ftDate:
  883. begin
  884. ltype:='D';
  885. lSize := 8;
  886. end;
  887. ftMemo:
  888. begin
  889. ltype:='M';
  890. lSize := 10;
  891. end;
  892. else
  893. begin
  894. raise EBinaryDataSetError.Create(
  895. 'InitFieldDefs: Unsupported field type');
  896. end;
  897. end; // case
  898. lFieldHdrIII.FieldType:=ltype; //DataType;
  899. StrPCopy(lFieldHdrIII.FieldName,FieldDefs.Items[Ix].Name);
  900. lFieldHdrIII.FieldSize:=lSize;
  901. lFieldHdrIII.FieldPrecision:=lPrec;
  902. Stream.Write(lFieldHdrIII,SizeOf(lFieldHdrIII));
  903. Inc(Offs,lSize);
  904. end;
  905. end;
  906. // end of header
  907. lterminator := $0d;
  908. Stream.Write(lterminator,SizeOf(lterminator));
  909. // update header
  910. _DataHdr.RecordSize := Offs;
  911. _DataHdr.FullHdrSize := Stream.Position;
  912. RecordSize := _DataHdr.RecordSize;
  913. HeaderSize := _DataHdr.FullHdrSize;
  914. // write the updated header
  915. WriteHeader;
  916. end;
  917. procedure TDbfFile.DbfFile_PackTable;
  918. var
  919. first,last:integer;
  920. p: Pointer;
  921. begin
  922. // Non tested.
  923. if (RecordSize <> 0) then
  924. begin
  925. first:=0;
  926. last:=CalcRecordCount-1;
  927. GetMem(p, RecordSize);
  928. try
  929. while first<last do begin
  930. // first find the first hole
  931. while first<last do begin
  932. ReadRecord(first, p);
  933. if (pRecordHdr(p)^.DeletedFlag <> ' ') then break;
  934. inc(first);
  935. end;
  936. // now find last one non deleted.
  937. while first<last do begin
  938. ReadRecord(last, p);
  939. if (pRecordHdr(p)^.DeletedFlag = ' ') then break;
  940. dec(last);
  941. end;
  942. if first<last then begin
  943. // found a non deleted record to put in the hole.
  944. WriteRecord(first, p);
  945. inc(first);
  946. dec(last);
  947. end;
  948. end;
  949. last:=CalcRecordCount;
  950. Stream.Size:=(last+1) * RecordSize + HeaderSize;
  951. finally
  952. FreeMem(p);
  953. end;
  954. end;
  955. end;
  956. function TDbfFile.GetFieldInfo(FieldName:string):TMyFieldInfo;
  957. var
  958. i:Integer;
  959. lfi:TMyFieldInfo;
  960. begin
  961. FieldName:=LowerCase(FieldName);
  962. for i:=0 to _MyFieldInfos.Count-1 do begin
  963. lfi:=TMyFieldInfo(_MyFieldInfos.Items[i]);
  964. if lfi.FieldName = FieldName then begin
  965. result:=lfi;
  966. exit;
  967. end;
  968. end;
  969. result:=nil;
  970. end;
  971. function TDbfFile.GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst:Pointer): Boolean;
  972. var
  973. FieldOffset: Integer;
  974. FieldSize: Integer;
  975. s:string;
  976. d:TDateTime;
  977. ld,lm,ly: word;
  978. MyFieldInfo:TMyFieldInfo;
  979. function TrimStr(const s: string): string;
  980. var
  981. iPos: integer;
  982. begin
  983. if DataType=ftString then
  984. begin
  985. if tDbf_TrimFields then Result:=Trim(s)
  986. else Result:=TrimRight(s);
  987. end
  988. else Result:= Trim(s);
  989. end;
  990. procedure CorrectYear(var wYear: word);
  991. var wD, wM, wY, CenturyBase: word;
  992. {$ifdef DELPHI_3}
  993. // Delphi 3 standard-behavior no change possible
  994. const TwoDigitYearCenturyWindow= 0;
  995. {$endif}
  996. begin
  997. if wYear>= 100 then
  998. Exit;
  999. DecodeDate(Date, wY, wm, wD);
  1000. // use Delphi-Date-Window
  1001. CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
  1002. Inc(wYear, CenturyBase div 100 * 100);
  1003. if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
  1004. Inc(wYear, 100);
  1005. end;
  1006. begin
  1007. MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  1008. FieldOffset := MyFieldInfo.Offset;
  1009. FieldSize := MyFieldInfo.Size;
  1010. SetString(s, PChar(Src) + FieldOffset, FieldSize );
  1011. s:=TrimStr(s);
  1012. result:=length(s)>0; // return if field is empty
  1013. if Result and (Dst<>nil) then// data not needed if Result= FALSE or Dst=nil
  1014. case DataType of
  1015. ftBoolean:
  1016. begin
  1017. // in DBase- FileDescription lowercase t is allowed too
  1018. // with asking for Result= TRUE s must be longer then 0
  1019. // else it happens an AV, maybe field is NULL
  1020. if (UpCase(s[1])='T') then Word(Dst^) := 1
  1021. else Word(Dst^) := 0;
  1022. end;
  1023. ftInteger, ftSmallInt{$ifndef DELPHI_3},ftLargeInt{$endif}:
  1024. begin
  1025. case DataType of
  1026. ftSmallInt : SmallInt(Dst^):= StrToIntDef(s, 0);
  1027. {$ifndef DELPHI_3}
  1028. ftLargeint : LargeInt(Dst^):= StrToInt64Def(s, 0);
  1029. {$endif}
  1030. else // ftInteger :
  1031. Integer(Dst^):= StrToIntDef(s, 0);
  1032. end; // case
  1033. end;
  1034. ftFloat:
  1035. begin
  1036. Double(Dst^) := DBFStrToFloat(s);
  1037. end;
  1038. ftCurrency:
  1039. begin
  1040. Double(Dst^) := DBFStrToFloat(s);
  1041. end;
  1042. ftDate:
  1043. begin
  1044. ld:=StrToIntDef(Copy(s,7,2),1);
  1045. lm:=StrToIntDef(Copy(s,5,2),1);
  1046. ly:=StrToIntDef(Copy(s,1,4),0);
  1047. if ld=0 then ld:=1;
  1048. if lm=0 then lm:=1;
  1049. // if (ly<1900) or (ly>2100) then ly:=1900;
  1050. // Year from 0001 to 9999 is possible
  1051. // everyting else is an error, an empty string too
  1052. // Do DateCorrection with Delphis possibillities for one or two digits
  1053. if (ly< 100) and (Length(Trim(Copy(s,1,4)))in [1, 2]) then CorrectYear(ly);
  1054. try
  1055. d:=EncodeDate(ly,lm,ld);
  1056. if Assigned(Dst) then Integer(Dst^) := DateTimeToTimeStamp(d).Date;
  1057. except
  1058. Integer(Dst^) := 0;
  1059. end;
  1060. end;
  1061. ftString: begin
  1062. StrPCopy(Dst,s);
  1063. end;
  1064. end;
  1065. end;
  1066. procedure TDbfFile.SetFieldData(Column:integer;DataType:TFieldType; Src,Dst:Pointer);
  1067. var
  1068. FieldSize,FieldPrec: Integer;
  1069. s:string;
  1070. fl:Double;
  1071. ts:TTimeStamp;
  1072. MyFieldInfo:TMyFieldInfo;
  1073. begin
  1074. MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  1075. FieldSize := MyFieldInfo.Size;
  1076. FieldPrec := MyFieldInfo.Prec;
  1077. Dst:=PChar(Dst)+MyFieldInfo.Offset;
  1078. if src<>nil then begin
  1079. case DataType of
  1080. ftBoolean:
  1081. begin
  1082. if Word(Src^) = 1 then s:='T'
  1083. else s:='F';
  1084. end;
  1085. ftInteger, ftSmallInt {$ifndef DELPHI_3},ftLargeInt{$endif}:
  1086. begin
  1087. case DataType of
  1088. ftSmallInt : s:= IntToStr(SmallInt(Src^));
  1089. {$ifndef DELPHI_3}
  1090. ftLargeInt: s:= IntToStr(LargeInt(Src^));
  1091. {$endif}
  1092. else //ftInteger
  1093. s:= IntToStr(Integer(Src^));
  1094. end;
  1095. // left filling
  1096. if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
  1097. end;
  1098. ftFloat,ftCurrency:
  1099. begin
  1100. fl := Double(Src^);
  1101. s:=FloatToDbfStr(fl,FieldSize,FieldPrec);
  1102. if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
  1103. end;
  1104. ftDate:
  1105. begin
  1106. ts.Time:=0;
  1107. ts.Date:=Integer(Src^);
  1108. s:= FormatDateTime('yyyymmdd', TimeStampToDateTime(ts));
  1109. end;
  1110. ftString:
  1111. begin
  1112. s:=PChar(Src); // finish with first 0
  1113. end;
  1114. end; // case
  1115. end; // if src<>nil (thanks andreas)
  1116. if Length(s)<FieldSize then begin
  1117. s:=s+StringOfChar(' ',FieldSize-Length(s));
  1118. end else if (Length(s)>FieldSize) then begin
  1119. if DataType= ftString then begin
  1120. // never raise for strings to long, its not customary
  1121. // TTable never raises
  1122. SetLength(s, FieldSize)
  1123. end else begin
  1124. raise eFieldToLongError.Create('Fielddata too long :' + IntToStr(Length(s))
  1125. + ' (must be between 1 and ' + IntToStr(FieldSize) + ').');
  1126. end;
  1127. end;
  1128. Move(PChar(s)^, Dst^, FieldSize);
  1129. end;
  1130. procedure TDbfFile.WriteHeader;
  1131. var
  1132. SystemTime: TSystemTime;
  1133. lAfterHdrIII:rAfterHdrIII;
  1134. lAfterHdrV:rAfterHdrV;
  1135. lterminator:Byte;
  1136. begin
  1137. Assert(Stream<>nil,'_dbfFile=Nil');
  1138. Stream.Position:=0;
  1139. GetLocalTime(SystemTime);
  1140. {$ifndef fpc}
  1141. _DataHdr.Year := SystemTime.wYear - 1900;
  1142. _DataHdr.Month := SystemTime.wMonth;
  1143. _DataHdr.Day := SystemTime.wDay;
  1144. {$else}
  1145. _DataHdr.Year := SystemTime.Year - 1900;
  1146. _DataHdr.Month := SystemTime.Month;
  1147. _DataHdr.Day := SystemTime.Day;
  1148. {$endif}
  1149. Stream.Seek(0,soFromBeginning);
  1150. Stream.WriteBuffer (_DataHdr, SizeOf(_DataHdr));
  1151. _DataHdr.RecordCount := CalcRecordCount;
  1152. if _DbfVersion >= xBaseV then begin
  1153. FillChar(lAfterHdrV,SizeOf(lAfterHdrV),0);
  1154. Stream.WriteBuffer (lAfterHdrV, SizeOf(lAfterHdrV));
  1155. end else begin
  1156. FillChar(lAfterHdrIII,SizeOf(lAfterHdrIII),0);
  1157. Stream.WriteBuffer (lAfterHdrIII, SizeOf(lAfterHdrIII));
  1158. end;
  1159. _Seek(_DataHdr.RecordCount); // last byte usually...
  1160. lterminator := $1A;
  1161. Stream.Write(lterminator,SizeOf(lterminator));
  1162. end;
  1163. function TDbf._ComponentInfo:string;
  1164. begin
  1165. Result:='TDbf V' + IntToStr(_MAJOR_VERSION) + '.' + IntToStr(_MINOR_VERSION);
  1166. end;
  1167. procedure TDbf._OpenFiles(CreateIt:boolean);
  1168. var
  1169. fileopenmode : integer;
  1170. lPath,lFilename,lIndexName,lMemoName : string;
  1171. isAbsolute:boolean;
  1172. design,doreadonly:boolean;
  1173. begin
  1174. design:=(csDesigning in ComponentState);
  1175. doreadonly:=design or _ReadOnly;
  1176. lPath:=_GetPath;
  1177. isAbsolute:=((length(_TableName)>=1) and (_TableName[1]='\'))
  1178. or ((length(_TableName)>=2) and (_TableName[2]=':'));
  1179. if isAbsolute then lfilename:=_TableName
  1180. else lFilename:=lPath+_TableName;
  1181. lFilename:=ChangeFileExt(lFilename,'.dbf');
  1182. lIndexName:=ChangeFileExt(lFilename,'.mdx');
  1183. lMemoName:=ChangeFileExt(lFilename,'.dbt');
  1184. // check if the file exists
  1185. _dbfFile:=TDbfFile(GetPagedFile(lFileName));
  1186. _indexFile:=TIndexFile(GetPagedFile(lIndexName));
  1187. _dbtFile:=TDbtFile(GetPagedFile(lMemoName));
  1188. if CreateIt then begin
  1189. if _dbfFile=nil then _dbfFile:=TDbfFile.Create(lFileName,fmCreate);
  1190. //if _indexfile=nil then _indexFile := TIndexFile.Create(lIndexName, fmCreate);
  1191. if _dbtfile=nil then _dbtFile := TDbtFile.Create(lMemoName, fmCreate,_dbfFile._DbfVersion);
  1192. end else if not FileExists(lFileName) then begin
  1193. raise eBinaryDataSetError.Create ('Open: Table file not found : ' + lFileName);
  1194. end else begin
  1195. if DoReadOnly then
  1196. fileopenmode := fmOpenRead + fmShareDenyNone
  1197. else
  1198. fileopenmode := fmOpenReadWrite + fmShareDenyWrite;
  1199. if _dbfFile=nil then _dbfFile := TDBFFile.Create(lFileName, fileopenmode);
  1200. if (_indexFile=nil) and FileExists (lIndexName) then begin
  1201. _indexFile := TIndexFile.Create(lIndexName, fileopenmode);
  1202. end;
  1203. if (_dbtFile=nil) and FileExists (lMemoName) then begin
  1204. _dbtFile := TDbtFile.Create(lMemoName, fileopenmode,_dbfFile._DbfVersion);
  1205. end;
  1206. end;
  1207. _PrevBuffer:=AllocRecordBuffer;
  1208. _IsCursorOpen:=true;
  1209. end;
  1210. function TDbf._GetPath:string;
  1211. var
  1212. lPath:string;
  1213. begin
  1214. if (csDesigning in ComponentState) then begin
  1215. lPath:=_DesignTimePath;
  1216. end else begin
  1217. if ((length(_RunTimePath)>=1) and (_RunTimePath[1]=DirSeparator))
  1218. or ((length(_RunTimePath)>=2) and (_RunTimePath[2]=':'))
  1219. then begin
  1220. // if the _RunTimePath is absolute...
  1221. // it is either \ or \blahblah or c:\
  1222. lPath:=_RunTimePath;
  1223. end else begin
  1224. {$ifndef fpc}
  1225. lPath:=extractfilepath(Application.Exename)+_RunTimePath;
  1226. {$else}
  1227. lPath:=extractfilepath(paramstr(0))+_RunTimePath;
  1228. {$endif}
  1229. end;
  1230. end;
  1231. lPath:=ExpandFileName(trim(lPath));
  1232. if (length(lPath)>0) and (lPath[length(lPath)]<>DirSeparator) then lPath:=lPath+DirSeparator;
  1233. result:=lPath;
  1234. end;
  1235. procedure TDbf._CloseFiles;
  1236. var
  1237. i:integer;
  1238. begin
  1239. if _dbfFile<>nil then begin
  1240. if not _ReadOnly then _dbfFile.WriteHeader;
  1241. _dbfFile.Release;
  1242. _dbfFile:=nil;
  1243. end;
  1244. if _indexFile<>nil then begin
  1245. _indexFile.Release;
  1246. _indexFile:=nil;
  1247. end;
  1248. if _dbtFile<>nil then begin
  1249. _dbtFile.Release;
  1250. _dbtFile:=nil;
  1251. end;
  1252. if _indexes<>nil then begin
  1253. for i:=0 to _Indexes.Count-1 do begin
  1254. TIndex(_Indexes[i]).Free;
  1255. end;
  1256. _Indexes.Clear;
  1257. _CurIndex:=nil;
  1258. end;
  1259. if (_PrevBuffer<>nil) then begin
  1260. FreeRecordBuffer(_PrevBuffer);
  1261. _PrevBuffer:=nil;
  1262. end;
  1263. _IsCursorOpen:=false;
  1264. end;
  1265. procedure TDbf._SetIndexName(const Value: string);
  1266. begin
  1267. _CurIndex:=_GetIndex(Value);
  1268. Resync([]);
  1269. end;
  1270. function TDbf._GetIndexName: string;
  1271. begin
  1272. if _CurIndex=nil then Result:=''
  1273. else Result:=_CurIndex._IndexFile._Filename;
  1274. end;
  1275. function TDbf._GetIndex(filename:string):TIndex;
  1276. var
  1277. i:integer;
  1278. lindex:TIndex;
  1279. begin
  1280. result:=nil;
  1281. filename:=lowercase(_GetPath + filename);
  1282. for i:=0 to _indexes.Count-1 do begin
  1283. lindex:=TIndex(_indexes.Items[i]);
  1284. if lindex._IndexFile._Filename=filename then begin
  1285. result:=lindex;
  1286. exit;
  1287. end;
  1288. end;
  1289. end;
  1290. //==========================================================
  1291. //============ TMyBlobFile
  1292. //==========================================================
  1293. constructor TMyBlobFile.Create(ModeVal:TBlobStreamMode;FieldVal:TField);
  1294. begin
  1295. Mode:=ModeVal;
  1296. Field:=FieldVal;
  1297. end;
  1298. destructor TMyBlobFile.destroy;
  1299. var
  1300. Dbf:TDbf;
  1301. begin
  1302. if (Mode=bmWrite) then begin
  1303. Size:=Position; // Strange but it leave tailing trash bytes if I do not write that.
  1304. Dbf:=TDbf(Field.DataSet);
  1305. Dbf._dbtFile.WriteMemo(MemoRecno,ReadSize,Self);
  1306. Dbf._dbfFile.SetFieldData(Field.FieldNo-1,
  1307. ftInteger,@MemoRecno,@pDbfRecord(TDbf(Field.DataSet).ActiveBuffer)^.deletedflag);
  1308. // seems not bad
  1309. {$ifndef fpc}
  1310. // FPC doesn't allow to call protected methods ?!!
  1311. Dbf.SetModified(true);
  1312. {$endif}
  1313. // but would that be better
  1314. //if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
  1315. // DataEvent(deFieldChange, Longint(Field));
  1316. //end;
  1317. end;
  1318. inherited;
  1319. end;
  1320. //====================================================================
  1321. // TDbf = TDataset Descendant.
  1322. //====================================================================
  1323. constructor TDbf.Create(AOwner: TComponent); {override;}
  1324. begin
  1325. inherited create(aOwner);
  1326. BookmarkSize:=sizeof(rBookmarkData);
  1327. _RunTimePath:='.';
  1328. _IsCursorOpen:=false;
  1329. _Indexes:=TList.Create;
  1330. _CurIndex:=nil;
  1331. _IndexFiles:=TStringList.Create;
  1332. end;
  1333. destructor TDbf.Destroy; {override;}
  1334. var
  1335. i:integer;
  1336. begin
  1337. inherited;
  1338. _CurIndex:=nil;
  1339. for i:=0 to _Indexes.Count-1 do begin
  1340. TIndex(_Indexes[i]).Free;
  1341. end;
  1342. _Indexes.Free;
  1343. _IndexFiles.Free;
  1344. // _MemIndex.Free;
  1345. end;
  1346. function TDbf._FilterRecord(Buffer: PChar): Boolean;
  1347. var
  1348. SaveState: TDatasetState;
  1349. s:string;
  1350. begin
  1351. Result:=True;
  1352. if Length(easyfilter)<>0 then begin
  1353. SetString(s,buffer,RecordSize);
  1354. s:=LowerCase(s);
  1355. if Pos(easyfilter,s)=0 then begin
  1356. Result:=False;
  1357. Exit;
  1358. end;
  1359. end;
  1360. if not Assigned(OnFilterRecord) then Exit;
  1361. if not Filtered then Exit;
  1362. _FilterBuffer:=buffer;
  1363. SaveState:=SetTempState(dsFilter);
  1364. OnFilterRecord(self,Result);
  1365. RestoreState(SaveState);
  1366. end;
  1367. function TDbf._RecordDataSize:integer;
  1368. begin
  1369. if _dbfFile=nil then result:=0
  1370. else result:=_dbfFile.RecordSize;
  1371. end;
  1372. function TDbf._FullRecordSize:integer;
  1373. begin
  1374. result:=sizeof(rBeforeRecord) + _RecordDataSize + CalcFieldsSize;
  1375. end;
  1376. function TDbf.AllocRecordBuffer: PChar; {override virtual abstract from TDataset}
  1377. begin
  1378. result:=StrAlloc(_FullRecordSize);
  1379. InternalInitRecord(result);
  1380. end;
  1381. procedure TDbf.FreeRecordBuffer(var Buffer: PChar); {override virtual abstract from TDataset}
  1382. begin
  1383. StrDispose(Buffer);
  1384. end;
  1385. procedure TDbf.GetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
  1386. var
  1387. prec:pDbfRecord;
  1388. begin
  1389. prec:=pDbfRecord(Buffer);
  1390. pBookMarkData(Data)^:=prec^.BookMarkData;
  1391. end;
  1392. function TDbf.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; {override virtual abstract from TDataset}
  1393. var
  1394. prec:pDbfRecord;
  1395. begin
  1396. prec:=pDbfRecord(Buffer);
  1397. result:=prec^.BookMarkFlag;
  1398. end;
  1399. function TDbf.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {override virtual abstract from TDataset}
  1400. var
  1401. ptr:pointer;
  1402. begin
  1403. Result := False;
  1404. if State=dsFilter then begin
  1405. Ptr:=_FilterBuffer;
  1406. end else if State = dsCalcFields then begin
  1407. // ***** calc fields ***** set correct buffer
  1408. ptr := @(pDbfRecord(CalcBuffer)^.deletedflag);
  1409. end else begin
  1410. if IsEmpty then exit;
  1411. ptr:=@(pDbfRecord(ActiveBuffer)^.deletedflag);
  1412. end;
  1413. if Field.FieldNo>0 then begin
  1414. Result:=_dbfFile.GetFieldData(Field.FieldNo - 1,Field.DataType,ptr,Buffer);
  1415. end else begin { calculated fields.... }
  1416. Inc(PChar(Ptr), Field.Offset + GetRecordSize);
  1417. {$ifndef fpc}
  1418. Result := Boolean(PChar(Ptr)[0]);
  1419. {$else}
  1420. Result := (Pchar(ptr)[0]<>#0);
  1421. {$endif}
  1422. if Result and (Buffer <> nil) then
  1423. Move(PChar(Ptr)[1], Buffer^, Field.DataSize);
  1424. end;
  1425. end;
  1426. function TDbf.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; {override virtual abstract from TDataset}
  1427. var
  1428. Acceptable : Boolean;
  1429. prec:pDBFRecord;
  1430. begin
  1431. prec:=pDBFRecord(Buffer);
  1432. if _dbfFile.RecordCount < 1 then
  1433. Result := grEOF
  1434. else repeat
  1435. result := grOk;
  1436. case GetMode of
  1437. gmCurrent :
  1438. begin
  1439. if prec^.BookmarkData.Recno=_PhysicalRecno then begin
  1440. exit; // try to fasten a bit...
  1441. end;
  1442. end;
  1443. gmNext :
  1444. begin
  1445. if _curIndex<>nil then begin
  1446. Acceptable:=_curIndex.Next;
  1447. end else begin
  1448. inc(_PhysicalRecno);
  1449. Acceptable:=(_PhysicalRecno<_dbfFile.RecordCount);
  1450. end;
  1451. if Acceptable then begin
  1452. result:= grOk;
  1453. end else begin
  1454. InternalLast;
  1455. result:= grEOF
  1456. end;
  1457. end;
  1458. gmPrior :
  1459. begin
  1460. if _curIndex<>nil then begin
  1461. Acceptable:=_curIndex.Prev;
  1462. end else begin
  1463. dec(_PhysicalRecno);
  1464. Acceptable:=(_PhysicalRecno>=0);
  1465. end;
  1466. if Acceptable then begin
  1467. result:= grOk;
  1468. end else begin
  1469. InternalFirst;
  1470. result:= grBOF
  1471. end;
  1472. end;
  1473. end;
  1474. if result=grOk then begin
  1475. if _curIndex<>nil then _PhysicalRecno:=_CurIndex.GetRealRecNo;
  1476. if (_PhysicalRecno>=_dbfFile.RecordCount)
  1477. or (_PhysicalRecno<0) then begin
  1478. result:=grError;
  1479. end else begin
  1480. _dbfFile.ReadRecord(_PhysicalRecno,@prec^.DeletedFlag);
  1481. result:=grOk;
  1482. end;
  1483. if Result = grOK then begin
  1484. ClearCalcFields(Buffer);
  1485. GetCalcFields(Buffer);
  1486. prec^.BookmarkFlag := bfCurrent;
  1487. prec^.BookmarkData.Recno:=PhysicalRecno;
  1488. end else if (Result = grError) and DoCheck then
  1489. raise eBinaryDataSetError.Create ('GetRecord: Invalid record');
  1490. end;
  1491. Acceptable := (_ShowDeleted or (prec^.DeletedFlag = ' '))
  1492. and _FilterRecord(Buffer);
  1493. if (GetMode=gmCurrent) and Not Acceptable then Result := grError;
  1494. until (Result <> grOK) or Acceptable;
  1495. end;
  1496. function TDbf.GetRecordSize: Word; {override virtual abstract from TDataset}
  1497. begin
  1498. Result := _RecordDataSize; // data only
  1499. end;
  1500. procedure TDbf.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); {override virtual abstract from TDataset}
  1501. begin
  1502. end;
  1503. procedure TDbf.InternalClose; {override virtual abstract from TDataset}
  1504. begin
  1505. _CloseFiles;
  1506. // disconnect field objects
  1507. BindFields(False);
  1508. // destroy field object (if not persistent)
  1509. if DefaultFields then
  1510. DestroyFields;
  1511. end;
  1512. procedure TDbf.InternalDelete; {override virtual abstract from TDataset}
  1513. begin
  1514. // CheckActive;
  1515. pRecordHdr(ActiveBuffer)^.DeletedFlag := '*'; //_DataHdr.LastDeleted;
  1516. _dbfFile.WriteRecord(_PhysicalRecNo,ActiveBuffer);
  1517. Resync([]);
  1518. end;
  1519. procedure TDbf.InternalFirst; {override virtual abstract from TDataset}
  1520. begin
  1521. if _dbfFile.RecordCount=0 then InternalLast
  1522. else if _curindex=nil then _PhysicalRecno:=-1
  1523. else _curIndex.First;
  1524. end;
  1525. procedure TDbf.InternalGotoBookmark(ABookmark: Pointer); {override virtual abstract from TDataset}
  1526. var
  1527. RecInfo: TRecInfo;
  1528. begin
  1529. RecInfo := TRecInfo(ABookmark^);
  1530. if (RecInfo.Bookmark >= 0) and (RecInfo.Bookmark < _dbfFile.RecordCount) then begin
  1531. _PhysicalRecno:=RecInfo.Bookmark;
  1532. end else
  1533. raise eBinaryDataSetError.Create ('Bookmark ' +
  1534. IntToStr (RecInfo.Bookmark) + ' not found');
  1535. end;
  1536. procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
  1537. begin
  1538. {$ifndef fpc}
  1539. Application.HandleException(Self);
  1540. {$endif}
  1541. end;
  1542. procedure TDbf.InternalInitFieldDefs; {override virtual abstract from TDataset}
  1543. begin
  1544. FieldDefs.Clear;
  1545. with FieldDefs do
  1546. begin
  1547. if IsCursorOpen then begin
  1548. _dbfFile.CreateFieldDefs(FieldDefs);
  1549. end else begin
  1550. _OpenFiles(false);
  1551. _dbfFile.CreateFieldDefs(FieldDefs);
  1552. Close();
  1553. end;
  1554. end;
  1555. end;
  1556. procedure TDbf.InternalInitRecord(Buffer: PChar); {override virtual abstract from TDataset}
  1557. var
  1558. prec:pDbfRecord;
  1559. begin
  1560. prec:=pDbfRecord(Buffer);
  1561. prec^.BookmarkData.RecNo:=-1;
  1562. prec^.BookmarkFlag:=TBookmarkFlag(0);
  1563. fillchar(prec^.DeletedFlag,_RecordDataSize,' ');
  1564. end;
  1565. procedure TDbf.InternalLast; {override virtual abstract from TDataset}
  1566. begin
  1567. if _curindex=nil then _PhysicalRecno:=_dbfFile.RecordCount
  1568. else _curIndex.Last;
  1569. end;
  1570. procedure TDbf.InternalOpen; {override virtual abstract from TDataset}
  1571. begin
  1572. _OpenFiles(false);
  1573. // if there are no persistent field objects,
  1574. InternalInitFieldDefs;
  1575. // create the fields dynamically
  1576. if DefaultFields then begin
  1577. CreateFields;
  1578. end;
  1579. BindFields (True);
  1580. // connect the TField objects with the actual fields
  1581. InternalFirst;
  1582. end;
  1583. procedure TDbf.InternalPost; {override virtual abstract from TDataset}
  1584. var
  1585. prec:pDbfRecord;
  1586. lIndex:TIndex;
  1587. i:integer;
  1588. begin
  1589. CheckActive;
  1590. prec:=pDbfRecord(ActiveBuffer);
  1591. prec^.DeletedFlag:=' ';
  1592. if State = dsEdit then
  1593. begin
  1594. // replace data with new data
  1595. if _indexes.Count>0 then begin
  1596. _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
  1597. for i:=0 to _indexes.Count-1 do begin
  1598. lindex:=TIndex(_indexes.Items[i]);
  1599. lindex.Update(_PhysicalRecno,_PrevBuffer,@prec^.DeletedFlag);
  1600. end;
  1601. end;
  1602. end else begin
  1603. // append
  1604. _PhysicalRecno:=_dbfFile._DataHdr.RecordCount;
  1605. inc(_dbfFile._DataHdr.RecordCount);
  1606. if _indexes.Count>0 then begin
  1607. _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
  1608. for i:=0 to _indexes.Count-1 do begin
  1609. lindex:=TIndex(_indexes.Items[i]);
  1610. lindex.Insert(_PhysicalRecno,@prec^.DeletedFlag);
  1611. end;
  1612. end;
  1613. end;
  1614. _dbfFile.WriteRecord(_PhysicalRecno,@prec^.DeletedFlag);
  1615. end;
  1616. procedure TDbf.CreateTable; //(FieldDefs:TFieldDefs);
  1617. var
  1618. ix:integer;
  1619. begin
  1620. CheckInactive;
  1621. // InternalInitFieldDefs;
  1622. if FieldDefs.Count = 0 then
  1623. begin
  1624. for Ix := 0 to FieldCount - 1 do
  1625. begin
  1626. with Fields[Ix] do
  1627. begin
  1628. if FieldKind = fkData then
  1629. FieldDefs.Add(FieldName,DataType,Size,Required);
  1630. end;
  1631. end;
  1632. end;
  1633. _OpenFiles(true);
  1634. try
  1635. _dbfFile.DbfFile_CreateTable(FieldDefs);
  1636. finally
  1637. // close the file
  1638. _CloseFiles;
  1639. end;
  1640. end;
  1641. procedure TDbf.PackTable;
  1642. begin
  1643. _dbfFile.dbfFile_PackTable;
  1644. Resync([]);
  1645. end;
  1646. function TDbf.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; {override virtual}
  1647. var
  1648. Memoi:array[1..32] of char;
  1649. lBlob:TMyBlobFile;
  1650. begin
  1651. lBlob:=TMyBlobFile.Create(Mode,Field);
  1652. if _dbfFile.GetFieldData(Field.FieldNo-1, ftString,@pDbfRecord(ActiveBuffer)^.deletedflag,@Memoi[1]) then begin
  1653. lBlob.MemoRecno:=StrToIntDef(Memoi,0);
  1654. _dbtFile.ReadMemo(lBlob.MemoRecno,lBlob);
  1655. lBlob.ReadSize:=lBlob.Size;
  1656. end else lBlob.MemoRecno:=0;
  1657. Result:=lBlob;
  1658. end;
  1659. {$ifdef DELPHI_3}
  1660. procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
  1661. begin
  1662. if (Src <> nil) and (Dest<>nil) then begin
  1663. if ToOem then CharToOem(Src,Dest)
  1664. else OemToChar(Src,Dest);
  1665. end;
  1666. end;
  1667. {$else}
  1668. {$ifndef fpc}
  1669. function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
  1670. begin
  1671. if (Src <> nil) and (Dest<>nil) then begin
  1672. if ToOem then CharToOem(Src,Dest)
  1673. else OemToChar(Src,Dest);
  1674. result:= StrLen(Dest);
  1675. end else result:=0;
  1676. end;
  1677. {$else}
  1678. procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
  1679. begin
  1680. end;
  1681. {$endif}
  1682. {$endif}
  1683. procedure TDbf.ClearCalcFields(Buffer: PChar);
  1684. begin
  1685. FillChar(Buffer[_dbfFile.RecordSize], CalcFieldsSize, 0);
  1686. end;
  1687. procedure TDbf.InternalSetToRecord(Buffer: PChar); {override virtual abstract from TDataset}
  1688. var
  1689. prec:pDbfRecord;
  1690. begin
  1691. if Buffer=nil then exit;
  1692. prec:=pDbfRecord(Buffer);
  1693. _PhysicalRecno:=prec^.BookmarkData.RecNo;
  1694. _ResyncIndexes(Buffer);
  1695. end;
  1696. procedure TDbf._ResyncIndexes(Buffer: PChar);
  1697. var
  1698. i:integer;
  1699. lindex:TIndex;
  1700. begin
  1701. if _indexes.Count>0 then begin
  1702. _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
  1703. for i:=0 to _indexes.Count-1 do begin
  1704. lindex:=TIndex(_indexes.Items[i]);
  1705. lindex.GotoKey(_physicalRecno,nil);
  1706. end;
  1707. end;
  1708. end;
  1709. function TDbf.IsCursorOpen: Boolean; {override virtual abstract from TDataset}
  1710. begin
  1711. result:=_IsCursorOpen;
  1712. end;
  1713. procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); {override virtual abstract from TDataset}
  1714. var
  1715. prec:pDbfRecord;
  1716. begin
  1717. prec:=pDbfRecord(Buffer);
  1718. prec^.BookMarkFlag:=Value;
  1719. end;
  1720. procedure TDbf.SetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
  1721. var
  1722. prec:pDbfRecord;
  1723. begin
  1724. prec:=pDbfRecord(Buffer);
  1725. prec^.BookMarkData:=pBookMarkData(Data)^;
  1726. end;
  1727. procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
  1728. var
  1729. prec:pDbfRecord;
  1730. dst:pointer;
  1731. begin
  1732. if (Field.FieldNo >= 0) then begin
  1733. prec:=pDbfRecord(ActiveBuffer);
  1734. dst:=@prec^.DeletedFlag;
  1735. _dbfFile.SetFieldData(Field.FieldNo - 1,Field.DataType,Buffer,Dst);
  1736. end else begin { ***** fkCalculated, fkLookup ***** }
  1737. prec:=pDbfRecord(CalcBuffer);
  1738. dst:=@prec^.DeletedFlag;
  1739. Inc(integer(dst), GetRecordSize + Field.Offset);
  1740. Boolean(dst^) := LongBool(Buffer);
  1741. if Boolean(dst^) then begin
  1742. Inc(integer(dst), 1);
  1743. Move(Buffer^, dst^, Field.DataSize);
  1744. end;
  1745. end; { end of ***** fkCalculated, fkLookup ***** }
  1746. if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
  1747. DataEvent(deFieldChange, Longint(Field));
  1748. end;
  1749. end;
  1750. // this function is just for the grid scrollbars
  1751. // it doesn't have to be perfectly accurate, but fast.
  1752. function TDbf.GetRecordCount: Integer; {override virtual}
  1753. begin
  1754. if _curIndex=nil then begin
  1755. result:=_dbfFile.RecordCount;
  1756. end else begin
  1757. result:=_curIndex.GuessRecordCount;
  1758. end;
  1759. end;
  1760. // this function is just for the grid scrollbars
  1761. // it doesn't have to be perfectly accurate, but fast.
  1762. function TDbf.GetRecNo: Integer; {override virtual}
  1763. begin
  1764. UpdateCursorPos;
  1765. if _curIndex=nil then begin
  1766. result:=_PhysicalRecno+1;
  1767. end else begin
  1768. result:=_curIndex.GuessRecNo;
  1769. end;
  1770. end;
  1771. procedure TDbf.SetRecNo(Value: Integer); {override virual}
  1772. begin
  1773. if _curIndex=nil then begin
  1774. _PhysicalRecno:=Value-1;
  1775. end else begin
  1776. //result:=_curIndex.GuessRecNo;
  1777. end;
  1778. Resync([rmExact]);
  1779. end;
  1780. procedure TDBf.DeleteIndex(const AName: string);
  1781. begin
  1782. // I must admit that is seems a bit expeditive.
  1783. // but I does implement this method because TTable does
  1784. DeleteFile(_GetPath + Name);
  1785. end;
  1786. procedure TDbf.CloseIndexFile(const IndexFileName: string);
  1787. var
  1788. lindex:tindex;
  1789. begin
  1790. lindex:=_GetIndex(IndexFileName);
  1791. if lindex<>nil then begin
  1792. lindex.Free;
  1793. _indexes.Delete(_indexes.IndexOf(lindex));
  1794. if _curindex = lindex then begin
  1795. _curindex:=nil;
  1796. resync([]);
  1797. end;
  1798. end;
  1799. end;
  1800. procedure TDbf.OpenIndexFile(AnIndexName:string);
  1801. var
  1802. lIndexFile:TIndexFile;
  1803. lIndex:TIndex;
  1804. begin
  1805. lindex:=_GetIndex(IndexName);
  1806. if lindex=nil then begin
  1807. IndexName:=lowercase(_GetPath + IndexName);
  1808. lIndexFile:=TIndexFile(GetPagedFile(IndexName));
  1809. if lIndexFile=nil then begin
  1810. lIndexFile:=TIndexFile.Create(IndexName,fmOpenReadWrite + fmShareDenyWrite);
  1811. end;
  1812. lIndex:=TIndex.Create(lIndexFile,0,false);
  1813. _Indexes.Add(lIndex);
  1814. lIndex.InitFieldDef(_DbfFile,lIndex._NdxHdr.KeyDesc);
  1815. end;
  1816. end;
  1817. (*
  1818. procedure TDbfFile.DbfFile_PackTable;
  1819. var
  1820. begin
  1821. end;
  1822. *)
  1823. {$ifdef fpc}
  1824. procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);
  1825. begin
  1826. AddIndex(indexName,IndexFields,options,'');
  1827. end;
  1828. {$endif}
  1829. {$ifdef DELPHI_3}
  1830. procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
  1831. var
  1832. DescFields:string;
  1833. {$else}
  1834. {$ifndef fpc}
  1835. procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
  1836. var
  1837. {$else}
  1838. procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);
  1839. var
  1840. {$endif}
  1841. {$endif}
  1842. lfilename:string;
  1843. lIndexFile:TIndexFile;
  1844. lIndex:TIndex;
  1845. cur,thelast:integer;
  1846. begin
  1847. lfilename:=lowercase(_GetPath+IndexName);
  1848. lIndexFile:=TIndexFile(GetPagedFile(lfilename));
  1849. if lIndexFile<>nil then exit;
  1850. lIndexFile:=TIndexFile.Create(lfilename,fmCreate);
  1851. lIndex:=TIndex.Create(lIndexFile,0,true);
  1852. {$ifndef fpc}
  1853. lIndex.InitFieldDef(_DbfFile,Fields);
  1854. {$else}
  1855. lIndex.InitFieldDef(_DbfFile,IndexFields);
  1856. {$endif}
  1857. with lIndex._NdxHdr do begin
  1858. startpage:=1;
  1859. nbPage:=1;
  1860. keyformat:=#0;
  1861. keytype:='C';
  1862. dummy:=$5800;
  1863. keylen:=lindex._FieldLen;
  1864. nbkey:=(512-8) div (lindex._FieldLen+8);
  1865. keyreclen:=lindex._FieldLen+8;
  1866. Unique:=0;
  1867. KeyDesc[0]:=' ';
  1868. {$ifndef fpc}
  1869. StrLCopy(KeyDesc,PChar(UpperCase(Fields)),255);
  1870. {$else}
  1871. StrLCopy(KeyDesc,PChar(UpperCase(IndexFields)),255);
  1872. {$endif}
  1873. end;
  1874. lindex._IndexFile._Seek(lindex._RootPage);
  1875. lindex._IndexFile.Stream.Write(lindex._NdxHdr,SizeOf(lindex._NdxHdr));
  1876. cur:=0;
  1877. thelast:=_DbfFile.CalcRecordCount;
  1878. while cur<thelast do begin
  1879. _DbfFile.ReadRecord(cur, _PrevBuffer);
  1880. lIndex.Insert(cur,_PrevBuffer);
  1881. inc(cur);
  1882. end;
  1883. _Indexes.Add(lIndex);
  1884. end;
  1885. //==========================================================
  1886. //============ dbtfile
  1887. //==========================================================
  1888. constructor TDbtFile.Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
  1889. begin
  1890. inherited Create(FileName,Mode);
  1891. _DbtVersion:=Ver;
  1892. if mode = fmCreate then begin
  1893. FillChar(_MemoHdr,sizeof(_MemoHdr),0);
  1894. end else begin
  1895. Stream.Position:=0;
  1896. Stream.read(_MemoHdr,SizeOf(_MemoHdr));
  1897. end;
  1898. HeaderSize:=0;
  1899. RecordSize:=_MemoHdr.BlockLen;
  1900. if (RecordSize=0) or ((RecordSize mod 128)<>0) then begin
  1901. _MemoHdr.BlockLen := $200;
  1902. RecordSize := $200;
  1903. end;
  1904. // Can you tell me why the header of dbase3 memo contains 1024 and it 512 ?
  1905. if _DbtVersion=xBaseIII then RecordSize:=512;
  1906. end;
  1907. procedure TDbtFile.ReadMemo(recno:Integer;Dst:TStream);
  1908. var
  1909. Buff:array[0..511] of char;
  1910. i,lsize:integer;
  1911. finish:boolean;
  1912. lastc:char;
  1913. begin
  1914. if recno=0 then Exit;
  1915. Stream.Position:= RecordSize * recno;
  1916. if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
  1917. Stream.read(Buff[0],8);
  1918. if (Buff[0]=#$ff) and (Buff[1]=#$ff) and
  1919. (Buff[2]=#$08) and (Buff[3]=#$00) then begin
  1920. // dbase IV memo
  1921. lsize:=(PInteger(@Buff[4])^)-8;
  1922. end else begin
  1923. lsize:=0;
  1924. end;
  1925. repeat
  1926. if lsize>SizeOf(Buff) then begin
  1927. Stream.read(Buff,SizeOf(Buff));
  1928. Dst.Write(buff,SizeOf(Buff));
  1929. Dec(lsize,SizeOf(Buff));
  1930. end else if lsize>0 then begin
  1931. Stream.read(Buff,lsize);
  1932. Dst.Write(buff,lsize);
  1933. lsize:=0;
  1934. end;
  1935. until lsize=0;
  1936. end else begin
  1937. finish:=False;
  1938. Stream.read(Buff,SizeOf(Buff));
  1939. lastc:=#0;
  1940. repeat
  1941. for i:=0 to SizeOf(Buff)-2 do begin
  1942. if ((Buff[i]=#$1A) and
  1943. ((Buff[i+1]=#$1A) or ((i=0) and (lastc=#$1A))))
  1944. or (Buff[i]=#$0)
  1945. then begin
  1946. if i>0 then Dst.Write(buff,i);
  1947. finish:=True;
  1948. break;
  1949. end;
  1950. end;
  1951. if finish then Break;
  1952. Dst.Write(buff,512);
  1953. lastc:=Buff[511];
  1954. Stream.read(Buff,SizeOf(Buff));
  1955. until finish;
  1956. end;
  1957. Dst.Seek(0,0);
  1958. end;
  1959. procedure TDbtFile.WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
  1960. var
  1961. ByteBefore:Integer;
  1962. ByteAfter:Integer;
  1963. Buff:array[0..511] of char;
  1964. i:Integer;
  1965. c:Byte;
  1966. Append:Boolean;
  1967. begin
  1968. if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
  1969. ByteBefore:=8;
  1970. ByteAfter:=0;
  1971. end else begin // stupid files
  1972. ByteBefore:=0;
  1973. ByteAfter:=2;
  1974. end;
  1975. if Src.Size = 0 then begin
  1976. MemoRecno:=0;
  1977. end else begin
  1978. if ((ByteBefore+Src.Size+ByteAfter+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
  1979. <= ((ReadSize+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
  1980. then begin
  1981. Append:=false;
  1982. //MemoRecno:=MemoRecno;
  1983. end else begin
  1984. Append:=True;
  1985. MemoRecno:=_MemoHdr.NextBlock;
  1986. if MemoRecno=0 then begin
  1987. _MemoHdr.NextBlock:=1;
  1988. MemoRecno:=1;
  1989. end;
  1990. end;
  1991. Stream.Seek(_MemoHdr.BlockLen * MemoRecno,0);
  1992. i:=Src.Position;
  1993. Src.Seek(0,0);
  1994. if ByteBefore=8 then begin
  1995. i:=$0008ffff;
  1996. Stream.Write(i,4);
  1997. i:=Src.Size+ByteBefore+ByteAfter;
  1998. Stream.Write(i,4);
  1999. end;
  2000. repeat
  2001. i:=Src.Read(buff,512);
  2002. if i=0 then break;
  2003. Inc(_MemoHdr.NextBlock);
  2004. Stream.Write(Buff,i);
  2005. until i<512;
  2006. if ByteAfter=2 then begin
  2007. c:=$1A;
  2008. Stream.Write(c,1);
  2009. Stream.Write(c,1);
  2010. end;
  2011. if Append then begin
  2012. Stream.Seek(0,0);
  2013. Stream.Write(_MemoHdr,SizeOf(_MemoHdr))
  2014. end;
  2015. end;
  2016. end;
  2017. //==========================================================
  2018. //============ TIndexFile
  2019. //==========================================================
  2020. constructor TIndexFile.Create(const FileName: string; Mode: Word);
  2021. var
  2022. ext:string;
  2023. i:Integer;
  2024. begin
  2025. inherited Create(FileName,Mode);
  2026. HeaderSize:=0;
  2027. RecordSize:=512;
  2028. ext:=ExtractFileExt(FileName);
  2029. if (ext='.mdx') then begin
  2030. _IndexVersion:=xBaseIV;
  2031. if Mode = fmCreate then begin
  2032. FillChar(_MdxHdr,sizeof(_MdxHdr),0);
  2033. end else begin
  2034. Stream.read(_MdxHdr,SizeOf(_MdxHdr));
  2035. end;
  2036. for i:= 0 to _MdxHdr.TagUsed-1 do begin
  2037. // Stream.Position :=544 + i * _MdxHdr.TagSize;
  2038. // Stream.read(lMdxTag,SizeOf(rMdxTag));
  2039. // lIndex:=TIndex.Create(Self,lMdxTag.pageno);
  2040. // _Indexes.Add(lIndex);
  2041. // if i=0 then lIndex.ReadPage(lIndex._NdxHdr.startpage);
  2042. end;
  2043. end else begin
  2044. _IndexVersion:=xBaseIII;
  2045. (*
  2046. _IndexFile._Seek(Pos);
  2047. _IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
  2048. _Root:=TIndexPage.Create(Self);
  2049. _Root.SetPageNo(_NdxHdr.startpage);
  2050. lPos:=_Root;
  2051. _nblevel:=1;
  2052. repeat
  2053. lPos.LocalFirst;
  2054. if lPos.Entry._LowerPage=0 then break;
  2055. inc(_nblevel);
  2056. lChild:=TIndexPage.Create(Self);
  2057. lChild._UpperLevel:=lPos;
  2058. lPos._LowerLevel:=lChild;
  2059. lChild.SetPageNo(lPos.Entry._LowerPage);
  2060. lPos:=lChild;
  2061. until false;
  2062. _Spare:=TIndexPage.Create(Self);
  2063. // _Field:=_IndexFile._Dbf.FindField(_NdxHdr.KeyDesc);
  2064. First;
  2065. *)
  2066. end;
  2067. end;
  2068. destructor TIndexFile.Destroy;
  2069. begin
  2070. inherited;
  2071. end;
  2072. //==========================================================
  2073. //============ TIndexPage
  2074. //==========================================================
  2075. constructor TIndexPage.Create(Parent:TIndex);
  2076. begin
  2077. _LowerLevel:=nil;
  2078. _UpperLevel:=nil;
  2079. _Index:=Parent;
  2080. _PageNo:=-1;
  2081. _EntryNo:=-1;
  2082. end;
  2083. destructor TIndexPage.Destroy;
  2084. begin
  2085. if _LowerLevel<>nil then _LowerLevel.Free;
  2086. end;
  2087. function TIndexPage.GetPEntry(EntryNo:integer):PNdxEntry;
  2088. begin
  2089. Result:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
  2090. end;
  2091. function TIndexPage.LocalInsert(Recno:integer; Buffer:Pchar;LowerPage:integer):boolean;
  2092. var
  2093. src,dst:pointer;
  2094. siz:integer;
  2095. begin
  2096. if _PageBuff.NbEntries < _Index._NdxHdr.nbkey then begin
  2097. src:=Entry;
  2098. dst:=GetPEntry(_EntryNo+1);
  2099. siz:=(_PageBuff.NbEntries - _EntryNo)
  2100. * _Index._NdxHdr.keyreclen + 8;
  2101. Move(Src^, Dst^, Siz);
  2102. inc(_PageBuff.NbEntries);
  2103. SetEntry(Recno,Buffer,LowerPage);
  2104. Write;
  2105. Result:=true;
  2106. end else begin
  2107. Result:=false;
  2108. end;
  2109. end;
  2110. function TIndexPage.LocalDelete:boolean;
  2111. var
  2112. src,dst:pointer;
  2113. siz:integer;
  2114. begin
  2115. if _PageBuff.NbEntries >=0 then begin
  2116. if _EntryNo<_PageBuff.NbEntries then begin
  2117. src:=GetPEntry(_EntryNo+1);
  2118. dst:=Entry;
  2119. siz:=(_PageBuff.NbEntries - _EntryNo - 1)
  2120. * _Index._NdxHdr.keyreclen + 8;
  2121. Move(Src^, Dst^, Siz);
  2122. end;
  2123. dec(_PageBuff.NbEntries);
  2124. Write;
  2125. if ((_PageBuff.NbEntries=0) and (_lowerlevel=nil))
  2126. or (_PageBuff.NbEntries<0) then begin
  2127. if _UpperLevel<>nil then begin
  2128. _UpperLevel.LocalDelete;
  2129. end;
  2130. end else if (_EntryNo>LastEntryNo) then begin
  2131. SetEntryNo(LastEntryNo); // We just removed the last on this page.
  2132. if (_UpperLevel<>nil) then begin
  2133. _UpperLevel.SetEntry(0,Entry^.CKey,_PageNo);
  2134. end;
  2135. end;
  2136. Result:=true;
  2137. end else begin
  2138. Result:=false;
  2139. end;
  2140. end;
  2141. function TIndexPage.LastEntryNo:integer;
  2142. begin
  2143. if (_LowerLevel=nil) then begin
  2144. result := _PageBuff.NbEntries - 1;
  2145. end else begin
  2146. result := _PageBuff.NbEntries;
  2147. end;
  2148. end;
  2149. procedure TIndexPage.LocalFirst;
  2150. begin
  2151. SetEntryNo(0);
  2152. end;
  2153. procedure TIndexPage.LocalLast;
  2154. begin
  2155. SetEntryNo(LastEntryNo);
  2156. end;
  2157. function TIndexPage.LocalPrev:boolean;
  2158. begin
  2159. if _EntryNo>0 then begin
  2160. SetEntryNo(_EntryNo-1);
  2161. Result:=true;
  2162. end else begin
  2163. Result:=false;
  2164. end;
  2165. end;
  2166. function TIndexPage.LocalNext:boolean;
  2167. begin
  2168. if (_EntryNo<LastEntryNo) then begin
  2169. SetEntryNo(_EntryNo+1);
  2170. Result:=true;
  2171. end else begin
  2172. Result:=false;
  2173. end;
  2174. end;
  2175. procedure TIndexPage.First;
  2176. begin
  2177. LocalFirst;
  2178. if (_LowerLevel<>nil) then LowerLevel.First;
  2179. end;
  2180. procedure TIndexPage.Last;
  2181. begin
  2182. LocalLast;
  2183. if (_LowerLevel<>nil) then LowerLevel.Last;
  2184. end;
  2185. function TIndexPage.Prev:boolean;
  2186. begin
  2187. if (_LowerLevel<>nil) and LowerLevel.Prev then begin
  2188. result:=true;
  2189. exit;
  2190. end;
  2191. Result:=LocalPrev;
  2192. if Result and (Entry^._LowerPage>0) then LowerLevel.Last;
  2193. end;
  2194. function TIndexPage.Next:boolean;
  2195. begin
  2196. if (_LowerLevel<>nil) and LowerLevel.next then begin
  2197. result:=true;
  2198. exit;
  2199. end;
  2200. Result:=LocalNext;
  2201. if Result and (Entry^._LowerPage>0) then LowerLevel.First;
  2202. end;
  2203. function TIndexPage.FindNearest(Recno:integer; Key:pchar):integer;
  2204. var
  2205. cmpres:integer;
  2206. v1,v2:double;
  2207. p:TIndexPage;
  2208. begin
  2209. Result:=-1;
  2210. if @Key=nil then begin
  2211. Exit;
  2212. end;
  2213. SetEntryNo(0);
  2214. while _EntryNo<=_PageBuff.NbEntries do begin
  2215. if _EntryNo=_PageBuff.NbEntries then break;
  2216. if _Index._NdxHdr.keytype='C' then begin
  2217. cmpres:=StrLIComp(PChar(Key),Entry^.CKey,_Index._FieldLen);
  2218. end else begin
  2219. // Numeric field... to do
  2220. v1:=PDouble(Key)^;
  2221. v2:=Entry^.NKey;
  2222. if v1>v2 then cmpres:=1
  2223. else if v1<v2 then cmpres:=-1
  2224. else cmpres:=0;
  2225. end;
  2226. if cmpres=0 then begin
  2227. if _LowerLevel=nil then begin
  2228. if (Entry^.RecNo=Recno) then begin
  2229. result:=0;
  2230. Exit;
  2231. end else if (Entry^.Recno>Recno) then begin
  2232. result:=-1;
  2233. Exit;
  2234. end;
  2235. end else begin
  2236. p:=self;
  2237. while p._LowerLevel<>nil do begin
  2238. p:=p.LowerLevel;
  2239. p.LocalLast;
  2240. end;
  2241. if (p.Entry^.Recno>=Recno) then begin
  2242. result:=-1;
  2243. Exit;
  2244. end;
  2245. end;
  2246. end else if cmpres<0 then begin
  2247. result:=-1;
  2248. exit;
  2249. end;
  2250. SetEntryNo(_EntryNo+1);
  2251. end;
  2252. result:=1;
  2253. Exit;
  2254. end;
  2255. procedure TIndexPage.SetEntry(Recno:Integer; key:PChar; LowerPage:integer);
  2256. begin
  2257. assert((_EntryNo>=0) and (_EntryNo<=_PageBuff.NbEntries));
  2258. if (_EntryNo=self._PageBuff.NbEntries) then begin
  2259. if (_UpperLevel<>nil) then begin
  2260. _UpperLevel.SetEntry(0,key,Self._PageNo);
  2261. end;
  2262. end else begin
  2263. if _Index._NdxHdr.keytype='C' then begin
  2264. mymove(key,Entry^.CKey,_Index._NdxHdr.keylen);
  2265. end else begin
  2266. Entry^.NKey:=PDouble(key)^;
  2267. end;
  2268. end;
  2269. Entry^.RecNo:=RecNo;
  2270. Entry^._LowerPage:=LowerPage;
  2271. Write;
  2272. end;
  2273. function TIndexPage.LowerLevel : TIndexPage;
  2274. begin
  2275. if (_LowerLevel<>nil) and (_LowerLevel._PageNo<>Entry^._LowerPage) then begin
  2276. _LowerLevel.SetPageNo(Entry^._LowerPage);
  2277. end;
  2278. result:=_LowerLevel;
  2279. end;
  2280. function TIndexPage.Insert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
  2281. var
  2282. src,dst:PNdxEntry;
  2283. siz:integer;
  2284. split,old_entry:integer;
  2285. lSpare:TIndexPage;
  2286. begin
  2287. if not LocalInsert(recno,buffer,lowerpage) then begin
  2288. // The entry is FULL so we will split this page
  2289. // 1 - Check parent exist
  2290. if _UpperLevel=nil then begin
  2291. AddNewLevel;
  2292. end;
  2293. old_entry:=_EntryNo;
  2294. split:=_EntryNo;
  2295. if split < _Index._NdxHdr.nbkey div 2 then begin
  2296. split:=_Index._NdxHdr.nbkey div 2;
  2297. end;
  2298. lSpare:=TIndexPage.Create(_Index);
  2299. try
  2300. // 2 - Create new page with first part
  2301. inc(_Index._NdxHdr.nbPage);
  2302. lSpare._PageNo:=_Index._NdxHdr.nbPage;
  2303. _Index._IndexFile._Seek(_Index._RootPage);
  2304. _Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));
  2305. if _lowerlevel=nil then begin
  2306. lSpare._PageBuff.NbEntries:=split;
  2307. end else begin
  2308. lSpare._PageBuff.NbEntries:=split-1;
  2309. end;
  2310. siz:=split*_Index._NdxHdr.keyreclen+8;
  2311. src:=@_PageBuff.Entries;
  2312. dst:=@lSpare._PageBuff.Entries;
  2313. Move(src^,dst^,siz);
  2314. lSpare.Write;
  2315. // 3 - Keep only end-part in this page
  2316. siz:=(_PageBuff.NbEntries-Split);
  2317. _PageBuff.NbEntries:=siz;
  2318. siz:=siz*_Index._NdxHdr.keyreclen+8;
  2319. SetEntryNo(split);
  2320. src:=Entry;
  2321. SetEntryNo(0);
  2322. dst:=Entry;
  2323. Move(src^,dst^,siz);
  2324. // 3 - Update upper level
  2325. lSpare.SetEntryNo(split-1);
  2326. _UpperLevel.Insert(0,lSpare.Entry^.CKey,lSpare._PageNo);
  2327. // We just need to go on inserted record now
  2328. if old_entry>=split then begin
  2329. _UpperLevel.LocalNext;
  2330. SetEntryNo(old_entry - split);
  2331. LocalInsert(Recno,Buffer,LowerPage);
  2332. lSpare.Write;
  2333. end else begin
  2334. lSpare.SetEntryNo(old_entry);
  2335. lSpare.LocalInsert(Recno,Buffer,LowerPage);
  2336. Write;
  2337. end;
  2338. finally
  2339. lspare.free;
  2340. end;
  2341. end;
  2342. Result:=true;
  2343. end;
  2344. function TIndexPage.Delete:boolean;
  2345. begin
  2346. Result:=LocalDelete;
  2347. end;
  2348. procedure TIndexPage.SetPageNo(page:Integer);
  2349. begin
  2350. if (_PageNo<>page) and (page>0) then begin
  2351. _Index._IndexFile.ReadRecord(Page,@_PageBuff);
  2352. _PageNo:=page;
  2353. _EntryNo:=-1;
  2354. end;
  2355. end;
  2356. procedure TIndexPage.AddNewLevel;
  2357. var
  2358. lNewPage:TIndexPage;
  2359. begin
  2360. lNewPage:=TIndexPage.Create(_Index);
  2361. inc(_Index._NdxHdr.nbPage);
  2362. lNewPage._PageNo:= _Index._NdxHdr.nbPage;
  2363. _Index._NdxHdr.startpage:= _Index._NdxHdr.nbPage;
  2364. _Index._IndexFile._Seek(_Index._RootPage);
  2365. _Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));
  2366. lNewPage._PageBuff.NbEntries:=0;
  2367. lNewPage._UpperLevel:=nil;
  2368. lNewPage._LowerLevel:=_Index._Root;
  2369. lNewPage.SetEntryNo(0);
  2370. lNewPage.SetEntry(0,nil,_PageNo);
  2371. _Index._Root._UpperLevel:=lNewPage;
  2372. _Index._Root:=lNewPage;
  2373. lNewPage:=nil;
  2374. end;
  2375. procedure TIndexPage.Write;
  2376. begin
  2377. _Index._IndexFile.WriteRecord(_PageNo,@_PageBuff);
  2378. end;
  2379. procedure TIndexPage.SetEntryNo(entryno:Integer);
  2380. begin
  2381. if (_EntryNo<>entryno) then begin
  2382. _EntryNo:=entryno;
  2383. if _EntryNo>=0 then Entry:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
  2384. end;
  2385. end;
  2386. procedure TIndexPage.WritePage(Page:integer);
  2387. begin
  2388. _Index._IndexFile.WriteRecord(Page,@_PageBuff);
  2389. end;
  2390. //==========================================================
  2391. //============ TIndex
  2392. //==========================================================
  2393. constructor TIndex.Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
  2394. var
  2395. lPos:TIndexPage;
  2396. lChild:TIndexPage;
  2397. begin
  2398. _RootPage:=RootPage;
  2399. _IndexFile:=Parent;
  2400. //_IndexOrder:=TList.Create;
  2401. if CreateIt then begin
  2402. FillChar(_NdxHdr,sizeof(_NdxHdr),0);
  2403. _NdxHdr.startpage:=1;
  2404. _NdxHdr.nbPage:=2;
  2405. _NdxHdr.keyformat:=#0;
  2406. _NdxHdr.keytype:='C';
  2407. _IndexFile._Seek(RootPage);
  2408. _IndexFile.Stream.Write(_NdxHdr,SizeOf(_NdxHdr));
  2409. _FieldPos := 0;
  2410. _FieldLen := 0;
  2411. end else begin
  2412. _IndexFile._Seek(RootPage);
  2413. _IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
  2414. end;
  2415. _Root:=TIndexPage.Create(Self);
  2416. _Root.SetPageNo(_NdxHdr.startpage);
  2417. lPos:=_Root;
  2418. _nblevel:=1;
  2419. repeat
  2420. lPos.LocalFirst;
  2421. if lPos.Entry^._LowerPage=0 then break;
  2422. inc(_nblevel);
  2423. lChild:=TIndexPage.Create(Self);
  2424. lChild._UpperLevel:=lPos;
  2425. lPos._LowerLevel:=lChild;
  2426. lChild.SetPageNo(lPos.Entry^._LowerPage);
  2427. lPos:=lChild;
  2428. until false;
  2429. inc(_IndexFile._cntuse);
  2430. First;
  2431. end;
  2432. destructor TIndex.Destroy;
  2433. begin
  2434. _IndexFile.Release;
  2435. _Root.Free;
  2436. end;
  2437. function TIndex.Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
  2438. var
  2439. res:integer;
  2440. begin
  2441. pPos:=_Root;
  2442. repeat
  2443. res:=pPos.FindNearest(Recno,Buffer);
  2444. if res<>0 then begin
  2445. if pPos.Entry^._LowerPage<>0 then begin
  2446. pPos:=pPos.LowerLevel;
  2447. res:=2;
  2448. end;
  2449. end;
  2450. until res<>2;
  2451. Result:=res;
  2452. end;
  2453. procedure TIndex.Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
  2454. var
  2455. lPos:TIndexPage;
  2456. begin
  2457. if _FieldLen=0 then exit;
  2458. inc(PrevBuffer,_FieldPos);
  2459. inc(NewBuffer,_FieldPos);
  2460. if StrLIComp(PrevBuffer,NewBuffer,_FieldLen)<>0 then begin
  2461. Delete;
  2462. Find(Recno+1,NewBuffer,lPos);
  2463. lPos.Insert(Recno+1,NewBuffer,0);
  2464. end;
  2465. end;
  2466. procedure TIndex.Insert(Recno:integer; Buffer:PChar);
  2467. var
  2468. lPos:TIndexPage;
  2469. begin
  2470. if _FieldLen=0 then exit;
  2471. inc(Buffer,_FieldPos);
  2472. Find(Recno+1,Buffer,lPos);
  2473. lPos.Insert(Recno+1,Buffer,0);
  2474. end;
  2475. function TIndex.Delete:boolean;
  2476. var
  2477. lPos:TIndexPage;
  2478. begin
  2479. lpos:=_root;
  2480. while lpos._LowerLevel<>nil do begin
  2481. lPos:=lPos.LowerLevel;
  2482. end;
  2483. lPos.Delete;
  2484. Result:=true;
  2485. end;
  2486. function TIndex.Pos:TIndexPage;
  2487. var
  2488. p:TIndexPage;
  2489. begin
  2490. p:=_Root;
  2491. while p.Entry^._LowerPage>0 do begin
  2492. p:=p.LowerLevel;
  2493. end;
  2494. result:=p;
  2495. end;
  2496. procedure TIndex.First;
  2497. begin
  2498. _Root.First;
  2499. dec(Pos._EntryNo);
  2500. end;
  2501. procedure TIndex.Last;
  2502. begin
  2503. _Root.Last;
  2504. inc(Pos._EntryNo);
  2505. end;
  2506. function TIndex.Prev:boolean;
  2507. begin
  2508. result:=_Root.Prev;
  2509. end;
  2510. function TIndex.Next:boolean;
  2511. begin
  2512. result:=_Root.Next;
  2513. end;
  2514. (*
  2515. procedure TIndex.SetRecNo(Value: Integer);
  2516. var
  2517. pos:integer;
  2518. p:TIndexPage;
  2519. i:integer;
  2520. ldiv:integer;
  2521. begin
  2522. p:=_Root;
  2523. ldiv:=1;
  2524. while p.Entry^._LowerPage>0 do begin
  2525. ldiv:=ldiv*(_NdxHdr.nbkey+1);
  2526. p:=p._LowerLevel;
  2527. end;
  2528. pos:=value div ldiv;
  2529. p:=_Root;
  2530. while p.Entry^._LowerPage>0 do begin
  2531. p._EntryNo:=pos;
  2532. value:=value - pos * (_NdxHdr.nbkey+1);
  2533. ldiv:=ldiv div (_NdxHdr.nbkey+1);
  2534. pos:=value div ldiv;
  2535. p:=p._LowerLevel;
  2536. end;
  2537. {
  2538. pos:=1;
  2539. First;
  2540. While pos<value do begin
  2541. if Next = false then break;
  2542. inc(pos);
  2543. end;
  2544. }
  2545. end;
  2546. *)
  2547. function TIndex.GuessRecordCount: Integer;
  2548. var
  2549. lPos:TIndexPage;
  2550. nbrecord:integer;
  2551. begin
  2552. // I just read first level and Guess an approximate record count...
  2553. nbrecord:=_Root._PageBuff.NbEntries;
  2554. lPos:=_Root.LowerLevel;
  2555. while lpos<>nil do begin
  2556. nbrecord:=nbrecord*(_NdxHdr.nbkey+1);
  2557. lPos:=lPos.LowerLevel;
  2558. end;
  2559. result:=nbrecord;
  2560. end;
  2561. function TIndex.GuessRecNo:Integer;
  2562. var
  2563. p:TIndexPage;
  2564. begin
  2565. p:=_Root;
  2566. result:=p._EntryNo;
  2567. while p.Entry^._LowerPage>0 do begin
  2568. p:=p.LowerLevel;
  2569. Result:=Result*(_NdxHdr.nbkey+1) + p._EntryNo;
  2570. end;
  2571. end;
  2572. function TIndex.GetRealRecNo:integer;
  2573. var
  2574. ippos : TIndexPage;
  2575. begin
  2576. ippos:=_Root;
  2577. while ippos._LowerLevel<>nil do begin
  2578. ippos:=pos.LowerLevel;
  2579. end;
  2580. if (ippos._EntryNo<0) or (ippos._EntryNo>=ippos._PageBuff.NbEntries) then Result:=-1
  2581. else Result:=ippos.Entry^.RecNo-1;
  2582. end;
  2583. procedure TIndex.GotoKey(recno:integer; buffer:pchar);
  2584. begin
  2585. // very temporary implementation
  2586. // could definitely be a bit faster.
  2587. _Root.First;
  2588. repeat
  2589. if self.Pos.Entry^.RecNo=(recno+1) then begin
  2590. exit;
  2591. end;
  2592. until Next=false;
  2593. end;
  2594. procedure TIndex.InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
  2595. var
  2596. FieldInfo:TMyFieldInfo;
  2597. begin
  2598. FieldInfo:=DbfFile.GetFieldInfo(FieldDesc);
  2599. if FieldInfo<>nil then begin
  2600. _FieldPos:=FieldInfo.Offset;
  2601. _FieldLen:=FieldInfo.Size;
  2602. end;
  2603. end;
  2604. //==========================================================
  2605. //============ initialization
  2606. //==========================================================
  2607. {$ifndef fpc}
  2608. type
  2609. TTableNameProperty = class(TStringProperty)
  2610. public
  2611. procedure Edit; override;
  2612. function GetAttributes: TPropertyAttributes; override;
  2613. end;
  2614. procedure TTableNameProperty.Edit; {override;}
  2615. var
  2616. FileOpen: TOpenDialog;
  2617. Dbf: TDbf;
  2618. begin
  2619. FileOpen := TOpenDialog.Create(Application);
  2620. try
  2621. with fileopen do begin
  2622. Dbf:=GetComponent(0) as TDbf;
  2623. Filename := Dbf.DesignTimePath + GetValue;
  2624. Filter := 'Dbf table|*.dbf';
  2625. if Execute then begin
  2626. SetValue(ExtractFilename(Filename));
  2627. Dbf.DesignTimePath:=ExtractFilePath(Filename);
  2628. end;
  2629. end;
  2630. finally
  2631. Fileopen.free;
  2632. end;
  2633. end;
  2634. function TTableNameProperty.GetAttributes: TPropertyAttributes; {override;}
  2635. begin
  2636. Result := [paDialog, paRevertable];
  2637. end;
  2638. type
  2639. TRunTimePathProperty = class(TStringProperty)
  2640. end;
  2641. TDesignTimePathProperty = class(TStringProperty)
  2642. end;
  2643. //==========================================================
  2644. //============ initialization
  2645. //==========================================================
  2646. procedure Register;
  2647. begin
  2648. RegisterComponents('Exemples', [TDbf]);
  2649. RegisterPropertyEditor(TypeInfo(string), TDbf, 'TableName', TTableNameProperty);
  2650. RegisterPropertyEditor(TypeInfo(string), TDbf, 'RunTimePath', TRunTimePathProperty);
  2651. RegisterPropertyEditor(TypeInfo(string), TDbf, 'DesignTimePath', TDesignTimePathProperty);
  2652. // RegisterPropertyEditor(TypeInfo(TStrings), TDbf, 'IndexFiles', TIndexFilesProperty);
  2653. // ShowMessage(ToolServices.GetProjectName);
  2654. end;
  2655. {$endif fpc}
  2656. initialization
  2657. _PagedFiles := TList.Create;
  2658. tDbf_TrimFields := true;
  2659. finalization
  2660. _PagedFiles.free;
  2661. end.