home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / TPKERMIT / CONNECT.PAS next >
Pascal/Delphi Source File  |  1987-03-25  |  15KB  |  329 lines
  1. (* +FILE+ CONNECT.PASVT100 *)
  2. (* ================================================================== *)
  3. (*  Global Var and Procedures for special key specifications.         *)
  4. (* ================================================================== *)
  5. Const
  6.      Gversion = '  ' ;
  7.      TermType = ' VT100  ' ;
  8.      graph = '- Not applicable         ' ;
  9.  
  10. Var
  11.      EscSeq : Array [1..$88,1..2] of char ;
  12.      KeyTableName : String[14] ;
  13.      KeyTable : Text ;
  14. (*------------------------------------------------------------------- *)
  15. Function hexinteger (chars : string2): byte ;
  16.     begin (* HexInteger *)
  17.     If chars[1] in ['A'..'F'] then chars[1]:=chr(ord(chars[1])+9);
  18.     If chars[2] in ['A'..'F'] then chars[2]:=chr(ord(chars[2])+9);
  19.     hexinteger := (ord(chars[1]) shl 4) + (ord(chars[2]) and $0F) ;
  20.     end  ; (* HexInteger *)
  21. (*------------------------------------------------------------------- *)
  22.  
  23. Procedure ReadKeytable ;
  24. var I : integer ;
  25.     Newname : string[15] ;
  26.     comment : string[80] ;
  27. label retry ;
  28.  
  29.     Begin (* ReadKeytable *)
  30.     keytablename := 'KEYTABLE.DAT' ;
  31.     Assign(keytable,keytablename) ;
  32. retry :
  33.     {$I-}  Reset(keytable);  {$I+}
  34.     If IORESULT = 0 then
  35.          Begin (* Initiate key table *)
  36.          For i := 1 to $88 do
  37.               Begin (* init EscSeq table *)
  38.               Readln(KeyTable,EscSeq[i,1],EscSeq[i,2],comment) ;
  39.               If copy(comment,2,2) <> '  ' then
  40.                  EscSeq[i,1] := Chr(HexInteger(copy(comment,2,2))) ;
  41.               If copy(comment,4,2) <> '  ' then
  42.                  EscSeq[i,2] := Chr(HexInteger(copy(comment,4,2))) ;
  43.               End ; (* init EscSeq table *)
  44.          Close(keytable);
  45.          End   (* Initiate key table *)
  46.                   else
  47.          Begin (* Warning *)
  48.          ClrScr ;
  49.          Writeln('*** File ',Keytablename,' not found on drive.');
  50.          Writeln('    Please specify drive or new name of keytable file. ');
  51.          Readln(newname);
  52.          If Length(Newname) = 1 then
  53.               keytablename := Newname + ':' + keytablename
  54.                                 else
  55.               keytablename := Newname ;
  56.          Assign(keytable,keytablename);
  57.          If length(keytablename)<3 then Running := false
  58.                                    else Goto Retry ;
  59.          End ; (* Warning *)
  60.     End ; (* ReadKeytable *)
  61.  
  62. const
  63.      APLTABLE : array [0..127] of byte =
  64. {00}  ($00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F,  {0F}
  65. {01}   $10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$1A,$1B,$1C,$1D,$1E,$1F,  {1F}
  66. {02}   $20,$05,$29,$3C,$F3,$3D,$3E,$5D,$FA,$5E,$86,$F6,$2C,$2B,$2E,$2F,  {1F}
  67. {03}   $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$28,$5B,$3B,$78,$3A,$5C,  {3F}
  68. {04}   $FD,$E0,$E6,$EF,$8F,$EE,$5F,$EC,$91,$E2,$F8,$27,$95,$FE,$E7,$F9,  {4F}
  69. {05}   $2A,$3F,$FB,$8D,$7E,$19,$FC,$17,$0E,$18,$0B,$1B,$1D,$1A,$F2,$2D,  {5F}
  70. {06}   $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F,  {6F}
  71. {07}   $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$7B,$1C,$7D,$24,$2D); {7F}
  72.    Over1 = 'T('#$E5'T)'#$EA'GM'#$1F'HM'#$1E'OM'#$E8'O?'#$ED'O_'#$E9'OP'#$0F ;
  73.    Over2 = 'BN'#$15'GT'#$13'BJ'#$F5'NJ'#$F4'?_'#$A7'/_'#$EB'CJ'#$A6'KL'#$97 ;
  74.    Over3 = 'K.'#$21'L+'#$98 ;
  75.    Over4 = 'aFabFbcFcdFdeFefFfgFghFhiFijFjkFklFlmFmnFnoFopFpqFqrFrsFs' ;
  76.    Over5 = 'tFtuFuvFvwFwxFxyFyzFz' ;
  77. (* ================================================================== *)
  78. (*  Connection - Connect to the other computer and simulates          *)
  79. (*               a VT100 type terminal .                              *)
  80. (*                                                                    *)
  81. (* ================================================================== *)
  82.  
  83. Procedure Connection ;
  84.     VAR
  85.          achar,bchar : byte ;
  86.          i : integer ;
  87.          overchar : string[2] ;
  88.          overchars : string[160] ;
  89.          EscapeFlag : boolean ;
  90.     (* -------------------------------------------------------- *)
  91.     Procedure Escape ;
  92.          Var Pn,Pc : byte ;
  93.  
  94.          Function PNumber (var achar : byte) : integer ;
  95.           var Numstr : string[3];
  96.               Num,result : integer ;
  97.               Begin (* PNumber *)
  98.               Numstr := '' ;
  99.               While chr(achar) in ['0'..'9']  do
  100.                    Begin (* get number *)
  101.                    Numstr := Numstr + chr(achar) ;
  102.                    If Readchar(achar) then ;
  103.                    End ; (* get number *)
  104.               Val(Numstr,Num,Result);
  105.               PNumber := Num ;
  106.               End ; (* PNumber *)
  107.  
  108.     Begin (* Escape Sequence *)
  109.     If Readchar(achar) then
  110.     CASE chr(achar) of  (* First Level *)
  111.          '[':
  112.                If Readchar(achar) then
  113.                CASE chr(achar) of   (* Second level *)
  114.                  'C': CursorRight ;
  115.                  'D': CursorLeft  ;
  116.                  'J': ClrScr ; (* Erase End of Display *)
  117.                  'K': ClrEol ; (* Erase End of Line *)
  118.                  '?': ;        (* Special functions - not yet implemented *)
  119.                  'H': GoToXY(0,0);  (* Cursor Home *)
  120.                  'm':(* NormVideo*) ;  (* Exit all attribute modes *)
  121.                 else
  122.                      Begin (* Esc [ Pn x   functions *)
  123.                      Pn := PNumber(achar);
  124.                      CASE chr(achar) of (* third level *)
  125.                         'A': For i := 1 to Pn do Cursorup ;
  126.                         'B': For i := 1 to Pn do Cursordown ;
  127.                         'C': For i := 1 to Pn do CursorRight ;
  128.                         'D': For i := 1 to Pn do CursorLeft ;
  129.                         ';': Begin (* Direct cursor addressing *)
  130.                              If readchar(achar) then ;
  131.                              Pc := PNumber (achar);
  132.                              GoToXY(Pc,Pn);
  133.                              If (pn<1) or (pc<1) then
  134.                               writeln('***',pn,' ',pc,'***');
  135.                              End ; (* Direct cursor addressing *)
  136.                         'q': FatCursor(Pn=1) ;
  137.                         'm',
  138.                         '}':
  139.                              Case Pn of      (* Field specs *)
  140.                              0: begin (* Normal *)
  141.                                 TextColor(LightGray);
  142.                                 Textbackground(black);
  143.                                 end ;
  144.                              1: begin (* High Intensity *)
  145.                                 TextColor(White);
  146.                                 Textbackground(black);
  147.                                 end ;
  148.                              4: begin (* Underline *)
  149.                                 TextColor(White);
  150.                                 Textbackground(black);
  151.                                 end ;
  152.                              5: begin (* Blink *)
  153.                                 TextColor(White+ blink);
  154.                                 Textbackground(black);
  155.                                 end ;
  156.                              7: begin (* Reverse *)
  157.                                 TextColor(Black);
  158.                                 Textbackground(white);
  159.                                 end ;
  160.                              8: begin (* Invisible *)
  161.                                 TextColor(Black);
  162.                                 Textbackground(black);
  163.                                 end ;
  164.                             30: Textcolor(Black);
  165.                             31: Textcolor(Red);
  166.                             32: Textcolor(Green);
  167.                             33: Textcolor(yellow);
  168.                             34: Textcolor(Blue);
  169.                             35: Textcolor(Magenta);
  170.                             36: Textcolor(Cyan);
  171.                             37: Textcolor(White);
  172.  
  173.                             40: Textbackground(Black);
  174.                             41: Textbackground(Red);
  175.                             42: Textbackground(Green);
  176.                             43: Textbackground(Yellow);
  177.                             44: Textbackground(Blue);
  178.                             45: Textbackground(Magenta);
  179.                             46: Textbackground(Cyan);
  180.                             47: Textbackground(White);
  181.  
  182.                              End ; (* case of Field specs *)
  183.                         'J': Case Pn of
  184.                              0: ClrScr ;
  185.                              1: ClrScr ; (* clear to beginning *)
  186.                              2: ClrScr ;
  187.                              End ; (*  J - Pn Case *)
  188.                         'K': Case Pn of
  189.                              1: ClrEol ; (* clear to beginning *)
  190.                              2: ClrEol ; (* clear line *)
  191.                              End ; (*  J - Pn Case *)
  192.                         'L': For i := 1 to Pn do InsLine ; (* Insert Line *)
  193.                         'M': For i := 1 to Pn do DelLine ; (* Delete Line *)
  194.                         '@': For i := 1 to Pn do (* InsertChar *)  ;
  195.                         'P': For i := 1 to Pn do (* DeleteChar *)  ;
  196.                      End ; (* Case third level *)
  197.                      End ; (* Esc [ Pn x   functions *)
  198.  
  199.                End ; (* second level Case *)
  200.  
  201.          'D': CursorDown ;    (* Index *)
  202.          'M': CursorUp   ;    (* Reverse Index *)
  203.          'H':            ;    (* Set Tab Stop *)
  204.          '(':            ;    (* G0 *)
  205.          ')':            ;    (* G1 *)
  206.          End ; (* First Level Case  *)
  207.  
  208.     End ; (* Escape Sequence *)
  209.     (* -------------------------------------------------------- *)
  210.          Procedure RemoteCommand  ;
  211.          Var
  212.               i : integer ;
  213.               Filename : Comstring ;
  214.          Begin (* RemoteCommand procedure *)
  215.          GotSOH := true ;
  216.          If RecvPacket then
  217.               Begin (* Got a Packet *)
  218.               If  InPacketType = Ord('S') then        (* Send Packet *)
  219.                    Begin (* Receive *)
  220.                    writeln('Got a Send    request ');
  221.                    Filename :=  '' ;
  222.                    RecvFile(filename);
  223.                    End   (* Receive *)
  224.                                           else
  225.               If  InPacketType = Ord('R') then        (* Receive Packet *)
  226.                    Begin (* Receive *)
  227.                    writeln('Got a receive request ');
  228.                    for i := 1 to InCount-3 do
  229.                        filename[i] := chr(RecvData[i]);
  230.                    Filename[0] :=  chr(InCount-3) ;
  231.                    waitxon := XonXoff ;
  232.                    SendFile(filename);
  233.                    End   (* Receive *)
  234.                                           else
  235.               If  InPacketType = Ord('G') then        (* General Packet *)
  236.                    Begin (* Receive *)
  237.                    writeln('Got a General request ');
  238.                    SendPacketType('Y');
  239.                    End   (* Receive *)
  240.                                           else
  241.  
  242.                    Begin (* Unknow packet Type *)
  243.                    OutCount := 15 ;
  244.                    Outseq := 0 ;
  245.                    OutPacketType := Ord('E');
  246.         (*           SendData := 'Unknow Command';  *)
  247.                    End;   (* Unknown packet Type *)
  248.               End   (* Got a Packet *)
  249.          End ; (* RemoteCommand Procedure *)
  250.     (* -------------------------------------------------------- *)
  251.  
  252.     Begin (* Connection *)
  253.     DialModem ;
  254.     Overchars := Over1+Over2+Over3+Over4+Over5 ;
  255.     RemoteScreen ;      (* Save local screen, restore remote screen *)
  256.     While KeyChar(achar,bchar) do ;    (* Empty keyboard buffer *)
  257.     While connected do
  258.          Begin (* connected *)
  259.          If RecvChar(achar) then
  260.               if achar < $20 then
  261.                    Begin (* Control Character *)
  262.                    if achar = StartChar then  RemoteCommand
  263.                                         else
  264.                    if achar = EOT then connected := false
  265.                                   else
  266.                    if achar = ESC then Escape
  267.                                   else
  268.                    if (achar=BS) and AplFlag then
  269.                         Begin (* Overstrick character *)
  270.                         overchar[0] := chr(2) ;
  271.                         If Readchar(achar) then overchar[2]:=chr(achar);
  272.                         i:=Pos(overchar,overchars);
  273.                         If i > 0 then  achar := ord(overchars[i+2])
  274.                                  else
  275.                               begin (* reverse order *)
  276.                               overchar[2] := overchar[1] ;
  277.                               overchar[1] := chr(achar);
  278.                               i:=Pos(overchar,overchars);
  279.                               If i>0 then achar := ord(overchars[i+2])
  280.                                      else achar := AplTable[ord(overchar[2])];
  281.                               end ; (* reverse order *)
  282.                         write(chr(BS),chr(achar));
  283.                         End  (* Overstrick character *)
  284.                                              else
  285.                    if achar in [7,8,10,13] then write(chr(achar));
  286.                    End   (* Control Character *)
  287.                              else
  288.                    If achar <> DEL then
  289.                              if AplFlag then begin (* APL char *)
  290.                                              write(chr(APLTABLE[achar]));
  291.                                              overchar[1] := chr(achar) ;
  292.                                              end
  293.                                         else write(chr(achar));
  294.          if KeyChar(achar,bchar) then
  295.               Begin (* key input *)
  296.               if bchar = $70 then connected := false else  (* Alt F9  *)
  297.               if bchar = $71 then SendBreak          else  (* Alt F10 *)
  298.  
  299.               If ((achar=0) or (EscSeq[bchar,1]<>' ')
  300.                             or (EscSeq[bchar,2]<>' ') ) and
  301.                           (achar <> $09)  then
  302.                    Begin (* Send escape sequence *)
  303.  
  304.                    If EscSeq[Bchar,1]<>' ' then SendChar(Esc);
  305.                    If EscSeq[Bchar,1]<>' ' then
  306.                              SendChar(Ord(EscSeq[bchar,1])) ;
  307.                    If EscSeq[bchar,2]<>' ' then
  308.                              SendChar(Ord(EscSeq[bchar,2])) ;
  309.                    End  (* Send Escape Sequence *)
  310.                                                     else
  311.                    Begin (* Normal Key *)
  312.                    If EscapeFlag then
  313.                         if achar = $7B then AplFlag := true  else
  314.                         if achar = $7D then AplFlag := false ;
  315.                    Escapeflag := achar = ESC ;
  316.                    if achar = LocalChar then connected := false else
  317.                       if achar = BreakChar then SendBreak
  318.                                            else Sendchar(achar);
  319.                    if LocalEcho and connected then
  320.                              if AplFlag then write(chr(APLTABLE[achar]))
  321.                                         else write(chr(achar));
  322.                    End ; (* Normal Key *)
  323.  
  324.              End; (* key input *)
  325.          End; (* connected *)
  326.     LocalScreen ;  (* save remote screen , restore local screen *)
  327.     End ; (* Connection *)
  328.  
  329.