Newsgroup: it.comp.lang.pascal
Titolo: [LUNGO] Il mio piccolo gestore di archivi

 or you can
compile by yourself with Turbo Pascal 7.0+ or Free Pascal 2.0.2+.
*)
uses dos;
const key_len = 50;
  val_len = 200;
  dim_buf = 25;
type keyfield = string[key_len];
  form = record
           key : keyfield;
           value : string[val_len];
         end;
  bulk = array[0..0] of longint;
  buffer = array[1..dim_buf] of longint;
var name : string;
  tab : file of form;
  idx : text;
  idxsize : longint;
  memidx : ^bulk;
  holes : buffer;
  holeptr : integer;
  opt : char;
(* internal routines *)
function hash(fl : keyfield; sz : longint) : longint;
(* return the hash of the field *)
(* by the famous DJ Bernstein *)
var i : integer;
  j : longint;
begin
  j:=5381;
  for i:=1 to length(fl) do
    j:=(j+(j shl 5)) xor ord(fl[i]);
  hash:=abs(j) mod sz;
end;
procedure create(ds : boolean; var sz : longint);
(* reserve space for the hash index and set such size *)
var i : longint;
  j : integer;
  s : string;
begin
  if ds then
    begin
      readln(idx,s);
      val(s,sz,j);
    end
  else
    repeat
      write('Hash index size?');
      readln(sz);
    until sz>0;
  getmem(memidx,sizeof(longint)*(sz-1));
  for i:=0 to sz-1 do memidx^[i]:=-1;
end;
 
procedure build(var sz : longint);
(* initialize the hash index by the archive *)
var rec : form;
  i,j,k : longint;
begin
  repeat
    seek(tab,0);
    k:=filesize(tab)-1;
    for i:=0 to k do
      begin
        read(tab,rec);
        if rec.key='' then continue;
        j:=hash(rec.key,sz);
        if memidx^[j]<0 then memidx^[j]:=i
        else
          begin
            freemem(memidx,sizeof(longint)*(sz-1));
            sz:=sz+1;
            getmem(memidx,sizeof(longint)*(sz-1));
            for j:=0 to sz-1 do memidx^[j]:=-1;
            j:=-1;
            break;
          end;
      end;
  until (i=k) and (j>=0);
end;
procedure mount;
(* read from the disk the packed hash index *)
var i,j : longint;
  k : integer;
  s : string;
begin
  i:=0;
  while not eof(idx) do
    begin
      readln(idx,s);
      val(s,j,k);
      if j<0 then i:=i-j
      else
        begin
          memidx^[i]:=j;
          i:=i+1;
        end;
    end;
end;
procedure resync(sz : longint);
(* write on the disk the packed hash index *)
var i,j : longint;
  s : string;
begin
  j:=0;
  str(sz,s);
  writeln(idx,s);
  for i:=0 to sz-1 do
    if memidx^[i]<0 then j:=j-1
    else
      begin
        if j<0 then
          begin
            str(j,s);
            writeln(idx,s);
            j:=0;
          end;
        str(memidx^[i],s);
        writeln(idx,s);
      end;
end;
procedure open(var sz : longint);
(* check both the files for proper r/w mode *)
var diskidx : boolean;
  s : string;
begin
  s:=concat(name,'.idx');
  assign(idx,s);
  if fsearch(s,'.')<>''
    then diskidx:=true
    else diskidx:=false;
  s:=concat(name,'.tab');
  assign(tab,s);
  if fsearch(s,'.')<>'' then
    begin
      reset(tab);
      if diskidx then
        begin
          reset(idx);
          create(diskidx,sz);
          mount;
          close(idx);
          erase(idx);
        end
      else
        begin
          create(diskidx,sz);
          build(sz);
        end;
    end
  else
    begin
      rewrite(tab);
      create(false,sz);
    end;
end;
(* user commands *)
 
procedure help;
begin
  writeln('(h)elp');
  writeln('(q)uit');
  writeln('(f)etch');
  writeln('(d)elete');
  writeln('(s)earch');
  writeln('(v)iew');
  writeln('(c)ompact');
  writeln('(e)xport');
