*COPY IKCUTL 05000000 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., filemode letter 05002000 * Entry: SCANPTR string has option 05003000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05005000 * CMS filespec parts @SC86295 05006000 FN EQU FILNAM,8 @SC86295 05007000 FT EQU FN+8,8 @SC86295 05008000 FM EQU FT+8,2 @SC86295 05009000 * 05010000 IFN EQU IFILE,8 @SC86295 05011000 IFT EQU IFN+8,8 @SC86295 05012000 IFM EQU IFT+8,2 @SC86295 05013000 * 05014000 JFN EQU JFNAM,8 Foreign FN for SEND @SC86295 05015000 JFT EQU JFN+8,8 Foreign FT for SEND @SC86295 05016000 * 05017000 NTOKN N=CWDERR,H=CWDERR @SC86164 05018000 LTR 7,7 Length of token @SC86164 05019000 BNZ CWDERR >1 @SC86164 05020000 TR 0(1,6),UPCASE @SC87034 05021000 MVC IFM(1),0(6) Copy mode letter @SC86164 05022000 NXTFSET IFILE,CWD,E=CWDERR @SC86295 05023000 MVC DEST(1),IFM Save new mode @SC86316 05024000 B RTRN0 @SC86295 05025000 CWDERR PTEXT 'Must be valid CMS mode letter' @SC86295 05026000 B SUBERR @SC86295 05027000 * 05028000 * DSPACE Routine - display available disk space @SC86164 05029000 * 05030000 * Show space in 'working directory' or other minidisk 05031000 * Entry: SCANPTR string has option (none => working directory) 05032000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05033000 DSPACE ENTER ALT @SC86164 05034000 MVC QDISK+16(1),DEST Default filemode @SC86164 05035000 NTOKN N=DSPACEX @SC86164 05036000 TR 0(1,6),UPCASE @SC87034 05037000 MVC QDISK+16(1),0(6) @SC86164 05038000 DSPACEX HOST QDISK,E=RTRN1 @SC86295 05039000 B RTRN0 @SC86295 05040000 LOCALS , @SC86295 05041000 EXIT , @SC86295 05042000 TITLE 'FSPEC Routine - extract filespec from scan string' 05043000 * 05044000 * Entry: R1->name field, R0=flags selecting operation (see below) 05045000 * For parse operations, SCANPTR defines the input string. 05046000 * For getting foreign or display filespec, R7->output buffer 05047000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05048000 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05049000 * 05050000 * Flags: Notes: 05051000 * Tasks: FFRCF FFSND FFGET FFNEW 05052000 * Parse RECV X set ROVR properly 05053000 * Parse SEND 1st X 05054000 * Parse SEND 2nd X X 05055000 * Parse GET 1st X X 05056000 * Parse GET 2nd X set ROVR properly 05057000 * Parse F-packet (FFHDR) X X X 05058000 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05059000 * Parse TAKE 05060000 * 05061000 * Get unique name X R15: 0=>ok, 1=>bad 05062000 * Interactive name check X X R15: 0=>ok, 1=>bad 05063000 * Get foreign name (FFENC) X X R15->end of string 05064000 * Get display form (FFDSP) X X R15->end of string 05065000 * 05066000 FSPEC ENTER @SC86295 05067000 STC 0,FSPFLG @SC86295 05068000 LR 0,1 Copy ptr to filespec @SC86295 05069000 TM FSPFLG,FFNEW @SC86295 05070000 BO FSPWRN @SC86295 05071000 XC 0(18,1),0(1) Clear filespec @SC86295 05072000 MVC FSPBAD(16),=C'Invalid filename' @SC86295 05073000 PTEXT FSPBAD,16 Standard msg form @SC86295 05074000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05075000 MVC 16(2,1),DEST Default FM @SC86295 05076000 TM FSPFLG,FFHDR @SC86295 05077000 BO FSPHD @SC86295 05078000 TM FSPFLG,FFUTL @SC86295 05079000 BNO FSPTR @SC86295 05080000 TM FSPFLG,FFWLD Utility: default to all files? @SC86295 05081000 BZ FSPASC No @SC86295 05082000 MVC 0(8,1),ASTER Yes @SC86295 05083000 MVC 8(8,1),ASTER @SC86295 05084000 FSPASC TM FL2,SRV Server mode? @SC86295 05085000 BZ FSPCPY No, don't need to convert @SC86295 05086000 ICM 15,15,LEN Get length @SC86295 05087000 BZ FSPCPY @SC86295 05088000 BCTR 15,0 Correct for EX @SC86158 05089000 L 1,ADR Get string ptr @SC86295 05090000 EX 15,TRATOE Change to EBCDIC @SC86158 05091000 MVI UPCASE+C'.',C' ' @SC86158 05092000 EX 15,TRUPCAS Upcase and dot to space @SC86158 05093000 MVI UPCASE+C'.',C'.' @SC86158 05094000 B FSPCPY @SC86295 05095000 FSPTR TM FSPFLG,FFRCF @SC86295 05096000 BZ FSPTS @SC86295 05097000 TM FSPFLG,FFSND+FFGET @SC86295 05098000 BNZ FSPSN2 Foreign filespec for SEND or GET @SC86295 05099000 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05100000 NI FL4,255-NMOK Collision not checked yet @SC87012 05101000 MVI 0(1),C'$' Default FN @SC86295 05102000 MVC UFM,DEST Default FM, can change by = = x @SC86295 05103000 B FSPCPY @SC86295 05104000 FSPHD MVC 0(8,1),=CL8'$' Default fn @SC86295 05105000 MVC 8(8,1),0(1) Default ft @SC86295 05106000 MVC 16(2,1),UFM Default fm @SC86295 05107000 L 2,ADR @SC86295 05108000 TR 0(256,2),FSPTAB Make valid fn chars @SC86295 05109000 B FSPCPY @SC86295 05110000 FSPTS TM FSPFLG,FFSND @SC86295 05111000 BZ FSPTG @SC86295 05112000 TM FL5,SALL @SC86295 05113000 BZ *+10 @SC86295 05114000 MVC 16(2,1),ASTER Default FM for SEND @SC86295 05115000 B FSPASC @SC86295 05116000 FSPSN2 MVI 1(1),C'=' Foreign file name is same @SC86295 05117000 MVI 9(1),C'=' @SC86295 05118000 CTOKN H=FSP2H,N=RTRN0 @SC86295 05119000 LA 1,L'JFNAM @SC86295 05120000 CLM 7,3,*-2 Does it fit? @SC86224 05121000 BNH *+6 Yes @SC86224 05122000 LR 7,1 Use what we can @SC86224 05123000 LR 3,0 @SC86295 05124000 STC 7,0(3) Save length @SC86224 05125000 LA 0,1(3) @SC86295 05126000 MVCL 0,6 Get fn, at least @SC86224 05127000 MVI TRTBL+C'.',2 See if valid CMS token @SC86224 05128000 MVI TRTBL+C'/',2 @SC86224 05129000 SR 2,2 @SC86224 05130000 TRT 1(9,3),TRTBL @SC86295 05131000 MVI TRTBL+C'.',0 @SC86224 05132000 MVI TRTBL+C'/',0 @SC86224 05133000 BCT 2,RTRN0 Not valid: must be complex string @SC86224 05134000 MVC FSPPTR,SCANPTR @SC86295 05135000 LA 2,3 @SC86295 05136000 FSPCNT NTOKN N=FSPCNZ @SC86295 05137000 BCT 2,FSPCNT @SC86295 05138000 FSPCNZ MVC SCANPTR,FSPPTR Restore ptrs @SC86295 05139000 N 2,F1 @SC86295 05140000 BNZ RTRN0 Single token string @SC86295 05141000 LA 0,9(3) Get 2nd token @SC86295 05142000 MVI 0(3),0 Clear length again @SC86295 05143000 MVC FSPBADX,=C'type' @SC86295 05144000 CTOKN H=FSP2H,N=FSPMIS @SC86295 05145000 MVCL 0,6 @SC86295 05146000 B RTRN0 @SC86295 05147000 FSPTG TM FSPFLG,FFGET @SC86295 05148000 BO FSPRC @SC86295 05149000 TM FSPFLG,FFGIV GIVE command? @SC87117 05150000 BO *+10 Yes, keep specific FM @SC87117 05151000 MVC 16(2,1),ASTER Default FM for TAKE @SC86295 05152000 MVC 8(8,1),=CL8'TAKE' @SC86295 05153000 FSPCPY CTOKN H=FSPH,N=FSPZ @SC86295 05154000 TM FSPFLG,FFRCF @SC86295 05155000 BZ FSPCPN @SC86295 05156000 CLI 0(6),C'=' @SC86224 05157000 BE FSPREQ Go if RECEIVE = ... @SC86295 05158000 CLI 0(6),C'*' @SC86224 05159000 BE FSPINV @SC86295 05160000 FSPCPN BAL 14,FSPTOK Get fn @SC87034 05161000 MVC FSPBADX,=C'type' @SC86295 05162000 CTOKN H=FSPH,N=FSPZ @SC86295 05163000 CLI 0(6),C'=' @SC86224 05164000 BE FSPINV Go if RECEIVE xxx = @SC86295 05165000 TM FSPFLG,FFRCF @SC86295 05166000 BZ FSPCPT @SC86295 05167000 CLI 0(6),C'*' @SC86224 05168000 BE FSPINV Go if RECEIVE xxx * @SC86295 05169000 OI FL1,ROVR Overwrite received fname @SC86295 05170000 FSPCPT BAL 14,FSPTOK Get ft @SC87034 05171000 TM FSPFLG,FFHDR Getting name from packet? @SC86295 05172000 BO RTRN0 Yes, done @SC86295 05173000 MVC FSPBADX,=C'mode' @SC86295 05174000 CTOKN H=FSPH,N=FSPZ @SC86295 05175000 TM FSPFLG,FFRCF @SC86295 05176000 BZ FSPCPM @SC86295 05177000 CLI 0(6),C'*' @SC86224 05178000 BE FSPINV @SC86295 05179000 FSPCPM LA 1,L'FM @SC86224 05180000 BAL 14,FSPTOK Get fm @SC87034 05181000 B RTRN0 @SC86295 05182000 * 05183000 FSPREQ MVC FSPBADX,=C'type' @SC86295 05184000 CTOKN H=FSPH,N=FSPZ Pick ft for RECEIVE = @SC86295 05185000 CLI 0(6),C'=' @SC86224 05186000 BNE FSPINV Go if FT is not = @SC86295 05187000 CLI 0(6),C'*' @SC86224 05188000 BE FSPINV Bad FM @SC86295 05189000 MVC FSPBADX,=C'mode' @SC86295 05190000 CTOKN H=FSPH,N=FSPZ Pick fm for RECEIVE = = @SC86295 05191000 LA 1,L'FM @SC86224 05192000 BAL 14,FSPTOK Use FM they specified @SC87034 05193000 MVC UFM,0(1) Use for all of file group @SC87034 05194000 B RTRN0 @SC87034 05195000 * 05196000 FSPTOK LR 8,0 Save start @SC87034 05197000 LR 9,1 And length @SC87034 05198000 MVCL 0,6 Copy token with padding @SC87034 05199000 LR 1,8 @SC87034 05200000 BCTR 9,0 Fix for TR @SC87034 05201000 EX 9,TRUPCAS Upcase the token @SC87034 05202000 BR 14 @SC87034 05203000 * 05204000 FSPZ LR 14,0 @SC86295 05205000 CLI 0(14),C' ' Any default given? @SC86295 05206000 BH RTRN0 Yes, use it @SC86295 05207000 FSPMIS MVC FSPBAD,=C'Missing' @SC86295 05208000 FSPINV LA 15,2 @SC86295 05209000 B FSPPTRS @SC86295 05210000 * 05211000 FSPH PTEXT 'Filespec has format: fn ft [fm]' @SC86295 05212000 B FSP0H @SC86295 05213000 FSP2H PTEXT 'Enter foreign filespec' @SC86295 05214000 FSP0H LA 15,1 @SC86295 05215000 FSPPTRS L 14,4(13) @SC86295 05216000 STM 3,4,32(14) Return msg ptrs @SC86295 05217000 FSPRET RET , @SC86295 05218000 * 05219000 * Non-parsing functions . . . 05220000 * 05221000 * Get unique filespec 05222000 FSPWRN LR 4,1 Save name ptr @SC86295 05223000 TM FSPFLG,FFENC @SC86295 05224000 BO FSPENC Encode name into buffer @SC86295 05225000 TM FSPFLG,FFDSP @SC86295 05226000 BO FSPDSP Copy name into buffer for display @SC86295 05227000 TM FL4,NMOK Already checked? @SC87012 05228000 BO RTRN0 Yes, ok @SC87012 05229000 LA 6,8+6(1) End of FT @BS86001 05230000 BCTR 6,0 @BS86001 05231000 CLI 0(6),C' ' Find end of token @BS86001 05232000 BE *-6 @BS86001 05233000 LA 5,10+1 Allowed retries @BS86001 05234000 LA 7,C'0' Extra character @BS86001 05235000 OI FL4,NMOK Assume it checks @SC87012 05236000 FSPSTA OPENF T,(4),E=RTRN0 Does it exist already? @SC86135 05237000 MVI 1(6),C'$' Yes, modify FT @BS86001 05238000 STC 7,2(6) Serialize @BS86001 05239000 LA 7,1(7) Bump counter @BS86001 05240000 BCT 5,FSPSTA @BS86001 05241000 B RTRN1 Failed @SC86295 05242000 * 05243000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05244000 * substitution from JFSPEC, but disable subsequent subst. 05245000 * Return updated ptr in R15 05246000 FSPENC LA 1,JFSPEC Complex string? @SC86224 05247000 LA 5,JFNAM Remote file-spec @SC86155 05248000 BAL 14,PAKFOR @SC86224 05249000 BNZ FSPFILS Yes, tokens aren't used @SC86224 05250000 BAL 14,FSPFID Filename @HF86223 05251000 LA 7,1(7) Skip over period @HF86223 05252000 BAL 14,FSPFID Filetype @HF86223 05253000 FSPFILS MVI JFSPEC,0 Turn off string @SC86224 05254000 CLI JFN,C'=' Partial renaming? @SC86224 05255000 BE FSPENR Yes, keep it @SC86224 05256000 CLI JFT,C'=' @SC86224 05257000 BE FSPENR @SC86224 05258000 MVI JFN,C'=' Now use original name @SC86171 05259000 MVI JFT,C'=' @SC86171 05260000 FSPENR LR 15,7 Save ptr @SC86295 05261000 B FSPRET @SC86295 05262000 * 05263000 * Copy name at (R1) into (R7) buffer in display form 05264000 * Return updated ptr in R15 05265000 FSPDSP BAL 14,FSPDTK Filename @SC86295 05266000 BAL 14,FSPDTK Filetype @SC86295 05267000 MVC 0(2,7),0(4) Filemode @SC86295 05268000 LA 7,2(7) @SC86295 05269000 B FSPENR @SC86295 05270000 * 05271000 * Subroutine to detokenize a list into ASCII @SC86135 05272000 FSPFID MVC 0(8,7),0(4) Copy token @SC86135 05273000 CLI 0(5),C'=' Keep true name? @SC86171 05274000 BE *+10 Yes @SC86171 05275000 MVC 0(8,7),0(5) No, use override @SC86171 05276000 LA 1,8(7) End of token if no blanks @SC86135 05277000 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05278000 TR 0(8,7),ETOA Ascii it @SC86135 05279000 LR 7,1 New end of string @SC86135 05280000 LA 4,8(4) Next token @SC86135 05281000 LA 5,8(5) @SC86171 05282000 MVI 0(7),ADOT Add an ASCII dot, just in case @SC86135 05283000 BR 14 @SC86135 05284000 * 05285000 * Subroutine to detokenize a list in EBCDIC @SC86295 05286000 FSPDTK MVC 0(8,7),0(4) Copy token @SC86135 05287000 LA 1,8(7) End of token if no blanks @SC86135 05288000 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05289000 MVI 0(1),C' ' Add a BLANK @SC86295 05290000 LA 7,1(1) New end of string @SC86135 05291000 LA 4,8(4) Next token @SC86135 05292000 BR 14 @SC86135 05293000 * 05294000 * Subroutine to set up CMS token for copying @SC86224 05295000 CMSTOK8 LA 7,1(7) @SC86224 05296000 ICM 7,8,BLANK @SC86224 05297000 LA 1,8 @SC86224 05298000 BR 14 @SC86224 05299000 * 05300000 * Valid CMS file name characters @SC86295 05301000 FSPTAB DC 64C'_',C' ' space @SC86295 05302000 DC 10C'_',C' ' dot @SC86295 05303000 DC 02C'_',C'+' plus @SC86295 05304000 DC 12C'_',C'$' dollar sign @SC86295 05305000 DC 04C'_',C'-' dash @SC86295 05306000 DC 12C'_',C'_' underscore @SC86295 05307000 DC 12C'_',C':#@' colon, pound sign, at sign@SC86295 05308000 DC 04C'_',C'ABCDEFGHI' a-i @SC86295 05309000 DC 07C'_',C'JKLMNOPQR' j-r @SC86295 05310000 DC 08C'_',C'STUVWXYZ' s-z @SC86295 05311000 DC 23C'_',C'ABCDEFGHI' A-I @SC86295 05312000 DC 07C'_',C'JKLMNOPQR' J-R @SC86295 05313000 DC 08C'_',C'STUVWXYZ' S-Z @SC86295 05314000 DC 06C'_',C'0123456789' 0-9 @SC86295 05315000 DC 06C'_' @SC86295 05316000 LOCALS , @SC86295 05317000 FSPBAD DS C'Invalid',C' file' @SC86295 05318000 FSPBADX DS C'name' @SC86295 05319000 FSPPTR DS XL8 Saved scan ptrs @SC86295 05320000 FSPFLG DS X Filespec flags @SC86295 05321000 FSPEC EXIT @SC86295 05322000 TITLE 'KHELP routine - perform HELP command' 05323000 * Handle HELP command, rest of string given by SCANPTR. 05324000 KHELP ENTER , @SC86355 05325000 * CMS version ignores any extra operands on HELP command @SC86355 05326000 L 2,ORGR1 Ptr to original command @SC86355 05327000 CLI 0(2),C'*' Was it a START? @SC86355 05328000 BE KHLDF Yes, use default @SC86355 05329000 CLI 0(2),X'FF' Nothing at all? @SC86355 05330000 BNE KHLI Something, use it @SC87007 05331000 KHLDF LA 2,=CL8'KERMIT' @SC86355 05332000 KHLI LA 1,CMD Command buffer @SC87007 05333000 MVC 0(5,1),=CL5'HELP' @SC86355 05334000 MVC 5(30,1),0(2) Copy operand @SC86355 05335000 LA 0,5+8 Length of command @SC86355 05336000 STM 0,1,SCANPTR Set up for system @SC86355 05337000 OI FL4,UCMD @SC86355 05338000 KCALL SUPFNC,3 Do it @SC86355 05339000 RET , @SC86355 05340000 LOCALS , 05341000 KHELP EXIT , @SC87007 05342000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05343000 SUPFNC ENTER @SC86295 05344000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05345000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05346000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-9) 05347000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05348000 * 2 -> Clean up afterwards and stop interception 05349000 * 3 -> Execute host command with or without interception 05350000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05351000 * 4 -> Execute CP command with or without interception 05352000 * R0->text, R6=len 05353000 * 5 -> Stop interception if going 05354000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05355000 * 7 -> Test for stacked lines, return number in R15 05356000 * 8 -> Log off (doesn't return!) 05357000 * 9 -> Wait specified time 05358000 * 10-> Return clock time in R15 (centisec) 05359000 * 11-> Seup up new prompt string at (R0) 05360000 BCT 1,ICPFIN @SC86158 05361000 * Start interception, initialize ptrs @SC86158 05362000 MVI ERRNUM,ERRNOE OK @SC86158 05363000 LA 0,2048 Suitable offset @SC86158 05364000 A 0,WBUF Output buffer @SC86158 05365000 L 1,TSENT Limit @SC86158 05366000 LR 15,0 @SC86158 05367000 STM 15,0,TXTPTR Save @SC86158 05368000 STM 0,1,SVCOPTR @SC86158 05369000 SR 1,0 Get length @SC86158 05370000 L 15,=X'15000000' @SC86158 05371000 MVCL 0,14 Fill with NL (X'15') @SC86158 05372000 CLC SVCNPSW,SVCSNAG Already set up? @SC86158 05373000 BE RTRN0 Yes, but how? @SC86295 05374000 MVC SAVENPSW,SVCNPSW @SC86158 05375000 MVC TYPSAV,ADMSCWR @SC86283 05376000 DMSKEY NUCLEUS @SC86283 05377000 MVC SVCNPSW,SVCSNAG Set up interception (SVC) @SC86283 05378000 MVC ADMSCWR,=A(ICPTYP) (BALR) @SC86283 05379000 DMSKEY RESET @SC86283 05380000 B RTRN0 @SC86295 05381000 * Clean up after interception @SC86295 05382000 ICPFIN BCT 1,ICPHST @SC86158 05383000 L 5,SVCOPTR End of text @SC86158 05384000 ST 5,TXTPTR+4 Save @SC86158 05385000 B ICPRST1 Now restore interrupts @SC86295 05386000 * Restore SVC interrupt vector @SC86158 05387000 ICPRST BCT 1,SFCLIN @SC86295 05388000 ICPRST1 CLC SVCNPSW,SVCSNAG @SC86295 05389000 BNE RTRN0 OK @SC86295 05390000 DMSKEY NUCLEUS @SC86283 05391000 MVC SVCNPSW,SAVENPSW @SC86283 05392000 MVC ADMSCWR,TYPSAV @SC86283 05393000 DMSKEY RESET @SC86283 05394000 B RTRN0 05395000 * Avoid user-area CMS commands, otherwise execute command at @SC86158 05396000 * (R0) already tokenized. Save return code. @SC86158 05397000 ICPHST BCT 1,ICPCP @SC86158 05398000 TM FL4,UCMD User CMS command? @SC86295 05399000 BZ ICPCMS0 No, already tokenized @SC86295 05400000 LM 0,1,SCANPTR @SC86295 05401000 LTR 15,0 @SC87034 05402000 BNP ICPCMIL Nothing there @SC87034 05403000 BCTR 15,0 Get length for TR @SC87034 05404000 EX 15,TRUPCAS Convert to upper case @SC87034 05405000 DMSKEY NUCLEUS Enter Key 0 @SC86295 05406000 L 15,ASCANN @SC86295 05407000 BALR 14,15 Tokenize data @SC86295 05408000 LR 0,15 @SC86295 05409000 DMSKEY RESET Restore user key @SC86295 05410000 LTR 15,0 Did SCANN fail? @SC86295 05411000 BNZ ICPCMIL Yes @SC86295 05412000 LR 0,1 @SC86295 05413000 ICPCMS0 LR 3,0 @SC86295 05414000 CLC =C'CP ',0(3) CP command? @SC86158 05415000 BE ICPCMSCP Yes, do it @SC86158 05416000 MVC IFT,=CL8'EXEC' @SC86158 05417000 MVC IFM,ASTER Search all disks @SC86158 05418000 TM OPTFLAGS,NOIMPEX EXEC's allowed? @SC86158 05419000 BO ICPCMSM No, try for module @SC86158 05420000 TM FL4,UCMD User CMS command? @SC86158 05421000 BZ ICPCMSM No, avoid EXEC's @SC86158 05422000 ICPCMSA MVC IFN,0(3) @SC86158 05423000 LA 4,1 @SC86158 05424000 ICPCMSS NXTFSET IFILE @SC86295 05425000 NXTF E=ICPABBR Get name @SC86295 05426000 LR 5,1 @SC86295 05427000 USING FDBD,5 @SC86295 05428000 TM FDBFLGS,WFN Any wild chars? @SC86295 05429000 BO ICPCMIL Yes, illegal @SC86158 05430000 DMSEXS MVC,0(8,3),IFN Found, copy full name @SC86158 05431000 CLI IFT,C'E' EXEC? @SC86158 05432000 BNE ICPCMSU No, module. Check it @SC86158 05433000 S 3,F8 Back up to EXEC in COMBUF @SC86158 05434000 B ICPCMSX Do it @SC86158 05435000 ICPABBR LTR 4,4 Already tried abbrev? @SC86158 05436000 BZ ICPCMSM Yes, give up @SC86158 05437000 TM OPTFLAGS,NOABBREV Allowed? @SC86158 05438000 BO ICPCMSM No, just do it @SC86158 05439000 DMSKEY NUCLEUS @SC86158 05440000 LM 0,1,0(3) Get name entered @SC86158 05441000 L 15,AABBREV Look up abbreviation @SC86158 05442000 BALR 14,15 @SC86158 05443000 LR 4,15 Save RC @SC86158 05444000 DMSKEY RESET Return to normal @SC86158 05445000 LTR 4,4 Did we find one? @SC86158 05446000 BNZ ICPCMSM No, give up @SC86158 05447000 STM 0,1,IFN Yes, try it @SC86158 05448000 B ICPCMSS Now R4=0, don't loop @SC86158 05449000 ICPCMSM CLI IFT,C'M' @SC86158 05450000 BE ICPCMSX Already looked @SC86158 05451000 MVC IFT,=CL8'MODULE' @SC86158 05452000 B ICPCMSA Start over again @SC86158 05453000 ICPCMSU CLI FDBRCF,C'F' System-key transient? @SC86295 05454000 DROP 5 @SC86295 05455000 BE ICPCMSX OK, no problem @SC86158 05456000 MVC IFM,FM Get right mode letter @SC86158 05457000 LA 2,CMD Buffer for 1st record of module @SC86295 05458000 MVC 4(4,2),=A(KERMIT) In case of failure @SC86295 05459000 MVC IFSCB+8(18),IFILE @SC86295 05460000 FSREAD FSCB=IFSCB,BUFFER=(2) Get header record @SC86295 05461000 FSCLOSE FSCB=IFSCB @SC86158 05462000 CLC =A(KERMIT),CMD+4 Check beginning adr @SC86158 05463000 BNH ICPCMIL User-area, forbid it @SC86158 05464000 ICPCMSX HOST 0(3),E=*+4 Accept errors @SC86158 05465000 LTR 6,15 Save return code @SC86295 05466000 BNM SFCRC @SC86295 05467000 TM OPTFLAGS,NOIMPCP @SC86295 05468000 BO ICPCMIL No implied CP commands @SC86295 05469000 TM FL4,UCMD User command? @SC86295 05470000 BO ICPCMSCP Yes, maybe it's for CP @SC86295 05471000 ICPCMIL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05472000 B RTRNM1 @SC86295 05473000 ICPCMP CLC 1(,4),0(3) Partial token matching @SC86158 05474000 IFSCB FSCB 'X X',BSIZE=80,RECNO=1,RECFM=V @SC86158 05475000 * Execute CP command sent to CMS (assumed SCANN'ed) @SC86158 05476000 ICPCMSCP L 0,NUCPLCMD Get cmd ptr @SC86158 05477000 L 6,NUCPLEND @SC86158 05478000 SR 6,0 Get length @SC86158 05479000 LA 1,1 Simulate normal entry @SC86158 05480000 * Execute CP command at (R0) with text interception @SC86158 05481000 ICPCP BCT 1,ICPRST @SC86158 05482000 LR 1,0 Copy ptr for upcasing @SC87034 05483000 LTR 4,6 @SC87034 05484000 BNP ICPCMIL Nothing there @SC87034 05485000 BCTR 4,0 @SC87034 05486000 EX 4,TRUPCAS @SC87034 05487000 CLC SVCNPSW,SVCSNAG @SC86283 05488000 BNE ICPCDG Not intercepting, just do it @SC86283 05489000 KCALL SETMSG,3 Restore CP settings @SC86158 05490000 LM 1,2,SVCOPTR Response buffer @SC86158 05491000 SR 2,1 Get buffer length @SC86158 05492000 L 7,=F'8192' Max length from CP @SC86158 05493000 CR 7,2 Do we have that much? @SC86158 05494000 BNH *+6 @SC86158 05495000 LR 7,2 Use what we have @SC86158 05496000 LR 2,7 Remember @SC86158 05497000 ICM 6,8,BLANK @SC86158 05498000 DIAG 0,6,8 Issue command @SC86158 05499000 BZ *+6 @SC86158 05500000 LR 7,2 Not likely: filled buffer @SC86158 05501000 A 7,SVCOPTR @SC86158 05502000 BCTR 7,0 Scan back over any extra X'15' @SC86158 05503000 CLI 0(7),X'15' @SC86158 05504000 BE *-6 @SC86158 05505000 LA 7,2(7) Keep one X'15' @SC86158 05506000 C 7,SVCOPTR+4 Be careful of end @SC86158 05507000 BNH *+8 OK @SC86158 05508000 L 7,SVCOPTR+4 Got past it somehow @SC86158 05509000 ST 7,SVCOPTR @SC86158 05510000 KCALL SETMSG,2 Change CP settings again @SC86158 05511000 B ICPRC @SC86295 05512000 * 05513000 ICPCDG DIAG 0,6,8 Issue command @SC86283 05514000 ICPRC C 6,F1 Illegal command? @SC86295 05515000 BE ICPCMIL Yes @SC86295 05516000 * Issue return code msg if needed @SC86295 05517000 SFCRC LTR 4,6 Check RC @SC86295 05518000 BZ SFCZRC RC=0 @SC86158 05519000 TM FL4,UCMD User cmd? @SC86316 05520000 BZ SFCZRC No, don't issue message @SC86316 05521000 MVC CMD(2),=C'R(' Set up message @SC86209 05522000 LA 15,CMD+2 @SC86209 05523000 BAL 2,EDDEC Edit RC into msg @SC86295 05524000 MVI 0(15),C')' Format is R(rc) @SC86209 05525000 LA 0,1(15) @SC86268 05526000 LA 1,CMD Start of edited string @SC86209 05527000 SR 0,1 Length @SC86268 05528000 WTEXT (1),(0) @SC86268 05529000 SFCZRC LR 15,6 @SC86295 05530000 MVI ERRNUM,ERRNOE No errors @SC86295 05531000 B RTRN @SC86295 05532000 * 05533000 SFCLIN BCT 1,SFCSTK @SC86295 05534000 * Retrieve original command line arguments, if any @SC86295 05535000 * Return code =0 if yes, =1 if no @SC86295 05536000 * Leave string in CBUF buffer (up to 256), length in CLEN @SC86295 05537000 LM 5,6,ORGR0 Original R0,R1 @SC87253 05538000 CLI 0(6),255 @SC86171 05539000 BE RTRN1 Go if, e.g., just 'START' @SC86171 05540000 LA 6,8(6) Ok, point to arguments @SC86171 05541000 CLI 0(6),255 @SC86171 05542000 BE RTRN1 Go if nothing on cmd 05543000 L 3,CBUF A safe data area 05544000 CLI ORGR1,1 @SC87253 05545000 BL SFCCMDK R1 hi order byte is 0 05546000 CLI ORGR1,11 @SC87253 05547000 BH SFCCMDK R1 hi order byte is > X'0B' 05548000 L 6,4(5) Address of arguments @SC87253 05549000 MVC 0(256,3),0(6) Copy this, instead 05550000 S 6,8(5) End address of command @SC87253 05551000 LPR 3,6 Make it positive @SC86295 05552000 B SFCCMDS @SC86295 05553000 * 05554000 SFCCMDK MVC 0(8,3),0(6) Copy token 05555000 LA 1,8(3) Char after token @SC86295 05556000 TRT 0(8,3),TRTBL Find blank @SC86295 05557000 MVI 0(1),C' ' Add a blank, in case @SC86295 05558000 LA 3,1(1) Skip over blank @SC86295 05559000 LA 6,8(6) Skip a CMS token 05560000 CLI 0(6),255 05561000 BNE SFCCMDK Loop if not end 05562000 S 3,CBUF Length = current pos - beginning 05563000 SFCCMDS C 3,F256 Is it too long? 05564000 BNH *+8 No, OK length 05565000 L 3,F256 Truncate past CMD length 05566000 ST 3,CLEN Save command length 05567000 B RTRN0 @SC86295 05568000 * 05569000 * Test for stacked commands @SC86295 05570000 * return code = number of stacked lines @SC86295 05571000 SFCSTK BCT 1,SFCKIL @SC86295 05572000 LH 15,NUMFINRD Pending lines @SC86295 05573000 A 15,NUCNLSTK Lines in program stack @SC86295 05574000 B RTRN @SC86295 05575000 * 05576000 * Log out @SC86295 05577000 SFCKIL BCT 1,SFCWT @SC86295 05578000 CPCMD 1,0,'LOGOFF' @SC86295 05579000 * 05580000 * Wait specified time in R0 (sec) 05581000 SFCWT BCT 1,SFCCLK @SC86295 05582000 LINEDIT TEXT='SL ..... SEC',DOT=NO,DISP=CPCOMM, +05583000 SUB=(DEC,(0)) @SC86184 05584000 B RTRN0 @SC86295 05585000 * 05586000 * Return time in centisec in R15 05587000 SFCCLK BCT 1,SFCPRP @SC87351 05588000 STCK TMPDW Store TOD clock @SC86295 05589000 LM 14,15,TMPDW @SC86295 05590000 SLDL 14,8 Take mod 204 days @SC86295 05591000 SRDL 14,20 Get in microsec @SC86295 05592000 D 14,=F'10000' Get in centisec @SC86295 05593000 B RTRN @SC86295 05594000 * 05595000 SFCPRP B RTRN0 No action for prompting @SC87351 05596000 TITLE 'SVC interceptor, executed in system protect key' 05597000 USING ICPTYP,15 @SC86283 05598000 ICPTYP STM 12,14,SVCSV1 Save regs @SC86283 05599000 L 13,SVCSNAG+4 Addressability @SC86283 05600000 DROP 15 05601000 USING SVCEXIT,13 @SC86283 05602000 B ICPTGO Grab it @SC86283 05603000 SVCEXIT STM 12,13,0 Save regs @SC86158 05604000 BALR 13,0 Addressability @SC86158 05605000 USING *,13 @SC86158 05606000 L 13,SVCSNAG+4 Addressability @SC86283 05607000 USING SVCEXIT,13 @SC86283 05608000 ICM 13,8,SVCEXIT Flag for SVC entry @SC86283 05609000 MVC SVCSV1(8),0 @SC86158 05610000 STM 14,15,SVCSV2 @SC86158 05611000 L 12,AFVS @SC86158 05612000 USING FVSECT,12 @SC86158 05613000 TM UFDBUSY,ABNBIT ABEND in progress? @SC86158 05614000 BO SVCCNCL @SC86158 05615000 CLI SVCOPSW+3,13 ABEND? @SC86158 05616000 BE SVCCNCL @SC86158 05617000 CLI SVCOPSW+3,203 @SC86158 05618000 BE SVC203T Could be DMSABN @SC86158 05619000 CLI SVCOPSW+3,202 @SC86158 05620000 BNE SVCGO Ok, do it @SC86158 05621000 CLC =CL8'TYPLIN',0(1) WRTERM? @SC86158 05622000 BNE SVCGO No, do it @SC86158 05623000 ICPTGO LM 14,15,SVCOPTR Output ptrs @SC86158 05624000 SR 15,14 Length left @SC86158 05625000 LA 12,255 Limit @SC86158 05626000 CH 12,14(1) Buffer length @SC86295 05627000 BNH *+8 Too big @SC86158 05628000 LH 12,14(1) Ok, use it @SC86295 05629000 LTR 12,12 @SC86158 05630000 BNP ICPTRET @SC86283 05631000 CR 12,15 Enough room? @SC86283 05632000 BH ICPTRET No @SC86283 05633000 ICM 15,7,9(1) Buffer address @SC86295 05634000 BCTR 12,0 Set up for mvc @SC86158 05635000 EX 12,SVCCOPY Move to WBUF @SC86158 05636000 LA 14,2(12,14) New end @SC86158 05637000 ST 14,SVCOPTR @SC86158 05638000 ICPTRET SR 15,15 Success @SC86283 05639000 CLM 13,8,SVCEXIT Was it an SVC? @SC86283 05640000 BE SVCDONE Yes @SC86283 05641000 LM 12,14,SVCSV1 Restore regs @SC86283 05642000 BR 14 Return @SC86283 05643000 SVCDONE L 12,SVCOPSW+4 Return adr @SC86158 05644000 CLI 0(12),0 Error adr given? @SC86158 05645000 BNE SVCRET @SC86158 05646000 LA 14,4(12) Yes, skip over @SC86158 05647000 SVCSKP STCM 14,7,SVCOPSW+5 @SC86158 05648000 SVCRET LM 12,14,SVCSV1 Restore @SC86158 05649000 SR 15,15 'success' @SC86158 05650000 LPSW SVCOPSW Return @SC86158 05651000 SVCCOPY MVC 0(,14),0(15) @SC86158 05652000 * 05653000 SVC203T L 12,SVCOPSW+4 Code ptr @SC86158 05654000 SVCABNT CLI 1(12),11 DMSABN? @SC86158 05655000 BNE SVCGO No, do it @SC86158 05656000 SVCCNCL MVC SVCNPSW,SAVENPSW Cancel interception @SC86158 05657000 MVC ADMSCWR,TYPSAV @SC86283 05658000 SVCGO MVC 0(8,0),SAVENPSW Proper SVC handler @SC86158 05659000 LM 12,15,SVCSV1 @SC86158 05660000 LPSW 0 @SC86158 05661000 * Storage for SVC interception @SC86158 05662000 SAVENPSW DS D SYSTEM SVC NPSW @SC86158 05663000 SVCSNAG DC A(0,SVCEXIT) My replacement @SC86158 05664000 SVCSV1 DS 2F Saved 12,13 @SC86158 05665000 SVCSV2 DS 2F Saved 14,15 @SC86158 05666000 SVCOPTR DS 2F Buffer output and end ptrs @SC86158 05667000 TYPSAV DS F Saved system address @SC86283 05668000 LOCALS , @SC86295 05669000 SUPFNC EXIT @SC86158 05670000 TITLE 'TERMIO Routine - Handle terminal I/O' 05671000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05672000 * successfull, R15 returns transferred byte count (else returns -1). 05673000 * Command code is in R0: 05674000 * 1 => Open line for I/O 4 => Write packet 05675000 * 2 => Close line 5 => Read packet 05676000 * 3 => Reset line status after ( 6 => Write message ) not used 05677000 * environment changes 05678000 * 05679000 TERMIO ENTER 05680000 SR 15,15 OK @SC86295 05681000 BCT 0,TRMCLS @SC86295 05682000 * Open terminal line for protocol 05683000 WAITT 05684000 STAX BR14 Ingore attention interrupts 05685000 MVI RIOC,X'80' Nothing saved @SC86295 05686000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05687000 B TRMSPRP @SC87275 05688000 * Close terminal line after protocol transfer 05689000 TRMCLS BCT 0,TRMRSET @SC86295 05690000 STAX 05691000 B RTRN0 @SC86295 05692000 * (Re)set terminal characteristics to suit environment 05693000 TRMRSET BCT 0,TRMRW @SC86295 05694000 B RTRN0 @SC86295 05695000 * 05696000 * Perform I/O request 05697000 TRMRW BCT 0,TRMRD @SC87275 05698000 CLI WRRD,0 Write/read? @SC87275 05699000 BE TRMWO No, do it immediately @SC87275 05700000 MVC RIOPRP(8),0(1) Yes, save stuff for prompt @SC87275 05701000 B RTRN0 @SC87275 05702000 TRMWO MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05703000 B TRMEX Do the write @SC87275 05704000 TRMRD TS TRMFLG @SC87275 05705000 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05706000 * 05707000 TRMEX SLA 0,4 @SC87275 05708000 LA 8,TRMPLS @SC87275 05709000 AR 8,0 Get appropriate CCW skeleton @SC86295 05710000 MVC 9(3,8),1(1) Copy adr @SC86295 05711000 MVC 14(2,8),6(1) Copy len @SC86295 05712000 HOST 0(8) Issue command @SC86295 05713000 LH 15,14(8) Number of chars xfer'd @SC86295 05714000 TRMSPRP LA 0,S1EOL Reinstate "normal" prompt @SC87275 05715000 LA 1,2 @SC87275 05716000 CLI S1HND,0 Handshake desired? @SC87275 05717000 BNE *+6 Yes, ok @SC87275 05718000 BCTR 1,0 No, send just the EOL @SC87275 05719000 STM 0,1,RIOPRP @SC87275 05720000 RET @SC86295 05721000 * 05722000 TRMPLS DS 0F Terminal I/O plists @SC86295 05723000 * WRTERM Plist during Kermit protocol 05724000 DC CL8'TYPLIN' 05725000 DC X'01',AL3(*-*) Send buffer address @SC86190 05726000 DC C'B',X'92' B=Black,02=No xlate,90=Long @TB86218 05727000 DC H'0' Buffer length 05728000 * RDTERM plist during RPACK 05729000 DC CL8'WAITRD' 05730000 DC X'01',AL3(*-*) Rcv buffer addr @SC86190 05731000 DC C'*',C'B' *:long, B:prompt/direct @SC87201 05732000 DC AL2(0) Input data length 05733000 RIOPRP DC A(0,1) Prompt @SC87275 05734000 LOCALS , @SC86295 05735000 EXIT 05736000 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05737000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05738000 * successfull, R15 returns transferred byte count (else returns -1). 05739000 * Command code is in R0: 05740000 * 1 => Open screen for I/O 4 => Write packet 05741000 * 2 => Close screen 5 => Read packet 05742000 * 3 => Reset screen status after 6 => Write message 05743000 * environment changes 05744000 * 05745000 * CCW Flags, WCC flag bits, CSW flags: 05746000 CC EQU X'40' Command chaining @SC86159 05747000 SLI EQU X'20' Suppress Incorr Len Ind 05748000 ATN EQU X'80' Attention 05749000 CE EQU X'08' Channel end 05750000 DE EQU X'04' Device end 05751000 UC EQU X'02' Unit check 05752000 UE EQU X'01' Unit exception 05753000 CPBRK EQU ATN+CE+DE+UC CP break-in 05754000 * 05755000 SCRNIO ENTER 05756000 BCT 0,SCRCLS @SC86295 05757000 XC CONSCSW(8),CONSCSW Clear any previous data @SC86135 05758000 WAITT , Make CMS happy 05759000 HOST HNDINTPL Issue HNDINT @SC86295 05760000 LA 8,SCRCCWCL Clear screen now @SC86295 05761000 BAL 9,SCRNEX @SC86295 05762000 MVI RIOC,X'80' Nothing saved @SC86295 05763000 ICM 0,15,LCLDLY @SC87268 05764000 BZ RTRN0 Skip extra delay @SC87268 05765000 CPCMD 6,7,'SL 1 SEC' This seems useful @HF86233 05766000 B RTRN0 @SC86295 05767000 SCRCLS BCT 0,SCRRSET @SC86295 05768000 LA 8,SCRCCWVM Release screen @SC86295 05769000 BAL 9,SCRNEX @SC86295 05770000 HNDINT CLR,(CON1) 05771000 LA 5,=C'READY ...' Make sure hanging writes appear @SC86159 05772000 MVC 6(3,5),CONSADH Use console vaddr @SC86159 05773000 LA 7,9 String length @SC86159 05774000 CPCMD 5,7,RESP=YES Suppress reply @SC86159 05775000 B RTRN0 @SC86295 05776000 * (Re)set device characteristics to suit environment 05777000 SCRRSET BCT 0,SCRRW @SC86295 05778000 B RTRN0 05779000 * 05780000 * Perform I/O request 05781000 SCRRW SLA 0,3 @SC86295 05782000 LA 8,SCRCCWS-8 @SC86295 05783000 AR 8,0 Get appropriate CCW skeleton @SC86295 05784000 MVC 1(3,8),1(1) Copy adr @SC86295 05785000 MVC 6(2,8),6(1) Copy len @SC86295 05786000 BAL 9,SCRNEX Execute internal subr @SC86295 05787000 C 8,=A(SCRWCCW+8) Write or Read? @SC87286 05788000 BE SCRLOG Read: log the AID @SC87286 05789000 BH RTRN No, just return @SC87286 05790000 CLI TRMTP,C'G' @SC87215 05791000 BE RTRN No interrupt if graphics @SC87215 05792000 * Wait for attention interrupt 05793000 SCRWLP CLI CONSUNIT,ATN @SC86295 05794000 BE RTRN Read if last int was an ATTN @SC86295 05795000 LR 9,15 Save byte count @SC86295 05796000 WAITD CON1 Wait for ATTN intrpt 05797000 LR 15,9 @SC86295 05798000 B SCRWLP @SC86295 05799000 * 05800000 SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05801000 BZ RTRN No, that's all @SC87286 05802000 L 2,LOGBUF Ptr to buffer @SC87286 05803000 MVI 0(2),C'A' Set label @SC87286 05804000 L 3,0(8) Ptr to AID @SC87286 05805000 MVC 2(3,2),0(3) Copy into buffer @SC87286 05806000 LR 9,15 Save data length @SC87286 05807000 WRITF LOGPTR,BSIZE=5 Log it @SC87286 05808000 LR 15,9 Return data length @SC87286 05809000 B RTRN @SC87286 05810000 * 05811000 SCRNEX LR 1,8 Get CCW ptr @SC86295 05812000 LA 4,1 Allow retry @SC86159 05813000 LH 2,CONSADDR Console address 05814000 TIO 0(2) See if usable 05815000 BC 6,*-4 Loop if busy or CSW stored 05816000 BC 1,SCRERR not operational: error 05817000 SCRDIAG DIAG 1,2,X'0058' Start I/O via diagnose @SC86159 05818000 BNZ SCRERR Error 05819000 SCRWAIT WAITD CON1 Wait for I/O to complete 05820000 CLI CONSCHAN,0 05821000 BNE SCRERR Go if ch error 05822000 CLI CONSUNIT,CE 05823000 BE SCRWAIT Wait if just a ch end 05824000 CLI CONSUNIT,CPBRK 05825000 BE SCRBRK Possible error if CP broke in @SC86159 05826000 LH 15,6(8) Buffer size @SC86295 05827000 LH 1,CONSBYTC Residual count @SC86295 05828000 LTR 1,1 @SC86295 05829000 BZ *+8 0 => was a write @SC86295 05830000 LA 1,3(1) Deduct 3 for buffer adr @SC86295 05831000 SR 15,1 Bytes read @SC86295 05832000 CLI CONSUNIT,DE 05833000 BER 9 Go if dev end @SC86295 05834000 CLI CONSUNIT,CE+DE 05835000 BER 9 Go if chan and dev end @SC86295 05836000 CLI CONSUNIT,ATN 05837000 BER 9 Go if attn @SC86295 05838000 SCRERR SR 15,15 @SC86295 05839000 BCTR 15,0 Return error code of -1 @SC86295 05840000 BR 9 @SC86295 05841000 SCRBRK BCT 4,SCRERR Quit after one retry @SC86159 05842000 LA 5,=C'RESET ...' @SC86159 05843000 MVC 6(3,5),CONSADH Use console vaddr @SC86159 05844000 LA 7,9 String length @SC86159 05845000 CPCMD 5,7,RESP=YES Suppress reply @SC86159 05846000 LA 6,RTRYIO @SC86159 05847000 DIAG 6,2,X'0058' Take the screen back @SC86159 05848000 BNZ SCRERR @SC86159 05849000 SCRTWT WAITD CON1 Wait for I/O to complete @SC86159 05850000 CLI CONSCHAN,0 @SC86159 05851000 BNE SCRERR Go if ch error @SC86159 05852000 CLI CONSUNIT,CE @SC86159 05853000 BE SCRTWT Wait if just a ch end @SC86159 05854000 LR 1,8 Retrieve R1 @SC86159 05855000 B SCRDIAG Try again @SC86159 05856000 DS 0D 05857000 SCRCCWCL DC X'19',AL3(0),AL1(SLI),X'FF',AL2(1) 05858000 SCRCCWVM DC X'19',AL3(0),AL1(SLI),X'FE',AL2(1) 05859000 * 05860000 SCRCCWS DS 0D Pattern commands @SC86295 05861000 SCRWCCW DC X'29',AL3(0),AL1(SLI),X'00',AL2(0) Write @SC86295 05862000 DC X'2A',AL3(0),AL1(SLI),X'80',AL2(0) Read mod @SC86295 05863000 DC X'29',AL3(0),AL1(SLI),X'80',AL2(0) Write mod @SC86295 05864000 RTRYIO DC 0D'0',X'19',AL3(0),AL1(CC+SLI),X'FF',AL2(1) @SC86159 05865000 DC X'29',AL3(RTRYCM),AL1(SLI),X'80',AL2(1) @SC86159 05866000 RTRYCM DC X'C0' @SC86159 05867000 TITLE 'SETMSG Routine - controls CP breakin' 05868000 * Entry: R1 selects operation 05869000 * Exit: R15=0 if ok 05870000 * 1-> Analyze user environment, determine if suitable. 05871000 * Save quantities needed and condition line for entering commands. 05872000 * Perform any system-dependent initialization. 05873000 * 2-> Condition line for protocol transfers. 05874000 * 3-> Decondition line at end of transfer. 05875000 * 4-> System-dependent clean-up at exit. 05876000 * 5-> Reperform system-dependent intialization after SET LINE. 05877000 SETMSG ENTER ALT @SC86295 05878000 BCT 1,STM2 Go if R1 not 1, so no init 05879000 STMSTY L 2,CBUF Put diag result here 05880000 LA 3,32 Get this much info 05881000 DIAG 2,3,X'00' Identify 05882000 MVC USRTAKE,16(2) Move userid to our buffer 05883000 L 1,ASTMUSET @SC87117 05884000 MVC 0(STMUL+STMLL,1),STMUOFF Set up pattern @SC87117 05885000 CPCMD 2,4,'Q SET',RESP=YES @SC86148 05886000 MVC ADR,CBUF Response address for parser 05887000 ST 5,LEN Response length for parser 05888000 MVC STMSCNS(8),SCANPTR Save string ptrs @SC87117 05889000 S 1,F4 Start of list: back 8, up L'SET +1@SC87117 05890000 SR 5,5 Length of previous data @SC86148 05891000 LA 8,STMLEN-2 Descriptor list @SC86148 05892000 LA 4,6 Number of items in QUERY SET @SC86148 05893000 BAL 2,STMGET @SC86295 05894000 BCT 4,*-4 @SC86148 05895000 MVC SCANPTR(8),STMSCNS @SC87117 05896000 BAL 2,STMGET Scan again for LINEDIT @SC87117 05897000 CPCMD 2,6,'Q TERM',RESP=YES @SC86148 05898000 MVC ADR,CBUF Response address for parser 05899000 ST 7,LEN Response length for parser @SC87117 05900000 LA 1,1(1) One extra: L'TERM - L'SET @SC87117 05901000 BAL 2,STMGET @SC86295 05902000 BAL 2,STMGET (if more: put S 1,F4 in loop) @SC87295 05903000 STM 10,11,STMSAVR Save base registers @SC87117 05904000 HOST STMEXC Set up subcommand environment @SC87117 05905000 B STM5X @SC87351 05906000 DS 0F @SC87117 05907000 STMEXC DC CL8'SUBCOM',CL8'KERMIT' @SC87117 05908000 DC F'0',A(STMSUBC,0) @SC87117 05909000 * 05910000 STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05911000 TM FL1,TSTF @SC86295 05912000 BO RTRN0 Just testing, don't change it @SC86295 05913000 CLI TRMLIN,C' ' Alternate comm line? @SC87300 05914000 BNE RTRN1 Not allowed! @SC87300 05915000 LA 2,STMUOFF Set everything off 05916000 MVC STMUOTB,AOUTRTBL Save user's table ptrs @SC87201 05917000 MVC STMUITB,AINTRTBL @SC87201 05918000 LA 7,F0 Set to turn off translation @SC87201 05919000 LR 8,7 @SC87201 05920000 B STMD 05921000 * 05922000 STM3 BCT 1,STM4 @SC86316 05923000 L 2,ASTMUSET Restore user's settings @SC87117 05924000 LA 7,STMUITB Restore user's table ptrs @SC87201 05925000 LA 8,STMUOTB @SC87201 05926000 STMD LA 4,STMUL Length of 1st batch @SC87117 05927000 LA 5,0(2,4) Start of 2nd @SC87117 05928000 CPCMD 2,4 Issue a bunch of CP commands @SC87117 05929000 CLI TRMTP,C'T' Fullscreen mode? @SC87166 05930000 BNE RTRN0 Yes, skip linemode stuff @CR86321 05931000 DMSEXS MVC,AINTRTBL,0(7) Restore input table @SC87201 05932000 DMSEXS MVC,AOUTRTBL,0(8) Restore output table @SC87201 05933000 LA 7,STMLL @SC87295 05934000 CPCMD 5,7,RESP=YES No, do linemode stuff @SC87295 05935000 B RTRN0 05936000 * 05937000 STM4 BCT 1,STM5 Special clean-up @SC87351 05938000 B RTRN0 Special clean-up not needed @SC87351 05939000 * 05940000 STM5 DS 0H Re-init after SET LINE @SC87351 05941000 STM5X SR 2,2 @SC86295 05942000 BCTR 2,0 @SC86295 05943000 CLI TRMLIN,C' ' External line? @SC87351 05944000 BE STM5D No, use console @SC87351 05945000 LA 5,3+1 Allow no more than 3 hex digits @SC87351 05946000 SR 2,2 Init value @SC87351 05947000 LA 1,TRMLIN Ptr to string @SC87351 05948000 STM5L CLI 0(1),C' ' Look for end of value @SC87351 05949000 BE STM5D Ok, got number @SC87351 05950000 IC 3,0(1) @SC87351 05951000 CLI 0(1),C'0' 0-9? @SC87351 05952000 BL STM5LA @SC87351 05953000 CLI 0(1),C'9' @SC87351 05954000 BH RTRN1 Bad digit @SC87351 05955000 B STM5LS Ok, use it @SC87351 05956000 STM5LA CLI 0(1),C'A' A-F? @SC87351 05957000 BL RTRN1 Bad @SC87351 05958000 CLI 0(1),C'F' @SC87351 05959000 BH RTRN1 Bad @SC87351 05960000 LA 3,9(3) OK, get in binary @SC87351 05961000 STM5LS SLL 3,28 Convert to nybble @SC87351 05962000 SLDL 2,4 @SC87351 05963000 BCT 5,STM5L @SC87351 05964000 B RTRN1 String too long @SC87351 05965000 STM5D DIAG 2,3,X'0024' Get console flags 05966000 BO RTRN1 Bad device(?) @SC87351 05967000 CLM 3,8,=X'8020' Is this a terminal? @SC87351 05968000 BNE RTRN1 No, bad device @SC87351 05969000 STH 2,CONSADDR Save console addr (CUU) 05970000 UNPK CONSADH(4),CONSADDR(3) @SC86159 05971000 TR CONSADH(3),TRHEX Save as chars @SC86159 05972000 CLM 4,12,=X'8020' Is this a TTY? @SC86295 05973000 BE *+8 Yes @SC87351 05974000 MVI TRMTP,C'S' Remember going via S/1 @SC87166 05975000 B RTRN0 05976000 * 05977000 * Parse CP response for token pointed by R1: token 05978000 * On entry: R1 = ptr-8-R5 of name in user list @SC86148 05979000 * R5 = length of previous token @SC86148 05980000 * R8 = ptr to previous len-1 of name,data @SC86148 05981000 * On exit: R1,R5,R8 updated @SC86148 05982000 * value copied into user list @SC86148 05983000 * 05984000 STMGET LA 8,2(8) Point to next descriptor @SC86148 05985000 LA 1,8(5,1) Advance to next name @SC86148 05986000 IC 5,1(8) Get length of data @SC86148 05987000 STMGET1 NTOKN N=0(2) Pick next token @SC86295 05988000 CLM 7,1,0(8) Is this the same size we want? @SC86148 05989000 BNE STMGET1 Not the size we want @SC86148 05990000 EX 7,STMGETC is it right one? 05991000 BNE STMGET1 Nope, keep on looking @SC86148 05992000 AR 1,7 Space over name @SC86148 05993000 NTOKN N=0(2) Use the next token @SC86316 05994000 EX 5,STMGETM Copy value @SC86148 05995000 BR 2 @SC86295 05996000 * 05997000 STMGETC CLC 0(,1),0(6) Check token against list @SC86148 05998000 STMGETM MVC 2(,1),0(6) Save value in list @SC86148 05999000 * 06000000 * MSG WNG ACNT RUN TIME IMSG EDIT SIZE SCRL@SC87295 06001000 STMLEN DC AL1(02,3,02,3,03,2,02,2,04,3,03,3,06,2,07,2,05,3) C87295 06002000 * 06003000 STMUOFF DC C'SET MSG OFF ',X'15' CP commands to set all off 06004000 DC C'SET WNG OFF ',X'15' (in order of CP msgs) 06005000 DC C'SET ACNT OFF',X'15' 06006000 DC C'SET RUN ON ',X'15' 06007000 DC C'SET TIMER OFF ',X'15' @SC87117 06008000 DC C'SET IMSG OFF ',X'15' @SC87117 06009000 STMUL EQU *-STMUOFF @CR86321 06010000 DC C'SET LINEDIT OFF',X'15' Separate batch of SET's@SC87117 06011000 STMLOFF DC C'TERM LINESIZE OFF' @CR86321 06012000 DC CL5' ',C'SCROLL CONT' (if more, cut to 1 sp) @SC87295 06013000 STMLL EQU *-STMUOFF-STMUL @SC87117 06014000 TITLE 'STMSUBC Routine - subcommand environment handler' 06015000 USING STMSUBC,15 @SC87117 06016000 STMSUBC STM 14,12,12(13) Save registers @SC87117 06017000 LM 10,11,STMSAVR Get base registers @SC87117 06018000 LA 0,USNTRFLX Length of locals @SC87117 06019000 BAL 14,SUBENT Set up entry @SC87117 06020000 LR 15,12 Recover local base register @SC87117 06021000 LR 2,0 Save ptr to EPLIST @SC87117 06022000 LA 0,RTRNUM Set to return error code @SC87117 06023000 L 1,=A(USNCMDX) All commands but QUIT @SC87117 06024000 BAL 14,LOOPS @SC87117 06025000 L 12,AUSNTRF Ptr to main loop routine @SC87117 06026000 LM 15,0,4(2) Ptrs to command and end @SC87117 06027000 SR 0,15 Get length @SC87117 06028000 LA 1,CMD @SC87117 06029000 MVC 0(256,1),0(15) Copy to buffer @SC87117 06030000 OI KFLG-USNTRFSV(13),CMDC+SIGN Indicate just 1 cmd @SC87117 06031000 B LUPPRS @SC87117 06032000 STMSAVR DS 2F @SC87117 06033000 TITLE 'S1INT Routine - interrupt handler' 06034000 USING S1INT,15 @SC86295 06035000 S1INT STM 2,3,CONSCSW Save CSW from interrupt 06036000 CLI CONSUNIT,CE 06037000 BNE S1IOK Go if not a ch end int @SC86295 06038000 LA 15,1 Flag we expect another 06039000 BR 14 @SC86295 06040000 S1IOK SR 15,15 R15=0-> intrpt proc complete 06041000 BR 14 @SC86295 06042000 DROP 15 @SC86295 06043000 * 06044000 * HNDINT Plist for Series/1 interrupt handling 06045000 HNDINTPL DC CL8'HNDINT' HNDINT plist 06046000 DC CL4'SET' Set function 06047000 DC CL4'CON1' Symbolic device 06048000 DC AL4(S1INT) S1 Interrupt handler 06049000 CONSADDR DC AL2(9) Console address 06050000 DC CL2'WC' 06051000 DC 8X'FF' 06052000 * 06053000 CONSCSW DS A (key + cc)(1) + CCW addr(3) 06054000 CONSUNIT DS X Unit status 06055000 CONSCHAN DS X Channel status 06056000 CONSBYTC DS H Byte count 06057000 CONSADH DC C'...',C' ' Unpacked vaddr + pad @SC86159 06058000 LOCALS , @SC86295 06059000 STMSCNS DS 2F Saved scan ptrs @SC87117 06060000 SETMSG EXIT 06061000 TITLE 'DISKIO Routine - performs disk I/O functions' 06062000 * Function selected on entry by R0: 06063000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 06064000 * 2=> open (out): (same, but no complete FDB if new file) 06065000 * 3=> test name: R2->name. Returns R1->FDB if found (else R15=1) 06066000 * 4=> close file: R1->adr(FAB). 06067000 * 5=> set up search: R1->pattern name. 06068000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 06069000 * 7=> close search (if any). 06070000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 06071000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 06072000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 06073000 * 11=> test space: R1->adr(FAB), R2=est. Kbytes. Return R15=0 if ok. 06074000 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 06075000 * always returns R15=1 06076000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 06077000 * 14=> delete file: R1->name. Returns R15=0 if ok. 06078000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 06079000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 06080000 DISKIO ENTER 06081000 USING FABD,3 @SC86295 06082000 SR 4,4 Signal no block assigned @SC86295 06083000 BCT 0,DSKOPNO @SC86295 06084000 * 06085000 * Open for input file whose name is at (R2), FDB at (R1) 06086000 BAL 9,DSKALC Get FAB @SC86295 06087000 DSKOP0 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 06088000 BNZ DSKER1 Not found @SC86295 06089000 BAL 14,DSKVALS @SC86295 06090000 B RTRN0 @SC86295 06091000 * 06092000 * Open for output file whose name is at (R2), FDB at (R1) 06093000 DSKOPNO BCT 0,DSKTEST @SC86295 06094000 BAL 9,DSKALC Get FAB @SC86295 06095000 TM FDBFLGS,APPN @SC86295 06096000 BO DSKOP2 @SC86295 06097000 FSERASE FSCB=(3) @SC86295 06098000 B DSKOPLR @SC87012 06099000 DSKOP2 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 06100000 BNZ DSKOPLR Not found, just writing new @SC87012 06101000 BAL 14,DSKVALS @SC86295 06102000 DSKOPLR SR 0,0 @SC87012 06103000 ICM 0,3,FDBLRC File LRECL @SC87012 06104000 TM FL1,BINF @SC87012 06105000 BO *+8 @SC87012 06106000 L 0,MAXLRC TEXT file, no limit @SC87012 06107000 ST 0,MAXOUT Set output buffer limit @SC87012 06108000 B RTRN0 @SC86295 06109000 * 06110000 * Test for existence of file whose name is at (R2) 06111000 DSKTEST BCT 0,DSKCLOS @SC86295 06112000 MVC DSKSTNM,0(2) @SC86295 06113000 LA 3,DSKSTT @SC86295 06114000 B DSKOP0 Test file @SC86295 06115000 * 06116000 * Close file whose ticket is at (R1), release block 06117000 DSKCLOS BCT 0,DSKNSET @SC86295 06118000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 06119000 BZ RTRN0 None, ignore @SC86295 06120000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 06121000 FSCLOSE FSCB=(3) @SC86295 06122000 LA 0,FABDWDS @SC86295 06123000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06124000 B RTRN0 @SC86295 06125000 * 06126000 * Read from file whose ticket is at (R1) 06127000 DSKRED BCT 0,DSKWRT @SC86295 06128000 * - - - not used - - - @SC86295 06129000 B RTRN1 @SC87320 06130000 * 06131000 * Write to file whose ticket is at (R1) 06132000 DSKWRT BCT 0,DSKTSP @SC86316 06133000 * - - - not used - - - @SC86295 06134000 B RTRN1 @SC87320 06135000 * 06136000 * Analyze error: packed dec. code in TMPDW 06137000 DSKXXX BCT 0,DSKUTL @SC86316 06138000 MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 06139000 L 2,EMSGP Ptr to msg buffer @SC87338 06140000 MVC 0(8,2),0(1) Copy oprn name @SC87338 06141000 MVC 8(2,2),=C'R=' @SC87338 06142000 OI TMPDW+7,15 Set zone @SC87338 06143000 UNPK 10(2,2),TMPDW Copy error code @SC87338 06144000 MVC EMSGL,F12 Length of string @SC87338 06145000 B RTRN1 @SC87338 06146000 * 06147000 * Disk utility for file(s) at (R1) and (R2) 06148000 DSKUTL LR 8,0 Save code-12 @SC86316 06149000 BCTR 0,0 Code-13: DIR,DEL,REN,COP @SC86316 06150000 SLA 0,3 @SC86295 06151000 LA 5,DSKCMDS @SC86295 06152000 AR 5,0 Ptr to command name @SC86295 06153000 LA 4,CMD Buffer for tokenized command @SC86295 06154000 MVC 0(8,4),0(5) @SC86295 06155000 LA 4,8(4) @SC86295 06156000 LR 6,1 1st file @SC86295 06157000 BAL 3,DSKUTCP @SC86295 06158000 SRA 0,4 @SC86295 06159000 BZ *+10 @SC86295 06160000 LR 6,2 2nd file @SC86295 06161000 BAL 3,DSKUTCP @SC86295 06162000 BCT 8,*+14 Go if not LISTFILE @SC86295 06163000 MVC 0(16,4),=CL16'( DATE' @SC86295 06164000 LA 4,16(4) @SC86295 06165000 MVI 0(4),X'FF' Insert fence @SC86295 06166000 MVC 1(7,4),0(4) @SC86295 06167000 LA 0,CMD @SC86295 06168000 NI FL4,255-UCMD Not user command: already tokens @SC86295 06169000 KCALL SUPFNC,3 Execute it @SC86295 06170000 B RTRN @SC86295 06171000 * 06172000 DSKUTCP LA 7,LFID Length of name @SC86295 06173000 ICM 7,8,BLANK Blank fill @SC86295 06174000 LA 5,24 @SC86295 06175000 MVCL 4,6 Copy name and update R4 @SC86295 06176000 BR 3 @SC86295 06177000 * 06178000 DSKCMDS DC C'LISTFILE' Utility command names @SC86295 06179000 DC C'ERASE ' @SC86295 06180000 DC C'RENAME ' @SC86295 06181000 DC C'COPYFILE' @SC86295 06182000 * 06183000 * Return on error, release useless block, if any 06184000 DSKER1 LTR 1,4 Any block assigned? @SC86295 06185000 BZ RTRN1 No @SC86295 06186000 LA 0,FABDWDS Yes, release it @SC86295 06187000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 06188000 B RTRN1 Flag error @SC86295 06189000 * 06190000 DSKALC LR 5,1 Save FDB ptr @SC86295 06191000 MVC DSKSTNM,0(2) @SC86295 06192000 LA 0,FABDWDS @SC86295 06193000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 06194000 LR 3,1 New block ptr @SC86295 06195000 LR 4,1 @SC86295 06196000 L 1,4(13) @SC86295 06197000 ST 3,20(1) Return R0 @SC86295 06198000 XC 0(8*FABDWDS,3),0(3) @SC86295 06199000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 06200000 MVC FABFN(18),0(2) @SC86295 06201000 OI FDBFLGS,FDBEPL @SC86295 06202000 MVI FABANIT+3,1 @SC86295 06203000 BR 9 @SC86295 06204000 * 06205000 DSKLKP DMSKEY NUCLEUS @SC86295 06206000 GETFST DSKSTT Call system routine for FST @SC86295 06207000 LR 9,0 Save ADT ptr @SC86295 06208000 LR 8,1 And FST ptr @SC86295 06209000 LTR 1,15 Save return code @SC86295 06210000 DMSKEY RESET @SC86295 06211000 LTR 15,1 Test return code @SC86295 06212000 BR 2 @SC86295 06213000 * 06214000 * Set up search through list of files, pattern at (R1) 06215000 DSKNSET BCT 0,DSKNXT @SC86295 06216000 NI DSKFL,255-CWDF Find files @SC86295 06217000 MVC NXFN(18),0(1) @SC86295 06218000 DSKNSX MVI ADT,X'80' Start over @SC86295 06219000 B RTRN0 @SC86295 06220000 * 06221000 * Flush previous file pattern 06222000 DSKXSET BCT 0,DSKCWDF @SC86295 06223000 B DSKNSX @SC86295 06224000 * 06225000 * Check CWD string, return code in R15 06226000 DSKCWDF BCT 0,DSKRED @SC86295 06227000 OI DSKFL,CWDF Find disk @SC86295 06228000 MVC NXFN(18),0(1) @SC86295 06229000 MVI ADT,X'80' Start over @SC86295 06230000 B NXTFST @SC86295 06231000 * 06232000 * Check disk space for proposed file: FAB ptr at (R1) 06233000 DSKTSP BCT 0,DSKXXX @SC86316 06234000 ICM 3,15,0(1) Get FAB ptr @SC86316 06235000 BZ RTRN1 ?? @SC86316 06236000 USING ADTSECT,9 @SC86316 06237000 L 9,IADT Look at 1st ADT @SC86316 06238000 DSKTSP1 CLC ADTM,FABFM Find right disk @SC86316 06239000 BE DSKTSP2 @SC86316 06240000 ICM 9,15,ADTPTR Try next @SC86316 06241000 BNZ DSKTSP1 @SC86316 06242000 B RTRN0 Disk not found! @SC86316 06243000 DSKTSP2 L 1,ADTNUM Total blocks @SC86316 06244000 S 1,ADTUSED Less used @SC86316 06245000 M 0,ADTDBSIZ Times block size @SC86316 06246000 SRDA 0,10 Convert to Kbytes @SC86316 06247000 CLR 1,2 @SC87012 06248000 BL RTRN1 No room @SC86316 06249000 B RTRN0 Ok @SC86316 06250000 * 06251000 * NXTFST Routine - searches the ADT and FST chains 06252000 DSKNXT BCT 0,DSKXSET @SC86295 06253000 * Carl Kass and Jeff Damens, CUCCA User Services, 12/80 06254000 * Modified for Kermit-CMS by Vace Kundakci, 12/85 06255000 * Copyright (C) 1980 Columbia University 06256000 * Permission is granted to any individual or institution to copy 06257000 * or use this program, except for explicitly commercial purposes. 06258000 * 06259000 * IFN, IFT, IFM contains a CMS filename, possibly containing wildcard 06260000 * characters, and FST and ADT contain pointers to a valid ADT & FST 06261000 * or are null (negative ADT), return the next FST matching the given 06262000 * filename in FST and the address of the corresponding ADT in ADT. 06263000 * Also move the matched filename into FN, FT, FM. 06264000 * Also return info in a File Descriptor Block @SC86151 06265000 * 06266000 USING FSTSECT,8 06267000 USING DCHSECT,1 06268000 NXTFST ICM 9,15,ADT Supplied ADT 06269000 BP NXFNEXT Use it if there's one 06270000 L 9,IADT Else, start with first ADT @SC86295 06271000 NI DSKFL,255-WFM-WFT-WFN Nothing wild yet 06272000 LA 3,NXFN @SC86295 06273000 BAL 14,NXFPAT @SC86295 06274000 OI DSKFL,WFN @SC86295 06275000 LA 3,NXFT @SC86295 06276000 BAL 14,NXFPAT @SC86295 06277000 OI DSKFL,WFT @SC86295 06278000 CLI NXFM,C'A' @SC86115 06279000 BNL NXFAFM Go if mode letter is A or more 06280000 MVI NXFM,C'%' Set to % if it was blank @SC86115 06281000 OI DSKFL,WFM 06282000 NXFAFM CLI NXFM+1,C'0' @SC86115 06283000 BNL NXFADT Go if mode number is numeric 06284000 MVI NXFM+1,C'%' Set to % if was blank or * @SC86115 06285000 NXFADT TM ADTFLG1,ADTFRO+ADTFRW 06286000 BZ NXFNADT 06287000 CLI NXFM,C'%' @SC86115 06288000 BE NXFFFST Go if he can use any 06289000 CLC ADTM,NXFM 06290000 BE NXFFFST Go if it is this disk 06291000 TM DSKFL,CWDF Called for CWD? @SC86295 06292000 BO NXFNADT Just looking for disk @SC86222 06293000 CLC ADTMX,NXFM Check for read-only extension @SC86222 06294000 BE NXFFFST Yes, search here too @SC86222 06295000 NXFNADT ICM 9,15,ADTPTR Use next ADT @SC86295 06296000 BNZ NXFADT But ony if it exists 06297000 NXFER MVI ADT,255 For next time, start all over 06298000 B RTRN1 Bad return code @SC86295 06299000 * 06300000 NXFPAT LA 1,8(3) End addr of FN or FT @SC86295 06301000 TRT 0(8,3),TRTBL Look for space @SC86295 06302000 SR 1,3 Compute length @SC86295 06303000 ST 1,NXFFNL-NXFN(3) Length of pattern @SC86295 06304000 MVI TRTBL+C' ',0 Don't want to catch a blank @SC86115 06305000 MVI TRTBL+C'%',1 Want to catch a percent @SC86115 06306000 MVI TRTBL+C'*',1 Want to catch an asterisk @SC86115 06307000 TRT 0(8,3),TRTBL See if any % or * in FN @SC86295 06308000 MVI TRTBL+C'%',0 Restore TRTBL @SC86115 06309000 MVI TRTBL+C'*',0 @SC86115 06310000 MVI TRTBL+C' ',1 @SC86115 06311000 BZ 4(14) No wild chars found @SC86295 06312000 BR 14 @SC86295 06313000 * 06314000 NXFFFST L 1,ADTFDA Grab hyperblock ptr 06315000 TM DSKFL,CWDF Called for CWD? @SC86295 06316000 BO NXFHSV Yes, found it @SC86164 06317000 NXFHYP ST 1,NXFHYPE Save for later 06318000 LA 8,DCHDATA Point to first FST 06319000 L 3,DCHDWSIZ Get size of hyperblock 06320000 SLL 3,3 Convert to bytes 06321000 LA 2,DCHSECT(3) Add to get end of hyperblk 06322000 ST 2,NXFHEND Save it 06323000 * 06324000 * All initialized. Ready to step through files. R8 contains current 06325000 * FST, R9 contains current ADT, NXFHYPE contains current hyperblock 06326000 * NXFHEND has end of hyperblock. 06327000 * 06328000 NXFFST CLC F0,FSTN 06329000 BE NXFNHYP Go try next hyperblock 06330000 CLC F0,FSTN+4 06331000 BE NXFNFST Go if directory or Alocmap 06332000 LA 4,NXFN @SC86295 06333000 LA 5,FSTN @SC86295 06334000 TM DSKFL,WFN @SC86295 06335000 BAL 14,NXFCOMP Test pattern against token @SC86295 06336000 LA 4,NXFT @SC86295 06337000 LA 5,FSTT @SC86295 06338000 TM DSKFL,WFT @SC86295 06339000 BAL 14,NXFCOMP Test pattern against token @SC86295 06340000 * 06341000 CLI NXFM+1,C'%' @SC86115 06342000 BE NXFHAVE Go if any FM is ok 06343000 CLC NXFM+1(1),FSTM+1 @SC86295 06344000 BNE NXFNFST Go if no match 06345000 NXFHAVE MVC FN,FSTN Return FN @SC86164 06346000 MVC FT,FSTT Return FT 06347000 MVC FM+1(1),FSTM+1 Return FM number 06348000 LA 3,DSKSTT @SC86295 06349000 BAL 14,DSKVALS Copy out quantities @SC86295 06350000 NXFHSV MVC FM(1),ADTM Return FM letter @SC86164 06351000 ST 9,ADT Save ADT for him @SC86295 06352000 ST 8,FST Ditto for FST @SC86164 06353000 B RTRN0 @SC86295 06354000 * 06355000 * Come to NXFNFST to step to next file. 06356000 * 06357000 NXFNEXT L 8,FST 06358000 NXFNFST TM ADTFLG4,ADTEDF 06359000 BZ NXFNEDF Go if not EDF 06360000 LA 8,FSTL2(8) Point to next EDF FST 06361000 B NXFEDF 06362000 * 06363000 NXFNEDF LA 8,FSTL(8) Point to next non-EDF FST 06364000 NXFEDF C 8,NXFHEND End of hyperblock? 06365000 BL NXFFST No, there are more FSTs still 06366000 NXFNHYP L 1,NXFHYPE Point to current hyperblock 06367000 ICM 1,B'1111',DCHFWPTR Next hyperblock 06368000 BNZ NXFHYP Go use next hyperblock if any 06369000 B NXFNADT Need to use next disk 06370000 * 06371000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06372000 L 1,4(13) @SC86295 06373000 ST 0,24(1) Return ptr to caller @SC86295 06374000 NI DSKFL,255-WARB @SC86295 06375000 TM ADTFLG4,ADTEDF Extended format? @SC86149 06376000 BZ DSKVNEF @SC86149 06377000 L 1,ADTDBSIZ Block size @SC86149 06378000 M 0,FSTADBC Number of blocks @SC86149 06379000 L 7,FSTAIC Get item count @SC86239 06380000 MVC FDBDATE+1(3),FSTADATI Copy file date @SC86295 06381000 B DSKVEF @SC86149 06382000 DSKVNEF SR 0,0 @SC86149 06383000 LA 1,800 Block size @SC86149 06384000 MH 1,FSTDBC @SC86149 06385000 LH 7,FSTIC Get item count @SC86239 06386000 PACK FDBDATE+1(2),FSTYR(3) Copy file year @SC86295 06387000 MVC FDBDATE+2(2),FSTD Copy file date @SC86295 06388000 DSKVEF SRDA 0,10 Convert to kbytes @SC86149 06389000 M 6,FSTIL Compute byte count (approx. if V) @SC86239 06390000 AL 7,=F'1023' Round up @SC87007 06391000 BNO *+8 No overflow @SC86239 06392000 LA 6,1(6) @SC86239 06393000 SRDA 6,10 @SC86239 06394000 CLR 1,7 Compare with official length @SC86239 06395000 BL *+6 @SC86239 06396000 LR 1,7 Use computed length instead @SC86239 06397000 LTR 1,1 @SC86239 06398000 BNZ *+8 @SC86239 06399000 LA 1,1 Never say zero length @SC86239 06400000 ST 1,FDBSIZE File size @SC86295 06401000 MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06402000 CLI FDBDATE+1,X'50' @SC86295 06403000 BH *+8 Ok @SC86295 06404000 MVI FDBDATE,X'20' Must be 21st @SC86295 06405000 MVC FDBRCF,FSTFV Copy format @SC86295 06406000 MVC FDBLRC,FSTIL+2 No, copy from FST @SC86295 06407000 LR 7,14 @SC86295 06408000 SR 0,0 Search from start @SC86295 06409000 LR 1,3 Filename in FAB @SC86295 06410000 A 13,F8 Preserve chain ptr in save area @SC86295 06411000 L 15,AACTLKP Find if active file @SC86295 06412000 BALR 14,15 @SC86295 06413000 S 13,F8 Resume ptr to save area @SC86295 06414000 LTR 15,15 Is it active? @SC86295 06415000 BNZR 7 @SC86295 06416000 OI FDBFLGS,FDBACTV Yes @SC86295 06417000 BR 7 @SC86295 06418000 * 06419000 DSKFL EQU DSKSTT+FDBFLGS-FABD Flags for operation @SC86295 06420000 CWDF EQU X'80' Looking only for disk @SC86295 06421000 WARB EQU X'40' Wild char seen @SC86295 06422000 * 06423000 DROP 1,8,9 @SC86295 06424000 * 06425000 NXFCOMP MVC NXFSTR,0(5) Copy name in @SC86295 06426000 BO NXFWF Go if wild FN or FT @SC86295 06427000 CLC NXFSTR,0(4) @SC86295 06428000 BNE NXFNFST Go if no match @SC86295 06429000 BR 14 @SC86295 06430000 * 06431000 NXFWF LA 1,8(5) Assume end @SC86295 06432000 TRT 0(8,5),TRTBL Look for first non-space @SC86295 06433000 SR 1,5 Compute length @SC86295 06434000 LR 7,1 Save length @SC86295 06435000 L 5,NXFFNL-NXFN(4) @SC86295 06436000 LA 6,NXFSTR @SC86295 06437000 * 06438000 * Enter here with R4-R7 containing: 06439000 * pattern address and length 06440000 * source address and length 06441000 * 06442000 NI DSKFL,255-WARB Haven't seen any of these @SC86295 06443000 ICM 7,B'1000',ASTER Use * as the fill char 06444000 WLDLOOP CLCL 4,6 Compare them 06445000 BER 14 They're equal, fine @SC86295 06446000 * 06447000 * String mismatch - so examine offending pattern character. If not 06448000 * % or * and we haven't seen any * yet, we fail. If it's % we just 06449000 * skip it; if it's * we skip it and remember we've seen it. Else 06450000 * back up to one past the last * and try again. 06451000 * 06452000 CLI 0(4),C'%' @SC86115 06453000 BE WLDLEN1 Go if % = LEN(1) pattern 06454000 CLI 0(4),C'*' @SC86115 06455000 BE WLDARB Go if * = ARB pattern 06456000 TM DSKFL,WARB @SC86295 06457000 BZ NXFNFST Go if ARB already seen @SC86295 06458000 CLM 7,B'0111',F0 More data to compare? 06459000 BE NXFNFST Go if exhausted @SC86295 06460000 LM 4,7,WLDPAT Restore addr of old ARB char 06461000 LA 6,1(6) Push one past 06462000 BCTR 7,0 Decrement length 06463000 STM 6,7,WLDSRC Store changed addr 06464000 B WLDLOOP And go compare again. 06465000 * 06466000 WLDLEN1 LA 4,1(4) Increment pattern addr 06467000 BCTR 5,0 Decrement pattern len 06468000 CLM 7,7,F0 Length to compare more @SC86119 06469000 BE NXFNFST None, pattern '%' is extra @SC86119 06470000 LA 6,1(6) Increment source addr 06471000 BCTR 7,0 Decrement source len 06472000 CLM 7,7,F0 Length to compare more @SC86119 06473000 BNE WLDLOOP Go if more data 06474000 LTR 5,5 Anything more in pattern? 06475000 BZR 14 No, it's a match @SC86295 06476000 CLI 0(4),C'*' @SC86115 06477000 BE WLDLOOP Go if ARB 06478000 B NXFNFST Failed @SC86295 06479000 * 06480000 * If pattern ends in ARB, then it will match anything. So return to 06481000 * caller if the pattern is exhausted. 06482000 * 06483000 WLDARB OI DSKFL,WARB Remember we saw one @SC86295 06484000 LA 4,1(4) Pass the ARB 06485000 BCTR 5,0 Decrement its length 06486000 LTR 5,5 Any more left? 06487000 BZR 14 No, it's a match @SC86295 06488000 STM 4,7,WLDPAT Save where they were 06489000 B WLDLOOP 06490000 * 06491000 LOCALS , @SC86295 06492000 WLDPAT DS A Place in pattern of last ARB 06493000 DS F Length of pattern past ARB 06494000 WLDSRC DS A Place in source when ARB seen 06495000 DS F Length of source past WLDSRC 06496000 * 06497000 WILD EXIT 06498000