{
  Joachim Deckers
  Anlage zur 2. Staatsexamensarbeit / 28.5.96

  Diese Unit Protokoll wird zuerst im Abschnitt "7.3.5.1 Einfache Protokollsprachen"
  benötigt.

  Simuliert wird eine einfache Datenübertragung zwischen zwei Rechnern bzw. zwei
  Rechneranwendungen, wobei anstelle einer Netzwerkkarte eine Datei zur Pufferung
  der Daten verwendet wird.

  Ggf. sollte die Konstante dateiname verändert werden!
}


UNIT protokoll;


INTERFACE



PROCEDURE Sende(zeichenkette: string);
  { Sendet den String zeichenkette }
PROCEDURE SendeChars(anzahl: Word; feld: PChar);
  { Sendet anzahl Zeichen aus dem Speicher ab der Position,
      auf die feld zeigt (ohne Größenkontrolle des Feldes).}
PROCEDURE Empfange(anzahl: Word; var zeichenkette: string);
  { Wenn noch anzahl gesendete Zeichen zur Verfügung stehen,
      werden anzahl Zeichen empfangen und in zeichenkette abgelegt.
    Sonst wird ein String der Länge 0 in zeichenkette abgelegt. }
PROCEDURE EmpfangeChars(var anzahl: Word; feld: PChar);
  { Wenn noch anzahl gesendete Zeichen zur Verfügung stehen,
      werden anzahl Zeichen ampfangen und ab der Position im Speicher
      abgelegt, auf die feld zeigt (ohne Kontrolle, wie groß das Feld ist).}
PROCEDURE SetzeZurueck;
  { Löscht alle bisher gesendeten Zeichen.
      Kein Empfänger kann danach noch Zeichen empfangen. }  

PROCEDURE Uebertragungsfehler(simulation: boolean);
  { Schaltet die Simulation von Sende- und Empfangsfehlern ein (true)
      oder aus (false). Durch die Simulation wird die Laufzeit merklich erhöht. }
PROCEDURE SetzeFehlerrate(rate: real);
  { Setzt die Fehlerrate für Sendefehler auf rate und
      verhindert die Simulation von Empfangsfehlern. }
PROCEDURE SetzeFehlerraten(srate: real; erate: real);
  { Setzt die Fehlerraten für Sendefehler und für Empfangsfehler }
PROCEDURE SendeFehler(simulation: boolean);
  { Schaltet die Simulation von Sendefehlern ein (true) oder aus (false).} 
PROCEDURE EmpfangsFehler(simulation:boolean);
  { Schaltet die Simulation von Empfangsfehlern ein (true) oder
      aus (false).}


PROCEDURE Warte(centisec: longint);
  { Wartet centisec Hundertstel Sekunden mit der weiteren Programmausführung.
      Die Prozeßkontrolle wird währenddessen immer wieder an Windows zurückgegeben.}

PROCEDURE PCharInString(anzahl: Byte; von: PChar; var zu:string);
  { Kopiert Zeichen aus einem Feld von Chars in einen String.
    Näheres siehe unten. }


IMPLEMENTATION

uses   windos,    { Zeitabfrage }
       wincrt,    { Standard-I/O }
       winprocs,  { Dateioperationen (shared), Meldungsfenster, Taskverwaltung }
       wintypes,  { PChar }
       strings;   { StrPCopy }

const  dateiname   = 'PROTOKOL.DAT'; { für die Sende-/Empfangsdaten } 

       { Durch den exklusiven Zugriff bei Schreiboperationen kann immer
         nur ein Prozeß zu einer Zeit schreiben. Daher müssen andere
         Prozesse, die zur gleichen Zeit Schreibzugriff benötigen,
         eine (nicht immer gleichlange!) Zeit warten und es dann erneut
         versuchen. }
       maxversuche =   5; { Anzahl Versuche bei mißlungenen Dateioperationen      }    
       minwartezeit=  10; { Obere und untere Schranken für Wartezeit vor erneutem }
       maxwartezeit= 200; { Versuch nach mißlungener Dateioperation (öffnen)      } 

       outofmemory = 'Nicht genügend Speicher vorhanden!';
       teststring  : string[4] = 'test'; { siehe Hauptprogramm }

