home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / c / qk3sys.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  12KB  |  288 lines
  1. Unit Sysfunc ;
  2. (* ================================================================= *)
  3. (*  MsDos SYSTEM  dependent Routines for Kermit .                    *)
  4. (* ================================================================= *)
  5. Interface
  6.     Uses Dos,Crt,Graph,     (* Standard Turbo Pascal Units *)
  7.     KGlobals,modempro ;
  8. TYPE
  9.     ScreenArray = array [0..3999] of byte ;
  10. Var
  11.     RealScreen      : ^ScreenArray ;
  12.     GraphDriver,Graphmode : integer ;
  13.     margintop,marginbot : byte ;
  14. (* Functions & Procedures *)
  15.     Function KeyChar (var Achar,Bchar : byte): boolean ;
  16.     Procedure CursorUp ;
  17.     Procedure CursorDown ;
  18.     Procedure CursorRight ;
  19.     Procedure CursorLeft ;
  20.     Procedure Scroll(updown,top,bottom:byte);
  21.     Procedure FatCursor(flag :boolean);
  22.     Procedure RemoteScreen ;
  23.     Procedure LocalScreen ;
  24.     Procedure SetDefaultDrive (Drive : Byte);
  25.     Function DefaultDrive : Byte ;
  26.  
  27. (* ================================================================= *)
  28. Implementation
  29. CONST
  30.     (* FLAGS in flag register *)
  31.     Cflag = $0001 ;
  32.     Pflag = $0004 ;
  33.     Aflag = $0010 ;
  34.     Zflag = $0040 ;
  35.     Tflag = $0100 ;
  36.     Iflag = $0200 ;
  37.     Dflag = $0400 ;
  38.     Oflag = $0800 ;
  39.  
  40. VAR
  41.     RemSaveX,RemSaveY,LocSaveX,LocSaveY : integer ;
  42.     SaveLocalScreen  : ^ScreenArray  ;
  43.     SaveRemoteScreen : ^ScreenArray  ;
  44.     register  : registers ;
  45.     NumLock,ScrollLock : byte ;
  46.     Mono : boolean ;
  47.     i : integer ;
  48. (* ------------------------------------------------------------------ *)
  49. (* KeyChar - get a character from the Keyboard.                       *)
  50. (*           It returns TRUE if character found and the char is       *)
  51. (*           returned in the parameter.                               *)
  52. (*           It returns FALSE if no keyboard character.               *)
  53. (*                                                                    *)
  54. (* ------------------------------------------------------------------ *)
  55.     Function KeyChar (var Achar,Bchar : byte): boolean ;
  56.     Begin (* KeyChar *)
  57.     with register do
  58.            begin
  59.            ah := 1;
  60.            intr($16,register);
  61.            if (Zflag and flags)=Zflag then
  62.  
  63. (* ------ The following code is required only if we want to us the ----- *)
  64. (* ------ NUMLOCK and SCROLLLOCK key as function keys  ----------------- *)
  65.               begin (* check for Numlck and Scroll Lck *)
  66.               ah := 2;
  67.               intr($16,register);
  68.               If  (al and $10) <> ScrollLock then
  69.                    Case (al and $0F) of
  70.                    0:     Bchar := $46 ; (* not shifted *)
  71.                    1,2,3: Bchar := $86 ; (* shifted *)
  72.                    4,5,6,7: Bchar := $87 ; (* control *)
  73.                    else Bchar := $87 ; (* Alt *)
  74.                    end  (* case *)
  75.                                             else
  76.               If  (al and $20) <> NumLock then
  77.                    Case (al and $0F) of
  78.                     0:     Bchar := $45 ; (* not shifted *)
  79.                     1,2,3: Bchar := $85 ; (* shifted *)
  80.                     4,5,6,7: Bchar := $88 ; (* control *) (* Not Available *)
  81.                     Else Bchar := $88 ; (* Alt *)
  82.                    End (* case *)
  83.                                              else Bchar := 0 ;
  84.               ScrollLock := (al and $10) ;
  85.               NumLock := (al and $20) ;
  86.               Achar := 0 ;
  87.               If Bchar <> 0 then   KeyChar := true
  88.                             else   KeyChar := false
  89.               End   (* check for Numlck and Scroll Lck *)
  90. (*------ If you don't need this code, replace it with ------------------ *)
  91. (* --------   KeyChar := False ----------------------------------------- *)
  92.                                      else
  93.               begin
  94.               ah := 0;
  95.               intr($16,register);
  96.               Achar := al ;
  97.               Bchar := ah ;
  98.               KeyChar := true;
  99.               end ;
  100.            end;
  101.     End ; (* KeyChar *)
  102.  
  103. (* ------------------------------------------------------------------ *)
  104. (* CursorUp -                                                         *)
  105. (* ------------------------------------------------------------------ *)
  106.     Procedure CursorUp ;
  107.     Begin (* CursorUp *)
  108.     If margintop <> WhereY then GotoXY(WhereX,WhereY-1);
  109.     End;  (* CursorUp *)
  110.  
  111. (* ------------------------------------------------------------------ *)
  112. (* CursorDown -                                                       *)
  113. (* ------------------------------------------------------------------ *)
  114.     Procedure CursorDown ;
  115.     Begin (* CursorDown *)
  116.     If marginbot <> WhereY then GotoXY(WhereX,WhereY+1);
  117.     End;  (* CursorDown *)
  118.  
  119. (* ------------------------------------------------------------------ *)
  120. (* CursorRight -                                                      *)
  121. (* ------------------------------------------------------------------ *)
  122.     Procedure CursorRight ;
  123.     Begin (* CursorRight *)
  124.     GotoXY(WhereX+1,WhereY);
  125.     End;  (* CursorRight *)
  126.  
  127. (* ------------------------------------------------------------------ *)
  128. (* CursorLeft -                                                       *)
  129. (* ------------------------------------------------------------------ *)
  130.     Procedure CursorLeft ;
  131.     Begin (* CursorLeft *)
  132.     GotoXY(WhereX-1,WhereY);
  133.     End;  (* CursorLeft *)
  134. (* ------------------------------------------------------------------ *)
  135. (* Scroll - Scrolls a section of screen up or down.                   *)
  136. (* ------------------------------------------------------------------ *)
  137.     Procedure Scroll(updown,top,bottom:byte);
  138.     Begin (* Scroll  *)
  139.     With register do
  140.          begin (* Scroll up *)
  141.          ch := top  ;   cl := 0 ;      (*   top right hand corner *)
  142.          dh := bottom ; dl := 79 ;     (* bottom left hand corner *)
  143.          bh := $07 ;                   (* blank line attribute *)
  144.          al := 1 ;                     (* number of line to scroll *)
  145.          ah := updown ;  (* Function code 6 - Scroll up   *)
  146.                          (* Function code 7 - Scroll down *)
  147.          intr($10,register);
  148.          end (* Scroll *)
  149.     End;  (* Scroll *)
  150.  
  151. (* ------------------------------------------------------------------ *)
  152. (* FatCursor -                                                       *)
  153. (* ------------------------------------------------------------------ *)
  154.     Procedure FatCursor(flag :boolean);
  155.     Begin (* FatCursor *)
  156.     With register do
  157.          begin (* Cursor size *)
  158.          if Mono then cl := 12
  159.                  else cl := 7 ;
  160.          if flag then ch := 1
  161.                  else if Mono then ch := 11
  162.                               else ch := 6 ;
  163.          ah := 1;  (* Function code 1 - Select cursor type  *)
  164.          intr($10,register);
  165.          end ; (* Cursor size *)
  166.     End;  (* FatCursor *)
  167.  
  168. (* ------------------------------------------------------------------ *)
  169. (* RemoteScreen - Procedure                                           *)
  170. (*                This procedure save the local screen and restores   *)
  171. (*                the remote screen.                                  *)
  172. (*                Also setup the 25th line to display settings        *)
  173. (* ------------------------------------------------------------------ *)
  174.     Procedure RemoteScreen ;
  175.     var i : integer ;
  176.     Begin (* RemoteScreen *)
  177.     LocSaveX := whereX ; LocSaveY := whereY ;  (* Save local cursor *)
  178.     SaveLocalScreen^ := RealScreen^ ;   (* Save local Screen *)
  179.     RealScreen^ := SaveRemoteScreen^ ;   (* Switch Screens *)
  180.     if Line25Flag then
  181.          begin  (* ---- set up 25th line with status ------ *)
  182.          GotoXY(1,25);
  183.          If Mono then
  184.               Begin Textcolor(Black) ; Textbackground(White); end
  185.                  else
  186.               Begin Textcolor(Blue); Textbackground(Yellow); end ;
  187.          Write  (' Port ');
  188.          If PrimaryPort then Write('One : ')
  189.                         else Write('Two : ');
  190.          Write(Baudrate,' baud, ');
  191.          Case paritytype(parity) of
  192.              OddP : write('Odd  ');
  193.              EvenP: write('Even ');
  194.              MarkP: write('Mark ');
  195.              NoneP: write('None ');
  196.          end ; (* parity case *)
  197.          Write('parity, ');
  198.          If LocalEcho then Write('Half duplex, ')
  199.                       else Write('Full duplex, ');
  200.          If XonXoff then write('IBM-Xon  ')
  201.                     else if NoEcho then write('NoEcho   ')
  202.                                    else write('Standard ');
  203.          Write  ('    ExitChar=CTL ',chr($5C),'   ' ) ;
  204.          Textcolor(LightGray); Textbackground(0);
  205.          end   (* ---- set up 25th line with status ------ *)
  206.                  else
  207.          begin (* clear 25th line *)
  208.          Textcolor(White) ;  Textbackground(0) ;
  209.          GotoXY(1,25);
  210.          write(' ':79);
  211.          End ;  (* clear 25th line *)
  212.          (* -------------------------------------------- *)
  213.     Window(1,1,80,24);
  214.     GotoXY(RemSaveX,RemSaveY);
  215.     End;  (* RemoteScreen *)
  216.  
  217. (* ------------------------------------------------------------------ *)
  218. (* LocalScreen  - Procedure                                           *)
  219. (*                This procedure save the remote screen and restores  *)
  220. (*                the local  screen.                                  *)
  221. (* ------------------------------------------------------------------ *)
  222.     Procedure LocalScreen ;
  223.     Begin (* LocalScreen *)
  224.     RemSaveX := whereX ; RemSaveY := whereY ;  (* Save Remote Cursor *)
  225.     SaveRemoteScreen^ := RealScreen^ ;   (* Save Remote Screen *)
  226.     RealScreen^ := SaveLocalScreen^ ;    (* Restore Local Screen *)
  227.     TextColor(Yellow); TextBackground(Black);
  228.     Window(1,1,80,25);
  229.     GotoXY(LocSaveX,LocSaveY);
  230.     End;  (* LocalScreen *)
  231. (* ------------------------------------------------------------------ *)
  232. (* SetDefaultDrive -                                                  *)
  233. (* ------------------------------------------------------------------ *)
  234.     Procedure SetDefaultDrive (Drive : Byte);
  235.     Begin (* SetDefaultDrive *)
  236.     With register do
  237.          begin (* Select disk *)
  238.          DL := Drive ;
  239.          Ax := $0E00 ;      { Select default drive }
  240.          MsDos(Register);
  241.          end; (* Select disk *)
  242.     End;  (* SetDefaultDrive *)
  243.  
  244. (* ------------------------------------------------------------------ *)
  245. (* DefaultDrive - returns the value of the default drive              *)
  246. (*                 A=0,B=1,C=2 etc.                                   *)
  247. (* ------------------------------------------------------------------ *)
  248.     Function DefaultDrive : Byte ;
  249.     Begin (* DefaultDrive *)
  250.     With register do
  251.          begin (* Current disk *)
  252.          Ax := $1900 ;      { Find default drive }
  253.          MsDos(Register);
  254.          DefaultDrive := al ;
  255.          end; (* Current disk *)
  256.     End;  (* DefaultDrive *)
  257. (* ----------------------------------------------------------------- *)
  258. Begin (* Sysfunc Unit *)
  259. new(SaveRemoteScreen);
  260. new(SaveLocalScreen) ;
  261. RemSaveX := 1 ;
  262. RemSaveY := 1 ;
  263. For i:= 0 to 1999 do
  264.     Begin (* Clear out SaveRemoteScreen *)
  265.     SaveRemoteScreen^[i*2] := $20 ; (* Blank Character *)
  266.     SaveRemoteScreen^[i*2+1] := $07 ; (* light Gray on Black *)
  267.     End ;(* Clear out SaveRemoteScreen *)
  268. DetectGraph(GraphDriver,GraphMode);
  269.    Case GraphDriver of
  270.      CGA : RealScreen := PTR($B800,0000);
  271.     MCGA : RealScreen := PTR($B800,0000);
  272.      EGA : RealScreen := PTR($B800,0000);
  273.    EGA64 : RealScreen := PTR($B800,0000);
  274.   EGAMono: RealScreen := PTR($B800,0000);
  275. HercMono : RealScreen := PTR($B000,0000);
  276.   ATT400 : RealScreen := PTR($B800,0000);
  277.      VGA : RealScreen := PTR($B800,0000);
  278.   PC3270 : RealScreen := PTR($B800,0000);
  279.   else     RealScreen := PTR($B000,0000);
  280.     End ; (* case *)
  281.  
  282.  Mono := (GraphDriver=HercMono) or
  283.          (GraphDriver=EGAMono) or
  284.          (RealScreen =PTR($B000,0000)) ;
  285.  
  286. End. (* Sysfunc Unit *)
  287.  
  288.