home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / ibmtsoqueens / ts2ker.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  114KB  |  2,801 lines
  1. PROGRAM KERMIT;
  2. (*********************************************************************)
  3. (*                                                                   *)
  4. (*    KERMIT  - File transfer Program for MVS/TSO                    *)
  5. (*              ( and RACF file access control )                     *)
  6. (*    Author  - Fritz Buetikofer (M70B@CBEBDA3T.BITNET)              *)
  7. (*    Version - 2.3                                                  *)
  8. (*    Date    - 1987 August                                          *)
  9. (*                                                                   *)
  10. (*    This program is an adaptation of the original CMS version of   *)
  11. (*    Victor Lee. Due to a big difference between CMS and TSO, most  *)
  12. (*    parts of the program had to be changed.                        *)
  13. (*                                                                   *)
  14. (*********************************************************************)
  15. (*                                                                   *)
  16. (*  1985 Sept 10  Program is totally changed for use with MVS/XA TSO *)
  17. (*                without any Series/1 frontend processor.           *)
  18. (*  1985 Oct  15  Commands DISK, DIR, DELETE, TYPE and WHO added     *)
  19. (*                for those users, not very experienced with TSO.    *)
  20. (*  1985 Oct  24  Correct treatment of the 'repetition' char.        *)
  21. (*  1985 Oct  29  Check of the sequence of data packets from the     *)
  22. (*                micro. Old packets are skipped by an ACK.          *)
  23. (*  1985 Nov  14  Correct handling of the 8th bit quoting for text   *)
  24. (*                files (according to the 2 translation tables).     *)
  25. (*  1985 Nov  22  Warning to user, if using a 327x-alike terminal-   *)
  26. (*                emulator (fullscreen support not available yet).   *)
  27. (*  1986 Jan  03  New command MEMBER added for partitionned files    *)
  28. (*  1986 Jan  13  Wildcard procedure added for sending files.        *)
  29. (*  1986 Feb  03  Setup Option added, using TSO file KERMIT.SETUP    *)
  30. (*                if present.                                        *)
  31. (*            05  Remote help file built in.                         *)
  32. (*  1986 Feb  18  KERMIT may issue FINISH command to micro running   *)
  33. (*                actually in server mode.                           *)
  34. (*  1986 Apr  04  SET REPEATCHAR, SET SOHchar and SET option ?       *)
  35. (*                facility added                                     *)
  36. (*  1986 May  07  TAKE command added, to execute commands from an    *)
  37. (*                external file.                                     *)
  38. (*  1986 May  14  Display in STATUS screen, whether Init-file has    *)
  39. (*                been processed or not.                             *)
  40. (*  1986 May  23  SET ATOE/ETOA added to modify the ASCII<->EBCDIC   *)
  41. (*                translation table on running KERMIT program.       *)
  42. (*  1986 June 16  SET INCOMPLETE added to control the disposition of *)
  43. (*                an incomplete incoming file.                       *)
  44. (*  1986 Aug  28  Command SEND filename updated, so the user can spe-*)
  45. (*                cify the name going to the micro.                  *)
  46. (*********************************************************************)
  47. (*  After a period of other work to be done, I found again some time *)
  48. (*  to implement a brand new feature: long packets !                 *)
  49. (*                                                                   *)
  50. (*  1987 Jan  19  Abort Remote_Help or Remote_Dir if not ACK or NAK  *)
  51. (*                is received (return to server_init state).         *)
  52. (*  1987 Jan  23  Implementation of long packets done. For test use  *)
  53. (*                I restricted the max. length to 1024 = 1K, which   *)
  54. (*                seems to be adequate for use over LANs.            *)
  55. (*                As soon as pack.length exceeds 256 bytes, the      *)
  56. (*                checktype is automatically set to 3=CRC.           *)
  57. (*  1987 Jan  30  Modifications in SendPacket and RecvPacket, be-    *)
  58. (*                cause they handled the checktype wrong.            *)
  59. (*  1987 Mar  25  Modification in Main Program, so that the first    *)
  60. (*                packet received in SERVER-mode is handled correct. *)
  61. (*  1987 Mar  27  Implementation of the ATTRIBUTE packets. Addition  *)
  62. (*                of the command DO, which executes members taken    *)
  63. (*                from the partitioned dataset KERMIT.PROFILE.       *)
  64. (*  1987 Aug  15  Corrections in routine SENDFILE, so that ACKs are  *)
  65. (*                checked with the actual sequence.                  *)
  66. (*                                                                   *)
  67. (*********************************************************************)
  68. (*                                                                   *)
  69. (*  1.   This version of kermit will handle binary files,            *)
  70. (*       i.e. it will handle 8th bit quoting.                        *)
  71. (*                                                                   *)
  72. (*  2.   By default all characters received are converted from       *)
  73. (*       ASCII and stored as EBCDIC. Also all characters send are    *)
  74. (*       converted from EBCDIC to ASCII.  To avoid the translation   *)
  75. (*       for non-text file you must set TEXT OFF.                    *)
  76. (*                                                                   *)
  77. (*  3.   This version contains a slot for all the documented         *)
  78. (*       advanced server functions, however only some are implemented*)
  79. (*                                                                   *)
  80. (*********************************************************************)
  81. (*                                                                   *)
  82. (*  Utility Procedures:                                              *)
  83. (*       SendPacket      RecvPacket    ReSendit     TSOService       *)
  84. (*       SendACK         GetToken      Wait         UPCase           *)
  85. (*       TRead           TWrite        Prompt       InPacket         *)
  86. (*       OutPacket       TermSize      CheckDsn     Extract          *)
  87. (*       CRCheck         SendChar      CheckParms   Micro_Finish     *)
  88. (*       RecvChar        SendError     ParmPacket   FileToPacket     *)
  89. (*       Wildcard_Search Write_State                                 *)
  90. (*                                                                   *)
  91. (*                                                                   *)
  92. (*  Command Procedures                                               *)
  93. (*       SendFile  - Sends a file to another computer.               *)
  94. (*       RecvFile  - Receive a file from another computer.           *)
  95. (*       ShowIT    - Display the options and status of last tranfer. *)
  96. (*       SetIT     - Set the options.                                *)
  97. (*       Help      - Displays the commands available.                *)
  98. (*       RemoteCommand - handle commands initiated by micro.         *)
  99. (*                                                                   *)
  100. (*********************************************************************)
  101. %TITLE Declarations
  102. TYPE
  103.     LString   = STRING (256);
  104.     FString   = PACKED ARRAY (.1..256.) OF CHAR;
  105.     LPString  = STRING (1024);
  106.     PString   = PACKED ARRAY (.1..1024.) OF CHAR;
  107.     BYTE      = PACKED 0..255;
  108.     TWOBYTES  = PACKED 0..65535;
  109.     OVERLAY   = (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE);
  110.     PACKET    = RECORD CASE OVERLAY OF
  111.                  ONE   :( CHARS : PACKED ARRAY (.1..1024.) OF CHAR );
  112.                  TWO   :( BYTES : PACKED ARRAY (.1..1024.) OF BYTE )
  113.                 END;
  114.  
  115.     STATETYPE = (S_I,S,SF,SD,SZ,SB,C,A,R,RF,RD);
  116.  
  117.     ABORTTYPE = (NOSOH,BADSF,NOT_S,NOT_SFBZ,NOT_DZ);
  118.  
  119.     DISPTYPE  = (NEW, NEWMEM, OLD, OLDMEM, SHARE,
  120.                  MODIFY, ERROR, NOACC, BADNAME, NOMEM);
  121.  
  122.     COMMANDS  = ($BAD,  $SEND,   $RECEIVE, $SERVER, $SET,
  123.                  $SHOW, $STATUS, $HELP,    $QUES,   $DEL,
  124.                  $DIR,  $DISK,   $MEM,     $TSO,    $TYPE,
  125.                  $WHO,  $FINISH, $QUIT,    $END,    $EXIT,
  126.                  $DO,   $LOG,    $TAKE,    $VERSION);
  127.  
  128.     WHATFLAGS = ($ZERO,        $TEXTMODE,
  129.                  $EXTEND1,
  130.                  $RECFM,       $PACKETSIZE,
  131.                  $EXTEND2,     $EOLCHAR,
  132.                  $CNTRL_QUOTE, $EXTEND3,
  133.                  $BIT8_QUOTE,  $EXTEND4,
  134.                  $CHECKTYPE,   $EXTEND5,
  135.                  $DELAY,       $DEBUG,
  136.                  $REPCHAR,     $EXTEND6,
  137.                  $SOHCHAR,     $ATOE,
  138.                  $ETOA,        $INCOMPLETE,
  139.                  $EXTEND7,     $DUMMY);
  140.  
  141.  CONST
  142.     COMMTABLE = 'BAD     ' ||
  143.                 'SEND    ' ||
  144.                 'RECEIVE ' ||
  145.                 'SERVER  ' ||
  146.                 'SET     ' ||
  147.                 'SHOW    ' ||
  148.                 'STATUS  ' ||
  149.                 'HELP    ' ||
  150.                 '?       ' ||
  151.                 'DELETE  ' ||
  152.                 'DIR     ' ||
  153.                 'DISK    ' ||
  154.                 'MEMBERS ' ||
  155.                 'TSO     ' ||
  156.                 'TYPE    ' ||
  157.                 'WHO     ' ||
  158.                 'FINISH  ' ||
  159.                 'QUIT    ' ||
  160.                 'END     ' ||
  161.                 'EXIT    ' ||
  162.                 'DO      ' ||
  163.                 'LOGOUT  ' ||
  164.                 'TAKE    ' ||
  165.                 'VERSION ';
  166.  
  167.     WHATTABLE = 'BAD     ' ||
  168.                 'TEXTMODE' ||
  169.                 '        ' ||
  170.                 'RECFM   ' ||
  171.                 'PACKETSI' ||
  172.                 'ZE      ' ||
  173.                 'EOLCHAR ' ||
  174.                 'CNTRL_QU' ||
  175.                 'OTE     ' ||
  176.                 'BIT8_QUO' ||
  177.                 'TE      ' ||
  178.                 'CHECKTYP' ||
  179.                 'E       ' ||
  180.                 'DELAY   ' ||
  181.                 'DEBUG   ' ||
  182.                 'REPEATCH' ||
  183.                 'AR      ' ||
  184.                 'SOHCHAR ' ||
  185.                 'ATOE    ' ||
  186.                 'ETOA    ' ||
  187.                 'INCOMPLE' ||
  188.                 'TE      ' ||
  189.                 'DUMMY   ';
  190.  
  191.     SPECTABLE = '00'XC || '!"#$%&''()*+,-./:;<=>{|}~';
  192.  
  193.     DCB_Fix   = 'RECFM(F,B) LRECL(80)   BLKSIZE(6160)'; (* Fixed    *)
  194.     DCB_Var   = 'RECFM(V,B) LRECL(255)  BLKSIZE(3024)'; (* Variable *)
  195.     DCB_Bin   = 'RECFM(U)   LRECL(1024) BLKSIZE(6144)'; (* Binary   *)
  196.     DCB_DEBUG = 'RECFM(V,B) LRECL(255) BLKSIZE(6200)';
  197.     DEBUGNAME = 'KERMIT.DEBUG';         (* Name of DEBUG   data set *)
  198.     CMDNAME   = 'KERMIT.SETUP';         (* Name of SETUP   data set *)
  199.     PROFNAME  = 'KERMIT.PROFILE';       (* Name of PROFILE data set *)
  200.  
  201. VAR
  202.     RUNNING,
  203.     EndKermit,
  204.     GetFile,
  205.     EOLINE,
  206.     Remote,
  207.     CmdMode,
  208.     Init_File,
  209.     GETREPLY       : BOOLEAN;
  210.     COMMAND,
  211.     SETTING        : ALFA;
  212.     REQUEST        : STRING (9);
  213.     CINDEX,
  214.     CHECKBYTES,
  215.     I,J,K,LEN,RC,
  216.     ScreenSize     : INTEGER;
  217.     Handle_Attribute,
  218.     Long_Packet,
  219.     TEXTMODE, FB   : BOOLEAN;
  220.     UserID         : STRING (8);
  221.     STATE          : STATETYPE;
  222.     ABORT          : ABORTTYPE;
  223.     DsnDisp        : DISPTYPE;
  224.     INPUTSTRING,                              (* Command string *)
  225.     TSOCommand     : LString;                (* TSO command string *)
  226.     Line           : LPString;
  227.     (* Packet variables *)                        (* format   *)
  228.     (* Receive       Send     *)                  (* SOH      *)
  229.     INCOUNT,      OUTCOUNT,                       (* COUNT    *)
  230.     INDATACOUNT,  OUTDATACOUNT  : INTEGER;        (* Chr-COUNT*)
  231.     INSEQ,        OUTSEQ        : BYTE;           (* SEQNUM   *)
  232.     INPACKETTYPE, OUTPACKETTYPE : CHAR;           (* TYPE     *)
  233.     REPLYMSG,     SENDMSG       : PACKET;         (* DATA...  *)
  234.     CHECKSUM                    : INTEGER;        (* CHECKSUM *)
  235.     CRC                         : TWOBYTES;       (* CRC-CCITT*)
  236.  
  237.     SENDBUFF,RECVBUFF : PACKET;
  238.     MAXLENGTH,SI,RI,RECVLENGTH,FC : TWOBYTES;
  239.     TSODS,                            (* File with TSO info *)
  240.     DFILE,                            (* DEBUG-Info file    *)
  241.     CmdFile,                          (* SETUP file         *)
  242.     SFILE     : TEXT;                 (* SEND file          *)
  243.     FileCount : INTEGER;
  244.     FileList  : ARRAY (.1..100.) OF LString;
  245.  
  246. STATIC
  247.     ASCIITOEBCDIC,
  248.     EBCDICTOASCII           : PACKED ARRAY (.1..255.) OF CHAR;
  249.     CAPAS,
  250.     PSIZE, ECHAR, SCHAR     : INTEGER;
  251.     CNTRL_QUOTE, BIT8_QUOTE,
  252.     CHECKTYPE, REPEATCHAR,
  253.     SeqChar, LastSeq, SOH   : CHAR;
  254.     Delay                   : REAL;
  255.     Debug, RECEIVING,
  256.     Incomplete_File         : BOOLEAN;
  257.     CRLF                    : STRING (4);
  258.  
  259. VALUE
  260.     PSIZE       := 94;        (* PACKET size = 94 (maximum) *)
  261.     SOH         := '01'XC ;   (* Start of packet - <Ctrl>-A *)
  262.     ECHAR       := 13;        (* End of line char - CR  *)
  263.     SCHAR       := 1;
  264.     CAPAS       := 0;
  265.     CNTRL_QUOTE := '#';
  266.     BIT8_QUOTE  := '&';
  267.     CHECKTYPE   := '1';       (* 1 BYTE checksum *)
  268.     Delay       := 6.0;       (* Wait-factor = 6 seconds *)
  269.     Debug       := FALSE;     (* No debugging first    *)
  270.     REPEATCHAR  := '~';       (* Repeat quote *)
  271.     CRLF        := '#M#J';    (* String with CR, LF *)
  272.     SeqChar     := '31'XC;    (* Initial value *)
  273.     Incomplete_File := TRUE;  (* Keep/Discard incomplete file *)
  274.  
  275. (* THIS IS THE EXTENDED-ASCII TO EBCDIC TABLE, TYPE SWISS *)
  276.     ASCIITOEBCDIC :=
  277.            '010203372D2E2F1605250B0C0D0E0F'XC ||  (* 0. *)
  278.          '100000003C3D322618193F271C1D1E1F'XC ||  (* 1. *)
  279.          '404F7F7B5B6C507D4D5D5C4E6B604B61'XC ||  (* 2. *)
  280.          'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'XC ||  (* 3. *)
  281.          '7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'XC ||  (* 4. *)
  282.          'D7D8D9E2E3E4E5E6E7E8E94AE05A5F6D'XC ||  (* 5. *)
  283.          '79818283848586878889919293949596'XC ||  (* 6. *)
  284.          '979899A2A3A4A5A6A7A8A9C06AD0A107'XC ||  (* 7. *)
  285.          '48DC51424344814852535457565863C1'XC ||  (* 8. *)
  286.          'C50000CBCCCDDBDDA8ECFC00B1000086'XC ||  (* 9. *)
  287.          '455596DE49D58196005F000000000000'XC ||  (* A. *)
  288.          '000000FAEDEDEDBCBCEDFABCBBBBBBBC'XC ||  (* B. *)
  289.          'ABCECFEBBF8FEBEBABACCECFEBBF8FCE'XC ||  (* C. *)
  290.          'CECFCFABABACAC8F8FBBAC0000000000'XC ||  (* D. *)
  291.          '00000000000000000000000000000000'XC ||  (* E. *)
  292.          '00000000000000000000AF0000009F00'XC;    (* F. *)
  293. (*  THIS IS THE EBCDIC TO EXTENDED-ASCII CONVERSION TABLE (SWISS)  *)
  294. (*   CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL  *)
  295.     EBCDICTOASCII :=
  296.            '0102030009007F0009000B0C0D0E0F'XC ||  (* 0. *)
  297.          '10202020000D0800181900001C1D1E1F'XC ||  (* 1. *)
  298.          '00000000000A171B0000000000050607'XC ||  (* 2. *)
  299.          '0000160000000004000000001415001A'XC ||  (* 3. *)
  300.          '2020838485A0000087A45B2E3C282B21'XC ||  (* 4. *)
  301.          '268288898AA18C8B8D005D242A293B5E'XC ||  (* 5. *)
  302.          '2D2F008E0000000000007C2C255F3E3F'XC ||  (* 6. *)
  303.          '000000000000000000603A2340273D22'XC ||  (* 7. *)
  304.          '006162636465666768690000002800C5'XC ||  (* 8. *)
  305.          '006A6B6C6D6E6F7071720000002900FE'XC ||  (* 9. *)
  306.          '007E737475767778797A00C0DA5B00FA'XC ||  (* A. *)
  307.          '009C000000000000000000D9BF5D00C4'XC ||  (* B. *)
  308.          '7B41424344454647484900939495C1C2'XC ||  (* C. *)
  309.          '7D4A4B4C4D4E4F50515200968197A300'XC ||  (* D. *)
  310.          '5C00535455565758595A00C399B40000'XC ||  (* E. *)
  311.          '30313233343536373839B3009A000000'XC ;   (* F. *)
  312.  
  313. LABEL MAINLOOP;
  314. %TITLE Special TSO Routines
  315. (*==================================================================*)
  316. (* TSOService  - This procedure executes all TSO command requests.  *)
  317. (*==================================================================*)
  318. (* The following routine resides in the LPA -> Pgm must be loaded *)
  319. PROCEDURE IKJEFTSR (CONST P1 : INTEGER; CONST P2 : FString;
  320.                     VAR P3, P4, P5, P6 : INTEGER); FORTRAN;
  321.  
  322. PROCEDURE TSOService (CONST Cmd : LString; VAR Code : INTEGER);
  323.  
  324. VAR
  325.   Command       : FString;
  326.   a, b, c, d, e : INTEGER;
  327.  
  328. BEGIN
  329.   a := 257; c := 0; d := 0;   e := 0;
  330.   Command := Cmd; b := LENGTH (Cmd);
  331.   IKJEFTSR (a, Command, b, c, d, e);
  332.   Code := c
  333. END (* TSOService *);
  334.  
  335. (*==================================================================*)
  336. (* Waiting     - This procedure waits 'w' seconds before proceeding *)
  337. (*==================================================================*)
  338. PROCEDURE Wait (CONST i : INTEGER); FORTRAN;     (* Pause i seconds *)
  339. PROCEDURE Waiting (w : REAL);
  340. TYPE
  341.   Convert = RECORD
  342.                CASE BOOLEAN OF
  343.                  TRUE  : ( Int  : INTEGER);
  344.                  FALSE : ( Chrs : PACKED ARRAY (.1..4.) OF CHAR);
  345.             END;
  346. VAR
  347.   I    : INTEGER;
  348.   Fact : Convert;
  349. BEGIN
  350.   I := TRUNC (w * 100);
  351.   Fact.Chrs (.1.) := CHR (0);
  352.   Fact.Chrs (.2.) := CHR (0);
  353.   Fact.Chrs (.3.) := CHR (I DIV 256);
  354.   Fact.Chrs (.4.) := CHR (I MOD 256);
  355.   Wait (Fact.Int)
  356. END (* Waiting *);
  357.  
  358.  
  359. PROCEDURE UPCASE (VAR S : ALFA);
  360. VAR i  : INTEGER;
  361.     ch : CHAR;
  362. BEGIN
  363.   FOR i := 1 TO LENGTH (S) DO BEGIN
  364.       ch := S (.i.);
  365.       IF ch IN (.'a'..'z'.) THEN S (.i.) := CHR ( ORD (ch) + 64)
  366.   END
  367. END;
  368. %PAGE
  369. PROCEDURE TRead     (CONST Prompt : FString;
  370.                      CONST Prompt_Len : INTEGER;
  371.                      VAR   Message : PString;
  372.                      VAR   M_Len, RC : INTEGER); FORTRAN;
  373.  
  374. (*==================================================================*)
  375. (* Prompt      - This procedure prompts the user for input          *)
  376. (*==================================================================*)
  377.  
  378. PROCEDURE Prompt (p : LString; VAR s : LString);
  379.  
  380. VAR
  381.   m     : FString;
  382.   n     : PString;
  383.   i,j,k : INTEGER;
  384.  
  385. BEGIN
  386.   m := p; i := LENGTH (p);
  387.   TRead (m, i, n, j, k);
  388.   s := SUBSTR (STR (n), 1, j) || ' '
  389. END;
  390.  
  391. (*==================================================================*)
  392. (* InPacket   - This procedure reads a packet from the terminal     *)
  393. (*==================================================================*)
  394.  
  395. PROCEDURE InPacket (VAR s : LPString);
  396.  
  397. VAR
  398.   m     : FString;
  399.   n     : PString;
  400.   i,j,k : INTEGER;
  401.  
  402. BEGIN
  403.   m := ''; i := 0;
  404.   TRead (m, i, n, j, k);
  405.   s := SUBSTR (STR (n), 1, j) || ' '
  406. END;
  407. (*==================================================================*)
  408. (* OutPacket   - This procedure writes a packet to the terminal     *)
  409. (*==================================================================*)
  410. PROCEDURE TWrite    (CONST Line : PString;
  411.                      CONST Len  : INTEGER;
  412.                      VAR   RC   : INTEGER); FORTRAN;
  413.  
  414. PROCEDURE OutPacket (l : LPString);
  415.  
  416. VAR
  417.   m   : PString;
  418.   i,j : INTEGER;
  419.  
  420. BEGIN
  421.   m := l; i := LENGTH (l);
  422.   TWrite (l, i, j)
  423. END;
  424.  
  425. (*==================================================================*)
  426. (* TermSize    - This procedure reads the screen size of the other  *)
  427. (*               Kermit terminal's emulator.                        *)
  428. (*==================================================================*)
  429. PROCEDURE TermSize  (VAR a : INTEGER); FORTRAN;
  430. %PAGE
  431. FUNCTION Upper (S : LString) : LString;
  432. VAR i  : INTEGER;
  433.     ch : CHAR;
  434. BEGIN
  435.   Upper := S;
  436.   FOR i := 1 TO LENGTH (S) DO BEGIN
  437.       ch := S (.i.);
  438.       IF ch IN (.'a'..'z'.) THEN Upper (.i.) := CHR ( ORD (ch) + 64)
  439.   END
  440. END;
  441.  
  442. (*==================================================================*)
  443. (* CheckDsn    - This procedure verifies whether a data set exists  *)
  444. (*               and if so, it prompts the user for a new name.     *)
  445. (*==================================================================*)
  446. PROCEDURE CheckDsn (VAR KFile : LString; VAR Result : DISPTYPE);
  447.  
  448. CONST
  449.     RelId = '00000001';
  450.  
  451. VAR TSODS : TEXT;
  452.     InFile,
  453.     Line  : LString;
  454.     Name  : STRING (20);
  455.     Dot,Num,
  456.     Col   : INTEGER;
  457.     IsPDS : BOOLEAN;
  458.  
  459.   PROCEDURE NewChar (VAR L : LString; N : INTEGER);
  460.   CONST
  461.     Charset = '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ'; (* 36 items *)
  462.   VAR
  463.     Chg : CHAR;
  464.     j   : INTEGER;
  465.   BEGIN
  466.     Chg := L (.N.);
  467.     j   := INDEX (Charset, STR (Chg));
  468.     j   := j + 1;
  469.     IF j > 36 THEN j := 1;
  470.     Chg := Charset (.j.);
  471.     L (.N.) := Chg
  472.   END;
  473.  
  474. BEGIN
  475.   InFile := Upper (KFile);
  476.   IF InFile (.1.) <> '''' THEN
  477.      InFile := '''' || UserID || '.' || InFile || '''';
  478.   IF Debug THEN WRITELN (DFILE, 'Checking data set ', InFile);
  479.   TSOService ('PROFILE NOPROMPT',  RC);
  480.   TSOService ('TSODS LISTDS ' || InFile || ' MEM', RC);
  481.   TSOService ('PROFILE PROMPT',  RC);
  482.   RESET   (TSODS);
  483.   READLN  (TSODS, Line);
  484.   IF Debug THEN WRITELN (DFILE, Line);
  485.   (* -------------------------------------*)
  486.   (* Maybe filename is invaild            *)
  487.   (* -------------------------------------*)
  488.   IF INDEX (Line, 'INVALID DATA SET') > 0 THEN
  489.     IF NOT GetFile THEN Result := BADNAME
  490.     ELSE BEGIN
  491.       (* TSO Kermit got an invalid data set name from micro *)
  492.       (* ... will try now to write data to a temporary file *)
  493.       (* called KERMIT.TEMP                                 *)
  494.       IF Debug THEN WRITELN (DFile, KFile || ' renamed to KERMIT.TEMP');
  495.       KFile := 'KERMIT.TEMP';
  496.       CheckDsn (KFile, Result)
  497.     END
  498.   ELSE BEGIN
  499.     READLN  (TSODS, Line);
  500.     IF Debug THEN WRITELN (DFILE, Line);
  501.     (* -------------------------------------*)
  502.     (* Maybe file is not in catalog         *)
  503.     (* -------------------------------------*)
  504.     IF INDEX (Line, 'NOT IN CATALOG') > 0 THEN Result := NEW
  505.     ELSE BEGIN
  506.       Result := SHARE;
  507.       IsPDS  := FALSE;
  508.       READLN  (TSODS, Line);
  509.       IF INDEX (Line, 'PO') > 0 THEN BEGIN (* Dsn is partitioned *)
  510.          IsPDS  := TRUE;
  511.          IF INDEX (KFile, '(') = 0 THEN BEGIN (* No member for PDS *)
  512.             Result := ERROR;
  513.             IF NOT GetFile THEN Result := NOMEM;
  514.             IF Debug THEN WRITELN (DFILE, 'No member specified !!');
  515.             RETURN
  516.          END;
  517.          READLN  (TSODS, Line); READLN  (TSODS, Line);
  518.          READLN  (TSODS, Line); READLN  (TSODS, Line);
  519.          IF Debug THEN WRITELN (DFILE, Line);
  520.          IF INDEX (Line, 'NOT FOUND') > 0 THEN Result := NEWMEM
  521.             ELSE Result := OLDMEM
  522.       END
  523.     END
  524.   END;
  525.   CLOSE (TSODS);
  526.   IF NOT GetFile THEN
  527.      IF (Result = SHARE) OR (Result = OLDMEM) THEN BEGIN
  528.         TSOService ('TSODS LISTCAT ENT(' || InFile || ')', RC);
  529.         IF RC <> 0 THEN BEGIN
  530.           IF Debug THEN WRITELN (DFILE, 'No access to file ' || InFile);
  531.           Result := NOACC
  532.         END
  533.      END;
  534.   IF GetFile THEN
  535.    CASE Result OF
  536.      NEW,
  537.      NEWMEM : (* New data set or member *);
  538.      ERROR  : (* Do nothing yet *);
  539.      OLDMEM,
  540.      SHARE  : BEGIN
  541.                 IF Remote THEN Num := 3
  542.                 ELSE BEGIN
  543.                   WRITELN ('Data set or member already exists ...');
  544.                   WRITELN (' ');
  545.                   WRITELN ('    (1) Overwrite it ? ');
  546.                   WRITELN ('    (2) Append to file ? ');
  547.                   WRITELN (' or (3) create new file name ? ');
  548.                   READLN  (Num);
  549.                   IF (Num < 1) OR (Num > 3) THEN Num := 3
  550.                 END;
  551.                 CASE Num OF
  552.                   1 : Result := OLD;
  553.                   2 : Result := MODIFY;
  554.                   3 : BEGIN
  555.                         InFile := KFile;
  556.                         Col := INDEX (InFile, '(');
  557.                         IF IsPDS THEN Col := INDEX (InFile, ')');
  558.                         Num := LENGTH (InFile);
  559.                         IF Col > 0 THEN NewChar (InFile, Col - 1)
  560.                                    ELSE NewChar (InFile, Num);
  561.                         KFile := InFile;
  562.                         IF Debug THEN
  563.                            WRITELN (DFILE, 'Trying with ', KFile);
  564.                         CheckDsn (KFile, Result)
  565.                       END
  566.                   END
  567.                 END
  568.      END
  569. END;
  570.  
  571.  
  572. (*================================================================*)
  573. (* Extract   - This procedure constructs a KERMIT filename from   *)
  574. (*             a TSO data set name.                               *)
  575. (*================================================================*)
  576. PROCEDURE Extract (Filename : LString; VAR KermName : LString);
  577.  
  578. VAR Name, Typ : String(8);
  579.     PDS,Dot,i : INTEGER;
  580.  
  581. BEGIN
  582.   Filename := LTRIM (Filename);
  583.   Dot := INDEX (Filename, '.') + 1;
  584.   IF Filename (.1.) = '''' THEN
  585.      Filename := SUBSTR (Filename, Dot , LENGTH (Filename)-Dot);
  586.   Typ := '';
  587.   PDS := INDEX (Filename, '(');
  588.   Dot := INDEX (Filename, '.');
  589.   IF PDS > 0 THEN BEGIN
  590.     i    := INDEX (Filename, ')');
  591.     Name := SUBSTR (Filename, PDS+1, i-PDS-1);
  592.     Filename := DELETE (Filename, PDS)
  593.   END ELSE
  594.     IF Dot > 0 THEN BEGIN
  595.       Name := SUBSTR (Filename, 1, Dot-1);
  596.       Filename := SUBSTR (Filename, Dot+1)
  597.     END ELSE
  598.       BEGIN Name := Filename; Filename := '' END;
  599.   IF Filename <> '' THEN
  600.     REPEAT
  601.       Dot := INDEX (Filename, '.');
  602.       IF Dot > 0 THEN Filename := SUBSTR (Filename, Dot+1)
  603.                  ELSE BEGIN Typ := Filename; Filename := '' END;
  604.     UNTIL Filename = '';
  605.   IF Typ = '' THEN KermName := Name
  606.      ELSE KermName := Name || '.' || Typ;
  607. END;
  608. %PAGE
  609. (*==================================================================*)
  610. (* Wildcard_Search:  This procedure generates a list of filenames,  *)
  611. (*                   which follow a given mask.                     *)
  612. (*==================================================================*)
  613. PROCEDURE Wildcard_Search (VAR S : LString);
  614.  
  615. VAR Flag   : BOOLEAN;
  616.     Line,
  617.     DSname : LString;
  618.     User   : STRING (8);
  619.     Mask1,
  620.     Mask2,
  621.     Name,
  622.     FullDsn,
  623.     Level  : STRING (40);
  624.     Len1, Len2,
  625.     Star,                   (* Position of '*' in filename  *)
  626.     Dot,                    (* Position of '.' in filename  *)
  627.     ParOp,                  (* Position of '(' in filename  *)
  628.     ParCl  : INTEGER;       (* Position of ')' in filename  *)
  629.  
  630. BEGIN
  631.   FileCount := 0;
  632.   S := Upper (S);
  633.   IF INDEX (S, '*') = 0 THEN BEGIN
  634.      FileCount := 1;
  635.      FileList (.1.) := S;
  636.      RETURN
  637.   END;
  638.   IF S(.1.) = '''' THEN BEGIN
  639.      Dot  := INDEX (S, '.');
  640.      User := SUBSTR (S, 2, Dot-2);
  641.      S    := SUBSTR (S, Dot+1, LENGTH (S)-Dot-1);
  642.   END ELSE User := UserId;
  643.   DSname := S;
  644.   Star   := INDEX (S, '*');
  645.   IF Star < LENGTH (S) THEN BEGIN
  646.      Line   := SUBSTR (S, Star+1);
  647.      IF INDEX (Line , '*') > 0 THEN BEGIN
  648.         WRITELN (' No double wildcard allowed ');
  649.         RETURN
  650.      END
  651.   END;
  652.   Dot    := INDEX (S, '.');
  653.   ParOp  := INDEX (S, '(');
  654.   IF ParOp > 0 THEN BEGIN
  655.      ParCl  := INDEX (S, ')');
  656.      DSname := SUBSTR (S, 1, ParOp-1);
  657.      IF Star > ParOp THEN BEGIN   (* He would like all PDS members *)
  658.         Mask1 := ' '; Mask2 := ' ';
  659.         IF Star > ParOp + 1 THEN
  660.            Mask1 := SUBSTR (S, ParOp+1, Star-ParOp-1);
  661.         IF Star < Parcl - 1 THEN BEGIN
  662.            Mask2 := SUBSTR (S, Star+1, ParCl-Star-1);
  663.            Len2  := LENGTH (Mask2)
  664.         END;
  665.         FullDsn := '''' || User || '.' || DSname || '''';
  666.         TSOService ('TSODS LISTD ' || FullDsn || ' m', RC);
  667.         RESET  (TSODS);
  668.         READLN (TSODS, Line);
  669.         IF INDEX (Line, 'NOT IN CATALOG') > 0 THEN RETURN;
  670.         READLN (TSODS, Line);
  671.         READLN (TSODS, Line);
  672.         IF INDEX (Line, 'PO') = 0 THEN BEGIN
  673.            FileCount := FileCount + 1;
  674.            IF User = UserID THEN FileList (.FileCount.) := DSNAME
  675.            ELSE FileList (.FileCount.) :=
  676.                 '''' || User || '.' || DSNAME || '''';
  677.            RETURN;  (* File is not a PDS *)
  678.         END;
  679.         READLN (TSODS, Line);
  680.         READLN (TSODS, Line);
  681.         READLN (TSODS, Line);
  682.         WHILE NOT EOF (TSODS) DO BEGIN
  683.           READLN (TSODS, Line);
  684.           IF INDEX (Line, 'NOT USEABLE') > 1 THEN BEGIN
  685.              CLOSE (TSODS);
  686.              RETURN
  687.           END;
  688.           Line := LTRIM (Line);
  689.           Len1 := LENGTH (Line);
  690.           Flag := TRUE;
  691.           IF Mask1 <> ' ' THEN
  692.              IF INDEX (Line, Mask1) <> 1 THEN Flag := FALSE;
  693.           IF Mask2 <> ' ' THEN
  694.              IF SUBSTR (Line, Len1-Len2+1, Len2) <> Mask2 THEN
  695.                 Flag := FALSE;
  696.           IF Flag THEN BEGIN
  697.              FileCount := FileCount + 1;
  698.              IF User = UserID THEN FileList (.FileCount.) :=
  699.                 DSNAME || '(' || Line || ')'
  700.              ELSE FileList (.FileCount.) :=
  701.              '''' || User || '.' || DSNAME || '(' || Line || ')''';
  702.           END;
  703.         END;
  704.         CLOSE  (TSODS)
  705.      END
  706.   END ELSE
  707.   IF ParOp > 0 THEN RETURN
  708.      ELSE BEGIN
  709.        Name := SUBSTR (S, 1, Dot-1);
  710.        Level := 'LEV(' || User || ')';
  711.        TSOService ('TSODS LISTCAT ' || Level, RC);
  712.        Mask1 := User; Mask2 := ' ';
  713.        IF Star > 1 THEN
  714.           Mask1 := Mask1 || '.' || SUBSTR (S, 1, Star-1);
  715.        IF LENGTH (S) > Star THEN BEGIN
  716.           Mask2 := SUBSTR (S, Star+1);
  717.           Len2  := LENGTH (Mask2)
  718.        END;
  719.        RESET  (TSODS);
  720.        REPEAT
  721.          READLN (TSODS, Line);
  722.          IF INDEX (Line, 'THE NUMBER OF') <> 0 THEN LEAVE;
  723.          IF INDEX (Line, 'SECURITY VERIFICATION') <> 0 THEN
  724.             READLN (TSODS, Line)
  725.          ELSE BEGIN
  726.             Line := SUBSTR (Line, 17);
  727.             Len1 := LENGTH (Line);
  728.             Flag := TRUE;
  729.             IF Mask1 <> ' ' THEN
  730.                IF INDEX (Line, Mask1) <> 1 THEN Flag := FALSE;
  731.             IF Mask2 <> ' ' THEN
  732.                IF SUBSTR (Line, Len1-Len2+1, Len2) <> Mask2 THEN
  733.                   Flag := FALSE;
  734.             IF Flag THEN BEGIN
  735.                FileCount := FileCount + 1;
  736.                IF User = UserID THEN
  737.                 FileList (.FileCount.) := SUBSTR (Line, LENGTH(User)+2)
  738.                ELSE FileList (.FileCount.) := '''' || Line || ''''
  739.             END
  740.          END;
  741.          READLN (TSODS, Line)
  742.        UNTIL EOF (TSODS);
  743.        CLOSE (TSODS)
  744.      END
  745. END; (* Wildcard_Search *)
  746.  
  747. %TITLE KERMIT Utilities
  748. (* ===============================================================  *)
  749. (* CRCheck  -  This procedure generates a CRC (CCITT) .             *)
  750. (*             The generator polynomial is X^16+X^12+X^5+1          *)
  751. (*             which is 1021 hex or the reverse 8408 hex            *)
  752. (* Side Effect - The global variable CRC is updated. The CRC should *)
  753. (*               be zero at the start of each CRC calculation and   *)
  754. (*               should be called once for each byte to checked.    *)
  755. (*               no other call to this procedure is necessary.      *)
  756. (*              The CRC is done on all 8 bits in the byte.          *)
  757. (* ===============================================================  *)
  758. PROCEDURE CRCheck(MYBYTE : BYTE);
  759. VAR
  760.  j,c,t : INTEGER;
  761. BEGIN
  762.   c := MYBYTE;
  763.   FOR j := 0 TO 7 DO BEGIN
  764.     t   := CRC && c;
  765.     CRC := CRC >> 1;
  766.     IF ODD (t) THEN CRC := CRC && '8408'X;
  767.     c   := c >> 1
  768.   END
  769. END; (* CRCheck *)
  770.  
  771. (*================================================================*)
  772. (* SendChar -  This procedure sends a char to the terminal.       *)
  773. (* Side Effect - none                                             *)
  774. (*================================================================*)
  775. PROCEDURE SendChar (VAR L : LPString; MyChar : CHAR);
  776. BEGIN
  777.   L := L || STR (MyChar);
  778.   IF MyChar = '0D'XC THEN OutPacket (L)
  779. END;  (* Send Char *)
  780.  
  781. (* ===============================================================*)
  782. (* RecvChar -  This procedure gets a char from string L.          *)
  783. (* Side Effect - EOLINE is set                                    *)
  784. (* ===============================================================*)
  785. PROCEDURE RecvChar (VAR L : LPString; VAR MyChar : CHAR);
  786. BEGIN
  787.   EOLINE := FALSE;
  788.   IF LENGTH (L) > 0 THEN MyChar := L (.1.);
  789.   IF LENGTH (L) > 1 THEN L := SUBSTR (L, 2)
  790.      ELSE EOLINE := TRUE;
  791. END;  (* Recv Char *)
  792.  
  793. %TITLE Procedure Write_State
  794. (*==================================================================*)
  795. (* WRITE_STATE - write the present state to the debug file          *)
  796. (*==================================================================*)
  797. procedure Write_State;
  798. var
  799.   mess : string(2);
  800. begin
  801.     CASE STATE OF
  802.        S_I : mess := 'I ';
  803.        S   : mess := 'S ';
  804.        SF  : mess := 'SF';
  805.        SD  : mess := 'SD';
  806.        SZ  : mess := 'SZ';
  807.        SB  : mess := 'SB';
  808.        C   : mess := 'C ';
  809.        A   : mess := 'A ';
  810.        R   : mess := 'R ';
  811.        RF  : mess := 'RF';
  812.        RD  : mess := 'RD';
  813.        OTHERWISE mess := '??'
  814.     END ; (* CASE state *)
  815.     WRITELN (DFILE, '(State = ' || mess || ')' )
  816. end;
  817. %TITLE Procedure SendPacket
  818. (* ===============================================================  *)
  819. (* SendPacket -This procedure sends the SENDMSG packet .            *)
  820. (*          1. The COUNT sent includes SEQ,PACKETTYPE,and CHECKSUM  *)
  821. (*             i.e. it is 3 larger than the DATACOUNT.              *)
  822. (*          2. The COUNT and SEQ and CHECKSUM values are offset by  *)
  823. (*             32 decimal (20hex) to make it a printable ASCII char.*)
  824. (*          3. The CHECKSUM are calculated on the ASCII value of    *)
  825. (*             the printable characters.                            *)
  826. (*          4. All character sent must be converted to EBCDIC       *)
  827. (*             which get translated back to ASCII by the hardware.  *)
  828. (*             The DATA and PACKETTYPE are stored in this program   *)
  829. (*             as EBCDIC. The other char are assumed ASCII.         *)
  830. (* Assumptions:                                                     *)
  831. (*       The following Global variables must be correctly set       *)
  832. (*       before calling this procedure .                            *)
  833. (*       1. OUTDATACOUNT - an integer-byte count of data characters.*)
  834. (*       2. OUTSEQ    - an integer-byte count of sequence number.   *)
  835. (*       3. OUTPACKETTYPE - an EBCDIC char  of type .               *)
  836. (*       4. SENDMSG   - an EBCDIC array of data to be sent.         *)
  837. (* ===============================================================  *)
  838. PROCEDURE SendPacket;
  839. VAR I,SUM, Len1, Len2, HCheck : INTEGER;
  840. BEGIN
  841.   IF Debug THEN BEGIN
  842.      WRITE (DFILE, 'SEND PACKET :  ');
  843.      Write_State
  844.   END;
  845.   Line := '';
  846.   SUM := 0;
  847.   CRC := 0;
  848.   CHECKBYTES := 1;
  849.   IF ( (OUTPACKETTYPE IN (.'X','F','Z','B','D','E'.) ) OR
  850.        (INPACKETTYPE  IN (.'D','C','K','F','Z','B'.) ) ) THEN
  851.      IF CHECKTYPE = '2' THEN CHECKBYTES := 2
  852.         ELSE  IF CHECKTYPE = '3' THEN CHECKBYTES := 3;
  853.   SendChar (Line, SOH);                                 (* SOH   *)
  854.   OUTCOUNT := OUTDATACOUNT + 2 + CHECKBYTES;
  855.   If (Long_Packet AND (OUTDATACOUNT > 90)) THEN
  856.      IF OUTPACKETTYPE = 'D' THEN OUTCOUNT := 0;
  857.   SendChar (Line, ASCIITOEBCDIC (.OUTCOUNT+32.));       (* COUNT *)
  858.   SUM := SUM + OUTCOUNT + 32;
  859.   CRCheck (OUTCOUNT + 32);
  860.   SendChar (Line, ASCIITOEBCDIC (.OUTSEQ+32.));           (* SEQ   *)
  861.   IF NOT GetFile THEN SeqChar := ASCIITOEBCDIC (.OUTSEQ+32.);
  862.   SUM := SUM + OUTSEQ + 32;
  863.   CRCheck (OUTSEQ + 32);
  864.   SendChar (Line, OUTPACKETTYPE);                        (* TYPE  *)
  865.   SUM := SUM + ORD (EBCDICTOASCII (.ORD(OUTPACKETTYPE).) );
  866.   CRCheck ( ORD (EBCDICTOASCII (.ORD (OUTPACKETTYPE).) ));
  867.   IF (Long_Packet AND (OUTDATACOUNT > 90)) THEN
  868.      IF OUTPACKETTYPE = 'D' THEN BEGIN
  869.         OUTCOUNT := OUTDATACOUNT + CHECKBYTES;
  870.         Len1 := OUTCOUNT DIV 95;
  871.         SendChar (Line, ASCIITOEBCDIC (.Len1+32.));      (* LENX1 *)
  872.         SUM := SUM + Len1 + 32;
  873.         CRCheck (Len1 + 32);
  874.  
  875.         Len2 := OUTCOUNT MOD 95;
  876.         SendChar (Line, ASCIITOEBCDIC (.Len2+32.));      (* LENX2 *)
  877.         SUM := SUM + Len2 + 32;
  878.         CRCheck (Len2 + 32);
  879.  
  880.         HCheck := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ;
  881.         SendChar (Line, ASCIITOEBCDIC (.HCheck+32.));   (* HCHECK *)
  882.         SUM := SUM + HCheck + 32;
  883.         CRCheck (HCheck + 32);
  884.      END;
  885.  
  886.   IF OUTDATACOUNT > 0 THEN
  887.      FOR I := 1 TO OUTDATACOUNT DO
  888.        WITH SENDMSG DO
  889.        BEGIN                                          (* Send Data *)
  890.          SendChar (Line, CHARS(.I.));
  891.          SUM := SUM + ORD (EBCDICTOASCII (.BYTES(.I.).));
  892.          CRCheck (ORD (EBCDICTOASCII (.BYTES(.I.).)))
  893.        END;
  894.   IF CHECKBYTES = 1 THEN
  895.   BEGIN                                        (* One char checksum *)
  896.     CHECKSUM := (SUM + (SUM AND 'C0'X) DIV '40'X ) AND '3F'X ;
  897.     SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
  898.     SendChar (Line, '0D'XC)
  899.   END
  900.   ELSE IF CHECKBYTES = 2  THEN
  901.   BEGIN                                        (* Two char checksum *)
  902.     CHECKSUM := (SUM DIV '40'X)  AND '3F'X ;  (* BIT 11 - 6 *)
  903.     SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
  904.     CHECKSUM := (SUM         )  AND '3F'X ;  (* BIT 0 - 5  *)
  905.     SendChar (Line, ASCIITOEBCDIC (.CHECKSUM+32.));
  906.     SendChar (Line, '0D'XC)
  907.   END
  908.   ELSE BEGIN                              (* CRC-CCITT  3 character *)
  909.     SendChar (Line,ASCIITOEBCDIC(.((CRC DIV '1000'X) AND '0F'X) +32.));
  910.     SendChar (Line,ASCIITOEBCDIC(.((CRC DIV '0040'X) AND '3F'X) +32.));
  911.     SendChar (Line,ASCIITOEBCDIC(.((CRC           ) AND '3F'X) +32.));
  912.     SendChar (Line, '0D'XC)
  913.   END;
  914.   IF Debug THEN WRITELN (DFILE, Line)
  915. END;  (* SendPacket procedure  *)
  916. %TITLE Function RecvPacket
  917. (*==================================================================*)
  918. (* RecvPacket -This Function returns TRUE if it successfully        *)
  919. (*             recieved a packet and FALSE if it had an error.      *)
  920. (*  Side Effects:                                                   *)
  921. (*       The following global variables will be set.                *)
  922. (*       1. INCOUNT - an integer value of the msg char count .      *)
  923. (*       2. INSEQ - an integer value of the sequence count.         *)
  924. (*       3. TYPE  - an EBCDIC character of message type(Y,N,D,F,etc)*)
  925. (*       4. REPLYMSG - an EBCDIC array of the data sent.            *)
  926. (*                                                                  *)
  927. (*         a)  All characters are received as EBCDIC values and     *)
  928. (*             must be converted back to ASCII before using.        *)
  929. (*==================================================================*)
  930. FUNCTION RecvPacket : BOOLEAN;
  931. VAR
  932.     I,SUM,RESENDS,
  933.     LEN1, LEN2,
  934.     HCheck, Chk1,
  935.     Chk2, Chk3,
  936.     InCh1,
  937.     InCh2, InCh3  : INTEGER;
  938.     INCHAR,SChar  : CHAR;
  939.     Ext_Length    : BOOLEAN;
  940. LABEL FINDSOH;
  941.  
  942. BEGIN
  943.   IF Debug THEN BEGIN
  944.      WRITE (DFILE, 'RECEIVE PACKET :  ');
  945.      Write_State
  946.   END;
  947.   InPacket (Line);
  948.   IF LENGTH (Line) > 0 THEN
  949.      IF Line (.1.) <> SOH THEN Line := STR (SOH) || Line;
  950.   IF Debug THEN WRITELN (DFILE, Line);
  951. FINDSOH:
  952.   RecvChar (Line, INCHAR);                           (* SOH *)
  953.   IF EOLINE THEN
  954.   BEGIN (* Null response *)
  955.     RecvPacket := TRUE;
  956.     INPACKETTYPE:='N';
  957.     RETURN
  958.   END;  (* Null response *)
  959.   IF INCHAR <> SOH THEN GOTO FINDSOH;                (* no SOH *)
  960.   SUM := 0;
  961.   CRC := 0;
  962.   Ext_Length := FALSE;
  963.  
  964.   RecvChar (Line, INCHAR);
  965.   INCOUNT := ORD (EBCDICTOASCII (.ORD (INCHAR).));   (* COUNT *)
  966.   SUM := INCOUNT;
  967.   CRCheck (INCOUNT);
  968.   INCOUNT := INCOUNT - 32; (* To absolute value *)
  969.   IF INCOUNT = 0 THEN Ext_Length := TRUE;
  970.  
  971.   RecvChar (Line, INCHAR);
  972.   INSEQ := ORD (EBCDICTOASCII (.ORD (INCHAR).));      (* SEQ   *)
  973.   SChar   := LastSeq;
  974.   LastSeq := SeqChar;
  975.   SeqChar := INCHAR;
  976.   SUM := SUM + INSEQ;
  977.   CRCheck (INSEQ);
  978.   INSEQ := INSEQ - 32;
  979.   IF Debug THEN WRITELN (DFILE,'SeqChar = ', SeqChar,LastSeq);
  980.  
  981.   RecvChar (Line, INCHAR);
  982.   INPACKETTYPE := INCHAR;                       (* TYPE  *)
  983.   SUM := SUM + ORD (EBCDICTOASCII (.ORD (INCHAR).));
  984.   CRCheck (ORD (EBCDICTOASCII (.ORD (INCHAR).)));
  985.  
  986.   IF Ext_Length THEN BEGIN
  987.      RecvChar (Line, INCHAR);                   (* LENX1 *)
  988.      LEN1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  989.      SUM := SUM + LEN1;
  990.      CRCheck (LEN1);
  991.      LEN1 := (LEN1 - 32) * 95;
  992.  
  993.      RecvChar (Line, INCHAR);                   (* LENX2 *)
  994.      LEN2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  995.      SUM := SUM + LEN2;
  996.      CRCheck (LEN2);
  997.      LEN2 := LEN2 - 32;
  998.      INCOUNT := LEN1 + LEN2;
  999.  
  1000.      RecvChar (Line, INCHAR);                   (* HCHECK *)
  1001.      HCheck := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1002.      CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63;
  1003.      IF HCheck <> CHECKSUM + 32 THEN BEGIN
  1004.        RecvPacket := FALSE;
  1005.        SeqChar := LastSeq;
  1006.        LastSeq := SChar;
  1007.        IF Debug THEN WRITELN (DFILE,'HChecksum error : ', CHECKSUM+32);
  1008.        RETURN
  1009.      END;
  1010.      SUM := SUM + HCheck;
  1011.      CRCheck (HCheck);
  1012.   END;
  1013.  
  1014.   CHECKBYTES := 1;
  1015.   IF NOT ( (INPACKETTYPE IN (.'S','G','I','C','R','K','N'.) ) OR
  1016.            (OUTPACKETTYPE = 'S') ) THEN
  1017.      IF CHECKTYPE = '2' THEN CHECKBYTES := 2  ELSE
  1018.         IF CHECKTYPE = '3' THEN CHECKBYTES := 3;
  1019.   INDATACOUNT := INCOUNT - 2 - CHECKBYTES;
  1020.   IF Ext_Length THEN INDATACOUNT := INCOUNT - CHECKBYTES;
  1021.   IF INDATACOUNT > 0 THEN
  1022.      FOR I := 1 TO INDATACOUNT DO
  1023.        WITH REPLYMSG DO
  1024.        BEGIN                                         (* Receive data *)
  1025.          RecvChar (Line, CHARS (.I.));
  1026.          SUM := SUM + ORD (EBCDICTOASCII (.BYTES (.I.).));
  1027.          CRCheck (ORD (EBCDICTOASCII (.BYTES (.I.).)) )
  1028.        END;
  1029.  
  1030.   RecvPacket := TRUE;               (* ASSUME OK UNLESS CHECK FAILS *)
  1031.  
  1032.   IF CHECKBYTES = 1 THEN
  1033.   BEGIN                                       (* One byte CHECKSUM *)
  1034.     CHECKSUM := (SUM + (SUM AND 192) DIV 64 ) AND 63;
  1035.     RecvChar (Line, INCHAR);
  1036.     IF ORD (EBCDICTOASCII (.ORD (INCHAR).)) <> CHECKSUM + 32
  1037.     THEN BEGIN
  1038.        RecvPacket := FALSE;
  1039.        SeqChar := LastSeq;
  1040.        LastSeq := SChar;
  1041.        IF Debug THEN WRITELN (DFILE, 'Checksum error : ', CHECKSUM+32)
  1042.     END
  1043.   END
  1044.  
  1045.   ELSE IF CHECKBYTES = 2  THEN
  1046.   BEGIN                                       (* TWO BYTE CHECKSUM  *)
  1047.     Chk1 := (SUM  DIV '40'X ) AND '3F'X;
  1048.     Chk2 := (SUM         ) AND '3F'X;
  1049.     RecvChar  (Line, INCHAR);
  1050.     InCh1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1051.     RecvChar (Line, INCHAR);
  1052.     InCh2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1053.  
  1054.     IF ((InCh1 <> Chk1 + 32) OR (InCh2 <> Chk2 + 32)) THEN BEGIN
  1055.        RecvPacket := FALSE;
  1056.        SeqChar := LastSeq;
  1057.        LastSeq := SChar;
  1058.        IF Debug THEN WRITELN (DFILE, 'Checksum-2 error : ', Chk1+32);
  1059.        IF Debug THEN WRITELN (DFILE, '                   ', Chk2+32)
  1060.     END
  1061.   END
  1062.  
  1063.   ELSE BEGIN                                   (* CRC-CCITT checksum*)
  1064.     (* First char is bits 16-12, second is bits 11-6 and   *)
  1065.     (* third is bits 5-0 *)
  1066.     RecvChar (Line, INCHAR);
  1067.     InCh1 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1068.     RecvChar (Line, INCHAR);
  1069.     InCh2 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1070.     INCHAR := '0D'XC;
  1071.     RecvChar (Line, INCHAR);
  1072.     InCh3 := ORD (EBCDICTOASCII (.ORD (INCHAR).));
  1073.  
  1074.     Chk1 :=  ((CRC DIV '1000'X) AND '0F'X) +32;
  1075.     Chk2 :=  ((CRC DIV '40'X) AND'3F'X)  +32;
  1076.     Chk3 :=   (CRC AND '3F'X) +32;
  1077.  
  1078.     IF ((InCh1 <> Chk1) OR (InCh2 <> Chk2) OR (InCh3 <> Chk3))
  1079.        THEN BEGIN
  1080.        RecvPacket := FALSE;
  1081.        SeqChar := LastSeq;
  1082.        LastSeq := SChar;
  1083.        IF Debug THEN BEGIN
  1084.           WRITELN (DFILE, 'Checksum-3 (CRC) error : ', Chk1);
  1085.           WRITELN (DFILE, '                         ', Chk2);
  1086.           WRITELN (DFILE, '                         ', Chk3)
  1087.        END
  1088.     END
  1089.   END
  1090. END;  (* RecvPacket procedure  *)
  1091. %TITLE Procedures ReSendit, SendACK & SendError
  1092. (*==================================================================*)
  1093. (* ReSendit -  This procedure RESENDS the packet if it gets a nak   *)
  1094. (*             It calls itself recursively upto the number of times *)
  1095. (*             specified in the intial parameter list.              *)
  1096. (* Side Effects - If it fails then the STATE in the message is set  *)
  1097. (*                to 'A' which means ABORT .                        *)
  1098. (*==================================================================*)
  1099. PROCEDURE ReSendit ( RETRIES : INTEGER );
  1100. BEGIN
  1101.   IF RETRIES > 0 THEN
  1102.   BEGIN                                  (* Try again *)
  1103.     SendPacket;
  1104.     IF RecvPacket THEN
  1105.        IF INPACKETTYPE = 'Y' THEN BEGIN
  1106.           IF NOT GetFile AND (LastSeq<>SeqChar)
  1107.                  THEN ReSendit (RETRIES-1)
  1108.           END
  1109.           ELSE IF INPACKETTYPE = 'N' THEN ReSendit(RETRIES-1)
  1110.              ELSE STATE := A
  1111.     ELSE STATE := A
  1112.   END
  1113.   ELSE STATE := A                 (* Retries failed - ABORT *)
  1114. END; (* ReSendit procedure  *)
  1115.  
  1116. (*--------------------------------------------------------------*)
  1117. (*  SendACK - Procedure will send an ACK or NAK                 *)
  1118. (*            depending on the value of the Boolean parameter   *)
  1119. (*            i.e.  ENDACK(TRUE)  sends an ACK packet           *)
  1120. (*                 SENDACK(FALSE) sends an NAK packet           *)
  1121. (*--------------------------------------------------------------*)
  1122. PROCEDURE SendACK (B : BOOLEAN);
  1123. BEGIN
  1124.   OUTDATACOUNT := 0;
  1125.   IF B THEN OUTSEQ := OUTSEQ + 1;
  1126.   IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1127.   IF B THEN OUTPACKETTYPE := 'Y'
  1128.        ELSE OUTPACKETTYPE := 'N';
  1129.   SendPacket
  1130. END;  (* Send ACK or NAK *)
  1131.  
  1132. (*--------------------------------------------------------------*)
  1133. (*  SendError - Sends an error packet, with a message passed    *)
  1134. (*              from the caller.                                *)
  1135. (*--------------------------------------------------------------*)
  1136. PROCEDURE SendError (ErrStr : LString);
  1137. BEGIN
  1138.   OUTDATACOUNT  := LENGTH (ErrStr);
  1139.   SENDMSG.CHARS := ErrStr;
  1140.   OUTSEQ := 0;
  1141.   OUTPACKETTYPE := 'E';
  1142.   SendPacket
  1143. END;  (* SendError *)
  1144. %TITLE Some Send_X_Packet routines
  1145. (*-----------------------------------------------------------*)
  1146. (* SendBPacket - send break packet to terminate transmission *)
  1147. (*-----------------------------------------------------------*)
  1148. PROCEDURE SendBPacket;
  1149. BEGIN
  1150.   OUTDATACOUNT  := 0 ;
  1151.   OUTSEQ        := OUTSEQ + 1 ;
  1152.   IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  1153.   OUTPACKETTYPE := 'B' ;
  1154.   SendPacket;
  1155.   IF RecvPacket THEN (* It's ok *)
  1156. END; (* SendBPacket *)
  1157.  
  1158. (*-----------------------------------------------------------*)
  1159. (* SendZPacket - send EOF packet                             *)
  1160. (*-----------------------------------------------------------*)
  1161. PROCEDURE SendZPacket;
  1162. BEGIN
  1163.   OUTDATACOUNT  :=  0 ;
  1164.   OUTSEQ        := OUTSEQ + 1 ;
  1165.   IF OUTSEQ >= 64 THEN OUTSEQ := 0; ;
  1166.   OUTPACKETTYPE := 'Z' ;
  1167.   SendPacket;
  1168.   IF RecvPacket THEN (* Ok *)
  1169. END; (* SendZPacket *)
  1170.  
  1171. (*-----------------------------------------------------------*)
  1172. (* SendXPacket - send data header packet for terminal        *)
  1173. (*-----------------------------------------------------------*)
  1174. PROCEDURE SendXPacket (Head : LString);
  1175. BEGIN
  1176.   OUTDATACOUNT  := LENGTH (Head);
  1177.   OUTSEQ        := OUTSEQ + 1 ;
  1178.   IF OUTSEQ >= 64 THEN OUTSEQ := 0 ;
  1179.   OUTPACKETTYPE := 'X';
  1180.   SENDMSG.CHARS := Head;
  1181.   SendPacket;
  1182.   IF RecvPacket THEN
  1183.      IF INPACKETTYPE='Y' THEN (* It's ok *)
  1184.      ELSE IF INPACKETTYPE = 'N' THEN ReSendit (10)
  1185. END; (* SendXPacket *)
  1186.  
  1187. (*-----------------------------------------------------------*)
  1188. (* SendYPacket - send acknoledgement with data to micro      *)
  1189. (*-----------------------------------------------------------*)
  1190. PROCEDURE SendYPacket (Head : LString);
  1191. BEGIN
  1192.   OUTDATACOUNT  := LENGTH (Head);
  1193.   OUTPACKETTYPE := 'Y';
  1194.   SENDMSG.CHARS := Head;
  1195.   SendPacket
  1196. END; (* SendYPacket *)
  1197.  
  1198. (*-----------------------------------------------------------*)
  1199. (* SendDPacket - send data packet to micro                   *)
  1200. (*-----------------------------------------------------------*)
  1201. PROCEDURE SendDPacket (Head : LString; VAR Flag : BOOLEAN);
  1202. BEGIN
  1203.   OUTSEQ := OUTSEQ + 1;
  1204.   IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1205.   OUTDATACOUNT  := LENGTH (Head);
  1206.   OUTPACKETTYPE := 'D';
  1207.   SENDMSG.CHARS := Head;
  1208.   SendPacket;
  1209.   Flag := TRUE;
  1210.   IF RecvPacket THEN
  1211.      IF INPACKETTYPE='Y' THEN  (* nothing *)
  1212.      ELSE IF INPACKETTYPE='N' THEN ReSendit (10)
  1213.           ELSE Flag := FALSE
  1214. END; (* SendDPacket *)
  1215. %TITLE Procedures GetToken & ParmPacket
  1216. (* ===============================================================  *)
  1217. (* GetToken -  This procedure extracts a token from a string and    *)
  1218. (*             the function returns a 8 character token value.      *)
  1219. (*             the string is update with the portion that is left.  *)
  1220. (* ===============================================================  *)
  1221. FUNCTION GetToken ( VAR INSTRING : STRING(256)) : ALFA;
  1222.  VAR
  1223.     BP,BPM : INTEGER ; (* Blank Pointer *)
  1224.  
  1225. BEGIN
  1226.   IF LENGTH (INSTRING) < 1 THEN GetToken := '        '
  1227.   ELSE BEGIN
  1228.     BP := INDEX (INSTRING, ' ');
  1229.     IF BP = 0 THEN BP := LENGTH (INSTRING) + 1;
  1230.     BPM := MIN(BP,9);
  1231.     GetToken := DELETE (INSTRING, BPM);
  1232.     INSTRING := DELETE (INSTRING, 1, MIN (BP, LENGTH (INSTRING)))
  1233.   END
  1234. END; (* GetToken *)
  1235.  
  1236. (*=================================================================*)
  1237. (* ParmPacket - This procedure makes the PARAMETER PACKET.         *)
  1238. (*=================================================================*)
  1239. PROCEDURE ParmPacket;
  1240. VAR i, l1, l2 : BYTE;
  1241. BEGIN
  1242.   OUTDATACOUNT := 13;
  1243.   OUTSEQ       := 0;
  1244.   WITH SENDMSG DO
  1245.   BEGIN         (* Setup PARM packet *)
  1246.     (* The values  are tranformed by adding hex 20 to    *)
  1247.     (* the true value, making the value a printable char *)
  1248.     CHARS (.1.)  := ASCIITOEBCDIC (.94+32.);    (* Buffersize       *)
  1249.     CHARS (.2.)  := ASCIITOEBCDIC (.'28'X.);    (* Time out 8 sec   *)
  1250.     CHARS (.3.)  := ASCIITOEBCDIC (.'20'X.);    (* Num padchars=0   *)
  1251.     CHARS (.4.)  := ASCIITOEBCDIC (.'40'X.);    (* Pad char=blank   *)
  1252.     CHARS (.5.)  := ASCIITOEBCDIC (.ECHAR+32.); (* EOL char = CR    *)
  1253.     CHARS (.6.)  := CNTRL_QUOTE;                (* Quote character  *)
  1254.     CHARS (.7.)  := BIT8_QUOTE;                 (* Quote character  *)
  1255.     IF BIT8_QUOTE = '00'XC THEN CHARS (.7.) := 'Y';
  1256.     CHARS (.8.)  := CHECKTYPE;                  (* Check type       *)
  1257.     CHARS (.9.)  := REPEATCHAR;                 (* Repeat character *)
  1258.     IF REPEATCHAR = '00'XC THEN CHARS (.7.) := ' ';
  1259.     l1 := 2+8;                                  (* 2 = LONGP        *)
  1260.                                                 (* 8 = ATTRIBUTE    *)
  1261.     CHARS (.10.) := ASCIITOEBCDIC (.l1+32.);    (* CAPAS character  *)
  1262.     CHARS (.11.) := ASCIITOEBCDIC (.'20'X.);    (* Window size = 0  *)
  1263.     IF Long_Packet THEN l1 := PSIZE DIV 95 ELSE l1 := 0;
  1264.     CHARS (.12.) := ASCIITOEBCDIC (.l1+32.);    (* Ext.packet len1  *)
  1265.     IF Long_Packet THEN l2 := PSIZE MOD 95 ELSE l2 := 94;
  1266.     CHARS (.13.) := ASCIITOEBCDIC (.l2+32.);    (* Ext.packet len2  *)
  1267.                                                 (* DEF:0*95+94= 94  *)
  1268.   END
  1269. END;  (*  parameters *)
  1270. %TITLE Procedure FileToPacket
  1271. (*==================================================================*)
  1272. (* FileToPacket - This procedure files in a DATA packet D or X type *)
  1273. (*                with data from the file SFILE.                    *)
  1274. (*==================================================================*)
  1275. PROCEDURE FileToPacket;
  1276. BEGIN
  1277.   OUTDATACOUNT := 0;
  1278.   OUTSEQ       := OUTSEQ + 1;
  1279.   IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1280.   WHILE (OUTDATACOUNT < PSIZE-3-4-4) AND (NOT EOF (SFILE)) DO
  1281.   BEGIN (* Read a record *)
  1282.     OUTDATACOUNT := OUTDATACOUNT + 1 ;
  1283.     READ (SFILE, SENDMSG.CHARS (.OUTDATACOUNT.));
  1284.     WITH SENDMSG DO
  1285.        IF TEXTMODE THEN
  1286.        BEGIN  (* translate file *)
  1287.          (* The following double translation is used to   *)
  1288.          (* filter out meaningless EBCDIC characters into *)
  1289.          (* something more consistent.                    *)
  1290.          IF BYTES (.OUTDATACOUNT.) <> 0 THEN
  1291.             CHARS (.OUTDATACOUNT.) :=
  1292.             EBCDICTOASCII (.BYTES (.OUTDATACOUNT.).);
  1293.          IF BYTES (.OUTDATACOUNT.) > 127 THEN
  1294.          BEGIN                           (* 8th bit quote this char *)
  1295.            BYTES (.OUTDATACOUNT+1.) := BYTES (.OUTDATACOUNT.) - 128;
  1296.            CHARS (.OUTDATACOUNT.)   := BIT8_QUOTE;
  1297.            OUTDATACOUNT := OUTDATACOUNT + 1
  1298.          END;
  1299.          IF BYTES (.OUTDATACOUNT.) < 32 THEN
  1300.          BEGIN                               (* control quoting *)
  1301.             BYTES (.OUTDATACOUNT+1.) :=
  1302.             BYTES (.OUTDATACOUNT.) + 64;
  1303.             CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
  1304.             OUTDATACOUNT := OUTDATACOUNT + 1
  1305.          END;
  1306.          IF BYTES (.OUTDATACOUNT.) = '7F'X THEN
  1307.          BEGIN                                 (* <DEL> quoting *)
  1308.             CHARS (.OUTDATACOUNT+1.) := '3F'XC;
  1309.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1310.             OUTDATACOUNT := OUTDATACOUNT + 1
  1311.          END;
  1312.          IF BYTES (.OUTDATACOUNT.) = '7E'X THEN
  1313.          BEGIN                                 (* Repeat quoting *)
  1314.             CHARS (.OUTDATACOUNT+1.) := '7E'XC;
  1315.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1316.             OUTDATACOUNT := OUTDATACOUNT + 1
  1317.          END;
  1318.          IF BYTES (.OUTDATACOUNT.) <> 0 THEN
  1319.             CHARS (.OUTDATACOUNT.) :=
  1320.                   ASCIITOEBCDIC (.BYTES (.OUTDATACOUNT.).);
  1321.          IF (CHARS (.OUTDATACOUNT.) = CNTRL_QUOTE) OR
  1322.             (CHARS (.OUTDATACOUNT.) = BIT8_QUOTE) THEN
  1323.          BEGIN                                (* Quote the quote *)
  1324.             CHARS (.OUTDATACOUNT+1.) := CHARS (.OUTDATACOUNT.);
  1325.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1326.             OUTDATACOUNT := OUTDATACOUNT + 1
  1327.          END
  1328.        END
  1329.        ELSE BEGIN (* Untranslated file *)
  1330.          (* Untranslated file means the file is stored as  *)
  1331.          (* 8 bit ASCII. However it must be translated into*)
  1332.          (* EBCDIC so that the comten software will trans- *)
  1333.          (* late it back into ASCII.                       *)
  1334.          IF BYTES (.OUTDATACOUNT.) >= 128 THEN
  1335.             IF BIT8_QUOTE = '00'XC THEN        (* No bit8 quoting *)
  1336.                                           (* Just drop the 8th bit  *)
  1337.                BYTES (.OUTDATACOUNT.) := BYTES (.OUTDATACOUNT.) - 128
  1338.             ELSE BEGIN                         (* BIT8 QUOTING *)
  1339.                BYTES (.OUTDATACOUNT+1.) := BYTES (.OUTDATACOUNT.)-128;
  1340.                CHARS (.OUTDATACOUNT.)   := BIT8_QUOTE;
  1341.                OUTDATACOUNT := OUTDATACOUNT + 1
  1342.             END;
  1343.          IF BYTES (.OUTDATACOUNT.) < 32 THEN
  1344.          BEGIN                                   (* CONTROL QUOTING *)
  1345.             BYTES (.OUTDATACOUNT+1.) := BYTES (.OUTDATACOUNT.) + 64;
  1346.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1347.             OUTDATACOUNT := OUTDATACOUNT + 1
  1348.          END;
  1349.          IF BYTES (.OUTDATACOUNT.) = '7F'X THEN
  1350.          BEGIN                                     (* <DEL> quoting *)
  1351.             CHARS (.OUTDATACOUNT+1.) := '3F'XC;
  1352.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1353.             OUTDATACOUNT := OUTDATACOUNT + 1
  1354.          END;
  1355.          IF BYTES (.OUTDATACOUNT.) = '7E'X THEN
  1356.          BEGIN                                     (* Repeat quoting *)
  1357.             CHARS (.OUTDATACOUNT+1.) := '7E'XC;
  1358.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1359.             OUTDATACOUNT := OUTDATACOUNT + 1
  1360.          END;
  1361.          IF BYTES (.OUTDATACOUNT.) <> 0 THEN
  1362.             CHARS (.OUTDATACOUNT.) :=
  1363.                   ASCIITOEBCDIC (.BYTES (.OUTDATACOUNT.).);
  1364.          IF (CHARS (.OUTDATACOUNT.) = CNTRL_QUOTE) OR
  1365.             (CHARS (.OUTDATACOUNT.) = BIT8_QUOTE) THEN
  1366.          BEGIN                                  (* Quote the quote *)
  1367.             CHARS (.OUTDATACOUNT+1.) := CHARS (.OUTDATACOUNT.);
  1368.             CHARS (.OUTDATACOUNT.)   := CNTRL_QUOTE;
  1369.             OUTDATACOUNT := OUTDATACOUNT + 1
  1370.          END
  1371.        END;
  1372.        IF EOLN (SFILE) THEN BEGIN             (* Send CR, LF *)
  1373.          READLN (SFILE);
  1374.        (*IF TEXTMODE AND (OUTDATACOUNT>1) THEN              *)
  1375.             (* Delete trailing blanks *)
  1376.        (*WHILE (SENDMSG.CHARS (.OUTDATACOUNT.) = ' ') AND   *)
  1377.        (*      (OUTDATACOUNT > 1) DO                        *)
  1378.        (*  OUTDATACOUNT := OUTDATACOUNT - 1;                *)
  1379.          IF TEXTMODE THEN BEGIN              (* Only for text files *)
  1380.             OUTDATACOUNT := OUTDATACOUNT + 1;
  1381.             SENDMSG.CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
  1382.             OUTDATACOUNT := OUTDATACOUNT + 1;
  1383.             SENDMSG.CHARS (.OUTDATACOUNT.):='M'; (* Carriage Ret *)
  1384.             OUTDATACOUNT := OUTDATACOUNT + 1;
  1385.             SENDMSG.CHARS (.OUTDATACOUNT.) := CNTRL_QUOTE;
  1386.             OUTDATACOUNT := OUTDATACOUNT + 1;
  1387.             SENDMSG.CHARS (.OUTDATACOUNT.) := 'J'  (* Line Feed *)
  1388.          END
  1389.        END
  1390.    END
  1391. END; (* FILE TO PACKET *)
  1392.  
  1393. %TITLE Procedure CheckParms
  1394. (********************************************************************)
  1395. (* CheckParms- This routine checks the parameters received from     *)
  1396. (*             the micro KERMIT.                                    *)
  1397. (********************************************************************)
  1398. PROCEDURE CheckParms;
  1399. VAR i : INTEGER;
  1400. BEGIN
  1401.  IF INDEX (SPECTABLE, STR (CNTRL_QUOTE)) = 0 THEN CNTRL_QUOTE := '#';
  1402.  IF INDEX ('123', STR (CHECKTYPE))       = 0 THEN CHECKTYPE   := '1';
  1403.  IF INDEX (SPECTABLE, STR (BIT8_QUOTE))  = 0 THEN BIT8_QUOTE  := '&';
  1404.  IF BIT8_QUOTE = 'Y'  THEN BIT8_QUOTE  := '&';
  1405.  IF BIT8_QUOTE = 'N'  THEN BIT8_QUOTE  := '00'XC;
  1406.  IF INDEX (SPECTABLE, STR (REPEATCHAR))  = 0 THEN REPEATCHAR  := '~';
  1407.  i := CAPAS DIV 2;
  1408.  IF ODD (i) THEN Long_Packet := TRUE ELSE Long_Packet := FALSE;
  1409.  IF (NOT Long_Packet AND (PSIZE > 94)) THEN PSIZE := 94;
  1410.  IF PSIZE > 1000 THEN PSIZE := 1000;
  1411.  IF PSIZE < 26 THEN PSIZE := 94;
  1412.  (* IF PSIZE > 256 THEN CHECKTYPE := '3'; *)
  1413.  i := CAPAS DIV 8;
  1414.  IF ODD (i) THEN Handle_Attribute := TRUE
  1415.             ELSE Handle_Attribute := FALSE
  1416. END; (* CheckParms *)
  1417.  
  1418. %TITLE Procedure SendFile
  1419. (********************************************************************)
  1420. (* SendFile  - This routine handles the sending of a file to        *)
  1421. (*             the micro computer.                                  *)
  1422. (*             If the parameter string is blank it gets the file-   *)
  1423. (*             name from the users.                                 *)
  1424. (*             If it is non blank it assumes the file name is in    *)
  1425. (*             the parameter string, which was obtained by the      *)
  1426. (*             remote RECEIVE file command.                         *)
  1427. (********************************************************************)
  1428. PROCEDURE SendFile (FNAME : LString; XHeader : BOOLEAN);
  1429.  
  1430. LABEL LOOP1;
  1431.  
  1432. VAR
  1433.   Member      : STRING(8);
  1434.   AsName,
  1435.   KermName    : LString;
  1436.   Closed,
  1437.   SENDING,EOL : BOOLEAN;
  1438.   i, j, Ix,
  1439.   RETRIES     : INTEGER;
  1440.   DUMMY,
  1441.   B8Quote     : CHAR;
  1442.  
  1443. BEGIN
  1444.   IF FNAME = ' ' THEN  (* Get file name *)
  1445.      REPEAT
  1446.        Prompt ('Enter name of sendfile>', FNAME)
  1447.      UNTIL FNAME <> ' ';
  1448.   FNAME := LTRIM (FNAME);
  1449.   FNAME := TRIM (FNAME);
  1450.   AsName := ' ';
  1451.   IF INDEX(FNAME,' ') > 1 THEN BEGIN
  1452.      i := INDEX(FNAME,' ');
  1453.      AsName := SUBSTR (FNAME, i+1);
  1454.      FNAME  := SUBSTR (FNAME, 1, i-1);
  1455.      AsName := LTRIM  (Upper (AsName));
  1456.      IF INDEX(AsName,'AS ') > 0 THEN BEGIN
  1457.         i := INDEX  (AsName,'AS ') + 3;
  1458.         AsName := SUBSTR(AsName, i)
  1459.      END;
  1460.      IF Debug THEN WRITELN (DFile, 'AsName3 = ' || AsName);
  1461.   END;
  1462.   Wildcard_Search (FNAME);
  1463.   IF FileCount > 0 THEN FNAME := FileList (.1.)
  1464.   ELSE BEGIN (* No filename meets search criteria *)
  1465.     IF Remote THEN SendError ('No filename meets search criteria')
  1466.        ELSE WRITELN ('No filename meets search criteria');
  1467.        RETURN   (* Return to calling routine *)
  1468.   END;
  1469.   FNAME := TRIM (FNAME);
  1470.   CheckDsn (FNAME, DsnDisp);
  1471.   CASE DsnDisp OF
  1472.     BADNAME: BEGIN  (* Invalid TSO filename specified *)
  1473.                IF Remote THEN
  1474.                   SendError ('Bad filename ' || FNAME)
  1475.                ELSE WRITELN ('Bad filename ' || FNAME);
  1476.                RETURN   (* Return to calling routine *)
  1477.              END;
  1478.     NOMEM :  BEGIN  (* No member for PDS specified *)
  1479.                IF Remote THEN
  1480.                   SendError ('No member for PDS specified')
  1481.                ELSE WRITELN ('No member for PDS specified');
  1482.                RETURN   (* Return to calling routine *)
  1483.              END;
  1484.     NOACC :  BEGIN  (* No access to dataset *)
  1485.                IF Remote THEN
  1486.                   SendError ('No access to requested file')
  1487.                ELSE WRITELN ('No access to requested file');
  1488.                RETURN   (* Return to calling routine *)
  1489.              END;
  1490.     NEW,
  1491.     NEWMEM : BEGIN  (* Data set or member not found *)
  1492.                IF Remote THEN
  1493.                   SendError ('Data set ' || FNAME || ' not found')
  1494.                ELSE WRITELN ('Data set ', FNAME, ' not found !');
  1495.                RETURN   (* Return to calling routine *)
  1496.              END;
  1497.     OTHERWISE (* ok, data set exists *)
  1498.   END;
  1499.   IF AsName = ' ' THEN Extract (FNAME, KermName)
  1500.      ELSE KermName := AsName;
  1501.   IF Debug THEN WRITELN (DFILE, ' Sending file ', FNAME);
  1502.   IF NOT Remote THEN BEGIN
  1503.      WRITELN ('ready to SEND file  - Put Micro in receive mode. ');
  1504.      Waiting (Delay)
  1505.   END;
  1506.   Ix := 1;
  1507.   IF XHeader THEN BEGIN                 (* Type file in remote mode *)
  1508.      STATE := SD;
  1509.      TSOCommand := 'ALLOC F(SFILE) DA(' || FNAME || ') SHR REUSE';
  1510.      TSOService (TSOCommand, RC);
  1511.      IF Debug THEN WRITELN (DFILE, TSOCommand, ' RC = ', RC);
  1512.      RESET (SFILE)
  1513.   END ELSE STATE := S;
  1514.   GETREPLY := FALSE;
  1515.   SENDING := TRUE;
  1516.   WHILE SENDING DO BEGIN (* Send files *)
  1517.     IF GETREPLY THEN
  1518.        IF RecvPacket THEN
  1519.           IF (INPACKETTYPE = 'Y') AND (SeqChar=LastSeq) THEN {}
  1520.              ELSE IF (INPACKETTYPE = 'Y') AND (SeqChar<>LastSeq)
  1521.                   THEN ReSendit (10)
  1522.                 ELSE IF INPACKETTYPE = 'N' THEN ReSendit(10)
  1523.                    ELSE IF INPACKETTYPE = 'R' THEN STATE := S
  1524.                       ELSE STATE := A
  1525.                          ELSE  ReSendit(10);
  1526.   GETREPLY := TRUE;
  1527.   IF (INPACKETTYPE = 'Y') AND (INDATACOUNT > 0) THEN
  1528.      IF REPLYMSG.CHARS (.1.) = 'X' THEN STATE := SZ
  1529.         ELSE IF REPLYMSG.CHARS (.1.) = 'Z' THEN STATE := SZ;
  1530.  
  1531.   CASE STATE OF
  1532.     S :  BEGIN                                  (* Send INIT packit *)
  1533.            OUTPACKETTYPE := 'S';
  1534.            ParmPacket;
  1535.            SendPacket;
  1536.            STATE := SF
  1537.          END;
  1538.  
  1539.     SF:  BEGIN                                  (* Send file header *)
  1540.            IF INDATACOUNT > 1 THEN
  1541.            BEGIN                      (* Get init parameters *)
  1542.              IF INDATACOUNT >= 1 THEN
  1543.                 PSIZE :=
  1544.                 ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.1.).)) - 32;
  1545.              IF INDATACOUNT >= 5 THEN
  1546.                 ECHAR :=
  1547.                 ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.5.).)) - 32;
  1548.              IF INDATACOUNT >= 6 THEN
  1549.                 CNTRL_QUOTE := REPLYMSG.CHARS (.6.);
  1550.              IF INDATACOUNT >= 7 THEN BEGIN
  1551.                 B8Quote := REPLYMSG.CHARS (.7.);
  1552.                 IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
  1553.                 IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
  1554.                    BIT8_QUOTE := B8Quote
  1555.              END;
  1556.              IF INDATACOUNT >= 8 THEN
  1557.                 CHECKTYPE  := REPLYMSG.CHARS (.8.)
  1558.              ELSE CHECKTYPE  := '1';
  1559.              IF INDATACOUNT >= 9 THEN
  1560.                 REPEATCHAR := REPLYMSG.CHARS (.9.)
  1561.              ELSE REPEATCHAR := '~';
  1562.              IF INDATACOUNT >= 10 THEN
  1563.                 CAPAS      :=
  1564.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.10.).)) - 32
  1565.                 ELSE CAPAS := 0;
  1566.              IF INDATACOUNT >= 13 THEN BEGIN
  1567.                 PSIZE :=
  1568.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.12.).)) - 32;
  1569.                 PSIZE := PSIZE * 95 +
  1570.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.13.).)) - 32
  1571.              END;
  1572.              CheckParms
  1573.            END;
  1574.            OUTSEQ        := OUTSEQ + 1;
  1575.            IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1576.            OUTPACKETTYPE := 'F';
  1577.            SENDMSG.CHARS := KermName;
  1578.            OUTDATACOUNT  := LENGTH (KermName);
  1579.            SendPacket;
  1580.            TSOCommand := 'ALLOC F(SFILE) DA(' || FNAME ||
  1581.                          ') SHR REUSE';
  1582.            TSOService (TSOCommand, RC);
  1583.            IF Debug THEN WRITELN (DFILE, TSOCommand, ' RC = ', RC);
  1584.            Closed := FALSE;
  1585.            RESET (SFILE);
  1586.            IF Handle_Attribute THEN               (* Send attributes *)
  1587.               IF RecvPacket THEN
  1588.                  IF INPACKETTYPE = 'Y' THEN BEGIN
  1589.                     OUTSEQ        := OUTSEQ + 1;
  1590.                     IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1591.                     OUTPACKETTYPE := 'A';
  1592.                     SENDMSG.CHARS := '."I2'; (*IBM/370 with MVS/TSO*)
  1593.                     OUTDATACOUNT  := 4;
  1594.                     SendPacket
  1595.                   END;
  1596.            STATE := SD
  1597.          END;
  1598.  
  1599.     SD:  BEGIN                                         (* Send data *)
  1600.            OUTPACKETTYPE := 'D';
  1601.            FileToPacket;
  1602.            SendPacket;
  1603.            IF EOF (SFILE) THEN STATE := SZ
  1604.          END;
  1605.  
  1606.     SZ:  BEGIN
  1607.            OUTDATACOUNT  := 0;
  1608.            OUTSEQ        := OUTSEQ + 1;
  1609.            IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1610.            OUTPACKETTYPE := 'Z';
  1611.            SendPacket;
  1612.     LOOP1: IF Ix >= FileCount THEN STATE := SB
  1613.            ELSE BEGIN
  1614.               IF NOT Closed THEN BEGIN
  1615.                  CLOSE (SFILE);
  1616.                  TSOService ('FREE F(SFILE)', RC);
  1617.                  Closed := TRUE
  1618.               END;
  1619.               Ix := Ix + 1;
  1620.               FNAME := FileList (.Ix.);
  1621.               CheckDsn (FNAME, DsnDisp);
  1622.               CASE DsnDisp OF
  1623.                  BADNAME: BEGIN  (* Invalid TSO filename specified *)
  1624.                             IF DEBUG THEN WRITELN
  1625.                                (DFILE, 'Bad filename ' || FNAME);
  1626.                             GOTO LOOP1
  1627.                           END;
  1628.                  NOMEM :  BEGIN  (* No member specified *)
  1629.                             IF DEBUG THEN WRITELN
  1630.                                (DFILE,'No member for PDS specified');
  1631.                             GOTO LOOP1
  1632.                           END;
  1633.                  NOACC :  BEGIN  (* No access to dataset *)
  1634.                             IF DEBUG THEN WRITELN
  1635.                                (DFILE,'No access to requested file');
  1636.                             GOTO LOOP1
  1637.                           END;
  1638.                  NEW,
  1639.                  NEWMEM : BEGIN  (* Data set or member not found *)
  1640.                             IF Debug THEN WRITELN (DFILE,
  1641.                                  'Data set ' || FNAME || ' not found');
  1642.                             GOTO LOOP1
  1643.                           END;
  1644.                  OTHERWISE (* ok, data set exists *)
  1645.               END;
  1646.               Extract (FNAME, KermName);
  1647.               STATE := SF
  1648.            END;
  1649.          END;
  1650.  
  1651.     SB:  BEGIN                                    (* Last file sent *)
  1652.            OUTDATACOUNT  := 0;
  1653.            OUTSEQ        := OUTSEQ + 1;
  1654.            IF OUTSEQ >= 64 THEN OUTSEQ := 0;
  1655.            OUTPACKETTYPE := 'B';
  1656.            SendPacket;
  1657.            STATE := C
  1658.          END;
  1659.  
  1660.      C:  BEGIN                                 (* Completed Sending *)
  1661.            CLOSE (SFILE);
  1662.            TSOService ('FREE F(SFILE)', RC);
  1663.            SENDING := FALSE
  1664.          END;
  1665.  
  1666.      A:  BEGIN                                    (* Abort Sending *)
  1667.            CLOSE (SFILE);
  1668.            TSOService ('FREE F(SFILE)', RC);
  1669.            ABORT   := BADSF;
  1670.            SENDING := FALSE;
  1671.            SendError ('Send file aborted')
  1672.          END
  1673.      END  (* CASE of STATE *)
  1674.    END  (* Send files *)
  1675. END; (* SendFile procedure *)
  1676. %TITLE Procedure RecvFile
  1677. (* **************************************************************** *)
  1678. (* RecvFile  - This routine handles the Receiving of a file from    *)
  1679. (*             the micro computer.                                  *)
  1680. (*                                                                  *)
  1681. (* Note : whenever a CR,LF pair is received it assumes it is the    *)
  1682. (*        an EOLN indicator and are not stored in the file.         *)
  1683. (*        However if we get two CR,LF in a row we can not write     *)
  1684. (*        an empty record so we must store the next CR,LF in the    *)
  1685. (*        next record .                                             *)
  1686. (* **************************************************************** *)
  1687. PROCEDURE RecvFile;
  1688.  
  1689. VAR
  1690.   BIT8       : BYTE;
  1691.   B8Quote,
  1692.   Dummy      : CHAR;
  1693.   IN_Attr,
  1694.   FILEWANTED,
  1695.   OldFname   : LString;
  1696.   REP, K,
  1697.   RETRIES,IX : INTEGER;
  1698.   CRFLAG,
  1699.   CRLFFLAG   : BOOLEAN;
  1700.   TITLE      : STRING (80);
  1701.   RFILE      : TEXT;                               (* RECEIVE file *)
  1702.  
  1703.   (*-------------------------------------------------------------*)
  1704.   (*  SendNAK - Procedure of RECVFILE, will check the number of  *)
  1705.   (*            RETRIES , if it is greater than 0 it will send a *)
  1706.   (*            call SENDACK(FALSE) which send a NAK packet and  *)
  1707.   (*            decrements the RETRIES by 1.                     *)
  1708.   (*  Side Effect - RETRIES is decremented by 1.                 *)
  1709.   (*                STATE is set to A if no more retries.        *)
  1710.   (*-------------------------------------------------------------*)
  1711.   PROCEDURE SendNAK;
  1712.   BEGIN
  1713.     IF RETRIES > 0 THEN
  1714.     BEGIN
  1715.       SendACK (FALSE);
  1716.       RETRIES := RETRIES - 1
  1717.     END
  1718.     ELSE STATE := A
  1719.   END; (* SEND ACK or NAK *)
  1720.  
  1721.   (*---------------------------------------------------------------*)
  1722.   (*  AllocFile - Procedure of RECVFILE, will allocate a file for  *)
  1723.   (*              receiving function.                              *)
  1724.   (*---------------------------------------------------------------*)
  1725.   PROCEDURE AllocFile (OutFile : LSTRING);
  1726.   VAR
  1727.     DsnDCB  : STRING(40);
  1728.   BEGIN
  1729.     IF NOT TEXTMODE THEN DsnDCB := DCB_Bin
  1730.        ELSE IF FB THEN DsnDCB := DCB_Fix
  1731.           ELSE DsnDCB := DCB_Var;
  1732.     TSOCommand := 'ALLOC F(RFILE) DA(' || OutFile || ') ';
  1733.     CASE DsnDisp OF
  1734.        NEW    : BEGIN
  1735.                   TSOCommand :=
  1736.                      TSOCommand || 'NEW TR SP(5,5) ' || DsnDCB;
  1737.                   IF INDEX (OutFile, '(') > 0 THEN
  1738.                      TSOCommand := TSOCommand || ' DIR(5)';
  1739.                 END;
  1740.        NEWMEM,
  1741.        SHARE  : TSOCommand := TSOCommand || 'SHR REUSE';
  1742.        OLD,
  1743.        OLDMEM : TSOCommand := TSOCommand || 'OLD REUSE';
  1744.        MODIFY : TSOCommand := TSOCommand || 'MOD REUSE';
  1745.     END;
  1746.     TSOService (TSOCommand, RC);
  1747.     IF Debug THEN WRITELN (DFILE, TSOCommand, ' => RetCode = ', RC);
  1748.   END; (* Allocate File for Receiving *)
  1749.  
  1750.   (*---------------------------------------------------------------*)
  1751.   (*  DecodeAttr - Decode incoming attribute fields.               *)
  1752.   (*---------------------------------------------------------------*)
  1753.   PROCEDURE DecodeAttr (AttrStr : LSTRING);
  1754.   VAR
  1755.     K,
  1756.     Len : INTEGER;
  1757.     Ch1 : CHAR;
  1758.     Attribute : STRING(94);
  1759.   BEGIN
  1760.     WHILE LENGTH (AttrStr) > 1 DO BEGIN
  1761.       Ch1       := AttrStr (.1.);
  1762.       Len       := ORD (EBCDICTOASCII (. ORD (AttrStr(.2.)).))-32;
  1763.       Attribute := SUBSTR (AttrStr, 3, Len);
  1764.       AttrStr   := DELETE (AttrStr, 1, Len+2);
  1765.       IF DEBUG THEN WRITELN (DFILE, 'Attribute: ', Ch1,' ', Attribute)
  1766.     END;
  1767.   END; (* DecodeAttr *)
  1768.  
  1769. BEGIN
  1770.   GetFile := TRUE;
  1771.   IF NOT Remote THEN
  1772.     IF LENGTH (INPUTSTRING) > 0 THEN BEGIN
  1773.        FILEWANTED := INPUTSTRING;
  1774.        IF INDEX (FILEWANTED, '*') > 0 THEN BEGIN
  1775.           WRITELN ('Wildcards not allowed, yet');
  1776.           RETURN
  1777.        END;
  1778.        CheckDsn  (FILEWANTED, DsnDisp);
  1779.        IF DsnDisp = ERROR THEN BEGIN
  1780.           WRITELN ('An error occurred while reading DS information');
  1781.           WRITELN ('Please turn DEBUG option ON, and retry operation');
  1782.           RETURN
  1783.        END;
  1784.        AllocFile (FILEWANTED);
  1785.        WRITELN (' RECEIVE mode - Issue a SEND command from micro. ')
  1786.     END;
  1787.   IF Remote THEN BEGIN OUTSEQ := 0; SendNAK END;
  1788.   STATE := R;
  1789.   RECEIVING := TRUE;
  1790.   RETRIES := 10;            (* Up to 10 retries allowed. *)
  1791.  
  1792.   WHILE RECEIVING DO
  1793.   CASE STATE OF
  1794.     R : BEGIN                             (* Initial Receive State  *)
  1795.           IF (NOT RecvPacket) OR (INPACKETTYPE='N') THEN SendNAK
  1796.           ELSE (* Get a packet *)
  1797.             IF INPACKETTYPE = 'S' THEN
  1798.             BEGIN  (* Get Init parameters *)
  1799.               IF INDATACOUNT >= 1 THEN
  1800.                  PSIZE := ORD(EBCDICTOASCII(.REPLYMSG.BYTES(.1.).))-32;
  1801.               IF INDATACOUNT >= 5 THEN
  1802.                  ECHAR := ORD(EBCDICTOASCII(.REPLYMSG.BYTES(.5.).))-32;
  1803.               IF INDATACOUNT >= 6 THEN
  1804.                  CNTRL_QUOTE := REPLYMSG.CHARS (.6.);
  1805.               IF INDATACOUNT >= 7 THEN BEGIN
  1806.                  B8Quote := REPLYMSG.CHARS (.7.);
  1807.                  IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
  1808.                  IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
  1809.                     BIT8_QUOTE := B8Quote
  1810.               END;
  1811.               IF INDATACOUNT >= 8 THEN
  1812.                  CHECKTYPE  := REPLYMSG.CHARS (.8.)
  1813.               ELSE CHECKTYPE  := '1';
  1814.               IF INDATACOUNT >= 9 THEN
  1815.                  REPEATCHAR := REPLYMSG.CHARS(.9.)
  1816.               ELSE REPEATCHAR := '~';
  1817.               IF INDATACOUNT >= 10 THEN
  1818.                  CAPAS      :=
  1819.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.10.).)) - 32
  1820.                  ELSE CAPAS := 0;
  1821.               IF INDATACOUNT >= 13 THEN BEGIN
  1822.                  PSIZE :=
  1823.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.12.).)) - 32;
  1824.                  PSIZE := PSIZE * 95 +
  1825.                    ORD (EBCDICTOASCII (.REPLYMSG.BYTES (.13.).)) - 32
  1826.               END;
  1827.               CheckParms;
  1828.               OUTPACKETTYPE := 'Y';
  1829.               ParmPacket;
  1830.               SendPacket;
  1831.               STATE := RF
  1832.             END
  1833.             ELSE BEGIN (* Not init packet *)
  1834.               STATE := A;   (* ABORT if not INIT packet *)
  1835.               ABORT := NOT_S
  1836.             END
  1837.         END ; (* Initial Receive State  *)
  1838.  
  1839.     RF: IF (NOT RecvPacket) OR (INPACKETTYPE='N') THEN SendNAK
  1840.         ELSE (* Get a packet *)
  1841.           IF INPACKETTYPE = 'S' THEN STATE:=R
  1842.           ELSE IF INPACKETTYPE = 'Z' THEN SendACK (TRUE)
  1843.             ELSE IF INPACKETTYPE = 'B' THEN STATE:=C
  1844.                ELSE IF INPACKETTYPE = 'F' THEN
  1845.                   BEGIN                          (* Got file header *)
  1846.                     FILEWANTED :=
  1847.                       SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
  1848.                     IF INDEX (FILEWANTED, '*') > 0 THEN BEGIN
  1849.                        SendError ('No wildcards allowed, yet');
  1850.                        RETURN
  1851.                     END;
  1852.                     IX := LENGTH (FILEWANTED);
  1853.                     IF FILEWANTED (.IX.) = '.' THEN
  1854.                        FILEWANTED := SUBSTR (FILEWANTED, 1, IX-1);
  1855.                     IF Remote THEN BEGIN
  1856.                        OldFname := FILEWANTED;
  1857.                        CheckDsn (FILEWANTED, DsnDisp);
  1858.                        IF DsnDisp = ERROR THEN STATE := A
  1859.                           ELSE AllocFile (FILEWANTED)
  1860.                     END;
  1861.                     IF DsnDisp <> ERROR THEN BEGIN
  1862.                        REWRITE (RFILE);
  1863.                        CRFLAG := FALSE;
  1864.                        CRLFFLAG := FALSE;
  1865.                        STATE := RD;
  1866.                        SendACK (TRUE)
  1867.                     END
  1868.                   END
  1869.                   ELSE BEGIN (* Not S,F,B,Z packet *)
  1870.                     (* ABORT if not a S,F,B,Z type packet *)
  1871.                     STATE := A;
  1872.                     ABORT := NOT_SFBZ
  1873.                   END;
  1874.  
  1875.     RD: IF (NOT RecvPacket) OR (INPACKETTYPE='N') THEN SendNAK
  1876.         ELSE (* Got a good packet *)
  1877.            IF INPACKETTYPE = 'A' THEN
  1878.               BEGIN                              (* Got attributes  *)
  1879.                  IN_Attr :=
  1880.                     SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
  1881.                  DecodeAttr (IN_Attr);
  1882.                  SendACK (TRUE)
  1883.               END
  1884.            ELSE IF INPACKETTYPE = 'D' THEN          (* Receive data *)
  1885.              IF SeqChar = LastSeq THEN BEGIN         (* Drop packet *)
  1886.                 OUTSEQ := OUTSEQ - 1;
  1887.                 RETRIES := 10;               (* Reset RETRIES count *)
  1888.                 SendACK (TRUE)
  1889.              END ELSE BEGIN                     (* Correct sequence *)
  1890.              RETRIES := 10;                  (* Reset RETRIES count *)
  1891.              I := 1;
  1892.              REP := 1;
  1893.              WHILE I <= INDATACOUNT DO
  1894.                 WITH REPLYMSG DO
  1895.                   IF TEXTMODE THEN BEGIN       (* SCAN EBCDIC data *)
  1896.                     IF CHARS (.I.) = REPEATCHAR THEN
  1897.                     BEGIN                       (* Repeat character *)
  1898.                       REP := ORD (EBCDICTOASCII (.BYTES (.I+1.).))-32;
  1899.                       I := I + 2
  1900.                     END;
  1901.                     IF CHARS (.I.) = BIT8_QUOTE THEN
  1902.                     BEGIN                        (* 8 bit character *)
  1903.                       I := I+1 ;
  1904.                       BIT8 := 128
  1905.                     END ELSE BIT8 := 0;
  1906.                     IF CHARS (.I.) = CNTRL_QUOTE THEN
  1907.                     BEGIN                      (* CONTROL character *)
  1908.                       I := I+1;
  1909.                       CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
  1910.                       IF CHARS (.I.) = '3F'XC THEN (* Make it a del *)
  1911.                          BYTES (.I.) := '7F'X
  1912.                       ELSE
  1913.                         IF BYTES(.I.) >= 64 THEN (* Make it a control *)
  1914.                            IF CHARS (.I.) <> '7E'XC THEN
  1915.                               BYTES (.I.) := BYTES (.I.) - 64;
  1916.                       IF BYTES (.I.) <> 0 THEN
  1917.                          CHARS (.I.) :=
  1918.                                ASCIITOEBCDIC (.BYTES (.I.) + BIT8.);
  1919.                     END ELSE
  1920.                       IF BIT8 <> 0 THEN BEGIN
  1921.                          CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
  1922.                          CHARS (.I.) :=
  1923.                                ASCIITOEBCDIC (.BYTES (.I.) + BIT8.)
  1924.                       END;
  1925.                     IF CRFLAG THEN BEGIN  (* previous char was a CR *)
  1926.                        CRFLAG := FALSE;
  1927.                        IF CHARS (.I.) = '25'XC THEN WRITELN (RFILE)
  1928.                        ELSE BEGIN
  1929.                          WRITE (RFILE, '0D'XC);
  1930.                          FOR K := 1 TO REP DO
  1931.                              WRITE  (RFILE, CHARS (.I.));
  1932.                          REP := 1
  1933.                        END
  1934.                     END ELSE
  1935.                        IF  CHARS (.I.) = '0D'XC THEN CRFLAG := TRUE
  1936.                        ELSE BEGIN                    (* not a CR *)
  1937.                           CRFLAG := FALSE;
  1938.                           FOR K := 1 TO REP DO
  1939.                             WRITE  (RFILE, CHARS (.I.));
  1940.                           REP := 1
  1941.                        END;
  1942.                     I := I + 1
  1943.                   END
  1944.                   ELSE BEGIN             (* Text mode is OFF *)
  1945.                     (* Revert back to ASCII data record *)
  1946.                     IF CHARS (.I.) = REPEATCHAR THEN
  1947.                     BEGIN                       (* Repeat character *)
  1948.                       REP := ORD (EBCDICTOASCII (.BYTES (.I+1.).))-32;
  1949.                       I := I + 2
  1950.                     END;
  1951.                     IF CHARS (.I.) = BIT8_QUOTE THEN
  1952.                     BEGIN                       (* 8TH BIT QUOTING  *)
  1953.                       I := I+1;
  1954.                       BIT8 := 128
  1955.                     END ELSE BIT8 := 0;
  1956.                     IF CHARS (.I.) = CNTRL_QUOTE THEN
  1957.                     BEGIN                      (* CONTROL character *)
  1958.                       I := I+1 ;
  1959.                       CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
  1960.                       IF CHARS (.I.) = '3F'XC THEN (* Make it a del *)
  1961.                          BYTES (.I.) := '7F'X
  1962.                         ELSE
  1963.                         IF BYTES(.I.) >= 64 THEN (* Make it a control *)
  1964.                            IF CHARS (.I.) <> '7E'XC THEN
  1965.                               BYTES (.I.) := BYTES (.I.) - 64;
  1966.                     END   (* CONTROL character *)
  1967.                     ELSE CHARS (.I.) := EBCDICTOASCII (.BYTES (.I.).);
  1968.                     BYTES (.I.) := BYTES (.I.) + BIT8;
  1969.                     FOR K := 1 TO REP DO
  1970.                         WRITE  (RFILE, CHARS (.I.));
  1971.                     REP := 1;
  1972.                     I := I + 1
  1973.                   END ;
  1974.            SendACK (TRUE)
  1975.          END
  1976.          ELSE IF INPACKETTYPE = 'F' THEN BEGIN       (* Send ACK *)
  1977.            OUTSEQ := OUTSEQ - 1;
  1978.            SendACK (TRUE)
  1979.          END
  1980.          ELSE IF INPACKETTYPE = 'Z' THEN
  1981.          BEGIN                              (* End of Receive File *)
  1982.            CLOSE (RFILE);
  1983.            TSOService ('FREE F(RFILE)', RC);
  1984.            STATE := RF;
  1985.            SendACK (TRUE)
  1986.          END
  1987.          ELSE BEGIN                             (* Not D,Z packet *)
  1988.            STATE := A;   (* ABORT - Type not D or Z, *)
  1989.            ABORT := NOT_DZ
  1990.          END;
  1991.  
  1992.      C:  BEGIN                               (* COMPLETED Receiving *)
  1993.            CLOSE (RFILE);
  1994.            TSOService ('FREE F(RFILE)', RC);
  1995.            SendACK (TRUE);
  1996.            RECEIVING := FALSE;
  1997.            GetFile   := FALSE
  1998.          END;
  1999.  
  2000.      A:  BEGIN                                  (* Abort Receiving *)
  2001.            CLOSE (RFILE);
  2002.            IF Incomplete_File THEN
  2003.               TSOService ('FREE F(RFILE)', RC)
  2004.            ELSE TSOService ('FREE F(RFILE) DELETE', RC);
  2005.            RECEIVING := FALSE;
  2006.            GetFile   := FALSE;
  2007.            SendError ('Receive file aborted')
  2008.          END
  2009.    END (* CASE of STATE *)
  2010. END;  (* RecvFile *)
  2011.  
  2012. %TITLE Procedure ShowIT
  2013. (******************************************************************)
  2014. (* ShowIT -    This routine handles the SHOW COMMAND.             *)
  2015. (******************************************************************)
  2016.  
  2017. PROCEDURE ShowIT;
  2018. BEGIN
  2019.   WRITELN ('------- Current Status -----------');
  2020.   WRITELN (' ');
  2021.   IF ScreenSize = 0 THEN
  2022.      WRITELN (' KERMIT currently running in line mode (ASCII). ')
  2023.   ELSE WRITELN (' KERMIT currently running in full-screen mode.');
  2024.   WRITE   (' Init file KERMIT.SETUP ... ');
  2025.   IF Init_File THEN WRITELN ('already loaded')
  2026.      ELSE WRITELN ('not specified');
  2027.   WRITELN (' Your PROFILE data set is KERMIT.PROFILE');
  2028.   WRITELN (' ');
  2029.   IF TEXTMODE THEN BEGIN
  2030.      WRITELN (' TEXT MODE   is ON  - ASCII/EBCDIC');
  2031.      IF FB THEN  WRITELN (' RECFM_INPUT is FB, LRECL is 80')
  2032.            ELSE  WRITELN (' RECFM_INPUT is VB, LRECL is 255')
  2033.   END ELSE BEGIN
  2034.      WRITELN (' TEXT MODE   is OFF' );
  2035.      WRITELN (' RECFM_INPUT is U, BLKSIZE is 1024')
  2036.   END;
  2037.   WRITELN ('                ');
  2038.   WRITE   (' PACKET SIZE is ', PSIZE:3);
  2039.   IF Long_Packet THEN  WRITELN (' (extended packets)')
  2040.                  ELSE  WRITELN (' (standard packets)');
  2041.   WRITELN (' EOL CHAR    is ', ECHAR:2,' decimal(ascii)');
  2042.   WRITELN (' SOH CHAR    is ', SCHAR:2,' decimal(ascii)');
  2043.   WRITELN (' CNTRL_QUOTE is ', CNTRL_QUOTE);
  2044.   WRITELN (' BIT8_QUOTE  is ', BIT8_QUOTE, ORD (BIT8_QUOTE));
  2045.   WRITELN (' CHECKTYPE   is ', CHECKTYPE);
  2046.   WRITELN (' REPEATCHAR  is ', REPEATCHAR, ORD(REPEATCHAR));
  2047.   WRITELN (' DELAY       is ', Delay:3:1, ' seconds');
  2048.   WRITE   (' DEBUG mode  is ');
  2049.   IF Debug THEN WRITELN ('ON') ELSE WRITELN ('OFF');
  2050.   WRITE   (' INCOMPLETE  is ');
  2051.   IF Incomplete_File THEN WRITELN ('KEEP') ELSE WRITELN ('DELETE');
  2052.   WRITELN (' ');
  2053.   IF STATE = C THEN WRITELN('Last File transferred completed OK. ');
  2054.   IF STATE = A THEN BEGIN (* ABORTED file transfer *)
  2055.      WRITE  ('Last File transfer Aborted while ');
  2056.      CASE ABORT OF
  2057.        BADSF   : WRITELN ('attempting to send file to micro.');
  2058.        NOT_S   : WRITELN ('waiting for Init Packet.');
  2059.        NOT_SFBZ: WRITELN ('waiting for File header packet.');
  2060.        NOT_DZ  : WRITELN ('waiting for a DATA  packet.');
  2061.        OTHERWISE WRITELN ('being completely confused ');
  2062.      END;   (* CASE ABORT *)
  2063.      WRITELN(' ')
  2064.   END (* ABORTED file transfer *)
  2065. END;  (* ShowIT procedure *)
  2066.  
  2067. %TITLE Procedure SetIT
  2068. (******************************************************************)
  2069. (* SetIT  -    This routine handles the SET COMMAND.              *)
  2070. (******************************************************************)
  2071.  
  2072. PROCEDURE SetIT;
  2073. VAR Answer : ALFA;
  2074.     Temp   : STRING (1);
  2075.     N1, N2 : INTEGER;
  2076.  
  2077. BEGIN
  2078.   COMMAND := GETTOKEN (INPUTSTRING);
  2079.   UPCASE (COMMAND);
  2080.   REQUEST := ' ' || TRIM (STR (COMMAND));
  2081.   CINDEX := INDEX (WHATTABLE, REQUEST) DIV 8 ;
  2082.   IF LENGTH (INPUTSTRING) = 0 THEN INPUTSTRING := '?';
  2083.  
  2084.   CASE WHATFLAGS (CINDEX) OF
  2085.     $TEXTMODE :                                   (* TEXT MODE FLAG *)
  2086.             IF INPUTSTRING(.1.) = '?' THEN
  2087.                WRITELN ('Enter ON for Textfiles, OFF for binary files')
  2088.             ELSE BEGIN
  2089.             SETTING := GETTOKEN (INPUTSTRING);
  2090.             UPCASE (SETTING);
  2091.                TEXTMODE := NOT (SETTING = 'OFF     ');
  2092.                IF TEXTMODE THEN WRITELN ('TEXT MODE is ON ')
  2093.                   ELSE WRITELN ('TEXT MODE is OFF');
  2094.             END;
  2095.     $RECFM :                                          (* RECFM  *)
  2096.             IF INPUTSTRING(.1.) = '?' THEN BEGIN
  2097.                WRITELN ('Enter FB for fixed record length, ');
  2098.                WRITELN ('   or VB for variable record length')
  2099.             END ELSE BEGIN
  2100.                SETTING := GETTOKEN (INPUTSTRING);
  2101.                UPCASE (SETTING);
  2102.                  IF SETTING = 'FB      ' THEN FB := TRUE
  2103.                     ELSE FB := FALSE;
  2104.                  IF FB THEN WRITELN ('INPUT RECFM is FB, LRECL is 80')
  2105.                     ELSE WRITELN ('INPUT RECFM is VB, LRECL is 255 ')
  2106.             END;
  2107.     $PACKETSIZE:                              (* SET PACKET SIZE *)
  2108.             IF INPUTSTRING(.1.) = '?' THEN
  2109.               WRITELN ('Enter number (range 26 .. 1000) as packetsize')
  2110.             ELSE BEGIN
  2111.                IF INPUTSTRING (.1.) = '-' THEN
  2112.                   INPUTSTRING := SUBSTR (INPUTSTRING, 2);
  2113.                READSTR (INPUTSTRING, PSIZE);
  2114.                IF (PSIZE > 1000) THEN BEGIN
  2115.                   WRITELN ('ERROR: Number too large. Will use 1000');
  2116.                   PSIZE := 1000
  2117.                END;
  2118.                IF (PSIZE < 26) THEN BEGIN
  2119.                   WRITELN ('ERROR: Number too small. Will use 94');
  2120.                   PSIZE := 94
  2121.                END;
  2122.                IF PSIZE > 94 THEN Long_Packet := TRUE
  2123.                              ELSE Long_Packet := FALSE;
  2124.             (* IF PSIZE > 256 THEN CHECKTYPE := '3'; *)
  2125.                WRITELN ('PACKET SIZE is ',PSIZE:4)
  2126.             END;
  2127.    $EOLCHAR :                               (* SET end of line char *)
  2128.             IF INPUTSTRING(.1.) = '?' THEN
  2129.                WRITELN ('Enter number (ascii) used as eol character')
  2130.             ELSE BEGIN
  2131.                IF INPUTSTRING (.1.) = '-' THEN
  2132.                   INPUTSTRING := SUBSTR (INPUTSTRING, 2);
  2133.                READSTR (INPUTSTRING, ECHAR);
  2134.                IF (ECHAR < 5) OR (ECHAR > 18) THEN ECHAR := 13 ;
  2135.                WRITELN ('EOLCHAR     is ', ECHAR, ' decimal(ascii)')
  2136.             END;
  2137.    $CNTRL_QUOTE:                             (* SET control quote *)
  2138.             IF INPUTSTRING(.1.) = '?' THEN
  2139.                WRITELN ('Enter character to be used as cntrl quote')
  2140.             ELSE BEGIN
  2141.                READSTR (INPUTSTRING, Temp);
  2142.                IF INDEX (SPECTABLE, Temp) > 0 THEN
  2143.                   CNTRL_QUOTE := Temp (.1.) ELSE CNTRL_QUOTE := '#';
  2144.                WRITELN ('CNTRL QUOTE is ', CNTRL_QUOTE)
  2145.             END;
  2146.    $BIT8_QUOTE:                                (* SET bit 8 quote *)
  2147.             IF INPUTSTRING(.1.) = '?' THEN
  2148.                WRITELN ('Enter character to be used as bit8 quote')
  2149.             ELSE BEGIN
  2150.                READSTR (INPUTSTRING, Temp);
  2151.                IF INDEX (SPECTABLE, Temp) > 0 THEN
  2152.                   BIT8_QUOTE := Temp (.1.) ELSE BIT8_QUOTE := '&';
  2153.                WRITELN ('BIT8_QUOTE  is ', BIT8_QUOTE)
  2154.             END;
  2155.    $CHECKTYPE :                                  (* SET CHECK TYPE  *)
  2156.             IF INPUTSTRING(.1.) = '?' THEN
  2157.                WRITELN ('Enter number (1,2 or 3) to select check type')
  2158.             ELSE BEGIN
  2159.                READSTR (INPUTSTRING, CHECKTYPE);
  2160.                IF INDEX ('123', STR (CHECKTYPE)) = 0 THEN
  2161.                   CHECKTYPE := '1';
  2162.                WRITELN ('CHECKTYPE   is ', CHECKTYPE )
  2163.             END;
  2164.    $DELAY :                                     (* SET DELAY FACTOR *)
  2165.             IF INPUTSTRING(.1.) = '?' THEN
  2166.                WRITELN ('Enter send wait-time in seconds (2 .. 30)')
  2167.             ELSE BEGIN
  2168.                READSTR (INPUTSTRING, Delay);
  2169.                IF (Delay < 2) OR (Delay > 30) THEN Delay := 6;
  2170.                WRITELN ('Delay now set to ', Delay:3:1, ' seconds')
  2171.             END;
  2172.    $DEBUG :                                     (* SET DEBUG option *)
  2173.             IF INPUTSTRING(.1.) = '?' THEN BEGIN
  2174.                WRITELN ('Enter ON to log transactions, or');
  2175.                WRITELN ('      OFF to finish logging')
  2176.             END ELSE BEGIN
  2177.                READSTR (INPUTSTRING, Answer);
  2178.                UPCASE (Answer);
  2179.                IF Answer = 'ON'  THEN
  2180.                 IF Debug THEN (* DEBUG was already ON ! *)
  2181.                 ELSE BEGIN
  2182.                  Debug := TRUE;
  2183.                  TSOService ('FREE F(DFILE)', RC);
  2184.                  TSOService ('DELETE ' || DEBUGNAME, RC);
  2185.                  TSOCommand := 'ALLOC F(DFILE) DA(' || DEBUGNAME ||
  2186.                                ') NEW SP(1,1) CYL ' || DCB_DEBUG;
  2187.                  TSOService (TSOCommand, RC);
  2188.                  IF RC < 8 THEN REWRITE (DFILE)
  2189.                  ELSE BEGIN
  2190.                     Debug := FALSE;
  2191.                     WRITELN ('Debug file could not be allocated, ',
  2192.                              'return code is ', RC)
  2193.                  END
  2194.                 END;
  2195.                IF Answer = 'OFF' THEN
  2196.                 IF Debug THEN BEGIN
  2197.                   Debug := FALSE;
  2198.                   CLOSE (DFILE);
  2199.                   TSOService ('FREE F(DFILE)', RC)
  2200.                 END ELSE (* DEBUG was already OFF ! *);
  2201.                WRITE ('Debug mode now set to ');
  2202.                IF Debug THEN WRITELN ('ON') ELSE WRITELN ('OFF')
  2203.              END;
  2204.    $REPCHAR :                                    (* SET repeat char *)
  2205.             IF INPUTSTRING(.1.) = '?' THEN
  2206.                WRITELN ('Enter character to be used as repeat quote')
  2207.             ELSE BEGIN
  2208.                READSTR (INPUTSTRING, Temp);
  2209.                IF INDEX (SPECTABLE, Temp) > 0 THEN
  2210.                   REPEATCHAR := Temp (.1.) ELSE REPEATCHAR := '~';
  2211.                WRITELN ('REPEAT CHAR is ', REPEATCHAR)
  2212.             END;
  2213.    $SOHCHAR :                                    (* SET repeat char *)
  2214.             IF INPUTSTRING(.1.) = '?' THEN
  2215.          WRITELN ('Enter decimal value (1..18) used as soh character')
  2216.             ELSE BEGIN
  2217.                IF INPUTSTRING (.1.) = '-' THEN
  2218.                   INPUTSTRING := SUBSTR (INPUTSTRING, 2);
  2219.                READSTR (INPUTSTRING, SCHAR);
  2220.                IF (SCHAR < 1) OR (SCHAR > 18) THEN SCHAR := 1 ;
  2221.                SOH := CHR (SCHAR);
  2222.                WRITELN ('SOHCHAR     is ', SCHAR, ' decimal(ascii)')
  2223.             END;
  2224.    $ATOE:                              (* SET ASCII -> EBCDIC table *)
  2225.             IF INPUTSTRING(.1.) = '?' THEN BEGIN
  2226.                WRITELN ('Enter two numbers, the first is the entry in');
  2227.                WRITELN ('the ASCII table, the second the correspond.');
  2228.                WRITELN ('EBCDIC char. The valid range is (1 .. 255) ')
  2229.             END
  2230.             ELSE BEGIN
  2231.                READSTR (INPUTSTRING, N1, N2);
  2232.                IF (N1 < 1) OR (N1 > 255) THEN RETURN;
  2233.                IF (N2 < 0) OR (N2 > 255) THEN RETURN;
  2234.                ASCIITOEBCDIC (.N1.) := CHR (N2);
  2235.                WRITELN ('ASCII (', N1:3,') has now the value of ',
  2236.                         'EBCDIC (', N2:3,')')
  2237.             END;
  2238.    $ETOA:                              (* SET EBCDIC -> ASCII table *)
  2239.             IF INPUTSTRING(.1.) = '?' THEN BEGIN
  2240.                WRITELN ('Enter two numbers, the first is the entry in');
  2241.                WRITELN ('the EBCDIC table, the second the correspon.');
  2242.                WRITELN ('ASCII char. The valid range is (1 .. 255) ')
  2243.             END
  2244.             ELSE BEGIN
  2245.                READSTR (INPUTSTRING, N1, N2);
  2246.                IF (N1 < 1) OR (N1 > 255) THEN RETURN;
  2247.                IF (N2 < 0) OR (N2 > 255) THEN RETURN;
  2248.                EBCDICTOASCII (.N1.) := CHR (N2);
  2249.                WRITELN ('EBCDIC (', N1:3,') has now the value of ',
  2250.                         'ASCII (', N2:3,')')
  2251.             END;
  2252.    $INCOMPLETE:                            (* SET incomplete option *)
  2253.             IF INPUTSTRING(.1.) = '?' THEN BEGIN
  2254.                WRITELN ('Enter options KEEP or DELETE to control the');
  2255.                WRITELN ('disposition of an incomplete file.')
  2256.             END
  2257.             ELSE BEGIN
  2258.                SETTING := GETTOKEN (INPUTSTRING);
  2259.                UPCASE (SETTING);
  2260.                IF (SETTING = 'DELETE  ') OR (SETTING = 'DEL     ') THEN
  2261.                   Incomplete_File := FALSE;
  2262.                IF SETTING = 'KEEP    ' THEN
  2263.                   Incomplete_File := TRUE
  2264.             END;
  2265.    $DUMMY: WRITELN ('NOT YET implemented ');
  2266.  
  2267.    OTHERWISE BEGIN                         (*  Invalid SET  OPTION  *)
  2268.      WRITELN ('SET ', REQUEST, ' - invalid option specified.');
  2269.      WRITELN ('Valid   OPTIONS are :   ');
  2270.      WRITELN ('----------------------- ');
  2271.      WRITELN (' ');
  2272.      WRITELN (' BIT8_QUOTE   c     - Bit8 quote character');
  2273.      WRITELN (' CHECK        n     - Block check type');
  2274.      WRITELN (' CNTRL_QUOTE  c     - Quote character');
  2275.      WRITELN (' DELAY        nnn   - Delay factor');
  2276.      WRITELN (' DEBUG       ON/OFF - Debug mode ');
  2277.      WRITELN (' EOLCHAR      nn    - Endline char (decimal)');
  2278.      WRITELN (' INCOMPLETE KEEP/DEL- Disposition of incomplete files');
  2279.      WRITELN (' PACKETSIZE   nn    - Packet size (decimal)');
  2280.      WRITELN (' RECFM       VB/FB  - Variable or Fixed');
  2281.      WRITELN (' REPEATCHAR   c     - Repeat char');
  2282.      WRITELN (' SOHCHAR      nn    - Start of packet (decimal)');
  2283.      WRITELN (' TEXTMODE    ON/OFF - for text / binary files');
  2284.    END
  2285.   END
  2286. END; (* SetIT  procedure *)
  2287.  
  2288. %TITLE Procedure Help
  2289. (******************************************************************)
  2290. (* Help   -    This routine handles the HELP COMMAND.             *)
  2291. (******************************************************************)
  2292. PROCEDURE Help;
  2293. BEGIN
  2294.  WRITELN (' The following are the valid KERMIT-TSO commands : ');
  2295.  WRITELN (' ');
  2296.  WRITELN (' SEND filename      - send a file to the micro');
  2297.  WRITELN ('      as! filename! (you may select the new name)');
  2298.  WRITELN (' RECEIVE filename! - receive a file from the micro');
  2299.  WRITELN (' SERVER             - go into server mode');
  2300.  WRITELN (' SET option value   - set OPTION to VALUE');
  2301.  WRITELN (' STATUS             - displays current options settings');
  2302.  WRITELN (' TAKE filename      - execute commands from a file');
  2303.  WRITELN (' DO   membername    - execute commands from your profile');
  2304.  WRITELN (' HELP               - displays this information');
  2305.  WRITELN (' EXIT, END or QUIT  - exit KERMIT , terminate program');
  2306.  WRITELN (' LOGOUT             - exit KERMIT and logoff from host');
  2307.  WRITELN (' ');
  2308.  WRITELN ('Additional TSO facilities:');
  2309.  WRITELN (' DELETE filename    - deletes cataloged data set');
  2310.  WRITELN (' DIR userid!       - shows user directory');
  2311.  WRITELN (' DISK               - displays disk usage');
  2312.  WRITELN (' MEMBERS filename   - shows member list of a file');
  2313.  WRITELN (' TSO command        - issues a TSO command');
  2314.  WRITELN (' TYPE filename      - displays data set at the screen');
  2315.  WRITELN (' WHO                - shows users logged in on the host');
  2316. END ; (* HELP procedure *)
  2317.  
  2318. %TITLE Procedure Micro_Finish;
  2319. (*******************************************************************)
  2320. (* Micro_Finish - This routine turns down a micro's KERMIT running *)
  2321. (*                in server mode (used only with setup-files).     *)
  2322. (*******************************************************************)
  2323. PROCEDURE Micro_Finish;
  2324. VAR Ok : BOOLEAN;
  2325. BEGIN
  2326.   OUTSEQ := 0;
  2327.   OUTPACKETTYPE := 'I';
  2328.   ParmPacket;
  2329.   SendPacket;
  2330.   IF RecvPacket AND (INPACKETTYPE='Y') THEN (* Ok *)
  2331.      ELSE ReSendit(10);
  2332.   OUTDATACOUNT  := 1;
  2333.   OUTSEQ        := 0;
  2334.   OUTPACKETTYPE := 'G';
  2335.   SENDMSG.CHARS := 'F';
  2336.   SendPacket;
  2337.   IF RecvPacket AND (INPACKETTYPE='Y') THEN  (* Ok *)
  2338.      ELSE ReSendit(10)
  2339. END;  (* Micro_Finish *)
  2340.  
  2341. %TITLE Procedure RemoteCommand
  2342. (*******************************************************************)
  2343. (* RemoteCommand -This routine handles the COMMANDS from a remote  *)
  2344. (*                kermit.                                          *)
  2345. (*******************************************************************)
  2346. PROCEDURE RemoteCommand;
  2347.  
  2348. CONST
  2349.   COMMANDTABLE     = 'CEGIRSYK';
  2350.   SUBCOMMANDTABLE  = 'ICLFDUETRKSPWMHQJV';
  2351.  
  2352. TYPE
  2353.   SUBCOMMANDTYPE = (ZERO,I,C,L,F,D,U,E,T,R,K,S,P,W,M,H,Q,J,V);
  2354.  
  2355. VAR
  2356.   COMMANDTYPE,
  2357.   SUBCOMMAND,
  2358.   B8Quote     : CHAR ;
  2359.   Ix          : INTEGER ;
  2360.   Ok          : BOOLEAN;
  2361.   TSOUser     : STRING (10);
  2362.   TSOFname    : STRING (80);
  2363.   XLine       : LString;
  2364. LABEL CHECKCOMMAND ;
  2365.  
  2366. (*-----------------------------------------------------------*)
  2367. (* Remote_Help - send help information to remote micro       *)
  2368. (*-----------------------------------------------------------*)
  2369. PROCEDURE Remote_Help;
  2370. BEGIN
  2371. SendDPacket
  2372.    ('This is the KERMIT server running under MVS/XA TSO'||CRLF, Ok);
  2373. IF NOT Ok THEN RETURN;
  2374. SendDPacket (CRLF, Ok);
  2375. IF NOT Ok THEN RETURN;
  2376. SendDPacket
  2377.   ('The following server commands are actually supported:'||CRLF, Ok);
  2378. IF NOT Ok THEN RETURN;
  2379. SendDPacket (CRLF, Ok);
  2380. IF NOT Ok THEN RETURN;
  2381. SendDPacket
  2382.   ('  DELETE filename - erases a specific host file'||CRLF, Ok);
  2383. IF NOT Ok THEN RETURN;
  2384. SendDPacket
  2385.   ('  DIR             - displays your disk directory'||CRLF, Ok);
  2386. IF NOT Ok THEN RETURN;
  2387. SendDPacket
  2388.   ('  DISK            - displays the current disk usage'||CRLF, Ok);
  2389. IF NOT Ok THEN RETURN;
  2390. SendDPacket
  2391.   ('  FINISH          - finishes server mode on the host'||CRLF, Ok);
  2392. IF NOT Ok THEN RETURN;
  2393. SendDPacket
  2394.   ('  GET filename    - requests one or more files'||CRLF, Ok);
  2395. IF NOT Ok THEN RETURN;
  2396. SendDPacket
  2397.   ('  HELP            - displays this information page'||CRLF, Ok);
  2398. IF NOT Ok THEN RETURN;
  2399. SendDPacket
  2400.   ('  LOGOUT          - stops host KERMIT and logout'||CRLF, Ok);
  2401. IF NOT Ok THEN RETURN;
  2402. SendDPacket
  2403.   ('  SEND filename   - sends one or more files to the host'||CRLF,Ok);
  2404. IF NOT Ok THEN RETURN;
  2405. SendDPacket
  2406.   ('  TYPE filename   - displays a specific host file'||CRLF, Ok);
  2407. IF NOT Ok THEN RETURN
  2408. END; (* Remote_Help *)
  2409.  
  2410. %PAGE
  2411. BEGIN  (* RemoteCommand procedure *)
  2412.   INPUTSTRING  := Line;
  2413.   COMMANDTYPE  := INPUTSTRING(.4.);
  2414.   INPACKETTYPE := COMMANDTYPE;
  2415.   GetFile := FALSE;
  2416.   CHECKCOMMAND :
  2417.   IF INDEX (COMMANDTABLE, STR (COMMANDTYPE)) = 0 THEN BEGIN
  2418.      SendError ('Unknown commandtype, ' || STR (COMMANDTYPE));
  2419.      RETURN
  2420.   END;
  2421.   IF COMMANDTYPE = 'C' THEN BEGIN            (* HOST command *)
  2422.     INPUTSTRING := SUBSTR (INPUTSTRING, 5);
  2423.     SendYPacket ('Host Command not available')
  2424.   END;
  2425.   IF COMMANDTYPE = 'K' THEN BEGIN            (* KERMIT command *)
  2426.     INPUTSTRING := SUBSTR (INPUTSTRING, 5);
  2427.     SendYPacket ('KERMIT command not executed')
  2428.   END;
  2429.   IF COMMANDTYPE = 'E' THEN (* Got an error message back *);
  2430.   IF COMMANDTYPE = 'I' THEN BEGIN            (* INITIALIZE *)
  2431.     INDATACOUNT := ORD (EBCDICTOASCII (.ORD (INPUTSTRING(.2.)).))-32-3;
  2432.     IF INDATACOUNT >= 1 THEN
  2433.        PSIZE := ORD (EBCDICTOASCII (.ORD (INPUTSTRING (.4+1.)).))-32;
  2434.     IF INDATACOUNT>= 5 THEN
  2435.        ECHAR := ORD (EBCDICTOASCII (.ORD (INPUTSTRING (.4+5.)).))-32;
  2436.     IF INDATACOUNT>= 6 THEN CNTRL_QUOTE := INPUTSTRING (.4+6.) ;
  2437.     IF INDATACOUNT>= 7 THEN BEGIN
  2438.        B8Quote := INPUTSTRING (.4+7.);
  2439.        IF B8Quote = 'Y' THEN BIT8_QUOTE := '&';
  2440.        IF NOT (B8Quote IN (.'Y', 'N'.)) THEN
  2441.           BIT8_QUOTE := B8Quote
  2442.     END;
  2443.     IF INDATACOUNT>= 8 THEN CHECKTYPE  := INPUTSTRING (.4+8.)
  2444.        ELSE CHECKTYPE  := '1';
  2445.     IF INDATACOUNT>= 9 THEN REPEATCHAR := INPUTSTRING (.4+9.)
  2446.        ELSE REPEATCHAR := '~';
  2447.     IF INDATACOUNT >= 10 THEN
  2448.        CAPAS := ORD (EBCDICTOASCII (.ORD (INPUTSTRING (.4+10.)).))-32
  2449.        ELSE CAPAS := 0;
  2450.     IF INDATACOUNT >= 13 THEN BEGIN
  2451.        PSIZE := ORD (EBCDICTOASCII(.ORD(INPUTSTRING(.4+12.)).))-32;
  2452.        PSIZE := PSIZE * 95 +
  2453.                   ORD (EBCDICTOASCII(.ORD(INPUTSTRING(.4+13.)).))-32
  2454.     END;
  2455.     OUTPACKETTYPE := 'Y';
  2456.     CheckParms;
  2457.     ParmPacket ;
  2458.     SendPacket ;
  2459.     IF RecvPacket THEN
  2460.     BEGIN
  2461.       COMMANDTYPE := INPACKETTYPE ;
  2462.       INPUTSTRING := 'XXX'||  STR(INPACKETTYPE) ||
  2463.                      SUBSTR (STR (REPLYMSG.CHARS), 1, INDATACOUNT);
  2464.       GOTO CHECKCOMMAND
  2465.     END
  2466.   END;
  2467.   IF COMMANDTYPE = 'R' THEN BEGIN         (* Send to micro *)
  2468.     INPUTSTRING := SUBSTR (INPUTSTRING, 5);
  2469.     TSOFname := LTRIM (INPUTSTRING);
  2470.     IF Debug THEN WRITELN (DFILE, 'REM: Sending file(s)', TSOFname);
  2471.     SendFile (TSOFname, FALSE)
  2472.   END;
  2473.   IF COMMANDTYPE = 'S' THEN BEGIN            (* Receive from micro *)
  2474.     IF Debug THEN WRITELN (DFILE, 'REM: Receiving file(s) from micro');
  2475.     RecvFile
  2476.   END;
  2477.   IF COMMANDTYPE = 'Y' THEN (* Got an ACK for break packet *);
  2478.   IF COMMANDTYPE = 'G' THEN BEGIN                 (* GENERAL *)
  2479.     SUBCOMMAND := INPUTSTRING (.5.);
  2480.     OUTSEQ := 0;
  2481.     CASE SUBCOMMANDTYPE (INDEX (SUBCOMMANDTABLE, STR (SUBCOMMAND))) OF
  2482.  
  2483.          C:                                    (* CHANGE command *)
  2484.             SendError ('No CHANGE directory available under MVS');
  2485.  
  2486.          D: BEGIN                             (* DIRECTORY command *)
  2487.               TSOService ('TSODS LISTCAT' , RC);
  2488.               IF RC <> 0 THEN
  2489.                  SendYPacket ('No file(s) found for '|| UserID)
  2490.               ELSE BEGIN (* GOT directory *)
  2491.                 OUTSEQ := 64;
  2492.                 SendXPacket ('DIRECTORY for ' || UserID);
  2493.                 RESET  (TSODS);
  2494.                 WHILE NOT EOF (TSODS) DO BEGIN
  2495.                   READLN (TSODS, XLine);
  2496.                   XLine := XLine || CRLF;
  2497.                   SendDPacket (XLine, Ok);
  2498.                   IF NOT Ok THEN LEAVE
  2499.                 END;
  2500.                 CLOSE (TSODS);
  2501.                 IF INPACKETTYPE='Y' THEN SendZPacket;
  2502.                 IF INPACKETTYPE='Y' THEN SendBPacket
  2503.               END
  2504.             END;
  2505.  
  2506.          E: BEGIN                             (* Erase File command *)
  2507.               IF LENGTH (INPUTSTRING) > 7 THEN
  2508.                  TSOFname :=
  2509.                    SUBSTR (INPUTSTRING, 7, LENGTH (INPUTSTRING)-6);
  2510.               IF Debug THEN WRITELN (DFILE, 'Delete data set ' ||
  2511.                                      TSOFname);
  2512.               TSOService ('DELETE ' || TSOFname, RC);
  2513.               IF RC = 0 THEN TSOCommand := 'File deleted '
  2514.                         ELSE TSOCommand := 'Not deleted  ';
  2515.               SendYPacket (TSOCommand)
  2516.             END;
  2517.  
  2518.          F: BEGIN                              (* FINISH command *)
  2519.               RUNNING := FALSE ;
  2520.               SendACK (TRUE)
  2521.             END;
  2522.  
  2523.          H: BEGIN                                 (* HELP  command *)
  2524.               OUTSEQ := 64;
  2525.               SendXPacket ('');
  2526.               Remote_Help;
  2527.               IF INPACKETTYPE='Y' THEN SendZPacket;
  2528.               IF INPACKETTYPE='Y' THEN SendBPacket
  2529.             END;
  2530.  
  2531.          I:                                       (* LOGIN  command *)
  2532.             SendYPacket ('Already logged on');
  2533.  
  2534.          J:                                         (* Journal *)
  2535.             SendYPacket ('No Journal available, use DEBUG option');
  2536.  
  2537.          K:                                        (* Copy file   *)
  2538.             SendYPacket ('No Copy function available, yet');
  2539.  
  2540.          L: BEGIN                                 (* LOGOUT command *)
  2541.               RUNNING := FALSE ;
  2542.               EndKermit := TRUE;
  2543.               SendACK (TRUE)
  2544.             END;
  2545.  
  2546.          M:                                     (* MESSAGE  command *)
  2547.             SendYPacket ('No Message function available, yet');
  2548.  
  2549.          P:                                       (* Print  command *)
  2550.             SendYPacket ('No Print function available, yet');
  2551.  
  2552.          Q:                                 (* QUERY status command *)
  2553.             SendYPacket ('No Query state available');
  2554.  
  2555.          R:                                        (* Rename file *)
  2556.             SendYPacket ('No Rename function available, yet');
  2557.  
  2558.          S:                                       (* Submit command *)
  2559.             SendYPacket ('Submit command not implemented');
  2560.  
  2561.          T: BEGIN                              (* TYPE File command *)
  2562.               IF LENGTH (INPUTSTRING) > 7 THEN
  2563.                  TSOFname := SUBSTR (INPUTSTRING, 7,
  2564.                    ORD (EBCDICTOASCII (.ORD(INPUTSTRING(.6.)).))-32)
  2565.               ELSE BEGIN
  2566.                  SendError ('No file specified');
  2567.                  RETURN
  2568.               END;
  2569.               IF INDEX (TSOFname,'*') > 0 THEN
  2570.                 SendError ('No * allowed for typing files')
  2571.               ELSE BEGIN
  2572.                 OUTSEQ := 64;
  2573.                 SendXPacket ('Typing file : ' || TSOFname);
  2574.                 SendFile    (TSOFname, TRUE)
  2575.               END
  2576.             END;
  2577.  
  2578.          U: BEGIN                             (* Disk Usage command *)
  2579.               TSOService ('TSODS SPACE TOTAL', RC);
  2580.               IF RC <> 0 THEN SendError ('Error on Disk Space')
  2581.               ELSE BEGIN
  2582.                 OUTSEQ := 64;
  2583.                 SendXPacket ('Disk usage of ' || UserID);
  2584.                 RESET (TSODS);
  2585.                 FOR Ix := 1 TO 2 DO BEGIN
  2586.                   READLN (TSODS, XLine);
  2587.                   IF LENGTH (XLine) > 35 THEN
  2588.                      XLine := SUBSTR (XLine, 1, 35);
  2589.                   SendDPacket (XLine || CRLF, Ok);
  2590.                   IF NOT Ok THEN LEAVE
  2591.                 END;
  2592.                 CLOSE (TSODS);
  2593.                 IF INPACKETTYPE='Y' THEN SendZPacket;
  2594.                 IF INPACKETTYPE='Y' THEN SendBPacket
  2595.               END
  2596.             END;
  2597.  
  2598.          W:                                         (* WHO command *)
  2599.             SendYPacket ('Try WHO in interactive mode');
  2600.  
  2601.          OTHERWISE SendError ('Unknown subcommand')     (* ERROR *)
  2602.       END
  2603.    END
  2604. END ; (* REMOTECOMMAND procedure *)
  2605.  
  2606. %TITLE KERMIT - Main Program
  2607. (******************************************************************)
  2608. (********         OUTER BLOCK OF KERMIT                    ********)
  2609. (******************************************************************)
  2610.  
  2611. BEGIN
  2612.   TERMIN   (INPUT);   TERMOUT (OUTPUT);
  2613.   TermSize (ScreenSize);
  2614.   Remote   := FALSE; EndKermit := FALSE;
  2615.   TEXTMODE := TRUE;  Init_File := FALSE;
  2616.   RUNNING  := TRUE;  CmdMode   := FALSE;
  2617.   Handle_Attribute := FALSE;
  2618.   Long_Packet      := FALSE;
  2619.   IF INDEX (PARMS, '@INIT') = 0 THEN UserID    := PARMS
  2620.   ELSE BEGIN
  2621.      CmdMode   := TRUE;
  2622.      Init_File := TRUE;
  2623.      Remote    := TRUE;
  2624.      UserID    := SUBSTR (PARMS, 1, (INDEX(PARMS,'@INIT')-1));
  2625.      TSOCommand := 'ALLOC F(CMDFILE) DA(' || CMDNAME || ') SHR REUSE';
  2626.      TSOService (TSOCommand, RC);
  2627.      RESET (CmdFile);
  2628.   END;
  2629.   TSOService ('DELETE TSODS', RC);
  2630.   TSOCommand := 'ALLOC F(TSODS) DA(TSODS) NEW TR SP(1,1) ' || DCB_Var;
  2631.   TSOService (TSOCommand, RC);
  2632.   WRITELN('Welcome to KERMIT under MVS/XA-TSO V2.3');
  2633.   WRITELN(' ');
  2634.   IF ScreenSize > 0 THEN BEGIN
  2635.      WRITELN (' You are running Kermit-TSO from a full-screen device.');
  2636.      WRITELN (' There is no filetransfer supported in this mode.');
  2637.      WRITELN (' ')
  2638.   END;
  2639.   WHILE RUNNING DO BEGIN (* Command Loop *)
  2640.     MAINLOOP: (* NORMAL IO *)
  2641.     IF CmdMode THEN BEGIN
  2642.        IF NOT EOF (CmdFile) THEN READLN (CmdFile, INPUTSTRING)
  2643.        ELSE BEGIN
  2644.           INPUTSTRING := ' ';
  2645.           CmdMode     := FALSE;
  2646.           Remote      := TRUE;
  2647.           CLOSE (CmdFile)
  2648.        END
  2649.     END ELSE Prompt ('KERMIT-TSO>', INPUTSTRING) ;
  2650.     IF (BIT8_QUOTE = '00'XC) AND (NOT TEXTMODE) THEN BEGIN
  2651.       WRITELN ('**** WARNING - TEXT MODE is turned off, other');
  2652.       WRITELN ('               KERMIT can not handle the 8th bit.')
  2653.     END ; (* Warning *)
  2654.     GetFile := FALSE;
  2655.     INPUTSTRING := LTRIM(INPUTSTRING);
  2656.     IF INPUTSTRING = ' '  THEN GOTO MAINLOOP;
  2657.     IF SUBSTR(INPUTSTRING,1,1) = STR (SOH) THEN RemoteCommand
  2658.        ELSE BEGIN (* Local Command *)
  2659.          INPUTSTRING := LTRIM (INPUTSTRING);
  2660.          COMMAND := GETTOKEN (INPUTSTRING);
  2661.          UPCASE (COMMAND);
  2662.          REQUEST := ' ' || TRIM (STR (COMMAND));
  2663.          CINDEX := INDEX(COMMTABLE,REQUEST) DIV 8 ;
  2664.          CASE COMMANDS(CINDEX) OF
  2665.            $BAD    : WRITELN (COMMAND, 'is an invalid command.');
  2666.            $SEND   : SendFile (INPUTSTRING, FALSE);
  2667.            $RECEIVE: BEGIN
  2668.                        INPUTSTRING := LTRIM(INPUTSTRING);
  2669.                        IF INPUTSTRING = ' ' THEN BEGIN
  2670.                           Remote := TRUE;
  2671.                           WRITELN ('ready to RECEIVE file  - ',
  2672.                             'SEND file(s) from Micro. ');
  2673.                           Waiting (Delay)
  2674.                        END;
  2675.                        RecvFile;
  2676.                        Remote := FALSE
  2677.                      END;
  2678.            $SERVER : BEGIN
  2679.                        WRITELN('Entering SERVER mode - ',
  2680.                                'Issue FINISH or LOGOUT command from',
  2681.                                ' micro to stop SERVER');
  2682.                        IF Debug THEN
  2683.                           WRITELN (DFILE, 'Entering SERVER mode ...');
  2684.                        Remote    := TRUE;
  2685.                        REPEAT
  2686.                         STATE := S_I; (* Server_Init state *)
  2687.                         IF RecvPacket THEN BEGIN
  2688.                           Line := '   ' || STR (INPACKETTYPE) ||
  2689.                            SUBSTR(STR(REPLYMSG.CHARS),1,INDATACOUNT);
  2690.                           IF Debug THEN WRITELN (DFILE,'>>',Line);
  2691.                           RemoteCommand
  2692.                         END;
  2693.                        UNTIL NOT RUNNING;
  2694.                        IF Debug THEN
  2695.                           WRITELN (DFILE, 'SERVER mode ended');
  2696.                        Remote := FALSE;
  2697.                        IF NOT EndKermit THEN RUNNING := TRUE
  2698.                      END;
  2699.            $SET    : SetIT;
  2700.            $SHOW,
  2701.            $STATUS : ShowIT;
  2702.            $HELP,
  2703.            $QUES   : HELP ;
  2704.            $DEL    : BEGIN
  2705.                        TSOService ('DELETE ' || INPUTSTRING, RC);
  2706.                        IF RC > 0 THEN WRITELN ('Data set ' ||
  2707.                                  INPUTSTRING || ' not deleted');
  2708.                      END;
  2709.            $DIR    : IF INPUTSTRING = ' '
  2710.                         THEN TSOService ('LISTCAT ', RC)
  2711.                         ELSE TSOService ('LISTCAT LEV(' ||
  2712.                                           INPUTSTRING  || ')', RC);
  2713.            $DISK   : BEGIN
  2714.                         WRITELN ('Total disk space in tracks:');
  2715.                         TSOService ('SPACE TOTAL ', RC)
  2716.                      END;
  2717.            $MEM    : IF INPUTSTRING <> ' ' THEN BEGIN
  2718.                         INPUTSTRING := TRIM (INPUTSTRING);
  2719.                         CheckDsn (INPUTSTRING, DsnDisp);
  2720.                         IF DsnDisp = SHARE THEN
  2721.                            WRITELN ('File ', INPUTSTRING,
  2722.                                     ' is sequential')
  2723.                         ELSE IF DsnDisp = NEW THEN
  2724.                            WRITELN ('File ', INPUTSTRING,
  2725.                                     ' does not exist')
  2726.                         ELSE BEGIN
  2727.                            RESET   (TSODS);
  2728.                            FOR I := 1 TO 7 DO READLN  (TSODS, Line);
  2729.                            IF INDEX (Line, 'NOT USEABLE') > 1 THEN
  2730.                            WRITELN ('No access to file: ', INPUTSTRING)
  2731.                            ELSE BEGIN
  2732.                               WRITELN ('Memberlist for: ', INPUTSTRING);
  2733.                               I := 1;
  2734.                               WHILE NOT EOF (TSODS) DO BEGIN
  2735.                                  WRITE  (Line:-12);
  2736.                                  READLN (TSODS, Line);
  2737.                                  I := I + 1;
  2738.                                  IF I > 5 THEN BEGIN
  2739.                                     WRITELN; I := 1 END;
  2740.                               END; WRITELN (Line:-12)
  2741.                            END;
  2742.                            CLOSE   (TSODS)
  2743.                         END
  2744.                      END
  2745.                      ELSE WRITELN ('No file specified');
  2746.            $TSO    : BEGIN
  2747.                        TSOService (INPUTSTRING, RC);
  2748.                        IF RC <> 0 THEN
  2749.                        WRITELN (' TSO command ended with error ', RC)
  2750.                      END;
  2751.            $TYPE   : BEGIN
  2752.                        TSOService ('LIST ' || INPUTSTRING, RC);
  2753.                        IF RC > 0 THEN WRITELN ('Data set ' ||
  2754.                                  INPUTSTRING || ' not found');
  2755.                      END;
  2756.            $WHO    : TSOService ('USERS ', RC);
  2757.            $FINISH : IF NOT CmdMode THEN WRITELN ('Nothing happens ...')
  2758.                      ELSE Micro_Finish;
  2759.            $QUIT,
  2760.            $END,
  2761.            $EXIT   : RUNNING := FALSE;
  2762.            $LOG    : IF (COMMAND = 'LOG') OR (COMMAND = 'LOGOUT')
  2763.                      THEN BEGIN
  2764.                        RUNNING   := FALSE ;
  2765.                        EndKermit := TRUE
  2766.                      END;
  2767.            $DO,
  2768.            $TAKE   : IF INPUTSTRING = '' THEN
  2769.                           WRITELN ('No commandfile specified')
  2770.                      ELSE IF CmdMode THEN (* Do nothing *)
  2771.                         ELSE BEGIN
  2772.                           IF COMMANDS(CINDEX) = $DO THEN
  2773.                              INPUTSTRING := PROFNAME || '(' ||
  2774.                                             TRIM(INPUTSTRING) || ')';
  2775.                           TSOCommand := 'ALLOC F(CMDFILE) DA(' ||
  2776.                                         INPUTSTRING || ') SHR REUSE';
  2777.                           TSOService (TSOCommand, RC);
  2778.                           IF RC <= 4 THEN BEGIN
  2779.                              CmdMode := TRUE;
  2780.                              Remote  := TRUE;
  2781.                              RESET (CmdFile)
  2782.                           END ELSE WRITELN ('Commandfile not found')
  2783.                        END;
  2784.            $VERSION: BEGIN
  2785.                        WRITELN (' This is the KERMIT filetransfer ',
  2786.                         'program for IBM System 370 under MVS/TSO.');
  2787.                        WRITELN (' The actual version number is 2.3',
  2788.                         ', featuring long packets ... Fritz B.')
  2789.                      END;
  2790.            OTHERWISE WRITELN (COMMAND, ' is an INVALID command');
  2791.          END  (* Execute the Command *)
  2792.       END; (* Local Command *)
  2793.       INPUTSTRING := ''
  2794.    END ; (* Command Loop *)
  2795.    IF Debug THEN CLOSE (DFILE);
  2796.    IF CmdMode THEN CLOSE (CmdFile);
  2797.    TSOService ('FREE F(TSODS) DELETE', RC);
  2798.    IF EndKermit THEN TSOService ('TSOEXEC LOGOFF',  RC);
  2799.    WRITELN('End of KERMIT  ')
  2800. END.
  2801.