unit
TDBFile; { Use DBF like FoxPro }
interface
uses
Objects; { Standard Turbo lib }
const
SizeOfBuffer = 65520;
stDelete : Byte = 42;
stNormal : Byte = 32;
ON : Boolean = TRUE;
OFF : Boolean = FALSE;
function GetDay : Byte;
function GetMonth : Byte;
function GetYear : Word;
type
PBuffer = ^TBuffer;
TBuffer = array [0..65520] of Byte;
PRec = ^TRec;
TRec = record
Data : String;
Next : PRec;
end;
PHeadRec = ^THeadRec;
THeadRec = record
Sign : Byte;
Year : Byte;
Month : Byte;
Day : Byte;
RecNum : LongInt;
HeadLen : Word;
RecLen : Word;
Reserved : array [1..20] of Byte;
end; { Структура заголовка DBF-файла }
PFieldRec = ^TFieldRec;
TFieldRec = record
Name : array [0..10] of Char;
FieldType : Char;
Displacem : LongInt;
FieldLen : Byte;
DecPlace : Byte;
Reserved : array [1..14] of Byte;
end; { Структура описателя поля }
PInfoRec = ^TInfoRec;
TInfoRec = record
Name : String[10];
FieldType : Char;
Displacem : LongInt;
FieldLen : Byte;
DecPlace : Byte;
Next : PInfoRec;
end; { Информационная структура для потока }
PDBFStream = ^TDBFStream;
TDBFStream = object (TBufStream)
Head : PHeadRec;
Info : PInfoRec;
FieldNum : Word;
Current : LongInt;
stDeleted : Boolean;
constructor Use(FName : String);
constructor Create(FName : String; PInfo : PInfoRec);
procedure Go(Num : LongInt);
procedure Append(var Rec);
procedure AppendBlank;
procedure AppendNBlank(Num : LongInt);
procedure WriteToField(var Rec; NumField : Byte);
procedure WriteStr(S : String; NumField : Byte);
procedure WriteRec(PR : PRec);
procedure ReadFromField(var Rec; NumField : Byte);
procedure ReadStr(var S : String; NumField : Byte);
procedure Gather(var Rec); { to }
procedure Scatter(var Rec); { from }
procedure Delete;
procedure ReCall;
function Deleted : Boolean;
function RecCount : LongInt;
{ !!!!!!!!!!!!!!!!!!!!!!!!!!! }
procedure Pack; { not quiet right }
{ !!!!!!!!!!!!!!!!!!!!!!!!!!! }
procedure SetDeleted(Del : Boolean);
function Field(Num : LongInt) : PInfoRec;
function FieldType(Num : LongInt) : Char;
function FieldLen(Num : LongInt) : Byte;
procedure WriteAllNames; { U can exclude it... }
destructor Close; virtual;
end; { Объект DBF-файла }
function NewField(Name: String; FieldType: Char; FieldLen: Byte;
DecPlace : Byte; Next : PInfoRec) : PInfoRec;
function NewRec(Data : String; Next : PRec) : PRec;
function Format(V : Real; W, D : Byte) : String;
procedure DeleteFile(FileName : String);
implementation
uses
DOS, TPEms;
{ Get from TPProf (I think OOPro too can do it) }
function GetDay : Byte; assembler;
asm
MOV AH,2Ah
INT 21h
MOV AL,DL
end;
function GetMonth : Byte; assembler;
asm
MOV AH,2Ah
INT 21h
MOV AL,DH
end;
function GetYear : Word; assembler;
asm
MOV AH,2Ah
INT 21h
MOV AX,CX
end;
constructor TDBFStream.Use;
var
LPInfo : PInfoRec;
LPField : PFieldRec;
I, J : Byte;
begin
inherited Init(FName, stOpen, SizeOfBuffer);
if Status<>stOk then Exit;
stDeleted:=OFF;
New(Head);
Read(Head^, 32);
New(LPField);
New(Info);
LPInfo:=Info;
I:=0;
while (I+1)*32 < Head^.HeadLen do begin
Read(LPField^, 32);
J:=0;
while LPField^.Name[J]<>#0 do begin
LPInfo^.Name[J+1]:=LPField^.Name[J];
Inc(J);
end;
LPInfo^.Name[0] :=Chr(J);
LPInfo^.FieldType:=LPField^.FieldType;
LPInfo^.Displacem:=LPField^.Displacem;
LPInfo^.FieldLen :=LPField^.FieldLen;
LPInfo^.DecPlace :=LPField^.DecPlace;
Inc(I);
if (I+1)*32 >= Head^.HeadLen
then LPInfo^.Next:=nil
else begin
LPInfo^.Next:=New(PInfoRec);
LPInfo:=LPInfo^.Next;
end;
end;
FieldNum:=I-1;
Current:=1;
Seek(Head^.HeadLen);{ Go(1); }
end;
constructor TDBFStream.Create;
var
LPInfo : PInfoRec;
LPField : PFieldRec;
I, J : Byte;
RN : LongInt;
HL, RL,
DP : Word;
begin
inherited Init(FName, stCreate, SizeOfBuffer);
stDeleted:=OFF;
Info:=PInfo;
I:=0;
RL:=1;
DP:=1;
while PInfo<>nil do begin
Inc(I);
PInfo^.Displacem:=DP;
DP:=DP+PInfo^.FieldLen;
RL:=RL+PInfo^.FieldLen;
PInfo:=PInfo^.Next;
end;
HL:=32*I+33;
FieldNum:=I;
New(Head);
with Head^ do begin
Sign :=3;
Year :=GetYear-1900;
Month :=GetMonth;
Day :=GetDay;
RecNum :=0;
HeadLen:=HL;
RecLen :=RL;
FillChar(Reserved[1],20,0);
end;
Write(Head^,32);
New(LPField);
LPInfo:=Info;
for I:=1 to FieldNum do begin
with LPField^ do begin
FillChar(Name[0],11,0);
J:=Length(LPInfo^.Name);
Move(LPInfo^.Name[1],Name[0],J);
FieldType:=LPInfo^.FieldType;
Displacem:=LPInfo^.Displacem;
FieldLen:=LPInfo^.FieldLen;
DecPlace:=LPInfo^.DecPlace;
FillChar(Reserved[1],14,0);
end;
Write(LPField^,32);
LPInfo:=LPInfo^.Next;
end;
I:=13;
Write(I,1);
Current:=1;
Seek(Head^.HeadLen);{ Go(1); }
end;
procedure TDBFStream.Go;
begin
Current:=Num;
Seek(Head^.HeadLen+(Num-1)*Head^.RecLen);
end;
procedure TDBFStream.Append;
begin
with Head^ do begin
Seek(HeadLen+(RecNum+1)*RecLen);
Write(Rec,RecLen);
Inc(RecNum);
Seek(HeadLen+RecNum*RecLen);
end;
end;
procedure TDBFStream.AppendBlank;
var
PB : PBuffer;
begin
New(PB);
FillChar(PB^[0],Head^.RecLen+1,32);
Append(PB^[0]);
Dispose(PB);
end;
procedure TDBFStream.AppendNBlank;
var
PB : PBuffer;
I : LongInt;
begin
New(PB);
FillChar(PB^[0],Head^.RecLen,32);
for I:=1 to Num do Append(PB^[0]);
Dispose(PB);
end;
procedure TDBFStream.WriteToField;
var
C : LongInt;
LPInfo : PInfoRec;
begin
C:=GetPos;
LPInfo:=Field(NumField);
Seek(C+LPInfo^.Displacem);
Write(Rec,LPInfo^.FieldLen);
Seek(C);
end;
procedure TDBFStream.WriteStr;
begin
FillChar(S[Length(S)+1],255-Length(S),0);
WriteToField(S[1],NumField);
end;
procedure TDBFStream.WriteRec(PR : PRec);
const
PB : PBuffer = nil;
LPRec : PRec = nil;
var
I, J : Word;
begin
GetMem(PB,Head^.RecLen);
LPRec:=PR;
FillChar(PB^[0],Head^.RecLen,0);
PB^[0]:=stNormal;
I:=1;
J:=1;
while LPRec<>nil do begin
Move(LPRec^.Data[1],PB^[I],FieldLen(J));
Inc(I,FieldLen(J));
Inc(J);
LPRec:=LPRec^.Next;
end;
Write(PB^[0],Head^.RecLen);
FreeMem(PB,Head^.RecLen);
end;
procedure TDBFStream.ReadFromField;
var
C : LongInt;
LPInfo : PInfoRec;
begin
C:=GetPos;
LPInfo:=Field(NumField);
Seek(C+LPInfo^.Displacem);
Read(Rec,LPInfo^.FieldLen);
Seek(C);
end;
procedure TDBFStream.ReadStr;
var
LPInfo : PInfoRec;
begin
LPInfo:=Field(NumField);
FillChar(S[Length(S)+1],255-Length(S),0);
FillChar(S[0],1,LPInfo^.FieldLen);
ReadFromField(S[1],NumField);
end;
procedure TDBFStream.Gather; { to }
var
C : LongInt;
begin
C:=GetPos;
Write(Rec, Head^.RecLen);
Seek(C);
end;
procedure TDBFStream.Scatter; { from }
var
C : LongInt;
begin
Read(Rec, Head^.RecLen);
Inc(Current);
end;
procedure TDBFStream.Delete;
begin
Write(stDelete,1);
Seek(GetPos-1);
end;
procedure TDBFStream.ReCall;
begin
Write(stNormal,1);
Seek(GetPos-1);
end;
function TDBFStream.Deleted;
var
C : Byte;
begin
Read(C,1);
Seek(GetPos-1);
Deleted:=(C=stDelete);
end;
procedure TDBFStream.SetDeleted;
begin
stDeleted:=Del;
end;
function TDBFStream.RecCount;
const
PB : PBuffer = nil;
var
C : LongInt;
I : LongInt;
begin
New(PB);
C:=Current;
Seek(Head^.HeadLen);
for I:=1 to Head^.RecNum do begin
Read(PB^[0],Head^.RecLen);
if (not stDeleted) and (PB^[0]<>stDelete) then Inc(C);
end;
RecCount:=C;
Dispose(PB);
Go(C);
end;
procedure TDBFStream.Pack;
const
P : PBuffer = nil;
var
R : PStream;
I, J : LongInt;
S : String;
begin
S:=GetEnv('TEMP')+'\@@@@@@@@.@@@';
I:=System.Pos('\\',S);
if I<>0 then System.Delete(S,I,1);
if Head^.HeadLen>Head^.RecLen then I:=Head^.HeadLen
else I:=Head^.RecLen;
if EMSInstalled
then R:=New(PEMSStream,Init(I,I))
else R:=New(PBufStream,Init(S,stCreate,SizeOfBuffer));
New(P);
I:=0;
Seek(0);
R^.Seek(0);
Read(P^[0],Head^.HeadLen);
R^.Write(P^[0],Head^.HeadLen);
for J:=1 to Head^.RecNum do begin
Read(P^[0],Head^.RecLen);
if P^[0]<>stDelete then begin
Inc(I);
R^.Write(P^[0],Head^.RecLen);
end;
end;
Seek(0);
R^.Seek(0);
CopyFrom(R^, R^.GetSize);
Seek(Head^.HeadLen);
Head^.RecNum:=I;
R^.Done;
if not EMSInstalled then DeleteFile(S);
end;
function TDBFStream.Field;
var
LPInfo : PInfoRec;
begin
LPInfo:=Info;
if Num>FieldNum
then Field:=LPInfo
else begin
while Num>1 do begin
LPInfo:=LPInfo^.Next;
Dec(Num);
end;
Field:=LPInfo;
end;
end;
function TDBFStream.FieldType;
var
LPInfo : PInfoRec;
begin
LPInfo:=Info;
if Num>FieldNum
then FieldType:='C'
else begin
while Num>1 do begin
LPInfo:=LPInfo^.Next;
Dec(Num);
end;
FieldType:=LPInfo^.FieldType;
end;
end;
function TDBFStream.FieldLen;
const
LPInfo : PInfoRec = nil;
begin
LPInfo:=Info;
if Num>FieldNum
then FieldLen:=0
else begin
while Num>1 do begin
LPInfo:=LPInfo^.Next;
Dec(Num);
end;
FieldLen:=LPInfo^.FieldLen;
end;
end;
procedure TDBFStream.WriteAllNames;
var
LPInfo : PInfoRec;
begin
LPInfo:=Info;
while LPInfo<>nil do with LPInfo^ do begin
Writeln('---'#16' ',Name:10,' "',FieldType,'" ',FieldLen:3,
'.',DecPlace);
LPInfo:=Next;
end;
end;
destructor TDBFStream.Close;
var
LPInfo : PInfoRec;
I : Byte;
C : LongInt;
begin
with Head^ do begin
Year:=GetYear-1900;
Month:=GetMonth;
Day:=GetDay;
end;
Seek(0);
Write(Head^,32);
Seek(Head^.HeadLen+Head^.RecNum*Head^.RecLen);
I:=26;
Write(I,1);
Truncate;
Dispose(Head);
while Info<>nil do begin
LPInfo:=Info;
Info:=Info^.Next;
Dispose(LPInfo);
end;
inherited Done;
end;
function NewField(Name : String; FieldType : Char; FieldLen : Byte;
DecPlace : Byte; Next : PInfoRec) : PInfoRec;
var
LPInfo : PInfoRec;
begin
New(LPInfo);
LPInfo^.Name:=Name;
LPInfo^.FieldType:=FieldType;
LPInfo^.FieldLen:=FieldLen;
LPInfo^.DecPlace:=DecPlace;
LPInfo^.Next:=Next;
NewField:=LPInfo;
end;
function NewRec(Data : String; Next : PRec) : PRec;
const
LPRec : PRec = nil;
begin
New(LPRec);
LPRec^.Data:=Data;
LPRec^.Next:=Next;
NewRec:=LPRec;
end;
function Format(V : Real; W, D : Byte) : String;
var
S : String;
begin
Str(V:W:D,S);
while Byte(S[0])<W do S:=S+' ';
Format:=S;
end;
procedure DeleteFile(FileName : String);
var
Regs : Registers;
begin
FileName:=Concat(FileName,#0);
with Regs do begin
flags:=( flags and $0000 );
DS := Seg(FileName[1]);
DX := Ofs(FileName[1]);
AH := $41;
MsDos( Regs );
end;
end;
end.
| 
