(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(*  Soubor: CFG.PAS                                                        *)
(*  Obsah: jednotka pro praci s konfiguracnimi soubory                     *)
(*  Autor: Mircosoft (http://mircosoft.mzf.cz)                             *)
(*  Posledni uprava: 17.11.2020                                            *)
(*  Pro kompilaci: RETEZCE.TPU                                             *)
(*  Pro spusteni: nic                                                      *)
(*  Upozorneni: tyto zdrojove kody pouzivate na vlastni nebezpeci          *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
unit CFG;
{$I-,R-,B-} {dulezite, nemenit}
interface

type
{pomocne typy (netreba cist):}
UkNaCfgPolozku = ^cfgpolozka;
CfgPolozka = record
             Dalsi:uknacfgpolozku;
             Adresa:pointer;
             Typ:word;
             Vyrizeno:boolean;
             Jmeno:string;
             end;
UkNaCfgSekci = ^cfgsekce;
CfgSekce = record
           Dalsi:uknacfgsekci;
           PrvniPolozka:uknacfgpolozku;
           Vyrizeno:boolean;
           Jmeno:string;
           end;
{Jestli v techto typech cokoli zmenite, je potreba patricne upravit funkce
VelikostSekce a VelikostPolozky, aby velikosti pocitaly spravne.
Jmeno musi byt vzdy posledni polozka.}

{************************* uzivatelsky typ: *********************************}
Konfigurace = object
              PrvniSekce,VybranaSekce:uknacfgsekci;
              procedure init;
              {Vynuluje interni ukazatele. Zavolejte jednou pred prvnim
              pouzitim.}
              procedure VyberSekci(_Jmeno:string);
              {Sekci s danym Jmenem prohlasi za aktualne vybranou. Pokud jeste
              neexistovala, bude automaticky vytvorena. Vyber sekce je nutny
              pred jakoukoli manipulaci s datovymi polozkami. Jmeno muze byt
              jakykoli text, ktery neobsahuje znak '=' a nezacina na ';'.
              Piste vcetne pripadnych [zavorek] okolo, jestli je tam chcete
              mit.}
              procedure DefinujPolozku(_Jmeno:string; _Adresa:pointer; _Typ:word);
              {Do aktualne vybrane sekce prida datovou polozku. Pokud uz
              polozka se stejnym jmenem existovala, bude nahrazena. Pokud
              zadna sekce neni vybrana, nestane se nic.
              _Jmeno - jak se ma polozka v konfiguracnim souboru jmenovat.
                       Nesmi obsahovat znak '='.
              _Adresa - adresa promenne, ktera obsahuje hodnotu polozky.
                        Zadejte @promenna nebo addr(promenna).
                        Nejde zadat primou hodnotu nebo konstantu.
              _Typ - datovy typ promenne. Zadejte nekterou z konstant
                     uvedenych o obrazovku niz.}
              procedure Uloz(Soubor:string);
              {Ulozi do daneho Souboru (jmeno i s koncovkou) aktualni hodnoty
              promennych pripojenych pres datove polozky konfigurace.
              Pokud soubor neexistuje, bude vytvoren. Pokud existuje, budou
              v nem existujici sekce a datove polozky s odpovidajicimi jmeny
              nahrazeny novymi hodnotami, neexistujici pridany a polozky
              oznacene typem _smazat odstraneny. Zustane zachovano puvodni
              poradi radku, prazdne radky, komentare a vsechny sekce a
              polozky, ktere v konfiguraci nejsou definovany.}
              procedure Nacti(Soubor:string);
              {Nacte ze Souboru (opet jmeno i s koncovkou) hodnoty do
              promennych pripojenych pres datove polozky. Pokud polozku
              s odpovidajicim jmenem v souboru nenajde nebo pokud jeji hodnota
              neodpovida uvedenemu typu (napr. text misto cisla), prislusna
              promenna zustane beze zmeny. Pokud ciselna hodnota presahuje
              rozsah daneho ciselneho typu, bude patricne oriznuta. Sekce a
              polozky v souboru, pro ktere nejsou v konfiguraci nadefinovane
              odpovidajici protejsky se stejnym jmenem, se ignoruji
              (v konfiguraci se nic nevytvari).}
              procedure ZrusPolozku(_Jmeno:string);
              {Odstrani z vybrane sekce polozku s danym _Jmenem. To znamena
              jenom to, ze uz se nebude ukladat ani nacitat; pro skutecne
              vymazani ze souboru predefinujte polozku na typ _smazat
              a zavolejte metodu Uloz.}
              procedure ZrusSekci(_Jmeno:string);
              {Odstrani z konfigurace danou sekci vcetne vsech polozek v ni,
              takze uz se nebudou ukladat ani nacitat. Pro skutecne vymazani
              sekce ze souboru tento objekt zadne prostredky nema.}
              procedure Zrus;
              {Zrusi vsechny sekce a polozky, tj. vrati konfiguraci do stavu,
              v jakem byla po uvodnim initu.}
              private
              {pomocne interni metody, ktere nejsou urcene pro volani zvenku:}
              procedure VyberSekci2(_Jmeno:string; var Predchozi:uknacfgsekci);
              {Pokusi se vybrat sekci s danym Jmenem. Pokud ji najde, vrati
              navic v parametru Predchozi adresu predchozi sekce. Pokud ji
              nenajde, novou nevytvori a nebude vybrana zadna sekce.
              Nepouziva orezavani jmen.}
              function HodnotaPolozky(ktere:uknacfgpolozku):string;
              {Vraci hodnotu dane polozky v textovem formatu (jak bude zapsana
              do souboru). Pri jakekoli neplatne adrese vraci ''.}
              end;
{Vsechny metody pracuji "tise", tj. pripadne chyby nijak nehlasi ani neshodi
program, jenom proste nic neudelaji.}

{Mozne hodnoty pro parametr _Typ metody DefinujPolozku:}
const _string  = $0000; {Dolni byte urcuje maximalni delku, napr.:
                        DefinujPolozku('Neco',@neco,_string+30);
                        Zadate-li pouze _string bez pricteni delky, povazuje
                        se za dovolene maximum 255 znaku.}
      _boolean = $0100; {U vsech ostatnich typu se dolni byte ignoruje.}
      _char    = $0200;
      _byte    = $0300;
      _shortint= $0400;
      _word    = $0500;
      _integer = $0600;
      _longint = $0700;
      _real    = $0800;

      _smazat = $8000; {kdyz zavolate metodu Uloz, polozky typu _smazat
                       budou z ciloveho souboru odstraneny
                       (zalezi jen na nejvyssim bitu, takze pro prehlednost
                       muzete psat napr. _integer+_smazat)}

{*************************** verejne promenne: ******************************}

const cfgSoubor:string[12]='CONFIG.CFG'; {predpokladam, ze si sem program
           vlozi jmeno, ktere se k nemu bude dobre hodit. Kdyz potom vsechny
           jednotky budou nacitat nastaveni odtud, bude na vsechno stacit
           jeden soubor a nebude treba upravovat kazdou jednotku zvlast.}
      cfgCS:boolean=false; {Jestli se maji rozlisovat velka a mala pismena ve
           jmenech sekci a datovych polozek. True znamena, ze pokud velikost
           pismen neodpovida, povazuje se to za dve ruzna jmena.
           Plati jak pro vyber sekci a polozek v konfiguraci, tak pro hledani
           v souborech.}
      cfgOrezatJmena:boolean=true; {True znamena, ze se ignoruji mezery na
           zacatku a konci jmen sekci a polozek (vhodne napr. pro odsazovani
           a zarovnavani do sloupcu). False znamena, ze se do jmena pocitaji
           i mezery pred a za nim.
           Plati jak pro vyber sekci a polozek v konfiguraci, tak pro hledani
           v souborech.}
      cfgOrezatHodnoty:boolean=false; {totez pro hodnoty datovych polozek}

{************************ dalsi verejne procedury: **************************}

procedure PodepisSeTu;
{Do hlavniho konfiguracniho souboru (promenna Cfgsoubor, viz vyse) si
poznamena, ze uz jsme tento program na tomto pocitaci jednou spousteli.
Vraci true, pokud se ukladani zdarilo.}
function ByliJsmeTu:boolean;
{Rekne, jestli program uz nekdy na tomhle pocitaci bezel a poznamenal si do
konfiguracniho souboru podpis.}

{****************************************************************************}

implementation
uses retezce;

{Vypocty velikosti podle delky jmena (aby se neplytvalo pameti na cely
255znakovy string, kdyz je jmeno vetsinou podstatne kratsi):}

function VelikostSekce(jmeno:string):word;
Begin
velikostsekce:=2*sizeof(pointer)+sizeof(boolean)+1+length(jmeno);
End;{velikostsekce}

function VelikostPolozky(jmeno:string):word;
Begin
velikostpolozky:=2*sizeof(pointer)+sizeof(word)+sizeof(boolean)+1+length(jmeno);
End;{velikostpolozky}


procedure konfigurace.init;
Begin              {Globalni promenne vetsinou byvaji vynulovane implicitne, }
prvnisekce:=nil;   {ale proc na to spolehat? Lokalni naopak nejsou implicitne}
vybranasekce:=nil; {vynulovane nikdy, potom je tohle nutne.                  }
End;{konfigurace.init}

procedure konfigurace.VyberSekci2(_Jmeno:string; var predchozi:uknacfgsekci);
Begin
{jestli se nema rozlisovat velikost pismen, musime si jmena prevest na jednu velikost:}
vybranasekce:=prvnisekce;
predchozi:=nil;
if not cfgcs then _jmeno:=stringup(_jmeno);
while vybranasekce<>nil do
 begin
 if (_jmeno=vybranasekce^.jmeno) or not cfgcs and (_jmeno=stringup(vybranasekce^.jmeno))
   then break; {kdyz jsme se trefili, koncime...}
 predchozi:=vybranasekce; {...jinak pidalkovitym stylem...}
 vybranasekce:=vybranasekce^.dalsi; {...prohledavame dal}
 end;
End;{vybersekci2}

procedure konfigurace.VyberSekci(_jmeno:string);
var p,nova:uknacfgsekci;
    velikost:word;
Begin
if cfgorezatjmena then _jmeno:=strip(_jmeno,'B',' ');
vybersekci2(_jmeno,p);
if vybranasekce=nil then {dana sekce jeste neexistuje - vytvorime ji}
  begin
  velikost:=velikostsekce(_jmeno);
  if velikost<=maxavail then
    begin
    getmem(nova,velikost);
    with nova^ do
      begin
      dalsi:=nil; {pridava se na konec, takze za touhle sekci urcite nic nebude}
      prvnipolozka:=nil; {zatim tu nic neni}
      vyrizeno:=false;
      jmeno:=_jmeno;
      end;
    {zapojeni do seznamu sekci:}
    if prvnisekce=nil
      then prvnisekce:=nova {bude prvni}
      else begin {seznam neni prazdny, tak nejdriv najdeme konec...}
           p:=prvnisekce;
           while p^.dalsi<>nil do p:=p^.dalsi;
           p^.dalsi:=nova; {...a za ten konec to vlozime}
           end;
    vybranasekce:=nova; {a novou sekci vybereme}
    end;
  end;
End;{konfigurace.vybersekci}

procedure konfigurace.ZrusSekci(_jmeno:string);
var up:uknacfgpolozku;
    predchozi:uknacfgsekci;
    ret:string;
Begin
if cfgorezatjmena then _jmeno:=strip(_jmeno,'B',' ');
vybersekci2(_jmeno,predchozi);
if vybranasekce<>nil then
  begin
  {smazani obsahu:}
  while vybranasekce^.prvnipolozka<>nil do
    begin
    up:=vybranasekce^.prvnipolozka;
    vybranasekce^.prvnipolozka:=up^.dalsi;
    freemem(up,velikostpolozky(up^.jmeno));
    end;
  {smazani sekce:}
  if predchozi=nil then prvnisekce:=vybranasekce^.dalsi
                   else predchozi^.dalsi:=vybranasekce^.dalsi;
  freemem(vybranasekce,velikostsekce(vybranasekce^.jmeno));
  vybranasekce:=nil;
  end;
End;{konfigurace.zrussekci}

procedure konfigurace.DefinujPolozku(_Jmeno:string; _Adresa:pointer; _Typ:word);
var p,nova:uknacfgpolozku;
    velikost:word;
Begin
if cfgorezatjmena then _jmeno:=strip(_jmeno,'B',' ');
if (vybranasekce<>nil)and(_jmeno<>'')and(_adresa<>nil) then
  begin
  zruspolozku(_jmeno); {jestli uz stejna polozka existuje, smazeme ji (jestli neexistuje, nic se nestane)}
  {jak velka bude nova polozka:}
  velikost:=velikostpolozky(_jmeno);
  if velikost>maxavail then exit; {staci nam pamet?}
  {vytvorime ji:}
  getmem(nova,velikost);
  with nova^ do begin
                dalsi:=nil; {bude na konci, takze za ni nic nebude}
                adresa:=_adresa;
                typ:=_typ;
                jmeno:=_jmeno;
                vyrizeno:=false;
                end;
  {a vlozime na konec seznamu:}
  p:=vybranasekce^.prvnipolozka;
  if p=nil then vybranasekce^.prvnipolozka:=nova
           else begin
                while p^.dalsi<>nil do p:=p^.dalsi;
                p^.dalsi:=nova;
                end;
  end;
End;{konfigurace.definujpolozku}


procedure konfigurace.ZrusPolozku(_jmeno:string);
var predchozi,p:uknacfgpolozku;
    VelkeJmeno:string;
Begin
if cfgorezatjmena then _jmeno:=strip(_jmeno,'B',' ');
velkejmeno:=stringup(_jmeno);
if vybranasekce<>nil then
  begin
  {nalezeni polozky:}
  p:=vybranasekce^.prvnipolozka;
  predchozi:=nil;
  while p<>nil do begin {dokud neprojdeme cely seznam}
                  if (p^.jmeno=_jmeno)
                     or not cfgcs and (stringup(p^.jmeno)=velkejmeno)
                    then break; {kdyz to je to hledane, koncime...}
                  predchozi:=p; {...jinak se pidalkovitym stylem...}
                  p:=p^.dalsi;  {...posuneme o polozku dal}
                  end;
  if p<>nil then begin {polozka se nasla, jdeme ji smazat}
                 if predchozi=nil then vybranasekce^.prvnipolozka:=p^.dalsi
                                  else predchozi^.dalsi:=p^.dalsi;
                 freemem(p,velikostpolozky(p^.jmeno));
                 end;
  end;
End;{konfigurace.zruspolozku}

procedure konfigurace.Nacti(Soubor:string);
 procedure ZpracujCeleCislo(TextovaHodnota:string; minimum,maximum:longint; kam:pointer; delka:word);
 var l:longint;
     kod:integer;
 Begin
 val(textovahodnota,l,kod);
 if kod=0 then
   begin
   if l<minimum then l:=minimum
                else if l>maximum then l:=maximum;
   move(l,kam^,delka); {vicebytova cisla se ukladaji nejnizsim bytem napred,}
   end;                {takze staci takhle zkopirovat par prvnich bytu      }
 End;{zpracujcelecislo}
var t:text;
    radek,jmeno,hodnota:string;
    predel,MaxDelka:byte;
    r:real;
    kod:integer;
    PuvodniVybrana,us:uknacfgsekci;
    up:uknacfgpolozku;
Begin
assign(t,soubor);
reset(t);
if ioresult=0 then
 begin
 puvodnivybrana:=vybranasekce;
 while not eof(t) do
  begin
  readln(t,radek);
  if ioresult<>0 then break;
  if (radek<>'')and(radek[1]<>';') then {kdyz to neni komentar}
   begin
   predel:=pos('=',radek);
   if predel=0
     then begin {je to nadpis sekce}
          if cfgorezatjmena then radek:=strip(radek,'B',' ');
          vybersekci2(radek,us)
          end
     else if vybranasekce<>nil {je to datova polozka a mame ji kam dat}
            then begin
                 {jmeno polozky:}
                 jmeno:=copy(radek,1,predel-1);
                 if cfgorezatjmena then jmeno:=strip(jmeno,'B',' ');
                 if not cfgcs then jmeno:=stringup(jmeno);
                 {zkusime polozku najit v konfiguraci:}
                 up:=vybranasekce^.prvnipolozka;
                 while up<>nil do
                   begin
                   if (jmeno=up^.jmeno)
                      or not cfgcs and (jmeno=stringup(up^.jmeno))
                     then break;
                   up:=up^.dalsi;
                   end;
                 if up<>nil {polozka se nasla, nacteme ji}
                   then begin
                        hodnota:=copy(radek,predel+1,length(radek)-predel);
                        if cfgorezathodnoty then hodnota:=strip(hodnota,'B',' ');
                        case up^.typ and $7F00 of
                         _string:begin
                                 maxdelka:=lo(up^.typ);
                                 if maxdelka=0 then maxdelka:=255;
                                 hodnota:=left(hodnota,maxdelka);
                                 move(hodnota[0],up^.adresa^,length(hodnota)+1);
                                 end;
                         _boolean:begin
                                  if hodnota<>'' then
                                   if hodnota[1] in ['n','N','f','F','0'] then boolean(up^.adresa^):=false
                                    else if hodnota[1] in ['a','A','y','Y','t','T','1'] then boolean(up^.adresa^):=true;
                                  end;
                         _char:if hodnota<>'' then char(up^.adresa^):=hodnota[1];
                         _byte:ZpracujCeleCislo(hodnota,0,255,up^.adresa,1);
                         _shortint:ZpracujCeleCislo(hodnota,-128,127,up^.adresa,1);
                         _word:ZpracujCeleCislo(hodnota,0,$FFFF,up^.adresa,2);
                         _integer:ZpracujCeleCislo(hodnota,-32768,32767,up^.adresa,2);
                         _longint:ZpracujCeleCislo(hodnota,-2147483647,2147483647,up^.adresa,4);
                         _real:begin
                               val(hodnota,r,kod);
                               if kod=0 then real(up^.adresa^):=r;
                               end;
                         end;
                        end;{nacitani polozky}
                 end;{if datova polozka}
   end{if platny radek}
  end;{while not eof}
 close(t);
 kod:=ioresult; {bezpecnostni reset pro pripad, ze by pri zavirani souboru doslo k chybe}
 vybranasekce:=puvodnivybrana;
 end;
End;{konfigurace.nacti}

function konfigurace.HodnotaPolozky(ktere:uknacfgpolozku):string;
var vysledek:string;
    MaxDelka:byte;
Begin
if (ktere=nil) or (ktere^.adresa=nil) then vysledek:='' else
 begin
 case ktere^.typ and $7F00 of
  _string:begin
          maxdelka:=lo(ktere^.typ);
          if maxdelka=0 then maxdelka:=255;
          vysledek:=left(string(ktere^.adresa^),maxdelka);
          end;
  _boolean:if boolean(ktere^.adresa^) then vysledek:='1'
                                      else vysledek:='0';
  _char:vysledek:=char(ktere^.adresa^);
  _byte:str(byte(ktere^.adresa^),vysledek);
  _shortint:str(shortint(ktere^.adresa^),vysledek);
  _word:str(word(ktere^.adresa^),vysledek);
  _integer:str(integer(ktere^.adresa^),vysledek);
  _longint:str(longint(ktere^.adresa^),vysledek);
  _real:str(real(ktere^.adresa^):0:4,vysledek);
  end;
 end;
hodnotapolozky:=vysledek
End;{hodnotapolozky}

procedure konfigurace.Uloz(soubor:string);
var puvodni,novy:text; {z puvodniho cteme a do noveho zapisujeme; nakonec puvodni smazeme a novy prejmenujeme na puvodni}
    us,puvodnivybrana:uknacfgsekci;
    up:uknacfgpolozku;
    radek,jmeno,hodnota:string;
    predel:byte; {pozice rovnitka v radku}
{}procedure DojedSekci; {zapise do noveho souboru zbytek aktualne vybrane sekce a oznaci tuto sekci za vyrizenou}
{}Begin
{}up:=vybranasekce^.prvnipolozka;
{}while up<>nil do
{} begin
{} if not up^.vyrizeno and (up^.typ and _smazat=0)
{}   then begin
{}        writeln(novy,up^.jmeno+'='+hodnotapolozky(up));
{}        up^.vyrizeno:=true;
{}        end;
{} up:=up^.dalsi;
{} end;
{}vybranasekce^.vyrizeno:=true;
{}End;{dojedsekci}
Begin
if prvnisekce=nil then exit; {neni co ukladat}
assign(puvodni,soubor);
assign(novy,'smazat.$$$'); {docasny soubor, ktery pak prejmenujeme nebo smazeme}
rewrite(novy);
if ioresult<>0 then exit; {nepovedlo se otevrit soubor pro zapis}
{inicializace pomocnych promennych v konfiguraci:}
us:=prvnisekce;
while us<>nil do begin
                 us^.vyrizeno:=false; {tuhle sekci jsme jeste neukladali}
                 {to same pro vsechny polozky v teto sekci:}
                 up:=us^.prvnipolozka;
                 while up<>nil do begin
                                  up^.vyrizeno:=false;
                                  up:=up^.dalsi;
                                  end;
                 us:=us^.dalsi;
                 end;
puvodnivybrana:=vybranasekce; {zaloha pro pozdejsi obnoveni}
vybranasekce:=nil; {dulezite!}
reset(puvodni);
if ioresult=0 then
 begin {puvodni soubor existuje, budeme ho postupne cist a doplnovat}
 while not eof(puvodni) do
  begin
  readln(puvodni,radek);
  if (radek<>'')and(radek[1]<>';') then {neni to komentar}
   begin
   predel:=pos('=',radek);
   if predel=0
     then begin {je to nadpis sekce}
          if vybranasekce<>nil then dojedsekci; {nejdriv dodelame pripadnou drive rozjetou sekci}
          if cfgorezatjmena then jmeno:=strip(radek,'B',' ')
                            else jmeno:=radek;
          vybersekci2(jmeno,us);
          if (vybranasekce<>nil) and vybranasekce^.vyrizeno {nasli jsme podruhe stejne jmeno sekce}
            then vybranasekce:=nil;
          {dokud je vybranasekce=nil, budou se radky kopirovat bez uprav}
          end
     else if vybranasekce<>nil {je to datova polozka a mame ji kde hledat}
            then begin
                 jmeno:=left(radek,predel-1); {to pred rovnitkem}
                 {zkusime ji najit:}
                 if cfgorezatjmena then jmeno:=strip(jmeno,'B',' ');
                 if not cfgcs then jmeno:=stringup(jmeno);
                 up:=vybranasekce^.prvnipolozka;
                 while up<>nil do
                  begin
                  if (jmeno=up^.jmeno) or not cfgcs and (jmeno=stringup(up^.jmeno))
                    then begin {nasli jsme ji}
                         if up^.vyrizeno or (up^.typ and _smazat<>0)
                           then radek:='' {smazeme ji ze souboru (vznikne prazdny radek, ale to nevadi)}
                           else begin {zapiseme ji}
                                radek:=up^.jmeno+'='+hodnotapolozky(up);
                                up^.vyrizeno:=true;
                                end;
                         break;
                         end;
                  up:=up^.dalsi;
                  end;{prohledavani sekce}
                 end;{zpracovani datove polozky}
   end;{prezvykovani radku}
  writeln(novy,radek);
  end;{while not eof(puvodni)}
 close(puvodni);
 if ioresult=0 then erase(puvodni);
 end;{if puvodni existuje}
{doplnime zbytek, ktery v puvodnim souboru nebyl (nebo uplne vsechno, pokud
zadny puvodni soubor neexistoval):}
if vybranasekce<>nil then dojedsekci;
vybranasekce:=prvnisekce;
while vybranasekce<>nil do
 begin
 if not vybranasekce^.vyrizeno
   then begin
        writeln(novy); {vynechani radku mezi sekcemi (pro prehlednost)}
        writeln(novy,vybranasekce^.jmeno);
        dojedsekci;
        end;
 vybranasekce:=vybranasekce^.dalsi;
 end;
close(novy);
rename(novy,soubor); {prejmenujeme novy na puvodni}
if ioresult=0 then {hm};
vybranasekce:=puvodnivybrana;
End;{konfigurace.uloz}

procedure konfigurace.Zrus;
var us:uknacfgsekci;
    up:uknacfgpolozku;
    velikost:word;
Begin
while prvnisekce<>nil do
  begin
  while prvnisekce^.prvnipolozka<>nil do
    begin
    up:=prvnisekce^.prvnipolozka^.dalsi;
    freemem(prvnisekce^.prvnipolozka,velikostpolozky(prvnisekce^.prvnipolozka^.jmeno));
    prvnisekce^.prvnipolozka:=up;
    end;
  us:=prvnisekce;
  prvnisekce:=prvnisekce^.dalsi;
  freemem(us,velikostsekce(us^.jmeno));
  end;
vybranasekce:=nil;
End;{konfigurace.zrus}


(****************************************************************************)


{nacteni informaci o pocitaci, na kterem program bezi:}
procedure OkoukniProstredi(var VerzeVBE,{verze VESA biosu; sice se stroj od stroje moc nemeni, ale proc to nepouzit}
                               GrafickaKarta, {jmeno grafarny (OEM ID)}
                               DatumVyroby, {datum vyroby BIOSu}
                               Hardware:string);{bitove pole obsahujici informace o existenci harddisku,
                                                 poctu disketovych mechanik, portu, tiskaren a podobne}
type pch=array[0..0] of char;
     tVESAInfo = record
                 Signatura:array[0..3] of char;
                 Verze:word; {verze VESA VBE}
                 JmenoKarty:^pch; {ukazatel na jmeno graficke karty (retezec zakonceny znakem #0)}
                 zbytek:array[1..502] of byte;
                 end;
var VESAinfo:^tVESAInfo;
    vysledek:word;
    b:byte;
Begin
if maxavail<sizeof(tvesainfo)
  then vysledek:=$FFFF {nestaci pamet}
  else begin {OK, pamet staci}
       new(vesainfo);
       asm
       mov AX,$4F00     {kod sluzby "zjisti informace o rozhrani VESA"}
       les DI,vesainfo  {adresa navratoveho zasobniku}
       int $10          {a makej...}
       mov vysledek,AX  {jak jsme dopadli?}
       end;
       end;
if vysledek=$4F {OK, informace jsou nacteny}
  then with vesainfo^ do
         begin
         verzevbe:=nastr(hi(verze))+'.'+nastr(lo(verze));
         b:=0;
         {prevod nulou ukonceneho retezce na string:}
         while (b<246)and(jmenokarty^[b]<>#0) do inc(b);
         byte(grafickakarta[0]):=b;
         move(jmenokarty^[0],grafickakarta[1],b);
         end
  else begin {informace se nenacetly (coz je v podstate taky informace)}
       verzevbe:='neznama';
       grafickakarta:=verzevbe;
       end;
if vysledek<>$FFFF then dispose(vesainfo); {jestli jsme zasobnik alokovali, zase ho uvolnime}
datumvyroby[0]:=#8; {delku retezce nastavime natvrdo na 8 znaku}
for b:=1 to 8 do datumvyroby[b]:=chr(mem[$F000:$FFF4+b]); {By Pedro Eisman, CRAMP / Dark Ritual, 1996}
hardware:=nastr(memw[0:$0410]);
End;{okoukniprostredi}

procedure ZpracujPodpis(p1,p2,p3,p4:pointer; ulozit:boolean);
{nacte nebo ulozi informace o pocitaci}
var kon:konfigurace;
Begin
kon.init;
kon.vybersekci('[prostredi]');
kon.definujpolozku('Verze VESA',p1,_string);
kon.definujpolozku('Graficka karta',p2,_string);
kon.definujpolozku('Datum vyroby BIOSu',p3,_string);
kon.definujpolozku('Hardware',p4,_string);
if ulozit then kon.uloz(cfgsoubor)
          else kon.nacti(cfgsoubor);
kon.zrus;
End;{zpracujpodpis}

procedure PodepisSeTu;
var texty:array[1..4] of string;
Begin
fillchar(texty,sizeof(texty),0);
okoukniprostredi(texty[1],texty[2],texty[3],texty[4]);
zpracujpodpis(@texty[1],@texty[2],@texty[3],@texty[4],true);
End;{podepissetu}

function ByliJsmeTu:boolean;
var texty:array[1..8] of string; {1..4 aktualni, 5..8 ulozene}
Begin
fillchar(texty,sizeof(texty),0);
okoukniprostredi(texty[1],texty[2],texty[3],texty[4]);
zpracujpodpis(@texty[5],@texty[6],@texty[7],@texty[8],false);
bylijsmetu:=(texty[1]=texty[5]) and (texty[2]=texty[6]) and
            (texty[3]=texty[7]) and (texty[4]=texty[8]);
End;{bylijsmetu}

END.

{Format konfiguracniho souboru (CFG, INI apod.):
 Obycejny textovy soubor, radky max. 255 znaku dlouhe. Kazdy radek muze byt:
a) Komentar - pozna se podle toho, ze zacina strednikem (;).
b) Prazdny
c) Datova polozka - pozna se podle toho, ze obsahuje rovnitko (=).
   Text pred rovnitkem je jmeno polozky, za rovnitkem jeji hodnota.
d) Nadpis sekce - cokoli, co neni komentar a neobsahuje rovnitko. Obvykle se
   pise do [hranatych zavorek], ale neni to nutne.

 Pri nacitani a ukladani se ignoruji:
- komentare,
- prazdne radky,
- datove polozky, ktere nejsou zadefinovane v konfiguraci,
- datove polozky, pred kterymi nebyl zadny radek s nadpisem sekce.

 Pri ukladani se:
- nezachovava odsazeni, rovnitko se pise hned za jmeno a hodnota hned za nej,
- booleany prevadeji na tvar 0/1 (misto true/false, ano/ne apod.),
- realna cisla zaokrouhluji na 4 desetinna mista,
- stringy orezavaji na zadanou maximalni delku.

 Pri nacitani se:
- stringy orezavaji na zadanou maximalni delku,
- cisla orezavaji na rozsah dany pouzitym typem,
- neplatne hodnoty (treba text misto cisla) ignoruji a prislusne promenne
  zustavaji beze zmeny.
}

(**** Priklad pouziti ****
 Dejme tomu, ze mame konfiguracni soubor TETRIS.CFG:

(zacatek souboru)
;Konfigurace pro hru Tetris
[hra]
HiScore   = 3098
Jmeno hrace  =Raketovej Pepa
Barva pozadi = 1

[zvuk]
;tohle si nastavte rucne (ano nebo ne):
zapnout=ano

[grafika]
BPP=8
Obnovovaci frekvence=75 Hz
(konec souboru)


 V programu udelame tohle:

var HiScore:word;
    Level:byte;
    JmenoHrace:string[60];
    zvuk:boolean;
    k:konfigurace;
...
k.init;
k.VyberSekci('[hra]');
k.DefinujPolozku('HiScore',@hiscore,_word);
k.DefinujPolozku('Level',@level,_byte);
k.DefinujPolozku('Jmeno hrace',@jmenohrace,_string+60);
k.vybersekci('[zvuk]');
k.definujpolozku('zapnout',@zvuk,_boolean);
k.nacti('TETRIS.CFG');

 Ted mame HiScore=3098, JmenoHrace='Raketovej Pepa' a zvuk=true. Polozka
"Level" v souboru nebyla, takze se do promenne Level nic nenacetlo a zustala
v ni jeji puvodni hodnota. Pro polozku "Barva pozadi", ktera v souboru je,
naopak nemame definovanou polozku v konfiguraci, takze se taky nenacetla.
Stejne tak se preskocila nedefinovana sekce [grafika].

...
HiScore:=4000;
Level:=3;
JmenoHrace:='Nekdo jiny';
{zvuk je porad true}
k.uloz('TETRIS.CFG');

 Aktualni hodnoty promennych HiScore, JmenoHrace a Zvuk v souboru prepsaly
puvodni hodnoty na radcich "HiScore", "Jmeno hrace" a "zapnout", radek pro
promennou Level byl nove vytvoren a nedefinovana polozka "Barva pozadi" se
preskocila. Soubor ted vypada takhle:

(zacatek souboru)
;Konfigurace pro hru Tetris
[hra]
HiScore=4000
Jmeno hrace=Nekdo jiny
Barva pozadi = 1
Level=3

[zvuk]
;tohle si nastavte rucne (ano nebo ne):
zapnout=1

[grafika]
BPP=8
Obnovovaci frekvence=75 Hz
(konec souboru)

 Nakonec muzeme konfiguraci zrusit:

k.zrus;
*)