var    lesepos           : Longint; { Momentane Position des Lesezeigers }
       f                 : Integer; { Dateihandle (unter Windows) }
       sendefehlersim,
       empfangsfehlersim : Boolean; { Fehlersimulation durchführen? }
       sendefehlerrate,
       empfangsfehlerrate: Real;    { Fehlerraten setzen }


function DateiExistiert: Boolean;
  { Prüft, ob die Datei für Sende-/Empfangsdaten existiert. }
begin
  f:=_lopen(dateiname,of_Share_Deny_None);
  if (f=-1) then
    DateiExistiert:=false
  else begin
    DateiExistiert:=true;
    _lclose(f)
  end;
end;  { datei_existiert }

procedure Fehler(titel, meldung: string; fatal: boolean);
  { Gibt eine Fehlermeldung in einer MessageBox aus.
    Falls fatal, wird die Programmausführung abgebrochen. }
var buffer: array[1..2,0..255] of char; 
begin
  StrPCopy(@buffer[1],titel);
  StrPCopy(@buffer[2],meldung);
  MessageBox(0,@buffer[2],@buffer[1],mb_IconExclamation or mb_Ok);
  if fatal then halt(100);
end;

procedure verzoegere;
  { Verzögert die Programmausführung nach mißlungenem Dateizugriff }
begin
  Warte(Round(minwartezeit+(maxwartezeit-minwartezeit)*random))
end;

procedure SendeChars; { s. o. }
var fzaehl, zaehl, zaehl2: Word;    
    offset               : Longint; 
    maske                : Byte;    { fuer Bitoperationen bei Fehlersimulation }
begin
  fzaehl:=0; { Zähler für Fehlversuche bei Öffnen der Datei }
  repeat     { Schleife für einzelne Versuche } 
    { Datei öffnen bzw. erzeugen }
    if not DateiExistiert then f:=_lcreat(dateiname,0)
    else f:=_lopen(dateiname,of_Share_Deny_Write or of_Write);
                             { Andere dürfen zugleich höchstens lesen }
    if f=-1 then begin
      inc(fzaehl);                          { Fehlerzähler inkrementieren        }
      if fzaehl<maxversuche then verzoegere { und ggf. warten fuer neuen Versuch }
    end
    else begin
      offset:=_llseek(f,0,2);      { Ans Ende der Datei positionieren }
      if (offset=-1) then
        Fehler('Positionierungsfehler','Die Botschaft wurde nicht gesendet.',false)
      else begin
        if sendefehlersim and (sendefehlerrate>0) then { Fehler simulieren? }
          for zaehl:=0 to anzahl-1 do
          begin
            maske:=1;
            for zaehl2:=1 to 8 do begin { Bitweise Fehler simulieren }
              if random<sendefehlerrate then
                feld[zaehl]:=char((byte(feld[zaehl]) and ($ff-maske))  { Bit löschen }
                      or ((byte(feld[zaehl]) and maske) xor maske));    { Bit kippen  }
              maske:=maske*2;
            end;
          end; { Ende der Fehlersimulation }

        if _lwrite(f,PChar(feld),anzahl)<>anzahl then { feld in die Datei schreiben }
          Fehler('Schreibfehler','Die Botschaft wurde nicht erfolgreich gesendet.',false);
      end; { else }
      _lclose(f)
    end { else } 
  until (f<>-1) or (fzaehl=maxversuche);
  if fzaehl=maxversuche then { Bei Sendefehler erfolgt Programmabbruch.
                               Er kann ja auch durch ReadOnly-Flags erzeugt sein! }
    Fehler('Sendefehler','Die Botschaftendatei konnte nicht geöffnet werden.',true);
  Keypressed;
  Yield;
end;

procedure Sende; { s. o. }
var feld: PChar; { Temporär angelegtes feld (für SendeChars) }
    l   : Word;  { Länge des Feldes }
begin
  l:=Length(zeichenkette)+1; {+1 wegen StrPCopy }
  if MaxAvail< l then 
    Fehler('Speicherfehler',outofmemory,true)
  else begin
    GetMem(feld, l);
    StrPCopy(feld,zeichenkette);
    SendeChars(l-1,feld);
    FreeMem(feld, l)
  end
