unit config;

interface

{---------------------------------------------------------------------------}

const configname : string = 'config.cfg';
      cfgstellen : integer = 7; { auf wieviele Stellen genau sollen }
                                { extended Variablen dargestellt werden ? }

type cfgvartyp = (exte,inte,stri,bool);

procedure xdefconfig(modname:string; name_:string; ptr:pointer; typ_:cfgvartyp);

function defconfig(name_:string; ptr:pointer; typ_:cfgvartyp) : boolean;

function readconfig : boolean;

function writeconfig : boolean;

{---------------------------------------------------------------------------}

implementation

type
     cfgvarstyp  = record
                    varptr : pointer;
                    name   : string[20];
                    typ    : cfgvartyp;
                    next   : pointer;
                   end;

     cvtptr = ^cfgvarstyp;

const  firstcfg : cvtptr = nil;

{---------------------------------------------------------------------------}

procedure xdefconfig(modname:string; name_:string; ptr:pointer; typ_:cfgvartyp);
begin
    if not defconfig(name_,ptr,typ_) then begin
       writeln('Not enough memory for configvariable!');
       writeln('called by ',modname);
       halt(1);
       end;
end;
{---------------------------------------------------------------------------}

function defconfig(name_:string; ptr:pointer; typ_:cfgvartyp) : boolean;
var ok:boolean;
    cfgp,newcfg : cvtptr;
begin
    ok := (maxavail>=sizeof(cfgvarstyp));
    if ok then begin
       new(newcfg);
       newcfg^.name   := name_;
       newcfg^.typ    := typ_;
       newcfg^.varptr := ptr;
       newcfg^.next   := nil;
       if firstcfg=nil then firstcfg:=newcfg
       else begin
            cfgp := firstcfg;
            while cfgp^.next<>nil do cfgp := cfgp^.next;
            cfgp^.next:=newcfg;
            end;
       end;
    defconfig:=ok;
end;

{---------------------------------------------------------------------------}

procedure exttostr(e:extended; var s:string);
var p : integer;
    ord,i,st : integer;
begin
  if (abs(e)<1e-4) or (abs(e)>1e6) then begin
       str(e:(cfgstellen+8),s);
       while s[1]=' ' do delete(s,1,1);
       while s[pos('E',s)-1]='0' do   delete(s,pos('E',s)-1,1);
       if    s[pos('E',s)-1]='.' then delete(s,pos('E',s)-1,1);
       p:=pos('E',s);
       while (p+2<=length(s)) and (s[p+2]='0') do delete(s,p+2,1);
       if s[p+1]='+' then delete(s,p+1,1);
       if s[length(s)]='E' then delete(s,length(s),1);
       end
  else begin
       str(e:(cfgstellen+8),s);
       p:=pos('E',s);
       val(copy(s,p+1,255),ord,i);
       st:=cfgstellen-ord-1;
       if st<2 then st:=2;
       str(e:st:st,s);
       while s[1]=' ' do delete(s,1,1);
       while s[length(s)]='0' do   delete(s,length(s),1);
       if    s[length(s)]='.' then delete(s,length(s),1);
       end;
end;

{---------------------------------------------------------------------------}

function cfginhalt(cfgp:cvtptr) : string;
var s    : string;
    pint : ^integer;
    eint : ^extended;
    spo  : ^string;
    bpo  : ^boolean;
begin
    s:='';
    if cfgp^.typ=inte then begin
         pint:=cfgp^.varptr;
         if pint^<>0 then str(pint^,s) else s:=' 0';
         end
    else
    if cfgp^.typ=exte then begin
         eint:=cfgp^.varptr;
         if eint^<>0 then exttostr(eint^,s) else s:=' 0';
         end
    else
    if cfgp^.typ=stri then begin
         spo:=cfgp^.varptr;
         s:=spo^;
         end;
    if cfgp^.typ=bool then begin
         bpo:=cfgp^.varptr;
         if bpo^ then s:='YES' else s:='NO ';
         end;
    cfginhalt:=s;
end;

{---------------------------------------------------------------------------}


function setzewert(cfgp:cvtptr;var s:string):boolean;
var epo : ^extended;
    ipo : ^integer;
    spo : ^string;
    bpo : ^boolean;
    i,j : integer;
    li  : longint;
begin
    while pos(' ',s)>0 do delete(s,pos(' ',s),1);
    if cfgp^.typ=exte then begin  epo:=cfgp^.varptr;  val(s,epo^,i);  end
    else
    if cfgp^.typ=inte then begin
                   ipo:=cfgp^.varptr;
                   val(s,li,i);
                   if (li>32767) then ipo^:=32767
                   else
                   if (li<-32768) then ipo^:=-32768
                   else ipo^:=li;
                   end
    else
    if cfgp^.typ=stri then begin  spo:=cfgp^.varptr;  spo^:=s; i:=0;  end
    else
    if cfgp^.typ=bool then begin
                   bpo:=cfgp^.varptr;
                   i:=0;
                   for j:=1 to length(s) do s[j]:=upcase(s[j]);
                   if (pos('YES',s)>0) or (pos('JA',s)>0) or
                      (pos('WAHR',s)>0) or (pos('TRUE',s)>0) then
                      bpo^:=true
                   else
                   if (pos('NO',s)>0) or (pos('NEIN',s)>0) or
                      (pos('FALSCH',s)>0) or (pos('FALSE',s)>0) then
                      bpo^:=false
                   else
                      i:=1;
                   end;
    setzewert:=(i=0);
end;

{---------------------------------------------------------------------------}

const io_intern : integer = 0;

function iocheck:boolean;
var ok:boolean;
begin
    ok := (io_intern=0);
    if ok then begin
       io_intern:=ioresult;
       ok := (io_intern=0);
       end;
    iocheck := ok;
end;

{---------------------------------------------------------------------------}

function readconfig : boolean;
var cfgp  : cvtptr;
    datei : text;
    ende  : boolean;
    ok    : boolean;
    n,s   : string;
    p     : integer;
begin
 assign(datei,configname);
 {$I-}
 reset(datei);
 io_intern:=ioresult;
 {$I+}
 if (firstcfg<>nil) and (io_intern=0) then begin
    {$I-}
    io_intern:=0;
    reset(datei);
    ok := iocheck;
    if ok then ende := eof(datei) else ende := true;
    while ok and (not ende) do begin
          readln(datei,s);
          ok   := iocheck;
          ende := eof(datei);
          if ok then p := pos('=',s) else p:=0;
          if ok and (p>0) then begin
             n:=copy(s,1,p-1);
             delete(s,1,p);
             cfgp := firstcfg;
             while (cfgp<>nil) and (n<>cfgp^.name) do begin
                   cfgp:=cfgp^.next;
                   end;
             if cfgp<>nil then setzewert(cfgp,s);
             end;
          end;
    close(datei);
    {$I+}
    readconfig:=iocheck;
    end
 else begin
      {$I-}
      close(datei);
      io_intern:=ioresult;
      {$I+}
      readconfig:=true;
      end;
end;

{---------------------------------------------------------------------------}

function writeconfig : boolean;
var cfgp  : cvtptr;
    datei : text;
begin
    assign(datei,configname);
    {$I-}
    io_intern:=0;
    rewrite(datei);
    cfgp := firstcfg;
    {$B+}
    while iocheck and (cfgp<>nil) do begin
          writeln(datei,cfgp^.name,'=',cfginhalt(cfgp));
          cfgp:=cfgp^.next;
          end;
    close(datei);
    {$I+}
    writeconfig:=iocheck;
end;

{---------------------------------------------------------------------------}

begin
end.