*COPY IK0PRO 07000000 CHECKVER IK0PRO,4.2 @SC90072 07000500 TITLE 'SERVER Routine - performs Server mode functions' 07001000 * Exit: ERRNUM set appropriately. 07001500 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 XL1'FF',AL3(SRVSTP) Stop @SC88074 07016500 DC AL1(00),AL3(SRVILL) Error routine @SC86355 07017000 SRVLUP MVI SEQ,0 Reset packet number @SC86135 07018000 TM FL3,ZPRO Must stop? @SC88074 07018300 BO SRVXIT Yes, return immediately @SC88074 07018600 OI FL5,NAK0 Resend NAK during retry @SC90037 07019000 MVC SRVTIM,TIMOUT Save time-out limit @SC86355 07020000 MVC TIMOUT,TIMOSRV Set for server mode @SC90045 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 MVC ERRNUM(2),OLDERR Restore previous error code @SC90059 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 SRVMOP @SC88323 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 MVC MSNDPTR,MSNDBUF No extra files @SC88306 07052000 KCALL SEND @SC88306 07052500 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 SRVMOP @SC88323 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 SRVMOP MVI ERRNUM,ERRMOP Missing operand @SC88323 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 MVC MSNDPTR,MSNDBUF No extra files @SC88306 07108500 KCALL SEND Send all @SC86158 07109000 CLI ERRNUM,ERRNOE Problem with SEND? @SC86295 07110000 BNE SRVLUP Yes, remember that @SC86295 07111000 MVC ERRNUM(2),OLDERR No, use code from commands @SC90033 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 SRVMOP None, error @SC88323 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 SRVMOP @SC88323 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,ERRIPS Assume missing operand @SC88323 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 SRVERP Really bad @SC88323 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 SRVERP Inconsistant @SC88323 07193000 B 4(9) @SC86295 07194000 * Set up copy 07195000 SRVGPRW ICM 0,15,WBUFL @SC86171 07196000 BNP SRVMOP No text @SC88323 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(2),OLDERR Copy back error number @SC90033 07218000 SRVXIT NI FL2,255-SRV Turn off SERVER mode @SC86158 07219000 KCALL INTINI,0 Clear interrupt trapping 07220000 RET 07221000 * 07221200 SRVSTP MVC TIMOUT,SRVTIM Restore timeout @SC88074 07221400 B SRVXIT @SC88074 07221600 * 07222000 TRATOE TR 0(,1),ATOE @SC89215 07222300 * 07222600 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 MVC NSENTAC,F0 Number of files for acctng @AB89191 07252500 KCALL SUPFNC,10 @SC86295 07253000 ST 15,SECTOT Save start time @SC86295 07254000 ST 15,TINSV+12 Also for length tuning @SC88325 07254200 ST 15,TINSV+28 @SC88325 07254400 ST 15,TINSV+44 @SC88325 07254600 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,TUNECT Time to tune up @SC88349 07260000 STH 0,SNPKCT @SC86345 07261000 MVI REASON,0 Not rejected yet @SC86316 07262000 MVI SEQ,0 Reset packet number @SC86135 07263000 TM FL4,SFM @SC88100 07263300 BO SNDS8 Just sending from memory @SC88100 07263600 SNDSET OI SNFLG,NEWGRP Haven't started yet @SC88306 07263800 NXTFSET IFILE,E=SNDNON Init for NXTFST call @SC87012 07264000 SNDS8 LA 8,SNDST Set state table @SC89263 07265000 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 MVC FLNOPTS(LFOPTS),IFOPTS Copy file options @SC89218 07276500 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 A 5,FLFID1 Next filespec @SC88092 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 POINTF FILPTR,FLNOPTS,E=SNDSHRT Skip, if requested @SC89218 07291500 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 NI SNFLG,255-NEWGRP Not first of this group @SC88306 07298000 TM SNFLG,FIRST @SC86295 07298500 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 MVC RTYPPRV,RTYPE Set up in case S packet gets lost @SC89263 07314500 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),ATOED Back to EBCDIC @SC89301 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 KCALL ACCTST,FILNAM Copy name to table @SC88306 07337000 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 BAL 2,SNDPKLC Check length of attribute info @SC90037 07353500 ICM 4,15,KBYTES File length known? @SC86295 07354000 BZ SNDAT0 No, skip it @SC86316 07355000 TM ATFLG,ATFLNG Length attribute desired? @SC90037 07355300 BZ SNDAT0 No, skip it @SC90037 07355600 MVI 0(5),AEXCL Yes, ASCII ! => size @SC88273 07356000 LA 15,2(5) @SC86295 07357000 BAL 2,EDDEC Format it @SC86295 07358000 TR 2(9,5),ETOAD Convert plenty to ASCII @SC88273 07358500 SR 15,5 @SC86295 07359000 LA 4,ABL-2(15) Number of digits (printably) @SC88273 07360000 STC 4,1(5) @SC86295 07361000 AR 5,15 End of string @SC86295 07362000 SNDAT0 TM ATFL2,ATFORG Origin wanted? @SC90037 07363000 BZ SNDAT0B No, skip it @SC90037 07363200 BAL 2,SNDPKLC Check length of attribute info @SC90037 07363400 MVC 0(LSYSATR,5),SYSATR @SC90037 07363600 LA 5,LSYSATR(5) System code @SC88273 07364000 SNDAT0B TM ATFLG,ATFTYP Type wanted? @SC90037 07364200 BZ SNDAT1Z No, skip it and encoding too @SC90037 07364400 BAL 2,SNDPKLC Check length of attribute info @SC90037 07364600 MVC 0(3,5),=AL1(ABL+2,ABL+1,AB) "!B - it's binary @SC88273 07365000 TM FL4,SFM Sending from memory buffer? @SC90016 07365300 BO *+12 Yes, always text file @SC90016 07365600 TM FL1,BINF Binary file? @SC86149 07366000 BO SNDAT1 Yes @SC86316 07367000 MVC 2(4,5),=AL1(AA,ABL+10,ABL+1,AA) A*!A - ASCII @SC88273 07368000 TM ATFL2,ATFENC Encoding wanted? @SC90037 07368300 BZ SNDAT1 No, skip it @SC90037 07368600 LA 5,3(5) Advance over extra item @SC86316 07369000 ICM 2,15,CDESPTR @SC90040 07369080 BZ SNDAT1 @SC90040 07369160 MVI 2(5),AC Level-1 syntax @SC90040 07369240 SR 1,1 @SC90040 07369320 IC 1,4(,2) Get length of designator @SC90040 07369400 LA 0,ABL+1(,1) Modified length of ENC attribute @SC90040 07369480 STC 0,1(,5) @SC90040 07369560 MVC 3(11,5),5(2) Copy plenty of text @SC90040 07369640 AR 5,1 Account for extra stuff @SC90040 07369720 SNDAT1 LA 5,3(5) @SC86316 07370000 SNDAT1Z TM ATFL2,ATFFMT Format wanted? @SC90037 07370200 BZ SNDAT3 No, skip it @SC90037 07370400 BAL 2,SNDPKLC Check length of attribute info @SC90037 07370600 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(ABL+3,AA,AM,AJ) #AMJ Delimited @SC88273 07378000 SNDATD BAL 2,SNDAT2 @SC86295 07379000 DC AL1(ABL+2,AD,A5) "D5 Undelimited 5-byte pref@SC90037 07380000 SNDATV BAL 2,SNDAT2 @SC86295 07381000 DC AL1(ABL+2,AV,A2) "V2 2-byte bin. pref. @SC90037 07382000 SNDAT2 MVI 0(5),ABL+15 ASCII / => Format @SC88273 07383000 MVC 1(9,5),0(2) Copy string @SC86295 07384000 UNCHR 4,0(2) Get length @SC88273 07385000 LA 5,2(4,5) Update string ptr @SC86295 07388000 SNDAT3 CLI FDATE,0 File date defined? @SC86295 07389000 BE SNDAT5 No, skip it @SC90037 07390000 TM ATFLG,ATFDAT Date wanted? @SC90037 07390200 BZ SNDAT5 No, skip it @SC90037 07390400 BAL 2,SNDPKLC Check length of attribute info @SC90037 07390600 MVC 0(2,5),=AL1(A#,ABL+8) Yes, yyyymmdd (ASCII #) @SC88273 07391000 UNPK 2(9,5),FDATE(5) Insert zones @SC86295 07392000 LA 4,10(5) End of date @SC88273 07392040 CLC FDATE+4(3),F0 Time defined too? @SC88235 07392090 BE SNDAT4 No, just use date @SC88235 07392180 MVI 1(5),ABL+17 Yes, add string length - hh:mm:ss @SC88273 07392270 MVC 10(9,5),TIMPLT and edit time @SC88235 07392360 ED 10(9,5),FDATE+4 @SC88235 07392450 CLI 11(5),C' ' @SC88235 07392540 BNE *+8 @SC88235 07392630 MVI 11(5),C'0' Insist on leading zeroes @SC88235 07392720 LA 4,9(4) Advance over time @SC88273 07392900 SNDAT4 TR 2(17,5),ETOAD Convert date/time to ASCII @SC88273 07393100 LR 5,4 New ptr in either case @SC88273 07393300 SNDAT5 DS 0H @SC90037 07393380 BAL 2,SNDPKLC Check length of attribute info @SC90037 07393460 SR 8,8 Unconditionally send all @SC90037 07393540 LA 2,SNDATZ Place to go when done @SC90037 07393620 ST 2,SNDPKLR @SC90037 07393700 B SNDAT9 @SC90037 07393780 * Send A-packet if buffer full. Use last version that fit. @SC90037 07393860 SNDPKLC L 8,MAXSIZ Set limit for packet @SC90037 07393940 SNDAT9 L 15,ASDATA @SC86295 07394000 SR 5,15 @SC86295 07395000 BNP SNDPKLZ @SC90037 07395300 CR 5,8 Full yet? @SC90037 07395600 BNH SNDPKLZ No, go back for more @SC90037 07395900 ICM 5,15,SNDPKLN Length from last time through @SC90037 07396200 BZ SNDPKLZ This shouldn't happen @SC90037 07396500 ST 5,DATL Set length @SC86295 07397000 LA 8,SNDST Restore state ptr @SC89263 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 SNDPKLX Ok @SC90037 07403000 L 1,ARDATA @SC86316 07404000 CLI 0(1),AN Refused? @SC86149 07405000 BE SNDCAN Sigh @SC86149 07406000 SNDPKLX SR 5,5 Clear length to send @SC90037 07406100 L 2,SNDPKLR Will have to redo @SC90037 07406200 SNDPKLZ ST 5,SNDPKLN Save length available @SC90037 07406300 A 5,ASDATA Restore as ptr into buffer @SC90037 07406400 ST 2,SNDPKLR Where to go if need to redo @SC90037 07406500 BR 2 @SC90037 07406600 * @SC90037 07406700 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 KCALL SUPFNC,10 Get time @SC88325 07421000 ST 15,CSECTOT Save @SC88325 07421300 KCALL OPTPKT Calculate optimum size @SC88325 07421600 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,TUNECT Repeat target @SC88349 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 KCALL ACCTNG Save code in table @SC88092 07445500 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 MVI ERRNUM,ERRNOE No error yet @SC88092 07470500 CLC DATL,F0 07471000 BE SNDEOF No more data to send 07472000 B SNDDAT Send last chunk 07473000 * 07474000 SNDNON TM SNFLG,NEWGRP @SC88306 07475000 BZ SNDMNXT Filespec wasn't totally missing @SC89218 07475200 SNDFNF MVI ERRNUM,ERRFNF Not found @SC87012 07475230 KCALL ACCTST,IFILE Copy name to table @SC88306 07475260 SNDACT KCALL ACCTNG Set error number @SC89218 07475290 SNDMNXT DS 0H @SC89218 07475320 CLC MSNDPTR,MSNDBUF Any more filespecs pending? @SC88306 07475400 BNH SNDBRK No, all done @SC88306 07475600 L 1,MSNDPTR @SC88306 07475800 SH 1,=Y(LFSTF) Back up to next filespec @SC89218 07476000 ST 1,MSNDPTR And save new ptr @SC88306 07476200 MVC IFILE(LFSTF),0(1) Copy out names @SC89218 07476400 B SNDSET Start all over again @SC88306 07476800 * 07477000 SNDBRK MVC ERRNUM(2),ERRLAST Last error code+reason code @SC89218 07477100 CLI ERRNUM,ERRNOE Last transfer ok? @SC89218 07477200 BE SNDBRKP Yes @SC89218 07477300 TM SNFLG,FIRST @SC88306 07477600 BZ SNDAB2 Send E-packet: transfer started @SC89218 07477800 TM FL2,SRV 07478000 BO SNDAB2 Go if server @SC89218 07479000 B SNDRET @SC86295 07480000 * 07480100 SNDSHRT BAL 9,SNDCLS Close input file @SC89218 07480200 NI SNFLG,255-NEWGRP Not first of the group anymore @SC89218 07480300 MVI ERRNUM,ERRFTS File too short for request @SC89218 07480400 KCALL ACCTST,FILNAM Copy name to table @SC89218 07480500 B SNDACT On to next file, if any @SC89218 07480600 * 07481000 SNDBRKP TM SNFLG,FIRST See if actually started @SC89218 07482000 BO SNDRET No, just quit @SC89218 07482300 MVI STYPE,AB Packet type = BREAK @SC89218 07482600 XC DATL,DATL 07483000 BAL 9,INPUTSPK Send BRK and Interpret response @SC86295 07484000 SNDBR2 DS 0H @SC86165 07485000 MVC ERRNUM(2),ERRLAST Reset error+reason @SC89218 07486000 B SNDRET Done @SC89218 07487000 * 07488000 SNDABR BAL 9,SNDCLS Close disk file @SC86295 07490000 KCALL ACCTNG Save code in table @SC88092 07490500 SNDAB2 DS 0H @SC89218 07490700 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 LA 0,0 Indicate return from SEND @AB89191 07494500 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 * 07500300 TIMPLT DC C' ',X'2120',C':',2X'20',C':',2X'20' Time edit @SC88235 07500600 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 NEWGRP EQU X'40' File is the first of a new group @SC88306 07505500 SNDPKLR DS A Saved return adr for attribute @SC90037 07505600 SNDPKLN DS F Length of attributes composed @SC90037 07505700 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 XC NSENT,NSENT Clear count of files @SC88092 07511500 MVC NSENTAC,F0 Number of files for acctng @AB89191 07511700 MVC FL1SV,FL1 Save file attribute defaults: @SC90037 07511760 MVC TYPFSV,TYPFIL File type... @SC90037 07511820 MVC RCFSV,FILRCF Format @SC90037 07511880 MVC LRCSV,FILLRC Record length... @SC90037 07511940 KCALL SUPFNC,10 @SC86295 07512000 ST 15,SECTOT Save start time @SC86295 07513000 CLI RTYPE,AF Starting with file header packet? @SC88074 07514000 BE RECFHD Yes, skip INIT stuff @SC88074 07514200 CLI RTYPE,AX @SC88074 07514400 BE RECFHD Yes, skip INIT stuff @SC88074 07514600 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 CLI RTYPE,0 @SC88074 07518000 BNE RECSRV Skip read if already got packet @SC88074 07518500 MVI SEQ,0 Reset packet number @SC88074 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 KCALL RPACK Get header packet @SC88074 07529000 RECFHD LA 8,RECFNST Next state table for RECEIVE F @SC88074 07529500 SR 3,3 Clear retry counter for INPUTLUP @SC88074 07530000 BAL 9,INPUTINR Interpret header packet @SC88074 07530500 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 MVC FILFSIZ,F0 Clear expected size in Kbytes @SC90037 07533500 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),ATOED Convert to std EBCDIC @SC89301 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=RECNER Check collisions @SC88053 07556000 TM FL4,NMCHNG @SC90033 07556040 BZ RECCMSG @SC90033 07556080 CLI CLSNFL,C'B' @SC90033 07556120 BNE RECCTSTD @SC90033 07556160 LA 2,FILNAM Must back up original file @SC90033 07556200 LA 0,15 Rename it to unique new name @SC90033 07556240 KCALL DISKIO,XFILE @SC90033 07556280 CLI TRMLIN,C' ' Alt. line? @SC90033 07556320 BE RECCBZ No, be quiet @SC90033 07556360 MVC CMD(9),=CL24'--original backed up as ' @SC90033 07556400 LA 7,CMD+24 @SC90033 07556440 LA 1,FILNAM @SC90033 07556480 BAL 2,STAFSP Format backup name and show it @SC90033 07556520 RECCBZ MVC FILNAM,XFILE Now, just use intended name @SC90033 07556560 B RECCMSG @SC90033 07556600 RECCTSTD CLI CLSNFL,C'D' @SC90033 07556640 BNE RECCMSG Other case is just "rename" @SC90033 07556680 OI RFLG,RRJC Reject file @SC90033 07556720 MVI REASON,STACNCLS Reason was file collision @SC90033 07556760 CLI TRMLIN,C' ' Alt. line? @SC90033 07556800 BE RECOPN No, be quiet @SC90033 07556840 WTEXT '--discarded as duplicate' @SC90033 07556880 B RECOPN @SC90033 07556920 RECCMSG DS 0H @SC90033 07556960 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-SVATT @SC90033 07564000 XC FILFLGS,FL3 @SC86295 07565000 KCALL ACCTST,FILNAM Copy name to table @SC88306 07565500 L 7,RBUF Ptr to input buffer @SC88264 07574000 LA 0,FFDSP @SC88264 07574080 KCALL FSPEC,FILNAM Copy chosen name into buffer @SC88264 07574160 L 2,RBUF @SC88264 07574240 LR 3,15 End of string @SC88264 07574320 SR 3,2 Get length of string @SC88264 07574400 ST 3,RBUFL @SC88264 07574480 LA 15,ETOAD Standard table @SC89301 07574560 BAL 14,TRANSLAT Convert to ASCII @SC88264 07574640 BAL 9,ENCODEN Copy into packet buffer @SC88264 07574720 BAL 2,SENDACKL @SC88264 07574800 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 9,RECDNST From now on accept D only @SC90037 07580010 CR 8,9 Already seen a D packet? @SC90037 07580020 BE RECDATN Yes, handle routinely @SC90037 07580030 LR 8,9 No, 1st open file @SC90037 07580040 TM RFLG,RRJC File rejected? @SC90037 07580050 BO RECRJX Yes, ignore all data @SC90037 07580060 OPENF O,FILNAM,FILFDB,FILPTR,E=RECRER @SC86295 07580070 USING FDBD,1 @SC86295 07580080 L 2,FABLRTR Get effective record length @SC88120 07580090 ST 2,FSIZE Copy LRECL @SC86295 07580100 MVC FRECF,FDBRCF Save info @SC86295 07580110 DROP 1 @SC86295 07580120 TM FL1,BINF @SC88120 07580130 BO RECMAXO Binary, just fold at LRECL @SC88120 07580140 CLI TRNCFL,C'H' Test: F, H, or T @SC88120 07580150 BL RECMAXO F => fold at LRECL @SC88120 07580160 LA 2,1(2) Assume H => abort at LRECL+1 @SC88120 07580170 BE RECMAXO @SC88120 07580180 ICM 2,8,LOBIT+3 T => fold at "infinity", but trunc@SC88120 07580190 RECMAXO ST 2,MAXOUT @SC88120 07580200 BAL 14,RDWSET Check for special format @SC86295 07580210 ICM 0,15,FILFSIZ Expected size, if known @SC90037 07580220 BZ RECDATN Not known, proceed @SC90037 07580230 OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJL Check disk space@SC90037 07580240 RECDATN DS 0H @SC90037 07580250 TM RFLG,RRJC File rejected? @SC89218 07580300 BO RECRJX Yes, ignore all data @SC90033 07580600 KCALL DECODE,E=RECABR Decode and write to file @SC86316 07581000 RECDAK BAL 2,SENDACK Send an ack @SC86149 07582000 B RECDAT 07583000 * 07584000 RECSCN LR 7,6 Start one before number @SC90037 07584030 RECSCL CLI 0(7),ACOM Look for comma @SC90037 07584060 BER 14 Found one @SC90037 07584090 CR 7,5 @SC90037 07584120 BNLR 14 Already at end of string @SC90037 07584150 LA 7,1(,7) @SC90037 07584180 B RECSCL Keep looking @SC90037 07584210 * 07584240 RECALKP LTR 7,7 @SC90037 07584270 BNP RECRJC No value at all. Give up @SC90037 07584300 IC 4,0(,6) Get value code @SC90037 07584330 LA 6,1(,6) Advance scan ptr over code char @SC90037 07584360 BCTR 7,0 Length of stuff left @SC90037 07584390 B CLKP Dispatch on value, table at (2) @SC90037 07584420 * 07584450 RECAMJ NI FL1,255-BINF Set it Text @SC90037 07584480 MVI TYPFIL,C'T' @SC90037 07584510 LTR 7,7 Any more stuff? @SC90037 07584540 BZR 14 No, assume AMJ @SC90037 07584570 C 7,F2 Yes, had better be AMJ! @SC90037 07584600 BNE RECRJC Isn't AMJ, give up @SC90037 07584630 CLC 0(2,6),=AL1(AM,AJ) @SC90037 07584660 BNE RECRJC Isn't AMJ, give up @SC90037 07584690 BR 14 Ok @SC90037 07584720 * 07584750 RECCKA L 5,ARDATA Attributes @SC88273 07585000 L 3,DATL Get length @SC86316 07587000 AR 3,5 Ptr to end @SC88273 07588000 MVI ERRNUM,ERRIPS In case of error @SC86316 07591000 RECCKL CR 5,3 Another attribute? @SC86316 07592000 BNL RECDAK No, done @SC86316 07593000 TM RFLG,RRJC File rejected? @SC90033 07593300 BO RECDAK Yes, ignore further attributes @SC90033 07593600 UNCHR 4,0(5),REASON Get code @SC90037 07594000 BNP RECABR Invalid: code must be >0 @SC90037 07594500 UNCHR 7,1(5) Get length of value @SC88273 07595000 BM RECABR Invalid: length was <0 @SC86316 07599000 LA 6,2(5) Space over code+length @SC88273 07600000 LA 5,0(7,6) Next field @SC86316 07601000 CR 5,3 Does it match? @SC86316 07602000 BH RECABR Overflows data @SC86316 07603000 LR 14,4 @SC90037 07603090 BCTR 14,0 Bit index for this attribute @SC90037 07603180 SRDL 14,3 Get byte index @SC90037 07603270 SRL 15,29 And bit remainder @SC90037 07603360 LA 1,X'80' @SC90037 07603450 SRL 1,0(15) Convert to bit mask @SC90037 07603540 IC 15,ATFLG(14) Load attribute flags @SC90037 07603630 NR 15,1 Honor this attribute? @SC90037 07603720 BZ RECCKL No, just ignore it @SC90037 07603810 BAL 2,CLKP @SC86316 07604000 RECLNCOD DC AL1(01),AL3(RECALN) ! - File length @SC90037 07605000 DC AL1(02),AL3(RECATP) " - Type @SC90037 07605100 DC AL1(09),AL3(RECAAC) ) - Access @SC90037 07605200 DC AL1(10),AL3(RECAEN) * - Encoding @SC90037 07605300 DC AL1(11),AL3(RECADI) + - Disposition @SC90037 07605400 DC AL1(15),AL3(RECAFM) / - Format @SC90037 07605500 DC X'0',AL3(RECCKL) Other @SC86316 07606000 * Access attribute @SC90037 07606020 RECAAC BAL 2,RECALKP @SC90037 07606040 DC AL1(AA),AL3(RECAAA) Append @SC90037 07606060 DC AL1(AN),AL3(RECCKL) Normal (obey user) @SC90037 07606080 DC AL1(AS),AL3(RECAAS) Supersede @SC90037 07606100 DC AL1(00),AL3(RECRJC) unknown, reject @SC90037 07606120 RECAAA OI FILFLGS,APPN Append @SC90037 07606140 B RECCKL @SC90037 07606160 RECAAS NI FILFLGS,255-APPN Don't append @SC90037 07606180 B RECCKL @SC90037 07606200 * Format attribute @SC90037 07606220 RECAFM BAL 14,RECSCN Check for comma @SC90037 07606240 SR 7,6 Length of extra stuff @SC90037 07606260 BAL 2,RECALKP @SC90037 07606280 DC AL1(AA),AL3(RECAFA) ASCII @SC90037 07606300 DC AL1(AD),AL3(RECAFD) D (binary) @SC90037 07606320 DC AL1(AF),AL3(RECAFF) Fixed (binary) @SC90037 07606340 DC AL1(AM),AL3(RECLRC) LRECL @SC90037 07606360 DC AL1(AV),AL3(RECAFD) V (binary) @SC90037 07606380 DC AL1(00),AL3(RECRJC) ? @SC90037 07606400 RECAFA BAL 14,RECAMJ Set it Text @SC90037 07606420 B RECALP @SC90037 07606440 RECAFF LA 4,AB Plain old Binary @SC90037 07606460 RECAFD OI FL1,BINF Binary selected @SC90037 07606480 IC 4,ATOED(4) Ok, set file type as well @SC90037 07606500 STC 4,TYPFIL @SC90037 07606520 RECALP BAL 14,RECSCN Look for comma @SC90037 07606540 LA 6,1(,7) Skip over comma for next piece @SC90037 07606560 CR 6,5 @SC90037 07606580 BNL RECCKL Ran out of attribute stuff @SC90037 07606600 B RECAFM Do next piece @SC90037 07606620 RECLRC BAL 14,RECSCN Look for comma @SC90037 07606640 SR 7,6 Length of number string @SC90037 07606660 LR 14,7 Convert number to EBCDIC @SC90037 07606680 BNP RECRJC Impossible, reject it @SC90037 07606700 BCTR 14,0 @SC90037 07606720 EX 14,RECTRAT @SC90037 07606740 BAL 14,GETNUM Get number @SC90037 07606760 B RECRJC Not proper numeric string @SC90037 07606780 LTR 0,0 Validate LRECL @SC90037 07606800 BNP RECRJC No good @SC90037 07606820 STCM 0,3,FILLRC Ok, use it @SC90037 07606840 B RECALP Look for another subattribute @SC90037 07606860 * Length attribute @SC90037 07606880 RECALN LTR 14,7 Copy length @SC88273 07607000 BNP RECRJC No good @SC88273 07607300 BCTR 14,0 @SC88273 07607600 EX 14,RECTRAT @SC88273 07607900 BAL 14,GETNUM Get file length @SC88273 07608200 B RECRJC @SC88273 07608500 ST 0,FILFSIZ Save expected size @SC90037 07609000 OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJC Check disk space@SC90037 07610000 B RECCKL Ok, keep looking @SC86316 07612000 RECTRAT TR 0(,6),ATOED Convert to EBCDIC for decoding @SC88273 07612500 * Type attribute @SC90037 07612508 RECATP BAL 2,RECALKP @SC90037 07612516 DC AL1(AA),AL3(RECATA) ASCII @SC90037 07612524 DC AL1(AB),AL3(RECATB) Binary @SC90037 07612532 DC AL1(00),AL3(RECRJC) Don't allow any other @SC90037 07612540 RECATA BAL 14,RECAMJ Set it Text @SC90037 07612548 B RECCKL Ok @SC90037 07612556 RECATB TM FL1,BINF Already binary? @SC90037 07612564 BO RECCKL Yes, that's fine @SC90037 07612572 OI FL1,BINF No, set it binary @SC90037 07612580 MVI TYPFIL,C'B' And choose simple binary @SC90037 07612588 B RECCKL @SC90037 07612596 * Disposition attribute @SC90037 07612604 RECADI BAL 2,RECALKP @SC90037 07612612 DC AL1(AA),AL3(RECCKL) Archive (not implemented) @SC90037 07612620 DC AL1(AM),AL3(RECADM) Mail @SC90037 07612628 DC AL1(AP),AL3(RECADP) Print @SC90037 07612636 DC AL1(AS),AL3(RECADS) Submit as batch job @SC90037 07612644 DC AL1(00),AL3(RECRJC) unknown, reject @SC90037 07612652 * 07612660 RECADM LTR 7,7 Any recipients given? @SC90037 07612668 BNP RECRJC No, that's bad @SC90037 07612676 BAL 2,RECAD1 @SC90037 07612684 DC AL4(KMAIL1),AL2(L'KMAIL1,L'KMAIL2,L'KMAIL3) @SC90037 07612692 RECADP BAL 2,RECAD1 @SC90037 07612700 DC AL4(KPRNT1),AL2(L'KPRNT1,L'KPRNT2,L'KPRNT3) @SC90037 07612708 RECADS BAL 2,RECAD1 @SC90037 07612716 DC AL4(KSUBM1),AL2(L'KSUBM1,L'KSUBM2,L'KSUBM3) @SC90037 07612724 RECAD1 ICM 0,15,0(2) Get prototype ptr @SC90037 07612732 LH 1,4(,2) Get length of 1st piece @SC90037 07612740 LA 14,CMD @SC90037 07612748 ST 14,ADR Save ptr to command buffer @SC90037 07612756 ST 1,LEN Save length of 1st piece @SC90037 07612764 LR 15,1 @SC90037 07612772 MVCL 14,0 Copy first piece to buffer @SC90037 07612780 ST 0,RECDSPTR Save ptr to 2nd piece @SC90037 07612788 LR 4,7 Save length of options @SC90037 07612796 LA 0,FFDSP @SC90037 07612804 LR 7,14 Feed output ptr to FSPEC @SC90037 07612812 KCALL FSPEC,FILNAM Copy filespec to buffer @SC90037 07612820 LR 14,15 New output ptr @SC90037 07612828 LR 7,4 Retrieve option length @SC90037 07612836 L 0,RECDSPTR Get ptr to 2nd piece @SC90037 07612844 LH 1,6(,2) Get length of 2nd piece @SC90037 07612852 LR 15,1 @SC90037 07612860 MVCL 14,0 Copy 2nd piece to buffer @SC90037 07612868 LR 4,14 Save ptr to insert @SC90037 07612876 LR 15,7 @SC90037 07612884 MVCL 14,6 Copy attribute stuff to buffer @SC90037 07612892 TR 0(94,4),ATOED Convert to EBCDIC @SC90037 07612900 LH 1,8(,2) Get length of 3rd piece @SC90037 07612908 LR 15,1 @SC90037 07612916 MVCL 14,0 Copy 3nd piece to buffer @SC90037 07612924 ST 14,RECDSPTR Save ptr to end of command @SC90037 07612932 OI FL4,UCMD @SC90037 07612940 KCALL SUPFNC,3,E=RECRJC Test if facility exists @SC90037 07612948 B RECCKL @SC90037 07612956 * 07613000 * Encoding attribute @SC90037 07613100 RECAEN BAL 2,RECALKP @SC90037 07613200 DC AL1(AA),AL3(RECCKL) ASCII @SC90037 07613300 DC AL1(AC),AL3(RECAEC) Special character set @SC90040 07613350 DC AL1(AE),AL3(RECATB) Binary @SC90037 07613400 DC AL1(00),AL3(RECRJC) Don't allow any other @SC90037 07613500 * 07613600 RECAEC LTR 7,7 @SC90040 07613630 BNP RECCKL Character set not specified @SC90040 07613660 KCALL TBLATT,E=RECRJC @SC90040 07613690 B RECCKL @SC90040 07613720 * 07613750 RECRJL MVC REASON,RECLNCOD Because of length @SC90037 07614000 RECRJX L 9,ASDATA Output buffer @SC90037 07614100 MVI 0(9),AX Reject this file @SC90033 07614300 MVC DATL,F1 @SC90033 07614600 B RECRJ2 Now accept only EOF pkt @SC90033 07614900 RECRJC L 9,ASDATA Output buffer @SC86316 07615200 MVI 0(9),AN Mark it rejected @SC88273 07616000 TOCHR 0,REASON,1(9) Copy attribute code to response @SC90037 07617000 MVC DATL,F2 Data = 'N' + code @SC86316 07620300 RECRJ2 DS 0H @SC90033 07620600 OI RFLG,RRJC Mark it rejected @SC86316 07621000 BAL 2,SENDACKL Acknowledge @SC86316 07623000 B RECDAT And wait for EOF @SC86316 07624000 * 07625000 RECEOF TM RFLG,RRJC File rejected? @SC89218 07626000 BO RECDISC Yes, discard @SC89218 07626300 CLC DATL,F1 @SC89218 07626600 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 RECDISC DS 0H @SC89218 07630500 CLOSF FILPTR Close the file @SC86135 07631000 TM FILFLGS,APPN Appending to old file? @SC90033 07632000 BO RECKEP Yes, keep what we got @SC86225 07633000 TM FL1,KEEP @SC90037 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 ICM 1,15,WBUFL Check length in buffer @SC88120 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 MVI ERRNUM,ERRNOE No error yet @SC88092 07644300 ICM 1,15,RECDSPTR Any special disposition? @SC90037 07644330 BZ RECACK @SC90037 07644360 LA 14,CMD @SC90037 07644390 ST 14,ADR Save ptr to command buffer @SC90037 07644420 SR 1,14 Get length of command @SC90037 07644450 ST 1,LEN @SC90037 07644480 OI FL4,UCMD @SC90037 07644510 KCALL SUPFNC,3,E=RECDSPX Disposition failed @SC90037 07644540 RECACK KCALL ACCTNG Save code in table @SC89218 07644600 BAL 14,RECRSTA Restore attributes @SC90037 07644800 BAL 2,SENDACK Send an ACK @SC89218 07645000 BAL 14,INCRSEQ 07646000 NI FL1,255-ROVR Only change first file 07647000 B RECFIL 07648000 * 07649000 RECBRK MVI ERRNUM,ERRTRC Receive cancelled? @SC90033 07650000 TM RFLG,RTRC+RRJC @SC90033 07650200 BNZ RECERP Yes, send an error packet @SC90033 07650400 TM FL2,SRV Server will read another command @SC90033 07650600 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 B RECRET @SC89218 07658000 * 07658200 RECDSPX MVI ERRNUM,ERRDSP Code for disposition failure @SC90037 07658400 B RECABR @SC90037 07658600 * 07659000 RECNER LA 1,DSKSTT Name error, point to dummy block @SC88053 07662300 MVC FABCOMM-FABD(8,1),=CL8'Collisn' Indicate type @SC88053 07662600 RECRER ERRF , Cannot write. Analyze error @SC87338 07663000 RECABR CLOSF FILPTR Close open file @SC86135 07664000 KCALL ACCTNG Save code in table @SC88092 07664500 BAL 14,RECRSTA Restore attributes @SC90037 07664700 RECERP KCALL ERPACK Send error packet @SC90033 07665000 RECRET ICM 0,15,RECTRC Any records truncated? @SC87268 07666000 LA 0,4 Indicate return from RECEIVE @AB89191 07666500 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 * Restore file attribute defaults from saved values @SC90037 07671100 RECRSTA XC FL1,FL1SV Restore flags @SC90037 07671200 NI FL1,255-BINF-REN-KEEP Restore only these flags @SC90037 07671300 XC FL1,FL1SV @SC90037 07671400 MVC TYPFIL,TYPFSV Restore file type @SC90037 07671500 MVC FILRCF,RCFSV Restore record format @SC90037 07671600 MVC FILLRC,LRCSV Restore record length @SC90037 07671700 BR 14 @SC90037 07671800 * Receive mode Rpack interpret input tables 07672000 RECINST DC AL1(AS),AL3(0) Micro sent parm 07673000 DC XL1'FF',AL3(RECABR) Stop @SC88074 07673500 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 XL1'FF',AL3(RECABR) Stop @SC88074 07677500 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 XL1'FF',AL3(RECABR) Stop @SC88074 07681500 DC AL1(00),AL3(RECABR) Error return 07682000 LOCALS , @SC86295 07683000 RECDSPTR DS F Saved length of command @SC90037 07683500 RFLG DS X Local flags @SC86295 07684000 RTRC EQU X'80' Other side cancelled @SC86295 07685000 RRJC EQU X'40' I cancelled @SC86316 07686000 FL1SV DS X Saved global flags @SC90037 07686200 TYPFSV DS C Saved file type @SC90037 07686400 RCFSV DS C Saved record format @SC90037 07686600 LRCSV DS H Saved record length @SC90037 07686800 RECEIV EXIT 07687000 TITLE 'ACCTNG Routine - save statistics for a transfer' 07687030 ACCTNG ENTER 07687060 MVC ERRLAST(2),ERRNUM Save error codes for file @SC89218 07687070 LM 2,3,DSKTOT Current byte count @SC88092 07687090 SL 3,SSVDSK+4 Get difference from this file @SC88092 07687120 BC 3,*+6 @SC88092 07687150 BCTR 2,0 @SC88092 07687180 AL 3,=F'512' Round up @SC88092 07687210 BC 12,*+8 @SC88092 07687240 AL 2,F1 @SC88092 07687270 SL 2,SSVDSK @SC88092 07687300 SRDL 2,10 Convert to Kbytes @SC88092 07687330 MVC SSVDSK(8),DSKTOT @SC88092 07687360 TS ACCTFLG See if file is current @SC89218 07687370 BNZ RTRN0 No, do nothing @SC89218 07687380 ICM 2,15,NSENT Calculate offset into table @SC88092 07687390 BZ RTRN Must not be counting @SC88092 07687420 MH 2,FLFID1+2 @SC88092 07687450 A 2,TSENT Ptr to next name slot @SC88092 07687480 S 2,F5 @SC88092 07687510 CLC F0,0(2) Already set? @SC88092 07687540 BNE RTRN Yes, don't mess it up @SC88092 07687570 STCM 3,15,0(2) Save file size in Kbytes @SC88092 07687600 MVC 4(1,2),ERRNUM Save error code for file @SC88092 07687630 B RTRN0 @SC88306 07687640 * 07687643 * Copy file name from (R1) to file table, if possible; update count. 07687646 ACCTST ENTER ALT @SC88306 07687649 MVI ACCTFLG,0 Indicate file is current @SC89218 07687650 L 3,NSENT Number of files sent so far @SC88306 07687652 LA 4,1(,3) Incr number of sent files @AB89191 07687655 ST 4,NSENTAC Number of files for acctng @AB89191 07687656 C 3,=A(MAXNSENT) Did we send more than countable? @SC88306 07687658 BNL RTRN0 Yes, cannot keep track of 'em @SC88306 07687661 MH 3,FLFID1+2 Times length of items @SC88306 07687664 A 3,TSENT Loc in sent-table @SC88306 07687667 MVC 0(LFID,3),0(1) Save fn ft sent @SC88306 07687670 XC LFID(5,3),LFID(3) Clear error code @SC88306 07687673 ST 4,NSENT Keep it @SC88306 07687679 B RTRN0 @SC88306 07687682 LOCALS , @SC88092 07687690 ACCTNG EXIT , @SC88092 07687720 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 CLI TRMTP,C'V' @SC89020 07785300 BE *+12 TTY ==> limited @SC89020 07785600 CLI TRMTP,C'T' @SC87166 07786000 BNE SPAREHL Not TTY ==> not limited @SC90010 07787000 C 5,AMAXWT @SC86205 07788000 BNH *+8 @SC86205 07789000 L 5,AMAXWT Biggest we can send @SC86205 07790000 SPAREHL S 5,F3 Extended header length @SC90010 07790200 CLI S1HND,0 @SC90010 07790400 BE SPARNY Ok, no handshake @SC90010 07790600 BCTR 5,0 Deduct one for handshake @SC90010 07790800 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'V' @SC89020 07856300 BE *+12 TTY ==> limited @SC89020 07856600 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'V' @SC88323 07870300 BE RPARSTT VTAM TTY @SC88323 07870600 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 BNE ENC8B Can use 8bit quoting, do it @SC89072 07938090 TM SPRTY,DAT8 Can't: see if 8-bit channel @SC89072 07938180 BO ENCCTL Yes, that's ok too @SC89072 07938270 MVI ERRNUM,ERRPTY No, can't send this byte! @SC89072 07938360 LA 15,1 @SC89072 07938450 B ENCRET Save length, in case ERPACK loop @SC89072 07938540 ENC8B DS 0H @SC89072 07938630 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 * Exit: ERRNUM left unchanged unless there is an error. 08014500 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 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),ATOED No, must be 5-byte ASCII prefix @SC89301 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 BL DECMORE No, keep appending @SC88120 08070000 KCALL OUTBUF,(9),E=RTRN1 Yes, write buffer @SC88120 08070080 SR 9,9 Reset count and output pointer @SC88120 08070160 L 1,WBUF @SC88120 08070240 TM FL1,BINF @SC88120 08070320 BO DECPUT Binary always folds, no problem @SC88120 08070400 CLI CUR,CR Exactly full just in time? @SC88120 08070480 BE DECIGN Yes, don't create empty line @SC88120 08070560 LA 0,1 Other, this is called folding @SC88120 08070640 A 0,RECFLD @SC88120 08070720 ST 0,RECFLD @SC88120 08070800 B DECPUT Ok, now copy the new character @SC88120 08070880 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,ALF @SC89301 08075000 BNE DECTAB Not an LF 08076000 CLI PREV,CR 08077000 BE DECIGN A cr/lf together = ignre the LF 08078000 DECWRT KCALL OUTBUF,(9),E=RTRN1 Write buffer @SC88120 08080000 SR 9,9 Reset length to resume decoding 08081000 L 1,WBUF Reset pointer also 08082000 B DECIGN 08085000 * 08086000 DECTAB TM FL2,TABS 08087000 BZ DECCTLZ Skip if not expanding tabs 08088000 CLI CUR,AHT @SC89301 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,ASUB @SC89301 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 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,=A(ERRTAB) Pointer address @SC89215 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),ETOAD ASCII it @SC89301 08163000 LA 8,F0 Point to null list @SC89072 08163500 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 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 * ERRNUM set if error found, unchanged otherwise @SC89219 08253500 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 BC 12,*+8 @SC88092 08259000 AL 14,F1 @SC86295 08260000 STM 14,15,TINTOT Save new count @SC86295 08261000 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 MVI RPKERN,ERRSOH No start-of-packet found @SC89219 08269500 RPKBEG SR 3,3 Use this for IC's 08270000 L 14,ARPKT Point to recv buffer @SC89065 08270500 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 @SC89219 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 MVI RPKERN,ERRBPC SOH found - cksm may be bad @SC89219 08279500 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 NI RTYPE,X'7F' Assure conventional ASCII char @SC88074 08288500 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 RPKBEG Err if chksums mismatch @SC89219 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 received? @SC89219 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 CLC RMARK,0(8) @SC89219 08334300 BE RPKBEG Found another mark, start over @SC89219 08334600 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 CLC RMARK,0(8) @SC89065 08339300 BE RPKBEG Found another mark, start over @SC89065 08339600 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 RPKBEG Skip if chksums don't match @SC89219 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 RPKBEG Skip if chksums don't match @SC89219 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 CR 8,7 @BS86001 08371000 BL RPKBEG More stuff, see if it's a packet @BS86001 08372000 RPKERR DS 0H @SC89219 08372020 L 8,APKT Ptr to packet @SC88074 08372040 MVC STOPBUF,0(8) Copy to work area @SC88074 08372080 LA 8,STOPBUF @SC88074 08372120 L 7,RCVPKL @SC88074 08372160 AR 7,8 Ptr to packet end in work area @SC88074 08372200 CLC RMARK,0(8) @SC88074 08372240 BE RPKNAK Assume bad packet if SOH present @SC88074 08372280 BCTR 7,0 @SC88074 08372320 CLC REOL,0(7) @SC88074 08372360 BNE *+6 @SC88074 08372400 BCTR 7,0 Don't count closing EOL @SC88074 08372440 TR STOPBUF,ATOED @SC89301 08372480 TR STOPBUF,UPCASE @SC88074 08372520 CLI 0(8),C'S' @SC88074 08372560 BE *+8 @SC88074 08372600 LA 8,1(8) Allow one extra character in front@SC88074 08372640 S 7,F3 Back len(STOP) - 1 @SC88074 08372680 CR 7,8 @SC88074 08372720 BNE RPKNAK Doesn't match exactly @SC88074 08372760 CLC =C'STOP',0(8) @SC88074 08372800 BE RPKSTP Exact match @SC88074 08372840 RPKNAK MVI RTYPE,AQ Return a Q pkt 08373000 RPKRET RET 08374000 * @SC88074 08374100 RPKSTP OI FL3,ZPRO Indicate stopping protocol mode @SC88074 08374200 MVI ERRNUM,ERRTRC Transfer cancelled, if any @SC88074 08374300 MVI RTYPE,X'FF' Special packet type for quitting @SC88074 08374400 RET @SC88074 08374500 LOCALS , @SC86295 08375000 STOPBUF DS CL8 Work area @SC88074 08375100 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 HTBL 00,00,10,81,21,02,31,83,42,04,52,85,63,06,73,87 @SC89268 08403000 HTBL 84,08,94,89,A5,0A,B5,8B,C6,0C,D6,8D,E7,0E,F7,8F @SC89268 08404000 * 08405000 CRCTAB2 HTBL 00,00,11,89,23,12,32,9B,46,24,57,AD,65,36,74,BF @SC89268 08406000 HTBL 8C,48,9D,C1,AF,5A,BE,D3,CA,6C,DB,E5,E9,7E,F8,F7 @SC89268 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'V' @SC88323 08418300 BE RIOTTY Go if VTAM TTY @SC88323 08418600 LA 5,OFF80 Turn off all X'80' bits @SC86316 08421000 TM RPRTY,DAT8 Unless 8-bit line @SC88288 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 ICM 6,15,KSYSETOA Possible overriding table @SC88302 08441100 BZ *+6 @SC88302 08441200 LR 5,6 Use it instead @SC88302 08441300 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 SR 8,8 Assume raw not wanted @SC88168 08461000 TM DBGFLG,DBGRW @SC88168 08461100 BO *+8 @SC88168 08461200 LA 8,ATOE Raw wanted @SC88168 08461300 CR 3,8 Correct type (raw/EBCDIC)? @SC88168 08461400 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 TM DBGFLG,DBGSV SAVE requested? @SC88168 08478300 BZR 9 No, skip closing log file @SC88168 08478600 SAVEF LOGPTR Update disk directory @SC88168 08478900 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 RTYPE,0 Clear previous received packet @SC88074 08485500 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 LA 9,0(5,2) Save start of ASCII stuff @SC88288 08511500 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'V' @SC88323 08519300 BE SIOTTY Go if VTAM TTY @SC88323 08519600 LR 3,2 Copy end of transmission @SC88288 08521500 SR 2,1 Total length @SC86154 08522000 ST 2,S1WRPL+4 Store len in CCW @SC86154 08523000 LR 2,9 Start of ASCII stuff @SC88288 08523100 SR 3,2 Length @SC88288 08523200 LA 15,ON80 Set high bits @SC88288 08523300 TM SPRTY,DAT8 Unless 8-bit line @SC88288 08523400 BO *+8 Yes, 8-bit downloading @SC88288 08523500 BAL 14,TRANSLAT @SC88288 08523600 L 4,=A(SCRNIO) I/O routine for fullscreen @SC89215 08524000 LA 5,S1WRPL 1st plist @SC87275 08525000 SIOGO LM 7,8,0(5) @SC87275 08526000 LM 14,15,TOUTOT Update send count @SC88006 08526100 ALR 15,8 @SC88006 08526200 BC 12,*+8 @SC88092 08526300 AL 14,F1 @SC88006 08526400 STM 14,15,TOUTOT Save new count @SC88006 08526500 LR 6,8 Set up for log routine @SC88168 08526700 BAL 9,RIORAW Log it @SC86316 08527000 NI FL5,255-NAK0 Something sent now @SC90037 08527500 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'V' @SC88323 08539300 BE SIOCOM No problem if TTY @SC88323 08539600 * 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 DS 0H @SC88100 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 ICM 15,15,KSYSATOE Possible overriding table @SC88302 08558300 BNZ SIOTRNT @SC88302 08558600 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 SIOTRNT DS 0H @SC88302 08562500 LR 3,2 Length @SC87281 08563000 LR 2,1 @SC86202 08564000 BAL 14,TRANSLAT Do the translate @SC86202 08565000 L 4,=A(TERMIO) I/O routine for TTY @SC89215 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 AL1(RTA),X'4040',C' ' Blanks to end of screen @SC88139 08574000 SIOMSL EQU *-SIOMSGXX @TB87009 08575000 * For setting high bits... @SC88288 08575050 ON80 DC X'808182838485868788898A8B8C8D8E8F' @SC88288 08575100 DC X'909192939495969798999A9B9C9D9E9F' @SC88288 08575150 DC X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF' @SC88288 08575200 DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' @SC88288 08575250 DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' @SC88288 08575300 DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' @SC88288 08575350 DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' @SC88288 08575400 DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' @SC88288 08575450 DC X'808182838485868788898A8B8C8D8E8F' @SC88288 08575500 DC X'909192939495969798999A9B9C9D9E9F' @SC88288 08575550 DC X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF' @SC88288 08575600 DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' @SC88288 08575650 DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' @SC88288 08575700 DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' @SC88288 08575750 DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' @SC88288 08575800 DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' @SC88288 08575850 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 MVI RTYPE,AN No packet received yet @SC89263 08591500 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 FL5,NAK0 Send NAK during retry, if any @SC90037 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'V' @SC88323 08610300 BE INTINITY Go if TTY @SC88323 08610600 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 FL5,NAK0 Will we receive? @SC90037 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 NI FL3,255-ZPRO Now stopping protocol mode @SC88074 08644000 TM FL2,PROTO Was line open? @SC88074 08644500 BZ INTINIR No @SC86295 08645000 LA 0,2 @SC86295 08646000 L 15,=A(TERMIO) @SC89215 08647000 CLI TRMTP,C'T' @SC87300 08648000 BE INTINIK Go if TTY @SC87300 08649000 CLI TRMTP,C'V' @SC88323 08649300 BE INTINIK Go if VTAM TTY @SC88323 08649600 L 15,=A(SCRNIO) @SC89215 08652000 INTINIK KCALL (15) Release line @SC87300 08653000 KCALL SETMSG,3 @SC86316 08654000 MVC S1HND,SVHND Restore handshake character @SC87343 08655000 NI FL2,255-PROTO End protocol mode @SC88035 08655500 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 1,15,FLNOPTS Get record counter @SC89218 08715100 AL 1,F1 @SC89218 08715200 STCM 1,15,FLNOPTS Update record counter @SC89218 08715300 CLM 1,15,FLNOPTS+4 Passed end? @SC89218 08715400 BH IBFEOF Yes, quit now @SC89218 08715500 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 BC 12,*+8 @SC88092 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),ETOAD @SC89301 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 C 0,F1 @SC88340 08760100 BE IBFTRUNC Record of 1 blank always converted@SC88340 08760200 CLI FRECF,C'F' @SC88050 08760300 BE IBFTRUNC Always trim if fixed length @SC88349 08760600 CLC RMARG,F0 @SC88349 08760700 BE IBFTRUZ Don't trim if no fixed rt. margin @SC88349 08760800 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 IBFTRUZ BCTR 9,0 Point to last char of record @SC88050 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 * Entry: R1=length of buffer (which starts where WBUF points) 08783300 * Exit: R15=0 if ok, other if error (ERRNUM set) 08783600 OUTBUF ENTER 08784000 LR 9,1 Save buffer length @SC88120 08785000 L 6,FSIZE Use to hold lrecl @SC88120 08786000 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 LA 15,15 Suitable disk error @SC86151 08803000 CR 1,9 Match? @SC86151 08804000 BE OBFLEN Ok, do it @SC88053 08805000 L 1,FILPTR Ptr to disk FAB @SC88053 08805500 MVC FABCOMM-FABD(8,1),=CL8'Binary' @SC88053 08806000 B OBFERR No, give up @SC88053 08806500 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 CR 9,6 Compare data len. to trunc len. @SC88120 08820000 BE OBFWRT Go if lrecl exactly @SC87268 08824000 BH OBFTRNC Go if must truncate @SC87268 08825000 CLI FRECF,C'F' @SC88120 08825300 BNE OBFWRT Go if variable format @SC88120 08825600 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 CLI TRNCFL,C'H' Do we halt here? @SC88120 08837200 BNE OBFLRECL Truncation allowed, ok @SC88120 08837400 MVI ERRNUM,ERRRTR Mark error and stop @SC88120 08837600 B RTRN1 @SC88120 08837800 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 BC 12,*+8 @SC88092 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 TITLE 'FOPSTR Routine - test string for file options' 08854000 * Entry: R1->Address of option field, R6->string, R7=length - 1 08855000 * Exit: R15=0 + R6,R7 fixed if ok, R15=1 if error (msg ptrs set up) 08856000 FOPSTR ENTER , @SC89218 08857000 LR 5,1 Save ptr to options @SC89218 08858000 NI FL2,255-FOPTS Clear option flag @SC89218 08859000 MVC 0(8,5),=F'0,-1' Default values @SC89218 08860000 LA 9,0(7,6) Point to last character @SC89218 08861000 LR 1,9 @SC89218 08862000 EX 7,FOPTRT Scan for option starter @SC89218 08863000 BZ RTRN0 Not found, no action @SC89218 08864000 OI FL2,FOPTS Yes, note the fact @SC89218 08865000 PTEXT 'Option error: Missing option(s)' Just in case @SC89249 08866000 CR 1,9 Anything after the starter? @SC89218 08867000 BE FOPERR No, too bad @SC89218 08868000 PTEXT 'Option error: Invalid final delimiter' In case@SC89249 08869000 CLI 0(9),FBRK2 Check ending @SC89218 08870000 BNE FOPERR Wrong one @SC89218 08871000 LR 0,1 @SC89218 08872000 SR 0,6 Length of stuff before options @SC89218 08873000 BCTR 0,0 Length - 1 @SC89218 08874000 LA 6,1(,1) Ptr to option string @SC89218 08875000 RETREG (7,0) Return length-1 as fixed R7 @SC89218 08876000 * Set up loop over line numbers @SC89218 08877000 LA 1,2 @SC89218 08878000 LR 2,5 Ptr to option fields @SC89218 08879000 LA 8,C'-' Delimiter after 1st number @SC89218 08880000 * 08881000 FOPNLP LA 7,1(,9) End of string @SC89218 08882000 SR 7,6 Length remaining @SC89218 08883000 CH 7,*+10 @SC89218 08884000 BNH *+8 @SC89218 08885000 LA 7,15 Max allowed by GETNUM @SC89218 08886000 LR 15,6 Save start of string @SC89218 08887000 BAL 14,GETNUM 1st, returns R15->end of digits @SC89218 08888000 LR 7,15 @SC89218 08889000 SR 7,6 Length of numeric string @SC89218 08890000 BAL 14,GETNUM 2nd, returns number and skips @SC89218 08891000 SR 0,0 Omitted, use -1 @SC89218 08892000 BCTR 0,0 @SC89218 08893000 LA 6,1(,15) Ptr to rest of string @SC89218 08894000 STCM 0,15,0(2) Save result in option field @SC89218 08895000 CLI 0(15),FBRK2 Reached end? @SC89218 08896000 BE FOPNLQ Yes, quit scanning @SC89218 08897000 CLI 0(15),C'_' Reached end of range limits? @SC89218 08898000 BE FOPNLQ Yes, quit scanning @SC89218 08899000 PTEXT 'Option error: Invalid delimiter' @SC89249 08900000 CLM 8,1,0(15) Delimiter for this number? @SC89218 08901000 BNE FOPERR None of these, syntax error @SC89218 08902000 LA 2,4(,2) Advance output ptr @SC89218 08903000 LA 8,C'_' Change delimiter @SC89218 08904000 BCT 1,FOPNLP Get next number @SC89218 08905000 FOPNLQ ICM 1,15,0(5) Check starting line number @SC89218 08906000 S 1,F1 Convert to number to skip @SC89218 08907000 BNM *+6 @SC89218 08908000 SR 1,1 No skipping @SC89218 08909000 STCM 1,15,0(5) @SC89218 08910000 PTEXT 'Option error: Invalid line range' @SC89249 08911000 CLM 1,15,4(5) Check range for order @SC89218 08912000 BNL FOPERR Upper limit smaller! @SC89218 08913000 CR 6,9 Any more option text? @SC89218 08914000 BNL RTRN0 No, all done @SC89218 08915000 * Other options @SC89218 08916000 * 08917000 * 08918000 * Nothing implemented @SC89218 08919000 * 08920000 * Fall through if option not defined @SC89218 08921000 PTEXT 'Option error: Unknown file option(s)' @SC89249 08922000 FOPERR RETREG 3,4 Return msg ptrs as R3, R4 @SC89218 08923000 MVI ERRNUM,ERROPT Error with option(s) @SC89249 08923500 B RTRN1 @SC89218 08924000 * 08925000 FOPTRT TRT 0(,6),FOPBRK Scan for initial character @SC89218 08926000 FOPBRK DC 256X'00' @SC89218 08927000 ORG FOPBRK+FBRK1 @SC89218 08928000 DC X'01' @SC89218 08929000 ORG , @SC89218 08930000 LOCALS , @SC89218 08931000 EXIT , @SC89218 08932000 END KERMIT 08933000