end;

procedure EmpfangeChars; { s. o. }
var offset,
    groesse: Longint; { Größe der datei }
    zaehl,
    fzaehl,
    zaehl2 : Integer;
    maske  : Byte;    { für Bitoperationen bei Fehlersimulation }

begin
  fzaehl:=0; { Zähler für Fehlversuche bei Öffnen der Datei }
  if anzahl>0 then { Bei anzahl=0 ist nichts zu empfangen. }
    repeat
      f:=_lopen(dateiname,of_Share_Deny_None or of_Read);
                          { Andere dürfen zugleich lesen und schreiben } 
      if (f=-1) then begin
        inc(fzaehl);
        if fzaehl<maxversuche then verzoegere
      end
      else begin
        groesse:=_llseek(f,0,2)+1;
        if lesepos>groesse then { Wurde die Datei zwischendurch zurückgesetzt? }
          lesepos:=0;
        if anzahl+lesepos<groesse then { Sind genügend Zeichen gesendet worden? }
        begin
          offset:=_llseek(f,lesepos,0); { Lesezeiger in der Datei positionieren }
          if offset=-1 then
            Fehler('Positionierungsfehler','Es wurde keine Botschaft empfangen.',false);

          if _lread(f,feld,anzahl)<>anzahl then
            { Darf nicht passieren - groesse kann hoechstens wachsen }
            Fehler('Lesefehler','Unit Protokoll überprüfen!',true);

          if empfangsfehlersim and (empfangsfehlerrate>0) then { Fehler simulieren? }
            for zaehl:=0 to anzahl-1 do
            begin
              maske:=1;
              for zaehl2:=1 to 8 do begin { Bitweise Fehler simulieren }
                if random<empfangsfehlerrate then
                  feld[zaehl]:=char((byte(feld[zaehl]) and ($ff-maske)){ Bit löschen }
                    or ((byte(feld[zaehl]) and maske) xor maske));   { Bit kippen }
                maske:=maske*2;
              end;
            end; { Ende der Fehlersimulation }

          inc(lesepos,anzahl);
        end
        else
          anzahl:=0;
        _lclose(f);
      end;
      Keypressed;
      Yield;
    until (f<>-1) or (fzaehl=maxversuche);
  if fzaehl=maxversuche then
     Fehler('Empfangsfehler','Die Botschaftendatei kann nicht geöffnet werden.',true)
  { Alternative: (wenn kein ProgrAbbruch erfolgen soll)
  if fzaehl=maxversuche then begin
     Fehler('Empfangsfehler','Die Botschaftendatei kann nicht geöffnet werden.',false)
     anzahl:=0
  end }
end;


