home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / ti990.zip / ti990.src < prev    next >
Text File  |  1988-08-16  |  110KB  |  2,748 lines
  1. PROGRAM kermit;                                         {$NO GLOBALS}
  2. {
  3. Copyright (C) 1986, Trustees of Columbia University in the City of New
  4. York.  Permission is granted to any individual or institution to copy
  5. or use this program except for explicitly commercial purposes, provided
  6. this copyright notice is retained.
  7.  
  8. The Kermit file transfer protocol was developed at Columbia University.
  9. It is named after Kermit the Frog, star of the television series THE
  10. MUPPET SHOW; the name is used by permission of Henson Associates, Inc.
  11. "Kermit" is also Celtic for "free".  KERMIT is available for many
  12. systems for only a nominal fee from Columbia and from various user
  13. group organizations, such as DECUS and SHARE.
  14.  
  15. Author: Paul W. Madaus
  16.         Johnson Controls, Inc.
  17.         507 E. Michigan St.
  18.         Milwaukee, WI  53201
  19.         (414) 274-4528
  20.  
  21.   THIS VERSION OF KERMIT SOURCE WAS ORIGINALLY DESIGNED TO RUN ON THE
  22.   SPERRY(UNIVAC) 1100.  I HAVE CHOSEN TO CONVERT AND IMPLEMENT THIS
  23.   VERSION OF KERMIT ONTO THE TI-990 DX10 SYSTEMS.  THE CONVERSION OF
  24.   SYSTEM SPECIFIC PROCEDURES WAS STRAIGHTFORWARD, THE BASIC PROTOCOL
  25.   OF THE UNIVAC VERSION WAS WRITTEN IN STANDARD PASCAL, AND OF ALL THE
  26.   VERSIONS TESTED FOR CONVERSION, THE UNIVAC VERSION PRODUCED AN
  27.   ACCEPTABLE AMOUNT OF ERRORS UPON INITIAL DX10 COMPILATION(not a
  28.   deciding factor - but very influential).  BEFORE CONTINUING FURTHER,
  29.   I WISH TO CREDIT THE ORIGINAL UNIVAC VERSION(2.0) OF THIS PROGRAM TO:
  30.  
  31.                      Edgar Butt         (last known address)
  32.                      Computer Science Center
  33.                      University of Maryland
  34.                      College Park, Maryland 20742
  35.                      Phone (301) 454-2946
  36.  
  37.   MY METHOD OF RE-DESIGN WILL CONSIST OF REMOVAL OR CONVERSION OF
  38.   ALL UNIVAC SYSTEM DEPENDENT SOFTWARE, ADDITION OF A COMMAND
  39.   PARSING MECHANISM, ADDITION OF INTERACTIVE COMMAND CONTROL,
  40.   ADDITION OF SEVERAL NEW KERMIT COMMANDS, ADDITION OF SIMPLE TTY TYPE
  41.   TERMINAL EMULATION VIA CONNECT CMD, ADDITION OF REMOTE AS WELL AS
  42.   LOCAL KERMIT EXECUTION, AND ADDITION OF A PASCAL XOR FUNTION FOR
  43.   7th AND 8th BIT SETTING AND RESETTING.  THIS PROGRAM MAKES USE OF
  44.   TI PASCAL EXTENSIONS BUT DOES NOT INCLUDE ANY NON-TI PASCAL
  45.   STRUCTURES.  PROGRAM WAS COMPILED AND LINKED AT DX10 REL. 3.7.0 AND
  46.   DX10 PASCAL REL. 1.8.0.  THE TI PASCAL CONFIGURATION PROCESS WAS
  47.   NOT USED ONLY FOR GREATER SIMPLICITY AND EASIER PORTABILITY.
  48.   < more comments to follow in documentation... >
  49. }
  50.  
  51. CONST
  52.  
  53.                { NEXT TWO CONSTANTS USED IN CONNECT FOR XOFF TUNING }
  54.   xoff_threshold=800; { NO. OF CHARS TO RECEIVE BEFORE SENDING XOFF }
  55.     buf_threshold=1000;    { GUARD TO AVOID OVERFILLING CHAR BUFFER }
  56.  
  57.     maxtry = 5;
  58.     maxbuf = 200;
  59.     maxflen=50;                          { MAXIMUM FILE NAME LENGTH }
  60.     maxwrt = 132;
  61.  
  62.     ascnul = 0;
  63.     ascsoh = 1;
  64.     ascbs = 8;
  65.     asclf = 10;
  66.     asccr = 13;
  67.     ascsp = 32;                                                   { }
  68.     ascns = 35;                                                   {#}
  69.     ascamp = 38;                                                  {&}
  70.     ascast = 42;                                                  {*}
  71.     ascper = 46;                                                  {.}
  72.     ascb = 66;                                                    {B}
  73.     ascc = 67;                                                    {C}
  74.     ascd = 68;                                                    {D}
  75.     asce = 69;                                                    {E}
  76.     ascf = 70;                                                    {F}
  77.     ascg = 71;                                                    {G}
  78.     asch = 72;                                                    {H}
  79.     asci = 73;                                                    {I}
  80.     ascl = 76;                                                    {L}
  81.     ascn = 78;                                                    {N}
  82.     asco = 79;                                                    {O}
  83.     ascr = 82;                                                    {R}
  84.     ascs = 83;                                                    {S}
  85.     asct = 84;                                                    {T}
  86.     ascx = 88;                                                    {X}
  87.     ascy = 89;                                                    {Y}
  88.     ascz = 90;                                                    {Z}
  89.  
  90.     asctil = 126;                                                 {~}
  91.     ascdel = 127;                                            {rubout}
  92.  
  93.     mark = ascsoh;
  94.     crlf='#0D#0A';
  95.  
  96.                                           { DX10 SVC I/O SUBOPCODES }
  97.       asslun = #91;                 { ASSIGN LUNO SVC I/O SUBOPCODE }
  98.     opnrwd = #03;                   { OPEN REWIND SVC I/O SUBOPCODE }
  99.     readas = #09;                    { READ ASCII SVC I/O SUBOPCODE }
  100.     writas = #0B;                   { WRITE ASCII SVC I/O SUBOPCODE }
  101.     moddev= #15;                    { MODIFY DEVICE CHARACTERISTICS }
  102.     rfc=#05;                            { READ FILE CHARACTERISTICS }
  103.     genluno=#04;                           { GENERATE LUNO FLAG SET }
  104.     lunass=#80;             { LUNO ASSIGNED BIT FOR PDT STATUS WORD }
  105.  
  106.     ret_sys_info=#3F;                      { RETURN SYSTEM INFO SVC }
  107.     pdt_memory=1;                           { RETURN PDT STRUCTURES }
  108.  
  109. TYPE
  110.  
  111.   ascval = 0..255;                                         { A BYTE }
  112.  
  113.                   { WE'LL NEED STATIC LENGTH STRING BUFFERS ON DX10 }
  114.   char2=PACKED ARRAY[1..2]OF char;
  115.   char4=PACKED ARRAY[1..4]OF char;
  116.   char12=PACKED ARRAY[1..12]OF char;
  117.   char40=PACKED ARRAY[1..40]OF char;
  118.   char80=PACKED ARRAY[1..80]OF char;
  119.   flen=PACKED ARRAY[1..maxflen]OF char;
  120.   scistring=PACKED ARRAY[0..10]OF char;
  121.  
  122.   byte6=PACKED ARRAY[1..6]OF ascval;          { FILLERS AND OFFSETS }
  123.   byte12=PACKED ARRAY[1..12]OF ascval;
  124.   byte16=PACKED ARRAY[1..16]OF ascval;
  125.   byte18=PACKED ARRAY[1..18]OF ascval;
  126.   byte28=PACKED ARRAY[1..28]OF ascval;
  127.   byte60=PACKED ARRAY[1..60]OF ascval;
  128.  
  129.   kermitstates = (kcommand,
  130.     fininit,
  131.     byeinit,
  132.     getinit,
  133.     wexit,
  134.     kexit,
  135.     cexit,                                       { EXIT TO CMD MODE }
  136.     sinitiate,
  137.     sheader,
  138.     sdata,
  139.     sbreak,
  140.     rcv,
  141.     rinitiate,
  142.     rheader,
  143.     rdata);
  144.   filestatus = (closed, open, endfile);
  145.  
  146.   ablk=PACKED RECORD                            { ABORT I/O CALLBLK }
  147.     op,lun:ascval
  148.     END;
  149.  
  150.   wblk=PACKED RECORD                                 { WAIT I/O SVC }
  151.     op,err:ascval;
  152.     addr:integer
  153.     END;
  154.  
  155.   w1blk=PACKED RECORD                 { WAIT ANY I/O COMPLETION SVC }
  156.     op:ascval;
  157.     fil1,fil2,fil3:ascval                            { ZERO FILLERS }
  158.     END;
  159.  
  160.   eflags = SET OF                                      { EDIT FLAGS }
  161.   (pass,etx,esc,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15);
  162.  
  163.   pblk=PACKED RECORD                             { PASSTHRU CALLBLK }
  164.     resv1:integer;
  165.     eflg:eflags;
  166.     resv2:integer
  167.     END;
  168.  
  169.   rfcblk=PACKED RECORD              { FOR READ FILE CHARACTERISTICS }
  170.     fil1,fil2,fil3:integer;
  171.     filesize:longint
  172.     END;
  173.  
  174.   ascbuf = RECORD
  175.     ln: integer;
  176.     ch: PACKED ARRAY[1..maxbuf] OF
  177.       ascval
  178.     END;
  179.  
  180.   sbits = SET of 0..35;
  181.   btype=ARRAY[1..16] OF integer;               { FOR DISPLAY-ACCEPT }
  182.  
  183.   suflags= SET OF                                       { SVC FLAGS }
  184.   (bsy,err,eofil,evnt,f1,f2,f3,f4,qret,rep,f5,f6,f7,opn,ext,blnk);
  185.  
  186.   exflags=SET OF                        { EXTENDED CALL BLOCK FLAGS }
  187.     (fstrt,inten,blink,graph,asci8,tedit,beep,right,curpos,filchr,
  188.       noinit,trmchr,noecho,chrval,flderr,wbeep);
  189.  
  190.   svcblk = PACKED RECORD                            { SVC CALLBLOCK }
  191.     svc,                                               { SVC OPCODE }
  192.       stat,                                           { STATUS CODE }
  193.       subop,                                    { SVC I/O SUBOPCODE }
  194.       lun:ascval;                                            { LUNO }
  195.     flags:suflags;                          { SYSTEM AND USER FLAGS }
  196.     buf:integer;                              { DATA BUFFER ADDRESS }
  197.     lrl:integer;                            { LOGICAL RECORD LENGTH }
  198.     cc:integer;                                   { CHARACTER COUNT }
  199.     fil1:integer;                                        { NOT USED }
  200.         { EXTENDED CALL BLOCK BEGINS HERE - RESERVED FOR FUTURE USE }
  201.     xblk:exflags;                                        { NOT USED }
  202.     filorflg:ascval;                { FILL CHAR OR ASSIGN LUNO FLAG }
  203.     event:ascval;                                      { EVENT BYTE }
  204.     crow:ascval;                            { CURSOR POSITION - ROW }
  205.     ccol:ascval;                            { CURSOR POSITION - COL }
  206.     frow:ascval;                                { FIELD START - ROW }
  207.     fcol:ascval;                                { FIELD START - COL }
  208.     devaddr:integer;               { DEVICE POINTER FOR ASSIGN LUNO }
  209.     fil2,fil3:integer                                    { NOT USED }
  210.     END;
  211.  
  212.   svcptr=@svcblk;                      { SVC POINTER TYPE FOR SCB$A }
  213.  
  214.   waitblk = PACKED RECORD              { WAIT FOR I/O SVC CALLBLOCK }
  215.     opcode:ascval;                                     { SVC OPCODE }
  216.     stat:ascval;                                            { ERROR }
  217.     svcaddr:integer                   { ACTUAL SVC I/O ADDRESS (+2) }
  218.     END;
  219.  
  220.   bytebits=SET OF                  { 16 BITS TO A WORD - FOR XORING }
  221.   (b15,b14,b13,b12,b11,b10,b9,b8,b7,b6,b5,b4,b3,b2,b1,b0);
  222.  
  223.   svccbt = PACKED RECORD  { SVC BLOCK FOR RETURN SYSTEM INFORMATION }
  224.     opcode,                                                { OPCODE }
  225.       error,                                               { STATUS }
  226.       data_type,                    { TYPE OF STRUCTURE TO RETRIEVE }
  227.       flags:ascval;                                         { FLAGS }
  228.     index,                                       { STRUCTURE NUMBER }
  229.       read_addr,                            { OFFSET INTO STRUCTURE }
  230.       buff_len,                                  { READ BUFFER SIZE }
  231.       ret_len,                           { NUMBER OF BYTES RETURNED }
  232.       bufaddr,                                { READ BUFFER ADDRESS }
  233.       reserved:integer
  234.     END;
  235.                                                                    {}
  236.   pdtrec=PACKED RECORD
  237.      { BASED ON CURRENT PDT STRUCTURE - NOT AT ALL LIKELY TO CHANGE }
  238.     addr:integer;
  239.     fil0:byte6;                                            { FILLER }
  240.     bsy:ascval;                                { CONTAINS BUSY BITS }
  241.     fil1:ascval;                               { OTHER HALF OF BYTE }
  242.     fil2:byte18;                                           { FILLER }
  243.     tiline:ascval;           { NEED UPPER PORTION OF TILINE ADDRESS }
  244.     fil3:ascval;                                           { FILLER }
  245.     fil4:byte12;                                           { FILLER }
  246.     devnam:char4;                                     { DEVICE NAME }
  247.     fil5:byte60;                                           { FILLER }
  248.     addr2:integer;                 { SHOULD BE SAME THIS PDT'S ADDR }
  249.     fil6:byte28;                                           { FILLER }
  250.     vdtsc1:bytebits;                        { PORT INITIALIZED WORD }
  251.     fil7:byte16;                                           { FILLER }
  252.     init:bytebits;                          { PORT INITIALIZED WORD }
  253.     fil8:byte60                                            { FILLER }
  254.     END;
  255.  
  256.   buf=PACKED ARRAY[1..1024]OF char;            { ADJUST IF YOU WISH }
  257.  
  258. VAR
  259.  
  260.                                          { I HOPE I USE ALL THESE!! }
  261.   iniflg: boolean;              {Set true after first initialization}
  262.   server: boolean;
  263.   state: kermitstates;
  264.   filbuf,wrtbuf,redbuf,sndbuf,rcvbuf,cmdbuf: ascbuf;
  265.   redix: integer;
  266.   rfile,wfile,lfile: text;                    { DX10 TEXT FILE TYPES}
  267.   wbfile:FILE OF char80;                        { BINARY WRITE FILE }
  268.   rbfile:FILE OF char80;                         { BINARY READ FILE }
  269.   bbuf:char80;                                 { BINARY DATA BUFFER }
  270.   bptr:integer;                              { CURRENT BBUF POINTER }
  271.   fname,rfname,lname,ioname,namebuf,tname:flen;   { DX10 FILE PATHS }
  272.   fnlen,rfnlen,iolen,lnlen,tlen:integer;
  273.   rstatus, wstatus,lstatus: filestatus;
  274.   seq,rcvseq: integer;
  275.   rlen: integer;
  276.   stype,rcvtyp: ascval;
  277.   numtry: integer;
  278.   numcserr: integer;
  279.   ineoln: boolean;
  280.   sndonly: boolean;
  281.   sndlog, rcvlog, wrtlog, redlog: boolean;
  282.   creol: boolean;
  283.   lfeol: boolean;
  284.   crlfeol: boolean;
  285.   gotcr: boolean;
  286.  
  287.   locbsiz: ascval;
  288.   loctout: ascval;
  289.   locnpad: ascval;
  290.   locpad: ascval;
  291.   loceol: ascval;
  292.   locquo: ascval;
  293.   optqu8: ascval;
  294.   locqu8: ascval;
  295.   locrep: ascval;
  296.  
  297.   rembsiz: ascval;
  298.   remdsiz: ascval;
  299.               {Maximum number of data characters to send (remBsiz-3)}
  300.   remtout: ascval;
  301.   remnpad: ascval;
  302.   rempad: ascval;
  303.   remeol: ascval;
  304.   remquo: ascval;
  305.   remqu8: ascval;
  306.   remrep: ascval;
  307.  
  308.   oval:boolean;                               { IOTERM SETTING SAVE }
  309.   blk:btype;                      { FOR DISPLAY-ACCEPT CLEARSCREENS }
  310.   lun:integer;                                    { FOR INITSCREENS }
  311.   eolflg:boolean;          { DX10 RECORDS DO NOT CONTAIN CRs OR LFs }
  312.   pcbuf,tcbuf:char2;                                    { CHAR BUFS }
  313.   ts:svcblk;                           { TERMINAL SVC I/O CALLBLOCK }
  314.   ps:svcblk;                               { PORT SVC I/O CALLBLOCK }
  315.   sp:svcptr;                          { SVCBLK POINTER FOR MISC I/O }
  316.   s:svcblk;
  317.   rs:rfcblk;                     { READ FILE CHARACTERISTICS BUFFER }
  318.   recsred:integer;                 { NUMBER OF RECORDS READ IN FILE }
  319.   percent:real;                    { PERCENT OF FILE SENT TO REMOTE }
  320.   a:ablk;                                       { ABORT I/O CALLBLK }
  321.   w:wblk;                                        { WAIT I/O CALLBLK }
  322.   w1:w1blk;                                  { WAIT ANY I/O CALLBLK }
  323.   p:pblk;                            { EDIT FLAG BLOCK FOR PASSTHRU }
  324.   bsbuf:char40;                    { BIG USER MESSAGE STRING BUFFER }
  325.   ssbuf:char12;       { SMALL STRING BUFFER - MAINLY FOR THE PROMPT }
  326.   cond:boolean;                                 { CONNECTED BOOLEAN }
  327.   pktsnt:integer;                 { A RUNNING COUNT OF PACKETS SENT }
  328.   headok:boolean;                         { HEADER PACKET SENT FLAG }
  329.   sending:boolean;                                 { SENDING A FILE }
  330.   receiving:boolean;                             { RECEIVING A FILE }
  331.   local:boolean;                         { MODE WE ARE OPERATING IN }
  332.   syn,val:scistring;                          { FOR SYNONYM SETTING }
  333.   perr:integer;                                  { GET PARM ERR BUF }
  334.   isc:boolean;                       { ISC TYPE TERMINAL - OPTIONAL }
  335.   binary:boolean;                           { BINARY TYPE FILE FLAG }
  336.   reof:boolean;                    { READ FILE EOF ENCOUNTERED FLAG }
  337.  
  338.                                      { FORWARD REFERENCE PROCEDURES }
  339.  
  340. PROCEDURE error(msg:char40);forward;   { 40 CHARACTER ERROR MESSAGE }
  341.  
  342.                                     { TI PASCAL EXTERNAL PROCEDURES }
  343.  { THESE FIRST TWO PROCEDURES DEPEND ON THE EXISTENCE OF TIFORMS ON }
  344.       { YOUR DX10 SYSTEM AND ARE OPTIONAL SINCE THEY ONLY CLEAR THE }
  345.          { SCREEN UPON KERMIT INITIALIZATION.  YOU MAY REMOVE THEM. }
  346. PROCEDURE initscreen(VAR block:btype;
  347.   unit : integer );external;                              { TIFORMS }
  348.  
  349. PROCEDURE clearscreen( VAR block : btype);external;       { TIFORMS }
  350.  
  351. PROCEDURE delay(l:longint);external;            { DELAY L millisecs }
  352.  
  353. PROCEDURE p$parm(num:integer;         { GET PARMS FROM CALLING PROC }
  354.   VAR str:PACKED ARRAY[1..?]OF char;VAR err:integer);external;
  355.  
  356. PROCEDURE store$syn(VAR syn,value:scistring);external;
  357.  
  358. PROCEDURE set$acnm(locvar,locfil:integer);external;
  359.                                             { SET PASCAL FILE NAMES }
  360. PROCEDURE setpdt(w1addr,w2addr:integer);external;     { NOT TI PROC }
  361.    { ASSEMBLY - SET PORT INIT BITS FOR 2 WORDS IN PDT IF OPEN FAILS }
  362. PROCEDURE svc$(call_blk_addr:integer);external;       { PROCESS SVC }
  363.  
  364. FUNCTION scb$a(fileloc:integer):svcptr;external;
  365.                                       { GET TI FILE CHARACTERISTICS }
  366. { ***************************************************************** }
  367.  
  368. PROCEDURE passt(VAR s:svcblk;onoff:boolean);
  369.      { SET OR RESET THE PASSTHRU MODE - DEVICE MUST ALREADY BE OPEN }
  370. BEGIN                                                       { PASST }
  371.                                        { SET TERMINAL PASSTHRU MODE }
  372.   IF onoff THEN
  373.     p.eflg:=[pass]                              { SET PASSTHRU FLAG }
  374.   ELSE
  375.     p.eflg:=[];                               { RESET PASSTHRU FLAG }
  376.   p.resv1:=0;
  377.   p.resv2:=0;
  378.   s.flags:=[];                                { WAIT FOR COMPLETION }
  379.   s.subop:=moddev;                    { SET MODIFY DEVICE SUBOPCODE }
  380.   s.buf:=location(p);
  381.   s.cc:=6;
  382.   svc$(location(s))                             { SET PASSTHRU MODE }
  383. END;                                                        { PASST }
  384.  
  385. PROCEDURE abort(VAR s:svcblk);
  386. BEGIN
  387.   IF bsy IN s.flags THEN
  388.     BEGIN
  389.       a.op:=15;                         { SET ONCE ABORT I/O OPCODE }
  390.       a.lun:=s.lun;
  391.       svc$(location(a));
  392.       w.op:=1;                           { SET ONCE WAIT I/O OPCODE }
  393.       w.err:=0;                { NOW WAIT FOR THIS ABORT COMPLETION }
  394.       w.addr:=location(s)+2;
  395.       svc$(location(w))
  396.     END
  397. END;
  398.  
  399. PROCEDURE chktrm(devname:char4);
  400.  
  401. VAR
  402.   sys_info : svccbt;                             { USED TO GET PDTs }
  403.   pdt_addr :integer;                             { PDT ADDRESS SAVE }
  404.   pdt:pdtrec;                               { GENERAL PDT STRUCTURE }
  405.   vdtaddr,iniaddr:integer; { ADDRESS BUFFERS THE TWO PDT INIT WORDS }
  406.  
  407. BEGIN                                                      { CHKTRM }
  408.  
  409.   vdtaddr:=-1;                        { NOT A VALID PDT ADDRESS YET }
  410.   iniaddr:=-1;                        { NOT A VALID PDT ADDRESS YET }
  411.   IF devname[1]='S' AND devname[2]='T' THEN
  412.     WITH sys_info DO                       { SEARCH FOR DEVICES PDT }
  413.       BEGIN
  414.         opcode:=ret_sys_info;
  415.         error:=0;
  416.         data_type:=pdt_memory;            { RETRIEVE PDT STRUCTURES }
  417.         flags:=0;
  418.         index:=0;                  { START AT BEGINNING OF PDT LIST }
  419.         read_addr:=0;                             { OFFSET INTO PDT }
  420.         buff_len:=size(pdt);                  { SIZE OF READ BUFFER }
  421.         ret_len:=0;                   { ACTUAL NUMBER OF BYTES READ }
  422.         bufaddr:=location(pdt);
  423.         reserved:=0;
  424.         REPEAT
  425.           index:=succ(index);                  { GET NEXT PDT ENTRY }
  426.           pdt_addr:=pdt.addr;                 { POINTER TO NEXT PDT }
  427.           svc$(location(sys_info));                  { GET NEXT PDT }
  428.           IF pdt.devnam=devname AND error=0 THEN
  429.             BEGIN                                { FOUND THE DEVICE }
  430.               IF index=1 THEN   { IF FIRST PDT ON LIST THEN WE HAVE }
  431.                 pdt_addr:=pdt.addr2;   { TO GET ITS ADDR WITHIN PDT }
  432.               IF (pdt.bsy=0 OR pdt.bsy=lunass) AND
  433. { ONLY ALLOW LUNO ASSISNED BIT SET IN PDT STATUS WORD i.e. not busy }
  434.                   pdt.tiline>= #F8 AND
  435.     { MAKE SURE STATION COMING OFF CI403 BOARD --> TILINE TYPE ADDR }
  436.                   NOT (b2 IN pdt.vdtsc1 AND    { SEE IF ONE OR BOTH }
  437.                   b2 IN pdt.init) THEN   { WORDS NEEDS MODIFICATION }
  438. { ALL THE ABOVE CONDITIONS MUST BE SATISFIED FOR THIS FINAL ATTEMPT }
  439. { TO OPEN A 931 PORT TO EVEN BE ATTEMPTED.  ADDRESSES OF WORDS WILL }
  440.    { BE SET THAT NEED BIT MODIFICATION, ELSE ADDRESSES REMAIN AT -1 }
  441.                 BEGIN
  442.                   IF NOT b2 IN pdt.vdtsc1 THEN       { NEED BIT SET }
  443.                     vdtaddr:=pdt_addr+location(pdt.vdtsc1)-location(
  444.                         pdt
  445.                         );  { SO SET ADDRESS OF WORD TO BE MODIFIED }
  446.                   IF NOT b2 IN pdt.init THEN   { SAME FOR THIS WORD }
  447.                     iniaddr:=pdt_addr+location(pdt.init)-location(pdt
  448.                         );
  449.                   setpdt(vdtaddr,iniaddr)
  450.                                          { SET APPROPRIATE PDT BITS }
  451.                 END
  452.             END
  453.         UNTIL pdt.addr=0 OR pdt.devnam=devname OR error<>0
  454.       END
  455. END;                                                       { CHKTRM }
  456.  
  457. PROCEDURE initio(dev:integer;VAR s:svcblk);
  458.  
  459. VAR
  460.   devnam:char4;                               { DEVICE NAME TO OPEN }
  461.  
  462. BEGIN                                                      { INITIO }
  463.   IF s.stat=0 THEN                     { CHECK FOR ANY PREVIOUS ERR }
  464.     WITH s DO
  465.       BEGIN
  466.         svc:=0;                                           { SVC I/O }
  467.         subop:=asslun;                      { ASSIGN LUNO OPERATION }
  468.         lun:=0;                         { SYSTEM WILL PICK THE LUNO }
  469.         flags:=[];                         { USE EXTENDED CALLBLOCK }
  470.         buf:=0;                                             { CLEAR }
  471.         lrl:=0;                                             { CLEAR }
  472.         cc:=0;                                              { CLEAR }
  473.         fil1:=0;                                            { CLEAR }
  474.         xblk:=[];                                           { CLEAR }
  475.         filorflg:=genluno;         { SYSTEM TO GENERATE LUNO NUMBER }
  476.         event :=0;                                          { CLEAR }
  477.         crow :=0;                                           { CLEAR }
  478.         ccol :=0;                                           { CLEAR }
  479.         frow :=0;                                           { CLEAR }
  480.         fcol :=0;                                           { CLEAR }
  481.         devaddr:=dev;                         { DEVICE NAME POINTER }
  482.         fil2:=0;                                            { CLEAR }
  483.         fil3:=0;                                            { CLEAR }
  484.         svc$(location(s));                        { PERFORM THE SVC }
  485.         IF stat=0 THEN                   { LUNO ASSIGNMENT COMPLETE }
  486.           BEGIN                               { OPEN DEVICE FOR I/O }
  487.             filorflg :=0;                                   { CLEAR }
  488.             devaddr:=0;                                     { CLEAR }
  489.             subop:=opnrwd;   { SET OPEN REWIND OPERATION FOR DEVICE }
  490.             flags:=[qret];      { QUICK RETURN SO WE CAN CHECK OPEN }
  491.             svc$(location(s));                    { OPEN THE DEVICE }
  492.             delay(500);           { ALLOW OPEN OF DEVICE TO PROCEED }
  493.             IF bsy IN flags THEN
  494.               BEGIN                         { OPEN NOT COMPLETE YET }
  495.                 delay(3000);                       { WAIT SOME MORE }
  496.                 IF bsy IN flags THEN
  497.                   BEGIN
  498.                     abort(s);
  499.                             { ABORT AND CHECK PORT'S PDT INIT WORDS }
  500.                     stat:=0;
  501.                     IF dev=location(ioname) THEN
  502.                       BEGIN           { PDT MAY NEED INITIALIZATION }
  503.                         FOR i:=1 TO 4 DO
  504.                           devnam[i]:=ioname[(i+1)];
  505.                         chktrm(devnam)
  506.                      { CHECK AND POSSIBLY MODIFY PDT PORT INIT BITS }
  507.                       END;
  508.                     svc$(location(s));       { TRY ONE MORE ATTEMPT }
  509.                     delay(2000);
  510.                     IF bsy IN flags THEN
  511.                       stat:= #FF   { COULDN'T OPEN DEVICE SET ERROR }
  512.                   END
  513.               END;
  514.             flags:=[];                                { RESET FLAGS }
  515.             IF stat=0 AND dev=location(ioname) THEN
  516.               passt(s,true);     { SET PASSTHRU MODE ON REMOTE PORT }
  517.             lrl:=1                                 { FOR MOST READS }
  518.           END
  519.       END
  520. END;                                                       { INITIO }
  521.  
  522.           { IN SOME PROCEDURES I CALL SVC$ DIRECTLY FOR QUICKER I/O }
  523. PROCEDURE readdev(VAR rs:svcblk;wait:boolean;bufloc:integer);
  524. BEGIN
  525.   rs.subop:=readas;
  526.   rs.buf:=bufloc;
  527.   IF wait THEN                                { WAIT I/O COMPLETION }
  528.     rs.flags:=rs.flags-[qret]
  529.   ELSE
  530.     rs.flags:=rs.flags+[qret];
  531.   svc$(location(rs))                                  { DO THE READ }
  532. END;
  533.  
  534. PROCEDURE writdev(VAR rs:svcblk;wait:boolean;
  535.   numchars:integer;bufloc:integer);
  536. BEGIN
  537.   rs.subop:=writas;
  538.   rs.buf:=bufloc;
  539.   rs.cc:=numchars;
  540.   IF wait THEN                                { WAIT I/O COMPLETION }
  541.     rs.flags:=rs.flags-[qret]
  542.   ELSE
  543.     rs.flags:=rs.flags+[qret];
  544.   svc$(location(rs))                                 { DO THE WRITE }
  545. END;
  546.  
  547. FUNCTION devbsy(ds:svcblk):boolean;
  548. BEGIN
  549.   devbsy:=bsy IN ds.flags                      { DEVICE DOING I/O ? }
  550. END;
  551.  
  552.                                                        {$NO WARNINGS}
  553. FUNCTION bxor(i:integer;b:ascval):ascval;              { XOR 128/64 }
  554.  
  555. VAR
  556.   a:bytebits;                             { BIT MANIPULATION NEEDED }
  557.  
  558. BEGIN                                                        { BXOR }
  559.   a:= b::bytebits;              { TYPE CONVERT FOR BIT MANIPULATION }
  560.   IF i = 64 THEN
  561.     BEGIN                                                  { XOR 64 }
  562.       IF ( b6 IN a ) THEN
  563.         a:=a - [b6]                                   { RESET BIT 6 }
  564.       ELSE
  565.         a:=a+ [b6]                                      { SET BIT 6 }
  566.     END;                                                   { XOR 64 }
  567.   IF i = 128 THEN
  568.     BEGIN                                                 { XOR 128 }
  569.       IF ( b7 IN a ) THEN
  570.         a:=a- [b7]                                    { RESET BIT 7 }
  571.       ELSE
  572.         a:=a+[b7]                                       { SET BIT 7 }
  573.     END;                                                  { XOR 128 }
  574.                               { NO OTHER XORS DONE IN THIS PROTOCOL }
  575.   b:=a::ascval;                    { TYPE CONVERT FOR COMPATABILITY }
  576.   bxor:=b                                   { RETURN FUNCTION VALUE }
  577. END;                                                         { BXOR }
  578.                                                           {$WARNINGS}
  579. FUNCTION makechar (i: integer): ascval;
  580.  
  581. BEGIN
  582.   makechar:=ascsp+i
  583. END;
  584.  
  585. FUNCTION unchar (a: ascval): integer;
  586.  
  587. BEGIN
  588.   unchar:=a-ascsp
  589. END;
  590.  
  591. FUNCTION tog64(a: ascval): ascval;
  592.  
  593. BEGIN
  594.   tog64:=bxor(64,a)                                {System dependent}
  595. END;
  596.  
  597. FUNCTION tog128(a: ascval): ascval;
  598.  
  599. BEGIN
  600.   tog128:=bxor(128,a)                              {System dependent}
  601. END;
  602.  
  603. FUNCTION checksum (sum: integer): ascval;
  604.  
  605. BEGIN                        { SINGLE CHARACTER ARITHMETIC CHECKSUM }
  606.   checksum := (((sum MOD 256) DIV 64) + sum) MOD 64
  607. END;
  608.  
  609. PROCEDURE logopn;                     { OPEN LOG FILE - IF DEMANDED }
  610.  
  611. BEGIN
  612.   set$acnm(location(lfile),location(lname));
  613.                                              { SET PASCAL FILE NAME }
  614.   rewrite(lfile);                       { OPEN LOG FILE FOR WRITING }
  615.   lstatus:=open;                                   { ASSUME SUCCESS }
  616.   write(lfile,'DX10 KERMIT-990  --- LOGFILE');
  617.   writeln(lfile);
  618.   bsbuf:='LOGGING REQUESTED TO:                   ';
  619.   writdev(ts,true,22,location(bsbuf));
  620.   FOR i:=1 TO ord(lname[1]) DO
  621.     BEGIN
  622.       tcbuf[1]:=lname[(i+1)];
  623.       writdev(ts,true,1,location(tcbuf))
  624.     END;
  625.   tcbuf:='#0D#0A';
  626.   writdev(ts,true,2,location(tcbuf))
  627. END;
  628.  
  629. PROCEDURE logcls;
  630.  
  631. BEGIN
  632.   IF lstatus=open THEN
  633.     close(lfile)                               { CLOSE THE LOG FILE }
  634. END;
  635.  
  636.                                          { Buffer routines - FOLLOW }
  637.  
  638. PROCEDURE bufinit(VAR buf:ascbuf);
  639.  
  640. BEGIN
  641.   buf.ln:=0
  642. END;
  643.  
  644. PROCEDURE putbuf(VAR buf: ascbuf; a:ascval);
  645.  
  646. BEGIN
  647.   IF NOT (buf.ln<maxbuf) THEN
  648.                      { I THINK THE CAUSE OF THIS ERROR NEEDS FIXING }
  649.     BEGIN            { THIS CONDITION SHOULD BE AVOIDED - FIX LATER }
  650.       error('SIZE OF ASCII BUFFER EXCEEDED           ')
  651.     END
  652.   ELSE
  653.     BEGIN
  654.       buf.ln:=buf.ln+1;
  655.       buf.ch[buf.ln]:=a
  656.     END
  657. END;
  658.  
  659. PROCEDURE lintobuf(l: flen; len: integer; VAR buf: ascbuf);
  660.  
  661. BEGIN
  662.   bufinit(buf);
  663.   FOR i:=2 TO (len+1) DO
  664.     putbuf(buf,ord(l[i]))
  665. END;
  666.  
  667. PROCEDURE buftolin(buf: ascbuf; VAR l:flen; VAR len: integer);
  668.  
  669. VAR a:ascval;
  670.  
  671. BEGIN
  672.   len:=buf.ln;
  673.   IF len>maxflen THEN len:=maxflen;
  674.   FOR i:=1 TO len DO
  675.     BEGIN
  676.       a:=buf.ch[i];
  677.       IF a>127 THEN a:=a-127;
  678.       l[(i+1)]:=chr(a)
  679.     END;
  680.   l[1]:=chr(len)                                 { NEED FILE LENGTH }
  681. END;
  682.  
  683.                      { Process parameters to and from remote Kermit }
  684.  
  685. PROCEDURE putpar;
  686. VAR temp: ascval;
  687.  
  688. BEGIN
  689.   bufinit(filbuf);
  690.   putbuf(filbuf,makechar(locbsiz));
  691.   putbuf(filbuf,makechar(loctout));
  692.   putbuf(filbuf,makechar(locnpad));
  693.   putbuf(filbuf,tog64(locpad));
  694.   putbuf(filbuf,makechar(loceol));
  695.   putbuf(filbuf,locquo);
  696.   temp:=ascsp;                        { SO FAR NO EIGHT BIT QUOTING }
  697.   IF locqu8<>0 THEN temp:=locqu8;
  698.   putbuf(filbuf,temp);
  699.   putbuf(filbuf,ascsp);    {Only know how do to 1 character checksum}
  700.   temp:=ascsp;
  701.   IF locrep<>0 THEN temp:=locrep;
  702.   putbuf(filbuf,temp)
  703. END;
  704.  
  705. PROCEDURE getpar;
  706.  
  707. BEGIN
  708.   IF rcvbuf.ln > 0 THEN rembsiz:=unchar(rcvbuf.ch[1]);
  709.   IF rcvbuf.ln > 1 THEN remtout:=unchar(rcvbuf.ch[2]);
  710.   IF rcvbuf.ln > 2 THEN remnpad:=unchar(rcvbuf.ch[3]);
  711.   IF rcvbuf.ln > 3 THEN rempad:=tog64(rcvbuf.ch[4]);
  712.   IF rcvbuf.ln > 4 THEN remeol:=unchar(rcvbuf.ch[5]);
  713.   IF rcvbuf.ln > 5 THEN remquo:=rcvbuf.ch[6];
  714.   IF rcvbuf.ln > 6 THEN remqu8:=rcvbuf.ch[7];
  715.     { DONT GET CHCKSUM - WE ARE ONLY SET UP FOR SINGLE CHAR CHCKSUM }
  716.   IF rcvbuf.ln > 8 THEN remrep:=rcvbuf.ch[9];
  717.  
  718. " remdsiz:=rembsiz-3;
  719.   remdsiz:=rembsiz-6;      { SEND LESS DATA - EXCEEDING REMOTE BUFS }
  720.   IF state=rinitiate THEN         {Our parameters have not been sent}
  721.     BEGIN
  722.       IF locqu8=0 THEN remqu8:=0;      { WE DONT WANT 8-BIT QUOTING }
  723.       IF ((32<remqu8) AND (remqu8<63)) OR ((95<remqu8) AND (remqu8<
  724.           127))
  725.           AND (remqu8<>remquo) THEN
  726.         BEGIN
  727.           locqu8:=ascy
  728.                       {Remote Kermit specified 8-bit quote character}
  729.         END
  730.       ELSE
  731.         IF remqu8=ascy THEN
  732.           BEGIN
  733.             locqu8:=ascamp;
  734.             IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=asctil;
  735.             IF (locqu8=remquo) OR (locqu8=remrep) THEN locqu8:=ascns;
  736.             remqu8:=locqu8
  737.           END
  738.         ELSE
  739.           BEGIN
  740.             locqu8:=0;                       {Don't do 8-bit quoting}
  741.             remqu8:=0
  742.           END;
  743.       IF ((32<remrep) AND (remrep<63)) OR ((95<remrep) AND (remrep<
  744.           127))
  745.           AND (remrep<>remquo) AND (remrep<>remqu8) AND (locrep<>0)
  746.           THEN
  747.         BEGIN
  748.           locrep:=remrep                  {Agree to do repeat counts}
  749.         END
  750.       ELSE
  751.         BEGIN
  752.           remrep:=0;
  753.           locrep:=0
  754.         END
  755.     END
  756.   ELSE                        {Our parameters have already been sent}
  757.     BEGIN
  758.       IF (remqu8<>ascy) AND (remqu8<>locqu8) THEN
  759.         BEGIN
  760.           locqu8:=0                          {Don't do 8-bit quoting}
  761.         END;
  762.       IF remrep<>locrep THEN
  763.         locrep:=0                            {Don't do repeat counts}
  764.     END
  765. END;
  766.  
  767. PROCEDURE rcvpkt;
  768.  
  769. { rcvtyp = 0 - no soh encountered
  770.            1 - soh encountered, but packet incomplete
  771.            2 - Checksum error
  772.             Other - ASCII value of packet type from good packet
  773.  
  774.    rcvseq = -1 - Not a valid packet
  775.             0...63 - Sequence number from valid packet
  776.  
  777.    rcvbuf.ln - number of ascii values input since last SOH
  778.  
  779.    rcvbuf.ch - array of ascii values input                        }
  780.  
  781. VAR
  782.   c:PACKED ARRAY[1..2]OF char;
  783.   av,rt: ascval;
  784.   rst,rsq,cs:integer;
  785.   cct:integer;
  786.   dlay:integer;                                   { A DELAY COUNTER }
  787.   dtim:longint;                              { VARIABLE DELAY TIMES }
  788.  
  789. BEGIN
  790.   cct:=0;
  791.   IF rcvlog THEN write(lfile,'RCV <');
  792.   rcvtyp:=0;
  793.   rcvseq:=-1;                                 { NO VALID PACKET YET }
  794.   rst:=0;
  795.   ineoln:=false;
  796.   bufinit(rcvbuf);
  797. { FOR OPTIMAL SPEED WE WILL AVOID THE PROCEDURE CALL TO READ A CHAR }
  798.   ps.subop:=readas;
  799.   ps.buf:=location(c);
  800.   ps.flags:=ps.flags+[qret];
  801.   svc$(location(ps));                              { QUEUE THE READ }
  802.   WHILE NOT ineoln AND cct<230 DO
  803.                 { UNTIL END OF PACKET OR UNTIL NO SOH LIMIT REACHED }
  804.     BEGIN
  805.       dlay:=0;                                { CLEAR DELAY COUNTER }
  806.       dtim:=0;                                   { NO INITIAL DELAY }
  807.                    { THIS WHILE LOOP MAY BE FINE TUNED IF NECESSARY }
  808.       WHILE (bsy IN ps.flags) AND dtim<=200 DO
  809.         BEGIN
  810.           delay(dtim);            { VARIABLE DELAY BEGINS WITH ZERO }
  811.           dlay:=succ(dlay);                { INCREMENT TIME COUNTER }
  812.               { THIS DELAY MECHANISM MAY NEED FINE(or GROSS) TUNING }
  813.           IF( (dlay MOD 10) = 0) THEN
  814.             dtim:=dtim+50                   { WAIT LONGER NEXT TIME }
  815.         END;
  816.       IF bsy IN ps.flags THEN
  817.           { READ CHARACTER COULD NOT COMPLETE IN ABOUT FIVE SECONDS }
  818.         ineoln:=true              { SO LEAVE --> RESEND LAST PACKET }
  819.       ELSE                                         { WE READ A CHAR }
  820.         BEGIN
  821.           IF rcvlog THEN
  822.             BEGIN
  823.               IF ps.stat<>0 THEN
  824.                 write(lfile,'^^ERR IN PORT READ: ',ps.stat hex,' ^^')
  825.               ELSE
  826.                 write(lfile,c[1])
  827.             END;
  828.           cct:=succ(cct);
  829.           av:=ord(c[1]);
  830.                       { WE HAVE THE CHAR - SO REQUEUE THE NEXT READ }
  831.           svc$(location(ps));
  832.                        { QUEUE NEXT READ WHILE PROCESSING LAST CHAR }
  833.           IF av=mark THEN rst:=1;
  834.           CASE rst OF
  835.  
  836.             0:                    {Mark character never encountered.}
  837.               BEGIN
  838.                 putbuf(rcvbuf,av);
  839.               END;
  840.  
  841.             1:                                      {Mark character.}
  842.               BEGIN
  843.                 rcvtyp:=1;
  844.                 rcvseq:=-1;
  845.                 cct:=0;                           { CLEAR PACKET OK }
  846.                 bufinit(rcvbuf);
  847.                 rst:=2
  848.               END;
  849.  
  850.             2:                                {Length of the packet.}
  851.               BEGIN
  852.                 cs:=av;                         {Initialize checksum}
  853.                 rlen:=unchar(av)-3;
  854.                 rst:=3
  855.               END;
  856.  
  857.             3:                                       {Packet number.}
  858.               BEGIN
  859.                 cs:=cs+av;
  860.                 rsq:=unchar(av);
  861.                 rst:=4
  862.               END;
  863.  
  864.             4:                                         {Packet type.}
  865.               BEGIN
  866.                 cs:=cs+av;
  867.                 rt:=av;                    {remember the packet type}
  868.                 rst:=5;
  869.                 IF rlen=0 THEN
  870.                   rst:=6
  871.               END;
  872.  
  873.             5:                                        {Data portion.}
  874.               BEGIN
  875.                 cs:=cs+av;
  876.                 putbuf(rcvbuf,av);
  877.                 IF rcvbuf.ln = rlen THEN
  878.                   rst:=6
  879.               END;
  880.  
  881.             6:                                            {Checksum.}
  882.               BEGIN
  883.                 IF checksum(cs)=unchar(av) THEN
  884.                   BEGIN
  885.                     rcvtyp:=rt;
  886.                     rcvseq:=rsq;
  887.                     ineoln:=true        {Ignore the rest of the line}
  888.          { CARRIAGE CONTROL CHAR WILL BE READ FROM NEXT QUEUED READ }
  889.                   END
  890.                 ELSE
  891.                   BEGIN
  892.                     numcserr:=numcserr+1;
  893.                     rst:=0;                   {Look for another mark}
  894.                     rcvtyp:=2;              {Indicate checksum error}
  895.                     ineoln:=true                   { RETURN ERR NOW }
  896.                   END
  897.               END
  898.             END                                              { CASE }
  899.         END                          { ELSE - NOT BSY --> CHAR READ }
  900.     END;
  901.   IF rcvlog THEN
  902.     writeln(lfile,'>');
  903.   IF cct>=230 THEN
  904.  { AFTER RECEIVING 230 UNSUCCESSFUL CHARACTERS - IT'S TIME TO RESET }
  905.     error('#0D#0A230 CHARS AND STILL NO VALID PACKET.#0D#0A');
  906.   IF bsy IN ps.flags THEN
  907.     abort(ps)                            { CLEAN UP BEFORE WE LEAVE }
  908. END;                                                       { RCVPKT }
  909.  
  910.                                 { Build and send packets PROCEDURES }
  911.  
  912. PROCEDURE makepacket(ptype: ascval; seq, len: integer);
  913.  
  914. VAR c: ascval;
  915.   cs: integer;
  916.  
  917. BEGIN
  918.   bufinit(sndbuf);
  919.   FOR i:=1 TO remnpad DO         { ADD PAD CHARS IF ANY TO BE ADDED }
  920.     putbuf(sndbuf,rempad);
  921.   putbuf(sndbuf,mark);                                 { SOH MARKER }
  922.   c:=makechar(len+3);
  923.   cs:=c;                                        {Initialize checksum}
  924.   putbuf(sndbuf,c);                              { LENGTH OF PACKET }
  925.   c:=makechar(seq);
  926.   cs:=cs+c;
  927.   putbuf(sndbuf,c);                             { PACKET SEQ NUMBER }
  928.   c:=ptype;
  929.   cs:=cs+c;
  930.   putbuf(sndbuf,c);                                   { PACKET TYPE }
  931.   FOR i:=1 TO len DO
  932.     BEGIN
  933.       c:=filbuf.ch[i];
  934.       cs:=cs+c;
  935.       putbuf(sndbuf,c)                            { ADD PACKET DATA }
  936.     END;
  937.   c:=makechar(checksum(cs));
  938.   putbuf(sndbuf,c);                        { ADD CHECKSUM TO PACKET }
  939.   IF (remeol<>asccr) AND (remeol<>asclf) THEN
  940.     putbuf(sndbuf,remeol)             { EOL MARKER AT END OF PACKET }
  941. END;
  942.  
  943. PROCEDURE sndpkt;
  944.  
  945. VAR                           { NEED CONTIGUOUS PACKED DATA FOR SVC }
  946.   tbuf:PACKED ARRAY[1..maxbuf]OF ascval;
  947.   ens:integer;                      { ENCODE PROCEDURE ERROR BUFFER }
  948.  
  949. BEGIN
  950.   IF sndlog THEN write(lfile,'SND <');
  951.   FOR i:=1 TO sndbuf.ln DO
  952.     BEGIN
  953.       tbuf[i]:=sndbuf.ch[i];                    { PACK DATA FOR SVC }
  954.       IF sndlog THEN                                       { LOG IT }
  955.         write(lfile,chr(sndbuf.ch[i]))
  956.     END;
  957.   tbuf[sndbuf.ln+1]:= #0D;                          { SEND EOL CHAR }
  958.   IF sndlog THEN
  959.     write(lfile,'#0D');                                    { LOG IT }
  960.   writdev(ps,true,(sndbuf.ln+1),location(tbuf)); {WRITE(send) PACKET}
  961.   IF ps.stat<>0 AND sndlog THEN
  962.     write(lfile,'  ERR IN SNDPKT: ',ps.stat hex,'  ');
  963.   IF local THEN
  964.     BEGIN                           { DISPLAY SEND OR RECEIVE STATS }
  965.       IF sending THEN
  966.         BEGIN
  967.                                                        {$NO WARNINGS}
  968.           percent:=recsred/rs.filesize*100;
  969.                                       { PERCENT OF FILE SENT SO FAR }
  970.                                                           {$WARNINGS}
  971.           ssbuf:='     %     #0D';             { DISPLAY % TEMPLATE }
  972.           IF state=sbreak THEN             { DONE SENDING THIS FILE }
  973.             BEGIN
  974.               sending :=false;                  { BREAK OUT OF HERE }
  975.               ssbuf:='100.0%  OK#0D#0A'
  976.             END
  977.           ELSE
  978.             encode(ssbuf,1,ens,percent:5:1);
  979.                                           { PLACE PERCENT IN STRING }
  980.           writdev(ts,true,12,location(ssbuf))
  981.                                          { DISPLAY PERCENT COMPLETE }
  982.         END
  983.       ELSE
  984.         IF receiving THEN
  985.           BEGIN
  986.             pktsnt:=succ(pktsnt);
  987.             ssbuf:='<=#0D#0A        ';
  988.             IF rcvtyp=ascb THEN          { DONE RECEIVING THIS FILE }
  989.               BEGIN
  990.                 receiving:=false;
  991.                 ssbuf:='  COMPLETE#0D#0A';
  992.                 writdev(ts,true,12,location(ssbuf))
  993.               END
  994.             ELSE
  995.               BEGIN
  996.                 IF pktsnt>=36 THEN       { NEW LINE FOR NEAT FORMAT }
  997.                   BEGIN
  998.                     writdev(ts,true,4,location(ssbuf));
  999.                     pktsnt:=0
  1000.                   END
  1001.                 ELSE
  1002.                   writdev(ts,true,2,location(ssbuf))
  1003.               END
  1004.           END
  1005.     END;
  1006.   IF sndlog THEN
  1007.     writeln(lfile,'>')
  1008. END;
  1009.  
  1010.                                            { File output PROCEDURES }
  1011.  
  1012. PROCEDURE wrtrec;
  1013.  
  1014. VAR
  1015.   c:char;
  1016.  
  1017. BEGIN
  1018.   IF wrtlog THEN write(lfile,'WRT [');
  1019.   FOR i:=1 TO wrtbuf.ln DO
  1020.     BEGIN
  1021.       c:=chr(wrtbuf.ch[i]);               { ASCII VALUE MAY BE >127 }
  1022.       IF NOT binary THEN
  1023.         write(wfile,c)                             { TEXT CHARACTER }
  1024.       ELSE
  1025.         BEGIN
  1026.           bptr:=succ(bptr);           { ADVANCE BINARY CHAR BUF PTR }
  1027.           IF bptr>size(bbuf) THEN            { BUF FULL -> WRITE IT }
  1028.             BEGIN
  1029.               write(wbfile,bbuf); { WRITE BUF INCLUDING TRAIL BLNKS }
  1030.               bptr:=1                               { RESET BUF PTR }
  1031.             END;
  1032.           bbuf[bptr]:=c                            { STORE OUR CHAR }
  1033.         END;
  1034.       IF wrtlog THEN
  1035.         write(lfile,c)
  1036.     END;
  1037.   IF NOT binary THEN
  1038.     writeln(wfile);
  1039.   IF wrtlog THEN writeln(lfile,']');
  1040.   bufinit(wrtbuf)
  1041. END;
  1042.  
  1043. PROCEDURE wrtcls;                                  {System dependent}
  1044.  
  1045. BEGIN
  1046.   IF wstatus=open THEN
  1047.     BEGIN
  1048.       IF wrtbuf.ln>0 THEN wrtrec;
  1049.       IF binary THEN          { TAKE CARE OF REMAINING BINARY CHARS }
  1050.         BEGIN
  1051.           FOR i:=(bptr+1) TO (size(bbuf)) DO
  1052.             bbuf[i]:=' ';               { BLANK FILL REST OF RECORD }
  1053.           write(wbfile,bbuf);            { WRITE LAST BINARY RECORD }
  1054.           close(wbfile)
  1055.         END
  1056.       ELSE
  1057.         close(wfile)                 { CLOSE THE FILE BEING WRITTEN }
  1058.     END;
  1059.   wstatus:=closed
  1060. END;
  1061.  
  1062. PROCEDURE wrtopn;
  1063. VAR
  1064.   wstat: boolean;
  1065.  
  1066. BEGIN
  1067.   wrtcls;
  1068.   IF binary THEN
  1069.     BEGIN                      { OPEN SPECIAL FILE FOR BINARY CHARS }
  1070.     { ACTUALLY WE USE FILE OF CHAR80 TO AVOID TRAIL BLNK TRUNCATION }
  1071.       set$acnm(location(wbfile),location(fname));
  1072.                                                   { SET PASCAL NAME }
  1073.       ioterm(wbfile,oval,false);         { TURN OFF I/O TERM ON ERR }
  1074.       rewrite(wbfile);              { I HOPE THEY WANT A CLEAR FILE }
  1075.       wstat:= status(wbfile)=0;              { CHECK FOR OPEN ERROR }
  1076.       ioterm(wbfile,oval,true)       { TURN BACK ON I/O TERM ON ERR }
  1077.     END
  1078.   ELSE
  1079.     BEGIN               { OPEN NORMAL TEXT FILE FOR NON-BINARY DATA }
  1080.       set$acnm(location(wfile),location(fname));
  1081.                                                   { SET PASCAL NAME }
  1082.       ioterm(wfile,oval,false);          { TURN OFF I/O TERM ON ERR }
  1083.       rewrite(wfile);               { I HOPE THEY WANT A CLEAR FILE }
  1084.       wstat:= status(wfile)=0;               { CHECK FOR OPEN ERROR }
  1085.       ioterm(wfile,oval,true)        { TURN BACK ON I/O TERM ON ERR }
  1086.     END;
  1087.   IF wstat THEN wstatus:=open;
  1088.   bufinit(wrtbuf)
  1089. END;
  1090.  
  1091. PROCEDURE wrtasc(a:ascval);
  1092.  
  1093. BEGIN
  1094.   IF wrtbuf.ln >=maxwrt THEN wrtrec;
  1095.   putbuf(wrtbuf,a)
  1096. END;
  1097.  
  1098. PROCEDURE putrec(buf: ascbuf);
  1099.                               { Process data portion of data packet }
  1100. VAR
  1101.   i,repcnt:integer;
  1102.   a:ascval;
  1103.   qflag: boolean;
  1104.  
  1105. BEGIN
  1106.   i:=1;
  1107.   WHILE i<= buf.ln DO
  1108.     BEGIN
  1109.       a:=buf.ch[i];
  1110.       i:=succ(i);
  1111.       repcnt:=1;
  1112.       IF a=remrep THEN
  1113.         BEGIN                            { REPEAT CHAR SYMBOL FOUND }
  1114.           repcnt:=unchar(buf.ch[i]);             { GET REPEAT COUNT }
  1115.           i:=succ(i);
  1116.           a:=buf.ch[i];                            { CHAR TO REPEAT }
  1117.           i:=succ(i)
  1118.         END;
  1119.       qflag:= a=remqu8;                               { 8th BIT SET }
  1120.       IF qflag THEN
  1121.         BEGIN                                      { THEN HANDLE IT }
  1122.           a:=buf.ch[i];
  1123.           i:=succ(i)
  1124.         END;
  1125.       IF a=remquo THEN
  1126.         BEGIN                                         { 7th BIT SET }
  1127.           a:=buf.ch[i];
  1128.           i:=succ(i);
  1129.           IF (a<>remquo) AND (a<>remqu8) AND (a<>remrep) THEN
  1130.             a:=tog64(a)
  1131.         END;
  1132.       IF qflag THEN
  1133.         a:=tog128(a);
  1134.       FOR j:=1 TO repcnt DO
  1135.         BEGIN                                  { WRITE DATA TO FILE }
  1136.           IF a=asclf THEN
  1137.             BEGIN
  1138.               IF lfeol OR gotcr THEN
  1139.                 BEGIN
  1140.                   wrtrec;
  1141.                   gotcr:=false
  1142.                 END
  1143.               ELSE
  1144.                 BEGIN
  1145.                   wrtasc(a)
  1146.                 END
  1147.             END
  1148.           ELSE
  1149.             BEGIN
  1150.               IF gotcr THEN
  1151.                 BEGIN
  1152.                   wrtasc(asccr);
  1153.                   gotcr:=false
  1154.                 END;
  1155.               IF a=asccr THEN
  1156.                 BEGIN
  1157.                   IF creol THEN
  1158.                     BEGIN
  1159.                       wrtrec
  1160.                     END
  1161.                   ELSE
  1162.                     IF crlfeol THEN
  1163.                       BEGIN
  1164.                         gotcr:=true
  1165.                       END
  1166.                     ELSE
  1167.                       BEGIN
  1168.                         wrtasc(a)
  1169.                       END
  1170.                 END
  1171.               ELSE
  1172.                 BEGIN
  1173.                   wrtasc(a)
  1174.                 END
  1175.             END
  1176.         END
  1177.     END
  1178. END;
  1179.  
  1180. PROCEDURE redrec;                                      { File input }
  1181.  
  1182. VAR c: char;
  1183.   a: ascval;
  1184.  
  1185. BEGIN
  1186.   bufinit(redbuf);
  1187.   IF redix >= 0 AND NOT binary THEN
  1188.     readln(rfile);                        { GET TEXT RECORD TO TASK }
  1189.   IF binary THEN
  1190.     BEGIN
  1191.       IF eof(rbfile) THEN
  1192.         reof:=true
  1193.       ELSE
  1194.         read(rbfile,bbuf)                     { READ 80 CHAR RECORD }
  1195.     END;
  1196.   redix:=0;
  1197.   IF NOT binary THEN
  1198.     reof:= eof(rfile);
  1199.   IF NOT reof THEN                     { NOT EOF ON FILETYPE IN USE }
  1200.     BEGIN                    { BINARY TYPE OR TEXT TYPE NOT EOF YET }
  1201.       IF redlog THEN write(lfile,'RED [');
  1202.       IF NOT binary THEN
  1203.         WHILE NOT eoln(rfile) DO
  1204.           BEGIN                               { PROCESS TEXT RECORD }
  1205.             read(rfile,c);
  1206.             IF redlog THEN write(lfile,c);
  1207.             a:=ord(c);
  1208.             putbuf(redbuf,a)
  1209.           END
  1210.       ELSE
  1211.         FOR i:=1 TO size(bbuf) DO
  1212.           BEGIN
  1213.             IF redlog THEN write(lfile,bbuf[i]);
  1214.             a:=ord(bbuf[i]);
  1215.             putbuf(redbuf,a)
  1216.           END;
  1217.       recsred:=succ(recsred);              { NUMBER OF RECORDS READ }
  1218.       IF redlog THEN writeln(lfile,']');
  1219.       IF creol OR crlfeol THEN putbuf(redbuf,asccr);
  1220.       IF lfeol OR crlfeol THEN
  1221.         putbuf(redbuf,asclf)
  1222.     END
  1223. END;
  1224.  
  1225. PROCEDURE redopn;                                  {System dependent}
  1226.  
  1227. VAR
  1228.   rstat: boolean;
  1229.  
  1230. BEGIN
  1231.   rstatus:=closed;
  1232.   IF NOT binary THEN
  1233.     BEGIN
  1234.       set$acnm(location(rfile),location(fname));  { SET PASCAL NAME }
  1235.       ioterm(rfile,oval,false);          { TURN OFF I/O TERM ON ERR }
  1236.       reset(rfile);                         { OPEN FILE FOR READING }
  1237.       rstat:= status(rfile)=0;               { CHECK FOR OPEN ERROR }
  1238.       ioterm(rfile,oval,true)        { TURN BACK ON I/O TERM ON ERR }
  1239.     END
  1240.   ELSE                                           { BINARY FILE TYPE }
  1241.     BEGIN
  1242.       set$acnm(location(rbfile),location(fname)); { SET PASCAL NAME }
  1243.       ioterm(rbfile,oval,false);         { TURN OFF I/O TERM ON ERR }
  1244.       reset(rbfile);                        { OPEN FILE FOR READING }
  1245.       rstat:= status(rbfile)=0;              { CHECK FOR OPEN ERROR }
  1246.       ioterm(rbfile,oval,true)       { TURN BACK ON I/O TERM ON ERR }
  1247.     END;
  1248.   IF rstat THEN
  1249.     BEGIN
  1250.       rstatus:=open;
  1251.       IF NOT binary THEN
  1252.         sp:=scb$a(location(rfile))   { GET CALLBLOCK OF FILE OPENED }
  1253.       ELSE                                                 { BINARY }
  1254.         sp:=scb$a(location(rbfile)); { GET CALLBLOCK OF FILE OPENED }
  1255.       s.svc:=0;                  { SET UP READ FILE CHARACTERISTICS }
  1256.       s.subop:=rfc;                                     { SUBOPCODE }
  1257.       s.buf:=location(rs);                 { CHARACTERISTICS BUFFER }
  1258.       s.lrl:=size(rs);
  1259.       s.lun:=sp@.lun;                                 { LUNO NUMBER }
  1260.       svc$(location(s));                          { PERFORM THE SVC }
  1261.       IF lstatus = open THEN
  1262.         BEGIN                     { RECORD SVC STATUS AND FILE SIZE }
  1263.           writeln(lfile,'THE SVC RFC STATUS: ',s.stat hex);
  1264.           writeln(lfile,'FILE SIZE IS: ',rs.filesize);
  1265.         END;
  1266.   { RS.FILESIZE IS THE NO. OF RECORDS IN FILE USED FOR DISPLAYING % }
  1267.       IF rs.filesize=0 THEN rs.filesize:=100;
  1268.       recsred:=0
  1269.     END;
  1270.   reof:=false;                             { NO EOF ENCOUNTERED YET }
  1271.   redix:= -1;
  1272.   redbuf.ln:= -1
  1273. END;
  1274.  
  1275. PROCEDURE redcls;
  1276.  
  1277. BEGIN
  1278.   IF rstatus=open THEN                        { SEE IF FILE IS OPEN }
  1279.     BEGIN
  1280.       IF NOT binary THEN
  1281.         close(rfile)                               { CLOSE THE FILE }
  1282.       ELSE
  1283.         close(rbfile)
  1284.     END;
  1285.   rstatus:=closed
  1286. END;
  1287.  
  1288. PROCEDURE getrec;               { Build data portion of data packet }
  1289.  
  1290. VAR a: ascval;
  1291.   exit: boolean;
  1292.   prevln,previx,tix: integer;
  1293.  
  1294. BEGIN
  1295.   bufinit(filbuf);
  1296.         { WE MUST IMPLEMENT SPECIAL EOF HANDLING FOR FILE OF CHAR80 }
  1297.   IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
  1298.     BEGIN
  1299.       rstatus:=endfile
  1300.     END
  1301.   ELSE
  1302.     BEGIN
  1303.       exit:=false;
  1304.       REPEAT
  1305.         IF redix >= redbuf.ln THEN
  1306.           BEGIN
  1307.             redrec;
  1308.             IF (NOT binary AND eof(rfile)) OR (binary AND reof) THEN
  1309.               BEGIN
  1310.                 exit:=true;
  1311.                 IF filbuf.ln=0 THEN
  1312.                   rstatus:=endfile
  1313.               END
  1314.           END;
  1315.         IF redix < redbuf.ln THEN
  1316.           BEGIN
  1317.             prevln:=filbuf.ln;
  1318.             previx:=redix;
  1319.             redix:=redix+1;
  1320.             a:=redbuf.ch[redix];
  1321.             IF locrep<>0 THEN
  1322.               BEGIN
  1323.                 tix:=redix+1;
  1324.                 WHILE (a=redbuf.ch[tix]) AND (tix<=redbuf.ln) DO
  1325.                   tix:=tix+1;
  1326.                 tix:=tix-redix;         {tix is now the repeat count}
  1327.                 IF tix>3 THEN
  1328.                   BEGIN
  1329.                     IF tix>94 THEN tix:=94;
  1330.                     putbuf(filbuf,locrep);
  1331.                     putbuf(filbuf,makechar(tix));
  1332.                     redix:=redix-1+tix
  1333.                   END
  1334.               END;
  1335.             IF (a>127) THEN
  1336.               BEGIN
  1337.                 IF locqu8<>0 THEN putbuf(filbuf,locqu8);
  1338.                 a:=tog128(a)
  1339.               END;
  1340.             IF (a<32) OR (a=ascdel) THEN
  1341.               BEGIN
  1342.                 putbuf(filbuf,locquo);
  1343.                 a:=tog64(a)
  1344.               END;
  1345.             IF (a=locquo) OR (a=locqu8) OR (a=locrep) THEN
  1346.               BEGIN
  1347.                 putbuf(filbuf,locquo)
  1348.               END;
  1349.             putbuf(filbuf,a);
  1350.             IF filbuf.ln >= remdsiz THEN
  1351.               BEGIN
  1352.                 exit:=true;
  1353.                 IF filbuf.ln>remdsiz THEN
  1354.                   BEGIN
  1355.                {Character expansion caused buffer length to be
  1356.                 exceeded.  Back up.}
  1357.                   filbuf.ln:=prevln;
  1358.                     redix:=previx
  1359.                   END
  1360.               END
  1361.           END
  1362.       UNTIL exit
  1363.     END
  1364. END;
  1365.  
  1366. PROCEDURE gencmd(r:ascbuf);
  1367.  
  1368. BEGIN                                                      { GENCMD }
  1369.   IF r.ch[1]=ascl THEN                     { EXIT KERMIT AND LOGOFF }
  1370.     BEGIN
  1371.       sndpkt;                                            { SEND ACK }
  1372.       ssbuf:='$QUIT       ';     { SCI SYNONYM FOR LOGOFF UPON EXIT }
  1373.       FOR i:=1 TO 5 DO
  1374.         syn[i]:=ssbuf[i];
  1375.       syn[0]:='#05';                               { SET SYN LENGTH }
  1376.       ssbuf:='YES         ';                     { VALUE OF SYNONYM }
  1377.       FOR i:=1 TO 3 DO
  1378.         val[i]:=ssbuf[i];                                 { MOVE IT }
  1379.       val[0]:='#03';                                       { LENGTH }
  1380.       store$syn(syn,val);           { SET $QUIT SYN IN CALLING PROC }
  1381.       server:=false;                                  { EXIT SERVER }
  1382.       state:=kexit                                    { EXIT KERMIT }
  1383.     END
  1384.   ELSE
  1385.     IF r.ch[1]=ascf THEN                         { JUST EXIT KERMIT }
  1386.       BEGIN
  1387.         sndpkt;                                          { SEND ACK }
  1388.         server:=false;                                { EXIT SERVER }
  1389.         state:=kexit                                  { EXIT KERMIT }
  1390.       END
  1391.     ELSE
  1392.       error('UNSUPPORTED GENERIC COMMAND.            ')
  1393. END;                                                       { GENCMD }
  1394.  
  1395. PROCEDURE sendinitiate;                               { Send states }
  1396.  
  1397. BEGIN
  1398.   IF fnlen>0 THEN
  1399.     BEGIN
  1400.       redopn;
  1401.       IF rstatus=open THEN
  1402.         BEGIN
  1403.           putpar;                        {Put parameters into buffer}
  1404.           makepacket(ascs,seq,filbuf.ln);
  1405.                                     {Make packet with our parameters}
  1406.           numtry:=0;
  1407.           state:=sheader
  1408.         END
  1409.       ELSE
  1410.         error('ERROR OPENING READ FILE                 ')
  1411.     END
  1412.   ELSE
  1413.     error('NO READ FILE SPECIFIED                  ')
  1414. END;
  1415.  
  1416. PROCEDURE sendheader;
  1417.  
  1418. VAR
  1419.   wrkbuf:flen;             { WORKING BUFFER FOR FILENAME EXTRACTION }
  1420.   cptr:integer;                               { A TEMP CHAR POINTER }
  1421.  
  1422. BEGIN
  1423.   IF rcvtyp=ascy THEN
  1424.     BEGIN
  1425.       headok:=true;
  1426.       IF NOT sndonly THEN getpar;
  1427.                               {Get parameters from ACK of 'S' packet}
  1428.       IF rfnlen>0 THEN
  1429.         BEGIN          { USER SPECIFIED REMOTE FILENAME - USE AS IS }
  1430.           lintobuf(rfname,rfnlen,filbuf)     {Send remote file name.}
  1431.         END
  1432.       ELSE
  1433.         BEGIN                      { USE LOCAL FILE NAME FOR REMOTE }
  1434.  
  1435. { WE MUST STRIP ANY UNUSUAL CHARS AND/OR DIRECTORY NAMES FROM LOCAL
  1436.   PATH TO BUILD A REMOTE FILENAME.  KERMIT DOES ALLOW THE USE OF A
  1437.   DOT WITHIN A FILENAME, BUT SINCE DX10 DOESN'T AND DX10 IS THE
  1438.   ORIGINATING SYSTEM, WE WILL ONLY ALLOW UPPERCASE CHARS AND DIGITS
  1439.   WITHIN A FILENAME.  IF THE USER WANTS ANYTHING ELSE - THEN USE THE
  1440.   REMOTE FILE OPTION ON SEND COMMAND -  THAT'S WHAT IT'S THERE FOR. }
  1441.  
  1442.           FOR k:=1 TO maxflen DO
  1443.             wrkbuf[k]:=' ';        { CLEAR FILE NAME WORKING BUFFER }
  1444.           cptr:=fnlen+1;                 { POINT TO END OF FILENAME }
  1445.           WHILE cptr>2 AND fname[cptr]<>'.' DO
  1446.             BEGIN              { EXTRACT LOCAL FILE NAME FOR REMOTE }
  1447.               IF fname[cptr]<>'$' AND fname[cptr]<>'_' THEN
  1448.                 wrkbuf[cptr]:=fname[cptr]
  1449.               ELSE { WE'LL REPLACE ANY ILLEGAL CHARS WITH 0 - SORRY }
  1450.                 wrkbuf[cptr]:='0';
  1451.               cptr:=pred(cptr)
  1452.             END;         { GOT A FILE NAME - NOW PUT IN RIGHT PLACE }
  1453.           rfnlen:=2;                { NOW KEEP TRACK OF LENGTH ALSO }
  1454.           FOR k:=1 TO maxflen DO
  1455.             IF wrkbuf[k]<>' ' THEN
  1456.               BEGIN         { EXTRACT GOOD NAME FROM WORKING BUFFER }
  1457.                 rfname[rfnlen]:=wrkbuf[k];       { GRAB A GOOD CHAR }
  1458.                 rfnlen:=succ(rfnlen)
  1459.               END;
  1460.           rfnlen:=rfnlen-2;           { ADJUST FOR TRUE NAME LENGTH }
  1461.           rfname[1]:=chr(rfnlen);
  1462.           lintobuf(rfname,rfnlen,filbuf)  { SEND ADJUSTED FILE NAME }
  1463.         END;
  1464.       numtry:=0;
  1465.       seq:=(seq+1) MOD 64;
  1466.       makepacket(ascf,seq,filbuf.ln);
  1467.       state:=sdata
  1468.     END
  1469. END;
  1470.  
  1471. PROCEDURE senddata;
  1472.  
  1473. BEGIN
  1474.   IF rcvtyp=ascy THEN
  1475.     BEGIN
  1476.       IF headok THEN          { LAST PACKET - FILE HEADER WAS ACKed }
  1477.         BEGIN
  1478.           sending:=true;                       { START SENDING FILE }
  1479.           headok:=false;                        { RESET HEADER FLAG }
  1480.           bsbuf:= 'SENDING FILE:                           ';
  1481.           writdev(ts,true,15,location(bsbuf));
  1482.           FOR k:=1 TO fnlen DO
  1483.             bsbuf[k]:=fname[k+1];
  1484.           writdev(ts,true,fnlen,location(bsbuf));
  1485.           ssbuf:=' ==>        ';
  1486.           writdev(ts,true,5,location(ssbuf));
  1487.           FOR k:=1 TO rfnlen DO
  1488.             bsbuf[k]:=rfname[k+1];
  1489.           writdev(ts,true,rfnlen,location(bsbuf));
  1490.           tcbuf:=crlf;
  1491.           writdev(ts,true,2,location(tcbuf))
  1492.         END;
  1493.       getrec;
  1494.       numtry:=0;
  1495.       seq:=(seq+1) MOD 64;
  1496.       IF rstatus = open THEN
  1497.         makepacket(ascd,seq,filbuf.ln)
  1498.       ELSE
  1499.         BEGIN
  1500.           makepacket(ascz,seq,0);
  1501.           state:=sbreak;
  1502.           fnlen:=0
  1503.         END
  1504.     END
  1505. END;
  1506.  
  1507. PROCEDURE sendbreak;
  1508.  
  1509. BEGIN
  1510.   IF rcvtyp=ascy THEN
  1511.     BEGIN
  1512.       numtry:=0;
  1513.       seq:=(seq+1) MOD 64;
  1514.       makepacket(ascb,seq,0)
  1515.     END;
  1516.   state:=wexit
  1517. END;
  1518.  
  1519.                                         { Receive states PROCEDURES }
  1520.  
  1521. PROCEDURE rcvinitiate;
  1522.  
  1523. BEGIN
  1524.   IF rcvtyp=ascs THEN
  1525.     BEGIN
  1526.       getpar;                            {Get parameters from packet}
  1527.       putpar;                            {Put parameters into buffer}
  1528.       makepacket(ascy,seq,filbuf.ln);
  1529.                                 {Make ACK packet with our parameters}
  1530.       seq:=rcvseq;
  1531.       numtry:=0;
  1532.       seq:=(seq+1) MOD 64;
  1533.       state:=rheader
  1534.     END
  1535. END;
  1536.  
  1537. PROCEDURE rcvheader;
  1538.  
  1539. BEGIN
  1540.   IF rcvtyp=ascf THEN
  1541.     BEGIN
  1542.       IF fnlen=0 THEN
  1543.         BEGIN                                { USE REMOTE FILE NAME }
  1544.           buftolin(rcvbuf,fname,fnlen);
  1545.         END;
  1546.       IF fnlen>0 THEN
  1547.         BEGIN                  { GOT A FILE TO RECEIVE TO - OPEN IT }
  1548.           wrtopn;
  1549.           IF wstatus=open THEN
  1550.             BEGIN
  1551.               makepacket(ascy,seq,0);
  1552.               numtry:=0;
  1553.               seq:=(seq+1) MOD 64;
  1554.               headok:=true;
  1555.               state:=rdata
  1556.             END
  1557.           ELSE
  1558.             error('ERROR OPENING WRITE FILE                ')
  1559.         END
  1560.       ELSE
  1561.         error('NO OUTPUT FILE SPECIFIED                ')
  1562.     END
  1563.   ELSE
  1564.     IF rcvtyp=ascb THEN
  1565.       BEGIN
  1566.         makepacket(ascy,seq,0);
  1567.         sndpkt;
  1568.         state:=cexit
  1569.       END
  1570.     ELSE
  1571.       IF rcvtyp=ascg THEN
  1572.         BEGIN
  1573.           makepacket(ascy,seq,0);                     { ACKNOWLEDGE }
  1574.           numtry:=0;
  1575.           gencmd(rcvbuf)               { PROCESS GENERIC KERMIT CMD }
  1576.         END
  1577.       ELSE
  1578.         error('WRONG PACKET RECEIVING FILE HEADER      ')
  1579. END;
  1580.  
  1581. PROCEDURE receivedata;
  1582.  
  1583. BEGIN
  1584.   IF rcvtyp=ascd THEN
  1585.     BEGIN
  1586.       IF headok THEN          { LAST PACKET - FILE HEADER WAS ACKed }
  1587.         BEGIN
  1588.           receiving:=true;                   { START RECEIVING FILE }
  1589.           headok:=false;                        { RESET HEADER FLAG }
  1590.           bsbuf:= 'RECEIVING FILE:                         ';
  1591.           writdev(ts,true,17,location(bsbuf));
  1592.           FOR k:=1 TO rfnlen DO
  1593.             bsbuf[k]:=rfname[k+1];
  1594.           writdev(ts,true,rfnlen,location(bsbuf));
  1595.           ssbuf:=' ==>        ';
  1596.           writdev(ts,true,5,location(ssbuf));
  1597.           FOR k:=1 TO fnlen DO
  1598.             bsbuf[k]:=fname[k+1];
  1599.           writdev(ts,true,fnlen,location(bsbuf));
  1600.           tcbuf:=crlf;
  1601.           writdev(ts,true,2,location(tcbuf))
  1602.         END;
  1603.       putrec(rcvbuf);
  1604.       makepacket(ascy,seq,0);
  1605.       numtry:=0;
  1606.       seq:=(seq+1) MOD 64
  1607.     END
  1608.   ELSE
  1609.     IF rcvtyp=ascz THEN             { RECEIVED EOF INDICATOR PACKET }
  1610.       BEGIN
  1611.         wrtcls;
  1612.         fnlen:=0;
  1613.         makepacket(ascy,seq,0);
  1614.         numtry:=0;
  1615.         seq:=(seq+1) MOD 64;
  1616.         state:=rheader
  1617.       END
  1618.     ELSE
  1619.       error('UNEXPECTED PACKET RECEIVING DATA        ')
  1620. END;
  1621.  
  1622. PROCEDURE get;                                { PREPARE AN R PACKET }
  1623.  
  1624. BEGIN
  1625.   IF rcvtyp=ascy THEN
  1626.     BEGIN                    { I PACKET ACKed - CONTINUE NEXT STATE }
  1627.       lintobuf(rfname,rfnlen,filbuf);       { SEND FILE NAME TO GET }
  1628.       numtry:=0;
  1629.       makepacket(ascr,seq,filbuf.ln);
  1630.       state:=rinitiate
  1631.     END
  1632. END;
  1633.  
  1634. PROCEDURE iinitiate;
  1635.  
  1636. BEGIN
  1637.   putpar;                                {Put parameters into buffer}
  1638.   makepacket(asci,seq,filbuf.ln);         { MAKE I PARAMETER PACKET }
  1639.   numtry:=0
  1640. END;
  1641.  
  1642. PROCEDURE finish;              { SHUT DOWN REMOTE SERVER AND KERMIT }
  1643.  
  1644. BEGIN
  1645.   bufinit(filbuf);
  1646.   putbuf(filbuf,ascf);
  1647.   makepacket(ascg,seq,filbuf.ln);   {Make packet with our parameters}
  1648.   numtry:=0;
  1649.   state:=wexit
  1650. END;
  1651.  
  1652. PROCEDURE bye;           { SHUT DOWN REMOTE SERVER, KERMIT & LOGOFF }
  1653.  
  1654. BEGIN
  1655.   bufinit(filbuf);
  1656.   putbuf(filbuf,ascl);
  1657.   makepacket(ascg,seq,filbuf.ln);   {Make packet with our parameters}
  1658.   numtry:=0;
  1659.   state:=wexit
  1660. END;
  1661.  
  1662. PROCEDURE connect;                              { CONNECT TO REMOTE }
  1663.  
  1664.       { THE PROCEDURE CONNECT IS A SIMPLE TTY TYPE EMULATOR USED TO }
  1665.   { CONNECT REMOTE SYSTEMS OR MODEMS.  FULL DUPLEX I/O IS EMULATED. }
  1666.   { I/O IS ACCOMPLISHED VIA SVC CALLS.  CALLS TO PROCEDURES TO PER- }
  1667.   { FORM READS AND WRITES HAVE BEEN REMOVED FOR GREATER SPEED -     }
  1668.   { ESPECIALLY NEEDED FOR CHARACTER INPUT.  A WAIT ON ANY I/O       }
  1669.   { CALL IS MADE WHEN NOTHING IS GOING ON - TO AVOID SPINNING.      }
  1670.   { IF WE GET AN INPUT BUFFER OVERFLOW(I.E. THE CHARACTERS ARE COM- }
  1671.   { ING IN FASTER THAN WE CAN HANDLE THEM),THEN WE WILL DYNAMICALLY }
  1672.   { ADJUST OUR XOFF THRESHOLD(I.E. NUMBER OF CHARACTERS TO RECEIVE  }
  1673.   { AT ONE TIME BEFORE SENDING AN XOFF) TO ADAPT TO THE SYSTEM.     }
  1674.  
  1675.  
  1676.  
  1677. VAR
  1678.   escseq:boolean;                         { ESCAPE FROM REMOTE HOST }
  1679.   xbuf:char2;                              { XON - XOFF CHAR BUFFER }
  1680.   fq,bq:integer;                                    { CHAR POINTERS }
  1681.   xoff:boolean;                              { XOFF-XON IN PROGRESS }
  1682.   wrt:boolean;                  { WRITE TO TERMINAL IS TAKING PLACE }
  1683.   b:boolean;                                { DOUBLE BUFFER POINTER }
  1684.   bufp:ARRAY[boolean]OF buf;        { REMOTE CONNECT DOUBLE BUFFERS }
  1685.   justread:char;                            { FOR ECHO CHAR CONTROL }
  1686.   ti:integer;                            { GET CHAR LOOP CONTROLLER }
  1687.   dummy:char2;                       { JUNK TO SATISFY A WRITE NEED }
  1688.   adjustxoff:integer; { CURRENT NO. OF CHARS TO RECEIVE BEFORE XOFF }
  1689.   inesc:integer;                              { CHEAP EMULATOR FLAG }
  1690.   seqnum:integer;   { HOW MANY ESQ SEQ. CHARS TO THROW AWAY FOR ISC }
  1691.   twochar:boolean;                               { DOUBLE CHAR FLAG }
  1692.  
  1693. BEGIN
  1694.   seqnum:=0;
  1695.   inesc:=0;                          { NO VALID CHARACTER TO OUTPUT }
  1696.   twochar:=false;                  { NO 2 CHAR SEQUENCE TO SEND YET }
  1697.   adjustxoff:=xoff_threshold;                   { SET INITIAL VALUE }
  1698.   bq:=0;
  1699.   fq:=0;
  1700.   w1.op:= #36;          { SET WAIT ON ANY I/O COMPLETION SVC OPCODE }
  1701.   w1.fil1:=0;                             { CLEAR REST OF CALLBLOCK }
  1702.   w1.fil2:=0;
  1703.   w1.fil3:=0;
  1704.   dummy:='#08#08';
  1705.   xbuf:='#13#11';                    { XOFF AND XON FOR I/O CONTROL }
  1706.   xoff:=false;
  1707.   wrt:=false;
  1708.   b:=true;
  1709.   escseq:=false;
  1710.   ti:=0;
  1711.   ps.subop:=readas;                          { READ ASCII SUBOPCODE }
  1712.   ps.flags:=[qret];                              { QUICK RETURN I/O }
  1713.   ps.buf:=location(pcbuf);                             { SET BUFFER }
  1714.   ps.lrl:=1;                              { READ A SINGLE CHARACTER }
  1715.   svc$(location(ps));                       { PERFORM I/O OPERATION }
  1716.   ts.subop:=readas;                          { READ ASCII SUBOPCODE }
  1717.   ts.flags:=[qret];                              { QUICK RETURN I/O }
  1718.   ts.buf:=location(tcbuf);                             { SET BUFFER }
  1719.   ts.lrl:=1;                              { READ A SINGLE CHARACTER }
  1720.   svc$(location(ts));                       { PERFORM I/O OPERATION }
  1721.  
  1722.                                         { UNTIL ESCAPE SEQ IS TYPED }
  1723.   WHILE NOT escseq AND ts.stat=0 AND
  1724.       (ps.stat=0 OR (ps.stat>=#50 AND ps.stat<=#52)) DO
  1725.     BEGIN                       { PARITY,FRAME,OVERFLOW - NON-FATAL }
  1726.  
  1727.       IF ps.stat>=#50 AND ps.stat<=#52 THEN
  1728.         BEGIN   { NOT FATAL - i.e. HOPEFULLY THINGS WILL GET BETTER }
  1729.           IF ps.stat=#52 THEN
  1730.             BEGIN                                  { OVERFLOW ERROR }
  1731.               IF lstatus=open THEN
  1732.                 BEGIN
  1733.                   writeln(lfile,'PORT FULL BUFFER ERROR');
  1734.                   writeln(lfile,'CHARS BUFFED SO FAR: ',fq)
  1735.                 END;
  1736.    { ATTEMPT TO ADJUST XOFF THRESHOLD FOR CURRENT SYSTEM CONDITIONS }
  1737.    { BUT KEEP ABOVE MINIMUM TO AVOID XOFFING EVERY LINE OR TWO.     }
  1738.       { ADJUSTING XOFF THRESHOLD IS EXPERIMENTAL AND MAY BE REMOVED }
  1739.               IF fq>200 AND fq<adjustxoff THEN
  1740.                 adjustxoff:=fq
  1741.             END
  1742.           ELSE
  1743.             IF ps.stat=#51 THEN
  1744.               BEGIN
  1745.                 IF lstatus=open THEN
  1746.                   writeln(lfile,'PORT FRAMING ERROR')
  1747.               END
  1748.             ELSE                              { JUST A PARITY ERROR }
  1749.               BEGIN
  1750.                 IF lstatus=open THEN
  1751.                   writeln(lfile,'PARITY ERROR ON PORT.')
  1752.               END;
  1753.           ps.stat:=0;                               { CLEAR THE ERR }
  1754.           svc$(location(ps))                         { REQUEUE READ }
  1755.         END;
  1756.  
  1757.       IF NOT bsy IN ps.flags AND ps.stat=0 THEN
  1758.         BEGIN                 { GOT A CHAR FROM REMOTE SYSTEM/MODEM }
  1759.           ti:=0;                   { RESET GET CHAR LOOP CONTROLLER }
  1760.           WHILE ti<800 AND ps.stat=0 DO
  1761.       { HOW LONG YOU WANT TO STAY IN HERE DEPENDS ON AVOVE CONSTANT }
  1762.             BEGIN
  1763.             { STAY HERE FOR AWHILE IN CASE MORE CHARS ARE COMING IN }
  1764.               IF NOT bsy IN ps.flags THEN
  1765.                 BEGIN                               { READ FINISHED }
  1766.                   fq:=succ(fq);    { NUMBER OF CHARS READ IN SO FAR }
  1767.  (******************************************************************)
  1768.                   IF isc THEN    { A VERY QUICK 931 TO TTY EMULATOR }
  1769.  { THE OBJECTIVE HERE IS TO ATTEMPT TO INHIBIT THE ESCAPE SEQUENCES }
  1770. { THAT GET SENT TO A TI VDT931 TERMINAL, THUS EMULATING A TTY MODE. }
  1771. { IF AN ESCAPE SEQUENCE ARRIVES, THEN THE ESCAPE SEQUENCE WILL BE   }
  1772. { THROWN AWAY.  THE NUMBER OF CHARACTERS TOSSED WILL DEPEND ON THE  }
  1773. { TYPE OF SEQUENCE.  MOST ARE SINGLE CHARACTER SEQUENCES.           }
  1774.                     CASE inesc OF               { OUR PRESENT STATE }
  1775.                       0:
  1776.                         IF pcbuf[1] <> '#1B' THEN
  1777.                           bufp[b,fq]:=pcbuf[1]
  1778.                         ELSE
  1779.                           BEGIN
  1780.                             inesc:=1;
  1781.                             fq:=pred(fq)   { THROW AWAY ESCAPE CHAR }
  1782.                           END;
  1783.                       1:
  1784.                         BEGIN
  1785.                           inesc:=2;          { ASSUME >2 SEQ LENGTH }
  1786. { DEPENDING ON THE ESQ SEQ IDENTIFIER, NUMBER OF CHARS TO TOSS IS SET }
  1787.                           CASE pcbuf[1] OF
  1788.                             'V': seqnum:=1;
  1789.                             'Y':
  1790.                               BEGIN
  1791.                           { DO A CRLF ON A CURSOR POSITION SEQUENCE }
  1792.                                 seqnum:=2;
  1793.                                 bufp[b,fq]:='#0A';
  1794.                                 fq:=succ(fq);
  1795.                                 bufp[b,fq]:='#0D';
  1796.                                 fq:=succ(fq)
  1797.                               END;
  1798.                             '4': seqnum:=1;
  1799.                             '@': seqnum:=2;
  1800.                             '>': seqnum:=2;
  1801.                             'j':seqnum:=2;
  1802.                             'x': seqnum:=4;
  1803.                             '?': seqnum:=3;
  1804.                             'k':
  1805.                               seqnum:=2
  1806.                             OTHERWISE
  1807.                                { JUST TOSS THIS ONE i.e. 2 CHAR SEQ }
  1808.                               inesc:=0
  1809.                                   { AND RETURN TO NORMAL CHAR STATE }
  1810.                             END;
  1811.                           fq:=pred(fq)              { TOSS THE CHAR }
  1812.                         END;
  1813.                       2:
  1814.                         BEGIN
  1815.                           seqnum:=pred(seqnum);
  1816.                             { SET NUMBER OF CHARS REMAINING TO TOSS }
  1817.                           fq:=pred(fq);             { TOSS THIS ONE }
  1818.                           IF seqnum=0 THEN       { ALL DONE TOSSING }
  1819.                             inesc:=0 { RETURN TO NORMAL INPUT STATE }
  1820.                         END
  1821.                       END
  1822.                   ELSE
  1823.  (******************************************************************)
  1824.                     bufp[b,fq]:=pcbuf[1];  { SAVE CHAR - DOUBLE BUF }
  1825.                   IF fq>adjustxoff THEN
  1826.                     BEGIN                    { READ BUF ALMOST FULL }
  1827.                       ps.subop:=writas;     { WRITE ASCII SUBOPCODE }
  1828.                       ps.flags:=[];
  1829.                       ps.buf:=location(xbuf);       { POINT TO XOFF }
  1830.                       ps.cc:=1;               { CHARACTERS TO WRITE }
  1831.                       svc$(location(ps));               { SEND XOFF }
  1832.                       ps.subop:=readas;      { READ ASCII SUBOPCODE }
  1833.                       ps.flags:=[qret];          { QUICK RETURN I/O }
  1834.                       ps.buf:=location(pcbuf);         { SET BUFFER }
  1835.                       ps.lrl:=1;          { READ A SINGLE CHARACTER }
  1836.                       IF ps.stat=0 THEN
  1837.                         svc$(location(ps));     { NOW EMPTY PDT BUF }
  1838.                       WHILE fq<buf_threshold AND ps.stat=0 AND NOT
  1839.                           xoff DO
  1840.                         BEGIN       { EMPTY PDT BUFFER OF ALL CHARS }
  1841.                           IF NOT bsy IN ps.flags THEN
  1842.                             BEGIN
  1843.                               fq:=succ(fq);
  1844.                               bufp[b,fq]:=pcbuf[1];
  1845.                               IF fq<buf_threshold THEN
  1846.                                 svc$(location(ps))
  1847.                               ELSE
  1848.                                 xoff:=true
  1849.                               { ONLY IF USER HAS "LARGE" PDT BUFFER }
  1850.                             END
  1851.                           ELSE
  1852.                             BEGIN
  1853.                               delay(100);
  1854.                               xoff:=bsy IN ps.flags          { DONE }
  1855.                             END
  1856.                         END;
  1857.                       IF lstatus = open THEN
  1858.                         BEGIN
  1859.                           writeln(lfile,'FQ SURPASSED ADJUST IS:',fq);
  1860.                           IF xoff THEN
  1861.                             writeln(lfile,'XOFF WAS JUST SET')
  1862.                         END
  1863.                     END
  1864.                   ELSE
  1865.                     svc$(location(ps));          { CONTINUE READING }
  1866.                   ti:=0              { RESET ITERATION LOOP CONTROL }
  1867.                 END
  1868.               ELSE
  1869.                 ti:=succ(ti)
  1870.             END
  1871.         END
  1872.       ELSE                              { EITHER DEVBSY(PS) OR XOFF }
  1873.         BEGIN
  1874.           IF fq>0 AND NOT wrt AND bsy IN ts.flags AND
  1875.               (bsy IN ps.flags OR xoff) THEN
  1876.             BEGIN
  1877.               IF fq>80 THEN
  1878.                 BEGIN      { LIMITED TO 80 CHAR WRITE WITH PASSTHRU }
  1879.                   bq:=fq-80;
  1880.                   fq:=80
  1881.                 END;
  1882.               abort(ts);
  1883.               ts.subop:=writas;             { WRITE ASCII SUBOPCODE }
  1884.               ts.flags:=[qret];                  { QUICK RETURN I/O }
  1885.               ts.cc:=fq;                      { CHARACTERS TO WRITE }
  1886.               ts.buf:=location(bufp[b]);         { SET WRITE BUFFER }
  1887.               IF isc THEN              { SPECIAL CHARACTER HANDLING }
  1888.                 BEGIN
  1889.                   IF fq=1 AND bufp[b,1]=justread THEN
  1890.                         { THIS IS WHERE WE CAN SUPPRESS ECHO ON ISC }
  1891.                     ts.buf:=location(dummy)  { OR NON-PASSTHRU TERM }
  1892.                   ELSE              { ONLY UPPERCASE ON ISC ALLOWED }
  1893.                     FOR i:=1 TO (bq+fq) DO        { L.C. --> U.CASE }
  1894.                       IF bufp[b,i]>='a' AND bufp[b,i]<='z' THEN
  1895.                         bufp[b,i]:=chr(ord(bufp[b,i])-32)
  1896.                 END;
  1897.               svc$(location(ts));           { PERFORM I/O OPERATION }
  1898.               wrt:=true;
  1899.               b:=NOT b;                   { ENABLE DOUBLE BUFFERING }
  1900.               fq:=0
  1901.             END
  1902.           ELSE
  1903.             IF NOT(wrt OR bsy IN ts.flags OR ts.stat<>0)AND
  1904.                 (bsy IN ps.flags OR xoff) THEN
  1905.               BEGIN                 { READ A CHAR FROM THE TERMINAL }
  1906.                 IF ts.cc=1 THEN
  1907.                   BEGIN
  1908.                     justread:=tcbuf[1];
  1909.                                     { SAVE LAST CHAR READ FROM TERM }
  1910.                     IF tcbuf[1]='#40' OR tcbuf[1]='#5E' OR
  1911.                         tcbuf[1]='#25' THEN
  1912.                       BEGIN                    { SPECIAL CHARACTERS }
  1913.                         tcbuf[2]:=tcbuf[1];
  1914.                                  { SAVE POSSIBLE SPECIAL START CHAR }
  1915.                         svc$(location(ts));
  1916.                                          { TRY FOR SPECIAL SEQUENCE }
  1917.                         delay(200);   { ALLOW DELAY FOR REST OF SEQ }
  1918.                         IF NOT bsy IN ts.flags AND ts.stat=0 THEN
  1919.                           BEGIN                  { GOT ANOTHER CHAR }
  1920.                             IF tcbuf='#40#40' THEN
  1921.                               escseq:=true                { GET OUT }
  1922.                             ELSE
  1923. { IF ON ISC(NO-PASSTHRU TERM) THE FOLLOWING KEY SEQUENCES ARE NEEDED }
  1924.       { IN ORDER TO SEND SPECIAL CONTROL KEYS TO TI REMOTE 931 PORT }
  1925.                               IF tcbuf='#5E#5E' THEN
  1926.                                 BEGIN
  1927.                                   twochar:=true;  { A TWO CHAR SEND }
  1928.                                   tcbuf:='#1B#68'         { CMD KEY }
  1929.                                 END
  1930.                               ELSE
  1931.                                 IF tcbuf='#25#25' THEN
  1932.                                   BEGIN
  1933.                                     twochar:=true;
  1934.                                                   { A TWO CHAR SEND }
  1935.                                     tcbuf:='#1B#67' { BLNK ORGE KEY }
  1936.                                   END
  1937.                                 ELSE
  1938.                                   IF tcbuf='#5E#40' THEN
  1939.                                     tcbuf[1]:='#1B'       { ESQ KEY }
  1940.                                   ELSE
  1941.                                     IF tcbuf='#25#40' THEN
  1942.                                       tcbuf[1]:='#11'    { SEND XON }
  1943.                           END
  1944.                       END
  1945.                   END
  1946.                 ELSE
  1947.                   IF isc THEN               { ONLY FOR ISC TERMINAL }
  1948.                     BEGIN
  1949.                       tcbuf:=crlf;        { HEURISTIC-PROBABLY A CR }
  1950.                       ts.subop:=writas;
  1951.                       ts.flags:=[];
  1952.                       ts.cc:=1;
  1953.                       ts.buf:=location(tcbuf)+1;
  1954.                       svc$(location(ts))          { WRITE LF TO ISC }
  1955.                     END;
  1956.                 IF NOT escseq AND NOT xoff AND ts.stat=0 THEN
  1957.                   BEGIN
  1958.                     abort(ps);
  1959.                     ps.subop:=writas;       { WRITE ASCII SUBOPCODE }
  1960.                     ps.flags:=[];
  1961.                     IF isc AND twochar THEN
  1962.                       BEGIN
  1963.                         twochar:=false;                     { RESET }
  1964.                         ps.cc:=2                    { WRITE 2 CHARS }
  1965.                       END
  1966.                     ELSE
  1967.                       ps.cc:=1;               { CHARACTERS TO WRITE }
  1968.                     ps.buf:=location(tcbuf);           { SET BUFFER }
  1969.                     svc$(location(ps));     { PERFORM I/O OPERATION }
  1970.                     IF ps.stat=0 THEN
  1971.                       BEGIN                   { CONTINUE - NO ERROR }
  1972.                         ps.subop:=readas;    { READ ASCII SUBOPCODE }
  1973.                         ps.flags:=[qret];        { QUICK RETURN I/O }
  1974.                         ps.buf:=location(pcbuf);       { SET BUFFER }
  1975.                         ps.lrl:=1;        { READ A SINGLE CHARACTER }
  1976.                         svc$(location(ps)); { PERFORM I/O OPERATION }
  1977.                         IF NOT bsy IN ts.flags AND ts.stat=0 THEN
  1978.                           BEGIN
  1979.                                { READ POSSIBLY QUEUED ALREADY ABOVE }
  1980.                             ts.subop:=readas;
  1981.                                              { READ ASCII SUBOPCODE }
  1982.                             ts.lrl:=1;         { READ A SINGLE CHAR }
  1983.                             ts.flags:=[qret];    { QUICK RETURN I/O }
  1984.                             ts.buf:=location(tcbuf);   { SET BUFFER }
  1985.                             svc$(location(ts))
  1986.                                             { PERFORM I/O OPERATION }
  1987.                           END
  1988.                       END
  1989.                   END
  1990.               END
  1991.             ELSE
  1992.               IF wrt AND NOT bsy IN ts.flags AND ts.stat=0 AND
  1993.                   (bsy IN ps.flags OR xoff) THEN
  1994.                 BEGIN
  1995.                   IF bq>0 THEN
  1996.                     BEGIN
  1997.                       ts.subop:=writas;     { WRITE ASCII SUBOPCODE }
  1998.                       ts.flags:=[qret];          { QUICK RETURN I/O }
  1999.                       ts.buf:=ts.buf+80;               { SET BUFFER }
  2000.                       IF bq>80 THEN
  2001.                         BEGIN
  2002.                           ts.cc:=80;
  2003.                           bq:=bq-80
  2004.                         END
  2005.                       ELSE
  2006.                         BEGIN
  2007.                           ts.cc:=bq;
  2008.                           bq:=0
  2009.                         END;
  2010.                       svc$(location(ts))
  2011.                     END
  2012.                   ELSE
  2013.                     BEGIN
  2014.                       wrt:=false;
  2015.                       ts.subop:=readas;      { READ ASCII SUBOPCODE }
  2016.                       ts.flags:=[qret];          { QUICK RETURN I/O }
  2017.                       ts.buf:=location(tcbuf);         { SET BUFFER }
  2018.                       svc$(location(ts));   { PERFORM I/O OPERATION }
  2019.                       IF xoff THEN
  2020.                         BEGIN
  2021.                           IF lstatus=open THEN
  2022.                             writeln(lfile,'XOFF BEING RESET');
  2023.                           xoff:=false;
  2024.                           pcbuf[1]:=xbuf[2];
  2025.                           IF bsy IN ps.flags THEN
  2026.                             abort(ps);
  2027.                           ps.subop:=writas; { WRITE ASCII SUBOPCODE }
  2028.                           ps.flags:=[];
  2029.                           ps.buf:=location(pcbuf);     { SET BUFFER }
  2030.                           ps.cc:=1;           { CHARACTERS TO WRITE }
  2031.                           svc$(location(ps));
  2032.                                             { PERFORM I/O OPERATION }
  2033.                           IF ps.stat=0 THEN
  2034.                             ps.subop:=readas;
  2035.                                              { READ ASCII SUBOPCODE }
  2036.                           ps.flags:=[qret];      { QUICK RETURN I/O }
  2037.                           ps.lrl:=1;      { READ A SINGLE CHARACTER }
  2038.                           svc$(location(ps))
  2039.                                             { PERFORM I/O OPERATION }
  2040.                         END
  2041.                     END
  2042.                 END
  2043.         END;
  2044.       IF bsy IN ps.flags AND bsy IN ts.flags AND
  2045.           bq=0 AND fq=0 AND NOT wrt AND NOT xoff THEN
  2046.                                                  { NOTHING GOING ON }
  2047.         svc$(location(w1))    { DONT SPIN - WAIT ANY I/O COMPLETION }
  2048.     END;
  2049.  
  2050.   IF ts.stat<>0 AND lstatus=open THEN
  2051.     BEGIN
  2052.       writeln(lfile,'A TERMINAL SVC ERROR.');
  2053.       writeln(lfile,'THE SVC ERROR IS: ',ts.stat hex);
  2054.       writeln(lfile,'BYE')
  2055.     END;
  2056.   IF ps.stat<>0 AND lstatus=open THEN
  2057.     BEGIN
  2058.       writeln(lfile,'A REMOTE PORT SVC ERROR.');
  2059.       writeln(lfile,'THE SVC ERROR IS: ',ps.stat hex);
  2060.       writeln(lfile,'BYE')
  2061.     END
  2062. END;                                                      { CONNECT }
  2063.  
  2064. PROCEDURE help;
  2065.  
  2066. BEGIN                                                        { HELP }
  2067.   tcbuf:=crlf;
  2068.   writdev(ts,true,2,location(tcbuf));
  2069.   bsbuf:='THE FOLLOWING COMMANDS ARE SUPPORTED.#0D#0A ';
  2070.   writdev(ts,true,40,location(bsbuf));
  2071.   bsbuf:='PLEASE USE UPPERCASE FOR ALL COMMANDS.#0D#0A';
  2072.   writdev(ts,true,40,location(bsbuf));
  2073.   writdev(ts,true,2,location(tcbuf));
  2074.   bsbuf:='LOG <OPTIONAL FILENAME>               #0D#0A';
  2075.   writdev(ts,true,40,location(bsbuf));
  2076.   bsbuf:='CONNECT - CONNECT TO REMOTE SYSTEM.   #0D#0A';
  2077.   writdev(ts,true,40,location(bsbuf));
  2078.   bsbuf:='SEND <LOCAL FILE> <OPTIONAL REM FILE> #0D#0A';
  2079.   writdev(ts,true,40,location(bsbuf));
  2080.   bsbuf:='RECEIVE <DX10 RECEIVE FILE NAME>      #0D#0A';
  2081.   writdev(ts,true,40,location(bsbuf));
  2082.   bsbuf:='FINISH - SHUT DOWN REMOTE KERMIT.     #0D#0A';
  2083.   writdev(ts,true,40,location(bsbuf));
  2084.   bsbuf:='BYE - SHUT DOWN AND LOG OFF REMOTE.   #0D#0A';
  2085.   writdev(ts,true,40,location(bsbuf));
  2086.   bsbuf:='TEST - SEND ONLY TEST MODE.           #0D#0A';
  2087.   writdev(ts,true,40,location(bsbuf));
  2088.   bsbuf:='EXIT - LEAVE KERMIT.                  #0D#0A';
  2089.   writdev(ts,true,40,location(bsbuf));
  2090.   bsbuf:='SERVER - PLACE KERMIT IN SERVER MODE. #0D#0A';
  2091.   writdev(ts,true,40,location(bsbuf));
  2092.   bsbuf:='BINARY - SEND/RECEIVE BINARY FILE.    #0D#0A';
  2093.   writdev(ts,true,40,location(bsbuf));
  2094.   bsbuf:='TEXT - SEND/RECEIVE TEXT FILE(DEFAULT)#0D#0A';
  2095.   writdev(ts,true,40,location(bsbuf));
  2096.   bsbuf:='GET <REMOTE FILE NAME> <LOCAL FILE>   #0D#0A';
  2097.   writdev(ts,true,40,location(bsbuf));
  2098.   writdev(ts,true,2,location(tcbuf));
  2099.   writdev(ts,true,2,location(tcbuf))
  2100. END;                                                         { HELP }
  2101.  
  2102. PROCEDURE error;          { Error processing - Process fatal errors }
  2103. VAR l:integer;
  2104.  
  2105. BEGIN                                                       { ERROR }
  2106.   l:=size(msg);
  2107.   IF l>maxbuf-6 THEN l:=maxbuf-6;
  2108.   bufinit(filbuf);
  2109.   FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
  2110.                                     {Make message readable in packet}
  2111.   FOR i:=1 TO l DO putbuf(filbuf,ord(msg[i]));
  2112.   FOR i:=1 TO 3 DO putbuf(filbuf,ascsp);
  2113.                                     {Make message readable in packet}
  2114.   makepacket(asce,seq,filbuf.ln);
  2115.   sndpkt;
  2116.   state:=cexit;                    { THEN EXIT BACK TO COMMAND MODE }
  2117.   IF local AND NOT server THEN           { OUT ERROR TO CONSOLE TOO }
  2118.     BEGIN
  2119.       ssbuf:='#0D#0A#0D#0A        ';
  2120.       writdev(ts,true,4,location(ssbuf));
  2121.       writdev(ts,true,40,location(msg));
  2122.       writdev(ts,true,4,location(ssbuf))
  2123.     END
  2124. END;                                                        { ERROR }
  2125.  
  2126. PROCEDURE kermcommand;
  2127.  
  2128. BEGIN                                                 { KERMCOMMAND }
  2129.   IF lstatus=open AND server THEN
  2130.     writeln(lfile,'IN SERVER MODE');
  2131.   REPEAT
  2132.     rcvpkt;                                          { GET A PACKET }
  2133.     IF rcvseq>-1 THEN                       { LEGAL PACKET RECEIVED }
  2134.       BEGIN
  2135.         IF rcvtyp=asci AND server THEN { RECEIVED INIT PARMS PACKET }
  2136.           BEGIN
  2137.             getpar;                      {Get parameters from packet}
  2138.             putpar;                      {Put parameters into buffer}
  2139.             seq:=rcvseq;
  2140.             makepacket(ascy,seq,filbuf.ln);
  2141.                                 {Make ACK packet with our parameters}
  2142.             sndpkt                                { AND SEND IT OFF }
  2143.           END
  2144.         ELSE
  2145.           IF rcvtyp=ascs THEN
  2146.             BEGIN                       { RECEIVED SEND-INIT PACKET }
  2147.               state:=rinitiate
  2148.             END
  2149.           ELSE
  2150.             IF rcvtyp=ascr AND server THEN
  2151.               BEGIN                 { RECEIVE A FILE REQUEST PACKET }
  2152.                 IF fnlen=0 THEN
  2153.                   BEGIN
  2154.                     buftolin(rcvbuf,fname,fnlen)
  2155.                   END;
  2156.                 state:=sinitiate
  2157.               END
  2158.             ELSE
  2159.               IF rcvtyp=ascg AND server THEN
  2160.                 BEGIN
  2161.                   makepacket(ascy,seq,0);             { ACKNOWLEDGE }
  2162.                   numtry:=0;
  2163.                   gencmd(rcvbuf)   { PROCESS GENERIC KERMIT COMMAND }
  2164.                 END
  2165.               ELSE
  2166.                 error('UNEXPECTED PACKET TYPE                  ')
  2167.       END
  2168.     ELSE
  2169.       IF rcvseq=-1 THEN
  2170.         BEGIN
  2171.           makepacket(ascn,seq,0);
  2172.           sndpkt                                { SEND PERIODIC NAK }
  2173.         END
  2174.       ELSE
  2175.         IF rcvseq=-2 THEN
  2176.           BEGIN
  2177.             state:=cexit;
  2178.             server:=false
  2179.           END
  2180.   UNTIL state<>kcommand
  2181. END;
  2182.  
  2183. PROCEDURE kerminitialize;                    { Initialization state }
  2184. VAR lstat: boolean;
  2185.  
  2186. BEGIN
  2187.   state:=kcommand;
  2188.   numtry:=0;
  2189.   seq:=0;
  2190.   fnlen:=0;                               {Indicate no file name yet}
  2191.   rfnlen:=0;                              { NO REMOTE FILE NAME YET }
  2192.   pktsnt:=0;                               { NUMBER OF PACKETS SENT }
  2193.   sending:=false;
  2194.   receiving:=false;                      { NOT RECEIVING A FILE YET }
  2195.  
  2196.   locbsiz:=78;
  2197.   loctout:=12;
  2198.   locnpad:=0;
  2199.   locpad:=0;
  2200.   loceol:=asccr;
  2201.   locquo:=ascns;
  2202.                  {  locqu8 will be set after options are processed. }
  2203.   locrep:=asctil;         {Initialize to 0 to turn off repeat counts}
  2204.  
  2205.   rembsiz:=78;
  2206.                                               { remdsiz:=rembsiz-3; }
  2207.   remdsiz:=rembsiz-6;        { MAKE SMALLER - EXCEEDING REMOTE BUFS }
  2208.   remtout:=12;
  2209.   remnpad:=0;
  2210.   rempad:=0;
  2211.   remeol:=asccr;
  2212.   remqu8:=0;
  2213.   remrep:=0;
  2214.   headok:=false;                             { NO HEADER PACKET YET }
  2215.   bptr:=0;                      { NO DATA IN BINARY DATA BUFFER YET }
  2216.  
  2217.   bufinit(sndbuf);
  2218.  
  2219.   {The following should only be done on the first call to initialize}
  2220.   IF iniflg=false THEN
  2221.     BEGIN
  2222.       sndonly:=false;
  2223.       sndlog:=false;
  2224.       rcvlog:=false;
  2225.       wrtlog:=false;
  2226.       redlog:=false;
  2227.       lnlen:=0;                                   { LOG FILE LENGTH }
  2228.       crlfeol:=true;
  2229.       creol:=false;
  2230.       lfeol:=false;
  2231.       rstatus:=closed;
  2232.       wstatus:=closed;
  2233.       lstatus:=closed;
  2234.       eolflg:=false;                  { NO CR OR LF ENCOUNTERED YET }
  2235.       server:=false;                      { SET ONLY IN SERVER MODE }
  2236.       cond:=false;
  2237.       optqu8:=0;                      { ASSUME NO EIGHT-BIT QUOTING }
  2238.       binary:=false                 { DEFAUTLT NON-BINARY TYPE DATA }
  2239.     END;
  2240.   locqu8:=optqu8;  { EIGHT BIT QUOTING DONE ONLY WITH BINARY OPTION }
  2241.   iniflg:=true
  2242. END;
  2243.  
  2244. PROCEDURE getstr(VAR wp,strlen:integer;VAR str:flen;cnt:boolean);
  2245. (******************************************************************
  2246. * ATTEMPT TO GET A THE NEXT STRING WITHIN THIS BUFFER OF STRINGS
  2247. *
  2248. *   WP - CURRENT CHAR POINTER WITHIN THE BUFFER
  2249. *   STRLEN - LENGTH OF THE STRING RETURNED - 0 IF NONE OR PAST END.
  2250. *   STR - THE ACTUAL STRING
  2251. *   CNT - IF TRUE PUT THE COUNT AT FRONT OF STRING - NEEDED FOR
  2252. *         FILE NAMES.
  2253. ********************************************************************)
  2254.  
  2255. BEGIN                                                      { GETSTR }
  2256.   strlen:=0;                        { CLEAR --> NO VALID STRING YET }
  2257.   WHILE cmdbuf.ch[wp]<>ascsp AND wp <=cmdbuf.ln DO
  2258.     wp:=succ(wp);                          { SKIP PAST CHARS IF ANY }
  2259.   WHILE cmdbuf.ch[wp]=ascsp AND wp <=cmdbuf.ln DO
  2260.     wp:=succ(wp);         { SKIP PAST BLANKS BETWEEN STRINGS IF ANY }
  2261.   WHILE cmdbuf.ch[wp]<>ascsp AND wp<=cmdbuf.ln DO
  2262.     BEGIN                  { SAVE THE STRING WE ARE NOW POINTING TO }
  2263.       strlen:=succ(strlen);                 { SAVE LENGTH OF STRING }
  2264.       str[strlen]:=chr(cmdbuf.ch[wp]);                { MOVE A CHAR }
  2265.       wp:=succ(wp)                            { BUMP BUFFER POINTER }
  2266.     END;
  2267.   IF strlen > 0 THEN                              { STRING IS VALID }
  2268.     BEGIN
  2269.       IF cnt THEN                   { WE NEED STRING COUNT AT FRONT }
  2270.         BEGIN
  2271.           FOR i:= (strlen+1) DOWNTO 2 DO
  2272.             str[i]:=str[(i-1)];         { SHIFT STRING ONE TO RIGHT }
  2273.           str[1]:=chr(strlen)
  2274.                              { PUT STRING LENGTH AT FRONT OF STRING }
  2275.         END
  2276.     END
  2277. END;                                                       { GETSTR }
  2278.  
  2279. PROCEDURE prscmd(VAR parseok:boolean);     { PARSE A KERMIT COMMAND }
  2280.  
  2281. VAR
  2282.   sp:integer;                            { A STRING(cmdbuf) POINTER }
  2283.  
  2284. BEGIN
  2285.   sp:=1;                     { POINT TO THE BEGINNING OF THE CMDBUF }
  2286.                      (******************** SEND ********************)
  2287.   IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascn)
  2288.       THEN
  2289.     BEGIN                                  { THIS IS A SEND COMMAND }
  2290.       getstr(sp,fnlen,fname,true);
  2291.                                    { GET FILE NAME TO SEND - IF ANY }
  2292.       IF fnlen = 0 THEN
  2293.         BEGIN
  2294.                       { SEND FILE NAME NOT IN CMD BUF - PROMPT USER }
  2295.           bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
  2296.           writdev(ts,true,40,location(bsbuf));
  2297.           bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
  2298.           writdev(ts,true,23,location(bsbuf))
  2299.         END
  2300.       ELSE
  2301.         BEGIN
  2302.           parseok:=true;             { CMD ENTERED SYNTACTICALLY OK }
  2303.           state:=sinitiate;                   { SET SEND INIT STATE }
  2304.           getstr(sp,rfnlen,rfname,true)
  2305.                                    { CHK FOR REMOTE FILENAME IN CMD }
  2306.                                    { A REMOTE FILE NAME IS OPTIONAL }
  2307.         END
  2308.     END;
  2309.  
  2310.                      (****************** RECEIVE *******************)
  2311.   IF (cmdbuf.ch[1]=ascr AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascc)
  2312.       THEN
  2313.     BEGIN                               { THIS IS A RECEIVE COMMAND }
  2314.       getstr(sp,fnlen,fname,true);
  2315.                            { GET LOCAL FILENAME TO STORE FILE UNDER }
  2316.       IF fnlen = 0 THEN
  2317.         BEGIN
  2318.           { REQUIRED RECEIVE FILE NAME NOT IN CMD BUF - PROMPT USER }
  2319.           bsbuf:='FILE NAME SPECIFICATIONS WERE NOT ENTERE';
  2320.           writdev(ts,true,40,location(bsbuf));
  2321.           bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
  2322.           writdev(ts,true,23,location(bsbuf))
  2323.         END
  2324.       ELSE
  2325.         BEGIN
  2326.           state:=rcv;                               { SET RCV STATE }
  2327.           parseok:=true              { CMD ENTERED SYNTACTICALLY OK }
  2328.         END
  2329.     END;
  2330.  
  2331.                       (******************** GET ********************)
  2332.   IF (cmdbuf.ch[1]=ascg AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
  2333.       THEN                                  { THIS IS A GET COMMAND }
  2334.     BEGIN            { EXTRACT FROM COMMAND LINE REMOTE FILE TO GET }
  2335.       getstr(sp,rfnlen,rfname,true);
  2336.       IF rfnlen = 0 THEN
  2337.         BEGIN
  2338.             { REMOTE FILE NAME TO GET NOT IN CMD LINE - PROMPT USER }
  2339.           bsbuf:='A REMOTE FILE NAME TO GET MUST BE ENTERE';
  2340.           writdev(ts,true,40,location(bsbuf));
  2341.           bsbuf:='D - TRY AGAIN PLEASE.#0D#0A                 ';
  2342.           writdev(ts,true,23,location(bsbuf))
  2343.         END
  2344.       ELSE
  2345.         BEGIN
  2346.           getstr(sp,fnlen,fname,true);
  2347.                                  { LOCAL FILE NAME TO WRITE FILE TO }
  2348.           IF fnlen=0 THEN
  2349.             BEGIN
  2350.           { LOCAL FILE NAME TO WRITE REMOTE FILE TO NOT IN CMD LINE }
  2351.               bsbuf:='A LOCAL DX10 FILE NAME MUST BE ENTERED -';
  2352.               writdev(ts,true,40,location(bsbuf));
  2353.               bsbuf:=
  2354.                   ' TRY AGAIN PLEASE.#0D#0A                    ';
  2355.               writdev(ts,true,20,location(bsbuf))
  2356.             END
  2357.           ELSE
  2358.             BEGIN
  2359.               parseok:=true;         { CMD ENTERED SYNTACTICALLY OK }
  2360.               iinitiate;                    { MAKE INITIAL I PACKET }
  2361.               state:=getinit                { PREPARE R PACKET NEXT }
  2362.             END
  2363.         END
  2364.     END;
  2365.  
  2366.                      (********************* LOG ********************)
  2367.   IF (cmdbuf.ch[1]=ascl AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascg)
  2368.       THEN
  2369.     BEGIN                                             { SET LOGGING }
  2370.       IF lstatus <> open THEN                    { NOT ALREADY OPEN }
  2371.         BEGIN
  2372.           getstr(sp,lnlen,lname,true); { GET USER LOG FILE - IF ANY }
  2373.           IF lnlen = 0 THEN                  { USE DEFAULT LOG FILE }
  2374.             p$parm(5,lname,perr);   { GET DEFAULT LOG FILE PATHNAME }
  2375.           sndlog:=true;
  2376.           rcvlog:=true;
  2377.           wrtlog:=true;
  2378.           redlog:=true;
  2379.           logopn;
  2380.           parseok:=true              { LOG COMMAND ACCEPTED CORRECT }
  2381.         END
  2382.       ELSE
  2383.         BEGIN
  2384.           bsbuf:='LOG FILE ALREADY OPEN - NO NEED TO SET L';
  2385.           writdev(ts,true,40,location(bsbuf));
  2386.           bsbuf:='OGGING AGAIN.#0D#0A                         ';
  2387.           writdev(ts,true,15,location(bsbuf))
  2388.         END
  2389.     END;
  2390.  
  2391.                      (******************** TEST ********************)
  2392.   IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascs)
  2393.       THEN
  2394.     BEGIN                                   { SEND ONLY FOR TESTING }
  2395.       sndonly:=true;
  2396.       parseok:=true;                { TEST COMMAND ACCEPTED CORRECT }
  2397.       bsbuf:='TEST MODE->NO PACKETS WILL BE RECEIVED#0D#0A';
  2398.       writdev(ts,true,40,location(bsbuf))
  2399.     END;
  2400.  
  2401.                    (******************** SERVER ********************)
  2402.   IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascr)
  2403.       THEN
  2404.     BEGIN                                   { SEND ONLY FOR TESTING }
  2405.       server:=true;
  2406.       bsbuf:='#0D#0AKERMIT SERVER RUNNING ON DX10 HOST,#0D#0AP';
  2407.       writdev(ts,true,40,location(bsbuf));
  2408.       bsbuf:='LEASE TYPE YOUR ESC SEQUENCE TO RETURN#0D#0A';
  2409.       writdev(ts,true,40,location(bsbuf));
  2410.       bsbuf:='TO YOUR LOCAL MACHINE.  SHUT DOWN#0D#0ASERVE';
  2411.       writdev(ts,true,40,location(bsbuf));
  2412.       bsbuf:='R BY TYPING THE BYE OR FINISH COMMAND #0D#0A';
  2413.       writdev(ts,true,40,location(bsbuf));
  2414.       bsbuf:='ON YOUR LOCAL MACHINE....             #0D#0A';
  2415.       writdev(ts,true,40,location(bsbuf));
  2416.       parseok:=true;                          { SERVER CMD ACCEPTED }
  2417.       makepacket(ascn,seq,0);           { SEND INITIAL NAK TO LOCAL }
  2418.       sndpkt                                   { GET THINGS ROLLING }
  2419.     END;
  2420.  
  2421.                   (******************** CONNECT ********************)
  2422.   IF (cmdbuf.ch[1]=ascc AND cmdbuf.ch[2]=asco AND cmdbuf.ch[3]=ascn)
  2423.       THEN
  2424.     BEGIN                                         { CONNECT COMMAND }
  2425.       IF local THEN           { CONNECT ONLY IN LOCAL MODE - PLEASE }
  2426.         BEGIN
  2427.           bsbuf:='#0D#0ACONNECTING THRU                       ';
  2428.           writdev(ts,true,18,location(bsbuf));
  2429.           FOR k:=1 TO ord(ioname[1]) DO
  2430.             bsbuf[k]:=ioname[k+1];
  2431.           writdev(ts,true,(ord(ioname[1])),location(bsbuf));
  2432.           bsbuf:=', SPEED 1200#0D#0ATO ESCAPE AND RETURN TO YO';
  2433.           writdev(ts,true,40,location(bsbuf));
  2434.           bsbuf:='UR LOCAL  #0D#0ASYSTEM - TYPE TWO "AT SIGN" ';
  2435.           writdev(ts,true,40,location(bsbuf));
  2436.           bsbuf:=' @  #0D#0ACHARACTERS IN QUICK SEQUENCE.   #0D#0A';
  2437.           writdev(ts,true,40,location(bsbuf));
  2438.           IF NOT isc THEN
  2439.             passt(ts,true)
  2440.                       { SET PASSTHRU MODE WHILE CONNECTED TO REMOTE }
  2441.           ELSE             { DISPLAY SPECIAL CHAR SEQUENCES FOR ISC }
  2442.             BEGIN
  2443.               tcbuf:=crlf;
  2444.               writdev(ts,true,2,location(tcbuf));
  2445.               writdev(ts,true,2,location(tcbuf));
  2446.               bsbuf:='TYPE THE FOLLOWING IN FAST SEQUENCE : #0D#0A';
  2447.               writdev(ts,true,40,location(bsbuf));
  2448.               bsbuf:='^ ^ (TWO UP ARROWS) FOR CMD KEY.      #0D#0A';
  2449.               writdev(ts,true,40,location(bsbuf));
  2450.               bsbuf:='% % (TWO PERCENTS) FOR BLNK ORNGE KEY.#0D#0A';
  2451.               writdev(ts,true,40,location(bsbuf));
  2452.               bsbuf:='@ ^ ( AT SIGN AND UP ARROW) FOR ESQ.  #0D#0A';
  2453.               writdev(ts,true,40,location(bsbuf));
  2454.               bsbuf:='@ % ( AT SIGN AND PERCENT) FOR DC1.   #0D#0A';
  2455.               writdev(ts,true,40,location(bsbuf));
  2456.               writdev(ts,true,2,location(tcbuf))
  2457.             END;
  2458.           IF ts.stat=0 THEN
  2459.             connect;                 { GO ATTEMPT CONNECT TO REMOTE }
  2460.           bsbuf:='#0A#0DKERMIT IS BACK TO LOCAL SYSTEM.     #0D#0A';
  2461.           writdev(ts,true,40,location(bsbuf));
  2462.           IF ts.stat<>0 THEN
  2463.             BEGIN         { CONSOLE TERMINAL I/O ERR DURING CONNECT }
  2464.               bsbuf:='CONSOLE TERMINAL ERROR DURING CONNECT.#0D#0A';
  2465.               writdev(ts,true,40,location(bsbuf))
  2466.             END;
  2467.           IF ps.stat<>0 THEN
  2468.             BEGIN            { REMOTE PORT I/O ERROR DURING CONNECT }
  2469.               bsbuf:='REMOTE PORT I/O ERROR DURING CONNECT. #0D#0A';
  2470.               writdev(ts,true,40,location(bsbuf))
  2471.             END;
  2472.           IF NOT isc THEN                       { TURN OFF PASSTHRU }
  2473.             BEGIN                  { SO WE CAN DO CMD CONTROL AGAIN }
  2474.               IF bsy IN ts.flags THEN         { ABORT ANY I/O FIRST }
  2475.                 abort(ts);          { OR PASSTHRU WON'T BE AFFECTED }
  2476.               passt(ts,false)                    { THEN TURN IT OFF }
  2477.             END;
  2478.           parseok:=true   { ONLY ERR ON THIS COMMAND IS MISSPELLING }
  2479.         END
  2480.       ELSE
  2481.         BEGIN
  2482.           bsbuf:='#0D#0AYOU HAVE ALREADY CONNECTED TO A REMOTE';
  2483.           writdev(ts,true,40,location(bsbuf));
  2484.           bsbuf:='#0D#0ASYSTEM.  USE YOUR ESCAPE SEQUENCE IF Y';
  2485.           writdev(ts,true,40,location(bsbuf));
  2486.           bsbuf:='OU #0D#0AWISH TO RETURN TO YOUR LOCAL SYSTEM';
  2487.           writdev(ts,true,40,location(bsbuf));
  2488.           bsbuf:='.#0D#0A                                     ';
  2489.           writdev(ts,true,3,location(bsbuf))
  2490.         END
  2491.     END;
  2492.  
  2493.                    (******************** FINISH ********************)
  2494.   IF (cmdbuf.ch[1]=ascf AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
  2495.       THEN
  2496.     BEGIN                           { USER TYPED THE FINISH COMMAND }
  2497.       parseok:=true;                 { CMD ENTERED SYNTACTICALLY OK }
  2498.       iinitiate;                 { MAKE REQUIRED PRECEDING I PACKET }
  2499.       state:=fininit
  2500.     END;
  2501.  
  2502.                       (******************** BYE ********************)
  2503.   IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=ascy AND cmdbuf.ch[3]=asce)
  2504.       THEN
  2505.     BEGIN                              { USER TYPED THE BYE COMMAND }
  2506.       parseok:=true;                 { CMD ENTERED SYNTACTICALLY OK }
  2507.       iinitiate;                 { MAKE REQUIRED PRECEDING I PACKET }
  2508.       state:=byeinit
  2509.     END;
  2510.  
  2511.                       (******************** SET-RESERVED FOR FUTURE*)
  2512.   IF (cmdbuf.ch[1]=ascs AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=asct)
  2513.       THEN
  2514.     BEGIN                                  { SET A KERMIT PARAMETER }
  2515.       sp:=4;                                      { WE GOT PAST SET }
  2516.       WHILE cmdbuf.ch[sp]=ascsp AND sp<30 DO
  2517.         sp:=succ(sp);                                 { SKIP SPACES }
  2518.       parseok:=true;
  2519.       bsbuf:='SET COMMAND RESERVED FOR FUTURE USE.  #0D#0A';
  2520.    { YOU COULD PROBABLY IMPLEMENT SET BAUD , SET PARITY, ETC. HERE. }
  2521.       writdev(ts,true,40,location(bsbuf))
  2522.     END;
  2523.  
  2524.                      (******************** HELP ********************)
  2525.   IF (cmdbuf.ch[1]=asch AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascl)
  2526.       THEN
  2527.     BEGIN                                         { USER WANTS HELP }
  2528.       help;                                          { SO HELP USER }
  2529.       state:=cexit;
  2530.       parseok:=true                             { COMMAND PARSED OK }
  2531.     END;
  2532.  
  2533.                    (******************** BINARY ********************)
  2534.   IF (cmdbuf.ch[1]=ascb AND cmdbuf.ch[2]=asci AND cmdbuf.ch[3]=ascn)
  2535.       THEN
  2536.     BEGIN                                    { SET BINARY FILE TYPE }
  2537.       optqu8:=ascamp;              { EIGHT-BIT QUOTING WILL BE DONE }
  2538.       crlfeol:=false;            { NO CARRIAGE CON. IN BINARY FILES }
  2539.       binary:=true;                    { BINARY TYPE FILE TRANSFERS }
  2540.       bsbuf:='BINARY FILE - 8 BIT QUOTING TURNED ON.#0D#0A';
  2541.       writdev(ts,true,40,location(bsbuf));
  2542.       state:=cexit;
  2543.       parseok:=true                             { COMMAND PARSED OK }
  2544.     END;
  2545.  
  2546.                    (********************** TEXT ********************)
  2547.   IF (cmdbuf.ch[1]=asct AND cmdbuf.ch[2]=asce AND cmdbuf.ch[3]=ascx)
  2548.       THEN
  2549.     BEGIN                                      { SET TEXT FILE TYPE }
  2550.       optqu8:=0;                { NO EIGHT-BIT QUOTING WILL BE DONE }
  2551.       crlfeol:=true;                      { SET CARRIAGE CONTROL ON }
  2552.       binary:=false;                          { NO BINARY FILE TYPE }
  2553.       bsbuf:='TEXT FILE TYPE TRANSFER TURNED ON.    #0D#0A';
  2554.       writdev(ts,true,40,location(bsbuf));
  2555.       state:=cexit;
  2556.       parseok:=true                             { COMMAND PARSED OK }
  2557.     END;
  2558.  
  2559.                     (********************* EXIT ********************)
  2560.   IF (cmdbuf.ch[1]=asce AND cmdbuf.ch[2]=ascx AND cmdbuf.ch[3]=asci)
  2561.       THEN
  2562.     BEGIN                                   { SET PROPER EXIT FLAGS }
  2563.       server:=false;
  2564.       state:=kexit;
  2565.       parseok:=true                 { EXIT COMMAND ACCEPTED CORRECT }
  2566.     END;
  2567.  
  2568. END;
  2569.  
  2570. PROCEDURE getcmd;                { INTERACTIVELY GET A USER COMMAND }
  2571.  
  2572. VAR
  2573.   validcmd:boolean;
  2574.  
  2575. BEGIN                                                      { GETCMD }
  2576.   validcmd:=false;
  2577.   tcbuf:=crlf;
  2578.   writdev(ts,true,2,location(tcbuf));
  2579.   WHILE NOT validcmd DO
  2580.     BEGIN
  2581.       ssbuf:='KERMIT-990> ';    { USER PROMPT- MODIFIABLE IN FUTURE }
  2582.       writdev(ts,true,12,location(ssbuf));
  2583.       bufinit(cmdbuf);                   { CLEAR THE COMMAND BUFFER }
  2584.       IF local THEN
  2585.         BEGIN
  2586.           ts.lrl:=size(cmdbuf.ch);           { SIZE OF BUF FOR READ }
  2587.           readdev(ts,true,location(cmdbuf.ch));
  2588.           cmdbuf.ln:=ts.cc;           { GET ACTUAL SIZE OF CMD READ }
  2589.           ssbuf:='#0D#0A          ';         { JUST CRLF FOR OTHERS }
  2590.           writdev(ts,true,2,location(ssbuf))
  2591.         END
  2592.       ELSE    { PORT IS IN PASSTHRU MODE SO READ ONE CHAR AT A TIME }
  2593.         BEGIN
  2594.           ineoln:=false;                       { NOT END OF CMD YET }
  2595.           WHILE NOT ineoln DO                { CMD ENDS WITH RETURN }
  2596.             BEGIN
  2597.               readdev(ts,true,location(tcbuf));        { GET A CHAR }
  2598.               IF tcbuf[1]='#0D' THEN
  2599.                 BEGIN
  2600.                   tcbuf:=crlf;       { ECHO PROPER CARRIAGE CONTROL }
  2601.                   writdev(ts,true,2,location(tcbuf));
  2602.                   ineoln:=true               { ACCEPT AND PARSE CMD }
  2603.                 END
  2604.               ELSE
  2605.                 IF tcbuf[1]='#08' THEN
  2606.                   BEGIN
  2607.                     IF cmdbuf.ln>=1 THEN              { BS IS LEGAL }
  2608.                       BEGIN
  2609.                         ssbuf:='#08 #08         ';
  2610.                                           { THIS IS A BS? - ALMOST! }
  2611.                         writdev(ts,true,3,location(ssbuf));
  2612.                         cmdbuf.ch[cmdbuf.ln]:=ascsp;
  2613.                                         { BLANK POSITION IN CMD BUF }
  2614.                         cmdbuf.ln:=pred(cmdbuf.ln)
  2615.                       END
  2616.                   END
  2617.                 ELSE
  2618.                   BEGIN
  2619.                     writdev(ts,true,1,location(tcbuf)); { ECHO CHAR }
  2620.                     cmdbuf.ch[(cmdbuf.ln+1)]:=ord(tcbuf[1]);
  2621.                                                         { SAVE CHAR }
  2622.                     IF cmdbuf.ch[1] <> ascsp THEN
  2623.                                                { IGNORE LEAD SPACES }
  2624.                       cmdbuf.ln:=succ(cmdbuf.ln)   { INC CHAR COUNT }
  2625.                   END
  2626.             END
  2627.         END;
  2628.       IF cmdbuf.ln >1 THEN            { WE HAVE ACTUAL CMD TO PARSE }
  2629.         BEGIN
  2630.           prscmd(validcmd);                     { PARSE THE COMMAND }
  2631.           IF NOT validcmd THEN   { PARSE FAILURE --> CMD SYNTAX ERR }
  2632.             BEGIN
  2633.               bsbuf:='INCORRECT OR NON-SUPPORTED COMMAND:     ';
  2634.               writdev(ts,true,38,location(bsbuf));
  2635.               FOR i:=1 TO cmdbuf.ln DO
  2636.                 BEGIN
  2637.                   tcbuf[1]:=chr(cmdbuf.ch[i]);
  2638.                   writdev(ts,true,1,location(tcbuf))
  2639.                                                   { DISPLAY BAD CMD }
  2640.                 END;
  2641.               tcbuf:='#0D#0A';
  2642.               writdev(ts,true,2,location(tcbuf))
  2643.             END
  2644.         END
  2645.     END
  2646. END;                                                       { GETCMD }
  2647.  
  2648. { ************************* Main block **************************** }
  2649.  
  2650. BEGIN                                                      { KERMIT }
  2651.          { LET'S TAKE CARE OF SOME STANDARD FILE I/O INITIALIZATION }
  2652.   p$parm(6,ioname,perr);            { GET MY STATUS LOCAL OR REMOTE }
  2653.   local:=ioname[2]='L';
  2654.   p$parm(7,ioname,perr);           { CHECK FOR SPECIAL ISC TERMINAL }
  2655.   isc:=ioname[2]='I' AND local;
  2656.   IF local AND NOT isc THEN                { THIS BLOCK IS OPTIONAL }
  2657.     BEGIN                  { DONT TRY TO CLEAR SOME REMOTE TERMINAL }
  2658.       initscreen(blk,lun);       { ENABLE DISPLAY-ACCEPT FOR CLEARS }
  2659.       clearscreen(blk)                           { CLEAR THE SCREEN }
  2660.     END;
  2661.   p$parm(3,ioname,perr);                     { GET REMOTE PORT NAME }
  2662.   p$parm(4,tname,perr);                          { MY TERMINAL NAME }
  2663.   initio(location(tname),ts);               { OPEN CONSOLE TERMINAL }
  2664.   initio(location(ioname),ps);  { OPEN REMOTE PORT AND SET PASSTHRU }
  2665.   IF ps.stat=0 AND ts.stat=0 THEN             { PORTS READY FOR I/O }
  2666.     BEGIN                                { NORMAL KERMIT PROCESSING }
  2667.       ssbuf:='#0D#0A#0D#0A        ';
  2668.       writdev(ts,true,2,location(bsbuf));
  2669.       bsbuf:='WELCOME TO DX10 KERMIT-990 - RELEASE 1.0';
  2670.       writdev(ts,true,40,location(bsbuf));
  2671.       bsbuf:= '#0D#0A                                      ';
  2672.       writdev(ts,true,2,location(bsbuf));
  2673.       bsbuf:='TYPE HELP TO VIEW THE KERMIT COMMANDS.#0D#0A';
  2674.       writdev(ts,true,40,location(bsbuf));
  2675.       iniflg:=false;                      { FOR ONCE ONLY VAR INITS }
  2676.       state:=kcommand;
  2677.       WHILE server OR state<>kexit DO
  2678.         BEGIN
  2679.           kerminitialize;
  2680.                     { KCOMMAND MAY BE A GOOD CHOICE FOR SERVER MODE }
  2681.           WHILE NOT server AND state=kcommand DO
  2682.             getcmd;
  2683.           IF state=rcv THEN state:=kcommand;
  2684.                                   { FALL BACK TO CMD MODE AFTER RCV }
  2685.           IF state=kcommand THEN kermcommand;
  2686.           IF state=sinitiate THEN sendinitiate;
  2687.           IF state=rinitiate THEN rcvinitiate;
  2688.           WHILE state<>cexit AND state<>kexit DO
  2689.             BEGIN                            { PACKET SENDING STATE }
  2690.               REPEAT
  2691.                 sndpkt;
  2692.                 numtry:=numtry+1;
  2693.                 IF sndonly THEN
  2694.                   BEGIN
  2695.                     rcvseq:=seq;
  2696.                     rcvtyp:=ascy;
  2697.                     rcvbuf.ln:=0
  2698.                   END
  2699.                 ELSE
  2700.                   BEGIN
  2701.                     rcvpkt
  2702.                   END;
  2703.                 IF rcvtyp=ascn THEN
  2704.                   BEGIN                              { RECEIVED NAK }
  2705.                     rcvseq:=(rcvseq-1) MOD 64;
  2706.                     rcvtyp:=ascy
  2707.                   END
  2708.               UNTIL (rcvseq=seq) OR (numtry>=maxtry) OR (state=
  2709.                   kexit) OR (state = cexit);
  2710.               IF (rcvseq<>seq) AND (state<>kexit) THEN
  2711.                 error('DIDNT RECEIVE EXPECTED PACKET           ')
  2712.               ELSE
  2713.                 IF rcvtyp=asce THEN      {Just received error packet}
  2714.                   BEGIN
  2715.                     state:=wexit
  2716.                   END
  2717.                 ELSE
  2718.                   BEGIN
  2719.                     CASE state OF
  2720.                       getinit:get;
  2721.                       sheader :sendheader;
  2722.                       sdata :senddata;
  2723.                       sbreak :sendbreak;
  2724.                       rinitiate:rcvinitiate;
  2725.                       rheader :rcvheader;
  2726.                       rdata :receivedata;
  2727.                       wexit:state:=cexit;      { ALLOWS LAST SNDPKT }
  2728.                       fininit:finish;         { BUILD FINISH PACKET }
  2729.                       byeinit:bye;               { BUILD BYE PACKET }
  2730.                       kexit :;
  2731.                       cexit:
  2732.                       END
  2733.                   END
  2734.             END;
  2735.           wrtcls
  2736.         END;
  2737.       logcls;                              { CLOSE LOG FILE IF OPEN }
  2738.       bsbuf:='KERMIT END.#0D#0AHAVE A HOPPY HAPPY DAY!!!#0D#0A';
  2739.       writdev(ts,true,40,location(bsbuf))
  2740.     END
  2741.   ELSE
  2742.     IF ts.stat=0 THEN           { TERMINAL OK TO OUTPUT PORT ERR TO }
  2743.       BEGIN
  2744.         bsbuf:='KERMIT PORT OPEN FAILED - TRY AGAIN.#0D#0A#0D#0A';
  2745.         writdev(ts,true,40,location(bsbuf))
  2746.       END
  2747. END.                                                       { KERMIT }
  2748.