end;
procedure quit(sz : longint);
begin
  rewrite(idx);
  resync(sz);
  close(idx);
  freemem(memidx,sizeof(longint)*(sz-1));
  close(tab);
end;
procedure fetch(sz : longint; hl : buffer; var pt : integer);
var rec : form;
  i,j : longint;
begin
  repeat
    write('Key field?');
    readln(rec.key);
  until rec.key<>'';
  i:=hash(rec.key,sz);
  if memidx^[i]<0 then
    begin
      write('Value field?');
      readln(rec.value);
      if pt=0 then j:=filesize(tab)
      else
        begin
          j:=hl[pt];
          if pt<dim_buf then
            begin
              pt:=pt+1;
              if hl[pt]<0 then pt:=0;
            end
          else pt:=0;
        end;
      seek(tab,j);
      write(tab,rec);
      memidx^[i]:=j;
    end
  else writeln('That collides!');
end;
procedure delete(sz : longint);
var rec : form;
  hs : longint;
begin
  repeat
    write('Hash key?');
    readln(hs);
  until (hs>=0) and (hs<sz);
  if memidx^[hs]>=0 then
    begin
      rec.key:='';
      rec.value:='';
      seek(tab,memidx^[hs]);
      write(tab,rec);
      memidx^[hs]:=-1;
    end
  else writeln('Empty here!');
end;
procedure search(sz : longint);
var i : longint;
  fl : keyfield;
begin
  repeat
    write('Key field?');
    readln(fl);
  until fl<>'';    
  i:=hash(fl,sz);
  if memidx^[i]>=0 then writeln(i)
  else writeln('That fails!');
end;
procedure view(sz : longint);
var rec : form;
  hs : longint;
begin
  repeat
    write('Hash key?');
    readln(hs);
  until (hs>=0) and (hs<sz);
  if memidx^[hs]>=0 then
    begin
      seek(tab,memidx^[hs]);
      read(tab,rec);
      writeln(rec.value);
    end
  else writeln('Empty here!');  
end;
procedure compact(var hl : buffer; var pt : integer);
var rec : form;
  i : longint;
begin
  i:=0;
  seek(tab,i);
  while (not eof(tab)) and (pt<dim_buf) do
    begin
      read(tab,rec);
      if rec.key='' then
        begin
          pt:=pt+1;
          hl[pt]:=i;
        end;
      i:=i+1;
    end;
  for i:=pt+1 to dim_buf do hl[i]:=-1;
  writeln(pt);
  pt:=1;
end;
procedure export;
var pln : text;
  rec : form;
  i : longint;
  s : string;
begin
  assign(pln,concat(name,'.txt'));
  rewrite(pln);
  seek(tab,0);
  for i:=0 to filesize(tab)-1 do
    begin
      read(tab,rec);
      s:=concat(rec.key,' | ');
      s:=concat(s,rec.value);
      writeln(pln,s);
    end;
  close(pln);
end;
begin
  writeln('mbdbm pro1, Copyright (C) 2006 Marco Borsari');
  writeln('mbdbm comes with ABSOLUTELY NO WARRANTY.');
  writeln('This is free software, and you are welcome');
  writeln('to redistribute it under the terms of GNU GPL.');
  repeat
    write('Database name?');
    readln(name);
  until name<>'';
  holeptr:=0;
  open(idxsize);
  help;
  repeat
    write('Option?');
    readln(opt);
    case opt of
      'h' : help;
      'f' : fetch(idxsize,holes,holeptr);
      'd' : delete(idxsize);
      's' : search(idxsize);
      'v' : view(idxsize);
      'c' : compact(holes,holeptr);
      'e' : export;
    end;
  until opt='q';
  quit(idxsize);
end.
-- 
Omega e' omega e basta

Aggiunta nota tecnica:
5) la funzione di ricompattamento del file dei record in effetti si
limita soltanto, per evitare spreco di lavoro su disco, a prendere
nota delle eventuali chiavi vuote, che nel caso verranno riutilizzate
in fase di inserimento.
