Columbia Kermit

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

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

Wrap

Assembly Source File | 2020-01-01 | 196.3 KB | 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