home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 14 / tools / loop.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-10  |  7.2 KB  |  194 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      LOOP.PAS                          *)
  3. (*  Abbruch von Endlos-Schleifen mit einem Turbo Pascal   *)
  4. (*  unter Verwendung der Unit TSR.PAS aus PASCAL 5/1988   *)
  5. (*          (c) 1989 Waldemar Zylka & TOOLBOX             *)
  6. (* ------------------------------------------------------ *)
  7. PROGRAM LOOP;
  8.  
  9. {$R-,S-,V-,B-,I-,N-}         (* damit alles schneller ist *)
  10. {$M 1024,1,1}                (* Minimum Stack und Heap    *)
  11.  
  12. USES  Tsr, Crt, Dos;
  13.  
  14. CONST HotKey      = $6200;         (*  HotKey :   Ctrl-F5 *)
  15.       HotTaste    = 'Ctrl-F5';
  16.       Name        = 'Loop  v1.0';
  17.       Aktivierung = ' aktivieren.';
  18.       Meldung0    = ' bereits geladen, bitte mit ';
  19. VAR   Regs        : Registers;
  20.  
  21. {$F+}                  (* Tsr wird benutzt: FAR Codierung *)
  22.  
  23. TYPE  StatusZeile  = ARRAY [0..79] OF WORD;
  24.       ScreenInhalt = ARRAY [0..79] OF WORD;
  25.  
  26. CONST LoopInit : BOOLEAN = FALSE;
  27.       MonoScreen = $B000;   ColorScreen = $B800;
  28.       ColorStatBold : BYTE    = Yellow;
  29.       ColorStatNorm : BYTE    = LightCyan;
  30.       ColorStatBack : BYTE    = blue;
  31.       BoldBegin               = '';
  32.       BoldEnd                 = '';
  33.       Meldung1 = '  Programm abbrechen ? (J/N) ';
  34.       Meldung2 =
  35.             '  Programmabbruch nicht möglich, da DOS aktiv';
  36. VAR   DosByteOff,
  37.       DosByteSeg    : WORD;
  38.       Keller        : ^StatusZeile;
  39.       Screen        : ^ScreenInhalt;
  40.       ScreenMode    : BYTE ABSOLUTE  $0040:$0049;
  41.       VideoBuffer   : WORD;
  42.  
  43. (* ------------------------------------------------------ *)
  44. (*  Diese Prozedur der Tsr-Unit hinzufügen;               *)
  45. (*  den Prozedurkopf in den Interface-Teil eintragen.     *)
  46. (*  Zusätzlich muß die Prozedur SwitchStack - bisher eine *)
  47. (*  Unterprozedur von Int16_ - verschoben werden, damit   *)
  48. (*  sie von SwitchBackDos genutzt werden kann.            *)
  49. (* ------------------------------------------------------ *)
  50. { !!!!
  51. PROCEDURE SwitchBackDos;
  52.                  (* bricht das aktuelle Programm ab, dies *)
  53. BEGIN            (* ist etwa bei unendlichen Schleifen gut*)
  54.   SetIntVec($16, CurrInt16);
  55.   SwitchBack;            (* aus der alten Int16_ Prozedur *)
  56.   Regs.AX := $4CC8;                     (* ExitCode = 200 *)
  57.   Msdos(Regs);
  58. END;
  59. !!!! }
  60.  
  61. (* ------------------------------------------------------ *)
  62. PROCEDURE InitLoop;
  63.                    (* Bildschirmtyp und Adresse ermitteln *)
  64. BEGIN
  65.   IF ScreenMode = Mono THEN VideoBuffer := MonoScreen
  66.                        ELSE VideoBuffer := ColorScreen;
  67.   Screen   := Ptr(VideoBuffer, $0000);
  68.   LoopInit := TRUE;
  69. END;
  70.  
  71. (* ------------------------------------------------------ *)
  72. PROCEDURE WriteCharVideo(x, y : BYTE; Zeichen : CHAR;
  73.                                       Attr    : BYTE);
  74. (* Schreibt Zeichen mit Attr direkt an der Position (x,y) *)
  75. (* in den Bildschirm                                      *)
  76. VAR Offset : INTEGER;
  77. BEGIN
  78.   Offset := Pred(x) SHL 1 + Pred(y)*160;
  79.   MemW[VideoBuffer:Offset]       := Ord(Zeichen) ;
  80.   MemW[VideoBuffer:Succ(Offset)] := Attr ;
  81. END;
  82.  
  83. (* ------------------------------------------------------ *)
  84. PROCEDURE RefZeile(StatusLine : STRING);
  85.       (* Referenzzeile schreiben, oberste Bildschirmzeile *)
  86. VAR  UrAttr, j, i : BYTE;
  87. BEGIN
  88.   IF NOT LoopInit THEN InitLoop;
  89.   New(Keller);
  90.   Move(Screen^[0], Keller^, SizeOf(Keller^));
  91.   UrAttr := TextAttr;
  92.                              (* Turbos TextAttr speichern *)
  93.   TextColor(ColorStatNorm);
  94.                              (* Turbos TextAttr verändern *)
  95.   TextBackground(ColorStatBack);
  96.   FOR i := 1 TO 79 DO WriteCharVideo(i, 1, ' ', TextAttr);
  97.                              (* Untergrund                *)
  98.   j := 1;
  99.   FOR i := 1 TO BYTE(StatusLine[0]) DO BEGIN
  100.     IF (StatusLine[i] = BoldBegin) THEN BEGIN
  101.                              (* BoldZeichen liegt vor     *)
  102.       TextColor(ColorStatBold);
  103.       Inc(i);                (* Turbos TextAttr verändern *)
  104.     END;
  105.     IF (StatusLine[i] = BoldEnd) THEN BEGIN
  106.                              (* BoldModus Ende-Zeichen    *)
  107.       TextColor(ColorStatNorm);
  108.       Inc(i);                (* Turbos TextAttr verändern *)
  109.     END;
  110.     WriteCharVideo(j, 1, StatusLine[i], TextAttr);
  111.                              (* Text schreiben            *)
  112.     Inc(j);
  113.   END;
  114.   TextAttr := UrAttr;     (* Turbos TextAttr restaurieren *)
  115. END;
  116.  
  117. (* ------------------------------------------------------ *)
  118. PROCEDURE RmRefZeile;(* Referenzzeile verschwinden lassen *)
  119. BEGIN
  120.   Move(Keller^, Screen^[0], SizeOf(Keller^));
  121.   Dispose(Keller);
  122. END;
  123.  
  124. (* ------------------------------------------------------ *)
  125. PROCEDURE EndlosLoop;
  126.          (* Abbruch von laufenden Programmen, EndlosLoops *)
  127. VAR  k  : CHAR;
  128.          (* Wird als residente Routine installiert        *)
  129. BEGIN
  130.   IF (Mem[DosByteOff:DosByteSeg] = 0) THEN BEGIN
  131.                                   (* DOS ist nicht aktiv  *)
  132.     RefZeile(Meldung1);           (* also melden wir uns  *)
  133.     REPEAT
  134.       IF KeyPressed THEN          (* und fragen höflich:  *)
  135.       k := ReadKey;               (* "Abbruch ?"          *)
  136.     UNTIL ((UpCase(k) = 'J') OR (UpCase(k) = 'N'));
  137.     IF (UpCase(k) = 'J') THEN BEGIN    (* Also abbrechen  *)
  138.       RmRefZeile;
  139.       SwitchBackDos;     (* Stack umschalten, dann zurück *)
  140.     END ELSE RmRefZeile;
  141.   END ELSE BEGIN           (* DOS ist gerade noch aktiv   *)
  142.     RefZeile(Meldung2);    (* also teilen wir es mit .... *)
  143.     Delay(2000);           (* ... warten etwas und        *)
  144.     RmRefZeile;            (* machen alles rückgängig.    *)
  145.   END;
  146. END;
  147.  
  148. {$F-}                                  (* Ende FAR Modell *)
  149.  
  150. (* ------------------------------------------------------ *)
  151.  
  152. FUNCTION LoopInstall : BOOLEAN;
  153.                   (* Loop bereits installiert ?           *)
  154.                   (* Schützt vor mehrmaliger Installation *)
  155. VAR Jahr, Monat, Tag, WochTag  : WORD;
  156. BEGIN
  157.   GetDate(Jahr, Monat, Tag, WochTag);
  158.   Write(^M^J, Name);
  159.   IF (MemW[0:$3FA] = Tag) AND
  160.      (MemW[0:$3FE] = Jahr) THEN BEGIN      (* Check Marke *)
  161.     Sound(300); WriteLn(Meldung0 + HotTaste + Aktivierung);
  162.     Delay(200); NoSound;
  163.     Halt(255);                            (* ExitCode 255 *)
  164.     LoopInstall := TRUE;
  165.     Exit;
  166.   END ELSE BEGIN
  167.     MemW[0:$3FA] := Tag;
  168.              (* InstallationsMarke schreiben ins Intr $FF *)
  169.     MemW[0:$3FE] := Jahr;
  170.     DirectVideo  := TRUE;
  171.     CheckSnow    := FALSE;       (* siehe Handbuch, S.125 *)
  172.     WriteLn(' installiert, bitte mit ',
  173.             HotTaste, ' aktivieren.');
  174.     LoopInstall  := FALSE;
  175.   END;
  176. END;
  177.  
  178. BEGIN                                    (* Hauptprogramm *)
  179.   IF (NOT LoopInstall) THEN BEGIN
  180.     Regs.ax := $3400;
  181.          (* DOS Flag (Anzahl aktiver Dos Funktionen) über *)
  182.     MsDos(Regs);
  183.          (* undokumentierte Funktion 34H Intr21 abfragen: *)
  184.     DosByteOff := Regs.bx;
  185.          (* mem[DosByteSeg:DosByteOff] = 0 Aufruf möglich *)
  186.     DosByteSeg := Regs.es;
  187.          (* mem[....:....] <> 0 Dos Funktion aktiv, Auf-  *)
  188.          (* ruf führt zum Systemcrash                     *)
  189.     MakeResident(@EndlosLoop, HotKey);
  190.   END;
  191. END.
  192. (* ------------------------------------------------------ *)
  193. (*                   Ende von LOOP.PAS                    *)
  194.