Turbo Toolbox/Turbo_Toolbox.iso/extra18/grdlagen/umleitg/hrdosum.pas

Pascal/Delphi Source File | 1992-01-22 | 14.7 KB | 564 lines

(* ------------------------------------------------- *)
(*                     HRDOSUM.PAS                   *)
(*            (c) 1992 H.Rüter & DMV-Verlag          *)
(* ------------------------------------------------- *)
(* Diese Unit ermöglicht es Dos-IN/OUT-Umleitungen   *)
(* zu erkennen.                                      *)
(* Programme die mit dieser Unit erstellt werden,    *)
(* können diese Umleitungen für eigene Zwecke nutzen.*)
(* Wichtig ist,daß im Hauptprogramm die Unit CRT vor *)
(* HRDOSUM initialisiert wird, damit die Umleitungen *)
(* auch realisiert werden.                           *)
(* Die umgeleiteten Ein/Ausgaben sind immer auf dem  *)
(* Bildschirm zu sehen, damit man auch weiß, was da  *)
(* umgeleitet wird können. ( -> Uses Crt,HRDOSUM ... *)
(* ------------------------------------------------- *)
UNIT HRDosUm;
{$M 1024,0,0,I-,R-,S-,N-,V-,B-,A+,D+}
                   (* Höchstmögliche Geschwindigkeit *)

INTERFACE

TYPE
  InOutModus =
     (NoRedirection,
         (* Keine Umleitung                          *)
     InputRedirection,
         (* Input kommt aus redir. Datei             *)
     OutPutRedirection,
         (* Alle Write(Ln)-Aufrufe werden umgeleitet *)
     AllScreenRedirection,
         (* Alles auf dem Bildschirm wird umgeleitet *)
     ProtRedirection);
         (* Eingaben werden protokolliert            *)

CONST
  EoFLine      : BOOLEAN = FALSE;
  EoFInput     : BOOLEAN = FALSE;
      { Für Inputumleitung :
          True -> kein Zeichen im Puffer }


  FUNCTION DosOutputRedirected : BOOLEAN;
    { Screen-Output umgeleitet ?  }
  FUNCTION DosInputRedirected : BOOLEAN;
    { Input umgeleitet         ?  }
  PROCEDURE ChangeInOutModus(Mode : InOutModus);
    { Ändert den Umleitungsmodus  }
  FUNCTION  GetInOutModus : InOutModus;
    { Liefert den Umleitungsmodus }

  FUNCTION ReadKey : CHAR;
    { Ersetzt CRT-READKEY         }
  FUNCTION KeyPressed : BOOLEAN;
    { Ersetzt CRT-KEYPRESSED      }

  PROCEDURE SetInputDelay(Sec1000 : WORD);
    { Zur Simulation von Eingaben wird die
      Eingabegeschwindigkeit verringert }

  PROCEDURE SetReadKeyMode(Redirected : BOOLEAN);
    { Falls Redirected = TRUE, werden Eingaben
      via »ReadKey« ebenfalls umgeleitet }
  FUNCTION  GetReadKeyMode : BOOLEAN;
    { Liefert den momentanen ReadKey-Modus }

  PROCEDURE ChangeSightAbleMode(Sight:Boolean);
    { Wenn OutPut-Umleitung aktiv, kann man hier
      die Sichtbarkeit auf dem Screen beeinflussen }
  FUNCTION OutPutSightAble : BOOLEAN;
    { Umgeleiteter Output auch auf Screen sichtbar  }

  PROCEDURE InSightOnOff(Sight : BOOLEAN);
    { Wenn InPut-Umleitung aktiv, kann man hier
      die Sichtbarkeit auf dem Screen beeinflussen }

  FUNCTION InPutSightAble : BOOLEAN;
    { Umgeleiteter Input auch auf Screen sichtbar  }

  PROCEDURE ProtOut;
    { Schaltet Protokollierung für
      Read(ln)/Write(ln)/ReadKey aus }
  PROCEDURE ProtOn;
    { Schaltet Protokollierung für
      Read(ln)/Write(ln)/ReadKey wieder ein}

IMPLEMENTATION

USES Crt, Dos;

TYPE
  StdDateien       = (InputD,OutPutD,ErrorD,AuxD,PrnD);
  LHTTYP           = ARRAY [0..$FF] OF BYTE;
  LHtPtr           = ^LHTTyp;

  TreiberFunc      =
{$IFNDEF VER40}
    FUNCTION (VAR F : TextRec) : INTEGER;
{$ELSE}
    Pointer;
{$ENDIF}

CONST
  StdHandles       : ARRAY[0..4] OF BYTE = (1,1,1,0,2);
  PufferSize       = 1024;
  EoFile           = #26;

  InDelay          : WORD    = 100;
  PufferPos        : WORD    =   0;
  ActPufferSize    : WORD    =   0;

  ReadKeyReDir     : BOOLEAN = FALSE;
  ReFilled         : BOOLEAN = FALSE;
  OutSight         : BOOLEAN = TRUE;
  InSight          : BOOLEAN = TRUE;
  ActModus         : InOutModus = NoRedirection;
  Prot             : BOOLEAN = TRUE;

VAR
  OldCrtIn,
  OldCrtInFlush,
  OldCrtOut,
  OldCrtOutFlush,
  OldSystemOut,
  OldSystemFlush,
  OldSystemIn,
  OldSystemInFlush : TreiberFunc;

  Puffer           : ARRAY [1..PufferSize] OF CHAR;
  LHTAdr           : LHTPtr;
  Regs             : Registers;


  FUNCTION GetLHTAdr : LHTPtr;
    { Liefert die Start-Adresse
      der L(ocal)H(andle)T(abelle) }
  BEGIN
    GetLHTAdr := LHTPtr(Ptr(MemW[PrefixSeg:$36],
                            MemW[PrefixSeg:$34]));
  END;

  FUNCTION IsUmgeleitet(Datei : StdDateien) : BOOLEAN;
  BEGIN
    IsUmgeleitet := LHTAdr^[Ord(Datei)] <>
                    StdHandles[Ord(Datei)];
  END;

  FUNCTION DosOutputRedirected : BOOLEAN;
  BEGIN
    DosOutputRedirected := IsUmgeleitet(OutputD);
  END;

  FUNCTION DosInputRedirected : BOOLEAN;
  BEGIN
    DosInputRedirected := IsUmgeleitet(InputD);
  END;

{$IFDEF Ver40 }
  FUNCTION CallCrtOutFunc(VAR TR : TextRec) : INTEGER;
  INLINE($FF/$1E/OldCrtOut );   { Call Far }

  FUNCTION CallSystemOutFunc(VAR TR: TextRec): INTEGER;
  INLINE($FF/$1E/OldSystemOut );   { Call Far }

  FUNCTION CallCrtInFunc(VAR TR : TextRec) : INTEGER;
  INLINE($FF/$1E/OldCrtIn );   { Call Far }
{$ENDIF }

  PROCEDURE GetInOutAdr;
    { Diese Prozedur holt sämtliche für die Unit
      wichtigen Adressen der TextRec-Routinen }
  BEGIN
    AssignCrt(Input);
      { Auf jeden Fall Crt-Routinen initialisieren }
    RESET(Input);
    WITH TextRec(Input) DO BEGIN
      OldCrtIn      := TreiberFunc(InOutFunc);
      OldCrtInFlush := TreiberFunc(FlushFunc);
    END;
    Assign(Input,'');
      { Auf System-Routinen umschalten }
    RESET(Input);
    WITH TextRec(Input) DO BEGIN
      OldSystemIn      := TreiberFunc(InOutFunc);
      OldSystemInFlush := TreiberFunc(FlushFunc);
    END;
    AssignCrt(Input);          { Input wieder via CRT }
    Reset(Input);
    AssignCrt(Output);      { Output via CRT-Routinen }
    Rewrite(Output);
    WITH TextRec(Output) DO BEGIN
      OldCrtOut      := TreiberFunc(InOutFunc);
      OldCrtOutFlush := TreiberFunc(FlushFunc);
    END;
    Assign(Output,'');   { Output via System-Routinen }
    Rewrite(Output);
    WITH TextRec(Output) DO BEGIN
      OldSystemOut      := TreiberFunc(InOutFunc);
      OldSystemFlush    := TreiberFunc(FlushFunc);
    END;
    AssignCrt(Output);
                     { Output wieder via CRT-Routinen }
    Rewrite(Output);
  END;

  PROCEDURE WriteOutPut(Puffer : Pointer; Size : WORD);
    { Schreibt Size Zeichen aus dem
      Puffer in Standard-OutPut }
  BEGIN
    WITH Regs DO BEGIN
      AH := $40;
      BX := Ord(OutPutD);         { Handle ! }
      CX := Size;
      DS := Seg(Puffer^);
      DX := Ofs(Puffer^);
      MsDos(Regs);
      IF (Odd(Flags AND fCarry)) OR (AX = 0) THEN BEGIN
        AssignCrt(Output);
        Rewrite(Output);
        WriteLn('Fehler bei Zeichenausgabe ',
                'auf OUTPUT',^G);
        WriteLn('Programmabbruch !!!');
        Writeln('Fehler : ', AX);
        Halt;
      END;
    END;
  END;

  PROCEDURE FillInputBuffer;
    { Füllt den EingabePuffer mit Zeichen
      aus der Standard-Eingabe }
    { Wenn keine Zeichen mehr in Standard-Eingabe,
      dann EOFINPUT := TRUE }
  BEGIN
    WITH Regs DO BEGIN
      AH := $3F;
      BX := Ord(InputD);            { Handle ! }
      CX := PufferSize;
      DS := Seg(Puffer);
      DX := Ofs(Puffer);
      MsDos(Regs);
      IF Odd(Flags AND fCarry) THEN BEGIN
        WriteLn('Fehler bei Zeicheneinlesen ',
                'über Standardeingabe.', ^G);
        WriteLn('Programmabbruch !!!');
        WriteLn('Fehler : ', AX);
        Halt;
      END;
      ActPufferSize := AX;
                        { Aktuelle Puffergröße merken }
      EoFInput := (ActPufferSize = 0);
    END;
  END;

  FUNCTION DosReadC : CHAR;
    { Liest ein Zeichen aus dem Eingabepuffer aus }
  VAR
    C : CHAR;
  BEGIN
    IF PufferPos = 0 THEN BEGIN
                              { Nur bei Programmstart }
      FillInputBuffer;
      PufferPos := 1;
    END;
    IF NOT EOFInPut THEN BEGIN
      C  := Puffer[PufferPos];   { Zeichen holen }
      IF (Succ(PufferPos) <= PufferSize) AND
         (Puffer[Succ(PufferPos)] = EoFile) THEN
        EoFInput := TRUE;
    END;
    IF PufferPos < ActPufferSize THEN
      Inc(PufferPos)
    ELSE BEGIN
      FillInputBuffer;
      { Wenn Puffer geleert, dann versuchen,
        Puffer neu zu füllen }
      PufferPos := 1;
    END;
    IF Not(c IN [#10,#13]) THEN
      Delay(Abs(InDelay-(InDelay MOD 10) *
            Random(InDelay MOD 20)) MOD 1000);
      { Maximale Simulationsverzögerung 1000 mSec }
    DosReadC := C;
  END;

  PROCEDURE GetString(VAR S : STRING);
    { Holt eine String aus dem InputPuffer }
  VAR
    Ch : CHAR;
  BEGIN
    S := '';
    EoFLine := FALSE;
    IF EoFInput THEN Exit;
    WHILE NOT EoFInput AND
          NOT EoFLine DO BEGIN
                 { Einlesen, bis CRLF oder File-Ende }
      Ch := DosReadC;
      S  := S + Ch;
      IF InSight THEN Write(Ch);
        { Bei "Sichtbarkeitsmodus" Zeichen schreiben }
      IF Ch = #10 THEN EoFLine := TRUE;
    END;
  END;

{$F+ }
  FUNCTION NewOut(VAR F : TextRec) : INTEGER;
    { Neue Output-Routine für Textausgaben }
  VAR
    Result   : INTEGER;
    F2       : TextRec;
  BEGIN
    F2 := F;
{$IFNDEF VER40 }
      { Alte Screen-OutPutroutine aufrufen }
    IF OutSight THEN Result := OldCrtOut(F)
                ELSE Result := 0;
    IF (Result = 0) AND Prot THEN
      Result := OldSystemOut(F2);
{$ELSE }
      { .. und dasselbe für Turbo Version 4.0 }
    IF OutSight THEN Result := CallCrtOutFunc(F)
                ELSE Result := 0;
    IF (Result = 0) AND Prot THEN
      Result := CallSystemOutFunc(F2);
{$ENDIF }
    NewOut := Result;
  END;

  FUNCTION NewIn(VAR F : TextRec) : INTEGER;
    { Neue Inputroutine für Texteingaben }
  VAR
    i               : Word;
    s               : String;
  BEGIN
    WITH F DO BEGIN
      GetString(s);  { String aus Inputpuffer holen.. }
                     {... und in F einbauen           }
      FOR i := 1 TO Length(s) DO
        BufPtr^[Pred(i)] := s[i];
      IF Length(s) > 0 THEN BufEnd := Succ(Length(s))
                       ELSE BufEnd := 0;
                                  { Pufferende setzen }
      BufPos := 0;
    END;
    NewIn := 0;
  END;

  FUNCTION NewInFlush(VAR F : TextRec) : INTEGER;
    { Neue InputFlushroutine für Texteingaben }
  BEGIN
    WITH F DO BEGIN
      BufPos := 0;
      BufEnd := 0;
    END;
    NewInFlush := 0;
  END;

  FUNCTION NewInOut(VAR F : TextRec) : INTEGER;
    { Neue Inputroutine für Output-Umleitung }
  VAR
    Result : INTEGER;
  BEGIN
    WITH F DO BEGIN
{$IfNDEF VER40 }
      Result := OldCrtIn(F);
        { Eingabe mit alter Routine holen..}
{$ELSE }
      Result := CallCrtInFunc(F);
{$ENDIF }
      IF (Result = 0) AND Prot THEN
        WriteOutPut(BufPtr, BufEnd);
                                {..und protokollieren }
    END;
    NewInOut := Result;
  END;
{$F- }

  PROCEDURE AssignNewInput;
    { Neue Routinen zur Eingabeumleitung auf die
      entsprechenden Zeiger setzen }
  BEGIN
    Reset(Input);
    WITH TextRec(Input) DO BEGIN
      InOutFunc := @NewIn;
      FlushFunc := @NewInFlush;
    END;
  END;

  PROCEDURE AssignNewOutPut;
    { Neue Routinen zur Ausgabeumleitung auf die
      entsprechenden Zeiger setzen }
  BEGIN
    Rewrite(Output);
    WITH TextRec(Output) DO BEGIN
      InOutFunc := @NewOut;
      FlushFunc := @NewOut;
    END;
  END;

  PROCEDURE AssignOldOutPut;
    { CRT-Ausgaberoutinen setzen }
  BEGIN
    Rewrite(Output);
    WITH TextRec(Output) DO BEGIN
      InOutFunc := @OldCrtOut;
      FlushFunc := @OldCrtOutFlush;
    END;
  END;

  PROCEDURE AssignOldInPut;
    { CRT-Eingaberoutinen setzen }
  BEGIN
    Reset(Input);
    WITH TextRec(InPut) DO BEGIN
      InOutFunc := @OldCrtIn;
      FlushFunc := @OldCrtInFlush;
    END;
  END;

  PROCEDURE AssignProtInPut;
    { Neue Eingaberoutinen für Outputumleitung setzen }
  BEGIN
    Reset(Input);
    WITH TextRec(InPut) DO BEGIN
      InOutFunc := @NewInOut;
      FlushFunc := @OldCrtInFlush;
    END;
  END;

  PROCEDURE AssignAllProt;
    { Neue Routinen für Umleitung des gesamten
      Screen-Outputs setzen }
  BEGIN
    AssignProtInput;
    AssignNewOutPut;
  END;

  FUNCTION GetInOutModus : InOutModus;
  BEGIN
    GetInOutModus := ActModus;
  END;

  PROCEDURE ChangeInOutModus(Mode : InOutModus);
  BEGIN
    CASE Mode OF
      NoRedirection       :
        BEGIN
          AssignOldInput; AssignOldOutPut;
        END;
      InputRedirection    :
        BEGIN
          AssignNewInput; SetReadKeyMode(TRUE);
        END;
      OutPutRedirection   : AssignNewOutPut;
      ProtRedirection     :
        BEGIN
          AssignProtInput;
        END;
      OutPutRedirection   : AssignNewOutPut;
      AllScreenRedirection: AssignAllProt;
    END;
    ActModus := Mode;
    Prot     := TRUE;
  END;

  FUNCTION ReadC : CHAR;
  VAR
    C : CHAR;
  BEGIN
    C := Crt.ReadKey;
    IF (ActModus IN
        [ProtRedirection, AllScreenRedirection]) AND
        Prot THEN
      WriteOutPut(@C, 1);
    ReadC := C;
  END;

  FUNCTION ReadKey : CHAR;
  BEGIN
    IF (ActModus IN [InputRedirection]) AND
        ReadKeyReDir THEN
      ReadKey := DosReadC
    ELSE
      ReadKey := ReadC;
  END;

  FUNCTION KeyPressed : BOOLEAN;
  BEGIN
    IF (ActModus = InputRedirection) AND
        ReadKeyReDir THEN
      KeyPressed  := NOT EoFInput
    ELSE
      KeyPressed  := Crt.KeyPressed;
  END;

  PROCEDURE SetInputDelay(Sec1000 : WORD);
  BEGIN
    InDelay := Sec1000;
  END;

  PROCEDURE SetReadKeyMode(Redirected : BOOLEAN);
  BEGIN
    ReadKeyRedir := Redirected;
  END;

  FUNCTION GetReadKeyMode : BOOLEAN;
  BEGIN
    GetReadKeyMode := ReadKeyRedir;
  END;

  FUNCTION OutPutSightAble : BOOLEAN;
  BEGIN
    OutPutSightable := OutSight;
  END;

  PROCEDURE ChangeSightAbleMode(Sight : BOOLEAN);
  BEGIN
    OutSight := Sight;
  END;

  FUNCTION InPutSightAble : BOOLEAN;
  BEGIN
    InPutSightable := InSight;
  END;

  PROCEDURE InSightOnOff(Sight : BOOLEAN);
  BEGIN
    InSight := Sight;
  END;

  FUNCTION DosVersionsNr : WORD;
  BEGIN
    WITH Regs DO BEGIN
      AH   := $30;
      MsDos(Regs);
      IF AL = 0 THEN DosVersionsNr := 1
                ELSE DosVersionsNr := AL;
    END;
  END;

  PROCEDURE ProtOut;
  BEGIN
    Prot := FALSE;
  END;

  PROCEDURE ProtON;
  BEGIN
    PROT := TRUE;
  END;

BEGIN
  IF DosversionsNr < 2 THEN BEGIN
    WriteLn('Falsche DOS-Version !!!');
    WriteLn('Programm ', ParamStr(0),
            ' läuft erst ab DOS-Version 2.0');
    WriteLn('Programmabbruch !!!',^G^G);
    Halt;
  END;
  Randomize;
  GetInOutAdr;
  LHTAdr := GetLHTAdr;
END.
(* ------------------------------------------------- *)
(*             Ende von HRDOSUM.PAS                  *)