home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / vmspascal / vxkerm.pas < prev    next >
Pascal/Delphi Source File  |  1988-08-15  |  69KB  |  3,178 lines
  1. {
  2.     Program :  KERMIT.PAS           - Main program 
  3.              PARSER.PAS         - Kermit Command Parser 
  4.              PGLOBAL.PAS        - Parser Global Definitions 
  5.              VERSION.PAS     - Version header & prompts    
  6.              VTERM.FOR          - Kermit Virtual Terminal Program 
  7.              VTGLOBAL.FOR       - Virtual Terminal Global Definitions 
  8.  
  9.     Author :   Philip Murton - original RT-11 pascal program,
  10.            Bruce W. Pinn - modified version for VMS 3.x
  11.                     added regular command parser,
  12.                     virtual terminal support,
  13.                     pretty pascal code.
  14.  
  15.     Date :  April 28, 1983
  16.     Site :  University of Toronto
  17.         Computing Services
  18.  
  19.     Abstract :
  20.          This program implements the KERMIT protocol under VAX/VMS.  KERMIT
  21.     is an acronym for the expression "KL-10 Error-Free Reciprocol
  22.     Microcomputer Interchange over TTY-Lines".  For more information on
  23.     Kermit please refer to the documentation included with this distri-
  24.     bution.
  25.          This version of KERMIT, with its virtual terminal support, may
  26.     be used as a local, or remote kermit.
  27.  
  28.     Bug Fixes :
  29.         01-JUN-83  BWP  Reset packet pointer to zero after each
  30.                 file group send/receive to satisfy UNIX
  31.                 kermit.
  32.  
  33.         01-JUN-83  BWP  Fixed file handling so that if incoming line
  34.                 exceeds 133 then it is wrapped to next line.
  35.  
  36.         08-AUG-83  BWP  Fixed getfile so that routine will open an
  37.                 incoming file of xxx to xxx. as opposed to
  38.                 xxx.DAT.
  39.  
  40.         09-AUG-83  BWP  Fixed parsing routine to strip off leading
  41.                 blanks from user command.
  42.  
  43.         09-AUG-83  BWP  Fixed parsing routine to allow `?' to be
  44.                 specified after send or receive command.
  45.  
  46.         10-AUG-83  BWP  Fixed bug so that when remote connection
  47.                 generates hangup, the user cannot type conn
  48.                 to reconnect.  This also fixes the gobbled
  49.                 character problem (actually now only one 
  50.                 gobbled character).
  51.  
  52.         11-AUG-83  BWP  Added dcl call to parser.
  53.  
  54.         11-AUG-83  BWP  Turned off control-(c/y) checking.
  55.  
  56.         15-AUG-83  BWP  Adjusted code to check local user for input
  57.                 during send.  (Allow abort, and retransmit
  58.                 packets.)
  59.  
  60.         29-SEP-83  BWP  Fixed code so that before each send the
  61.                 find_file/next file pointer is reset to zero.
  62.  
  63.         29-SEP-83  BWP  Turned off sysprv priviledge after allocating
  64.                 the remote port.
  65.  
  66.         01-NOV-83  BWP  Turned on, then off control-y handling when
  67.                 execing DCL.
  68.  
  69.         01-NOV-83  BWP  Fixed bug so that when user performs transfer
  70.                 abort the diskfile is appropriately closed.
  71.  
  72.         01-NOV-83  BWP  Fixed bug so that when user aborts, or error
  73.                 occurs during a file open, an error packet is
  74.                 sent to the remote kermit.
  75.  
  76.         19-NOV-83  BWP  Placed kludge in SLEEPVMS to avoid the problem
  77.                 with chr function in PASCAL 2.2.
  78.  
  79.         28-NOV-83  BWP  Fixed the parsing of the receiveinit packet
  80.                 so that the quote character was interpretted
  81.                 correctly.
  82.  
  83.         20-DEC-83  BWP    Provided eight-bit quoting facility for the
  84.                 program.
  85.                 (Version 1.1)
  86.  
  87.         22-MAY-84  PTM    Add error messages for file opens and add
  88.                 flush of TypeAhead in SendInit.
  89.                 Add message for non-ascii send in Text file.
  90.                 (Version 1.1A)
  91.  
  92.         23-JUL-84  PTM    On unsucessful receive delete file.
  93.                 Modify ErrorPack 
  94.                 (Version 1.1B)                  
  95.  
  96.         26-JUL-84  PTM    Increase line length for Text file to 255
  97.                 on write.
  98.                 Fix DataToFile for <CR><CR><LF> sequence.
  99.                 (Version 1.1C)                  
  100.  
  101.         10-AUG-84  PTM    GetData does not quote properly !!
  102.                 (Version 1.1D)                  
  103.  
  104.         22-AUG-84  PTM    Fix GetData for DEL.
  105.                 Modify ErrorPack.
  106.                 (Version 1.1E)                  
  107.                 }
  108.  
  109.  
  110. { TOP OF PROGRAM }
  111. [inherit('SYS$LIBRARY:STARLET')]
  112. program Kermit(input,output,file3,file4,binfile,helpfile);
  113.  
  114. label 
  115.       9999;               { used only to simulate a "halt"  instruction }
  116.  
  117. const 
  118.  
  119.     { standard file descriptors. subscripts in open, etc. }
  120.       STDIN = 1;          { these are not to be changed }
  121.       STDOUT = 2;
  122.       STDERR = 3;
  123.       LOCALCHAN = 5;
  124.       REMOTECHAN = 6;
  125.  
  126.     { other io-related stuff }
  127.       IOERROR = 0;        { status values for open files  }
  128.       IOAVAIL = 1;
  129.       IOREAD = 2;
  130.       IOWRITE = 3;
  131.       MAXOPEN = 6;        { maximum number of open files  }
  132.  
  133.     { eight bit stuff }
  134.       SBIT = 7;
  135.       EBIT = 8;
  136.       BLKSIZE = 512;
  137.  
  138.     { universal manifest constants  }
  139.       NULL = 0;
  140.       ENDSTR = -255;         { null-terminated strings }
  141.       ENDFILE = -256;
  142.       ENDOFQIO = -257;
  143.       MAXSTR = 100;       { longest possible string }
  144.       CONLENGTH = 20;     { length of constant string }
  145.       MAXCHARPERLINE = 255; { Maximum number of characters for file line }
  146.       STDCHARPERLINE = 133; { Standard number of characters for file line }
  147.  
  148.     { ascii character set in decimal }
  149.       BACKSPACE = 8;
  150.       TAB = 9;
  151.       NEWLINE = 10;
  152.       BLANK = 32;
  153.       EXMARK = 33;
  154.       SHARP = 35;
  155.       AMPERSAND = 38;
  156.       PERIOD = 46;
  157.       RABRACK = 62;
  158.       QUESTION = 63;
  159.       GRAVE = 96;
  160.       TILDE = 126;
  161.       LETA = 65;
  162.       LETZ = 90;
  163.       LETsa = 97;
  164.       LETsz = 122;
  165.       LET0 = 48;
  166.       LET9 = 57;
  167.  
  168.       SOH = 1;            { ascii SOH character }
  169.       CR = 13;            { CR }
  170.       DEL = 127;          { rubout }
  171.  
  172.       DEFTRY = 5;         { default for number of retries }
  173.       DEFITRY = 10;       { default for number of retries on init }
  174.       DEFTIMEOUT = 20;    { default time  out }
  175.       MAXPACK = 94;       { max is 94 }
  176.       DEFDELAY = 5;      { delay before  sending first init }
  177.       NUMPARAM = 7;       { number of parameters in init packet }
  178.       DEFQUOTE = SHARP;   { default quote character   }
  179.       DEFEBQUOTE = AMPERSAND;
  180.       DEFPAD = 0;         { default number of padding chars   }
  181.       DEFPADCHAR = 0;     { default padding character  }
  182.  
  183.     { SYSTEM DEPENDENT }
  184.       DEFEOL = CR;
  185.  
  186.     { packet TYPES  }
  187.  
  188.       TYPEB  = 66;    { ord('B') }
  189.       TYPED  = 68;    { ord('D') }
  190.       TYPEE  = 69;    { ord('E') }
  191.       TYPEF  = 70;    { ord('F') }
  192.       TYPEN  = 78;    { ord('N') }
  193.       TYPES  = 83;    { ord('S') }
  194.       TYPET  = 84;    { ord('T') }
  195.       TYPEY  = 89;    { ord('Y') }
  196.       TYPEZ  = 90;    { ord('Z') }
  197.  
  198.       MAXCMD = 10;
  199.  
  200.     { Virtual Terminal Support }
  201.       LOCALONLY = 0;
  202.       LOCALREMOTE = 1;
  203.  
  204.     { VMS qio buffer size }
  205.       VMSBUFSIZE = 512;
  206.       SLEEPEFN = 10;
  207.  
  208.     { Command parser constants }
  209.       SMALLSIZE = 13;
  210.       LARGESIZE = 80;
  211.       MINPACKETSIZE = 10;
  212.       MAXPACKETSIZE = 94;
  213.  
  214.       %include   'kermdir:pglobal.pas'
  215.  
  216. type 
  217.      character = ENDOFQIO..127;     { byte-sized. ascii + other stuff }
  218.      schar = -128..127;
  219.      wordInteger = 0..65535;
  220.      string = array [1..MAXSTR] of character;
  221.      vstring = record
  222.            len : integer;
  223.            ch  : array [1..MAXSTR] of char;
  224.            end;
  225.      cstring = PACKED array [1..CONLENGTH] of char;
  226.      filedesc = IOERROR..MAXOPEN;
  227.      ioblock = record                { to keep track of open files }
  228.            filevar : text;
  229.            mode : -IOWRITE..IOWRITE;
  230.            ftype : SBIT..EBIT;
  231.            end;
  232.  
  233.     { Eight bit file stuff }
  234.      block = packed array[1..BLKSIZE] of char;
  235.      binfiletype = file of block;
  236.      EBQtype = (Ascii, Binary);
  237.  
  238.     { Data  TYPES for Kermit }
  239.      Packet = RECORD
  240.            mark : character;       { SOH character  }
  241.            count: character;       { # of bytes following this field }
  242.            seq  : character;       { sequence number modulo 64  }
  243.            ptype: character;       { d,y,n,s,b,f,z,e,t  packet type }
  244.            data : string;          { the actual data }
  245.           end;
  246.     { chksum is last validchar in data array }
  247.     { eol is added, not considered  part of packet proper }
  248.  
  249.      timeArray = packed array[1..2] of integer;
  250.      Command = (Transmit,Receive,Invalid,Connect);
  251.      KermitStates = (FileData,Init,Break,FileHeader,EOFile,Complete,Abort);
  252.      EOLtype = (LineFeed,CrLf,JustCr);
  253.  
  254.      Words = (Low,High);
  255.      Stats = integer;
  256.      Ppack = ^Packet;
  257.  
  258.      Intype = (nothing,CRin,abortnow);
  259.  
  260.     {  Parser defined types }
  261.      vmsString = varying[255] of char;
  262.      $UBYTE = [BYTE] 0..255;
  263.      string13 = packed array [1..SMALLSIZE] of char;
  264.      string80 = packed array [1..LARGESIZE] of char;
  265.  
  266. var 
  267.     openlist : array [1..MAXOPEN] of ioblock; { open files  }
  268.     cmdargs  : 0..MAXCMD;
  269.     cmdlin   : string;
  270.     cmdidx   : array [1..MAXCMD] of 1..MAXSTR;
  271.     file3,file4,helpfile : text;
  272.     file3cnt, file4cnt : integer;
  273.  
  274.     { varibles for  Kermit }
  275.     DiskFile : filedesc;     { File being read/written }
  276.     SaveState : kermitstates;
  277.     NextArg  : integer;      { next argument to process }
  278.     local    : boolean;      { local/remote flag }
  279.     MaxTry   : integer;
  280.     n        : integer;      { packet number }
  281.     NumTry   : integer;      { times this packet retried }
  282.     OldTry   : integer;
  283.     Delay    : integer;
  284.     Pad, MyPad : integer;      { number of padding characters I need  }
  285.     PadChar, MyPadChar: character;
  286.     MyTimeOut, TheirTimeOut : integer;
  287.     timeOutStatus, fudge : boolean;
  288.     Runtype, oldRunType  : command;
  289.     State    : kermitstates;
  290.  
  291.     LineIN, LineOUT, ControlIN,ControlOUT : filedesc;
  292.     SizeRecv, SizeSend : integer;
  293.     SendEOL, SendQuote : character;
  294.     myEOL,myQuote: character;
  295.     EOLFORFILE : EOLtype;
  296.     NumSendPacks, NumRecvPacks : integer;
  297.     NumACK, NumNAK : integer;
  298.     NumACKrecv, NumNAKrecv, NumBADrecv : integer;
  299.     RunTime : integer;
  300.     startTime, endTime: timeArray;
  301.     ChInFileRecv, ChInPackRecv, ChInFileSend, ChInPackSend : Stats;
  302.     Debug : boolean;
  303.                      
  304.     { Check for received file - was it OK ? }
  305.     TransferOK : boolean;   
  306.     
  307.     ThisPacket :    Ppack;  { current packet being  sent }
  308.     LastPacket :    Ppack;  { last  packet sent }
  309.     CurrentPacket : Ppack;  { current packet received }
  310.     NextPacket :    Ppack;  { next  packet being received }
  311.     InputPacket : Ppack;    { save  input to do debug }
  312.  
  313.     { these are used for the Receive Packet procedures }
  314.     FromConsole : Intype;   { input from Console during     receive }
  315.     check: integer;         { Checksum }
  316.     PacketPtr : integer;    { pointer to InputPacket }
  317.     dataptr : integer;      { pointer to data of Packet }
  318.     fld : 0..5;             { current fld number }
  319.     t : character;          { input character }
  320.     finished : boolean;     { finished packet ? }
  321.     restart : boolean;      { restart packet ? }
  322.     control : boolean;      { quoted ? }
  323.     isgood : boolean;       { packet is good  ? }
  324.  
  325.     {  Virtual Terminal Connect Parameters  }
  326.     localChannel, remoteChannel : integer;
  327.     locWriteFunc, locReadFunc : integer;
  328.     remWriteFunc, remReadFunc : integer;
  329.     vTermSetType : integer;
  330.     invalidConnection : boolean;
  331.  
  332.     {  VMS qiow read buffer, and pointers. }
  333.     vmsReadModifer : integer;
  334.     vmsReadBuff, vmsWriteBuff : packed array[1..VMSBUFSIZE] of schar;
  335.     vmsChRead, curBuffPoint, vmsWritePnt, vmsFilePnt, stat : integer;
  336.     ctrlOff : integer;
  337.     fileExists, lastFile, vmsWriteFlg : boolean;
  338.  
  339.     {  VMS routine exit handler vars. }
  340.     exitStatus : integer;
  341.  
  342.     { Eight Bit Quoting Info }
  343.     sentEBQuote, recvdEBQuote, needEBQuote : boolean; { Used for determining 8 bit state }
  344.     EBQState : EBQtype;             { ... }
  345.     EBQchar : character;         { Quote character for 8 bit trans }
  346.     binfile : binfiletype;         { Binary file }
  347.     ishigh : integer;             { Shift to put high bit on }
  348.     binascflg : -1..1;             { State of file open binary/ascii }
  349.     binbuffer : block;             { Buffer for binary data }
  350.     binptr : integer;             { Binary buffer pointer }
  351.     
  352.     {  Parser defined variables }
  353.     commandLine, fileSpec : string80;
  354.     exitProgram : boolean;
  355.     localEcho, sFileSpec, rFileSpec, lSpeed, transtype : integer;
  356.     escape, debugging, commandLen, fileEol, parity : integer;
  357.  
  358.  
  359. procedure SetUpVirtualTerminal(var remChanl : integer;
  360.                    var remRFunc : integer;
  361.                    var remWFunc : integer;
  362.                    var locChanl : integer;
  363.                    var locRFunc, locWFunc,
  364.                    status, setType, locEcho,
  365.                    parity, speed  : integer) ;
  366. fortran;
  367.  
  368.  
  369. procedure SetUpExitHandlerVMS(swapm, priority : integer);
  370. fortran;
  371.  
  372. [asynchronous, external (LIB$DISABLE_CTRL)]
  373.  
  374. function $Disable_Ctrl
  375.       ( var mask : integer := %immed 0)
  376.    : integer;
  377. external;
  378.  
  379. [asynchronous, external (LIB$ENABLE_CTRL)]
  380.  
  381. function $Enable_Ctrl
  382.       ( var mask : integer := %immed 0)
  383.    : integer;
  384. external;
  385.  
  386. [asynchronous, external (LIB$FIND_FILE)]
  387.  
  388. function $Find_File
  389.       ( var fileName : varying[$l1] of
  390.                 char := %immed 0;
  391.     var resultName : varying[$l2] of
  392.                 char := %immed 0;
  393.     var context : integer := %immed 0;
  394.     var defaultName : varying[$l3] of
  395.                 char := %immed 0;
  396.     var relatedName : varying[$l4] of
  397.                 char := %immed 0 )
  398.    : integer;
  399. external;
  400.  
  401. [asynchronous, external (LIB$SPAWN)]
  402.  
  403. function $Spawn
  404.       ( var shelline : varying[$ll1] of
  405.                 char := %immed 0)
  406.    : integer;
  407. external;
  408.  
  409. [asynchronous, external (LIB$SUBX)]
  410.  
  411. function $Subx
  412.       ( var a : timeArray;
  413.     var b : timeArray;
  414.     var c : timeArray)
  415.    : integer;
  416. external;
  417.  
  418.  
  419. [asynchronous, external (LIB$EDIV)]
  420.  
  421. function $Ediv
  422.       ( var divisor   : integer := %immed 0;
  423.     var dividend  : timeArray;
  424.     var quotient  : integer := %immed 0;
  425.     var remainder : integer := %immed 0)
  426.    : integer;
  427. external;
  428.  
  429.  
  430. procedure DebugMessage(c : cstring);
  431. forward;
  432.  
  433.  
  434. procedure PutCln( x:cstring;
  435.                fd:filedesc);
  436. forward;
  437.  
  438.  
  439. procedure AddTo( var sum : Stats;
  440.           inc:integer);
  441. forward;
  442.  
  443.  
  444. procedure PutCN( x:cstring;
  445.          v : integer;
  446.          fd:filedesc);
  447. forward;
  448.  
  449.  
  450. procedure FinishUp(noErrors : boolean);
  451. forward;
  452.  
  453.  
  454. procedure ErrorPack(c:cstring);
  455. forward;
  456.  
  457.  
  458. procedure ProgramHalt; { used by external  procedures for halt }
  459. begin
  460.     GOTO 9999
  461. end;
  462.  
  463. procedure Greeting; {Kermit Version Message}
  464. const
  465. %include   'kermdir:version.pas'
  466. begin
  467.     writeln(VERSION);        
  468. end;
  469.  
  470. { initio  -- initialize open file list  }
  471.  
  472. procedure Initio;
  473.  
  474. var 
  475.     status : integer;
  476.     i : filedesc;
  477. begin
  478.     controlIN := STDIN;
  479.     controlOUT := STDOUT;
  480.  
  481.     openlist[STDIN].mode := IOREAD;
  482.     openlist[STDOUT].mode := IOWRITE;
  483.     openlist[STDERR].mode := IOWRITE;
  484.  
  485.    { connect STDERR to  user's terminal ... }
  486.  
  487.     open(FILE_VARIABLE := file3,
  488.      FILE_NAME := 'SYS$ERROR');
  489.  
  490.     rewrite(file3);
  491.  
  492.     file3cnt := 0;
  493.  
  494.    { initialise all files to seven bit as default }
  495.     for i := STDIN to MAXOPEN do
  496.     openlist[i].ftype := SBIT;
  497.  
  498.    { initialize rest of files }
  499.     for i := STDERR+1 to MAXOPEN do
  500.     openlist[i].mode := IOAVAIL;
  501.  
  502.     {  Initialize the local channel }
  503.     vTermSetType := LOCALONLY;
  504.     invalidConnection := false;
  505.     SetUpVirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
  506.              localChannel, locReadFunc, locWriteFunc,
  507.              status, vTermSetType, localEcho, parity, lSpeed);
  508.     if (status <> ss$_normal) then
  509.     invalidConnection := true;
  510.  
  511.     openlist[LOCALCHAN].mode := IOREAD;
  512. end;
  513.  
  514.  
  515. function Sopen (name : string; mode : integer) : filedesc;
  516. { Sopen  -- open a file for reading or  writing }
  517.  
  518. var 
  519.     i : integer;
  520.     intname : PACKED array [1..MAXSTR] of char;
  521.     found : boolean;
  522.  
  523. procedure Iopen(var f : text;
  524.         var binf : binfiletype;
  525.         var linelen : integer);
  526. begin
  527.     linelen := 0;
  528.     case openlist[i].mode of
  529.  
  530.     IOERROR,
  531.     IOAVAIL : { Do Nothing; this should actually not happen };
  532.  
  533.     IOREAD :
  534.         begin
  535.         open(FILE_VARIABLE := f,
  536.              FILE_NAME := intname,
  537.              RECORD_LENGTH := 255,
  538.              HISTORY := OLD,
  539.              ERROR := CONTINUE);
  540.         if (status(f) <> NULL) then
  541.             begin
  542.             openlist[i].mode := IOAVAIL;
  543.             i := IOERROR;
  544.             fileExists := false
  545.             end
  546.         else
  547.             begin
  548.             reset(f, ERROR := CONTINUE);
  549.             openlist[i].ftype := SBIT;
  550.             end;
  551.         end;
  552.  
  553.     -IOREAD :
  554.         begin
  555.         open(FILE_VARIABLE := binf,
  556.              FILE_NAME := intname,
  557.              RECORD_TYPE := FIXED,
  558.              CARRIAGE_CONTROL := NONE,
  559.              RECORD_LENGTH := 512,
  560.              HISTORY := OLD,
  561.              ERROR := CONTINUE);
  562.         if (status(binf) <> NULL) then
  563.             begin
  564.             openlist[i].mode := IOAVAIL;
  565.             i := IOERROR;
  566.             fileExists := false
  567.             end
  568.         else
  569.             begin
  570.                 reset(binf, ERROR := CONTINUE);
  571.             openlist[i].ftype := EBIT;
  572.             binbuffer := binf^;
  573.             binptr := 1;
  574.             end;
  575.         end;
  576.  
  577.     IOWRITE :
  578.         begin
  579.         open(FILE_VARIABLE := f,
  580.              FILE_NAME := intname,
  581.              RECORD_LENGTH := 255,
  582.              HISTORY := NEW,
  583.              ERROR := CONTINUE);
  584.         if (status(f) <> 0) then
  585.             begin
  586.             openlist[i].mode := IOAVAIL;
  587.             i := IOERROR;
  588.             end
  589.         else
  590.             begin
  591.                 rewrite(f, ERROR := CONTINUE);
  592.             openlist[i].ftype := SBIT;
  593.             end;
  594.         end;
  595.  
  596.     -IOWRITE:
  597.         begin
  598.         open(FILE_VARIABLE := binf,
  599.              FILE_NAME := intname,
  600.              RECORD_TYPE := FIXED,
  601.              CARRIAGE_CONTROL := NONE,
  602.              RECORD_LENGTH := 512,
  603.              HISTORY := NEW,
  604.              ERROR := CONTINUE);
  605.         if (status(binf) <> 0) then
  606.             begin
  607.             openlist[i].mode := IOAVAIL;
  608.             i := IOERROR;
  609.             end
  610.         else
  611.             begin
  612.             rewrite(binf, ERROR := CONTINUE);
  613.             openlist[i].ftype := EBIT;
  614.             end;
  615.         binptr := 1;
  616.         end;
  617.     end;
  618.  
  619. end;
  620.  
  621. begin
  622.     i := 1;
  623.     DebugMessage ('Sopen...            ');
  624.     while (name[i] <> ENDSTR) and (name[i] <> NEWLINE) do
  625.         begin
  626.         intname[i] := chr(name[i]);
  627.         i := i + 1
  628.         end;
  629.  
  630.     for i := i to MAXSTR do
  631.         intname[i] := ' ';      { pad name with blanks  }
  632.  
  633.  
  634.     { find  a free slot in openlist }
  635.     Sopen := IOERROR;
  636.     found := false;
  637.     i := 1;
  638.     while (i <= MAXOPEN) and (not found) do
  639.         begin
  640.         if (openlist[i].mode = IOAVAIL) then
  641.             begin
  642.                 openlist[i].mode := mode;
  643.             case i of
  644.                 1:      { nothing };
  645.                 2:      { nothing };
  646.                 3:      { nothing };
  647.                 4:      Iopen(file4, binfile, file4cnt);
  648.             end;
  649.             Sopen := i;
  650.             found := true
  651.             end;
  652.         i := i + 1
  653.         end
  654. end;
  655.  
  656. function getc (var c : character) : character;
  657. { getc  (UCB) -- get one character from standard input }
  658.  
  659. var 
  660.     ch : char;
  661. begin
  662.     if eof then
  663.     c := ENDFILE
  664.     else if eoln then
  665.     begin
  666.         readln;
  667.         c := NEWLINE
  668.     end
  669.      else
  670.     begin
  671.         read(ch);
  672.         c := ord(ch)
  673.     end;
  674.      getc := c
  675. end;
  676.  
  677.  
  678. function Getcf (var c: character; fd : filedesc) : character;
  679. { getcf  -- get one character from file }
  680.  
  681. var 
  682.     ch : char;
  683.  
  684. procedure Getcfx(VAR f:text);
  685. begin
  686.     if eof(f) then
  687.     c := ENDFILE
  688.     else if eoln(f) then
  689.     begin
  690.         readln(f);
  691.         c := NEWLINE
  692.     end
  693.     else
  694.     begin
  695.         read(f, ch);
  696.         c := ord(ch)
  697.     end;
  698. end;
  699.  
  700. procedure GetBinary(var c : character);
  701. var
  702.     x : packed record
  703.         case boolean of
  704.             true : (c : char);
  705.             false: (i : -128..127);
  706.             end;
  707.     i : integer;
  708. begin
  709.     if binptr > BLKSIZE then
  710.     begin
  711.         get(binfile, ERROR := CONTINUE);
  712.         if eof(binfile) then
  713.         c := ENDFILE
  714.         else
  715.         begin
  716.             binptr := 1;
  717.             binbuffer := binfile^;
  718.             GetBinary(c);
  719.         end;
  720.     end
  721.     else
  722.     begin
  723.         x.c := binbuffer[binptr];
  724.         c := x.i;
  725.         binptr := binptr + 1;
  726.     end;
  727. end;
  728.  
  729. begin
  730.     case fd of
  731.     STDIN :
  732.         Getcf := getc(c);
  733.     STDERR :
  734.         Getcfx(file3);
  735.     4 :
  736.         case openlist[fd].ftype of
  737.         SBIT : Getcfx(file4);
  738.         EBIT : GetBinary(c);
  739.         end;
  740.     LOCALCHAN :
  741.         PutCln('Read of local chan. ', STDERR);
  742.     REMOTECHAN :
  743.         PutCln('Read of remote Chan.', STDERR);
  744.     end;
  745.  
  746.     Getcf := c
  747. end;
  748.  
  749.  
  750. function GetVmsPacket (fd : filedesc) : integer;
  751. {  Function to get a block of text from the incomming channel. }
  752.  
  753. function GetBlockVMS(channel, channelReadFunc : integer) : integer;
  754.  
  755.  
  756. var 
  757.     status : integer;
  758.     info, addrCh, addrIosb : integer;
  759.     ch : char;
  760.     channelTerminator : packed array[1..2] of integer;
  761.     channelIosb : packed array[1..4] of wordInteger;
  762. begin
  763.  
  764.     DebugMessage('GetBlockVMS...      ');
  765.     curBuffPoint := 0;
  766.     timeOutStatus := false;
  767.     channelTerminator[1] := 0;
  768.     channelTerminator[2] := 2**myEol;
  769.     channelReadFunc := channelReadFunc + vmsReadModifer;
  770.  
  771.     status := $QIOW(,%immed (channel),
  772.              %immed (channelReadFunc),
  773.              channelIosb,,,
  774.              vmsReadBuff,
  775.              %immed (VMSBUFSIZE),
  776.              %immed (TheirTimeOut),
  777.              %ref (channelTerminator),,);
  778.  
  779.     if ( not(odd(status)) or  not(odd(channelIosb[1]))) then
  780.     timeOutStatus := true;
  781.  
  782.     GetBlockVms := channelIosb[2] + channelIosb[4];
  783. end;
  784.  
  785. begin
  786.     if (openlist[fd].mode <> IOREAD) then
  787.     begin
  788.         PutCln('Getcf:  mode=IOREAD ', STDERR);
  789.         ProgramHalt;
  790.     end;
  791.     case fd of
  792.     LOCALCHAN: 
  793.         GetVmsPacket := GetBlockVms(localChannel,
  794.                         locReadFunc);
  795.     REMOTECHAN:
  796.         GetVmsPacket := GetBlockVms(remoteChannel,
  797.                         remReadFunc);
  798.     end;
  799. end;
  800.  
  801. procedure FlushTypeAhead(mode : boolean);
  802. { Flush TypeAhead buffer for input line }
  803. begin
  804.     if mode then 
  805.     vmsReadModifer := IO$M_TIMED + IO$M_PURGE
  806.     else
  807.     vmsReadModifer := IO$M_TIMED;
  808. end;
  809.  
  810. procedure PutBinary(c : character);
  811. var
  812.     i : integer;
  813. begin
  814.     if (c = ENDFILE) then
  815.     begin    { Flush the Buffer }
  816.         while (binptr <= BLKSIZE) do
  817.         begin
  818.             binbuffer[binptr] := chr(NULL);
  819.             binptr := binptr + 1;
  820.         end;
  821.         c := NULL;
  822.     end;
  823.     if (binptr > BLKSIZE) then
  824.     begin
  825.         binfile^ := binbuffer;
  826.         put(binfile);
  827.         binptr := 1;
  828.         PutBinary(c);
  829.     end
  830.     else
  831.     begin
  832.         binbuffer[binptr] := chr(c);
  833.         binptr := binptr + 1;
  834.     end;
  835. end;
  836.  
  837.  
  838. procedure Putc (c : character);
  839. { putc  (UCB) -- put one character on standard output }
  840. begin
  841.     if c = NEWLINE then
  842.     writeln
  843.     else
  844.     write(chr(c));
  845. end;
  846.  
  847.  
  848. procedure Putcf (c : character; fd : filedesc);
  849. { putcf  -- put a single character on file fd }
  850.  
  851. procedure Putcfx(var f:text;
  852.          var linelen : integer;
  853.              maxforline :integer);
  854. begin
  855.     linelen := linelen + 1;
  856.     IF (c = NEWLINE) then
  857.     begin
  858.         linelen := 0;
  859.         writeln(f);
  860.     end
  861.     else
  862.     if (linelen > maxforline) then
  863.         begin
  864.         linelen := 1;
  865.         writeln(f);
  866.         write(f, chr(c))
  867.         end
  868.     else
  869.         write(f, chr(c));
  870. end;
  871.  
  872. procedure PutCVMS(    channel, channelWriteFunc : integer;
  873.           var totalChars : integer);
  874.  
  875. var 
  876.     status : integer;
  877.     channelIosb : packed array[1..2] of integer;
  878. begin
  879.     status := $QIOW(,%immed (channel),
  880.              %immed (channelWriteFunc),
  881.              channelIosb,,,
  882.              %ref (vmsWriteBuff),
  883.              %immed (totalChars),,,,);
  884.  
  885.     {  Reset put buffer pointer }
  886.     vmsWritePnt := 0;
  887.  
  888.     if (not(odd(status))) then
  889.     PutCN('PutCVMS : bad qiow  ', status, STDERR);
  890.  
  891. end;
  892.  
  893.  
  894. procedure BufferPutVMS(var  currentPntr : integer;
  895.                 c : character);
  896. {  Buffer the character to be written. }
  897. begin
  898.     vmsWritePnt := vmsWritePnt + 1;
  899.  
  900.     if (vmsWritePnt > VMSBUFSIZE) then
  901.     begin
  902.         FinishUp(true);
  903.         ProgramHalt;
  904.     end;
  905.  
  906.     if (c <> Pad) and (c <> sendEOL) then
  907.         AddTo(ChInPackSend, 1);
  908.  
  909.     vmsWriteBuff[vmsWritePnt] := c;
  910. end;
  911.  
  912.  
  913. begin
  914.     case fd of
  915.     STDOUT :
  916.         Putc(c);
  917.     STDERR :
  918.         Putcfx(file3, file3cnt, STDCHARPERLINE);
  919.     4 :
  920.         case openlist[fd].ftype of
  921.         SBIT : Putcfx(file4, file4cnt, MAXCHARPERLINE);
  922.         EBIT : PutBinary(c);
  923.         end;
  924.     LOCALCHAN : 
  925.         if (vmsWriteFlg) then
  926.         PutcVMS(localChannel, locWriteFunc, vmsWritePnt)
  927.         else
  928.         BufferPutVMS(vmsWritePnt, c);
  929.     REMOTECHAN : 
  930.         if (vmsWriteFlg) then
  931.         PutcVMS(remoteChannel, remWriteFunc, vmsWritePnt)
  932.         else
  933.         BufferPutVMS(vmsWritePnt, c);
  934.     end;
  935. end;
  936.  
  937.  
  938. procedure FlushPutBufferVMS;
  939. {  Flush the put buffer by writing it out to the remote channel. }
  940.  
  941. var 
  942.     c : character;
  943. begin
  944.     vmsWriteFlg := true;
  945.     PutCf(c, LineOut);
  946.     vmsWriteFlg := false;
  947. end;
  948.  
  949.  
  950. procedure PutStr (var s : string; f : filedesc);
  951. { putstr (UCB)  -- put out string on file }
  952.  
  953. var 
  954.     i : integer;
  955. begin
  956.     i := 1;
  957.     while (s[i] <> ENDSTR) do
  958.     begin
  959.         Putcf(s[i], f);
  960.         i := i + 1
  961.     end
  962. end;
  963.  
  964.  
  965. procedure Sclose (var fd : filedesc);
  966. {  Close a File descriptor }
  967. var  
  968.    DeleteOnClose : boolean;  
  969. begin
  970.     if (fd > STDERR) and (fd <= MAXOPEN) then
  971.     begin
  972.  
  973.         { Check if file received was OK }             
  974.  
  975.         DeleteOnClose :=  ( abs(openlist[fd].mode) = IOWRITE) and     
  976.                 (not TransferOK); 
  977.  
  978.         case fd of
  979.         1:      { nothing };
  980.         2:      { nothing };
  981.         3:
  982.             close(file3, ERROR := CONTINUE);
  983.         4:
  984.             case openlist[fd].ftype of
  985.             SBIT : 
  986.                 if DeleteOnClose then 
  987.                 close(file4, DISPOSITION := DELETE,
  988.                     ERROR := CONTINUE)
  989.                 else                    
  990.                 close(file4, ERROR := CONTINUE);
  991.             EBIT :
  992.                 begin
  993.                 if (openlist[fd].mode = -IOWRITE) then
  994.                     PutBinary(ENDFILE);
  995.                 if DeleteOnClose then 
  996.                     close(binfile, DISPOSITION := DELETE,
  997.                         ERROR := CONTINUE)
  998.                 else
  999.                     close(binfile, ERROR := CONTINUE);
  1000.                 end;
  1001.             end;
  1002.         end;
  1003.         openlist[fd].mode := IOAVAIL;
  1004.         end;
  1005.     fd := IOERROR;
  1006. end;
  1007.  
  1008.  
  1009. function ItoC (n : integer; var s : string; i : integer)
  1010.         : integer;      { returns end of s }
  1011. { ItoC  - convert integer n to char string in s[i]... }
  1012. begin
  1013.     if (n < 0) then
  1014.     begin
  1015.         s[i] := ord('-');
  1016.         ItoC := ItoC(-n, s, i+1)
  1017.     end
  1018.     else
  1019.     begin
  1020.         if (n >= 10) then
  1021.         i := ItoC(n div 10, s, i);
  1022.         s[i] := n mod 10 + ord('0');
  1023.         s[i+1] := ENDSTR;
  1024.         ItoC := i + 1
  1025.     end
  1026. end;
  1027.  
  1028.  
  1029. function LengthSTIP (var s : string) : integer;
  1030. { lengthSTIP -- compute length of string }
  1031.  
  1032. var 
  1033.     n : integer;
  1034. begin
  1035.     n := 1;
  1036.     while (s[n] <> ENDSTR) do
  1037.     n := n + 1;
  1038.     LengthSTIP := n - 1
  1039. end;
  1040.  
  1041.  
  1042. procedure Scopy (var src : string; i : integer;
  1043.          var dest : string; j : integer);
  1044. { scopy -- copy string  at src[i] to dest[j] }
  1045. begin
  1046.     while (src[i] <> ENDSTR) do
  1047.     begin
  1048.         dest[j] := src[i];
  1049.         i := i + 1;
  1050.         j := j + 1
  1051.     end;
  1052.     dest[j] := ENDSTR
  1053. end;
  1054.  
  1055.  
  1056. function IsUpper (c : character) : boolean;
  1057. { isupper -- true if c  is upper case letter }
  1058. begin
  1059.     isupper := (c >= ord('A')) and (c <= ord('Z'))
  1060. end;
  1061.  
  1062.  
  1063. function IndexSTIP (var s : string; c : character) : integer;
  1064. { IndexSTIP -- find position of character c in string s }
  1065.  
  1066. var 
  1067.     i : integer;
  1068. begin
  1069.     i := 1;
  1070.     while (s[i] <> c) and (s[i] <> ENDSTR) do
  1071.     i := i + 1;
  1072.     if (s[i] = ENDSTR) then
  1073.     IndexSTIP := 0
  1074.      else
  1075.     IndexSTIP := i
  1076. end;
  1077.  
  1078.  
  1079. procedure CtoS( x:cstring;  var s:string);
  1080. { convert constant to STIP string }
  1081.  
  1082. var 
  1083.     i : integer;
  1084. begin
  1085.     for i:=1 to CONLENGTH do
  1086.     s[i] := ord(x[i]);
  1087.     s[CONLENGTH+1] := ENDSTR;
  1088. end;
  1089.  
  1090.  
  1091. function Exists( s:string):  boolean;
  1092. { returns true  if file exists }
  1093.  
  1094. var 
  1095.     fd:  filedesc;
  1096.     result: boolean;
  1097.     temp : character;
  1098.     dummy: boolean;
  1099. begin
  1100.     DebugMessage ('Exists...           ');
  1101.     fileExists := true;
  1102.     fd   := Sopen(s,IOREAD*binascflg);
  1103.     Sclose(fd);
  1104.     Exists := fileExists;
  1105. end;
  1106.  
  1107.  
  1108. procedure PutCon( x:cstring;
  1109.            fd:filedesc);
  1110. { output literal }
  1111. var 
  1112.     s: string;
  1113. begin
  1114.     CtoS(x,s);
  1115.     PutStr(s,fd);
  1116. end;
  1117.  
  1118.  
  1119. procedure PutCln;
  1120. { output literal followed by NEWLINE }
  1121. begin
  1122.     PutCon(x,fd);
  1123.     Putcf(NEWLINE,fd);
  1124. end;
  1125.  
  1126.  
  1127. procedure PutNum( n:integer;
  1128.           fd:filedesc);
  1129. { Ouput number  }
  1130.  
  1131. var 
  1132.     s: string;
  1133.     dummy: integer;
  1134. begin
  1135.     s[1] := BLANK;
  1136.     dummy := ItoC(n,s,2);
  1137.     PutStr(s,fd);
  1138. end;
  1139.  
  1140.  
  1141. procedure PutCS( x:cstring;
  1142.          s : string;
  1143.          fd:filedesc);
  1144. { output literal & string }
  1145. begin
  1146.     PutCon(x,fd);
  1147.     PutStr(s,fd);
  1148.     Putcf(NEWLINE,fd);
  1149. end;
  1150.  
  1151.  
  1152. procedure PutCN;
  1153. { output literal & number }
  1154. begin
  1155.     PutCon(x,fd);
  1156.     PutNum(v,fd);
  1157.     Putcf(NEWLINE,fd);
  1158. end;
  1159.  
  1160.  
  1161. procedure AddTo;
  1162. begin
  1163.     sum := sum + inc;
  1164. end;
  1165.  
  1166.  
  1167. procedure OverHd( p,f: Stats;
  1168.           var o:integer);
  1169. { Calculate OverHead as % }
  1170. { 0verHead := (p-f)*100/f }
  1171. begin
  1172.     if (f <> 0) then
  1173.     o := ((p - f)*100) div f
  1174.     else
  1175.     o := 100;
  1176. end;
  1177.  
  1178.  
  1179. procedure CalRat( f:   Stats;
  1180.           t:integer;
  1181.           var r:integer);
  1182. { Calculate Effective Baud Rate }
  1183. { Rate  = f*10/t }
  1184. begin
  1185.     if (t <> 0) then
  1186.     r := (f * 10) div t
  1187.     else
  1188.     r := 0;
  1189. end;
  1190.  
  1191.  
  1192. procedure BadVTerminalConnect;
  1193. { Inform user that connection was not valid. }
  1194. begin
  1195.     PutCon(' ? VTerm Connection ',ControlOUT);
  1196.     PutCln('not established     ',ControlOUT);
  1197. end;
  1198.  
  1199.  
  1200. procedure DebugMessage;
  1201. { Print writeln if debug }
  1202. begin
  1203.     if debug then
  1204.     Putcln(c,STDERR);
  1205. end;
  1206.  
  1207.  
  1208. procedure DebugMessNumb(s : cstring; val : integer);
  1209. { Print message and a number }
  1210. begin
  1211.     if debug then
  1212.     begin
  1213.         Putcln(s, STDERR);
  1214.         PutNum(val, STDERR);
  1215.     end;
  1216. end;
  1217.  
  1218.  
  1219. procedure CopyStringVMS(var fileSpec : string80;
  1220.             var newFile : string);
  1221. {  System dependent procedure to copy a VMS string to a STIP string }
  1222.  
  1223. var 
  1224.     tempFile : cstring;
  1225.     i : integer;
  1226. begin
  1227.     tempFile := '                    ';
  1228.     for i:=1 to CONLENGTH do
  1229.     tempFile[i] := fileSpec[i];
  1230.     CtoS(tempFile, newFile);
  1231. end;
  1232.  
  1233.  
  1234. procedure CheckTypeAhead(var consoleChar : InType);
  1235.  
  1236. const 
  1237.       ABORTCONs = 'a';
  1238.       ABORTCONL = 'A';
  1239.  
  1240. type 
  1241.  
  1242.      $UBYTE = [byte] 0..255;
  1243.      $WORD =  [word] -32768..32767;
  1244.      blotto = [unsafe] array[1..500] of $UBYTE;
  1245.      typeAhead = packed record
  1246.                 case boolean of
  1247.                 true : ( a : blotto);
  1248.                 false: ( b : [unsafe] array[1..250] of $WORD);
  1249.                end;
  1250.  
  1251. var 
  1252.     infoTypeAhead : typeAhead;
  1253.     blottoreal : blotto;
  1254.     statqiow, sensemode, i, typeAheadCnt : integer;
  1255.     tempChar : character;
  1256.  
  1257. begin
  1258.  
  1259.     consoleChar := nothing;
  1260.  
  1261.     sensemode := io$_sensemode + io$m_typeahdcnt;
  1262.     statqiow := $qiow(,
  1263.                localChannel,
  1264.                sensemode,,,,
  1265.                blottoreal,,,,,);
  1266.  
  1267.     for i:=1 to 8 do
  1268.     infoTypeAhead.a[i] := blottoreal[i];
  1269.  
  1270.     typeAheadCnt := infoTypeAhead.b[1];
  1271.  
  1272.     if (typeAheadCnt > 0) then
  1273.     begin
  1274.         statqiow := $qiow(,
  1275.                    localChannel,
  1276.                    locReadFunc,,,,
  1277.                    blottoreal,
  1278.                    typeAheadCnt,,,,);
  1279.         tempChar := blottoreal[1];
  1280.         if ((tempChar = ord(ABORTCONs)) or (tempChar = ord(ABORTCONL))) then
  1281.         begin
  1282.             consoleChar := abortnow;
  1283.             if (local) then
  1284.             PutCln('Aborting Transfer   ', STDERR)
  1285.         end
  1286.         else if (tempChar = CR) then
  1287.         begin
  1288.             consoleChar := CRin;
  1289.             if (local)
  1290.             then
  1291.                 PutCln('Resending Packet    ', STDERR)
  1292.         end;
  1293.     end;
  1294.  
  1295. end;
  1296.  
  1297.  
  1298. procedure ClockVMS(var timeState : timeArray);
  1299. {  System dependent routine to obtain clock time from VMS. }
  1300.  
  1301. var 
  1302.     status : integer;
  1303. begin
  1304.     status := $gettim(timeState);
  1305.     if (status <> ss$_normal) then
  1306.     PutCN('Bad sys$gettim      ',status, STDERR);
  1307.  
  1308. end;
  1309.  
  1310.  
  1311. function TotalRunTimeVMS(startTime, endTime : timeArray) : integer;
  1312. {  Calculate the total runtime for the transfer }
  1313.  
  1314. var 
  1315.     tempTime3 : timeArray;
  1316.     status, i, quotient, remainder, million : integer;
  1317. begin
  1318.  
  1319.     status := $Subx(endTime, startTime, tempTime3);
  1320.     if (status <> ss$_normal) then
  1321.     PutCN('Bad multi-add $addx ',status, STDERR);
  1322.  
  1323.     million := 10000000;
  1324.     status := $ediv(million, tempTime3, quotient, remainder);
  1325.     if (status <> ss$_normal) then
  1326.     PutCN('Bad multi-div $ediv ', status, STDERR);
  1327.  
  1328.     TotalRunTimeVMS := quotient;
  1329. end;
  1330.  
  1331.  
  1332. procedure SleepVMS( t:integer);   { pause for t seconds }
  1333. {  System Dependent routine for VMS }
  1334.  
  1335. type 
  1336.     { Data TYPES for VMS dependent code }
  1337.      $quad = [quad,unsafe] record
  1338.                    l0 : unsigned;
  1339.                    l1 : integer;
  1340.               end;
  1341.  
  1342. var 
  1343.     sleepLength : vmsString;
  1344.     timConvert : string;
  1345.     endPos, status, i : integer;
  1346.     binaryTime : $quad;
  1347.     kludgechar : char;
  1348.  
  1349. begin
  1350.     DebugMessage('Sleep...            ');
  1351.     sleepLength := '0 00:0';
  1352.     if ( (t mod 60) = 1) then
  1353.     begin
  1354.         sleepLength := sleepLength+'1:';
  1355.         t := t rem 60;
  1356.     end
  1357.     else
  1358.     sleepLength := sleepLength+'0:';
  1359.  
  1360.     endPos := ItoC(t, timConvert, 1);
  1361.  
  1362.     if (endPos = 2) then
  1363.     sleepLength := sleepLength+'0';
  1364.  
  1365.     for i:=1 to (endPos-1) do
  1366.     begin
  1367.         kludgechar := chr(timConvert[i]);
  1368.         sleepLength := sleepLength+kludgechar;
  1369.     end;
  1370.  
  1371.     status := $BINTIM(sleepLength, binaryTime);
  1372.     if (not(odd(status)) and (local)) then
  1373.     PutCln('Sleep: Illegal time ', STDERR);
  1374.  
  1375.     status := $SETIMR(SleepEFN, binaryTime);
  1376.     if (not(odd(status)) and (local)) then
  1377.     PutCln('Sleep: Bad set time ', STDERR);
  1378.  
  1379.     status := $WAITFR(SleepEFN);
  1380.     if (not(odd(status)) and (local)) then
  1381.     PutCln('Sleep : Hibernation ', STDERR);
  1382.  
  1383. end;
  1384.  
  1385.  
  1386. procedure PutPacket( p : Ppack); { Output Packet }
  1387.  
  1388. var 
  1389.     i : integer;
  1390. begin
  1391.     DebugMessage('PutPacket...        ');
  1392.     if (Pad >0) then
  1393.     for i := 1 to Pad do
  1394.         Putcf(PadChar,LineOut);
  1395.      with p^ do
  1396.      begin
  1397.          Putcf(mark,LineOut);
  1398.          Putcf(count,LineOut);
  1399.          Putcf(seq,LineOut);
  1400.          Putcf(ptype,LineOut);
  1401.          PutStr(data,LineOut);
  1402.      end;
  1403.  
  1404.      FlushPutBufferVMS;
  1405. end;
  1406.  
  1407.  
  1408. function GetIn  : character;  { get character    }
  1409. { Should return NULL ( ENDSTR ) if  no characters }
  1410.  
  1411. var 
  1412.     c : character;
  1413. begin
  1414.     curBuffPoint := curBuffPoint + 1;
  1415.  
  1416.     if (curBuffPoint <= vmsChRead) then
  1417.     c := vmsReadBuff[curBuffPoint]
  1418.     else
  1419.     c := ENDOFQIO;
  1420.     GetIn := c;
  1421.     if (c <> NULL) then
  1422.         AddTo(ChInPackRecv,1)
  1423. end;
  1424.  
  1425.  
  1426. function MakeChar(   c:character):  character;
  1427. { convert integer to printable }
  1428. begin
  1429.     MakeChar := c+BLANK;
  1430. end;
  1431.  
  1432.  
  1433. function UnChar( c:character):  character;
  1434. { reverse of makechar }
  1435. begin
  1436.     UnChar := c - BLANK
  1437. end;
  1438.  
  1439.  
  1440. function IsControl( c:character):  boolean;
  1441. { true if control }
  1442. begin
  1443.     if (c >= NULL) then
  1444.     IsControl := (c = DEL ) or (c < BLANK )
  1445.     else
  1446.     IsControl := IsControl(c + 128);
  1447. end;
  1448.  
  1449.  
  1450. function Ctl( c:character):  character;
  1451. { c XOR 100 }
  1452. begin
  1453.     if (c >= NULL) then
  1454.     if (c < 64) then
  1455.         c := c + 64
  1456.     else
  1457.         c := c-64
  1458.     else
  1459.     c := Ctl(c + 128) - 128;
  1460.  
  1461.     Ctl := c;
  1462. end;
  1463.  
  1464.  
  1465. function Checkfunction( c:integer):  character;
  1466. { calculate checksum }
  1467.  
  1468. var 
  1469.     x: integer;
  1470. begin
  1471.     DebugMessage('Checkfunction...    ');
  1472.     {    Checkfunction := (c + ( c and 300 ) /100 ) and 77; }
  1473.     x := (c MOD 256 ) DIV 64;
  1474.     x := x+c;
  1475.     Checkfunction := x MOD 64;
  1476. end;
  1477.  
  1478.  
  1479. procedure SetEBQuoteState;
  1480. begin
  1481.     if (EBQState = Binary) then
  1482.     begin
  1483.         transType := oBINARY;
  1484.         binascflg := oBINSTATE;
  1485.     end
  1486.     else
  1487.     begin
  1488.         transType := oASCII;
  1489.         binascflg := oASCSTATE;
  1490.     end;
  1491. end;
  1492.  
  1493.  
  1494. procedure EnCodeParm( var data:string);    { encode parameters }
  1495.  
  1496. var 
  1497.     i: integer;
  1498. begin
  1499.     DebugMessage('EnCodeParm...       ');
  1500.     for i:=1 to NUMPARAM do
  1501.     data[i] := BLANK;
  1502.     data[NUMPARAM+1] := ENDSTR;
  1503.     data[1] := MakeChar(SizeRecv);          { my  biggest packet }
  1504.     data[2] := MakeChar(MyTimeOut);         { when I want timeout}
  1505.     data[3] := MakeChar(MyPad);             { how much padding }
  1506.     data[4] := Ctl(MyPadChar);              { my padding character }
  1507.     data[5] := MakeChar(myEOL);             { my EOL }
  1508.     data[6] := MyQuote;                     { my quote char }
  1509.  
  1510.     { Handle eight bit quoting parm }
  1511.     case RunType of
  1512.     Transmit :
  1513.         if EBQState = Binary then
  1514.         begin
  1515.             if EBQChar <> DEFEBQUOTE then
  1516.             begin
  1517.                 data[7] := EBQChar;
  1518.                 sentEBQuote := true;
  1519.             end
  1520.             else
  1521.             data[7] := TYPEY;
  1522.         end
  1523.         else
  1524.         data[7] := TYPEN;
  1525.  
  1526.     Receive :
  1527.         if EBQState = Binary then
  1528.         begin
  1529.             if recvdEBQuote then
  1530.             data[7] := TYPEY
  1531.             else if needEBQuote then
  1532.             data[7] := EBQChar
  1533.             else
  1534.             begin
  1535.                 EBQState := Ascii;
  1536.                 data[7] := TYPEN;
  1537.             end;
  1538.         end
  1539.         else
  1540.         data[7] := TYPEN;
  1541.     end;
  1542.  
  1543.     SetEBQuoteState;
  1544.  
  1545. end;
  1546.  
  1547.  
  1548. function CheckEBQuote(    inchr : character;
  1549.               var outchr : character) : EBQtype;
  1550. begin
  1551.     if (inchr in [EXMARK..RABRACK, GRAVE..TILDE]) then
  1552.     begin
  1553.         outchr := inchr;
  1554.         CheckEBQuote := Binary
  1555.     end
  1556.     else
  1557.     CheckEBQuote := Ascii;
  1558. end;
  1559.  
  1560.  
  1561. procedure DeCodeParm( var data:string); {   decode parameters }
  1562. var
  1563.     InEBQChar : character;
  1564.     i,l : integer;
  1565. begin
  1566.     DebugMessage('DeCodeParm...       ');
  1567.     { Pad with blanks }
  1568.     l := lengthSTIP(data);
  1569.     IF l < NUMPARAM
  1570.       THEN    
  1571.     FOR i := l + 1 TO NUMPARAM DO
  1572.         data[i] := BLANK;
  1573.     data[NUMPARAM+1] := ENDSTR;
  1574.  
  1575.     SizeSend := UnChar(data[1]);
  1576.     TheirTimeOut := UnChar(data[2]);   { when I should time  out }
  1577.     Pad := UnChar(data[3]);            { padding characters  to send  }
  1578.     PadChar := Ctl(data[4]);           { padding character }
  1579.     SendEOL := UnChar(data[5]);        { EOL to send }
  1580.     SendQuote := data[6];              { quote to send }
  1581.  
  1582.     { Handle eight bit quoting parm }
  1583.     InEBQchar := data[7];
  1584.     case RunType of
  1585.     Transmit :
  1586.         if EBQState = Binary then
  1587.         begin
  1588.             if sentEBQuote then
  1589.             begin
  1590.                 if InEBQchar <> TYPEY then
  1591.                 EBQState := Ascii;
  1592.             end
  1593.             else if InEBQchar = TYPEN then
  1594.             EBQState := Ascii
  1595.             else
  1596.             EBQState := CheckEBQuote(InEBQchar, EBQchar);
  1597.         end;
  1598.  
  1599.     Receive :
  1600.         if EBQState = Binary then
  1601.         begin
  1602.             if InEBQchar = TYPEY then
  1603.             needEBQuote := true
  1604.             else if InEBQchar = TYPEN then
  1605.             EBQState := Ascii
  1606.             else
  1607.             begin
  1608.                 EBQState := CheckEBQuote(InEBQchar, EBQchar);
  1609.                 if EBQState = Binary then
  1610.                 recvdEBQuote := true;
  1611.             end;
  1612.         end;
  1613.     end;
  1614.  
  1615.     SetEBQuoteState;
  1616.  
  1617. end;
  1618.  
  1619.  
  1620. procedure StartRun; { initialization as necessary }
  1621. begin
  1622.     DebugMessage('StartRun...         ');
  1623.     ClockVMS(startTime);
  1624.  
  1625.     NumSendPacks := 0;
  1626.     NumRecvPacks := 0;
  1627.     NumACK := 0;
  1628.     NumNAK := 0;
  1629.     NumACKrecv := 0;
  1630.     NumNAKrecv := 0;
  1631.     NumBADrecv := 0;
  1632.  
  1633.     ChInFileRecv := 0;
  1634.     ChInFileSend := 0;
  1635.     ChInPackRecv := 0;
  1636.     ChInPackSend := 0;
  1637.  
  1638.     RunTime := 0;
  1639.  
  1640.     vmsWritePnt := 0;
  1641.     vmsWriteFlg := false;
  1642.     FlushTypeAhead(false);
  1643.     
  1644.     State := Init;              { send  initiate is the start state }
  1645.     NumTry := 0;                { say no tries  yet }
  1646. end;
  1647.  
  1648.  
  1649. procedure OpenPortVMS;
  1650.  
  1651. var 
  1652.     status : integer;
  1653. begin
  1654.     vTermSetType := LOCALREMOTE;
  1655.  
  1656.     LineIN := REMOTECHAN;
  1657.     LineOUT := REMOTECHAN;
  1658.     openlist[LINEIN].mode := IOREAD;
  1659.     openList[LINEOUT].mode := IOREAD;
  1660.  
  1661.     status := ss$_normal;
  1662.     SetUpVirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
  1663.              localChannel, locReadFunc, locWriteFunc,
  1664.              status, vTermSetType, localEcho, parity, lSpeed);
  1665.     if (status <> ss$_normal) then
  1666.         invalidConnection := true;
  1667. end;
  1668.  
  1669.  
  1670. procedure VirtualTerminal(var remChanl : integer;
  1671.               var remRFunc : integer;
  1672.               var remWFunc : integer;
  1673.               var locChanl : integer;
  1674.               var locRFunc : integer;
  1675.               var locWFunc : integer;
  1676.               var conStatus : boolean ) ;
  1677. fortran;
  1678.  
  1679.  
  1680. procedure ConnectVMS;
  1681. { System Dependent connect to remote }
  1682. begin
  1683.     VirtualTerminal(remoteChannel, remReadFunc, remWriteFunc,
  1684.             localChannel, locReadFunc, locWriteFunc,
  1685.             invalidConnection);
  1686. end;
  1687.  
  1688.  
  1689. procedure ResetKermitPacketNumber;
  1690. begin
  1691.     n := 0;
  1692. end;
  1693.  
  1694.  
  1695. procedure KermitInit;  { initialize various parameters  & defaults }
  1696. begin
  1697.     DebugMessage('KermitInit...       ');
  1698.  
  1699.     Pad := DEFPAD;               { set defaults }
  1700.     MyPad := DEFPAD;
  1701.     PadChar := DEFPADCHAR;
  1702.     MyPadChar := DEFPADCHAR;
  1703.     TheirTimeOut := DEFTIMEOUT;
  1704.     MyTimeOut := DEFTIMEOUT;
  1705.     Delay := DEFDELAY;
  1706.     SizeRecv := MAXPACK;
  1707.     SizeSend := MAXPACK;
  1708.     SendEOL := DEFEOL;
  1709.     MyEOL := DEFEOL;
  1710.     SendQuote := DEFQUOTE;
  1711.     MyQuote := DEFQUOTE;
  1712.     EBQChar := DEFEBQUOTE;
  1713.     MaxTry := DEFITRY;
  1714.  
  1715.     localEcho := oOFF;
  1716.     parity := oNONE;
  1717.     lSpeed := o4800BAUD;
  1718.     fileEol := oCLF;
  1719.     transtype := oASCII;
  1720.     binascflg := oASCSTATE;
  1721.     lastFile := false;
  1722.     Local := false;      { default to remote }
  1723.  
  1724.     Debug := false;
  1725.     debugging := oOFF;
  1726.     Runtype := invalid;
  1727.  
  1728.     DiskFile := IOERROR;      { to indicate  not open yet }
  1729.     LineIN := LOCALCHAN;
  1730.     LineOUT := LOCALCHAN;
  1731.     ControlIN := STDIN;
  1732.     ControlOUT := STDOUT;
  1733.  
  1734.     new(ThisPacket);
  1735.     new(LastPacket);
  1736.     new(CurrentPacket);
  1737.     new(NextPacket);
  1738.     new(InputPacket);
  1739. end;
  1740.  
  1741.  
  1742. procedure FinishUp;
  1743. { do any  end of transmission clean up }
  1744. begin
  1745.     DebugMessage('FinishUp...         ');
  1746.  
  1747.     Sclose(DiskFile);
  1748.  
  1749.     ClockVMS(endTime);
  1750.     if not(noErrors) then
  1751.     RunTime := TotalRunTimeVMS(startTime, endTime)
  1752.     else
  1753.     begin
  1754.         ErrorPack('Aborting Transfer   ');
  1755.         RunTime := 0;
  1756.     end;
  1757.  
  1758.     oldRunType := RunType;
  1759.     lastFile := false;
  1760.     PutCf(NEWLINE, ControlOUT);
  1761.  
  1762. end;
  1763.  
  1764.  
  1765. procedure DebugPacket(    mes : cstring;
  1766.             var p : Ppack);
  1767. { Print Debugging Info }
  1768. begin
  1769.     DebugMessage('DebugPacket...      ');
  1770.     PutCon(mes,STDERR);
  1771.     with p^ do
  1772.     begin
  1773.         PutNum(Unchar(count),STDERR);
  1774.         PutNum(Unchar(seq),STDERR);
  1775.         Putcf(BLANK,STDERR);
  1776.         Putcf(ptype,STDERR);
  1777.         Putcf(NEWLINE,STDERR);
  1778.         PutStr(data,STDERR);
  1779.         Putcf(NEWLINE,STDERR);
  1780.     end;
  1781. end;
  1782.  
  1783.  
  1784. procedure ReSendPacket;
  1785. { re -sends previous packet }
  1786. begin
  1787.     DebugMessage('ReSendPacket...     ');
  1788.     NumSendPacks := NumSendPacks+1;
  1789.     if Debug then
  1790.     DebugPacket('Re-Sending ...      ',LastPacket);
  1791.     PutPacket(LastPacket);
  1792. end;
  1793.  
  1794.  
  1795. procedure SendPacket;
  1796. { expects count as  length of data portion }
  1797. { and seq as number of packet }
  1798. { builds &  sends packet }
  1799.  
  1800. var 
  1801.     i,len,chksum : integer;
  1802.     temp : Ppack;
  1803. begin
  1804.     DebugMessage('Sending Packet      ');
  1805.     if (NumTry <> 1) and (Runtype = Transmit ) then
  1806.     ReSendPacket
  1807.     else
  1808.     begin
  1809.         with ThisPacket^ do
  1810.         begin
  1811.             mark := SOH;               { mark }
  1812.             len := count;             {  save length }
  1813.             count := MakeChar(len+3); {  count = 3+length of data }
  1814.             seq := MakeChar(seq);     {  seq number }
  1815.             chksum := count + seq + ptype;
  1816.             if ( len > 0) then      { is there data ? }
  1817.             for i:= 1 to len do
  1818.                 if (data[i] >= 0) then
  1819.                 chksum := chksum + data[i]  { loop for data }
  1820.                 else
  1821.                 chksum := chksum + data[i] + 256;
  1822.             chksum := Checkfunction(chksum);  {  calculate  checksum }
  1823.             data[len+1] := MakeChar(chksum);  {  make printable & output }
  1824.             data[len+2] := SendEOL;           { EOL }
  1825.             data[len+3] := ENDSTR;
  1826.         end;
  1827.  
  1828.         NumSendPacks := NumSendPacks+1;
  1829.         if Debug then
  1830.         DebugPacket('Sending ...         ',ThisPacket);
  1831.         PutPacket(ThisPacket);
  1832.  
  1833.         if Runtype = Transmit then
  1834.         begin
  1835.             temp := LastPacket;
  1836.             LastPacket := ThisPacket;
  1837.             ThisPacket := temp;
  1838.         end;
  1839.     end;
  1840. end;
  1841.  
  1842.  
  1843. procedure SendACK(   n:integer); { send ACK  packet }
  1844. begin
  1845.     DebugMessage('SendAck...          ');
  1846.     with ThisPacket^ do
  1847.     begin
  1848.         count := 0;
  1849.         seq := n;
  1850.         ptype := TYPEY;
  1851.     end;
  1852.     SendPacket;
  1853.     NumACK := NumACK+1;
  1854. end;
  1855.  
  1856. procedure SendNAK(   n:integer); { send NAK  packet }
  1857. begin
  1858.     DebugMessage('SendNAK...          ');
  1859.     with ThisPacket^ do
  1860.     begin
  1861.         count := 0;
  1862.         seq := n;
  1863.         ptype := TYPEN;
  1864.     end;
  1865.     SendPacket;
  1866.     NumNAK := NumNAK+1;
  1867. end;
  1868.  
  1869.  
  1870. procedure ErrorPack;
  1871. { output Error packet if remote or print message if local }
  1872. var 
  1873.   i : integer;
  1874. begin
  1875.     DebugMessage('ErrorPack...        ');
  1876.     with ThisPacket^ do
  1877.     begin
  1878.         seq := n;
  1879.         ptype := TYPEE;
  1880.         if local then     
  1881.                 CtoS('Kermit:             ',data)
  1882.             else
  1883.         CtoS('Remote Kermit:      ',data);
  1884.         for i := 1 to CONLENGTH do    
  1885.         data[CONLENGTH + i] := ord(c[i]);
  1886.         data[CONLENGTH + CONLENGTH + 1] := ENDSTR;
  1887.         count := LengthSTIP(data);
  1888.  
  1889.         if local then 
  1890.         begin
  1891.            putstr(data,STDERR);
  1892.            putcf(NEWLINE,STDERR);
  1893.         end    
  1894.             else
  1895.         SendPacket;
  1896.     end;
  1897. end;
  1898.  
  1899.  
  1900. procedure PutErr( c:cstring);
  1901. { Print error_messages }
  1902. begin
  1903.     DebugMessage('PutErr...           ');
  1904.     if Local then
  1905.     Putcln(c,STDERR);
  1906. end;
  1907.  
  1908.  
  1909. procedure Field1; { Count }
  1910.  
  1911. var 
  1912.     test: boolean;
  1913. begin
  1914.     DebugMessage('Field1...           ');
  1915.     with NextPacket^ do
  1916.     begin
  1917.         InputPacket^.count := t;
  1918.         count := UnChar(t);
  1919.         test := (count >= 3) or (count <= SizeRecv-2);
  1920.         if not test then
  1921.         DebugMessage('Bad count           ');
  1922.         isgood := isgood and test;
  1923.     end;
  1924. end;
  1925.  
  1926.  
  1927. procedure Field2; { Packet Number }
  1928.  
  1929. var 
  1930.     test : boolean;
  1931. begin
  1932.     DebugMessage('Field2...           ');
  1933.     with NextPacket^ do
  1934.     begin
  1935.         InputPacket^.seq := t;
  1936.         seq := UnChar(t);
  1937.         test := (seq >= 0) or (seq <= 63);
  1938.         if not test then
  1939.         DebugMessage('Bad seq number      ');
  1940.         isgood := isgood and test;
  1941.     end;
  1942. end;
  1943.  
  1944.  
  1945. procedure Field3; { Packet type }
  1946.  
  1947. var 
  1948.     test : boolean;
  1949. begin
  1950.     DebugMessage('Field3...           ');
  1951.     with NextPacket^ do
  1952.     begin
  1953.         ptype := t;
  1954.         InputPacket^.ptype := t;
  1955.  
  1956.         test := (t =TYPEB) or (t=TYPED) or (t=TYPEE) or (t=TYPEF)
  1957.             or (t=TYPEN) or (t=TYPES) or (t=TYPEY) or (t=TYPEZ);
  1958.         if not test then
  1959.         DebugMessage('Bad Packet type     ');
  1960.         isgood := isgood and test;
  1961.     end;
  1962. end;
  1963.  
  1964.  
  1965. procedure ProcessQuoted; { for data }
  1966. begin
  1967.     with NextPacket^ do
  1968.     begin
  1969.         if (t = MyQuote) or ((t = EBQchar) and (EBQState = Binary)) then
  1970.         begin
  1971.             if control then
  1972.             begin
  1973.                 data[dataptr] := t + ishigh;
  1974.                 dataptr := dataptr + 1;
  1975.                 control := false;
  1976.                 ishigh := 0;
  1977.             end
  1978.             else if (t = MyQuote) then { Set Control on }
  1979.             control := true;
  1980.         end
  1981.         else if control then
  1982.         begin
  1983.             data[dataptr] := ctl(t) + ishigh;
  1984.             dataptr := dataptr + 1;
  1985.             control := false;
  1986.             ishigh := 0;
  1987.         end
  1988.         else
  1989.         begin
  1990.             data[dataptr] := t + ishigh;
  1991.             dataptr := dataptr + 1;
  1992.             ishigh := 0;
  1993.         end;
  1994.     end;
  1995. end;
  1996.  
  1997.  
  1998. procedure Field4; { Data }
  1999. begin
  2000.     PacketPtr := PacketPtr+1;
  2001.     InputPacket^.data[PacketPtr] := t;
  2002.  
  2003.     with NextPacket^ do
  2004.     begin
  2005.         if ((pType = TYPES) or (pType = TYPEY)) then
  2006.         begin
  2007.             data[dataptr] := t;
  2008.             dataptr := dataptr+1;
  2009.         end
  2010.         else
  2011.         begin
  2012.             if (EBQstate = Binary) then
  2013.             begin { Has it been quoted }
  2014.                 if (not(control) and (t = EBQchar)) then
  2015.                 ishigh := 128
  2016.                 else
  2017.                 ProcessQuoted;
  2018.             end
  2019.             else
  2020.             ProcessQuoted;
  2021.         end;
  2022.     end;
  2023. end;
  2024.  
  2025.  
  2026. procedure Field5; { Check Sum }
  2027.  
  2028. var 
  2029.     test : boolean;
  2030. begin
  2031.     DebugMessage('Field5...           ');
  2032.     with InputPacket^ do
  2033.     begin
  2034.         PacketPtr := PacketPtr +1;
  2035.         data[PacketPtr] := t;
  2036.         PacketPtr := PacketPtr +1;
  2037.         data[PacketPtr] := ENDSTR;
  2038.     end;
  2039.     {  end of input string }
  2040.     check := Checkfunction(check);
  2041.     check := MakeChar(check);
  2042.     test := (t=check);
  2043.     if not test then
  2044.     DebugMessNumb('Bad CheckSum=       ', check);
  2045.     isgood := isgood and test;
  2046.     NextPacket^.data[dataptr] := ENDSTR;
  2047.     {  end of data string }
  2048.     finished := true;  { set finished }
  2049. end;
  2050.  
  2051.  
  2052. procedure BuildPacket;
  2053. { receive packet &  validate checksum }
  2054.  
  2055. var 
  2056.     temp : Ppack;
  2057. begin
  2058.     with NextPacket^ do
  2059.     begin
  2060.         if restart then
  2061.         begin
  2062.             { read until get SOH marker }
  2063.             if  (t = SOH) then
  2064.             begin
  2065.                 finished := false;    { set varibles }
  2066.                 control := false;
  2067.                 ishigh := 0;      { no shift }
  2068.                 isgood := true;
  2069.                 seq := -1;       { set return values to  bad packet }
  2070.                 ptype := QUESTION;
  2071.                 data[1] := ENDSTR;
  2072.                 data[MAXSTR] := ENDSTR;
  2073.                 restart := false;
  2074.                 fld := 0;
  2075.                 dataptr := 1;
  2076.                 PacketPtr := 0;
  2077.                 check := 0;
  2078.             end;
  2079.         end
  2080.         else                          { have started packet  }
  2081.         begin
  2082.             if (t=SOH) then
  2083.             restart := true
  2084.             else if (t=myEOL) then
  2085.             begin
  2086.                 finished := true;
  2087.                 isgood := false;
  2088.             end
  2089.             else
  2090.             begin
  2091.                 case fld of
  2092.                 { increment  field number }
  2093.                 0:   fld := 1;
  2094.                 1:   fld := 2;
  2095.                 2:   fld := 3;
  2096.                 3: 
  2097.                     if (count=3) then
  2098.                     fld := 5
  2099.                     else
  2100.                         fld := 4;
  2101.                 4: 
  2102.                     if (PacketPtr>=count-3) then
  2103.                     fld := 5;
  2104.                 end { case };
  2105.  
  2106.                 if (fld<>5) then
  2107.                 { add into checksum }
  2108.                     check := check+t;
  2109.  
  2110.                 case fld of
  2111.                 1:      Field1;
  2112.                 2:      Field2;
  2113.                 3:      Field3;
  2114.                 4:      Field4;
  2115.                 5:      Field5;
  2116.                 end; { case }
  2117.             end;
  2118.         end;
  2119.  
  2120.     if finished then
  2121.         begin
  2122.         if (ptype=TYPEE)  and isgood then   { error_packets }
  2123.             begin
  2124.             if Local then
  2125.                 PutStr(data,STDERR);
  2126.             Putcf(NEWLINE,STDERR);
  2127.             FinishUp(true);
  2128.             ProgramHalt;
  2129.             end;
  2130.         NumRecvPacks := NumRecvPacks+1;
  2131.         if Debug then
  2132.             begin
  2133.             DebugPacket('Received ...        ',InputPacket);
  2134.             if isgood then
  2135.                 PutCln('Is Good             ',STDERR);
  2136.             end;
  2137.         temp := CurrentPacket;
  2138.         CurrentPacket := NextPacket;
  2139.         NextPacket := temp;
  2140.     end;
  2141.     end;
  2142. end;
  2143.  
  2144.  
  2145. function ReceivePacket: boolean;
  2146. begin
  2147.     DebugMessage('ReceivePacket...    ');
  2148.     finished := false;
  2149.     restart := true;
  2150.     FromConsole := nothing;  { No Interupt }
  2151.  
  2152.     {  Obtain packet from VMS incoming channel }
  2153.     vmsChRead := GetVMSPacket(LineIn);
  2154.  
  2155.     {  Check local terminal for abort, resend character }
  2156.     if local then
  2157.     begin
  2158.         CheckTypeAhead(FromConsole);
  2159.         case FromConsole of
  2160.         abortnow: 
  2161.            begin
  2162.             FinishUp(true);
  2163.             ProgramHalt;
  2164.            end;
  2165.         nothing:        { nothing };
  2166.         CRin: 
  2167.             begin
  2168.             t := MyEOL;
  2169.             FromConsole := nothing;
  2170.             end;
  2171.         end;
  2172.     end;
  2173.  
  2174.     if (vmsChRead = 0) then
  2175.     begin
  2176.         ReceivePacket := false;
  2177.         if (timeOutStatus) then
  2178.         begin
  2179.             CurrentPacket^.ptype := TYPET;
  2180.             restart := true;
  2181.             if (local) then
  2182.             PutCln('Timed Out           ', STDERR)
  2183.         end;
  2184.     end
  2185.     else
  2186.     begin
  2187.         repeat
  2188.         t := GetIn;
  2189.  
  2190.         if (t<>ENDOFQIO) then
  2191.             BuildPacket
  2192.         else
  2193.             begin
  2194.             finished := true;
  2195.             isgood := false;
  2196.             end;
  2197.         until finished;
  2198.  
  2199.         ReceivePacket := isgood;
  2200.     end;
  2201. end;
  2202.  
  2203.  
  2204. function ReceiveACK :    boolean;
  2205. { receive ACK with  correct number }
  2206.  
  2207. var 
  2208.     Ok: boolean;
  2209. begin
  2210.     DebugMessage('ReceiveACK...       ');
  2211.     Ok := ReceivePacket;
  2212.     with CurrentPacket^ do
  2213.     begin
  2214.         if (ptype=TYPEY) then
  2215.         NumACKrecv := NumACKrecv+1
  2216.         else if (ptype=TYPEN) then
  2217.         NumNAKrecv := NumNAKrecv+1
  2218.         else
  2219.         NumBadrecv := NumBadrecv +1;
  2220.         { got right  one ? }
  2221.         ReceiveACK := ( Ok and (ptype=TYPEY) and (n=seq))
  2222.     end;
  2223. end;
  2224.  
  2225.  
  2226. procedure GetData(   var newstate:KermitStates);
  2227. { get data from file into ThisPacket }
  2228.  
  2229. var 
  2230.     { and return next state - data &  EOF }
  2231.     x,c : character;
  2232.     i: integer;
  2233. begin
  2234.     DebugMessage('GetData...          ');
  2235.     if (NumTry=1) then
  2236.     begin
  2237.         i := 1;
  2238.         x := ENDSTR;
  2239.         with ThisPacket^ do
  2240.         begin
  2241.             while (i< SizeSend - 8 ) and (x <> ENDFILE) do
  2242.             { leave room for quote  & NEWLINE }
  2243.             begin
  2244.                 x := Getcf(c,DiskFile);
  2245.                 if (x<>ENDFILE) then
  2246.                     begin
  2247.                     if (x > DEL) then
  2248.                        begin
  2249.                     ErrorPack('Non-ASCII text char ');
  2250.                     FinishUp(true);
  2251.                     ProgramHalt;
  2252.                        end;    
  2253.                     if (x < NULL) then
  2254.                         case EBQstate of
  2255.                            ascii :
  2256.                         begin    
  2257.                           ErrorPack('No Binary Support   ');
  2258.                           FinishUp(true);
  2259.                           ProgramHalt;
  2260.                         end;
  2261.                         binary : 
  2262.                         begin
  2263.                             data[i] := EBQchar;
  2264.                             i := i + 1;
  2265.                             x := x + 128;
  2266.                         end;
  2267.                     end;
  2268.  
  2269.                     if (IsControl(x)) or (x=SendQuote) or 
  2270.                     ((x = EBQchar) and (EBQState = Binary)) then
  2271.                     begin          { control char -- quote }
  2272.                         if ((x=NEWLINE) and
  2273.                          (EBQState <> Binary)) then 
  2274.                         case EOLFORFILE of
  2275.                             LineFeed:   { ok as  is };
  2276.                             CrLf: 
  2277.                             begin
  2278.                                 data[i] := SendQuote;
  2279.                                 i := i+1;
  2280.                                 data[i] := Ctl(CR);
  2281.                                 i := i+1;
  2282.                                 { LF  will sent below }
  2283.                             end;
  2284.                             JustCR:
  2285.                             x := CR;
  2286.                         end { case };
  2287.                         data[i] := SendQuote;
  2288.                         i := i+1;
  2289.                         { V1.1D next line should be 'and' }
  2290.                         if (x<>SendQuote) and (x <> EBQchar) then
  2291.                         data[i] := Ctl(x)
  2292.                         else
  2293.                         data[i] := x;
  2294.                     end
  2295.                     else               { regular char }
  2296.                     data[i] := x;
  2297.                 end;
  2298.  
  2299.                 if (x<>ENDFILE) then
  2300.                 begin
  2301.                     i := i+1;    { increase  count for next char }
  2302.                     AddTo(ChInFileSend,1);
  2303.                 end;
  2304.             end;
  2305.  
  2306.             data[i] := ENDSTR;   { to terminate  string }
  2307.  
  2308.             count := i -1;       { length }
  2309.             seq := n;
  2310.             ptype := TYPED;
  2311.  
  2312.             if (x=ENDFILE) then
  2313.             begin
  2314.                 newstate := EOFile;
  2315.                 Sclose(DiskFile);
  2316.             end
  2317.             else
  2318.             newstate := FileData;
  2319.         SaveState := newstate;        { save state }
  2320.         end
  2321.     end
  2322.     else
  2323.     newstate := SaveState;        {  get old state }
  2324. end;
  2325.  
  2326.  
  2327. function GetFileVMS(    fileName : string80;
  2328.             var newFileName : string;
  2329.             var nextFilePnt : integer;
  2330.             var lastFile : boolean) : boolean;
  2331. {  Routine to get a new file from VMS }
  2332.  
  2333. var 
  2334.     vmsFileIn, vmsFileRes : varying[80] of char;
  2335.     stat, i, j, lenStr, tempPnt : integer;
  2336.     tempFile : cstring;
  2337.  
  2338. begin
  2339.     vmsFileIn := fileName;
  2340.     tempPnt := nextFilePnt;
  2341.     stat := $Find_File(fileName := vmsFileIn,
  2342.                resultName := vmsFileRes,
  2343.                context := tempPnt);
  2344.     nextFilePnt := tempPnt;
  2345.     if ((stat <> rms$_normal) or (lastFile)) then
  2346.     begin
  2347.         if (stat = rms$_fnf) and (RunType <> Receive) then
  2348.          PutErr('VMS - File Not Found')
  2349.         else if (stat = rms$_typ) then
  2350.         PutErr('VMS - File Type Err ')
  2351.         else if (stat <> rms$_normal) and (stat <> rms$_nmf) and
  2352.             (RunType <> Receive) then
  2353.         PutErr('VMS - RMS file Error');
  2354.         GetFileVMS := false;
  2355.         lastFile := true;
  2356.     end
  2357.     else
  2358.     begin
  2359.         i := index(vmsFileRes,']');
  2360.         lenStr := length(vmsFileRes) - i;
  2361.           vmsFileRes := substr(vmsFileRes, i+1, lenStr);
  2362.         i := index(vmsFileRes, ';');
  2363.         vmsFileRes := substr(vmsFileRes, 1, i-1);
  2364.         tempFile := vmsFileRes;
  2365.         for j:=(length(vmsFileRes) + 1) to CONLENGTH do
  2366.         tempFile[j] := ' ';
  2367.         CtoS(tempFile, newFileName);
  2368.         newFilename[i] := ENDSTR;    { Shorten to correct file length }
  2369.         GetFileVMS := true;
  2370.     end;
  2371. end;
  2372.  
  2373.  
  2374. function GetNextFile:    boolean;
  2375. { get next  file to send in ThisPacket }
  2376. { returns true if no more }
  2377.  
  2378. var 
  2379.     result: boolean;
  2380. begin
  2381.     DebugMessage('GetNextFile...      ');
  2382.     result := true;
  2383.     if (NumTry=1) then
  2384.     with ThisPacket^ do
  2385.         begin
  2386.         if GetFileVMS(fileSpec, data, vmsFilePnt, lastFile) then
  2387.             begin            { open file  }
  2388.             DiskFile := Sopen(data,IOREAD*binascflg);
  2389.             if DiskFile = IOERROR then
  2390.                 begin
  2391.                 ErrorPack('Cannot open file    ');
  2392.                 FinishUp(true);
  2393.                 ProgramHalt;
  2394.                 end;
  2395.             count := LengthSTIP(data);
  2396.             AddTo(ChInFileSend , count);
  2397.             seq := n;
  2398.             ptype := TYPEF;
  2399.             result := false;
  2400.             end;
  2401.         end
  2402.     else
  2403.         result := false; { for saved packet  }
  2404.     GetNextFile := result;
  2405. end;
  2406.  
  2407.  
  2408. procedure SendFile; { send file name  packet }
  2409. begin
  2410.     DebugMessage('SendFile...         ');
  2411.     if NumTry > MaxTry then
  2412.     begin
  2413.         PutErr ('Send file - Too Many');
  2414.         State := Abort;      { too many tries, abort }
  2415.     end
  2416.     else
  2417.     begin
  2418.         NumTry := NumTry+1;
  2419.         if GetNextFile then
  2420.         begin
  2421.             State := Break;
  2422.             NumTry := 0;
  2423.         end
  2424.         else
  2425.         begin
  2426.             if ((NumTry = 1) and (local)) then
  2427.             PutCs('Sending File...     ',
  2428.                     ThisPacket^.data, controlOUT);
  2429.             if debug then
  2430.             begin
  2431.                 if (NumTry = 1) then
  2432.                 PutStr(ThisPacket^.data,STDERR)
  2433.                 else
  2434.                 PutStr(LastPacket^.data,STDERR);
  2435.                 Putcf(NEWLINE,STDERR);
  2436.             end;
  2437.             SendPacket;     { send this packet }
  2438.             if ReceiveACK then
  2439.             begin
  2440.                 State := FileData;
  2441.                 NumTry := 0;
  2442.                 n := (n+1) MOD 64;
  2443.             end
  2444.         end;
  2445.     end;
  2446. end;
  2447.  
  2448.  
  2449. procedure SendData;  { send file data packets }
  2450.  
  2451. var 
  2452.     newstate: KermitStates;
  2453. begin
  2454.     DebugMessage('SendData...         ');
  2455.     if debug then
  2456.     PutCN ( 'Sending data        ',n,STDERR);
  2457.     if NumTry > MaxTry then
  2458.     begin
  2459.         State := Abort;       { too  many tries, abort }
  2460.         PutErr ('Send data - Too many');
  2461.     end
  2462.     else
  2463.     begin
  2464.         NumTry := NumTry+1;
  2465.         GetData(newstate);
  2466.         SendPacket;
  2467.         if ReceiveACK then
  2468.         begin
  2469.             State := newstate;
  2470.             NumTry := 0;
  2471.             n := (n+1) MOD 64;
  2472.         end
  2473.     end;
  2474. end;
  2475.  
  2476.  
  2477. procedure SendEOF;    { send  EOF  packet }
  2478. begin
  2479.     DebugMessage('SendEOF...          ');
  2480.     if NumTry > MaxTry then
  2481.     begin
  2482.         State := Abort;       { too  many tries, abort }
  2483.         PutErr('Send EOF - Too Many ');
  2484.     end
  2485.     else
  2486.     begin
  2487.         NumTry := NumTry+1;
  2488.         if (NumTry = 1) then
  2489.         begin
  2490.             with ThisPacket^ do
  2491.             begin
  2492.                 ptype := TYPEZ;
  2493.                 seq := n;
  2494.                 count := 0;
  2495.             end;
  2496.             Sclose(DiskFile);
  2497.         end;
  2498.         SendPacket;
  2499.         if ReceiveACK then
  2500.         begin
  2501.             State := FileHeader;
  2502.             NumTry := 0;
  2503.             n := (n+1) MOD 64;
  2504.         end
  2505.     end;
  2506. end;
  2507.  
  2508.  
  2509. procedure SendBreak; { send break packet }
  2510. begin
  2511.     DebugMessage ('Sending break       ');
  2512.     if NumTry > MaxTry then
  2513.     begin
  2514.         State := Abort;       { too  many tries, abort }
  2515.         PutErr('Send break -Too Many');
  2516.     end
  2517.     else
  2518.     begin
  2519.         NumTry := NumTry+1;
  2520.         { make up packet  }
  2521.         if NumTry = 1 then
  2522.         begin
  2523.             with ThisPacket^ do
  2524.             begin
  2525.                 ptype := TYPEB;
  2526.                 seq := n;
  2527.                 count := 0;
  2528.             end
  2529.         end;
  2530.         SendPacket; { send this packet }
  2531.         if ReceiveACK then
  2532.         State := Complete;
  2533.     end;
  2534. end;
  2535.  
  2536.  
  2537. procedure SendInit;  { send init packet }
  2538. begin
  2539.     DebugMessage ('Sending init        ');
  2540.     if NumTry > MaxTry then
  2541.     begin
  2542.         State := Abort;      { too many tries, abort }
  2543.         PutErr('Cannot Initialize   ');
  2544.     end
  2545.     else
  2546.     begin
  2547.         NumTry := NumTry+1;
  2548.         if (NumTry = 1) then
  2549.         begin
  2550.             with ThisPacket^ do
  2551.             begin
  2552.                 EnCodeParm(data);
  2553.                 count := NUMPARAM;
  2554.                 seq := n;
  2555.                 ptype := TYPES;
  2556.             end
  2557.         end;
  2558.  
  2559.         SendPacket; { send this packet }
  2560.         if (NumTry = 1) then { Flush to prevent pile up of NAK's }
  2561.         FlushTypeAhead(true);
  2562.         if ReceiveACK then
  2563.         begin
  2564.              with CurrentPacket^ do
  2565.              begin
  2566.                  SizeSend := UnChar(data[1]);
  2567.                  TheirTimeOut := UnChar(data[2]);
  2568.                  Pad := UnChar(data[3]);
  2569.                  PadChar := Ctl(data[4]);
  2570.                  SendEOL := CR;  { default to CR  }
  2571.                  if (LengthSTIP(data) >= 5) then
  2572.                 if (data[5] <> 0) then
  2573.                     SendEOL := UnChar(data[5]);
  2574.                 SendQuote := SHARP;  { default # }
  2575.                 if (LengthSTIP(data) >= 6) then
  2576.                     if (data[6] <> 0) then
  2577.                     SendQuote := data[6];
  2578.             end;
  2579.  
  2580.             State := FileHeader;
  2581.             NumTry := 0;
  2582.             MaxTry := DEFTRY;  { use regular default now  }
  2583.             n := (n+1) MOD 64;
  2584.           end;
  2585.     end;
  2586.     FlushTypeAhead(false);
  2587. end;
  2588.  
  2589.  
  2590. procedure SendSwitch;
  2591. { Send-switch is the state  table switcher for sending files.
  2592. * It loops until either it is finished or a fault is encountered.
  2593. * Routines called by sendswitch are responsible for changing the state. }
  2594.  
  2595. begin
  2596.     DebugMessage ('Send Switch         ');
  2597.     SleepVMS(Delay);
  2598.     StartRun;
  2599.     repeat
  2600.     case State of
  2601.         FileData:     SendData;         { data-send state }
  2602.         FileHeader:   SENDFILE;         { send file name }
  2603.         EOFile:       SendEOF;          { send end-of-file }
  2604.         Init:         SendInit;         { send initialize }
  2605.         Break:        SendBreak;        { send break }
  2606.         Complete:     {  nothing };
  2607.         Abort:        {  nothing };
  2608.     end { case };
  2609.     until ( (State = Abort) or (State=Complete) );
  2610. end;
  2611.  
  2612.  
  2613. procedure GetFile(   data:string);
  2614. { create file from  fileheader packet }
  2615.  
  2616. const 
  2617.     { used  for GetFile }
  2618.       FLEN1 = 10;
  2619.       FLEN2 = 13;
  2620.       EXTLEN = 3;
  2621.  
  2622. var 
  2623.     p, strend, i, j, periodCnt : integer;
  2624.     temp : string;
  2625. begin
  2626.     DebugMessage ('GetFile...          ');
  2627.     with CurrentPacket^ do
  2628.     begin
  2629.         if DiskFile = IOERROR then
  2630.         begin
  2631.             i := 1;
  2632.             j := 1;
  2633.             periodCnt := 0;
  2634.             repeat
  2635.                 if (data[i] in [LETA..LETZ, LETsa..LETsz,
  2636.                         LET0..LET9, PERIOD]) then
  2637.                 begin
  2638.                 temp[j] := data[i];
  2639.                 if data[i] = PERIOD then
  2640.                     begin
  2641.                     p := j;
  2642.                     periodCnt := periodCnt + 1;
  2643.                     end
  2644.                 end
  2645.                 else
  2646.                 begin
  2647.                     temp[j] := j + LET0;
  2648.                 if not (temp[j] in [LET0..LET9]) then
  2649.                     temp[j] := LET0;
  2650.                 end;
  2651.                 i := i + 1;
  2652.                 j := j + 1;
  2653.             until (data[i] = ENDSTR);
  2654.  
  2655.             temp[j] := ENDSTR;
  2656.             j := j - 1;
  2657.                 
  2658.             {  check position of '.' -- truncate if bad }
  2659.             if periodCnt = 2 then
  2660.             begin
  2661.                 temp[p] := ENDSTR;
  2662.                 p := IndexSTIP(temp,PERIOD);
  2663.             end;
  2664.  
  2665.             if (p > FLEN1 ) then
  2666.                 begin
  2667.                     temp[FLEN1] := PERIOD;
  2668.                 temp[p] := (p mod 10) + LET0;
  2669.                 p := FLEN1;
  2670.                 end;
  2671.  
  2672.             {  check Max length }
  2673.             if j > FLEN2 then
  2674.             begin
  2675.                     temp[FLEN2 +1] := ENDSTR;
  2676.                 j := FLEN2;
  2677.             end;
  2678.  
  2679.             if (j >= FLEN1) then
  2680.             begin
  2681.                     if ((j-p) > EXTLEN) then
  2682.                 if (p <> NULL) then
  2683.                     begin
  2684.                             temp[p +EXTLEN+1] := PERIOD;
  2685.                     temp[p +EXTLEN+2] := ENDSTR;
  2686.                     end
  2687.                 else
  2688.                     temp[j - EXTLEN] := PERIOD;
  2689.             end
  2690.             else
  2691.             begin
  2692.                 temp[j +1] := PERIOD;
  2693.                 temp[j +2] := ENDSTR;
  2694.             end;
  2695.  
  2696.             if Exists(temp) then
  2697.             if (local) or (debug) then
  2698.                 PutCS('File already exists ',temp,
  2699.                               STDERR);
  2700.  
  2701.             if (local) or (debug) then
  2702.                 PutCS('Creating...         ',temp,STDERR);
  2703.  
  2704.             DiskFile := Sopen(temp,IOWRITE*binascflg);
  2705.             end;
  2706.  
  2707.     if (Diskfile = IOERROR) then
  2708.         begin
  2709.         FinishUp(true);
  2710.         ProgramHalt;
  2711.         end;
  2712.     end;
  2713. end;
  2714.  
  2715.  
  2716. procedure ReceiveInit;
  2717. { receive init packet }
  2718. { respond with ACK  and  our parameters }
  2719.  
  2720. var 
  2721.     receiveStat : boolean;
  2722. begin
  2723.     DebugMessage ('ReceiveInit...      ');
  2724.     if NumTry > MaxTry then
  2725.     begin
  2726.         State := Abort;
  2727.         PutErr('Cannot receive init ');
  2728.     end
  2729.     else
  2730.     begin
  2731.         NumTry := NumTry+1;
  2732.         receiveStat := ReceivePacket;
  2733.         if (ReceiveStat and (CurrentPacket^.ptype = TYPES)) then
  2734.         begin
  2735.             n := CurrentPacket^.seq;
  2736.             DeCodeParm(InputPacket^.data);
  2737.             {  now send mine }
  2738.             with ThisPacket^ do
  2739.             begin
  2740.                 count := NUMPARAM;
  2741.                 seq := n;
  2742.                 Ptype := TYPEY;
  2743.                 EnCodeParm(data);
  2744.             end;
  2745.             SendPacket;
  2746.  
  2747.             NumACK := NumACK+1;
  2748.             State := FileHeader;
  2749.             OldTry := NumTry;
  2750.             NumTry := 0;
  2751.             MaxTry := DEFTRY; { use  regular default now }
  2752.             n := (n+1) MOD 64
  2753.         end
  2754.         else
  2755.         begin
  2756.             if Debug then
  2757.             PutCln('Received Bad init   ',STDERR);
  2758.             SendNAK(n);
  2759.         end;
  2760.     end;
  2761. end;
  2762.  
  2763.  
  2764. procedure DataToFile; { output to file }
  2765.  
  2766. var 
  2767.     len,i : integer;
  2768.     temp : string;
  2769. begin
  2770.     DebugMessage ('DataToFile...       ');
  2771.     with CurrentPacket^ do
  2772.     begin
  2773.         len := LengthSTIP(data);
  2774.         AddTo(ChInFileRecv ,len);
  2775.         if (EBQState <> Binary) then
  2776.         case EOLFORFILE of
  2777.             LineFeed:
  2778.             PutStr(data,DiskFile);
  2779.             CrLf: 
  2780.                 begin  { output CR only if next is not LF }
  2781.                 for i:=1 to len do
  2782.                 if data[i] = CR then
  2783.                    begin
  2784.                      if data[i+1] <> NEWLINE then
  2785.                        Putcf(data[i],DiskFile);
  2786.                    end
  2787.                 else
  2788.                    Putcf(data[i],DiskFile);
  2789.             end;
  2790.             JustCR: 
  2791.             begin   { change CR  to NEWLINE }
  2792.                 for i:=1 to len do
  2793.                 if data[i]=CR then
  2794.                     data[i] := NEWLINE;
  2795.                 PutStr(data,DiskFile);
  2796.             end;
  2797.         end
  2798.         else
  2799.             PutStr(data, DiskFile);
  2800.     end;
  2801. end;
  2802.  
  2803.  
  2804. procedure dodata;  {  Process Data packet }
  2805. begin
  2806.     DebugMessage ('DoData...           ');
  2807.     with CurrentPacket^ do
  2808.     begin
  2809.         if  seq = ((n + 63) MOD 64) then
  2810.         begin                { data last one }
  2811.             if OldTry>MaxTry then
  2812.             begin
  2813.                 State := Abort;
  2814.                 PutErr('Old data - Too many ');
  2815.             end
  2816.             else
  2817.              begin
  2818.                  SendACK(seq);
  2819.                  NumTry := 0;
  2820.              end;
  2821.          end
  2822.          else
  2823.          begin            { data  - this one }
  2824.             if (n<>seq) then
  2825.             SendNAK(n)
  2826.             else
  2827.             begin
  2828.             DataToFile;
  2829.             SendACK(n); { ACK }
  2830.             OldTry := NumTry;
  2831.             NumTry := 0;
  2832.             n := (n+1) MOD 64;
  2833.             end;
  2834.         end;
  2835.      end;
  2836. end;
  2837.  
  2838. procedure doFileLast;   { Process File Packet }
  2839. begin          { File header - last  one  }
  2840.     DebugMessage ('DoFileLast...       ');
  2841.     if OldTry > MaxTry { tries ? } then
  2842.     begin
  2843.         State := Abort;
  2844.         PutErr('Old file - Too many ');
  2845.     end
  2846.     else
  2847.     begin
  2848.         OldTry := OldTry+1;
  2849.         with CurrentPacket^ do
  2850.         begin
  2851.             if seq = ((n + 63) MOD 64) then
  2852.                 {  packet number }
  2853.             begin  { send ACK }
  2854.                 SendACK(seq);
  2855.                 NumTry := 0
  2856.             end
  2857.             else
  2858.             begin
  2859.                 SendNAK(n);   {  NAK }
  2860.             end;
  2861.         end;
  2862.     end;
  2863. end;
  2864.  
  2865.  
  2866. procedure DoEOF;  { Process EOF packet }
  2867. begin                 { EOF  - this one }
  2868.     DebugMessage ('DoEOF...            ');
  2869.     if CurrentPacket^.seq<>n then   { packet number ? }
  2870.     SendNAK(n) { NAK }
  2871.     else
  2872.     begin               { send ACK }
  2873.         TransferOK := true; { Set true before calling Sclose }    
  2874.         Sclose(DiskFile);  { close file }
  2875.         SendACK(n);
  2876.         OldTry := NumTry;
  2877.         NumTry := 0;
  2878.         n := (n+1) MOD 64; { next packet  }
  2879.         State := FileHeader;   { change state }
  2880.     end;
  2881. end;
  2882.  
  2883.  
  2884. procedure ReceiveData;  { Receive data packets }
  2885.  
  2886. var 
  2887.     strend: integer;
  2888.     good : boolean;
  2889.  
  2890. begin
  2891.     DebugMessage ('ReceiveData...      ');
  2892.     if NumTry > MaxTry then          { check number of tries }
  2893.     begin
  2894.         State := Abort;
  2895.         if local then
  2896.         PutCN('Recv data -Too many ',n,STDERR);
  2897.     end
  2898.     else
  2899.     begin
  2900.         NumTry := NumTry+1;                { increase number of tries }
  2901.         good := ReceivePacket;        { get  packet }
  2902.         with CurrentPacket^ do
  2903.             begin
  2904.                 if debug then
  2905.             PutCN('Receiving (Data)    ',CurrentPacket^.seq,STDERR);
  2906.             if ((ptype = TYPED) or (ptype=TYPEZ)
  2907.                or (ptype=TYPEF)) and good then     { check type }
  2908.             case ptype of
  2909.                 TYPED:  doData;
  2910.                 TYPEF:  doFileLast;
  2911.                 TYPEZ:  doEOF;
  2912.             end { case }
  2913.             else
  2914.             begin
  2915.                 if Debug then
  2916.                 PutCln('Expected data pack  ',STDERR);
  2917.                 SendNAK(n);
  2918.             end;
  2919.         end;
  2920.     end;
  2921. end;
  2922.  
  2923.  
  2924. procedure doBreak; {  Process Break packet }
  2925. begin                    { Break transmission }
  2926.     DebugMessage ('DoBreak...          ');
  2927.     if CurrentPacket^.seq<>n then    { packet number ? }
  2928.         SendNAK(n) { NAK }
  2929.     else
  2930.         begin            { send   ACK }
  2931.           SendACK(n) ;
  2932.         State := Complete  { change  state }
  2933.     end;
  2934. end;
  2935.  
  2936.  
  2937. procedure DoFile; { Process file packet }
  2938. begin                 { File Header  }
  2939.     DebugMessage ('DoFile...           ');
  2940.     with CurrentPacket^ do
  2941.     begin
  2942.         if seq<>n then           { packet number ? }
  2943.         SendNAK(n)  { NAK }
  2944.         else
  2945.         begin               { send ACK }
  2946.             AddTo(ChInFileRecv, LengthSTIP(data));
  2947.               GetFile(data);   { get file  name }
  2948.             TransferOK := false;     
  2949.               SendACK(n);
  2950.             OldTry := NumTry;
  2951.             NumTry := 0;
  2952.             n := (n+1) MOD 64; { next packet  }
  2953.             State := FileData;   { change state  }
  2954.         end;
  2955.     end;
  2956. end;
  2957.  
  2958.  
  2959. procedure DoEOFLast; { Process EOF Packet }
  2960. begin               { end of File Last One}
  2961.     DebugMessage ('DoEOFLast...        ');
  2962.     if OldTry > MaxTry then
  2963.     begin
  2964.         State := Abort;
  2965.         PutErr('Old EOF - Too many  ');
  2966.     end
  2967.     else
  2968.     begin
  2969.         OldTry := OldTry+1;
  2970.         with CurrentPacket^ do
  2971.         begin
  2972.              if seq =((n + 63 ) MOD 64) then
  2973.             {  packet number }
  2974.             begin  { send ACK }
  2975.                 SendACK(seq);
  2976.                 Numtry := 0
  2977.             end
  2978.             else
  2979.              begin
  2980.                 SendNAK(n);  { NAK }
  2981.             end
  2982.         end;
  2983.     end;
  2984. end;
  2985.  
  2986.  
  2987. procedure DoInitLast;
  2988. begin                { Init  Packet - last one }
  2989.     DebugMessage ('DoInitLast...       ');
  2990.     if OldTry> DEFITRY then
  2991.     begin
  2992.         State := Abort;
  2993.         PutErr('Old init - Too many ');
  2994.     end
  2995.     else
  2996.     begin
  2997.         OldTry := OldTry+1;
  2998.         if CurrentPacket^.seq = ((n + 63) MOD  64) then
  2999.             { packet number }
  3000.         begin   { send ACK }
  3001.             with ThisPacket^ do
  3002.             begin
  3003.                 count := NUMPARAM;
  3004.                 seq := CurrentPacket^.seq;
  3005.                 ptype := TYPEY;
  3006.                 EnCodeParm(data);
  3007.             end;
  3008.             SendPacket;
  3009.             NumACK := NumACK+1;
  3010.             NumTry := 0;
  3011.         end
  3012.         else
  3013.         begin
  3014.             SendNAK(n);  { NAK }
  3015.         end;
  3016.     end;
  3017.  end;
  3018.  
  3019.  
  3020. procedure ReceiveFile; { receive file packet  }
  3021.  
  3022. var 
  3023.     good: boolean;
  3024.  
  3025. begin
  3026.     DebugMessage ('ReceiveFile...      ');
  3027.     if NumTry > MaxTry then          { check number of tries }
  3028.     begin
  3029.         State := Abort;
  3030.         PutErr('Recv file - Too many');
  3031.     end
  3032.     else
  3033.     begin
  3034.         NumTry := NumTry+1;                { increase number of tries }
  3035.         good := ReceivePacket;             { get packet }
  3036.         with CurrentPacket^ do
  3037.             begin
  3038.               if debug then
  3039.             PutCN('Receiving (File)    ',seq,STDERR);
  3040.             if ((ptype = TYPES) or (ptype=TYPEZ)
  3041.                or (ptype=TYPEF) or (ptype=TYPEB)) { check type }
  3042.                and good then
  3043.             case ptype of
  3044.                 TYPES:  doInitLast;
  3045.                 TYPEZ:  doEOFLast;
  3046.                 TYPEF:  doFile;
  3047.                 TYPEB:  doBreak;
  3048.             end { case }
  3049.             else
  3050.             begin
  3051.                 if Debug then
  3052.                 PutCln('Expected File Pack  ',STDERR);
  3053.                 SendNAK(n);
  3054.             end;
  3055.         end;
  3056.     end;
  3057. end;
  3058.  
  3059.  
  3060. procedure RecvSwitch; { this procedure  is the main receive routine }
  3061. begin
  3062.     DebugMessage ('RecvSwitch...       ');
  3063.     StartRun;
  3064.     repeat
  3065.     case State of
  3066.         FileData:       ReceiveData;
  3067.         Init:           ReceiveInit;
  3068.         Break:          {  nothing };
  3069.         FileHeader:     ReceiveFile;
  3070.         EOFile:         {  nothing };
  3071.         Complete:       {  nothing };
  3072.         Abort:          {  nothing };
  3073.     end;
  3074.     {  case }
  3075.     until (State = Abort ) or ( State = Complete );
  3076. end;
  3077.  
  3078.  
  3079. procedure KermitMain; { Main  procedure }
  3080.  
  3081. var 
  3082.     aline : string;
  3083.     j : integer;
  3084.     errorOccurred : boolean;
  3085. begin
  3086.  
  3087.     DebugMessage ('KermitMain...       ');
  3088.  
  3089.     errorOccurred := false;
  3090.     case Runtype of
  3091.     Receive: 
  3092.         begin { filename is optional here }
  3093.         if (rFileSpec = oON) then
  3094.             begin
  3095.             CopyStringVMS(fileSpec, aline);
  3096.             if ((Exists(aline)) and (local)) then
  3097.                 PutCS('Overwriting         ',aline,STDERR);
  3098.             DiskFile := Sopen(aline, IOWRITE*binascflg);
  3099.             if (DiskFile = IOERROR) then
  3100.                 begin
  3101.                 PutErr('Cannot Open File    ');
  3102.                 errorOccurred := true;
  3103.                 end
  3104.             else
  3105.                 if (local) then
  3106.                 PutCS('Receiving File...   ',
  3107.                            aline, ControlOUT);
  3108.             rFileSpec := oOFF;
  3109.             end;
  3110.  
  3111.         if not(errorOccurred) then
  3112.             RecvSwitch;
  3113.         end;
  3114.     Transmit: 
  3115.         SendSwitch;
  3116.  
  3117.     Invalid:        { nothing };
  3118.     end; {  case }
  3119.  
  3120.     FinishUp(errorOccurred); { end  of program }
  3121.  
  3122. end { main   };
  3123.  
  3124. {  Include the parser into kermit. }
  3125. %include   'kermdir:parser.pas/list'
  3126.  
  3127. begin
  3128.  
  3129.     ctrlOff := LIB$M_CLI_CTRLY;
  3130.     stat := $Disable_ctrl(ctrlOff);
  3131.  
  3132.     SetUpExitHandlerVMS(1, 6);   { VMS dependent routine }
  3133.  
  3134.     Greeting;
  3135.  
  3136.     KermitInit;       { initialize }
  3137.  
  3138.     initio;
  3139.  
  3140.     9999: { Goto for an error packet }
  3141.  
  3142.     RunType := Invalid;
  3143.  
  3144.     while not(exitProgram) do
  3145.     begin
  3146.  
  3147.         PromptAndParseUser(exitProgram, RunType);
  3148.  
  3149.         if not(exitProgram) then
  3150.         begin
  3151.             ResetKermitPacketNumber;
  3152.             case RunType of
  3153.             Receive,
  3154.             Transmit : 
  3155.                 if not(invalidConnection) then
  3156.                 KermitMain
  3157.                 else
  3158.                 BadVTerminalConnect;
  3159.             Connect : 
  3160.                 begin
  3161.                 local := true;
  3162.                 OpenPortVMS;
  3163.                 if not(invalidConnection) then
  3164.                     ConnectVMS
  3165.                 else
  3166.                     BadVTerminalConnect;
  3167.                 end;
  3168.             end;
  3169.         end;
  3170.         RunType := Invalid;
  3171.     end;
  3172.  
  3173.     SetUpExitHandlerVMS(0, 4);   { VMS dependent routine }
  3174.  
  3175.     stat := $Enable_Ctrl(ctrlOff);
  3176.  
  3177. end.
  3178.