{ READ_DBF.PAS Copyright (c) TrSek alias Zdeno Sekerak } { Unit urceny pre citanie DBF citanie/zapis suborov, reindexaciu. } { } { Datum:19.06.1995 http://www.trsek.com } unit READ_DBF; interface uses crt,dos,kniznic; const max_viet=80; { max - kolko moze byt maximalne premennych v 1 vete } k_index='.ind'; { koncovka pre subor s indexami } k_dbf='.dbf'; { koncovka pre DBF subor } max_ind=5000; type premenna=(C,L,N,D); { typ premennej C-retazec, L-logicka, N-numericka } { D-datum } hlava=record { typ tzv. hlavy DBF blizie informacie } nazov: array[1..11] of char; { na horeuvedenej adrese } typep: char; zac: word; none2: array[1..2] of byte; size: byte; desat: byte; none3: array[1..14] of byte; end; type index = word; { typ indexoveho suboru } var base : array[1..max_viet] of string; { polozky jednej vety } hlavy : array[1..max_viet] of hlava; { hlavy (popisy) kazdej z poloziek } indexy : array[1..max_ind] of index; { Global indexov } { base : tbase; hlavy : thlavy; indexy : tindexy;} f: file of char; { nacitava jednotlive vety DBF } ff: file of hlava; { nacitava hlavy DBF } poc,dtab,dvet: word; { poc-pocet viet, dtab-dlzka tabulky } { hlavy, dvet-velkost jednej vety v kB } spoc: word; { Realny, skutocny pocet viet } den,mes,rok: byte; { den,mesiac,rok z DBF } typdbf: byte; { typ dBase, prvy byt DBF } pp: integer; { pp-pocet premennych vo vete } { rpp-kolko premennych vypisat z vety } AllSize: LongInt; { celkova velkost suboru DBF } SAllSize: LongInt; { Skutocna celkova velkost suboru DBF } i,x: integer; { pomocne premenne } fyzvet: word; { cislo aktualnej (fyzickej) vety v DBF } relvet: word; { cislo relativnej vety } r_od,r_do,r_size: longint; { od,do fyzicky precital dbf } quick: pointer; { pointer na fyzicke citanie dbf } kolko: longint; { kolko je fyzicky citane } function nothing ( i :integer) :string; procedure closebase; procedure opendbase ( meno :string ); function get_index ( i_subor :string; i:word ) :word; procedure put_index ( i_subor :string; p,i:word ); procedure r_read ( subor:string; r_seek:longint); procedure r_write ( subor:string ); procedure write_poc ( meno:string; poc:word ); procedure cit_mem ( meno:string; dbf_veta:longint ); procedure zap_mem ( meno:string; dbf_veta:longint ); procedure cit_vety ( meno :string; dbf_veta:word ); procedure zap_vety ( meno :string; dbf_veta:word ); procedure clear_all_index; procedure put_all_index ( meno :string ); implementation function nothing(i:integer):string; begin nothing:=copy(' ',1,i); end; procedure closebase; begin freemem(quick,kolko); kolko:=0; end; procedure opendbase(meno:string); { otvor DBF a precitaj z nej hlavy } var sub:SearchRec; ch:char; p:word; i_f:file of index; akt:integer; begin if kolko>0 then closebase; assign(f,meno+k_dbf); {$I-} reset(f); {$I+} { ak DBF nejestvuje } if ioresult<>0 then begin writeln('Subor bud nejestvuje, alebo nieje spravna cesta.'); halt(0); end; findfirst(meno+k_dbf,Archive,Sub); { zisti jeho velkost } AllSize:=Sub.Size; SAllSize:=Sub.Size; read(f,ch);typdbf:=ord(ch); { precitaj uvodne info typ dBase } read(f,ch);rok:=ord(ch); { den, mesiac, rok poslednej editacie } read(f,ch);mes:=ord(ch); read(f,ch);den:=ord(ch); read(f,ch);poc:=ord(ch); read(f,ch);poc:=poc+256*ord(ch); spoc:=poc; { Aky je skutocny pocet viet } for i:=1 to 3 do read(f,ch); { zisti velkost tabulky hlav } dtab:=ord(ch);read(f,ch);dtab:=dtab+256*ord(ch); pp:=round(dtab/32)-1; { dtab/32-1= pocet premennych } { ale vypisuje najviac 20 z jednej vety } read(f,ch);dvet:=ord(ch); read(f,ch);dvet:=dvet+256*ord(ch); { zisti dlzku jednej vety } close(f); assign(ff,meno+k_dbf); reset(ff); read(ff,hlavy[1]); { toto precita hlavu hlav } { pekne sprosto som to nazval } for i:=1 to pp do read(ff,hlavy[i]); { toto cita hlavu kazdej premennej } close(ff); { co vsetko obsahuje ??? } { kontakt na programatora je v zahlavy } for i:=1 to pp do case hlavy[i].typep of { nastavi velkost premennych pre jednotlive } { premenne podla hlavy } 'C':base[i]:=nothing(hlavy[i].size); 'L':base[i]:=nothing(1); 'N':if hlavy[i].desat>0 then base[i]:=nothing(hlavy[i].size) else base[i]:=nothing(hlavy[i].size+hlavy[i].desat); 'D':base[i]:=nothing(8); end; FindFirst(meno+k_index,Archive,Sub); if DosError<>0 then begin hlaska('Vytvaram INDEXOVY subor '+meno+k_index,-1); akt:=0;clear_all_index; for p:=1 to poc do begin inc(akt);indexy[akt]:=p; if akt>=max_ind then begin put_all_index(meno); akt:=0; end; end; put_all_index(meno); hlaska(' ',-1); end else begin assign(i_f,meno+k_index); reset(i_f); poc:=FileSize(i_f)-1; AllSize:=dtab+1+longint(poc)*longint(dvet); close(i_f); end; { Kvoli rychlosti ...} FindFirst(meno+k_dbf,Archive or Hidden or ReadOnly,sub); kolko:=MaxAvail; if MaxAvail>66035 then kolko:=65535 else kolko:=MaxAvail-500; if kolko>Sub.Size then kolko:=Sub.Size; kolko:=round(MaxAvail/2); r_size:=Sub.Size; getmem(quick,kolko); r_od:=0;r_do:=0; end; function get_index(i_subor:string;i:word):word; var i_f:file of index; p_index:index; begin p_index:=0; assign(i_f,i_subor+k_index); {$I-} reset(i_f); if FileSize(i_f)>i then begin seek(i_f,i); read(i_f,p_index); { Dodatocne uprav Globalne premenne pocet a Velkost DBF } poc:=FileSize(i_f)-1; AllSize:=dtab+1+longint(poc)*longint(dvet); end { Co ak sa pyta na neexistujuci index ??? } else p_index:=0; {$I+} if IoResult=0 then close(i_f); get_index:=p_index end; procedure put_index(i_subor:string;p,i:word); var i_f:file of index; p_index:index; pp:word; begin p_index:=0; assign(i_f,i_subor+k_index); {$I-} Reset(i_f); {$I-} if IoResult<>0 then ReWrite(i_f); if FileSize(i_f)<=p then for pp:=p to FileSize(i_f) do begin seek(i_f,pp);write(i_f,p_index); end; seek(i_f,p); write(i_f,i); { Dodatocne uprav Globalne premenne pocet a Velkost DBF } poc:=FileSize(i_f)-1; AllSize:=dtab+1+longint(poc)*longint(dvet); close(i_f); end; procedure r_read(subor:string;r_seek:longint); var ff1:file; err:word; begin Assign (ff1,subor); {$I-} ReSet (ff1,1); {$I+} if IoResult<>0 then exit; if r_seek>r_size then begin close (ff1);exit;end; r_od:=r_seek;r_do:=r_seek+kolko; if r_do>r_size then r_do:=r_size; Seek(ff1,r_od); BlockRead (ff1,quick^,word(r_do-r_od),err); if err>word(r_do-r_od) then hlaska('Chyba fyzickeho citania DBF opusti program !!!',0); close (ff1); end; procedure r_write( subor:string ); var ff1:file; err:word; begin Assign (ff1,subor); {$I-} ReSet (ff1,1); {$I+} if IoResult<>0 then exit; Seek(ff1,r_od); BlockWrite (ff1,quick^,word(r_do-r_od),err); if err>word(r_do-r_od) then hlaska('Chyba fyzickeho citania DBF opusti program !!!',0); close (ff1); end; procedure write_poc ( meno:string; poc:word ); var f:file of byte; b1,b2:byte; porov:longint; begin b1:=trunc(poc/256);b2:=poc-b1*256; assign(f,meno+k_dbf); reset(f); seek(f,4); write(f,b2);write(f,b1); porov:=dtab+longint(poc)*longint(dvet); seek(f,porov); truncate(f); close(f); SAllSize:=dtab+longint(poc)*longint(dvet); AllSize:=SAllSize; end; procedure cit_mem( meno:string; dbf_veta:longint ); var p:pointer; i:integer; zacni:longint; begin zacni:=dtab+LongInt(dbf_veta)*LongInt(dvet)+1; if zacni+dvet>r_do then r_read(meno,zacni); if zacni r_size then begin zacni:=r_od+dvet; r_read(meno,zacni); r_do:=r_do+dvet; r_size:=r_size+dvet; r_write(meno); end; for x:=1 to pp do { nastrka to do premennych } for i:=1 to hlavy[x].size do begin if base[x][i]<>chr(byte(p^)) then begin byte(p^):=ord(base[x][i]); nutne:=true; end; p:=Ptr(Seg(p^),Ofs(p^)+1); end; if nutne then r_write(meno); end; procedure cit_vety(meno:string; dbf_veta:word); var p:integer; porov:LongInt; begin relvet:=dbf_veta; dbf_veta:=get_index(meno,dbf_veta); fyzvet:=dbf_veta; if dbf_veta<1 then exit; dbf_veta:=dbf_veta-1; porov:=dtab+longint(dbf_veta+1)*longint(dvet); if (Porov>SAllSize) then exit; cit_mem(meno+k_dbf,dbf_veta); end; procedure zap_vety( meno:string; dbf_veta:word); var porov:longint; i:word; p:pointer; begin relvet:=dbf_veta; dbf_veta:=get_index(meno,dbf_veta); fyzvet:=dbf_veta; if dbf_veta<1 then begin { Zapis novej vety } dbf_veta:=spoc+1;inc(spoc); put_index(meno,relvet,dbf_veta); end; dbf_veta:=dbf_veta-1; porov:=dtab+longint(dbf_veta+1)*longint(dvet); if (Porov>SAllSize) then begin inc(poc);spoc:=dbf_veta+1; write_poc(meno,spoc); AllSize:=dtab+longint(poc+1)*longint(dvet); end; zap_mem(meno+k_dbf,dbf_veta); end; procedure clear_all_index; var i:integer; begin for i:=1 to max_ind do indexy[i]:=0; end; procedure put_all_index( meno :string ); var i_f:file of index; p_index:index; pp:word; i:integer; begin p_index:=0; assign(i_f,meno+k_index); {$I-} Reset(i_f); {$I-} if IoResult<>0 then begin ReWrite(i_f); seek(i_f,1); end; for i:=1 to max_ind do if indexy[i]<>0 then write(i_f,indexy[i]); { Dodatocne uprav Globalne premenne pocet a Velkost DBF } poc:=FileSize(i_f)-1; AllSize:=dtab+1+longint(poc)*longint(dvet); close(i_f); clear_all_index; end; end.