home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB18.ZIP / ITERM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-08-21  |  17.5 KB  |  582 lines
  1. program iterm;
  2.  
  3. {  Scott Murphy
  4.    77 So. Adams St. #301
  5.    Denver, CO 80209
  6.    Compuserve 70156,263  }
  7.  
  8. Const
  9.      VERSION = '1.5';
  10.      SAVE_BUF_SIZE = 2048;             {size of text save buffer}
  11.      BELL_FREQ = 440;                  {frequncy for bell sound}
  12.      BELL_DELAY = 100;                 {duration of bell sound}
  13.      DEFAULT_BAUD = 1200;               {Serial port speed at start-up}
  14.  
  15. type
  16.     bigstring        = string[80];    {general purpose}
  17.     cset              = set of 0..127;
  18. var
  19.    SaveText              : 0..1;       {flag for saving text to disk}
  20.    SaveOpen              : boolean;    {flag for open textsave file}
  21.    SaveBuffer            : array[1..SAVE_BUF_SIZE] of char;
  22.    SavePtr               : integer;
  23.    SaveFile              : file of char;
  24.    DiscardSet            : set of 0..127;
  25.    exit,
  26.    xtnd  : boolean;
  27.    a     : byte;
  28.    c,i   : integer;
  29.    PrevLine : string[40];
  30.    CurrLine : string[40];
  31.    LineIndex : integer;
  32.    ch : char;
  33.  
  34. {$C-}
  35.  
  36.  
  37. {$I ITRMPORT.INC}
  38. {$I ITRMMISC.INC}
  39. {$I ITRMWIND.INC}
  40.  
  41. (******** ITRMXFER.INC ********)
  42. const
  43.      SOH = 1;                          {Start Of Header}
  44.      EOT = 4;                          {End Of Transmission}
  45.      ACK = 6;                          {ACKnowledge}
  46.      NAK = $15;                        {Negative AcKnowledge}
  47.      CAN = $18;                        {CANcel}
  48.      MAXERRS = 10;                     {Maximum allowed errors}
  49.      L = 0;
  50.      H = 1;
  51. type
  52.      bytevec130 = array[1..133] of byte;
  53.  
  54. {*** variables used as globals in this source segment
  55.      (actually global to whole  source) ***}
  56. var
  57.    checksum : byte;
  58.    sector : bytevec130;
  59.    fname : bigstring;
  60.    response : string[1];
  61.    f : stream;
  62.    crcval,db,sb : integer;
  63.    p : parity_set;
  64.  
  65. procedure purge;
  66. begin
  67.      while cgetc(1) <> -1 do
  68.            ;
  69. end;
  70.  
  71. procedure ShowCrt(sec, try, tot : integer);
  72. type
  73.     str3 = string[3];
  74. var
  75.    i : integer;
  76.  
  77.      function ToString(n : integer) : str3;
  78.      var
  79.         s : str3;
  80.      begin
  81.           str(n,s);
  82.           ToString := s
  83.      end;
  84. begin
  85.      status(0,concat('Blk:', ToString(sec),
  86.                      ' Try:', ToString(try){,
  87.                      ' Errs:', ToString(tot)}))
  88. end;
  89.  
  90.  
  91. procedure updcrc(a : byte);
  92. begin
  93.    inline( $8A/$46/$04/        {MOV     AL,[BP+04]}
  94.            $8B/$1E/crcval/     {MOV     BX,crcval}
  95.            $B9/$08/$00/        {MOV     CX,0008}
  96. {loop0}    $D0/$E0/            {SHL     AL,1}
  97.            $D1/$D3/            {RCL     BX,1}
  98.            $73/$04/            {JNC     loop1}
  99.            $81/$F3/$21/$10/    {XOR     BX,$1021}
  100. {loop1}    $E2/$F4/            {LOOP    loop0}
  101.            $89/$1E/crcval)     {MOV     crcval,BX}
  102. end;
  103.  
  104. procedure SaveCommStatus;
  105. begin
  106.       p := parity;
  107.       db := dbits;
  108.       sb := stop_bits;
  109.       dbits        := 8;
  110.       parity       := none;
  111.       stop_bits    := 1;
  112.       update_uart
  113. end;
  114.  
  115. procedure recv_wcp;
  116. {receive a file using Ward Christensen's checksum protocol}
  117. label
  118.      99;
  119. var
  120.   j, firstchar, sectnum, sectcurr,
  121.    toterr, errors, sectcomp : integer;
  122.    ErrorFlag : boolean;
  123. begin
  124.      status(2, 'RECV XMODEM');
  125.      ErrorFlag := TRUE;
  126.      SaveCommStatus;
  127.      OpenTemp(1,3,80,8,2);
  128.      repeat
  129.            write('Enter a filename for download file (<cr> to abort): ');
  130.            readln(fname);
  131.            supcase(fname);
  132.            if length(fname) > 0 then
  133.               if exists(fname) then
  134.               begin
  135.                 write(fname, ' Exists. OK to overwrite it (Y/N)? ');
  136.                 readln(response);
  137.                 if upcase(response) = 'Y' then
  138.                    ErrorFlag := FALSE;
  139.               end
  140.               else ErrorFlag := FALSE
  141.      until (not ErrorFlag) or (length(fname) = 0);
  142.      CloseTemp;
  143.      if length(fname) > 0 then
  144.          f := fopen(fname,'w');
  145.      if length(fname) = 0 then
  146.         writeln(#13,#10,'ITERM --- user aborted receive.')
  147.      else if f = NIL then
  148.          writeln(#13,#10,'ITERM --- could not open ',fname, ' Aborting receive.');
  149.      if (f = NIL) or (length(fname) = 0) then
  150.         goto 99;
  151.      writeln('Ready to receive ', fname);
  152.      sectnum := 0;
  153.      errors := 0;
  154.      toterr := 0;
  155.      ShowCrt(0,0,0);
  156.      send(ord('C')); {request CRC}
  157.      repeat
  158.           ErrorFlag := FALSE;
  159.           repeat
  160.                firstchar := cgetc(10)
  161.           until (firstchar = SOH) or (firstchar = EOT) or (firstchar = -1);
  162.           if firstchar = -1 then
  163.              ErrorFlag := TRUE;
  164.           if firstchar = SOH then
  165.           begin
  166.                sectcurr := cgetc(1);
  167.                sectcomp := cgetc(1);
  168.                if (sectcurr + sectcomp) = 255 then
  169.                begin
  170.                     if sectcurr = (sectnum + 1) then
  171.                     begin
  172.                          crcval := 0;
  173.                          checksum := 0;
  174.                          for j := 1 to 128 do
  175.                          begin
  176.                               sector[j] := cgetc(1);
  177.                               updcrc(sector[j]);
  178.                               checksum := checksum + sector[j]
  179.                          end;
  180.                          sector[129] := cgetc(1);
  181.                          sector[130] := cgetc(1);
  182.                          updcrc(sector[129]);
  183.                          updcrc(sector[130]);
  184.                          if crcval = 0 then
  185.                          begin
  186.                               send(ACK);
  187.                               errors := 0;
  188.                               sectnum := sectcurr;
  189.                               ShowCrt(sectnum, errors, toterr);
  190.                               for j := 1 to 128 do
  191.                                   write(f^,sector[j])
  192.                          end
  193.                          else
  194.                              ErrorFlag := TRUE
  195.                     end
  196.                     else
  197.                     if sectcurr = sectnum then
  198.                     begin
  199.                        purge;
  200.                        send(ACK)
  201.                     end
  202.                     else
  203.                       ErrorFlag := TRUE
  204.                end
  205.                else
  206.                    ErrorFlag := TRUE
  207.           end;
  208.           if ErrorFlag then
  209.           begin
  210.                errors := errors + 1;
  211.                if sectnum > 0 then
  212.                   toterr := succ(toterr);
  213.                purge;
  214.                ShowCrt(sectnum, errors, toterr);
  215.                send(NAK)
  216.           end
  217.      until (firstchar = EOT) or (errors = MAXERRS);
  218.      if (firstchar = EOT) and (errors < MAXERRS) then
  219.      begin
  220.           send(ACK);
  221.           close(f^);
  222.           dispose(f);
  223.           writeln('DONE.')
  224.      end
  225.      else begin
  226.           send(CAN);
  227.           writeln('ABORTING: Error limit exceeded or unrecoverable error.');
  228.           close(f^);
  229.           erase(f^);
  230.           dispose(f)
  231.      end;
  232. 99:
  233.      status(0,' ');
  234.      status(2,'On-Line/Ready');
  235.      dbits        := db;
  236.      parity       := p;
  237.      stop_bits    := sb;
  238.      update_uart;
  239. end;
  240.  
  241. procedure SendAscii;
  242. var
  243.    f : stream;
  244.    b : byte;
  245.    fname : bigstring;
  246.    c : integer;
  247. begin
  248.      OpenTemp(10,5,60,12,2);
  249.      repeat
  250.            Write('Filename to transmit? ');
  251.            readln(fname);
  252.            f := fopen(fname, 'r');
  253.            if f = NIL then
  254.            begin
  255.                 Writeln('Can''t open: ',fname);
  256.                 WriteLn('Please try a different spelling, drive or disk.');
  257.                 WriteLn
  258.            end
  259.      until (f <> NIL) or (Length(fname) = 0);
  260.      CloseTemp;
  261.      if f <> NIL then
  262.      begin
  263.           Status(0,'Sending ASCII');
  264.           OpenTemp(1,3,80,20,1);
  265.           b := 0;
  266.           while (not eof(f^)) and (b <> 26)do
  267.           begin
  268.                read(f^,b);
  269.                if (b <> 26) and (b <> 10) then
  270.                begin
  271.                   send(b);
  272.                   c := cgetc(1);
  273.                   if c = 19 then
  274.                      while cgetc(0) <> 17 do ;
  275.                   if c <> -1 then
  276.                      write(chr(c and $7F));
  277.                   if c = 13 then
  278.                      writeln
  279.                end
  280.           end;
  281.           CloseTemp;
  282.           close(f^);
  283.           dispose(f);
  284.           Status(0,' ')
  285.      end
  286. end;
  287.  
  288. procedure send_wcp;
  289. Label
  290.   99;
  291. Var
  292.    UserKey : char;
  293.    c, sectnum, errors : integer;
  294.    bflag : boolean;
  295.  
  296.   function ReadBlock : integer;
  297.   Var
  298.     i, j : integer;
  299.   begin
  300.     FillChar(sector, 133, ^Z);
  301.     sector[1] := SOH;
  302.     sector[2] := sectnum;
  303.     sector[3] := 255 - sectnum;
  304.     crcval := 0;
  305.     i := 4;
  306.     while (not eof(f^)) and (i < 132) do
  307.     begin
  308.       read(f^, sector[i]);
  309.       updcrc(sector[i]);
  310.       i := succ(i)
  311.     end;
  312.     for j := i to 131 do
  313.       updcrc(sector[j]);
  314.     updcrc(0); updcrc(0);
  315.     sector[132] := hi(crcval);
  316.     sector[133] := lo(crcval);
  317.     ReadBlock := i - 4
  318.   end;
  319.  
  320.   procedure SendBlock;
  321.   Var i : integer;
  322.   begin
  323.     for i := 1 to 133 do
  324.       send(sector[i])
  325.   end;
  326.  
  327. begin
  328.      status(2, 'SEND XMODEM');
  329.      SaveCommStatus;
  330.      OpenTemp(1,3,80,8,2);
  331.      repeat
  332.        write('Enter a filename for upload file (<cr> to abort): ');
  333.        readln(fname);
  334.        supcase(fname);
  335.        if length(fname) > 0 then
  336.        begin
  337.          bflag := exists(fname);
  338.          if not bflag then
  339.          begin
  340.            writeln('Could not open file ',fname);
  341.            writeln('(Spelling or drive designation wrong?)');
  342.            writeln
  343.          end
  344.        end
  345.     until bflag or (length(fname) = 0);
  346.     CloseTemp;
  347.     if length(fname) = 0 then
  348.       goto 99;
  349.     f := fopen(fname,'r');
  350.     writeln(^M, ^J, 'Transmitting file: ',fname);
  351.     writeln(LongFileSize(f^):6:0,' bytes, ',int(LongFileSize(f^)/133.0)+1:4:0,' Blocks');
  352.     writeln('Approximate time to send:',
  353.              (int(LongFileSize(f^)/133.0)+1)*22.1666667/speed:6:2,
  354.              ' minutes at',speed:5,' bps.');
  355.     sectnum := 1;
  356.     errors := 0;
  357.     ShowCrt(0,0,0);
  358.     UserKey := #0;
  359.     repeat
  360.       c := cgetc(1);
  361.       if keypressed then read(kbd, UserKey)
  362.     until (c <> -1) or (UserKey = ^X);
  363.     if UserKey = ^X then goto 99;
  364.     UserKey := #0;
  365.     purge;
  366.     while (ReadBlock > 0) and (errors <= MAXERRS) do
  367.     begin
  368.       errors := 0;
  369.       repeat
  370.         ShowCrt(sectnum, errors, 0);
  371.         SendBlock;
  372.         repeat
  373.           c := cgetc(0);
  374.           if KeyPressed then read(kbd,UserKey);
  375.         until (c <> -1) or (UserKey = ^X);
  376.         if UserKey = ^X then goto 99;
  377.         if c = ACK then
  378.           sectnum := sectnum + 1
  379.         else
  380.           errors := errors + 1
  381.       until (c = ACK) or (errors = MAXERRS)
  382.     end;
  383.     errors := 0;
  384.     repeat
  385.       send(EOT);
  386.       repeat
  387.         c := cgetc(10);
  388.         if KeyPressed then read(kbd,UserKey);
  389.       until (c <> -1) or (UserKey = ^X);
  390.       if UserKey = ^X then goto 99;
  391.       if c = NAK then errors := errors + 1
  392.     until (c = ACK) or (errors = MAXERRS);
  393.     99:
  394.     close(f^);
  395.     dispose(f);
  396.     if UserKey = ^X then
  397.     begin
  398.       WriteLn(^M,^J,'Cancelling transmission of ',fname, ' at your request');
  399.       repeat
  400.         send(CAN);
  401.         purge
  402.       until cgetc(1) = -1
  403.     end;
  404.     status(0,' ');
  405.     status(2,'On-Line/Ready');
  406.     dbits        := db;
  407.     parity       := p;
  408.     stop_bits    := sb;
  409.     update_uart
  410. end;
  411.  
  412. (******** END ITERMXFER.INC **********)
  413.  
  414. {$I ITRMDIAL.INC}
  415. {$I ITRMSAVE.INC}
  416.  
  417.  
  418. begin
  419.      ClrScr;
  420.      InitWindow(StatWin,1,1,80,2);
  421.      InitWindow(TermWin,1,3,80,25);
  422.      CurrentWin := TermWin;
  423.      UsePermWindow(TermWin);
  424.      status(1,'ITERM ver: ' + VERSION);
  425.      status(2,'Initializing');
  426.      CurrLine := '';
  427.      PrevLine := '';
  428.      LineIndex := 1;
  429.      SaveText := 0;
  430.      SaveOpen := FALSE;
  431.      SavePtr := 1;
  432.      DiscardSet := [];
  433.      InitPhn;
  434.      setup;
  435.      set_up_recv_buffer;
  436.      remove_port;
  437.      setup;
  438.      set_up_recv_buffer;
  439.      exit := false;
  440.      GotoXY(1,1);
  441.      status(2,'Off-Line/Ready');
  442.      while not exit do
  443.      begin
  444.           if keypressed then
  445.           begin
  446.                scan(xtnd, a);
  447.                if xtnd then
  448.                   case a of
  449.                        19   : {alt-R}
  450.                               recv_wcp;
  451.                        45   : {alt-X}
  452.                               begin
  453.                                    OpenTemp(20,18,60,22,1);
  454.                                    writeln('───ITERM───');
  455.                                    write('Do you really want to exit (Y/N)? ');
  456.                                    readln(ch);
  457.                                    if upcase(ch) = 'Y' then
  458.                                       exit := TRUE;
  459.                                    CloseTemp
  460.                               end;
  461.                        67   : {F9}
  462.                               begin
  463.                                    SaveText := 1 - SaveText;
  464.                                    if SaveText = 1 then
  465.                                    begin
  466.                                         Status(3, 'Text save: ON');
  467.                                         if not SaveOpen then
  468.                                            InitSaveFile
  469.                                    end
  470.                                    else
  471.                                       Status(3, 'Text Save: OFF')
  472.                               end;
  473.                        68   : {F10}
  474.                               if SaveOpen then
  475.                               begin
  476.                                    SaveOpen := FALSE;
  477.                                    SaveText := 0;
  478.                                    status(3,'Closing save file');
  479.                                    for i := 1 to SavePtr do
  480.                                        write(SaveFile, SaveBuffer[i]);
  481.                                    close(SaveFile);
  482.                                    Status(3, 'Text Save: OFF')
  483.                               end;
  484.                        31   : {alt-S}
  485.                               send_wcp;
  486.                        32   : {alt-D}
  487.                               auto_dial;
  488.                        35   : {alt-H}
  489.                               begin
  490.                                    writeln('───ITERM───');
  491.                                    status(2,'Disconnecting');
  492.                                    term_ready(FALSE);
  493.                                    delay(500);
  494.                                    term_ready(TRUE);
  495.                                    status(2,'Off-Line/Ready')
  496.                               end;
  497.                        46   : {alt-C}
  498.                               ClrScr;
  499.                        48   : {alt-B}
  500.                               break;
  501.                        25   : {alt-P}
  502.                               NewParms;
  503.                        59   : {F1}
  504.                               if phones[CurPhone].paced then
  505.                                  SendPaced(phones[CurPhone].id + #13)
  506.                               else
  507.                                  StrSend(phones[CurPhone].id + #13);
  508.                        60   : {F2}
  509.                               if phones[CurPhone].paced then
  510.                                  SendPaced(phones[CurPhone].pw + #13)
  511.                               else
  512.                                  StrSend(phones[CurPhone].pw + #13);
  513.                        61   : {F3}
  514.                               SendPaced(PrevLine);
  515.                        77   : {Cursor Right}
  516.                               begin
  517.                                  if LineIndex <= length(PrevLine) then
  518.                                     send(ord(PrevLine[LineIndex]));
  519.                                  LineIndex := LineIndex + 1
  520.                               end;
  521.                       72   : {Cursor up}
  522.                              PushPage;
  523.                       80   : {Cursor Down}
  524.                              PopPage;
  525.                       65   : {F7}
  526.                              SendAscii;
  527.                   end {case}
  528.                else if a = 13 then
  529.                begin
  530.                     PrevLine := CurrLine;
  531.                     Currline := '';
  532.                     LineIndex := 1;
  533.                     send(a)
  534.                end
  535.                else
  536.                begin
  537.                    CurrLine := CurrLine + chr(a);
  538.                    send(a)
  539.                end
  540.           end; {if KeyPressed}
  541.           c := cgetc(0);
  542.           if not (c in DiscardSet) then
  543.           case c of
  544.               -1 : begin
  545.                    end; {no action}
  546.                9 : {tab}
  547.                    begin
  548.                         for c := WhereX to (WhereX div 8 + 1)*8 do
  549.                             write(' ');
  550.                         c := 9
  551.                    end;
  552.                7 : {bell}
  553.                     begin
  554.                          sound(BELL_FREQ);
  555.                          delay(BELL_DELAY);
  556.                          NoSound
  557.                     end;
  558.                12 : {form-feed}
  559.                     ClrScr;
  560.               else  write(chr(c and $7F));
  561.           end; {case}
  562.           if (c <> -1) and (SaveText = 1) and (not (c in DiscardSet)) then
  563.                DiskBuffer(chr(c));
  564.      end; {while not exit}
  565.      remove_port;
  566.      if cflag then
  567.      begin
  568.           status(3,'Updating ITERM.PHN');
  569.           rewrite(phfile);
  570.           for c := 1 to MAXPHONES do
  571.               write(phfile, phones[c]);
  572.           close(phfile)
  573.      end;
  574.      if SaveOpen then
  575.      begin
  576.           status(3,'Closing save file');
  577.           for i := 1 to SavePtr do
  578.               write(SaveFile, SaveBuffer[i]);
  579.           close(SaveFile)
  580.      end
  581. end.
  582.