*COPY IK0PRO 07000000 TITLE 'SERVER Routine - performs Server mode functions' 07001000 SERVER ENTER 07002000 LA 0,SRVKFIN @SC86295 07003000 L 1,=A(SRVKCMD) @SC87012 07004000 BAL 14,LOOPS Set up command loop @SC86295 07005000 KCALL INTINI,1,E=SRVXIT Initialize for server @SC87300 07006000 OI FL2,SRV Server is on 07007000 MVI ERRNUM,ERRNOE No errors yet @SC86156 07008000 BAL 8,SRVLUP Set state table @SC86135 07009000 * Server mode Rpack interpret input table @SC86135 07010000 DC AL1(AS),AL3(SRVREC) Micro wants to send a file @SC86135 07011000 DC AL1(AC),AL3(SRVHST) A host command @SC86171 07012000 DC AL1(AI),AL3(0) Micro sent parms @SC86135 07013000 DC AL1(AG),AL3(SRVGEN) A generic command @SC86135 07014000 DC AL1(AK),AL3(SRVKRM) A KERMIT command @SC86158 07015000 DC AL1(AR),AL3(SRVSND) Micro wants to get a file @SC86135 07016000 DC AL1(00),AL3(SRVILL) Error routine @SC86355 07017000 SRVLUP MVI SEQ,0 Reset packet number @SC86135 07018000 OI FL1,NAK0 Resend NAK during retry 07019000 MVC SRVTIM,TIMOUT Save time-out limit @SC86355 07020000 MVI TIMOUT,120 Set to 2 minutes @SC86355 07021000 MVC LIMTRY,F5 Error loop 5 times for command @SC86355 07022000 MVC OLDERR,ERRNUM Save for STATUS @SC86158 07023000 BAL 9,INPUT Read a packet and interpret @SC86295 07024000 MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07025000 KCALL SPARSET Set up for exchange @SC86152 07026000 KCALL SPAR Interpret I packet from other 07027000 KCALL RPAR Reply to the I packet 07028000 BAL 2,SENDACKL Send an ACK, length set 07029000 MVI ERRNUM,ERRNOE OK @SC86158 07030000 B SRVLUP Loop again no matter what 07031000 * 07032000 SRVREC MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07033000 XC SCANPTR,SCANPTR @SC86295 07034000 LA 0,FFRCF @SC86295 07035000 KCALL FSPEC,FILNAM Get filespec @SC86295 07036000 KCALL INTINI,3,E=SRVXIT @SC87300 07037000 KCALL RECEIV Get the file 07038000 B SRVLUP End of file protocol 07039000 * 07040000 SRVSND MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07041000 BAL 9,DECODEN Decode the file name @SC86295 07042000 ICM 0,B'1111',WBUFL decoded name length 07043000 BNP SRVIPS @SC86158 07044000 L 1,WBUF Decoded data 07045000 SRVSNT STM 0,1,SCANPTR @SC86295 07046000 LA 0,FFSND @SC86295 07047000 KCALL FSPEC,IFILE,E=SRVERP Get filespec @SC86295 07048000 XC SCANPTR,SCANPTR @SC86295 07049000 LA 0,FFSND+FFRCF @SC86295 07050000 KCALL FSPEC,JFSPEC,E=SRVERP Get filespec @SC86295 07051000 SRVSNC KCALL SEND 07052000 B SRVLUP Go around again 07053000 * 07054000 SRVGEN MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07055000 BAL 9,DECODEN Decode the command @SC86295 07056000 ICM 0,15,WBUFL Decoded command length @SC86158 07057000 BNP SRVIPS @SC86158 07058000 MVI ERRNUM,ERRNOE OK so far @SC86171 07059000 BCTR 0,0 Remove command from data length @SC86158 07060000 L 1,WBUF Decoded data @SC86158 07061000 IC 4,0(1) @SC86158 07062000 BAL 2,CLKP Dispatch on command @SC86158 07063000 DC AL1(AC),AL3(SRVCWD) cwd @SC86158 07064000 DC AL1(AD),AL3(SRVDIR) directory @SC86158 07065000 DC AL1(AE),AL3(SRVDEL) erase @SC86158 07066000 DC AL1(AF),AL3(SRVFIN) finish @SC86158 07067000 DC AL1(AH),AL3(SRVHLP) help @SC86158 07068000 DC AL1(AK),AL3(SRVCPY) copy @SC86158 07069000 DC AL1(AL),AL3(SRVFIN) bye @SC86158 07070000 DC AL1(AR),AL3(SRVREN) rename @SC86158 07071000 DC AL1(AT),AL3(SRVTYP) type @SC86158 07072000 DC AL1(AU),AL3(SRVQDS) space @SC86158 07073000 DC AL1(00),AL3(SRVERS) Unknown command @SC86158 07074000 * 07075000 SRVILL MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07076000 SRVERS MVI ERRNUM,ERRUSC Unknown Server command @SC86156 07077000 SRVERP KCALL SUPFNC,5 @SC86158 07078000 KCALL ERPACK Send an error packet @SC86158 07079000 L 0,IOERC I/O error count @SC86158 07080000 CL 0,F5 Lots of consecutive errors? @SC86158 07081000 BL SRVLUP Not yet, OK @SC86158 07082000 B SRVXIT Yes, give up now @SC86158 07083000 * 07084000 SRVIPS MVI ERRNUM,ERRIPS Invalid syntax @SC86158 07085000 B SRVERP @SC86158 07086000 * 07087000 SRVHST MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07088000 BAL 9,DECODEN Get command for host @SC86171 07089000 BAL 9,SRVGPRW To EBCDIC, start interception @SC86295 07090000 B LUPHST Do it @SC86295 07091000 * 07092000 SRVKRM MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07093000 BAL 9,DECODEN Get command for Kermit @SC86295 07094000 BAL 9,SRVGPRW To EBCDIC, start interception @SC86295 07095000 B LUPTOK Parse command @SC87012 07096000 * 07097000 SRVKF0 MVI ERRNUM,ERRNOE No errors @SC86295 07098000 SRVKFIN MVC OLDERR,ERRNUM Save error code @SC86295 07099000 KCALL SUPFNC,2 Clean up after interception @SC86295 07100000 SRVKFTX LM 4,5,TXTPTR @SC86158 07101000 SR 5,4 Any? @SC86158 07102000 LA 2,SRVLUP Return adr @SC86158 07103000 BNP SENDACK No, just ACK command @SC86158 07104000 LA 3,1023(5) Round up @SC86158 07105000 SRA 3,10 Convert to kbytes @SC86158 07106000 ST 3,KBYTES @SC86158 07107000 OI FL4,SFM+TXT @SC86158 07108000 KCALL SEND Send all @SC86158 07109000 CLI ERRNUM,ERRNOE Problem with SEND? @SC86295 07110000 BNE SRVLUP Yes, remember that @SC86295 07111000 MVC ERRNUM,OLDERR No, use code from commands @SC86295 07112000 B SRVLUP Get another command @SC86158 07113000 * 07114000 SRVTYP OI FL4,TXT Send disk file to remote display @SC86158 07115000 BAL 9,SRVGSTR Get file-spec @SC86295 07116000 B SRVERP None, error @SC86158 07117000 B SRVSNT @SC86158 07118000 * 07119000 * Send remote help message to other system @SC86158 07120000 SRVHLP LA 4,RMHTXT Where to copy HELP TEXT from @SC86158 07121000 LA 5,RMHTXTZ End of text @SC86158 07122000 STM 4,5,TXTPTR @SC86158 07123000 B SRVKFTX @SC86158 07124000 * 07125000 SRVDIR BAL 3,SRVUTL @SC86295 07126000 DC AL1(13,4+1) Wild matches @SC86295 07127000 * 07128000 SRVDEL BAL 3,SRVUTL @SC86295 07129000 DC AL1(14,0+1) No wild matches @SC86295 07130000 * 07131000 SRVREN BAL 3,SRVUTL @SC86295 07132000 DC AL1(15,4+2) Wild matches @SC86295 07133000 * 07134000 SRVCPY BAL 3,SRVUTL @SC86295 07135000 DC AL1(16,0+2) No wild matches @SC86295 07136000 * 07137000 SRVCWD BAL 9,SRVGSTR Get operand @SC86295 07138000 B SRVERP @SC86158 07139000 BAL 9,SRVGPRM Convert to plist @SC86295 07140000 MVI ERRNUM,ERRFNF In case of error @SC86158 07141000 KCALL CWDSET,E=SRVERP @SC86158 07142000 B SRVKF0 No errors @SC86295 07143000 * 07144000 SRVQDS BAL 9,SRVGSTR Extract letter @SC86295 07145000 LA 0,0 None, use default @SC86158 07146000 BAL 9,SRVGPRM @SC86295 07147000 B LUPSPA @SC86295 07148000 * Generate command PLIST: R3-> parms @SC86158 07149000 SRVUTL LA 2,FILNAM 1st or only filespec @SC86295 07150000 LH 4,0(3) @SC86295 07151000 N 4,F3 Get number of names @SC86295 07152000 SRVUTLP XC SCANPTR,SCANPTR @SC86295 07153000 BAL 9,SRVGSTR Extract file-spec @SC86295 07154000 B SRVUT1 None, check if wildcard allowed @SC86158 07155000 STM 0,1,SCANPTR @SC86295 07156000 SRVUT1 LA 0,FFUTL @SC86295 07157000 TM 1(3),4 Test flag @SC86295 07158000 BZ *+8 @SC86295 07159000 LA 0,FFUTL+FFWLD Wild match if part omitted @SC86295 07160000 KCALL FSPEC,(2),E=SRVERP Get filespec into command @SC86295 07161000 LR 0,6 Length remaining @SC86158 07162000 LR 1,7 Next field @SC86158 07163000 LA 2,IFILE 2nd ptr @SC86158 07164000 BCT 4,SRVUTLP Loop over file-specs @SC86158 07165000 KCALL SUPFNC,1 Start interception @SC86158 07166000 CLC 0(1,3),SRVDIR+4 @SC86158 07167000 BE SRVUT6 Don't issue STATE if DIR cmd @SC86158 07168000 MVI ERRNUM,ERRFNF Assume not found @SC86158 07169000 OPENF T,FILNAM,E=SRVERP @SC86295 07170000 SRVUT6 LA 1,FILNAM 1st or only filespec @SC86295 07171000 LA 2,IFILE Possible 2nd @SC86295 07172000 XR 0,0 @SC86295 07173000 IC 0,0(3) @SC86295 07174000 KCALL DISKIO @SC86295 07175000 CLI ERRNUM,ERRNOE Problem? @SC86295 07176000 BNE SRVERP Yes, too bad @SC86295 07177000 B SRVKFIN @SC86295 07178000 * Get substring from Generic command @SC86158 07179000 * R0= no. of chars left in packet excluding substr count byte @SC86158 07180000 * R1-> one before count byte @SC86158 07181000 SRVGSTR MVI ERRNUM,ERRMOP Assume missing operand @SC86158 07182000 BCTR 0,0 Remove operand length field @SC86158 07183000 LA 7,1(1) ditto @SC86158 07184000 LTR 6,0 If no operands @SC86158 07185000 BNPR 9 then return error @SC86295 07186000 UNCHR 0,1(1) Operand size @SC86158 07187000 BZR 9 Error if zero length field @SC86295 07188000 BM SRVIPS Really bad @SC86158 07189000 LA 1,2(1) Location of operand @SC86158 07190000 AR 7,0 Get ptr to next field @SC86158 07191000 SR 6,0 Length remaining @SC86158 07192000 BM SRVIPS Inconsistant @SC86158 07193000 B 4(9) @SC86295 07194000 * Set up copy 07195000 SRVGPRW ICM 0,15,WBUFL @SC86171 07196000 BNP SRVIPS No text @SC86171 07197000 L 1,WBUF Ptr to text @SC86171 07198000 * Copy parameter at (R1), length in R0 and set up interception @SC86158 07199000 SRVGPRM LTR 15,0 Any chars? @SC86171 07200000 BNP SRVGPS No @SC86171 07201000 BCTR 15,0 Yes, translate @SC86171 07202000 EX 15,TRATOE @SC86171 07203000 EX 15,TRUPCAS @SC86171 07204000 SRVGPS STM 0,1,SCANPTR Save string ptrs @SC86158 07205000 KCALL SUPFNC,1 Start intercepting @SC86158 07206000 BR 9 @SC86295 07207000 * 07208000 SRVFIN MVI WRRD,0 Just write (no read) when ending 07209000 MVC S1HND,SVHND Always use requested handshake @SC87343 07210000 BAL 2,SENDACK Send an ACK 07211000 L 1,WBUF Ptr to decoded data @SC86190 07212000 CLI 0(1),AL @SC86190 07213000 BNE SRVNOLOG Skip logging out @SC86295 07214000 CLOSF LOGPTR Close debug-log @SC86135 07215000 KCALL SUPFNC,8 Log out @SC86295 07216000 SRVNOLOG DS 0H (or fall through just in case) @SC86295 07217000 MVC ERRNUM,OLDERR Copy back error number @SC86171 07218000 SRVXIT NI FL2,255-SRV Turn off SERVER mode @SC86158 07219000 KCALL INTINI,0 Clear interrupt trapping 07220000 RET 07221000 * 07222000 RMHTXT DC C'Kermit-&KSYS. Server handles the following:' @SC86268 07223000 DC X'1515' @SC86158 07224000 DC C'Function Standard command',X'15' @SC86158 07225000 DC C'-------- ----------------',X'1515' @SC86158 07226000 DC C'Send a file SEND file',X'15' @SC86158 07227000 DC C'Retrieve a file GET file',X'15' @SC86158 07228000 DC C'Log off system BYE or LOGOUT',X'15' @SC86158 07229000 DC C'Exit from server FINISH',X'15' @SC86158 07230000 DC C'Issue Kermit cmd REMOTE KERMIT cmd',X'15' @SC86158 07231000 DC C'Issue system cmd REMOTE HOST [CP] cmd',X'15' @SC86268 07232000 DC C'List directory REMOTE DIRECTORY file',X'15' @SC86158 07233000 DC C'Type a file REMOTE TYPE file',X'15' @SC86158 07234000 DC C'Copy a file REMOTE COPY f1 f2',X'15' @SC86158 07235000 DC C'Rename a file REMOTE RENAME f1 f2',X'15' @SC86158 07236000 DC C'Erase a file REMOTE DELETE file',X'15' @SC86158 07237000 DC C'Change disk area REMOTE CWD area',X'15' @SC86158 07238000 DC C'Show disk space REMOTE SPACE area',X'15' @SC86158 07239000 RMHTXTZ EQU * @SC86158 07240000 LOCALS , @SC86295 07241000 RETADR DS A Return adr if no more TAKE stuff @SC86295 07242000 CMDPTR DS A Adr of command table @SC86295 07243000 TAKLEV DS F Take file level @SC86121 07244000 TAKTAB DS (TAKMAX)F Tickets for I/O @SC86295 07245000 SRVTIM DS X Saved timeout limit @SC86355 07246000 SERVER EXIT 07247000 TITLE 'SEND Routine - sends a file' 07248000 * Send file(s) and set ERRNUM appropriately 07249000 * Entry: filespec pattern in IFILE 07250000 SEND ENTER 07251000 XC TOUTOT(LSTATS),TOUTOT Clear statistics @SC86295 07252000 KCALL SUPFNC,10 @SC86295 07253000 ST 15,SECTOT Save start time @SC86295 07254000 TM FL4,SFM @SC86295 07255000 BO *+10 From memory: keep old file list @SC86295 07256000 XC NSENT,NSENT Number of files sent 07257000 MVI SNFLG,FIRST Haven't started yet @SC86295 07258000 XC FDATE,FDATE Clear file date @SC86295 07259000 LA 0,30 Tune up after 30 packets @SC86345 07260000 STH 0,SNPKCT @SC86345 07261000 MVI REASON,0 Not rejected yet @SC86316 07262000 MVI SEQ,0 Reset packet number @SC86135 07263000 NXTFSET IFILE,E=SNDNON Init for NXTFST call @SC87012 07264000 BAL 8,SNDNXT Set state table @SC86135 07265000 * Send mode Rpack interpret input table @SC86135 07266000 SNDNST DC AL1(AY),AL3(0) Micro ACK'd @SC86295 07267000 DC AL1(00),AL3(SNDABR) Error routine @SC86135 07268000 SNDNXT CLI CXZ,AZ 07269000 BE SNDBRK Stop file group send 07270000 MVI FRECF,C'F' Just in case @SC86151 07271000 TM FL4,SFM @SC86158 07272000 BO SNDNOW Just sending from memory @SC86158 07273000 NXTF E=SNDNON Get next/first file @SC86295 07274000 MVI CXZ,0 In case aborted last file 07275000 MVI REASON,0 Not rejected yet @SC86316 07276000 L 5,TSENT TABLE W/FILES SENT SO FAR 07277000 ICM 4,B'1111',NSENT Number of files sent so far 07278000 AIF ('&KSYS' NE 'CMS').SOPN @SC86295 07279000 BZ SNDOPN Go if none sent yet @SC86295 07280000 SNDTBL CLC 0(16,5),FILNAM @SC86295 07281000 BE SNDNXT Go if sent already 07282000 LA 5,LFID(5) Next file @SC86295 07283000 BCT 4,SNDTBL 07284000 .SOPN ANOP 07285000 SNDOPN OPENF I,FILNAM,FILFDB,FILPTR,E=SNDFNF @SC87012 07286000 USING FDBD,1 @SC86295 07287000 MVC FRECF,FDBRCF Save format and file size @SC86295 07288000 MVC KBYTES,FDBSIZE @SC86295 07289000 MVC FDATE,FDBDATE Save file date @SC86295 07290000 DROP 1 @SC86295 07291000 CLI TRMLIN,C' ' Alt. line? @SC87300 07292000 BE SNDNOW No, be quiet @SC87300 07293000 MVC CMD(8),=CL8'Sending ' Yes, display message @SC87300 07294000 LA 7,CMD+8 @SC87300 07295000 LA 1,FILNAM @SC87300 07296000 BAL 2,STAFSP Format name and show it @SC87300 07297000 SNDNOW TM SNFLG,FIRST @SC86295 07298000 BZ SNDFIL Go if not first file 07299000 NI SNFLG,255-FIRST No first file flag @SC86295 07300000 MVC LIMTRY,MAXTNT Limit for INIT retries @SC86345 07301000 TM FL4,NPS Non-protocol? @HF86232 07302000 BZ SNDPRO No, normal send message @HF86232 07303000 KCALL INTINI,5,E=SNDRET Initialize for non-protocol @SC87300 07304000 B SNDATZ Skip protocol stuff @HF86232 07305000 SNDPRO KCALL INTINI,2,E=SNDRET Initialize for send @SC87300 07306000 TM FL2,SRV 07307000 BO SNDINI Go if Server mode 07308000 L 0,LCLDLY Time to wait @SC86164 07309000 KCALL SUPFNC,9 @SC86295 07310000 SNDINI DS 0H @SC86152 07311000 KCALL RPARSET Set up for exchange @SC86152 07312000 KCALL RPAR Our S packet to send @SC86152 07313000 MVI STYPE,AS PACKET TYPE = SEND INITIATE 07314000 BAL 9,INPUTSPK Send RPAR and Interpret response @SC86295 07315000 KCALL SPAR Interpret reply to our S packet 07316000 MVC BCTU,BCTR Switch chksum to negotiated one 07317000 MVC LIMTRY,MAXTRY Reset limit @SC86164 07318000 BAL 14,INCRSEQ 07319000 SNDFIL MVI STYPE,AX Text transmission? @SC86158 07320000 TM FL4,TXT @SC86158 07321000 BO *+8 Yes @SC86158 07322000 MVI STYPE,AF Packet type = file header @SC86158 07323000 XC DATL,DATL Null file spec. @SC86158 07324000 TM FL4,SFM @SC86158 07325000 BNZ SNDCNTH From memory, no file name @SC86158 07326000 BAL 9,PAKFIL Compress to buffer with appends @HF86223 07327000 CLI TRMLIN,C' ' Alt. line? @SC87300 07328000 BE SNDFIL2 No, be quiet @SC87300 07329000 MVC CMD(5),=CL5' as ' Yes, display message @SC87300 07330000 L 1,RBUF Ptr to name in ASCII @SC87300 07331000 MVC CMD+5(250),0(1) @SC87300 07332000 TR CMD+5(250),ATOE Back to EBCDIC @SC87300 07333000 LA 0,CMD+5(7) End of msg + name @SC87300 07334000 BAL 2,STAPMSG Show sending name @SC87300 07335000 SNDFIL2 DS 0H @SC87300 07336000 L 3,NSENT Number of files sent so far 07337000 LR 4,3 Ditto 07338000 C 3,=A(MAXNSENT) Did we send more than countable? @SC86135 07339000 BNL SNDCNT Yes, cannot keep track of 'em 07340000 MH 3,=Y(LFID) Times length of items @SC86295 07341000 A 3,TSENT Loc in sent-table 07342000 MVC 0(LFID,3),FILNAM Save fn ft sent @SC86295 07343000 LA 4,1(4) Incr number of sent files 07344000 ST 4,NSENT Keep it 07345000 SNDCNT BAL 9,ENCODEN Encode fn @SC86295 07346000 SNDCNTH BAL 9,INPUTSPK Send name and interpret response @SC86295 07347000 BAL 14,INCRSEQ 07348000 MVC TMP,SCAPA Copy my flags @SC86149 07349000 NI TMP,8 Attributes @SC86149 07350000 NC TMP,RCAPA Check if both on @SC86149 07351000 BZ SNDATZ No, skip it @SC86149 07352000 L 5,ASDATA @SC86295 07353000 ICM 4,15,KBYTES File length known? @SC86295 07354000 BZ SNDAT0 No, skip it @SC86316 07355000 MVI 0(5),C'!' Yes @SC86295 07356000 LA 15,2(5) @SC86295 07357000 BAL 2,EDDEC Format it @SC86295 07358000 SR 15,5 @SC86295 07359000 IC 4,ATOE+ABL-2(15) Indicate number of digits @SC86295 07360000 STC 4,1(5) @SC86295 07361000 AR 5,15 End of string @SC86295 07362000 SNDAT0 MVC 0(L'SYSATR,5),SYSATR @SC86316 07363000 LA 5,L'SYSATR(5) System code @SC86295 07364000 MVC 0(3,5),=C'"!B' Say it's binary @SC86316 07365000 TM FL1,BINF Binary file? @SC86149 07366000 BO SNDAT1 Yes @SC86316 07367000 MVC 2(4,5),=C'A*!A' No, also say it's ASCII @SC86316 07368000 LA 5,3(5) Advance over extra item @SC86316 07369000 SNDAT1 LA 5,3(5) @SC86316 07370000 IC 4,TYPFIL Specific file type @SC86295 07371000 BAL 2,CLKP Dispatch via table @SC86295 07372000 DC C'T',AL3(SNDATT) Text @SC86295 07373000 DC C'D',AL3(SNDATD) D-binary @SC86295 07374000 DC C'V',AL3(SNDATV) V-binary @SC86295 07375000 DC X'0',AL3(SNDAT3) Must be Binary @SC86295 07376000 SNDATT BAL 2,SNDAT2 @SC86295 07377000 DC AL1(3),C'AMJ' Format is delimited @SC86295 07378000 SNDATD BAL 2,SNDAT2 @SC86295 07379000 DC AL1(2),C'D%' Format is undelimited @SC86316 07380000 SNDATV BAL 2,SNDAT2 @SC86295 07381000 DC AL1(2),C'V"' Format is 2-byte binary prefix @SC86295 07382000 SNDAT2 MVI 0(5),C'/' Format @SC86295 07383000 MVC 1(9,5),0(2) Copy string @SC86295 07384000 TR 1(1,5),ATOE+ABL Convert to char @SC86295 07385000 SR 4,4 @SC86295 07386000 IC 4,0(2) Get length @SC86295 07387000 LA 5,2(4,5) Update string ptr @SC86295 07388000 SNDAT3 CLI FDATE,0 File date defined? @SC86295 07389000 BE SNDAT9 No, skip it @SC86295 07390000 MVC 0(2,5),=C'#(' Yes, use yyyymmdd @SC86295 07391000 UNPK 2(9,5),FDATE(5) Insert zones @SC86295 07392000 LA 5,10(5) Update ptr @SC86295 07393000 SNDAT9 L 15,ASDATA @SC86295 07394000 SR 5,15 @SC86295 07395000 TR 0(256,15),ETOA Convert to ASCII @SC86295 07396000 ST 5,DATL Set length @SC86295 07397000 LA 8,SNDNST Restore state ptr @SC86295 07398000 MVI STYPE,AA @SC86149 07399000 BAL 9,INPUTSPK Send it @SC86295 07400000 BAL 14,INCRSEQ @SC86149 07401000 CLC DATL,F0 Any objections? @SC86149 07402000 BE SNDATZ Ok @SC86149 07403000 L 1,ARDATA @SC86316 07404000 CLI 0(1),AN Refused? @SC86149 07405000 BE SNDCAN Sigh @SC86149 07406000 SNDATZ DS 0H @SC86149 07407000 NI FL1,255-EOF Not end of file yet 07408000 BAL 14,RDWSET Check for special format @SC86151 07409000 XC RBUFL,RBUFL No data in input buffer 07410000 TM FL4,NPS Non-protocol? @SC86165 07411000 BO SNDNPS Yes, do it @SC86165 07412000 SNDENC KCALL ENCODE,E=SNDENX Encode the data and more 07413000 SNDDAT MVI STYPE,AD PACKET TYPE = DATA 07414000 BAL 9,INPUTSPK Send data and interpret reply @SC86295 07415000 BAL 14,INCRSEQ 07416000 LH 15,SNPKCT @SC86345 07417000 BCT 15,SNDTUNZ No tuning yet @SC86345 07418000 CLC MAXSIZ+4,AKMAX Long packets selected? @SC86345 07419000 BNP SNDTUNY No @SC86345 07420000 BAL 9,OPTPKT Calculate optimum size @SC86345 07421000 LTR 15,15 Valid? @SC86345 07422000 BNP SNDTUNY No @SC86345 07423000 C 15,MAXSIZ+4 Other Kermit's limit @SC86345 07424000 BNH *+8 @SC86345 07425000 L 15,MAXSIZ+4 @SC86345 07426000 C 15,AKMAX @SC86345 07427000 BNL *+8 @SC86345 07428000 L 15,AKMAX Don't get too small @SC86345 07429000 ST 15,MAXSIZ Set send limit @SC86345 07430000 SNDTUNY LA 15,20 Repeat after 20 more @SC86345 07431000 SNDTUNZ STH 15,SNPKCT @SC86345 07432000 CLC DATL,F1 07433000 BNE SNDENC Go if no Data in ack 07434000 L 1,ARDATA @SC86190 07435000 CLI 0(1),AX @SC86190 07436000 BE SNDCAN Go if Abort sending file 07437000 CLI 0(1),AZ @SC86190 07438000 BNE SNDENC Go if not Abort sending grp 07439000 SNDCAN MVC CXZ,0(1) Pick up data @SC86190 07440000 MVI ERRNUM,ERRTRC Send cancelled @SC86156 07441000 CLC DATL,F2 Any reason given (if A-pkt) @SC86316 07442000 BL SNDEOF None @SC86316 07443000 UNCHR 2,1(1),REASON Yes, save it @SC86316 07444000 SNDEOF BAL 9,SNDCLS Close file @SC86295 07445000 MVI STYPE,AZ PACKET TYPE = EOF 07446000 XC DATL,DATL 07447000 L 9,ASDATA @SC86295 07448000 MVI 0(9),AD In case of discard @SC86295 07449000 CLI CXZ,0 Aborting this file? @SC86125 07450000 BE *+8 No, ok @SC86125 07451000 MVI DATL+3,1 Yes, send 'D' @SC86125 07452000 BAL 9,INPUTSPK Send EOF and Interpret response @SC86295 07453000 BAL 14,INCRSEQ 07454000 TM FL4,SFM @SC86158 07455000 BO SNDBRK Memory has only one 'file' @SC86158 07456000 B SNDNXT else GET-NEXT-FILE 07457000 * 07458000 SNDNPS MVI WRRD,0 Set for send only @SC86165 07459000 SNDNPSL KCALL NPREAD,E=(SNDABR,P) @SC86165 07460000 CLC SNDPKL,F0 OK, any data? @SC86165 07461000 BE SNDNPZ No, must be done @SC86165 07462000 KCALL SIO,E=SNDABR Send what we got @SC86165 07463000 TM FL1,EOF Any more? @SC86165 07464000 BZ SNDNPSL Yes, get it @SC86165 07465000 SNDNPZ BAL 9,SNDCLS Reached end @SC86295 07466000 B SNDBR2 All done @SC86165 07467000 * 07468000 SNDENX LTR 15,15 Positive or negative error? 07469000 BP SNDABR Pos: error from ENCODE, not EOF 07470000 CLC DATL,F0 07471000 BE SNDEOF No more data to send 07472000 B SNDDAT Send last chunk 07473000 * 07474000 SNDNON TM SNFLG,FIRST @SC86295 07475000 BZ SNDBRK Go if not first file 07476000 SNDFNF MVI ERRNUM,ERRFNF Not found @SC87012 07477000 TM FL2,SRV 07478000 BO SNDABR Go if server 07479000 B SNDRET @SC86295 07480000 * 07481000 SNDBRK MVI STYPE,AB PACKET TYPE = BREAK 07482000 XC DATL,DATL 07483000 BAL 9,INPUTSPK Send BRK and Interpret response @SC86295 07484000 SNDBR2 DS 0H @SC86165 07485000 MVI ERRNUM,ERRNOE Reset error (OK) @SC86156 07486000 CLI CXZ,0 07487000 BE SNDRET Go if x-fer not stopped 07488000 MVI ERRNUM,ERRTRC Set this anyway @SC86156 07489000 SNDABR BAL 9,SNDCLS Close disk file @SC86295 07490000 TM FL4,NPS Non-protocol? @SC86165 07491000 BO SNDRET Yes, skip error packet @SC86165 07492000 KCALL ERPACK Send error packet 07493000 SNDRET NI FL4,255-NPS-SFM-TXT @SC86165 07494000 B RETSNRC Close statistics and return @SC86295 07495000 * 07496000 SNDCLS TM FL4,SFM Text xmit? @SC86158 07497000 BOR 9 Yes, no disk file @SC86295 07498000 CLOSF FILPTR Close it @SC86158 07499000 BR 9 @SC86295 07500000 LOCALS , @SC86295 07501000 SNPKCT DS H Cyclic counter for tuning @SC86345 07502000 CXZ DS X Flag for aborted transmission @SC86295 07503000 SNFLG DS X More local flags @SC86295 07504000 FIRST EQU X'80' File is the first one @SC86295 07505000 SEND EXIT 07506000 TITLE 'RECEIV Routine - receives a file' 07507000 * Receive file(s) and set ERRNUM appropriately 07508000 * Entry: filespec in FILNAM if ROVR is set 07509000 RECEIV ENTER 07510000 XC TOUTOT(LSTATS),TOUTOT Clear statistics @SC86295 07511000 KCALL SUPFNC,10 @SC86295 07512000 ST 15,SECTOT Save start time @SC86295 07513000 MVI SEQ,0 Reset packet number @SC86135 07514000 KCALL SPARSET Set up for exchange @SC86152 07515000 LA 8,RECINST Next state table for RECEIVE I 07516000 MVC LIMTRY,MAXTNT Limit for INIT retries @SC86345 07517000 TM FL2,SRV 07518000 BO RECSRV Go if in server 07519000 KCALL RPACK Get init info 07520000 RECSRV SR 3,3 Clear retry counter for INPUTLUP 07521000 BAL 9,INPUTINR Interpret response to RPAC @SC86295 07522000 KCALL SPAR Interpret his S packet 07523000 KCALL RPAR Reply to the S packet 07524000 BAL 2,SENDACKL Send an ACK, length set 07525000 MVC BCTU,BCTR Restore desired chksum 07526000 MVC LIMTRY,MAXTRY Set retry limit @SC86164 07527000 BAL 14,INCRSEQ 07528000 RECFIL LA 8,RECFNST Next state table for RECEIVE F 07529000 BAL 9,INPUT Read a packet and interpret @SC86295 07530000 NI RFLG,255-RTRC-RRJC Clear each time @SC86316 07531000 MVI REASON,0 07532000 NI FL1,255-EOF Turn of EOF = no ctl-z seen 07533000 TM FL1,ROVR 07534000 BO RECOVR Overwrite the name sent? 07535000 BAL 9,DECODEN Decode the input @SC86295 07536000 L 1,WBUF Start of data 07537000 L 0,WBUFL Data length decoded 07538000 TR 0(256,1),ATOE First to EBCDIC 07539000 STM 0,1,SCANPTR Set up scan @SC86295 07540000 MVC CMD+5(250),0(1) Extra copy for display @SC87300 07541000 LA 0,FFHDR @SC86295 07542000 KCALL FSPEC,FILNAM @SC86295 07543000 CLI TRMLIN,C' ' Alt. line? @SC87300 07544000 BE RECOVR No, be quiet @SC87300 07545000 MVC CMD(5),=CL5'File ' Yes, display message @SC87300 07546000 LA 0,CMD+5 @SC87300 07547000 A 0,WBUFL @SC87300 07548000 BAL 2,STAPMSG Show name @SC87300 07549000 RECOVR LA 3,FILNAM Point to fn 07550000 TM FL3,APPN Appending to old files? @SC86203 07551000 BO RECOPN Yes, just do it @SC86295 07552000 TM FL1,REN 07553000 BZ RECOPN No, just do it @SC86295 07554000 LA 0,FFNEW @SC86295 07555000 KCALL FSPEC,FILNAM,E=RECRER Check collisions @SC86295 07556000 CLI TRMLIN,C' ' Alt. line? @SC87300 07557000 BE RECOPN No, be quiet @SC87300 07558000 MVC CMD(9),=CL9' Rcv as ' Yes, display message @SC87300 07559000 LA 7,CMD+9 @SC87300 07560000 LA 1,FILNAM @SC87300 07561000 BAL 2,STAFSP Format name and show it @SC87300 07562000 RECOPN XC FILFLGS,FL3 Set flag for DISP @SC86295 07563000 NI FILFLGS,255-APPN @SC86295 07564000 XC FILFLGS,FL3 @SC86295 07565000 OPENF O,FILNAM,FILFDB,FILPTR,E=RECRER @SC86295 07566000 USING FDBD,1 @SC86295 07567000 SR 0,0 @SC86295 07568000 ICM 0,3,FDBLRC @SC86295 07569000 ST 0,FSIZE Copy LRECL @SC86295 07570000 MVC FRECF,FDBRCF Save info @SC86295 07571000 DROP 1 @SC86295 07572000 BAL 14,RDWSET Check for special format @SC86295 07573000 BAL 2,SENDACK 07574000 XC WBUFL,WBUFL Data length in WBUF 07575000 MVI PREV,0 Char previously decoded 07576000 LA 8,RECANST State table: REC D or A @SC86149 07577000 RECDAT BAL 14,INCRSEQ @SC86316 07578000 BAL 9,INPUT Read a packet and interpret @SC86295 07579000 LA 8,RECDNST Next state table: REC D only @SC86149 07580000 KCALL DECODE,E=RECABR Decode and write to file @SC86316 07581000 RECDAK BAL 2,SENDACK Send an ack @SC86149 07582000 B RECDAT 07583000 * 07584000 RECCKA L 2,ARDATA Attributes @SC86316 07585000 LR 5,2 Save start @SC86316 07586000 L 3,DATL Get length @SC86316 07587000 LA 15,ATOE @SC86316 07588000 BAL 14,TRANSLAT Convert to EBCDIC @SC86316 07589000 LR 3,2 Save end @SC86316 07590000 MVI ERRNUM,ERRIPS In case of error @SC86316 07591000 RECCKL CR 5,3 Another attribute? @SC86316 07592000 BNL RECDAK No, done @SC86316 07593000 LR 6,5 @SC86316 07594000 IC 4,0(6) Get code @SC86316 07595000 SR 5,5 @SC86316 07596000 IC 5,1(6) Get length of value @SC86316 07597000 UNCHR 7,ETOA(5) @SC86316 07598000 BM RECABR Invalid: length was <0 @SC86316 07599000 LA 6,2(6) Space over code+length @SC86316 07600000 LA 5,0(7,6) Next field @SC86316 07601000 CR 5,3 Does it match? @SC86316 07602000 BH RECABR Overflows data @SC86316 07603000 BAL 2,CLKP @SC86316 07604000 DC C'!',AL3(RECALN) File length @SC86316 07605000 DC X'0',AL3(RECCKL) Other @SC86316 07606000 RECALN BAL 14,GETNUM Get file length @SC86316 07607000 B RECABR @SC86316 07608000 LR 2,0 @SC86316 07609000 LA 0,11 Ask for length check @SC86316 07610000 KCALL DISKIO,FILPTR,E=RECRJC @SC86316 07611000 B RECCKL Ok, keep looking @SC86316 07612000 * 07613000 RECRJC LA 8,RECZNST Now accept only EOF pkt @SC86316 07614000 L 9,ASDATA Output buffer @SC86316 07615000 MVI 0(9),C'N' Mark it rejected @SC86316 07616000 S 6,F2 Back up to attribute code @SC86316 07617000 MVC 1(1,9),0(6) Copy to output @SC86316 07618000 TR 0(2,9),ETOA ASCIIify @SC86316 07619000 UNCHR 0,1(9),REASON @SC86316 07620000 OI RFLG,RRJC Mark it rejected @SC86316 07621000 MVC DATL,F2 Data = 'N' + code @SC86316 07622000 BAL 2,SENDACKL Acknowledge @SC86316 07623000 B RECDAT And wait for EOF @SC86316 07624000 * 07625000 RECEOF CLC DATL,F1 07626000 BNE RECWR One piece of data 07627000 L 1,ARDATA @SC86190 07628000 CLI 0(1),AD @SC86190 07629000 BNE RECWR Go if not discard 07630000 CLOSF FILPTR Close the file @SC86135 07631000 TM FL3,APPN Appending to old file? @SC86225 07632000 BO RECKEP Yes, keep what we got @SC86225 07633000 TM FL5,KEEP @SC86225 07634000 BO RECKEP Don't delete it anyway @SC86225 07635000 ERASF FILNAM And delete it @SC86295 07636000 RECKEP MVI ERRNUM,ERRTRC Receive cancelled @SC86225 07637000 OI RFLG,RTRC Remember that @SC86295 07638000 B RECACK Pick up later on 07639000 * If data left in buffer when we get EOF, write remaining data. 07640000 RECWR CLC WBUFL,F0 07641000 BE RECCLO No data in WBUF, send Ack 07642000 KCALL OUTBUF,E=RECABR Write out buffer 07643000 RECCLO CLOSF FILPTR Close it @SC86135 07644000 RECACK BAL 2,SENDACK Send an ACK 07645000 BAL 14,INCRSEQ 07646000 NI FL1,255-ROVR Only change first file 07647000 B RECFIL 07648000 * 07649000 RECBRK TM FL2,SRV Server will read another command @SC87343 07650000 BO *+8 so don't zap write/read flag @SC87343 07651000 MVI WRRD,0 No read for Ack'ing BRK pkt @SC87343 07652000 BAL 2,SENDACK Send an ACK 07653000 MVI ERRNUM,ERRNOE Reset error @SC86156 07654000 TM RFLG,RTRC+RRJC @SC86295 07655000 BZ RECRET OK @SC86295 07656000 MVI ERRNUM,ERRTRC Receive cancelled @SC86156 07657000 B RECABR 07658000 * 07659000 RECBAD MVI ERRNUM,ERRFNE Illegal filename @SC86156 07660000 B RECABR 07661000 * 07662000 RECRER ERRF , Cannot write. Analyze error @SC87338 07663000 RECABR CLOSF FILPTR Close open file @SC86135 07664000 KCALL ERPACK Send error packet @SC86316 07665000 RECRET ICM 0,15,RECTRC Any records truncated? @SC87268 07666000 BZ RETSNRC None @SC87268 07667000 CLI ERRNUM,0 @SC87268 07668000 BNE *+8 Already got some (worse) error @SC87268 07669000 MVI ERRNUM,ERRRTR Indicate error @SC87268 07670000 B RETSNRC Close statistics and return @SC87268 07671000 * Receive mode Rpack interpret input tables 07672000 RECINST DC AL1(AS),AL3(0) Micro sent parm 07673000 DC AL1(00),AL3(RECABR) Error routine 07674000 RECFNST DC AL1(AF),AL3(0) Micro sent a filename 07675000 DC AL1(AX),AL3(0) Micro sent a filename @SC86155 07676000 DC AL1(AB),AL3(RECBRK) Micro sent end of transaction 07677000 DC AL1(00),AL3(RECABR) Error return 07678000 RECANST DC AL1(AA),AL3(RECCKA) Micro sent A-packet @SC86316 07679000 RECDNST DC AL1(AD),AL3(0) Micro sent data 07680000 RECZNST DC AL1(AZ),AL3(RECEOF) Micro sent EOF @SC86316 07681000 DC AL1(00),AL3(RECABR) Error return 07682000 LOCALS , @SC86295 07683000 RFLG DS X Local flags @SC86295 07684000 RTRC EQU X'80' Other side cancelled @SC86295 07685000 RRJC EQU X'40' I cancelled @SC86316 07686000 RECEIV EXIT 07687000 TITLE 'SPAR Routine - use parms from other host in DATA' 07688000 SPAR ENTER 07689000 L 7,DATL Data length @SC86120 07690000 L 5,ARDATA Point to data @SC86190 07691000 LA 8,DEFPARM @SC86190 07692000 SR 8,5 Set up offset for defaults @SC86190 07693000 BCTR 5,0 Point one before data @SC86190 07694000 LA 6,1 Set up BXH @SC86120 07695000 AR 7,5 Point to last data char @SC86120 07696000 BAL 14,SPARFTCH Get a char @SC86120 07697000 UNCHR 4 Max send packet size @SC86120 07698000 C 4,AKMIN Less than min Kermit size? @SC86295 07699000 BNL SPARSPM No, it's OK 07700000 LA 4,KMIN Else, use the min value 07701000 SPARSPM C 4,AKMAX More than max Kermit size? @SC86295 07702000 BNH SPARSPS No, it's OK 07703000 LA 4,KMAX 07704000 SPARSPS ST 4,SPSIZ Save max send packet size 07705000 BAL 14,SPARFTCH Get a char @SC86120 07706000 UNCHR 4,,TIMOUT Timeout micro wants us to do @SC86120 07707000 BAL 14,SPARFTCH Get a char @SC86120 07708000 UNCHR 4,,SPADN Pad count micro wants @SC86120 07709000 BAL 14,SPARFTCH @SC86120 07710000 CTL 4,,SPADC Pad char micro wants @SC86120 07711000 BAL 14,SPARFTCH @SC86120 07712000 UNCHR 4,,SEOL EOL char we have to use @SC86120 07713000 CLC SEOL,SMARK 07714000 BE SPARCR Use CR if EOL=MARK char 07715000 CLI SEOL,ABL 07716000 BL SPAREOL2 OK if within ctl range @SC87274 07717000 SPARCR MVI SEOL,CR Send a CR to that crazy micro 07718000 SPAREOL2 MVC S1EOL,SEOL Make extra copy @SC87274 07719000 SPARCTL BAL 14,SPARFTCH @SC86120 07720000 NOTQR *+8 Go if not 33-62 or 96-126 @SC86120 07721000 LA 4,A# Default ctl-quote @SC86120 07722000 STC 4,RCTLQ Save ctl-quote micro's using @SC86120 07723000 BAL 14,SPARFTCH @SC86120 07724000 CLI EBQC,0 @SC87008 07725000 BE SPARNB 8-bit is off @SC87008 07726000 CLM 4,1,=AL1(AY) @SC86120 07727000 BNE *+8 @SC86120 07728000 IC 4,EBQC Micro agrees @SC86120 07729000 BAL 14,SPARCKQX @SC86120 07730000 B SPARNB Micro says no 8-bit quoting @SC86120 07731000 CLI EBQ,0 07732000 BE SPAREBQ Use it if we agree 07733000 CLM 4,1,EBQ @SC86120 07734000 BE SPAREBQ Or we match 07735000 SPARNB SR 4,4 Otherwise cannot do it 07736000 SPAREBQ STC 4,EBQ Set 8-bit-quoting char/flag 07737000 BAL 14,SPARFTCH @SC86120 07738000 S 4,=A(A0) @SC86120 07739000 BNP SPARBCD Go if less than 1, use 1 @SC86120 07740000 C 4,F3 @SC86295 07741000 BH SPARBCD Go if over 3, use 1 07742000 CLM 4,B'0001',BCTR Requested and our BCT same? 07743000 BE SPARBCT Yes, they are the same 07744000 CLI BCTR,0 07745000 BE SPARBCT We'll accept anything 07746000 SPARBCD LA 4,1 We don't match, use 1 07747000 SPARBCT STC 4,BCTR Micro's chksum length 07748000 BAL 14,SPARFTCH @SC86120 07749000 BAL 14,SPARCKQX See if valid @SC86120 07750000 B SPARNR No good @SC86120 07751000 CLM 4,1,EBQ @SC86120 07752000 BE SPARNR Go if same prefix 07753000 CLI RPTQ,0 07754000 BE SPARRQ We can use anything 07755000 CLM 4,1,RPTQ @SC86120 07756000 BE SPARRQ We match 07757000 SPARNR SR 4,4 No repeat quoting 07758000 SPARRQ STC 4,RPTQ Use negotiated repeat quote 07759000 BAL 14,SPARFTCH Get capabilities @SC86149 07760000 UNCHR 4,,RCAPA @SC86149 07761000 TM RCAPA,LONGP Test for long packet bit @TB86196 07762000 BZ SPARNX No extended packets @TB86196 07763000 MVC TMP,RCAPA @SC86202 07764000 SPARNS1 TM TMP,MORCAPAS Test for more CAPAS bytes @SC86202 07765000 BZ SPARNS2 No more @TB86196 07766000 BAL 14,SPARFTCH Get capabilities @TB86196 07767000 UNCHR 4,,TMP @TB86196 07768000 B SPARNS1 @TB86196 07769000 SPARNS2 BAL 14,SPARFTCH Skip window byte @SC86202 07770000 BAL 14,SPARFTCH Get next header byte @TB86196 07771000 LR 1,4 @TB86196 07772000 UNCHR 1 MAXLX1 byte @TB86196 07773000 MH 1,XLFCT+2 Times the factor @SC86202 07774000 BAL 14,SPARFTCH Get next header byte @TB86196 07775000 UNCHR 4 MAXLX2 byte @TB86196 07776000 AR 1,4 Compute total length @TB86196 07777000 BNP SPARNX If zero, use default @TB86196 07778000 ST 1,SPSIZ New SPSIZ for extended @TB86196 07779000 SPARNX DS 0H @TB86196 07780000 * Now compute MAXSIZ 07781000 L 5,SPSIZ Maximum send packet size 07782000 C 5,AKMAX Check max packet size @TB86196 07783000 BNH SPARNY Not long @TB86196 07784000 S 5,F3 Extended header length @TB86196 07785000 CLI TRMTP,C'T' @SC87166 07786000 BNE SPARNY Not TTY ==> not limited @SC87166 07787000 C 5,AMAXWT @SC86205 07788000 BNH *+8 @SC86205 07789000 L 5,AMAXWT Biggest we can send @SC86205 07790000 SPARNY DS 0H @SC86205 07791000 S 5,F5 Minus control information 07792000 IC 4,BCTR Get user's negotiated BCT 07793000 SR 5,4 Minus checksum length 07794000 CLI EBQ,0 07795000 BE SPARNEBQ Go if no 8-Bit quoting 07796000 BCTR 5,0 Another one for 8-bit quoting 07797000 SPARNEBQ CLI RPTQ,0 07798000 BE SPARNRQ Go if no repeat char quoting 07799000 BCTR 5,0 07800000 BCTR 5,0 Minus two for repeat prefix 07801000 SPARNRQ ST 5,MAXSIZ Save max length for data field 07802000 ST 5,MAXSIZ+4 Static extra copy (for tuning) 07803000 SPARBAK RET @SC86152 07804000 SPARCKQX CLM 4,1,RCTLQ @SC86120 07805000 BER 14 Cannot use same prefix @SC86120 07806000 CLM 4,1,SCTLQ @SC86120 07807000 BER 14 @SC86120 07808000 B CHKQR Test if 33-62 or 96-126 @SC86120 07809000 SPARFTCH L 4,SPACE Default @SC86120 07810000 BXH 5,6,*+8 Check for more data @SC86120 07811000 IC 4,0(5) OK, use it @SC86120 07812000 C 4,SPACE Default? @SC86120 07813000 BNER 14 @SC86120 07814000 IC 4,0(5,8) Yes, get default value @SC86190 07815000 BR 14 @SC86120 07816000 * 07817000 * SPARSET Routine - set up for exchange (SPAR 1st) @SC86152 07818000 * 07819000 SPARSET ENTER ALT @SC86152 07820000 MVI BCTR,0 Use whatever micro wants @SC86152 07821000 MVI EBQ,0 @SC86152 07822000 MVI RPTQ,0 @SC86152 07823000 MVI BCTU,1 Must start at 1 @SC86295 07824000 B SPARBAK @SC86152 07825000 LOCALS , @SC86295 07826000 SPAR EXIT 07827000 TITLE 'RPAR Routine - sets up parms to send to other host' 07828000 RPAR ENTER 07829000 OI FL3,PXCH Parameters exchanged now @SC87012 07830000 L 9,ASDATA @SC86295 07831000 TOCHR 5,RPSIZ+3,0(9) Receive packet size limit @SC86295 07832000 TOCHR 5,RTIMO,1(9) Time limit for micro to wait @SC86295 07833000 TOCHR 5,RPADN,2(9) Number of padding chars. @SC86295 07834000 CTL 5,RPADC,3(9) Pad character @SC86295 07835000 TOCHR 5,REOL,4(9) EOL char I need @SC86295 07836000 MVC 5(1,9),SCTLQ @SC86295 07837000 MVC 6(1,9),EBQ @SC86295 07838000 CLI EBQ,0 07839000 BNE RPARBCT It's OK if not null 07840000 MVI 6(9),AN Else, use an N @SC86295 07841000 RPARBCT MVC 7(1,9),BCTR Negotiated checksum @SC86295 07842000 OI 7(9),A0 Make into a real digit @SC86295 07843000 MVC 8(1,9),RPTQ @SC86295 07844000 CLI RPTQ,0 07845000 BNE *+8 It's ok if not null @SC86149 07846000 MVI 8(9),ABL Else, use a blank @SC86295 07847000 LA 0,10 Size of data @SC86149 07848000 NI SCAPA,255-LONGP No long packets @TB86196 07849000 LA 5,KMAX Largest old KERMIT size @TB86196 07850000 C 5,RPSIZ Check max packet size @TB86196 07851000 BNL RPARNEX KMAX >= RPSIZ @TB86196 07852000 TOCHR 5,,0(9) Set largest packet size @SC86295 07853000 OI SCAPA,LONGP Long packets @TB86196 07854000 MVI 10(9),ABL Window size is blank @SC86295 07855000 L 5,RPSIZ Packet size @SC86205 07856000 CLI TRMTP,C'T' @SC87166 07857000 BNE RPARS1 Not TTY ==> not limited @SC87166 07858000 C 5,AMAXRT @SC86205 07859000 BNH *+8 @SC86205 07860000 L 5,AMAXRT Biggest we can send @SC86205 07861000 RPARS1 SR 4,4 @SC86205 07862000 D 4,XLFCT Compute extended size bytes @TB86196 07863000 TOCHR 5,,11(9) Extended size 1 @SC86295 07864000 TOCHR 4,,12(9) Extended size 2 @SC86295 07865000 LA 0,13 Size of data @TB86196 07866000 RPARNEX DS 0H @TB86196 07867000 TOCHR 5,SCAPA,9(9) Capabilities @SC86295 07868000 ST 0,DATL Return it @SC86149 07869000 LA 0,3 Reset function @SC86295 07870000 CLI TRMTP,C'F' @SC87300 07871000 BE RPARSTT 3708/fullscreen @SC87300 07872000 CLI TRMTP,C'T' @SC87166 07873000 BE RPARSTT TTY @SC87166 07874000 KCALL SCRNIO @SC86295 07875000 B RPARBAK @SC86295 07876000 RPARSTT KCALL TERMIO @SC86295 07877000 RPARBAK RET @SC86152 07878000 * 07879000 * RPARSET Routine - set up for exchange (RPAR 1st) @SC86152 07880000 * 07881000 RPARSET ENTER ALT @SC86152 07882000 MVI BCTU,1 Must start at 1 @SC86295 07883000 TM FL2,SRV Possible I-packet exchange? @SC87169 07884000 BZ RPSCLR Not in Server mode @SC87169 07885000 TM FL3,PXCH Any exchange since last SET? @SC87169 07886000 BO RPARBAK Yes, keep latest settings @SC87169 07887000 RPSCLR MVC BCTR,BCTC Use what user set @SC87169 07888000 MVC EBQ,EBQC Set what we want otherwise @SC86152 07889000 RPSEBQ CLI RPTQ,0 @SC86152 07890000 BNE RPARBAK If RPTQ is set leave it alone @SC86152 07891000 MVC RPTQ,RPTQC Set what we want otherwise @SC86152 07892000 B RPARBAK @SC86152 07893000 LOCALS , @SC86295 07894000 RPAR EXIT 07895000 TITLE 'ENCODE Routine - encode pkts from RBUF into DATA' 07896000 ENCODE ENTER 07897000 L 6,MAXSIZ @SC86295 07898000 L 9,ASDATA Pointer to data to fill @SC86190 07899000 AR 6,9 Limit on output @SC86295 07900000 ENCAGAIN L 8,RBUFP Index of next char in RBUF 07901000 L 5,RBUFL Data length in RBUF @SC86163 07902000 L 1,RBUF Point to start of buffer 07903000 AR 5,1 Point to char after last one 07904000 AR 8,1 Point to char to encode @SC86163 07905000 ENCNXT CR 8,5 Are we past the last char? @SC86163 07906000 BL ENCPKT No, not exhausted RBUF yet @SC86163 07907000 TM FL1,NAME @SC86163 07908000 BO ENCEMPT No more disk read if file name @SC86163 07909000 KCALL INBUF,E=ENCRET @SC86163 07910000 B ENCAGAIN @SC86163 07911000 ENCPKT CLI RPTQ,0 07912000 BE ENCEBQ Go if no repeat quoting 07913000 LA 14,3(8) Point to 3 chars past current @SC86163 07914000 CR 14,5 Is this past the last char? @SC86163 07915000 BNL ENCEBQ Yes, not enough to use repeat 07916000 CLC 0(2,8),1(8) At least 3 of these? @SC86163 07917000 BNE ENCEBQ No, not enough @SC86163 07918000 LR 2,8 Start of string @SC86163 07919000 LA 3,KMAX(8) Max allowed by notation @SC86163 07920000 CR 3,5 Watch for end of data @SC86163 07921000 BNH *+6 @SC86163 07922000 LR 3,5 Truncate at max @SC86163 07923000 LR 15,3 Same limit @SC86163 07924000 SR 3,2 Get lengths @SC86163 07925000 SR 15,14 Length of shorter string @SC86163 07926000 ICM 15,8,0(8) Use starting char for fill @SC86163 07927000 CLCL 2,14 Find end of match @SC86163 07928000 SR 14,8 Get repeat count @SC86163 07929000 AR 8,14 Advance ptr to @SC86163 07930000 BCTR 8,0 last matching char @SC86163 07931000 MVC 0(1,9),RPTQ Put repeat quote into DATA @SC86163 07932000 TOCHR 14,,1(9) @SC86163 07933000 LA 9,2(9) Count 2 for RPTQ and rpt count @SC86295 07934000 ENCEBQ TM 0(8),128 @SC86163 07935000 BZ ENCCTL no 8th bit 07936000 CLI EBQ,0 07937000 BE ENCCTL cannot use 8bit quoting 07938000 NI 0(8),127 Get rid of 8th bit @SC86163 07939000 MVC 0(1,9),EBQ Move EBQ into DATA 07940000 LA 9,1(9) Count for it @SC86295 07941000 ENCCTL IC 7,0(8) Load desired char @SC86163 07942000 CLI 0(8),ABL @SC86163 07943000 BL ENCSCTL within control range 07944000 CLI 0(8),ADEL @SC86163 07945000 BNE ENCNCTL not a control char 07946000 ENCSCTL CTL 7 Convert to non-control @SC86163 07947000 B ENCMVCTL 07948000 * 07949000 ENCNCTL CLM 7,1,SCTLQ @SC86163 07950000 BE ENCMVCTL send prefix if ctl quote char 07951000 CLM 7,1,EBQ @SC86163 07952000 BE ENCMVCTL ditto if 8bit quote 07953000 CLM 7,1,RPTQ @SC86163 07954000 BNE ENCNOCTL not so if not repeat quote 07955000 ENCMVCTL MVC 0(1,9),SCTLQ Move a ctl quote 07956000 LA 9,1(9) incr for it 07957000 ENCNOCTL STC 7,0(9) Move the char, finally! @SC86163 07958000 LA 9,1(9) incr for it 07959000 LA 8,1(8) Incr RBUF pointer @SC86163 07960000 CR 9,6 Did we reach max pkt size? @SC86295 07961000 BL ENCNXT Test for more data @SC86295 07962000 * 07963000 ENCFULL CR 8,5 Are we past the last char? @SC86163 07964000 BL ENCGOOD No, not exhausted RBUF data yet @SC86163 07965000 ENCEMPT XC RBUFL,RBUFL Zap data length for next time @SC86163 07966000 ENCGOOD SR 15,15 07967000 S 8,RBUF Get current index @SC86163 07968000 ST 8,RBUFP Save RBUF index 07969000 ENCRET S 9,ASDATA Get length @SC86295 07970000 ST 9,DATL Save encoded DATA length @SC86295 07971000 RET , @SC86295 07972000 LOCALS , @SC86295 07973000 ENCODE EXIT 07974000 TITLE 'NPREAD Routine - copy from RBUF to SDATA' @HF86150 07975000 NPREAD ENTER @HF86150 07976000 L 6,SPSIZ Max packet length @SC86295 07977000 LR 4,6 Save @SC86295 07978000 L 9,ASPKT Fill pointer (includes header) @SC86165 07979000 SR 7,7 @SC86165 07980000 IC 7,TCTLQ Fetch control quote @SC86165 07981000 NPRAGAIN L 8,RBUFP Index of next char in RBUF @SC86165 07982000 L 5,RBUFL Data length in RBUF @SC86165 07983000 L 1,RBUF Start of buffer @SC86165 07984000 AR 5,1 Point to char after last one @SC86165 07985000 AR 8,1 Point to char to encode @SC86165 07986000 NPRNXT CR 8,5 Are we past the last char? @SC86165 07987000 BL NPRTCT No, not exhausted RBUF yet @SC86165 07988000 NPRRD KCALL INBUF,E=NPRRET @HF86150 07989000 B NPRAGAIN @SC86165 07990000 NPRTCT LTR 7,7 Test for quoting @SC86165 07991000 BZ NPRNOCTL Not enabled @HF86150 07992000 CLM 7,1,0(8) Is it a quote character? @HF86150 07993000 BNE NPRNOCTL No, copy it @HF86150 07994000 LA 8,1(8) Check next @HF86150 07995000 CR 8,5 @HF86150 07996000 BNL NPRRD Ran out of data, ignore the quote @HF86150 07997000 CLM 7,1,0(8) If repeat of quote character @HF86150 07998000 BE NPRNOCTL send that character @HF86150 07999000 NI 0(8),X'1F' Make control character @HF86150 08000000 NPRNOCTL MVC 0(1,9),0(8) Copy the char @HF86150 08001000 LA 9,1(9) Incr for it @HF86150 08002000 LA 8,1(8) Incr RBUF pointer @HF86150 08003000 BCT 6,NPRNXT Get next character if any room @SC86295 08004000 * 08005000 NPRGOOD SR 15,15 @HF86150 08006000 S 8,RBUF Convert to index @SC86165 08007000 ST 8,RBUFP Save it @SC86165 08008000 NPRRET SR 4,6 Get DATA length @SC86295 08009000 ST 4,SNDPKL Save it @HF86150 08010000 RET @HF86150 08011000 LOCALS , @SC86295 08012000 NPREAD EXIT @HF86150 08013000 TITLE 'DECODE Routine - decode pkts from DATA to WBUF' 08014000 DECODE ENTER 08015000 ICM 5,B'1111',DATL Data length to decode 08016000 BNP RTRN1 No data to decode @SC86295 08017000 TM FL1,EOF 08018000 BO DECNULL Ignore if ctl-z caused EOF 08019000 L 1,WBUF Point to output buffer 08020000 L 9,WBUFL Number of chars in it 08021000 AR 1,9 Point to next spot to fill 08022000 L 8,ARDATA Data to be decoded @SC86190 08023000 AR 5,8 Point one past the last char 08024000 DECLOOP LA 3,1 Repeat count @SC86316 08025000 CLI RPTQ,0 08026000 BE DECEBQ Not doing repeats 08027000 CLC RPTQ,0(8) 08028000 BNE DECEBQ Not the repeat quote 08029000 UNCHR 3,1(8) Get number of repeats @SC86316 08030000 LA 8,2(8) skip to char to decode 08031000 DECEBQ MVI CUR,0 No 8th bit yet 08032000 CLI EBQ,0 08033000 BE DECCTL Not doing 8bit quoting 08034000 CLC EBQ,0(8) 08035000 BNE DECCTL Not the 8bit quote 08036000 LA 8,1(8) point to char to decode 08037000 MVI CUR,128 8th bit seen 08038000 DECCTL CLC RCTLQ,0(8) 08039000 BNE DECCHR not the ctl quote 08040000 LA 8,1(8) point to char to decode 08041000 CLI 0(8),63 08042000 BL DECCHR skip if not in ctl range 08043000 CLI 0(8),95 08044000 BH DECCHR skip if not in ctl range 08045000 CTL 4,0(8),0(8) Ctl it 08046000 DECCHR OC 0(1,8),CUR put in the parity 08047000 MVC CUR,0(8) move it here also 08048000 TR CUR,ATOE keep the EBCDIC version here 08049000 DECRLOOP TM FL1,NAME 08050000 BO DECPUT skip if not writing to disk 08051000 LTR 7,9 Started yet? @SC86316 08052000 BZ DECTFUL No @SC86151 08053000 C 9,RDWLEN @SC86151 08054000 BNE DECTFUL @SC86151 08055000 L 6,WBUF Just finished RDW @SC86316 08056000 SR 14,14 @SC86151 08057000 ICM 14,3,0(6) Get expected length @SC86316 08058000 C 9,F2 Short? @SC86262 08059000 BE DECVLEN Yes, we got it @SC86262 08060000 TR 0(5,6),ATOE No, must be 5-byte ASCII prefix @SC86316 08061000 MVI ERRNUM,ERRBPC Look out for bad field @SC86262 08062000 BAL 14,GETNUM Read length field @SC86316 08063000 B RTRN1 Bad @SC86316 08064000 LR 14,0 @SC86316 08065000 DECVLEN DS 0H @SC86262 08066000 AR 14,9 + RDW length @SC86151 08067000 ST 14,MAXOUT Reset byte limit @SC86151 08068000 DECTFUL C 9,MAXOUT Max write buffer size reached? @SC86151 08069000 BNL DECWRT Yes, write the buffer 08070000 DECMORE TM FL1,BINF 08071000 BO DECPUT No special test in binary mode 08072000 CLI CUR,CR 08073000 BE DECWRT A cr means end of record 08074000 CLI CUR,LF 08075000 BNE DECTAB Not an LF 08076000 CLI PREV,CR 08077000 BE DECIGN A cr/lf together = ignre the LF 08078000 DECWRT ST 9,WBUFL Buffer length to write 08079000 KCALL OUTBUF,E=RTRN1 Dump it @SC86295 08080000 SR 9,9 Reset length to resume decoding 08081000 L 1,WBUF Reset pointer also 08082000 CLC WBUFL,MAXOUT 08083000 BNL DECMORE Resume decoding if max 08084000 B DECIGN 08085000 * 08086000 DECTAB TM FL2,TABS 08087000 BZ DECCTLZ Skip if not expanding tabs 08088000 CLI CUR,TAB 08089000 BNE DECCTLZ Not a tab 08090000 LR 0,1 Save output ptr @SC86355 08091000 LH 2,TABCNT Get count of tabs that are set @TS86100 08092000 LTR 2,2 Any? @SC86355 08093000 BZ DECTL8 No, use every 8 cols @SC86355 08094000 LA 7,TABTBL Yes, point to table of tabs @TS86100 08095000 SR 1,1 @TS86100 08096000 DECTLP IC 1,0(7) Get tab column from table @TS86100 08097000 BCTR 1,0 Adjust for displacement compare @TS86100 08098000 CR 1,9 Where is this tab compared to buf @TS86100 08099000 BH DECTLX Above buffer position @TS86100 08100000 LA 7,1(7) Point to next tab position @TS86100 08101000 BCT 2,DECTLP Continue with next tab @TS86100 08102000 DECTL8 DS 0H @SC86355 08103000 LA 1,8(9) Buffer pointer + 8 @SC86355 08104000 SRL 1,3 @SC86355 08105000 SLL 1,3 Round up to multiple of 8 @SC86355 08106000 DECTLX C 1,MAXLRC @SC86355 08107000 BL *+8 @SC86355 08108000 L 1,MAXLRC Don't go past end of buffer @SC86355 08109000 SR 1,9 Number of blanks to add @SC86355 08110000 AR 9,1 Advance the count @SC86355 08111000 LA 15,ABL @SC86355 08112000 SLL 15,24 Set for ASCII blank fill @SC86355 08113000 MVCL 0,14 Jump to tab stop @SC86355 08114000 LR 1,0 Restore output ptr @SC86355 08115000 B DECIGN skip to the end of this 08116000 * 08117000 DECCTLZ TM FL2,EOFZ 08118000 BZ DECPUT Skip if EOF is off 08119000 CLI CUR,SUB 08120000 BNE DECPUT Skip if not a ctl-z 08121000 OI FL1,EOF Fake an end-of-file 08122000 B DECEOF all done 08123000 * 08124000 DECPUT C 9,MAXLRC Still within disk buffer? @SC86355 08125000 BNL *+10 No, don't copy @SC86355 08126000 MVC 0(1,1),0(8) Yes, put the data in buffer @SC86355 08127000 LA 9,1(9) Increment count 08128000 LA 1,1(1) Increment pointer 08129000 DECIGN MVC PREV,CUR copy the decoded char 08130000 BCT 3,DECRLOOP Repeat it repeat count times @SC86316 08131000 LA 8,1(8) Increment decoded data pointer 08132000 CR 8,5 Did we reach end of DATA? 08133000 BL DECLOOP No, More data left to decode 08134000 DECEOF ST 9,WBUFL Save buffer length 08135000 DECNULL B RTRN0 Good return code @SC86295 08136000 LOCALS , @SC86295 08137000 CUR DS C Char being decoded @SC86295 08138000 DECODE EXIT 08139000 TITLE 'ERPACK Routine - send error packet with errnum' 08140000 ERPACK ENTER 08141000 CLI ERRNUM,ERRABO @SC86295 08142000 BE RTRN0 Skip it if the micro died @SC86295 08143000 CLI ERRNUM,ERRTRC @SC86295 08144000 BE RTRN0 Skip it if other cancelled @SC86295 08145000 MVI STYPE,AE Error packet 08146000 MVC SEQ,RSN Synch packet numbers 08147000 SR 5,5 08148000 IC 5,ERRNUM Get right message number 08149000 SLL 5,2 Pointer offset = ERRNUM * 4 @SC86156 08150000 A 5,AERRTAB Pointer address @SC86156 08151000 L 3,0(5) Msg ptr @SC86156 08152000 SR 4,4 @SC86156 08153000 IC 4,0(5) Msg length @SC86156 08154000 TM FL2,PROTO @SC87300 08155000 BZ RTRN0 Skip packet if never started @SC87300 08156000 TM FL2,SRV Server will read another command @SC87343 08157000 BO *+8 so don't zap write/read flag @SC87343 08158000 MVI WRRD,0 No read ncessary for Err pkt @SC87300 08159000 ST 4,RBUFL Save length to encode @SC86156 08160000 L 1,RBUF 08161000 MVC 0(50,1),0(3) Put data in RBUF (and some extra) @SC86156 08162000 TR 0(50,1),ETOA Ascii it @SC86156 08163000 BAL 9,ENCODEN @SC86295 08164000 KCALL SPACK Send error packet @SC86135 08165000 RET 08166000 LOCALS , @SC86295 08167000 ERPACK EXIT 08168000 TITLE 'SPACK Routine - sends DATA buffer' 08169000 SPACK ENTER 08170000 SR 3,3 Zero out IC register 08171000 L 8,AASPKT SNDPKT address @SC86295 08172000 SPKNX3 LA 8,3(8) Remove LX1, LX2, HCHECK from hdr @SC86295 08173000 L 9,DATL Data size 08174000 IC 3,BCTU CHK len 08175000 LA 9,2(3,9) Data, CHK, SEQ, TYP lengths 08176000 LA 1,3(9) Plus SOH, LEN, EOL lengths @SC86202 08177000 C 9,AKMAX Check packet length byte @SC86202 08178000 BNH SPKNXDL1 No extended data len @SC86202 08179000 LA 1,3(1) Plus LX1,LX2,HCHECK for ext. hdr @SC86202 08180000 SR 9,9 Set 'Type 0' extended hdr @SC86202 08181000 SH 8,SPKNX3+2 Remove LX1, LX2, HCHECK from hdr @SC86295 08182000 SPKNXDL1 ST 1,SNDPKL SNDPKT length @SC86202 08183000 LM 14,15,TOUTOT Update send count @SC86295 08184000 ALR 15,1 @SC86295 08185000 BNO *+8 @SC86295 08186000 AL 14,F1 @SC86295 08187000 STM 14,15,TOUTOT Save new count @SC86295 08188000 ST 8,ASPKT Ptr to buffer @SC86295 08189000 MVC 0(1,8),SMARK Add mark to packet @SC86295 08190000 TOCHR 9,,1(8) Add it to packet @SC86295 08191000 TOCHR 4,SEQ,2(8) Get packet number @SC86295 08192000 AR 9,4 And add to checksum 08193000 IC 3,STYPE Type 08194000 STC 3,3(8) Store in buffer @SC86295 08195000 AR 9,3 Add to checksum 08196000 CLI 1(8),ABL Chk 'Type 0' extended hdr @SC86295 08197000 BNE SPKNXDL3 No extended data len @TB86196 08198000 L 7,DATL Data size @TB86196 08199000 IC 3,BCTU CHK len @TB86196 08200000 AR 7,3 Sum = extended length @TB86196 08201000 SR 6,6 @TB86196 08202000 D 6,XLFCT Get two parts @TB86196 08203000 TOCHR 7,,4(8) Add LENX1 to packet @SC86295 08204000 AR 9,7 And add to checksum @TB86196 08205000 TOCHR 6,,5(8) Add LENX2 to packet @SC86295 08206000 AR 9,6 And add to checksum @TB86196 08207000 LR 6,9 Chksum thru LENX2 byte @TB86196 08208000 SRL 6,6 High 2 bits of total @TB86196 08209000 N 6,F3 Get just 2 bits @SC86295 08210000 AR 6,9 Get type-1 check value @TB86196 08211000 N 6,MOD64 @TB86196 08212000 TOCHR 6,,6(8) Make printable @SC86295 08213000 AR 9,6 And add to checksum @TB86196 08214000 SPKNXDL3 DS 0H @TB86196 08215000 L 8,ASDATA @SC86295 08216000 BCTR 8,0 Ptr one before data @SC86295 08217000 ICM 6,B'1111',DATL Data length 08218000 BZ SPKCHK Go if no data 08219000 LR 5,6 @SC86135 08220000 SPKCHAR IC 3,0(5,8) Pick up char @SC86295 08221000 AR 9,3 Add to checksum 08222000 BCT 5,SPKCHAR Yes, there's more data @SC86135 08223000 SPKCHK LA 6,1(6,8) Point to where chksum goes @SC86295 08224000 LR 7,9 Need copy of chksum 08225000 CLI BCTU,2 08226000 BE SPKCHK2 Go if 2 char chksum 08227000 BH SPKCHK3 Go if 3 char CRC 08228000 SRL 9,6 High 2 bits of total 08229000 N 9,F3 Get just 2 bits @SC86295 08230000 AR 7,9 Add the two values 08231000 B SPKCHK1 Go add chksum to data 08232000 * 08233000 SPKCHK3 L 5,ASPKT @SC86190 08234000 LA 5,1(5) Where checksum starts @SC86190 08235000 KCALL CRCCLC Calculate the CRC 08236000 LR 7,15 Keep in here 08237000 SRL 15,12 High 4 bits of high byte 08238000 TOCHR 15,,0(6) Make char printable 08239000 LA 6,1(6) Bump output pointer 08240000 SPKCHK2 LR 15,7 total 08241000 SRL 15,6 Next 6 bits of total @SC86295 08242000 N 15,MOD64 Get just 6 bits @SC86295 08243000 TOCHR 15,,0(6) Make char printable 08244000 LA 6,1(6) Bump pointer 08245000 SPKCHK1 N 7,MOD64 Get low order 6 bits 08246000 TOCHR 7,,0(6) Make printable 08247000 SPKEOL MVC 1(2,6),S1EOL Add micro's EOL char + handshake @SC87274 08248000 KCALL SIO Write the SNDPKT @SC86135 08249000 RET , Return with SIO's rc @SC86295 08250000 LOCALS , @SC86295 08251000 SPACK EXIT 08252000 TITLE 'RPACK Routine - Reads data into DATA buffer' 08253000 RPACK ENTER 08254000 KCALL RIO,E=RPKNAK 08255000 L 7,RCVPKL Length of data read 08256000 LM 14,15,TINTOT Update recv count @SC86295 08257000 ALR 15,7 @SC86295 08258000 BNO *+8 @SC86295 08259000 AL 14,F1 @SC86295 08260000 STM 14,15,TINTOT Save new count @SC86295 08261000 L 14,ARPKT Point to recv buffer @SC86295 08262000 L 8,APKT Point to PKT @SC86190 08263000 MVI RTYPE,AT In case of time-out @SC87012 08264000 C 7,F1 Time-out signal is ASCII T @SC87012 08265000 BNE *+12 @SC87012 08266000 CLI 0(8),AT @SC87012 08267000 BE RTRN Yes, timed out @SC87012 08268000 AR 7,8 Point past last char 08269000 RPKBEG SR 3,3 Use this for IC's 08270000 RPKLOOP CLC RMARK,0(8) 08271000 LA 8,1(8) Try next character @SC86135 08272000 BE RPKSOH Go if a Control-A 08273000 CR 8,7 Are we within the received pkt? 08274000 BL RPKLOOP Yes, keep on looking for SOH 08275000 B RPKERR 08276000 * 08277000 RPKSOH LA 9,4(14) Skip over usual header @SC86295 08278000 MVC 1(3,14),0(8) Copy usual header to RCVPKT @SC86295 08279000 UNCHR 3,0(8) Length 08280000 BM RPKBEG Invalid length, try again @SC86153 08281000 LA 5,ABL(3) Chksum accumulator 08282000 LR 4,3 Keep length to compute DATA len 08283000 LA 15,0(3,8) pkt len + beg 08284000 CR 15,7 Is it within received pkt? 08285000 BNL RPKBEG too long, look for another SOH 08286000 IC 3,2(8) Pick up packet type @SC86153 08287000 STC 3,RTYPE Save value here @SC86153 08288000 AR 5,3 Add to checksum @SC86153 08289000 BCTR 4,0 -1 for Seq # 08290000 BCTR 4,0 -1 for Type 08291000 UNCHR 3,1(8) Pick up packet number @SC86153 08292000 BM RPKBEG Invalid char @SC86153 08293000 LA 5,ABL(3,5) Add to checksum 08294000 STC 3,RSN Received packet number @SC86135 08295000 LA 8,3(8) Go to putative data @SC86153 08296000 CLI 1(14),ABL Is this an extended pkt? @SC86295 08297000 BNE RPKEXT2 No @TB86196 08298000 LA 15,3(8) Past LENX1,LENX2,HCHECK @TB86196 08299000 CR 15,7 Is it within rcvd pkt? @TB86196 08300000 BNL RPKBEG Too long, try for another SOH @TB86196 08301000 MVC 4(3,14),0(8) Copy extended pkt hdr @SC86295 08302000 UNCHR 1,0(8) Pick up LENX1 byte @TB86196 08303000 LA 5,ABL(1,5) Add to check @SC86202 08304000 MH 1,XLFCT+2 High digit of size @SC86202 08305000 UNCHR 3,1(8) Pick up LENX2 byte @TB86196 08306000 LA 5,ABL(3,5) Add to chksum @SC86202 08307000 AR 1,3 Total extended pkt size @TB86196 08308000 UNCHR 3,2(8) Pick up HCHECK byte @TB86196 08309000 LR 6,5 Keep chksum copy here @TB86196 08310000 SRL 6,6 High 2 bits of total @TB86196 08311000 N 6,F3 Get just 2 bits @SC86295 08312000 AR 6,5 Add the two values @TB86196 08313000 N 6,MOD64 Get low order 6 bits @TB86196 08314000 CR 6,3 Chk computed vs received @TB86196 08315000 BNE RPKERR Err if chksums no match @TB86196 08316000 LA 5,ABL(3,5) Add HCHECK to chksum @SC86202 08317000 LA 8,3(8) Update input+output ptrs @SC86202 08318000 LA 9,3(9) Past LX1,LX2,HCHECK @SC86202 08319000 LR 4,1 Save length of data+check @SC86202 08320000 AR 1,8 Expected end of packet @SC86202 08321000 CR 1,7 Is it within pkt? @SC86202 08322000 BH RPKBEG Too long, chk for SOH @SC86202 08323000 RPKEXT2 DS 0H @SC86202 08324000 IC 3,BCTU Chksum length @SC86202 08325000 SR 4,3 Minus chksum length @SC86202 08326000 BM RPKBEG Can't have negative data length @SC86202 08327000 ST 4,DATL Save data length @SC86202 08328000 ST 9,ARDATA Save ptr @SC86202 08329000 LTR 4,4 Any data to send? 08330000 BZ RPKCHK Nope 08331000 RPKCHAR IC 3,0(8) Get next data char 08332000 STC 3,0(9) Move it to DATA 08333000 AR 5,3 Add to checksum 08334000 LA 8,1(8) Bump input buffer pointer 08335000 LA 9,1(9) Bump output buffer pointer 08336000 BCT 4,RPKCHAR Decrement amount of input 08337000 RPKCHK UNCHR 3,0(8) Get checksum 08338000 LR 6,9 CRC calc ends here @SC86135 08339000 LA 8,1(8) Bump input pointer 08340000 LR 4,5 Keep chksum copy here 08341000 CLI BCTU,2 08342000 BE RPKCHK2 Go if using 2 char chksum 08343000 BH RPKCHK3 Three character CRC 08344000 SRL 5,6 High 2 bits of total 08345000 N 5,F3 Get just 2 bits @SC86295 08346000 AR 4,5 Add the two values 08347000 B RPKCHK1 compare it 08348000 * 08349000 RPKCHK3 LA 5,1(14) Start of data for CRC @SC86295 08350000 KCALL CRCCLC Calculate the CRC 08351000 LR 4,15 Keep computed value here also 08352000 SRL 15,12 High 4 bits of high byte 08353000 CR 15,3 compare computed and received 08354000 BNE RPKERR skip if chksums don't match 08355000 UNCHR 3,0(8) Get next char of checksum 08356000 LA 8,1(8) Bump input pointer 08357000 RPKCHK2 LR 15,4 Get back the CRC 08358000 SRL 15,6 Next 6 bits of total @SC86295 08359000 N 15,MOD64 Get just 6 bits @SC86295 08360000 CR 15,3 compare computed and received 08361000 BNE RPKERR skip if chksums don't match 08362000 UNCHR 3,0(8) Get checksum 08363000 LA 8,1(8) Bump input pointer 08364000 RPKCHK1 N 4,MOD64 Get low order 6 bits 08365000 CR 4,3 Compare computed and received 08366000 BE RPKRET skip if chksums match 08367000 TM FL1,TSTF @SC86295 08368000 BO RPKRET Just testing, anything goes @SC86295 08369000 RPKERR MVI ERRNUM,ERRBPC Rpack error @SC86156 08370000 CR 8,7 @BS86001 08371000 BL RPKBEG More stuff, see if it's a packet @BS86001 08372000 RPKNAK MVI RTYPE,AQ Return a Q pkt 08373000 RPKRET RET 08374000 LOCALS , @SC86295 08375000 RPACK EXIT 08376000 TITLE 'CRCCLC Routine - calculates CRC' 08377000 * Calculate the CRC and return it in R15. Expects R5 to point to the 08378000 * start of the data on which the CRC is calculated, and R6 to the 08379000 * char after the last one. 08380000 * 08381000 CRCCLC ENTER 08382000 SR 15,15 Initial CRC value is zero 08383000 CRCLUP IC 4,0(5) Get the next character @SC86295 08384000 XR 4,15 XOR char and CRC low byte @SC86295 08385000 LR 7,4 same as above 08386000 SRL 7,4 High 4 bits of low byte 08387000 N 4,F Low 4 bits of low byte 08388000 N 7,F High 4 bits of low byte @SC86295 08389000 ALR 4,4 Double to get index into table 08390000 LH 4,CRCTAB2(4) CRC for low 4 bits 08391000 ALR 7,7 Double to get another index 08392000 LH 7,CRCTAB1(7) CRC for high 4 bits 08393000 XR 4,7 XOR the two 08394000 SRL 15,8 Shift prev CRC 8 bits to right 08395000 XR 15,4 XOR current char's CRC into it 08396000 N 15,=XL4'FFFF' Drop negative stuff @SC86295 08397000 LA 5,1(5) Bump input pointer 08398000 CR 5,6 Did we reach the end? 08399000 BL CRCLUP Nope, loop for whole pkt 08400000 CRCRET RET 08401000 * Table to use for CRC calculation 08402000 CRCTAB1 DC X'00,00,10,81,21,02,31,83,42,04,52,85,63,06,73,87' 08403000 DC X'84,08,94,89,A5,0A,B5,8B,C6,0C,D6,8D,E7,0E,F7,8F' 08404000 * 08405000 CRCTAB2 DC X'00,00,11,89,23,12,32,9B,46,24,57,AD,65,36,74,BF' 08406000 DC X'8C,48,9D,C1,AF,5A,BE,D3,CA,6C,DB,E5,E9,7E,F8,F7' 08407000 * 08408000 LOCALS , @SC86295 08409000 CRCCLC EXIT 08410000 TITLE 'RIO Routine - Read packet into RCVPKT' 08411000 RIO ENTER 08412000 MVI SIORIO,C'R' Set type @SC86316 08413000 L 7,APKT Ptr to data @SC86316 08414000 L 15,RIOC Previous read count @SC86295 08415000 MVI RIOC,X'80' Nothing left in read buffer @SC86295 08416000 CLI TRMTP,C'T' @SC87166 08417000 BE RIOTTY Go if not a S/1? @SC87166 08418000 CLI TRMTP,C'F' @SC87300 08419000 BE RIOTTY Go if not a S/1? @SC87300 08420000 LA 5,OFF80 Turn off all X'80' bits @SC86316 08421000 TM FL2,DAT8 Unless 8-bit line @SC86316 08422000 BZ *+6 Not 8-bit @SC86316 08423000 SR 5,5 Yes, use all bits @SC86316 08424000 LTR 15,15 Any previous? @SC86295 08425000 BNM RIOCOM Yes, use it @SC86295 08426000 CLI TRMTP,C'G' @SC87215 08427000 BE RIOS1R Skip prompt if graphics mode @SC87215 08428000 LA 0,4 Write @SC86295 08429000 KCALL SCRNIO,S1XOPL,E=(RIOER,M) Send a prompt @SC86295 08430000 RIOS1R DS 0H @SC87215 08431000 LA 0,5 Read @SC86295 08432000 KCALL SCRNIO,S1RDPL,E=(RIOER,M) perform read @SC86295 08433000 BP RIOCOM @SC86355 08434000 RIOER MVI ERRNUM,ERRTIE Terminal I/O error @SC86156 08435000 B RTRN1 Error, return to caller @SC86295 08436000 * 08437000 RIOTTY LA 5,ETOA Translate to ASCII @SC86316 08438000 TM FL4,TTAB Using separate terminal tables? @SC87117 08439000 BZ *+8 No @SC87117 08440000 LA 5,TETOA Yes @SC87117 08441000 LTR 15,15 Any previous data? @SC86295 08442000 BNM RIOCOM Yes, use it @SC86295 08443000 LA 0,5 No, read some now @SC86295 08444000 KCALL TERMIO,TYRDPL,E=(RIOER,M) @SC86295 08445000 RIOCOM LR 6,15 Copy byte count @SC86295 08446000 ST 6,RCVPKL Save 08447000 BAL 9,RIORAW Log raw data @SC86316 08448000 LR 2,7 @SC86316 08449000 LR 3,6 Length @SC86202 08450000 LTR 15,5 Copy table ptr @SC86316 08451000 BZ *+8 Don't translate after all @SC86316 08452000 BAL 14,TRANSLAT Do the translate @SC86202 08453000 BAL 9,RIOLOG Write to log @SC86190 08454000 B RTRN0 @SC86295 08455000 * Write record to log buffer, R7->data, R6=length @SC87286 08456000 * Clobbers R0,R1,R2,R3,R8,R14,R15, return to (R9) @SC87286 08457000 RIORAW SR 3,3 Write raw data @SC86316 08458000 B RIOLG1 @SC86316 08459000 RIOLOG LA 3,ATOE Write data in EBCDIC @SC86316 08460000 RIOLG1 C 3,DBGTYP Correct type? @SC86316 08461000 BNER 9 No, skip this one @SC86316 08462000 TM FL1,DEBUG @SC86316 08463000 BZR 9 Skip if no debugging @SC86190 08464000 LA 8,2(6) Two extra for R:, etc. @SC87286 08465000 L 2,LOGBUF LOG buffer @SC86316 08466000 MVC 0(1,2),SIORIO Indicate log type @SC86316 08467000 LA 2,2(2) Skip over prefix @SC86190 08468000 LR 0,2 Buffer ptr @SC86190 08469000 LR 1,8 Data length @SC86316 08470000 LR 14,7 Data ptr @SC86316 08471000 LR 15,8 @SC86316 08472000 MVCL 0,14 Copy to log buffer @SC86316 08473000 LTR 15,3 Check if translation needed @SC86316 08474000 BZ *+10 No @SC86316 08475000 LR 3,8 Data length @SC86316 08476000 BAL 14,TRANSLAT Do the translate @SC86202 08477000 WRITF LOGPTR,BSIZE=(8),E=RIOLQU @SC87034 08478000 BR 9 Done @SC86190 08479000 RIOLQU CLOSF LOGPTR Turn off DEBUG, it fails @SC86355 08480000 NI FL1,255-DEBUG @SC86355 08481000 BR 9 @SC86355 08482000 TITLE 'SIO Routine - Send packet in SNDPKT' 08483000 SIO ENTER ALT @SC86190 08484000 MVI SIORIO,C'S' Set type @SC86316 08485000 MVI RIOC,X'80' Set no read count @SC86295 08486000 L 6,SNDPKL Length of SNDPKT to be sent 08487000 TM FL4,NPS Non-protocol? @SC86239 08488000 BO SIOPLEN Yes, no handshake at all @LP87272 08489000 CLI WRRD,0 Only writing? @LP87272 08490000 * BE SIOPLEN Yes, handshake done next Read @LP87272 08491000 CLI S1HND,0 Handshake desired at all? @SC87275 08492000 BE SIOPLEN No, skip it @SC87275 08493000 LA 6,1(6) Allow for handshake character @LP87272 08494000 SIOPLEN DS 0H @SC86239 08495000 L 7,ASPKT Ptr to send data @SC86316 08496000 BAL 9,RIOLOG Write to log @SC86190 08497000 L 2,S1WRPL Final output buffer @SC86154 08498000 LR 1,2 Save start @SC86154 08499000 SR 3,3 @SC86154 08500000 TM FL4,NPS Non-protocol? @SC86191 08501000 BO *+8 Yes, skip padding @SC86191 08502000 IC 3,SPADN Pad count @SC86154 08503000 LA 4,S1DATA @SC86154 08504000 LA 5,S1ORDL Length of Series/1 stuff @SC86154 08505000 CLI TRMTP,C'G' Graphics? @SC87215 08506000 BNE SIOPAD @SC87215 08507000 LA 4,GRDATA Yes, use separate command @SC87215 08508000 LA 5,GRDL @SC87215 08509000 SIOPAD DS 0H @SC87215 08510000 AR 3,5 Total padding + Series/1 @SC86154 08511000 ICM 5,8,SPADC Get padding character @SC86154 08512000 MVCL 2,4 Copy to buffer with padding @SC86154 08513000 LR 3,6 Packet length @SC86154 08514000 LR 5,6 @SC86154 08515000 LR 4,7 Ptr to packet @SC86316 08516000 MVCL 2,4 Copy packet to buffer @SC86154 08517000 CLI TRMTP,C'T' @SC87166 08518000 BE SIOTTY Go if not S/1? @SC87166 08519000 CLI TRMTP,C'F' @SC87300 08520000 BE SIOTTY Go if not S/1? @SC87300 08521000 SR 2,1 Total length @SC86154 08522000 ST 2,S1WRPL+4 Store len in CCW @SC86154 08523000 L 4,ASCRNIO I/O routine for fullscreen @SC87275 08524000 LA 5,S1WRPL 1st plist @SC87275 08525000 SIOGO LM 7,8,0(5) @SC87275 08526000 BAL 9,RIORAW Log it @SC86316 08527000 LA 0,4 Write @SC86295 08528000 KCALL (4),(5),E=(RIOER,M) @SC87275 08529000 CLI TRMTP,C'G' @SC87215 08530000 BE SIOGOOD No immediate answer if graphics @SC87215 08531000 LA 0,5 @SC86295 08532000 KCALL (4),8(5),E=(RIOER,M) Read it now @SC87275 08533000 CLI WRRD,0 Write/read? @SC86301 08534000 BE SIOGOOD No, ignore bare status @SC86301 08535000 LTR 15,15 @TB87009 08536000 BP SIOCOM @TB87009 08537000 CLI TRMTP,C'T' @SC87275 08538000 BE SIOCOM No problem if TTY @SC87275 08539000 CLI TRMTP,C'F' @SC87300 08540000 BE SIOCOM No problem if TTY @SC87300 08541000 * If only 3 bytes (AID and cursor) come in, VTAM has caused @TB87009 08542000 * the S/1 to discard its transparent data. Fill the screen and @TB87009 08543000 * read it back in protocol conversion mode to cause VTAM @TB87009 08544000 * to put up a longer READ MODIFIED CCW at its next read. @TB87009 08545000 LA 0,6 Message (Leave Transparent Mode) @TB87009 08546000 KCALL SCRNIO,SIORTPL,E=(SIORTY,M) @TB87009 08547000 LA 0,5 @TB87009 08548000 KCALL SCRNIO,S1RDPL,E=(RIOER,M) Rdmod to prime VTAM. @TB87009 08549000 SIORTY SR 15,15 No data actually seen. @TB87009 08550000 SIOCOM DS 0H @TB87009 08551000 ST 15,RIOC save residual byte count 08552000 SIOGOOD NI FL1,255-NAK0 Something sent now @SC86295 08553000 B RTRN0 @SC86295 08554000 * 08555000 SIOTTY L 1,TYWRPL Skip S/1 stuff @SC86295 08556000 SR 2,1 Length to write @SC86154 08557000 ST 2,TYWRPL+4 Length @SC86295 08558000 LA 15,ATOE Send in EBCDIC @SC86202 08559000 TM FL4,TTAB Using separate terminal tables? @SC87117 08560000 BZ *+8 No @SC87117 08561000 LA 15,TATOE Yes @SC87117 08562000 LR 3,2 Length @SC87281 08563000 LR 2,1 @SC86202 08564000 BAL 14,TRANSLAT Do the translate @SC86202 08565000 L 4,ATERMIO I/O routine for TTY @SC87275 08566000 LA 5,TYWRPL 1st plist @SC87275 08567000 B SIOGO Now do it @SC87275 08568000 * @TB87009 08569000 SIORTPL DC A(SIOMSGXX,SIOMSL) @TB87009 08570000 * Greetings for ERROR mode @TB87009 08571000 SIOMSGXX DC X'&S1CMD',AL1(SBA),X'4040' @TB87009 08572000 DC C'S/1 VTAM Error Recovery ' @TB87009 08573000 DC X'3C5D7F40' Repeat blanks to end of screen @TB87009 08574000 SIOMSL EQU *-SIOMSGXX @TB87009 08575000 LOCALS , @SC86295 08576000 SIORIO DS C Operation code @SC86316 08577000 SIO EXIT 08578000 TITLE 'INTINI Routine - Initialize console for protocol' 08579000 * If R1 is 0, reset the traps unless in Server mode. 08580000 * If R1 is positive, set up console traps for protocol: 08581000 * 1 for SERVER, 2 for SEND, 3 for RECEIVE, 4 for short msg @SC86184 08582000 * R15 = 0 on return if ok 08583000 * 08584000 INTINI ENTER 08585000 MVI WRRD,5 Reset w/r flag @SC86184 08586000 TM FL2,SRV 08587000 BO INTINIR Return if server running 08588000 LTR 3,1 Call type: 0 or 1-5 @HF86232 08589000 BZ INTINICL If R1 is 0 clear traps 08590000 OI FL2,PROTO Line open for transfer @SC86295 08591000 ICM 5,15,LCLDLY No delay? @HF86232 08592000 BNZ INTINIDL @HF86232 08593000 LA 1,5 Yes, use no message @HF86232 08594000 INTINIDL C 1,F5 No delay or non-protocol send? @HF86232 08595000 BE INTINIMS Yes @HF86232 08596000 BCT 5,INTINIMS Short delay? @HF86232 08597000 LA 1,4 Yes, use short message anyway @SC86184 08598000 INTINIMS SLL 1,3 8-byte indexing @HF86232 08599000 LA 5,INTCCWSR-8(1) Get ptr to correct CCW @SC86184 08600000 MVC SVHND,S1HND Save handshake character @SC87343 08601000 KCALL SETMSG,2,E=INTINERR Prepare line for transfer @SC87300 08602000 LA 0,2 @SC87309 08603000 SR 0,3 @SC87309 08604000 LPR 0,0 Get ABS(code-2) @SC87309 08605000 BCT 0,*+8 Test for Serve or Rec codes (1,3) @SC87309 08606000 OI FL1,NAK0 Send NAK during retry, if any @SC87309 08607000 MVI RIOC,X'80' Clr any prev byte count @SC86295 08608000 CLI TRMTP,C'T' @SC87166 08609000 BE INTINITY Go if TTY @SC87166 08610000 CLI TRMTP,C'F' @SC87300 08611000 BE INTINITY Go if TTY @SC87300 08612000 LA 0,1 Open screen @SC86295 08613000 KCALL SCRNIO @SC86295 08614000 LA 0,6 Simple write @SC86316 08615000 KCALL SCRNIO,(5),E=(INTINIR,M) Message @SC86295 08616000 C 3,F2 Was this SEND? @SC86184 08617000 BE INTINIR SEND does sleep anyway 08618000 ICM 0,15,LCLDLY See if speed wanted @SC87253 08619000 BZ INTINIP Yes, no greetings anyway @SC87309 08620000 LA 0,1 Wait 1 sec @SC86295 08621000 KCALL SUPFNC,9 This seems essential @SC86295 08622000 INTINIP CLI TRMTP,C'G' Graphics terminal? @SC87309 08623000 BNE INTINIR No, go ahead @SC87309 08624000 TM FL1,NAK0 Will we receive? @SC87309 08625000 BZ *+8 No, fine @SC87309 08626000 BAL 2,SENDNAK Yes, must prompt hardware @SC87309 08627000 B INTINIR 08628000 * 08629000 INTINITY L 1,0(5) Text address from ccw @SC86184 08630000 LH 4,6(5) Get total length @SC86184 08631000 LA 3,INTPRL(1) Skip over WCC and SBA @SC86184 08632000 SH 4,*-2 and deduct that from length @SC86184 08633000 C 4,F64 @SC86184 08634000 BL INTINIT2 Just one (short) line @SC86184 08635000 LA 4,80 Length to type 08636000 WTEXT (3),(4) 08637000 LA 3,80(3) Next line 08638000 INTINIT2 WTEXT (3),(4) @SC86184 08639000 LA 0,1 @SC86295 08640000 KCALL TERMIO Open line @SC86295 08641000 B INTINIR 08642000 * 08643000 INTINICL TM FL2,PROTO Was line open? @SC86295 08644000 BZ INTINIR No @SC86295 08645000 LA 0,2 @SC86295 08646000 L 15,ATERMIO @SC87300 08647000 CLI TRMTP,C'T' @SC87300 08648000 BE INTINIK Go if TTY @SC87300 08649000 CLI TRMTP,C'F' @SC87300 08650000 BE INTINIK Go if 3708/fullscreen @SC87300 08651000 L 15,ASCRNIO @SC87300 08652000 INTINIK KCALL (15) Release line @SC87300 08653000 KCALL SETMSG,3 @SC86316 08654000 MVC S1HND,SVHND Restore handshake character @SC87343 08655000 INTINIR B RTRN0 @SC87300 08656000 * 08657000 INTINERR NI FL2,255-PROTO Turn off protocol mode @SC87300 08658000 MVI ERRNUM,ERRCOM Bad comm line @SC87300 08659000 B RTRN1 @SC87300 08660000 * 08661000 DS 0D 08662000 INTCCWSR DC A(INTMSGSR,INTPRL+80+80) @SC86295 08663000 INTCCWSN DC A(INTMSGSN,INTPRL+80+80) @SC86295 08664000 INTCCWRC DC A(INTMSGRC,INTPRL+80+80) @SC86295 08665000 INTCCWQU DC A(INTMSGQU,INTQL) @SC86295 08666000 INTCCWNL DC A(INTMSGQU,INTPRL) @SC86295 08667000 * Short greetings @SC86184 08668000 INTMSGQU DC X'&S1CMD',AL1(SBA),X'4040' @SC86295 08669000 INTPRL EQU *-INTMSGQU Length of prefix @SC86295 08670000 INTMSGQ2 DC C'Kermit-&KSYS....' @SC86268 08671000 INTQL EQU *-INTMSGQU @SC86184 08672000 * Greetings for RECEIVE mode 08673000 INTMSGRC DC X'&S1CMD',AL1(SBA),X'4040' @SC86295 08674000 DC CL80'Kermit-&KSYS ready to receive.' @SC86268 08675000 DC CL80'Please escape to local Kermit now to SEND the file(s).' 08676000 * Greetings for SEND mode 08677000 INTMSGSN DC X'&S1CMD',AL1(SBA),X'4040' @SC86295 08678000 DC CL80'Kermit-&KSYS ready to send.' @SC86268 08679000 DC CL80'Please escape to local Kermit now to RECEIVE the file(s).' 08680000 * Greetings for SERVER mode 08681000 INTMSGSR DC X'&S1CMD',AL1(SBA),X'4040' @SC86295 08682000 DC CL80'Entering server mode. Please escape to local Kermit now.' 08683000 DC CL80'To terminate the server use the BYE or FINISH commands.' 08684000 * 08685000 LOCALS , @SC86295 08686000 INTINI EXIT 08687000 TITLE 'INBUF Routine - read next disk record into WBUF' 08688000 * Exit: R15=0 if ok, -1 if EOF, 1 if read error (ERRNUM set) 08689000 INBUF ENTER 08690000 TM FL1,EOF 08691000 BO RTRNM1 Go if hit eof already @SC86295 08692000 SR 15,15 In case reading from memory @SC86158 08693000 ST 15,RBUFP Clear read buffer pointer @SC86158 08694000 ST 15,RBUFL Clear read buffer length @SC86158 08695000 L 9,RBUF Read into this buffer @SC86158 08696000 TM FL4,SFM Source is memory? @SC86158 08697000 BZ IBFDSK No, read disk @SC86158 08698000 LM 4,5,TXTPTR Yes, copy to buffer @SC86158 08699000 CR 4,5 Any left? @SC86158 08700000 BNL IBFEOF No, quit @SC86158 08701000 XC CMD,CMD @SC86158 08702000 MVI CMD+X'15',1 Set up TRT @SC86158 08703000 MVC 0(256,9),0(4) Copy one line or so @SC86158 08704000 LA 1,256(4) In case no NL @SC86158 08705000 TRT 0(256,4),CMD Scan for NL @SC86158 08706000 CR 1,5 No X'15'? @SC86158 08707000 BNH *+6 OK @SC86158 08708000 LR 1,5 Limit is end of data @SC86158 08709000 SR 1,4 Length of line @SC86158 08710000 LA 4,1(1,4) @SC86158 08711000 ST 4,TXTPTR Update ptr @SC86158 08712000 LR 0,1 Save length @SC86158 08713000 B IBFXLAT Go change to ASCII @SC86158 08714000 IBFDSK DS 0H @SC86158 08715000 ICM 2,15,RDWLEN Special format? @SC86151 08716000 BZ *+6 No @SC86151 08717000 AR 9,2 Space over record descriptor @SC86151 08718000 READF FILPTR,BUFFER=(9),E=IBFERR @SC87034 08719000 LM 14,15,DSKTOT Update disk count @SC86295 08720000 ALR 15,0 @SC86295 08721000 BNO *+8 @SC86295 08722000 AL 14,F1 @SC86295 08723000 STM 14,15,DSKTOT Save new count @SC86295 08724000 LTR 2,2 Special format? @SC86151 08725000 BZ IBFNRM No @SC86151 08726000 SR 9,2 Back up to start of buffer @SC86151 08727000 STCM 0,3,0(9) Store length @SC86151 08728000 C 2,F2 Short? @SC86262 08729000 BE IBFVLEN Yes @SC86262 08730000 CVD 0,TMPDW No, use 5-byte ASCII @SC86262 08731000 OI TMPDW+7,15 @SC86262 08732000 UNPK 0(5,9),TMPDW @SC86262 08733000 TR 0(5,9),ETOA @SC86262 08734000 IBFVLEN DS 0H @SC86262 08735000 AR 0,2 @SC86151 08736000 B IBFLEN Must be binary @SC86151 08737000 IBFNRM DS 0H @SC86151 08738000 TM FL1,BINF 08739000 BO IBFLEN No trans for binary file 08740000 ICM 1,15,RMARG Text file: check margins @SC87253 08741000 BZ IBFCKLM No right margin specified @SC87253 08742000 CR 0,1 @SC87253 08743000 BNH IBFCKLM Record is shorter than margin @SC87253 08744000 LR 0,1 Truncate record at margin @SC87253 08745000 IBFCKLM L 1,LMARG @SC87253 08746000 S 1,F1 @SC87253 08747000 BNP IBFXLAT No left margin, or start in col 1 @SC87253 08748000 SR 0,1 See if record is long enough @SC87253 08749000 BNP IBFEMPT Too short, make empty record @SC87253 08750000 LR 2,9 Ptr to record @SC87253 08751000 LR 3,0 Shortened length @SC87253 08752000 LA 4,0(1,2) @SC87253 08753000 LR 5,3 @SC87253 08754000 MVCL 2,4 Eliminate stuff before margin @SC87253 08755000 IBFXLAT LA 15,ETOA Change to ASCII @SC86202 08756000 LR 2,9 Address @SC86202 08757000 LR 3,0 Length @SC86202 08758000 BAL 14,TRANSLAT Do the translate @SC86202 08759000 AR 9,0 Point one past last char 08760000 IBFTRUNC BCTR 9,0 Back up one 08761000 CLI 0(9),ABL 08762000 BNE IBFLCHAR Found non-blank 08763000 BCT 0,IBFTRUNC FIND LAST CHAR 08764000 IBFEMPT SR 0,0 Record is empty @SC87253 08765000 BCTR 9,0 Empty record @SC86119 08766000 IBFLCHAR MVI 1(9),CR Add CR @SC86135 08767000 MVI 2(9),ALF Add LF @SC86135 08768000 A 0,F2 Two extra bytes of data 08769000 IBFLEN ST 0,RBUFL LRECL or LRECL + 2 (FOR CRLF) 08770000 B RTRN0 08771000 * 08772000 IBFEOF OI FL1,EOF 08773000 B RTRNM1 @SC86295 08774000 * 08775000 IBFERR C 15,F12 EOF code? 08776000 BE IBFEOF Yes 08777000 ERRF , Disk read error, analyze it @SC87338 08778000 CLOSF FILPTR Close file @SC86295 08779000 B RTRN1 @SC86295 08780000 LOCALS , @SC86295 08781000 INBUF EXIT 08782000 TITLE 'OUTBUF Routine - write WBUF to a disk file' 08783000 OUTBUF ENTER 08784000 L 9,WBUFL Amount of data to write 08785000 SR 6,6 @SC86295 08786000 ICM 6,3,LRECL Use to hold lrecl @SC86295 08787000 L 7,WBUF Address of buffer 08788000 ICM 2,15,RDWLEN @SC86151 08789000 BZ OBFNRM @SC86151 08790000 SR 1,1 Special format @SC86151 08791000 ICM 1,3,0(7) Get true record length @SC86151 08792000 C 2,F2 Short? @SC86262 08793000 BE OBFVLEN Yes @SC86262 08794000 PACK TMPDW,0(5,7) No, must be 5-byte ASCII @SC86262 08795000 OI TMPDW+7,15 Get + sign @SC86262 08796000 CVB 1,TMPDW Convert back to binary @SC86262 08797000 OBFVLEN DS 0H @SC86262 08798000 AR 7,2 Skip over descriptor @SC86151 08799000 SR 9,2 Correct length @SC86151 08800000 L 15,FILPTR Ptr to disk FAB @SC87351 08801000 MVC FABCOMM-FABD(8,15),=CL8'Binary' @SC87351 08802000 LA 15,15 Suitable disk error @SC86151 08803000 CR 1,9 Match? @SC86151 08804000 BNZ OBFERR No, give up @SC86151 08805000 B OBFLEN Do it @SC87351 08806000 OBFNRM DS 0H @SC86151 08807000 TM FL1,BINF 08808000 BO OBFLEN Go if binary data file 08809000 LTR 9,9 Any data to write? 08810000 BNZ OBFTR Yes, there's data 08811000 MVI 0(7),ABL Make first char a space 08812000 LA 9,1 Length of one 08813000 OBFTR LA 15,ATOE Change to EBCDIC @SC86202 08814000 LR 2,7 @SC86202 08815000 LR 3,9 Length @SC86202 08816000 BAL 14,TRANSLAT Do the translate @SC86202 08817000 OBFLEN CLI FRECF,C'F' @SC87012 08818000 BNE OBFWRT Go if variable format @SC87012 08819000 TM FL3,APPN Appending to old file? @SC86203 08820000 BZ *+8 No, use LRECL @SC86203 08821000 L 6,FSIZE Yes, use old size @SC86203 08822000 CR 9,6 Compare data length and lrecl 08823000 BE OBFWRT Go if lrecl exactly @SC87268 08824000 BH OBFTRNC Go if must truncate @SC87268 08825000 LR 1,6 Else, get lrecl size 08826000 SR 1,9 Pad with this many spaces 08827000 LA 0,0(9,7) Where to start padding 08828000 SR 15,15 @SC86295 08829000 TM FL1,BINF @SC86295 08830000 BO *+8 @SC86295 08831000 ICM 15,8,BLANK Pad with spaces @SC86295 08832000 MVCL 0,14 Do it 08833000 B OBFLRECL And note new length @SC87268 08834000 OBFTRNC LA 0,1 @SC87268 08835000 A 0,RECTRC @SC87268 08836000 ST 0,RECTRC Increment count of truncations @SC87268 08837000 OBFLRECL LR 9,6 Length has to be this size 08838000 OBFWRT LM 14,15,DSKTOT Update disk count @SC86295 08839000 ALR 15,9 @SC86295 08840000 BNO *+8 @SC86295 08841000 AL 14,F1 @SC86295 08842000 STM 14,15,DSKTOT Save new count @SC86295 08843000 WRITF FILPTR,BUFFER=(7),BSIZE=(9) @SC87034 08844000 LTR 15,15 Any disk write errors? 08845000 BZ OBFRET Nope, all OK 08846000 MVI ERRNUM,ERRFUL Maybe disk is full @SC86345 08847000 CLM 15,1,ERRNUM Is it? @SC86345 08848000 BE OBFRET Yes, too bad @SC86345 08849000 OBFERR ERRF , General write error, analyze it @SC87338 08850000 OBFRET RET 08851000 LOCALS , @SC86295 08852000 OUTBUF EXIT 08853000 END KERMIT 08854000