procedure PCharInString(anzahl: Byte; von: PChar; var zu:string);
  { Wegen der Längenbegrenzung von Strings auf 255 Zeichen unter allen
    mir bekannten PASCAL-Compilern, werden Bytefelder verwendet, auf die mit 
    einem Zeiger vom Typ PChar zugegriffen wird (Längenbegrenzung:
    65535 Zeichen). Da aber auch Zeichenketten, die #0 enthalten, verarbeitet
    werden sollen, darf die Routine StrPas aus der Unit Strings (Borland
    Turbo Pascal für Windows 1.5) nicht verwendet werden sondern muß´
    durch eine eigene Routine PCharInString ersetzt werden. Dafür muß kontrolliert
    werden, ob bei der jeweils verwendeten Compiler-Version Strings noch
    immer den bisher üblichen Aufbau haben (Pos. 0 enthält die Länge,
    Pos. 1 - Pos. Length(..) die Zeichenkette. Dieses geschieht im
    Hauptprogramm der Unit. }
begin
  zu[0]:=char(anzahl);
  while (anzahl>0) do begin
    zu[anzahl]:=von[anzahl-1];
    dec(anzahl);
  end
end;

procedure Empfange; {s. o.}
var feld: PChar; { Temporär angelegtes Feld für EmpfangeChars }
    l   : Word;  { Größe des Feldes }
begin
  if MaxAvail< anzahl then
    Fehler('Speicherfehler',outofmemory,true)
  else if anzahl>0 then 
    begin
      GetMem(feld, anzahl);
      EmpfangeChars(anzahl,feld);
      PCharInString(anzahl,feld,zeichenkette);
      FreeMem(feld, anzahl)
    end
    else zeichenkette:='';
end;

procedure SetzeZurueck; {s. o.}
begin 
  f:=_lcreat(dateiname,0);
  _lclose(f);
end;


procedure ZeigeAn;
  { Zeigt die Datei als Hexdump auf die Standardausgabe aus.
    NUR FUER TESTZWECKE !!! 
    Ggf. Prozedurkopf in den INTERFACE-Teil aufnehmen! }
var i, k   : Integer;
    c      : array [1..9] of byte;
    groesse: Longint;
begin
  Write('Anzeige der Datei ',dateiname);
  f:=_lopen(dateiname,of_Share_Deny_None or of_Read);
  if (f=-1) then
    Writeln('--- Datei konnte nicht geöffnet werden!')
  else begin   
    groesse:=_llseek(f,0,2)+1;
    Writeln(' (',groesse,' Bytes):');
    _llseek(f,0,0);
    for i:=0 to (groesse-1) div 8 do begin
      k:=_lread(f,PChar(@c),8);
      for k:=1 to 8 do
        if (i*8+k<groesse) then
          write(' ',c[k]:3)
        else write('    ');
      write(' : ');
      for k:=1 to 8 do
        if (i*8+k<groesse) then
          if IsCharAlphaNumeric(char(c[k])) then
            write(char(c[k]):1)
          else write('.');
      writeln;
    end;
  end;
end;

 procedure SendeFehler; {s. o.}
 begin
   sendefehlersim:=simulation
 end;

 procedure EmpfangsFehler; {s. o.}
 begin
   empfangsfehlersim:=simulation
 end;

 procedure Uebertragungsfehler; {s. o.}
 begin
   SendeFehler(simulation);
   EmpfangsFehler(simulation);
 end;

 procedure SetzeFehlerraten; {s. o.}
 begin
   sendefehlerrate:=srate;
   empfangsfehlerrate:=erate;
   if (erate*srate<>0.0) then
     if ((srate<=1.526e-5) or (erate<1.526e-5)) then
       Fehler('Warnung','Fehlerraten zwischen 0 und 0.00001526 sind nicht möglich.',false)
       { Na ja, genauer gesagt: Die kleinstmögliche Fehlerrate liegt bei 2^(-16) }
     else
     if (srate<1e-4) or (erate<1e-4) then
       Fehler('Warnung','Bei Fehlerraten unter 0.0001 wird die Simulation sehr ungenau!',false);
 end;

 procedure SetzeFehlerrate; {s. o.}
 begin
   sendefehlerrate:=rate;
   empfangsfehlerrate:=0;
 end;

 procedure Warte; {s. o.}
 var t1, t2          : longint;
     std,min,sec,s100: word;
 begin
   gettime(std,min,sec,s100);
   t1:=s100+100*(sec+60*(min+60*std));
   repeat
     gettime(std,min,sec,s100);
     t2:=s100+100*(sec+60*(min+60*std));
     KeyPressed;
     { Keypressed wird bei Verwendung von Yield und WinCRT benötigt,
       damit Programmabbrüche möglich sind. }
     Yield;
   until (t2-t1>=centisec) or (t2<t1) { falls ein neuer Tag anbricht... }
 end;

begin { Hauptprogramm zur Initialisierung der Unit-Variablen }
  if (Length(teststring)<>ord(teststring[0])) or (SizeOf(teststring)<>Length(teststring)+1) then
    { Vgl. Kommentar bei Procedure PCharInString }
    Fehler('Fataler Fehler','Der Compiler verarbeitet Strings nicht wie vorgesehen!',true);   
  lesepos           :=0;
  sendefehlersim    :=false;
  empfangsfehlersim :=false;
  sendefehlerrate   :=1E-4;
  empfangsfehlerrate:=0;
  CheckBreak        :=TRUE;
  randomize
end.