home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
ibm370.zip
/
iktutl.asm
< prev
next >
Wrap
Assembly Source File
|
1993-10-21
|
204KB
|
2,483 lines
*COPY IKTUTL 05000000
CHECKVER IKTUTL,4.3 @SC90072 05000500
TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05001000
* Set new 'working directory', i.e., DSN prefix 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
SR 5,5 @SC86299 05003500
MVI IFILE+44,C' ' @SC86299 05004000
NTOKN N=CWDLEN,H=CWDERR @SC86299 05004500
LA 1,0(7,6) End of string @SC86299 05005000
BCTR 1,0 @SC86299 05005500
CLC =C'()',0(1) Prefix is PDS name? @SC86299 05006000
BNE CWDTL No @SC86299 05006500
S 7,F2 Yes, remove null member name @SC86299 05007000
BM CWDERR @SC86299 05007500
MVI IFILE+44,C'.' Indicate PDS wanted @SC86299 05008000
CWDTL LA 7,1(7) Token length @SC86299 05008500
CH 7,LA44+2 Suitable? @SC86299 05009000
BH CWDERR Too long @SC86299 05009500
LR 5,7 @SC86299 05010000
ICM 7,8,BLANK @SC86299 05010500
LA 0,IFILE @SC86299 05011000
LA44 LA 1,44 Length of DSN alone @SC86299 05011500
MVCL 0,6 Copy to filename buffer @SC86299 05012000
TR IFILE,UPCASE And upcase it @SC87034 05012500
NXTFSET IFILE,CWD,E=CWDERR @SC86295 05013000
CWDLEN MVC DEST(45),IFILE Save new prefix @SC86299 05013500
STH 5,DESTL @SC86299 05014000
B RTRN0 @SC86295 05014500
CWDERR PTEXT '&CWDERRM' @SC86299 05015000
B SUBERR @SC86295 05015500
* 05016000
* DSPACE Routine - display available disk space @SC86164 05016500
* 05017000
* Show space available in 'working directory' or other area 05017500
* Entry: SCANPTR string has option (none => working directory) 05018000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05018500
DSPACE ENTER ALT @SC86164 05019000
* * * * * * * * * * * * * * * * * * * * * * 05019500
PTEXT '&SPACERR' @SC86299 05020000
B SUBERR @SC86299 05020500
* * * * * * * * * * * * * * * * * * * * * * 05021000
B RTRN0 @SC86295 05021500
LOCALS , @SC86295 05022000
EXIT , @SC86295 05022500
TITLE 'FSPEC Routine - extract filespec from scan string' 05023000
* 05023500
* Entry: R1->name field, R0=flags selecting operation (see below) 05024000
* For parse operations, SCANPTR defines the input string. 05024500
* For getting foreign or display filespec, R7->output buffer 05025000
* Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05025500
* For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05026000
* 05026500
* Flags: Notes: 05027000
* Tasks: FFRCF FFSND FFGET FFNEW 05027500
* Parse RECV X set ROVR properly 05028000
* Parse SEND 1st X 05028500
* Parse SEND 2nd X X 05029000
* Parse GET 1st X 05029500
* Parse GET 2nd X X set ROVR properly 05030000
* Parse F-packet (FFHDR) X X X 05030500
* Parse for Generic(FFUTL) X X FFWLD: allow partial 05031000
* Parse TAKE 05031500
* 05032000
* Get unique name X R15: 0=>ok, 1=>bad 05032500
* Interactive name check X X R15: 0=>ok, 1=>bad 05033000
* Get foreign name (FFENC) X X R15->end of string 05033500
* Get display form (FFDSP) X X R15->end of string 05034000
* 05034500
FSPEC ENTER @SC86295 05035000
STC 0,FSPFLG @SC86295 05035500
LR 5,0 @SC88049 05036000
SRL 5,4 Convert flags to index @SC88049 05036500
LR 0,1 Copy ptr to filespec @SC86295 05037000
TM FSPFLG,FFNEW @SC86295 05037500
BO FSPWRN @SC86295 05038000
LR 8,1 Save ptr to DSN field @SC86299 05038500
XC 0(52,8),0(8) Clear DSN field @SC86299 05039000
MVC 52(8,8),=CL8' ' Clear password @SC88342 05039500
PTEXT '&BADFSPC' @SC86299 05040000
MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05040500
IC 5,FSP0(5) Get dispatch adr @SC88049 05041000
B FSP0(5) Go to proper handler @SC88049 05041500
* TAKE GET 1st SEND 1st Generic @SC88049 05042000
FSP0 DC AL1(FSPCPY-FSP0,FSPSN2-FSP0,FSPASC-FSP0,FSPUTL-FSP0) SC88049 05042500
* RECEIVE GET 2nd SEND 2nd F-packet @SC88049 05043000
DC AL1(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) @SC88049 05043500
FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05044000
BZ FSPASC No @SC86295 05044500
LA 1,LFID @SC88043 05045000
LA 14,DEST Default to prefix @SC88043 05045500
LH 15,DESTL @SC88043 05046000
BAL 2,FSPBPAD Copy with blank fill @SC88070 05046500
LR 0,8 Restore ptr to name field @SC88043 05047000
FSPASC TM FL2,SRV Server mode? @SC86295 05047500
BZ FSPCPY No, don't need to convert @SC86295 05048000
ICM 15,15,LEN Get length @SC86295 05048500
BZ FSPCPY @SC86295 05049000
BCTR 15,0 Correct for EX @SC86158 05049500
L 5,ADR Get string ptr @SC89215 05050000
EX 15,FSPTRAE Change to EBCDIC @SC89215 05050500
EX 15,FSPTRUP Upcase and dot to space @SC89215 05051000
B FSPCPY @SC86295 05051500
FSPTRAE TR 0(,5),ATOED @SC89301 05052000
FSPTRUP TR 0(,5),UPCASE @SC89215 05052500
FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05053000
NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05053500
MVI 0(1),C'$' Allow missing DSN @SC86299 05054000
B FSPCPY @SC86295 05054500
FSPHD MVI 0(1),1 Use default if missing DSN @SC86299 05055000
B FSPCPY @SC86299 05055500
FSPSN2 CLI BRK,C',' @SC88306 05056000
BE RTRN0 No foreign name: multiple format @SC88306 05056500
NTOKN H=FSP2H,N=RTRN0 @SC88306 05057000
LA 7,1(,7) Get token length @SC89179 05057500
LA 1,L'JFNAM @SC86295 05058000
CR 7,1 Does it fit? @SC89179 05058500
BNH *+6 Yes @SC86224 05059000
LR 7,1 Use what we can @SC86224 05059500
LR 3,0 @SC86295 05060000
STC 7,0(3) Save length @SC86224 05060500
LA 0,1(3) @SC86295 05061000
MVCL 0,6 Get fn, at least @SC86224 05061500
B RTRN0 @SC86295 05062000
* 05062500
FSPSLSH TRT 0(,6),FSPTRSL Find slash, if any @SC88342 05063000
FSPPSMV MVC 52(,8),1(1) Copy password into field @SC88342 05063500
* 05064000
FSPCPY NTOKN H=FSPH,N=FSPZ @SC86299 05064500
FSPCP2 MVC FSPCH1,0(6) Save 1st char @SC88043 05065000
MVI TRTBL+C'.',1 Set to intercept these @SC88043 05065500
MVI TRTBL+C'(',2 @SC86299 05066000
KCALL FOPSTR,LFID(,8),E=FSPINV @SC89218 05066500
LR 2,7 Save length-1 @SC88342 05067000
LA 15,44 Length of DSN proper @SC86299 05067500
AR 7,6 Last char of string @SC86299 05068000
LR 1,7 @SC88342 05068500
EX 2,FSPSLSH Look for '/' @SC88342 05069000
BZ FSPPSZ No password @SC88342 05069500
SR 7,1 Get length @SC88342 05070000
BNP FSPPSY None after all @SC88342 05070500
CH 7,*+10 Check against maximum @SC88342 05071000
BNH *+8 Ok @SC88342 05071500
LA 7,8 Max length @SC88342 05072000
BCTR 7,0 Prepare for MVC @SC88342 05072500
EX 7,FSPPSMV Move password to output field @SC88342 05073000
FSPPSY LR 7,1 Remove password from string @SC88342 05073500
BCTR 7,0 Remove '/' too @SC88342 05074000
FSPPSZ DS 0H @SC88342 05074500
CLI 0(6),C'''' Full name? @SC86299 05075000
BNE FSPPRE No, add prefix @SC86299 05075500
LA 6,1(6) Yes, skip over quote @SC86299 05076000
CLI 0(7),C'''' Must have close quote as well @SC86299 05076500
BNE *+6 @SC86299 05077000
BCTR 7,0 Back up over it @SC86299 05077500
BE *+8 @SC86299 05078000
BAL 9,FSPTU Missing: quit if user typed this @SC86299 05078500
B FSPPREZ @SC86299 05079000
FSPPRE CLI 0(7),C'''' Better not be trailing quote @SC86299 05079500
BNE *+10 Ok @SC86299 05080000
BAL 9,FSPTU Error @SC86299 05080500
BCTR 7,0 Didn't quit, so patch it up @SC86299 05081000
LH 1,DESTL Length of prefix @SC86299 05081500
LTR 1,1 Any? @SC86299 05082000
BZ FSPPREZ No @SC86299 05082500
LA 14,DEST Ptr to prefix string @SC86299 05083000
MVCL 0,14 Copy prefix to name field @SC86299 05083500
CLI DESTP,C'.' PDS? @SC86299 05084000
BNE FSPDOT No, join with a dot @SC88070 05084500
BAL 2,FSPBFIL Yes, prefix is entire DSN @SC88070 05085000
TM FSPFLG,FFHDR Reading from header packet? @SC88070 05085500
BNO FSPCPP No, user must have entered it @SC88070 05086000
BAL 9,FSPFDOT Ok, find file type, if any @SC88070 05086500
LR 7,1 And skip it @SC88070 05087000
B FSPCPG @SC88070 05087500
FSPDOT LA 14,LOCASE+C'.' @SC86299 05088000
LA 1,1 @SC86299 05088500
MVCL 0,14 Append a dot @SC86299 05089000
FSPPREZ BAL 2,FSPANAT Add '#' if numeric char next @SC86299 05089500
FSPCPA BAL 9,FSPFDOT Find a break (dot or end) @SC88070 05090000
SR 1,6 Length of token @SC86299 05090500
BP *+8 @SC86299 05091000
BAL 9,FSPTU Null token @SC86299 05091500
LR 14,6 Save start of token @SC86299 05092000
AR 6,1 Ptr to break @SC86299 05092500
CR 1,5 Max allowed for this token @SC86299 05093000
BNH *+10 Ok @SC86299 05093500
BAL 9,FSPTU Too long @SC86299 05094000
LR 1,5 Use max @SC86299 05094500
CR 1,15 Room left in name field? @SC86299 05095000
BNH FSPCPC Ok @SC86299 05095500
BAL 9,FSPTU Overfilled @SC86299 05096000
MVI TRTBL+C'.',0 Keep going, but ignore further tok@SC86299 05096500
LR 1,15 @SC86299 05097000
FSPCPC MVCL 0,14 Copy token @SC86299 05097500
BCT 2,FSPCPF Go if reached end of name @SC86299 05098000
LA 6,1(6) Skip over dot @SC86299 05098500
CR 6,7 Was dot the last char? @SC86299 05099000
BH FSPCPE Yes, oops @SC86299 05099500
C 15,F1 Room for another token? @SC86299 05100000
BH FSPDOT Ok, keep going @SC86299 05100500
SR 5,5 No, suppress further tokens @SC86299 05101000
BAL 9,FSPTU Quit if user typed it @SC86299 05101500
B FSPCPA Keep going @SC86299 05102000
FSPTRT TRT 0(,6),TRTBL Find end of token @SC86299 05102500
FSPCPE BAL 9,FSPTU Quit if user type it @SC86299 05103000
FSPCPF CR 6,7 @SC92147 05103500
BNL FSNOTGDG End of name, definitely not GDG @SC92147 05104000
CH 15,=H'9' Room for last GDG index? @SC92147 05104500
BL FSNOTGDG No, definitely not GDG @SC92147 05105000
CLI 1(6),C'+' @GA92147 05105500
BE FSCPGDG @GA92147 05106000
CLI 1(6),C'-' @GA92147 05106500
BE FSCPGDG @GA92147 05107000
CLI 1(6),C'0' @GA92147 05107500
BNE FSNOTGDG @GA92147 05108000
FSCPGDG SR 7,6 Get source length in R7 @GA92147 05108500
LA 7,1(,7) Bump length by 1 @GA92147 05109000
ICM 7,8,BLANK For padding @GA92147 05109500
LR 1,15 Dest length remaining @GA92147 05110000
MVCL 0,6 Move GDG 'member' @GA92147 05110500
CLM 7,7,F0 Any overflow? @SC92147 05111000
BE *+12 No, continue @SC92147 05111500
BAL 9,FSPTU Error @SC92147 05112000
MVI 43(8),C')' Try to repair it, if possible @SC92147 05112500
LR 7,6 Reset "end" ptr @SC92147 05113000
LA 5,FSPTBGDG Use table for GDG names @SC92147 05113500
B FSPCPG Go fill member field with blanks @SC92147 05114000
FSNOTGDG BAL 2,FSPBFIL Fill the rest with blanks @GA92147 05114500
LA 5,FSPTAB Use table for normal DSNAMEs @SC92147 05115000
BCTR 6,0 Back up to last char of DSN @SC86299 05115500
CR 6,7 @SC86299 05116000
BE FSPCPG No member name @SC86299 05116500
LA 6,2(6) Ptr to member name @SC86299 05117000
CLI 0(7),C')' Must be matching paren @SC86299 05117500
BE FSPCPG Ok @SC86299 05118000
BAL 9,FSPTU Oops @SC86299 05118500
FSPCPP LA 7,1(7) Pretend it's there @SC86299 05119000
FSPCPG SR 7,6 Length of member name @SC86299 05119500
LA 15,8 Length of member name, if any @SC88070 05120000
BZ FSPCPM None, forget it @SC86299 05120500
ST 5,FSPDSN Save table ptr @SC92147 05121000
BAL 2,FSPANAT '#' if numeric char next @SC86299 05121500
L 5,FSPDSN Restore @SC92147 05122000
FSPCPM LR 14,0 @SC86299 05122500
ICM 7,8,BLANK @SC86299 05123000
MVCL 14,6 Copy member name @SC86299 05123500
CLM 7,7,F0 Did it fit? @SC86299 05124000
BE *+8 @SC86299 05124500
BAL 9,FSPTU Oops @SC86299 05125000
MVC FSPDSN,0(8) Save raw name @SC86299 05125500
TR FSPDSN,UPCASE Upcase it @SC87034 05126000
TR 0(52,8),0(5) Convert to valid chars, if nec. @SC92147 05126500
TR 44(8,8),FSPMTAB Stricter limits on member name @SC86299 05127000
TR 52(8,8),UPCASE Upcase password, if any @SC88342 05127500
CLI FSPFLG,FFUTL DELETE? @SC88096 05128000
BE FSPTCNV Yes, allow '*' @SC88096 05128500
CLI FSPFLG,FFSND Send request? @SC88096 05129000
BE FSPTCNV Yes, allow '*' @SC88096 05129500
TR 0(52,8),FSPSTAB Convert asterisk to pound sign @SC88096 05130000
FSPTCNV DS 0H @SC88096 05130500
CLC FSPDSN,0(8) Any conversions? @SC86299 05131000
BE *+8 No, ok @SC86299 05131500
BAL 9,FSPTU Yes, quit if user typed it @SC86299 05132000
OI FL1,ROVR Found a name @SC86299 05132500
MVI TRTBL+C'.',0 Restore table @SC86299 05133000
MVI TRTBL+C'(',0 @SC86299 05133500
TM FSPFLG,FFHDR Parse for TAKE? @SC88043 05134000
BNZ RTRN0 No, fine @SC88043 05134500
CLI FSPCH1,C'''' Fully qualified? @SC88043 05135000
BE RTRN0 Yes, honor it @SC88043 05135500
LA 1,44(8) No, find end of name @SC88043 05136000
LR 14,1 @SC88043 05136500
TRT 0(44,8),TRTBL Get ptr to end+1 in R1 @SC88043 05137000
SR 14,1 Length remaining @SC88043 05137500
CH 14,=H'5' @SC88043 05138000
BL RTRN0 Too short anyway @SC88043 05138500
S 1,F8 @SC88043 05139000
CLC 0(8,1),DKERMINI Is it .KERMINI? @SC88113 05139500
BE RTRN0 Yes, that's ok @SC88043 05140000
CLC =C'.TAKE',3(1) Or is is .TAKE? @SC88043 05140500
BE RTRN0 That's ok too @SC88043 05141000
MVC 8(5,1),=C'.TAKE' No, use default type @SC88043 05141500
B RTRN0 @SC87034 05142000
* 05142500
FSPZ LA 6,=C'$.$' In case we must use default @SC87338 05143000
LA 7,3-1 @SC87338 05143500
CLI 0(8),1 @SC86299 05144000
BE FSPCP2 Get default DSN 'prefix.$.$' @SC87338 05144500
BH RTRN0 Don't insist @SC86299 05145000
PTEXT '&NOFSPEC' @SC86299 05145500
B FSPINV @SC86299 05146000
FSPTU TM FSPFLG,FFHDR @SC86299 05146500
BOR 9 From other Kermit, accept it @SC86299 05147000
FSPINV MVI TRTBL+C'.',0 Restore table @SC86299 05147500
MVI TRTBL+C'(',0 @SC86299 05148000
LA 15,2 @SC86299 05148500
B FSPPTRS @SC86295 05149000
* 05149500
FSPBFIL LR 1,15 Length remaining @SC88070 05150000
SR 15,15 Set up just to pad @SC88070 05150500
FSPBPAD ICM 15,8,BLANK @SC88070 05151000
MVCL 0,14 Copy with blank fill @SC88070 05151500
BR 2 @SC88070 05152000
* 05152500
FSPFDOT LA 1,1(7) End of string @SC88070 05153000
LA 2,2 In case no breaks @SC86299 05153500
SR 7,6 @SC86299 05154000
EX 7,FSPTRT Find break @SC86299 05154500
AR 7,6 Restore ptr to last char @SC86299 05155000
BR 9 @SC88070 05155500
* 05156000
FSPH PTEXT '&FMTFSPC&FSPCPRM' @SC91224 05156500
CLI FSPFLG,FFSND SEND 1st? @SC89261 05157000
BE *+8 Yes, use whole message @SC89261 05157500
SH 4,=H'&FMTOPT' Chop off option part @SC91224 05158000
B FSP0H @SC86295 05158500
FSP2H PTEXT '&FORFSPC' @SC86295 05159000
FSP0H LA 15,1 @SC86295 05159500
FSPPTRS RETREG 3,4 Return msg ptrs @SC86295 05160000
FSPRET RET , @SC86295 05160500
* 05161000
* Non-parsing functions . . . 05161500
* 05162000
* Get unique filespec 05162500
FSPWRN LR 4,1 Save name ptr @SC86295 05163000
TM FSPFLG,FFENC @SC86295 05163500
BO FSPENC Encode name into buffer @SC86295 05164000
TM FSPFLG,FFDSP @SC86295 05164500
BO FSPDSP Copy name into buffer for display @SC86295 05165000
TM FL4,NMOK Already checked? @SC87012 05165500
BO RTRN0 Yes, ok @SC87012 05166000
MVC XFILE,0(4) Save original name @SC90033 05166500
* This routine checks to see if the old data set is a PDS. @TS86001 05167000
* If so, it then allocates and opens the data set and does a @TS86001 05167500
* FIND to determine if the member is present. @TS86001 05168000
LA 5,10 Allowed retries (0-9) @SC88125 05168500
LA 7,C'0' Extra character @BS86001 05169000
MVC FSPDSN,0(4) @SC87015 05169500
BAL 9,FSPTOPN @SC87015 05170000
USING FDBD,1 @SC87015 05170500
CLI FSPDSMB,C' ' Member specified? @SC87015 05171000
BE FSPNOPDS No, be sure it isn't a PDS @SC87015 05171500
TM FDBFLGS,PDSF Yes, be sure it is @SC87015 05172000
BZ RTRN1 Too bad @SC87015 05172500
XC FSPDSMB,FSPDSMB Signal DSORG=PO for allocation @SC88119 05173000
OPENF I,FSPDSN,FILFDB,PDSPTR,E=FSPDERM @SC88049 05173500
MVC FSPDSMB,44(4) Copy requested member name @SC87015 05174000
LA 1,FSPDSMB+7 Last char of member @SC87015 05174500
TRT FSPDSMB,TRTBL Find blank @SC87015 05175000
LR 6,1 Tentative byte to modify @SC86299 05175500
BAL 3,FSPRMPT Set up rechecking via R3 @SC88125 05176000
FSPTFND L 1,PDSPTR @SC87015 05176500
FIND (1),FSPDSMB,D Search for member name @SC87015 05177000
B *+4(15) Branch on return code @TS86001 05177500
B 0(9) 0 - member was found @TS86001 05178000
B FSPNOKM 4 - member not found @TS86001 05178500
B FSPDERR 8 - I/O error or lack of memory @TS86001 05179000
FSPTOPN OPENF T,FSPDSN,E=FSPNOKD No collision @SC87015 05179500
BR 9 @SC87015 05180000
FSPNOPDS TM FDBFLGS,PDSF Be sure it isn't a PDS @SC87015 05180500
BO FSPDERM Too bad @SC88076 05181000
LA 3,FSPTOPN Just test DSN for existence @SC87015 05181500
MVI TRTBL+C'.',1 @SC87015 05182000
TRT FSPDSN(9),TRTBL Find end of 1st index @SC87015 05182500
LR 6,1 @SC87015 05183000
LA 1,8(6) Last possible end of 2nd @SC87015 05183500
TRT 2(7,6),TRTBL @SC87015 05184000
MVI TRTBL+C'.',0 Restore TRT @SC87015 05184500
LR 6,1 Byte to modify @SC87015 05185000
BZ FSPRMPT Index level was 8 bytes @SC87015 05185500
CLI FSPDSN+43,C' ' Exactly 44 bytes already? @SC88125 05186000
BE *+10 No, there's some room @SC88125 05186500
BCTR 6,0 Yes, can't shift name over @SC88020 05187000
B FSPRMPT @SC88020 05187500
LA 1,FSPDSN @SC87015 05188000
MVC 1(43,1),0(4) Shift name over one @SC87015 05188500
SR 6,1 @SC87015 05189000
EX 6,FSPMVDS And copy beginning back @SC87015 05189500
AR 6,1 @SC87015 05190000
FSPRMPT OI FL4,NMCHNG Yes, remember collision occurred @SC90033 05190500
CLI CLSNFL,C'O' Old-fashioned WARNING ON? @SC90033 05191000
BNE FSPSTA No, concoct unique name @SC90033 05191500
TM FSPFLG,FFGET User typed it? @SC87015 05192000
BO FSPRMP2 Yes @TS86001 05192500
FSPSTA STC 7,0(6) Modify DSN @SC88125 05193000
BALR 9,3 See if still a conflict @SC88125 05193500
LA 7,1(7) Bump counter @BS86001 05194000
BCT 5,FSPSTA @BS86001 05194500
FSPDERR CLOSF PDSPTR Close the data set @SC87015 05195000
FSPDERM PTEXT '&FILCLSN' @SC88049 05195500
L 1,EMSGP Explanatory message @SC88049 05196000
MVC 0(21,1),0(3) @SC88049 05196500
ST 4,EMSGL @SC88049 05197000
B FSP0H Return ptrs and rc=1 @SC88049 05197500
FSPMVDS MVC 0(,1),0(4) @SC88020 05198000
FSPNOKM MVC 44(8,4),FSPDSMB @SC87015 05198500
FSPNOKD MVC 0(44,4),FSPDSN Copy name back @SC87015 05199000
FSPNOK OI FL4,NMOK @SC87015 05199500
CLOSF PDSPTR @SC87015 05200000
B RTRN0 @SC87015 05200500
FSPRMP2 LA 7,CMD @SC87015 05201000
LA 0,FFDSP @SC87015 05201500
KCALL FSPEC,(4) Format DSN for message @SC87015 05202000
PTEXT '&QQWRITE',AREG=0,LREG=1 Ask if ok @SC92300 05202500
LR 2,15 @SC92300 05203000
LR 3,1 @SC92300 05203500
MVCL 2,0 @SC92300 05204000
SR 2,7 @SC92300 05204500
RTEXT (7),PROMPT=((7),(2)) @SC92300 05205000
LTR 0,0 Length of reply @SC87015 05205500
BNP FSPDERR If zero give up @SC88076 05206000
TR 0(9,7),UPCASE Upcase 1st chars of reply @SC87015 05206500
CLC =C'&AAAAAOK',0(7) Was reply "ok"? @SC88076 05207000
BNE FSPDERR No, abort operation @SC88076 05207500
B FSPNOK @SC87015 05208000
* 05208500
* Encode name at (R1) into (R7) buffer (in ASCII), possibly with 05209000
* substitution from JFSPEC, but disable subsequent subst. 05209500
* Return updated ptr in R15 05210000
FSPENC LA 1,JFSPEC Complex string? @SC86224 05210500
BAL 14,PAKFOR @SC86224 05211000
BNZ FSPECPZ Yes, name overridden @SC86299 05211500
CLI 44(4),C' ' Member? @SC86299 05212000
BE FSPENT No, get name and type from DSN @SC86299 05212500
MVC 0(8,7),44(4) Yes, use member name @SC88070 05213000
LA 1,8(7) Possible end @SC88070 05213500
TRT 0(8,7),TRTBL Find end of name @SC88070 05214000
LR 5,1 Save @SC88070 05214500
BAL 9,FSPESCNS Find last DSN qualifier @SC88070 05215000
MVI 0(5),C'.' Join to member name @SC88070 05215500
MVC 1(8,5),0(3) Copy the qualifier @SC88070 05216000
SR 5,7 Length of member name @SC88070 05216500
LA 1,1(5,1) Adjust effective end of DSN @SC88070 05217000
B FSPENTR Done, convert to ASCII @SC88070 05217500
FSPENT BAL 9,FSPESCNS Find last qualifier @SC88070 05218000
BCTR 3,0 Move back to separating dot @SC88070 05218500
BAL 9,FSPESCN Back to previous qualifier @SC88070 05219000
MVC 0(17,7),0(3) At most 2 tokens + dot @SC86299 05219500
B FSPENTR Done, convert to ASCII @SC88070 05220000
* 05220500
FSPESCNS LA 1,44(4) @SC86299 05221000
TRT 0(44,4),TRTBL Find end of DSN @SC86299 05221500
LR 3,1 @SC92147 05222000
BCTR 3,0 Check to see if relative GDG @SC92147 05222500
CLI 0(3),C')' @SC92147 05223000
BNE FSPESCN2 No, that's fine @SC92147 05223500
FSPESCNL BCTR 3,0 Look back for opening parenthesis @SC92147 05224000
CR 3,4 Past beginning of DSN? @SC92147 05224500
BL FSPESCN2 Yes, must be weird @SC92147 05225000
CLI 0(3),C'(' @SC92147 05225500
BNE FSPESCNL Keep looking @SC92147 05226000
LR 1,3 Found it, lop off relative number @SC92147 05226500
FSPESCN2 DS 0H @SC92147 05227000
LR 3,1 @SC86299 05227500
FSPESCN BCTR 3,0 Scan back for dots @SC86299 05228000
CR 3,4 Past beginning of DSN? @SC86299 05228500
BL FSPECP Yes, use all @SC86299 05229000
CLI 0(3),C'.' No, found dot? @SC86299 05229500
BNE FSPESCN No, keep looking @SC86299 05230000
FSPECP LA 3,1(3) Stuff to copy @SC86299 05230500
BR 9 @SC88070 05231000
FSPENTR DS 0H Translate and adjust ptr @SC88070 05231500
TR 0(17,7),ETOAD @SC89301 05232000
SR 1,3 Length of stuff copied @SC86299 05232500
AR 7,1 Advance ptr @SC86299 05233000
FSPECPZ MVI JFSPEC,0 Turn off string @SC86299 05233500
FSPENR LR 15,7 Save ptr @SC86295 05234000
B FSPRET @SC86295 05234500
* 05235000
* Copy name at (R1) into (R7) buffer in display form 05235500
* Return updated ptr in R15 05236000
FSPDSP LR 14,7 Copy output ptr @SC86299 05236500
LA 2,DEST Check if prefix exists @SC86299 05237000
LH 3,DESTL @SC86299 05237500
LTR 3,3 @SC86299 05238000
BZ FSPDCP No prefix, skip quotes @SC86299 05238500
LA 1,1(3) One extra for dot @SC86299 05239000
ICM 3,8,LOCASE+C'.' @SC86299 05239500
CLCL 0,2 Does it match prefix? @SC86299 05240000
BE FSPDCP Yes, chop it off @SC86299 05240500
LR 0,4 No, use quotes for whole name @SC86299 05241000
MVI 0(14),C'''' @SC86299 05241500
LA 14,1(14) @SC86299 05242000
FSPDCP LA 1,44(4) @SC86299 05242500
TRT 0(44,4),TRTBL Find end of name @SC86299 05243000
SR 1,0 Length @SC86299 05243500
LR 15,1 @SC86299 05244000
MVCL 14,0 Copy name to buffer @SC86299 05244500
CLI 44(4),C' ' Member name, too? @SC86299 05245000
BE FSPDCY No, done @SC86299 05245500
MVI 0(14),C'(' Yes, insert in parens @SC86299 05246000
MVC 1(8,14),44(4) Copy name to buffer @SC86299 05246500
LA 1,9(14) @SC86299 05247000
TRT 1(8,14),TRTBL Find end of member name @SC86299 05247500
MVI 0(1),C')' Close member name @SC86299 05248000
LA 14,1(1) @SC86299 05248500
FSPDCY LR 15,14 Return output ptr @SC86299 05249000
CLI 0(7),C'''' Need close quote? @SC86299 05249500
BNE *+12 No, that's all @SC86299 05250000
MVI 0(15),C'''' Yes, do it @SC86299 05250500
LA 15,1(15) @SC86299 05251000
B FSPRET @SC86299 05251500
* 05252000
* Insert '#' if token would otherwise begin with a digit @SC86299 05252500
FSPANAT LA 5,8 Tentative token length @SC86299 05253000
CLI 0(6),C'0' Digit? @SC86299 05253500
BLR 2 No, ok @SC86299 05254000
CLI 0(6),C'9' Really? @SC86299 05254500
BHR 2 No, but illegal anyway @SC86299 05255000
BAL 9,FSPTU Bad form @SC86299 05255500
LA 14,LOCASE+C'#' @SC86299 05256000
LA 1,1 @SC86299 05256500
MVCL 0,14 Copy '#' @SC86299 05257000
BCTR 5,0 Now allow only 7 @SC86299 05257500
BR 2 @SC86299 05258000
* 05258500
FSPTRSL DC XL256'00' For finding a '/' @SC88342 05259000
ORG FSPTRSL+C'/' @SC88342 05259500
DC X'1' @SC88342 05260000
ORG , @SC88342 05260500
* 05261000
* Valid DSN characters @SC86299 05261500
FSPTAB DC 64C'#',C' ' space @SC86299 05262000
DC 10C'#',C'.' dot @SC86299 05262500
DC 15C'#',C'$*' dollar sign, asterisk @SC86299 05263000
DC 03C'#',C'-' hyphen @SC86299 05263500
DC 26C'#',C'#@' pound sign, at sign @SC86299 05264000
DC 04C'#',C'ABCDEFGHI' a-i @SC86299 05264500
DC 07C'#',C'JKLMNOPQR' j-r @SC86299 05265000
DC 08C'#',C'STUVWXYZ' s-z @SC86299 05265500
DC 22C'#',C'{ABCDEFGHI' {,A-I @SC86299 05266000
DC 07C'#',C'JKLMNOPQR' J-R @SC86299 05266500
DC 08C'#',C'STUVWXYZ' S-Z @SC86299 05267000
DC 06C'#',C'0123456789' 0-9 @SC86299 05267500
DC 06C'#' @SC86299 05268000
* Valid GDG name characters @SC92147 05268500
FSPTBGDG DC 64C'#',C' ' space @SC92147 05269000
DC 10C'#',C'.' dot @SC92147 05269500
DC 01C'#',C'(+' paren, plus (for GDGs) @GA92147 05270000
DC 12C'#',C'$*)' dollar, asterisk, paren @GA92147 05270500
DC 02C'#',C'-' hyphen @GA92147 05271000
DC 26C'#',C'#@' pound sign, at sign @SC92147 05271500
DC 04C'#',C'ABCDEFGHI' a-i @SC92147 05272000
DC 07C'#',C'JKLMNOPQR' j-r @SC92147 05272500
DC 08C'#',C'STUVWXYZ' s-z @SC92147 05273000
DC 22C'#',C'{ABCDEFGHI' {,A-I @SC92147 05273500
DC 07C'#',C'JKLMNOPQR' J-R @SC92147 05274000
DC 08C'#',C'STUVWXYZ' S-Z @SC92147 05274500
DC 06C'#',C'0123456789' 0-9 @SC92147 05275000
DC 06C'#' @SC92147 05275500
* Valid member name characters @SC86299 05276000
FSPMTAB DC 75AL1(*-FSPMTAB),C'#' dot @SC86299 05276500
DC 20AL1(*-FSPMTAB),C'#' hyphen @SC88096 05277000
DC 95AL1(*-FSPMTAB),C'#' { @SC86299 05277500
DC 63AL1(*-FSPMTAB) @SC86299 05278000
* Replace asterisks if not a send request @SC88096 05278500
FSPSTAB DC 92AL1(*-FSPSTAB),C'#' asterisk @SC88096 05279000
DC 163AL1(*-FSPSTAB) @SC88096 05279500
LOCALS , @SC86295 05280000
PDSPTR DS A Ticket for PDS testing @SC87015 05280500
FSPDSN DS 0CL60 Temp for name field @SC88342 05281000
PDSNM DS CL44 Test DSN @SC87015 05281500
FSPDSMB DS CL8 Test member @SC87015 05282000
FSPPASS DS CL8 Password @SC88342 05282500
FSPFLG DS X Filespec flags @SC86295 05283000
FSPCH1 DS C Saved 1st char of spec. @SC88043 05283500
FSPEC EXIT @SC86295 05284000
TITLE 'KHELP routine - perform HELP command' 05284500
* Handle HELP command, rest of string given by SCANPTR. 05285000
* On entry, R6->help command string 05285500
KHELP ENTER , @SC86355 05286000
LR 8,6 Save ptr to command @SC88043 05286500
NTOKN N=KHLI See if subcommand given @SC86355 05287000
L 1,=A(USNCMD) Command table @SC87117 05287500
SCAN (1),KHLF,NODISP @SC86355 05288000
WTEXT '&BADSBCM' Not found @SC86355 05288500
RET , @SC86355 05289000
KHLF CLM 7,8,F0 Just '?' @SC86355 05289500
BE RTRN Yes, done @SC86355 05290000
KHLI LM 6,7,SCANPTR Rest of string @SC88043 05290500
AR 6,7 Ptr to end @SC88043 05291000
LR 0,8 Start of command @SC88043 05291500
SR 6,0 Total length @SC88043 05292000
NI FL4,255-UCMD @SC88043 05292500
KCALL SUPFNC,3 Do it @SC86355 05293000
RET , @SC86355 05293500
LOCALS , 05294000
KHELP EXIT , @SC87007 05294500
TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05295000
SUPFNC ENTER @SC86295 05295500
* On entry, R1 = operation code, R0 = possible ptr @SC86158 05296000
* Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05296500
* ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05297000
* 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05297500
* 2 -> Clean up afterwards and stop interception 05298000
* 3 -> Execute host command with or without interception 05298500
* If UCMD set, SCANPTR gives text, else R0->text,R6=len 05299000
* 4 -> (not used) 05299500
* 5 -> Stop interception if going 05300000
* 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05300500
* 7 -> Test for stacked lines, return number in R15 05301000
* 8 -> Log off (must return to TMP) 05301500
* 9 -> Wait specified time 05302000
* 10-> Return clock time in R15 (centisec) 05302500
* 11-> Setup up new prompt string at (R0) 05303000
STC 1,SFCFLGS @SC92342 05303500
AR 1,1 @SC92342 05304000
LH 1,SFCT-2(1) @SC92342 05304500
B SFCT(1) @SC92342 05305000
SFCT DC Y(ICPBEG-SFCT,ICPFIN-SFCT,ICPHST-SFCT) 1-3 @SC92342 05305500
DC Y(ICPCMIL-SFCT,ICPRST-SFCT,SFCLIN-SFCT) 4-6 @SC92342 05306000
DC Y(SFCSTK-SFCT,SFCKIL-SFCT,SFCWT-SFCT) 7-9 @SC92342 05306500
DC Y(SFCCLK-SFCT,SFCRET-SFCT,SFCRET-SFCT) 10-12 @SC92342 05307000
* 05307500
* Start interception, initialize ptrs @SC86158 05308000
ICPBEG DS 0H @SC92342 05308500
MVI ERRNUM,ERRNOE OK @SC86158 05309000
L 1,WBUF Output buffer @SC90264 05309500
LA 0,2048(,1) Skip over some, to be safe @SC90264 05310000
A 1,F64KP End of buffer @SC90264 05310500
LR 15,0 @SC86158 05311000
STM 15,0,TXTPTR Save @SC86158 05311500
STM 0,1,SVCOPTR @SC86158 05312000
SR 1,0 Get length @SC86158 05312500
L 15,=X'15000000' @SC86158 05313000
MVCL 0,14 Fill with NL (X'15') @SC86158 05313500
* ------------ determine if SVC screen is possible @SC88026 05314000
* - if so, then do it @SC88026 05314500
B ICPSTK @SC88026 05315000
MVI ICPFL,2 Now intercepting subtask SVC's @SC88026 05315500
SFCRET DS 0H @SC92342 05316000
B RTRN0 @SC88026 05316500
* Can't screen SVC's, create a STACK element @SC88026 05317000
ICPSTK OPENF T,STKDSN,E=ICPST2 See if any previous output @SC88026 05317500
USING FDBD,1 Yes, clear it @SC88106 05318000
SR 3,3 @SC88106 05318500
LA 4,FDBDEVT-2 Create volume list (n,type,vol) @SC88106 05319000
MVC 0(2,4),F1+2 Just one volume @SC88106 05319500
STM 2,4,SFCDEL+4 Simulate CAMLST @SC88106 05320000
MVI SFCDEL,X'0C' Code for UNCAT @SC88106 05320500
CATALOG SFCDEL @SC88106 05321000
MVI SFCDEL,X'41' Codes for SCRATCH @SC88106 05321500
MVI SFCDEL+2,X'40' @SC88106 05322000
SCRATCH SFCDEL @SC88106 05322500
DROP 1 @SC88106 05323000
ICPST2 LA 1,STKDSN Get ptrs to DYNALC arguments @SC88026 05323500
LA 2,STKDD @SC88026 05324000
LA 3,FILUNT @SC88026 05324500
LA 4,FILVOL @SC88026 05325000
LA 5,=X'42' NEW,CATLG @SC88026 05325500
LA 6,FILTRKAL @SC88026 05326000
LA 7,STKDRC @SC88026 05326500
STM 1,7,STKDYN Set up calling sequence @SC88026 05327000
OI STKDYN+24,X'80' No buffer ptr @SC88119 05327500
KCALL DYNALC,STKDYN,EXT Allocate output file @SC88026 05328000
MVI CPECB,0 Clear ECB (for neatness) @SC88076 05328500
STACK MF=(E,IOPLAREA),PARM=STKA Create STACK elt. @SC88026 05329000
MVI ICPFL,1 Now intercepting @SC87020 05329500
B RTRN0 @SC86295 05330000
* Clean up after interception @SC86295 05330500
ICPFIN DS 0H @SC92342 05331000
L 5,SVCOPTR End of text @SC86158 05331500
ST 5,TXTPTR+4 Save @SC86158 05332000
ICPRST CLI ICPFL,2 Were we intercepting SVC's? @SC92342 05332500
BNE ICPFINST No, see if STACK @SC88026 05333000
*---------- stop snagging SVC's @SC88026 05333500
B ICPRST1 Ok @SC88026 05334000
ICPFINST CLI ICPFL,1 Were we intercepting via STACK? @SC88026 05334500
BNE ICPRST1 No, fine @SC88026 05335000
MVI CPECB,0 Clear ECB (for neatness) @SC88076 05335500
STACK MF=(E,IOPLAREA),PARM=STKZ Yes, remove STACK elt.@SC88026 05336000
CLI SFCFLGS,5 Stop intercepting without cleanup?@SC92342 05336500
BE ICPRST1 Yes, quit now @SC92342 05337000
* Copy output to buffer @SC88026 05337500
OPENF I,STKDSN,FILFDB,STKTKT,E=ICPRST1 @SC88026 05338000
L 3,STKTKT Ptr to FAB @SC88106 05338500
USING FABD,3 @SC88106 05339000
L 5,TXTPTR+4 Buffer ptr @SC88026 05339500
ICPSTLP READF STKTKT,BUFFER=(5),BSIZE=255,E=ICPSTZ @SC88026 05340000
TM FDBFLGS,FABRECCC Carriage control? @SC88246 05340500
BZ *+8 No, that's fine @SC88106 05341000
MVI 0(5),C' ' Yes, blank it out @SC88106 05341500
AR 5,0 Space over data @SC88026 05342000
LA 5,1(5) Leave one X'15' @SC88026 05342500
B ICPSTLP And read more @SC88026 05343000
ICPSTZ CLOSF STKTKT Done @SC88026 05343500
ST 5,TXTPTR+4 New end of output @SC88026 05344000
DROP 3 @SC88106 05344500
ICPRST1 MVI ICPFL,0 @SC87020 05345000
B RTRN0 05345500
* Execute TSO command at (R0) with length (R6), unless UCMD set, 05346000
* in which case string given by SCANPTR 05346500
ICPHST DS 0H @SC92342 05347000
TM FL4,UCMD User command? @SC86295 05347500
BO ICPCM0 Yes, scan already set up @SC86355 05348000
ICPCMI ST 0,ADR Set scan string ptrs @SC86355 05348500
ST 6,LEN @SC86355 05349000
ICPCM0 LM 0,1,SCANPTR Get length and adr @SC87034 05349500
LTR 6,0 Copy length @SC87034 05350000
BNP ICPCMIL No good @SC87034 05350500
BCTR 6,0 @SC87034 05351000
LA 5,0(6,1) Point to last character in string @GH89057 05351500
NTOKN N=ICPCMIL No good @SC86355 05352000
MVI SFCBUF+4,C' ' Initialize command buffer ... @GH89057 05352500
MVC SFCBUF+4+1(256-1),SFCBUF+4 ... to blanks @GH89057 05353000
SR 5,6 Compute decremented length ... @GH89057 05353500
MVC SFCBUF+4(*-*),0(6) Copy text to command buffer @GH89057 05354000
EX 5,*-6 ... and nothing else @GH89057 05354500
LR 5,6 Start of command name @SC86355 05355000
EX 7,TRUPCAS Capitalize command name @GH89112 05355500
LA 7,1(7) Length of name @SC86355 05356000
MVC EXCFLG,0(6) Copy 1st character (% if implicit)@SC89073 05356500
CLI 0(6),C'%' Is it implicit EXEC? @SC89073 05357000
BNE SFCCM1 No @SC89073 05357500
BCT 7,*+8 Yes, chop off '%' @SC89073 05358000
B ICPCMIL Oops, name was just '%' @SC89073 05358500
LA 6,1(6) @SC89073 05359000
SFCCM1 DS 0H @SC89073 05359500
ICM 7,8,BLANK Set up for padding @SC86355 05360000
L 2,ORGR1 Get address of kermit CPPL @TS86001 05360500
MVC ATCHCPPL(16),0(2) initialize attach CPPL @TS86001 05361000
LA 2,ATCHCPPL Get address of attach CPPL @TS86001 05361500
USING CPPL,2 Make attach CPPL addressable @TS86001 05362000
LA 1,SFCBUF @SC86355 05362500
ST 1,CPPLCBUF Put the command buffer into CPPL @TS86001 05363000
L 3,CPPLECT Get the ECT address @TS86001 05363500
USING ECT,3 Make it addressable @TS86001 05364000
MVC ECTPCMD,ORGPCMD Initialize, in case sub HELP @SC89052 05364500
LA 14,ECTSCMD @SC86355 05365000
LA 15,L'ECTSCMD @SC86355 05365500
MVCL 14,6 Copy to subcommand field @SC86355 05366000
CLM 7,7,F0 @SC88054 05366500
BNE ICPCMIL Command name longer than 8 @SC88054 05367000
CLI ECTSCMD,C'H' Is it HELP? @SC88043 05367500
BNE *+12 It's not subcommand help @SC88043 05368000
TM FL4,UCMD It might be (if generated) @SC88043 05368500
BZ *+10 ... yes, HELP as subcommand @SC88043 05369000
MVC ECTPCMD,ECTSCMD This is really a command @SC88026 05369500
LR 4,6 Default parameter ptr @SC86355 05370000
LR 8,6 Default end of string @SC86355 05370500
NTOKN N=SFCNPRM Find parameters, if any @SC86355 05371000
L 8,ADR @SC86355 05371500
A 8,LEN True end of string @SC86355 05372000
LR 4,6 Start of parameters @SC86355 05372500
SFCNPRM SR 4,5 Get offset to parameters @SC86355 05373000
STH 4,SFCBUF+2 Save in command buffer @SC86355 05373500
MVC SFCBLDL(4),=H'1,60' Set BLDL count & length @SC90149 05374000
SR 8,5 Get total length @SC86355 05374500
LA 8,4(8) Plus prefix info @SC88022 05375000
STH 8,SFCBUF Save in command buffer @SC86355 05375500
CLI EXCFLG,C'%' Check for explicit implicit clist @SC89073 05376000
BNE SFCLOCCP Try for a CP first @GH89056 05376500
SFCEXEC XC SFCBUF+2(2),SFCBUF+2 Indicate implicit clist @GH89056 05377000
CLC ECTSCMD,=CL8'EXEC' (Avoid looping) @GH89056 05377500
BE ICPCMIL This shouldn't happen! @GH89056 05378000
MVC SFCBLDL+4(8),ECTSCMD Copy into BLDL list @GH89050 05378500
ICM 1,15,SYSPROC Ptr to CLIST library DCB @SC89073 05379000
BZ ICPCMIL No such library @SC89073 05379500
BLDL (1),SFCBLDL @SC89073 05380000
LTR 15,15 @SC89073 05380500
BNZ ICPCMIL Couldn't find the CLIST @SC89073 05381000
MVC ECTPCMD,=CL8'EXEC' Ok, locate EXEC @GH89056 05381500
MVC ECTSCMD,=CL8'EXEC' @GH89056 05382000
SFCLOCCP DS 0H Come here to try again @GH89056 05382500
MVC SFCBLDL+4(8),ECTSCMD Copy into BLDL list @GH89050 05383000
BLDL 0,SFCBLDL Check for command to ATTACH @GH89050 05383500
LTR 15,15 Does command exist? @GH89050 05384000
BNZ SFCEXEC No: assume a CLIST @GH89056 05384500
STAX SFCATTN,DEFER=NO,REPLACE=NO,MF=(E,SFCSTBL), @SC88118+05385000
USADDR=ATCHECB In case subtask has no STAX @SC88118 05385500
ATTACH ECB=ATCHECB,DE=SFCBLDL+4,SHSPV=78,SZERO=NO, +05386000
MF=(E,(2)),SF=(E,ATCBLK) @SC86355 05386500
LTR 15,15 Was attach successful? @TS86001 05387000
BZ *+12 Ok @SC88118 05387500
BAL 14,SFCATCLN Restore everything @SC88118 05388000
B ICPCMIL No, must not exist @SC88026 05388500
ST 1,ATCHTCB Save TCB address @TS86001 05389000
WAIT ECB=ATCHECB Wait for subtask to finish @TS86001 05389500
LA 1,ATCTXP Set up req blk ptr to text list @SC88087 05390000
LA 4,ATCTXT Text list follows RB @SC88087 05390500
MVC 0(6,4),=H'1,1,4' Text unit type 1: TCB adr @SC88087 05391000
LA 5,ATCDRB RB ptr follows text list @SC88087 05391500
ST 1,ATCDRB+8 Fill in RB @SC88087 05392000
STM 4,5,ATCTXP Fill in text list + RB ptr @SC88087 05392500
MVI ATCTXP,X'80' Only item in text list @SC88087 05393000
MVC 0(2,5),=AL1(20,5) Finish up RB: length, type @SC88087 05393500
MVI ATCRBP,X'80' @SC88087 05394000
LA 1,ATCRBP @SC88087 05394500
SVC 99 DYNALLOC to free allocations @SC88087 05395000
DETACH ATCHTCB Detach the subtask @TS86001 05395500
BAL 14,SFCATCLN Restore everything @SC88118 05396000
SR 4,4 @SC86355 05396500
ICM 4,7,ATCHECB+1 Get return code @SC86355 05397000
* Issue return code msg if needed @SC86295 05397500
BZ SFCZRC RC=0 @SC86158 05398000
LR 15,6 @SC90264 05398500
TM FL4,UCMD User cmd? @SC86316 05399000
BZ RTRN No. No message, just rc in R15 @SC90264 05399500
MVC CMD(2),=C'R(' Set up message @SC86209 05400000
LA 15,CMD+2 @SC86209 05400500
BAL 2,EDDEC Edit RC into msg @SC86295 05401000
MVI 0(15),C')' Format is R(rc) @SC86209 05401500
LA 0,1(15) @SC86268 05402000
LA 1,CMD Start of edited string @SC86209 05402500
SR 0,1 Length @SC86268 05403000
WTEXT (1),(0) @SC86268 05403500
SFCZRC LR 15,4 @SC86295 05404000
MVI ERRNUM,ERRNOE No errors @SC86295 05404500
B RTRN @SC86295 05405000
ICPCMIL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05405500
B RTRNM1 @SC86295 05406000
* 05406500
SFCATCLN STAX , Restore after ATTACH (saves R14) @SC88118 05407000
BR 14 @SC88118 05407500
* 05408000
SFCATTN STM 14,12,12(13) Save regs @SC88118 05408500
LR 3,15 @SC88118 05409000
USING SFCATTN,3 @SC88118 05409500
L 4,8(1) Ptr to ECB @SC88118 05410000
LA 2,4(4) Ptr to TCB @SC88118 05410500
TM 0(4),X'40' Already finished? @SC88118 05411000
BO SFCATTNR Yes, we just missed it @SC88118 05411500
STATUS STOP,TCB=(2) Suppress execution @SC88118 05412000
POST (4) No, so we just drop it @SC88118 05412500
SFCATTNR LM 14,12,12(13) Restore regs @SC88118 05413000
BR 14 @SC88118 05413500
DROP 3 @SC88118 05414000
* 05414500
SFCLIN DS 0H @SC92342 05415000
* Retrieve original command line arguments, if any @SC86295 05415500
* Return code =0 if yes, =1 if no @SC86295 05416000
* Leave string in CBUF buffer (up to 256), length in CLEN @SC86295 05416500
L 2,ORGR1 Original R1 @SC86355 05417000
L 3,CPPLCBUF CBUF ptr @SC91121 05417500
LH 5,0(,3) PARM length @SC91121 05418000
AR 5,3 End of data @SC91121 05418500
LH 4,2(,3) Parm offset @SC91121 05419000
LA 4,4(4,3) Start of data @SC91121 05419500
SR 5,4 Length of data @SC91121 05420000
BNP RTRN1 Nothing there @SC86299 05420500
LA 6,7+4(,5) Add 4 for overhead and round @SC91121 05421000
N 6,=F'-7' ... to doubleword @SC91121 05421500
GETMAIN R,LV=(6),SP=1 @SC91121 05422000
ST 1,APGPB+GTPBIBUF-GTPB Save ptr for GETLIN @SC91121 05422500
STH 6,0(,1) Set up new block @SC91121 05423000
SR 6,5 Deduct data length @SC91121 05423500
S 6,F4 and overhead @SC91121 05424000
STH 6,2(,1) The rest is the new offset @SC91121 05424500
LA 0,4(6,1) New starting point for data @SC91121 05425000
LR 1,5 @SC91121 05425500
MVCL 0,4 Fill up new block @SC91121 05426000
B RTRN0 @SC86295 05426500
* 05427000
* Test for stacked commands @SC86295 05427500
* return code = number of stacked lines @SC86295 05428000
SFCSTK DS 0H @SC92342 05428500
LA 2,APGPB @NW86330 05429000
USING GTPB,2 @NW86330 05429500
ICM 1,15,GTPBIBUF Ptr to input buffer, if any @SC87015 05430000
BNZ RTRN1 Yes, line is stacked @SC87015 05430500
SR 0,0 @SC91205 05431000
IC 0,ERRNUM Get current status code @SC91205 05431500
C 0,F1 @SC91205 05432000
BH *+6 @SC91205 05432500
SR 0,0 Treat 1 as if 0 @SC91205 05433000
L 1,ORGR1 Get ptr to CPPL @SC91205 05433500
USING CPPL,1 @SC91205 05434000
L 1,CPPLECT Get ECT ptr @SC91205 05434500
USING ECT,1 @SC91205 05435000
STCM 0,7,ECTRTCD Set CC for any CLIST running @SC91205 05435500
DROP 1 @SC91205 05436000
MVI CPECB,0 Clear ECB @SC88119 05436500
L 15,GETLINAD Entry point for GETLINE routine @NW86330 05437000
GETLINE PARM=(2),TERMGET=(EDIT,NOWAIT),ENTRY=(15), +05437500
MF=(E,IOPLAREA) @SC87015 05438000
C 15,F4 Check return code @SC87015 05438500
BNH RTRN1 Got one now @SC88095 05439000
MVC GTPBIBUF,F0 Clear it, just in case @SC88095 05439500
B RTRN0 Nothing stacked @SC88095 05440000
DROP 2 @SC90264 05440500
* 05441000
* Log out @SC86295 05441500
SFCKIL DS 0H @SC92342 05442000
LR 3,13 @SC88026 05442500
L 3,4(3) Look back through save areas @SC88026 05443000
CLC =A(USNTRF),16(3) Find main loop @SC89215 05443500
BNE *-10 @SC88026 05444000
L 3,8(3) Ptr to main save area @SC88026 05444500
OI KFLG-USNTRFSV(3),CMDC Set flag to quit @SC88026 05445000
PTEXT 'LOGOFF',AREG=0,LREG=6 @SC88026 05445500
NI FL4,255-UCMD Internal @SC86355 05446000
B ICPCMI Do it @SC86355 05446500
* 05447000
* Wait specified time in R0 (sec) 05447500
SFCWT DS 0H @SC92342 05448000
MH 0,=H'100' Convert to centisec @SC86299 05448500
ST 0,TMPDW @SC86299 05449000
STIMER WAIT,BINTVL=TMPDW @SC86299 05449500
B RTRN0 @SC86295 05450000
* 05450500
* Return time in centisec in R15 05451000
SFCCLK DS 0H @SC92342 05451500
STCK TMPDW Store TOD clock @SC86295 05452000
LM 14,15,TMPDW @SC86295 05452500
SLDL 14,8 Take mod 204 days @SC86295 05453000
SRDL 14,20 Get in microsec @SC86295 05453500
D 14,=F'10000' Get in centisec @SC86295 05454000
B RTRN @SC86295 05454500
* 05455000
TITLE 'SVC interceptor, executed in system protect key' 05455500
USING ICPTYP,15 @SC86283 05456000
ICPTYP STM 12,14,SVCSV1 Save regs @SC86283 05456500
LR 13,15 Addressability @SC87020 05457000
DROP 15 05457500
USING ICPTYP,13 @SC87020 05458000
ICPTGO LM 14,15,SVCOPTR Output ptrs @SC86158 05458500
SR 15,14 Length left @SC86158 05459000
LA 12,255 Limit @SC86158 05459500
CLR 12,0 Buffer length @SC87020 05460000
BNH *+8 Too big @SC86158 05460500
LR 12,0 Ok, use it @SC87020 05461000
LTR 12,12 @SC86158 05461500
BNP ICPTRET @SC86283 05462000
CR 12,15 Enough room? @SC86283 05462500
BH ICPTRET No @SC86283 05463000
BCTR 12,0 Set up for mvc @SC86158 05463500
EX 12,SVCCOPY Move to WBUF @SC86158 05464000
LA 14,2(12,14) New end @SC86158 05464500
ST 14,SVCOPTR @SC86158 05465000
ICPTRET SR 15,15 Success @SC86283 05465500
LM 12,14,SVCSV1 Restore regs @SC86283 05466000
BR 14 Return @SC86283 05466500
SVCCOPY MVC 0(,14),0(1) @SC87020 05467000
* 05467500
* Storage for SVC interception @SC86158 05468000
SVCSV1 DS 2F Saved 12,13 @SC86158 05468500
SVCSV2 DS 2F Saved 14,15 @SC86158 05469000
SVCOPTR DS 2F Buffer output and end ptrs @SC86158 05469500
STKA STACK MF=L,DATASET=(*,OUTDD=STKDD) @SC88026 05470000
STKZ STACK MF=L,DELETE=TOP @SC88026 05470500
STKDD DC CL8'K999999Y' DD name for STACK interception @SC88026 05471000
LOCALS , @SC86295 05471500
ATCHCPPL DS 4F Subtask CPPL area @TS86001 05472000
SFCSTBL STAX MF=L ATTN during subtask execution @SC88118 05472500
ATCBLK ATTACH SF=L ATTACH parameter list @SC88022 05473000
ATCHECB DS F Subtask ECB @TS86001 05473500
DS 6X Leave some space for text unit @SC88291 05474000
ATCHTCB DS F Subtask TCB ptr @TS86001 05474500
ATCTXT EQU ATCHTCB-6,6 Prefix to TCB ptr (watch overlap!)@SC88087 05475000
SFCBUF DS F,CL256 Command buffer @GH89057 05475500
SFCBLDL DS 2H BLDL list: count & length @GH89050 05476000
DS CL8,XL52 BLDL list: membername, TTRC, etc. @GH89050 05476500
SFCDEL DS 0F CAMLST overlays... @SC88106 05477000
STKDYN DS 7F DYNALC calling sequence @SC88026 05477500
* - Also used for CAMLST UNCAT/SCRATCH & DYNALLOC@SC88106 05478000
STKDRC DS F DYNALC return code @SC88026 05478500
STKTKT DS A Ptr to STACK file FAB @SC88026 05479000
ORG STKDYN Overlay interception stuff @SC88087 05479500
ATCDRB DS 5F DYNALLOC RB (init to zeroes) @SC88087 05480000
ATCTXP DS A Text unit list (ATCTXT) @SC88087 05480500
ATCRBP DS A Ptr to RB @SC88087 05481000
ORG , @SC88087 05481500
EXCFLG DS C Flag for implicit EXEC @SC89073 05482000
SFCFLGS DS X Type of call to SUPFNC @SC92342 05482500
SUPFNC EXIT @SC86158 05483000
TITLE 'TERMIO Routine - Handle terminal I/O' 05483500
* R1 points to a pair of (adr,len) for read or write. If I/O is 05484000
* successfull, R15 returns transferred byte count (else returns -1). 05484500
* Command code is in R0: 05485000
* 1 => Open line for I/O 4 => Write packet 05485500
* 2 => Close line 5 => Read packet 05486000
* 3 => Reset line status after ( 6 => Write message ) not used 05486500
* environment changes 05487000
* 05487500
TERMIO ENTER 05488000
SR 15,15 OK @SC86295 05488500
STC 0,CONSOPR @SC92180 05489000
BCT 0,TRMCLS @SC86295 05489500
* Open terminal line for protocol 05490000
STAX BR14,REPLACE=NO Ingore attention interrupts @SC88118 05490500
MVI RIOC,X'80' Nothing saved @SC86295 05491000
MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05491500
CLI TRMTP,C'F' Non-transparent full-screen? @SC92030 05492000
BNE RTRN0 No, all set @SC92030 05492500
STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode @SC92030 05493000
LA 1,TRMFULA1 Set up introducer: adr @SC92030 05493500
LA 2,TRMFULL1 Length @SC92030 05494000
STM 1,2,WRCMD @SC92030 05494500
LA 0,TRMFULL1+TRMFULL2 @SC92030 05495000
ICM 1,8,=X'03' FULLSCR (for VTAM) @SC92030 05495500
BAL 8,TRMLOG @SC92180 05496000
TPUT (1),(0),R Clear and format @SC92030 05496500
B RTRN0 @SC86295 05497000
* Close terminal line after protocol transfer 05497500
TRMCLS BCT 0,TRMRSET @SC86295 05498000
STAX 05498500
CLI TRMTP,C'F' Non-transparent full-screen? @SC92030 05499000
BNE RTRN0 No, all set @SC92030 05499500
STFSMODE OFF @SC92030 05500000
SR 0,0 @SC92030 05500500
KCALL SCRNIO One final CLEAR @SC92030 05501000
B RTRN0 @SC86295 05501500
* (Re)set terminal characteristics to suit environment 05502000
TRMRSET BCT 0,TRMRW @SC86295 05502500
B RTRN0 @SC86295 05503000
* 05503500
* Perform I/O request 05504000
TRMRW BCT 0,TRMRD @SC87015 05504500
CLI WRRD,0 Write/read? @SC87275 05505000
BNE *+8 Yes @SC87275 05505500
MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05506000
L 0,4(1) Get length @SC87015 05506500
L 1,0(1) and address @SC87015 05507000
CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 05507500
BNE TRMW0 No @SC92030 05508000
LA 2,TRMFULA2 Stuff to append to stream @SC92030 05508500
XI FL3,FCLRF Flip switch for clearing @SC92030 05509000
TM FL3,FCLRF Clearing now? @SC92030 05509500
BO TRMWAP Yes, finish stream @SC92030 05510000
LA 2,TRMFULB2 Stuff to append if not clearing @SC92030 05510500
MVC 0(TRMFULL1,1),TRMFULB1 Replace introducer @SC92030 05511000
TRMWAP LR 3,0 @SC92030 05511500
AR 3,1 End of data @SC92030 05512000
MVC 0(TRMFULL2,3),0(2) Append extra commands @SC92030 05512500
AH 0,=Y(TRMFULL2) Add length of extra @SC92030 05513000
B TRMW1 @SC92030 05513500
TRMW0 DS 0H @SC92030 05514000
ICM 1,8,=X'02' CONTROL @SC87317 05514500
CLI TRMTP,C'V' @SC88323 05515000
BNE *+8 @SC87317 05515500
TRMW1 DS 0H @SC92030 05516000
ICM 1,8,=X'03' FULLSCR (for VTAM) @SC88323 05516500
BAL 8,TRMLOG @SC92180 05517000
TPUT (1),(0),R Flags already set @SC87317 05517500
B RTRN0 @SC87317 05518000
* 05518500
* TRMLOG: Dump command parameters and data buffer @SC92180 05519000
* Return via R8. R3, R7, and R14-R15 destroyed. @SC92180 05519500
TRMLOG STM 0,1,TRMLRS Save ptrs @SC92180 05520000
LA 1,TRMLRS Get plist ptr @SC92180 05520500
SLR 2,2 Convert op. code to log label @SC92180 05521000
IC 2,CONSOPR @SC92180 05521500
LA 2,CONSOPRS(2) @SC92180 05522000
IC 0,0(,2) @SC92180 05522500
LA 2,8 Size of plist @SC92180 05523000
BAL 7,SCRLOG Log it @SC92180 05523500
LM 0,1,TRMLRS Restore R1 @SC92180 05524000
LA 2,C'd' @SC92180 05524500
BAL 7,SCRLOG Log it @SC92180 05525000
LM 0,1,TRMLRS Restore R1 @SC92180 05525500
BR 8 @SC92180 05526000
* 05526500
* Read from terminal 05527000
TRMRD MVC KTGETT(8),0(1) Copy adr,len @SC87015 05527500
TS TRMFLG @SC87275 05528000
BZ RTRN0 Just a follow-up. 0-length read @SC87275 05528500
MVI ECBTGET,0 Clear ECB @SC87015 05529000
SR 5,5 Set flag 'no timing' @SC87015 05529500
ICM 5,1,TIMOSRV Timing allowed? @SC90045 05530000
BZ TRMPST @NW86330 05530500
ICM 5,1,TIMOUT Any timing requested? @SC87015 05531000
BZ TRMPST No, just wait @SC87015 05531500
MH 5,=H'100' @SC87015 05532000
ST 5,TMPDW @SC87015 05532500
LA 1,ECBTGET ECB for timer to post @SC88299 05533000
STCM 1,15,TMXPT Set up addressibility @SC88299 05533500
STIMER REAL,TMXIT,BINTVL=TMPDW @SC88299 05534000
TRMPST POST ECBREAD Tell async sub to go for it @NW86330 05534500
WAIT ECB=ECBTGET @NW86330 05535000
CLI ECBTGET+3,0 Check return code @NW86330 05535500
BNE TRMTIM @NW86330 05536000
LTR 5,5 Timing enabled? @SC87015 05536500
BZ TRMRET No, fine @SC87015 05537000
TTIMER CANCEL Yes, kill timer @SC87015 05537500
TRMRET DS 0H @SC92030 05538000
L 0,KTGETT+4 @SC92030 05538500
L 1,KTGETT @SC92030 05539000
BAL 8,TRMLOG Log data read @SC92180 05539500
L 15,KTGETT+4 Get length read @SC92030 05540000
S 15,WRCMDL+4 Deduct 3 for buffer adr @SC92030 05540500
B RTRN @SC87015 05541000
TRMTIM DETACH TASKADD Blow off task @NW86330 05541500
MVI ECBREAD,0 Zero out read ECB @NW86330 05542000
ATTACH EP=KERMTGET,MF=(E,COMPTR) @NW86330 05542500
ST 1,TASKADD Save adr for detach @NW86330 05543000
L 1,APKT Ptr to data buffer @SC87015 05543500
MVI 0(1),AT Timed out @SC87015 05544000
B RTRN1 Set count to one @SC87015 05544500
* 05545000
TRMFULA1 DC X'C2,11,4040,3C,4040,00,1D60,11,C150' @SC92030 05545500
TRMFULL1 EQU *-TRMFULA1 @SC92030 05546000
TRMFULA2 DC X'11,C36F,1D40,13' @SC92030 05546500
TRMFULL2 EQU *-TRMFULA2 @SC92030 05547000
TRMFULB1 DC X'C2,11,4040,3C,4040,00,1D60,11,C650' @SC92030 05547500
TRMFULB2 DC X'11,C86F,1D40,13' @SC92030 05548000
LTORG @SC92180 05548500
TITLE 'KERMTGET Routine - Read from terminal (timed)' 05549000
* ECB's control timing flow @NW86330 05549500
KERMTGET CSECT @SC87015 05550000
USING *,12 @SC88299 05550500
SAVE (14,12),,* @SC87015 05551000
LR 12,15 @SC88299 05551500
LM 10,11,0(1) Set up addressibility @SC87015 05552000
KTGLP0 WAIT ECB=ECBREAD @NW86330 05552500
MVI ECBREAD,0 Zero ECB @NW86330 05553000
L 1,KTGETT Adr of buffer to put in @NW86330 05553500
L 0,KTGETT+4 Max TGET (although tcam's 4k) @NW86330 05554000
TGET (1),(0),ASIS @NW86330 05554500
LTR 15,15 @NW86330 05555000
BZ KTGLEN Ok @NW86330 05555500
C 15,F12 @NW86330 05556000
BE KTGLEN Ok @NW86330 05556500
CH 15,=H'24' @SC92030 05557000
BE KTGLEN Ok, Full-screen @SC92030 05557500
SR 1,1 Error @NW86330 05558000
BCTR 1,0 @NW86330 05558500
KTGLEN ST 1,KTGETT+4 Save length @SC87015 05559000
POST ECBTGET Tell em we read it @NW86330 05559500
B KTGLP0 Keep repeating @NW86330 05560000
LTORG @SC87015 05560500
TITLE 'GETLIN Routine - Get a line from terminal' @SC87015 05561000
* Entry: R1->buffer of length 256 @SC87015 05561500
* Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1. @SC87015 05562000
GETLIN ENTER @SC87015 05562500
LR 8,1 Save buffer ptr @SC88095 05563000
LA 9,256 For copying @SC88095 05563500
LA 3,APGPB Ptr to GETLINE block @SC88095 05564000
USING GTPB,3 @SC88095 05564500
ICM 5,15,GTPBIBUF Already got something? @SC88095 05565000
BNZ GTL1 Yes, return it @SC87015 05565500
SR 0,0 @SC91205 05566000
IC 0,ERRNUM Get current status code @SC91205 05566500
C 0,F1 @SC91205 05567000
BH *+6 @SC91205 05567500
SR 0,0 Treat 1 as if 0 @SC91205 05568000
L 1,ORGR1 Get ptr to CPPL @SC91205 05568500
USING CPPL,1 @SC91205 05569000
L 1,CPPLECT Get ECT ptr @SC91205 05569500
USING ECT,1 @SC91205 05570000
STCM 0,7,ECTRTCD Set CC for any CLIST running @SC91205 05570500
DROP 1 @SC91205 05571000
MVI CPECB,0 Clear ECB @SC88119 05571500
L 15,GETLINAD Entry point for GETLINE routine @NW86330 05572000
GETLINE PARM=(3),TERMGET=(EDIT,WAIT),ENTRY=(15), @SC88095+05572500
MF=(E,IOPLAREA) @SC87015 05573000
SR 2,2 @SC88095 05573500
C 15,F4 Problem? @SC87015 05574000
BH GTLA Yes, give up with len=0 @SC87015 05574500
L 5,GTPBIBUF Ptr to input buffer @SC88095 05575000
GTL1 LH 1,0(5) Length of stuff (inc. header) @SC88095 05575500
AR 1,5 End of buffer @SC88095 05576000
LR 0,1 Save end @SC88095 05576500
LH 6,2(5) Get starting offset (init. 0) @SC88095 05577000
LA 6,4(6,5) Ptr into buffer @SC88095 05577500
LR 2,1 @SC88095 05578000
SR 2,6 Length of text remaining @SC88095 05578500
BNP GTLFRE None, return length 0 @SC88095 05579000
SR 4,4 @SC88095 05579500
IC 4,LNDLM Get delimiter @SC88095 05580000
LA 4,TRTBL(4) Ptr to delimiter char @SC88095 05580500
MVI 0(4),1 Set up to snag delims @SC88095 05581000
MVI TRTBL+C' ',0 And ignore blanks @SC88095 05581500
CR 2,9 Get shorter of 256 and string @SC88095 05582000
BNH *+6 @SC88095 05582500
LR 2,9 @SC88095 05583000
BCTR 2,0 Set up for EX @SC88095 05583500
EX 2,GTLTRT @SC88095 05584000
MVI 0(4),0 Now clear out table @SC88095 05584500
MVI TRTBL+C' ',1 And restore @SC88095 05585000
SR 1,6 Length of line @SC88095 05585500
LR 7,1 Set up MVCL @SC88095 05586000
CR 9,7 Get shorter of 256 and string @SC88095 05586500
BNH *+6 @SC88095 05587000
LR 9,7 @SC88095 05587500
LR 2,9 Length actually copied @SC88095 05588000
MVCL 8,6 @SC88095 05588500
AR 6,7 In case we couldn't use it all @SC88095 05589000
CR 6,0 Finished input? @SC88095 05589500
BNL GTLFRE Yes, release it @SC88095 05590000
S 6,F3 + 1 - 4: skip over linend char @SC88095 05590500
SR 6,5 New offset ptr @SC88095 05591000
STH 6,2(5) @SC88095 05591500
B GTLZ Return @SC88095 05592000
GTLFRE LR 1,5 This buffer is used up @SC88095 05592500
LH 0,0(1) Get total length @SC88095 05593000
FREEMAIN RC,LV=(0),A=(1),SP=1 Free input buffer @NW86330 05593500
GTLA MVC GTPBIBUF,F0 Clear input indicator @SC87015 05594000
GTLZ RETREG (0,2) Return (2) as R0 @SC89218 05594500
B RTRN0 @SC87015 05595000
DROP 3 @SC88095 05595500
GTLTRT TRT 0(,6),TRTBL Find a delimiter @SC88095 05596000
LOCALS , @SC87015 05596500
GETLIN EXIT , @SC87015 05597000
TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05597500
* R1 points to a pair of (adr,len) for read or write. If I/O is 05598000
* successfull, R15 returns transferred byte count (else returns -1). 05598500
* Command code is in R0: 05599000
* 0 => Clear screen on console (not comm line) @SC90045 05599500
* 1 => Open screen for I/O 4 => Write packet (gets ATTN) 05600000
* 2 => Close screen 5 => Read packet 05600500
* 3 => Reset screen status after 6 => Write message (no ATTN) 05601000
* environment changes 05601500
* 05602000
TERMIO ENTER AGAIN @SC92180 05602500
SCRNIO ENTER ALT @SC92180 05603000
LA 8,SCRPLST Get PLST ptr @SC90222 05603500
LR 6,1 Save ptr to plist @SC90222 05604000
LTR 0,0 @SC90045 05604500
BZ SCRCLR @SC90045 05605000
STC 0,CONSOPR Save command code @LP88158 05605500
BCT 0,SCRCLS @SC86295 05606000
* Set up for transparent I/O 05606500
L 1,=A(IDEFS) CSECT of initializations @SC90173 05607000
USING DEFS,1 Mapped via DSECT @SC90173 05607500
LA 2,S1DATA Series/1 introducer @SC90173 05608000
LA 3,S1ORDL+2 Length + 2 @SC90173 05608500
CLI TRMTP,C'S' @SC90173 05609000
BE SCRPRSET Do it @SC90173 05609500
LA 2,GRDATA Graphics introducer @SC90173 05610000
LA 3,GRDL+2 Length + 2 @SC90173 05610500
CLI TRMTP,C'G' @SC90173 05611000
BE SCRPRSET Do it @SC90173 05611500
LA 2,AEADAT AEA introducer @SC90173 05612000
LA 3,AEAL+2 @SC90173 05612500
DROP 1 @SC90173 05613000
SCRPRSET LR 5,3 @SC90173 05613500
LA 4,S1EOL+2 Get start of command buffer @SC90173 05614000
SR 4,5 @SC90173 05614500
STM 4,5,S1XOPL Set up prompt plist @SC90173 05615000
S 5,F2 Deduct stuff already there @SC90173 05615500
MVCL 4,2 @SC90173 05616000
MVI SCRLST,0 Clear op code @SC88091 05616500
STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode @TS86001 05617000
LA 6,CLRSPLST @SC90222 05617500
BAL 9,SCRNEXW Clear screan @SC90222 05618000
B RTRN0 @SC86295 05618500
SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05619000
BE RTRN0 Yes, can't clear screen @SC90045 05619500
CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05620000
BE RTRN0 Yes, can't clear screen @SC90045 05620500
CLI TRMTP,C'F' Is it some full-screen? @SC92030 05621000
BE *+12 Yes, must clear frequently @SC92030 05621500
TM FL2,PROTO In protocol mode? @SC90045 05622000
BO RTRN0 Yes, skip clearing screen @SC90045 05622500
STFSMODE ON,INITIAL=YES,NOEDIT=YES Full-screen mode @SC91246 05623000
B SCRCLRB Do it @SC91246 05623500
SCRCLS BCT 0,SCRRSET @SC86295 05624000
* Clean up after I/O 05624500
SCRCLRB DS 0H @SC91246 05625000
LA 6,CLRSPLST @SC90222 05625500
BAL 9,SCRNEXW Clear screan @SC90222 05626000
STFSMODE OFF @TS86001 05626500
B RTRN0 @SC86295 05627000
* (Re)set device characteristics to suit environment 05627500
SCRRSET BCT 0,SCRRW @SC86295 05628000
B RTRN0 05628500
* 05629000
* Perform I/O request 05629500
SCRRW DS 0H @SC90222 05630000
SR 2,2 @SC88091 05630500
IC 2,SCRLST 1=>Write, 2=>Read, 3=>Wr. msg. @SC88091 05631000
STC 0,SCRLST Save new code @SC88091 05631500
BCT 0,SCRRD Different handling for each @SC88019 05632000
SCRWM DS 0H Come back here for message @SC88105 05632500
BAL 9,SCRNEXW Write it @SC90222 05633000
ICM 1,15,SCRRC Check return code @SC90222 05633500
BNZ RTRNM1 This may never happen @SC90222 05634000
B RTRN0 Assume OK @SC88019 05634500
SCRRD BCT 0,SCRWM Go if "Write message" @SC88019 05635000
C 2,F3 Was last operation a Write msg? @SC88091 05635500
BNE SCRRD1 No, fine @SC88091 05636000
TPG SCRF6,1 Yes, must trigger a READ MOD @SC90145 05636500
SCRRD1 DS 0H @SC88091 05637000
MVI 4(8),X'81' Flags: TGET @SC88019 05637500
SCRE4TRY BAL 9,SCRNEX Execute internal subr @SC93159 05638000
LTR 15,15 Did it fail? @LP88188 05638500
BL RTRN Yes, continue @LP88188 05639000
TM FL2,PROTO In midst of transfer? @SC88203 05639500
BZ RTRN No, must be status check @SC88203 05640000
L 1,4(,8) Data address @LP88188 05640500
CLI 0(1),X'E4' 7171 overrun (line error)? @LP88188 05641000
BNE RTRN No, continue @LP88188 05641500
LA 8,SCRE4RES Reset transparent mode @SC93159 05642000
MVI CONSOPR,6 @SC93159 05642500
BAL 9,SCRNEXP @SC93159 05643000
LA 8,SCRE4RET @LP88188 05643500
MVI CONSOPR,4 And send a dummy packet @LP88188 05644000
BAL 9,SCRNEXP @SC93159 05644500
MVI CONSOPR,5 Do the read again @LP88188 05645000
LA 8,SCRPLST Get PLST ptr @SC93159 05645500
B SCRE4TRY Loop until no more E4 reply @LP88188 05646000
* 05646500
* SCRLOG: Hexadecimal log of (R2) bytes at address (R1) @LP88158 05647000
* Log label is taken from R0 low order byte. @SC89166 05647500
* Return via R7. R0-R3 and R15 destroyed. @SC89166 05648000
SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05648500
BZR 7 No, that's all @SC89166 05649000
TM DBGFLG,DBGIO I/O stuff requested? @SC88168 05649500
BZR 7 No, skip it @SC89166 05650000
L 3,LOGBUF Ptr to buffer @LP88158 05650500
STC 0,0(,3) Set log label @SC89166 05651000
LA 3,2(,3) Start of data area @SC91172 05651500
TM DBGFLG,DBGTI Times requested? @SC91172 05652000
BZ SCRLOGA No, just do hex dump @SC91172 05652500
ST 1,SCRLR1 Save ptr to block @SC91172 05653000
BAL 14,ACCTTOD Get time of day in seconds @SC91172 05653500
MVI 0(3),C' ' Leave a space @SC91172 05654000
KCALL DUMPTOD,1(3) Format time into buffer @SC91172 05654500
LR 3,15 Get ptr to end of string @SC91172 05655000
L 1,SCRLR1 Restore R1 @SC91172 05655500
SCRLOGA LA 0,6*9(,3) End of line buffer @SC91172 05656000
TM DBGFLG,DBGLO Long buffer requested? @SC90222 05656500
BZ *+8 @SC90222 05657000
LA 0,50*9(,3) Yes, long buffer @SC91172 05657500
SCRLOGLP MVI 0(3),C' ' Add for readability @LP88158 05658000
UNPK 1(9,3),0(5,1) Unpack into buffer @SC88168 05658500
TR 1(8,3),TRHEX Convert to printable hex @SC88168 05659000
LA 3,9(3) Advance text ptr @SC88168 05659500
LA 1,4(1) and data source @LP88158 05660000
S 2,F4 Finished data? @SC88168 05660500
BNP SCRLGEND Yes, go write @LP88158 05661000
CR 3,0 Reached text limit? @LP88158 05661500
BL SCRLOGLP no, loop for more slices @LP88158 05662000
MVC 0(3,3),=C'...' Show incomplete @LP88158 05662500
LA 3,3(3) @SC88168 05663000
SCRLGEND DS 0H @LP88158 05663500
AR 2,2 Check for incomplete slice @SC88168 05664000
BNM *+6 No, ok @SC88168 05664500
AR 3,2 Yes, adjust end of text @SC88168 05665000
S 3,LOGBUF Get length of text @SC88168 05665500
WRITF LOGPTR,BSIZE=(3) Log it @LP88158 05666000
TM DBGFLG,DBGSV SAVE requested? @SC88168 05666500
BZR 7 No, skip closing log file @SC89166 05667000
SAVEF LOGPTR Update disk directory @SC88168 05667500
BR 7 @SC89166 05668000
* 05668500
SCRNEXW MVI 4(8),X'03' Flags: FULLSCR/NOEDIT @SC90222 05669000
MVI 12(8),X'01' More flags: NOEDIT for TPUT @SC90222 05669500
SCRNEX MVC 5(3,8),1(6) Copy adr @SC90222 05670000
MVC 2(2,8),6(6) Copy len @SC90222 05670500
OI 12(8),X'80' Flag for extended plist @SC90222 05671000
SCRNEXP DS 0H @SC93159 05671500
LR 1,8 Get plist ptr @SC90222 05672000
SLR 2,2 Convert op. code to log label @LP88158 05672500
IC 2,CONSOPR @LP88158 05673000
LA 2,CONSOPRS(2) @LP88158 05673500
IC 0,0(,2) @SC89166 05674000
LA 2,16 Size of plist @SC90222 05674500
BAL 7,SCRLOG Log it @SC90222 05675000
CLI CONSOPR,5 Read operation? @SC90222 05675500
BE SCRNEXG Yes, use registers only @SC90222 05676000
ICM 0,8,=X'80' Set hi bit of R0 @SC90222 05676500
LR 1,8 Get ptr for SVC @SC90222 05677000
TPUT (1),(0),R @SC90222 05677500
LH 5,2(,8) Number of chars sent @SC90222 05678000
B SCRNEXT Now rejoin @SC90222 05678500
SCRNEXG LM 0,1,0(8) Load up registers for SVC @SC90222 05679000
TGET (1),(0),R @SC90222 05679500
LR 5,1 Number of chars recv'd @SC90222 05680000
SCRNEXT ST 15,SCRRC Save return code @SC90222 05680500
LTR 15,15 @SC90222 05681000
BZ SCRNEXD Ok, log data @SC90222 05681500
CH 15,=H'24' Check for "ok, but NOEDIT" @SC91259 05682000
BE SCRNEXD Yup, that's ok @SC91259 05682500
LA 1,SCRRC @SC90222 05683000
LA 2,4 @SC90222 05683500
LA 0,C'e' "Error" label @SC90222 05684000
BAL 7,SCRLOG Log the return code @SC90222 05684500
SCRNEXD L 1,4(,8) Data address @SC90222 05685000
LA 0,C'd' "Data" label @SC89166 05685500
LR 2,5 Data size @SC90222 05686000
BAL 7,SCRLOG Log data @SC90222 05686500
LR 15,5 @LP88186 05687000
S 15,WRCMDL+4 Deduct 3 for buffer adr @SC90173 05687500
BNMR 9 Presumably ok @SC92030 05688000
CLI WRRD,0 Was it write-only? @SC92030 05688500
BNER 9 No @SC92030 05689000
C 5,F1 If READ, did we get just AID? @SC92030 05689500
BNER 9 No @SC92030 05690000
SR 15,15 Yes, assume all is well @SC92030 05690500
BR 9 @SC86299 05691000
* 05691500
SCRE4RES TPUT SCRE4LTM,SCRE4LTL,NOEDIT,MF=L @SC93159 05692000
SCRE4RET TPUT SCRE4DWR,SCRE4DWL,NOEDIT,MF=L @SC93159 05692500
SCRE4LTM DC &S1CMD,AL1(SBA),X'4040',AL1(ICR),X'4040' Reset @SC93159 05693000
SCRE4LTL EQU *-SCRE4LTM Length of command @SC88168 05693500
SCRE4DWR DC &S1CMD,AL1(SBA),X'5D7F',AL1(SBA),X'000180' packe@SC93159 05694000
SCRE4DWL EQU *-SCRE4DWR Length of command @SC88168 05694500
* 05695000
CLRSPEC DC &S1CMD,AL1(SBA),X'4040',X'3C404000' Clr scrn @SC90264 05695500
CLRSPECL EQU *-CLRSPEC Length of clear screen @TS86001 05696000
CLRSPLST DC AL4(CLRSPEC,CLRSPECL) @SC90222 05696500
* 05697000
CONSOPRS DC C'?ocswrmg' Console command labels for log @SC93146 05697500
SCRF6 DC X'F6' Cmd to trigger a READ MOD @SC90145 05698000
LOCALS , @SC86299 05698500
SCRPLST DS 4F Plist for TPUT/TGET @SC88019 05699000
TRMLRS EQU SCRPLST Saved registers for logging @SC92180 05699500
SCRRC DS F Return code from TPUT/TGET @SC90222 05700000
SCRLR1 DS F Saved R1 in SCRLOG @SC91172 05700500
CONSOPR DS XL1 Current I/O operation @SC89180 05701000
SCRNIO EXIT , @SC86299 05701500
TITLE 'SETMSG Routine - controls CP breakin' 05702000
* Entry: R1 selects operation 05702500
* Exit: R15=0 if ok 05703000
* 1-> Analyze user environment, determine if suitable. 05703500
* Save quantities needed and condition line for entering commands. 05704000
* Perform any system-dependent initialization. 05704500
* 2-> Condition line for protocol transfers. 05705000
* 3-> Decondition line at end of transfer. 05705500
* 4-> System-dependent clean-up at exit. 05706000
* 5-> Reperform system-dependent initialization after SET LINE. 05706500
SETMSG ENTER , @SC87015 05707000
BCT 1,STM2 Go if R1 not 1, so no init 05707500
L 1,ORGR1 Get original R1 @SC86299 05708000
TM 0(1),X'80' Is this a command processor? @SC86299 05708500
BO NOTCP No, then refuse user @SC86299 05709000
USING CPPL,1 @SC86299 05709500
L 2,CPPLUPT Get ptr to UPT @SC86299 05710000
USING UPT,2 @SC86299 05710500
XR 3,3 @SC86299 05711000
IC 3,UPTPREFL Get length @SC86299 05711500
STH 3,DESTL Save for later @SC86299 05712000
MVC DEST(7),UPTPREFX Move prefix @SC86299 05712500
MVI DESTP,C' ' Not a PDS @SC86299 05713000
MVC OLDUPTSW,UPTSWS Save UPTSWS for later @TL89181 05713500
LA 4,IOPLAREA Get address of IOPL @TS86001 05714000
USING IOPL,4 Make it addressable @TS86001 05714500
MVC IOPLUPT,CPPLUPT Copy UPT ptr @TS86001 05715000
L 3,CPPLECT Copy ECT ptr @SC89052 05715500
ST 3,IOPLECT @SC89052 05716000
LA 0,CPECB Get address of ECB @TS86001 05716500
ST 0,IOPLECB Put into IOPL @TS86001 05717000
USING ECT,3 @SC89052 05717500
MVC ORGPCMD,ECTPCMD Save for Kermit HELP @SC89052 05718000
DROP 3,4 @SC89052 05718500
OPENF L,=C'SYSPROC ',,SYSPROC,E=STMS1 @SC89073 05719000
STMS1 DS 0H @SC89073 05719500
B STMOK Do some more setup @SC90173 05720000
* 05720500
STM5X DS 0H Now set up controller type @SC90173 05721000
MVI TRMTP,C'&KCONT' 1st assume TTY @SC88309 05721500
GTSIZE , Get terminal info @SC86299 05722000
LTR 0,0 Is this a graphics device? @SC86299 05722500
BZ STMSTY No @SC86299 05723000
GTTERM PRMSZE=GTTSIZ,ATTRIB=GTTATTR,MF=(E,GTTPL) @DL92073 05723500
SR 1,1 Assume Query not allowed @SC91311 05724000
TM GTTATTR+3,1 @SC91311 05724500
BZ STMGRS Query not allowed @SC91311 05725000
LA 1,STCQBIT Ok, Query is allowed @SC91311 05725500
STMGRS DS 0H @SC91311 05726000
O 1,=A(&CONOPTS) Options @SC91311 05726500
KCALL SETCON Find out just what kind... @SC91311 05727000
B RTRN0 @SC90173 05727500
STMSTY STSIZE SIZE=130 Set up linesize @TS86001 05728000
STCC ATTN Try PROFILE(ATTN) @GH89042 05728500
LTR 0,0 Check for LD=ATTN @GH89042 05729000
BM RTRN0 Must be TCAM TTY @SC90173 05729500
LA 15,X'FF' Set mask @GH89042 05730000
NR 15,0 Isolate old LD @GH89042 05730500
STCC LD=(15) Restore old LD @GH89042 05731000
LTR 0,0 Did first STCC work? @GH89042 05731500
BM RTRN0 Yes: must be TCAM TTY @SC90173 05732000
MVI TRMTP,C'V' No: must be VTAM TWX @GH89042 05732500
B RTRN0 @SC90173 05733000
STMOK DS 0H @SC88042 05733500
* Note: KWRKBASE is 11... @SC89268 05734000
STM 10,11,COMPTR Save ptrs for KERMTGET @SC87015 05734500
LA 0,STKDSN Set up DSN for STACK @SC88026 05735000
LH 1,DESTL @SC88026 05735500
LA 2,DEST Get userid prefix @SC88026 05736000
LA 3,LFID @SC88026 05736500
MVCL 0,2 Copy prefix @SC88026 05737000
LR 1,3 @SC88026 05737500
LA 2,=CL8'.KER.BUF' @SC88026 05738000
LA 3,8 Copy rest of name @SC88026 05738500
ICM 3,8,BLANK Fill with blanks @SC88026 05739000
MVCL 0,2 @SC88026 05739500
LA 5,READATTN ATTN routine adr (just post ECB) @SC88118 05740000
LA 6,CPECB Ptr to ECB to post on ATTN @SC88118 05740500
STAX (5),MF=(E,STAXPLR),USADDR=(6) @SC88118 05741000
LOAD EP=IKJGETL Get line routine adr @NW86330 05741500
ST 0,GETLINAD Store it off @NW86330 05742000
LA 0,PTLLEN @SC88026 05742500
ST 0,PTPB+4 Set up PUTLINE parameter block @SC88026 05743000
LOAD EP=IKJPUTL PUTLINE routine adr @SC88026 05743500
ST 0,PUTLINAD @SC88026 05744000
L 5,=A(KERMTGET) Adr of TGET module @NW86330 05744500
PTEXT 'IDENTIFY failed.' Just in case @SC87015 05745000
IDENTIFY EP=KERMTGET,ENTRY=(5) @NW86330 05745500
LTR 15,15 @NW86330 05746000
BNZ SUBERR @SC87015 05746500
PTEXT 'ATTACH failed.' Just in case @SC87015 05747000
ATTACH EP=KERMTGET,MF=(E,COMPTR) @SC87015 05747500
LTR 15,15 @NW86330 05748000
BNZ SUBERR @SC87015 05748500
ST 1,TASKADD Save adr for detach @NW86330 05749000
B STM5X @SC90173 05749500
* 05750000
READATTN STM 14,12,12(13) Save registers @SC88118 05750500
L 1,8(1) Get ptr to term ECB @SC88118 05751000
POST (1) Post it @SC88118 05751500
LM 14,12,12(13) Restore registers @SC88118 05752000
BR 14 @SC88118 05752500
* 05753000
STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05753500
CLI S1HND,XON User wants special one anyway? @SC87343 05754000
BNE STM2X @SC87343 05754500
BAL 14,TTYCHK TTY terminals can't change hndshk @SC92030 05755000
MVI S1HND,0 System provides the handshake @SC87343 05755500
STM2X DS 0H @SC87343 05756000
TM FL1,TSTF @SC86295 05756500
BO RTRN0 Just testing, don't change it @SC86295 05757000
CLI TRMLIN,C' ' Alternate comm line? @SC87300 05757500
BNE RTRN1 Not allowed! @SC87300 05758000
STCOM NO Set NOINTERCOM during protocol @TL89181 05758500
ICM 1,15,STMUOFF Turn off, just in case @SC88042 05759000
B STMD 05759500
* 05760000
STM3 BCT 1,STM4 @SC86316 05760500
TM OLDUPTSW,UPTNCOM Chk for NOINTERCOM in old UPT @TL89181 05761000
BO STM3A If so, leave it off @TL89181 05761500
STCOM YES Otherwise, set INTERCOM back on @TL89181 05762000
STM3A DS 0H @TL89181 05762500
ICM 1,3,STMUCH Restore user's settings @SC88042 05763000
ICM 1,12,STMUOFF Set flags to modify CDEL+LDEL @SC88042 05763500
STMD LA 0,7 @SC88042 05764000
SLL 0,24 Set entry code for STCC @SC88042 05764500
SVC 94 @SC88042 05765000
STC 0,STMUCH Save previous LDEL @SC88042 05765500
STC 1,STMUCH+1 and CDEL @SC88042 05766000
DROP 1,2 @SC88042 05766500
B RTRN0 05767000
* 05767500
STM4 BCT 1,STM5 Special clean-up @SC87351 05768000
DETACH TASKADD Kill sub-task @SC87296 05768500
CLOSF SYSPROC Close CLIST library @SC89073 05769000
B RTRN0 Special clean-up done @SC87296 05769500
* 05770000
STM5 DS 0H Re-init after SET LINE @SC87351 05770500
MVI TRMTP,C'N' Assume bad until validated @SC90173 05771000
CLI TRMLIN,C' ' External line? @SC87351 05771500
BE STM5X No, use terminal @SC90173 05772000
B RTRN1 Other lines not allowed @SC90173 05772500
* 05773000
NOTCP PTEXT '&NOTCPER' @SC86299 05773500
TPUT (3),(4) Simplest output method... @SC88287 05774000
B RTRN1 @SC88287 05774500
* 05775000
STMUOFF DC X'3000FFFF' No char & line delete @SC88042 05775500
* 05776000
LOCALS , @SC86295 05776500
GTTPL GTTERM MF=L Parameter block for GTTERM @SC91311 05777000
GTTATTR DS F Results from GTTERM @SC91311 05777500
GTTSIZ DS H GTTERM size response (ignore) @DL92073 05778000
SETMSG EXIT 05778500
TITLE 'DISKIO Routine - performs disk I/O functions' 05779000
* ERRNUM unchanged unless there is a disk error 05779500
* Function selected on entry by R0: 05780000
* 0=> same as 9 (q.v.), but if ok, return R1->buffer,R0=# and remove 05780500
* the sequence number (if any) from the buffer (used for TAKE files) 05781000
* 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05781500
* 2=> open (out): (same) 05782000
* 3=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05782500
* writable (else R15=1) @SC91269 05783000
* (will say "found" if member given, but it's not a PDS) @SC88043 05783500
* (will say "not found" if given member of PDS is missing) 05784000
* 4=> close file: R1->adr(FAB). 05784500
* 5=> set up search: R1->pattern name. 05785000
* 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05785500
* 7=> close search (if any). 05786000
* 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05786500
* 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05787000
* 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05787500
* 11=> test space: R1->pattern FDB (has size in Kbytes), 05788000
* R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05788500
* 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05789000
* always returns R15=1 05789500
* 13=> directory info on file: R1->name. Returns R15=0 if ok. 05790000
* 14=> delete file: R1->name. Returns R15=0 if ok. 05790500
* 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05791000
* 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05791500
* 21=> save file status in directory: R1->FAB. @SC88168 05792000
* 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05792500
* 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05793000
* Return R15=0 if ok. @SC89218 05793500
* 24=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05794000
* readable (else R15=1) @SC91269 05794500
DISKIO ENTER 05795000
USING FABD,3 @SC86295 05795500
SR 4,4 Signal no block assigned @SC86295 05796000
STC 0,DSKCOD Save function code (for now) @SC88101 05796500
LA 5,DYNDSP @SC86345 05797000
LA 6,FDBTRKAL-FDBD(1) Use pattern TRKAL @SC88026 05797500
LA 7,DYNRC @SC86345 05798000
L 8,DFMSGP Ptr to message buffer @SC88119 05798500
XC 0(4,8),0(8) Clear out old message @SC88119 05799000
STM 5,8,DYNPL+16 Set up calling sequence @SC86345 05799500
LA 5,DISKIO+4095 @SC92022 05800000
USING DISKIO+4095,5 @SC92022 05800500
LR 6,0 @SC92022 05801000
AR 6,6 @SC92022 05801500
LH 6,DSK0(6) Get handler address @SC92022 05802000
B DSK0(6) Do the function @SC92022 05802500
DSK0 DC Y(DSKRED-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,DSKXSET-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05804000
DC Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05804500
DC Y(DSKXXX-DSK0),8Y(DSKUTL-DSK0) 12-20 @SC89073 05805000
DC Y(DSKTCLOS-DSK0,DSKOPLIB-DSK0) 21-22 @SC89073 05805500
DC Y(DSKPNT-DSK0,DSKTEST-DSK0) 23-24 @SC91269 05806000
DC 8Y(DSKER1-DSK0) Spares @SC89073 05806500
* 05807000
* Open for input file whose name is at (R2), FDB at (R1) 05807500
DSKOPNI DS 0H @SC89073 05808000
BAL 9,DSKALC Get FAB @SC86295 05808500
BAL 2,DSKLKP Get DSCB @SC86299 05809000
BNZ DSKER1 Not found @SC86295 05809500
BAL 14,DSKTCON Check PDS notation @SC88119 05810000
BAL 14,DSKVALS @SC86295 05810500
BAL 9,DSKFABS Set up FAB from FDB @SC86299 05811000
LH 0,FABLRECL @SC86299 05811500
CH 0,FDBBSIZ+2 Too big? @SC86299 05812000
BNL *+8 Yes, just read a buffer full @SC86299 05812500
ST 0,FDBBSIZ Set buffer size, in case RECFM=F @SC86299 05813000
B DSKOPT Open and test @SC88049 05813500
* 05814000
* Open for output file whose name is at (R2), FDB at (R1) 05814500
DSKOPNO DS 0H @SC89073 05815000
BAL 9,DSKALC Get FAB @SC86295 05815500
BAL 2,DSKLKP Get DSCB @SC86299 05816000
MVI DYNDSP,X'42' NEW,CATLG if not found @SC89250 05816500
BNZ DSKOPN Not found, just writing new @SC86299 05817000
BAL 14,DSKTCON Check PDS notation @SC88119 05817500
MVI DYNDSP,X'18' OLD,KEEP @SC86299 05818000
TM DS1DSO,2 PDS? @SC88083 05818500
BO DSKOPVA Yes, keep the other members! @SC88083 05819000
TM FDBFLGS,APPN @SC86295 05819500
BZ *+8 @SC90033 05820000
MVI DYNDSP,X'28' MOD,KEEP @SC88083 05820500
TM FDBFLGS,APPN+SVATT @SC90033 05821000
BZ DSKOPN @SC90033 05821500
DSKOPVA DS 0H @SC88083 05822000
BAL 14,DSKVALS @SC86295 05822500
BAL 9,DSKFABS Set up FAB from FDB @SC86299 05823000
DSKOPN MVI DSKOPLS,X'8F' Code for OPEN OUTPUT @SC88049 05823500
LH 0,FDBLRC @SC88120 05824000
BAL 2,DSKTV @SC88120 05824500
S 0,F4 Deduct 4 for RDW if RECFM=V @SC88120 05825000
ST 0,FABLRTR Set effective record length @SC88120 05825500
DSKOPT KCALL DYNALC,DYNPL,EXT @SC86299 05826000
CLI DYNRC+3,0 @SC88119 05826500
BNE DSKERAL Error on allocation @SC88119 05827000
CLI DYNDSP,X'42' NEW dataset? @SC88090 05827500
BNE DSKOPBZ No, assume BLKSIZE is ok @SC88090 05828000
DEVTYPE FABDDNAM,DYNPL Yes, get max block @SC88090 05828500
ICM 0,15,DYNPL+4 @SC88090 05829000
BNH DSKOPBZ Max not defined?? @SC88090 05829500
CH 0,FABBLKSI @SC88090 05830000
BNL DSKOPBZ Current BLKSIZE is ok @SC88090 05830500
STH 0,FABBLKSI Mustn't exceed physical limits! @SC88090 05831000
DSKOPBZ DS 0H @SC88090 05831500
OPEN MF=(E,DSKOPLS) @SC88049 05832000
TM FABOFLGS,X'10' @SC86299 05832500
BZ DSKER1 Didn't work @SC86299 05833000
LA 9,FDBD FDB pointer @SC91283 05833500
RETREG (0,3),(1,9) Return FAB ptr in R0, FDB in R1 @SC91283 05834000
B RTRN0 @SC86295 05834500
* 05835000
* Open library with DDNAME at (R2) - for BLDL only @SC89073 05835500
DSKOPLIB LR 8,2 @SC89073 05836000
LA 1,TAKFDB VB/256 @SC89073 05836500
LA 2,F0+FABDSN-FABDSMB DS=PO @SC89073 05837000
BAL 9,DSKALC Get a DCB @SC89073 05837500
MVC FABDDNAM,0(8) Use given DD name @SC89073 05838000
DMSFREE DWORDS=176/8,ERR=DSKER1 Get a JFCB @SC89073 05838500
LR 7,1 Save ptr to block @SC92022 05839000
ST 7,FABEXL Add to exit list @SC92022 05839500
MVI FABEXL,7 Mark it a JFCB @SC89073 05840000
RDJFCB MF=(E,DSKOPLS) @SC88073 05840500
LR 6,15 @SC89073 05841000
DMSFRET DWORDS=176/8,LOC=(7) @SC92022 05841500
LTR 15,6 @SC89073 05842000
BNZ DSKER1 @SC89073 05842500
MVI FABEXL,0 Disable JFCB ptr @SC89073 05843000
B DSKOPBZ Now open for input @SC89073 05843500
* 05844000
* Test for existence of file whose name is at (R2) 05844500
DSKTEST DS 0H @SC89073 05845000
LR 8,2 Save DSN ptr @SC89250 05845500
LA 1,FILFDB Default pattern for HRECALL @SC89250 05846000
BAL 9,DSKALC Allocate DCB @SC89250 05846500
BAL 2,DSKLKP Get DSCB @SC86299 05847000
BNZ DSKER1 Not found @SC86299 05847500
CLI FABDSMB,C' ' Did we want a member? @SC88119 05848000
BE DSKTE1 No, fine @SC88043 05848500
TM DS1DSO,2 Was it a PDS? @SC88043 05849000
BZ DSKTE1 No, ignore the conflict for now @SC88043 05849500
XC FABDSMB,FABDSMB Signal DSORG=PO @SC88119 05850000
OPENF I,FABDSN,FILFDB,DSKTKT,E=DSKER1 @SC89250 05850500
MVC FABDSMB,44(8) Restore member name @SC89250 05851000
L 1,DSKTKT @SC88043 05851500
MVC PDSBLK(4),=Y(1,58) Set count and length @GH90139 05852000
MVC PDSMEMBR,44(8) Move in member name @GH90139 05852500
BLDL (1),PDSBLK See if member is there @GH90139 05853000
LR 6,15 Save return code @SC92022 05853500
CLOSF DSKTKT Close it up again @SC88043 05854000
LTR 6,6 @SC92022 05854500
BNZ DSKER1 Wasn't there @SC89250 05855000
DSKTE1 MVC DSKSTT+FDBD-FABD(FDBINFO),FDBD Save FDB stuff @SC89250 05855500
LA 0,FABDWDS Release FAB storage @SC89250 05856000
LR 1,3 @SC89250 05856500
DMSFRET DWORDS=(0),LOC=(1) @SC89250 05857000
SR 4,4 Mark it gone @SC89250 05857500
LA 3,DSKSTT Ptr for internal FDB @SC89250 05858000
BAL 14,DSKVALS Fill out FDB @SC89250 05858500
LA 9,FDBD FDB pointer @SC91283 05859000
RETREG (1,9) Return FDB ptr in R1 @SC91283 05859500
B RTRN0 @SC86299 05860000
* 05860500
* Close file whose ticket is at (R1), release block 05861000
DSKCLOS DS 0H @SC89073 05861500
ICM 3,15,0(1) Get FAB ptr, if any @SC86295 05862000
BZ RTRN0 None, ignore @SC86295 05862500
MVI 0(1),X'80' Flag for normal close @SC88049 05863000
LR 2,1 Save ptr @SC88049 05863500
CLOSE MF=(E,(1)) Close it @SC88049 05864000
XC 0(4,2),0(2) Ok, now clear ticket @SC88049 05864500
TM FABBUFCB+3,1 Any buffers? @SC88043 05865000
BO DSKFRPZ No, fine @SC88043 05865500
FREEPOOL (3) @SC86299 05866000
DSKFRPZ DS 0H Now free whole FAB @SC88043 05866500
LA 0,FABDWDS @SC86295 05867000
LR 1,3 @SC86299 05867500
DMSFRET DWORDS=(0),LOC=(1) @SC86295 05868000
B RTRN0 @SC86295 05868500
* 05869000
* TClose file whose ticket is in (R1) @SC88168 05869500
DSKTCLOS ST 1,DSKTKT @SC88168 05870000
MVI DSKTKT,X'80' Flag for normal close @SC88168 05870500
CLOSE MF=(E,DSKTKT),TYPE=T @SC88168 05871000
B RTRN0 @SC88168 05871500
* 05872000
* Read from file whose ticket is at (R1) 05872500
DSKRED DS 0H @SC89073 05873000
LTR 3,1 Get FAB ptr @SC86299 05873500
BNP RTRN1 Not defined anymore @SC86299 05874000
L 15,FABGET I/O routine @SC86299 05874500
BALR 14,15 Go to it @SC86299 05875000
LM 14,15,FDBBUFF Get buffer and size @SC92022 05875500
LH 7,FABLRECL Actual length @SC86299 05876000
LR 0,7 Save length for number check @SC88101 05876500
AR 7,1 End of record @SC86299 05877000
BAL 2,DSKTV @SC86299 05877500
LA 1,4(1) Skip over SDW if V @SC86299 05878000
CLI DSKCOD,0 NONUM? @SC88101 05878500
BNE DSKREDC No, use everything @SC88101 05879000
CLI FDBRCF,C'F' Fixed-length records? @SC88101 05879500
BNE DSKREDV No, line numbers at start (if any)@SC88101 05880000
CH 0,=H'80' See if F/80 @SC88101 05880500
BNE DSKREDC No @SC88101 05881000
MVZ DSKMNTH(5),75(1) See if 76-80 are all numeric @SC90213 05881500
CLC DSKMNTH(5),=8C'0' (DSKMNTH was cleared: LOCAL) @SC90213 05882000
BNE DSKREDC No @SC88101 05882500
S 7,F8 Yes, move the end back @SC88101 05883000
B DSKREDC @SC88101 05883500
DSKREDV LA 0,8(1) Is length at least 8? @SC88101 05884000
CR 0,7 @SC88101 05884500
BNL DSKREDC No, can't be numbered @SC88101 05885000
MVZ DSKMNTH(8),0(1) See if 1-8 all numeric @SC90213 05885500
CLC DSKMNTH(8),=8C'0' (DSKMNTH was cleared: LOCAL) @SC90213 05886000
BNE DSKREDC No, not numbered @SC88101 05886500
LA 1,8(1) Yes, skip over number @SC88101 05887000
DSKREDC DS 0H @SC88101 05887500
SR 7,1 Revised length @SC86299 05888000
LR 6,1 @SC86299 05888500
CR 7,15 @SC92022 05889000
BNL *+6 @SC86299 05889500
LR 15,7 Buffer not filled @SC92022 05890000
L 1,4(13) @SC86299 05890500
ST 15,20(,1) Return length in R0 @SC92022 05891000
CLI DSKCOD,0 NONUM? @SC88101 05891500
BNE *+8 @SC88101 05892000
ST 14,24(,1) Yes, return R1 ptr @SC92022 05892500
MVCL 14,6 Copy to buffer @SC92022 05893000
B RTRN0 @SC86299 05893500
* End of file on input. Don't close it yet. @SC86295 05894000
DSKEOD LA 15,12 End return code @SC86295 05894500
B RTRN @SC86295 05895000
* 05895500
* Write to file whose ticket is at (R1) 05896000
DSKWRT DS 0H @SC89073 05896500
LTR 3,1 Get FAB ptr @SC86299 05897000
BNP RTRN1 Not defined anymore @SC86299 05897500
LM 8,9,FDBBUFF Get buffer and size @SC92022 05898000
DSKWR1 LR 6,9 Copy for LRECL @SC92022 05898500
BAL 2,DSKTV @SC86299 05899000
LA 6,4(,9) + 4 if RECFM=V @SC92022 05899500
STH 6,FABLRECL Set up for output @SC86299 05900000
IC 7,ERRNUM Save previous error code, if any @SC88139 05900500
MVI ERRNUM,0 Clear error number @SC86299 05901000
L 15,FABGET I/O routine @SC86299 05901500
BALR 14,15 Do it @SC86299 05902000
SR 15,15 @SC86299 05902500
ICM 15,1,ERRNUM See if deadly error @SC86299 05903000
BNZ RTRN Yes, pass return code @SC86299 05903500
STC 7,ERRNUM Restore previous error code @SC88139 05904000
TM FABRECFM,FABRECU Check if V @SC91283 05904500
BNM DSKWR2 No, U @SC91283 05905000
TM FABRECFM,FABRECF @SC91283 05905500
BO DSKWR2 No, F @SC91283 05906000
XC 0(4,1),0(1) @SC86299 05906500
STCM 6,3,0(1) In case V @SC86299 05907000
LA 1,4(1) V: space over SDW @SC86299 05907500
DSKWR2 DS 0H @SC91283 05908000
LR 6,1 @SC86299 05908500
LR 7,9 @SC92022 05909000
MVCL 6,8 Copy to output record @SC92022 05909500
B RTRN0 @SC86295 05910000
* 05910500
* Point past 1st N records of file at (R1) @SC89218 05911000
DSKPNT ICM 3,15,0(1) Get ticket @SC89218 05911500
BZ RTRN1 Not open @SC89218 05912000
LR 3,1 @SC89218 05912500
LTR 2,2 Number of records to skip @SC89218 05913000
BNP RTRN0 Never mind @SC89218 05913500
DSKPNTL READF 0(,3),E=RTRN1 Skip one @SC89218 05914000
BCT 2,DSKPNTL ... until finished @SC89218 05914500
B RTRN0 Return with completion code @SC89218 05915000
* 05915500
* Analyze error: packed dec. code in TMPDW 05916000
DSKXXX DS 0H @SC89073 05916500
MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 05917000
L 2,EMSGP Ptr to msg buffer @SC87338 05917500
CLC =C' ',0(2) Proper SYNAD message? @SC87338 05918000
BE *+10 Yes, ok @SC87338 05918500
XC EMSGL,EMSGL No, clear length @SC87338 05919000
B RTRN1 @SC87338 05919500
* 05920000
* Disk utility for file(s) at (R1) and (R2) 05920500
DSKUTL LR 8,0 Save code-12 @SC86316 05921000
MVC DSKPSAV(8),DESTL+1 Save Kermit prefix @SC88043 05921500
L 14,ORGR1 Find User prefix @SC88043 05922000
USING CPPL,14 @SC88043 05922500
L 14,CPPLUPT @SC88043 05923000
USING UPT,14 @SC88043 05923500
MVC DESTL+1(1),UPTPREFL Use that for now @SC88043 05924000
MVC DEST(7),UPTPREFX @SC88043 05924500
DROP 14 @SC88043 05925000
SH 0,=H'13' Code-13: DIR,DEL,REN,COP @SC89073 05925500
SLA 0,3 @SC86295 05926000
LA 14,DSKCMDS @SC92022 05926500
AR 14,0 Ptr to command name @SC92022 05927000
LA 7,CMD Buffer for system command @SC86299 05927500
MVC 0(8,7),0(14) @SC92022 05928000
LA 7,8(7) @SC86299 05928500
LTR 0,0 Was it DIR? @SC88043 05929000
BNZ DSKUTP No, use filespec(s) as is @SC88043 05929500
MVC 0(4,7),=C'LVL(' Yes, maybe need an option @SC88043 05930000
MVC 4(44,7),0(1) If so, need whole filespec @SC88043 05930500
LA 0,4(7) @SC88043 05931000
LA 1,44 @SC88043 05931500
LA 14,DEST Comparand is user prefix @SC88043 05932000
LH 15,DESTL @SC88043 05932500
ICM 15,8,BLANK Extended with blanks @SC88043 05933000
CLCL 0,14 @SC88043 05933500
BE DSKUTX Just that - no options @SC88043 05934000
LA 1,4+44(7) @SC88043 05934500
TRT 4(44,7),TRTBL Find end of filespec @SC88043 05935000
MVI 0(1),C')' And complete the syntax @SC88043 05935500
LA 7,1(1) End of command string @SC88043 05936000
B DSKUTX Do it @SC88043 05936500
DSKUTP DS 0H Other utilities... @SC88043 05937000
BAL 3,DSKUTCP @SC86295 05937500
SRA 0,4 @SC86295 05938000
BZ *+10 @SC86295 05938500
LR 1,2 2nd file @SC86295 05939000
BAL 3,DSKUTCP @SC86295 05939500
DSKUTX MVC DESTL+1(8),DSKPSAV Restore Kermit prefix @SC88043 05940000
LA 0,CMD @SC86295 05940500
LR 6,7 @SC86299 05941000
SR 6,0 @SC86299 05941500
NI FL4,255-UCMD Not user command: adr=(0),len=(6) @SC86295 05942000
KCALL SUPFNC,3 Execute it @SC86295 05942500
B RTRN @SC86295 05943000
* 05943500
DSKUTCP LR 4,0 Save ID @SC86299 05944000
LA 0,FFDSP @SC86299 05944500
KCALL FSPEC @SC86299 05945000
MVI 0(15),C' ' @SC86299 05945500
LA 7,1(15) New output ptr @SC86299 05946000
LR 0,4 @SC86299 05946500
BR 3 @SC86295 05947000
* 05947500
DSKCMDS DC C'LISTCAT ' Utility command names @SC86299 05948000
DC C'DELETE ' @SC86299 05948500
DC C'RENAME ' @SC86299 05949000
DC C'COPY ' @SC86299 05949500
* 05950000
DSKTV TM FABRECFM,FABRECU @SC86299 05950500
BNM 4(2) U @SC86299 05951000
TM FABRECFM,FABRECF @SC86299 05951500
BO 4(2) F @SC86299 05952000
BR 2 V @SC86299 05952500
* Check PDS notation -- must match DSORG. Return via R14 05953000
DSKTCON TM DS1DSO,2 Partitioned? @SC88119 05953500
BO DSKTCOP Yes, insist on member name @SC88119 05954000
CLI FABDSMB,C' ' Member name? @SC88119 05954500
BER 14 No, ok @SC88119 05955000
B DSKER1 @SC88119 05955500
DSKTCOP CLI FABDSMB,C' ' Member name? @SC88119 05956000
BNER 14 Yes, ok @SC88119 05956500
CLI FABDSMB+1,0 No, but maybe just want directory?@SC88119 05957000
BER 14 Yes, ok @SC88119 05957500
* Return on error, release useless block, if any 05958000
DSKER1 LTR 1,4 Any block assigned? @SC86295 05958500
BZ RTRN1 No @SC86295 05959000
LA 0,FABDWDS Yes, release it @SC86295 05959500
DMSFRET DWORDS=(0),LOC=(1) @SC86295 05960000
B RTRN1 Flag error @SC86295 05960500
* 05961000
DSKERAL L 1,DFMSGP Ptr to DAIRFAIL buffer @SC88119 05961500
SR 9,9 @SC88119 05962000
ICM 9,3,0(1) Length of message @SC88119 05962500
BZ DSKER1 None (why not?) @SC88119 05963000
LA 8,4(1) Start of text @SC88119 05963500
CLC =C'IKJ',0(8) Has msg id? @SC88119 05964000
BNE *+8 @SC88119 05964500
LA 8,10(8) Yes, skip it @SC88119 05965000
S 8,F2 @SC88119 05965500
MVC 0(2,8),=C' ' Make it begin with two blanks @SC88119 05966000
AR 9,1 End of message @SC88119 05966500
SR 9,8 Length to use @SC88119 05967000
DSKERMSG L 6,EMSGP Explanation buffer @SC89250 05967500
LA 7,LEMSG Length of same @SC88119 05968000
CR 7,9 @SC88119 05968500
BNH *+6 @SC88119 05969000
LR 7,9 Too long, use what we can @SC88119 05969500
ST 7,EMSGL Usable length @SC88119 05970000
MVCL 6,8 Copy to buffer @SC88119 05970500
B DSKER1 @SC88119 05971000
* 05971500
* Allocate FAB. Enter with R1->FDB pattern, R2->DSN @SC92022 05972000
* Clobber 0,1,2,15. Set R3,R4->new FAB, R6->pattern. @SC92022 05972500
* Return via R9. @SC92022 05973000
DSKALC DS 0H @SC92022 05973500
LA 6,1 Update counter @SC86299 05974000
A 6,EVCTR @SC86299 05974500
ST 6,EVCTR @SC86299 05975000
LR 6,1 Save FDB ptr @SC92022 05975500
LA 0,FABDWDS @SC86295 05976000
DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 05976500
LR 3,1 New block ptr @SC86295 05977000
ST 3,DSKOPLS Save for OPEN plist @SC88049 05977500
MVI DYNDSP,X'88' SHR,KEEP @SC86299 05978000
MVI DSKOPLS,X'80' Code for OPEN INPUT @SC88049 05978500
LR 4,3 Indicate we have it @SC88120 05979000
XC 0(8*FABDWDS,3),0(3) @SC86295 05979500
MVC FDBD(FDBCOP),0(6) Copy user's FDB @SC92022 05980000
MVC FABDSN,0(2) @SC86299 05980500
LA 15,FABDSN Set up DSN ptr @SC86299 05981000
LA 0,FABDDNAM Get DDN ptr @SC86299 05981500
LA 1,FDBUNT Get UNIT ptr @SC86299 05982000
LA 2,FDBVOL Get VOL ptr @SC86299 05982500
STM 15,2,DYNPL Set up DYNALC @SC86299 05983000
MVI FABBUFCB+3,1 Fill out DCB @SC86299 05983500
MVI FABDSORG,X'40' =PS @SC86299 05984000
MVI FABMACR,X'48' MACRF=GL @SC88043 05984500
CLI FABDSMB,0 Special case of PDS? @SC88119 05985000
BNE *+16 No @SC88043 05985500
MVI FABDSORG,X'02' Yes, set DSORG=PO @SC86299 05986000
MVI FABMACR,X'24' ... and MACRF=R @SC88043 05986500
MVI FABDSMB,C' ' and blot out member @SC88119 05987000
MVC FABMACR+1(1),FABMACR @SC88043 05987500
MVI FABIOBAD+3,1 @SC86299 05988000
LA 0,DSKEOD @SC86299 05988500
LA 1,FABEXL Modifiable exit list @SC89073 05989000
MVC 4(8,1),DSKOPEX Copy usual stuff into it @SC89073 05989500
STM 0,1,FABEODAD @SC86299 05990000
UNPK FABDDNAM,EVCTR(5) @SC86299 05990500
TR FABDDNAM,TRHEX Get unique DDNAME @SC86299 05991000
MVI FABDDNAM,C'K' @SC86299 05991500
MVI FABDDNAM+7,C'Z' @SC86299 05992000
MVI FABOFLGS,2 Not open yet @SC88043 05992500
MVI FABCHECK+3,1 @SC86299 05993000
LA 1,DSKSYN @SC87338 05993500
ST 1,FABSYNAD In case of error @SC86299 05994000
MVI FABIOBA+3,1 @SC86299 05994500
MVC FABEOBAD(16),FABIOBA @SC87314 05995000
MVI FABEOB+3,1 @SC86299 05995500
DSKFABS LH 1,FDBBLKSI Copy Info to DCB @SC88120 05996000
STH 1,FABBLKSI @SC88120 05996500
STH 1,FABLRECL @SC86299 05997000
MVI FABRECFM,FABRECU @SC86299 05997500
CLI FDBRCF,C'U' @SC86299 05998000
BE DSKFABCC @SC88246 05998500
MVC FABLRECL,FDBLRC Use true LRECL after all @SC88120 05999000
MVI FABRECFM,FABRECF+FABRECBR @SC86299 05999500
CLI FDBRCF,C'F' @SC86299 06000000
BE DSKFABCC @SC88246 06000500
MVI FABRECFM,FABRECV+FABRECBR @SC86299 06001000
DSKFABCC XC FABRECFM,FDBFLGS Copy carriage control flags @SC88246 06001500
NI FABRECFM,255-FABRECCC And only those flags @SC88246 06002000
XC FABRECFM,FDBFLGS @SC88246 06002500
BR 9 @SC86299 06003000
* 06003500
* Call with R15->name, return to R2 with CC set (Z if ok) 06004000
* Clobbers or sets 0,1,6,7,14,15. Assumes R3->full FAB @SC89250 06004500
* Assumes name ptr already stored in DYNPL, in case migrated @SC89250 06005000
DSKLKP SR 0,0 @SC86299 06005500
LA 1,CAMVOLS @SC86299 06006000
LA 14,X'44' Name code @SC86299 06006500
SLL 14,24 @SC86299 06007000
STM 14,1,CAMLOC Save dsn ptr, etc @SC86299 06007500
LA 0,CAMVOLS+6 @SC86299 06008000
LA 1,CAMDSCB @SC86299 06008500
LA 14,X'C1' Search code @SC86299 06009000
SLL 14,24 @SC86299 06009500
STM 14,1,CAMOBT @SC86299 06010000
LA 7,1 Flag for 1st pass @SC89250 06010500
DSKLKPL DS 0H @SC89250 06011000
MVC CAMVOLS(2),F0 Clear volume count @SC92147 06011500
LOCATE CAMLOC @SC86299 06012000
LTR 6,15 Retain 1st code in R6 @SC86299 06012500
BZ DSKLKPCT Cataloged ok @SC90275 06013000
CLI FDBVOL,C' ' Not cataloged, any volume given? @SC90275 06013500
BE DSKLKPNF No, can't find it @SC90275 06014000
MVC CAMVOLS+6(6),FDBVOL Try default volume @SC88342 06014500
LA 0,=C'SYSALLDA' and insist on catchall UNIT @SC88342 06015000
ST 0,DYNPL+8 for DYNALC @SC90275 06015500
OBTAIN CAMOBT Get DSCB if on given volume @SC90275 06016000
DSKLKPNF LTR 15,15 Non-zero return code => not found @SC90275 06016500
BR 2 @SC90275 06017000
DSKLKPCT DS 0H Cataloged dataset @SC90275 06017500
LA 15,1 @SC92147 06018000
CLC CAMVOLS(2),F0 Any volume list returned? @SC92147 06018500
BE DSKLKPNF No, must be GDG name (+n) @SC92147 06019000
OBTAIN CAMOBT Get DSCB @SC86299 06019500
LA 0,=C' ' Cataloged, don't specify @SC88342 06020000
LR 1,0 @SC88342 06020500
STM 0,1,DYNPL+8 @SC88342 06021000
LTR 15,15 Test return code @SC89250 06021500
BZR 2 Ok, file was found @SC89250 06022000
BCT 7,DSKLKPZ Quit if already tried recall @SC89250 06022500
TM FL2,PROTO Transfer/server mode in progress? @SC89250 06023000
* BO DSKLKPZ Quit if in protocol mode @SC89250 06023500
CLC =C'MIGRAT',CAMVOLS+6 @SC89250 06024000
BNE DSKLKPZ Quit if volume not MIGRAT @SC89250 06024500
L 6,DYNPL Get ptr to name again @SC89250 06025000
MVC LKPMEM,44(6) Save member name, if any @SC89250 06025500
MVI 44(6),C' ' And blank it out @SC89250 06026000
KCALL DYNALC,DYNPL,EXT Set up DD @SC89250 06026500
MVC 44(8,6),LKPMEM Restore member name @SC89250 06027000
CLI DYNRC+3,0 @SC89250 06027500
BNE DSKER1 Quit if failed @SC89250 06028000
OPEN MF=(E,DSKOPLS) Open (and wait for recall) @SC89250 06028500
CLOSE MF=(E,DSKOPLS) Don't use, just close it @SC89250 06029000
TM FABBUFCB+3,1 @SC89250 06029500
BO DSKLKPL No buffers, all set @SC89250 06030000
FREEPOOL (3) Free buffers first @SC89250 06030500
B DSKLKPL Try all over again to LOCATE @SC89250 06031000
* 06031500
DSKLKPZ PTEXT '&MIGRATD',AREG=8,LREG=9 @SC89250 06032000
B DSKERMSG Copy msg to buffer @SC89250 06032500
* 06033000
* Handle synchronous disk I/O errors 06033500
DSKSYN SYNADAF ACSMETH=QSAM Get system to do the work @SC87338 06034000
L 2,EMSGP Ptr to msg buffer @SC87338 06034500
MVC 0(80,2),48(1) Copy message (inc. 2 blanks) @SC87338 06035000
LA 2,80 @SC87338 06035500
ST 2,EMSGL Length of string @SC87338 06036000
SYNADRLS Clean up @SC87338 06036500
B RTRN1 @SC87338 06037000
* 06037500
* Set up search through list of files, pattern at (R1) 06038000
DSKNSET DS 0H @SC89073 06038500
MVI CIROPT,2 Get full names @SC87015 06039000
L 3,CIRWA Initialize length ptrs @SC87015 06039500
MVC 0(4,3),CIRWAL @SC87015 06040000
NI DSKFL,255-WFN-NXDON @SC87015 06040500
MVC NXFN,0(1) Copy name @SC87015 06041000
LA 1,NXFN+52 End of member slot @SC88096 06041500
TRT NXFN+44(8),TRTBL Find end of member name @SC88096 06042000
LR 7,1 Save ptr @SC92022 06042500
LA 1,NXFN+44 @SC87015 06043000
TRT NXFN(44),TRTBL @SC87015 06043500
LR 3,1 End of name @SC87015 06044000
MVI TRTBL+C'*',1 @SC87015 06044500
LA 0,NXFN @SC88096 06045000
LA 9,DSKNDIR Where to go if no "*" in DSN @SC88096 06045500
LA 14,DSKNCIR Where to go if "*" found @SC88096 06046000
TRT NXFN(44),TRTBL Check for wild card @SC87015 06046500
DSKNSW BZR 9 Len=max, just use the one file @SC88096 06047000
CLI 0(1),C'*' Did we find an asterisk @SC87015 06047500
BNER 9 No, just the end of the name @SC88096 06048000
MVI TRTBL+C'*',0 @SC88096 06048500
OI DSKFL,WFN Mark it wild @SC87015 06049000
LA 4,1(1) @SC87015 06049500
ST 4,NXSFPTR Save ptr to suffix @SC87015 06050000
SR 3,4 @SC87015 06050500
STH 3,DSNSFL and length @SC87015 06051000
SR 1,0 @SC87015 06051500
STH 1,DSNPFL Length of prefix @SC87015 06052000
BR 14 Now get name list @SC88096 06052500
DSKNCIR CLI NXFN+44,C' ' Insist no members if wild DSN @SC88096 06053000
BNE RTRN1 @SC88096 06053500
AR 1,0 End of prefix string @SC88096 06054000
DSKNPLP BCTR 1,0 Scan back for a dot @SC88096 06054500
CR 1,0 Must be one, else we scan universe@SC88096 06055000
BNH RTRN1 None there, give up @SC88096 06055500
CLI 0(1),C'.' @SC88096 06056000
BNE DSKNPLP Keep looking @SC88096 06056500
SR 1,0 Count of bytes in whole qualifiers@SC88096 06057000
L 14,CIRSRCH Argument ptr @SC87015 06057500
LA 15,44 @SC87015 06058000
ICM 1,8,BLANK @SC87015 06058500
MVCL 14,0 Copy with blank fill @SC87015 06059000
LINK EP=IKJEHCIR,MF=(E,CIRPARM) Call catalog routine @NW86330 06059500
LTR 15,15 @SC87015 06060000
BNZ RTRN1 Not found @SC87015 06060500
LA 1,45-4 Skip count bytes, then back one @SC88096 06061000
DSKNRET L 2,CIRWA ADR OF RETURNED CATALOG BUFFER @SC88096 06061500
SR 2,1 Back up one item @SC88096 06062000
ST 2,CATDSPTR Save ptr to buffer @NW86330 06062500
B RTRN0 @SC86295 06063000
* 06063500
DSKNDIR LR 3,7 Use end of member name @SC92022 06064000
LA 0,NXFN+44 Start of member @SC88096 06064500
LA 9,RTRN0 Where to go if not wild @SC88096 06065000
TRT NXFN+44(8),TRTBL Find any '*' @SC88096 06065500
MVI TRTBL+C'*',0 Now restore table @SC88096 06066000
BAL 14,DSKNSW Return here if '*' found @SC88096 06066500
SR 4,4 Clear FAB ptr @SC88096 06067000
LA 1,DSKDPAT Sample DCB info @SC88096 06067500
LA 2,CAMVOLS Reuse this area for the DSN @SC88096 06068000
MVC 0(44,2),NXFN Copy DSN @SC88096 06068500
MVI 44(2),C' ' And blank out member @SC88096 06069000
BAL 9,DSKALC Get a DCB (FAB) @SC88096 06069500
BAL 2,DSKLKP Get DSCB @SC88096 06070000
BNZ DSKER1 Not found @SC89317 06070500
TM DS1DSO,2 Is it really a PDS? @SC88096 06071000
BZ DSKER1 No, give up @SC89317 06071500
KCALL DYNALC,DYNPL,EXT Allocate file @SC88096 06072000
OPEN MF=(E,DSKOPLS) And open it to the directory @SC88096 06072500
TM FABOFLGS,X'10' Ok? @SC88096 06073000
BZ DSKER1 Too bad @SC88096 06073500
ST 4,DSKTKT Save ptr to FAB @SC88096 06074000
L 2,CIRWA Start of name buffer @SC88096 06074500
LH 9,CIRWAL Length @SC88096 06075000
AR 9,2 End of buffer @SC88096 06075500
S 9,FDBBSIZ Back up one block @SC88096 06076000
DSKDL1 READF DSKTKT,BUFFER=(2),E=DSKDLZ Read a block @SC88096 06076500
SR 7,7 @SC88096 06077000
ICM 7,3,0(2) Get length of block info @SC88096 06077500
AR 7,2 End of block @SC88096 06078000
BCTR 7,0 Set up BXLE @SC88096 06078500
LA 8,2(2) Point to member info @SC88096 06079000
DSKDL2 CLC 0(8,8),=8X'FF' End of directory? @SC88096 06079500
BE DSKDLZ Yes, all done @SC88096 06080000
TM 11(8),X'80' Alias member? @SC88096 06080500
BO DSKDL3 Yes, ignore it @SC88096 06081000
MVI 0(2),C'A' Create table entry @SC88096 06081500
MVC 1(8,2),0(8) with member name @SC88096 06082000
LA 2,9(2) @SC88096 06082500
DSKDL3 IC 6,11(8) Get entry length @SC88096 06083000
N 6,=F'31' @SC88096 06083500
LA 6,12(6,6) In bytes @SC88096 06084000
BXLE 8,6,DSKDL2 On to next member @SC88096 06084500
CR 2,9 Room for another block in table? @SC88096 06085000
BNH DSKDL1 Ok @SC88096 06085500
DSKDLZ MVI 0(2),0 End of table @SC88096 06086000
CLOSF DSKTKT Release the file @SC88096 06086500
C 2,CIRWA Did we find anything? @SC88096 06087000
BE RTRN1 No?? @SC88096 06087500
LA 1,9 Length of entries @SC88096 06088000
B DSKNRET Go init. ptr into table @SC88096 06088500
DSKDPAT DC A(0,256),C'F',X'0',H'256,0,0,256' @SC88096 06089000
* 06089500
* Flush previous file pattern 06090000
DSKXSET DS 0H @SC89073 06090500
OI DSKFL,NXDON @SC87015 06091000
B RTRN0 @SC87015 06091500
* 06092000
* Check CWD string, return code in R15 06092500
DSKCWDF DS 0H @SC89073 06093000
SR 4,4 Clear FAB ptr @SC91283 06093500
LR 2,1 Temp name ptr @SC91283 06094000
LA 1,DSKDPAT Sample DCB info @SC91283 06094500
BAL 9,DSKALC Get a DCB (FAB) @SC91283 06095000
BAL 2,DSKLKP Check name @SC87015 06095500
BNZ DSKCWDZ No conflict, assume valid @SC91283 06096000
TM DS1DSO,2 Was a full DSN, check DSORG @SC88054 06096500
BO DSKCWD1 It's a PDS -- see if it matches @SC88054 06097000
CLI FABDSMB,C'.' PDS requested? @SC91283 06097500
BE DSKER1 Yes, but file not found @SC91283 06098000
B DSKCWDZ @SC91283 06098500
DSKCWD1 CLI FABDSMB,C'.' PDS requested? @SC91283 06099000
BNE DSKER1 No, but file was found @SC91283 06099500
DSKCWDZ B DSKFRPZ Yes, ok @SC91283 06100000
* 06100500
* Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06101000
DSKTSP DS 0H @SC89073 06101500
* - - - get size of available space in R0,R1 @SC87015 06102000
LA 0,1023 For now, claim 4 Tbyte @SC87015 06102500
SRDA 0,10 Convert to Kbytes @SC86316 06103000
CLR 1,2 @SC87012 06103500
BL RTRN1 No room @SC86316 06104000
B RTRN0 Ok @SC86316 06104500
* 06105000
* Check against prefix and suffix criteria and return next match, 06105500
* if any 06106000
* Also return info in a File Descriptor Block @SC86151 06106500
DSKNXT DS 0H @SC89073 06107000
TM DSKFL,NXDON @SC87015 06107500
BO RTRN1 Nothing more @SC87015 06108000
MVC FILNAM,NXFN @SC87015 06108500
TM DSKFL,WFN Are we scanning? @SC87015 06109000
BO NXFBEG Yes, do it @SC87015 06109500
OI DSKFL,NXDON No, that's the only one @SC87015 06110000
LA 2,FILNAM @SC87015 06110500
B DSKTEST Now return file info @SC89157 06111000
NXFBEG L 6,CATDSPTR Ptr to place in catalog @NW86330 06111500
USING CATDSET,6 @NW86330 06112000
LA 7,NXFN+44 Start of member @SC88096 06112500
LA 8,8-1 Length of member name @SC88096 06113000
C 7,NXSFPTR Is suffix part of member name? @SC88096 06113500
BL *+12 Yes, we're set @SC88096 06114000
LA 7,NXFN No, use start of DSN @SC88096 06114500
LA 8,44-1 and length @SC88096 06115000
NXFDS LA 6,2(8,6) Next @SC88096 06115500
CLI TYPEBYTE,C'A' @NW86330 06116000
BNE NXFZ Assume end of list @SC87015 06116500
LH 2,DSNPFL Get prefix length @SC87015 06117000
LTR 2,2 @NW86330 06117500
BNP XL0092 @NW86330 06118000
LR 14,7 Compare saved prefix @SC88096 06118500
LA 3,CATDNAME against this name @SC87015 06119000
LA 9,0(2,3) End of possible match @SC92022 06119500
BCTR 2,0 Set up for CLC @SC87015 06120000
EX 2,NXFCMP @SC87015 06120500
BNE NXFDS No match @SC87015 06121000
XL0092 CLC DSNSFL,F0 @SC87015 06121500
BNH XL0002 Don't check suffix @NW86330 06122000
LA 1,1(8,3) Limit of name field @SC88096 06122500
EX 8,NXFTRT Find end of name @SC88096 06123000
LR 3,1 @SC87015 06123500
LH 4,DSNSFL @SC87015 06124000
SR 3,4 Ptr to start of suffix @SC87015 06124500
CR 3,9 @SC92022 06125000
BL NXFDS Shorter than prefix+suffix @SC88096 06125500
BCTR 4,0 @SC87015 06126000
L 14,NXSFPTR Ptr to comparison suffix @SC87015 06126500
EX 4,NXFCMP @SC87015 06127000
BNE NXFDS No match @SC87015 06127500
XL0002 SH 7,=Y(NXFN-FILNAM) Transpose into FILNAM @SC88096 06128000
EX 8,NXFCOP Copy DSN (or member) @SC88096 06128500
ST 6,CATDSPTR Save ptr for next time @NW86330 06129000
LA 2,FILNAM @SC87015 06129500
B DSKTEST Now return file info @SC89157 06130000
* 06130500
NXFCMP CLC 0(,3),0(14) @SC87015 06131000
NXFTRT TRT 0(,3),TRTBL Find end of name @SC88096 06131500
NXFCOP MVC 0(,7),CATDNAME Copy name @SC88096 06132000
* 06132500
NXFZ OI DSKFL,NXDON @SC87015 06133000
B RTRN1 Ran out of names @SC87015 06133500
* 06134000
* Clobbers any registers, returns via 14 @SC90139 06134500
DSKVALS DS 0H @SC92170 06135000
NI FDBFLGS,255-PDSF @SC87015 06135500
TM DS1DSO,2 ORG=PO? @SC87015 06136000
BZ DSKNOPDS No @GH90139 06136500
OI FDBFLGS,PDSF Yes, it's a PDS @SC87015 06137000
IC 15,PDSINDIC Get indicator @GH90139 06137500
N 15,=X'0000001F' Isolate last 5 bits @GH90139 06138000
BZ DSKNOPDS No user data in directory @GH90139 06138500
CH 15,=H'15' Enough user data? @GH90139 06139000
BNE DSKNOPDS No - use date/time from DSCB @GH90139 06139500
TM PDSINDIC,X'60' TTRs in user data area? @GH90139 06140000
BNZ DSKNOPDS Yes - can't handle load modules @GH90139 06140500
CLI ISPFMDTM,X'23' Is hour plausible? @SC90139 06141000
BH DSKNOPDS No - use DSCB date @SC90139 06141500
CLI ISPFMDTM+1,X'59' Is minute plausible? @SC90139 06142000
BH DSKNOPDS No - use DSCB date @SC90139 06142500
TRT ISPFMDTM,DSKPMSK Valid decimal time? @SC90139 06143000
BNZ DSKNOPDS No - use DSCB date @SC90139 06143500
CLC ISPFMDDT+2(2),=X'366F' Is day of year plausible?@SC90139 06144000
BH DSKNOPDS No - use DSCB date @SC90139 06144500
CLC ISPFMDDT+2(2),=X'0010' Is day of year plausible?@SC90139 06145000
BL DSKNOPDS No - use DSCB date @SC90139 06145500
TM ISPFMDDT+3,X'08' Valid sign nybble? @SC90139 06146000
BZ DSKNOPDS No - use DSCB date @SC90139 06146500
NI ISPFMDDT+3,X'F0' Remove sign nybble @SC90139 06147000
TRT ISPFMDDT,DSKPMSK Valid decimal date? @SC90139 06147500
BNZ DSKNOPDS No - use DSCB date @SC90139 06148000
OI ISPFMDDT+3,X'0F' Insert plus sign @SC90139 06148500
MVC FDBDATE+4(2),ISPFMDTM Copy hours, minutes @GH90139 06149000
XC TMPDW,TMPDW @GH90139 06149500
MVC TMPDW+4(4),ISPFMDDT Move modification date @GH90139 06150000
CVB 6,TMPDW Get 00YYDDD in binary @GH90139 06150500
SRDA 6,32 @GH90139 06151000
D 6,=F'1000' Separate YY from DDD @GH90139 06151500
STCM 6,B'0011',DS1CRDT+1 Save DDD @GH90139 06152000
STC 7,DS1CRDT Save YY @GH90139 06152500
LA 15,DS1CRDT Point to modified creation date @GH90139 06153000
B DSKCRDT Skip to date conversion @GH90139 06153500
DSKNOPDS DS 0H @SC90139 06154000
LA 15,DS1CRDT Assume creation date to be used @GH89270 06154500
CLI DS1MDDT,99 Is year plausible? @GH89270 06155000
BH DSKCRDT No - use creation date @GH89270 06155500
CLC DS1MDDT+1(2),=AL2(366) Is day of year plausible?@GH89270 06156000
BH DSKCRDT No - use creation date @GH89270 06156500
CLC DS1MDDT+1(2),=AL2(1) Is day of year plausible?@GH89270 06157000
BL DSKCRDT No - use creation date @GH89270 06157500
CLI DS1MDTM,X'23' Is hour plausible? @GH89270 06158000
BH DSKCRDT No - use creation date @GH89270 06158500
CLI DS1MDTM+1,X'59' Is minute plausible? @GH89270 06159000
BH DSKCRDT No - use creation date @GH89270 06159500
TRT DS1MDTM,DSKPMSK Valid decimal? @SC90139 06160000
BNZ DSKCRDT No - use creation date @SC90139 06160500
CLC DS1MDDT,DS1CRDT Is mod date before creation? @GH89270 06161000
BL DSKCRDT Yes - use creation date @GH89270 06161500
CLC DS1MDDT,DS1RFDT After latest ref? @GH89270 06162000
BH DSKCRDT Yes - use creation date @GH89270 06162500
MVC FDBDATE+4(2),DS1MDTM Copy hours, minutes @GH89270 06163000
LA 15,DS1MDDT Use modification date @GH89270 06163500
DSKCRDT SR 7,7 @SC90139 06164000
IC 7,0(,15) Get year in binary @SC90139 06164500
CLC 0(3,15),F0 @SC92181 06165000
BE DSKVDATZ Date field is null, skip it @SC92181 06165500
CVD 7,TMPDW @SC87296 06166000
MVO FDBDATE+1(2),TMPDW Copy year @SC87296 06166500
ICM 7,3,1(15) Get day-of-year in binary @GH89270 06167000
MVC DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31) @SC86299 06167500
TM 0(15),3 Check for leap year @GH89270 06168000
BNZ *+8 @SC87296 06168500
MVI DSKMNTH+9,29 Leap year, change Feb. @SC86299 06169000
LA 6,11 @SC86299 06169500
SR 0,0 @SC86299 06170000
DSKVMDL IC 0,DSKMNTH-1(6) @SC86299 06170500
SR 7,0 Test if passed the right month @SC86299 06171000
BNP DSKVMDM Got it @SC86299 06171500
BCT 6,DSKVMDL @SC86299 06172000
SR 0,0 Hit December @SC86299 06172500
DSKVMDM AR 7,0 Get day of month @SC86299 06173000
LCR 6,6 @SC86299 06173500
LA 6,12(6) Get month @SC86299 06174000
MH 6,=H'100' @SC86299 06174500
AR 6,7 Combine MMDD @SC86299 06175000
MH 6,=H'10' @SC86299 06175500
CVD 6,TMPDW @SC86299 06176000
MVC FDBDATE+2(2),TMPDW+5 @SC86299 06176500
MVI FDBDATE,X'19' Assume 20th Cent @SC86295 06177000
CLI FDBDATE+1,X'50' @SC86295 06177500
BH *+8 Ok @SC86295 06178000
MVI FDBDATE,X'20' Must be 21st @SC86295 06178500
DSKVDATZ DS 0H @SC92181 06179000
* = = = = = get file size in bytes in R6,R7 - - - 06179500
SR 6,6 Return 0 for now (i.e., unknown) @SC87015 06180000
SR 7,7 @SC87015 06180500
AL 7,=F'1023' Round up @SC87007 06181000
BNO *+8 No overflow @SC86239 06181500
LA 6,1(6) @SC86239 06182000
SRDA 6,10 @SC86239 06182500
ST 7,FDBSIZE @SC86299 06183000
MVC FDBBLKSI,DS1BLK @SC86299 06183500
MVC FDBDEVT,CAMDEVT Copy device type @SC88106 06184000
MVC FDBVOL,CAMVOLS+6 Copy volume name @GH88319 06184500
XC FDBFLGS,DS1RCF Copy carriage control flags @SC88246 06185000
NI FDBFLGS,255-FABRECCC And only those flags @SC88246 06185500
XC FDBFLGS,DS1RCF @SC88246 06186000
LH 1,DS1BLK Use BLKSIZE if 'U' @SC86299 06186500
MVI FDBRCF,C'U' @SC86299 06187000
TM DS1RCF,FABRECU @SC86299 06187500
BO DSKVLR @SC86299 06188000
LH 1,DS1LRC Use LRECL if 'F' @SC86299 06188500
MVI FDBRCF,C'F' @SC86299 06189000
TM DS1RCF,FABRECF @SC86299 06189500
BO DSKVLR @SC86299 06190000
MVI FDBRCF,C'V' @SC86299 06190500
DSKVLR STH 1,FDBLRC @SC86299 06191000
L 7,4(13) Get previous stack frame @SC88048 06191500
L 1,4(7) and the one before @SC88076 06192000
CLC =A(SERVER),16(1) Was the caller SERVER? @SC89215 06192500
BE *+12 Yes, ok @SC88076 06193000
CLC =A(USNTRF),16(1) No, was it USNTRF? @SC89215 06193500
BNER 14 No, don't bother checking TAKE's @SC88076 06194000
USING SERVERSV,7 Assume SERVER or USNTRF @SC88048 06194500
ICM 0,15,TAKLEV Any TAKE files open? @SC88048 06195000
BNPR 14 No, that's fine @SC88048 06195500
CH 0,=Y(TAKMAX) Be sure this is valid @SC88048 06196000
BNLR 14 Oops, give up @SC88048 06196500
DSKVACT LR 6,0 @SC88048 06197000
SLA 6,2 @SC88048 06197500
L 6,TAKTAB-4(6) Fetch a file ticket @SC88048 06198000
CLC FABDSN,FABDSN-FABD(6) Does the name match? @SC88048 06198500
BE DSKVACS Yes, this file is in use @SC88048 06199000
BCT 0,DSKVACT No, keep looking @SC88048 06199500
BR 14 No match, that's ok @SC88048 06200000
DSKVACS OI FDBFLGS,FDBACTV Yes, turn on flag @SC88048 06200500
DROP 7 @SC88048 06201000
BR 14 @SC86299 06201500
* 06202000
DSKPMSK DC 10XL16'10101010101' Mask for valid P bytes @SC90139 06202500
DC 96X'01' @SC90139 06203000
* 06203500
DSKOPEX DC 0F'0',X'05',AL3(DSKOPC) OPEN EXIT @SC86299 06204000
DC X'91',AL3(DSKABEND) DCB ABEND exit @TS86001 06204500
* 06205000
* Look for x37 abends @TS86001 06205500
DSKABEND MVI ERRNUM,ERRFUL Assume full @SC86355 06206000
XC EMSGL,EMSGL Clear extra message @SC87338 06206500
CLC =X'B370',0(1) B37 abend? @TS86001 06207000
BE DSKABX Yes @SC86355 06207500
CLC =X'D370',0(1) D37 abend? @TS86001 06208000
BE DSKABX Yes @SC86355 06208500
CLC =X'E370',0(1) E37 abend? @TS86001 06209000
BE DSKABX Yes @SC86355 06209500
* Look for 013 abend @TS86001 06210000
MVI ERRNUM,ERRDIE Assume I/O error @SC86355 06210500
CLC =X'0130',0(1) 013 abend? @TS86001 06211000
BNE DSKABX No, assume worst @SC86355 06211500
CLI 2(1),X'14' Mismatch DSORG? @TS86001 06212000
BNE *+12 No @SC86355 06212500
MVI ERRNUM,ERRFNE Yes, member invalid or missing @SC86355 06213000
B DSKABX @SC86355 06213500
CLI 2(1),X'18' Unknown member name? @TS86001 06214000
BNE DSKABX No, assume worst @SC86355 06214500
MVI ERRNUM,ERRFNF Yes, say "not found" @SC86355 06215000
DSKABX MVI 3(1),X'04' Ignore if possible @SC86355 06215500
BR 14 Return @TS86001 06216000
* 06216500
DSKOPC LR 3,1 @SC86299 06217000
LH 9,FABBLKSI @SC92022 06217500
LTR 9,9 @SC92022 06218000
BP *+8 @SC86299 06218500
LH 9,=H'6233' @SC92022 06219000
LR 6,9 @SC92022 06219500
TM FABRECFM,FABRECU @SC86299 06220000
BO DSKOPS @SC86299 06220500
LH 6,FABLRECL @SC86299 06221000
BNZ *+8 @SC86299 06221500
OI FABRECFM,FABRECV+FABRECBR @SC86299 06222000
LTR 6,6 @SC86299 06222500
BP DSKOPQ @SC86299 06223000
LA 6,80 @SC86299 06223500
BAL 2,DSKTV @SC88049 06224000
LA 6,4(6) Allow LRECL=84 for VB @SC88049 06224500
DSKOPQ TM FABRECFM,FABRECF @SC86299 06225000
BZ DSKOPV @SC86299 06225500
SR 8,8 @SC92022 06226000
DR 8,6 @SC92022 06226500
LTR 9,9 @SC92022 06227000
BP *+8 @SC88104 06227500
LA 9,1 BLKSIZE was less than LRECL! @SC92022 06228000
MR 8,6 @SC92022 06228500
B DSKOPS @SC86299 06229000
DSKOPV LA 4,4(6) @SC86299 06229500
CR 4,9 @SC92022 06230000
BNH DSKOPS @SC86299 06230500
LR 9,4 @SC92022 06231000
DSKOPS STH 6,FABLRECL @SC86299 06231500
STH 9,FABBLKSI @SC92022 06232000
BR 14 @SC86299 06232500
* 06233000
DROP 6 @SC87015 06233500
DROP 3 @SC90264 06234000
DROP 5 @SC92022 06234500
* 06235000
LOCALS , @SC86295 06235500
DYNPL DS A(0,0,0,0,DYNDSP,0,DYNRC) @SC88026 06236000
DS A(0) Ptr to message buffer @SC88119 06236500
DYNRC DS F @SC86299 06237000
DSKTKT DS A Ptr for testing member @SC88043 06237500
DSKOPLS DS F Ptr to new FAB @SC88049 06238000
DYNDSP DS X @SC86299 06238500
DSKMNTH DS XL11 Month length table @SC86299 06239000
DSKPSAV EQU DSKMNTH,8 Buffer for saved prefix @SC88043 06239500
DSKCOD DS X Saved DISKIO code @SC88308 06240000
EXIT 06240500