*COPY IK0CMD 03000000 TITLE 'USNTRF Routine - execute main loop' 03001000 * Execute Kermit commands (beginning with default TAKE files) 03002000 * Entry: environment already set up 03003000 * Exit: R15=0 03004000 * ERRNUM set appropriately 03005000 USNTRF ENTER 03006000 LA 0,KRMPROT @SC86295 03007000 LA 1,USNCMD Full list of commands @SC87117 03008000 BAL 14,LOOPS Set up loop return @SC86295 03009000 LA 2,USRTAKE 03010000 LA 1,LUSRT Length of name @SC86295 03011000 BAL 9,LUPTIN Test user KERMINI @SC86295 03012000 NOP 0 Not found, skip it @SC86295 03013000 LA 2,SYSTAKE @SC86135 03014000 LA 1,LSYST Length of name @SC86295 03015000 BAL 9,LUPTIN Test system KERMINI @SC86295 03016000 NOP 0 Not found, skip it @SC86295 03017000 MVI ERRNUM,ERRNFT No transfers yet @SC86295 03018000 KCALL SUPFNC,6,E=LOOP @SC86295 03019000 OI KFLG,CMDL+SIGN Got command line, suppress banner@SC86295 03020000 B LOOP @SC86295 03021000 * 03022000 KRMININC WTEXT 'Kermit-&KSYS Version &KVRSN (&KDATE.)' @SC86268 03023000 WTEXT 'Enter ? for a list of valid commands' 03024000 STRTMSGS , Any system-specific messages... @SC87338 03025000 OI KFLG,SIGN Banner done @SC86295 03026000 KRMPROB PTEXT BLANK,1 And leave a blank line 03027000 B LUPWRT Not an error @SC86295 03028000 * 03029000 KRMPROT TM KFLG,CMDL @SC86295 03030000 BZ KRMPROCL Go if Not cmd line 03031000 NI KFLG,255-CMDL Turn off command line @SC86295 03032000 OI KFLG,CMDC Command from cmd line @SC86295 03033000 L 1,CBUF address of cmd 03034000 L 0,CLEN Length @SC86171 03035000 B LUPPRS Go process it @SC86295 03036000 * 03037000 KRMPROCL TM KFLG,CMDC @SC86295 03038000 BZ KRMPROR Go if not cmd line 03039000 KCALL SUPFNC,7,E=(KRMXITQ,Z) Go if nothing stacked @SC86295 03040000 KRMPROR TM KFLG,SIGN Already printed banner? @SC86295 03041000 BO KRMPROX Yes, or suppressed @SC86295 03042000 KCALL SUPFNC,7,E=(KRMININC,Z) Go if nothing stacked @SC86295 03043000 KRMPROX LA 3,CMD @SC86295 03044000 LA 4,KPRPT Current prompt @SC87268 03045000 SR 0,0 @SC87268 03046000 IC 0,KPRPL Prompt length @SC87268 03047000 RTEXT (3),PROMPT=((4),(0)) @SC87268 03048000 LA 1,CMD Ptr to command @SC86171 03049000 B LUPPRS Go process it @SC86295 03050000 * 03051000 USNCMD KW 'EXIT',KRMXIT,MIN=2 03052000 KW 'QUIT',KRMXIT 03053000 USNCMDX KW 'BYE',KRMBYE,MIN=3 @SC86155 03054000 KW 'DIRECTORY',KRMDIR,MIN=3 @SC86295 03055000 KW 'ECHO',KRMECO,MIN=2 03056000 KW 'FINISH',KRMFIN,MIN=3 @SC86155 03057000 KW 'GET',KRMGET @SC86155 03058000 KW 'HELP',KRMHLP 03059000 KW 'LOCAL',LUPTOK,MIN=3 @SC86295 03060000 KW 'RECEIVE',KRMREC,MIN=3 03061000 KW 'REMOTE',KRMREM,MIN=3 @SC86155 03062000 KW 'SEND',KRMSND,MIN=3 03063000 KW 'SERVER',KRMSRV,MIN=3 03064000 KW 'XECHO',KRMXPE,MIN=2 @SC86204 03065000 KW 'XTYPE',KRMNPS,MIN=2 @SC86204 03066000 SRVKCMD KW '&KSYS.',LUPHST,MIN=2 Valid in Server mode ... @SC86295 03067000 AIF ('&KSYS' NE 'CMS').CM0Z @SC86355 03068000 KW 'CP',LUPCP,MIN=2 @SC86295 03069000 .CM0Z KW 'CWD',LUPCWD,MIN=2 @SC86295 03070000 KW 'GIVE',LUPGIV,MIN=2 @SC87117 03071000 KW 'HOST',LUPHST,MIN=2 @SC87253 03072000 KW 'KERMIT',LUPTOK @SC87343 03073000 KW 'SET',LUPSET,MIN=3 @SC86295 03074000 KW 'SHOW',LUPSHO,MIN=2 @SC86295 03075000 KW 'SPACE',LUPSPA,MIN=2 @SC86295 03076000 KW 'STATUS',LUPSTA,MIN=2 @SC86295 03077000 KW 'TAKE',LUPTAK,MIN=2 @SC86295 03078000 KW 'TDUMP',LUPDMP,MIN=2 @SC86295 03079000 KW 'TYPE',LUPHSTI,MIN=2 @SC86295 03080000 KW 03081000 * 03082000 KRMECO L 3,ADR Pick rest of line 03083000 ICM 4,B'1111',LEN Remaining data length 03084000 BNP KRMPROB Go if nothing left in cmd 03085000 B LUPWRT Else, print the rest @SC86295 03086000 * @SC86155 03087000 KRMREM KCALL GENCMD,0,E=LUPERK Send remote command @SC86295 03088000 B KRMXFZ @SC87300 03089000 * @SC86155 03090000 KRMBYE BAL 14,LUPCNF Check for illegal extras @SC86295 03091000 KCALL GENCMD,AL Send Logout command @SC86155 03092000 B KRMXFZ @SC87300 03093000 * 03094000 KRMFIN BAL 14,LUPCNF Check for illegal extras @SC86295 03095000 KCALL GENCMD,AF Send Finish command @SC86155 03096000 B KRMXFZ @SC87300 03097000 * 03098000 KRMGET LA 0,FFGET+FFRCF @SC86295 03099000 KCALL FSPEC,JFSPEC Get foreign filespec @SC86295 03100000 BAL 14,LUPCKFN @SC86295 03101000 LA 0,FFGET @SC86295 03102000 KCALL FSPEC,FILNAM Get native filespec, if any @SC86295 03103000 BAL 14,LUPCKFN @SC86295 03104000 BAL 14,LUPCNF Check for illegal extras @SC86295 03105000 LA 0,FFNEW+FFGET @SC87012 03106000 KCALL FSPEC,FILNAM,E=LUPWRTE Avoid collisions @SC87012 03107000 BAL 8,IPKSET Set state table, exchange parms @SC86295 03108000 * Init packet Rpack interpret input tables @SC86155 03109000 DC AL1(AY),AL3(0) ACK'ed @SC86155 03110000 DC AL1(00),AL3(KRMGETAB) Error @SC86155 03111000 BAL 9,PAKFIL Copy file specification to buffer @HF86223 03112000 BAL 9,ENCODEN Encode file-spec @SC86295 03113000 MVI STYPE,AR Packet type = receive initiate @SC86155 03114000 KCALL SPACK,E=KRMGETAB Send name @SC86155 03115000 KCALL RECEIV @SC86155 03116000 B KRMXFZ @SC86239 03117000 * 03118000 KRMGETAB KCALL INTINI,0 @SC86155 03119000 B KRMXFZ @SC87300 03120000 * 03121000 KRMREC LA 0,FFRCF @SC86295 03122000 KCALL FSPEC,FILNAM Get filespec @SC86295 03123000 BAL 14,LUPCKFN @SC86295 03124000 BAL 14,LUPCNF Check for illegal extras @SC86295 03125000 LA 0,FFNEW+FFGET @SC87012 03126000 KCALL FSPEC,FILNAM,E=LUPWRTE Avoid collisions @SC87012 03127000 KCALL INTINI,3,E=KRMXFZ Initialize for receive @SC87300 03128000 KCALL RECEIV 03129000 B KRMXFZ @SC86239 03130000 * 03131000 KRMNPS OI FL4,NPS @SC86165 03132000 MVI TCTLQ,0 Turn off control quoting @SC86165 03133000 * 03134000 KRMSND LA 0,FFSND @SC86295 03135000 KCALL FSPEC,IFILE Get filespec @SC86295 03136000 BAL 14,LUPCKFN @SC86295 03137000 LA 0,FFSND+FFRCF @SC86295 03138000 KCALL FSPEC,JFSPEC Get filespec @SC86295 03139000 BAL 14,LUPCKFN @SC86295 03140000 BAL 14,LUPCNF Check for illegal extras @SC86295 03141000 KRMSNDBG KCALL SEND 03142000 KRMXFZ SR 3,3 @SC86355 03143000 ICM 3,1,ERRNUM Ok? @SC86355 03144000 BZ LOOP Yes, get next command @SC86355 03145000 SLL 3,2 No, convert error number @SC86355 03146000 A 3,AERRTAB Ptr into message table @SC86355 03147000 SR 4,4 @SC86355 03148000 IC 4,0(3) Length @SC86355 03149000 ICM 3,7,1(3) Message ptr @SC86355 03150000 B LUPWRTE Display it and go on @SC86355 03151000 * 03152000 KRMXPE L 5,ADR Pointer to rest of line @HF86150 03153000 ICM 4,15,LEN Remaining data length @HF86150 03154000 BNP KRMXPEH Go if nothing specified @HF86150 03155000 L 3,RBUF @HF86150 03156000 MVC 0(256,3),0(5) Copy to disk read buffer @HF86150 03157000 AR 4,3 Get end @HF86150 03158000 STM 3,4,TXTPTR Point to text to copy @HF86150 03159000 OI FL4,SFM+NPS Data source: text string @SC86165 03160000 MVI TCTLQ,AUP Turn on control quoting @SC86165 03161000 B KRMSNDBG @SC86165 03162000 * 03163000 KRMXPEH PTEXT 'Text string with ^X for cntl-X' @SC86165 03164000 B LUPWRT @SC86295 03165000 * 03166000 KRMSRV BAL 14,LUPCNF Check for illegal extras @SC86295 03167000 KCALL SERVER Call SERVER routine @SC86295 03168000 B KRMXFZ Return to normal mode @SC86355 03169000 * 03170000 KRMDIR LA 0,FFUTL+FFWLD @SC86295 03171000 KCALL FSPEC,FILNAM Get pattern filespec @SC86295 03172000 BAL 14,LUPCKFN Make sure ok @SC86295 03173000 LA 0,13 @SC86295 03174000 KCALL DISKIO,FILNAM Do a DIR on it @SC86295 03175000 B LOOP @SC86295 03176000 * 03177000 KRMHLP KCALL KHELP Issue help request @SC86355 03178000 B LOOP @SC86355 03179000 * 03180000 KRMXIT FTOKN N=KRMXITQ,H=LUPCRH Check for illegal extras @SC86295 03181000 B LUPBAD Not just QUIT, maybe system Q @SC86295 03182000 * 03183000 KRMXITQ NXTFSET ,END Flush pending file list @SC86355 03184000 L 2,TAKLEVK @SC86295 03185000 KRMXITL BCTR 2,0 @SC86295 03186000 LTR 3,2 Any pending TAKE files? @SC86295 03187000 BM RTRN0 No @SC86295 03188000 SLA 3,2 @SC86295 03189000 CLOSF TAKTABK(3) Close the open file @SC86295 03190000 B KRMXITL Keep checking @SC86295 03191000 LOCALS , @SC86295 03192000 * See SERVER for mapping @SC86295 03193000 DS A Return adr if no more TAKE stuff @SC86295 03194000 DS A Adr of command table @SC86295 03195000 TAKLEVK DS F Take file level @SC86295 03196000 TAKTABK DS (TAKMAX)F Tickets for I/O @SC86295 03197000 KFLG DS X Local flags in main program @SC86295 03198000 SIGN EQU X'04' Already printed Kermit banner @SC86295 03199000 CMDC EQU X'02' Command gotten from cmd 03200000 CMDL EQU X'01' Data on cmd line 03201000 USNTRF EXIT 03202000 TITLE 'SET Routine - perform SET command options' 03203000 * Set/change values in STORAG. 03204000 * Entry: SCANPTR string has option 03205000 * Exit: R15=0 if ok, 1 if help needed, 2 if bad parameter name 03206000 * ERRNUM unchanged 03207000 SET ENTER 03208000 MVI SETXI,X'97' XI instruction @SC86273 03209000 NTOKN N=RTRN2 @SC86171 03210000 NI FL3,255-PXCH Make sure server renegotiates @SC86295 03211000 SCAN SETCMDKW,RTRN1 @SC86295 03212000 B RTRN2 @SC86295 03213000 * 03214000 SETOOKW KW 'OFF',SETOFF,MIN=2 @SC87166 03215000 KW 'ON',SETON,MIN=2 @SC87166 03216000 KW , @SC87166 03217000 * 03218000 SETROFF KW 'OFF',0,MIN=2 @SC87166 03219000 SETRAW KW 'RAW',SETDEBRW @SC86316 03220000 SETCMDOO KW 'OFF',SETOFFS,MIN=2 @SC87166 03221000 SETONKW KW 'ON',SETONS,MIN=2 @SC87166 03222000 KW , @SC86171 03223000 * 03224000 SETOFF EX 0,0(9) Yes, first turn flag on... @SC87166 03225000 EX 0,SETXI Then off @SC86273 03226000 B RTRN0 @SC87166 03227000 * 03228000 SETON EX 0,0(9) Turn flag on @SC87166 03229000 B RTRN0 @SC87166 03230000 * 03231000 SETOFFS B 4(9) @SC87166 03232000 * 03233000 SETONS BR 9 Go to ON handler @SC87166 03234000 * 03235000 SETTRKW KW 'TTY',SETT @SC87166 03236000 KW 'SERIES1',SETT @SC87166 03237000 KW 'GRAPHICS',SETT @SC87166 03238000 KW 'FULLSCREEN',SETT @SC87300 03239000 KW , @SC87166 03240000 * 03241000 SETT MVC TRMTP,0(6) @SC87166 03242000 B RTRN0 @SC87166 03243000 * 03244000 SETSWT KW 'CONTINUE',SETOFF @SC86171 03245000 KW 'HALT',SETON @SC86171 03246000 KW , @SC86171 03247000 * 03248000 SETDSC KW 'DISCARD',SETOFF @SC86225 03249000 KW 'KEEP',SETON @SC86225 03250000 KW , @SC86225 03251000 * 03252000 SETPAR KW 'MARK',SETOFF @SC86316 03253000 KW 'NONE',SETON @SC86316 03254000 KW , @SC86316 03255000 * 03256000 SETTABS LA 4,SETCMDOO @SC87166 03257000 BAL 14,SETSCN @SC87166 03258000 B SETTBON Turn on @SC86355 03259000 NI FL2,255-TABS Turn off @SC86355 03260000 MVC TABCNT,F0 Clear count @SC86355 03261000 B RTRN0 @SC86295 03262000 SETTBON OI FL2,TABS Turn on @SC86355 03263000 MVC TABCNT,F0 Clear count @SC86355 03264000 SR 0,0 Init previous tab @SC86355 03265000 LA 3,TABTBL Point to start of tab table @TS86100 03266000 LA 8,255 Limit on tab stops @SC86355 03267000 LA 5,TABCNT End of table @SC86355 03268000 SETTBLP ICM 2,15,LEN Any more tokens? @SC86355 03269000 BNP SETTBN No, done @SC86355 03270000 STC 0,0(3) Save previous tab @SC86355 03271000 BAL 2,SETNUM Read number @SC86355 03272000 CLM 0,1,0(3) Is this tab higher than previous? @SC86355 03273000 BNH SETTBSEQ No, tab out of sequence @TS86100 03274000 CR 3,5 Exceeded capacity? @SC86355 03275000 BNL SETTBHI Yes @TS86100 03276000 STC 0,0(3) Save tab setting @TS86100 03277000 LA 3,1(3) Bump counter @SC86355 03278000 B SETTBLP @SC86355 03279000 SETTBN LA 0,TABTBL Point to start of tab table @SC86355 03280000 SR 3,0 Get length of table @SC86355 03281000 STH 3,TABCNT Save the tab count @TS86100 03282000 B RTRN0 @SC86355 03283000 SETTBHI PTEXT 'Too many tabs' @SC86355 03284000 B SETTBER Return error @SC86355 03285000 SETTBSEQ PTEXT 'Tabs out of sequence' @TS86100 03286000 SETTBER NI FL2,255-TABS Turn off @SC86355 03287000 B SUBERR Return error @TS86100 03288000 * 03289000 SETLIN BAL 2,SETFSTR Get fixed-format string @SC86166 03290000 PTEXT 'Bad line' @SC87351 03291000 KCALL SETMSG,5,E=SUBERR Make sure it's ok @SC87351 03292000 B RTRN0 @SC86166 03293000 * 03294000 SETPRP LA 0,KPRPT Ptr to new prompt string @SC87351 03295000 KCALL SUPFNC,11 Ok it with system @SC87351 03296000 B RTRN0 @SC87351 03297000 * 03298000 KSETPRC , System-specific options @SC86355 03299000 * 03300000 SETFKW KW 'LRECL',SHOLR **COMPAT** @SC87166 03301000 KW 'T',SETFT **COMPAT** @SC87166 03302000 KW 'TYPE',SHOFILT **COMPAT** @SC87166 03303000 KFILKW , **COMPAT** @SC87166 03304000 SETFIL KW 'TEXT',SETFILET @SC86133 03305000 KW 'BINARY',SETFILEB @SC86262 03306000 SETDBIN KW 'D-BINARY',SETFILEB @SC86262 03307000 KW 'V-BINARY',SETFILEB @SC86151 03308000 KW 03309000 * 03310000 SETFILEB OI FL1,BINF Set binary on 03311000 SETFLR SR 0,0 @SC87012 03312000 ICM 0,3,LRECL Record length @SC86295 03313000 ST 0,MAXOUT Max output buffer size @SC86295 03314000 MVC TYPFIL,0(6) Save type @SC86151 03315000 B RTRN0 @SC86295 03316000 * 03317000 SETFILET NI FL1,255-BINF Set it OFF 03318000 B SETFLR @SC87012 03319000 * 03320000 KFILSET , @SC87012 03321000 * 03322000 SETDEB LA 0,ATOE EBCDIC log @SC86316 03323000 LA 4,SETRAW @SC86316 03324000 BAL 14,SETSCN @SC86316 03325000 B SETDEBON @SC86273 03326000 SETDEBOF NI FL1,255-DEBUG Set it OFF 03327000 ST 0,DBGTYP Save indicator @SC86316 03328000 CLOSF LOGPTR Done logging @SC86135 03329000 B RTRN0 @SC86295 03330000 * 03331000 SETDEBRW SR 0,0 No translation for log @SC86316 03332000 SETDEBON ST 0,DBGTYP Save indicator @SC86316 03333000 TM FL1,DEBUG Already on? @SC87012 03334000 BO RTRN0 Yes @SC87012 03335000 NI LOGFLGS,255-APPN @SC86295 03336000 LA 0,L'LOGNAM Name string length @SC86295 03337000 LA 1,LOGNAM and address @SC86295 03338000 STM 0,1,SCANPTR @SC86295 03339000 LA 0,FFRCF @SC86295 03340000 KCALL FSPEC,IFILE Convert to filespec @SC86295 03341000 PTEXT 'DEBUG error' @SC87012 03342000 OPENF O,IFILE,LOGFDB,LOGPTR,E=SUBERR @SC87012 03343000 OI FL1,DEBUG Enable logging @SC87012 03344000 B RTRN0 @SC86295 03345000 * 03346000 SET8B NTOKN N=SET8BH,H=SET8BH @SC87008 03347000 LA 4,AAMP Default value @SC87008 03348000 LA 9,SET8BS @SC87008 03349000 SCAN SETONKW,RTRN2 03350000 SR 4,4 Zero value means OFF @SC87008 03351000 LTR 7,7 Length=1? @SC87008 03352000 BNZ SET8BS No, can't be ON @SC87008 03353000 BAL 2,SETQCH2 Make sure it's valid @SC87008 03354000 SET8BS STC 4,EBQC New value @SC87008 03355000 B RTRN0 @SC87008 03356000 SET8BH PTEXT 'Must be ON, OFF, or a character' @SC87008 03357000 B SUBERR @SC87008 03358000 * 03359000 SETSTR LR 2,14 @SC87268 03360000 MVI 0(8),0 Default to blank @SC87166 03361000 BAL 9,WSP Remaining data length @SC86224 03362000 B RTRN0 Null string @SC86295 03363000 LR 1,4 Max length allowed @SC87268 03364000 CR 6,1 @SC86345 03365000 BH SETSTRH Too long @SC86345 03366000 STC 6,0(8) Save length @SC87166 03367000 LA 8,1(8) Skip over length byte @SC87268 03368000 XR 6,7 Exchange ptr and length @SC87268 03369000 XR 7,6 @SC87268 03370000 XR 6,7 @SC87268 03371000 B SETFST1 Go copy string @SC87268 03372000 * 03373000 SETRCTLQ BAL 2,SETQCHR Get a char for Receive-Ctl-quote 03374000 STC 4,RCTLQ(5) Set receive ctl quote @SC86164 03375000 LTR 5,5 Done if SEND @SC86223 03376000 BNZ RTRN0 @SC86295 03377000 STC 4,DEFPARM+5 Set default for SPAR @SC86120 03378000 B RTRN0 @SC86295 03379000 * 03380000 SETQCHR NTOKN H=SETQCHRH,N=SETQCHRH 03381000 LTR 7,7 Token length - 1 03382000 BP SETQCHRH Pos: token is too long 03383000 SETQCH2 SR 4,4 @SC87008 03384000 IC 4,0(6) Get the quote char @SC86120 03385000 IC 4,ETOA(4) Get ASCII form @SC86120 03386000 NOTQR SETQCHRH Go if not 33-62 or 96-126 @SC86120 03387000 BR 2 03388000 * 03389000 SETQCHRH PTEXT 'One char with ASCII value 33-62 or 96-126' @SC86224 03390000 B SUBERR @SC86295 03391000 * 03392000 SETLR ST 0,MAXOUT Max output buffer size @SC87166 03393000 B RTRN0 @SC86295 03394000 * 03395000 SETTIMO BCT 5,RTRN0 Done if rec @SC87166 03396000 TOCHR 0,,DEFPARM+1 Set default for SPAR @SC86164 03397000 B RTRN0 @SC86295 03398000 * 03399000 SETPADN BCT 5,RTRN0 Done if rec @SC87166 03400000 TOCHR 0,,DEFPARM+2 Set default for SPAR @SC86164 03401000 B RTRN0 @SC86295 03402000 * 03403000 SETPADC BCT 5,RTRN0 Done if rec @SC87166 03404000 CTL 0,,DEFPARM+3 Set default for SPAR @SC86164 03405000 B RTRN0 @SC86295 03406000 * 03407000 SETEOL BCT 5,RTRN0 Done if rec @SC87166 03408000 STC 0,S1EOL Extra copy for prompting @SC87274 03409000 TOCHR 0,,DEFPARM+4 Set default for SPAR 03410000 B RTRN0 @SC86295 03411000 * 03412000 SETSIZ C 0,AKMIN Less than min Kermit size? @SC87166 03413000 BL SETKSIZH Yes, error @SC86164 03414000 C 0,AKMAX More than max Kermit size? @SC86164 03415000 BNH SETRPS1 No, skip message call @TB86196 03416000 LTR 5,5 SEND? @SC86224 03417000 BNZ SETKSIZH Yes, can't set it long @SC86224 03418000 LR 6,0 Save value across WTEXT @SC86316 03419000 WTEXT 'Type 0 long packets specified' @SC86202 03420000 LR 0,6 @SC86316 03421000 SETRPS1 DS 0H @TB86196 03422000 BCT 5,RTRN0 Done if recv @SC86295 03423000 TOCHR 0,,DEFPARM+0 Set default for SPAR 03424000 B RTRN0 @SC86295 03425000 * 03426000 SETKSIZH PTEXT 'Operand must be 20-94 for SEND' KMIN-KMAX @SC86295 03427000 B SUBERR @SC86295 03428000 * 03429000 SETETOA LA 3,ETOA Address of table to change @SC86265 03430000 B SETTET2 @SC87117 03431000 SETTET LA 3,TETOA Address of table to change @SC87117 03432000 SETTET2 LA 2,ETOAD Address of original @SC87117 03433000 SETTR0 ICM 0,15,LEN Any more tokens? @SC87117 03434000 BP SETTR1 Yes, must be numeric @SC87117 03435000 MVC 0(256,3),0(2) No, just reset table @SC87117 03436000 B RTRN0 @SC87117 03437000 SETTR1 LA 8,255 Limit for each @SC87117 03438000 BAL 2,SETNUM Get a number for table offset @SC86295 03439000 AR 3,0 Save table offset here @SC86295 03440000 BAL 2,SETNUM Get a number for value @SC86295 03441000 STC 0,0(3) Change value @SC86295 03442000 B RTRN0 All done @SC86295 03443000 * 03444000 SETATOE LA 3,ATOE Adr of table to edit @SC86265 03445000 B SETTAT2 @SC87117 03446000 SETTAT LA 3,TATOE Address of table to change @SC87117 03447000 SETTAT2 LA 2,ATOED Address of original @SC87117 03448000 B SETTR0 Use common routine 03449000 * 03450000 * 03451000 * R6 points to token, R7 has length-1. Convert to binary in R0. 03452000 * Return via R2 03453000 SETNUM2 LR 2,14 Save return @SC87166 03454000 SETNUM NTOKN H=SETNUMH,N=SETNUMH @SC86295 03455000 LA 7,1(7) Length @SC86316 03456000 BAL 14,GETNUM @SC86316 03457000 B SETNUMH @SC86316 03458000 CLR 0,8 Within limit? @SC86295 03459000 BH SETNUMH Too big @SC87166 03460000 CLI 0(2),X'47' Entered at SETNUM2? @SC87166 03461000 BNER 2 No, return immediately @SC87166 03462000 LR 14,2 Ptr to caller @SC87166 03463000 S 14,F8 Back up to the LOAD instr @SC87166 03464000 MVC SETXI,0(14) Copy and modify op instr @SC87166 03465000 NC SETXI(2),=X'F60F' @SC87166 03466000 CLI SETXI,X'B6' Was is ICM? @SC87166 03467000 BNE *+8 No, ok @SC87166 03468000 MVI SETXI,X'BE' Yes, make into STCM @SC87166 03469000 EX 0,SETXI Store value @SC87166 03470000 BR 2 Return @SC87166 03471000 * 03472000 SETNUMH LA 15,CMD+16 @SC86295 03473000 SETMAXH MVC CMD(26),=C'Operand must be of length ' @SC86295 03474000 MVI 0(15),C'<' @SC86295 03475000 LA 15,1(15) @SC86295 03476000 LR 4,8 @SC86345 03477000 A 4,F1 @SC86345 03478000 BAL 2,EDDEC Put limit into message @SC86295 03479000 LR 4,15 End @SC86295 03480000 LA 3,CMD @SC86295 03481000 SR 4,3 @SC86295 03482000 B SUBERR @SC86295 03483000 * 03484000 SETFSTR LR 1,9 Save length @SC87166 03485000 NTOKN N=SETFST0,H=SETSTRH @SC87166 03486000 LA 7,1(7) @SC86295 03487000 CR 7,1 Name too long? @SC86295 03488000 BNH SETFST1 No, do it @SC86295 03489000 SETSTRH LR 8,1 Copy max length @SC86295 03490000 LA 15,CMD+26 Base message size @SC86295 03491000 B SETMAXH @SC86295 03492000 SETFST0 SR 7,7 Empty string @SC86295 03493000 SETFST1 ICM 7,8,BLANK Set for blank fill @SC86295 03494000 LR 9,1 @SC87166 03495000 MVCL 8,6 Copy name @SC87166 03496000 BR 2 @SC86295 03497000 TITLE 'SHOW Routine - performs SHOW command options' 03498000 * Display current values in STORAG. 03499000 * Entry: SCANPTR string has option 03500000 * Exit: R15=0 if ok, 1 if help needed, 2 if bad parameter name 03501000 * ERRNUM unchanged 03502000 SHOW ENTER ALT @SC86133 03503000 LA 0,CMD @SC86227 03504000 ST 0,SHOPTR Initialize output ptr @SC86227 03505000 MVI SETXI,X'91' TM instruction @SC87166 03506000 NTOKN N=SHOALL @SC86133 03507000 SCAN SHOCMDS,RTRN1 @SC86295 03508000 SHOBAD B RTRN2 Invalid operand @SC86295 03509000 * 03510000 SETCMDKW DS 0H @SC87166 03511000 KW 'ATOE',SETATOE,MIN=4 @SC87166 03512000 KW 'ETOA',SETETOA,MIN=4 @SC87166 03513000 KW 'FILE-TYPE',SHOFILT,MIN=5 @SC87166 03514000 KW 'TATOE',SETTAT,MIN=5 @SC87166 03515000 KW 'TETOA',SETTET,MIN=5 @SC87166 03516000 * 03517000 SHOCMDS KW 'RECFM',SHORFM,MIN=4 @SC87012 03518000 KW 'LRECL',SHOLR @SC86133 03519000 SHOCMDKW EQU * Must match order of code 03520000 KW 'TABS-EXPAND',SHOTABS @SC86133 03521000 KW 'EOF',SHOEOF,MIN=3 @SC86133 03522000 KW 'DEBUG',SHODEB @SC86133 03523000 KW 'BLOCK-CHECK',SHOBLK @SC86133 03524000 KW '8-BIT-QUOTE',SHO8B @SC87008 03525000 KW 'PROMPT',SHOPRP,MIN=2 @SC87268 03526000 KW 'LINE',SHOLIN,MIN=3 @SC87166 03527000 KW 'CONTROLLER',SHOTRM,MIN=3 @SC87268 03528000 KW 'HANDSHAKE',SHOHND @SC87274 03529000 KW 'PARITY',SHOPRTY @SC86316 03530000 KW 'WARNING',SHOWARN @SC86133 03531000 KW 'SYSCMD',SHOSYS,MIN=2 @SC86295 03532000 KW 'TTABLE',SHOTTB,MIN=2 @SC87117 03533000 KW 'DELAY',SHODLY,MIN=3 @SC86164 03534000 KW 'APPEND',SHOAPP,MIN=3 @SC86203 03535000 KW 'INCOMPLETE',SHOINC,MIN=3 @SC86225 03536000 KW 'TEST',SHOTST,MIN=4 @SC87166 03537000 KSETKW , Specific parameters @SC87166 03538000 KW 'FILE',SHOFIL @SC86295 03539000 KW 'MARGIN',SHOMRG @SC87253 03540000 KW 'FOREIGN',SHOFOR,MIN=3 @HF86223 03541000 KW 'RETRY',SHORETR,MIN=3 @SC86345 03542000 KW 'TAKE',SHOTAK,MIN=3 @SC86171 03543000 KW 'RECEIVE',SHORECV,MIN=3 @SC86133 03544000 KW 'SEND',SHOSEND,MIN=3 @SC86224 03545000 KW , @SC86133 03546000 * 03547000 SHOALL OI SFLG,ALLF Do all @SC86295 03548000 LA 1,SHOCMDKW Start at beginning @SC86133 03549000 * 03550000 * Each routine begins with R1-> keyword item @SC86133 03551000 SHOTABS CLI SETXI,X'97' SET or SHOW? @SC87166 03552000 BE SETTABS @SC87166 03553000 BAL 14,SHOOO On or off @SC86133 03554000 OI FL2,TABS @SC87166 03555000 SHOTABSZ LH 5,TABCNT Count of tabs @SC86355 03556000 LA 3,TABTBL Ptr to table of tabs @SC86355 03557000 BAL 14,SHOLIST Display list of tab stops, if any @SC86355 03558000 NOP 0 @SC87166 03559000 SHOEOF BAL 14,SHOOO On or off @SC86133 03560000 OI FL2,EOFZ @SC87166 03561000 SHODEB CLI SETXI,X'97' SET or SHOW? @SC87166 03562000 BE SETDEB @SC87166 03563000 LA 4,SETCMDOO @SC86345 03564000 CLC DBGTYP,F0 EBCDIC log? @SC86345 03565000 BNE *+8 Yes, it's ON or OFF @SC87166 03566000 LA 4,SETROFF No, it's RAW @SC87166 03567000 BAL 14,SHOXY @SC86345 03568000 OI FL1,DEBUG @SC87166 03569000 SHOBLK SR 4,4 @SC86133 03570000 LA 8,3 Limit @SC87166 03571000 IC 4,BCTC Get block check type @SC86133 03572000 BAL 14,SHONUM Print it @SC86133 03573000 B RTRN0 OK @SC87166 03574000 SHO8B LA 8,EBQC @SC87008 03575000 BAL 14,SHOCHRA Display ASCII char @SC87008 03576000 B SET8B @SC87166 03577000 SHOPRP LA 8,KPRPL Ptr to prompt @SC87268 03578000 LA 4,20 Max length @SC87268 03579000 BAL 14,SHOSTR @SC87268 03580000 B SETPRP Do any system-dependent setup @SC87351 03581000 SHOLIN LA 8,TRMLIN @SC87166 03582000 LA 9,L'TRMLIN @SC87166 03583000 BAL 14,SHOCHRN @SC87166 03584000 B SETLIN @SC87166 03585000 SHOTRM LA 4,SETTRKW @SC87166 03586000 LA 6,TRMTP @SC87166 03587000 BAL 14,SHOBRV Get full name from abbrev. @SC87166 03588000 NOP 0 @SC87166 03589000 SHOHND SR 4,4 @SC87274 03590000 IC 4,S1HND @SC87274 03591000 BAL 14,SHOCTL Print it @SC87274 03592000 B RTRN0 @SC87274 03593000 SHOPRTY LA 4,SETPAR @SC87166 03594000 BAL 14,SHOXY @SC86316 03595000 OI FL2,DAT8 @SC87166 03596000 SHOWARN BAL 14,SHOOO On or off @SC86133 03597000 OI FL1,REN @SC87166 03598000 SHOSYS BAL 14,SHOOO On or off @SC86295 03599000 OI FL2,PASS @SC87166 03600000 SHOTTB BAL 14,SHOOO On or off @SC87117 03601000 OI FL4,TTAB @SC87166 03602000 SHODLY L 4,LCLDLY @SC86164 03603000 BAL 14,SHONBIG Print it @SC86164 03604000 B RTRN0 @SC87166 03605000 SHOAPP BAL 14,SHOOO On or off @SC86203 03606000 OI FL3,APPN @SC87166 03607000 SHOINC LA 4,SETDSC List of possibles @SC87166 03608000 BAL 14,SHOXY @SC86225 03609000 OI FL5,KEEP @SC87166 03610000 SHOTST BAL 14,SHOOO @SC87166 03611000 OI FL1,TSTF Turn on @SC87166 03612000 * 03613000 KSHOPRC , System-specific options @SC86355 03614000 * 03615000 SHOFIL LA 4,SHOFILKW Ptr to sublist @SC87166 03616000 CLI SETXI,X'97' SET or SHOW **COMPAT** @SC87166 03617000 BNE *+8 SHOW **COMPAT** @SC87166 03618000 LA 4,SETFKW SET **COMPAT** @SC87166 03619000 BAL 14,SHOGRP @SC86295 03620000 SHOMRG LA 4,SHOMRGKW Ptr to sublist @SC87253 03621000 BAL 14,SHOGRP @SC87253 03622000 SHOFOR LA 4,SHOFORKW Ptr to sublist @SC87166 03623000 BAL 14,SHOGRP @SC86224 03624000 SHORETR LA 4,SHORETKW Ptr to sublist @SC87166 03625000 BAL 14,SHOGRP @SC86345 03626000 SHOTAK LA 4,SHOTAKKW Ptr to sublist @SC87166 03627000 BAL 14,SHOGRP @SC86224 03628000 SHORECV SR 5,5 Index for recv @SC86224 03629000 BAL 14,SHOGRPR @SC86224 03630000 SHOSEND LA 5,1 Index for send @SC86224 03631000 LA 14,SHOZZW @SC87166 03632000 SHOGRPR LA 4,SHORECKW Ptr to common sublist @SC87166 03633000 SHOGRP LR 2,14 Save return adr @SC87166 03634000 STM 1,4,SHOTMP Save top level ptr, return adr @SC87166 03635000 SETSCN LR 2,14 Copy return adr (again) @SC87166 03636000 TM SFLG,ALLF Doing all? @SC86295 03637000 BO SHORAL2 Yes @SC86133 03638000 NTOKN N=SHORALL @SC86133 03639000 LR 9,2 ??? @SC87166 03640000 SCAN (4),RTRN1 @SC87166 03641000 SHOHLP HELP (4),RTRN1 @SC87166 03642000 * 03643000 SHOFILKW KW 'TYPE',SHOFILT @SC86295 03644000 KW 'LRECL',SHOLR @SC86133 03645000 KFILKW @SC87166 03646000 KW , @SC87012 03647000 * 03648000 SHOMRGKW KW 'LEFT',SHOLFT @SC87253 03649000 KW 'RIGHT',SHORGT @SC87253 03650000 KW , @SC87253 03651000 * 03652000 SHORECKW KW 'END-OF-LINE',SHOEOL @SC86133 03653000 KW 'END-OF-PACKET',SHOEOL @SC86133 03654000 KW 'EOL',SHOEOL,MIN=3 @SC86133 03655000 SHOPSKW KW 'PACKET-SIZE',SHOSIZ @SC86133 03656000 KW 'PAD-CHAR',SHOPADC,MIN=5 @SC86164 03657000 KW 'PADDING',SHOPADN,MIN=3 @SC86164 03658000 KW 'QUOTE',SHOQUO @SC86133 03659000 KW 'START-OF-PACKET',SHOMARK @SC86133 03660000 KW 'TIMEOUT',SHOTIMO @SC86164 03661000 KW , @SC86133 03662000 * 03663000 SHOTAKKW KW 'ECHO',SHOECO,MIN=3 @SC86171 03664000 KW 'ERROR-ACTION',SHOHLT,MIN=3 @SC86171 03665000 KW , @SC86171 03666000 * 03667000 SHOFORKW KW 'PREFIX',SHOPFX @HF86223 03668000 KW 'SUFFIX',SHOSFX @HF86223 03669000 KW , @HF86223 03670000 * 03671000 SHORETKW KW 'INITIAL',SHORETI @SC86345 03672000 KW 'PACKETS',SHORETN @SC86345 03673000 KW , @SC86345 03674000 * 03675000 SHORALL OI SFLG,ALLF+ASRF Do just all send/recv items @SC86295 03676000 LA 14,SHOHLP Just help if SET @SC87166 03677000 SHORAL2 BAL 2,SHOKW Get ptr to kw send or receive @SC86133 03678000 BER 14 Help for SET @SC87166 03679000 L 15,SHOPTR Output line buffer ptr @SC86227 03680000 LA 1,CMD @SC86227 03681000 SR 15,1 Anything there? @SC86227 03682000 BNP SHORAL3 No @SC86227 03683000 ST 1,SHOPTR Yes, reset ptr @SC86227 03684000 WTEXT (1),(15) And write it out @SC86227 03685000 SHORAL3 DS 0H @SC86227 03686000 MVC CMD(2),=C' ' @SC86133 03687000 MVC CMD+2(7),0(6) Copy send or receive @SC86133 03688000 LA 0,CMD+2(7) Point past category @SC86316 03689000 ST 0,SHOPTR Save output ptr @SC86316 03690000 L 1,SHOTMP+12 Start at beginning @SC87166 03691000 ICM 14,7,0(1) Ptr to 1st routine @SC86171 03692000 BR 14 @SC86171 03693000 * 03694000 SETFT ICM 15,15,LEN SET F T ... **COMPAT** @SC87166 03695000 BNP SETFILET Nothing after: 'SET FILE-TYPE T' @SC87166 03696000 * 03697000 SHOFILT LA 4,SETFIL List of possibles @SC86151 03698000 LA 6,TYPFIL @SC87166 03699000 BAL 14,SHOBRV Get full name from abbrev. @SC87166 03700000 NOP 0 @SC87166 03701000 SHOLR SR 4,4 @SC86133 03702000 L 8,MAXLRC Upper limit @SC87166 03703000 ICM 4,3,LRECL @SC86133 03704000 BAL 14,SHONUM Print it @SC86133 03705000 B SETLR @SC87166 03706000 KFILSHO , @SC87012 03707000 B SHOGRPZ @SC86295 03708000 * 03709000 SHOLFT L 4,LMARG @SC87253 03710000 BAL 14,SHONBIG Print it @SC87253 03711000 B RTRN0 @SC87253 03712000 SHORGT L 4,RMARG @SC87253 03713000 BAL 14,SHONBIG Print it @SC87253 03714000 B RTRN0 @SC87253 03715000 B SHOGRPZ @SC87253 03716000 * 03717000 SHOECO BAL 14,SHOOO On or off @SC86171 03718000 OI FL2,ECHO @SC87166 03719000 SHOHLT LA 4,SETSWT List of possibles @SC87166 03720000 BAL 14,SHOXY @SC86171 03721000 OI FL5,TKHLT @SC87166 03722000 B SHOGRPZ @SC86171 03723000 * 03724000 SHOPFX LA 8,PREFIX Point to prefix @HF86223 03725000 LA 4,FORMAXL Max length @SC87268 03726000 BAL 14,SHOSTR Print message @SC86224 03727000 B RTRN0 @SC87268 03728000 SHOSFX LA 8,SUFFIX Point to suffix @HF86223 03729000 LA 4,FORMAXL Max length @SC87268 03730000 BAL 14,SHOSTR Print message @SC86224 03731000 B RTRN0 @SC87268 03732000 B SHOGRPZ @HF86223 03733000 * 03734000 SHORETI L 4,MAXTNT Initial retry limit @SC86345 03735000 BAL 14,SHONBIG Print it @SC87166 03736000 B RTRN0 @SC87166 03737000 SHORETN L 4,MAXTRY Normal retry limit @SC86345 03738000 BAL 14,SHONBIG Print it @SC87166 03739000 B RTRN0 @SC87166 03740000 B SHOGRPZ @SC86345 03741000 * 03742000 SHOEOL SR 4,4 @SC86133 03743000 IC 4,REOL(5) @SC86133 03744000 BAL 14,SHOCTL Print it @SC87166 03745000 B SETEOL @SC87166 03746000 LA 1,SHOPSKW Skip aliases @SC86133 03747000 SHOSIZ L 8,=A(KMAXE) Limit @SC87166 03748000 LR 3,5 @SC87166 03749000 SLA 3,2 Get fullword index @SC87166 03750000 L 4,RPSIZ(3) @SC87166 03751000 BAL 14,SHONUM Print number @SC86133 03752000 B SETSIZ @SC87166 03753000 SHOPADC SR 4,4 @SC86164 03754000 IC 4,RPADC(5) Pad character @SC86164 03755000 BAL 14,SHOCTL @SC87166 03756000 B SETPADC @SC87166 03757000 SHOPADN SR 4,4 @SC86164 03758000 LA 8,KMAX Same upper limit as packets @SC87166 03759000 IC 4,RPADN(5) Pad count @SC86164 03760000 BAL 14,SHONUM @SC86164 03761000 B SETPADN @SC87166 03762000 SHOQUO LA 8,RCTLQ(5) @SC86133 03763000 BAL 14,SHOCHRA Print as ascii @SC86133 03764000 B SETRCTLQ @SC87166 03765000 SHOMARK SR 4,4 @SC86133 03766000 IC 4,RMARK(5) @SC86133 03767000 BAL 14,SHOCTL @SC87166 03768000 B RTRN0 @SC87166 03769000 SHOTIMO SR 4,4 @SC86164 03770000 IC 4,RTIMO(5) Timeout limit @SC86164 03771000 BAL 14,SHONBIG @SC87166 03772000 B SETTIMO @SC87166 03773000 * 03774000 SHOGRPZ TM SFLG,ASRF Doing just receive/send? @SC86295 03775000 BO SHOZZW Yes, write last line @SC86227 03776000 LM 1,2,SHOTMP Get top level ptr, return adr @SC87166 03777000 LR 14,2 @SC86224 03778000 BAL 2,SHOKW Get ptr to name @SC86133 03779000 LA 1,0(7,6) Advance to next @SC86133 03780000 BR 14 @SC86224 03781000 * 03782000 SHOLIST LTR 5,5 Length of list @SC86355 03783000 BZ SHOZZ Empty, we're done @SC86355 03784000 LA 0,CMD+75 Set right margin @SC86355 03785000 MVI 0(15),C' ' Start with blank @SC86355 03786000 B *+8 @SC86355 03787000 SHOLSLP MVI 0(15),C',' Insert delimiter @SC86355 03788000 LA 15,1(15) @SC86355 03789000 CR 15,0 Any room? @SC86355 03790000 BL SHOLSED Yes, ok @SC86355 03791000 LA 1,CMD No, dump line @SC86355 03792000 SR 15,1 @SC86355 03793000 WTEXT (1),(15) @SC86355 03794000 MVI CMD,C' ' @SC86355 03795000 LA 15,CMD+1 Start indented @SC86355 03796000 LA 0,CMD+75 @SC86355 03797000 SHOLSED SR 4,4 @SC86355 03798000 IC 4,0(3) Get 1-byte item @SC86355 03799000 BAL 2,EDDEC Format it @SC86355 03800000 LA 3,1(3) Point to next item in list @SC86355 03801000 BCT 5,SHOLSLP @SC86355 03802000 B SHOZZ Finished list @SC86355 03803000 * 03804000 SHOKW MVC SETXI+1(3),1(14) Copy instr operands @SC87166 03805000 CLI SETXI,X'97' 'OI' if SET, but 'TM' if SHOW @SC87166 03806000 LA 6,5(1) Ptr to name @SC86133 03807000 LA 7,0 Preserve CC @SC86133 03808000 IC 7,3(1) Length (assumes high bytes clear) @SC86133 03809000 LA 7,1(7) @SC86133 03810000 BR 2 @SC86133 03811000 * 03812000 SHOCTL LA 8,ABL-1 Max control character (ASCII) @SC87166 03813000 TM FL1,TSTF @SC86295 03814000 BZ SHONUM @SC87166 03815000 SHONBIG L 8,=F'999999998' Almost anything @SC87166 03816000 SHONUM BAL 2,SHOKW @SC86133 03817000 BE SETNUM2 Get value for SET @SC87166 03818000 BAL 2,SHONAM Copy option name @SC86209 03819000 BAL 2,EDDEC Edit (R4) as decimal @SC86295 03820000 B SHOZZ @SC86133 03821000 * 03822000 SHOCHRA MVC TMP,0(8) Copy ascii char @SC86133 03823000 PTEXT SETCMDOO+5,3,AREG=8,LREG=9 @SC87008 03824000 TM TMP,X'60' Is it printable? @SC87008 03825000 BZ SHOCHRN No, say it's OFF @SC87008 03826000 TR TMP,ATOE Convert to ebcdic @SC86133 03827000 LA 8,TMP @SC86133 03828000 B SHOCHR @SC86224 03829000 SHOSTR BAL 2,SHOKW Get ptrs to name @SC87268 03830000 BE SETSTR Branch to dispatch for SET @SC87268 03831000 SR 9,9 Variable-length string @SC86224 03832000 IC 9,0(8) Get length @SC86224 03833000 LA 8,1(8) Ptr to text @SC86224 03834000 B SHOCHRD @SC87268 03835000 SHOCHR LA 9,1 Length is 1 @SC86224 03836000 SHOCHRN BAL 2,SHOKW Get ptrs to name @SC86224 03837000 BER 14 Branch to dispatch for SET @SC87166 03838000 SHOCHRD BAL 2,SHONAM Copy option name @SC87268 03839000 BAL 2,EDCHAR Append string at (R8) @SC87034 03840000 B SHOZZ Print message @SC87034 03841000 * 03842000 SHOBRV CLI SETXI,X'97' SET or SHOW? @SC87166 03843000 BE SETSCN @SC87166 03844000 LR 9,14 Save return adr @SC87166 03845000 LR 8,1 Save list ptr @SC87166 03846000 LR 1,4 Use list of suboptions @SC87166 03847000 SR 7,7 Assume 1-char abbrev @SC87166 03848000 ICM 7,8,* Indicate just search @SC87166 03849000 BAL 14,SCAN @SC87166 03850000 CR 0,0 These two skipped @SC87166 03851000 LR 4,1 if bad value @SC87166 03852000 LR 1,8 Retrieve ptrs @SC87166 03853000 LR 14,9 @SC87166 03854000 B SHOXY Display it @SC87166 03855000 * 03856000 SHOOO LA 4,SETOOKW Ptr to on/off @SC87166 03857000 SHOXY BAL 2,SHOKW Set up name @SC86133 03858000 BE SETSCN Parse value for SET @SC87166 03859000 LA 8,5(4) Value if off @SC86133 03860000 SR 9,9 @SC87166 03861000 IC 9,3(4) Length of name @SC86133 03862000 EX 0,SETXI Test bit @SC87166 03863000 BZ *+12 @SC86133 03864000 LA 8,6(9,8) Flag is on, advance @SC86133 03865000 IC 9,9(9,4) @SC86133 03866000 LA 9,1(9) @SC86133 03867000 SHOXL BAL 2,SHONAM Copy option name @SC86209 03868000 BAL 2,EDCHAR Append string at (R8) @SC86295 03869000 SR 15,9 Back up to string @SC87034 03870000 TR 0(30,15),LOCASE And make it lower case @SC87034 03871000 AR 15,9 Resume @SC87034 03872000 SHOZZ ST 15,SHOPTR Save end address @SC86227 03873000 LA 1,0(7,6) Advance to next @SC86345 03874000 LA 14,4(14) Skip over SET branch @SC87166 03875000 CLM 14,7,=AL3(SHOTABSZ) @SC86355 03876000 BER 14 Special treatment for tabs @SC86355 03877000 TM SFLG,ALLF Doing all? @SC86295 03878000 BOR 14 And resume if yes @SC86227 03879000 SHOZZW LA 1,CMD No, get address of buffer @SC86227 03880000 SR 15,1 Get length @SC86227 03881000 WTEXT (1),(15) Write it out @SC86227 03882000 B RTRN0 That's all @SC86295 03883000 * 03884000 SHONAM LA 15,CMD Output message buffer @SC86209 03885000 L 0,SHOPTR End of prev. msg @SC86227 03886000 CR 0,15 Empty? @SC86227 03887000 BE SHON1 Yes, start here @SC86227 03888000 LA 1,CMD+23 2nd column @SC86227 03889000 SR 1,0 Far enough? @SC86227 03890000 BP SHONF Yes, blank fill @SC86227 03891000 AH 1,=H'23' Try 3rd column @SC86227 03892000 BP SHONF OK @SC86227 03893000 SR 0,15 No room, dump line @SC86227 03894000 WTEXT (15),(0) @SC86227 03895000 LA 15,CMD And start over @SC86227 03896000 B SHON1 @SC86227 03897000 SHONF SR 15,15 @SC86295 03898000 ICM 15,8,BLANK @SC86295 03899000 MVCL 0,14 Fill with blanks to next column @SC86227 03900000 LR 15,0 New output ptr @SC86227 03901000 SHON1 MVC 0(40,15),0(6) Copy option name @SC87034 03902000 TR 1(39,15),LOCASE And beautify it @SC87034 03903000 AR 15,7 Space over it @SC86209 03904000 MVC 0(4,15),=C' is ' @SC87034 03905000 LA 15,4(15) Space over 'is' @SC86209 03906000 BR 2 @SC86209 03907000 * 03908000 LOCALS , @SC86295 03909000 SHOTMP DS 4F @SC87166 03910000 SHOPTR DS A More temporaries @SC86227 03911000 SETXI DS F XI executable instr @SC86273 03912000 SFLG DS X Local flags @SC86295 03913000 ALLF EQU X'80' Doing SHOW ALL @SC86295 03914000 ASRF EQU X'40' Doing SHOW REC or SHOW SEND @SC86295 03915000 SHOW EXIT 03916000 TITLE 'STATUS Routine - display latest error, etc.' @SC86295 03917000 * Exit: R15=0. ERRNUM unchanged. 03918000 STATUS ENTER @SC86156 03919000 CLI ERRNUM,ERRNFT Actual error? @BS86090 03920000 BNH STAMSG No @BS86090 03921000 CLI ERRNUM,ERRKCE Last command invalid? @SC86295 03922000 BE STAMSG Yes, do not show last file @HF86232 03923000 CLI FILNAM,0 File name defined? @BS86090 03924000 BE STAMSG No @BS86090 03925000 MVC CMD(16),=CL16'Last file used:' @BS86090 03926000 LA 7,CMD+16 Fill in name @BS86090 03927000 LA 1,FILNAM @SC86295 03928000 BAL 2,STAFSP Copy name and print @SC86295 03929000 STAMSG ICM 4,15,NSENT Number of files sent @SC86295 03930000 BZ STASNTZ @SC86295 03931000 LA 15,CMD Start of message buffer @SC86295 03932000 BAL 2,EDDEC Format number as decimal @SC86295 03933000 LA 0,17(15) Tentative end of message @SC86295 03934000 MVC 0(17,15),=C' files sent last.' @SC86295 03935000 BCT 4,STAPLR @SC86295 03936000 MVC 5(11,15),6(15) Only one file, make singular @SC86295 03937000 BCTR 0,0 @SC86295 03938000 STAPLR BAL 2,STAPMSG Show message @SC86295 03939000 STASNTZ ICM 0,15,PAKCNT Any transfer statistics? @SC86295 03940000 BZ STADATR No, skip it @SC86316 03941000 ICM 6,7,=C'pkt' @SC86295 03942000 BAL 3,STADPR Format msg @SC86295 03943000 ICM 0,15,SECTOT Any duration? @SC86295 03944000 BZ STADATR No, must have been very short @SC86316 03945000 ICM 6,7,=C'sec' @SC86295 03946000 BAL 3,STADPR Format msg @SC86295 03947000 MVC CMD(16),=C'Disk bytes/sec: ' @SC86295 03948000 LA 15,CMD+16 @SC86295 03949000 L 0,SECTOT @SC86295 03950000 LM 4,5,DSKTOT @SC86295 03951000 BAL 2,STAVB Format ratio @SC86295 03952000 BAL 2,STAPM15 Print line @SC86295 03953000 STADATR ICM 4,15,RTRCNT Any retries? @SC86316 03954000 BZ STADATZ No @SC86316 03955000 LA 15,CMD Yes, issue message @SC86316 03956000 BAL 2,EDDEC @SC86316 03957000 MVC 0(20,15),=C' repeat packets sent' @SC86316 03958000 LA 15,20(15) @SC86316 03959000 BAL 2,STAPM15 Print line @SC86316 03960000 L 1,SECTOT @SC86345 03961000 BAL 9,OPTPKT Get best packet size @SC86345 03962000 LTR 4,15 Valid? @SC86345 03963000 BNP STADATZ No, skip it @SC86345 03964000 MVC CMD(23),=C'Optimumum packet size: ' @SC86345 03965000 LA 15,CMD+23 @SC86345 03966000 BAL 2,EDDEC Format it @SC86345 03967000 BAL 2,STAPM15 @SC86345 03968000 STADATZ ICM 4,15,RECTRC Any truncated records? @SC87268 03969000 BZ STATRCZ No, ok @SC87268 03970000 LA 15,CMD Yes, issue message @SC87268 03971000 BAL 2,EDDEC @SC87268 03972000 MVC 0(18,15),=C' records truncated' @SC87268 03973000 LA 15,18(15) @SC87268 03974000 BAL 2,STAPM15 @SC87268 03975000 STATRCZ DS 0H @SC87268 03976000 SR 5,5 @SC86156 03977000 IC 5,ERRNUM Get offset into error table @SC86156 03978000 SLL 5,2 Get fullword index @SC86156 03979000 A 5,AERRTAB Pointer address @SC86156 03980000 L 1,0(5) Msg ptr @SC86156 03981000 SR 0,0 @SC86268 03982000 SLDL 0,8 Msg length @SC86316 03983000 SRL 1,8 Realign adr @SC86316 03984000 WTEXT (1),(0) Print message @SC86268 03985000 CLI ERRNUM,ERRTRC Cancelled? @SC86316 03986000 BNE STACKAB No @SC86316 03987000 SR 1,1 @SC86316 03988000 CLI REASON,15 Within table? @SC86316 03989000 BH *+8 No, must be new @SC86316 03990000 IC 1,REASON Ok, get the complaint code @SC86316 03991000 SLL 1,3 Index into table @SC86316 03992000 LA 1,STACNTB(1) @SC86316 03993000 LA 0,8 Length of items @SC86316 03994000 WTEXT (1),(0) @SC86316 03995000 STACKAB CLI ERRNUM,ERRABO Micro aborted? @BS86090 03996000 BE *+12 Yes @SC87338 03997000 CLI ERRNUM,ERRDIE No, disk I/O error? @SC87338 03998000 BNE STARET No @BS86090 03999000 ICM 0,15,EMSGL Yes, any message? @SC86268 04000000 BZ STARET No @BS86090 04001000 L 1,EMSGP @BS86090 04002000 WTEXT (1),(0) Yes, show it @SC86268 04003000 STARET RET @SC86295 04004000 * 04005000 STADPR MVC CMD(13),=C'Bytes/pkt: S=' @SC86295 04006000 LA 15,CMD+13 @SC86295 04007000 STCM 6,7,CMD+6 @SC86295 04008000 LM 4,5,TOUTOT @SC86295 04009000 BAL 2,STAVB Format ratio @SC86295 04010000 MVC 0(3,15),=C' R=' @SC86295 04011000 LA 15,3(15) @SC86295 04012000 LM 4,5,TINTOT @SC86295 04013000 BAL 2,STAVB Format ratio @SC86295 04014000 MVC 0(11,15),=C' requiring ' @SC86295 04015000 LA 15,11(15) @SC86295 04016000 LR 4,0 @SC86295 04017000 BAL 2,EDDEC Format number of units @SC86295 04018000 MVI 0(15),C' ' @SC86295 04019000 STCM 6,7,1(15) @SC86295 04020000 LA 0,4(15) End of msg @SC86295 04021000 BAL 2,STAPMSG Print it @SC86295 04022000 BR 3 @SC86295 04023000 * 04024000 STAVB DR 4,0 Get ratio @SC86295 04025000 AR 4,4 @SC86295 04026000 CR 4,0 @SC86295 04027000 BL *+8 @SC86295 04028000 A 5,F1 Round up @SC86295 04029000 LR 4,5 @SC86295 04030000 B EDDEC Format it @SC86295 04031000 * 04032000 * Table of reasons for rejecting Attribute packet @SC86316 04033000 STACNTB DC C'-Unknown-Length -Type -Date ' @SC86316 04034000 DC C'-Creator-Account-Area -Passwrd' @SC86316 04035000 DC C'-Blksize-Access -Coding -Disp ' @SC86316 04036000 DC C'-Protect-Protect-Origin -Format ' @SC86316 04037000 TITLE 'DUMP Routine - print translation table' 04038000 * Display current values in STORAG. 04039000 * Entry: SCANPTR string has option 04040000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 04041000 DUMP ENTER ALT @SC86156 04042000 NTOKN N=DUMPH A or E? @SC86156 04043000 SCAN DUMPKW,RTRN1 @SC86295 04044000 DUMPH HELP DUMPKW,RTRN1 @SC86295 04045000 * 04046000 DUMPKW KW 'ATOE',DUMPA @SC86156 04047000 KW 'ETOA',DUMPE @SC86156 04048000 KW 'NAMES',DMPN @SC86295 04049000 KW 'TATOE',DUMPTA,MIN=2 @SC87117 04050000 KW 'TETOA',DUMPTE,MIN=2 @SC87117 04051000 KW , @SC86156 04052000 * 04053000 DMPN L 5,TSENT Table ptr @SC86295 04054000 ICM 6,15,NSENT Number of files sent @SC86295 04055000 BNZ DMPNL @SC86295 04056000 WTEXT 'No files sent' @SC86295 04057000 B RTRN0 @SC86295 04058000 DMPNL LA 7,CMD Start of message buffer @SC86295 04059000 LR 1,5 @SC86295 04060000 BAL 2,STAFSP Show filespec @SC86295 04061000 LA 5,LFID(5) Advance ptr to next @SC86295 04062000 BCT 6,DMPNL @SC86295 04063000 B RTRN0 @SC86295 04064000 * 04065000 DUMPA LA 3,ATOE @SC86156 04066000 B DUMPAE @SC86156 04067000 DUMPE LA 3,ETOA @SC86156 04068000 B DUMPAE @SC87117 04069000 DUMPTA LA 3,TATOE @SC87117 04070000 B DUMPAE @SC87117 04071000 DUMPTE LA 3,TETOA @SC87117 04072000 DUMPAE LA 4,4 Bytes per word @SC86156 04073000 LA 5,15(3) End of 1st line @SC86156 04074000 LA 6,16 Bytes per line @SC86156 04075000 LA 7,256(3) 2 before end of table @SC86156 04076000 DUMPLL LA 2,CMD Output buffer @SC86156 04077000 DUMPLW UNPK 0(9,2),0(5,3) Convert a word @SC86156 04078000 TR 0(8,2),TRHEX Hex notation @SC86156 04079000 MVI 8(2),C' ' Leave a space between words @SC86156 04080000 LA 2,9(2) @SC86156 04081000 BXLE 3,4,DUMPLW Do next word @SC86156 04082000 LA 1,CMD Done line of 4 @SC86156 04083000 LA 0,35 @SC86268 04084000 WTEXT (1),(0) Print it @SC86268 04085000 BXLE 5,6,DUMPLL Done line, go to next @SC86156 04086000 B RTRN0 04087000 TITLE 'GIVTAB Routine - save translation table' 04088000 * Save current values in STORAG into a TAKE file on disk 04089000 * Entry: SCANPTR string has option 04090000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 04091000 GIVTAB ENTER ALT @SC87117 04092000 NTOKN N=GIVH A or E? @SC87117 04093000 SCAN GIVKW,RTRN1 @SC87117 04094000 GIVH HELP GIVKW,RTRN1 @SC87117 04095000 * 04096000 GIVKW KW 'ATOE',GIVA @SC87117 04097000 KW 'ETOA',GIVE @SC87117 04098000 KW 'TATOE',GIVTA,MIN=2 @SC87117 04099000 KW 'TETOA',GIVTE,MIN=2 @SC87117 04100000 KW , @SC87117 04101000 * 04102000 GIVA LA 6,ATOE-1 @SC87117 04103000 B GIVA1 @SC87117 04104000 GIVE LA 6,ETOA-1 @SC87117 04105000 B GIVE1 @SC87117 04106000 GIVTA LA 6,TATOE-1 @SC87117 04107000 GIVA1 LA 0,ATOED @SC87117 04108000 B GIVAE @SC87117 04109000 GIVTE LA 6,TETOA-1 @SC87117 04110000 GIVE1 LA 0,ETOAD @SC87117 04111000 GIVAE SR 15,15 @SC87117 04112000 IC 15,3(1) Get length of name @SC87117 04113000 MVC GIVBUF(4),=C'SET ' @SC87117 04114000 MVC GIVBUF+4(10),5(1) Copy name to command @SC87117 04115000 LA 15,GIVBUF+5(15) @SC87117 04116000 MVI 0(15),C' ' @SC87117 04117000 LA 15,1(15) Get ptr for 1st argument @SC87117 04118000 LR 1,0 @SC87117 04119000 BCTR 0,0 Back up to start at "difference" @SC87117 04120000 STM 15,1,GIVSV Save ptrs: cmd, table, table start@SC87117 04121000 LA 7,257 Table length + 1 @SC87117 04122000 LA 0,FFGIV @SC87117 04123000 KCALL FSPEC,FILNAM,E=GIVFNE Error @SC87117 04124000 MVI ERRNUM,ERRNOE Ok now @SC87117 04125000 OPENF O,FILNAM,LOGFDB,GIVPTR,E=GIVOPERR @SC87117 04126000 GIVLP LM 15,0,GIVSV Get output ptr, table scan ptr @SC87117 04127000 LA 6,1(6) Skip last difference @SC87117 04128000 AH 0,*-2 @SC87117 04129000 BCTR 7,0 New length left @SC87117 04130000 LR 1,7 Copy length @SC87117 04131000 CLCL 0,6 Find next difference @SC87117 04132000 BE GIVFIN All done @SC87117 04133000 ST 0,GIVSV+4 Save new ptr @SC87117 04134000 LR 4,0 Get offset @SC87117 04135000 S 4,GIVSV+8 @SC87117 04136000 BAL 2,EDDEC Write as decimal @SC87117 04137000 MVI 0(15),C' ' Leave space @SC87117 04138000 LA 15,1(15) @SC87117 04139000 IC 4,0(6) Get tailored character @SC87117 04140000 BAL 2,EDDEC Write as decimal @SC87117 04141000 LA 2,GIVBUF @SC87117 04142000 SR 15,2 Length of line @SC87117 04143000 WRITF GIVPTR,BUFFER=(2),BSIZE=(15),E=GIVWRERR @SC87117 04144000 B GIVLP @SC87117 04145000 GIVWRERR CLOSF GIVPTR Close output file @SC87117 04146000 GIVOPERR PTEXT 'Unable to write file' @SC87117 04147000 GIVFNE WTEXT (3),(4) Show message @SC87117 04148000 B RTRN1 @SC87117 04149000 GIVFIN CLOSF GIVPTR,E=GIVOPERR Close output file @SC87117 04150000 B RTRN0 @SC86295 04151000 LOCALS , @SC86295 04152000 GIVSV DS 3F Saved ptrs for saving table @SC87117 04153000 GIVPTR DS A Ticket for disk I/O @SC87117 04154000 GIVBUF DS CL25 Buffer for new file @SC87117 04155000 EXIT @SC86164 04156000 TITLE 'GENCMD Routine - send a Generic command' @SC86155 04157000 * Entry: SCANPTR has string 04158000 * Exit: R15=0 if ok, 1 if help needed, 2 if bad parameter 04159000 * ERRNUM set appropriately 04160000 GENCMD ENTER @SC86155 04161000 LA 8,1 One operand @SC86295 04162000 LTR 1,1 @SC86295 04163000 BZ REMCMD Parse REMOTE command @SC86295 04164000 LA 0,AG Packet type = generic command @SC86155 04165000 GENNUL SR 5,5 NO ARGUMENTS @SC86316 04166000 GENFILL STC 0,STYPE Set packet type @SC86155 04167000 L 3,RBUF Put string here @SC86155 04168000 CLI STYPE,AG Generic? @SC86155 04169000 BNE GENOTH1 No subcommand @SC86155 04170000 STC 1,0(3) Save subcommand byte @SC86155 04171000 LA 3,1(3) Move to next character position @SC86155 04172000 B GENOTH1 @SC86295 04173000 GENNXT NTOKN N=RTRN1 Get next argument @SC86295 04174000 LA 5,1(7) Length @SC86295 04175000 LR 4,6 Address @SC86295 04176000 GENOTH1 LTR 1,5 Any argument? @SC86155 04177000 BZ GENFILZ No, done @SC86155 04178000 CLI STYPE,AG Generic? @SC86155 04179000 BNE GENOTH2 No, skip length indicator @SC86155 04180000 TOCHR 1,,0(3) Yes, do it @SC86155 04181000 LA 3,1(3) @SC86155 04182000 GENOTH2 MVC 0(96,3),0(4) Copy argument @SC86155 04183000 TR 0(96,3),ETOA in ASCII @SC86155 04184000 AR 3,5 Advance ptr @SC86155 04185000 BCT 8,GENNXT @SC86295 04186000 GENFILZ S 3,RBUF Length of buffer @SC86155 04187000 ST 3,RBUFL Set buffer size @SC86155 04188000 BAL 8,IPKSET Set state table, exchange parms @SC86155 04189000 DC AL1(AY),AL3(0) ACK'ed Must be just @SC86155 04190000 DC AL1(00),AL3(GENABR) Error. these 2 items. @SC86155 04191000 BAL 8,GENSET Set state table @SC86155 04192000 * Server cmd Rpack interpret input table @SC86155 04193000 DC AL1(AY),AL3(0) ACK'ed @SC86155 04194000 DC AL1(AS),AL3(GENRPL) Long reply @SC86155 04195000 DC AL1(00),AL3(GENABR) Error @SC86155 04196000 GENSET BAL 9,ENCODEN Encode command @SC86295 04197000 BAL 9,INPUTSPK Send, get response @SC86295 04198000 MVI ERRNUM,ERRNOE No errors @SC86155 04199000 ICM 0,15,DATL Any short reply? @SC86155 04200000 BZ GENRET No, done @SC86155 04201000 NI FL1,255-EOF Yes, set flags @SC86155 04202000 XC WBUFL,WBUFL Clear old data @SC86155 04203000 OI LOGFLGS,APPN DISP=MOD @SC86295 04204000 BAL 2,GENRPS Set up file name @SC86295 04205000 OPENF O,REPNAM,LOGFDB,FILPTR,E=GENABR @SC86295 04206000 USING FDBD,1 @SC86295 04207000 SR 0,0 @SC86295 04208000 ICM 0,3,FDBLRC @SC86295 04209000 ST 0,FSIZE Copy LRECL @SC86295 04210000 MVC FRECF,FDBRCF Copy RECFM @SC86295 04211000 DROP 1 @SC86155 04212000 GENOPN KCALL DECODE,E=GENAB2 Copy message to output @SC86155 04213000 CLC WBUFL,F0 Any more? @SC86155 04214000 BE GENRPZ @SC86155 04215000 KCALL OUTBUF,E=GENAB2 Yes, copy that as well @SC86155 04216000 GENRPZ CLOSF FILPTR @SC86295 04217000 MVI ERRNUM,ERRNOE No errors @SC86155 04218000 B GENFIN @SC86295 04219000 * 04220000 GENRPL OI FL2,SRV Pretend this is server mode @SC86155 04221000 BAL 2,GENRPS Set up file name @SC86295 04222000 KCALL RECEIV @SC86155 04223000 NI FL2,255-SRV @SC86155 04224000 B GENFIN @SC86155 04225000 * 04226000 GENRPS LA 0,L'REPNAM Name string length @SC86295 04227000 LA 1,REPNAM and address @SC86295 04228000 STM 0,1,SCANPTR @SC86295 04229000 LA 0,FFRCF @SC86295 04230000 KCALL FSPEC,FILNAM Convert to filespec @SC86295 04231000 IC 9,FL3 Save flags @SC86295 04232000 OI FL3,APPN Don't erase it @SC86295 04233000 BR 2 @SC86295 04234000 * 04235000 GENAB2 CLOSF FILPTR @SC86295 04236000 GENABR KCALL ERPACK @SC86155 04237000 GENFIN STC 9,FL3 Restore flags @SC86295 04238000 GENRET KCALL INTINI,0 @SC86155 04239000 B RTRN0 @SC86295 04240000 * 04241000 * Make foreign Kermit execute command 04242000 REMCMD NTOKN N=RTRN2 @SC86295 04243000 SCAN REMCMDKW,RTRN1 @SC86295 04244000 B RTRN2 @SC86295 04245000 * 04246000 REMCMDKW KW 'COPY',REMCOP,MIN=2 @SC86295 04247000 KW 'CWD',REMARG,MIN=3 @SC86295 04248000 KW 'DIRECTORY',REMARG,MIN=3 @SC86155 04249000 KW 'ERASE',REMARG @SC86155 04250000 KW 'HELP',REMARG @SC86155 04251000 KW 'HOST',REMHST,MIN=2 @SC86155 04252000 KW 'KERMIT',REMKRM @SC86155 04253000 KW 'RENAME',REMREN @SC86295 04254000 KW 'SPACE',REMSPA,MIN=2 @SC86155 04255000 KW 'TYPE',REMARG,MIN=2 @SC86155 04256000 KW , @SC86155 04257000 * 04258000 REMHST LA 0,AC Host command @SC86155 04259000 B REMPRS @SC86155 04260000 * 04261000 REMKRM LA 0,AK KERMIT command @SC86155 04262000 REMPRS FTOKN N=RTRN1 See if anything given @SC86295 04263000 LR 4,7 @SC86295 04264000 LR 5,6 Use whole string @SC86295 04265000 B GENFILL @SC86295 04266000 * 04267000 REMSPA LA 1,AU Space command @SC86155 04268000 B REMPRSG @SC86155 04269000 * 04270000 REMCOP LA 8,2 Copy: two files @SC86295 04271000 LA 1,AK @SC86295 04272000 B REMPRSG @SC86295 04273000 REMREN LA 8,2 Rename: two files @SC86295 04274000 * 04275000 REMARG SR 1,1 @SC86155 04276000 IC 1,0(6) 1st letter is abbrev @SC86155 04277000 IC 1,ETOA(1) ASCII @SC86155 04278000 REMPRSG LA 0,AG (generic) @SC86155 04279000 NTOKN N=GENNUL Skip any blanks @SC86295 04280000 LA 5,1(7) Save length @SC86295 04281000 LR 4,6 Save ptr @SC86295 04282000 B GENFILL Copy to output @SC86155 04283000 LOCALS , @SC86295 04284000 REMCMD EXIT , @SC86155 04285000