1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779 |
- unit dbf_dbffile;
- interface
- {$I dbf_common.inc}
- uses
- Classes, SysUtils,
- {$ifdef SUPPORT_MATH_UNIT}
- Math,
- {$endif}
- {$ifdef WIN32}
- Windows,
- {$else}
- {$ifdef KYLIX}
- Libc,
- {$endif}
- Types, dbf_wtil,
- {$endif}
- Db,
- dbf_common,
- dbf_cursor,
- dbf_pgfile,
- dbf_fields,
- dbf_memo,
- dbf_idxfile;
- //====================================================================
- //=== Dbf support (first part)
- //====================================================================
- // TxBaseVersion = (xUnknown,xClipper,xBaseIII,xBaseIV,xBaseV,xFoxPro,xVisualFoxPro);
- // TPagedFileMode = (pfOpen,pfCreate);
- // TDbfGetMode = (xFirst,xPrev,xCurrent, xNext, xLast);
- // TDbfGetResult = (xOK, xBOF, xEOF, xError);
- type
- //====================================================================
- TDbfIndexMissingEvent = procedure(var DeleteLink: Boolean) of object;
- TUpdateNullField = (unClear, unSet);
- //====================================================================
- TDbfGlobals = class;
- //====================================================================
- TDbfFile = class(TPagedFile)
- protected
- FMdxFile: TIndexFile;
- FMemoFile: TMemoFile;
- FFieldDefs: TDbfFieldDefs;
- FIndexNames: TStringList;
- FIndexFiles: TList;
- FDbfVersion: TXBaseVersion;
- FPrevBuffer: PChar;
- FDefaultBuffer: PChar;
- FRecordBufferSize: Integer;
- FLockUserLen: DWORD;
- FFileCodePage: Cardinal;
- FUseCodePage: Cardinal;
- FFileLangId: Byte;
- FCountUse: Integer;
- FCurIndex: Integer;
- FForceClose: Boolean;
- FLockField: TDbfFieldDef;
- FNullField: TDbfFieldDef;
- FAutoIncPresent: Boolean;
- FCopyDateTimeAsString: Boolean;
- FDateTimeHandling: TDateTimeHandling;
- FOnLocaleError: TDbfLocaleErrorEvent;
- FOnIndexMissing: TDbfIndexMissingEvent;
- function HasBlob: Boolean;
- function GetMemoExt: string;
- function GetLanguageId: Integer;
- function GetLanguageStr: string;
- function GetUseFloatFields: Boolean;
- procedure SetUseFloatFields(NewUse: Boolean);
-
- protected
- procedure ConstructFieldDefs;
- procedure InitDefaultBuffer;
- procedure UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef; Action: TUpdateNullField);
- procedure WriteLockInfo(Buffer: PChar);
- public
- constructor Create;
- destructor Destroy; override;
- procedure Open;
- procedure Close;
- procedure Zap;
- procedure FinishCreate(FieldDefs: TDbfFieldDefs; MemoSize: Integer);
- function GetIndexByName(AIndexName: string): TIndexFile;
- procedure SetRecordSize(NewSize: Integer); override;
- procedure TryExclusive; override;
- procedure EndExclusive; override;
- procedure OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
- function DeleteIndex(const AIndexName: string): Boolean;
- procedure CloseIndex(AIndexName: string);
- procedure RepageIndex(AIndexFile: string);
- procedure CompactIndex(AIndexFile: string);
- function Insert(Buffer: PChar): integer;
- procedure WriteHeader; override;
- procedure ApplyAutoIncToBuffer(DestBuf: PChar); // dBase7 support. Writeback last next-autoinc value
- procedure FastPackTable;
- procedure RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
- procedure Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
- function GetFieldInfo(FieldName: string): TDbfFieldDef;
- function GetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer): Boolean;
- function GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
- procedure SetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer);
- procedure InitRecord(DestBuf: PChar);
- procedure PackIndex(lIndexFile: TIndexFile; AIndexName: string);
- procedure RegenerateIndexes;
- procedure LockRecord(RecNo: Integer; Buffer: PChar);
- procedure UnlockRecord(RecNo: Integer; Buffer: PChar);
- procedure RecordDeleted(RecNo: Integer; Buffer: PChar);
- procedure RecordRecalled(RecNo: Integer; Buffer: PChar);
- property MemoFile: TMemoFile read FMemoFile;
- property FieldDefs: TDbfFieldDefs read FFieldDefs;
- property IndexNames: TStringList read FIndexNames;
- property IndexFiles: TList read FIndexFiles;
- property MdxFile: TIndexFile read FMdxFile;
- property LanguageId: Integer read GetLanguageId;
- property LanguageStr: string read GetLanguageStr;
- property FileCodePage: Cardinal read FFileCodePage;
- property UseCodePage: Cardinal read FUseCodePage write FUseCodePage;
- property FileLangId: Byte read FFileLangId write FFileLangId;
- property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
- property PrevBuffer: PChar read FPrevBuffer;
- property ForceClose: Boolean read FForceClose;
- property CopyDateTimeAsString: Boolean read FCopyDateTimeAsString write FCopyDateTimeAsString;
- property UseFloatFields: Boolean read GetUseFloatFields write SetUseFloatFields;
- property DateTimeHandling: TDateTimeHandling read FDateTimeHandling write FDateTimeHandling;
- property OnIndexMissing: TDbfIndexMissingEvent read FOnIndexMissing write FOnIndexMissing;
- property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
- end;
- //====================================================================
- TDbfCursor = class(TVirtualCursor)
- protected
- FPhysicalRecNo: Integer;
- public
- constructor Create(DbfFile: TDbfFile);
- function Next: Boolean; override;
- function Prev: Boolean; override;
- procedure First; override;
- procedure Last; override;
- function GetPhysicalRecNo: Integer; override;
- procedure SetPhysicalRecNo(RecNo: Integer); override;
- function GetSequentialRecordCount: Integer; override;
- function GetSequentialRecNo: Integer; override;
- procedure SetSequentialRecNo(RecNo: Integer); override;
- end;
- //====================================================================
- TDbfGlobals = class
- protected
- FCodePages: TList;
- FCurrencyAsBCD: Boolean;
- FDefaultOpenCodePage: Integer;
- FDefaultCreateLangId: Byte;
- FUserName: string;
- FUserNameLen: DWORD;
-
- function GetDefaultCreateCodePage: Integer;
- procedure SetDefaultCreateCodePage(NewCodePage: Integer);
- procedure InitUserName;
- public
- constructor Create;
- destructor Destroy; override;
- function CodePageInstalled(ACodePage: Integer): Boolean;
- property CurrencyAsBCD: Boolean read FCurrencyAsBCD write FCurrencyAsBCD;
- property DefaultOpenCodePage: Integer read FDefaultOpenCodePage write FDefaultOpenCodePage;
- property DefaultCreateCodePage: Integer read GetDefaultCreateCodePage write SetDefaultCreateCodePage;
- property DefaultCreateLangId: Byte read FDefaultCreateLangId write FDefaultCreateLangId;
- property UserName: string read FUserName;
- property UserNameLen: DWORD read FUserNameLen;
- end;
- var
- DbfGlobals: TDbfGlobals;
- implementation
- uses
- {$ifndef WIN32}
- {$ifndef FPC}
- RTLConsts,
- {$else}
- BaseUnix,
- {$endif}
- {$endif}
- dbf_str, dbf_lang;
- const
- sDBF_DEC_SEP = '.';
- {$I dbf_struct.inc}
- //====================================================================
- // International separator
- // thanks to Bruno Depero from Italy
- // and Andreas Wöllenstein from Denmark
- //====================================================================
- function DbfStrToFloat(const Src: PChar; const Size: Integer): Extended;
- var
- iPos: PChar;
- eValue: extended;
- endChar: Char;
- begin
- // temp null-term string
- endChar := (Src + Size)^;
- (Src + Size)^ := #0;
- // we only have to convert if decimal separator different
- if DecimalSeparator <> sDBF_DEC_SEP then
- begin
- // search dec sep
- iPos := StrScan(Src, sDBF_DEC_SEP);
- // replace
- if iPos <> nil then
- iPos^ := DecimalSeparator;
- end else
- iPos := nil;
- // convert to double
- if TextToFloat(Src, eValue {$ifndef VER1_0}, fvExtended{$endif}) then
- Result := eValue
- else
- Result := 0;
- // restore dec sep
- if iPos <> nil then
- iPos^ := sDBF_DEC_SEP;
- // restore Char of null-term
- (Src + Size)^ := endChar;
- end;
- procedure FloatToDbfStr(const Val: Extended; const Size, Precision: Integer; const Dest: PChar);
- var
- Buffer: array [0..24] of Char;
- resLen: Integer;
- iPos: PChar;
- begin
- // convert to temporary buffer
- resLen := FloatToText(@Buffer[0], Val, {$ifndef FPC_VERSION}fvExtended,{$endif} ffFixed, Size, Precision);
- // prevent overflow in destination buffer
- if resLen > Size then
- resLen := Size;
- // null-terminate buffer
- Buffer[resLen] := #0;
- // we only have to convert if decimal separator different
- if DecimalSeparator <> sDBF_DEC_SEP then
- begin
- iPos := StrScan(@Buffer[0], DecimalSeparator);
- if iPos <> nil then
- iPos^ := sDBF_DEC_SEP;
- end;
- // fill destination with spaces
- FillChar(Dest^, Size, ' ');
- // now copy right-aligned to destination
- Move(Buffer[0], Dest[Size-resLen], resLen);
- end;
- function GetIntFromStrLength(Src: Pointer; Size: Integer; Default: Integer): Integer;
- var
- endChar: Char;
- Code: Integer;
- begin
- // save Char at pos term. null
- endChar := (PChar(Src) + Size)^;
- (PChar(Src) + Size)^ := #0;
- // convert
- Val(PChar(Src), Result, Code);
- // check success
- if Code <> 0 then
- Result := Default;
- // restore prev. ending Char
- (PChar(Src) + Size)^ := endChar;
- end;
- //====================================================================
- // TDbfFile
- //====================================================================
- constructor TDbfFile.Create;
- begin
- // init variables first
- FFieldDefs := TDbfFieldDefs.Create(nil);
- FIndexNames := TStringList.Create;
- FIndexFiles := TList.Create;
- // now initialize inherited
- inherited;
- end;
- destructor TDbfFile.Destroy;
- var
- I: Integer;
- begin
- // close file
- Close;
- // free files
- for I := 0 to Pred(FIndexFiles.Count) do
- TPagedFile(FIndexFiles.Items[I]).Free;
- // free lists
- FreeAndNil(FIndexFiles);
- FreeAndNil(FIndexNames);
- FreeAndNil(FFieldDefs);
- // call ancestor
- inherited;
- end;
- function TDbfFile.GetUseFloatFields: Boolean;
- begin
- Result := FFieldDefs.UseFloatFields;
- end;
- procedure TDbfFile.SetUseFloatFields(NewUse: Boolean);
- begin
- FFieldDefs.UseFloatFields := NewUse;
- end;
- procedure TDbfFile.Open;
- var
- lMemoFileName: string;
- lMdxFileName: string;
- MemoFileClass: TMemoFileClass;
- I: Integer;
- deleteLink: Boolean;
- lModified: boolean;
- LangStr: PChar;
- version: byte;
- begin
- // check if not already opened
- if not Active then
- begin
- // open requested file
- OpenFile;
- // check if we opened an already existing file
- lModified := false;
- if not FileCreated then
- begin
- HeaderSize := sizeof(rDbfHdr); // temporary
- // OH 2000-11-15 dBase7 support. I build dBase Tables with different
- // BDE dBase Level (1. without Memo, 2. with Memo)
- // Header Byte ($1d hex) (29 dec) -> Language driver ID.
- // $03,$83 xBaseIII Header Byte $1d=$00, Float -> N($13.$04) DateTime C($1E)
- // $03,$8B xBaseIV/V Header Byte $1d=$58, Float -> N($14.$04)
- // $04,$8C xBaseVII Header Byte $1d=$00 Float -> O($08) DateTime @($08)
- // $03,$F5 FoxPro Level 25 Header Byte $1d=$03, Float -> N($14.$04)
- // Access 97
- // $03,$83 dBaseIII Header Byte $1d=$00, Float -> N($13.$05) DateTime D($08)
- // $03,$8B dBaseIV/V Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
- // $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
- version := PDbfHdr(Header)^.VerDBF;
- case (version and $07) of
- $03:
- if LanguageID = 0 then
- FDbfVersion := xBaseIII
- else
- FDbfVersion := xBaseIV;
- $04:
- FDbfVersion := xBaseVII;
- $02, $05:
- FDbfVersion := xFoxPro;
- else
- // check visual foxpro
- if ((version and $FE) = $30) or (version = $F5) or (version = $FB) then
- begin
- FDbfVersion := xFoxPro;
- end else begin
- // not a valid DBF file
- raise EDbfError.Create(STRING_INVALID_DBF_FILE);
- end;
- end;
- FFieldDefs.DbfVersion := FDbfVersion;
- RecordSize := PDbfHdr(Header)^.RecordSize;
- HeaderSize := PDbfHdr(Header)^.FullHdrSize;
- if (HeaderSize = 0) or (RecordSize = 0) then
- begin
- HeaderSize := 0;
- RecordSize := 0;
- RecordCount := 0;
- FForceClose := true;
- exit;
- end;
- // check if specified recordcount correct
- if PDbfHdr(Header)^.RecordCount <> RecordCount then
- begin
- // This message was annoying
- // and was not understood by most people
- // ShowMessage('Invalid Record Count,'+^M+
- // 'RecordCount in Hdr : '+IntToStr(PDbfHdr(Header).RecordCount)+^M+
- // 'expected : '+IntToStr(RecordCount));
- PDbfHdr(Header)^.RecordCount := RecordCount;
- lModified := true;
- end;
- // determine codepage
- if FDbfVersion >= xBaseVII then
- begin
- // cache language str
- LangStr := @PAfterHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
- // VdBase 7 Language strings
- // 'DBWIN...' -> Charset 1252 (ansi)
- // 'DB999...' -> Code page 999, 9 any digit
- // 'DBHEBREW' -> Code page 1255 ??
- // 'FOX..999' -> Code page 999, 9 any digit
- // 'FOX..WIN' -> Charset 1252 (ansi)
- if (LangStr[0] = 'D') and (LangStr[1] = 'B') then
- begin
- if StrLComp(LangStr+2, 'WIN', 3) = 0 then
- FFileCodePage := 1252
- else
- if StrLComp(LangStr+2, 'HEBREW', 6) = 0 then
- begin
- FFileCodePage := 1255;
- end else begin
- FFileCodePage := GetIntFromStrLength(LangStr+2, 3, 0);
- if (Ord(LangStr[5]) >= Ord('0')) and (Ord(LangStr[5]) <= Ord('9')) then
- FFileCodePage := FFileCodePage * 10 + Ord(LangStr[5]) - Ord('0');
- end;
- end else
- if StrLComp(LangStr, 'FOX', 3) = 0 then
- begin
- if StrLComp(LangStr+5, 'WIN', 3) = 0 then
- FFileCodePage := 1252
- else
- FFileCodePage := GetIntFromStrLength(LangStr+5, 3, 0)
- end else begin
- FFileCodePage := 0;
- end;
- FFileLangId := GetLangId_From_LangName(LanguageStr);
- end else begin
- // FDbfVersion <= xBaseV
- FFileLangId := PDbfHdr(Header)^.Language;
- FFileCodePage := LangId_To_CodePage[FFileLangId];
- end;
- // determine used codepage, if no codepage, then use default codepage
- FUseCodePage := FFileCodePage;
- if FUseCodePage = 0 then
- FUseCodePage := DbfGlobals.DefaultOpenCodePage;
- // get list of fields
- ConstructFieldDefs;
- // open blob file if present
- lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
- if HasBlob then
- begin
- // open blob file
- if not FileExists(lMemoFileName) then
- MemoFileClass := TNullMemoFile
- else if FDbfVersion = xFoxPro then
- MemoFileClass := TFoxProMemoFile
- else
- MemoFileClass := TDbaseMemoFile;
- FMemoFile := MemoFileClass.Create(Self);
- FMemoFile.FileName := lMemoFileName;
- FMemoFile.Mode := Mode;
- FMemoFile.AutoCreate := false;
- FMemoFile.MemoRecordSize := 0;
- FMemoFile.DbfVersion := FDbfVersion;
- FMemoFile.Open;
- // set header blob flag corresponding to field list
- if FDbfVersion <> xFoxPro then
- begin
- PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80;
- lModified := true;
- end;
- end else
- if FDbfVersion <> xFoxPro then
- begin
- PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF and $7F;
- lModified := true;
- end;
- // check if mdx flagged
- if (FDbfVersion <> xFoxPro) and (PDbfHdr(Header)^.MDXFlag <> 0) then
- begin
- // open mdx file if present
- lMdxFileName := ChangeFileExt(FileName, '.mdx');
- if FileExists(lMdxFileName) then
- begin
- // open file
- FMdxFile := TIndexFile.Create(Self);
- FMdxFile.FileName := lMdxFileName;
- FMdxFile.Mode := Mode;
- FMdxFile.AutoCreate := false;
- FMdxFile.OnLocaleError := FOnLocaleError;
- FMdxFile.CodePage := UseCodePage;
- FMdxFile.Open;
- // is index ready for use?
- if not FMdxFile.ForceClose then
- begin
- FIndexFiles.Add(FMdxFile);
- // get index tag names known
- FMdxFile.GetIndexNames(FIndexNames);
- end else begin
- // asked to close! close file
- FreeAndNil(FMdxFile);
- end;
- end else begin
- // ask user
- deleteLink := true;
- if Assigned(FOnIndexMissing) then
- FOnIndexMissing(deleteLink);
- // correct flag
- if deleteLink then
- begin
- PDbfHdr(Header)^.MDXFlag := 0;
- lModified := true;
- end else
- FForceClose := true;
- end;
- end;
- end;
- // record changes
- if lModified then
- WriteHeader;
-
- // open indexes
- for I := 0 to FIndexFiles.Count - 1 do
- TIndexFile(FIndexFiles.Items[I]).Open;
- end;
- end;
- procedure TDbfFile.Close;
- var
- MdxIndex, I: Integer;
- begin
- if Active then
- begin
- // close index files first
- MdxIndex := -1;
- for I := 0 to FIndexFiles.Count - 1 do
- begin
- TIndexFile(FIndexFiles.Items[I]).Close;
- if TIndexFile(FIndexFiles.Items[I]) = FMdxFile then
- MdxIndex := I;
- end;
- // free memo file if any
- FreeAndNil(FMemoFile);
- // now we can close physical dbf file
- CloseFile;
- // free FMdxFile, remove it from the FIndexFiles and Names lists
- if MdxIndex >= 0 then
- FIndexFiles.Delete(MdxIndex);
- I := 0;
- while I < FIndexNames.Count do
- begin
- if FIndexNames.Objects[I] = FMdxFile then
- begin
- FIndexNames.Delete(I);
- end else begin
- Inc(I);
- end;
- end;
- FreeAndNil(FMdxFile);
- FreeMemAndNil(Pointer(FPrevBuffer));
- FreeMemAndNil(Pointer(FDefaultBuffer));
- // reset variables
- FFileLangId := 0;
- end;
- end;
- procedure TDbfFile.FinishCreate(FieldDefs: TDbfFieldDefs; MemoSize: Integer);
- var
- lFieldDescIII: rFieldDescIII;
- lFieldDescVII: rFieldDescVII;
- lFieldDescPtr: Pointer;
- lFieldDef: TDbfFieldDef;
- lMemoFileName: string;
- I, lFieldOffset, lSize, lPrec: Integer;
- lHasBlob: Boolean;
- lLocaleID: LCID;
- begin
- try
- // first reset file
- RecordCount := 0;
- lHasBlob := false;
- // determine codepage & locale
- if FFileLangId = 0 then
- FFileLangId := DbfGlobals.DefaultCreateLangId;
- FFileCodePage := LangId_To_CodePage[FFileLangId];
- lLocaleID := LangId_To_Locale[FFileLangId];
- FUseCodePage := FFileCodePage;
- // prepare header size
- if FDbfVersion = xBaseVII then
- begin
- // version xBaseVII without memo
- HeaderSize := SizeOf(rDbfHdr) + SizeOf(rAfterHdrVII);
- RecordSize := SizeOf(rFieldDescVII);
- FillChar(Header^, HeaderSize, #0);
- PDbfHdr(Header)^.VerDBF := $04;
- // write language string
- StrPLCopy(
- @PAfterHdrVII(PChar(Header)+SizeOf(rDbfHdr))^.LanguageDriverName[32],
- ConstructLangName(FFileCodePage, lLocaleID, false),
- 63-32);
- lFieldDescPtr := @lFieldDescVII;
- end else begin
- // version xBaseIII/IV/V without memo
- HeaderSize := SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
- RecordSize := SizeOf(rFieldDescIII);
- FillChar(Header^, HeaderSize, #0);
- if FDbfVersion = xFoxPro then
- begin
- PDbfHdr(Header)^.VerDBF := $02
- end else
- PDbfHdr(Header)^.VerDBF := $03;
- // standard language WE, dBase III no language support
- if FDbfVersion = xBaseIII then
- PDbfHdr(Header)^.Language := 0
- else
- PDbfHdr(Header)^.Language := FFileLangId;
- // init field ptr
- lFieldDescPtr := @lFieldDescIII;
- end;
- // begin writing fields
- FFieldDefs.Clear;
- // deleted mark 1 byte
- lFieldOffset := 1;
- for I := 1 to FieldDefs.Count do
- begin
- lFieldDef := FieldDefs.Items[I-1];
- // check if datetime conversion
- if FCopyDateTimeAsString then
- if lFieldDef.FieldType = ftDateTime then
- begin
- // convert to string
- lFieldDef.FieldType := ftString;
- lFieldDef.Size := 22;
- end;
- // update source
- lFieldDef.FieldName := AnsiUpperCase(lFieldDef.FieldName);
- lFieldDef.Offset := lFieldOffset;
- lHasBlob := lHasBlob or lFieldDef.IsBlob;
- // apply field transformation tricks
- lSize := lFieldDef.Size;
- lPrec := lFieldDef.Precision;
- if (lFieldDef.NativeFieldType = 'C')
- {$ifndef USE_LONG_CHAR_FIELDS}
- and (FDbfVersion = xFoxPro)
- {$endif}
- then
- begin
- lPrec := lSize shr 8;
- lSize := lSize and $FF;
- end;
- // update temp field props
- if FDbfVersion = xBaseVII then
- begin
- FillChar(lFieldDescVII, SizeOf(lFieldDescVII), #0);
- StrPLCopy(lFieldDescVII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescVII.FieldName)-1);
- lFieldDescVII.FieldType := lFieldDef.NativeFieldType;
- lFieldDescVII.FieldSize := lSize;
- lFieldDescVII.FieldPrecision := lPrec;
- // TODO: bug-endianness
- lFieldDescVII.NextAutoInc := lFieldDef.AutoInc;
- //lFieldDescVII.MDXFlag := ???
- end else begin
- FillChar(lFieldDescIII, SizeOf(lFieldDescIII), #0);
- StrPLCopy(lFieldDescIII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescIII.FieldName)-1);
- lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
- lFieldDescIII.FieldSize := lSize;
- lFieldDescIII.FieldPrecision := lPrec;
- // TODO: bug-endianness
- if FDbfVersion = xFoxPro then
- lFieldDescIII.FieldOffset := lFieldOffset;
- if (PDbfHdr(Header)^.VerDBF = $02) and (lFieldDef.NativeFieldType in ['0', 'Y', 'T', 'O', '+']) then
- PDbfHdr(Header)^.VerDBF := $30;
- if (PDbfHdr(Header)^.VerDBF = $30) and (lFieldDef.NativeFieldType = '+') then
- PDbfHdr(Header)^.VerDBF := $31;
- end;
- // update our field list
- with FFieldDefs.AddFieldDef do
- begin
- Assign(lFieldDef);
- Offset := lFieldOffset;
- AutoInc := 0;
- end;
- // save field props
- WriteRecord(I, lFieldDescPtr);
- Inc(lFieldOffset, lFieldDef.Size);
- end;
- // end of header
- WriteChar($0D);
- // write memo bit
- if lHasBlob then
- begin
- if FDbfVersion = xBaseIII then
- PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80
- else
- if FDbfVersion = xFoxPro then
- begin
- if PDbfHdr(Header)^.VerDBF = $02 then
- PDbfHdr(Header)^.VerDBF := $F5;
- end else
- PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $88;
- end;
- // update header
- PDbfHdr(Header)^.RecordSize := lFieldOffset;
- PDbfHdr(Header)^.FullHdrSize := HeaderSize + RecordSize * FieldDefs.Count + 1;
- // add empty "back-link" info, whatever it is:
- { A 263-byte range that contains the backlink, which is the relative path of
- an associated database (.dbc) file, information. If the first byte is 0x00,
- the file is not associated with a database. Therefore, database files always
- contain 0x00. }
- if FDbfVersion = xFoxPro then
- Inc(PDbfHdr(Header)^.FullHdrSize, 263);
- // write dbf header to disk
- inherited WriteHeader;
- finally
- RecordSize := PDbfHdr(Header)^.RecordSize;
- HeaderSize := PDbfHdr(Header)^.FullHdrSize;
- // write full header to disk (dbf+fields)
- WriteHeader;
- end;
- if HasBlob and (FMemoFile=nil) then
- begin
- lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
- if FDbfVersion = xFoxPro then
- FMemoFile := TFoxProMemoFile.Create(Self)
- else
- FMemoFile := TDbaseMemoFile.Create(Self);
- FMemoFile.FileName := lMemoFileName;
- FMemoFile.Mode := Mode;
- FMemoFile.AutoCreate := AutoCreate;
- FMemoFile.MemoRecordSize := MemoSize;
- FMemoFile.DbfVersion := FDbfVersion;
- FMemoFile.Open;
- end;
- end;
- function TDbfFile.HasBlob: Boolean;
- var
- I: Integer;
- begin
- Result := false;
- for I := 0 to FFieldDefs.Count-1 do
- if FFieldDefs.Items[I].IsBlob then
- Result := true;
- end;
- function TDbfFile.GetMemoExt: string;
- begin
- if FDbfVersion = xFoxPro then
- Result := '.fpt'
- else
- Result := '.dbt';
- end;
- procedure TDbfFile.Zap;
- begin
- // make recordcount zero
- RecordCount := 0;
- // update recordcount
- PDbfHdr(Header)^.RecordCount := RecordCount;
- // update disk header
- WriteHeader;
- // update indexes
- RegenerateIndexes;
- end;
- procedure TDbfFile.WriteHeader;
- var
- SystemTime: TSystemTime;
- lDataHdr: PDbfHdr;
- EofTerminator: Byte;
- begin
- if (HeaderSize=0) then
- exit;
- //FillHeader(0);
- lDataHdr := PDbfHdr(Header);
- GetLocalTime(SystemTime);
- lDataHdr^.Year := SystemTime.wYear - 1900;
- lDataHdr^.Month := SystemTime.wMonth;
- lDataHdr^.Day := SystemTime.wDay;
- // lDataHdr.RecordCount := RecordCount;
- inherited WriteHeader;
- EofTerminator := $1A;
- WriteBlock(@EofTerminator, 1, CalcPageOffset(RecordCount+1));
- end;
- procedure TDbfFile.ConstructFieldDefs;
- var
- {lColumnCount,}lHeaderSize,lFieldSize: Integer;
- lPropHdrOffset, lFieldOffset: Integer;
- lFieldDescIII: rFieldDescIII;
- lFieldDescVII: rFieldDescVII;
- lFieldPropsHdr: rFieldPropsHdr;
- lStdProp: rStdPropEntry;
- TempFieldDef: TDbfFieldDef;
- lSize,lPrec,I, lColumnCount: Integer;
- lAutoInc: Cardinal;
- dataPtr: PChar;
- lNativeFieldType: Char;
- lFieldName: string;
- lCanHoldNull: boolean;
- lCurrentNullPosition: integer;
- begin
- FFieldDefs.Clear;
- if DbfVersion >= xBaseVII then
- begin
- lHeaderSize := SizeOf(rAfterHdrVII) + SizeOf(rDbfHdr);
- lFieldSize := SizeOf(rFieldDescVII);
- end else begin
- lHeaderSize := SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
- lFieldSize := SizeOf(rFieldDescIII);
- end;
- HeaderSize := lHeaderSize;
- RecordSize := lFieldSize;
- FLockField := nil;
- FNullField := nil;
- FAutoIncPresent := false;
- lColumnCount := (PDbfHdr(Header)^.FullHdrSize - lHeaderSize) div lFieldSize;
- lFieldOffset := 1;
- lAutoInc := 0;
- I := 1;
- lCurrentNullPosition := 0;
- lCanHoldNull := false;
- try
- // there has to be minimum of one field
- repeat
- // version field info?
- if FDbfVersion >= xBaseVII then
- begin
- ReadRecord(I, @lFieldDescVII);
- lFieldName := AnsiUpperCase(PChar(@lFieldDescVII.FieldName[0]));
- lSize := lFieldDescVII.FieldSize;
- lPrec := lFieldDescVII.FieldPrecision;
- lNativeFieldType := lFieldDescVII.FieldType;
- // TODO: big-endianness
- lAutoInc := lFieldDescVII.NextAutoInc;
- if lNativeFieldType = '+' then
- FAutoIncPresent := true;
- end else begin
- ReadRecord(I, @lFieldDescIII);
- lFieldName := AnsiUpperCase(PChar(@lFieldDescIII.FieldName[0]));
- lSize := lFieldDescIII.FieldSize;
- lPrec := lFieldDescIII.FieldPrecision;
- lNativeFieldType := lFieldDescIII.FieldType;
- lCanHoldNull := (FDbfVersion = xFoxPro) and
- ((lFieldDescIII.FoxProFlags and $2) <> 0) and
- (lFieldName <> '_NULLFLAGS');
- end;
- // apply field transformation tricks
- if (lNativeFieldType = 'C')
- {$ifdef USE_LONG_CHAR_FIELDS}
- and (FDbfVersion = xFoxPro)
- {$endif}
- then
- begin
- lSize := lSize + lPrec shl 8;
- lPrec := 0;
- end;
- // add field
- TempFieldDef := FFieldDefs.AddFieldDef;
- with TempFieldDef do
- begin
- FieldName := lFieldName;
- Offset := lFieldOffset;
- Size := lSize;
- Precision := lPrec;
- AutoInc := lAutoInc;
- NativeFieldType := lNativeFieldType;
- if lCanHoldNull then
- begin
- NullPosition := lCurrentNullPosition;
- inc(lCurrentNullPosition);
- end else
- NullPosition := -1;
- end;
- // check valid field:
- // 1) non-empty field name
- // 2) known field type
- // {3) no changes have to be made to precision or size}
- if (Length(lFieldName) = 0) or (TempFieldDef.FieldType = ftUnknown) then
- raise EDbfError.Create(STRING_INVALID_DBF_FILE);
- // determine if lock field present, if present, then store additional info
- if lFieldName = '_DBASELOCK' then
- begin
- FLockField := TempFieldDef;
- FLockUserLen := lSize - 8;
- if FLockUserLen > DbfGlobals.UserNameLen then
- FLockUserLen := DbfGlobals.UserNameLen;
- end else
- if UpperCase(lFieldName) = '_NULLFLAGS' then
- FNullField := TempFieldDef;
- // goto next field
- Inc(lFieldOffset, lSize);
- Inc(I);
- // continue until header termination character found
- // or end of header reached
- until (I > lColumnCount) or (ReadChar = $0D);
- // test if not too many fields
- if FFieldDefs.Count >= 4096 then
- raise EDbfError.CreateFmt(STRING_INVALID_FIELD_COUNT, [FFieldDefs.Count]);
- // do not check FieldOffset = PDbfHdr(Header).RecordSize because additional
- // data could be present in record
- // get current position
- lPropHdrOffset := Stream.Position;
- // dBase 7 -> read field properties, test if enough space, maybe no header
- if (FDbfVersion = xBaseVII) and (lPropHdrOffset + Sizeof(lFieldPropsHdr) <
- PDbfHdr(Header)^.FullHdrSize) then
- begin
- // read in field properties header
- ReadBlock(@lFieldPropsHdr, SizeOf(lFieldPropsHdr), lPropHdrOffset);
- // read in standard properties
- lFieldOffset := lPropHdrOffset + lFieldPropsHdr.StartStdProps;
- for I := 0 to lFieldPropsHdr.NumStdProps - 1 do
- begin
- // read property data
- ReadBlock(@lStdProp, SizeOf(lStdProp), lFieldOffset+I*SizeOf(lStdProp));
- // is this a constraint?
- if lStdProp.FieldOffset = 0 then
- begin
- // this is a constraint...not implemented
- end else if lStdProp.FieldOffset <= FFieldDefs.Count then begin
- // get fielddef for this property
- TempFieldDef := FFieldDefs.Items[lStdProp.FieldOffset-1];
- // allocate space to store data
- TempFieldDef.AllocBuffers;
- // dataPtr = nil -> no data to retrieve
- dataPtr := nil;
- // store data
- case lStdProp.PropType of
- FieldPropType_Required: TempFieldDef.Required := true;
- FieldPropType_Default:
- begin
- dataPtr := TempFieldDef.DefaultBuf;
- TempFieldDef.HasDefault := true;
- end;
- FieldPropType_Min:
- begin
- dataPtr := TempFieldDef.MinBuf;
- TempFieldDef.HasMin := true;
- end;
- FieldPropType_Max:
- begin
- dataPtr := TempFieldDef.MaxBuf;
- TempFieldDef.HasMax := true;
- end;
- end;
- // get data for this property
- if dataPtr <> nil then
- ReadBlock(dataPtr, lStdProp.DataSize, lPropHdrOffset + lStdProp.DataOffset);
- end;
- end;
- // read custom properties...not implemented
- // read RI properties...not implemented
- end;
- finally
- HeaderSize := PDbfHdr(Header)^.FullHdrSize;
- RecordSize := PDbfHdr(Header)^.RecordSize;
- end;
- end;
- function TDbfFile.GetLanguageId: Integer;
- begin
- Result := PDbfHdr(Header)^.Language;
- end;
- function TDbfFile.GetLanguageStr: String;
- begin
- if FDbfVersion >= xBaseVII then
- Result := PAfterHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
- end;
- {
- I fill the holes with the last records.
- now we can do an 'in-place' pack
- }
- procedure TDbfFile.FastPackTable;
- var
- iDel,iNormal: Integer;
- pDel,pNormal: PChar;
- function FindFirstDel: Boolean;
- begin
- while iDel<=iNormal do
- begin
- ReadRecord(iDel, pDel);
- if (PChar(pDel)^ <> ' ') then
- begin
- Result := true;
- exit;
- end;
- Inc(iDel);
- end;
- Result := false;
- end;
- function FindLastNormal: Boolean;
- begin
- while iNormal>=iDel do
- begin
- ReadRecord(iNormal, pNormal);
- if (PChar(pNormal)^= ' ') then
- begin
- Result := true;
- exit;
- end;
- dec(iNormal);
- end;
- Result := false;
- end;
- begin
- if RecordSize < 1 then Exit;
- GetMem(pNormal, RecordSize);
- GetMem(pDel, RecordSize);
- try
- iDel := 1;
- iNormal := RecordCount;
- while FindFirstDel do
- begin
- // iDel is definitely deleted
- if FindLastNormal then
- begin
- // but is not anymore
- WriteRecord(iDel, pNormal);
- PChar(pNormal)^ := '*';
- WriteRecord(iNormal, pNormal);
- end else begin
- // Cannot found a record after iDel so iDel must be deleted
- dec(iDel);
- break;
- end;
- end;
- // FindFirstDel failed means than iDel is full
- RecordCount := iDel;
- RegenerateIndexes;
- // Pack Memofields
- finally
- FreeMem(pNormal);
- FreeMem(pDel);
- end;
- end;
- procedure TDbfFile.Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
- var
- lIndexFileNames: TStrings;
- lIndexFile: TIndexFile;
- NewBaseName: string;
- I: integer;
- begin
- // get memory for index file list
- lIndexFileNames := TStringList.Create;
- try
- // save index filenames
- for I := 0 to FIndexFiles.Count - 1 do
- begin
- lIndexFile := TIndexFile(IndexFiles[I]);
- lIndexFileNames.Add(lIndexFile.FileName);
- // prepare changing the dbf file name, needs changes in index files
- lIndexFile.PrepareRename(NewIndexFileNames[I]);
- end;
- // close file
- Close;
- if DeleteFiles then
- begin
- SysUtils.DeleteFile(DestFileName);
- SysUtils.DeleteFile(ChangeFileExt(DestFileName, GetMemoExt));
- end else begin
- I := 0;
- FindNextName(DestFileName, NewBaseName, I);
- SysUtils.RenameFile(DestFileName, NewBaseName);
- SysUtils.RenameFile(ChangeFileExt(DestFileName, GetMemoExt),
- ChangeFileExt(NewBaseName, GetMemoExt));
- end;
- // delete old index files
- for I := 0 to NewIndexFileNames.Count - 1 do
- SysUtils.DeleteFile(NewIndexFileNames.Strings[I]);
- // rename the new dbf files
- SysUtils.RenameFile(FileName, DestFileName);
- SysUtils.RenameFile(ChangeFileExt(FileName, GetMemoExt),
- ChangeFileExt(DestFileName, GetMemoExt));
- // rename new index files
- for I := 0 to NewIndexFileNames.Count - 1 do
- SysUtils.RenameFile(lIndexFileNames.Strings[I], NewIndexFileNames.Strings[I]);
- finally
- lIndexFileNames.Free;
- end;
- end;
- type
- TRestructFieldInfo = record
- SourceOffset: Integer;
- DestOffset: Integer;
- Size: Integer;
- end;
- { assume nobody has more than 8192 fields, otherwise possibly range check error }
- PRestructFieldInfo = ^TRestructFieldInfoArray;
- TRestructFieldInfoArray = array[0..8191] of TRestructFieldInfo;
- procedure TDbfFile.RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
- var
- DestDbfFile: TDbfFile;
- TempIndexDef: TDbfIndexDef;
- TempIndexFile: TIndexFile;
- DestFieldDefs: TDbfFieldDefs;
- TempDstDef, TempSrcDef: TDbfFieldDef;
- OldIndexFiles: TStrings;
- IndexName, NewBaseName: string;
- I, lRecNo, lFieldNo, lFieldSize, lBlobRecNo, lWRecNo, srcOffset, dstOffset: Integer;
- pBuff, pDestBuff: PChar;
- pBlobRecNoBuff: array[1..11] of Char;
- RestructFieldInfo: PRestructFieldInfo;
- BlobStream: TMemoryStream;
- begin
- // nothing to do?
- if (RecordSize < 1) or ((DbfFieldDefs = nil) and not Pack) then
- exit;
- // if no exclusive access, terrible things can happen!
- CheckExclusiveAccess;
- // make up some temporary filenames
- lRecNo := 0;
- FindNextName(FileName, NewBaseName, lRecNo);
- // select final field definition list
- if DbfFieldDefs = nil then
- begin
- DestFieldDefs := FFieldDefs;
- end else begin
- DestFieldDefs := DbfFieldDefs;
- // copy autoinc values
- for I := 0 to DbfFieldDefs.Count - 1 do
- begin
- lFieldNo := DbfFieldDefs.Items[I].CopyFrom;
- if (lFieldNo >= 0) and (lFieldNo < FFieldDefs.Count) then
- DbfFieldDefs.Items[I].AutoInc := FFieldDefs.Items[lFieldNo].AutoInc;
- end;
- end;
- // create temporary dbf
- DestDbfFile := TDbfFile.Create;
- DestDbfFile.FileName := NewBaseName;
- DestDbfFile.AutoCreate := true;
- DestDbfFile.Mode := pfExclusiveCreate;
- DestDbfFile.UseFloatFields := UseFloatFields;
- DestDbfFile.OnIndexMissing := FOnIndexMissing;
- DestDbfFile.OnLocaleError := FOnLocaleError;
- DestDbfFile.DbfVersion := FDbfVersion;
- DestDbfFile.FileLangId := FileLangId;
- DestDbfFile.Open;
- // create dbf header
- if FMemoFile <> nil then
- DestDbfFile.FinishCreate(DestFieldDefs, FMemoFile.RecordSize)
- else
- DestDbfFile.FinishCreate(DestFieldDefs, 512);
- // adjust size and offsets of fields
- GetMem(RestructFieldInfo, sizeof(TRestructFieldInfo)*DestFieldDefs.Count);
- for lFieldNo := 0 to DestFieldDefs.Count - 1 do
- begin
- TempDstDef := DestFieldDefs.Items[lFieldNo];
- if TempDstDef.CopyFrom >= 0 then
- begin
- TempSrcDef := FFieldDefs.Items[TempDstDef.CopyFrom];
- if TempDstDef.NativeFieldType in ['F', 'N'] then
- begin
- // get minimum field length
- lFieldSize := Min(TempSrcDef.Precision, TempDstDef.Precision) +
- Min(TempSrcDef.Size - TempSrcDef.Precision,
- TempDstDef.Size - TempDstDef.Precision);
- // if one has dec separator, but other not, we lose one digit
- if (TempDstDef.Precision > 0) xor
- ((TempSrcDef.NativeFieldType in ['F', 'N']) and (TempSrcDef.Precision > 0)) then
- Dec(lFieldSize);
- // should not happen, but check nevertheless (maybe corrupt data)
- if lFieldSize < 0 then
- lFieldSize := 0;
- srcOffset := TempSrcDef.Size - TempSrcDef.Precision -
- (TempDstDef.Size - TempDstDef.Precision);
- if srcOffset < 0 then
- begin
- dstOffset := -srcOffset;
- srcOffset := 0;
- end else begin
- dstOffset := 0;
- end;
- end else begin
- lFieldSize := Min(TempSrcDef.Size, TempDstDef.Size);
- srcOffset := 0;
- dstOffset := 0;
- end;
- with RestructFieldInfo[lFieldNo] do
- begin
- Size := lFieldSize;
- SourceOffset := TempSrcDef.Offset + srcOffset;
- DestOffset := TempDstDef.Offset + dstOffset;
- end;
- end;
- end;
- // add indexes
- TempIndexDef := TDbfIndexDef.Create(nil);
- for I := 0 to FIndexNames.Count - 1 do
- begin
- // get length of extension -> determines MDX or NDX
- IndexName := FIndexNames.Strings[I];
- TempIndexFile := TIndexFile(FIndexNames.Objects[I]);
- TempIndexFile.GetIndexInfo(IndexName, TempIndexDef);
- if Length(ExtractFileExt(IndexName)) > 0 then
- begin
- // NDX index, get unique file name
- lRecNo := 0;
- FindNextName(IndexName, IndexName, lRecNo);
- end;
- // add this index
- DestDbfFile.OpenIndex(IndexName, TempIndexDef.SortField, true, TempIndexDef.Options);
- end;
- TempIndexDef.Free;
- // get memory for record buffers
- GetMem(pBuff, RecordSize);
- BlobStream := TMemoryStream.Create;
- OldIndexFiles := TStringList.Create;
- // if restructure, we need memory for dest buffer, otherwise use source
- if DbfFieldDefs = nil then
- pDestBuff := pBuff
- else
- GetMem(pDestBuff, DestDbfFile.RecordSize);
- // let the games begin!
- try
- {$ifdef USE_CACHE}
- BufferAhead := true;
- DestDbfFile.BufferAhead := true;
- {$endif}
- lWRecNo := 1;
- for lRecNo := 1 to RecordCount do
- begin
- // read record from original dbf
- ReadRecord(lRecNo, pBuff);
- // copy record?
- if (pBuff^ <> '*') or not Pack then
- begin
- // if restructure, initialize dest
- if DbfFieldDefs <> nil then
- begin
- DestDbfFile.InitRecord(pDestBuff);
- // copy deleted mark (the first byte)
- pDestBuff^ := pBuff^;
- end;
- if (DbfFieldDefs <> nil) or (FMemoFile <> nil) then
- begin
- // copy fields
- for lFieldNo := 0 to DestFieldDefs.Count-1 do
- begin
- TempDstDef := DestFieldDefs.Items[lFieldNo];
- // handle blob fields differently
- // don't try to copy new blob fields!
- // DbfFieldDefs = nil -> pack only
- // TempDstDef.CopyFrom >= 0 -> copy existing (blob) field
- if TempDstDef.IsBlob and ((DbfFieldDefs = nil) or (TempDstDef.CopyFrom >= 0)) then
- begin
- // get current blob blockno
- GetFieldData(lFieldNo, ftString, pBuff, @pBlobRecNoBuff[1]);
- lBlobRecNo := StrToIntDef(pBlobRecNoBuff, -1);
- // valid blockno read?
- if lBlobRecNo >= 0 then
- begin
- BlobStream.Clear;
- FMemoFile.ReadMemo(lBlobRecNo, BlobStream);
- BlobStream.Position := 0;
- // always append
- DestDbfFile.FMemoFile.WriteMemo(lBlobRecNo, 0, BlobStream);
- end;
- // write new blockno
- DestDbfFile.SetFieldData(lFieldNo, ftInteger, @lBlobRecNo, pDestBuff);
- end else if (DbfFieldDefs <> nil) and (TempDstDef.CopyFrom >= 0) then
- begin
- // copy content of field
- with RestructFieldInfo[lFieldNo] do
- Move(pBuff[SourceOffset], pDestBuff[DestOffset], Size);
- end;
- end;
- end;
- // write record
- DestDbfFile.WriteRecord(lWRecNo, pDestBuff);
- // update indexes
- for I := 0 to DestDbfFile.IndexFiles.Count - 1 do
- TIndexFile(DestDbfFile.IndexFiles.Items[I]).Insert(lWRecNo, pDestBuff);
- // go to next record
- Inc(lWRecNo);
- end;
- end;
- {$ifdef USE_CACHE}
- BufferAhead := false;
- DestDbfFile.BufferAhead := false;
- {$endif}
- // save index filenames
- for I := 0 to FIndexFiles.Count - 1 do
- OldIndexFiles.Add(TIndexFile(IndexFiles[I]).FileName);
- // close dbf
- Close;
- // if restructure -> rename the old dbf files
- // if pack only -> delete the old dbf files
- DestDbfFile.Rename(FileName, OldIndexFiles, DbfFieldDefs = nil);
-
- // we have to reinit fielddefs if restructured
- Open;
- // crop deleted records
- RecordCount := lWRecNo - 1;
- // update date/time stamp, recordcount
- PDbfHdr(Header)^.RecordCount := RecordCount;
- WriteHeader;
- finally
- // close temporary file
- FreeAndNil(DestDbfFile);
- // free mem
- FreeAndNil(OldIndexFiles);
- FreeMem(pBuff);
- FreeAndNil(BlobStream);
- FreeMem(RestructFieldInfo);
- if DbfFieldDefs <> nil then
- FreeMem(pDestBuff);
- end;
- end;
- procedure TDbfFile.RegenerateIndexes;
- var
- lIndexNo: Integer;
- begin
- // recreate every index in every file
- for lIndexNo := 0 to FIndexFiles.Count-1 do
- begin
- PackIndex(TIndexFile(FIndexFiles.Items[lIndexNo]), EmptyStr);
- end;
- end;
- function TDbfFile.GetFieldInfo(FieldName: string): TDbfFieldDef;
- var
- I: Integer;
- lfi: TDbfFieldDef;
- begin
- FieldName := AnsiUpperCase(FieldName);
- for I := 0 to FFieldDefs.Count-1 do
- begin
- lfi := TDbfFieldDef(FFieldDefs.Items[I]);
- if lfi.fieldName = FieldName then
- begin
- Result := lfi;
- exit;
- end;
- end;
- Result := nil;
- end;
- // NOTE: Dst may be nil!
- function TDbfFile.GetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer): Boolean;
- var
- TempFieldDef: TDbfFieldDef;
- begin
- TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
- Result := GetFieldDataFromDef(TempFieldDef, DataType, Src, Dst);
- end;
- // NOTE: Dst may be nil!
- function TDbfFile.GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
- var
- FieldOffset, FieldSize: Integer;
- // s: string;
- ldd, ldm, ldy, lth, ltm, lts: Integer;
- date: TDateTime;
- timeStamp: TTimeStamp;
- asciiContents: boolean;
- {$ifdef SUPPORT_INT64}
- function GetInt64FromStrLength(Src: Pointer; Size: Integer; Default: Int64): Int64;
- var
- endChar: Char;
- Code: Integer;
- begin
- // save Char at pos term. null
- endChar := (PChar(Src) + Size)^;
- (PChar(Src) + Size)^ := #0;
- // convert
- Val(PChar(Src), Result, Code);
- // check success
- if Code <> 0 then Result := Default;
- // restore prev. ending Char
- (PChar(Src) + Size)^ := endChar;
- end;
- {$endif}
- procedure CorrectYear(var wYear: Integer);
- var wD, wM, wY, CenturyBase: Word;
- {$ifndef DELPHI_5}
- // Delphi 3 standard-behavior no change possible
- const TwoDigitYearCenturyWindow= 0;
- {$endif}
- begin
- if wYear >= 100 then
- Exit;
- DecodeDate(Date, wY, wm, wD);
- // use Delphi-Date-Window
- CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
- Inc(wYear, CenturyBase div 100 * 100);
- if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
- Inc(wYear, 100);
- end;
- procedure SaveDateToDst;
- begin
- {$ifdef SUPPORT_NEW_FIELDDATA}
- // Delphi 5 requests a TDateTime
- PDateTime(Dst)^ := date;
- {$else}
- // Delphi 3 and 4 request a TDateTimeRec
- // date is TTimeStamp.date
- // datetime = msecs == BDE timestamp as we implemented it
- if DataType = ftDateTime then
- begin
- PDateTimeRec(Dst)^.DateTime := date;
- end else begin
- PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
- end;
- {$endif}
- end;
- begin
- // test if non-nil source (record buffer)
- if Src = nil then
- begin
- Result := false;
- exit;
- end;
- // check Dst = nil, called with dst = nil to check empty field
- if (FNullField <> nil) and (Dst = nil) and (AFieldDef.NullPosition >= 0) then
- begin
- // go to byte with null flag of this field
- Src := PChar(Src) + FNullField.Offset + (AFieldDef.NullPosition shr 3);
- Result := (PByte(Src)^ and (1 shl (AFieldDef.NullPosition and $7))) <> 0;
- exit;
- end;
-
- FieldOffset := AFieldDef.Offset;
- FieldSize := AFieldDef.Size;
- Src := PChar(Src) + FieldOffset;
- asciiContents := false;
- // field types that are binary and of which the fieldsize should not be truncated
- case AFieldDef.NativeFieldType of
- '+', 'I':
- begin
- if FDbfVersion <> xFoxPro then
- begin
- Result := PDWord(Src)^ <> 0;
- if Result and (Dst <> nil) then
- begin
- PDWord(Dst)^ := SwapInt(PDWord(Src)^);
- if Result then
- PInteger(Dst)^ := Integer(PDWord(Dst)^ xor $80000000);
- end;
- end else begin
- Result := true;
- if Dst <> nil then
- PInteger(Dst)^ := PInteger(Src)^;
- end;
- end;
- 'O':
- begin
- {$ifdef SUPPORT_INT64}
- Result := (PInt64(Src)^ <> 0);
- if Result and (Dst <> nil) then
- begin
- SwapInt64(Src, Dst);
- if PInt64(Dst)^ > 0 then
- PInt64(Dst)^ := not PInt64(Dst)^
- else
- PDouble(Dst)^ := PDouble(Dst)^ * -1;
- end;
- {$endif}
- end;
- '@':
- begin
- Result := (PInteger(Src)^ <> 0) and (PInteger(PChar(Src)+4)^ <> 0);
- if Result and (Dst <> nil) then
- begin
- SwapInt64(Src, Dst);
- if FDateTimeHandling = dtBDETimeStamp then
- date := BDETimeStampToDateTime(PDouble(Dst)^)
- else
- date := PDateTime(Dst)^;
- SaveDateToDst;
- end;
- end;
- 'T':
- begin
- // all binary zeroes -> empty datetime
- Result := (PInteger(Src)^ <> 0) or (PInteger(PChar(Src)+4)^ <> 0);
- if Result and (Dst <> nil) then
- begin
- timeStamp.Date := PInteger(Src)^ - 1721425;
- timeStamp.Time := PInteger(PChar(Src)+4)^;
- date := TimeStampToDateTime(timeStamp);
- SaveDateToDst;
- end;
- end;
- 'Y':
- begin
- {$ifdef SUPPORT_INT64}
- Result := true;
- if Dst <> nil then
- begin
- // TODO: data is little endian;
- case DataType of
- ftCurrency:
- begin
- PDouble(Dst)^ := PInt64(Src)^ / 10000.0;
- end;
- ftBCD:
- begin
- PCurrency(Dst)^ := PCurrency(Src)^;
- end;
- end;
- end;
- {$endif}
- end;
- 'B': // foxpro double
- begin
- Result := true;
- if Dst <> nil then
- PDouble(Dst)^ := PDouble(Src)^;
- end;
- 'M':
- begin
- if FieldSize = 4 then
- begin
- Result := PInteger(Src)^ <> 0;
- if Dst <> nil then
- PInteger(Dst)^ := PInteger(Src)^;
- end else
- asciiContents := true;
- end;
- else
- asciiContents := true;
- end;
- if asciiContents then
- begin
- // SetString(s, PChar(Src) + FieldOffset, FieldSize );
- // s := {TrimStr(s)} TrimRight(s);
- // truncate spaces at end by shortening fieldsize
- while (FieldSize > 0) and ((PChar(Src) + FieldSize - 1)^ = ' ') do
- dec(FieldSize);
- // if not string field, truncate spaces at beginning too
- if DataType <> ftString then
- while (FieldSize > 0) and (PChar(Src)^ = ' ') do
- begin
- inc(PChar(Src));
- dec(FieldSize);
- end;
- // return if field is empty
- Result := FieldSize > 0;
- if Result and (Dst <> nil) then // data not needed if Result= false or Dst=nil
- case DataType of
- ftBoolean:
- begin
- // in DBase- FileDescription lowercase t is allowed too
- // with asking for Result= true s must be longer then 0
- // else it happens an AV, maybe field is NULL
- if (PChar(Src)^ = 'T') or (PChar(Src)^ = 't') then
- PWord(Dst)^ := 1
- else
- PWord(Dst)^ := 0;
- end;
- ftSmallInt:
- PSmallInt(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
- {$ifdef SUPPORT_INT64}
- ftLargeInt:
- PLargeInt(Dst)^ := GetInt64FromStrLength(Src, FieldSize, 0);
- {$endif}
- ftInteger:
- PInteger(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
- ftFloat, ftCurrency:
- PDouble(Dst)^ := DbfStrToFloat(Src, FieldSize);
- ftDate, ftDateTime:
- begin
- // get year, month, day
- ldy := GetIntFromStrLength(PChar(Src) + 0, 4, 1);
- ldm := GetIntFromStrLength(PChar(Src) + 4, 2, 1);
- ldd := GetIntFromStrLength(PChar(Src) + 6, 2, 1);
- //if (ly<1900) or (ly>2100) then ly := 1900;
- //Year from 0001 to 9999 is possible
- //everyting else is an error, an empty string too
- //Do DateCorrection with Delphis possibillities for one or two digits
- if (ldy < 100) and (PChar(Src)[0] = #32) and (PChar(Src)[1] = #32) then
- CorrectYear(ldy);
- try
- date := EncodeDate(ldy, ldm, ldd);
- except
- date := 0;
- end;
- // time stored too?
- if (AFieldDef.FieldType = ftDateTime) and (DataType = ftDateTime) then
- begin
- // get hour, minute, second
- lth := GetIntFromStrLength(PChar(Src) + 8, 2, 1);
- ltm := GetIntFromStrLength(PChar(Src) + 10, 2, 1);
- lts := GetIntFromStrLength(PChar(Src) + 12, 2, 1);
- // encode
- try
- date := date + EncodeTime(lth, ltm, lts, 0);
- except
- date := 0;
- end;
- end;
- SaveDateToDst;
- end;
- ftString:
- StrLCopy(Dst, Src, FieldSize);
- end else begin
- case DataType of
- ftString:
- if Dst <> nil then
- PChar(Dst)[0] := #0;
- end;
- end;
- end;
- end;
- procedure TDbfFile.UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef;
- Action: TUpdateNullField);
- var
- NullDst: pbyte;
- Mask: byte;
- begin
- // this field has null setting capability
- NullDst := PByte(PChar(Buffer) + FNullField.Offset + (AFieldDef.NullPosition shr 3));
- Mask := 1 shl (AFieldDef.NullPosition and $7);
- if Action = unSet then
- begin
- // clear the field, set null flag
- NullDst^ := NullDst^ or Mask;
- end else begin
- // set field data, clear null flag
- NullDst^ := NullDst^ and not Mask;
- end;
- end;
- procedure TDbfFile.SetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer);
- const
- IsBlobFieldToPadChar: array[Boolean] of Char = (#32, '0');
- SrcNilToUpdateNullField: array[boolean] of TUpdateNullField = (unClear, unSet);
- var
- FieldSize,FieldPrec: Integer;
- TempFieldDef: TDbfFieldDef;
- Len: Integer;
- IntValue: dword;
- year, month, day: Word;
- hour, minute, sec, msec: Word;
- date: TDateTime;
- timeStamp: TTimeStamp;
- asciiContents: boolean;
- procedure LoadDateFromSrc;
- begin
- {$ifdef SUPPORT_NEW_FIELDDATA}
- // Delphi 5 passes a TDateTime
- date := PDateTime(Src)^;
- {$else}
- // Delphi 3 and 4 pass a TDateTimeRec with a time stamp
- // date = integer
- // datetime = msecs == BDETimeStampToDateTime as we implemented it
- if DataType = ftDateTime then
- begin
- date := PDouble(Src)^;
- end else begin
- timeStamp.Time := 0;
- timeStamp.Date := PLongInt(Src)^;
- date := TimeStampToDateTime(timeStamp);
- end;
- {$endif}
- end;
- begin
- TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
- FieldSize := TempFieldDef.Size;
- FieldPrec := TempFieldDef.Precision;
- // if src = nil then write empty field
- // symmetry with above
- // foxpro has special _nullfield for flagging fields as `null'
- if (FNullField <> nil) and (TempFieldDef.NullPosition >= 0) then
- UpdateNullField(Dst, TempFieldDef, SrcNilToUpdateNullField[Src = nil]);
- // copy field data to record buffer
- Dst := PChar(Dst) + TempFieldDef.Offset;
- asciiContents := false;
- case TempFieldDef.NativeFieldType of
- '+', 'I':
- begin
- if FDbfVersion <> xFoxPro then
- begin
- if Src = nil then
- IntValue := 0
- else
- IntValue := PDWord(Src)^ xor $80000000;
- PDWord(Dst)^ := SwapInt(IntValue);
- end else begin
- if Src = nil then
- PDWord(Dst)^ := 0
- else
- PDWord(Dst)^ := PDWord(Src)^;
- end;
- end;
- 'O':
- begin
- {$ifdef SUPPORT_INT64}
- if Src = nil then
- begin
- PInt64(Dst)^ := 0;
- end else begin
- if PDouble(Src)^ < 0 then
- PLargeInt(Dst)^ := not PLargeInt(Src)^
- else
- PDouble(Dst)^ := (PDouble(Src)^) * -1;
- SwapInt64(Dst, Dst);
- end;
- {$endif}
- end;
- '@':
- begin
- if Src = nil then
- begin
- PInteger(Dst)^ := 0;
- PInteger(PChar(Dst)+4)^ := 0;
- end else begin
- LoadDateFromSrc;
- if FDateTimeHandling = dtBDETimeStamp then
- date := DateTimeToBDETimeStamp(date);
- SwapInt64(@date, Dst);
- end;
- end;
- 'T':
- begin
- // all binary zeroes -> empty datetime
- if Src = nil then
- begin
- PInteger(Dst)^ := 0;
- PInteger(PChar(Dst)+4)^ := 0;
- end else begin
- LoadDateFromSrc;
- timeStamp := DateTimeToTimeStamp(date);
- PInteger(Dst)^ := timeStamp.Date + 1721425;
- PInteger(PChar(Dst)+4)^ := timeStamp.Time;
- end;
- end;
- 'Y':
- begin
- {$ifdef SUPPORT_INT64}
- if Src = nil then
- begin
- PInt64(Dst)^ := 0
- end else begin
- case DataType of
- ftCurrency:
- PInt64(Dst)^ := Trunc(PDouble(Src)^ * 10000);
- ftBCD:
- PCurrency(Dst)^ := PCurrency(Src)^;
- end;
- end;
- // TODO: data is little endian
- {$endif}
- end;
- 'B':
- begin
- if Src = nil then
- PDouble(Dst)^ := 0
- else
- PDouble(Dst)^ := PDouble(Src)^;
- end;
- 'M':
- begin
- if FieldSize = 4 then
- begin
- if Src = nil then
- PInteger(Dst)^ := 0
- else
- PInteger(Dst)^ := PInteger(Src)^;
- end else
- asciiContents := true;
- end;
- else
- asciiContents := true;
- end;
- if asciiContents then
- begin
- if Src = nil then
- begin
- FillChar(Dst^, FieldSize, ' ');
- end else begin
- case DataType of
- ftBoolean:
- begin
- if PWord(Src)^ <> 0 then
- PChar(Dst)^ := 'T'
- else
- PChar(Dst)^ := 'F';
- end;
- ftSmallInt:
- GetStrFromInt_Width(PSmallInt(Src)^, FieldSize, PChar(Dst), #32);
- {$ifdef SUPPORT_INT64}
- ftLargeInt:
- GetStrFromInt64_Width(PLargeInt(Src)^, FieldSize, PChar(Dst), #32);
- {$endif}
- ftFloat, ftCurrency:
- FloatToDbfStr(PDouble(Src)^, FieldSize, FieldPrec, PChar(Dst));
- ftInteger:
- GetStrFromInt_Width(PInteger(Src)^, FieldSize, PChar(Dst),
- IsBlobFieldToPadChar[TempFieldDef.IsBlob]);
- ftDate, ftDateTime:
- begin
- LoadDateFromSrc;
- // decode
- DecodeDate(date, year, month, day);
- // format is yyyymmdd
- GetStrFromInt_Width(year, 4, PChar(Dst), '0');
- GetStrFromInt_Width(month, 2, PChar(Dst)+4, '0');
- GetStrFromInt_Width(day, 2, PChar(Dst)+6, '0');
- // do time too if datetime
- if DataType = ftDateTime then
- begin
- DecodeTime(date, hour, minute, sec, msec);
- // format is hhmmss
- GetStrFromInt_Width(hour, 2, PChar(Dst)+8, '0');
- GetStrFromInt_Width(minute, 2, PChar(Dst)+10, '0');
- GetStrFromInt_Width(sec, 2, PChar(Dst)+12, '0');
- end;
- end;
- ftString:
- begin
- // copy data
- Len := StrLen(Src);
- if Len > FieldSize then
- Len := FieldSize;
- Move(Src^, Dst^, Len);
- // fill remaining space with spaces
- FillChar((PChar(Dst)+Len)^, FieldSize - Len, ' ');
- end;
- end; // case datatype
- end;
- end;
- end;
- procedure TDbfFile.InitDefaultBuffer;
- var
- lRecordSize: integer;
- TempFieldDef: TDbfFieldDef;
- I: Integer;
- begin
- lRecordSize := PDbfHdr(Header)^.RecordSize;
- // clear buffer (assume all string, fix specific fields later)
- // note: Self.RecordSize is used for reading fielddefs too
- GetMem(FDefaultBuffer, lRecordSize+1);
- FillChar(FDefaultBuffer^, lRecordSize, ' ');
-
- // set nullflags field so that all fields are null
- if FNullField <> nil then
- FillChar(PChar(FDefaultBuffer+FNullField.Offset)^, FNullField.Size, $FF);
- // check binary and default fields
- for I := 0 to FFieldDefs.Count-1 do
- begin
- TempFieldDef := FFieldDefs.Items[I];
- // binary field? (foxpro memo fields are binary, but dbase not)
- if (TempFieldDef.NativeFieldType in ['I', 'O', '@', '+', '0', 'Y'])
- or ((TempFieldDef.NativeFieldType = 'M') and (TempFieldDef.Size = 4)) then
- FillChar(PChar(FDefaultBuffer+TempFieldDef.Offset)^, TempFieldDef.Size, 0);
- // copy default value?
- if TempFieldDef.HasDefault then
- begin
- Move(TempFieldDef.DefaultBuf[0], FDefaultBuffer[TempFieldDef.Offset], TempFieldDef.Size);
- // clear the null flag, this field has a value
- if FNullField <> nil then
- UpdateNullField(FDefaultBuffer, TempFieldDef, unClear);
- end;
- end;
- end;
- procedure TDbfFile.InitRecord(DestBuf: PChar);
- begin
- if FDefaultBuffer = nil then
- InitDefaultBuffer;
- Move(FDefaultBuffer^, DestBuf^, RecordSize);
- end;
- procedure TDbfFile.ApplyAutoIncToBuffer(DestBuf: PChar);
- var
- TempFieldDef: TDbfFieldDef;
- I, NextVal, lAutoIncOffset: {LongWord} Cardinal; {Delphi 3 does not know LongWord?}
- begin
- if FAutoIncPresent then
- begin
- // if shared, reread header to find new autoinc values
- if NeedLocks then
- begin
- // lock header so nobody else can use this value
- LockPage(0, true);
- end;
- // find autoinc fields
- for I := 0 to FFieldDefs.Count-1 do
- begin
- TempFieldDef := FFieldDefs.Items[I];
- if (TempFieldDef.NativeFieldType = '+') then
- begin
- // read current auto inc, from header or field, depending on sharing
- lAutoIncOffset := sizeof(rDbfHdr) + sizeof(rAfterHdrVII) +
- FieldDescVII_AutoIncOffset + I * sizeof(rFieldDescVII);
- // TODO: big-endianness
- if NeedLocks then
- ReadBlock(@NextVal, 4, lAutoIncOffset)
- else
- NextVal := TempFieldDef.AutoInc;
- // store to buffer, positive = high bit on, so flip it
- PCardinal(DestBuf+TempFieldDef.Offset)^ := SwapInt(NextVal or $80000000);
- // increase
- Inc(NextVal);
- TempFieldDef.AutoInc := NextVal;
- // write new value to header buffer
- PCardinal(FHeader+lAutoIncOffset)^ := NextVal;
- end;
- end;
- // write modified header (new autoinc values) to file
- WriteHeader;
-
- // release lock if locked
- if NeedLocks then
- UnlockPage(0);
- end;
- end;
- procedure TDbfFile.TryExclusive;
- var
- I: Integer;
- begin
- inherited;
- // exclusive succeeded? open index & memo exclusive too
- if Mode in [pfMemoryCreate..pfExclusiveOpen] then
- begin
- // indexes
- for I := 0 to FIndexFiles.Count - 1 do
- TPagedFile(FIndexFiles[I]).TryExclusive;
- // memo
- if FMemoFile <> nil then
- FMemoFile.TryExclusive;
- end;
- end;
- procedure TDbfFile.EndExclusive;
- var
- I: Integer;
- begin
- // end exclusive on index & memo too
- for I := 0 to FIndexFiles.Count - 1 do
- TPagedFile(FIndexFiles[I]).EndExclusive;
- // memo
- if FMemoFile <> nil then
- FMemoFile.EndExclusive;
- // dbf file
- inherited;
- end;
- procedure TDbfFile.OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
- //
- // assumes IndexName is not empty
- //
- const
- // memcr, memop, excr, exopen, rwcr, rwopen, rdonly
- IndexOpenMode: array[boolean, pfMemoryCreate..pfReadOnly] of TPagedFileMode =
- ((pfMemoryCreate, pfMemoryCreate, pfExclusiveOpen, pfExclusiveOpen, pfReadWriteOpen, pfReadWriteOpen,
- pfReadOnly),
- (pfMemoryCreate, pfMemoryCreate, pfExclusiveCreate, pfExclusiveCreate, pfReadWriteCreate, pfReadWriteCreate,
- pfReadOnly));
- var
- lIndexFile: TIndexFile;
- lIndexFileName: string;
- createMdxFile: Boolean;
- addedIndexFile: Integer;
- addedIndexName: Integer;
- begin
- // init
- addedIndexFile := -1;
- addedIndexName := -1;
- createMdxFile := false;
- // index already opened?
- lIndexFile := GetIndexByName(IndexName);
- if (lIndexFile <> nil) and (lIndexFile = FMdxFile) and CreateIndex then
- begin
- // index already exists in MDX file
- // delete it to save space, this causes a repage
- FMdxFile.DeleteIndex(IndexName);
- // index no longer exists
- lIndexFile := nil;
- end;
- if (lIndexFile = nil) and (IndexName <> EmptyStr) then
- begin
- // check if no extension, then create MDX index
- if Length(ExtractFileExt(IndexName)) = 0 then
- begin
- // check if mdx index already opened
- if FMdxFile <> nil then
- begin
- lIndexFileName := EmptyStr;
- lIndexFile := FMdxFile;
- end else begin
- lIndexFileName := ChangeFileExt(FileName, '.mdx');
- createMdxFile := true;
- end;
- end else begin
- lIndexFileName := IndexName;
- end;
- // do we need to open / create file?
- if lIndexFileName <> EmptyStr then
- begin
- // try to open / create the file
- lIndexFile := TIndexFile.Create(Self);
- lIndexFile.FileName := lIndexFileName;
- lIndexFile.Mode := IndexOpenMode[CreateIndex, Mode];
- lIndexFile.AutoCreate := CreateIndex or (Length(IndexField) > 0);
- lIndexFile.CodePage := UseCodePage;
- lIndexFile.OnLocaleError := FOnLocaleError;
- lIndexFile.Open;
- // index file ready for use?
- if not lIndexFile.ForceClose then
- begin
- // if we had to create the index, store that info
- CreateIndex := lIndexFile.FileCreated;
- // check if trying to create empty index
- if CreateIndex and (IndexField = EmptyStr) then
- begin
- FreeAndNil(lIndexFile);
- CreateIndex := false;
- createMdxFile := false;
- end else begin
- // add new index file to list
- addedIndexFile := FIndexFiles.Add(lIndexFile);
- end;
- // created accompanying mdx file?
- if createMdxFile then
- FMdxFile := lIndexFile;
- end else begin
- // asked to close! close file
- FreeAndNil(lIndexFile);
- end;
- end;
- // check if file succesfully opened
- if lIndexFile <> nil then
- begin
- // add index to list
- addedIndexName := FIndexNames.AddObject(IndexName, lIndexFile);
- end;
- end;
- // create it or open it?
- if lIndexFile <> nil then
- begin
- if not CreateIndex then
- if lIndexFile = FMdxFile then
- CreateIndex := lIndexFile.IndexOf(IndexName) < 0;
- if CreateIndex then
- begin
- // try get exclusive mode
- if IsSharedAccess then TryExclusive;
- // always uppercase index expression
- IndexField := AnsiUpperCase(IndexField);
- try
- // create index if asked
- lIndexFile.CreateIndex(IndexField, IndexName, Options);
- // add all records
- PackIndex(lIndexFile, IndexName);
- // if we wanted to open index readonly, but we created it, then reopen
- if Mode = pfReadOnly then
- begin
- lIndexFile.CloseFile;
- lIndexFile.Mode := pfReadOnly;
- lIndexFile.OpenFile;
- end;
- // if mdx file just created, write changes to dbf header
- // set MDX flag to true
- PDbfHdr(Header)^.MDXFlag := 1;
- WriteHeader;
- except
- // :-( need to undo 'damage'....
- // remove index from list(s) if just added
- if addedIndexFile >= 0 then
- FIndexFiles.Delete(addedIndexFile);
- if addedIndexName >= 0 then
- FIndexNames.Delete(addedIndexName);
- // delete index file itself
- lIndexFile.DeleteIndex(IndexName);
- // if no file created, do not destroy!
- if addedIndexFile >= 0 then
- begin
- lIndexFile.Close;
- Sysutils.DeleteFile(lIndexFileName);
- if FMdxFile = lIndexFile then
- FMdxFile := nil;
- lIndexFile.Free;
- end;
- end;
- // return to previous mode
- if TempMode <> pfNone then EndExclusive;
- end;
- end;
- end;
- procedure TDbfFile.PackIndex(lIndexFile: TIndexFile; AIndexName: string);
- var
- prevMode: TIndexUpdateMode;
- prevIndex: string;
- cur, last: Integer;
- {$ifdef USE_CACHE}
- prevCache: Integer;
- {$endif}
- begin
- // save current mode in case we change it
- prevMode := lIndexFile.UpdateMode;
- prevIndex := lIndexFile.IndexName;
- // check if index specified
- if Length(AIndexName) > 0 then
- begin
- // only pack specified index, not all
- lIndexFile.IndexName := AIndexName;
- lIndexFile.ClearIndex;
- lIndexFile.UpdateMode := umCurrent;
- end else begin
- lIndexFile.IndexName := EmptyStr;
- lIndexFile.Clear;
- lIndexFile.UpdateMode := umAll;
- end;
- // prepare update
- cur := 1;
- last := RecordCount;
- {$ifdef USE_CACHE}
- BufferAhead := true;
- prevCache := lIndexFile.CacheSize;
- lIndexFile.CacheSize := GetFreeMemory;
- if lIndexFile.CacheSize < 16384 * 1024 then
- lIndexFile.CacheSize := 16384 * 1024;
- {$endif}
- while cur <= last do
- begin
- ReadRecord(cur, FPrevBuffer);
- lIndexFile.Insert(cur, FPrevBuffer);
- inc(cur);
- end;
- // restore previous mode
- {$ifdef USE_CACHE}
- BufferAhead := false;
- lIndexFile.BufferAhead := true;
- {$endif}
- lIndexFile.Flush;
- {$ifdef USE_CACHE}
- lIndexFile.BufferAhead := false;
- lIndexFile.CacheSize := prevCache;
- {$endif}
- lIndexFile.UpdateMode := prevMode;
- lIndexFile.IndexName := prevIndex;
- end;
- procedure TDbfFile.RepageIndex(AIndexFile: string);
- var
- lIndexNo: Integer;
- begin
- // DBF MDX index?
- if Length(AIndexFile) = 0 then
- begin
- if FMdxFile <> nil then
- begin
- // repage attached mdx
- FMdxFile.RepageFile;
- end;
- end else begin
- // search index file
- lIndexNo := FIndexNames.IndexOf(AIndexFile);
- // index found?
- if lIndexNo >= 0 then
- TIndexFile(FIndexNames.Objects[lIndexNo]).RepageFile;
- end;
- end;
- procedure TDbfFile.CompactIndex(AIndexFile: string);
- var
- lIndexNo: Integer;
- begin
- // DBF MDX index?
- if Length(AIndexFile) = 0 then
- begin
- if FMdxFile <> nil then
- begin
- // repage attached mdx
- FMdxFile.CompactFile;
- end;
- end else begin
- // search index file
- lIndexNo := FIndexNames.IndexOf(AIndexFile);
- // index found?
- if lIndexNo >= 0 then
- TIndexFile(FIndexNames.Objects[lIndexNo]).CompactFile;
- end;
- end;
- procedure TDbfFile.CloseIndex(AIndexName: string);
- var
- lIndexNo: Integer;
- lIndex: TIndexFile;
- begin
- // search index file
- lIndexNo := FIndexNames.IndexOf(AIndexName);
- // don't close mdx file
- if (lIndexNo >= 0) then
- begin
- // get index pointer
- lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
- if (lIndex <> FMdxFile) then
- begin
- // close file
- lIndex.Free;
- // remove from lists
- FIndexFiles.Remove(lIndex);
- FIndexNames.Delete(lIndexNo);
- // was this the current index?
- if (FCurIndex = lIndexNo) then
- begin
- FCurIndex := -1;
- //FCursor := FDbfCursor;
- end;
- end;
- end;
- end;
- function TDbfFile.DeleteIndex(const AIndexName: string): Boolean;
- var
- lIndexNo: Integer;
- lIndex: TIndexFile;
- lFileName: string;
- begin
- // search index file
- lIndexNo := FIndexNames.IndexOf(AIndexName);
- Result := lIndexNo >= 0;
- // found index?
- if Result then
- begin
- // can only delete indexes from MDX files
- lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
- if lIndex = FMdxFile then
- begin
- lIndex.DeleteIndex(AIndexName);
- // remove it from the list
- FIndexNames.Delete(lIndexNo);
- // no more MDX indexes?
- lIndexNo := FIndexNames.IndexOfObject(FMdxFile);
- if lIndexNo = -1 then
- begin
- // no MDX indexes left
- lIndexNo := FIndexFiles.IndexOf(FMdxFile);
- if lIndexNo >= 0 then
- FIndexFiles.Delete(lIndexNo);
- lFileName := FMdxFile.FileName;
- FreeAndNil(FMdxFile);
- // erase file
- Sysutils.DeleteFile(lFileName);
- // clear mdx flag
- PDbfHdr(Header)^.MDXFlag := 0;
- WriteHeader;
- end;
- end else begin
- // close index first
- CloseIndex(AIndexName);
- // delete file from disk
- SysUtils.DeleteFile(AIndexName);
- end;
- end;
- end;
- function TDbfFile.Insert(Buffer: PChar): integer;
- var
- newRecord: Integer;
- lIndex: TIndexFile;
- error: Boolean;
- procedure RollBackIndexesAndRaise(HighIndex: Integer; IndexError: Boolean);
- var
- errorMsg: string;
- I: Integer;
- begin
- // rollback committed indexes
- error := IndexError;
- for I := 0 to HighIndex do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- lIndex.Delete(newRecord, Buffer);
- if lIndex.WriteError then
- begin
- lIndex.ResetError;
- error := true;
- end;
- end;
- // reset any dbf file error
- ResetError;
- // if part of indexes committed -> always index error msg
- // if error while rolling back index -> index error msg
- if error then
- errorMsg := STRING_WRITE_INDEX_ERROR
- else
- errorMsg := STRING_WRITE_ERROR;
- raise EDbfWriteError.Create(errorMsg);
- end;
- var
- I: Integer;
- begin
- // get new record index
- Result := 0;
- newRecord := RecordCount+1;
- // lock record so we can write data
- while not LockPage(newRecord, false) do
- Inc(newRecord);
- // write autoinc value
- ApplyAutoIncToBuffer(Buffer);
- // check indexes -> possible key violation
- I := 0; error := false;
- while (I < FIndexFiles.Count) and not error do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- error := lIndex.CheckKeyViolation(Buffer);
- Inc(I);
- end;
- // error occured while inserting? -> abort
- if error then
- begin
- UnlockPage(newRecord);
- lIndex.InsertError;
- // don't have to exit -- unreachable code
- end;
- // no key violation, insert record into index(es)
- for I := 0 to FIndexFiles.Count-1 do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- lIndex.Insert(newRecord, Buffer);
- if lIndex.WriteError then
- begin
- // if there's an index write error, I shouldn't
- // try to write the dbf header and the new record,
- // but raise an exception right away
- RollBackIndexesAndRaise(I, True);
- end;
- end;
- // indexes ok -> continue inserting
- // update header record count
- LockPage(0, true);
- // read current header
- ReadHeader;
- // increase current record count
- Inc(PDbfHdr(Header)^.RecordCount);
- // write header to disk
- WriteHeader;
- // done with header
- UnlockPage(0);
- if WriteError then
- begin
- // couldn't write header, so I shouldn't
- // even try to write the record.
- //
- // At this point I should "roll back"
- // the already written index records.
- // if this fails, I'm in deep trouble!
- RollbackIndexesAndRaise(FIndexFiles.Count-1, False);
- end;
- // write locking info
- if FLockField <> nil then
- WriteLockInfo(Buffer);
- // write buffer to disk
- WriteRecord(newRecord, Buffer);
- // done updating, unlock
- UnlockPage(newRecord);
- // error occurred while writing?
- if WriteError then
- begin
- // -- Tobias --
- // The record couldn't be written, so
- // the written index records and the
- // change to the header have to be
- // rolled back
- LockPage(0, true);
- ReadHeader;
- Dec(PDbfHdr(Header)^.RecordCount);
- WriteHeader;
- UnlockPage(0);
- // roll back indexes too
- RollbackIndexesAndRaise(FIndexFiles.Count-1, False);
- end else
- Result := newRecord;
- end;
- procedure TDbfFile.WriteLockInfo(Buffer: PChar);
- //
- // *) assumes FHasLockField = true
- //
- var
- year, month, day, hour, minute, sec, msec: Word;
- lockoffset: integer;
- begin
- // increase change count
- lockoffset := FLockField.Offset;
- Inc(PWord(Buffer+lockoffset)^);
- // set time
- DecodeDate(Now(), year, month, day);
- DecodeTime(Now(), hour, minute, sec, msec);
- Buffer[lockoffset+2] := Char(hour);
- Buffer[lockoffset+3] := Char(minute);
- Buffer[lockoffset+4] := Char(sec);
- // set date
- Buffer[lockoffset+5] := Char(year - 1900);
- Buffer[lockoffset+6] := Char(month);
- Buffer[lockoffset+7] := Char(day);
- // set name
- FillChar(Buffer[lockoffset+8], FLockField.Size-8, ' ');
- Move(DbfGlobals.UserName[1], Buffer[lockoffset+8], FLockUserLen);
- end;
- procedure TDbfFile.LockRecord(RecNo: Integer; Buffer: PChar);
- begin
- if LockPage(RecNo, false) then
- begin
- // reread data
- ReadRecord(RecNo, Buffer);
- // store previous data for updating indexes
- Move(Buffer^, FPrevBuffer^, RecordSize);
- // lock succeeded, update lock info, if field present
- if FLockField <> nil then
- begin
- // update buffer
- WriteLockInfo(Buffer);
- // write to disk
- WriteRecord(RecNo, Buffer);
- end;
- end else
- raise EDbfError.Create(STRING_RECORD_LOCKED);
- end;
- procedure TDbfFile.UnlockRecord(RecNo: Integer; Buffer: PChar);
- var
- I: Integer;
- lIndex: TIndexFile;
- begin
- // update indexes, possible key violation
- for I := 0 to FIndexFiles.Count - 1 do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- lIndex.Update(RecNo, FPrevBuffer, Buffer);
- end;
- // write new record buffer, all keys ok
- WriteRecord(RecNo, Buffer);
- // done updating, unlock
- UnlockPage(RecNo);
- end;
- procedure TDbfFile.RecordDeleted(RecNo: Integer; Buffer: PChar);
- var
- I: Integer;
- lIndex: TIndexFile;
- begin
- // notify indexes: record deleted
- for I := 0 to FIndexFiles.Count - 1 do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- lIndex.RecordDeleted(RecNo, Buffer);
- end;
- end;
- procedure TDbfFile.RecordRecalled(RecNo: Integer; Buffer: PChar);
- var
- I: Integer;
- lIndex: TIndexFile;
- begin
- // notify indexes: record recalled
- for I := 0 to FIndexFiles.Count - 1 do
- begin
- lIndex := TIndexFile(FIndexFiles.Items[I]);
- lIndex.RecordRecalled(RecNo, Buffer);
- end;
- end;
- procedure TDbfFile.SetRecordSize(NewSize: Integer);
- begin
- if NewSize <> RecordSize then
- begin
- if FPrevBuffer <> nil then
- FreeMemAndNil(Pointer(FPrevBuffer));
- if NewSize > 0 then
- GetMem(FPrevBuffer, NewSize);
- end;
- inherited;
- end;
- function TDbfFile.GetIndexByName(AIndexName: string): TIndexFile;
- var
- I: Integer;
- begin
- I := FIndexNames.IndexOf(AIndexName);
- if I >= 0 then
- Result := TIndexFile(FIndexNames.Objects[I])
- else
- Result := nil;
- end;
- //====================================================================
- // TDbfCursor
- //====================================================================
- constructor TDbfCursor.Create(DbfFile: TDbfFile);
- begin
- inherited Create(DbfFile);
- end;
- function TDbfCursor.Next: Boolean;
- begin
- if TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo) then
- begin
- inc(FPhysicalRecNo);
- Result := TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo);
- end else begin
- FPhysicalRecNo := TDbfFile(PagedFile).CachedRecordCount + 1;
- Result := false;
- end;
- end;
- function TDbfCursor.Prev: Boolean;
- begin
- if FPhysicalRecNo > 0 then
- dec(FPhysicalRecNo)
- else
- FPhysicalRecNo := 0;
- Result := FPhysicalRecNo > 0;
- end;
- procedure TDbfCursor.First;
- begin
- FPhysicalRecNo := 0;
- end;
- procedure TDbfCursor.Last;
- var
- max: Integer;
- begin
- max := TDbfFile(PagedFile).RecordCount;
- if max = 0 then
- FPhysicalRecNo := 0
- else
- FPhysicalRecNo := max + 1;
- end;
- function TDbfCursor.GetPhysicalRecNo: Integer;
- begin
- Result := FPhysicalRecNo;
- end;
- procedure TDbfCursor.SetPhysicalRecNo(RecNo: Integer);
- begin
- FPhysicalRecNo := RecNo;
- end;
- function TDbfCursor.GetSequentialRecordCount: Integer;
- begin
- Result := TDbfFile(PagedFile).RecordCount;
- end;
- function TDbfCursor.GetSequentialRecNo: Integer;
- begin
- Result := FPhysicalRecNo;
- end;
- procedure TDbfCursor.SetSequentialRecNo(RecNo: Integer);
- begin
- FPhysicalRecNo := RecNo;
- end;
- // codepage enumeration procedure
- var
- TempCodePageList: TList;
- // LPTSTR = PChar ok?
- function CodePagesProc(CodePageString: PChar): Cardinal; stdcall;
- begin
- // add codepage to list
- TempCodePageList.Add(Pointer(GetIntFromStrLength(CodePageString, StrLen(CodePageString), -1)));
- // continue enumeration
- Result := 1;
- end;
- //====================================================================
- // TDbfGlobals
- //====================================================================
- constructor TDbfGlobals.Create;
- begin
- FCodePages := TList.Create;
- FDefaultOpenCodePage := GetACP;
- // the following sets FDefaultCreateLangId
- DefaultCreateCodePage := GetACP;
- FCurrencyAsBCD := true;
- // determine which code pages are installed
- TempCodePageList := FCodePages;
- EnumSystemCodePages(@CodePagesProc, {CP_SUPPORTED} CP_INSTALLED);
- TempCodePageList := nil;
- InitUserName;
- end;
- procedure TDbfGlobals.InitUserName;
- {$ifdef FPC}
- {$ifndef WIN32}
- var
- TempName: UTSName;
- {$endif}
- {$endif}
- begin
- {$ifdef WIN32}
- FUserNameLen := MAX_COMPUTERNAME_LENGTH+1;
- SetLength(FUserName, FUserNameLen);
- // Windows.GetUserName(@FUserName[0], FUserNameLen);
- Windows.GetComputerName(PChar(FUserName), FUserNameLen);
- SetLength(FUserName, FUserNameLen);
- {$else}
- {$ifdef FPC}
- FpUname(TempName);
- FUserName := TempName.machine;
- FUserNameLen := Length(FUserName);
- {$endif}
- {$endif}
- end;
- destructor TDbfGlobals.Destroy; {override;}
- begin
- FCodePages.Free;
- end;
- function TDbfGlobals.GetDefaultCreateCodePage: Integer;
- begin
- Result := LangId_To_CodePage[FDefaultCreateLangId];
- end;
- procedure TDbfGlobals.SetDefaultCreateCodePage(NewCodePage: Integer);
- begin
- FDefaultCreateLangId := ConstructLangId(NewCodePage, GetUserDefaultLCID, false);
- end;
- function TDbfGlobals.CodePageInstalled(ACodePage: Integer): Boolean;
- begin
- Result := FCodePages.IndexOf(Pointer(ACodePage)) >= 0;
- end;
- initialization
- finalization
- FreeAndNil(DbfGlobals);
- (*
- Stuffs non implemented yet
- TFoxCDXHeader = Record
- PointerRootNode : Integer;
- PointerFreeList : Integer;
- Reserved_8_11 : Cardinal;
- KeyLength : Word;
- IndexOption : Byte;
- IndexSignature : Byte;
- Reserved_Null : TFoxReservedNull;
- SortOrder : Word;
- TotalExpressionLen : Word;
- ForExpressionLen : Word;
- Reserved_506_507 : Word;
- KeyExpressionLen : Word;
- KeyForExpression : TKeyForExpression;
- End;
- PFoxCDXHeader = ^TFoxCDXHeader;
- TFoxCDXNodeCommon = Record
- NodeAttributes : Word;
- NumberOfKeys : Word;
- PointerLeftNode : Integer;
- PointerRightNode : Integer;
- End;
- TFoxCDXNodeNonLeaf = Record
- NodeCommon : TFoxCDXNodeCommon;
- TempBlock : Array [12..511] of Byte;
- End;
- PFoxCDXNodeNonLeaf = ^TFoxCDXNodeNonLeaf;
- TFoxCDXNodeLeaf = Packed Record
- NodeCommon : TFoxCDXNodeCommon;
- BlockFreeSpace : Word;
- RecordNumberMask : Integer;
- DuplicateCountMask : Byte;
- TrailByteCountMask : Byte;
- RecNoBytes : Byte;
- DuplicateCountBytes : Byte;
- TrailByteCountBytes : Byte;
- HoldingByteCount : Byte;
- DataBlock : TDataBlock;
- End;
- PFoxCDXNodeLeaf = ^TFoxCDXNodeLeaf;
- *)
- end.
|