Columbia Kermit

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

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

Wrap

Assembly Source File | 2020-01-01 | 175KB | 2,156 lines

*COPY IKCUTL 05000000 CHECKVER IKCUTL,4.3 @SC90072 05000500 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000 * Set new 'working directory', i.e., filemode letter 05001500 * Entry: SCANPTR string has option 05002000 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05002500 CWDSET ENTER @SC86164 05003000 * CMS filespec parts @SC86295 05003500 FN EQU FILNAM,8 @SC86295 05004000 FT EQU FN+8,8 @SC86295 05004500 FM EQU FT+8,2 @SC86295 05005000 * 05005500 IFIFM EQU IFILE+16,2 @SC90344 05006000 * 05006500 JFN EQU JFNAM,8 Foreign FN for SEND @SC86295 05007000 JFT EQU JFN+8,8 Foreign FT for SEND @SC86295 05007500 * 05008000 NTOKN N=CWDERR,H=CWDERR @SC86164 05008500 LTR 7,7 Length of token @SC86164 05009000 BNZ CWDERR >1 @SC86164 05009500 MVC IFIFM(1),0(6) Copy mode letter @SC90037 05010000 TR IFIFM(1),UPCASE @SC91033 05010500 NXTFSET IFILE,CWD,E=CWDERR @SC86295 05011000 MVC DEST(1),IFIFM Save new mode @SC90037 05011500 B RTRN0 @SC86295 05012000 CWDERR PTEXT '&CWDERRM' @SC86295 05012500 B SUBERR @SC86295 05013000 * 05013500 * DSPACE Routine - display available disk space @SC86164 05014000 * 05014500 * Show space in 'working directory' or other minidisk 05015000 * Entry: SCANPTR string has option (none => working directory) 05015500 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05016000 DSPACE ENTER ALT @SC86164 05016500 MVC QDISK+16(1),DEST Default filemode @SC86164 05017000 NTOKN N=DSPACEX @SC86164 05017500 MVC QDISK+16(1),0(6) @SC86164 05018000 TR QDISK+16(1),UPCASE @SC91033 05018500 DSPACEX HOST QDISK,E=RTRN1 @SC86295 05019000 B RTRN0 @SC86295 05019500 LOCALS , @SC86295 05020000 EXIT , @SC86295 05020500 TITLE 'FSPEC Routine - extract filespec from scan string' 05021000 * 05021500 * Entry: R1->name field, R0=flags selecting operation (see below) 05022000 * For parse operations, SCANPTR defines the input string. 05022500 * For getting foreign or display filespec, R7->output buffer 05023000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05023500 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05024000 * 05024500 * Flags: Notes: 05025000 * Tasks: FFRCF FFSND FFGET FFNEW 05025500 * Parse RECV X set ROVR properly 05026000 * Parse SEND 1st X 05026500 * Parse SEND 2nd X X 05027000 * Parse GET 1st X 05027500 * Parse GET 2nd X X set ROVR properly 05028000 * Parse F-packet (FFHDR) X X X 05028500 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05029000 * Parse TAKE 05029500 * 05030000 * Get unique name X R15: 0=>ok, 1=>bad 05030500 * Interactive name check X X R15: 0=>ok, 1=>bad 05031000 * Get foreign name (FFENC) X X R15->end of string 05031500 * Get display form (FFDSP) X X R15->end of string 05032000 * 05032500 FSPEC ENTER @SC86295 05033000 STC 0,FSPFLG @SC86295 05033500 LR 5,0 @SC88049 05034000 SRL 5,4 Convert flags to index @SC88049 05034500 AR 5,5 @SC88049 05035000 LR 0,1 Copy ptr to filespec @SC86295 05035500 TM FSPFLG,FFNEW @SC86295 05036000 BO FSPWRN @SC86295 05036500 XC 0(18,1),0(1) Clear filespec @SC86295 05037000 MVC FSPBAD,=C'&INVALID' @SC86295 05037500 MVC FSPBADF(9),=C' filename' @SC86295 05038000 PTEXT FSPBAD,FSPBL Standard msg form @SC86295 05038500 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05039000 MVC 16(2,1),DEST Default FM @SC86295 05039500 LH 5,FSP0(5) Get dispatch adr @SC88049 05040000 B FSP0(5) Go to proper handler @SC88049 05040500 * TAKE GET 1st SEND 1st Generic @SC88049 05041000 FSP0 DC AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0) SC88049 05041500 * RECEIVE GET 2nd SEND 2nd F-packet @SC88049 05042000 DC AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) @SC88049 05042500 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05043000 BZ FSPASC No @SC86295 05043500 MVC 0(8,1),ASTER Yes @SC86295 05044000 MVC 8(8,1),ASTER @SC86295 05044500 FSPASC TM FL2,SRV Server mode? @SC86295 05045000 BZ FSPCPY No, don't need to convert @SC86295 05045500 ICM 15,15,LEN Get length @SC86295 05046000 BZ FSPCPY @SC86295 05046500 BCTR 15,0 Correct for EX @SC86158 05047000 L 5,ADR Get string ptr @SC89215 05047500 EX 15,FSPTRAE Change to EBCDIC @SC89215 05048000 EX 15,FSPTRUP Upcase and dot to space @SC89215 05048500 B FSPCPY @SC86295 05049000 FSPTRAE TR 0(,5),ATOED @SC89301 05049500 FSPTRUP TR 0(,5),FSPUPDOT @SC89215 05050000 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05050500 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05051000 MVI 0(1),C'$' Default FN @SC86295 05051500 MVC UFM,DEST Default FM, can change by = = x @SC86295 05052000 B FSPCPY @SC86295 05052500 FSPHD MVC 0(8,1),=CL8'$' Default fn @SC86295 05053000 MVC 8(8,1),0(1) Default ft @SC86295 05053500 MVC 16(2,1),UFM Default fm @SC86295 05054000 L 2,ADR @SC86295 05054500 TR 0(256,2),FSPTAB Make valid fn chars @SC86295 05055000 B FSPCPY @SC86295 05055500 FSPSND TM FL5,SALL @SC88049 05056000 BZ *+10 @SC86295 05056500 MVC 16(2,1),ASTER Default FM for SEND @SC86295 05057000 B FSPASC @SC86295 05057500 FSPSN2 MVI 1(1),C'=' Foreign file name is same @SC86295 05058000 MVI 9(1),C'=' @SC86295 05058500 CTOKN NODOT,H=FSP2H,N=RTRN0 @SC89097 05059000 LA 1,L'JFNAM @SC86295 05059500 CLM 7,3,*-2 Does it fit? @SC86224 05060000 BNH *+6 Yes @SC86224 05060500 LR 7,1 Use what we can @SC86224 05061000 LR 3,0 @SC86295 05061500 STC 7,0(3) Save length @SC86224 05062000 LA 0,1(3) @SC86295 05062500 MVCL 0,6 Get fn, at least @SC86224 05063000 MVI TRTBL+C'.',2 See if valid CMS token @SC86224 05063500 MVI TRTBL+C'/',2 @SC86224 05064000 SR 2,2 @SC86224 05064500 TRT 1(9,3),TRTBL @SC86295 05065000 MVI TRTBL+C'.',0 @SC86224 05065500 MVI TRTBL+C'/',0 @SC86224 05066000 BCT 2,RTRN0 Not valid: must be complex string @SC86224 05066500 MVC FSPPTR,SCANPTR @SC86295 05067000 LA 2,3 @SC86295 05067500 FSPCNT CLI BRK,C',' @SC88306 05068000 BE FSPCNZ Take comma as end @SC88306 05068500 NTOKN N=FSPCNZ @SC88306 05069000 BCT 2,FSPCNT @SC86295 05069500 FSPCNZ MVC SCANPTR,FSPPTR Restore ptrs @SC86295 05070000 N 2,F1 @SC86295 05070500 BNZ RTRN0 Single token string @SC86295 05071000 LA 0,9(3) Get 2nd token @SC86295 05071500 MVI 0(3),0 Clear length again @SC86295 05072000 MVC FSPBADX,=C'type' @SC86295 05072500 CTOKN NOBRK,H=FSP2H,N=FSPMIS @SC89097 05073000 MVCL 0,6 @SC86295 05073500 B RTRN0 @SC86295 05074000 FSPTAK TM FSPFLG,FFGIV GIVE command? @SC88049 05074500 BO *+10 Yes, keep specific FM @SC87117 05075000 MVC 16(2,1),ASTER Default FM for TAKE @SC86295 05075500 MVC 8(8,1),=CL8'TAKE' @SC86295 05076000 FSPCPY LA 5,LFID(,1) Point to file options @SC89218 05076500 CTOKN NOBRK,H=FSPH,N=FSPZ,OPTS=0 @SC89218 05077000 TM FSPFLG,FFRCF @SC86295 05077500 BZ FSPCPN @SC86295 05078000 CLI 0(6),C'=' @SC86224 05078500 BE FSPREQ Go if RECEIVE = ... @SC86295 05079000 CLI 0(6),C'*' @SC86224 05079500 BE FSPINV @SC86295 05080000 FSPCPN BAL 14,FSPTOK Get fn @SC87034 05080500 MVC FSPBADX,=C'type' @SC86295 05081000 CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ @SC89218 05081500 CLI 0(6),C'=' @SC86224 05082000 BE FSPINV Go if RECEIVE xxx = @SC86295 05082500 TM FSPFLG,FFRCF @SC86295 05083000 BZ FSPCPT @SC86295 05083500 CLI 0(6),C'*' @SC86224 05084000 BE FSPINV Go if RECEIVE xxx * @SC86295 05084500 OI FL1,ROVR Overwrite received fname @SC86295 05085000 FSPCPT BAL 14,FSPTOK Get ft @SC87034 05085500 MVC FSPBADX,=C'mode' @SC86295 05086000 CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ @SC89218 05086500 TM FSPFLG,FFRCF @SC86295 05087000 BZ FSPCPM @SC86295 05087500 CLI 0(6),C'*' @SC86224 05088000 BE FSPINV @SC86295 05088500 FSPCPM DS 0H @SC89097 05089000 BAL 14,FSPTOK Get fm @SC87034 05089500 B RTRN0 @SC86295 05090000 * 05090500 FSPREQ MVC FSPBADX,=C'type' @SC86295 05091000 CTOKN H=FSPH,N=FSPZ,OPTS=FSPZ Get ft for RECEIVE = @SC89218 05091500 CLI 0(6),C'=' @SC86224 05092000 BNE FSPINV Go if FT is not = @SC86295 05092500 CLI 0(6),C'*' @SC86224 05093000 BE FSPINV Bad FM @SC86295 05093500 MVC FSPBADX,=C'mode' @SC86295 05094000 CTOKN FM,H=FSPH,N=FSPZ,OPTS=FSPZ Pick fm @SC89218 05094500 BAL 14,FSPTOK Use FM they specified @SC87034 05095000 MVC UFM,0(1) Use for all of file group @SC87034 05095500 B RTRN0 @SC87034 05096000 * 05096500 FSPTOK LR 8,0 Save start @SC87034 05097000 LR 9,1 And length @SC87034 05097500 MVCL 0,6 Copy token with padding @SC87034 05098000 LR 1,8 @SC87034 05098500 BCTR 9,0 Fix for TR @SC87034 05099000 EX 9,TRUPCAS Upcase the token @SC87034 05099500 BR 14 @SC87034 05100000 * 05100500 FSPDOTS LTR 1,7 Copy length-1 @SC89097 05101000 BNPR 14 Can't convert if just '.' @SC89097 05101500 LR 9,6 Copy start of token @SC89097 05102000 FSPDOTL CLI 1(9),C'.' Scan for '.', if any @SC89097 05102500 BE FSPDOTF Found one @SC89097 05103000 LA 9,1(,9) Keep looking @SC89097 05103500 BCT 1,FSPDOTL @SC89097 05104000 BR 14 Not found, ordinary token @SC89097 05104500 FSPDOTF LR 7,9 Found dot: break up token @SC89097 05105000 SR 7,6 Length-1 of stuff before dot @SC89097 05105500 LM 8,9,SCANPTR @SC89097 05106000 SR 9,1 Back up over brk + post-dot stuff @SC89097 05106500 AR 8,1 ... and increase length left @SC89097 05107000 STM 8,9,SCANPTR @SC89097 05107500 MVI BRK,C' ' Reset separator too @SC89218 05108000 BR 14 @SC89097 05108500 * 05109000 FSPZ LR 14,0 @SC86295 05109500 CLI 0(14),C' ' Any default given? @SC86295 05110000 BH RTRN0 Yes, use it @SC86295 05110500 FSPMIS MVC FSPBAD,=C'&MISSING' @SC86295 05111000 FSPINV LA 15,2 @SC86295 05111500 B FSPPTRS @SC86295 05112000 * 05112500 FSPH PTEXT '&FMTFSPC&FSPCPRM' @SC92300 05113000 CLI FSPFLG,FFSND SEND 1st? @SC89261 05113500 BE *+8 Yes, use whole message @SC89261 05114000 SH 4,=H'&FMTOPT' Chop off option part @SC92300 05114500 B FSP0H @SC86295 05115000 FSP2H PTEXT '&FORFSPC' @SC86295 05115500 FSP0H LA 15,1 @SC86295 05116000 FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05116500 FSPRET RET , @SC86295 05117000 * 05117500 * Non-parsing functions . . . 05118000 * 05118500 * Get unique filespec 05119000 FSPWRN LR 4,1 Save name ptr @SC86295 05119500 TM FSPFLG,FFENC @SC86295 05120000 BO FSPENC Encode name into buffer @SC86295 05120500 TM FSPFLG,FFDSP @SC86295 05121000 BO FSPDSP Copy name into buffer for display @SC86295 05121500 TM FL4,NMOK Already checked? @SC87012 05122000 BO RTRN0 Yes, ok @SC87012 05122500 MVC XFILE,0(1) Save original name @SC90033 05123000 LA 6,8+6(1) End of FT @BS86001 05123500 BCTR 6,0 @BS86001 05124000 CLI 0(6),C' ' Find end of token @BS86001 05124500 BE *-6 @BS86001 05125000 LA 5,10+1 Allowed retries @BS86001 05125500 LA 7,C'0' Extra character @BS86001 05126000 OI FL4,NMOK Assume it checks @SC87012 05126500 FSPSTA OPENF T,(4),E=RTRN0 Does it exist already? @SC86135 05127000 OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05127500 MVI 1(6),C'$' Yes, modify FT @BS86001 05128000 STC 7,2(6) Serialize @BS86001 05128500 LA 7,1(7) Bump counter @BS86001 05129000 BCT 5,FSPSTA @BS86001 05129500 PTEXT '&FILCLSN' @SC88049 05130000 B FSP0H Return error code @SC88049 05130500 * 05131000 * Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05131500 * substitution from JFSPEC, but disable subsequent subst. 05132000 * Return updated ptr in R15 05132500 FSPENC LA 1,JFSPEC Complex string? @SC86224 05133000 LA 5,JFNAM Remote file-spec @SC86155 05133500 BAL 14,PAKFOR @SC86224 05134000 BNZ FSPFILS Yes, tokens aren't used @SC86224 05134500 BAL 14,FSPFID Filename @HF86223 05135000 LA 7,1(7) Skip over period @HF86223 05135500 BAL 14,FSPFID Filetype @HF86223 05136000 FSPFILS MVI JFSPEC,0 Turn off string @SC86224 05136500 CLI JFN,C'=' Partial renaming? @SC86224 05137000 BE FSPENR Yes, keep it @SC86224 05137500 CLI JFT,C'=' @SC86224 05138000 BE FSPENR @SC86224 05138500 MVI JFN,C'=' Now use original name @SC86171 05139000 MVI JFT,C'=' @SC86171 05139500 FSPENR LR 15,7 Save ptr @SC86295 05140000 B FSPRET @SC86295 05140500 * 05141000 * Copy name at (R1) into (R7) buffer in display form 05141500 * Return updated ptr in R15 05142000 FSPDSP BAL 14,FSPDTK Filename @SC86295 05142500 BAL 14,FSPDTK Filetype @SC86295 05143000 MVC 0(2,7),0(4) Filemode @SC86295 05143500 LA 7,2(7) @SC86295 05144000 B FSPENR @SC86295 05144500 * 05145000 * Subroutine to detokenize a list into ASCII @SC86135 05145500 FSPFID MVC 0(8,7),0(4) Copy token @SC86135 05146000 CLI 0(5),C'=' Keep true name? @SC86171 05146500 BE *+10 Yes @SC86171 05147000 MVC 0(8,7),0(5) No, use override @SC86171 05147500 LA 1,8(7) End of token if no blanks @SC86135 05148000 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05148500 TR 0(8,7),ETOAD ASCII it @SC89301 05149000 LR 7,1 New end of string @SC86135 05149500 LA 4,8(4) Next token @SC86135 05150000 LA 5,8(5) @SC86171 05150500 MVI 0(7),ADOT Add an ASCII dot, just in case @SC86135 05151000 BR 14 @SC86135 05151500 * 05152000 * Subroutine to detokenize a list in EBCDIC @SC86295 05152500 FSPDTK MVC 0(8,7),0(4) Copy token @SC86135 05153000 LA 1,8(7) End of token if no blanks @SC86135 05153500 TRT 0(8,7),TRTBL Find 1st blank @SC86135 05154000 MVI 0(1),C' ' Add a BLANK @SC86295 05154500 LA 7,1(1) New end of string @SC86135 05155000 LA 4,8(4) Next token @SC86135 05155500 BR 14 @SC86135 05156000 * 05156500 * Subroutine to set up CMS token for copying @SC86224 05157000 CMSTOK8 LA 7,1(7) @SC86224 05157500 ICM 7,8,BLANK @SC86224 05158000 LA 1,8 @SC86224 05158500 BR 14 @SC86224 05159000 * 05159500 * Table to convert EBCDIC text to upper case + dot to blank @SC89215 05160000 FSPUPDOT DC (C'.')AL1(*-FSPUPDOT) @SC89215 05160500 DC C' ' @SC89215 05161000 DC (127-C'.')AL1(*-FSPUPDOT) @SC89215 05161500 HTBL 80,C1,C2,C3,C4,C5,C6,C7,C8,C9,8A,8B,8C,8D,8E,8F @SC89268 05162000 HTBL 90,D1,D2,D3,D4,D5,D6,D7,D8,D9,9A,9B,9C,9D,9E,9F @SC89268 05162500 HTBL A0,A1,E2,E3,E4,E5,E6,E7,E8,E9,AA,AB,AC,AD,AE,AF @SC89268 05163000 DC 080AL1(*-FSPUPDOT) @SC89215 05163500 * Valid CMS file name characters @SC86295 05164000 FSPTAB DC 64C'_',C' ' space @SC86295 05164500 DC 10C'_',C' ' dot @SC86295 05165000 DC 02C'_',C'+' plus @SC86295 05165500 DC 12C'_',C'$' dollar sign @SC86295 05166000 DC 04C'_',C'-' dash @SC86295 05166500 DC 12C'_',C'_' underscore @SC86295 05167000 DC 12C'_',C':#@' colon, pound sign, at sign@SC86295 05167500 DC 04C'_',C'ABCDEFGHI' a-i @SC86295 05168000 DC 07C'_',C'JKLMNOPQR' j-r @SC86295 05168500 DC 08C'_',C'STUVWXYZ' s-z @SC86295 05169000 DC 23C'_',C'ABCDEFGHI' A-I @SC86295 05169500 DC 07C'_',C'JKLMNOPQR' J-R @SC86295 05170000 DC 08C'_',C'STUVWXYZ' S-Z @SC86295 05170500 DC 06C'_',C'0123456789' 0-9 @SC86295 05171000 DC 06C'_' @SC86295 05171500 LOCALS , @SC86295 05172000 FSPBAD DS C'&INVALID' @SC92300 05172500 FSPBADF DS C' file' @SC92300 05173000 FSPBADX DS C'name' @SC86295 05173500 FSPBL EQU *-FSPBAD Length of composite message @SC92300 05174000 FSPPTR DS XL8 Saved scan ptrs @SC86295 05174500 FSPFLG DS X Filespec flags @SC86295 05175000 FSPEC EXIT @SC86295 05175500 TITLE 'KHELP routine - perform HELP command' 05176000 * Handle HELP command, rest of string given by SCANPTR. 05176500 KHELP ENTER , @SC86355 05177000 LR 8,6 Save ptr to command @SC88043 05177500 SR 5,5 Clear length of extra word @SC90264 05178000 NTOKN N=KHLI See if subcommand given @SC86355 05178500 L 1,=A(USNCMD) Command table @SC87117 05179000 KHSCAN SCAN (1),KHLF,NODISP @SC86355 05179500 WTEXT '&BADSBCM' Not found @SC86355 05180000 RET , @SC86355 05180500 KHLF CLM 7,8,F0 Just '?' @SC86355 05181000 BE RTRN Yes, done @SC86355 05181500 C 1,=A(USNCSET) Is it the set command? @SC91320 05182000 BNE KHNORM Normal subcommands @SC90264 05182500 LA 4,KWNAME(,1) Set ptr to 'SET' string @SC91320 05183000 IC 5,KWMIN(,1) and actual length of abbreviation @SC91320 05183500 LA 5,1(,5) @SC91320 05184000 NTOKN N=KHSET Just SET -- no parameter @SC90264 05184500 L 1,=A(SETCMDKW) Keyword table @SC90264 05185000 B KHSCAN Go back and check parameter @SC90264 05185500 KHNORM DS 0H @SC90264 05186000 LA 6,KWNAME(,1) Ptr to name in table @SC90264 05186500 SR 7,7 @SC90264 05187000 IC 7,KWMIN(,1) Length - 1 of abbrev @SC90264 05187500 LA 7,1(,7) @SC90264 05188000 B KHLJ Create command string for typing @SC90264 05188500 KHSET SR 7,7 Plain SET with no parameter @SC90264 05189000 B KHLJ Do it @SC90264 05189500 KHLI PTEXT 'KERMITCM',AREG=6,LREG=7 @SC90264 05190000 KHLJ DS 0H @SC90264 05190500 MVC KHLPBF+8(8),KRMNAM Set up filename @SC90264 05191000 MVC KHLPBF+16(10),=CL10'HELPCMS * ' @SC90264 05191500 CLI KRMNAM,C'*' Was it a START? @SC90264 05192000 BE KHLDF Yes, use default @SC86355 05192500 CLI KRMNAM,X'FF' Nothing at all? @SC90264 05193000 BE KHLDF That's right, use default @SC90264 05193500 FSSTATE FSCB=KHLPBF,ERROR=KHLDF See if special help @SC90264 05194000 B KHLGEN @SC90264 05194500 KHERR WTEXT '&NOHELPF' Not found @SC90264 05195000 RET , @SC90264 05195500 KHLDF MVC KHLPBF+8(8),=CL8'KERMIT' @SC90264 05196000 FSSTATE FSCB=KHLPBF,ERROR=KHERR Give up if not found @SC90264 05196500 KHLGEN MVC KHLPBF+24(2),24(1) Copy filemode from FST @SC90264 05197000 MVC KHLPBF(8),=CL8'&TYPCMD ' @SC90264 05197500 MVC KHLPBF+26(30),=CL30' ( MEMBER' @SC90264 05198000 LA 14,KHLPBF+48 @SC90264 05198500 LR 15,5 @SC90264 05199000 MVCL 14,4 Copy 'SET' to buffer, if needed @SC90264 05199500 LR 15,7 @SC90264 05200000 MVCL 14,6 Copy 'subcmd' to buffer @SC90264 05200500 MVC KHLPBF+56(8),=8X'FF' @SC90264 05201000 LA 0,KHLPBF Set up for system @SC90264 05201500 LA 6,64 Length of string @SC90264 05202000 NI FL4,255-UCMD @SC90264 05202500 KCALL SUPFNC,3 Do it @SC86355 05203000 CH 15,=H'32' Library problem? @SC92003 05203500 BNE RTRN No, just give up @SC92003 05204000 MVC KHLPBF(8),=CL8'HELP' Switch to basic HELP cmd @SC92003 05204500 MVC KHLPBF+16(8),=8X'FF' @SC92003 05205000 LA 6,24 Length of new string (R0 still ok)@SC92003 05205500 KCALL SUPFNC,3 Do it @SC92003 05206000 RET , @SC86355 05206500 LOCALS , 05207000 KHLPBF DS 8CL8 @SC90264 05207500 KHELP EXIT , @SC87007 05208000 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05208500 SUPFNC ENTER @SC86295 05209000 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05209500 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05210000 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05210500 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05211000 * 2 -> Clean up afterwards and stop interception 05211500 * 3 -> Execute host command with or without interception 05212000 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05212500 * 4 -> Execute CP command with or without interception 05213000 * R0->text, R6=len 05213500 * 5 -> Stop interception if going 05214000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05214500 * 7 -> Test for stacked lines, return number in R15 05215000 * 8 -> Log off (doesn't return!) 05215500 * 9 -> Wait specified time 05216000 * 10-> Return clock time in R15 (centisec) 05216500 * 11-> Setup up new prompt string at (R0) 05217000 BCT 1,ICPFIN @SC86158 05217500 * Start interception, initialize ptrs @SC86158 05218000 MVI ERRNUM,ERRNOE OK @SC86158 05218500 L 1,WBUF Output buffer @SC90264 05219000 LA 0,2048(,1) Skip over some, to be safe @SC90264 05219500 A 1,F64KP End of buffer @SC90264 05220000 LR 15,0 @SC86158 05220500 STM 15,0,TXTPTR Save @SC86158 05221000 STM 0,1,SVCOPTR @SC86158 05221500 SR 1,0 Get length @SC86158 05222000 L 15,=X'15000000' @SC86158 05222500 MVCL 0,14 Fill with NL (X'15') @SC86158 05223000 MVI SVCSNAG+1,0 370-mode PSW @SC89235 05223500 LA 14,SVCOPSW+3 Assume page 0 version @SC89235 05224000 TM FLGXA,XACMS XA mode? @SC89235 05224500 BZ SFCSVCST No, fine @SC89235 05225000 MVI SVCSNAG+1,X'08' XA-mode PSW @SC89235 05225500 AIF ('&KTAG' NE 'XA').CMSXA1 @SC90067 05226000 L 1,ASVCSECT Ptr to SVC info @SC89235 05226500 USING SVCSECT,1 @SC89235 05227000 LA 14,SVCOCODE Use XA version @SC89235 05227500 .CMSXA1 ANOP @SC90067 05228000 SFCSVCST ST 14,SVCOCPTR Correct ptr to SVC code @SC89235 05228500 CLC SVCNPSW,SVCSNAG Already set up? @SC86158 05229000 BE RTRN0 Yes, but how? @SC86295 05229500 MVC SAVENPSW,SVCNPSW @SC86158 05230000 MVC TYPSAV,ADMSCWR @SC86283 05230500 DMSKEY NUCLEUS @SC86283 05231000 MVC SVCNPSW,SVCSNAG Set up interception (SVC) @SC86283 05231500 MVC ADMSCWR,=A(ICPTYP) (BALR) @SC86283 05232000 DMSKEY RESET @SC86283 05232500 B RTRN0 @SC86295 05233000 * Clean up after interception @SC86295 05233500 ICPFIN BCT 1,ICPHST @SC86158 05234000 L 5,SVCOPTR End of text @SC86158 05234500 ST 5,TXTPTR+4 Save @SC86158 05235000 B ICPRST1 Now restore interrupts @SC86295 05235500 * Restore SVC interrupt vector @SC86158 05236000 ICPRST BCT 1,SFCLIN @SC86295 05236500 ICPRST1 CLC SVCNPSW,SVCSNAG @SC86295 05237000 BNE RTRN0 OK @SC86295 05237500 DMSKEY NUCLEUS @SC86283 05238000 MVC SVCNPSW,SAVENPSW @SC86283 05238500 MVC ADMSCWR,TYPSAV @SC86283 05239000 NI MSGFLAGS,255-NOTYPING @SC88309 05239500 DMSKEY RESET @SC86283 05240000 B RTRN0 05240500 * Avoid user-area CMS commands, otherwise execute command at @SC86158 05241000 * (R0) already tokenized. Save return code. @SC86158 05241500 ICPHST BCT 1,ICPCP @SC86158 05242000 TM FL4,UCMD User CMS command? @SC86295 05242500 BZ ICPCMS0 No, already tokenized @SC86295 05243000 LM 0,1,SCANPTR @SC86295 05243500 LTR 15,0 @SC87034 05244000 BNP ICPCMIL Nothing there @SC87034 05244500 DMSKEY NUCLEUS Enter Key 0 @SC86295 05245000 L 15,ASCANN @SC86295 05245500 BALR 14,15 Tokenize data @SC86295 05246000 LR 3,0 Length of tokenized list @SC90073 05246500 BCTR 3,0 Get length for TR @SC90073 05247000 EX 3,TRUPCAS Convert to upper case @SC90073 05247500 LR 0,15 @SC86295 05248000 DMSKEY RESET Restore user key @SC86295 05248500 LTR 15,0 Did SCANN fail? @SC86295 05249000 BNZ ICPCMIL Yes @SC86295 05249500 C 3,F8 Did we get anything? @SC90073 05250000 BNH ICPCMIL No, just a fence. Give up @SC90073 05250500 LR 0,1 @SC86295 05251000 ICPCMS0 LR 3,0 @SC86295 05251500 CLC =C'CP ',0(3) CP command? @SC86158 05252000 BE ICPCMSCP Yes, do it @SC86158 05252500 MVI TRTBL+C'%',1 Possible wildcard chars @SC90037 05253000 MVI TRTBL+C'*',1 @SC90037 05253500 TRT 0(8,3),TRTBL See if any % or * in FN @SC90037 05254000 MVI TRTBL+C'%',0 Restore TRTBL @SC90037 05254500 MVI TRTBL+C'*',0 @SC90037 05255000 BZ *+12 No wild chars found @SC90037 05255500 CLI 0(1),C' ' Maybe just a blank? @SC90037 05256000 BNE ICPCMIL No, illegal @SC90037 05256500 MVC IFT,=CL8'EXEC' @SC86158 05257000 MVC IFM,ASTER Search all disks @SC86158 05257500 TM OPTFLAGS,NOIMPEX EXEC's allowed? @SC86158 05258000 BO ICPCMSM No, try for module @SC86158 05258500 TM FL4,UCMD User CMS command? @SC86158 05259000 BZ ICPCMSM No, avoid EXEC's @SC86158 05259500 ICPCMSA MVC IFN,0(3) @SC86158 05260000 LA 4,1 @SC86158 05260500 TM FL4,UCMD User CMS command? @SC90264 05261000 BO ICPCMSS Yes, might have abbrevs @SC90264 05261500 SR 4,4 No, disable abbrevs @SC90264 05262000 ICPCMSS FSSTATE FSCB=IFSCB,ERROR=ICPABBR See if exists @SC90037 05262500 LR 5,1 @SC86295 05263000 USING FSTSECT,5 @SC90037 05263500 TM FL4,UCMD User CMS command? @SC90264 05264000 BZ ICPCMSU No, do it now @SC90264 05264500 DMSEXS MVC,0(8,3),IFN Found, copy full name @SC86158 05265000 CLI IFT,C'E' EXEC? @SC86158 05265500 BNE ICPCMSU No, module. Check it @SC86158 05266000 S 3,F8 Back up to EXEC in COMBUF @SC86158 05266500 DMSEXS MVC,NUCPLBEG,NUCPLCMD Argst begins w/ cmd name @SC89264 05267000 B ICPCMSX Do it @SC86158 05267500 ICPABBR LTR 4,4 Already tried abbrev? @SC86158 05268000 BZ ICPCMSM Yes, give up @SC86158 05268500 TM OPTFLAGS,NOABBREV Allowed? @SC86158 05269000 BO ICPCMSM No, just do it @SC86158 05269500 DMSKEY NUCLEUS @SC86158 05270000 LM 0,1,0(3) Get name entered @SC86158 05270500 L 15,AABBREV Look up abbreviation @SC86158 05271000 BALR 14,15 @SC86158 05271500 LR 4,15 Save RC @SC86158 05272000 DMSKEY RESET Return to normal @SC86158 05272500 LTR 4,4 Did we find one? @SC86158 05273000 BNZ ICPCMSM No, give up @SC86158 05273500 STM 0,1,IFN Yes, try it @SC86158 05274000 B ICPCMSS Now R4=0, don't loop @SC86158 05274500 ICPCMSM CLI IFT,C'M' @SC86158 05275000 BE ICPCMEX Already looked @SC90037 05275500 MVC IFT,=CL8'MODULE' @SC86158 05276000 B ICPCMSA Start over again @SC86158 05276500 ICPCMEX CLC =CL8'EXEC',IFN Are we looking for an EXEC? @SC90037 05277000 BNE ICPCMSX No, just execute it @SC90037 05277500 MVC IFN,8(3) Yes, see if it exists @SC90037 05278000 MVC IFT,=CL8'EXEC' @SC90037 05278500 FSSTATE FSCB=IFSCB,ERROR=ICPCMIL See if exists @SC90037 05279000 B ICPCMSX @SC90037 05279500 ICPCMSU CLI FSTFV,C'F' System-key transient? @SC90037 05280000 BE ICPCMSX OK, no problem @SC86158 05280500 MVC IFM,FSTM Get right mode letter @SC86158 05281000 DROP 5 @SC90037 05281500 LA 2,CMD Buffer for 1st record of module @SC86295 05282000 MVC 4(4,2),=A(KERMIT) In case of failure @SC86295 05282500 FSREAD FSCB=IFSCB,BUFFER=(2) Get header record @SC86295 05283000 FSCLOSE FSCB=IFSCB @SC86158 05283500 CLC =A(KERMIT),CMD+4 Check beginning adr @SC86158 05284000 BH ICPCMSX Below Kermit, assume it's ok @SC89023 05284500 CLC =XL4'20000',=A(KERMIT) Are we both user-area? @SC89023 05285000 BNH ICPCMIL User-area, forbid it @SC86158 05285500 ICPCMSX HOST 0(3),E=*+4,EPL=YES Accept errors, use ext.PL. @SC89264 05286000 LTR 6,15 Save return code @SC86295 05286500 BNM SFCRC @SC86295 05287000 TM OPTFLAGS,NOIMPCP @SC86295 05287500 BO ICPCMIL No implied CP commands @SC86295 05288000 TM FL4,UCMD User command? @SC86295 05288500 BO ICPCMSCP Yes, maybe it's for CP @SC86295 05289000 ICPCMIL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05289500 B RTRNM1 @SC86295 05290000 ICPCMP CLC 1(,4),0(3) Partial token matching @SC86158 05290500 IFSCB FSCB 'X X',BSIZE=80,RECNO=1,RECFM=V @SC86158 05291000 IFN EQU IFSCB+8,8 @SC90037 05291500 IFT EQU IFN+8,8 @SC90037 05292000 IFM EQU IFT+8,2 @SC90037 05292500 * Execute CP command sent to CMS (assumed SCANN'ed) @SC86158 05293000 ICPCMSCP L 0,NUCPLCMD Get cmd ptr @SC86158 05293500 L 6,NUCPLEND @SC86158 05294000 SR 6,0 Get length @SC86158 05294500 LA 1,1 Simulate normal entry @SC86158 05295000 * Execute CP command at (R0) with text interception @SC86158 05295500 ICPCP BCT 1,ICPRST @SC86158 05296000 LR 1,0 Copy ptr for upcasing @SC87034 05296500 LTR 4,6 @SC87034 05297000 BNP ICPCMIL Nothing there @SC87034 05297500 BCTR 4,0 @SC87034 05298000 EX 4,TRUPCAS @SC87034 05298500 CLC SVCNPSW,SVCSNAG @SC86283 05299000 BNE ICPCDG Not intercepting, just do it @SC86283 05299500 KCALL SETMSG,3 Restore CP settings @SC86158 05300000 LM 1,2,SVCOPTR Response buffer @SC86158 05300500 SR 2,1 Get buffer length @SC86158 05301000 L 7,=F'8192' Max length from CP @SC86158 05301500 CR 7,2 Do we have that much? @SC86158 05302000 BNH *+6 @SC86158 05302500 LR 7,2 Use what we have @SC86158 05303000 LR 2,7 Remember @SC86158 05303500 ICM 6,8,BLANK @SC86158 05304000 DIAG 0,6,8 Issue command @SC86158 05304500 BZ *+6 @SC86158 05305000 LR 7,2 Not likely: filled buffer @SC86158 05305500 A 7,SVCOPTR @SC86158 05306000 BCTR 7,0 Scan back over any extra X'15' @SC86158 05306500 CLI 0(7),X'15' @SC86158 05307000 BE *-6 @SC86158 05307500 LA 7,2(7) Keep one X'15' @SC86158 05308000 C 7,SVCOPTR+4 Be careful of end @SC86158 05308500 BNH *+8 OK @SC86158 05309000 L 7,SVCOPTR+4 Got past it somehow @SC86158 05309500 ST 7,SVCOPTR @SC86158 05310000 KCALL SETMSG,2 Change CP settings again @SC86158 05310500 B ICPRC @SC86295 05311000 * 05311500 ICPCDG DIAG 0,6,8 Issue command @SC86283 05312000 ICPRC C 6,F1 Illegal command? @SC86295 05312500 BE ICPCMIL Yes @SC86295 05313000 * Issue return code msg if needed @SC86295 05313500 SFCRC LTR 4,6 Check RC @SC86295 05314000 BZ SFCZRC RC=0 @SC86158 05314500 LR 15,6 @SC90264 05315000 TM FL4,UCMD User cmd? @SC86316 05315500 BZ RTRN No. No message, just rc in R15 @SC90264 05316000 MVC CMD(2),=C'R(' Set up message @SC86209 05316500 LA 15,CMD+2 @SC86209 05317000 BAL 2,EDDEC Edit RC into msg @SC86295 05317500 MVI 0(15),C')' Format is R(rc) @SC86209 05318000 LA 0,1(15) @SC86268 05318500 LA 1,CMD Start of edited string @SC86209 05319000 SR 0,1 Length @SC86268 05319500 WTEXT (1),(0) @SC86268 05320000 SFCZRC LR 15,6 @SC86295 05320500 MVI ERRNUM,ERRNOE No errors @SC86295 05321000 B RTRN @SC86295 05321500 * 05322000 SFCLIN BCT 1,SFCSTK @SC86295 05322500 * Retrieve original command line arguments, if any @SC86295 05323000 * Return code =0 if yes, =1 if no @SC86295 05323500 * Leave string in CBUF buffer (up to 512), length in CLEN @SC89235 05324000 LM 5,6,ORGR0 Original R0,R1 @SC87253 05324500 CLI 0(6),255 @SC86171 05325000 BE RTRN1 Go if, e.g., just 'START' @SC86171 05325500 LA 6,8(6) Ok, point to arguments @SC86171 05326000 CLI 0(6),255 @SC86171 05326500 BE RTRN1 Go if nothing on cmd 05327000 L 8,CBUF A safe data area @SC89235 05327500 LA 9,512 Length of buffer @SC89235 05328000 CLI ORGR1,1 @SC87253 05328500 BL SFCCMDK R1 hi order byte is 0 05329000 CLI ORGR1,11 @SC87253 05329500 BH SFCCMDK R1 hi order byte is > X'0B' 05330000 LM 6,7,4(5) Address of arguments, end @SC89235 05330500 SR 7,6 Get length @SC89235 05331000 CR 9,7 How much info? @SC89235 05331500 BNH *+6 Ok @SC89235 05332000 LR 9,7 Copy only what's there @SC89235 05332500 ST 9,CLEN Save command length @SC89235 05333000 MVCL 8,6 @SC89235 05333500 B RTRN0 @SC89235 05334000 * 05334500 SFCCMDK AR 9,8 Ptr to end of buffer @SC89235 05335000 SFCCMDKL MVC 0(8,8),0(6) Copy token @SC89235 05335500 LA 1,8(,8) Char after token @SC89235 05336000 TRT 0(8,8),TRTBL Find blank @SC89235 05336500 MVI 0(1),C' ' Add a blank, in case @SC86295 05337000 LA 8,1(,1) Skip over blank @SC89235 05337500 LA 6,8(6) Skip a CMS token 05338000 CLI 0(6),255 05338500 BE SFCCMDKM End of str, quit copying @SC89235 05339000 CR 8,9 Is it too long? @SC89235 05339500 BL SFCCMDKL Loop if more room @SC89235 05340000 SFCCMDKM S 8,CBUF Length = current pos - beginning @SC89235 05340500 ST 8,CLEN Save command length @SC89235 05341000 B RTRN0 @SC86295 05341500 * 05342000 * Test for stacked commands @SC86295 05342500 * return code = number of stacked lines @SC86295 05343000 SFCSTK BCT 1,SFCKIL @SC86295 05343500 LH 15,NUMFINRD Pending lines @SC86295 05344000 A 15,NUCNLSTK Lines in program stack @SC86295 05344500 B RTRN @SC86295 05345000 * 05345500 * Log out @SC86295 05346000 SFCKIL BCT 1,SFCWT @SC86295 05346500 CPCMD 1,0,'LOGOFF' @SC86295 05347000 * 05347500 * Wait specified time in R0 (sec) 05348000 SFCWT BCT 1,SFCCLK @SC86295 05348500 LINEDIT TEXT='SL ..... SEC',DOT=NO,DISP=CPCOMM, +05349000 SUB=(DEC,(0)) @SC86184 05349500 L 1,=A(S1INTFL) No, set flag for interrupt @SC91095 05350000 OI 0(1),ATN @SC91095 05350500 B RTRN0 @SC86295 05351000 * 05351500 * Return time in centisec in R15 05352000 SFCCLK BCT 1,SFCPRP @SC87351 05352500 STCK TMPDW Store TOD clock @SC86295 05353000 LM 14,15,TMPDW @SC86295 05353500 SLDL 14,8 Take mod 204 days @SC86295 05354000 SRDL 14,20 Get in microsec @SC86295 05354500 D 14,=F'10000' Get in centisec @SC86295 05355000 B RTRN @SC86295 05355500 * 05356000 * Set up prompt string @SC89334 05356500 SFCPRP ICM 4,1,S1HND See if handshake is defined @SC89334 05357000 BZ RTRN0 No, skip it @SC89334 05357500 LR 1,0 Ptr to prompt string @SC89334 05358000 BCTR 1,0 Ptr to prompt string length @SC89334 05358500 SR 2,2 @SC89334 05359000 ICM 2,1,0(1) Get length @SC89334 05359500 BZ RTRN0 No prompt, leave it to system @SC89334 05360000 LA 3,0(2,1) Point to last character @SC89334 05360500 CLM 4,1,0(3) Is it the handshake? @SC89334 05361000 BE RTRN0 Yes, assume all is well @SC89334 05361500 STC 4,1(,3) No, tack one onto string @SC89334 05362000 LA 2,1(,2) And update length @SC89334 05362500 STC 2,0(,1) @SC89334 05363000 B RTRN0 @SC89334 05363500 TITLE 'SVC interceptor, executed in system protect key' 05364000 USING ICPTYP,15 @SC86283 05364500 ICPTYP STM 12,14,SVCSV1 Save regs @SC86283 05365000 L 13,SVCSNAG+4 Addressability @SC86283 05365500 DROP 15 05366000 USING SVCEXIT,13 @SC86283 05366500 B ICPTGO Grab it @SC86283 05367000 SVCEXIT STM 12,13,0 Save regs @SC86158 05367500 BALR 13,0 Addressability @SC86158 05368000 USING *,13 @SC86158 05368500 L 13,SVCSNAG+4 Addressability @SC86283 05369000 USING SVCEXIT,13 @SC86283 05369500 ICM 13,8,SVCEXIT Flag for SVC entry @SC86283 05370000 MVC SVCSV1(8),0 @SC86158 05370500 STM 14,15,SVCSV2 @SC86158 05371000 L 12,AFVS @SC86158 05371500 USING FVSECT,12 @SC86158 05372000 TM UFDBUSY,ABNBIT ABEND in progress? @SC86158 05372500 BO SVCCNCL @SC86158 05373000 L 14,SVCOCPTR Correct ptr to SVC code @SC89235 05373500 CLI 0(14),13 ABEND? @SC89235 05374000 BE SVCCNCL @SC86158 05374500 CLI 0(14),203 @SC89235 05375000 BE SVC203T Could be DMSABN @SC86158 05375500 CLI 0(14),204 Used only in CMS 5.5 and above @SC89235 05376000 BE *+12 @SC89235 05376500 CLI 0(14),202 @SC89235 05377000 BNE SVCGO Ok, do it @SC86158 05377500 CLC =CL8'TYPLIN',0(1) WRTERM? @SC86158 05378000 BNE SVCGO No, do it @SC86158 05378500 ICPTGO LM 14,15,SVCOPTR Output ptrs @SC86158 05379000 SR 15,14 Length left @SC86158 05379500 LA 12,255 Limit @SC86158 05380000 CH 12,14(1) Buffer length @SC86295 05380500 BNH *+8 Too big @SC86158 05381000 LH 12,14(1) Ok, use it @SC86295 05381500 LTR 12,12 @SC86158 05382000 BNP ICPTRET @SC86283 05382500 CR 12,15 Enough room? @SC86283 05383000 BH ICPTRET No @SC86283 05383500 ICM 15,7,9(1) Buffer address @SC86295 05384000 TM MSGFLAGS,NOTYPING @SC88309 05384500 BO ICPTRET HT is in effect @SC88309 05385000 TM 13(1),X'40' Error message? @SC88309 05385500 BZ *+8 No, keep whole text @SC88309 05386000 DIAG 15,12,X'5C' Adjust according to EMSG @SC88309 05386500 LTR 12,12 Anything to show? @SC88309 05387000 BNP ICPTRET Not anymore @SC88309 05387500 BCTR 12,0 Set up for mvc @SC86158 05388000 EX 12,SVCCOPY Move to WBUF @SC86158 05388500 LA 14,2(12,14) New end @SC86158 05389000 TM 13(1),X'80' Suppress NL? @SC88309 05389500 BZ *+6 No, keep it @SC88309 05390000 BCTR 14,0 Yes, append next line @SC88309 05390500 ST 14,SVCOPTR @SC86158 05391000 ICPTRET SR 15,15 Success @SC86283 05391500 CLM 13,8,SVCEXIT Was it an SVC? @SC86283 05392000 BE SVCDONE Yes @SC86283 05392500 LM 12,14,SVCSV1 Restore regs @SC86283 05393000 BR 14 Return @SC86283 05393500 SVCDONE L 12,SVCOPSW+4 Return adr @SC86158 05394000 CLI 0(12),0 Error adr given? @SC86158 05394500 BNE SVCRET @SC86158 05395000 LA 14,4(12) Yes, skip over @SC86158 05395500 SVCSKP STCM 14,7,SVCOPSW+5 @SC86158 05396000 SVCRET LM 12,14,SVCSV1 Restore @SC86158 05396500 SR 15,15 'success' @SC86158 05397000 LPSW SVCOPSW Return @SC86158 05397500 SVCCOPY MVC 0(,14),0(15) @SC86158 05398000 * 05398500 SVC203T L 12,SVCOPSW+4 Code ptr @SC86158 05399000 SVCABNT CLI 1(12),11 DMSABN? @SC86158 05399500 BNE SVCGO No, do it @SC86158 05400000 SVCCNCL MVC SVCNPSW,SAVENPSW Cancel interception @SC86158 05400500 MVC ADMSCWR,TYPSAV @SC86283 05401000 SVCGO MVC 0(8,0),SAVENPSW Proper SVC handler @SC86158 05401500 LM 12,15,SVCSV1 @SC86158 05402000 LPSW 0 @SC86158 05402500 * Storage for SVC interception @SC86158 05403000 SAVENPSW DS D SYSTEM SVC NPSW @SC86158 05403500 SVCSNAG DC A(0,SVCEXIT) My replacement @SC86158 05404000 SVCSV1 DS 2F Saved 12,13 @SC86158 05404500 SVCSV2 DS 2F Saved 14,15 @SC86158 05405000 SVCOPTR DS 2F Buffer output and end ptrs @SC86158 05405500 SVCOCPTR DS A Correct ptr to SVC code @SC89235 05406000 TYPSAV DS F Saved system address @SC86283 05406500 LOCALS , @SC86295 05407000 SUPFNC EXIT @SC86158 05407500 TITLE 'TERMIO Routine - Handle terminal I/O' 05408000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05408500 * successfull, R15 returns transferred byte count (else returns -1). 05409000 * Command code is in R0: 05409500 * 1 => Open line for I/O 4 => Write packet 05410000 * 2 => Close line 5 => Read packet 05410500 * 3 => Reset line status after ( 6 => Write message ) not used 05411000 * environment changes 05411500 * 05412000 TERMIO ENTER 05412500 SR 15,15 OK @SC86295 05413000 BCT 0,TRMCLS @SC86295 05413500 * Open terminal line for protocol 05414000 WAITT 05414500 STAX BR14 Ingore attention interrupts 05415000 MVI RIOC,X'80' Nothing saved @SC86295 05415500 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05416000 B TRMSPRP @SC87275 05416500 * Close terminal line after protocol transfer 05417000 TRMCLS BCT 0,TRMRSET @SC86295 05417500 STAX 05418000 B RTRN0 @SC86295 05418500 * (Re)set terminal characteristics to suit environment 05419000 TRMRSET BCT 0,TRMRW @SC86295 05419500 B RTRN0 @SC86295 05420000 * 05420500 * Perform I/O request 05421000 TRMRW BCT 0,TRMRD @SC87275 05421500 CLI WRRD,0 Write/read? @SC87275 05422000 BE TRMWO No, do it immediately @SC87275 05422500 MVC RIOPRP(8),0(1) Yes, save stuff for prompt @SC87275 05423000 CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 05423500 BNE RTRN0 No @SC92030 05424000 SR 0,0 Clear before every packet @SC92030 05424500 KCALL SCRNIO @SC92030 05425000 XI FL3,FCLRF Flip switch for skipping @SC92030 05425500 TM FL3,FCLRF Skipping now? @SC92030 05426000 BZ RTRN0 Not this time @SC92030 05426500 WRTERM ' ' Yes, skip two lines @SC92030 05427000 WRTERM ' ' @SC92030 05427500 B RTRN0 @SC87275 05428000 TRMWO MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05428500 B TRMEX Do the write @SC87275 05429000 TRMRD TS TRMFLG @SC87275 05429500 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05430000 * 05430500 TRMEX SLA 0,4 @SC87275 05431000 LR 2,0 @SC92180 05431500 SRA 2,1 Index * 8 = offset to output stuff@SC92180 05432000 LA 8,TRMPLS @SC87275 05432500 AR 8,0 Get appropriate CCW skeleton @SC86295 05433000 MVC 9(3,8),1(1) Copy adr @SC86295 05433500 MVC 14(2,8),6(1) Copy len @SC86295 05434000 LA 1,8(2,8) Ptrs for output @SC92180 05434500 L 4,0(,1) Remember them for logging data @SC92180 05435000 LH 5,6(,1) @SC92180 05435500 LA 2,8 Lenth of ptrs @SC92180 05436000 LA 0,C'w' @SC92180 05436500 BAL 7,SCRLOG Log it @SC92180 05437000 LA 1,0(,4) Ptr to buffer @SC92180 05437500 LR 2,5 Lenth of buffer @SC92180 05438000 LA 0,C'd' @SC92180 05438500 BAL 7,SCRLOG Log it @SC92180 05439000 HOST 0(8) Issue command @SC86295 05439500 CLC TRMPLS,0(8) Write only? @SC92180 05440000 BE TRMRLEN @SC92180 05440500 LA 1,8(,8) Ptr for input @SC92180 05441000 LA 2,8 Lenth of ptrs @SC92180 05441500 LA 0,C'r' @SC92180 05442000 BAL 7,SCRLOG Log it @SC92180 05442500 L 1,8(,8) @SC92180 05443000 LA 1,0(,1) Ptr to buffer @SC92180 05443500 LH 2,14(,8) @SC92180 05444000 LA 0,C'd' @SC92180 05444500 BAL 7,SCRLOG Log it @SC92180 05445000 TRMRLEN LH 15,14(,8) Number of chars xfer'd @SC92180 05445500 TRMSPRP LA 0,S1EOL Reinstate "normal" prompt @SC87275 05446000 LA 1,2 @SC87275 05446500 CLI S1HND,0 Handshake desired? @SC87275 05447000 BNE *+6 Yes, ok @SC87275 05447500 BCTR 1,0 No, send just the EOL @SC87275 05448000 STM 0,1,RIOPRP @SC87275 05448500 RET @SC86295 05449000 * 05449500 TRMPLS DS 0F Terminal I/O plists @SC86295 05450000 * WRTERM Plist during Kermit protocol 05450500 DC CL8'TYPLIN' 05451000 DC X'01',AL3(*-*) Send buffer address @SC86190 05451500 DC C'B',X'92' B=Black,02=No xlate,90=Long @TB86218 05452000 DC H'0' Buffer length 05452500 * RDTERM plist during RPACK 05453000 DC CL8'WAITRD' 05453500 DC X'01',AL3(*-*) Rcv buffer addr @SC86190 05454000 DC C'*',C'B' *:long, B:prompt/direct @SC87201 05454500 DC AL2(0) Input data length 05455000 RIOPRP DC A(0,1) Prompt @SC87275 05455500 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05456000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05456500 * successfull, R15 returns transferred byte count (else returns -1). 05457000 * Command code is in R0: 05457500 * 0 => Clear screen on console (not comm line) @SC90045 05458000 * 1 => Open screen for I/O 4 => Write packet 05458500 * 2 => Close screen 5 => Read packet 05459000 * 3 => Reset screen status after 6 => Write message (no ATTN) 05459500 * environment changes 7 => Read screen buffer 05460000 * 05460500 * CCW Flags, WCC flag bits, CSW flags: 05461000 CC EQU X'40' Command chaining @SC86159 05461500 SLI EQU X'20' Suppress Incorr Len Ind 05462000 ATN EQU X'80' Attention 05462500 CE EQU X'08' Channel end 05463000 DE EQU X'04' Device end 05463500 UC EQU X'02' Unit check 05464000 UE EQU X'01' Unit exception 05464500 CPBRK EQU ATN+CE+DE+UC CP break-in 05465000 * 05465500 SCRNIO ENTER ALT @SC92180 05466000 LTR 0,0 @SC90045 05466500 BZ SCRCLR @SC90045 05467000 STC 0,CONSOPR Save command code @LP88158 05467500 BCT 0,SCRCLS @SC86295 05468000 * Set up for transparent I/O 05468500 L 1,=A(IDEFS) CSECT of initializations @SC90173 05469000 USING DEFS,1 Mapped via DSECT @SC90173 05469500 LA 2,S1DATA Series/1 introducer @SC90173 05470000 LA 3,S1ORDL+2 Length + 2 @SC90173 05470500 CLI TRMTP,C'S' @SC90173 05471000 BE SCRPRSET Do it @SC90173 05471500 LA 2,GRDATA Graphics introducer @SC90173 05472000 LA 3,GRDL+2 Length + 2 @SC90173 05472500 CLI TRMTP,C'G' @SC90173 05473000 BE SCRPRSET Do it @SC90173 05473500 LA 2,AEADAT AEA introducer @SC90173 05474000 LA 3,AEAL+2 @SC90173 05474500 DROP 1 @SC90173 05475000 SCRPRSET LR 5,3 @SC90173 05475500 LA 4,S1EOL+2 Get start of command buffer @SC90173 05476000 SR 4,5 @SC90173 05476500 STM 4,5,S1XOPL Set up prompt plist @SC90173 05477000 S 5,F2 Deduct stuff already there @SC90173 05477500 MVCL 4,2 @SC90173 05478000 MVC HNDFNC,HNDPAT+8 Copy function (SET) @SC88326 05478500 WAITT , Make CMS happy 05479000 HOST HNDINTPL Issue HNDINT @SC86295 05479500 LA 8,SCRCCWCL Clear screen now @SC86295 05480000 BAL 9,SCRNEX @SC86295 05480500 MVI RIOC,X'80' Nothing saved @SC86295 05481000 ICM 0,15,LCLDLY @SC87268 05481500 BZ RTRN0 Skip extra delay @SC87268 05482000 CPCMD 6,7,'SL 1 SEC' This seems useful @HF86233 05482500 B RTRN0 @SC86295 05483000 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05483500 BE RTRN0 Yes, can't clear screen @SC90045 05484000 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05484500 BE RTRN0 Yes, can't clear screen @SC90045 05485000 CLI TRMTP,C'F' Is it a full-screen non-transpar? @SC92030 05485500 BE *+12 Yes, must clear frequently @SC92030 05486000 TM FL2,PROTO In protocol mode? @SC90045 05486500 BO RTRN0 Yes, skip clearing screen @SC90045 05487000 WAITT , Wait if necessary @SC90045 05487500 L 1,ADEVTAB Ptr to device table in nucleus @SC90045 05488000 LH 2,0(,1) CON1 is first device @SC90045 05488500 LA 1,SCRCCWCL Clear-screen CCW @SC90045 05489000 DIAG 1,2,X'58' Start I/O via diagnose @SC90045 05489500 B RTRN0 @SC90045 05490000 SCRCLS BCT 0,SCRRSET @SC86295 05490500 LA 8,SCRCCWVM Release screen @SC86295 05491000 BAL 9,SCRNEX @SC86295 05491500 MVC HNDFNC,=C'CLR ' @SC88326 05492000 HOST HNDINTPL Issue HNDINT CLR @SC88326 05492500 LA 5,=C'READY ...' Make sure hanging writes appear @SC86159 05493000 MVC 6(3,5),CONSADH Use console vaddr @SC86159 05493500 LA 7,9 String length @SC86159 05494000 CPCMD 5,7,RESP=YES Suppress reply @SC86159 05494500 B RTRN0 @SC86295 05495000 * (Re)set device characteristics to suit environment 05495500 SCRRSET BCT 0,SCRRW @SC86295 05496000 B RTRN0 05496500 * 05497000 * Perform I/O request 05497500 SCRRW MVC SCRCCW,0(1) Copy adr+len @SC88049 05498000 LR 5,0 @SC88049 05498500 CLC =C'CON1',HNDDV Console device? @SC89088 05499000 BE *+8 Yes, use DIAG 58 facility @SC89088 05499500 LA 5,4(,5) No, use alternate CCW codes @SC93146 05500000 CLI TRMTP,C'A' AEA-type device? @SC90173 05500500 BNE *+8 No, we've got it @SC90173 05501000 LA 5,8(,5) Yes, use alternate CCW codes @SC93146 05501500 IC 9,SCRCCM-1(5) Get command code @SC88049 05502000 STC 9,SCRCCW @SC88049 05502500 IC 9,SCRCCF-1(5) Get flags @SC88049 05503000 STC 9,SCRCCW+5 @SC88049 05503500 MVI SCRCCW+4,SLI Suppress length interrupts @SC88049 05504000 CLI CONSOPR,5 Read operation next? @SC89180 05504500 BE SCRE4TRY Yes, VTAM will be happy @SC89180 05505000 TM S1INTFL,ATN Seen attention interrupt lately? @SC89180 05505500 BZ SCRE4TRY No, VTAM will be happy @SC89180 05506000 LA 0,C'a' Yes, should see what he wants @SC89180 05506500 LA 1,CONSXSTA @SC89180 05507000 LA 2,2 @SC89180 05507500 BAL 7,SCRLOG Log the interrupt @SC89180 05508000 LA 0,5 @SC89180 05508500 KCALL SCRNIO,SCRRDPL Use recursive call to read @SC89180 05509000 SCRE4TRY LA 8,SCRCCW @LP88188 05509500 BAL 9,SCRNEX Execute internal subr @SC86295 05510000 CLI CONSOPR,5 Was it a packet read? @LP88188 05510500 BNE RTRN No, continue @LP88188 05511000 LTR 15,15 Did it fail? @LP88188 05511500 BL RTRN Yes, continue @LP88188 05512000 TM FL2,PROTO In midst of transfer? @SC88203 05512500 BZ RTRN No, must be status check @SC88203 05513000 L 1,0(8) Data address @LP88188 05513500 CLI 0(1),X'E4' 7171 overrun (line error)? @LP88188 05514000 BNE RTRN No, continue @LP88188 05514500 LA 8,SCRE4RET CCWs to reset transparent mode @LP88188 05515000 MVI CONSOPR,4 And send a dummy packet @LP88188 05515500 BAL 9,SCRNEX @LP88188 05516000 MVI CONSOPR,5 Do the read again @LP88188 05516500 B SCRE4TRY Loop until no more E4 reply @LP88188 05517000 * 05517500 *---- Subroutine of SCRNEX (must preserve R4,R8,R9) ----------*@SC91039 05518000 * Execute chnnl pgm; detect errors; wait for completion; @SC91039 05518500 * log CSW after completion; exit to SCRNEX handler if error; @SC91039 05519000 * wait for subsequent ATTN if write/read oprn. @SC91039 05519500 * Entry: R1->pgm, R2=vaddr, R7->return @SC91039 05520000 * Normal exit: clobber 0,1,2,3,15 and return @SC91039 05520500 * Error exit: clobber 0,1,2,3,15 and branch to SCRERR @SC91039 05521000 SCRXCT ENABLE INTTYPE=NONE Disable all interrupts @XN89235 05521500 ST 1,STMSCNS Save ptr to channel pgm @SC90222 05522000 TM 0(1),X'F0' Special console-type CCW? @SC91039 05522500 BZ SCRXNODI No, avoid DIAG 58 @SC91039 05523000 CLC =C'CON1',HNDDV Console device? @SC89088 05523500 BE SCRXDIAG Yes, use DIAG 58 facility @SC89088 05524000 SCRXNODI DS 0H @SC91039 05524500 AIF ('&KTAG' NE 'XA').CMSXA2 @SC90067 05525000 TM FLGXA,XACMS In 370/XA mode? @SC89235 05525500 BZ SCRXSIO No, do SIO @XN89235 05526000 MVC SCRORB+5(2),=X'40FF' Set various flags @XN89235 05526500 ST 1,ORBCPA Set Channel Program Address @XN89235 05527000 GETSID DEVICE=(2) Get subchannel number in R1 @XN89235 05527500 SSCH SCRORB Start the I/O operation @XN89235 05528000 BNZ SCRERR Error if not CC=0 @XN89235 05528500 B SCRXTSCH Drain the status @XN89235 05529000 SCRXSIO DS 0H @XN89235 05529500 .CMSXA2 ANOP @SC90067 05530000 DMSEXS MVC,CAW(4),STMSCNS Use basic SIO @SC90222 05530500 SIO 0(2) @SC89088 05531000 BC 2,SCRBUSY Maybe try again @SC91039 05531500 BC 4,SCRXTIOS Completed already, check status @SC91039 05532000 BNZ SCRERR I/O error case @XN89235 05532500 B SCRXTIO Drain status @XN89235 05533000 SCRXDIAG DIAG 1,2,X'58' Start I/O via diagnose @SC89088 05533500 BNZ SCRXERR I/O error @SC91039 05534000 AIF ('&KTAG' NE 'XA').CMSXA3 @SC90067 05534500 TM FLGXA,XACMS In 370/XA mode? @SC89235 05535000 BZ SCRXTIO No, do TIO @SC89235 05535500 GETSID DEVICE=(2) Get subchannel number in R1 @SC89235 05536000 SCRXTSCH TSCH SCRSUBAR Test status of device @SC89235 05536500 BC 4,SCRXTSCH Loop until status pending @XN89235 05537000 BC 1,SCRERR Error if not there now ! (??) @XN89235 05537500 SCRXTSCS MVC CONSCSW(8),IRBCSW Grab status @SC91039 05538000 B SCRXTIOO Rejoin 370 mode @SC89235 05538500 .CMSXA3 ANOP @SC90067 05539000 SCRXTIO DS 0H @SC89235 05539500 TIO 0(2) Test for completion @SC89088 05540000 BNZ *-4 Keep waiting @SC89088 05540500 SCRXTIOS MVC CONSCSW(8),CSW Grab status @SC91039 05541000 SCRXTIOO DS 0H @XN89235 05541500 MVI CONSATN,0 Haven't waited for attention yet @SC90222 05542000 CLI CONSOPR,4 Doing a write/read? @SC89088 05542500 BNE SCRXOK No, we don't need any interrupts @SC89088 05543000 TM CONSUNIT,255-CE-DE Already got attn or error? @SC91081 05543500 BNZ SCRXOK Yes, don't wait at all @SC91081 05544000 CLI TRMTP,C'S' S/1? @SC90173 05544500 BE *+12 @SC90173 05545000 CLI WRRD,0 Only writing? @SC90173 05545500 BE SCRXOK Yes, expect no ATTN @SC90173 05546000 HOST HNDWAIT Wait for I/O to complete @SC88326 05546500 MVI CONSATN,ATN Signal attention seen @SC90222 05547000 SCRXOK DS 0H @SC89088 05547500 ENABLE INTTYPE=ALL Reenable interrupts @XN89235 05548000 CLI CONSCHAN,0 @LP88186 05548500 BNE SCRERRC Go if ch error @SC90222 05549000 TM CONSUNIT,X'73' Any unit error? @LP88186 05549500 BNZ SCRERRC @LP88186 05550000 LA 0,C'i' "good interrupt" label @SC89166 05550500 * B SCRLOGI Log it fall through @LP88186 05551000 * 05551500 * SCRLOG: Hexadecimal log of (R2) bytes at address (R1) @LP88158 05552000 * Log label is taken from R0 low order byte. @SC89166 05552500 * Return via R7. R0-R3 and R15 destroyed. @SC89166 05553000 SCRLOGI DS 0H Special entry to log interrupts @LP88158 05553500 LA 1,CONSCSW @SC89166 05554000 LA 2,CONSTLEN @LP88158 05554500 SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05555000 BZR 7 No, that's all @SC89166 05555500 TM DBGFLG,DBGIO I/O stuff requested? @SC88168 05556000 BZR 7 No, skip it @SC89166 05556500 L 3,LOGBUF Ptr to buffer @LP88158 05557000 STC 0,0(,3) Set log label @SC89166 05557500 LA 3,2(,3) Start of data area @SC91172 05558000 TM DBGFLG,DBGTI Times requested? @SC91172 05558500 BZ SCRLOGA No, just do hex dump @SC91172 05559000 ST 1,SCRLR1 Save ptr to block @SC91172 05559500 BAL 14,ACCTTOD Get time of day in seconds @SC91172 05560000 MVI 0(3),C' ' Leave a space @SC91172 05560500 KCALL DUMPTOD,1(3) Format time into buffer @SC91172 05561000 LR 3,15 Get ptr to end of string @SC91172 05561500 L 1,SCRLR1 Restore R1 @SC91172 05562000 SCRLOGA LA 0,6*9(,3) End of line buffer @SC91172 05562500 TM DBGFLG,DBGLO Long buffer requested? @SC90222 05563000 BZ *+8 @SC90222 05563500 LA 0,50*9(,3) Yes, long buffer @SC91172 05564000 SCRLOGLP MVI 0(3),C' ' Add for readability @LP88158 05564500 UNPK 1(9,3),0(5,1) Unpack into buffer @SC88168 05565000 TR 1(8,3),TRHEX Convert to printable hex @SC88168 05565500 LA 3,9(3) Advance text ptr @SC88168 05566000 LA 1,4(1) and data source @LP88158 05566500 S 2,F4 Finished data? @SC88168 05567000 BNP SCRLGEND Yes, go write @LP88158 05567500 CR 3,0 Reached text limit? @LP88158 05568000 BL SCRLOGLP no, loop for more slices @LP88158 05568500 MVC 0(3,3),=C'...' Show incomplete @LP88158 05569000 LA 3,3(3) @SC88168 05569500 SCRLGEND DS 0H @LP88158 05570000 AR 2,2 Check for incomplete slice @SC88168 05570500 BNM *+6 No, ok @SC88168 05571000 AR 3,2 Yes, adjust end of text @SC88168 05571500 S 3,LOGBUF Get length of text @SC88168 05572000 WRITF LOGPTR,BSIZE=(3) Log it @LP88158 05572500 TM DBGFLG,DBGSV SAVE requested? @SC88168 05573000 BZR 7 No, skip closing log file @SC89166 05573500 SAVEF LOGPTR Update disk directory @SC88168 05574000 BR 7 @SC89166 05574500 * 05575000 *--- Major I/O routine: execute chnnl pgm w/ error recovery ---@SC91039 05575500 * Entry: R8->pgm, R9->return @SC91039 05576000 * Log pgm; wait for device ready; call SCRXCT to execute; @SC91039 05576500 * log data buffer; errors in SCRXCT fall out into retry loop.@SC91039 05577000 * Exit: clobber 0,1,2,3,4,5,7 and set R15= useful data length @SC91039 05577500 * (or -1 if error) @SC91039 05578000 SCRNEX LA 4,10 CP BREAKIN recovery retry count @LP88186 05578500 NI S1INTFL,255-ATN Clear pending attention, if any @SC89180 05579000 SCRNEXLP LR 1,8 Get CCW ptr @SC91039 05579500 SLR 2,2 Convert op. code to log label @LP88158 05580000 IC 2,CONSOPR @LP88158 05580500 LA 2,CONSOPRS(2) @LP88158 05581000 IC 0,0(,2) @SC89166 05581500 LA 2,8 Size of one CCW @LP88158 05582000 TM 4(1),CC Command chained? @LP88158 05582500 BZ *+8 @LP88158 05583000 LA 2,8(2) Yes, add another @LP88158 05583500 BAL 7,SCRLOG CCWs logged @SC89166 05584000 LH 2,CONSADDR Console address 05584500 AIF ('&KTAG' NE 'XA').CMSXA4 @SC90067 05585000 TM FLGXA,XACMS In 370/XA mode? @SC89235 05585500 BZ SCRTIO No, do TIO @SC89235 05586000 GETSID DEVICE=(2) Get subchannel number in R1 @XN89235 05586500 SCRTSCH TSCH SCRSUBAR Test status of console @XN89235 05587000 BZ SCRTSCH Loop if status stored @XN89235 05587500 B SCRTIOO Rejoin 370 mode @SC89235 05588000 SCRTIO DS 0H @SC89235 05588500 .CMSXA4 ANOP @SC90067 05589000 TIO 0(2) See if usable 05589500 BC 6,*-4 Loop if busy or CSW stored 05590000 SCRTIOO DS 0H @SC89235 05590500 BC 1,SCRERR not operational: error 05591000 LR 1,8 Copy CCW adr @SC89088 05591500 BAL 7,SCRXCT Execute and wait for completion @SC89166 05592000 BAL 7,SCRLOGD Log data and get count in R5 @SC90222 05592500 LR 15,5 @LP88186 05593000 TM 0(8),1 Is it a channel read? @LP88186 05593500 BOR 9 No, size OK @LP88186 05594000 S 15,WRCMDL+4 Deduct 3 for buffer adr @SC90173 05594500 BNLR 9 @LP88186 05595000 SLR 15,15 @LP88186 05595500 BR 9 Return to caller @LP88186 05596000 * 05596500 * Alternate entry to SCRLOG for logging data buffer. @SC91039 05597000 * Also returns data count in R5. @SC91039 05597500 SCRLOGD L 1,STMSCNS Get ptr to channel pgm @SC90222 05598000 LH 5,6(,1) Buffer size @SC90222 05598500 SH 5,CONSBYTC Minus residual count @LP88186 05599000 L 1,0(,1) Data address @SC90222 05599500 LA 0,C'd' "Data" label @SC89166 05600000 LR 2,5 Data size @LP88186 05600500 B SCRLOG Go log it @SC90222 05601000 * 05601500 *---- Error handler within SCRNEX - retry and loop or exit ----@SC91039 05602000 * 05602500 SCRXERR DS 0H @SC91039 05603000 AIF ('&KTAG' NE 'XA').CMSXA4B @SC91039 05603500 TM FLGXA,XACMS In 370/XA mode? @SC91039 05604000 BZ SCRXETIO No, do TIO @SC91039 05604500 GETSID DEVICE=(2) Get subchannel number in R1 @SC91039 05605000 TSCH SCRSUBAR Test status of device @SC91039 05605500 BC 1,SCRERR Error if not there now ! (??) @SC91039 05606000 BC 2,SCRBUSY @SC91039 05606500 B SCRXTSCS Go grab status @SC91039 05607000 SCRXETIO DS 0H @SC91039 05607500 .CMSXA4B ANOP @SC91039 05608000 TIO 0(2) DIAG failed, find out why @SC91039 05608500 BC 1,SCRERR Dead device @SC91039 05609000 BC 2,SCRBUSY @SC91039 05609500 B SCRXTIOS Something happened after all @SC91039 05610000 * 05610500 SCRERRC DS 0H Fatal I/O error @LP88186 05611000 LA 0,C'e' Indicate error interrupt or CC @SC89166 05611500 BAL 7,SCRLOGI Log it @SC89166 05612000 BAL 7,SCRLOGD Log data, if any @SC90222 05612500 CLI CONSUNIT,CPBRK CP stole the screen? @SC89088 05613000 BNE SCRERR Bin @LP88186 05613500 BCT 4,SCRBRK Go recover unless retries exhaust @LP88186 05614000 B SCRERR Give up @SC91039 05614500 SCRBUSY BCT 4,SCRNEXLP Retry without recovery @SC91039 05615000 SCRERR SR 15,15 @SC86295 05615500 BCTR 15,0 Return error code of -1 @SC86295 05616000 ENABLE INTTYPE=ALL Reenable interrupts @XN89235 05616500 BR 9 @SC86295 05617000 SCRBRK DS 0H CP BREAKIN recovery @LP88186 05617500 LA 1,RTRYIO @LP88186 05618000 LA 0,C'b' Log BREAKIN recovery CCW @SC89166 05618500 C 1,STMSCNS Were we already trying to recover?@SC91039 05619000 BE SCRBRKRD Yes, must issue a READ @SC91039 05619500 LA 2,16 @LP88186 05620000 BAL 7,SCRLOG @SC89166 05620500 LA 14,=C'RESET ...' @LP88186 05621000 MVC 6(3,14),CONSADH Use console vaddr @LP88186 05621500 LA 0,9 String length @LP88186 05622000 CPCMD 14,0,RESP=YES Reply to buffer @LP88186 05622500 LA 1,RTRYIO @LP88186 05623000 LH 2,CONSADDR Console address @LP88186 05623500 OI CONSOPR,X'80' Flag to avoid waiting for ATTN @LP88186 05624000 BAL 7,SCRXCT Take the screen back @SC89166 05624500 NI CONSOPR,X'7F' Restore as request @LP88186 05625000 B SCRNEXLP Try again @SC91039 05625500 SCRBRKRD LA 2,16 @SC91039 05626000 LA 1,RTRYIO2 Next try to read @SC91039 05626500 BAL 7,SCRLOG @SC91039 05627000 LA 1,RTRYIO2 Next try to read @SC91039 05627500 LH 2,CONSADDR Console address @SC91039 05628000 OI CONSOPR,X'80' Flag to avoid waiting for ATTN @SC91039 05628500 BAL 7,SCRXCT Read the screen @SC91039 05629000 NI CONSOPR,X'7F' Restore as request @SC91039 05629500 B SCRBRK Now try again to clear it @SC91039 05630000 DS 0D 05630500 SCRCCWCL DC X'19',AL3(0),AL1(SLI),X'FF',AL2(1) 05631000 SCRCCWVM DC X'19',AL3(0),AL1(SLI),X'FE',AL2(1) 05631500 RTRYIO2 CCW X'0A',SCRSENSE,SLI+CC,5 CMS normal read @SC91039 05632000 CCW X'03',0,SLI,1 @SC91039 05632500 * 05633000 RTRYIO DC 0D'0',X'19',AL3(0),AL1(CC+SLI),X'FF',AL2(1) @SC86159 05633500 DC X'29',AL3(RTRYCM),AL1(SLI),X'90',AL2(1) @TB88078 05634000 RTRYCM DC &S1CMD @SC90264 05634500 * 05635000 SCRE4RET DS 0D @LP88188 05635500 * DC X'29',AL3(SCRE4LTM),AL1(SLI+CC),X'90',Y(SCRE4LTL) C91178 05636000 DC X'29',AL3(SCRE4DWR),AL1(SLI),X'00',Y(SCRE4DWL) @SC88168 05636500 *CRE4LTM DC X'40',AL1(SBA),X'4040',AL1(ICR),X'4040' Reset @SC91178 05637000 *CRE4LTL EQU *-SCRE4LTM Length of command @SC91178 05637500 SCRE4DWR DC X'C2',AL1(SBA),X'5D7F',AL1(SBA),X'000180' packet@SC88168 05638000 SCRE4DWL EQU *-SCRE4DWR Length of command @SC88168 05638500 * --DIAG58--- ---SIO----- --DIAG58--- ---SIO----- @SC93146 05639000 * W R WM RB W R WM RB W R WM RB W R WM RB @SC93146 05639500 SCRCCM HTBL 29,2A,29,2A,01,06,05,02,29,2A,29,2A,11,06,05,02 @SC93146 05640000 SCRCCF HTBL 00,80,90,00,00,00,00,00,20,80,90,00,00,00,00,00 @SC93146 05640500 * Use x'10' flag in the writemsg CCW flag byte to @TB88078 05641000 * prohibit VM/XA DIAG58 from issuing Read Modifieds @TB88078 05641500 * to check for PA1 @TB88078 05642000 TITLE 'SETMSG Routine - controls CP breakin' 05642500 * Entry: R1 selects operation 05643000 * Exit: R15=0 if ok 05643500 * 1-> Analyze user environment, determine if suitable. 05644000 * Save quantities needed and condition line for entering commands. 05644500 * Perform any system-dependent initialization. 05645000 * 2-> Condition line for protocol transfers. 05645500 * 3-> Decondition line at end of transfer. 05646000 * 4-> System-dependent clean-up at exit. 05646500 * 5-> Reperform system-dependent initialization after SET LINE. 05647000 SETMSG ENTER ALT @SC86295 05647500 BCT 1,STM2 Go if R1 not 1, so no init 05648000 L 1,ORGR1 @SC88049 05648500 MVC KRMNAM,0(1) Copy original invoked name @SC88049 05649000 L 2,CBUF Put diag result here 05649500 LA 3,32 Get this much info 05650000 DIAG 2,3,X'00' Identify 05650500 MVC USRTAKE,16(2) Move userid to our buffer 05651000 MVC HNDINTPL(LHNDWT),HNDPAT Init HNDINT @SC88326 05651500 L 1,ASTMUSET @SC87117 05652000 MVC 8(9,1),=C'MACHINE -' @SC89235 05652500 CPCMD 2,4,'Q SET',RESP=YES @SC86148 05653000 MVC ADR,CBUF Response address for parser 05653500 ST 5,LEN Response length for parser 05654000 MVC STMSCNS(8),SCANPTR Save string ptrs @SC89235 05654500 SR 5,5 Length of previous data @SC89235 05655000 LA 8,STMMLEN-2 Descriptor list for MACHINE @SC89235 05655500 BAL 2,STMGET @SC89235 05656000 L 1,ASTMUSET @SC89235 05656500 CLI 8+8(1),C'-' Is it VM/XA? @SC89235 05657000 BE STMVMSP No, remember that @SC89235 05657500 OI FLGXA,XACP CP is VM/XA @SC89235 05658000 CLI 8+8(1),C'3' Is it in 370 mode? @SC89235 05658500 BE STMVMSP Yes, remember that @SC89235 05659000 OI FLGXA,XACMS CMS is in XA mode @SC89235 05659500 WRTERM '&NONXAMS' @SC89235 05660000 B RTRN1 Too bad, give up @SC89235 05660500 STMVMSP DS 0H @SC89235 05661000 MVC 0(STMUL+STMLL,1),STMUOFF Set up pattern @SC87117 05661500 S 1,F4 Start of list: back 8, up L'SET +1@SC87117 05662000 SR 5,5 Length of previous data @SC86148 05662500 LA 8,STMLEN-2 Descriptor list @SC86148 05663000 MVC SCANPTR(8),STMSCNS Restore ptrs @SC89235 05663500 BAL 2,STMGET @SC89235 05664000 BAL 2,STMGET @SC89235 05664500 MVC SCANPTR(8),STMSCNS Restore ptrs again @SC89235 05665000 LA 4,5 Number of items in QUERY SET @SC89235 05665500 BAL 2,STMGET @SC86295 05666000 BCT 4,*-4 @SC86148 05666500 CPCMD 2,6,'Q TERM',RESP=YES @SC86148 05667000 MVC ADR,CBUF Response address for parser 05667500 ST 7,LEN Response length for parser @SC87117 05668000 LA 1,1(1) One extra: L'TERM - L'SET @SC87117 05668500 BAL 2,STMGET @SC86295 05669000 BAL 2,STMGET @SC92030 05669500 BAL 2,STMGET (if more: put S 1,F4 in loop) @SC87295 05670000 * Note: KWRKBASE is 11... @SC89268 05670500 STM 10,11,STMSAVR Save base registers @SC87117 05671000 HOST STMEXC Set up subcommand environment @SC87117 05671500 B STM5X @SC87351 05672000 DS 0F @SC87117 05672500 STMEXC DC CL8'SUBCOM',CL8'KERMIT' @SC87117 05673000 DC F'0',A(STMSUBC,0) @SC87117 05673500 STMEXDRP DC CL8'SUBCOM',CL8'KERMIT' @SC92112 05674000 DC F'0',A(0),8X'FF' @SC92112 05674500 * 05675000 STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05675500 TM FL1,TSTF @SC86295 05676000 BO RTRN0 Just testing, don't change it @SC86295 05676500 LA 2,STMUOFF Set everything off 05677000 MVC STMUOTB,AOUTRTBL Save user's table ptrs @SC87201 05677500 MVC STMUITB,AINTRTBL @SC87201 05678000 LA 7,F0 Set to turn off translation @SC87201 05678500 LR 8,7 @SC87201 05679000 B STMD 05679500 * 05680000 STM3 BCT 1,STM4 @SC86316 05680500 L 2,ASTMUSET Restore user's settings @SC87117 05681000 LA 7,STMUITB Restore user's table ptrs @SC87201 05681500 LA 8,STMUOTB @SC87201 05682000 STMD LA 4,STMUL Length of 1st batch @SC87117 05682500 LA 5,0(2,4) Start of 2nd @SC87117 05683000 LA 6,STMSPL Length of VM/SP-only stuff @SC89235 05683500 TM FLGXA,XACP Is it VM/SP? @SC89235 05684000 BZ *+8 @SC89235 05684500 AR 2,6 No, skip that stuff @SC89235 05685000 SR 4,6 @SC89235 05685500 CPCMD 2,4 Issue a bunch of CP commands @SC87117 05686000 BAL 14,TTYCHK Line mode? @SC92030 05686500 B STMDTT Yes, do line-mode stuff @SC92030 05687000 B RTRN0 No, skip line-mode stuff @SC92030 05687500 STMDTT DS 0H @SC92030 05688000 DMSEXS MVC,AINTRTBL,0(7) Restore input table @SC87201 05688500 DMSEXS MVC,AOUTRTBL,0(8) Restore output table @SC87201 05689000 LA 7,STMLL @SC87295 05689500 CPCMD 5,7,RESP=YES No, do linemode stuff @SC87295 05690000 B RTRN0 05690500 * 05691000 STM4 BCT 1,STM5 Special clean-up @SC87351 05691500 HOST STMEXDRP Drop subcommand environment @SC92112 05692000 B RTRN0 @SC92112 05692500 * 05693000 STM5 DS 0H Re-init after SET LINE @SC87351 05693500 STM5X SR 2,2 @SC86295 05694000 BCTR 2,0 @SC86295 05694500 MVI TRMTP,C'N' Assume bad until validated @SC90173 05695000 CLI TRMLIN,C' ' External line? @SC87351 05695500 BE STM5D No, use console @SC87351 05696000 TR TRMLIN,UPCASE @SC88120 05696500 LA 5,3+1 Allow no more than 3 hex digits @SC87351 05697000 SR 2,2 Init value @SC87351 05697500 LA 1,TRMLIN Ptr to string @SC87351 05698000 STM5L CLI 0(1),C' ' Look for end of value @SC87351 05698500 BE STM5D Ok, got number @SC87351 05699000 IC 3,0(1) @SC87351 05699500 CLI 0(1),C'0' 0-9? @SC87351 05700000 BL STM5LA @SC87351 05700500 CLI 0(1),C'9' @SC87351 05701000 BH RTRN1 Bad digit @SC87351 05701500 B STM5LS Ok, use it @SC87351 05702000 STM5LA CLI 0(1),C'A' A-F? @SC87351 05702500 BL RTRN1 Bad @SC87351 05703000 CLI 0(1),C'F' @SC87351 05703500 BH RTRN1 Bad @SC87351 05704000 LA 3,9(3) OK, get in binary @SC87351 05704500 STM5LS SLL 3,28 Convert to nybble @SC87351 05705000 SLDL 2,4 @SC87351 05705500 LA 1,1(1) Keep scanning @SC88049 05706000 BCT 5,STM5L @SC87351 05706500 B RTRN1 String too long @SC87351 05707000 STM5D SR 3,3 Clear result register @SC91311 05707500 DIAG 2,3,X'24' Get console flags @SC91311 05708000 CLM 3,8,=X'40' Is it a dedicated GRAF dev? @SC88203 05708500 BE *+12 Yes, ok @SC88203 05709000 CLM 3,8,=X'8020' Is this a terminal? @SC87351 05709500 BNE RTRN1 No, bad device @SC87351 05710000 MVI TRMTP,C'&KCONT' 1st assume TTY @SC88309 05710500 STH 2,CONSADDR Save console addr (CUU) 05711000 UNPK CONSADH(4),CONSADDR(3) @SC86159 05711500 TR CONSADH(3),TRHEX Save as chars @SC86159 05712000 L 5,ADEVTAB Ptr to system device table @SC88326 05712500 LA 6,DEVSIZE Size of table item @SC88326 05713000 L 7,ATABEND End of table @SC88326 05713500 CLM 2,3,0(5) Check device vaddr @SC89235 05714000 BE STM5HL Found it, use this name @SC88326 05714500 BXLE 5,6,*-8 @SC88326 05715000 LA 5,HNDPATDV-4 Not found, use default name @SC88326 05715500 STM5HL MVC HNDDV,4(5) @SC88326 05716000 MVC WAITDV,4(5) @SC88326 05716500 CLM 4,8,=X'8020' Is this an SNA 3770/3767 or TTY? @2L90270 05717000 BE RTRN0 Yes, all set @SC88203 05717500 SR 1,1 Assume Query not allowed @SC91311 05718000 L 4,RIOPTRS Get more info @SC91311 05718500 L 6,RIOPTRS+4 Length allowed @SC91311 05719000 LR 7,6 Extra copy @SC91311 05719500 LR 5,2 Get vaddr @SC91311 05720000 DIAG 4,6,X'8C' Ask for the info @SC91311 05720500 LTR 5,5 Did it work? @SC91311 05721000 BNZ STMGRS No, give up @SC91311 05721500 LTR 6,6 Supposed residual count @SC91311 05722000 BM STMGRS Something wrong @SC91311 05722500 SR 7,6 Length of info @SC91311 05723000 CH 7,=H'6' Basic info always returned @SC91311 05723500 BNH STMGRS No Query info @SC91311 05724000 LA 1,STCQBIT Ok, Query is allowed @SC91311 05724500 STMGRS DS 0H @SC91311 05725000 O 1,=A(&CONOPTS) Options @SC91311 05725500 KCALL SETCON Find out just what kind... @SC91311 05726000 B RTRN0 05726500 * 05727000 * Parse CP response for token pointed by R1: <len-1> token 05727500 * On entry: R1 = ptr-8-R5 of name in user list @SC86148 05728000 * R5 = length of previous token @SC86148 05728500 * R8 = ptr to previous len-1 of name,data @SC86148 05729000 * On exit: R1,R5,R8 updated @SC86148 05729500 * value copied into user list @SC86148 05730000 * 05730500 STMGET LA 8,2(8) Point to next descriptor @SC86148 05731000 LA 1,8(5,1) Advance to next name @SC86148 05731500 IC 5,1(8) Get length of data @SC86148 05732000 STMGET1 NTOKN N=0(2) Pick next token @SC86295 05732500 CLM 7,1,0(8) Is this the same size we want? @SC86148 05733000 BNE STMGET1 Not the size we want @SC86148 05733500 EX 7,STMGETC is it right one? 05734000 BNE STMGET1 Nope, keep on looking @SC86148 05734500 AR 1,7 Space over name @SC86148 05735000 NTOKN N=0(2) Use the next token @SC86316 05735500 EX 5,STMGETM Copy value @SC86148 05736000 BR 2 @SC86295 05736500 * 05737000 STMGETC CLC 0(,1),0(6) Check token against list @SC86148 05737500 STMGETM MVC 2(,1),0(6) Save value in list @SC86148 05738000 * 05738500 * ACNT TIME -- SET @SC89235 05739000 STMLEN DC AL1(03,2,04,3) @SC89235 05739500 * MSG WNG RUN EDIT IMSG -- SET @SC89235 05740000 DC AL1(02,3,02,3,02,2,06,2,03,3) @SC89235 05740500 * TABC SIZE SCRL -- TERM @SC92030 05741000 DC AL1(06,1,07,2,05,3) @SC92030 05741500 * 05742000 STMUOFF EQU * Start of CP commands to set all off @SC89235 05742500 DC C'SET ACNT OFF',X'15' @SC89235 05743000 DC C'SET TIMER OFF ',X'15' @SC89235 05743500 STMSPL EQU *-STMUOFF Amount to skip if VM/XA @SC89235 05744000 DC C'SET MSG OFF ',X'15' @SC89235 05744500 DC C'SET WNG OFF ',X'15' (in order of CP msgs) 05745000 DC C'SET RUN ON ',X'15' 05745500 DC C'SET LINEDIT OFF',X'15' @SC88194 05746000 DC C'SET IMSG OFF ',X'15' @SC87117 05746500 STMUL EQU *-STMUOFF @CR86321 05747000 STMLOFF DC C'TERM TABCHAR OF' @SC92030 05747500 DC C' LINESIZE OFF' @SC92030 05748000 DC CL5' ',C'SCROLL CONT' (if more, cut to 1 sp) @SC87295 05748500 STMLL EQU *-STMUOFF-STMUL @SC87117 05749000 STMMLEN DC AL1(06,2) Descriptor for MACHINE @SC89235 05749500 TITLE 'STMSUBC Routine - subcommand environment handler' 05750000 USING STMSUBC,15 @SC87117 05750500 STMSUBC STM 14,12,12(13) Save registers @SC87117 05751000 LM 10,11,STMSAVR Get base registers @SC87117 05751500 LA 0,USNTRFLX Length of locals @SC87117 05752000 BAL 14,SUBENT Set up entry @SC87117 05752500 LR 15,KSUBBASE Recover local base register @SC89268 05753000 LR 2,0 Save ptr to EPLIST @SC87117 05753500 LA 0,RTRNUM Set to return error code @SC87117 05754000 L 1,=A(USNCMDX) All commands but QUIT @SC87117 05754500 BAL 14,LOOPS @SC87117 05755000 L KSUBBASE,=A(USNTRF) Ptr to main loop routine @SC89268 05755500 LM 15,0,4(2) Ptrs to command and end @SC87117 05756000 SR 0,15 Get length @SC87117 05756500 LA 1,CMD @SC87117 05757000 MVC 0(256,1),0(15) Copy to buffer @SC87117 05757500 OI KFLG-USNTRFSV(13),CMDC+SIGN Indicate just 1 cmd @SC87117 05758000 B LUPPRS @SC87117 05758500 TITLE 'S1INT Routine - interrupt handler' 05759000 USING S1INT,15 @SC86295 05759500 S1INT DS 0H @SC89088 05760000 STCM 3,12,CONSXSTA Save status bytes @SC89180 05760500 TM CONSXSTA,ATN Attention received? @SC89180 05761000 BZ S1IOK No, forget it @SC89180 05761500 OI S1INTFL,ATN Yes, remember it @SC89180 05762000 S1IOK SR 15,15 R15=0-> intrpt proc complete 05762500 BR 14 @SC86295 05763000 DROP 15 @SC86295 05763500 * 05764000 * HNDINT Plist for Series/1 interrupt handling 05764500 HNDPAT DC CL8'HNDINT' HNDINT plist @SC88326 05765000 DC CL4'SET' Set function 05765500 HNDPATDV DC CL4'CONK' Symbolic device (or CON1) @SC88326 05766000 DC AL4(S1INT) S1 Interrupt handler 05766500 DC AL2(9) Console address (fill in) @SC88326 05767000 DC CL2'AC' @SC91095 05767500 DC 4X'FF' @SC88326 05768000 DC CL8'WAIT' @SC88326 05768500 LHNDWT EQU *-HNDPAT @SC88326 05769000 * 05769500 CONSCSW DS A (key + cc)(1) + CCW addr(3) 05770000 CONSUNIT DS X Unit status 05770500 CONSCHAN DS X Channel status 05771000 CONSBYTC DS H Byte count 05771500 CONSATN DS X Flag for ATN seen, etc. @SC90222 05772000 CONSTLEN EQU *-CONSCSW End of console status log area @LP88158 05772500 * 05773000 SCRRDPL DC A(SCRSENSE,L'SCRSENSE) @SC89180 05773500 SCRSENSE DS XL10 Buffer for ATN-triggered read @SC89180 05774000 CONSXSTA DS XL2 Status bytes saved on interrupt @SC89180 05774500 S1INTFL DS X Saved interrupt flags @SC89180 05775000 * 05775500 CONSOPRS DC C'?ocswrmg' Console command labels for log @SC93146 05776000 STMSAVR DS 2F @SC88168 05776500 CONSADH DC C'...',C' ' Unpacked vaddr + pad @SC86159 05777000 LOCALS , @SC86295 05777500 SCRCCW DS D CCW for send, recv, msg @SC88049 05778000 STMSCNS DS 2F Saved scan ptrs @SC87117 05778500 SCRLR1 DS F Saved R1 in SCRLOG @SC91172 05779000 AIF ('&KTAG' NE 'XA').CMSXA5 @SC90067 05779500 SCRORB DS F'0' Parameter=0 @XN89235 05780000 DS X'00,40,FF,00' Key=0, etc. @XN89235 05780500 ORBCPA DS A Address is filled in @XN89235 05781000 SCRSUBAR DS 16F Storage for TSCH @XN89235 05781500 IRBCSW EQU SCRSUBAR+4,8 @XN89235 05782000 .CMSXA5 ANOP @SC90067 05782500 CONSOPR DS XL1 Current I/O operation @SC89180 05783000 SETMSG EXIT 05783500 TITLE 'DISKIO Routine - performs disk I/O functions' 05784000 * ERRNUM unchanged unless there is a disk error. 05784500 * Function selected on entry by R0: 05785000 * 0=> unnum: R1->FAB. Return R1->buffer,R0=# and remove the sequence 05785500 * number (if any) from the buffer (used for TAKE files) 05786000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05786500 * 2=> open (out): (same) 05787000 * 3=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05787500 * writable (else R15=1) @SC91269 05788000 * 4=> close file: R1->adr(FAB). 05788500 * 5=> set up search: R1->pattern name. 05789000 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05789500 * 7=> close search (if any). 05790000 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05790500 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05791000 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05791500 * 11=> test space: R1->pattern FDB (has size in Kbytes), 05792000 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05792500 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05793000 * always returns R15=1 05793500 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 05794000 * 14=> delete file: R1->name. Returns R15=0 if ok. 05794500 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05795000 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05795500 * 21=> save file status in directory: R1->FAB. (not used) @SC88168 05796000 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05796500 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05797000 * Return R15=0 if ok. @SC89218 05797500 * 24=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05798000 * readable (else R15=1) @SC91269 05798500 DISKIO ENTER 05799000 USING FABD,3 @SC86295 05799500 SR 4,4 Signal no block assigned @SC86295 05800000 STC 0,DSKCOD Save function code (for now) @SC88101 05800500 LR 5,0 @SC89073 05801000 AR 5,5 @SC89073 05801500 LH 5,DSK0(5) Get handler address @SC89073 05802000 B DSK0(5) Do the function @SC89073 05802500 DSK0 DC Y(DSKNON-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 05803000 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 05803500 DC Y(DSKNXT-DSK0,DSKNSX-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05804000 DC Y(DSKER1-DSK0,DSKER1-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05804500 DC Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0) 12-20 @SC89073 05805000 DC 2Y(DSKER1-DSK0),Y(DSKPNT-DSK0) 21-23 @SC89218 05805500 DC Y(DSKTEST-DSK0) 24- @SC91269 05806000 DC 8Y(DSKER1-DSK0) Spares @SC89073 05806500 * 05807000 DSKNON DS 0H @SC89073 05807500 LR 3,1 Address FAB @SC88101 05808000 L 0,FABNORD Get length of buffer @SC88101 05808500 L 2,FDBBUFF Get ptr to buffer @SC88101 05809000 CLI FDBRCF,C'F' Fixed-length records? @SC88101 05809500 BNE DSKNONZ No, no line numbers @SC88101 05810000 CH 0,=H'80' See if F/80 @SC88101 05810500 BNE DSKNONZ No @SC88101 05811000 MVZ WLDPAT(5),75(2) See if 76-80 are all numeric @SC88101 05811500 CLC WLDPAT(5),=5C'0' @SC88101 05812000 BNE DSKNONZ No @SC88101 05812500 S 0,F8 Yes, move the end back @SC88101 05813000 DSKNONZ RETREG 0,(1,2) Return R0 and (2) as R1 @SC88218 05813500 B RTRN0 Done @SC88101 05814000 DSKOPNI DS 0H @SC88101 05814500 * 05815000 * Open for input file whose name is at (R2), FDB at (R1) 05815500 BAL 9,DSKALC Get FAB @SC86295 05816000 DSKOP0 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 05816500 BNZ DSKER1 Not found @SC86295 05817000 BAL 14,DSKVALS @SC86295 05817500 B RTRN0 @SC86295 05818000 * 05818500 * Open for output file whose name is at (R2), FDB at (R1) 05819000 DSKOPNO DS 0H @SC89073 05819500 BAL 9,DSKALC Get FAB @SC86295 05820000 BAL 2,DSKLKP Get FST, ADT ptrs @SC86295 05820500 BNZ DSKOPLR Not found, just writing new @SC87012 05821000 TM FDBFLGS,APPN+SVATT Should we keep attributes? @SC90033 05821500 BZ *+8 No @SC90033 05822000 BAL 14,DSKVALS Yes, copy old ones to FDB @SC90033 05822500 TM FDBFLGS,APPN @SC86295 05823000 BO DSKOPLR @SC90033 05823500 FSERASE FSCB=(3) @SC86295 05824000 DSKOPLR SR 0,0 @SC87012 05824500 ICM 0,3,FDBLRC File LRECL @SC87012 05825000 CLI FDBRCF,C'V' RECFM F limited to LRECL @SC88120 05825500 BNE DSKSTLR @SC88120 05826000 CLI TYPFIL,C'B' Binary? @SC88120 05826500 BE DSKSTLR Yes, always fold @SC88120 05827000 L 0,MAXLRC TEXT file, no limit @SC87012 05827500 DSKSTLR ST 0,FABLRTR Set effective record length @SC88120 05828000 B RTRN0 @SC86295 05828500 * 05829000 * Test for existence of file whose name is at (R2) 05829500 DSKTEST DS 0H @SC89073 05830000 MVC DSKSTNM,0(2) @SC86295 05830500 LA 3,DSKSTT @SC86295 05831000 B DSKOP0 Test file @SC86295 05831500 * 05832000 * Close file whose ticket is at (R1), release block 05832500 DSKCLOS DS 0H @SC89073 05833000 ICM 3,15,0(1) Get FAB ptr, if any @SC86295 05833500 BZ RTRN0 None, ignore @SC86295 05834000 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 05834500 SR 15,15 Clear return code, in case active @SC92260 05835000 TM FDBFLGS,FDBACTV Is another copy active? @SC92260 05835500 BO DSKCLOS2 Yes, don't actually FINIS it @SC92260 05836000 FSCLOSE FSCB=(3) @SC86295 05836500 DSKCLOS2 LR 1,3 Set up DMSFREE @SC92260 05837000 LR 5,15 Save return code @SC92076 05837500 LA 0,FABDWDS @SC86295 05838000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 05838500 LR 15,5 @SC92076 05839000 CH 15,=H'6' @SC92076 05839500 BE RTRN0 Wasn't open anyway: maybe empty @SC92076 05840000 B RTRN @SC92076 05840500 * 05841000 * Point past 1st N records of file at (R1) @SC89218 05841500 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 05842000 BZ RTRN1 Not open @SC89218 05842500 LA 6,1 @SC89218 05843000 AR 6,2 Rec no. = 1 + number to skip @SC89218 05843500 BNP RTRN0 Never mind @SC89218 05844000 C 6,FDBNREC File long enough? @SC89218 05844500 BH RTRN1 No, skip it @SC89218 05845000 SR 0,0 Don't mess with write point @SC89218 05845500 FSPOINT FSCB=(3),WRPNT=(0),RDPNT=(6),FORM=E @SC89218 05846000 B RTRN Return with completion code @SC89218 05846500 * 05847000 * Analyze error: packed dec. code in TMPDW 05847500 DSKXXX DS 0H @SC89073 05848000 MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 05848500 L 2,EMSGP Ptr to msg buffer @SC87338 05849000 MVC 0(8,2),0(1) Copy oprn name @SC87338 05849500 MVC 8(2,2),=C'R=' @SC87338 05850000 OI TMPDW+7,15 Set zone @SC87338 05850500 UNPK 10(2,2),TMPDW Copy error code @SC87338 05851000 MVC EMSGL,F12 Length of string @SC87338 05851500 B RTRN1 @SC87338 05852000 * 05852500 * Disk utility for file(s) at (R1) and (R2) 05853000 DSKUTL SH 0,=H'13' Code-13: DIR,DEL,REN,COP @SC86316 05853500 LR 8,0 Save a copy @SC86316 05854000 SLA 0,3 @SC86295 05854500 LA 5,DSKCMDS @SC86295 05855000 AR 5,0 Ptr to command name @SC86295 05855500 LA 4,CMD Buffer for tokenized command @SC86295 05856000 MVC 0(8,4),0(5) @SC86295 05856500 LA 4,8(4) @SC86295 05857000 LR 6,1 1st file @SC86295 05857500 BAL 3,DSKUTCP @SC86295 05858000 SRA 0,4 @SC86295 05858500 BZ *+10 @SC86295 05859000 LR 6,2 2nd file @SC86295 05859500 BAL 3,DSKUTCP @SC86295 05860000 LTR 8,8 Code-13 @SC86316 05860500 BNZ *+14 Go if not LISTFILE @SC86316 05861000 MVC 0(16,4),=CL16'( DATE' @SC86295 05861500 LA 4,16(4) @SC86295 05862000 MVI 0(4),X'FF' Insert fence @SC86295 05862500 MVC 1(7,4),0(4) @SC86295 05863000 LA 0,CMD @SC86295 05863500 NI FL4,255-UCMD Not user command: already tokens @SC86295 05864000 KCALL SUPFNC,3 Execute it @SC86295 05864500 B RTRN @SC86295 05865000 * 05865500 DSKUTCP LA 7,LFID Length of name @SC86295 05866000 ICM 7,8,BLANK Blank fill @SC86295 05866500 LA 5,24 @SC86295 05867000 MVCL 4,6 Copy name and update R4 @SC86295 05867500 BR 3 @SC86295 05868000 * 05868500 DSKCMDS DC C'LISTFILE' Utility command names @SC86295 05869000 DC C'ERASE ' @SC86295 05869500 DC C'RENAME ' @SC86295 05870000 DC C'COPYFILE' @SC86295 05870500 * 05871000 * Return on error, release useless block, if any 05871500 DSKER1 LTR 1,4 Any block assigned? @SC86295 05872000 BZ RTRN1 No @SC86295 05872500 LA 0,FABDWDS Yes, release it @SC86295 05873000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 05873500 B RTRN1 Flag error @SC86295 05874000 * 05874500 DSKALC LR 5,1 Save FDB ptr @SC86295 05875000 MVC DSKSTNM,0(2) @SC86295 05875500 LA 0,FABDWDS @SC86295 05876000 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 05876500 LR 3,1 New block ptr @SC86295 05877000 LA 4,FDBD FDB pointer @SC88120 05877500 RETREG (0,3),(1,4) Return (3) as R0, (4) as R1 @SC89218 05878000 LR 4,3 Indicate we have it @SC88120 05878500 XC 0(8*FABDWDS,3),0(3) @SC86295 05879000 MVC FDBD(FDBCOP),0(5) Copy user's FDB @SC86295 05879500 MVC FDBLRC,FDBLRCTT Move lrecl to final location @SC92076 05880000 MVC FDBLRCTT,F0 @SC92076 05880500 MVC FABFN(18),0(2) @SC86295 05881000 OI FDBFLGS,FDBEPL @SC86295 05881500 MVI FABANIT+3,1 @SC86295 05882000 ICM 14,15,LFID(2) Get start and end for sending @SC89218 05882500 ICM 15,15,LFID+4(2) @SC89218 05883000 SLR 15,14 Length of request @SC89218 05883500 ST 15,FDBSREC Save for length computation @SC89218 05884000 BR 9 @SC86295 05884500 * 05885000 DSKLKP DMSKEY NUCLEUS @SC86295 05885500 CLI DSKCOD,3 Testing for possible output? @SC91269 05886000 BE DSKLKPW Yes, insist on writable @SC91269 05886500 CLI DSKCOD,2 Testing for possible output? @SC91269 05887000 BE DSKLKPW Yes, insist on writable @SC91269 05887500 CLI DSKCOD,11 Testing for possible output? @SC91269 05888000 BE DSKLKPW Yes, insist on writable @SC91269 05888500 GETFST DSKSTT Call system routine for FST @SC86295 05889000 B DSKLKP2 @SC91269 05889500 DSKLKPW GETFST DSKSTT,MODE=W Look for writable FST @SC91269 05890000 DSKLKP2 DS 0H @SC91269 05890500 LR 9,0 Save ADT ptr @SC86295 05891000 LR 8,1 And FST ptr @SC86295 05891500 LTR 1,15 Save return code @SC86295 05892000 DMSKEY RESET @SC86295 05892500 LTR 15,1 Test return code @SC86295 05893000 BR 2 @SC86295 05893500 * 05894000 * Set up search through list of files, pattern at (R1) 05894500 DSKNSET DS 0H @SC89073 05895000 NI DSKFL,255-CWDF Find files @SC86295 05895500 MVC NXFN(18),0(1) @SC86295 05896000 * 05896500 * Flush previous file pattern 05897000 DSKNSX MVI ADT,X'80' Start over @SC86295 05897500 B RTRN0 @SC86295 05898000 * 05898500 * Check CWD string, return code in R15 05899000 DSKCWDF DS 0H @SC89073 05899500 OI DSKFL,CWDF Find disk @SC86295 05900000 MVC NXFN(18),0(1) @SC86295 05900500 MVI ADT,X'80' Start over @SC86295 05901000 B NXTFST @SC86295 05901500 * 05902000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 05902500 DSKTSP L 5,FDBSIZE-FDBD(,1) Get actual size @SC90037 05903000 MVC DSKTRCF,FDBRCF-FDBD(1) Copy record format @SC92234 05903500 ICM 3,15,0(6) Get FAB ptr @SC90037 05904000 BZ DSKTSPX Not open yet @SC90037 05904500 IC 1,FABFM Get mode letter @SC90037 05905000 DSKTSP0 DS 0H @SC90037 05905500 USING FSTSECT,8 @SC90037 05906000 USING ADTSECT,9 @SC86316 05906500 L 9,IADT Look at 1st ADT @SC86316 05907000 DSKTSP1 CLM 1,1,ADTM Find right disk @SC90037 05907500 BE DSKTSP2 @SC86316 05908000 ICM 9,15,ADTPTR Try next @SC86316 05908500 BNZ DSKTSP1 @SC86316 05909000 B RTRN0 Disk not found! @SC86316 05909500 DSKTSP2 L 1,ADTNUM Total blocks @SC86316 05910000 AIF ('&CMSSFS' NE 'YES').CMSFS1 @SC92076 05910500 TM ADTFLG4,ADTDIR Shared File System? @AM90130 05911000 BO DSKTSFS Yes, do extra calculations @SC92076 05911500 .CMSFS1 ANOP @SC92076 05912000 S 1,ADTUSED Less used @SC86316 05912500 S 1,ADTARES Deduct reserve count (alt dir+map)@SC92234 05913000 DSKTSPC LA 7,4 Block overhead for F @SC92234 05913500 CLI DSKTRCF,C'F' Is it F? @SC92234 05914000 BE *+8 Yes @SC92234 05914500 LA 7,12 No, use overhead for V @SC92234 05915000 MR 6,1 Total overhead on free space @SC92234 05915500 D 6,ADTDBSIZ Convert to blocks @SC92234 05916000 BCTR 1,0 Deduct one more for good measure @SC92234 05916500 SR 1,7 Get the amount actually usable @SC92234 05917000 M 0,ADTDBSIZ Times block size @SC86316 05917500 SRDA 0,10 Convert to Kbytes @SC86316 05918000 CLR 1,5 @SC90037 05918500 BL RTRN1 No room @SC86316 05919000 B RTRN0 Ok @SC86316 05919500 DSKTSPX MVC DSKSTNM,0(2) File not opened yet, look for it @SC90037 05920000 BAL 2,DSKLKP @SC90037 05920500 IC 1,DSKSTNM+FABFM-FABFN Mode letter, in case @SC90037 05921000 BNZ DSKTSP0 Not found, nothing to erase @SC90037 05921500 TM ADTFLG4,ADTEDF Extended format? @SC90037 05922000 BZ DSKTSOF @SC90037 05922500 L 1,ADTDBSIZ Block size @SC90037 05923000 M 0,FSTADBC Number of blocks @SC90037 05923500 B DSKTSS @SC90037 05924000 DSKTSOF SR 0,0 @SC90037 05924500 LA 1,800 Block size @SC90037 05925000 MH 1,FSTDBC @SC90037 05925500 DSKTSS SRDA 0,10 Convert to kbytes @SC90037 05926000 SR 5,1 Assume old file will be erased @SC90037 05926500 BNP RTRN0 Will release enough for new file @SC90037 05927000 B DSKTSP2 Not enough, check free blocks @SC90037 05927500 * 05928000 AIF ('&CMSSFS' NE 'YES').CMSFS2 @SC92076 05928500 DSKTSFS ST 5,DSKMAX Save size needed @SC92076 05929000 LA 3,ADTFQDN Start of file pool name @SC92076 05929500 LA 1,8(,3) End of pool name field @SC92076 05930000 TRT 0(8,3),TRTBL Find first blank, if any @SC92076 05930500 SR 1,3 Get length of pool name @SC92076 05931000 ST 1,DSKPNLEN Set up plist @SC92076 05931500 * Get storage space limit @SC92076 05932000 LA 14,=CL8'DMSQLIMU' SFS Query Limits - Single User@SC92076 05932500 LA 15,DSKRTC @SC92076 05933000 LA 0,DSKREAS Reason code @SC92076 05933500 LA 1,ADTFQDN Start of file pool name @SC92076 05934000 LA 2,DSKPNLEN Length of name @SC92076 05934500 LA 3,ASTER User name (* = me) @SC92076 05935000 LA 4,F1 Length of name @SC92076 05935500 LA 5,DSKGRP @SC92076 05936000 LA 6,DSKMAX # of 4K blocks allowed @SC92076 05936500 LA 7,DSKUSD # used @SC92076 05937000 LA 8,DSKTHR @SC92076 05937500 STM 14,8,DSKQPLST @SC92076 05938000 OI DSKQPLST+40,X'80' Mark end of plist @SC92076 05938500 L 5,DSKMAX Restore needed size @SC92076 05939000 KCALL DMSCSL,DSKQPLST,EXT Get space quota info @SC92076 05939500 ICM 0,15,DSKRTC Did it work? @SC92076 05940000 BNZ RTRN0 No, just assume there's enough @SC92076 05940500 L 1,DSKMAX @SC92076 05941000 S 1,DSKUSD # of blocks left @SC92076 05941500 B DSKTSPC and rejoin @SC92076 05942000 .CMSFS2 ANOP @SC92076 05942500 * NXTFST Routine - searches the ADT and FST chains 05943000 DSKNXT DS 0H @SC89073 05943500 * Carl Kass and Jeff Damens, CUCCA User Services, 12/80 05944000 * Modified for Kermit-CMS by Vace Kundakci, 12/85 05944500 * Copyright (C) 1980 Columbia University 05945000 * Permission is granted to any individual or institution to copy 05945500 * or use this program, except for explicitly commercial purposes. 05946000 * 05946500 * NXFN,-FT,-FM contain a CMS fileid, possibly containing wildcard 05947000 * characters, and FST and ADT contain pointers to a valid ADT & FST 05947500 * or are null (negative ADT), return the next FST matching the given 05948000 * filename in FST and the address of the corresponding ADT in ADT. 05948500 * Also move the matched filename into FN, FT, FM. 05949000 * Also return info in a File Descriptor Block @SC86151 05949500 * 05950000 USING DCHSECT,1 05950500 NXTFST ICM 9,15,ADT Supplied ADT 05951000 BP NXFNEXT Use it if there's one 05951500 L 9,IADT Else, start with first ADT @SC86295 05952000 NI DSKFL,255-WFM-WFT-WFN Nothing wild yet 05952500 LA 3,NXFN @SC86295 05953000 BAL 14,NXFPAT @SC86295 05953500 OI DSKFL,WFN @SC86295 05954000 LA 3,NXFT @SC86295 05954500 BAL 14,NXFPAT @SC86295 05955000 OI DSKFL,WFT @SC86295 05955500 CLI NXFM,C'A' @SC86115 05956000 BNL NXFAFM Go if mode letter is A or more 05956500 MVI NXFM,C'%' Set to % if it was blank @SC86115 05957000 OI DSKFL,WFM 05957500 NXFAFM CLI NXFM+1,C'0' @SC86115 05958000 BNL NXFADT Go if mode number is numeric 05958500 MVI NXFM+1,C'%' Set to % if was blank or * @SC86115 05959000 NXFADT TM ADTFLG1,ADTFRO+ADTFRW 05959500 BZ NXFNADT 05960000 CLI NXFM,C'%' @SC86115 05960500 BE NXFFFST Go if he can use any 05961000 CLC ADTM,NXFM 05961500 BE NXFFFST Go if it is this disk 05962000 TM DSKFL,CWDF Called for CWD? @SC86295 05962500 BO NXFNADT Just looking for disk @SC86222 05963000 CLC ADTMX,NXFM Check for read-only extension @SC86222 05963500 BE NXFFFST Yes, search here too @SC86222 05964000 NXFNADT ICM 9,15,ADTPTR Use next ADT @SC86295 05964500 BNZ NXFADT But ony if it exists 05965000 NXFER MVI ADT,255 For next time, start all over 05965500 B RTRN1 Bad return code @SC86295 05966000 * 05966500 NXFPAT LA 1,8(3) End addr of FN or FT @SC86295 05967000 TRT 0(8,3),TRTBL Look for space @SC86295 05967500 SR 1,3 Compute length @SC86295 05968000 ST 1,NXFFNL-NXFN(3) Length of pattern @SC86295 05968500 MVI TRTBL+C' ',0 Don't want to catch a blank @SC86115 05969000 MVI TRTBL+C'%',1 Want to catch a percent @SC86115 05969500 MVI TRTBL+C'*',1 Want to catch an asterisk @SC86115 05970000 TRT 0(8,3),TRTBL See if any % or * in FN @SC86295 05970500 MVI TRTBL+C'%',0 Restore TRTBL @SC86115 05971000 MVI TRTBL+C'*',0 @SC86115 05971500 MVI TRTBL+C' ',1 @SC86115 05972000 BZ 4(14) No wild chars found @SC86295 05972500 BR 14 @SC86295 05973000 * 05973500 NXFFFST L 1,ADTFDA Grab hyperblock ptr 05974000 TM DSKFL,CWDF Called for CWD? @SC86295 05974500 BO NXFHSV Yes, found it @SC86164 05975000 NXFHYP ST 1,NXFHYPE Save for later 05975500 LA 8,DCHDATA Point to first FST 05976000 L 3,DCHDWSIZ Get size of hyperblock 05976500 SLL 3,3 Convert to bytes 05977000 LA 2,DCHSECT(3) Add to get end of hyperblk 05977500 ST 2,NXFHEND Save it 05978000 * 05978500 * All initialized. Ready to step through files. R8 contains current 05979000 * FST, R9 contains current ADT, NXFHYPE contains current hyperblock 05979500 * NXFHEND has end of hyperblock. 05980000 * 05980500 NXFFST CLI FSTN,0 Check if DIRECTORY or map @SC92350 05981000 BE NXFNFST Skip if so (or other garbage) @SC92350 05981500 CLI FSTFV,C'F' Ordinary RECFM? @SC90177 05982000 BE *+12 Yes, OK @SC90177 05982500 CLI FSTFV,C'V' Ordinary RECFM? @SC90177 05983000 BNE NXFNFST No, skip this item @SC90177 05983500 LA 4,NXFN @SC86295 05984000 LA 5,FSTN @SC86295 05984500 TM DSKFL,WFN @SC86295 05985000 BAL 14,NXFCOMP Test pattern against token @SC86295 05985500 LA 4,NXFT @SC86295 05986000 LA 5,FSTT @SC86295 05986500 TM DSKFL,WFT @SC86295 05987000 BAL 14,NXFCOMP Test pattern against token @SC86295 05987500 * 05988000 CLI NXFM+1,C'%' @SC86115 05988500 BE NXFHAVE Go if any FM is ok 05989000 CLC NXFM+1(1),FSTM+1 @SC86295 05989500 BNE NXFNFST Go if no match 05990000 NXFHAVE MVC FN,FSTN Return FN @SC86164 05990500 MVC FT,FSTT Return FT 05991000 MVC FM+1(1),FSTM+1 Return FM number 05991500 LA 3,DSKSTT @SC86295 05992000 MVC FDBSREC,F0 Length request not known @SC89218 05992500 BAL 14,DSKVALS Copy out quantities @SC86295 05993000 NXFHSV MVC FM(1),ADTM Return FM letter @SC86164 05993500 ST 9,ADT Save ADT for him @SC86295 05994000 ST 8,FST Ditto for FST @SC86164 05994500 B RTRN0 @SC86295 05995000 * 05995500 * Come to NXFNFST to step to next file. 05996000 * 05996500 NXFNEXT L 8,FST 05997000 NXFNFST TM ADTFLG4,ADTEDF 05997500 BZ NXFNEDF Go if not EDF 05998000 LA 8,FSTL2(8) Point to next EDF FST 05998500 AIF ('&CMSSFS' NE 'YES').CMSFS3 @SC92076 05999000 TM ADTFLG4,ADTDIR Shared file system? @EC89346 05999500 BZ NXFEDF No, skip @EC89346 06000000 LA 8,FSTL3-FSTL2(,8) Add additional dir ptr @EC89346 06000500 .CMSFS3 ANOP @SC92076 06001000 B NXFEDF 06001500 * 06002000 NXFNEDF LA 8,FSTL(8) Point to next non-EDF FST 06002500 NXFEDF C 8,NXFHEND End of hyperblock? 06003000 BL NXFFST No, there are more FSTs still 06003500 NXFNHYP L 1,NXFHYPE Point to current hyperblock 06004000 ICM 1,B'1111',DCHFWPTR Next hyperblock 06004500 BNZ NXFHYP Go use next hyperblock if any 06005000 B NXFNADT Need to use next disk 06005500 * 06006000 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06006500 RETREG (1,0) Return (0) as R1 to caller @SC89218 06007000 NI DSKFL,255-WARB @SC86295 06007500 TM ADTFLG4,ADTEDF Extended format? @SC86149 06008000 BZ DSKVNEF @SC86149 06008500 L 1,ADTDBSIZ Block size @SC86149 06009000 M 0,FSTADBC Number of blocks @SC86149 06009500 L 7,FSTAIC Get item count @SC86239 06010000 MVC FDBDATE+1(6),FSTADATI Copy file date/time @SC88235 06010500 B DSKVEF @SC86149 06011000 DSKVNEF SR 0,0 @SC86149 06011500 LA 1,800 Block size @SC86149 06012000 MH 1,FSTDBC @SC86149 06012500 LH 7,FSTIC Get item count @SC86239 06013000 PACK FDBDATE+1(2),FSTYR(3) Copy file year @SC86295 06013500 MVC FDBDATE+2(4),FSTD Copy file date/time @SC88235 06014000 DSKVEF SRDA 0,10 Convert to kbytes @SC86149 06014500 ST 7,FDBNREC Save number of records @SC89218 06015000 ICM 6,15,FDBSREC Length requested to send @SC89218 06015500 BZ DSKVFLN Not known @SC89218 06016000 CLR 7,6 Use min @SC89218 06016500 BNH *+6 @SC89218 06017000 LR 7,6 @SC89218 06017500 DSKVFLN DS 0H @SC89218 06018000 M 6,FSTIL Compute byte count (approx. if V) @SC86239 06018500 AL 7,=F'1023' Round up @SC87007 06019000 BC 12,*+8 No overflow @SC88092 06019500 LA 6,1(6) @SC86239 06020000 SRDA 6,10 @SC86239 06020500 CLR 1,7 Compare with official length @SC86239 06021000 BL *+6 @SC86239 06021500 LR 1,7 Use computed length instead @SC86239 06022000 LTR 1,1 @SC86239 06022500 BNZ *+8 @SC86239 06023000 LA 1,1 Never say zero length @SC86239 06023500 ST 1,FDBSIZE File size @SC86295 06024000 MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06024500 CLI FDBDATE+1,X'50' @SC86295 06025000 BH *+8 Ok @SC86295 06025500 MVI FDBDATE,X'20' Must be 21st @SC86295 06026000 MVC FDBRCF,FSTFV Copy format @SC86295 06026500 MVC FDBLRC,FSTIL+2 No, copy from FST @SC86295 06027000 LR 7,14 @SC86295 06027500 SR 0,0 Search from start @SC86295 06028000 LR 1,3 Filename in FAB @SC86295 06028500 A 13,F8 Preserve chain ptr in save area @SC86295 06029000 L 15,AACTLKP Find if active file @SC86295 06029500 BALR 14,15 @SC86295 06030000 S 13,F8 Resume ptr to save area @SC86295 06030500 LTR 15,15 Is it active? @SC86295 06031000 BNZR 7 @SC86295 06031500 OI FDBFLGS,FDBACTV Yes @SC86295 06032000 BR 7 @SC86295 06032500 * 06033000 DROP 1,8,9 @SC86295 06033500 * 06034000 NXFCOMP MVC NXFSTR,0(5) Copy name in @SC86295 06034500 BO NXFWF Go if wild FN or FT @SC86295 06035000 CLC NXFSTR,0(4) @SC86295 06035500 BNE NXFNFST Go if no match @SC86295 06036000 BR 14 @SC86295 06036500 * 06037000 NXFWF LA 1,8(5) Assume end @SC86295 06037500 TRT 0(8,5),TRTBL Look for first non-space @SC86295 06038000 SR 1,5 Compute length @SC86295 06038500 LR 7,1 Save length @SC86295 06039000 L 5,NXFFNL-NXFN(4) @SC86295 06039500 LA 6,NXFSTR @SC86295 06040000 * 06040500 * Enter here with R4-R7 containing: 06041000 * pattern address and length 06041500 * source address and length 06042000 * 06042500 NI DSKFL,255-WARB Haven't seen any of these @SC86295 06043000 ICM 7,B'1000',ASTER Use * as the fill char 06043500 WLDLOOP CLCL 4,6 Compare them 06044000 BER 14 They're equal, fine @SC86295 06044500 * 06045000 * String mismatch - so examine offending pattern character. If not 06045500 * % or * and we haven't seen any * yet, we fail. If it's % we just 06046000 * skip it; if it's * we skip it and remember we've seen it. Else 06046500 * back up to one past the last * and try again. 06047000 * 06047500 CLI 0(4),C'%' @SC86115 06048000 BE WLDLEN1 Go if % = LEN(1) pattern 06048500 CLI 0(4),C'*' @SC86115 06049000 BE WLDARB Go if * = ARB pattern 06049500 TM DSKFL,WARB @SC86295 06050000 BZ NXFNFST Go if ARB already seen @SC86295 06050500 CLM 7,B'0111',F0 More data to compare? 06051000 BE NXFNFST Go if exhausted @SC86295 06051500 LM 4,7,WLDPAT Restore addr of old ARB char 06052000 LA 6,1(6) Push one past 06052500 BCTR 7,0 Decrement length 06053000 STM 6,7,WLDSRC Store changed addr 06053500 B WLDLOOP And go compare again. 06054000 * 06054500 WLDLEN1 LA 4,1(4) Increment pattern addr 06055000 BCTR 5,0 Decrement pattern len 06055500 CLM 7,7,F0 Length to compare more @SC86119 06056000 BE NXFNFST None, pattern '%' is extra @SC86119 06056500 LA 6,1(6) Increment source addr 06057000 BCTR 7,0 Decrement source len 06057500 CLM 7,7,F0 Length to compare more @SC86119 06058000 BNE WLDLOOP Go if more data 06058500 LTR 5,5 Anything more in pattern? 06059000 BZR 14 No, it's a match @SC86295 06059500 CLI 0(4),C'*' @SC86115 06060000 BE WLDLOOP Go if ARB 06060500 B NXFNFST Failed @SC86295 06061000 * 06061500 * If pattern ends in ARB, then it will match anything. So return to 06062000 * caller if the pattern is exhausted. 06062500 * 06063000 WLDARB OI DSKFL,WARB Remember we saw one @SC86295 06063500 LA 4,1(4) Pass the ARB 06064000 BCTR 5,0 Decrement its length 06064500 LTR 5,5 Any more left? 06065000 BZR 14 No, it's a match @SC86295 06065500 STM 4,7,WLDPAT Save where they were 06066000 B WLDLOOP 06066500 DROP 3 @SC90264 06067000 * 06067500 LOCALS , @SC86295 06068000 WLDPAT DS A Place in pattern of last ARB 06068500 DS F Length of pattern past ARB 06069000 WLDSRC DS A Place in source when ARB seen 06069500 DS F Length of source past WLDSRC 06070000 ORG WLDPAT @SC92076 06070500 DSKQPLST DS 11F Plist for getting SFS quota @SC92076 06071000 DSKRTC DS F Return code from CSL @SC92076 06071500 DSKREAS DS F Reason code from CSL @SC92076 06072000 DSKGRP DS F SFS storage group number (ignored)@SC92076 06072500 DSKMAX DS F SFS storage maximum (4K blocks) @SC92076 06073000 DSKUSD DS F SFS storage used (4K) @SC92076 06073500 DSKTHR DS F SFS storage threshold @SC92076 06074000 DSKPNLEN DS F SFS storage pool name length @SC92076 06074500 DSKTRCF DS C Record format for space test @SC92234 06075000 ORG , @SC92076 06075500 DSKCOD DS X Saved DISKIO code @SC88308 06076000 * 06076500 WILD EXIT 06077000