Columbia Kermit

home *** CD-ROM | disk | FTP | other *** search

/ Columbia Kermit / kermit.zip / ibm370 / ik0pro.asm < prev next >

Wrap

Assembly Source File | 2020-01-01 | 241KB | 2,973 lines

*COPY IK0PRO 07500000 CHECKVER IK0PRO,4.3 @SC90072 07500500 TITLE 'SERVER Routine - performs Server mode functions' 07501000 * Exit: ERRNUM set appropriately. 07501500 SERVER ENTER 07502000 LA 0,SRVKFIN @SC86295 07502500 L 1,=A(SRVKCMD) @SC87012 07503000 BAL 14,LOOPS Set up command loop @SC86295 07503500 KCALL INTINI,1,E=SRVXIT Initialize for server @SC87300 07504000 OI FL2,SRV Server is on 07504500 MVI ERRNUM,ERRNOE No errors yet @SC86156 07505000 XC SRVIOS,SRVIOS Clear error count @SC90289 07505500 BAL 8,SRVLUP Set state table @SC86135 07506000 * Server mode Rpack interpret input table @SC86135 07506500 DC AL1(AS),AL3(SRVREC) Micro wants to send a file @SC86135 07507000 DC AL1(AC),AL3(SRVHST) A host command @SC86171 07507500 DC AL1(AI),AL3(0) Micro sent parms @SC86135 07508000 DC AL1(AG),AL3(SRVGEN) A generic command @SC86135 07508500 DC AL1(AK),AL3(SRVKRM) A KERMIT command @SC86158 07509000 DC AL1(AR),AL3(SRVSND) Micro wants to get a file @SC86135 07509500 DC XL1'FF',AL3(SRVSTP) Stop @SC88074 07510000 DC AL1(00),AL3(SRVILL) Error routine @SC86355 07510500 SRVLUP MVI SEQ,0 Reset packet number @SC86135 07511000 TM FL3,ZPRO Must stop? @SC88074 07511500 BO SRVXIT Yes, return immediately @SC88074 07512000 OI FL5,NAK0 Resend NAK during retry @SC90037 07512500 MVC SRVTIM,TIMOUT Save time-out limit @SC86355 07513000 MVC TIMOUT,TIMOSRV Set for server mode @SC90045 07513500 MVC LIMTRY,F5 Error loop 5 times for command @SC86355 07514000 MVC OLDERR,ERRNUM Save for STATUS @SC86158 07514500 MVC SRVIOE,SRVIOS Current error count @SC90289 07515000 XC SRVIOS,SRVIOS Clear count in case no new error @SC90289 07515500 BAL 9,INPUT Read a packet and interpret @SC86295 07516000 MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07516500 KCALL SPARSET Set up for exchange @SC86152 07517000 KCALL SPAR Interpret I packet from other 07517500 KCALL RPAR Reply to the I packet 07518000 BAL 2,SENDACKL Send an ACK, length set 07518500 MVC ERRNUM(2),OLDERR Restore previous error code @SC90059 07519000 B SRVLUP Loop again no matter what 07519500 * 07520000 SRVREC MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07520500 XC SCANPTR,SCANPTR @SC86295 07521000 LA 0,FFRCF @SC86295 07521500 KCALL FSPEC,FILNAM Get filespec @SC86295 07522000 KCALL INTINI,3,E=SRVXIT @SC87300 07522500 KCALL RECEIV Get the file 07523000 B SRVLUP End of file protocol 07523500 * 07524000 SRVSND MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07524500 BAL 9,DECODEN Decode the file name @SC86295 07525000 ICM 0,B'1111',WBUFL decoded name length 07525500 BNP SRVMOP @SC88323 07526000 L 1,WBUF Decoded data 07526500 SRVSNT STM 0,1,SCANPTR @SC86295 07527000 LA 0,FFSND @SC86295 07527500 KCALL FSPEC,IFILE,E=SRVERP Get filespec @SC86295 07528000 XC SCANPTR,SCANPTR @SC86295 07528500 LA 0,FFSND+FFRCF @SC86295 07529000 KCALL FSPEC,JFSPEC,E=SRVERP Get filespec @SC86295 07529500 SRVSNC MVC MSNDPTR,MSNDBUF No extra files @SC88306 07530000 KCALL SEND,0 @SC90239 07530500 B SRVLUP Go around again 07531000 * 07531500 SRVGEN MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07532000 BAL 9,DECODEN Decode the command @SC86295 07532500 ICM 0,15,WBUFL Decoded command length @SC86158 07533000 BNP SRVMOP @SC88323 07533500 MVI ERRNUM,ERRNOE OK so far @SC86171 07534000 BCTR 0,0 Remove command from data length @SC86158 07534500 L 1,WBUF Decoded data @SC86158 07535000 IC 4,0(1) @SC86158 07535500 BAL 2,CLKP Dispatch on command @SC86158 07536000 DC AL1(AC),AL3(SRVCWD) cwd @SC86158 07536500 DC AL1(AD),AL3(SRVDIR) directory @SC86158 07537000 DC AL1(AE),AL3(SRVDEL) erase @SC86158 07537500 DC AL1(AF),AL3(SRVFIN) finish @SC86158 07538000 DC AL1(AH),AL3(SRVHLP) help @SC86158 07538500 DC AL1(AK),AL3(SRVCPY) copy @SC86158 07539000 DC AL1(AL),AL3(SRVFIN) bye @SC86158 07539500 DC AL1(AR),AL3(SRVREN) rename @SC86158 07540000 DC AL1(AT),AL3(SRVTYP) type @SC86158 07540500 DC AL1(AU),AL3(SRVQDS) space @SC86158 07541000 DC AL1(00),AL3(SRVERS) Unknown command @SC86158 07541500 * 07542000 SRVILL MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07542500 CLI ERRNUM,ERRTIE Terminal I/O? @SC90289 07543000 BE SRVERP Yes, not just bad command @SC90289 07543500 SRVERS MVI ERRNUM,ERRUSC Unknown Server command @SC86156 07544000 SRVERP KCALL SUPFNC,5 @SC86158 07544500 KCALL ERPACK Send an error packet @SC86158 07545000 LA 0,1 @SC90289 07545500 AL 0,SRVIOE Old I/O error count @SC90289 07546000 ST 0,SRVIOS New count @SC90289 07546500 CL 0,F5 Lots of consecutive errors? @SC86158 07547000 BL SRVLUP Not yet, OK @SC86158 07547500 B SRVXIT Yes, give up now @SC86158 07548000 * 07548500 SRVMOP MVI ERRNUM,ERRMOP Missing operand @SC88323 07549000 B SRVERP @SC86158 07549500 * 07550000 SRVHST MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07550500 BAL 9,DECODEN Get command for host @SC86171 07551000 BAL 9,SRVGPRW To EBCDIC, start interception @SC86295 07551500 B LUPHST Do it @SC86295 07552000 * 07552500 SRVKRM MVC TIMOUT,SRVTIM Restore timeout setting @SC86355 07553000 BAL 9,DECODEN Get command for Kermit @SC86295 07553500 BAL 9,SRVGPRW To EBCDIC, start interception @SC86295 07554000 B LUPTOK Parse command @SC87012 07554500 * 07555000 SRVKF0 MVI ERRNUM,ERRNOE No errors @SC86295 07555500 SRVKFIN MVC OLDERR,ERRNUM Save error code @SC86295 07556000 KCALL SUPFNC,2 Clean up after interception @SC86295 07556500 SRVKFTX LM 4,5,TXTPTR @SC86158 07557000 SR 5,4 Any? @SC86158 07557500 LA 2,SRVLUP Return adr @SC86158 07558000 BNP SENDACK No, just ACK command @SC86158 07558500 LA 3,1023(5) Round up @SC86158 07559000 SRA 3,10 Convert to kbytes @SC86158 07559500 ST 3,KBYTES @SC86158 07560000 OI FL4,SFM+TXT @SC86158 07560500 XC FLNOPTS(LFOPTS),FLNOPTS @SC91116 07561000 MVC MSNDPTR,MSNDBUF No extra files @SC88306 07561500 KCALL SEND,0 Send all @SC90239 07562000 CLI ERRNUM,ERRNOE Problem with SEND? @SC86295 07562500 BNE SRVLUP Yes, remember that @SC86295 07563000 MVC ERRNUM(2),OLDERR No, use code from commands @SC90033 07563500 B SRVLUP Get another command @SC86158 07564000 * 07564500 SRVTYP OI FL4,TXT Send disk file to remote display @SC86158 07565000 BAL 9,SRVGSTR Get file-spec @SC86295 07565500 B SRVMOP None, error @SC88323 07566000 B SRVSNT @SC86158 07566500 * 07567000 * Send remote help message to other system @SC86158 07567500 SRVHLP LA 4,RMHTXT Where to copy HELP TEXT from @SC86158 07568000 LA 5,RMHTXTZ End of text @SC86158 07568500 STM 4,5,TXTPTR @SC86158 07569000 B SRVKFTX @SC86158 07569500 * 07570000 SRVDIR BAL 3,SRVUTL @SC86295 07570500 DC AL1(13,4+1) Wild matches @SC86295 07571000 * 07571500 SRVDEL BAL 3,SRVUTL @SC86295 07572000 DC AL1(14,0+1) No wild matches @SC86295 07572500 * 07573000 SRVREN BAL 3,SRVUTL @SC86295 07573500 DC AL1(15,4+2) Wild matches @SC86295 07574000 * 07574500 SRVCPY BAL 3,SRVUTL @SC86295 07575000 DC AL1(16,0+2) No wild matches @SC86295 07575500 * 07576000 SRVCWD BAL 9,SRVGSTR Get operand @SC86295 07576500 B SRVMOP @SC88323 07577000 BAL 9,SRVGPRM Convert to plist @SC86295 07577500 MVI ERRNUM,ERRFNF In case of error @SC86158 07578000 KCALL CWDSET,E=SRVERP @SC86158 07578500 B SRVKF0 No errors @SC86295 07579000 * 07579500 SRVQDS BAL 9,SRVGSTR Extract letter @SC86295 07580000 LA 0,0 None, use default @SC86158 07580500 BAL 9,SRVGPRM @SC86295 07581000 B LUPSPA @SC86295 07581500 * Generate command PLIST: R3-> parms @SC86158 07582000 SRVUTL LA 2,FILNAM 1st or only filespec @SC86295 07582500 LH 4,0(3) @SC86295 07583000 N 4,F3 Get number of names @SC86295 07583500 SRVUTLP XC SCANPTR,SCANPTR @SC86295 07584000 BAL 9,SRVGSTR Extract file-spec @SC86295 07584500 B SRVUT1 None, check if wildcard allowed @SC86158 07585000 STM 0,1,SCANPTR @SC86295 07585500 SRVUT1 LA 0,FFUTL @SC86295 07586000 TM 1(3),4 Test flag @SC86295 07586500 BZ *+8 @SC86295 07587000 LA 0,FFUTL+FFWLD Wild match if part omitted @SC86295 07587500 KCALL FSPEC,(2),E=SRVERP Get filespec into command @SC86295 07588000 LR 0,6 Length remaining @SC86158 07588500 LR 1,7 Next field @SC86158 07589000 LA 2,IFILE 2nd ptr @SC86158 07589500 BCT 4,SRVUTLP Loop over file-specs @SC86158 07590000 KCALL SUPFNC,1 Start interception @SC86158 07590500 MVI ERRNUM,ERRFNF File not found if error here @SC90264 07591000 CLC 0(1,3),SRVDIR+4 @SC86158 07591500 BE SRVUT6 Don't issue STATE if DIR cmd @SC86158 07592000 OPENF V,FILNAM,E=SRVERP Verify its existence @SC91269 07592500 MVI ERRNUM,ERRKCE In case of any other problem @SC90264 07593000 SRVUT6 LA 1,FILNAM 1st or only filespec @SC86295 07593500 LA 2,IFILE Possible 2nd @SC86295 07594000 XR 0,0 @SC86295 07594500 IC 0,0(3) @SC86295 07595000 KCALL DISKIO,E=SRVERP @SC90264 07595500 MVI ERRNUM,ERRNOE No problem @SC90264 07596000 B SRVKFIN @SC86295 07596500 * Get substring from Generic command @SC86158 07597000 * R0= no. of chars left in packet excluding substr count byte @SC86158 07597500 * R1-> one before count byte @SC86158 07598000 SRVGSTR MVI ERRNUM,ERRIPS Assume missing operand @SC88323 07598500 BCTR 0,0 Remove operand length field @SC86158 07599000 LA 7,1(1) ditto @SC86158 07599500 LTR 6,0 If no operands @SC86158 07600000 BNPR 9 then return error @SC86295 07600500 UNCHR 0,1(1) Operand size @SC86158 07601000 BZR 9 Error if zero length field @SC86295 07601500 BM SRVERP Really bad @SC88323 07602000 LA 1,2(1) Location of operand @SC86158 07602500 AR 7,0 Get ptr to next field @SC86158 07603000 SR 6,0 Length remaining @SC86158 07603500 BM SRVERP Inconsistant @SC88323 07604000 B 4(9) @SC86295 07604500 * Set up copy 07605000 SRVGPRW ICM 0,15,WBUFL @SC86171 07605500 BNP SRVMOP No text @SC88323 07606000 L 1,WBUF Ptr to text @SC86171 07606500 * Copy parameter at (R1), length in R0 and set up interception @SC86158 07607000 SRVGPRM LTR 15,0 Any chars? @SC86171 07607500 BNP SRVGPS No @SC86171 07608000 BCTR 15,0 Yes, translate @SC86171 07608500 LA 14,ATOE Current A-to-E @SC91284 07609000 CLC =C'&TRANSPA',TRNALF @SC91284 07609500 BNE *+8 @SC91284 07610000 LA 14,ATOED Use default if "transparent" @SC91284 07610500 EX 15,SRVGPTRA @SC91284 07611000 EX 15,TRUPCAS @SC86171 07611500 SRVGPS STM 0,1,SCANPTR Save string ptrs @SC86158 07612000 KCALL SUPFNC,1 Start intercepting @SC86158 07612500 BR 9 @SC86295 07613000 SRVGPTRA TR 0(,1),0(14) @SC91284 07613500 * 07614000 SRVFIN MVI WRRD,0 Just write (no read) when ending 07614500 MVI AEAFLG,X'80' ditto @SC90173 07615000 MVC S1HND,SVHND Always use requested handshake @SC87343 07615500 BAL 2,SENDACK Send an ACK 07616000 L 1,WBUF Ptr to decoded data @SC86190 07616500 CLI 0(1),AL @SC86190 07617000 BNE SRVNOLOG Skip logging out @SC86295 07617500 CLOSF LOGPTR Close debug-log @SC86135 07618000 KCALL SUPFNC,8 Log out @SC86295 07618500 SRVNOLOG DS 0H (or fall through just in case) @SC86295 07619000 MVC ERRNUM(2),OLDERR Copy back error number @SC90033 07619500 SRVXIT NI FL2,255-SRV Turn off SERVER mode @SC86158 07620000 KCALL INTINI,0 Clear interrupt trapping 07620500 RET 07621000 * 07621500 SRVSTP MVC TIMOUT,SRVTIM Restore timeout @SC88074 07622000 B SRVXIT @SC88074 07622500 * 07623000 RMHTXT EQU * @SC92300 07623500 ** BEGIN LANGUAGE-SPECIFIC DATA ** @SC92300 07624000 DC C'Kermit-&KSYS. Server handles the following:' @SC86268 07624500 DC X'1515' @SC86158 07625000 DC C'Function Standard command',X'15' @SC86158 07625500 DC C'-------- ----------------',X'1515' @SC86158 07626000 DC C'Send a file SEND file',X'15' @SC86158 07626500 DC C'Retrieve a file GET file',X'15' @SC86158 07627000 DC C'Log off system BYE or LOGOUT',X'15' @SC86158 07627500 DC C'Exit from server FINISH',X'15' @SC86158 07628000 DC C'Issue Kermit cmd REMOTE KERMIT cmd',X'15' @SC86158 07628500 DC C'Issue system cmd REMOTE HOST [CP] cmd',X'15' @SC86268 07629000 DC C'List directory REMOTE DIRECTORY file',X'15' @SC86158 07629500 DC C'Type a file REMOTE TYPE file',X'15' @SC86158 07630000 DC C'Copy a file REMOTE COPY f1 f2',X'15' @SC86158 07630500 DC C'Rename a file REMOTE RENAME f1 f2',X'15' @SC86158 07631000 DC C'Erase a file REMOTE DELETE file',X'15' @SC86158 07631500 DC C'Print a file REMOTE PRINT file',X'15' @SC91198 07632000 DC C'Change disk area REMOTE CWD area',X'15' @SC86158 07632500 DC C'Show disk space REMOTE SPACE area',X'15' @SC86158 07633000 ** END LANGUAGE-SPECIFIC DATA ** @SC92300 07633500 RMHTXTZ EQU * @SC86158 07634000 LOCALS , @SC86295 07634500 RETADR DS A Return adr if no more TAKE stuff @SC86295 07635000 CMDPTR DS A Adr of command table @SC86295 07635500 TAKLEV DS F Take file level @SC86121 07636000 TAKTAB DS (TAKMAX)F Tickets for I/O @SC86295 07636500 SRVTIM DS X Saved timeout limit @SC86355 07637000 SRVIOE DS F Current terminal I/O error count @SC90289 07637500 SRVIOS DS F Saved terminal I/O error count @SC90289 07638000 SERVER EXIT 07638500 TITLE 'SEND Routine - sends a file' 07639000 * Send file(s) and set ERRNUM appropriately 07639500 * Entry: filespec pattern in IFILE, Disp code (if any) in R1 @SC90239 07640000 SEND ENTER 07640500 STC 1,SNDDSP Save code @SC90239 07641000 XC NSENTAC(LSTATS),NSENTAC Clear statistics @SC90179 07641500 KCALL SUPFNC,10 @SC86295 07642000 ST 15,SECTOT Save start time @SC86295 07642500 ST 15,TINSV+12 Also for length tuning @SC88325 07643000 ST 15,TINSV+28 @SC88325 07643500 ST 15,TINSV+44 @SC88325 07644000 TM FL4,SFM @SC86295 07644500 BO *+10 From memory: keep old file list @SC86295 07645000 XC NSENT,NSENT Number of files sent 07645500 MVI SNFLG,FIRST Haven't started yet @SC86295 07646000 XC FDATE,FDATE Clear file date @SC86295 07646500 LA 0,TUNECT Time to tune up @SC88349 07647000 STH 0,SNPKCT @SC86345 07647500 MVI REASON,0 Not rejected yet @SC86316 07648000 MVI SEQ,0 Reset packet number @SC86135 07648500 TM FL4,SFM @SC88100 07649000 BO SNDS8 Just sending from memory @SC88100 07649500 SNDSET OI SNFLG,NEWGRP Haven't started yet @SC88306 07650000 NXTFSET IFILE,E=SNDNON Init for NXTFST call @SC87012 07650500 SNDS8 LA 8,SNDST Set state table @SC89263 07651000 SNDNXT CLI CXZ,AZ 07651500 BE SNDBRK Stop file group send 07652000 MVI FRECF,C'F' Just in case @SC86151 07652500 TM FL4,SFM @SC86158 07653000 BO SNDNOW Just sending from memory @SC86158 07653500 NXTF E=SNDNON Get next/first file @SC86295 07654000 MVI CXZ,0 In case aborted last file 07654500 MVI REASON,0 Not rejected yet @SC86316 07655000 MVC FLNOPTS(LFOPTS),IFOPTS Copy file options @SC89218 07655500 L 5,TSENT Table of files sent (transactions)@SC90179 07656000 ICM 4,15,NSENT Number of files sent @SC90179 07656500 AIF ('&KSYS' NE 'CMS').SOPN @SC86295 07657000 BZ SNDOPN Go if none sent yet @SC86295 07657500 NI SNFLG,255-NEWGRP Not first of this group @SC92300 07658000 SNDTBL CLC 0(16,5),FILNAM @SC86295 07658500 BE SNDNXT Go if sent already 07659000 A 5,FLFID1 Next filespec @SC88092 07659500 BCT 4,SNDTBL 07660000 .SOPN ANOP 07660500 SNDOPN OPENF I,FILNAM,FILFDB,FILPTR,E=SNDFNF @SC87012 07661000 USING FDBD,1 @SC86295 07661500 MVC FRECF,FDBRCF Save format and file size @SC86295 07662000 MVC KBYTES,FDBSIZE @SC86295 07662500 MVC FDATE,FDBDATE Save file date @SC86295 07663000 DROP 1 @SC86295 07663500 KCALL ACCTST,FILNAM Copy name to table @SC90179 07664000 POINTF FILPTR,FLNOPTS,E=SNDSHRT Skip, if requested @SC89218 07664500 CLI TRMLIN,C' ' Alt. line? @SC87300 07665000 BE SNDNOW No, be quiet @SC87300 07665500 INITSTR '&SENDING',CMD,REG=7 Yes, display message @SC92300 07666000 LA 1,FILNAM @SC87300 07666500 BAL 2,STAFSP Format name and show it @SC87300 07667000 SNDNOW NI SNFLG,255-NEWGRP Not first of this group @SC88306 07667500 TM SNFLG,FIRST @SC86295 07668000 BZ SNDFIL Go if not first file 07668500 NI SNFLG,255-FIRST No first file flag @SC86295 07669000 MVC LIMTRY,MAXTNT Limit for INIT retries @SC86345 07669500 TM FL4,NPS Non-protocol? @HF86232 07670000 BZ SNDPRO No, normal send message @HF86232 07670500 KCALL INTINI,5,E=SNDRET Initialize for non-protocol @SC87300 07671000 B SNDATZ Skip protocol stuff @HF86232 07671500 SNDPRO KCALL INTINI,2,E=SNDRET Initialize for send @SC87300 07672000 TM FL2,SRV 07672500 BO SNDINI Go if Server mode 07673000 L 0,LCLDLY Time to wait @SC86164 07673500 KCALL SUPFNC,9 @SC86295 07674000 SNDINI DS 0H @SC86152 07674500 KCALL RPARSET Set up for exchange @SC86152 07675000 KCALL RPAR Our S packet to send @SC86152 07675500 MVI STYPE,AS PACKET TYPE = SEND INITIATE 07676000 MVC RTYPPRV,RTYPE Set up in case S packet gets lost @SC89263 07676500 BAL 9,INPUTSPK Send RPAR and Interpret response @SC86295 07677000 KCALL SPAR Interpret reply to our S packet 07677500 MVC BCTU,BCTR Switch chk,flg to negotiated one @SC92085 07678000 CLI BCTR,AA Blank suppression? @SC92085 07678500 BL *+8 No, flag was off already @SC92085 07679000 MVI BCTOFF+3,1 Yes, turn it on @SC92085 07679500 NI BCTU,15 Use just length here @SC92085 07680000 MVC LIMTRY,MAXTRY Reset limit @SC86164 07680500 BAL 14,INCRSEQ 07681000 CLI SNDDSP,0 Any special disposition? @SC90239 07681500 BE SNDFIL No, skip it @SC90239 07682000 TM RCAPA,8 Yes -- can we send attributes? @SC90239 07682500 BZ SNDCMDER No. Give up @SC90239 07683000 SNDFIL MVI STYPE,AX Text transmission? @SC86158 07683500 TM FL4,TXT @SC86158 07684000 BO *+8 Yes @SC86158 07684500 MVI STYPE,AF Packet type = file header @SC86158 07685000 XC DATL,DATL Null file spec. @SC86158 07685500 TM FL4,SFM @SC86158 07686000 BNZ SNDCNTH From memory, no file name @SC86158 07686500 BAL 9,PAKFIL Compress to buffer with appends @HF86223 07687000 CLI TRMLIN,C' ' Alt. line? @SC87300 07687500 BE SNDFIL2 No, be quiet @SC87300 07688000 INITSTR '&AAAAAAS',CMD Yes, display message @SC92300 07688500 L 1,RBUF Ptr to name in ASCII @SC87300 07689000 MVC 0(250,15),0(1) @SC87300 07689500 TR 0(250,15),ATOED Back to EBCDIC @SC89301 07690000 AR 15,7 End of msg + name @SC87300 07690500 BAL 2,STAPM15 Show sending name @SC87300 07691000 SNDFIL2 DS 0H @SC87300 07691500 SNDCNT BAL 9,ENCODEN Encode fn @SC86295 07692000 SNDCNTH BAL 9,INPUTSPK Send name and interpret response @SC86295 07692500 BAL 14,INCRSEQ 07693000 MVC TMP,SCAPA Copy my flags @SC86149 07693500 NI TMP,8 Attributes @SC86149 07694000 NC TMP,RCAPA Check if both on @SC86149 07694500 BZ SNDATZ No, skip it @SC86149 07695000 L 5,ASDATA @SC86295 07695500 BAL 2,SNDPKLC Check length of attribute info @SC90037 07696000 ICM 4,15,KBYTES File length known? @SC86295 07696500 BZ SNDAT0 No, skip it @SC86316 07697000 TM ATFLG,ATFLNG Length attribute desired? @SC90037 07697500 BZ SNDAT0 No, skip it @SC90037 07698000 MVI 0(5),AEXCL Yes, ASCII ! => size @SC88273 07698500 LA 15,2(5) @SC86295 07699000 BAL 2,EDDEC Format it @SC86295 07699500 TR 2(9,5),ETOAD Convert plenty to ASCII @SC88273 07700000 SR 15,5 @SC86295 07700500 LA 4,ABL-2(15) Number of digits (printably) @SC88273 07701000 STC 4,1(5) @SC86295 07701500 AR 5,15 End of string @SC86295 07702000 SNDAT0 TM ATFL2,ATFORG Origin wanted? @SC90037 07702500 BZ SNDAT0B No, skip it @SC90037 07703000 BAL 2,SNDPKLC Check length of attribute info @SC90037 07703500 MVC 0(LSYSATR,5),SYSATR @SC90037 07704000 LA 5,LSYSATR(5) System code @SC88273 07704500 SNDAT0B TM ATFLG,ATFTYP Type wanted? @SC90037 07705000 BZ SNDAT1Z No, skip it and encoding too @SC90037 07705500 BAL 2,SNDPKLC Check length of attribute info @SC90037 07706000 MVC 0(3,5),=AL1(ABL+2,ABL+1,AB) "!B - it's binary @SC88273 07706500 TM FL4,SFM Sending from memory buffer? @SC90016 07707000 BO *+12 Yes, always text file @SC90016 07707500 TM FL1,BINF Binary file? @SC86149 07708000 BO SNDAT1 Yes @SC86316 07708500 MVC 2(4,5),=AL1(AA,ABL+10,ABL+1,AA) A*!A - ASCII @SC88273 07709000 TM ATFL2,ATFENC Encoding wanted? @SC90037 07709500 BZ SNDAT1 No, skip it @SC90037 07710000 LA 5,3(5) Advance over extra item @SC86316 07710500 ICM 2,15,CDESPTR @SC90040 07711000 BZ SNDAT1 @SC90040 07711500 MVI 2(5),AC Level-1 syntax @SC90040 07712000 SR 1,1 @SC90040 07712500 IC 1,4(,2) Get length of designator @SC90040 07713000 LA 0,ABL+1(,1) Modified length of ENC attribute @SC90040 07713500 STC 0,1(,5) @SC90040 07714000 MVC 3(11,5),5(2) Copy plenty of text @SC90040 07714500 AR 5,1 Account for extra stuff @SC90040 07715000 SNDAT1 LA 5,3(5) @SC86316 07715500 SNDAT1Z TM ATFL2,ATFFMT Format wanted? @SC90037 07716000 BZ SNDAT3 No, skip it @SC90037 07716500 BAL 2,SNDPKLC Check length of attribute info @SC90037 07717000 IC 4,TYPFIL Specific file type @SC86295 07717500 BAL 2,CLKP Dispatch via table @SC86295 07718000 DC C'T',AL3(SNDATT) Text @SC86295 07718500 DC C'D',AL3(SNDATD) D-binary @SC86295 07719000 DC C'V',AL3(SNDATV) V-binary @SC86295 07719500 DC X'0',AL3(SNDAT3) Must be Binary @SC86295 07720000 SNDATT BAL 2,SNDAT2 @SC86295 07720500 DC AL1(ABL+3,AA,AM,AJ) #AMJ Delimited @SC88273 07721000 SNDATD BAL 2,SNDAT2 @SC86295 07721500 DC AL1(ABL+2,AD,A5) "D5 Undelimited 5-byte pref@SC90037 07722000 SNDATV BAL 2,SNDAT2 @SC86295 07722500 DC AL1(ABL+2,AV,A2) "V2 2-byte bin. pref. @SC90037 07723000 SNDAT2 MVI 0(5),ABL+15 ASCII / => Format @SC88273 07723500 MVC 1(9,5),0(2) Copy string @SC86295 07724000 UNCHR 4,0(2) Get length @SC88273 07724500 LA 5,2(4,5) Update string ptr @SC86295 07725000 SNDAT3 CLI FDATE,0 File date defined? @SC86295 07725500 BE SNDAT5 No, skip it @SC90037 07726000 TM ATFLG,ATFDAT Date wanted? @SC90037 07726500 BZ SNDAT5 No, skip it @SC90037 07727000 BAL 2,SNDPKLC Check length of attribute info @SC90037 07727500 MVC 0(2,5),=AL1(A#,ABL+8) Yes, yyyymmdd (ASCII #) @SC88273 07728000 UNPK 2(9,5),FDATE(5) Insert zones @SC86295 07728500 LA 4,10(5) End of date @SC88273 07729000 CLC FDATE+4(3),F0 Time defined too? @SC88235 07729500 BE SNDAT4 No, just use date @SC88235 07730000 MVI 1(5),ABL+17 Yes, add string length - hh:mm:ss @SC88273 07730500 MVC 10(9,5),TIMPLT and edit time @SC88235 07731000 ED 10(9,5),FDATE+4 @SC88235 07731500 CLI 11(5),C' ' @SC88235 07732000 BNE *+8 @SC88235 07732500 MVI 11(5),C'0' Insist on leading zeroes @SC88235 07733000 LA 4,9(4) Advance over time @SC88273 07733500 SNDAT4 TR 2(17,5),ETOAD Convert date/time to ASCII @SC88273 07734000 LR 5,4 New ptr in either case @SC88273 07734500 SNDAT5 TM ATFL2,ATFDSP Disposition wanted? @SC90239 07735000 BZ SNDAT6 No @SC90239 07735500 CLI SNDDSP,0 @SC90239 07736000 BE SNDAT6 No special disposition @SC90239 07736500 BAL 2,SNDPKLC Check length of attribute info @SC90239 07737000 MVI 0(5),APLUS Disposition attribute @SC90239 07737500 MVC 2(,5),SNDDSP Selected code @SC90239 07738000 LM 6,7,LEN Any options? @SC90239 07738500 LTR 6,6 @SC90239 07739000 BZ SNDAT5B No @SC90239 07739500 MVC 3(80,5),0(7) Yes, allow up to 80 bytes @SC90239 07740000 TR 3(80,5),ETOAD Convert to ASCII @SC90239 07740500 SNDAT5B LA 2,1(,6) Length of code + options @SC90239 07741000 TOCHR 2,,1(,5) Save in packet @SC90239 07741500 LA 5,3(6,5) Advance ptr @SC90239 07742000 SNDAT6 DS 0H @SC90239 07742500 TM ATFL4,ATFEND End-signal wanted? @SC91109 07743000 BZ SNDATY No @SC91109 07743500 BAL 2,SNDPKLC Check length of attribute info @SC90037 07744000 MVC 0(2,5),=AL1(A@,ABL) Zero-length attribute @SC91109 07744500 LA 5,2(,5) Advance ptr @SC91109 07745000 SNDATY BAL 2,SNDPKLC Check length of attribute info @SC91109 07745500 SR 8,8 Unconditionally send all @SC90037 07746000 LA 2,SNDATZ Place to go when done @SC90037 07746500 ST 2,SNDPKLR @SC90037 07747000 B SNDAT9 @SC90037 07747500 * Send A-packet if buffer full. Use last version that fit. @SC90037 07748000 SNDPKLC L 8,MAXSIZ Set limit for packet @SC90037 07748500 SNDAT9 L 15,ASDATA @SC86295 07749000 SR 5,15 @SC86295 07749500 BNP SNDPKLZ @SC90037 07750000 CR 5,8 Full yet? @SC90037 07750500 BNH SNDPKLZ No, go back for more @SC90037 07751000 ICM 8,15,SNDPKLN Length from last time through @SC90239 07751500 BZ *+6 None. Must be one big attribute @SC90239 07752000 LR 5,8 Ok, use it @SC90239 07752500 ST 5,DATL Set length @SC86295 07753000 LA 8,SNDST Restore state ptr @SC89263 07753500 MVI STYPE,AA @SC86149 07754000 BAL 9,INPUTSPK Send it @SC86295 07754500 BAL 14,INCRSEQ @SC86149 07755000 CLC DATL,F0 Any objections? @SC86149 07755500 BE SNDPKLX Ok @SC90037 07756000 L 1,ARDATA @SC86316 07756500 CLI 0(1),AN Refused? @SC86149 07757000 BE SNDCAN Sigh @SC86149 07757500 SNDPKLX SR 5,5 Clear length to send @SC90037 07758000 L 2,SNDPKLR Will have to redo @SC90037 07758500 SNDPKLZ ST 5,SNDPKLN Save length available @SC90037 07759000 A 5,ASDATA Restore as ptr into buffer @SC90037 07759500 ST 2,SNDPKLR Where to go if need to redo @SC90037 07760000 BR 2 @SC90037 07760500 * @SC90037 07761000 SNDATZ DS 0H @SC86149 07761500 NI FL1,255-EOF Not end of file yet 07762000 BAL 14,RDWSET Check for special format @SC86151 07762500 MVI LCKOLD,0 Start at normal state @SC91275 07763000 XC RBUFL,RBUFL No data in input buffer 07763500 MVI CARCTL,0 Initialize flag, if CC @SC91116 07764000 TM FL4,NPS Non-protocol? @SC86165 07764500 BO SNDNPS Yes, do it @SC86165 07765000 SNDENC KCALL ENCODE,E=SNDENX Encode the data and more 07765500 SNDDAT MVI STYPE,AD PACKET TYPE = DATA 07766000 BAL 9,INPUTSPK Send data and interpret reply @SC86295 07766500 BAL 14,INCRSEQ 07767000 LH 15,SNPKCT @SC86345 07767500 BCT 15,SNDTUNZ No tuning yet @SC86345 07768000 CLC MAXSIZ+4,AKMAX Long packets selected? @SC86345 07768500 BNP SNDTUNY No @SC86345 07769000 KCALL SUPFNC,10 Get time @SC88325 07769500 ST 15,CSECTOT Save @SC88325 07770000 KCALL OPTPKT Calculate optimum size @SC88325 07770500 LTR 15,15 Valid? @SC86345 07771000 BNP SNDTUNY No @SC86345 07771500 C 15,MAXSIZ+4 Other Kermit's limit @SC86345 07772000 BNH *+8 @SC86345 07772500 L 15,MAXSIZ+4 @SC86345 07773000 C 15,AKMAX @SC86345 07773500 BNL *+8 @SC86345 07774000 L 15,AKMAX Don't get too small @SC86345 07774500 ST 15,MAXSIZ Set send limit @SC86345 07775000 SNDTUNY LA 15,TUNECT Repeat target @SC88349 07775500 SNDTUNZ STH 15,SNPKCT @SC86345 07776000 CLC DATL,F1 07776500 BNE SNDENC Go if no Data in ack 07777000 L 1,ARDATA @SC86190 07777500 CLI 0(1),AX @SC86190 07778000 BE SNDCAN Go if Abort sending file 07778500 CLI 0(1),AZ @SC86190 07779000 BNE SNDENC Go if not Abort sending grp 07779500 SNDCAN MVC CXZ,0(1) Pick up data @SC86190 07780000 MVI ERRNUM,ERRTRC Send cancelled @SC86156 07780500 CLC DATL,F2 Any reason given (if A-pkt) @SC86316 07781000 BL SNDEOF None @SC86316 07781500 UNCHR 2,1(1),REASON Yes, save it @SC86316 07782000 SNDEOF BAL 9,SNDCLS Close file @SC86295 07782500 KCALL ACCTNG Save code in table @SC88092 07783000 MVI STYPE,AZ PACKET TYPE = EOF 07783500 XC DATL,DATL 07784000 L 9,ASDATA @SC86295 07784500 MVI 0(9),AD In case of discard @SC86295 07785000 CLI CXZ,0 Aborting this file? @SC86125 07785500 BE *+8 No, ok @SC86125 07786000 MVI DATL+3,1 Yes, send 'D' @SC86125 07786500 BAL 9,INPUTSPK Send EOF and Interpret response @SC86295 07787000 BAL 14,INCRSEQ 07787500 TM FL4,SFM @SC86158 07788000 BO SNDBRK Memory has only one 'file' @SC86158 07788500 B SNDNXT else GET-NEXT-FILE 07789000 * 07789500 SNDNPS MVI WRRD,0 Set for send only @SC86165 07790000 MVI AEAFLG,X'80' ditto @SC90173 07790500 SNDNPSL KCALL NPREAD,E=(SNDABR,P) @SC86165 07791000 CLC SNDPKL,F0 OK, any data? @SC86165 07791500 BE SNDNPZ No, must be done @SC86165 07792000 KCALL SIO,E=SNDABR Send what we got @SC86165 07792500 TM FL1,EOF Any more? @SC86165 07793000 BZ SNDNPSL Yes, get it @SC86165 07793500 SNDNPZ BAL 9,SNDCLS Reached end @SC86295 07794000 MVI ERRNUM,ERRNOE Set code = no errors @SC90179 07794500 KCALL ACCTNG Save code in table @SC90179 07795000 TM FL4,SFM Internal file? @SC90179 07795500 BZ SNDNXT If not, on to next file (if any) @SC90179 07796000 B SNDBR2 All done @SC86165 07796500 * 07797000 SNDENX LTR 15,15 Positive or negative error? 07797500 BP SNDABR Pos: error from ENCODE, not EOF 07798000 MVI ERRNUM,ERRNOE No error yet @SC88092 07798500 CLC DATL,F0 07799000 BE SNDEOF No more data to send 07799500 B SNDDAT Send last chunk 07800000 * 07800500 SNDNON TM SNFLG,NEWGRP @SC88306 07801000 BZ SNDMNXT Filespec wasn't totally missing @SC89218 07801500 SNDFNF MVI ERRNUM,ERRFNF Not found @SC87012 07802000 KCALL ACCTST,IFILE Copy name to table @SC88306 07802500 SNDACT KCALL ACCTNG Set error number @SC89218 07803000 SNDMNXT DS 0H @SC89218 07803500 CLC MSNDPTR,MSNDBUF Any more filespecs pending? @SC88306 07804000 BNH SNDBRK No, all done @SC88306 07804500 L 1,MSNDPTR @SC88306 07805000 SH 1,=Y(LFSTF) Back up to next filespec @SC89218 07805500 ST 1,MSNDPTR And save new ptr @SC88306 07806000 MVC IFILE(LFSTF),0(1) Copy out names @SC89218 07806500 B SNDSET Start all over again @SC88306 07807000 * 07807500 SNDBRK MVC ERRNUM(2),ERRLAST Last error code+reason code @SC89218 07808000 CLI ERRNUM,ERRNOE Last transfer ok? @SC89218 07808500 BE SNDBRKP Yes @SC89218 07809000 TM SNFLG,FIRST @SC88306 07809500 BZ SNDAB2 Send E-packet: transfer started @SC89218 07810000 TM FL2,SRV 07810500 BO SNDAB2 Go if server @SC89218 07811000 B SNDRET @SC86295 07811500 * 07812000 SNDSHRT BAL 9,SNDCLS Close input file @SC89218 07812500 NI SNFLG,255-NEWGRP Not first of the group anymore @SC89218 07813000 MVI ERRNUM,ERRFTS File too short for request @SC89218 07813500 B SNDACT On to next file, if any @SC89218 07814000 * 07814500 SNDBRKP TM SNFLG,FIRST See if actually started @SC89218 07815000 BO SNDRET No, just quit @SC89218 07815500 TM FL4,NPS Non-protocol? @SC90292 07816000 BO SNDBR2 Yes, skip break packet @SC90292 07816500 MVI STYPE,AB Packet type = BREAK @SC89218 07817000 XC DATL,DATL 07817500 BAL 9,INPUTSPK Send BRK and Interpret response @SC86295 07818000 SNDBR2 DS 0H @SC86165 07818500 MVC ERRNUM(2),ERRLAST Reset error+reason @SC89218 07819000 B SNDRET Done @SC89218 07819500 * 07820000 SNDCMDER MVI ERRNUM,ERRDSP Say can't dispose of file @SC90239 07820500 * 07821000 SNDABR BAL 9,SNDCLS Close disk file @SC86295 07821500 KCALL ACCTNG Save code in table @SC88092 07822000 SNDAB2 DS 0H @SC89218 07822500 TM FL4,NPS Non-protocol? @SC86165 07823000 BO SNDRET Yes, skip error packet @SC86165 07823500 KCALL ERPACK Send error packet 07824000 SNDRET NI FL4,255-NPS-SFM-TXT @SC86165 07824500 LA 0,0 Indicate return from SEND @AB89191 07825000 B RETSNRC Close statistics and return @SC86295 07825500 * 07826000 SNDCLS TM FL4,SFM Text xmit? @SC86158 07826500 BOR 9 Yes, no disk file @SC86295 07827000 CLOSF FILPTR Close it @SC86158 07827500 BR 9 @SC86295 07828000 * 07828500 TIMPLT DC C' ',X'2120',C':',2X'20',C':',2X'20' Time edit @SC88235 07829000 LOCALS , @SC86295 07829500 SNPKCT DS H Cyclic counter for tuning @SC86345 07830000 CXZ DS X Flag for aborted transmission @SC86295 07830500 SNFLG DS X More local flags @SC86295 07831000 FIRST EQU X'80' File is the first one @SC86295 07831500 NEWGRP EQU X'40' File is the first of a new group @SC88306 07832000 SNDPKLR DS A Saved return adr for attribute @SC90037 07832500 SNDPKLN DS F Length of attributes composed @SC90037 07833000 SNDDSP DS X Saved code for disposition @SC90239 07833500 SEND EXIT 07834000 TITLE 'RECEIV Routine - receives a file' 07834500 * Receive file(s) and set ERRNUM appropriately 07835000 * Entry: filespec in FILNAM if ROVR is set 07835500 RECEIV ENTER 07836000 XC NSENTAC(LSTATS),NSENTAC Clear statistics @SC90179 07836500 XC NSENT,NSENT Clear count of files @SC88092 07837000 MVC FL1SV,FL1 Save file attribute defaults: @SC90037 07837500 MVC TYPFSV,TYPFIL File type... @SC90037 07838000 MVC RCFSV,FILRCF Format @SC90037 07838500 MVC LRCSV,FILLRC Record length... @SC90037 07839000 KCALL SUPFNC,10 @SC86295 07839500 ST 15,SECTOT Save start time @SC86295 07840000 CLI RTYPE,AF Starting with file header packet? @SC88074 07840500 BE RECFHD Yes, skip INIT stuff @SC88074 07841000 CLI RTYPE,AX @SC88074 07841500 BE RECFHD Yes, skip INIT stuff @SC88074 07842000 KCALL SPARSET Set up for exchange @SC86152 07842500 LA 8,RECINST Next state table for RECEIVE I 07843000 MVC LIMTRY,MAXTNT Limit for INIT retries @SC86345 07843500 CLI RTYPE,0 @SC88074 07844000 BNE RECSRV Skip read if already got packet @SC88074 07844500 MVI SEQ,0 Reset packet number @SC88074 07845000 KCALL RPACK Get init info 07845500 RECSRV SR 3,3 Clear retry counter for INPUTLUP 07846000 BAL 9,INPUTINR Interpret response to RPAC @SC86295 07846500 KCALL SPAR Interpret his S packet 07847000 KCALL RPAR Reply to the S packet 07847500 BAL 2,SENDACKL Send an ACK, length set 07848000 MVC BCTU,BCTR Switch to negotiated chksum/flag @SC92085 07848500 CLI BCTR,AA Blank suppression? @SC92085 07849000 BL *+8 No, flag was off already @SC92085 07849500 MVI BCTOFF+3,1 Yes, turn it on @SC92085 07850000 NI BCTU,15 Use just length here @SC92085 07850500 MVC LIMTRY,MAXTRY Set retry limit @SC86164 07851000 BAL 14,INCRSEQ 07851500 RECFIL KCALL RPACK Get header packet @SC88074 07852000 RECFHD LA 8,RECFNST Next state table for RECEIVE F @SC88074 07852500 SR 3,3 Clear retry counter for INPUTLUP @SC88074 07853000 BAL 9,INPUTINR Interpret header packet @SC88074 07853500 NI RFLG,255-RTRC-RRJC Clear each time @SC86316 07854000 MVI REASON,0 07854500 NI FL1,255-EOF Turn of EOF = no ctl-z seen 07855000 MVC FILFSIZ,F0 Clear expected size in Kbytes @SC90037 07855500 XC FDATE,FDATE Clear file date/time @SC91094 07856000 TM FL1,ROVR 07856500 BO RECOVR Overwrite the name sent? 07857000 BAL 9,DECODEN Decode the input @SC86295 07857500 L 1,WBUF Start of data 07858000 L 0,WBUFL Data length decoded 07858500 TR 0(256,1),ATOED Convert to std EBCDIC @SC89301 07859000 STM 0,1,SCANPTR Set up scan @SC86295 07859500 MVC CMD+&MSGFILL.(255-&MSGFILL),0(1) Extra copy @SC92300 07860000 LA 0,FFHDR @SC86295 07860500 KCALL FSPEC,FILNAM,E=RECNER Invalid, somehow? @SC91017 07861000 CLI TRMLIN,C' ' Alt. line? @SC87300 07861500 BE RECOVR No, be quiet @SC87300 07862000 MVC CMD(&MSGFILL),=C'&MSGFILE' Yes, display message @SC92300 07862500 LA 0,CMD+&MSGFILL @SC87300 07863000 A 0,WBUFL @SC87300 07863500 BAL 2,STAPMSG Show name @SC87300 07864000 RECOVR LA 3,FILNAM Point to fn 07864500 TM FL3,APPN Appending to old files? @SC86203 07865000 BO RECOPN Yes, just do it @SC86295 07865500 TM FL1,REN 07866000 BZ RECOPN No, just do it @SC86295 07866500 LA 0,FFNEW @SC86295 07867000 KCALL FSPEC,FILNAM,E=RECNER Check collisions @SC88053 07867500 TM FL4,NMCHNG @SC90033 07868000 BZ RECCMSG @SC90033 07868500 CLI CLSNFL,C'B' @SC90033 07869000 BNE RECCTSTD @SC90033 07869500 LA 2,FILNAM Must back up original file @SC90033 07870000 LA 0,15 Rename it to unique new name @SC90033 07870500 KCALL DISKIO,XFILE,E=RECNER Give up if rename fails @SC90264 07871000 CLI TRMLIN,C' ' Alt. line? @SC90033 07871500 BE RECCBZ No, be quiet @SC90033 07872000 INITSTR '&BACKDUP',CMD,REG=7 @SC92300 07872500 LA 1,FILNAM @SC90033 07873000 BAL 2,STAFSP Format backup name and show it @SC90033 07873500 RECCBZ MVC FILNAM,XFILE Now, just use intended name @SC90033 07874000 B RECCMSG @SC90033 07874500 RECCTSTD CLI CLSNFL,C'D' @SC90033 07875000 BNE RECCMSG Other case is just "rename" @SC90033 07875500 RECNER DS 0H Invalid name, cancel the transfer @SC91017 07876000 OI RFLG,RRJC Reject file @SC90033 07876500 MVI REASON,STACNCLS Reason was file collision @SC90033 07877000 CLI TRMLIN,C' ' Alt. line? @SC90033 07877500 BE RECOPN No, be quiet @SC90033 07878000 WTEXT '&DSCARDD' @SC90033 07878500 B RECOPN @SC90033 07879000 RECCMSG DS 0H @SC90033 07879500 CLI TRMLIN,C' ' Alt. line? @SC87300 07880000 BE RECOPN No, be quiet @SC87300 07880500 INITSTR '&RECVDAS',CMD,REG=7 Yes, display message @SC92300 07881000 LA 1,FILNAM @SC87300 07881500 BAL 2,STAFSP Format name and show it @SC87300 07882000 RECOPN XC FILFLGS,FL3 Set flag for DISP @SC86295 07882500 NI FILFLGS,255-APPN-SVATT @SC90033 07883000 XC FILFLGS,FL3 @SC86295 07883500 XC RECRCNT,RECRCNT Count of packets after rejection@SC91165 07884000 KCALL ACCTST,FILNAM Copy name to table @SC88306 07884500 L 7,RBUF Ptr to input buffer @SC88264 07885000 LA 0,FFDSP @SC88264 07885500 KCALL FSPEC,FILNAM Copy chosen name into buffer @SC88264 07886000 L 2,RBUF @SC88264 07886500 LR 3,15 End of string @SC88264 07887000 SR 3,2 Get length of string @SC88264 07887500 ST 3,RBUFL @SC88264 07888000 LA 15,ETOAD Standard table @SC89301 07888500 BAL 14,TRANSLAT Convert to ASCII @SC88264 07889000 BAL 9,ENCODEN Copy into packet buffer @SC88264 07889500 BAL 2,SENDACKL @SC88264 07890000 XC WBUFL,WBUFL Data length in WBUF 07890500 MVI LCKOLD,0 Start at normal state @SC91275 07891000 MVI DECESCP,0 @SC91275 07891500 MVI PREV,0 Char previously decoded 07892000 LA 8,RECANST State table: REC D or A @SC86149 07892500 RECDAT BAL 14,INCRSEQ @SC86316 07893000 BAL 9,INPUT Read a packet and interpret @SC86295 07893500 LA 9,RECDNST From now on accept D only @SC90037 07894000 CR 8,9 Already seen a D packet? @SC90037 07894500 BE RECDATN Yes, handle routinely @SC90037 07895000 LR 8,9 No, 1st open file @SC90037 07895500 TM RFLG,RRJC File rejected? @SC90037 07896000 BO RECRJX Yes, ignore all data @SC90037 07896500 OPENF O,FILNAM,FILFDB,FILPTR,E=RECOER @SC91017 07897000 USING FDBD,1 @SC86295 07897500 L 2,FABLRTR Get effective record length @SC88120 07898000 ST 2,FSIZE Copy LRECL @SC86295 07898500 MVC FRECF,FDBRCF Save info @SC86295 07899000 DROP 1 @SC86295 07899500 TM FL1,BINF @SC88120 07900000 BO RECMAXO Binary, just fold at LRECL @SC88120 07900500 CLI TRNCFL,C'H' Test: F, H, or T @SC88120 07901000 BL RECMAXO F => fold at LRECL @SC88120 07901500 LA 2,1(2) Assume H => abort at LRECL+1 @SC88120 07902000 BE RECMAXO @SC88120 07902500 ICM 2,8,LOBIT+3 T => fold at "infinity", but trunc@SC88120 07903000 RECMAXO ST 2,MAXOUT @SC88120 07903500 BAL 14,RDWSET Check for special format @SC86295 07904000 ICM 0,15,FILFSIZ Expected size, if known @SC90037 07904500 BZ RECDATN Not known, proceed @SC90037 07905000 OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJL Check disk space@SC90037 07905500 RECDATN DS 0H @SC90037 07906000 TM RFLG,RRJC File rejected? @SC89218 07906500 BO RECRJX Yes, ignore all data @SC90033 07907000 KCALL DECODE,E=RECABR Decode and write to file @SC86316 07907500 RECDAK BAL 2,SENDACK Send an ack @SC86149 07908000 B RECDAT 07908500 * 07909000 RECSCN LR 7,6 Start one before number @SC90037 07909500 RECSCL CLI 0(7),ACOM Look for comma @SC90037 07910000 BER 14 Found one @SC90037 07910500 CR 7,5 @SC90037 07911000 BNLR 14 Already at end of string @SC90037 07911500 LA 7,1(,7) @SC90037 07912000 B RECSCL Keep looking @SC90037 07912500 * 07913000 RECALKP LTR 7,7 @SC90037 07913500 BNP RECRJC No value at all. Give up @SC90037 07914000 IC 4,0(,6) Get value code @SC90037 07914500 LA 6,1(,6) Advance scan ptr over code char @SC90037 07915000 BCTR 7,0 Length of stuff left @SC90037 07915500 B CLKP Dispatch on value, table at (2) @SC90037 07916000 * 07916500 RECAMJ NI FL1,255-BINF Set it Text @SC90037 07917000 MVI TYPFIL,C'T' @SC90037 07917500 LTR 7,7 Any more stuff? @SC90037 07918000 BZR 14 No, assume AMJ @SC90037 07918500 C 7,F2 Yes, had better be AMJ! @SC90037 07919000 BNE RECRJC Isn't AMJ, give up @SC90037 07919500 CLC 0(2,6),=AL1(AM,AJ) @SC90037 07920000 BNE RECRJC Isn't AMJ, give up @SC90037 07920500 BR 14 Ok @SC90037 07921000 * 07921500 RECTRTD TRT 0(,6),TRTDIG Scan for invalid data bytes @SC91094 07922000 RECTRTB TRT 0(,6),TRTBL Scan for a blank @SC91094 07922500 RECMVTM MVC FDATE+4(0),TMPDW+4 Copy to output field @SC91094 07923000 TRTDIG DC (C' ')X'1',X'0' Detect space @SC91094 07923500 DC (C':'-C' '-1)X'1',X'0' and colon @SC91094 07924000 DC (C'0'-C':'-1)X'1',10X'0',(255-C'9')X'1' digits @SC91094 07924500 * 07925000 RECADT BCTR 7,0 @SC91094 07925500 EX 7,RECTRAT Convert to EBCDIC @SC91094 07926000 EX 7,RECTRTD Check if valid data @SC91094 07926500 BNZ RECRJC Invalid, reject @SC91094 07927000 LA 1,1(,7) Total length @SC91094 07927500 EX 7,RECTRTB @SC91094 07928000 BZ *+6 @SC91094 07928500 SR 1,6 Length of data alone @SC91094 07929000 PACK FDATE(5),0(9,6) @SC91094 07929500 C 1,F8 Full yyyymmdd? @SC91094 07930000 BH RECRJC Too big, kill it @SC91094 07930500 BE RECADT1 Ok @SC91094 07931000 CH 1,=H'6' Just yymmdd? @SC91094 07931500 BNE RECRJC No, illegal @SC91094 07932000 PACK FDATE+1(4),0(7,6) Leave room for century @SC91094 07932500 MVI FDATE,X'19' Assume 20th @SC91094 07933000 CLI FDATE+1,X'50' Unless yy<50 @SC91094 07933500 BNL RECADT1 @SC91094 07934000 MVI FDATE,X'20' Must be 21st @SC91094 07934500 RECADT1 MVI FDATE+4,0 Repair damage @SC91094 07935000 LA 1,1(,1) Account for separator @SC91094 07935500 SR 7,1 See if time also present @SC91094 07936000 BNP RECCKL No, all done @SC91094 07936500 AR 6,1 Ok, advance ptr @SC91094 07937000 MVC TMPDW(6),=AL1(0,1,3,4,6,7) @SC91094 07937500 TR TMPDW(6),0(6) Compress out colons @SC91094 07938000 PACK TMPDW+4(4),TMPDW(7) @SC91094 07938500 CH 7,=H'4' Just hh:mm? @SC91094 07939000 BE *+12 Ok @SC91094 07939500 CH 7,=H'7' hh:mm:ss? @SC91094 07940000 BNE RECRJC No, error @SC91094 07940500 SRL 7,1 @SC91094 07941000 BCTR 7,0 @SC91094 07941500 EX 7,RECMVTM Move to FDATE: 2 or 3 bytes @SC91094 07942000 B RECCKL @SC91094 07942500 * 07943000 RECCKA L 5,ARDATA Attributes @SC88273 07943500 L 3,DATL Get length @SC86316 07944000 AR 3,5 Ptr to end @SC88273 07944500 MVI ERRNUM,ERRIPS In case of error @SC86316 07945000 RECCKL CR 5,3 Another attribute? @SC86316 07945500 BNL RECDAK No, done @SC86316 07946000 TM RFLG,RRJC File rejected? @SC90033 07946500 BO RECDAK Yes, ignore further attributes @SC90033 07947000 UNCHR 4,0(5),REASON Get code @SC90037 07947500 BNP RECABR Invalid: code must be >0 @SC90037 07948000 UNCHR 7,1(5) Get length of value @SC88273 07948500 BM RECABR Invalid: length was <0 @SC86316 07949000 LA 6,2(5) Space over code+length @SC88273 07949500 LA 5,0(7,6) Next field @SC86316 07950000 CR 5,3 Does it match? @SC86316 07950500 BH RECABR Overflows data @SC86316 07951000 LR 14,4 @SC90037 07951500 BCTR 14,0 Bit index for this attribute @SC90037 07952000 SRDL 14,3 Get byte index @SC90037 07952500 SRL 15,29 And bit remainder @SC90037 07953000 LA 1,X'80' @SC90037 07953500 SRL 1,0(15) Convert to bit mask @SC90037 07954000 IC 15,ATFLG(14) Load attribute flags @SC90037 07954500 NR 15,1 Honor this attribute? @SC90037 07955000 BZ RECCKL No, just ignore it @SC90037 07955500 BAL 2,CLKP @SC86316 07956000 RECLNCOD DC AL1(01),AL3(RECALN) ! - File length @SC90037 07956500 DC AL1(02),AL3(RECATP) " - Type @SC90037 07957000 DC AL1(03),AL3(RECADT) # - Date @SC91094 07957500 DC AL1(09),AL3(RECAAC) ) - Access @SC90037 07958000 DC AL1(10),AL3(RECAEN) * - Encoding @SC90037 07958500 DC AL1(11),AL3(RECADI) + - Disposition @SC90037 07959000 DC AL1(15),AL3(RECAFM) / - Format @SC90037 07959500 DC AL1(32),AL3(RECAZZ) @ - End @SC91109 07960000 DC X'0',AL3(RECCKL) Other @SC86316 07960500 * Access attribute @SC90037 07961000 RECAAC BAL 2,RECALKP @SC90037 07961500 DC AL1(AA),AL3(RECAAA) Append @SC90037 07962000 DC AL1(AN),AL3(RECCKL) Normal (obey user) @SC90037 07962500 DC AL1(AS),AL3(RECAAS) Supersede @SC90037 07963000 DC AL1(00),AL3(RECRJC) unknown, reject @SC90037 07963500 RECAAA OI FILFLGS,APPN Append @SC90037 07964000 B RECCKL @SC90037 07964500 RECAAS NI FILFLGS,255-APPN Don't append @SC90037 07965000 B RECCKL @SC90037 07965500 * Format attribute @SC90037 07966000 RECAFM BAL 14,RECSCN Check for comma @SC90037 07966500 SR 7,6 Length of extra stuff @SC90037 07967000 BAL 2,RECALKP @SC90037 07967500 DC AL1(AA),AL3(RECAFA) ASCII @SC90037 07968000 DC AL1(AD),AL3(RECAFD) D (binary) @SC90037 07968500 DC AL1(AF),AL3(RECAFF) Fixed (binary) @SC90037 07969000 DC AL1(AM),AL3(RECLRC) LRECL @SC90037 07969500 DC AL1(AV),AL3(RECAFD) V (binary) @SC90037 07970000 DC AL1(00),AL3(RECRJC) ? @SC90037 07970500 RECAFA BAL 14,RECAMJ Set it Text @SC90037 07971000 B RECALP @SC90037 07971500 RECAFF LA 4,AB Plain old Binary @SC90037 07972000 RECAFD OI FL1,BINF Binary selected @SC90037 07972500 IC 4,ATOED(4) Ok, set file type as well @SC90037 07973000 STC 4,TYPFIL @SC90037 07973500 RECALP BAL 14,RECSCN Look for comma @SC90037 07974000 LA 6,1(,7) Skip over comma for next piece @SC90037 07974500 CR 6,5 @SC90037 07975000 BNL RECCKL Ran out of attribute stuff @SC90037 07975500 B RECAFM Do next piece @SC90037 07976000 RECLRC BAL 14,RECSCN Look for comma @SC90037 07976500 SR 7,6 Length of number string @SC90037 07977000 LR 14,7 Convert number to EBCDIC @SC90037 07977500 BNP RECRJC Impossible, reject it @SC90037 07978000 BCTR 14,0 @SC90037 07978500 EX 14,RECTRAT @SC90037 07979000 BAL 14,GETNUM Get number @SC90037 07979500 B RECRJC Not proper numeric string @SC90037 07980000 LTR 0,0 Validate LRECL @SC90037 07980500 BNP RECRJC No good @SC90037 07981000 STCM 0,3,FILLRC Ok, use it @SC90037 07981500 B RECALP Look for another subattribute @SC90037 07982000 * Length attribute @SC90037 07982500 RECALN LTR 14,7 Copy length @SC88273 07983000 BNP RECRJC No good @SC88273 07983500 BCTR 14,0 @SC88273 07984000 EX 14,RECTRAT @SC88273 07984500 BAL 14,GETNUM Get file length @SC88273 07985000 B RECRJC @SC88273 07985500 ST 0,FILFSIZ Save expected size @SC90037 07986000 OPENF S,FILNAM,FILFDB,FILPTR,E=RECRJC Check disk space@SC90037 07986500 B RECCKL Ok, keep looking @SC86316 07987000 RECTRAT TR 0(,6),ATOED Convert to EBCDIC for decoding @SC88273 07987500 * Type attribute @SC90037 07988000 RECATP BAL 2,RECALKP @SC90037 07988500 DC AL1(AA),AL3(RECATA) ASCII @SC90037 07989000 DC AL1(AB),AL3(RECATB) Binary @SC90037 07989500 DC AL1(00),AL3(RECRJC) Don't allow any other @SC90037 07990000 RECATA BAL 14,RECAMJ Set it Text @SC90037 07990500 B RECCKL Ok @SC90037 07991000 RECATB TM FL1,BINF Already binary? @SC90037 07991500 BO RECCKL Yes, that's fine @SC90037 07992000 OI FL1,BINF No, set it binary @SC90037 07992500 MVI TYPFIL,C'B' And choose simple binary @SC90037 07993000 B RECCKL @SC90037 07993500 * Disposition attribute @SC90037 07994000 RECADI BAL 2,RECALKP @SC90037 07994500 DC AL1(AA),AL3(RECCKL) Archive (not implemented) @SC90037 07995000 DC AL1(AM),AL3(RECADM) Mail @SC90037 07995500 DC AL1(AP),AL3(RECADP) Print @SC90037 07996000 DC AL1(AS),AL3(RECADS) Submit as batch job @SC90037 07996500 DC AL1(00),AL3(RECRJC) unknown, reject @SC90037 07997000 * 07997500 RECADM LTR 7,7 Any recipients given? @SC90037 07998000 BNP RECRJC No, that's bad @SC90037 07998500 BAL 2,RECAD1 @SC90037 07999000 DC AL4(KMAIL1),AL2(L'KMAIL1,L'KMAIL2,L'KMAIL3) @SC90037 07999500 RECADP BAL 2,RECAD1 @SC90037 08000000 DC AL4(KPRNT1),AL2(L'KPRNT1,L'KPRNT2,L'KPRNT3) @SC90037 08000500 RECADS BAL 2,RECAD1 @SC90037 08001000 DC AL4(KSUBM1),AL2(L'KSUBM1,L'KSUBM2,L'KSUBM3) @SC90037 08001500 RECAD1 ICM 0,15,0(2) Get prototype ptr @SC90037 08002000 LH 1,4(,2) Get length of 1st piece @SC90037 08002500 LA 14,CMD @SC90037 08003000 ST 14,ADR Save ptr to command buffer @SC90037 08003500 LA 4,1(,1) Leave room for null name @SC92120 08004000 ST 4,LEN Save length of 1st piece + '.' @SC92120 08004500 LR 15,1 @SC90037 08005000 MVCL 14,0 Copy first piece to buffer @SC90037 08005500 ST 0,RECDSPTR Save ptr to 2nd piece @SC90037 08006000 LR 4,7 Save length of options @SC90037 08006500 LA 0,FFDSP @SC90037 08007000 LR 7,14 Feed output ptr to FSPEC @SC90037 08007500 KCALL FSPEC,FILNAM Copy filespec to buffer @SC90037 08008000 LR 14,15 New output ptr @SC90037 08008500 LR 7,4 Retrieve option length @SC90037 08009000 L 0,RECDSPTR Get ptr to 2nd piece @SC90037 08009500 LH 1,6(,2) Get length of 2nd piece @SC90037 08010000 LR 15,1 @SC90037 08010500 MVCL 14,0 Copy 2nd piece to buffer @SC90037 08011000 LR 4,14 Save ptr to insert @SC90037 08011500 LR 15,7 @SC90037 08012000 MVCL 14,6 Copy attribute stuff to buffer @SC90037 08012500 TR 0(94,4),ATOED Convert to EBCDIC @SC90037 08013000 LH 1,8(,2) Get length of 3rd piece @SC90037 08013500 LR 15,1 @SC90037 08014000 MVCL 14,0 Copy 3nd piece to buffer @SC90037 08014500 ST 14,RECDSPTR Save ptr to end of command @SC90037 08015000 LA 7,CMD-1 @SC92120 08015500 A 7,LEN @SC92120 08016000 IC 4,0(,7) @SC92120 08016500 MVI 0(7),C'.' Use null name for 1st call @SC92120 08017000 OI FL4,UCMD @SC90037 08017500 KCALL SUPFNC,3,E=RECRJC Test if facility exists @SC90037 08018000 STC 4,0(,7) Restore name @SC92120 08018500 B RECCKL @SC90037 08019000 * 08019500 * Encoding attribute @SC90037 08020000 RECAEN BAL 2,RECALKP @SC90037 08020500 DC AL1(AA),AL3(RECCKL) ASCII @SC90037 08021000 DC AL1(AC),AL3(RECAEC) Special character set @SC90040 08021500 DC AL1(AE),AL3(RECATB) Binary @SC90037 08022000 DC AL1(00),AL3(RECRJC) Don't allow any other @SC90037 08022500 * 08023000 RECAEC LTR 7,7 @SC90040 08023500 BNP RECCKL Character set not specified @SC90040 08024000 KCALL TBLATT,E=RECRJC @SC90040 08024500 B RECCKL @SC90040 08025000 * 08025500 RECAZZ CR 5,3 End of attributes, must be last @SC91109 08026000 BNE RECRJC No, reject @SC91109 08026500 B RECCKL @SC91109 08027000 * 08027500 RECRJL MVC REASON,RECLNCOD Because of length @SC90037 08028000 RECRJX L 9,ASDATA Output buffer @SC90037 08028500 MVI 0(9),AX Reject this file @SC90033 08029000 MVC DATL,F1 @SC90033 08029500 LA 2,1 Count up cancel packets @SC91165 08030000 AH 2,RECRCNT @SC91165 08030500 STH 2,RECRCNT @SC91165 08031000 CH 2,=H'10' Other Kermit too persistent? @SC91165 08031500 BNL RECECNCL Yes, call a halt @SC91165 08032000 B RECRJ2 Now accept only EOF pkt @SC90033 08032500 RECRJC L 9,ASDATA Output buffer @SC86316 08033000 MVI 0(9),AN Mark it rejected @SC88273 08033500 TOCHR 0,REASON,1(9) Copy attribute code to response @SC90037 08034000 MVC DATL,F2 Data = 'N' + code @SC86316 08034500 RECRJ2 DS 0H @SC90033 08035000 OI RFLG,RRJC Mark it rejected @SC86316 08035500 BAL 2,SENDACKL Acknowledge @SC86316 08036000 B RECDAT And wait for EOF @SC86316 08036500 * 08037000 RECEOF TM RFLG,RRJC File rejected? @SC89218 08037500 BO RECDISC Yes, discard @SC89218 08038000 CLC DATL,F1 @SC89218 08038500 BNE RECWR One piece of data 08039000 L 1,ARDATA @SC86190 08039500 CLI 0(1),AD @SC86190 08040000 BNE RECWR Go if not discard 08040500 MVI REASON,0 Micro canceling; don't know why @SC91263 08041000 RECDISC DS 0H @SC89218 08041500 CLOSF FILPTR Close the file @SC86135 08042000 TM FILFLGS,APPN Appending to old file? @SC90033 08042500 BO RECKEP Yes, keep what we got @SC86225 08043000 TM FL1,KEEP @SC90037 08043500 BO RECKEP Don't delete it anyway @SC86225 08044000 ERASF FILNAM And delete it @SC86295 08044500 RECKEP MVI ERRNUM,ERRTRC Receive cancelled @SC86225 08045000 OI RFLG,RTRC Remember that @SC86295 08045500 B RECACK Pick up later on 08046000 * If data left in buffer when we get EOF, write remaining data. 08046500 RECWR ICM 1,15,WBUFL Check length in buffer @SC88120 08047000 BE RECCLO No data in WBUF, send Ack 08047500 KCALL OUTBUF,E=RECABR Write out buffer 08048000 RECCLO CLOSF FILPTR,E=RECCER Close the file @SC92076 08048500 MVI ERRNUM,ERRNOE No error yet @SC88092 08049000 ICM 1,15,RECDSPTR Any special disposition? @SC90037 08049500 BZ RECACK @SC90037 08050000 LA 14,CMD @SC90037 08050500 ST 14,ADR Save ptr to command buffer @SC90037 08051000 SR 1,14 Get length of command @SC90037 08051500 ST 1,LEN @SC90037 08052000 OI FL4,UCMD @SC90037 08052500 KCALL SUPFNC,3,E=RECDSPX Disposition failed @SC90037 08053000 RECACK KCALL ACCTNG Save code in table @SC89218 08053500 BAL 14,RECRSTA Restore attributes @SC90037 08054000 BAL 2,SENDACK Send an ACK @SC89218 08054500 BAL 14,INCRSEQ 08055000 NI FL1,255-ROVR Only change first file 08055500 NI FL4,255-NMOK-NMCHNG Check collision on next file@SC90211 08056000 B RECFIL 08056500 * 08057000 RECBRK MVI ERRNUM,ERRTRC Receive cancelled? @SC90033 08057500 TM RFLG,RTRC+RRJC @SC90033 08058000 BNZ RECERP Yes, send an error packet @SC90033 08058500 TM FL2,SRV Server will read another command @SC90033 08059000 BO *+12 so don't zap write/read flag @SC90173 08059500 MVI WRRD,0 No read for Ack'ing BRK pkt @SC87343 08060000 MVI AEAFLG,X'80' ditto @SC90173 08060500 BAL 2,SENDACK Send an ACK 08061000 MVI ERRNUM,ERRNOE Reset error @SC86156 08061500 B RECRET @SC89218 08062000 * 08062500 RECDSPX MVI ERRNUM,ERRDSP Code for disposition failure @SC90037 08063000 B RECABR @SC90037 08063500 * 08064000 RECECNCL MVI ERRNUM,ERRTRC Code for drastic cancellation @SC91165 08064500 B RECABR @SC91165 08065000 * 08065500 RECCER MVC FABCOMM-FABD+DSKSTT(8),=CL8'CLOSE' Error type @SC92076 08066000 B RECRER @SC92076 08066500 RECOER MVC FABCOMM-FABD+DSKSTT(8),=CL8'OPEN' Error type @SC91017 08067000 RECRER LA 1,DSKSTT Name error, point to dummy block @SC91017 08067500 ERRF , Cannot write. Analyze error @SC91017 08068000 RECABR CLOSF FILPTR Close open file @SC86135 08068500 KCALL ACCTNG Save code in table @SC88092 08069000 BAL 14,RECRSTA Restore attributes @SC90037 08069500 RECERP KCALL ERPACK Send error packet @SC90033 08070000 RECRET ICM 0,15,RECTRC Any records truncated? @SC87268 08070500 LA 0,4 Indicate return from RECEIVE @AB89191 08071000 BZ RETSNRC None @SC87268 08071500 CLI ERRNUM,0 @SC87268 08072000 BNE *+8 Already got some (worse) error @SC87268 08072500 MVI ERRNUM,ERRRTR Indicate error @SC87268 08073000 B RETSNRC Close statistics and return @SC87268 08073500 * Restore file attribute defaults from saved values @SC90037 08074000 RECRSTA XC FL1,FL1SV Restore flags @SC90037 08074500 NI FL1,255-BINF-REN-KEEP Restore only these flags @SC90037 08075000 XC FL1,FL1SV @SC90037 08075500 MVC TYPFIL,TYPFSV Restore file type @SC90037 08076000 MVC FILRCF,RCFSV Restore record format @SC90037 08076500 MVC FILLRC,LRCSV Restore record length @SC90037 08077000 BR 14 @SC90037 08077500 * Receive mode Rpack interpret input tables 08078000 RECINST DC AL1(AS),AL3(0) Micro sent parm 08078500 DC XL1'FF',AL3(RECABR) Stop @SC88074 08079000 DC AL1(00),AL3(RECABR) Error routine 08079500 RECFNST DC AL1(AF),AL3(0) Micro sent a filename 08080000 DC AL1(AX),AL3(0) Micro sent a filename @SC86155 08080500 DC AL1(AB),AL3(RECBRK) Micro sent end of transaction 08081000 DC XL1'FF',AL3(RECABR) Stop @SC88074 08081500 DC AL1(00),AL3(RECABR) Error return 08082000 RECANST DC AL1(AA),AL3(RECCKA) Micro sent A-packet @SC86316 08082500 RECDNST DC AL1(AD),AL3(0) Micro sent data 08083000 RECZNST DC AL1(AZ),AL3(RECEOF) Micro sent EOF @SC86316 08083500 DC XL1'FF',AL3(RECABR) Stop @SC88074 08084000 DC AL1(00),AL3(RECABR) Error return 08084500 LOCALS , @SC86295 08085000 RECDSPTR DS F Saved length of command @SC90037 08085500 RFLG DS X Local flags @SC86295 08086000 RTRC EQU X'80' Other side cancelled @SC86295 08086500 RRJC EQU X'40' I cancelled @SC86316 08087000 FL1SV DS X Saved global flags @SC90037 08087500 TYPFSV DS C Saved file type @SC90037 08088000 RCFSV DS C Saved record format @SC90037 08088500 LRCSV DS H Saved record length @SC90037 08089000 RECRCNT DS H Count of packets after rejection @SC91165 08089500 RECEIV EXIT 08090000 TITLE 'ACCTNG Routine - save statistics for a transfer' 08090500 ACCTNG ENTER 08091000 MVC ERRLAST(2),ERRNUM Save error codes for file @SC89218 08091500 LM 2,3,DSKTOT Current byte count @SC88092 08092000 SL 3,SSVDSK+4 Get difference from this file @SC88092 08092500 BC 3,*+6 @SC88092 08093000 BCTR 2,0 @SC88092 08093500 AL 3,=F'512' Round up @SC88092 08094000 BC 12,*+8 @SC88092 08094500 AL 2,F1 @SC88092 08095000 SL 2,SSVDSK @SC88092 08095500 SRDL 2,10 Convert to Kbytes @SC88092 08096000 MVC SSVDSK(8),DSKTOT @SC88092 08096500 TS ACCTFLG See if file is current @SC89218 08097000 BNZ RTRN0 No, do nothing @SC89218 08097500 ICM 2,15,NSENT Calculate offset into table @SC88092 08098000 BZ RTRN Must not be counting @SC88092 08098500 BCTR 2,0 Ok, back up one @SC91172 08099000 MH 2,FLFID1+2 @SC88092 08099500 A 2,TSENT Ptr to next name slot @SC88092 08100000 USING ACTBUF,2 @SC91172 08100500 CLC ACTSIZ,F0 Already set? @SC91172 08101000 BNE RTRN Yes, don't mess it up @SC88092 08101500 STCM 3,15,ACTSIZ Save file size in Kbytes @SC91172 08102000 MVC ACTERR(2),ERRNUM Save error code for file @SC91172 08102500 BAL 14,ACCTTOD Get time in R0 @SC91172 08103000 STCM 0,15,TRANEND @SC92210 08103500 DROP 2 @SC91172 08104000 B RTRN0 @SC88306 08104500 * 08105000 * Copy file name from (R1) to file table, if possible; update count. 08105500 ACCTST ENTER ALT @SC88306 08106000 MVI ACCTFLG,0 Indicate file is current @SC89218 08106500 L 3,NSENT Number of files sent so far @SC88306 08107000 LA 4,1(,3) Incr number of sent files @AB89191 08107500 ST 4,NSENTAC Number of files for acctng @AB89191 08108000 C 3,=A(MAXNSENT) Did we send more than countable? @SC88306 08108500 BNL RTRN0 Yes, cannot keep track of 'em @SC88306 08109000 MH 3,FLFID1+2 Times length of items @SC88306 08109500 A 3,TSENT Loc in sent-table @SC88306 08110000 USING ACTBUF,3 @SC91172 08110500 XC ACTBUF(ACTLEN),ACTBUF Clear out entry @SC91172 08111000 MVC ACTFID,0(1) Save filespec @SC91172 08111500 BAL 14,ACCTTOD Get time in R0 @SC91172 08112000 STCM 0,7,ACTBEG @SC91172 08112500 ST 4,NSENT Keep it @SC88306 08113000 B RTRN0 @SC88306 08113500 DROP 3 @SC91172 08114000 LOCALS , @SC91172 08114500 ACCTNG EXIT , @SC88092 08115000 TITLE 'SPAR Routine - use parms from other host in DATA' 08115500 SPAR ENTER 08116000 L 7,DATL Data length @SC86120 08116500 L 5,ARDATA Point to data @SC86190 08117000 LA 8,DEFPARM @SC86190 08117500 SR 8,5 Set up offset for defaults @SC86190 08118000 BCTR 5,0 Point one before data @SC86190 08118500 LA 6,1 Set up BXH @SC86120 08119000 AR 7,5 Point to last data char @SC86120 08119500 BAL 14,SPARFTCH Get a char @SC86120 08120000 UNCHR 4 Max send packet size @SC86120 08120500 C 4,AKMIN Less than min Kermit size? @SC86295 08121000 BNL SPARSPM No, it's OK 08121500 LA 4,KMIN Else, use the min value 08122000 SPARSPM C 4,AKMAX More than max Kermit size? @SC86295 08122500 BNH SPARSPS No, it's OK 08123000 LA 4,KMAX 08123500 SPARSPS ST 4,SPSIZ Save max send packet size 08124000 BAL 14,SPARFTCH Get a char @SC86120 08124500 UNCHR 4,,TIMOUT Timeout micro wants us to do @SC86120 08125000 BAL 14,SPARFTCH Get a char @SC86120 08125500 UNCHR 4,,SPADN Pad count micro wants @SC86120 08126000 BAL 14,SPARFTCH @SC86120 08126500 CTL 4,,SPADC Pad char micro wants @SC86120 08127000 BAL 14,SPARFTCH @SC86120 08127500 UNCHR 4,,SEOL EOL char we have to use @SC86120 08128000 CLC SEOL,SMARK 08128500 BE SPARCR Use CR if EOL=MARK char 08129000 CLI SEOL,ABL 08129500 BL SPAREOL1 OK if within ctl range @SC92030 08130000 SPARCR MVI SEOL,CR Send a CR to that crazy micro 08130500 SPAREOL1 CLI TRMTP,C'F' Doing FULL? @SC92030 08131000 BNE SPAREOL2 No, leave it @SC92030 08131500 MVI SEOL,AEXCL Yes, insist on printable EOL! @SC92030 08132000 SPAREOL2 MVC S1EOL,SEOL Make extra copy @SC87274 08132500 SPARCTL BAL 14,SPARFTCH @SC86120 08133000 NOTQR *+8 Go if not 33-62 or 96-126 @SC86120 08133500 LA 4,A# Default ctl-quote @SC86120 08134000 STC 4,RCTLQ Save ctl-quote micro's using @SC86120 08134500 BAL 14,SPARFTCH @SC86120 08135000 CLI EBQC,0 @SC87008 08135500 BE SPARNB 8-bit is off @SC87008 08136000 CLI LCKFRC,X'21' Forcing locks? @SC91275 08136500 BE SPARNB Yes, turn off 8-bit quote @SC91275 08137000 CLM 4,1,=AL1(AY) @SC86120 08137500 BNE *+8 @SC86120 08138000 IC 4,EBQC Micro agrees @SC86120 08138500 BAL 14,SPARCKQX @SC86120 08139000 B SPARNB Micro says no 8-bit quoting @SC86120 08139500 CLI EBQ,0 08140000 BE SPAREBQ Use it if we agree 08140500 CLM 4,1,EBQ @SC86120 08141000 BE SPAREBQ Or we match 08141500 SPARNB SR 4,4 Otherwise cannot do it 08142000 SPAREBQ STC 4,EBQ Set 8-bit-quoting char/flag 08142500 BAL 14,SPARFTCH @SC86120 08143000 CLM 4,1,=AL1(AB) @SC92085 08143500 BE SPARBCM Go if 'B' @SC92085 08144000 CH 4,SPARBCD+2 @SC92085 08144500 BL SPARBCD Go if less than 1, use 1 @SC92085 08145000 CLM 4,1,=AL1(A3) @SC92085 08145500 BH SPARBCD Go if over 3, use 1 @SC92085 08146000 SPARBCM CLM 4,1,BCTR Requested and our BCT same? @SC92085 08146500 BE SPARBCT Yes, they are the same 08147000 CLI BCTR,0 08147500 BE SPARBCT We'll accept anything 08148000 SPARBCD LA 4,A1 We don't match, use 1 @SC92085 08148500 SPARBCT STC 4,BCTR Micro's chksum length 08149000 BAL 14,SPARFTCH @SC86120 08149500 BAL 14,SPARCKQX See if valid @SC86120 08150000 B SPARNR No good @SC86120 08150500 CLM 4,1,EBQ @SC86120 08151000 BE SPARNR Go if same prefix 08151500 CLI RPTQ,0 08152000 BE SPARRQ We can use anything 08152500 CLM 4,1,RPTQ @SC86120 08153000 BE SPARRQ We match 08153500 SPARNR SR 4,4 No repeat quoting 08154000 SPARRQ STC 4,RPTQ Use negotiated repeat quote 08154500 BAL 14,SPARFTCH Get capabilities @SC86149 08155000 UNCHR 4,,RCAPA @SC86149 08155500 MVC LCKCAPA,RCAPA See if agree on locking shift @SC91275 08156000 NC LCKCAPA,SCAPA @SC91275 08156500 NI LCKCAPA,X'20' @SC91275 08157000 CLI EBQ,0 Negotiated 8-bit quoting? @SC91275 08157500 BNE *+8 Yes, locking is permitted @SC91275 08158000 MVI LCKCAPA,0 No, suppress locking @SC91275 08158500 OC LCKCAPA,LCKFRC Set anyway if FORCE mode @SC91275 08159000 TM RCAPA,LONGP Test for long packet bit @TB86196 08159500 BZ SPARNX No extended packets @TB86196 08160000 MVC TMP,RCAPA @SC86202 08160500 SPARNS1 TM TMP,MORCAPAS Test for more CAPAS bytes @SC86202 08161000 BZ SPARNS2 No more @TB86196 08161500 BAL 14,SPARFTCH Get capabilities @TB86196 08162000 UNCHR 4,,TMP @TB86196 08162500 B SPARNS1 @TB86196 08163000 SPARNS2 BAL 14,SPARFTCH Skip window byte @SC86202 08163500 BAL 14,SPARFTCH Get next header byte @TB86196 08164000 LR 1,4 @TB86196 08164500 UNCHR 1 MAXLX1 byte @TB86196 08165000 MH 1,XLFCT+2 Times the factor @SC86202 08165500 BAL 14,SPARFTCH Get next header byte @TB86196 08166000 UNCHR 4 MAXLX2 byte @TB86196 08166500 AR 1,4 Compute total length @TB86196 08167000 BNP SPARNX If zero, use default @TB86196 08167500 ST 1,SPSIZ New SPSIZ for extended @TB86196 08168000 SPARNX DS 0H @TB86196 08168500 * Now compute MAXSIZ 08169000 L 5,SPSIZ Maximum send packet size 08169500 LA 6,MAXWS Longest full-screen write @SC92030 08170000 BAL 14,TTYCHK @SC92030 08170500 LA 6,MAXWT Longest linemode write @SC92030 08171000 CLI TRMTP,C'F' @SC92030 08171500 BNE *+8 Not a full-screen non-transparent @SC92030 08172000 LA 6,77 Strictly limited @SC92030 08172500 CR 5,6 @SC92030 08173000 BNH SPAREHL @SC90134 08173500 LR 5,6 Biggest we can send @SC92030 08174000 SPAREHL S 5,F3 SOP, LEN, EOP don't count in LEN @SC92030 08174500 IC 4,SPADN Length of padding, if any @SC90277 08175000 SR 5,4 Part of I/O limit if long @SC90277 08175500 CLI S1HND,0 @SC90010 08176000 BE SPARNY Ok, no handshake @SC90010 08176500 BCTR 5,0 Deduct one for handshake @SC90010 08177000 SPARNY DS 0H @SC86205 08177500 C 5,AKMAX Can this be a long packet? @SC92030 08178000 BNH *+8 No @SC92030 08178500 S 5,F3 Yes, minus extended header length @SC92030 08179000 S 5,F3 Minus SEQ,TYP, and quoting leeway @SC92030 08179500 IC 4,BCTR Get user's negotiated BCT 08180000 N 4,F Get just length code: 1,2,3 @SC92085 08180500 SR 5,4 Minus checksum length 08181000 CLI EBQ,0 08181500 BE SPARNEBQ Go if no 8-Bit quoting 08182000 BCTR 5,0 Another one for 8-bit quoting 08182500 SPARNEBQ CLI RPTQ,0 08183000 BE SPARNRQ Go if no repeat char quoting 08183500 BCTR 5,0 08184000 BCTR 5,0 Minus two for repeat prefix 08184500 SPARNRQ ST 5,MAXSIZ Save max length for data field 08185000 ST 5,MAXSIZ+4 Static extra copy (for tuning) 08185500 CLI TRMTP,C'F' FULLSCREEN? @SC93173 08186000 BNE SPARCTST @SC93173 08186500 XC CTLTAB(32),CTLTAB Yes, must encode everything @SC93173 08187000 XC CTLTAB+127(33),CTLTAB+127 (DEL + C1) @SC93173 08187500 SPARCTST LA 1,XOFF Pretty dangerous to send XOFF! @SC93173 08188000 BAL 14,SPARENC @SC93173 08188500 IC 1,SEOL Must encode EOL @SC93173 08189000 BAL 14,SPARENC @SC93173 08189500 IC 1,SMARK Must encode SOP @SC93173 08190000 BAL 14,SPARENC @SC93173 08190500 IC 1,S1HND Must encode handshake @SC93173 08191000 BAL 14,SPARENC @SC93173 08191500 MVI CTLTAB+ABL,1 Mark all printables unprefixed @SC93173 08192000 MVC CTLTAB+ABL+1(94),CTLTAB+ABL @SC93173 08192500 SPARBAK RET @SC86152 08193000 * 08193500 SPARENC CL 1,=F'160' Proper control? @SC93173 08194000 BNLR 14 No, ignore this one @SC93173 08194500 LTR 1,1 Assume "0" means not defined @SC93173 08195000 BZR 14 and ignore such @SC93173 08195500 SR 0,0 @SC93173 08196000 STC 0,CTLTAB(1) Mark this one to encode @SC93173 08196500 BR 14 @SC93173 08197000 * 08197500 SPARCKQX CLM 4,1,RCTLQ @SC86120 08198000 BER 14 Cannot use same prefix @SC86120 08198500 CLM 4,1,SCTLQ @SC86120 08199000 BER 14 @SC86120 08199500 B CHKQR Test if 33-62 or 96-126 @SC86120 08200000 SPARFTCH L 4,SPACE Default @SC86120 08200500 BXH 5,6,*+8 Check for more data @SC86120 08201000 IC 4,0(5) OK, use it @SC86120 08201500 C 4,SPACE Default? @SC86120 08202000 BNER 14 @SC86120 08202500 IC 4,0(5,8) Yes, get default value @SC86190 08203000 BR 14 @SC86120 08203500 * 08204000 * SPARSET Routine - set up for exchange (SPAR 1st) @SC86152 08204500 * 08205000 SPARSET ENTER ALT @SC86152 08205500 MVI BCTR,0 Use whatever micro wants @SC86152 08206000 MVI EBQ,0 @SC86152 08206500 MVI RPTQ,0 @SC86152 08207000 MVI BCTU,1 Must start at 1 @SC86295 08207500 MVC BCTOFF,F0 (and flag at 0) @SC92085 08208000 B SPARBAK @SC86152 08208500 LOCALS , @SC86295 08209000 SPAR EXIT 08209500 TITLE 'RPAR Routine - sets up parms to send to other host' 08210000 RPAR ENTER 08210500 OI FL3,PXCH Parameters exchanged now @SC87012 08211000 L 9,ASDATA @SC86295 08211500 TOCHR 5,RTIMO,1(9) Time limit for micro to wait @SC86295 08212000 TOCHR 5,RPADN,2(9) Number of padding chars. @SC86295 08212500 CTL 5,RPADC,3(9) Pad character @SC86295 08213000 TOCHR 5,REOL,4(9) EOL char I need @SC86295 08213500 MVC 5(1,9),SCTLQ @SC86295 08214000 MVC 6(1,9),EBQ @SC86295 08214500 CLI EBQ,0 08215000 BNE RPARBCT It's OK if not null 08215500 MVI 6(9),AN Else, use an N @SC86295 08216000 RPARBCT MVC 7(1,9),BCTR Negotiated checksum @SC86295 08216500 MVC 8(1,9),RPTQ @SC86295 08217000 CLI RPTQ,0 08217500 BNE *+8 It's ok if not null @SC86149 08218000 MVI 8(9),ABL Else, use a blank @SC86295 08218500 LA 0,10 Size of data @SC86149 08219000 NI SCAPA,255-LONGP No long packets @TB86196 08219500 L 5,RPSIZ Packet size @SC92030 08220000 L 6,AMAXRS Biggest send for full-screen @SC92030 08220500 CLI TRMTP,C'A' 3174 AEA mode? @SC92030 08221000 BNE *+8 No, fine @SC92030 08221500 LA 6,127 Strict limit of 3174 buffer @SC92030 08222000 BAL 14,TTYCHK @SC92030 08222500 L 6,AMAXRT TTY limited separately by system @SC92030 08223000 CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 08223500 BNE *+8 No @SC92030 08224000 LA 6,78 Strict limit @SC92030 08224500 CR 5,6 @SC92030 08225000 BNH *+6 @SC92030 08225500 LR 5,6 Biggest we can receive @SC92030 08226000 LA 4,KMAX Limit for short packets @SC92030 08226500 CR 4,5 Check against actual limit @SC92030 08227000 BNH *+6 @SC92030 08227500 LR 4,5 Use actual limit @SC92030 08228000 TOCHR 4,,0(9) Largest short packet size @SC92030 08228500 C 5,AKMAX Are we allowing long packets? @SC92030 08229000 BNH RPARNEX KMAX >= RPSIZ @SC92030 08229500 OI SCAPA,LONGP Long packets @TB86196 08230000 MVI 10(9),ABL Window size is blank @SC86295 08230500 RPARS1 SR 4,4 @SC86205 08231000 SH 5,=H'7' Allow for long header @SC90277 08231500 D 4,XLFCT Compute extended size bytes @TB86196 08232000 TOCHR 5,,11(9) Extended size 1 @SC86295 08232500 TOCHR 4,,12(9) Extended size 2 @SC86295 08233000 LA 0,13 Size of data @TB86196 08233500 RPARNEX DS 0H @TB86196 08234000 TOCHR 5,SCAPA,9(9) Capabilities @SC86295 08234500 ST 0,DATL Return it @SC86149 08235000 LA 0,3 Reset function @SC86295 08235500 BAL 14,TTYCHK @SC92030 08236000 B RPARSTT Line mode @SC92030 08236500 KCALL SCRNIO @SC86295 08237000 B RPARBAK @SC86295 08237500 RPARSTT KCALL TERMIO @SC86295 08238000 RPARBAK RET @SC86152 08238500 * 08239000 * RPARSET Routine - set up for exchange (RPAR 1st) @SC86152 08239500 * 08240000 RPARSET ENTER ALT @SC86152 08240500 MVI BCTU,1 Must start at 1 @SC86295 08241000 MVC BCTOFF,F0 (and flag at 0) @SC92085 08241500 CLI TRMTP,C'F' @SC92030 08242000 BNE *+8 @SC92030 08242500 MVI S1EOL,AEXCL Insist on printable EOL for FULL @SC92030 08243000 TM FL2,SRV Possible I-packet exchange? @SC87169 08243500 BZ RPSCLR Not in Server mode @SC87169 08244000 TM FL3,PXCH Any exchange since last SET? @SC87169 08244500 BO RPARBAK Yes, keep latest settings @SC87169 08245000 RPSCLR MVC BCTR,BCTC Use what user set @SC87169 08245500 TR BCTR,ETOAD Convert to ASCII code @SC92085 08246000 MVC EBQ,EBQC Set what we want otherwise @SC86152 08246500 CLI LCKFRC,X'21' Forcing locks? @SC91275 08247000 BNE RPSEBQ No, ok @SC91275 08247500 MVI EBQ,0 Yes, disable 8-bit quote @SC91275 08248000 RPSEBQ CLI RPTQ,0 @SC86152 08248500 BNE RPARBAK If RPTQ is set leave it alone @SC86152 08249000 MVC RPTQ,RPTQC Set what we want otherwise @SC86152 08249500 B RPARBAK @SC86152 08250000 LOCALS , @SC86295 08250500 RPAR EXIT 08251000 TITLE 'ENCODE Routine - encode pkts from RBUF into DATA' 08251500 ENCODE ENTER 08252000 L 6,MAXSIZ @SC86295 08252500 L 9,ASDATA Pointer to data to fill @SC86190 08253000 AR 6,9 Limit on output @SC86295 08253500 ENCAGAIN L 8,RBUFP Index of next char in RBUF 08254000 L 5,RBUFL Data length in RBUF @SC86163 08254500 L 1,RBUF Point to start of buffer 08255000 AR 5,1 Point to char after last one 08255500 AR 8,1 Point to char to encode @SC86163 08256000 CR 8,1 Are we at the start? @SC91116 08256500 BH ENCNXT No, proceed @SC91116 08257000 TM FL1,NAME @SC91320 08257500 BO ENCNXT Names don't have CC anyway @SC91320 08258000 TM FL1,EOF Are we at the end? @SC91116 08258500 BO ENCNXT Yes, quit inserting CC @SC91116 08259000 TM FLNFLGS,FLNCC Yes, see if handling carriage ctl @SC91116 08259500 BZ ENCNXT No, proceed @SC91116 08260000 CR 5,1 Are we before 1st record? @SC91116 08260500 BE ENCNXT Yes, must read and look again @SC91116 08261000 SR 1,1 @SC91116 08261500 ICM 1,1,CARCTL @SC91116 08262000 BZ ENCNXTIN @SC91116 08262500 C 1,F3 @SC91116 08263000 BH ENCNXT Already set up: 1 replacement @SC91116 08263500 LA 0,0(1,9) Allow for the inserts @SC91116 08264000 CR 0,6 Plenty of room? @SC91116 08264500 BH ENCGOOD No, dump out a packet now @SC91116 08265000 ENCCCLP MVC 0(1,9),SCTLQ Insert a LF @SC91116 08265500 MVI 1(9),ALF+64 @SC91116 08266000 LA 9,2(,9) @SC91116 08266500 BCT 1,ENCCCLP Repeat correct number of LF's @SC91116 08267000 B ENCNXTIN Done inserting @SC91116 08267500 ENCNXT CR 8,5 Are we past the last char? @SC86163 08268000 BL ENCPKT No, not exhausted RBUF yet @SC86163 08268500 TM FL1,NAME @SC86163 08269000 BO ENCEMPT No more disk read if file name @SC86163 08269500 KCALL INBUF,E=ENCRET @SC86163 08270000 B ENCAGAIN @SC86163 08270500 ENCPKT MVC NEWCHAR,0(8) Get next input character @SC91275 08271000 TM LCKCAPA,X'20' @SC91275 08271500 BZ ENCLKZ Locking shift not enabled @SC91275 08272000 MVC LCKNEW,0(8) Look ahead 5 characters @SC91275 08272500 NC LCKNEW,=5X'80' Grab the 8th bits @SC91275 08273000 CLC LCKOLD,LCKNEW Is the next one the right state? @SC91275 08273500 BE ENCLKOK Yes, go on @SC91275 08274000 CLI EBQ,0 8th-bit quoting allowed? @SC91275 08274500 BE ENCLKSW No, must switch @SC91275 08275000 CLI 0(8),CR @SC91275 08275500 BE ENCLKSW CR, prevent interference with CC @SC91275 08276000 CLI 0(8),SI+128 @SC91275 08276500 BE ENCLKOK Avoid quoting shifted <1>SI @SC91275 08277000 CLC LCKNEW(4),LCKNEW+1 Different state; isolated? @SC91275 08277500 BNE ENCLKOK Yes, keep same state @SC91275 08278000 ENCLKSW MVC LCKOLD,LCKNEW Adjust state @SC91275 08278500 MVC 0(1,9),SCTLQ Insert prefix @SC91275 08279000 MVI 1(9),SO+64 Make a Shift Out @SC91275 08279500 CLI LCKNEW,X'80' 8-bit chars? @SC91275 08280000 BE *+8 Yes, that's it @SC91275 08280500 MVI 1(9),SI+64 No, make a Shift In @SC91275 08281000 LA 9,2(,9) Advance output ptr @SC91275 08281500 CR 9,6 Did we reach max pkt size? @SC91275 08282000 BNL ENCFULL Yes, must empty buffer now @SC91275 08282500 ENCLKOK XC NEWCHAR,LCKOLD Apply state @SC91275 08283000 CLI NEWCHAR,SO @SC91275 08283500 BL ENCLKZ Not a data-link special @SC91275 08284000 CLI NEWCHAR,DLE @SC91275 08284500 BH ENCLKZ Not a special @SC91275 08285000 LA 14,2(,9) Updated pointer @SC91275 08285500 CR 14,6 Special, is there enough room? @SC91275 08286000 BNL ENCFULL No, must empty buffer now @SC91275 08286500 MVC 0(1,9),SCTLQ Special, quote with DLE @SC91275 08287000 MVI 1(9),DLE+64 @SC91275 08287500 LR 9,14 Advance ptr @SC91275 08288000 ENCLKZ CLI RPTQ,0 @SC91275 08288500 BE ENCEBQ Go if no repeat quoting 08289000 CLC 0(1,8),1(8) At least 2 of these? @SC92052 08289500 BNE ENCEBQ No, not enough @SC86163 08290000 LA 14,2(,8) Next untested character @SC92052 08290500 LR 2,8 Start of string @SC86163 08291000 LA 3,KMAX(8) Max allowed by notation @SC86163 08291500 CR 3,5 Watch for end of data @SC86163 08292000 BNH *+6 @SC86163 08292500 LR 3,5 Truncate at max @SC86163 08293000 LR 15,3 Same limit @SC86163 08293500 SR 3,2 Get lengths @SC86163 08294000 SR 15,14 Length of shorter string @SC86163 08294500 BM ENCEBQ 2nd one wasn't real after all @SC92052 08295000 ICM 15,8,0(8) Use starting char for fill @SC86163 08295500 CLCL 2,14 Find end of match @SC86163 08296000 SR 14,8 Get repeat count @SC86163 08296500 C 14,=A(RPTMIN) Enough to justify? @SC92052 08297000 BL ENCEBQ No, not enough @SC92052 08297500 AR 8,14 Advance ptr to @SC86163 08298000 BCTR 8,0 last matching char @SC86163 08298500 MVC 0(1,9),RPTQ Put repeat quote into DATA @SC86163 08299000 TOCHR 14,,1(9) @SC86163 08299500 LA 9,2(9) Count 2 for RPTQ and rpt count @SC86295 08300000 ENCEBQ TM NEWCHAR,X'80' 8th bit on? @SC91275 08300500 BZ ENCCTL no 8th bit 08301000 CLI EBQ,0 08301500 BNE ENC8B Can use 8bit quoting, do it @SC89072 08302000 TM SPRTY,DAT8 Can't: see if 8-bit channel @SC89072 08302500 BO ENCCTL Yes, that's ok too @SC89072 08303000 MVI ERRNUM,ERRPTY No, can't send this byte! @SC89072 08303500 LA 15,1 @SC89072 08304000 B ENCRET Save length, in case ERPACK loop @SC89072 08304500 ENC8B DS 0H @SC89072 08305000 NI NEWCHAR,127 Get rid of 8th bit @SC91275 08305500 MVC 0(1,9),EBQ Move EBQ into DATA 08306000 LA 9,1(9) Count for it @SC86295 08306500 ENCCTL IC 7,NEWCHAR Load desired char @SC91275 08307000 CLI NEWCHAR,160 Corresponds to control character? @SC93173 08307500 BNL ENCNCTL Not within control range @SC93173 08308000 TRT NEWCHAR,CTLTAB Check table of safe ctls @SC93173 08308500 BNZ ENCNCTLT Don't need to encode it @SC93173 08309000 ENCSCTL CTL 7 Convert to non-control @SC86163 08309500 B ENCMVCTL 08310000 * 08310500 ENCNCTLT LTR 7,7 @SC93173 08311000 BZ ENCNOCTL NUL can't be a prefix char @SC93173 08311500 ENCNCTL CLM 7,1,SCTLQ @SC93173 08312000 BE ENCMVCTL send prefix if ctl quote char 08312500 CLM 7,1,EBQ @SC93173 08313000 BE ENCMVCTL ditto if 8bit quote 08313500 CLM 7,1,RPTQ @SC93173 08314000 BNE ENCNOCTL not so if not repeat quote 08314500 ENCMVCTL MVC 0(1,9),SCTLQ Move a ctl quote 08315000 LA 9,1(9) incr for it 08315500 ENCNOCTL STC 7,0(9) Move the char, finally! @SC86163 08316000 LA 9,1(9) incr for it 08316500 ENCNXTIN MVI CARCTL,1 Indicate started output @SC91116 08317000 LA 8,1(8) Incr RBUF pointer @SC86163 08317500 CR 9,6 Did we reach max pkt size? @SC86295 08318000 BL ENCNXT Test for more data @SC86295 08318500 * 08319000 ENCFULL CR 8,5 Are we past the last char? @SC86163 08319500 BL ENCGOOD No, not exhausted RBUF data yet @SC86163 08320000 ENCEMPT XC RBUFL,RBUFL Zap data length for next time @SC86163 08320500 ENCGOOD SR 15,15 08321000 S 8,RBUF Get current index @SC86163 08321500 ST 8,RBUFP Save RBUF index 08322000 ENCRET S 9,ASDATA Get length @SC86295 08322500 ST 9,DATL Save encoded DATA length @SC86295 08323000 RET , @SC86295 08323500 LOCALS , @SC86295 08324000 LCKNEW DS CL5 5-byte lookahead for shift lock @SC91275 08324500 NEWCHAR DS C Current character with shifts @SC91275 08325000 ENCODE EXIT 08325500 TITLE 'NPREAD Routine - copy from RBUF to SDATA' @HF86150 08326000 NPREAD ENTER @HF86150 08326500 L 6,SPSIZ Max packet length @SC86295 08327000 LR 4,6 Save @SC86295 08327500 L 9,ASPKT Fill pointer (includes header) @SC86165 08328000 SR 7,7 @SC86165 08328500 ICM 7,1,TCTLQ Fetch control quote @SC91180 08329000 BZ *+8 Quoting is off @SC91180 08329500 ICM 7,2,EBQC Get 8th-bit quote as well @SC91180 08330000 NPRAGAIN L 8,RBUFP Index of next char in RBUF @SC86165 08330500 L 5,RBUFL Data length in RBUF @SC86165 08331000 L 1,RBUF Start of buffer @SC86165 08331500 AR 5,1 Point to char after last one @SC86165 08332000 AR 8,1 Point to char to encode @SC86165 08332500 CR 8,1 Are we at the start? @SC91116 08333000 BH NPRNXT No, proceed @SC91116 08333500 TM FLNFLGS,FLNCC Yes, see if handling carriage ctl @SC91116 08334000 BZ NPRNXT No, proceed @SC91116 08334500 TM FL1,BINF @SC91116 08335000 BO NPRNXT No CC if binary @SC91116 08335500 CR 5,1 Are we before 1st record? @SC91116 08336000 BE NPRNXT Yes, must read and look again @SC91116 08336500 SR 1,1 @SC91116 08337000 ICM 1,1,CARCTL @SC91116 08337500 BZ NPRNXTIN @SC91116 08338000 C 1,F3 @SC91116 08338500 BH NPRNXT Already set up: 1 replacement @SC91116 08339000 CR 1,6 Plenty of room? @SC91116 08339500 BH NPRGOOD No, dump out a packet now @SC91116 08340000 NPRCCLP MVI 0(9),ALF Insert a LF @SC91116 08340500 LA 9,1(,9) @SC91116 08341000 BCTR 6,0 Count down space remaining @SC91116 08341500 BCT 1,NPRCCLP Repeat correct number of LF's @SC91116 08342000 NPRNXTIN MVI CARCTL,1 Mark it begun @SC91116 08342500 LA 8,1(,8) Skip over the control @SC91116 08343000 LTR 6,6 @SC91116 08343500 BNP NPRGOOD @SC91116 08344000 NPRNXT CR 8,5 Are we past the last char? @SC86165 08344500 BL NPRTCT No, not exhausted RBUF yet @SC86165 08345000 NPRRD KCALL INBUF,E=NPRRET @HF86150 08345500 B NPRAGAIN @SC86165 08346000 NPRTCT LTR 7,7 Test for quoting @SC86165 08346500 BZ NPRNOCTL Not enabled @HF86150 08347000 MVI NPR8B,0 Clear the 8th bit flag @SC91180 08347500 CLM 7,2,0(8) 8th-bit quote? @SC91180 08348000 BNE NPRNO8B No, ok @SC91180 08348500 MVI NPR8B,128 Yes, set flag @SC91180 08349000 LA 8,1(,8) Next byte is what counts @SC91180 08349500 CR 8,5 @SC91180 08350000 BNL NPRRD Ran out of data, ignore the quote @SC91180 08350500 NPRNO8B DS 0H @SC91180 08351000 CLM 7,1,0(8) Is it a quote character? @HF86150 08351500 BNE NPRNOCT0 No, copy it @SC91180 08352000 LA 8,1(8) Check next @HF86150 08352500 CR 8,5 @HF86150 08353000 BNL NPRRD Ran out of data, ignore the quote @HF86150 08353500 CLM 7,2,0(8) If 8th-bit quote character, @SC91180 08354000 BE NPRNOCT0 it was quoted, so use it. @SC91180 08354500 CLM 7,1,0(8) If repeat of quote character @HF86150 08355000 BE NPRNOCT0 it was quoted, so use it. @SC91180 08355500 NI 0(8),X'1F' Make control character @HF86150 08356000 NPRNOCT0 OC 0(,8),NPR8B Get proper 8th bit @SC91180 08356500 NPRNOCTL MVC 0(1,9),0(8) Copy the char @HF86150 08357000 LA 9,1(9) Incr for it @HF86150 08357500 LA 8,1(8) Incr RBUF pointer @HF86150 08358000 BCT 6,NPRNXT Get next character if any room @SC86295 08358500 * 08359000 NPRGOOD SR 15,15 @HF86150 08359500 S 8,RBUF Convert to index @SC86165 08360000 ST 8,RBUFP Save it @SC86165 08360500 NPRRET SR 4,6 Get DATA length @SC86295 08361000 ST 4,SNDPKL Save it @HF86150 08361500 RET @HF86150 08362000 LOCALS , @SC86295 08362500 NPR8B DS X 8th bit flag @SC91180 08363000 NPREAD EXIT @HF86150 08363500 TITLE 'DECODE Routine - decode pkts from DATA to WBUF' 08364000 * Exit: ERRNUM left unchanged unless there is an error. 08364500 DECODE ENTER 08365000 ICM 5,B'1111',DATL Data length to decode 08365500 BNP DECNULL No data to decode @SC91247 08366000 TM FL1,EOF 08366500 BO DECNULL Ignore if ctl-z caused EOF 08367000 L 1,WBUF Point to output buffer 08367500 L 9,WBUFL Number of chars in it 08368000 AR 1,9 Point to next spot to fill 08368500 L 8,ARDATA Data to be decoded @SC86190 08369000 AR 5,8 Point one past the last char 08369500 DECLOOP LA 3,1 Repeat count @SC86316 08370000 CLI RPTQ,0 08370500 BE DECEBQ Not doing repeats 08371000 CLC RPTQ,0(8) 08371500 BNE DECEBQ Not the repeat quote 08372000 UNCHR 3,1(8) Get number of repeats @SC86316 08372500 LA 8,2(8) skip to char to decode 08373000 DECEBQ MVI CUR,0 No 8th bit yet 08373500 CLI EBQ,0 08374000 BE DECCTL Not doing 8bit quoting 08374500 CLC EBQ,0(8) 08375000 BNE DECCTL Not the 8bit quote 08375500 LA 8,1(8) point to char to decode 08376000 MVI CUR,128 8th bit seen 08376500 DECCTL CLC RCTLQ,0(8) 08377000 BNE DECCHR not the ctl quote 08377500 LA 8,1(8) point to char to decode 08378000 MVC TMPC,0(8) @SC90270 08378500 NI TMPC,127 Look at low 7 bits @SC90270 08379000 CLI TMPC,63 @SC90270 08379500 BL DECCHR skip if not in ctl range 08380000 CLI TMPC,95 @SC90270 08380500 BH DECCHR skip if not in ctl range 08381000 CTL 4,0(8),0(8) Ctl it 08381500 DECCHR OC 0(1,8),CUR put in the parity 08382000 TM LCKCAPA,X'20' Locking shift enabled? @SC91275 08382500 BZ DECCH2 No, just do the byte @SC91275 08383000 CLI DECESCP,DLE Escape pending? @SC91275 08383500 BE DECCH2 Yes, just do the byte @SC91275 08384000 CLI 0(8),SO No, see if special coming @SC91275 08384500 BL DECCH2 No @SC91275 08385000 CLI 0(8),DLE @SC91275 08385500 BH DECCH2 No @SC91275 08386000 MVC DECESCP,0(8) Save special indicator @SC91275 08386500 BE DECINCIN Escape: ignore and suppress repeat@SC91275 08387000 XI 0(8),X'0F' SO->1, SI->0 @SC91275 08387500 IC 14,0(,8) Convert to new state byte @SC91275 08388000 SLL 14,7 @SC91275 08388500 STC 14,LCKOLD Save it @SC91275 08389000 B DECINCIN Nothing further on this byte @SC91275 08389500 DECCH2 MVI DECESCP,0 Not an escape @SC91275 08390000 XC 0(1,8),LCKOLD Put to current state @SC91275 08390500 MVC CUR,0(8) move it here also 08391000 DECRLOOP TM FL1,NAME 08391500 BO DECPUT skip if not writing to disk 08392000 LTR 7,9 Started yet? @SC86316 08392500 BZ DECTFUL No @SC86151 08393000 C 9,RDWLEN @SC86151 08393500 BNE DECTFUL @SC86151 08394000 L 6,WBUF Just finished RDW @SC86316 08394500 SR 14,14 @SC86151 08395000 ICM 14,3,0(6) Get expected length @SC86316 08395500 C 9,F2 Short? @SC86262 08396000 BE DECVLEN Yes, we got it @SC86262 08396500 TR 0(5,6),ATOED No, must be 5-byte ASCII prefix @SC89301 08397000 BAL 14,GETNUM Read length field @SC86316 08397500 B DECDLBAD Bad @SC91247 08398000 LR 14,0 @SC86316 08398500 DECVLEN DS 0H @SC86262 08399000 AR 14,9 + RDW length @SC86151 08399500 ST 14,MAXOUT Reset byte limit @SC86151 08400000 DECTFUL C 9,MAXOUT Max write buffer size reached? @SC86151 08400500 BL DECMORE No, keep appending @SC88120 08401000 KCALL OUTBUF,(9),E=RTRN1 Yes, write buffer @SC88120 08401500 SR 9,9 Reset count and output pointer @SC88120 08402000 L 1,WBUF @SC88120 08402500 TM FL1,BINF @SC88120 08403000 BO DECPUT Binary always folds, no problem @SC88120 08403500 CLI CUR,CR Exactly full just in time? @SC88120 08404000 BE DECIGN Yes, don't create empty line @SC88120 08404500 LA 0,1 Other, this is called folding @SC88120 08405000 A 0,RECFLD @SC88120 08405500 ST 0,RECFLD @SC88120 08406000 B DECPUT Ok, now copy the new character @SC88120 08406500 DECMORE TM FL1,BINF 08407000 BO DECPUT No special test in binary mode 08407500 CLI CUR,CR 08408000 BE DECWRT A cr means end of record 08408500 CLI CUR,ALF @SC89301 08409000 BNE DECTAB Not an LF 08409500 CLI PREV,CR 08410000 BE DECIGN A cr/lf together = ignre the LF 08410500 DECWRT KCALL OUTBUF,(9),E=RTRN1 Write buffer @SC88120 08411000 SR 9,9 Reset length to resume decoding 08411500 L 1,WBUF Reset pointer also 08412000 B DECIGN 08412500 * 08413000 DECTAB TM FL2,TABS 08413500 BZ DECCTLZ Skip if not expanding tabs 08414000 CLI CUR,AHT @SC89301 08414500 BNE DECCTLZ Not a tab 08415000 LR 0,1 Save output ptr @SC86355 08415500 LH 2,TABCNT Get count of tabs that are set @TS86100 08416000 LTR 2,2 Any? @SC86355 08416500 BZ DECTL8 No, use every 8 cols @SC86355 08417000 LA 7,TABTBL Yes, point to table of tabs @TS86100 08417500 SR 1,1 @TS86100 08418000 DECTLP IC 1,0(7) Get tab column from table @TS86100 08418500 BCTR 1,0 Adjust for displacement compare @TS86100 08419000 CR 1,9 Where is this tab compared to buf @TS86100 08419500 BH DECTLX Above buffer position @TS86100 08420000 LA 7,1(7) Point to next tab position @TS86100 08420500 BCT 2,DECTLP Continue with next tab @TS86100 08421000 DECTL8 DS 0H @SC86355 08421500 LA 1,8(9) Buffer pointer + 8 @SC86355 08422000 SRL 1,3 @SC86355 08422500 SLL 1,3 Round up to multiple of 8 @SC86355 08423000 DECTLX C 1,MAXLRC @SC86355 08423500 BL *+8 @SC86355 08424000 L 1,MAXLRC Don't go past end of buffer @SC86355 08424500 SR 1,9 Number of blanks to add @SC86355 08425000 AR 9,1 Advance the count @SC86355 08425500 LA 15,ABL @SC86355 08426000 SLL 15,24 Set for ASCII blank fill @SC86355 08426500 MVCL 0,14 Jump to tab stop @SC86355 08427000 LR 1,0 Restore output ptr @SC86355 08427500 B DECIGN skip to the end of this 08428000 * 08428500 DECCTLZ TM FL2,EOFZ 08429000 BZ DECPUT Skip if EOF is off 08429500 CLI CUR,ASUB @SC89301 08430000 BNE DECPUT Skip if not a ctl-z 08430500 OI FL1,EOF Fake an end-of-file 08431000 B DECEOF all done 08431500 * 08432000 DECPUT C 9,F64KP Still within disk buffer? @SC90338 08432500 BNL *+10 No, don't copy @SC86355 08433000 MVC 0(1,1),0(8) Yes, put the data in buffer @SC86355 08433500 LA 9,1(9) Increment count 08434000 LA 1,1(1) Increment pointer 08434500 DECIGN MVC PREV,CUR copy the decoded char 08435000 BCT 3,DECRLOOP Repeat it repeat count times @SC86316 08435500 DECINCIN LA 8,1(,8) Bump input data ptr @SC91275 08436000 CR 8,5 Did we reach end of DATA? 08436500 BL DECLOOP No, More data left to decode 08437000 DECEOF ST 9,WBUFL Save buffer length 08437500 DECNULL B RTRN0 Good return code @SC86295 08438000 * 08438500 DECDLBAD MVI ERRNUM,ERRBPC Bad length field for D-binary @SC91247 08439000 B RTRN1 @SC91247 08439500 LOCALS , @SC86295 08440000 CUR DS C Char being decoded @SC86295 08440500 TMPC DS C Low 7 bits of char @SC90270 08441000 DECODE EXIT 08441500 TITLE 'ERPACK Routine - send error packet with errnum' 08442000 ERPACK ENTER 08442500 CLI ERRNUM,ERRABO @SC86295 08443000 BE RTRN0 Skip it if the micro died @SC86295 08443500 CLOSF SIMPTR In case we were replaying this @SC91312 08444000 MVI STYPE,AE Error packet 08444500 MVC SEQ,RSN Synch packet numbers 08445000 SR 5,5 08445500 IC 5,ERRNUM Get right message number 08446000 SLL 5,2 Pointer offset = ERRNUM * 4 @SC86156 08446500 A 5,=A(ERRTAB) Pointer address @SC89215 08447000 L 3,0(5) Msg ptr @SC86156 08447500 SR 4,4 @SC86156 08448000 IC 4,0(5) Msg length @SC86156 08448500 TM FL2,PROTO @SC87300 08449000 BZ RTRN0 Skip packet if never started @SC87300 08449500 TM FL3,ZPRO @SC92064 08450000 BO *+12 Must stop, even if server mode @SC92064 08450500 TM FL2,SRV Server will read another command @SC87343 08451000 BO *+12 so don't zap write/read flag @SC90173 08451500 MVI WRRD,0 No read ncessary for Err pkt @SC87300 08452000 MVI AEAFLG,X'80' ditto @SC90173 08452500 L 1,RBUF 08453000 MVC 0(50,1),0(3) Put data in RBUF (and some extra) @SC86156 08453500 CLI ERRNUM,ERRTRC Cancelled? @SC91172 08454000 BNE ERPCODE No, message is complete @SC91172 08454500 SR 9,9 @SC91172 08455000 CLI REASON,STACNN Within table? @SC91172 08455500 BH *+8 No, must be new @SC91172 08456000 IC 9,REASON Ok, get the complaint code @SC91172 08456500 SLL 9,3 Index into table @SC91172 08457000 A 9,=A(STACNTB) @SC91172 08457500 LA 3,0(4,1) Offset to end of message @SC91172 08458000 MVI 0(3),C' ' Leave a space @SC91172 08458500 MVC 1(8,3),0(9) Get type of cancellation @SC91172 08459000 LA 4,9(,4) Lengthen message @SC91172 08459500 ERPCODE ST 4,RBUFL Save length to encode @SC91172 08460000 TR 0(50,1),ETOAD ASCII it @SC89301 08460500 LA 8,F0 Point to null list @SC89072 08461000 BAL 9,ENCODEN @SC86295 08461500 KCALL SPACK Send error packet @SC86135 08462000 RET 08462500 LOCALS , @SC86295 08463000 ERPACK EXIT 08463500 TITLE 'SPACK Routine - sends DATA buffer' 08464000 SPACK ENTER 08464500 SR 3,3 Zero out IC register 08465000 L 8,AASPKT SNDPKT address @SC86295 08465500 SPKNX3 LA 8,3(8) Remove LX1, LX2, HCHECK from hdr @SC86295 08466000 L 9,DATL Data size 08466500 IC 3,BCTU CHK len 08467000 LA 9,2(3,9) Data, CHK, SEQ, TYP lengths 08467500 LA 1,3(9) Plus SOH, LEN, EOL lengths @SC86202 08468000 C 9,AKMAX Check packet length byte @SC86202 08468500 BNH SPKNXDL1 No extended data len @SC86202 08469000 LA 1,3(1) Plus LX1,LX2,HCHECK for ext. hdr @SC86202 08469500 SR 9,9 Set 'Type 0' extended hdr @SC86202 08470000 SH 8,SPKNX3+2 Remove LX1, LX2, HCHECK from hdr @SC86295 08470500 SPKNXDL1 ST 1,SNDPKL SNDPKT length @SC86202 08471000 ST 8,ASPKT Ptr to buffer @SC86295 08471500 MVC 0(1,8),SMARK Add mark to packet @SC86295 08472000 TOCHR 9,,1(8) Add it to packet @SC86295 08472500 TOCHR 4,SEQ,2(8) Get packet number @SC86295 08473000 AR 9,4 And add to checksum 08473500 IC 3,STYPE Type 08474000 STC 3,3(8) Store in buffer @SC86295 08474500 AR 9,3 Add to checksum 08475000 CLI 1(8),ABL Chk 'Type 0' extended hdr @SC86295 08475500 BNE SPKNXDL3 No extended data len @TB86196 08476000 L 7,DATL Data size @TB86196 08476500 IC 3,BCTU CHK len @TB86196 08477000 AR 7,3 Sum = extended length @TB86196 08477500 SR 6,6 @TB86196 08478000 D 6,XLFCT Get two parts @TB86196 08478500 TOCHR 7,,4(8) Add LENX1 to packet @SC86295 08479000 AR 9,7 And add to checksum @TB86196 08479500 TOCHR 6,,5(8) Add LENX2 to packet @SC86295 08480000 AR 9,6 And add to checksum @TB86196 08480500 LR 6,9 Chksum thru LENX2 byte @TB86196 08481000 SRL 6,6 High 2 bits of total @TB86196 08481500 N 6,F3 Get just 2 bits @SC86295 08482000 AR 6,9 Get type-1 check value @TB86196 08482500 N 6,MOD64 @TB86196 08483000 TOCHR 6,,6(8) Make printable @SC86295 08483500 AR 9,6 And add to checksum @TB86196 08484000 SPKNXDL3 DS 0H @TB86196 08484500 L 8,ASDATA @SC86295 08485000 BCTR 8,0 Ptr one before data @SC86295 08485500 ICM 6,B'1111',DATL Data length 08486000 BZ SPKCHK Go if no data 08486500 LR 5,6 @SC86135 08487000 SPKCHAR IC 3,0(5,8) Pick up char @SC86295 08487500 AR 9,3 Add to checksum 08488000 BCT 5,SPKCHAR Yes, there's more data @SC86135 08488500 SPKCHK LA 6,1(6,8) Point to where chksum goes @SC86295 08489000 LR 7,9 Need copy of chksum 08489500 CLI BCTU,2 08490000 BE SPKCHK2 Go if 2 char chksum 08490500 BH SPKCHK3 Go if 3 char CRC 08491000 SRL 9,6 High 2 bits of total 08491500 N 9,F3 Get just 2 bits @SC86295 08492000 AR 7,9 Add the two values 08492500 B SPKCHK1 Go add chksum to data 08493000 * 08493500 SPKCHK3 L 5,ASPKT @SC86190 08494000 LA 5,1(5) Where checksum starts @SC86190 08494500 KCALL CRCCLC Calculate the CRC 08495000 LR 7,15 Keep in here 08495500 SRL 15,12 High 4 bits of high byte 08496000 A 15,BCTOFF 0/1 @SC92085 08496500 TOCHR 15,,0(6) Make char printable 08497000 LA 6,1(6) Bump output pointer 08497500 SPKCHK2 LR 15,7 total 08498000 SRL 15,6 Next 6 bits of total @SC86295 08498500 N 15,MOD64 Get just 6 bits @SC86295 08499000 A 15,BCTOFF 0/1 @SC92085 08499500 TOCHR 15,,0(6) Make char printable 08500000 LA 6,1(6) Bump pointer 08500500 SPKCHK1 N 7,MOD64 Get low order 6 bits 08501000 A 7,BCTOFF 0/1 @SC92085 08501500 TOCHR 7,,0(6) Make printable 08502000 SPKEOL MVC 1(2,6),S1EOL Add micro's EOL char + handshake @SC87274 08502500 KCALL SIO Write the SNDPKT @SC86135 08503000 RET , Return with SIO's rc @SC86295 08503500 LOCALS , @SC86295 08504000 SPACK EXIT 08504500 TITLE 'RPACK Routine - Reads data into DATA buffer' 08505000 * ERRNUM set if error found, unchanged otherwise @SC89219 08505500 RPACK ENTER 08506000 MVI RPKERN,ERRTIE Error if RIO fails @SC90289 08506500 RPKRED KCALL RIO,E=RPKNAK @SC90106 08507000 L 7,RCVPKL Length of data read 08507500 LM 14,15,TINTOT Update recv count @SC86295 08508000 ALR 15,7 @SC86295 08508500 BC 12,*+8 @SC88092 08509000 AL 14,F1 @SC86295 08509500 STM 14,15,TINTOT Save new count @SC86295 08510000 L 8,APKT Point to PKT @SC86190 08510500 C 7,F2 Watch for XON-XOFF pairs @SC90106 08511000 BNE *+14 @SC90106 08511500 CLC 0(2,8),=AL1(XON,XOFF) @SC90106 08512000 BE RPKRED Ignore pure flow-control "packet" @SC90106 08512500 MVI RTYPE,AT In case of time-out @SC87012 08513000 C 7,F1 Time-out signal is ASCII T @SC87012 08513500 BNE RPKSET @SC90106 08514000 CLI 0(8),XOFF @SC90106 08514500 BE RPKRED Spurious flow-control "packet" @SC90106 08515000 CLI 0(8),AT @SC87012 08515500 BE RTRN Yes, timed out @SC87012 08516000 RPKSET DS 0H @SC90106 08516500 AR 7,8 Point past last char 08517000 MVI RPKERN,ERRSOH No start-of-packet found @SC89219 08517500 MVC RMARKDT,RMARK Copy packet character @SC93173 08518000 CLI RMARKDT,ABL Is it a control? @SC93173 08518500 BL *+8 @SC93173 08519000 MVI RMARKDT,0 Yes, don't check for it in data @SC93173 08519500 RPKBEG SR 3,3 Use this for IC's 08520000 L 14,ARPKT Point to recv buffer @SC89065 08520500 RPKLOOP CLC RMARK,0(8) 08521000 LA 8,1(8) Try next character @SC86135 08521500 BE RPKSOH Go if a Control-A 08522000 CR 8,7 Are we within the received pkt? 08522500 BL RPKLOOP Yes, keep on looking for SOH 08523000 B RPKERR @SC89219 08523500 * 08524000 RPKSOH LA 9,4(14) Skip over usual header @SC86295 08524500 MVC 1(3,14),0(8) Copy usual header to RCVPKT @SC86295 08525000 MVI RPKERN,ERRBPC SOH found - cksm may be bad @SC89219 08525500 UNCHR 3,0(8) Length 08526000 BM RPKBEG Invalid length, try again @SC86153 08526500 LA 5,ABL(3) Chksum accumulator 08527000 LR 4,3 Keep length to compute DATA len 08527500 LA 15,0(3,8) pkt len + beg 08528000 CR 15,7 Is it within received pkt? 08528500 BNL RPKBEG too long, look for another SOH 08529000 IC 3,2(8) Pick up packet type @SC86153 08529500 STC 3,RTYPE Save value here @SC86153 08530000 NI RTYPE,X'7F' Assure conventional ASCII char @SC88074 08530500 AR 5,3 Add to checksum @SC86153 08531000 BCTR 4,0 -1 for Seq # 08531500 BCTR 4,0 -1 for Type 08532000 UNCHR 3,1(8) Pick up packet number @SC86153 08532500 BM RPKBEG Invalid char @SC86153 08533000 LA 5,ABL(3,5) Add to checksum 08533500 STC 3,RSN Received packet number @SC86135 08534000 LA 8,3(8) Go to putative data @SC86153 08534500 CLI 1(14),ABL Is this an extended pkt? @SC86295 08535000 BNE RPKEXT2 No @TB86196 08535500 LA 15,3(8) Past LENX1,LENX2,HCHECK @TB86196 08536000 CR 15,7 Is it within rcvd pkt? @TB86196 08536500 BNL RPKBEG Too long, try for another SOH @TB86196 08537000 MVC 4(3,14),0(8) Copy extended pkt hdr @SC86295 08537500 UNCHR 1,0(8) Pick up LENX1 byte @TB86196 08538000 LA 5,ABL(1,5) Add to check @SC86202 08538500 MH 1,XLFCT+2 High digit of size @SC86202 08539000 UNCHR 3,1(8) Pick up LENX2 byte @TB86196 08539500 LA 5,ABL(3,5) Add to chksum @SC86202 08540000 AR 1,3 Total extended pkt size @TB86196 08540500 UNCHR 3,2(8) Pick up HCHECK byte @TB86196 08541000 LR 6,5 Keep chksum copy here @TB86196 08541500 SRL 6,6 High 2 bits of total @TB86196 08542000 N 6,F3 Get just 2 bits @SC86295 08542500 AR 6,5 Add the two values @TB86196 08543000 N 6,MOD64 Get low order 6 bits @TB86196 08543500 CR 6,3 Chk computed vs received @TB86196 08544000 BNE RPKBEG Err if chksums mismatch @SC89219 08544500 LA 5,ABL(3,5) Add HCHECK to chksum @SC86202 08545000 LA 8,3(8) Update input+output ptrs @SC86202 08545500 LA 9,3(9) Past LX1,LX2,HCHECK @SC86202 08546000 LR 4,1 Save length of data+check @SC86202 08546500 AR 1,8 Expected end of packet @SC86202 08547000 CR 1,7 Is it within pkt? @SC86202 08547500 BH RPKBEG Too long, chk for SOH @SC86202 08548000 RPKEXT2 DS 0H @SC86202 08548500 IC 3,BCTU Chksum length @SC86202 08549000 SR 4,3 Minus chksum length @SC86202 08549500 BM RPKBEG Can't have negative data length @SC86202 08550000 ST 4,DATL Save data length @SC86202 08550500 ST 9,ARDATA Save ptr @SC86202 08551000 LTR 4,4 Any data received? @SC89219 08551500 BZ RPKCHK Nope 08552000 RPKCHAR IC 3,0(8) Get next data char 08552500 STC 3,0(9) Move it to DATA 08553000 AR 5,3 Add to checksum 08553500 CLC RMARKDT,0(8) Packet char? (disabled if FULL) @SC93173 08554000 BE RPKBEG Yes, must be error, start over @SC93173 08554500 LA 8,1(8) Bump input buffer pointer 08555000 LA 9,1(9) Bump output buffer pointer 08555500 BCT 4,RPKCHAR Decrement amount of input 08556000 RPKCHK UNCHR 3,0(8) Get checksum 08556500 S 3,BCTOFF 0/1 @SC92085 08557000 LR 6,9 CRC calc ends here @SC86135 08557500 LR 4,5 Keep chksum copy here 08558000 CLI BCTU,2 08558500 BE RPKCHK2 Go if using 2 char chksum 08559000 BH RPKCHK3 Three character CRC 08559500 SRL 5,6 High 2 bits of total 08560000 N 5,F3 Get just 2 bits @SC86295 08560500 AR 4,5 Add the two values 08561000 B RPKCHK1 compare it 08561500 * 08562000 RPKCHK3 LA 5,1(14) Start of data for CRC @SC86295 08562500 KCALL CRCCLC Calculate the CRC 08563000 LR 4,15 Keep computed value here also 08563500 SRL 15,12 High 4 bits of high byte 08564000 CR 15,3 compare computed and received 08564500 BNE RPKBEG Skip if chksums don't match @SC89219 08565000 LA 8,1(,8) Ok so far, bump input pointer @SC90285 08565500 UNCHR 3,0(8) Get next char of checksum 08566000 S 3,BCTOFF 0/1 @SC92085 08566500 RPKCHK2 LR 15,4 Get back the CRC 08567000 SRL 15,6 Next 6 bits of total @SC86295 08567500 N 15,MOD64 Get just 6 bits @SC86295 08568000 CR 15,3 compare computed and received 08568500 BNE RPKBEG Skip if chksums don't match @SC89219 08569000 LA 8,1(,8) Ok so far, bump input pointer @SC90285 08569500 UNCHR 3,0(8) Get checksum 08570000 S 3,BCTOFF 0/1 @SC92085 08570500 RPKCHK1 N 4,MOD64 Get low order 6 bits 08571000 CR 4,3 Compare computed and received 08571500 BE RPKRET skip if chksums match 08572000 TM FL1,TSTF @SC86295 08572500 BO RPKRET Just testing, anything goes @SC86295 08573000 CR 8,7 @BS86001 08573500 BL RPKBEG More stuff, see if it's a packet @BS86001 08574000 RPKERR DS 0H @SC89219 08574500 LA 8,STOPBUF @SC88074 08575000 L 7,RCVPKL @SC88074 08575500 AR 7,8 Ptr to packet end in work area @SC88074 08576000 CLC =X'114040',0(8) SBA sequence prepended? @SC91256 08576500 BNE *+8 No, normal @SC91256 08577000 A 8,F3 Yes, ignore it @SC91256 08577500 CLC RMARK,0(8) @SC88074 08578000 BE RPKNAK Assume bad packet if SOH present @SC88074 08578500 BCTR 7,0 @SC88074 08579000 IC 0,0(,7) Look at last character @SC91032 08579500 N 0,LOBIT (but only 7 bits) @SC91032 08580000 CLM 0,1,REOL Is it an EOL? @SC91032 08580500 BNE *+6 @SC88074 08581000 BCTR 7,0 Don't count closing EOL @SC88074 08581500 CLC =C'STOP',0(8) @SC91032 08582000 BE RPKSTUP Seems to be EBCDIC already (3270) @SC91032 08582500 CLC =C'stop',0(8) @SC91032 08583000 BE RPKSTUP Seems to be EBCDIC already (3270) @SC91032 08583500 TR STOPBUF,ATOED @SC89301 08584000 RPKSTUP DS 0H @SC91032 08584500 TR STOPBUF,UPCASE @SC88074 08585000 CLI 0(8),C'S' @SC88074 08585500 BE *+8 @SC88074 08586000 LA 8,1(8) Allow one extra character in front@SC88074 08586500 S 7,F3 Back len(STOP) - 1 @SC88074 08587000 CR 7,8 @SC88074 08587500 BNE RPKNAK Doesn't match exactly @SC88074 08588000 CLC =C'STOP',0(8) @SC88074 08588500 BE RPKSTP Exact match @SC88074 08589000 RPKNAK MVI RTYPE,AQ Return a Q pkt 08589500 RPKRET RET 08590000 * @SC88074 08590500 RPKSTP OI FL3,ZPRO Indicate stopping protocol mode @SC88074 08591000 MVI ERRNUM,ERRTRC Transfer cancelled, if any @SC88074 08591500 MVI REASON,0 Reason is "unknown" @SC92031 08592000 MVI RTYPE,X'FF' Special packet type for quitting @SC88074 08592500 RET @SC88074 08593000 LOCALS , @SC86295 08593500 RMARKDT DS C Packet char or NULL for scanning @SC93173 08594000 RPACK EXIT 08594500 TITLE 'CRCCLC Routine - calculates CRC' 08595000 * Calculate the CRC and return it in R15. Expects R5 to point to the 08595500 * start of the data on which the CRC is calculated, and R6 to the 08596000 * char after the last one. 08596500 * 08597000 CRCCLC ENTER 08597500 SR 15,15 Initial CRC value is zero 08598000 CRCLUP IC 4,0(5) Get the next character @SC86295 08598500 XR 4,15 XOR char and CRC low byte @SC86295 08599000 LR 7,4 same as above 08599500 SRL 7,4 High 4 bits of low byte 08600000 N 4,F Low 4 bits of low byte 08600500 N 7,F High 4 bits of low byte @SC86295 08601000 ALR 4,4 Double to get index into table 08601500 LH 4,CRCTAB2(4) CRC for low 4 bits 08602000 ALR 7,7 Double to get another index 08602500 LH 7,CRCTAB1(7) CRC for high 4 bits 08603000 XR 4,7 XOR the two 08603500 SRL 15,8 Shift prev CRC 8 bits to right 08604000 XR 15,4 XOR current char's CRC into it 08604500 N 15,=XL4'FFFF' Drop negative stuff @SC86295 08605000 LA 5,1(5) Bump input pointer 08605500 CR 5,6 Did we reach the end? 08606000 BL CRCLUP Nope, loop for whole pkt 08606500 CRCRET RET 08607000 * Table to use for CRC calculation 08607500 CRCTAB1 HTBL 00,00,10,81,21,02,31,83,42,04,52,85,63,06,73,87 @SC89268 08608000 HTBL 84,08,94,89,A5,0A,B5,8B,C6,0C,D6,8D,E7,0E,F7,8F @SC89268 08608500 * 08609000 CRCTAB2 HTBL 00,00,11,89,23,12,32,9B,46,24,57,AD,65,36,74,BF @SC89268 08609500 HTBL 8C,48,9D,C1,AF,5A,BE,D3,CA,6C,DB,E5,E9,7E,F8,F7 @SC89268 08610000 * 08610500 LOCALS , @SC86295 08611000 CRCCLC EXIT 08611500 TITLE 'RIO Routine - Read packet into RCVPKT' 08612000 RIO ENTER 08612500 MVI SIORIO,C'R' Set type @SC86316 08613000 L 7,APKT Ptr to data @SC86316 08613500 L 15,RIOC Previous read count @SC86295 08614000 MVI RIOC,X'80' Nothing left in read buffer @SC86295 08614500 RIOSM0 ICM 0,15,SIMPTR See if replaying... @SC91312 08615000 BNZ RIOSIM Read from canned file @SC91312 08615500 BAL 14,TTYCHK @SC92030 08616000 B RIOTTY Go if not transparent @SC92030 08616500 SR 4,4 Don't translate for STOP test @SC91032 08617000 LA 5,OFF80 Turn off all X'80' bits @SC86316 08617500 TM RPRTY,DAT8 Unless 8-bit line @SC88288 08618000 BZ *+6 Not 8-bit @SC86316 08618500 SR 5,5 Yes, use all bits @SC86316 08619000 LTR 15,15 Any previous? @SC86295 08619500 BNM RIOCOM Yes, use it @SC86295 08620000 LA 0,4 Write @SC86295 08620500 KCALL SCRNIO,S1XOPL,E=(RIOER,M) Send a prompt @SC86295 08621000 RIOS1R DS 0H @SC87215 08621500 LA 0,5 Read @SC86295 08622000 KCALL SCRNIO,RIOPTRS,E=(RIOER,M) perform read @SC90173 08622500 BP RIOCOM @SC86355 08623000 RIOER MVI ERRNUM,ERRTIE Terminal I/O error @SC86156 08623500 B RTRN1 Error, return to caller @SC86295 08624000 * 08624500 RIOSIM L 5,RIOPTRS+4 @SC91312 08625000 READF SIMPTR,BUFFER=(7),BSIZE=(5),E=RIOSMX @SC91312 08625500 LR 15,0 Save length @SC91312 08626000 SR 5,5 Assume no translation @SC91312 08626500 CLC =C'S:',0(7) @SC91312 08627000 BE RIOSIM @SC91312 08627500 CLC =C'R:',0(7) @SC91312 08628000 BNE *+8 @SC91312 08628500 L 5,AEPTRS+4 It's in EBCDIC, translate it @SC92352 08629000 LR 4,5 @SC91312 08629500 B RIOCOM @SC91312 08630000 * 08630500 RIOERR CLI WRRD,0 Expecting a reply? @SC91281 08631000 BNE RIOER Yes, report the error @SC91281 08631500 B SIOGOOD No, ignore it @SC91281 08632000 * 08632500 RIOTTY L 5,AEPTRS+4 Translate to ASCII (ETOA/TETOA) @SC92352 08633000 CLI TRMTP,C'F' Full-screen? @SC92030 08633500 BE RIOTTY1 Yes, avoid override table @SC92030 08634000 ICM 6,15,KSYSETOA Possible overriding table @SC88302 08634500 BZ *+6 @SC88302 08635000 LR 5,6 Use it instead @SC88302 08635500 RIOTTY1 DS 0H @SC92030 08636000 LR 4,5 Use same translation for STOP @SC91032 08636500 LTR 15,15 Any previous data? @SC86295 08637000 BNM RIOCOM Yes, use it @SC86295 08637500 LA 0,5 No, read some now @SC86295 08638000 KCALL TERMIO,RIOPTRS,E=(RIOER,M) perform read @SC90173 08638500 RIOCOM LR 6,15 Copy byte count @SC86295 08639000 ST 6,RCVPKL Save 08639500 MVC STOPBUF,0(7) Copy to work area, in case STOP @SC91032 08640000 LTR 4,4 Any translation for STOP test? @SC91032 08640500 BZ *+10 Don't translate it @SC91032 08641000 TR STOPBUF,0(4) Do the translate @SC91032 08641500 BAL 9,RIORAW Log raw data @SC86316 08642000 LR 2,7 @SC86316 08642500 LR 3,6 Length @SC86202 08643000 LTR 15,5 Copy table ptr @SC86316 08643500 BZ *+8 Don't translate after all @SC86316 08644000 BAL 14,TRANSLAT Do the translate @SC86202 08644500 BAL 9,RIOLOG Write to log @SC86190 08645000 B RTRN0 @SC86295 08645500 * Write record to log buffer, R7->data, R6=length @SC87286 08646000 * Clobbers R0,R1,R2,R3,R8,R14,R15, return to (R9) @SC87286 08646500 RIORAW SR 3,3 Write raw data @SC86316 08647000 B RIOLG1 @SC86316 08647500 RIOLOG L 3,AEPTRS Write data in EBCDIC (ATOE/TATOE) @SC92352 08648000 RIOLG1 SR 8,8 Assume raw not wanted @SC88168 08648500 TM DBGFLG,DBGRW @SC88168 08649000 BO *+8 @SC88168 08649500 L 8,AEPTRS Raw wanted @SC92352 08650000 CR 3,8 Correct type (raw/EBCDIC)? @SC88168 08650500 BNER 9 No, skip this one @SC86316 08651000 TM FL1,DEBUG @SC86316 08651500 BZR 9 Skip if no debugging @SC86190 08652000 LA 8,2(6) Two extra for R:, etc. @SC87286 08652500 L 2,LOGBUF LOG buffer @SC86316 08653000 MVC 0(1,2),SIORIO Indicate log type @SC86316 08653500 LA 2,2(2) Skip over prefix @SC86190 08654000 LR 0,2 Buffer ptr @SC86190 08654500 LR 1,8 Data length @SC86316 08655000 LR 14,7 Data ptr @SC86316 08655500 LR 15,8 @SC86316 08656000 MVCL 0,14 Copy to log buffer @SC86316 08656500 LTR 15,3 Check if translation needed @SC86316 08657000 BZ *+10 No @SC86316 08657500 LR 3,8 Data length @SC86316 08658000 BAL 14,TRANSLAT Do the translate @SC86202 08658500 WRITF LOGPTR,BSIZE=(8),E=RIOLQU @SC87034 08659000 TM DBGFLG,DBGSV SAVE requested? @SC88168 08659500 BZR 9 No, skip closing log file @SC88168 08660000 SAVEF LOGPTR Update disk directory @SC88168 08660500 BR 9 Done @SC86190 08661000 RIOLQU CLOSF LOGPTR Turn off DEBUG, it fails @SC86355 08661500 NI FL1,255-DEBUG @SC86355 08662000 BR 9 @SC86355 08662500 * 08663000 RIOSMX CLOSF SIMPTR Turn off replay -- it failed @SC91312 08663500 B RIOSM0 Try again for real @SC91312 08664000 TITLE 'SIO Routine - Send packet in SNDPKT' 08664500 SIO ENTER ALT @SC86190 08665000 MVI SIORIO,C'S' Set type @SC86316 08665500 MVI RTYPE,0 Clear previous received packet @SC88074 08666000 MVI RIOC,X'80' Set no read count @SC86295 08666500 L 6,SNDPKL Length of SNDPKT to be sent 08667000 TM FL4,NPS Non-protocol? @SC86239 08667500 BO SIOPLEN Yes, no handshake at all @LP87272 08668000 CLI WRRD,0 Only writing? @LP87272 08668500 * BE SIOPLEN Yes, handshake done next Read @LP87272 08669000 CLI S1HND,0 Handshake desired at all? @SC87275 08669500 BE SIOPLEN No, skip it @SC87275 08670000 LA 6,1(6) Allow for handshake character @LP87272 08670500 SIOPLEN DS 0H @SC86239 08671000 L 7,ASPKT Ptr to send data @SC86316 08671500 BAL 9,RIOLOG Write to log @SC86190 08672000 L 2,SIOPTRS Final output buffer @SC90173 08672500 LR 1,2 Save start @SC86154 08673000 SR 3,3 @SC86154 08673500 TM FL4,NPS Non-protocol? @SC86191 08674000 BO *+8 Yes, skip padding @SC86191 08674500 IC 3,SPADN Pad count @SC86154 08675000 LA 15,7(3,6) Length of pad+data @SC92030 08675500 STCM 15,3,AEABUFL Set length of OEM data struct fld @SC90173 08676000 LM 4,5,WRCMD Adr,len of I/O command stuff @SC90173 08676500 AR 3,5 Total padding + Series/1 @SC86154 08677000 LA 9,0(5,2) Save start of ASCII stuff @SC88288 08677500 ICM 5,8,SPADC Get padding character @SC86154 08678000 MVCL 2,4 Copy to buffer with padding @SC86154 08678500 LR 3,6 Packet length @SC86154 08679000 LR 5,6 @SC86154 08679500 LR 4,7 Ptr to packet @SC86316 08680000 MVCL 2,4 Copy packet to buffer @SC86154 08680500 LR 3,2 Copy end of transmission @SC90173 08681000 SR 2,1 Total length @SC90173 08681500 ST 2,SIOPTRS+4 Store len in CCW @SC90173 08682000 LR 2,9 Start of ASCII stuff @SC88288 08682500 SR 3,2 Length @SC88288 08683000 BAL 14,TTYCHK @SC92030 08683500 B SIOTTY Go if not transparent @SC92030 08684000 LA 15,ON80 Set high bits @SC88288 08684500 TM SPRTY,DAT8 Unless 8-bit line @SC88288 08685000 BO *+8 Yes, 8-bit downloading @SC88288 08685500 BAL 14,TRANSLAT @SC88288 08686000 L 4,=A(SCRNIO) I/O routine for fullscreen @SC89215 08686500 SIOGO LM 7,8,SIOPTRS @SC90173 08687000 LM 14,15,TOUTOT Update send count @SC88006 08687500 ALR 15,8 @SC88006 08688000 BC 12,*+8 @SC88092 08688500 AL 14,F1 @SC88006 08689000 STM 14,15,TOUTOT Save new count @SC88006 08689500 LR 6,8 Set up for log routine @SC88168 08690000 BAL 9,RIORAW Log it @SC86316 08690500 NI FL5,255-NAK0 Something sent now @SC90037 08691000 ICM 0,15,SIMPTR @SC91312 08691500 BNZ RTRN0 Replaying, suppress packet I/O @SC91312 08692000 LA 0,4 Write @SC86295 08692500 KCALL (4),SIOPTRS,E=(RIOER,M) @SC90173 08693000 CLI TRMTP,C'S' S/1? @SC90173 08693500 BE *+12 @SC90173 08694000 CLI WRRD,0 Only writing? @SC90173 08694500 BE SIOGOOD Yes, expect no answer @SC90173 08695000 LA 0,5 @SC86295 08695500 KCALL (4),RIOPTRS,E=(RIOER,M) Read it now @SC90173 08696000 CLI WRRD,0 Write/read? @SC86301 08696500 BE SIOGOOD No, ignore bare status @SC86301 08697000 LTR 15,15 @TB87009 08697500 BP SIOCOM @TB87009 08698000 CLI TRMTP,C'S' S/1? @SC90173 08698500 BNE SIOCOM No problem @SC90173 08699000 * If only 3 bytes (AID and cursor) come in, VTAM has caused @TB87009 08699500 * the S/1 to discard its transparent data. Fill the screen and @TB87009 08700000 * read it back in protocol conversion mode to cause VTAM @TB87009 08700500 * to put up a longer READ MODIFIED CCW at its next read. @TB87009 08701000 LA 0,6 Message (Leave Transparent Mode) @TB87009 08701500 KCALL SCRNIO,SIORTPL,E=(SIORTY,M) @TB87009 08702000 LA 0,5 @TB87009 08702500 KCALL SCRNIO,RIOPTRS,E=(RIOER,M) Rdmod to prime VTAM. @SC90173 08703000 L 14,RIOPTRS Input buffer @SC91039 08703500 CLC SIOMSGT,3(14) Is it what we just wrote? @SC91039 08704000 BNE SIOCOM No, maybe it's real @SC91039 08704500 SIORTY SR 15,15 No data actually seen. @TB87009 08705000 SIOCOM DS 0H @TB87009 08705500 ST 15,RIOC save residual byte count 08706000 SIOGOOD DS 0H @SC88100 08706500 B RTRN0 @SC86295 08707000 * 08707500 SIOTTY DS 0H @SC90173 08708000 CLI TRMTP,C'F' Full-screen? @SC92030 08708500 BE SIOTTY1 Yes, avoid override table @SC92030 08709000 ICM 15,15,KSYSATOE Possible overriding table @SC88302 08709500 BNZ SIOTRNT @SC88302 08710000 SIOTTY1 DS 0H @SC92030 08710500 L 15,AEPTRS Send in EBCDIC (ATOE/TATOE) @SC92352 08711000 SIOTRNT DS 0H @SC88302 08711500 BAL 14,TRANSLAT Do the translate @SC86202 08712000 L 4,=A(TERMIO) I/O routine for TTY @SC89215 08712500 B SIOGO Now do it @SC87275 08713000 * @TB87009 08713500 SIORTPL DC A(SIOMSGXX,SIOMSL) @TB87009 08714000 * Greetings for ERROR mode @TB87009 08714500 SIOMSGXX DC &S1CMD,AL1(SBA),X'4040' @SC90264 08715000 SIOMSGT DC C'&VTAMERR' @TB87009 08715500 DC AL1(RTA),X'4040',C' ' Blanks to end of screen @SC88139 08716000 SIOMSL EQU *-SIOMSGXX @TB87009 08716500 * For setting high bits... @SC88288 08717000 ON80 DC X'808182838485868788898A8B8C8D8E8F' @SC88288 08717500 DC X'909192939495969798999A9B9C9D9E9F' @SC88288 08718000 DC X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF' @SC88288 08718500 DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' @SC88288 08719000 DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' @SC88288 08719500 DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' @SC88288 08720000 DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' @SC88288 08720500 DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' @SC88288 08721000 DC X'808182838485868788898A8B8C8D8E8F' @SC88288 08721500 DC X'909192939495969798999A9B9C9D9E9F' @SC88288 08722000 DC X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF' @SC88288 08722500 DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' @SC88288 08723000 DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' @SC88288 08723500 DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' @SC88288 08724000 DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' @SC88288 08724500 DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' @SC88288 08725000 LOCALS , @SC86295 08725500 SIORIO DS C Operation code @SC86316 08726000 SIO EXIT 08726500 TITLE 'INTINI Routine - Initialize console for protocol' 08727000 * If R1 is 0, reset the traps unless in Server mode. 08727500 * If R1 is positive, set up console traps for protocol: 08728000 * 1 for SERVER, 2 for SEND, 3 for RECEIVE, 4 for short msg @SC86184 08728500 * R15 = 0 on return if ok 08729000 * 08729500 INTINI ENTER 08730000 TM FL2,SRV 08730500 BO INTINIR Return if server running 08731000 LTR 3,1 Call type: 0 or 1-5 @HF86232 08731500 BZ INTINICL If R1 is 0 clear traps 08732000 MVI WRRD,5 Reset w/r flag @SC91352 08732500 MVI AEAFLG,0 ditto for AEA @SC91352 08733000 CLI TRMTP,C'N' Controller = NONE? @SC90173 08733500 BE INTINERR If so, give up right away @SC90173 08734000 CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 08734500 BNE *+12 No, we're ok @SC92030 08735000 CLI SMARK,ABL Yes, see if printable SOP @SC92030 08735500 BL INTINBAD No, give up right away @SC92030 08736000 OI FL2,PROTO Line open for transfer @SC86295 08736500 MVI RTYPE,AN No packet received yet @SC89263 08737000 ICM 5,15,LCLDLY No delay? @HF86232 08737500 BNZ INTINIDL @HF86232 08738000 LA 1,5 Yes, use no message @HF86232 08738500 INTINIDL C 1,F5 No delay or non-protocol send? @HF86232 08739000 BE INTINIMS Yes @HF86232 08739500 BCT 5,INTINIMS Short delay? @HF86232 08740000 LA 1,4 Yes, use short message anyway @SC86184 08740500 INTINIMS SLL 1,3 8-byte indexing @HF86232 08741000 LA 5,INTCCWSR-8(1) Get ptr to correct CCW @SC86184 08741500 MVC SVHND,S1HND Save handshake character @SC87343 08742000 KCALL SETMSG,2,E=INTINERR Prepare line for transfer @SC87300 08742500 LA 0,2 @SC87309 08743000 SR 0,3 @SC87309 08743500 LPR 0,0 Get ABS(code-2) @SC87309 08744000 BCT 0,*+8 Test for Serve or Rec codes (1,3) @SC87309 08744500 OI FL5,NAK0 Send NAK during retry, if any @SC90037 08745000 MVI RIOC,X'80' Clr any prev byte count @SC86295 08745500 LA 6,S1DATA Series/1 stuff @SC90173 08746000 LA 7,S1ORDL Length of Series/1 stuff @SC90173 08746500 LA 8,3 Expect AID + cursor adr @SC90173 08747000 CLI TRMTP,C'S' @SC90173 08747500 BE INTSSIOC @SC90173 08748000 LA 6,GRDATA Graphics stuff @SC90173 08748500 LA 7,GRDL @SC90173 08749000 CLI TRMTP,C'G' @SC90173 08749500 BE INTSSIOC @SC90173 08750000 LA 6,AEADAT AEA stuff @SC90173 08750500 LA 7,AEAL @SC90173 08751000 LA 8,16 Expect AID + WSF stuff @SC90173 08751500 CLI TRMTP,C'A' @SC90173 08752000 BE INTSSIOC @SC90173 08752500 SR 7,7 Nothing for TTY-mode @SC90173 08753000 SR 8,8 @SC90173 08753500 CLI TRMTP,C'F' @SC92030 08754000 BNE INTSSIOC @SC92030 08754500 LA 8,FSRDOF Depends on system @SC92030 08755000 INTSSIOC STM 6,8,WRCMD Save ptrs for fullscreen I/O cmds @SC90173 08755500 A 8,RIOPTRS Get ptr to start of data @SC90173 08756000 ST 8,APKT @SC90173 08756500 BAL 14,TTYCHK @SC92030 08757000 B INTINITY Go if TTY @SC92030 08757500 LA 0,1 Open screen @SC86295 08758000 KCALL SCRNIO @SC86295 08758500 LA 0,6 Simple write @SC86316 08759000 KCALL SCRNIO,(5),E=(INTINIR,M) Message @SC86295 08759500 C 3,F2 Was this SEND? @SC86184 08760000 BE INTINIR SEND does sleep anyway 08760500 ICM 0,15,LCLDLY See if speed wanted @SC87253 08761000 BZ INTINIP Yes, no greetings anyway @SC87309 08761500 LA 0,1 Wait 1 sec @SC86295 08762000 KCALL SUPFNC,9 This seems essential @SC86295 08762500 INTINIP DS 0H @SC90173 08763000 B INTINIR 08763500 * 08764000 INTINITY L 1,0(5) Text address from ccw @SC86184 08764500 LH 4,6(5) Get total length @SC86184 08765000 LA 3,INTPRL(1) Skip over WCC and SBA @SC86184 08765500 SH 4,*-2 and deduct that from length @SC86184 08766000 SR 0,0 @SC92030 08766500 KCALL SCRNIO Clear screen if FULLSCREEN @SC92030 08767000 LA 6,80 @SC92161 08767500 INTINIT1 CR 4,6 @SC92161 08768000 BNH INTINIT2 Just one line left @SC92161 08768500 WTEXT (3),(6) Write out one line @SC92161 08769000 AR 3,6 Point to next line @SC92161 08769500 SR 4,6 Adjust length remaining @SC92161 08770000 B INTINIT1 @SC92161 08770500 INTINIT2 WTEXT (3),(4) @SC86184 08771000 WTEXT =X'24',1 SNA Inhibit Presentation @2L90270 08771500 LA 0,1 @SC86295 08772000 KCALL TERMIO Open line @SC86295 08772500 B INTINIR 08773000 * 08773500 INTINICL NI FL3,255-ZPRO Now stopping protocol mode @SC88074 08774000 TM FL2,PROTO Was line open? @SC88074 08774500 BZ INTINIR No @SC86295 08775000 CLI TRMTP,C'A' Special treatment of AEA here @SC91352 08775500 BNE INTINICM Not needed @SC91352 08776000 CLI AEAFLG,X'80' Transparency suppressed yet? @SC91352 08776500 BE INTINICM Yes, all set @SC91352 08777000 MVI AEAFLG,X'80' No, must do it now @SC91352 08777500 MVI WRRD,0 (just for completeness) @SC91352 08778000 MVI WRCMD+7,AEADOL Set up plist for WSF @SC91352 08778500 LA 0,4 Write @SC91352 08779000 KCALL SCRNIO,WRCMD Send just the D/O field @SC91352 08779500 INTINICM DS 0H @SC91352 08780000 LA 0,2 @SC86295 08780500 L 15,=A(SCRNIO) @SC89215 08781000 BAL 14,TTYCHK @SC92030 08781500 L 15,=A(TERMIO) TTY mode @SC92030 08782000 INTINIK KCALL (15) Release line @SC87300 08782500 KCALL SETMSG,3 @SC86316 08783000 MVC S1HND,SVHND Restore handshake character @SC87343 08783500 NI FL2,255-PROTO End protocol mode @SC88035 08784000 CLI TRMTP,C'T' @2L90270 08784500 BE *+12 Go if TTY @2L90270 08785000 CLI TRMTP,C'V' @2L90270 08785500 BNE INTINIR Go if VTAM TTY @2L90270 08786000 WTEXT =X'14',1 SNA Enable Presentation @2L90270 08786500 INTINIR B RTRN0 @SC87300 08787000 * 08787500 INTINBAD WTEXT '&UNPRSOP' @SC92030 08788000 INTINERR NI FL2,255-PROTO Turn off protocol mode @SC87300 08788500 MVI ERRNUM,ERRCOM Bad comm line @SC87300 08789000 B RTRN1 @SC87300 08789500 * 08790000 DS 0D 08790500 INTCCWSR DC A(INTMSGSR,INTPRL+80+80+80) @SC92161 08791000 INTCCWSN DC A(INTMSGSN,INTPRL+80+80+80) @SC92161 08791500 INTCCWRC DC A(INTMSGRC,INTPRL+80+80+80) @SC92161 08792000 INTCCWQU DC A(INTMSGQU,INTQL) @SC86295 08792500 INTCCWNL DC A(INTMSGQU,INTPRL+1) Send the blank, too @SC92072 08793000 * Short greetings @SC86184 08793500 INTMSGQU DC &S1CMD,AL1(SBA),X'4040' @SC90264 08794000 INTPRL EQU *-INTMSGQU Length of prefix @SC86295 08794500 INTMSGQ2 DC C' Kermit-&KSYS....' @SC92072 08795000 INTQL EQU *-INTMSGQU @SC86184 08795500 * Greetings for RECEIVE mode 08796000 INTMSGRC DC &S1CMD,AL1(SBA),X'4040' @SC90264 08796500 DC CL80'Kermit-&KSYS &READYR' @SC92300 08797000 DC CL80'&PLSESCP.&TOSEND' @SC92300 08797500 DC CL80'KERMIT READY TO RECEIVE...' @SC92161 08798000 * Greetings for SEND mode 08798500 INTMSGSN DC &S1CMD,AL1(SBA),X'4040' @SC90264 08799000 DC CL80'Kermit-&KSYS &READYS' @SC92300 08799500 DC CL80'&PLSESCP.&TORECV' @SC92300 08800000 DC CL80'KERMIT READY TO SEND...' @SC92161 08800500 * Greetings for SERVER mode 08801000 INTMSGSR DC &S1CMD,AL1(SBA),X'4040' @SC90264 08801500 DC CL80'Kermit-&KSYS &READYSR &PLSESCP..' @SC92300 08802000 DC CL80'&ENDSRV &AAAABYE &ZZZZOR &AAAAFIN..' @SC92300 08802500 DC CL80'KERMIT READY TO SERVE...' @SC92161 08803000 * 08803500 LOCALS , @SC86295 08804000 INTINI EXIT 08804500 TITLE 'INBUF Routine - read next disk record into WBUF' 08805000 * Exit: R15=0 if ok, -1 if EOF, 1 if read error (ERRNUM set) 08805500 INBUF ENTER 08806000 WEAKX KJETOA @SC91325 08806500 TM FL1,EOF 08807000 BO RTRNM1 Go if hit eof already @SC86295 08807500 SR 15,15 In case reading from memory @SC86158 08808000 ST 15,RBUFP Clear read buffer pointer @SC86158 08808500 ST 15,RBUFL Clear read buffer length @SC86158 08809000 L 9,RBUF Read into this buffer @SC86158 08809500 TM FL4,SFM Source is memory? @SC86158 08810000 BZ IBFDSK No, read disk @SC86158 08810500 LM 4,5,TXTPTR Yes, copy to buffer @SC86158 08811000 CR 4,5 Any left? @SC86158 08811500 BNL IBFEOF No, quit @SC86158 08812000 XC CMD,CMD @SC86158 08812500 MVI CMD+X'15',1 Set up TRT @SC86158 08813000 MVC 0(256,9),0(4) Copy one line or so @SC86158 08813500 LA 1,256(4) In case no NL @SC86158 08814000 TRT 0(256,4),CMD Scan for NL @SC86158 08814500 CR 1,5 No X'15'? @SC86158 08815000 BNH *+6 OK @SC86158 08815500 LR 1,5 Limit is end of data @SC86158 08816000 SR 1,4 Length of line @SC86158 08816500 LA 4,1(1,4) @SC86158 08817000 ST 4,TXTPTR Update ptr @SC86158 08817500 LR 0,1 Save length @SC86158 08818000 B IBFXLAT Go change to ASCII @SC86158 08818500 IBFDSK DS 0H @SC86158 08819000 ICM 1,15,FLNOPTS Get record counter @SC89218 08819500 AL 1,F1 @SC89218 08820000 STCM 1,15,FLNOPTS Update record counter @SC89218 08820500 CLM 1,15,FLNOPTS+4 Passed end? @SC89218 08821000 BH IBFEOF Yes, quit now @SC89218 08821500 ICM 2,15,RDWLEN Special format? @SC86151 08822000 AR 9,2 Space over record descriptor @SC86151 08822500 READF FILPTR,BUFFER=(9),E=IBFERR @SC87034 08823000 LM 14,15,DSKTOT Update disk count @SC86295 08823500 ALR 15,0 @SC86295 08824000 BC 12,*+8 @SC88092 08824500 AL 14,F1 @SC86295 08825000 STM 14,15,DSKTOT Save new count @SC86295 08825500 LTR 2,2 Special format? @SC86151 08826000 BZ IBFNRM No @SC86151 08826500 SR 9,2 Back up to start of buffer @SC86151 08827000 STCM 0,3,0(9) Store length @SC86151 08827500 C 2,F2 Short? @SC86262 08828000 BE IBFVLEN Yes @SC86262 08828500 CVD 0,TMPDW No, use 5-byte ASCII @SC86262 08829000 OI TMPDW+7,15 @SC86262 08829500 UNPK 0(5,9),TMPDW @SC86262 08830000 TR 0(5,9),ETOAD @SC89301 08830500 IBFVLEN DS 0H @SC86262 08831000 AR 0,2 @SC86151 08831500 B IBFLEN Must be binary @SC86151 08832000 IBFNRM DS 0H @SC86151 08832500 TM FL1,BINF 08833000 BO IBFLEN No trans for binary file 08833500 ICM 1,15,RMARG Text file: check margins @SC87253 08834000 BZ IBFCKLM No right margin specified @SC87253 08834500 CR 0,1 @SC87253 08835000 BNH IBFCKLM Record is shorter than margin @SC87253 08835500 LR 0,1 Truncate record at margin @SC87253 08836000 IBFCKLM L 1,LMARG @SC87253 08836500 S 1,F1 @SC87253 08837000 BNP IBFXLAT No left margin, or start in col 1 @SC87253 08837500 TM FLNFLGS,FLNCC @SC91116 08838000 BO IBFXLAT Can't use left margin if CC @SC91116 08838500 SR 0,1 See if record is long enough @SC87253 08839000 BNP IBFEMPT Too short, make empty record @SC87253 08839500 LR 2,9 Ptr to record @SC87253 08840000 LR 3,0 Shortened length @SC87253 08840500 LA 4,0(1,2) @SC87253 08841000 LR 5,3 @SC87253 08841500 MVCL 2,4 Eliminate stuff before margin @SC87253 08842000 IBFXLAT LA 15,ETOA Change to ASCII @SC86202 08842500 MVC IBFC1+1(1),0(9) Save column 1 as EBCDIC @SC91116 08843000 LR 2,9 Address @SC86202 08843500 LR 3,0 Length @SC86202 08844000 CLC =CL(LALF)'&JAPNEUC',TRNALF @SC91325 08844500 BNE IBFXLA1 Normal translation @SC91325 08845000 ICM 14,15,=A(KJETOA) See if 2-byte Kanji present @SC91325 08845500 BZ IBFXLA1 No, that could be a disaster @SC91325 08846000 KCALL (14),E=(IBFTRNX,M) Yes, call the routine @SC91325 08846500 LR 0,15 Get new length of buffer @SC91325 08847000 B IBFXLA2 Done translating @SC91325 08847500 IBFXLA1 DS 0H @SC91325 08848000 BAL 14,TRANSLAT Do the translate @SC86202 08848500 IBFXLA2 DS 0H @SC91325 08849000 AR 9,0 Point one past last char 08849500 C 0,F1 @SC88340 08850000 BE IBFTRUNC Record of 1 blank always converted@SC88340 08850500 CLI FRECF,C'F' @SC88050 08851000 BE IBFTRUNC Always trim if fixed length @SC88349 08851500 CLC RMARG,F0 @SC88349 08852000 BE IBFTRUZ Don't trim if no fixed rt. margin @SC88349 08852500 IBFTRUNC BCTR 9,0 Back up one 08853000 CLI 0(9),ABL 08853500 BNE IBFLCHAR Found non-blank 08854000 BCT 0,IBFTRUNC FIND LAST CHAR 08854500 IBFEMPT SR 0,0 Record is empty @SC87253 08855000 IBFTRUZ BCTR 9,0 Point to last char of record @SC88050 08855500 IBFLCHAR MVI 1(9),CR Add CR @SC86135 08856000 A 0,F1 Count up for CR @SC91116 08856500 TM FLNFLGS,FLNCC @SC91116 08857000 BO IBFCC Save LF for later @SC91116 08857500 MVI 2(9),ALF Add LF @SC86135 08858000 A 0,F1 Count up for LF @SC91116 08858500 IBFLEN ST 0,RBUFL LRECL or LRECL + 2 (FOR CRLF) 08859000 B RTRN0 08859500 * 08860000 IBFCC L 1,RBUF Start of buffer @SC91116 08860500 LH 2,IBFC1 @SC91116 08861000 IC 2,IBFCCTB(2) Determine proper format character @SC91116 08861500 CLI CARCTL,0 Just beginning file? @SC91116 08862000 BE *+8 Yes, suppress initial FF or LF @SC91116 08862500 STC 2,CARCTL No, remember what to insert @SC91116 08863000 MVI 0(1),ALF Usually substitute plain LF @SC91116 08863500 CLM 2,1,*+9 @SC91116 08864000 BNE *+8 @SC91116 08864500 MVI 0(1),AFF Page requires FF @SC91116 08865000 B IBFLEN @SC91116 08865500 * 08866000 IBFEOF OI FL1,EOF 08866500 B RTRNM1 @SC86295 08867000 * 08867500 IBFTRNX L 1,FILPTR Ptr to disk FAB @SC91325 08868000 MVC FABCOMM-FABD(8,1),=CL8'Xlate' @SC91325 08868500 LA 15,999 Weird error code @SC91325 08869000 IBFERR C 15,F12 EOF code? 08869500 BE IBFEOF Yes 08870000 ERRF , Disk read error, analyze it @SC87338 08870500 CLOSF FILPTR Close file @SC86295 08871000 B RTRN1 @SC86295 08871500 * 08872000 * Table of codes for combined ASA and machine carriage ctrl @SC91116 08872500 * 0-3 => advance "n" lines, 12 => form feed @SC91116 08873000 IBFCCTB DC AL1(1,0),(X'13'-X'02')AL1(1),AL1(2) @SC91116 08873500 DC (X'1B'-X'14')AL1(1),AL1(3) @SC91116 08874000 DC (X'4E'-X'1C')AL1(1),AL1(0) '+' @SC91116 08874500 DC (X'60'-X'4F')AL1(1),AL1(3) '-' @SC91116 08875000 DC (X'8B'-X'61')AL1(1),AL1(AFF) @SC91116 08875500 DC (C'0'-X'8C')AL1(1),AL1(2,AFF),14AL1(1) '0,1' @SC91116 08876000 LOCALS , @SC86295 08876500 IBFC1 DS H Index into CCTB @SC91116 08877000 INBUF EXIT 08877500 TITLE 'OUTBUF Routine - write WBUF to a disk file' 08878000 * Entry: R1=length of buffer (which starts where WBUF points) 08878500 * Exit: R15=0 if ok, other if error (ERRNUM set) 08879000 OUTBUF ENTER 08879500 WEAKX KJATOE @SC91325 08880000 LR 9,1 Save buffer length @SC88120 08880500 L 6,FSIZE Use to hold lrecl @SC88120 08881000 L 7,WBUF Address of buffer 08881500 ICM 2,15,RDWLEN @SC86151 08882000 BZ OBFNRM @SC86151 08882500 SR 1,1 Special format @SC86151 08883000 ICM 1,3,0(7) Get true record length @SC86151 08883500 C 2,F2 Short? @SC86262 08884000 BE OBFVLEN Yes @SC86262 08884500 PACK TMPDW,0(5,7) No, must be 5-byte ASCII @SC86262 08885000 OI TMPDW+7,15 Get + sign @SC86262 08885500 CVB 1,TMPDW Convert back to binary @SC86262 08886000 OBFVLEN DS 0H @SC86262 08886500 AR 7,2 Skip over descriptor @SC86151 08887000 SR 9,2 Correct length @SC86151 08887500 LA 15,15 Suitable disk error @SC86151 08888000 CR 1,9 Match? @SC86151 08888500 BE OBFLEN Ok, do it @SC88053 08889000 L 1,FILPTR Ptr to disk FAB @SC88053 08889500 MVC FABCOMM-FABD(8,1),=CL8'Binary' @SC88053 08890000 B OBFERR No, give up @SC88053 08890500 OBFNRM DS 0H @SC86151 08891000 TM FL1,BINF 08891500 BO OBFLEN Go if binary data file 08892000 LTR 9,9 Any data to write? 08892500 BNZ OBFTR Yes, there's data 08893000 MVI 0(7),ABL Make first char a space 08893500 LA 9,1 Length of one 08894000 OBFTR LA 15,ATOE Change to EBCDIC @SC86202 08894500 LR 2,7 @SC86202 08895000 LR 3,9 Length @SC86202 08895500 CLC =CL(LALF)'&JAPNEUC',TRNALF @SC91325 08896000 BNE OBFXLA1 Normal translation @SC91325 08896500 ICM 14,15,=A(KJATOE) See if 2-byte Kanji present @SC91325 08897000 BZ OBFXLA1 No, that could be a disaster @SC91325 08897500 KCALL (14),E=(OBFTRNX,M) Yes, call the routine @SC91325 08898000 LR 9,15 Get new length of buffer @SC91325 08898500 B OBFLEN Done translating @SC91325 08899000 OBFXLA1 DS 0H @SC91325 08899500 BAL 14,TRANSLAT Do the translate @SC86202 08900000 OBFLEN CR 9,6 Compare data len. to trunc len. @SC88120 08900500 BE OBFWRT Go if lrecl exactly @SC87268 08901000 BH OBFTRNC Go if must truncate @SC87268 08901500 CLI FRECF,C'F' @SC88120 08902000 BNE OBFWRT Go if variable format @SC88120 08902500 LR 1,6 Else, get lrecl size 08903000 SR 1,9 Pad with this many spaces 08903500 LA 0,0(9,7) Where to start padding 08904000 SR 15,15 @SC86295 08904500 TM FL1,BINF @SC86295 08905000 BO *+8 @SC86295 08905500 ICM 15,8,BLANK Pad with spaces @SC86295 08906000 MVCL 0,14 Do it 08906500 B OBFLRECL And note new length @SC87268 08907000 OBFTRNC LA 0,1 @SC87268 08907500 A 0,RECTRC @SC87268 08908000 ST 0,RECTRC Increment count of truncations @SC87268 08908500 CLI TRNCFL,C'H' Do we halt here? @SC88120 08909000 BNE OBFLRECL Truncation allowed, ok @SC88120 08909500 MVI ERRNUM,ERRRTR Mark error and stop @SC88120 08910000 B RTRN1 @SC88120 08910500 OBFLRECL LR 9,6 Length has to be this size 08911000 OBFWRT LM 14,15,DSKTOT Update disk count @SC86295 08911500 ALR 15,9 @SC86295 08912000 BC 12,*+8 @SC88092 08912500 AL 14,F1 @SC86295 08913000 STM 14,15,DSKTOT Save new count @SC86295 08913500 WRITF FILPTR,BUFFER=(7),BSIZE=(9) @SC87034 08914000 LTR 15,15 Any disk write errors? 08914500 BZ OBFRET Nope, all OK 08915000 MVI ERRNUM,ERRFUL Maybe disk is full @SC86345 08915500 CLM 15,1,ERRNUM Is it? @SC86345 08916000 BE OBFRET Yes, too bad @SC86345 08916500 OBFERR ERRF , General write error, analyze it @SC87338 08917000 OBFRET RET 08917500 OBFTRNX L 1,FILPTR Ptr to disk FAB @SC91325 08918000 MVC FABCOMM-FABD(8,1),=CL8'Xlate' @SC91325 08918500 LA 15,999 Weird error code @SC91325 08919000 B OBFERR Give up @SC91325 08919500 LOCALS , @SC86295 08920000 OUTBUF EXIT 08920500 TITLE 'FOPSTR Routine - test string for file options' 08921000 * Entry: R1->Address of option field, R6->string, R7=length - 1 08921500 * Exit: R15=0 + R6,R7 fixed if ok, R15=1 if error (msg ptrs set up) 08922000 FOPSTR ENTER , @SC89218 08922500 LR 5,1 Save ptr to options @SC89218 08923000 NI FL2,255-FOPTS Clear option flag @SC89218 08923500 MVC 0(8,5),=F'0,-1' Default values @SC89218 08924000 MVI 8(5),0 Default flags @SC91116 08924500 LA 9,0(7,6) Point to last character @SC89218 08925000 LR 1,9 @SC89218 08925500 EX 7,FOPTRT Scan for option starter @SC89218 08926000 BZ RTRN0 Not found, no action @SC89218 08926500 OI FL2,FOPTS Yes, note the fact @SC89218 08927000 PTEXT '&MISSOPS' Just in case @SC89249 08927500 CR 1,9 Anything after the starter? @SC89218 08928000 BE FOPERR No, too bad @SC89218 08928500 PTEXT '&BADDELF' In case @SC89249 08929000 CLI 0(9),FBRK2 Check ending @SC89218 08929500 BNE FOPERR Wrong one @SC89218 08930000 LR 0,1 @SC89218 08930500 SR 0,6 Length of stuff before options @SC89218 08931000 BCTR 0,0 Length - 1 @SC89218 08931500 LA 6,1(,1) Ptr to option string @SC89218 08932000 RETREG (7,0) Return length-1 as fixed R7 @SC89218 08932500 * Set up loop over line numbers @SC89218 08933000 LA 1,2 @SC89218 08933500 LR 2,5 Ptr to option fields @SC89218 08934000 LA 8,C'-' Delimiter after 1st number @SC89218 08934500 * 08935000 FOPNLP LA 7,1(,9) End of string @SC89218 08935500 SR 7,6 Length remaining @SC89218 08936000 CH 7,*+10 @SC89218 08936500 BNH *+8 @SC89218 08937000 LA 7,15 Max allowed by GETNUM @SC89218 08937500 LR 15,6 Save start of string @SC89218 08938000 BAL 14,GETNUM 1st, returns R15->end of digits @SC89218 08938500 LR 7,15 @SC89218 08939000 SR 7,6 Length of numeric string @SC89218 08939500 BAL 14,GETNUM 2nd, returns number and skips @SC89218 08940000 SR 0,0 Omitted, use -1 @SC89218 08940500 BCTR 0,0 @SC89218 08941000 LA 6,1(,15) Ptr to rest of string @SC89218 08941500 STCM 0,15,0(2) Save result in option field @SC89218 08942000 CLI 0(15),FBRK2 Reached end? @SC89218 08942500 BE FOPNLQ Yes, quit scanning @SC89218 08943000 CLI 0(15),C'_' Reached end of range limits? @SC89218 08943500 BE FOPNLQ Yes, quit scanning @SC89218 08944000 PTEXT '&BADDELM' @SC89249 08944500 CLM 8,1,0(15) Delimiter for this number? @SC89218 08945000 BNE FOPERR None of these, syntax error @SC89218 08945500 LA 2,4(,2) Advance output ptr @SC89218 08946000 LA 8,C'_' Change delimiter @SC89218 08946500 BCT 1,FOPNLP Get next number @SC89218 08947000 FOPNLQ ICM 1,15,0(5) Check starting line number @SC89218 08947500 S 1,F1 Convert to number to skip @SC89218 08948000 BNM *+6 @SC89218 08948500 SR 1,1 No skipping @SC89218 08949000 STCM 1,15,0(5) @SC89218 08949500 PTEXT '&BADRNGE' @SC89249 08950000 CLM 1,15,4(5) Check range for order @SC89218 08950500 BNL FOPERR Upper limit smaller! @SC89218 08951000 CR 6,9 Any more option text? @SC89218 08951500 BNL RTRN0 No, all done @SC89218 08952000 * Other options @SC89218 08952500 * 08953000 CLC =C'CC',0(6) @SC91116 08953500 BE FOPCC @SC91116 08954000 CLC =C'cc',0(6) @SC91116 08954500 BE FOPCC @SC91116 08955000 * Fall through if option not defined @SC89218 08955500 PTEXT '&BADOPTS' @SC89249 08956000 FOPERR RETREG 3,4 Return msg ptrs as R3, R4 @SC89218 08956500 MVI ERRNUM,ERROPT Error with option(s) @SC89249 08957000 B RTRN1 @SC89218 08957500 * 08958000 FOPCC OI FLNFLGS-FLNOPTS(5),FLNCC Set flag for CC @SC91116 08958500 B RTRN0 @SC91116 08959000 * 08959500 FOPTRT TRT 0(,6),FOPBRK Scan for initial character @SC89218 08960000 FOPBRK DC 256X'00' @SC89218 08960500 ORG FOPBRK+FBRK1 @SC89218 08961000 DC X'01' @SC89218 08961500 ORG , @SC89218 08962000 LOCALS , @SC89218 08962500 EXIT , @SC89218 08963000 TITLE 'KHDMP Routine - dump storage to log file' 08963500 * Dump area to log 08964000 * Entry: R1->area, R0=length, R2-> 8-byte title for area 08964500 * Exit: R15=0 if ok 08965000 KHDMP ENTER , @SC91008 08965500 AIF ('&KTRACE' EQ 'NO').KHDZ1 @SC91008 08966000 TM FL1,DEBUG+TSTF Special logging in effect? @SC91008 08966500 BNO RTRN0 No, that's all @SC91008 08967000 LA 5,15 Round up to mult of 16 @SC91008 08967500 ALR 5,0 From length @SC91008 08968000 SRA 5,4 Convert to count of lines @SC91008 08968500 BNP RTRN0 Nothing there @SC91008 08969000 LR 4,1 Save ptr to area @SC91008 08969500 L 6,LOGBUF Ptr to buffer @SC91008 08970000 MVI 0(6),C'*' Set log label @SC91008 08970500 MVC 2(8,6),0(2) Copy title @SC91008 08971000 WRITF LOGPTR,BSIZE=10 @SC91008 08971500 MVC 4*9+2(3,6),=C' *' Set off character version @SC91008 08972000 MVI 4*9+2+3+16(6),C'*' @SC91008 08972500 KHDLP1 LA 3,2(,6) Start of data area @SC91008 08973000 LA 1,4 Words to dump per line @SC91008 08973500 MVC 4*9+2+3(16,6),0(4) Copy string @SC91008 08974000 TR 4*9+2+3(16,6),KHDPRT and make printable @SC91008 08974500 MVI 0(3),C' ' Add for readability @SC91008 08975000 KHDLP2 UNPK 1(9,3),0(5,4) Unpack into buffer @SC91008 08975500 TR 1(8,3),TRHEX Convert to printable hex @SC91008 08976000 MVI 9(3),C' ' Blank out garbage @SC91008 08976500 LA 3,9(,3) Advance text ptr @SC91008 08977000 LA 4,4(,4) and data source @SC91008 08977500 BCT 1,KHDLP2 Loop over line of 16 @SC91008 08978000 LA 3,4*9+2+3+16+1 Length of data @SC91008 08978500 WRITF LOGPTR,BSIZE=(3) @SC91008 08979000 BCT 5,KHDLP1 Loop over lines @SC91008 08979500 TM DBGFLG,DBGSV SAVE requested? @SC91008 08980000 BZ RTRN0 No, skip closing log file @SC91008 08980500 SAVEF LOGPTR Update disk directory @SC91008 08981000 .KHDZ1 ANOP @SC91008 08981500 B RTRN0 @SC91008 08982000 * 08982500 AIF ('&KTRACE' EQ 'NO').KHDZ2 @SC91008 08983000 KHDPRT DC 64C'.',192AL1(*-KHDPRT) @SC91008 08983500 .KHDZ2 ANOP @SC91008 08984000 LOCALS , @SC91008 08984500 EXIT , @SC91008 08985000 END KERMIT 08985500