home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
deleteme.tar.gz
/
deleteme.tar
/
ikcutl.asm
< prev
next >
Wrap
Assembly Source File
|
1993-10-21
|
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