Columbia Kermit

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

/ Columbia Kermit / kermit.zip / ibm370 / ikxutl.asm < prev

Wrap

Assembly Source File | 2020-01-01 | 232KB | 2,860 lines

*COPY IKXUTL 05000000 CHECKVER IKXUTL,4.3 @SC90072 05000500 &STORDS DSECT @SC90264 05001000 DS (STKDWDS)D Allow room for stack @SC90264 05001500 DFHEIEND , @SC90264 05002000 TITLE 'CWDSET/DSPACE Routines - set/show working directory' 05002500 * Set new 'working directory' 05003000 * Entry: SCANPTR string has option 05003500 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged. 05004000 CWDSET ENTER @SC86164 05004500 NTOKN N=CWDRSET,H=CWDERR @SC86299 05005000 CLI 0(6),C'*' @SC90264 05005500 BE CWDRSET Any string beginning "*" is dflt @SC90264 05006000 LA 1,0(7,6) Point to last character @SC90264 05006500 CLI 0(1),C'''' Is it a quote? @SC90264 05007000 BE *+8 Yes, chop it off @SC90264 05007500 LA 7,1(,7) No, get true token length @SC90264 05008000 LR 5,7 @SC86299 05008500 ICM 7,8,BLANK @SC86299 05009000 LA 0,DEST @SC90264 05009500 LA 1,L'DEST Length of field @SC86299 05010000 CR 5,1 @SC90264 05010500 BNH *+6 @SC90264 05011000 LR 5,1 Claim no more than available @SC90264 05011500 STH 5,DESTL Set string length @SC90264 05012000 MVCL 0,6 Copy to filename buffer @SC86299 05012500 TR DEST,UPCASE And upcase it @SC87034 05013000 NXTFSET DESTL,CWD,E=CWDERR @SC90264 05013500 KCALL KFLCWD,DESTL @SC90264 05014000 B RTRN0 @SC86295 05014500 CWDRSET MVI DESTL+1,1 Set to default @SC90264 05015000 MVI DEST,C'*' @SC90264 05015500 KCALL KFLCWD,DESTL @SC90264 05016000 B RTRN0 @SC86295 05016500 CWDERR PTEXT '&CWDERRM' @SC92300 05017000 MVI DESTL+1,1 Set to default @SC90264 05017500 MVI DEST,C'*' @SC90264 05018000 KCALL KFLCWD,DESTL @SC90264 05018500 B SUBERR @SC86295 05019000 * 05019500 * DSPACE Routine - display available disk space @SC86164 05020000 * 05020500 * Show space available in 'working directory' or other area 05021000 * Entry: SCANPTR string has option (none => working directory) 05021500 * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged 05022000 DSPACE ENTER ALT @SC86164 05022500 CLI CURFUID,0 @SC90264 05023000 BNE DSP2 @SC90264 05023500 PTEXT '&NODIRDF' @SC90264 05024000 B SUBERR @SC86299 05024500 DSP2 L 4,LIMKFS Quota @SC90264 05025000 LA 15,CMD @SC90264 05025500 BAL 2,EDDEC Format number @SC90264 05026000 INITSTR '&BYTSALW' @SC92300 05026500 L 4,USRTOTL Amount used @SC90264 05027500 BAL 2,EDDEC Format number @SC90264 05028000 INITSTR '&BYTSUSD' @SC92300 05028500 MVC 0(LFUID,15),CURFUID @SC92300 05029000 LA 0,LFUID(,15) End of message @SC92300 05029500 BAL 2,STAPMSG @SC90264 05030000 B RTRN0 @SC86295 05030500 LOCALS , @SC86295 05031000 EXIT , @SC86295 05031500 TITLE 'FSPEC Routine - extract filespec from scan string' 05032000 * 05032500 * Entry: R1->name field, R0=flags selecting operation (see below) 05033000 * For parse operations, SCANPTR defines the input string. 05033500 * For getting foreign or display filespec, R7->output buffer 05034000 * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad. 05034500 * For R15=1 or 2 R3,R4 give message. ERRNUM may be leftover. 05035000 * 05035500 * Flags: Notes: 05036000 * Tasks: FFRCF FFSND FFGET FFNEW 05036500 * Parse RECV X set ROVR properly 05037000 * Parse SEND 1st X 05037500 * Parse SEND 2nd X X 05038000 * Parse GET 1st X 05038500 * Parse GET 2nd X X set ROVR properly 05039000 * Parse F-packet (FFHDR) X X X 05039500 * Parse for Generic(FFUTL) X X FFWLD: allow partial 05040000 * Parse TAKE 05040500 * 05041000 * Get unique name X R15: 0=>ok, 1=>bad 05041500 * Interactive name check X X R15: 0=>ok, 1=>bad 05042000 * Get foreign name (FFENC) X X R15->end of string 05042500 * Get display form (FFDSP) X X R15->end of string 05043000 * 05043500 FSPEC ENTER @SC86295 05044000 STC 0,FSPFLG @SC86295 05044500 LR 5,0 @SC88049 05045000 SRL 5,4 Convert flags to index @SC88049 05045500 LR 0,1 Copy ptr to filespec @SC86295 05046000 TM FSPFLG,FFNEW @SC86295 05046500 BO FSPWRN @SC86295 05047000 L 2,ADR Ptr to text string for analysis @SC90264 05047500 C 2,=A(KERMIT) Is it within Kermit? @SC90264 05048000 BL SCANFXZ No, we're safe @SC90264 05048500 C 2,=A(FOPSTR) (last CSECT in Kermit) @SC90264 05049000 BH SCANFXZ @SC90264 05049500 ICM 3,15,LEN Yes, but is it non-empty? @SC90264 05050000 BNP SCANFXZ No, don't need to copy @SC90264 05050500 BCTR 3,0 Yes, set up for MVC @SC90264 05051000 L 4,STRBUF Ptr to temporary area @SC90264 05051500 MVC 0(,4),0(2) @SC90264 05052000 EX 3,*-6 Move proper chunk @SC90264 05052500 ST 4,ADR Replace ptr to string @SC90264 05053000 SCANFXZ DS 0H @SC90264 05053500 LR 8,1 Save ptr to filespec @SC86299 05054000 USING FABFID,8 Map filespec @SC90264 05054500 XC FABFID,FABFID Clear filespec @SC90264 05055000 MVC FABFUID,DEST Init user id @SC90264 05055500 PTEXT '&BADFSPC' @SC90264 05056000 MVI ERRNUM,ERRFNE Assume bad file name @SC86158 05056500 IC 5,FSP0(5) Get dispatch adr @SC88049 05057000 B FSP0(5) Go to proper handler @SC88049 05057500 * TAKE GET 1st SEND 1st Generic @SC88049 05058000 FSP0 DC AL1(FSPCPY-FSP0,FSPSN2-FSP0,FSPASC-FSP0,FSPUTL-FSP0) SC88049 05058500 * RECEIVE GET 2nd SEND 2nd F-packet @SC88049 05059000 DC AL1(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0) @SC88049 05059500 FSPUTL TM FSPFLG,FFWLD Utility: default to all files? @SC88049 05060000 BZ FSPASC No @SC86295 05060500 LA 1,LFID @SC88043 05061000 LA 14,DEST Default to prefix @SC88043 05061500 * Convert to default filespec @SC90264 05062000 FSPASC TM FL2,SRV Server mode? @SC86295 05062500 BZ FSPCPY No, don't need to convert @SC86295 05063000 ICM 15,15,LEN Get length @SC86295 05063500 BZ FSPCPY @SC86295 05064000 BCTR 15,0 Correct for EX @SC86158 05064500 L 5,ADR Get string ptr @SC89215 05065000 EX 15,FSPTRAE Change to EBCDIC @SC89215 05065500 EX 15,FSPTRUP Upcase @SC89215 05066000 B FSPCPY @SC86295 05066500 FSPTRAE TR 0(,5),ATOED @SC89301 05067000 FSPTRUP TR 0(,5),UPCASE @SC89215 05067500 FSPRC NI FL1,255-ROVR Setup for RECEIVE @SC86295 05068000 NI FL4,255-NMOK-NMCHNG Collision not checked yet @SC90033 05068500 MVI FABFNAM,C'$' Allow missing filespec @SC90264 05069000 B FSPCPY @SC86295 05069500 FSPHD MVI FABFNAM,1 Use default if missing filespec @SC90264 05070000 B FSPCPY @SC86299 05070500 FSPSN2 CLI BRK,C',' @SC88306 05071000 BE RTRN0 No foreign name: multiple format @SC88306 05071500 NTOKN H=FSP2H,N=RTRN0 @SC88306 05072000 LA 7,1(,7) Get token length @SC89179 05072500 LA 1,L'JFNAM @SC86295 05073000 CR 7,1 Does it fit? @SC89179 05073500 BNH *+6 Yes @SC86224 05074000 LR 7,1 Use what we can @SC86224 05074500 LR 3,0 @SC86295 05075000 STC 7,0(3) Save length @SC86224 05075500 LA 0,1(3) @SC86295 05076000 MVCL 0,6 Get fn, at least @SC86224 05076500 B RTRN0 @SC86295 05077000 * 05077500 FSPCPY NTOKN H=FSPH,N=FSPZ @SC86299 05078000 FSPCP2 KCALL FOPSTR,LFID(,8),E=FSPINV @SC89218 05078500 * id.TD -> FABFTD, 4-byte ---, 4-byte destid, 4 blanks @SC90264 05079000 * id.TS -> FABFTS, 4-byte ---, 8-byte id @SC90264 05079500 * id.TSAUX -> FABFTS, 4-byte ---, 8-byte id @SC90264 05080000 * id.TSMAIN-> FABFTS+FABFMAIN, 4-byte ---, 8-byte id @SC90264 05080500 * id -> FABFTS, 4-byte ---, 8-byte id (but see below) @SC90264 05081000 * id.PGM -> FABFPGM, 4-byte parm, 8-byte pgm id @SC90264 05081500 * id.SPOOL -> FABFSPL, 4-byte class, 8-byte spool name @SC90264 05082000 * id.TAKE -> FABFTAK, 4-byte uid, 8-byte file id @SC90264 05082500 * id -> (same, if TAKE or GIVE command) @SC90264 05083000 * 'name.etc-> FABFSPL, 4-byte ', name ptr, 2-byte offset, len @SC90264 05083500 L 2,QFNPTR Last-used buffer @SC90264 05084000 MVC QFNPTR,QFNSIZ(2) Set up for next @SC90264 05084500 L 2,QFNPTR Get ptr @SC90264 05085000 MVC 0(QFNSIZ,2),DEST+1 Copy prefix to buffer, less '@SC90264 05085500 LH 14,DESTL Get length so far @SC90264 05086000 BCTR 14,0 @SC90264 05086500 CLI 0(6),C'''' Is name actually spelled out? @SC90264 05087000 BNE FSPQF1 No, keep prefix @SC90264 05087500 SR 14,14 Yes, start over @SC90264 05088000 LA 6,1(,6) and skip ' @SC90264 05088500 BCTR 7,0 @SC90264 05089000 MVI FABFUID,C'''' Qualified name @SC90264 05089500 FSPQF1 LA 1,0(7,6) Point to last character @SC90264 05090000 CLI 0(1),C'''' Does it end with a quote? @SC90264 05090500 BE *+8 Yes, chop it off @SC90264 05091000 LA 1,1(,1) No, keep last char @SC90264 05091500 LR 0,6 @SC90264 05092000 SR 1,0 Set up for MVCL @SC90264 05092500 ICM 1,8,BLANK @SC90264 05093000 STH 14,QFNSHB Save offset to start of short name@SC90264 05093500 AR 14,2 Ptr within buffer @SC90264 05094000 LA 15,QFNSIZ(,2) End of buffer @SC90264 05094500 SR 15,14 @SC90264 05095000 MVCL 14,0 Now, QFN is set, just in case @SC90264 05095500 EX 7,FSPTRUPD Convert to upper case @SC90264 05096000 CLI 0(6),C' ' Hope it didn't start with dot @SC90264 05096500 BE FSPINV Oops @SC90264 05097000 TM FSPFLG,FFRCF @SC86295 05097500 BZ *+8 @SC86295 05098000 OI FL1,ROVR Overwrite received fname @SC86295 05098500 MVI FABFLGS,FABFTS Default is tmp.stor. @SC90264 05099000 TM FSPFLG,X'70' TAKE file? @SC91150 05099500 BNZ *+8 No @SC91150 05100000 MVI FABFLGS,FABFTAK Yes, default is TAKE @SC90264 05100500 MVI TRTBL+C'/',1 Also look for slash @SC90264 05101000 FSPCPUID LA 1,1(7,6) Past end @SC90264 05101500 EX 7,FSPTRTB Find what was dot, if any @SC90264 05102000 MVI TRTBL+C'/',0 @SC90264 05102500 LR 5,1 Save ptr to first dot @SC90264 05103000 BZ FSPCP3 No dot, assume TS @SC90264 05103500 CLI 0(1),C'/' @SC90264 05104000 BNE FSPCPUIZ No slash either, go on @SC90264 05104500 SR 1,6 Get length of uid @SC90264 05105000 BNP FSPINV Empty uid, no good @SC90264 05105500 LR 0,6 Start of uid @SC90264 05106000 LA 1,1(,1) Length of uid plus '/' @SC90264 05106500 AR 6,1 Adjust ptrs to text @SC90264 05107000 SR 7,1 @SC90264 05107500 BNP FSPINV Nothing left, error @SC90264 05108000 BCTR 1,0 Get length of uid again @SC90264 05108500 LA 14,FABFUID @SC90264 05109000 LA 15,LFUID @SC90264 05109500 ICM 1,8,BLANK Set to blank-fill @SC90264 05110000 MVCL 14,0 Copy to FID @SC90264 05110500 CLM 1,7,F0 Uid all used up? @SC90264 05111000 BNE FSPINV No, was too long @SC90264 05111500 B FSPCPUID Now look for file name @SC90264 05112000 FSPCPUIZ LA 1,1(7,6) Past end @SC90264 05112500 AR 7,6 Ptr to last char @SC90264 05113000 SR 7,5 Anything after 1st dot? @SC90264 05113500 BNP FSPINV No, error @SC90264 05114000 BCTR 7,0 @SC90264 05114500 CLI FABFUID,C'''' Qualified name? @SC90264 05115000 BE FSPQFN Yes @SC90264 05115500 * EX 7,FSPTRTB5 Look for another dot @SC90264 05116000 SR 1,5 Get length of type + 1 @SC90264 05116500 S 1,F2 Length - 1 @SC90264 05117000 BM FSPINV Null, must have been .. @SC90264 05117500 LA 14,FSPTYPS Start of table @SC90264 05118000 SR 15,15 @SC90264 05118500 FSPCPTLP CLI 0(14),255 @SC90264 05119000 MVI FABFLGS,0 Just in case not found @SC90264 05119500 BE FSPINV Not found @SC90264 05120000 MVC FABFLGS,1(14) Copy flags @SC90264 05120500 IC 15,0(,14) Get length of possible type @SC90264 05121000 EX 1,FSPCPCLC See if a match @SC90264 05121500 LA 14,3(15,14) Space over this one, in case @SC90264 05122000 BNE FSPCPTLP No match, keep looking @SC90264 05122500 CR 1,15 Seems to match. Same length? @SC90264 05123000 BNE FSPCPTLP No match, keep looking @SC90264 05123500 FSPCP3 LA 15,1(7,6) Past end once more @SC90264 05124000 SR 5,6 Get length of token @SC90264 05124500 LR 7,5 @SC90264 05125000 ICM 7,8,BLANK @SC90264 05125500 LA 1,LFFNM @SC90264 05126000 LA 0,FABFNAM Start of name per se @SC90264 05126500 MVCL 0,6 Copy to destination name @SC90264 05127000 TM FABFLGS,FABFTAK @SC91150 05127500 BZ FSPCP4 Leave fileclass alone if not TAKE @SC91150 05128000 CLI FABFUID,C'*' Self? @SC91150 05128500 BNE FSPCP4 @SC91150 05129000 MVC FABFUID,KUSERID Yes, set to userid @SC91150 05129500 FSPCP4 DS 0H @SC91150 05130000 TM FABFLGS,FABFTS @SC91260 05130200 BO FSPCP5 @SC91260 05130400 TM FABFLGS,FABFTD @SC90264 05130500 BZ RTRN0 @SC90264 05131000 CLI FABFNAM+4,C' ' TD id must be only 4 bytes @SC90264 05131500 BNE FSPINV @SC90264 05132000 B RTRN0 @SC87034 05132500 FSPCP5 LA 1,FABFNAM+4 Last possible location of termid @SC91260 05132540 LA 2,5 Number of places to check @SC91260 05132580 FSPCP6 CLC =C'&KTRMS.',0(1) Look for termid signal @SC91260 05132620 BE FSPCP7 Found it @SC91260 05132660 BCTR 1,0 @SC91260 05132700 BCT 2,FSPCP6 Keep looking @SC91260 05132740 B RTRN0 Not there, name is all set @SC91260 05132780 FSPCP7 L 2,DFHEIBP @SC91260 05132820 MVC 0(4,1),EIBTRMID-DFHEIBLK(2) Replace with termid @SC91260 05132860 B RTRN0 @SC91260 05132900 * 05133000 FSPQFN MVI TRTBL+C'(',1 @SC90264 05133500 EX 7,FSPTRTB5 Find next dot or (, if any @SC90264 05134000 MVI TRTBL+C'(',0 @SC90264 05134500 SR 1,6 @SC90264 05135000 STH 1,QFNSHL @SC90264 05135500 MVC FABFNAM(8),QFNPTR Save ptrs to QFN in FAB @SC90264 05136000 MVI FABFLGS,FABFSPL Treat like a spool file, CL=' @SC90264 05136500 B RTRN0 @SC90264 05137000 * 05137500 FSPTRUPD TR 0(,6),FSPUPDOT Upcase and dot to blank @SC90264 05138000 FSPDSPMV MVC 1(,1),2(14) Copy type from table @SC90264 05138500 FSPCPCLC CLC 2(,14),1(5) Compare to type table @SC90264 05139000 FSPTRTB5 TRT 1(,5),TRTBL Look for 2nd blank @SC90264 05139500 FSPTRTB TRT 0(,6),TRTBL Look for blank @SC90264 05140000 * 05140500 * Table of file types: AL1(len-1,flags),C'type' @SC90264 05141000 FSPTYPS DC AL1(2-1,FABFTS),C'TS' @SC90264 05141500 DC AL1(5-1,FABFTS),C'TSAUX' @SC90264 05142000 DC AL1(6-1,FABFTS+FABFMAIN),C'TSMAIN' @SC90264 05142500 DC AL1(2-1,FABFTD),C'TD' @SC90264 05143000 DC AL1(3-1,FABFPGM),C'PGM' @SC90264 05143500 DC AL1(5-1,FABFSPL),C'SPOOL' @SC90264 05144000 DC AL1(4-1,FABFTAK),C'TAKE' @SC90264 05144500 DC AL1(255) @SC90264 05145000 * 05145500 FSPZ LA 6,1 Update counter @SC86299 05146000 A 6,EVCTR @SC86299 05146500 ST 6,EVCTR @SC86299 05147000 UNPK FSPFNAM(5),EVCTR(5) @SC90264 05147500 TR FSPFNAM(6),TRHEX Get unique DDNAME @SC90264 05148000 MVI FSPFNAM,C'K' @SC90264 05148500 MVC FSPFNAM+4(7),=C'&KTRMS..TS' Make unique @SC91260 05149500 LA 6,FSPFNAM Default name @SC90264 05150500 LA 7,11-1 @SC90264 05151000 CLI FABFNAM,1 @SC90264 05151500 BE FSPCP2 Get default DEST @SC90264 05152000 BH RTRN0 Don't insist @SC86299 05152500 PTEXT '&NOFSPEC' @SC90264 05153000 FSPINV LA 15,2 @SC86295 05153500 B FSPPTRS @SC86295 05154000 * 05154500 FSPH PTEXT '&FMTFSPC&FSPCPRM' @SC91224 05155000 CLI FSPFLG,FFSND SEND 1st? @SC89261 05155500 BE *+8 Yes, use whole message @SC89261 05156000 SH 4,=H'&FMTOPT' Chop off option part @SC91224 05156500 B FSP0H @SC86295 05157000 FSP2H PTEXT '&FORFSPC' @SC86295 05157500 FSP0H LA 15,1 @SC86295 05158000 FSPPTRS RETREG 3,4 @SC86295 05158500 FSPRET RET , @SC86295 05159000 * 05159500 * Non-parsing functions . . . 05160000 * 05160500 * Get unique filespec 05161000 FSPWRN LR 8,1 Save name ptr @SC90264 05161500 TM FSPFLG,FFENC @SC86295 05162000 BO FSPENC Encode name into buffer @SC86295 05162500 TM FSPFLG,FFDSP @SC86295 05163000 BO FSPDSP Copy name into buffer for display @SC86295 05163500 TM FL4,NMOK Already checked? @SC87012 05164000 BO RTRN0 Yes, ok @SC87012 05164500 MVC XFILE,FABFID Save original name @SC90033 05165000 MVC FSPFID,FABFID Save original name @SC87015 05165500 TM FABFLGS,FABFPGM Pipe? @SC90264 05166000 BO FSPNOKD Yes, name is already unique @SC90264 05166500 LA 6,FSPFNAM+6 End of id @SC90264 05167000 BCTR 6,0 @BS86001 05167500 CLI 0(6),C' ' Find end of token @BS86001 05168000 BE *-6 @BS86001 05168500 LA 5,10+1 Allowed retries @BS86001 05169000 LA 7,C'0' Extra character @BS86001 05169500 FSPTOPN OPENF T,FSPFID,E=FSPNOKA No collision @SC91150 05170000 CLI FSPFID+1,C'''' Quoted file name? @SC90264 05170500 BE FSPCOLL Yes, give up @SC90264 05171000 OI FL4,NMCHNG Remember collision occurred @SC90033 05171500 MVI 1(6),C'$' Yes, modify id @BS86001 05172000 TM FSPFID,FABFTAK TAKE file? @SC90264 05172500 BO *+8 Yes, keep it so @SC90264 05173000 MVI FSPFID,FABFTS No, alternate would always be TS @SC90264 05173500 STC 7,2(,6) Serialize @BS86001 05174000 LA 7,1(7) Bump counter @BS86001 05174500 BCT 5,FSPTOPN @SC87015 05175000 FSPCOLL PTEXT '&FILCLSN' @SC90264 05175200 B FSP0H Return ptrs and rc=1 @SC88049 05176000 FSPNOKA TM FSPFID,FABFTD TD? @SC91150 05176500 BZ FSPNOKD No, it's really ok @SC91150 05177000 CLI DSKSTT+FDBFL2-FABD,0 Did we find anything? @SC91150 05177500 BE FSPCOLL Nothing, can't write there @SC91150 05178000 FSPNOKD MVC FABFID,FSPFID Copy name back @SC87015 05178500 OI FL4,NMOK @SC87015 05179000 B RTRN0 @SC87015 05179500 * 05180000 * Encode name at (R8) into (R7) buffer (in ASCII), possibly with 05180500 * substitution from JFSPEC, but disable subsequent subst. 05181000 * Return updated ptr in R15 05181500 FSPENC CLI FABFLGS,0 Valid filespec? @SC90264 05182000 BNE FSPENC1 Yes, do it @SC90264 05182500 INITSTR '&NOFSPEC',0(7),REG=1 @SC92300 05183000 B FSPENTR And use it @SC90264 05184000 FSPENC1 LA 1,JFSPEC Complex string? @SC90264 05184500 BAL 14,PAKFOR @SC86224 05185000 BNZ FSPECPZ Yes, name overridden @SC86299 05185500 LR 1,7 Set ptr @SC90264 05186000 BAL 9,FSPDSPL Get id @SC90264 05186500 FSPENTR DS 0H Translate and adjust ptr @SC88070 05187000 TR 0(LFID+8,7),ETOAD @SC89301 05187500 LR 7,1 Advance ptr @SC86299 05188000 FSPECPZ MVI JFSPEC,0 Turn off string @SC86299 05188500 FSPENR LR 15,7 Save ptr @SC86295 05189000 B FSPRET @SC86295 05189500 * 05190000 * Copy name at (R8) into (R7) buffer in display form @SC90264 05190500 * Return updated ptr in R15 05191000 FSPDSP LR 1,7 Output ptr @SC90264 05191500 TM FABFLGS,FABFTAK TAKE file? @SC90264 05192000 BZ FSPDSP2 No, uid is ignored @SC90264 05192500 CLC FABFUID,CURFUID Yes. Is uid the usual? @SC91150 05193000 BE FSPDSP2 Yes, suppress it @SC90264 05193500 MVC 0(LFUID,1),FABFUID @SC90264 05194000 TRT 0(LFUID,1),TRTBL Check for trailing blanks @SC90264 05194500 BNZ *+8 @SC90264 05195000 LA 1,LFUID(,1) None, set ptr to max @SC90264 05195500 MVI 0(1),C'/' @SC90264 05196000 LA 1,1(,1) Skip over '/' @SC90264 05196500 FSPDSP2 BAL 9,FSPDSPL Encode id @SC90264 05197000 LR 15,1 End of string @SC90264 05197500 B FSPRET @SC86299 05198000 * Encode id from R8 into buffer at R1, return new ptr in R1 @SC90264 05198500 * Uses R2,R14,R15. Return via R9 @SC90264 05199000 FSPDSPL CLI FABFUID,C'''' Quoted file name? @SC90264 05199500 BNE FSPDSPL1 No, do normal decoding @SC90264 05200000 ICM 14,15,FABFNAM Yes, get ptr to buffer @SC90264 05200500 AH 14,FABFNAM+4 Get offset for display form @SC90264 05201000 S 14,F2 Back up to set up MVC @SC90264 05201500 MVI 0(1),C'''' Insert quote to flag it @SC90264 05202000 LH 15,FABFNAM+6 Get length of name @SC90264 05202500 BCTR 15,0 Correct for MVC @SC90264 05203000 EX 15,FSPDSPMV Move to the output @SC90264 05203500 LA 1,2(15,1) Point past the end @SC90264 05204000 BR 9 All done @SC90264 05204500 FSPDSPL1 MVC 0(LFFNM,1),FABFNAM Grab id @SC90264 05205000 TRT 0(LFFNM,1),TRTBL Check for trailing blanks @SC90264 05205500 BNZ *+8 @SC90264 05206000 LA 1,LFFNM(,1) @SC90264 05206500 MVI 0(1),C'.' Insert dot @SC90264 05207000 LA 14,FSPTYPS Start of table @SC90264 05207500 SR 15,15 @SC90264 05208000 FSPDSPLP CLI 0(14),255 @SC90264 05208500 BER 9 Not found, omit type (???) @SC90264 05209000 MVC FSPFID(1),1(14) Copy flags @SC90264 05209500 IC 15,0(,14) Get length of possible type @SC90264 05210000 EX 15,FSPDSPMV Copy type to string @SC90264 05210500 LA 14,3(15,14) Space over this one, in case @SC90264 05211000 NC FSPFID(1),FABFLGS See if same type @SC90264 05211500 BZ FSPDSPLP No match, keep looking @SC90264 05212000 LA 1,2(15,1) Point past the end @SC90264 05212500 BR 9 @SC90264 05213000 DROP 8 @SC90264 05213500 * 05214000 * Table to convert EBCDIC text to upper case + dot to blank @SC89215 05214500 FSPUPDOT DC (C'.')AL1(*-FSPUPDOT) @SC89215 05215000 DC C' ' @SC89215 05215500 DC (127-C'.')AL1(*-FSPUPDOT) @SC89215 05216000 HTBL 80,C1,C2,C3,C4,C5,C6,C7,C8,C9,8A,8B,8C,8D,8E,8F @SC89268 05216500 HTBL 90,D1,D2,D3,D4,D5,D6,D7,D8,D9,9A,9B,9C,9D,9E,9F @SC89268 05217000 HTBL A0,A1,E2,E3,E4,E5,E6,E7,E8,E9,AA,AB,AC,AD,AE,AF @SC89268 05217500 DC 080AL1(*-FSPUPDOT) @SC89215 05218000 LOCALS , @SC86295 05218500 FSPFID DS CL(LFID) @SC88342 05219000 FSPFNAM EQU FSPFID+1+LFUID File name per se @SC90264 05219500 FSPFLG DS X Filespec flags @SC86295 05220000 FSPEC EXIT @SC86295 05220500 TITLE 'KHELP routine - perform HELP command' 05221000 * Handle HELP command, rest of string given by SCANPTR. 05221500 * On entry, R6->help command string 05222000 KHELP ENTER , @SC86355 05222500 LR 8,6 Save ptr to command @SC88043 05223000 SR 5,5 Clear length of extra word @SC90264 05223500 NTOKN N=KHLI See if subcommand given @SC86355 05224000 L 1,=A(USNCMD) Command table @SC87117 05224500 KHSCAN SCAN (1),KHLF,NODISP @SC86355 05225000 WTEXT '&BADSBCM' Not found @SC86355 05225500 RET , @SC86355 05226000 KHLF CLM 7,8,F0 Just '?' @SC86355 05226500 BE RTRN Yes, done @SC86355 05227000 CLC =C'&AAAASET',KWNAME(1) @SC90264 05227500 BNE KHNORM Normal subcommands @SC90264 05228000 PTEXT 'SET',AREG=4,LREG=5 @SC90264 05228500 NTOKN N=KHSET Just SET -- no parameter @SC90264 05229000 L 1,=A(SETCMDKW) Keyword table @SC90264 05229500 B KHSCAN Go back and check parameter @SC90264 05230000 KHNORM DS 0H @SC90264 05230500 LA 6,KWNAME(,1) Ptr to name in table @SC90264 05231000 SR 7,7 @SC90264 05231500 IC 7,KWMIN(,1) Length - 1 of abbrev @SC90264 05232000 LA 7,1(,7) @SC90264 05232500 B KHLJ Create command string for typing @SC90264 05233000 KHSET SR 7,7 Plain SET with no parameter @SC90264 05233500 B KHLJ Do it @SC90264 05234000 KHLI PTEXT 'KERMITCM',AREG=6,LREG=7 @SC90264 05234500 KHLJ PTEXT '&TYPCMD ',AREG=0,LREG=1 @SC90264 05235000 LA 14,KHLPBF @SC90264 05235500 LR 15,1 @SC90264 05236000 MVCL 14,0 Copy 'type' to buffer @SC90264 05236500 MVC 0(LFUID,14),SYSUID Set up filespec @SC92150 05237000 LA 1,LFUID(,14) Tentative end of uid @SC92150 05237200 TRT 0(LFUID,14),TRTBL Find 1st blank, if any @SC92150 05237400 MVI 0(1),C'/' Insert separator @SC92150 05237600 LA 14,1(,1) @SC92150 05237800 LR 15,5 @SC90264 05238000 LA 5,8 Keep track of available space @SC90264 05238500 MVCL 14,4 Copy 'SET' to buffer, if needed @SC90264 05239000 LR 15,7 @SC90264 05239500 LR 7,5 Remaining space @SC90264 05240000 CR 15,7 Check for enough room @SC93264 05240100 BNH *+6 Ok, it fits @SC93264 05240200 LR 15,7 No, just use what fits @SC93264 05240300 MVCL 14,6 Copy 'subcmd' to buffer @SC90264 05240500 LA 15,4 Length of suffix desired @SC90264 05241000 CR 15,7 @SC90264 05241500 BNH *+6 @SC90264 05242000 LR 15,7 Can't fit it all @SC90264 05242500 LA 6,=CL4'HELP' Suffix @SC90264 05243000 MVCL 14,6 @SC90264 05243500 MVC 0(5,14),=C'.TAKE' Set file type @SC90264 05244000 LA 6,5(,14) End of string @SC90264 05244500 LA 0,KHLPBF Start of command @SC90264 05245000 SR 6,0 Total length @SC88043 05245500 NI FL4,255-UCMD @SC88043 05246000 KCALL SUPFNC,3 Do it @SC86355 05246500 RET , @SC86355 05247000 LOCALS , 05247500 KHLPBF DS CL4,C,CL(LFUID+1),CL8,CL5 Space for command @SC90264 05248000 KHELP EXIT , @SC87007 05248500 TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05249000 SUPFNC ENTER @SC86295 05249500 * On entry, R1 = operation code, R0 = possible ptr @SC86158 05250000 * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends) 05250500 * ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11) 05251000 * 1 -> Start typeout interception. N.B. &MAXLR >> 2048 for this 05251500 * 2 -> Clean up afterwards and stop interception 05252000 * 3 -> Execute host command with or without interception 05252500 * If UCMD set, SCANPTR gives text, else R0->text,R6=len 05253000 * 4 -> (not used) 05253500 * 5 -> Stop interception if going 05254000 * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null) 05254500 * 7 -> Test for stacked lines, return number in R15 05255000 * 8 -> Log off (must return to TMP) 05255500 * 9 -> Wait specified time 05256000 * 10-> Return clock time in R15 (centisec) 05256500 * 11-> Setup up new prompt string at (R0) 05257000 AR 1,1 @SC89268 05257500 LH 1,SFC0-2(1) Get dispatch address @SC89268 05258000 B SFC0(1) @SC89268 05258500 SFC0 DC Y(ICPBEG-SFC0,ICPFIN-SFC0,SFCHST-SFC0) 1-3 @SC89268 05259000 DC Y(SFCILL-SFC0,ICPRST-SFC0,SFCLIN-SFC0) 4-6 @SC89268 05259500 DC Y(SFCSTK-SFC0,SFCKIL-SFC0,SFCWT-SFC0) 7-9 @SC89268 05260000 DC Y(SFCCLK-SFC0,SFCPRP-SFC0) 10-11 @SC89268 05260500 * 05261000 * Start interception, initialize ptrs @SC86158 05261500 ICPBEG MVI ERRNUM,ERRNOE OK @SC89268 05262000 L 1,WBUF Output buffer @SC90264 05262500 LA 0,2048(,1) Skip over some, to be safe @SC90264 05263000 SH 1,=Y(MAXDOF) @SC90264 05263500 A 1,F64KP End of buffer @SC90264 05264000 LR 15,0 @SC86158 05264500 STM 15,1,TXTPTR Save @SC86158 05265000 SR 1,0 Get length @SC86158 05265500 L 15,=X'15000000' @SC86158 05266000 MVCL 0,14 Fill with NL (X'15') @SC86158 05266500 MVI ICPFL,2 Now intercepting typeout @SC88026 05267000 B RTRN0 @SC86295 05267500 * Clean up after interception @SC86295 05268000 ICPFIN DS 0H @SC89268 05268500 * Restore normal typeout 05269000 ICPRST MVI ICPFL,0 Tear down @SC88026 05269500 B RTRN0 05270000 * Execute host command at (R0) with length (R6), unless UCMD set, 05270500 * in which case string given by SCANPTR 05271000 SFCHST TM FL4,UCMD User command? @SC86295 05271500 BO SFCHS0 Yes, scan already set up @SC86355 05272000 ST 0,ADR Set scan string ptrs @SC86355 05272500 ST 6,LEN @SC86355 05273000 SFCHS0 LM 0,1,SCANPTR Get length and adr @SC87034 05273500 LTR 6,0 Copy length @SC87034 05274000 BNP SFCILL No good @SC87034 05274500 BCTR 6,0 @SC87034 05275000 EX 6,TRUPCAS @SC87034 05275500 NTOKN N=SFCHBAD @SC88308 05276000 SCAN HSTCMDS,RTRN0 Dispatch to handler @SC88308 05276500 * Not one of the canned commands, try as CICS @SC90264 05277000 MVI ERRNUM,ERRSYS Say illegal command if failure @SC90264 05277500 LA 7,1(,7) Token length @SC90264 05278000 LA 1,L'SFCPGM Length of field @SC90264 05278500 CR 7,1 Is it longer than max? @SC90264 05279000 BH RTRNM1 Yes, forbid it @SC90264 05279500 ICM 7,8,BLANK Prepare for MVCL with padding @SC90264 05280000 LA 0,SFCPGM @SC90264 05280500 MVCL 0,6 Copy to program name buffer @SC90264 05281000 ICM 15,15,=A(KHOST) @SC90264 05281500 BZ SFCHSX @SC90264 05282000 LA 0,SFCPGM @SC90264 05282500 L 1,ADR String address @SC90264 05283000 LA 2,LEN Ptr to length @SC90264 05283500 STM 0,2,SFCSECPL Set up calling sequence @SC90264 05284000 KCALL (15),SFCSECPL,EXT,E=RTRNM1 @SC90264 05284500 SFCHSX DS 0H @SC90264 05285000 L 2,ADR Ptr to remaining string @SC90264 05285500 EXEC CICS LINK PROGRAM(SFCPGM) COMMAREA(0(,2)), @SC90264+05286000 LENGTH(LEN+2) NOHANDLE, @SC91150 05286500 L 15,DFHEIBP Set up to copy EIB code @SC91150 05287000 CLC F0,EIBRCODE-DFHEIBLK(15) Ok? @SC91150 05287500 BNE RTRNM1 No, say illegal @SC91150 05288000 TM FSCTRMF,X'80' TTY? @SC91150 05288500 BZ SFCHSRC Yes, skip reformatting @SC91150 05289000 TM FL4,UCMD User cmd? @SC91150 05289500 BZ SFCHSRC No, skip reformatting @SC91150 05290000 EXEC CICS SEND FROM(ICPSETCC) LENGTH(=Y(ICPSETL)), @SC91150+05290500 CTLCHAR(=X'C3') WAIT, Reformat but don't clear @SC91150 05291000 SFCHSRC DS 0H @SC91150 05291500 SR 15,15 Clear RC for now @SC90264 05292000 CLC =C'R(',0(2) Is it a return code? @SC91150 05292500 BNE SFCUTZ No, just use 0 @SC91150 05293000 CLI 6(2),C')' Must be four bytes @SC91150 05293500 BNE SFCUTZ No, just use 0 @SC91150 05294000 CLC 2(1,2),3(2) Is it small number? @SC91150 05294500 BNE SFCUTZ No, just use 0 @SC91150 05295000 ICM 15,15,2(2) Ok use that code @SC91150 05295500 B SFCUTZ Display return code and return @SC90264 05296000 * 05296500 SFCHBAD MVI ERRNUM,ERRSYS Illegal system command @SC90223 05297000 HELP HSTCMDS,RTRNM1 @SC90223 05297500 * 05298000 HSTCMDS KW 'DIRECTORY',SFCDIR,MIN=3 @SC88308 05298500 KW 'COPY',SFCCOP,MIN=4 @SC88308 05299000 KW 'DELETE',SFCDEL,MIN=3 @SC88308 05299500 KW 'RENAME',SFCREN,MIN=3 @SC88308 05300000 KW '&TYPCMD',SFCTYP @SC88308 05300500 * ought to implement some on-line help @SC90264 05301000 KW '&ANYCICS',0,MIN=99 @SC90264 05301500 KW , @SC88308 05302000 * 05302500 SFCDIR LA 3,13 DISKIO dir function code @SC88308 05303000 B SFCUTL @SC88308 05303500 SFCDEL LA 3,14 DISKIO del function code @SC88308 05304000 B SFCUTL @SC88308 05304500 SFCREN LA 3,15 DISKIO ren function code @SC88308 05305000 B SFCUTL @SC88308 05305500 SFCCOP LA 3,16 DISKIO cop function code @SC88308 05306000 B SFCUTL @SC88308 05306500 SFCTYP LA 3,17 DISKIO typ function code @SC88308 05307000 * B SFCUTL @SC88308 05307500 SFCUTL SR 0,0 @SC88308 05308000 KCALL FSPEC,FILNAM,E=SUBERR @SC88308 05308500 CH 3,SFCDEL+2 @SC88308 05309000 BNH SFCUT1 Dir or del @SC88308 05309500 CH 3,SFCTYP+2 @SC88308 05310000 BE SFCUT1 Type @SC88308 05310500 SR 0,0 @SC88308 05311000 KCALL FSPEC,IFILE,E=SUBERR Get 2nd file name @SC88308 05311500 SFCUT1 FTOKN N=SFCUT6 See if anything else in command @SC88308 05312000 PTEXT '&NOOPERS' @SC88308 05312500 B SUBERR @SC88308 05313000 SFCUT6 LR 0,3 Get function code @SC88308 05313500 LA 2,IFILE Optional 2nd name @SC88308 05314000 KCALL DISKIO,FILNAM Do it @SC88308 05314500 SFCUTZ DS 0H @SC90264 05315000 LTR 4,15 @SC86295 05315500 * Issue return code msg if needed @SC86295 05316000 BZ SFCZRC RC=0 @SC86158 05316500 TM FL4,UCMD User cmd? @SC86316 05317000 BZ RTRN No. No message, just rc in R15 @SC90264 05317500 MVC CMD(2),=C'R(' Set up message @SC86209 05318000 LA 15,CMD+2 @SC86209 05318500 BAL 2,EDDEC Edit RC into msg @SC86295 05319000 MVI 0(15),C')' Format is R(rc) @SC86209 05319500 LA 0,1(15) @SC86268 05320000 LA 1,CMD Start of edited string @SC86209 05320500 SR 0,1 Length @SC86268 05321000 WTEXT (1),(0) @SC86268 05321500 SFCZRC LR 15,4 @SC86295 05322000 MVI ERRNUM,ERRNOE No errors @SC86295 05322500 B RTRN @SC86295 05323000 * Unused, system-specific command type 05323500 SFCILL MVI ERRNUM,ERRSYS Illegal system command @SC86295 05324000 B RTRNM1 @SC86295 05324500 * 05325000 * Retrieve original command line arguments, if any @SC86295 05325500 * Return code =0 if yes, =1 if no @SC86295 05326000 * Leave string in CBUF buffer (up to 512), length in CLEN @SC86295 05326500 SFCLIN DS 0H @SC89268 05327000 LH 15,LINLEN Length of data @SC90264 05327500 LTR 15,15 Anything there? @SC86299 05328000 BNP RTRN1 Nothing there @SC86299 05328500 L 14,GTLBUFP Start of data @SC90264 05329000 AR 15,14 End of data @SC90264 05329500 CLI 0(14),SBA Check for fullscreen buffer adr @SC90264 05330000 BNE *+8 @SC90264 05330500 LA 14,3(,14) Yes, skip over it @SC90264 05331000 SFCLNL1 LA 14,1(,14) Look for blank after tran id @SC90264 05331500 CLI 0(14),C' ' @SC90264 05332000 BE SFCLNL2 Found it @SC90264 05332500 CR 14,15 Anything left? @SC90264 05333000 BL SFCLNL1 Yes, keep looking @SC90264 05333500 SFCLNL2 DS 0H @SC90264 05334000 LA 14,1(,14) Skip over leading blanks, too @SC90264 05334500 CLI 0(14),C' ' Leading blanks? @SC90264 05335000 BE *-8 @SC90264 05335500 SR 15,14 Anything left? @SC90264 05336000 BNP RTRN1 Nothing there @SC86299 05336500 STM 14,15,GTPBPTRS Save ptrs for GETLIN @SC91121 05337000 B RTRN0 @SC86295 05337500 * 05338000 * Test for stacked commands @SC86295 05338500 * return code = number of stacked lines @SC86295 05339000 SFCSTK DS 0H Go to RTRN1 if something stacked @SC90264 05339500 ICM 1,15,GTPBPTRS+4 Length stacked for GETLIN @SC91121 05340000 BP RTRN1 Something there, say at least 1 @SC91121 05340500 B RTRN0 Nothing stacked @SC88095 05341000 * 05341500 * Log out @SC86295 05342000 SFCKIL LR 3,13 @SC88026 05342500 L 3,4(,3) Look back through save areas @SC88026 05343000 CLC =A(USNTRF),16(3) Find main loop @SC89215 05343500 BNE *-10 @SC88026 05344000 L 3,8(,3) Ptr to main save area @SC88026 05344500 OI KFLG-USNTRFSV(3),CMDC Set flag to quit @SC88026 05345000 L DFHEIBR,DFHEIBP @SC91260 05345500 USING DFHEIBLK,DFHEIBR @SC91260 05345600 EXEC CICS START TRANSID('CSSF') TERMID(EIBTRMID), @SC91260 05345700 DROP DFHEIBR @SC91260 05345800 B RTRN0 Can't do any better @SC90264 05346000 * 05346500 * Wait specified time in R0 (sec) 05347000 SFCWT CVD 0,TMPDW Convert to decimal @SC90264 05347500 EXEC CICS DELAY INTERVAL(TMPDW+4), @SC90264 05348000 B RTRN0 @SC90264 05348500 * 05348510 * Set up prompt string @SC89334 05348520 SFCPRP ICM 4,1,S1HND See if handshake is defined @SC89334 05348530 BZ RTRN0 No, skip it @SC89334 05348540 LR 1,0 Ptr to prompt string @SC89334 05348550 BCTR 1,0 Ptr to prompt string length @SC89334 05348560 SR 2,2 @SC89334 05348570 ICM 2,1,0(1) Get length @SC89334 05348580 BZ RTRN0 No prompt, leave it to system @SC89334 05348590 LA 3,0(2,1) Point to last character @SC89334 05348600 CLM 4,1,0(3) Is it the handshake? @SC89334 05348610 BE RTRN0 Yes, assume all is well @SC89334 05348620 STC 4,1(,3) No, tack one onto string @SC89334 05348630 LA 2,1(,2) And update length @SC89334 05348640 STC 2,0(,1) @SC89334 05348650 B RTRN0 @SC89334 05348660 * 05349000 * Return time in centisec in R15 05349500 SFCCLK STCK TMPDW Store TOD clock @SC89268 05350000 LM 14,15,TMPDW @SC86295 05350500 SLDL 14,8 Take mod 204 days @SC86295 05351000 SRDL 14,20 Get in microsec @SC86295 05351500 D 14,=F'10000' Get in centisec @SC86295 05352000 B RTRN @SC86295 05352500 * 05353000 TITLE 'Typeout interceptor' 05353500 * Entry: R1->message buffer, R0=length, R2-> ICPTYP, R15->ret, 05354000 * R14-R5 saved in ICPRGS. 05354500 * Exit: Message copied to storage. Registers restored. 05355000 USING ICPTYP,2 @SC89268 05355500 ICPTYP CLI ICPFL,2 Intercepting? @SC88026 05356000 BE ICPGO Yes, do it @SC88026 05356500 A 0,F3 Allow for SBA @SC90264 05357000 STH 0,GTMLEN Length of buffer needed @SC90264 05357500 EXEC CICS HANDLE CONDITION NOSTG, @SC90264 05358000 EXEC CICS GETMAIN SET(3) LENGTH(GTMLEN), @SC90264 05358500 EXEC CICS IGNORE CONDITION LENGERR, @SC90264 05359000 LH 0,GTMLEN Get length again @SC90264 05359500 LR 4,0 @SC90264 05360000 S 4,F3 Allow for SBA @NL90264 05360500 BCTR 4,0 @SC90264 05361000 L 1,ICPRGS+12 Retrieve ptr to data @SC90264 05361500 MVC 3(,3),0(1) Copy after SBA/CRLF @SC90264 05362000 EX 4,*-6 @SC90264 05362500 TM FSCTRMF,X'80' TTY? @SC90264 05363000 BZ ICPTT1 Yes @SC90264 05363500 EX 4,ICPTRDSP Eliminate dangerous characters @SC90264 05364000 TM FSCOTP,X'FF' Flag for clearing screen? @SC90264 05364500 BO ICPTF1 Yes, reformat it @SC90264 05365000 S 0,F3 Adjust for SBA @SC90264 05365500 AH 0,FSCOTP Current screen adr @SC90264 05366000 CH 0,FSCEND Will it all fit? @SC90264 05366500 BNH ICPTF2 Yes, do it @SC90264 05367000 EXEC CICS CONVERSE FROM(ICPMORCC) FROMLENGTH(=Y(ICPMORL)), +05367500 CTLCHAR(=X'C3') SET(4) TOLENGTH(FSCOTP), @SC90264 05368000 ICPTF1 MVC FSCOTP,FSCBEG @SC90264 05368500 EXEC CICS SEND FROM(ICPSETCC) LENGTH(=Y(ICPSETL)), @SC90264+05369000 CTLCHAR(=X'C3') ERASE WAIT, @SC90264 05369500 ICPTF2 LH 0,FSCOTP Current screen address @SC90264 05370000 SRDL 0,6 @SC90264 05370500 SLL 0,2 @SC90264 05371000 SLDL 0,6 Convert to 12/14-bit format @SC90264 05371500 STCM 0,3,1(3) @SC90264 05372000 TR 1(2,3),PRTBLE @SC90264 05372500 MVI 0(3),SBA Move to proper adr @SC90264 05373000 LA 1,79 Round up to whole line @SC90264 05373500 A 1,ICPRGS+8 @SC90264 05374000 SR 0,0 @SC90264 05374500 D 0,=F'80' @SC90264 05375000 M 0,=F'80' Convert to address increment @SC90264 05375500 CLC FSCOTP,FSCBEG @SC90264 05376000 BE *+8 @SC90264 05376500 AH 1,FSCOTP Rel. to old adr if not at top @SC90264 05377000 STH 1,FSCOTP @SC90264 05377500 EXEC CICS SEND FROM(0(,3)) LENGTH(GTMLEN) WAIT, @SC90264+05378000 CTLCHAR(=X'C2'), @SC90264 05378500 B ICPTZ Rejoin @SC90264 05379000 ICPTT1 DS 0H TTY output @SC90264 05379500 MVC 0(3,3),=AL1(CR,LF,XOFF) @SC90264 05380000 EXEC CICS SEND FROM(0(,3)) LENGTH(GTMLEN) WAIT, @SC90264 05380500 ICPTZ DS 0H @SC90264 05381000 EXEC CICS FREEMAIN DATA(0(,3)), @NL90264 05381500 B ICPTRET @SC87020 05382000 ICPGO LM 3,4,TXTPTR+4 Output ptrs @SC86158 05382500 SR 4,3 Length left @SC86158 05383000 TM FSCTRMF,1 Just a prompt? @SC90264 05383500 BO ICPTRET Yes, ignore it @SC90264 05384000 LA 15,255 Limit @SC86158 05384500 CLR 15,0 Buffer length @SC87020 05385000 BNH *+6 Too big @SC86158 05385500 LR 15,0 Ok, use it @SC87020 05386000 LTR 15,15 @SC86158 05386500 BNP ICPTRET @SC86283 05387000 CR 15,4 Enough room? @SC86283 05387500 BH ICPTRET No @SC86283 05388000 BCTR 15,0 Set up for mvc @SC86158 05388500 EX 15,ICPCOPY Move to WBUF @SC86158 05389000 LA 3,2(15,3) New end @SC86158 05389500 ST 3,TXTPTR+4 @SC86158 05390000 ICPTRET LM 14,5,ICPRGS Restore @SC88026 05390500 NI FSCTRMF,X'FE' Reset flag @SC90264 05391000 BR 15 Return @SC86283 05391500 ICPCOPY MVC 0(,3),0(1) @SC87020 05392000 ICPTRDSP TR 3(,3),ICPDSP Convert to safe displayables @SC90264 05392500 DROP 2 05393000 * Table of printable equivalents for binary 6-bit numbers @SC90264 05393500 PRTBLE DC C' ',9AL1(*-PRTBLE+192),7AL1(*-PRTBLE+64) @SC90264 05394000 DC 9AL1(*-PRTBLE+192),8AL1(*-PRTBLE+64) @SC90264 05394500 DC 8AL1(*-PRTBLE+192),6AL1(*-PRTBLE+64) @SC90264 05395000 DC 10AL1(*-PRTBLE+192),6AL1(*-PRTBLE+64) @SC90264 05395500 * Safely displayables @SC90264 05396000 ICPDSP DC 64C'.',192AL1(*-ICPDSP) @SC90264 05396500 * 05397000 ICPMORCC DC AL1(SBA),X'5DE9',C'*MORE*' @SC90264 05397500 ICPMORL EQU *-ICPMORCC @SC90264 05398000 ICPSETCC DC AL1(SBA),X'5B60',AL1(IC,RTA),X'5DE800' @SC90264 05398500 ICPERSL EQU *-ICPSETCC Blank cmd line @SC90264 05399000 DC AL1(SBA),X'4040',AL1(SF),X'60' @SC90264 05399500 DC AL1(SBA),X'5B5F',AL1(SF),X'40' @SC90264 05400000 DC AL1(SBA),X'5DE8',AL1(SF),X'60',C'TTYsym' @SC90264 05400500 ICPSETL EQU *-ICPSETCC @SC90264 05401000 * 05401500 LOCALS , @SC86295 05402000 SFCPGM DS CL8 Name of program to execute @SC90264 05402500 SFCSECPL DS 3A -> (name, string, ->length) @SC90264 05403000 SUPFNC EXIT @SC86158 05403500 TITLE 'GETLIN Routine - Get a line from terminal' @SC87015 05404000 * Entry: R1->buffer of length 256 @SC87015 05404500 * Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1. @SC87015 05405000 GETLIN ENTER @SC87015 05405500 LR 8,1 Save buffer ptr @SC88095 05406000 LA 9,256 For copying @SC88095 05406500 LM 6,7,GTPBPTRS Buffer adr and len @SC88095 05407000 LTR 7,7 Already got something? @SC90264 05407500 BP GTL1 Yes, return it @SC87015 05408000 GTLRD LM 0,1,GTLPRPS Any prompt? @SC90264 05408500 LTR 0,0 @SC90264 05409000 BP GTLPRMPT @SC90264 05409500 PTEXT ' ',AREG=1,LREG=0 @SC90264 05410000 GTLPRMPT OI FSCTRMF,1 Responsive @SC90264 05410500 BAL 15,WTEXT @SC90264 05411000 EXEC CICS RECEIVE SET(6) LENGTH(GTMLEN) ASIS, @SC90264 05411500 L 0,GTLBUFP @SC90264 05412000 LA 1,256 Length of my buffer @SC90264 05412500 LH 7,GTMLEN Length of data @SC90264 05413000 CR 1,7 @SC90264 05413500 BNH *+6 @SC90264 05414000 LR 1,7 @SC90264 05414500 STM 0,1,GTPBPTRS Buffer adr and len @SC90264 05415000 MVCL 0,6 Copy input stuff to buffer @SC90264 05415500 LM 6,7,GTPBPTRS Get adr and len again @SC90264 05416000 L DFHEIBR,DFHEIBP Get ptr to data block @SC90264 05416500 USING DFHEIBLK,DFHEIBR @SC90264 05417000 TM FSCTRMF,X'80' TTY? @SC90264 05417500 BZ GTLRDT Yes, skip fullscreen stuff @SC90264 05418000 CLI EIBAID,X'6D' CLEAR? @SC90264 05418500 BNE GTLRDF2 No, use it @SC90264 05419000 MVI FSCOTP,X'FF' Flag for reformatting @SC90264 05419500 B GTLRD @SC90264 05420000 DROP DFHEIBR @SC90264 05420500 GTLRDF2 A 6,F3 Space over SBA @SC90264 05421000 S 7,F3 @SC90264 05421500 LR 1,6 Copy command address @SC90264 05422000 LTR 0,7 Anything there? @SC90264 05422500 BNM GTLRDF3 Yes, ok @SC90264 05423000 PTEXT ' ',AREG=1,LREG=0 No, display blanks @SC90264 05423500 GTLRDF3 OI FSCTRMF,1 Indicate just copying @SC90264 05424000 BAL 15,WTEXT @SC90264 05424500 L 2,=A(ICPSETCC) Ptr to command string @SC90264 05425000 EXEC CICS SEND FROM(0(,2)) LENGTH(=Y(ICPERSL)) WAIT, @SC90264+05425500 CTLCHAR(=X'C3'), @SC90264 05426000 GTLRDT DS 0H @SC90264 05426500 GTL1 LTR 2,7 Length of text remaining @SC88095 05427000 BNP GTLFRE None, return length 0 @SC88095 05427500 LA 0,0(7,6) End of buffer @SC88095 05428000 SR 4,4 @SC88095 05428500 IC 4,LNDLM Get delimiter @SC88095 05429000 LA 4,TRTBL(4) Ptr to delimiter char @SC88095 05429500 MVI 0(4),1 Set up to snag delims @SC88095 05430000 MVI TRTBL+C' ',0 And ignore blanks @SC88095 05430500 CR 2,9 Get shorter of 256 and string @SC88095 05431000 BNH *+6 @SC88095 05431500 LR 2,9 @SC88095 05432000 LA 1,0(2,6) End, in case no delim found @SC88095 05432500 BCTR 2,0 Set up for EX @SC88095 05433000 EX 2,GTLTRT @SC88095 05433500 MVI 0(4),0 Now clear out table @SC88095 05434000 MVI TRTBL+C' ',1 And restore @SC88095 05434500 SR 1,6 Length of line @SC88095 05435000 LR 7,1 Set up MVCL @SC88095 05435500 CR 9,7 Get shorter of 256 and string @SC88095 05436000 BNH *+6 @SC88095 05436500 LR 9,7 @SC88095 05437000 LR 2,9 Length actually copied @SC88095 05437500 MVCL 8,6 @SC88095 05438000 AR 6,7 In case we couldn't use it all @SC88095 05438500 LA 6,1(,6) Skip over linend char @SC88095 05439000 LR 7,0 @SC88095 05439500 SR 7,6 New buffer length @SC88095 05440000 GTLFRE DS 0H @SC90264 05440500 STM 6,7,GTPBPTRS @SC88095 05441000 GTLZ RETREG (0,2) Return (2) as R0 @SC89218 05441500 B RTRN0 @SC87015 05442000 GTLTRT TRT 0(,6),TRTBL Find a delimiter @SC88095 05442500 LOCALS , @SC87015 05443000 GETLIN EXIT , @SC87015 05443500 TITLE 'TERMIO Routine - Handle terminal I/O' 05444000 * R1 points to a pair of (adr,len) for read or write. If I/O is 05444500 * successfull, R15 returns transferred byte count (else returns -1). 05445000 * Command code is in R0: 05445500 * 1 => Open line for I/O 4 => Write packet 05446000 * 2 => Close line 5 => Read packet 05446500 * 3 => Reset line status after ( 6 => Write message ) not used 05447000 * environment changes 05447500 * 05448000 TERMIO ENTER 05448500 SR 15,15 OK @SC86295 05449000 BCT 0,TRMCLS @SC86295 05449500 * Open terminal line for protocol 05450000 * Ignore attention interrupts @SC90264 05450500 MVI RIOC,X'80' Nothing saved @SC86295 05451000 MVI TRMFLG,X'FF' Initialize w/r flag @SC87275 05451500 CLI TRMTP,C'F' Non-transparent full-screen? @SC92030 05451560 BNE RTRN0 No, all set @SC92030 05451620 LA 1,TRMFULA1 Set up introducer: adr @SC92030 05451680 LA 2,TRMFULL1 Length @SC92030 05451740 STM 1,2,WRCMD @SC92030 05451800 EXEC CICS SEND FROM(TRMFULA1) WAIT ERASE, @SC92030+05451860 CTLCHAR(=X'C2') LENGTH(=Y(TRMFULL1+TRMFULL2)), @SC92030 05451920 B RTRN0 @SC86295 05452000 * Close terminal line after protocol transfer 05452500 TRMCLS BCT 0,TRMRSET @SC86295 05453000 * @SC90264 05453500 CLI TRMTP,C'F' Non-transparent full-screen? @SC92030 05453600 BNE RTRN0 No, all set @SC92030 05453700 SR 0,0 @SC92030 05453800 KCALL SCRNIO One final CLEAR @SC92030 05453900 B RTRN0 @SC86295 05454000 * (Re)set terminal characteristics to suit environment 05454500 TRMRSET BCT 0,TRMRW @SC86295 05455000 B RTRN0 @SC86295 05455500 * 05456000 * Perform I/O request 05456500 TRMRW LR 8,1 Save ptr to plist @SC90264 05457000 LM 2,3,0(8) Get address and length @SC90264 05457500 BCT 0,TRMRD @SC87015 05458000 CLI WRRD,0 Write/read? @SC87275 05458500 BNE *+8 Yes @SC87275 05459000 MVI TRMFLG,0 Indicate no action on follow-up @SC87275 05459500 CLI TRMTP,C'F' Full-screen non-transparent? @SC92030 05459530 BNE TRMRWW No @SC92030 05459560 LA 1,TRMFULA2 Stuff to append to stream @SC92030 05459590 XI FL3,FCLRF Flip switch for skipping @SC92030 05459620 TM FL3,FCLRF Skipping now? @SC92030 05459650 BO TRMWAP Yes, finish stream @SC92030 05459680 LA 1,TRMFULB2 Stuff to append if not clearing @SC92030 05459710 MVC 0(TRMFULL1,2),TRMFULB1 Replace introducer @SC92030 05459740 TRMWAP LA 4,0(3,2) End of data @SC92030 05459770 MVC 0(TRMFULL2,4),0(1) Append extra commands @SC92030 05459800 AH 3,=Y(TRMFULL2) Add length of extra @SC92030 05459830 STH 3,GTMLEN Set up length @SC92030 05459860 EXEC CICS SEND FROM(0(,2)) LENGTH(GTMLEN) WAIT ERASE, @SC92030+05459890 CTLCHAR(=X'C2'), @SC92030 05459920 B TRMWLG @SC92180 05459950 TRMRWW DS 0H @SC92030 05459980 STH 3,GTMLEN Set up length @SC90264 05460000 EXEC CICS SEND FROM(0(,2)) LENGTH(GTMLEN) WAIT, @SC90264 05460500 TRMWLG SR 6,6 Set return code to 0 @SC92180 05461000 LA 0,C'w' @SC92180 05461100 B TRMRWLG Log it @SC92180 05461200 * 05461500 * Read from terminal 05462000 TRMRD TS TRMFLG @SC87275 05462500 BZ RTRN0 Just a follow-up. 0-length read @SC87275 05463000 LM 2,3,0(8) Our buffer's adr and length @SC90264 05463500 STH 3,GTMLEN @SC90264 05464000 EXEC CICS HANDLE CONDITION LENGERR(RTRNM1), @SC90264 05464500 EXEC CICS RECEIVE INTO(0(,2)) LENGTH(GTMLEN) ASIS, @SC90264 05465000 LH 6,GTMLEN Set return code to length @SC92180 05465400 LA 0,C'r' @SC92180 05465450 TRMRWLG LR 1,8 Ptrs for I/O @SC92180 05465500 LR 5,2 Remember data buffer @SC92180 05465550 LA 2,8 Lenth of ptrs @SC92180 05465600 BAL 7,SCRLOG Log it @SC92180 05465650 LR 1,5 Ptr to buffer @SC92180 05465700 LH 2,GTMLEN Lenth of buffer @SC92180 05465750 LA 0,C'd' @SC92180 05465800 BAL 7,SCRLOG Log it @SC92180 05465850 LR 15,6 Use return code @SC92180 05465900 B RTRN @SC90264 05466000 * 05466060 TRMFULA1 DC X'1140401D6011C150' @SC92030 05466120 TRMFULL1 EQU *-TRMFULA1 @SC92030 05466180 TRMFULA2 DC X'11C36F1D4013' @SC92030 05466240 TRMFULL2 EQU *-TRMFULA2 @SC92030 05466300 TRMFULB1 DC X'1140401D6011C650' @SC92030 05466360 TRMFULB2 DC X'11C86F1D4013' @SC92030 05466420 TITLE 'SCRNIO Routine - Handle screen I/O via Series/1' 05467500 * R1 points to a pair of (adr,len) for read or write. If I/O is 05468000 * successfull, R15 returns transferred byte count (else returns -1). 05468500 * Command code is in R0: 05469000 * 0 => Clear screen on console (not comm line) @SC90045 05469500 * 1 => Open screen for I/O 4 => Write packet (gets ATTN) 05470000 * 2 => Close line 5 => Read packet 05470500 * 3 => Reset screen status after 6 => Write message (no ATTN) 05471000 * environment changes 7 => Read screen buffer 05471500 * 05472000 SCRNIO ENTER ALT @SC92180 05472500 LA 8,SCRPLST Get PLST ptr @SC90222 05473000 LTR 0,0 @SC90045 05473500 BZ SCRCLR @SC90045 05474000 LR 6,1 Save ptr to plist @SC90222 05474500 STC 0,CONSOPR Save command code @LP88158 05475000 BCT 0,SCRCLS @SC86295 05475500 * Set up for transparent I/O 05476000 L 1,=A(IDEFS) CSECT of initializations @SC90173 05476500 USING DEFS,1 Mapped via DSECT @SC90173 05477000 LA 2,S1DATA Series/1 introducer @SC90173 05477500 LA 3,S1ORDL+2 Length + 2 @SC90173 05478000 CLI TRMTP,C'S' @SC90173 05478500 BE SCRPRSET Do it @SC90173 05479000 LA 2,GRDATA Graphics introducer @SC90173 05479500 LA 3,GRDL+2 Length + 2 @SC90173 05480000 CLI TRMTP,C'G' @SC90173 05480500 BE SCRPRSET Do it @SC90173 05481000 LA 2,AEADAT AEA introducer @SC90173 05481500 LA 3,AEAL+2 @SC90173 05482000 DROP 1 @SC90173 05482500 SCRPRSET LR 5,3 @SC90173 05483000 LA 4,S1EOL+2 Get start of command buffer @SC90173 05483500 SR 4,5 @SC90173 05484000 STM 4,5,S1XOPL Set up prompt plist @SC90173 05484500 S 5,F2 Deduct stuff already there @SC90173 05485000 MVCL 4,2 @SC90173 05485500 * MVI SCRLST,0 Clear op code @SC88091 05486000 MVI RIOC,X'80' Nothing saved @SC86295 05486500 * Full-screen mode @SC90264 05487000 B SCRCLRX @SC90045 05487500 SCRCLR CLI TRMTP,C'T' Is it a TTY terminal? @SC90045 05488000 BE RTRN0 Yes, can't clear screen @SC90045 05488500 CLI TRMTP,C'V' Is it a TTY terminal? @SC90045 05489000 BE RTRN0 Yes, can't clear screen @SC90045 05489500 CLI TRMTP,C'F' Is it some full-screen? @SC92030 05489600 BE *+12 Yes, must clear frequently @SC92030 05489700 TM FL2,PROTO In protocol mode? @SC90045 05490000 BO RTRN0 Yes, skip clearing screen @SC90045 05490500 SCRCLRX LA 8,SCRCCWCL Clear-screen plist @SC90045 05491000 BAL 9,SCRNEX Do it @SC90045 05491500 MVI FSCOTP,X'FF' Flag for clearing @SC90264 05492000 B RTRN0 @SC86295 05492500 SCRCCWCL DC C'E',AL3(0),XL4'0' Erasure @SC90264 05493000 * 05493500 * Clean up after I/O 05494000 SCRCLS BCT 0,SCRRSET @SC86295 05494500 B SCRCLRX Clear screen @SC90045 05495000 * 05495500 * (Re)set device characteristics to suit environment 05496000 SCRRSET BCT 0,SCRRW @SC86295 05496500 B RTRN0 05497000 * 05497500 * Perform I/O request 05498000 * R6-> (adr,len); R0=1 if write, 2 if read, 3 if message. @SC90264 05498500 SCRRW DS 0H @SC90222 05499000 MVC 0(8,8),0(6) Copy plist @SC90264 05499500 STC 0,0(,8) Set operation code (arbitrary) @SC90264 05500000 CLI TRMTP,C'A' AEA? @SC90264 05500500 BNE *+8 No, use those codes @SC90264 05501000 OI 0(8),X'80' Mark this different @SC90264 05501500 BAL 9,SCRNEX Execute internal subr @SC86295 05502000 TM CONSOPR,1 Read request? @SC90264 05502500 BO SCRRDZ Yes, get length @SC90264 05503000 ICM 1,15,SCRRC Check return code @SC90222 05503500 BNZ RTRNM1 If error, say so @SC90222 05504000 B RTRN0 Return @SC86299 05504500 SCRRDZ LR 15,5 @LP88186 05505000 S 15,WRCMDL+4 Deduct 3 for buffer adr @SC90173 05505500 B RTRN Return @SC86299 05506000 * 05506500 * SCRLOG: Hexadecimal log of (R2) bytes at address (R1) @LP88158 05507000 * Log label is taken from R0 low order byte. @SC89166 05507500 * Return via R7. R0-R3 and R15 destroyed. @SC89166 05508000 SCRLOG TM FL1,DEBUG Logging in effect? @SC87286 05508500 BZR 7 No, that's all @SC89166 05509000 TM DBGFLG,DBGIO I/O stuff requested? @SC88168 05509500 BZR 7 No, skip it @SC89166 05510000 L 3,LOGBUF Ptr to buffer @LP88158 05510500 STC 0,0(,3) Set log label @SC89166 05511000 LA 3,2(,3) Start of data area @SC91172 05511500 TM DBGFLG,DBGTI Times requested? @SC91172 05512000 BZ SCRLOGA No, just do hex dump @SC91172 05512500 ST 1,SCRLR1 Save ptr to block @SC91172 05513000 BAL 14,ACCTTOD Get time of day in seconds @SC91172 05513500 MVI 0(3),C' ' Leave a space @SC91172 05514000 KCALL DUMPTOD,1(3) Format time into buffer @SC91172 05514500 LR 3,15 Get ptr to end of string @SC91172 05515000 L 1,SCRLR1 Restore R1 @SC91172 05515500 SCRLOGA LA 0,6*9(,3) End of line buffer @SC91172 05516000 TM DBGFLG,DBGLO Long buffer requested? @SC90222 05516500 BZ *+8 @SC90222 05517000 LA 0,50*9(,3) Yes, long buffer @SC91172 05517500 SCRLOGLP MVI 0(3),C' ' Add for readability @LP88158 05518000 UNPK 1(9,3),0(5,1) Unpack into buffer @SC88168 05518500 TR 1(8,3),TRHEX Convert to printable hex @SC88168 05519000 LA 3,9(3) Advance text ptr @SC88168 05519500 LA 1,4(1) and data source @LP88158 05520000 S 2,F4 Finished data? @SC88168 05520500 BNP SCRLGEND Yes, go write @LP88158 05521000 CR 3,0 Reached text limit? @LP88158 05521500 BL SCRLOGLP no, loop for more slices @LP88158 05522000 MVC 0(3,3),=C'...' Show incomplete @LP88158 05522500 LA 3,3(3) @SC88168 05523000 SCRLGEND DS 0H @LP88158 05523500 AR 2,2 Check for incomplete slice @SC88168 05524000 BNM *+6 No, ok @SC88168 05524500 AR 3,2 Yes, adjust end of text @SC88168 05525000 S 3,LOGBUF Get length of text @SC88168 05525500 WRITF LOGPTR,BSIZE=(3) Log it @LP88158 05526000 TM DBGFLG,DBGSV SAVE requested? @SC88168 05526500 BZR 7 No, skip closing log file @SC89166 05527000 SAVEF LOGPTR Update disk directory @SC88168 05527500 BR 7 @SC89166 05528000 * 05528500 *----- perform screen I/O operation, add to debug log ---------@SC90264 05529000 * Entry: R8-> X'code',AL3(adr),F'length', R9-> return @SC90264 05529500 * Exit: uses 0,1,2,3,5,7,14; data length in R15 or -1 if error @SC90264 05530000 SCRNEX LR 1,8 Get plist ptr @SC90222 05530500 SLR 2,2 Convert op. code to log label @LP88158 05531000 IC 2,CONSOPR @LP88158 05531500 LA 2,CONSOPRS(2) @LP88158 05532000 IC 0,0(,2) @SC89166 05532500 LA 2,8 Size of plist @SC90264 05533000 BAL 7,SCRLOG Log it @SC90222 05533500 LM 2,3,0(8) Data ptr and len @SC90264 05534000 TM 0(8),1 Write of some sort? @SC90264 05534500 BZ SCRNEXR No, read @SC90264 05535000 * Write... @SC90264 05535500 STH 3,GTMLEN Length of buffer needed @SC90264 05536000 LR 5,3 Save for logging @SC90264 05536500 CLI 0(8),C'E' Clear screen? @SC90264 05537000 BNE SCRNEXW0 No @SC90264 05537500 EXEC CICS SEND CONTROL ERASE FREEKB, Yes, do it @NL90264 05538000 B SCRNEXW2 @SC90264 05538500 SCRNEXW0 DS 0H @SC90264 05539000 CLI 0(8),X'81' WRITE STRUCTURED FIELD? @SC90264 05539500 BNE SCRNEXW1 No, just WRITE @SC90264 05540000 CLI WRRD,5 @SC92016 05540300 BE SCRNEXZ Expecting a reply - save ptrs @SC92016 05540400 EXEC CICS SEND STRFIELD WAIT DEFRESP, @SC92016+05540500 FROM(0(,2)) LENGTH(GTMLEN), @SC92016 05540600 B SCRNEXW2 @SC90264 05541000 SCRNEXW1 DS 0H @SC90264 05541500 MVI SCRCTLCH,X'C2' Unlock kbd normally @SC91039 05542000 CLI CONSOPR,6 Write message? @SC91039 05542500 B *+8 (BNE) $$$$$$$$ for now $$$$$$$$ @SC91039 05543000 MVI SCRCTLCH,X'C1' Yes, lock it to prevent clash @SC91039 05543500 EXEC CICS SEND WAIT FROM(0(,2)) LENGTH(GTMLEN), @SC91039+05544000 CTLCHAR(SCRCTLCH), @SC91039 05544500 SCRNEXW2 DS 0H @SC90264 05545000 B SCRNEXZ @SC90264 05545500 * Read... @SC90264 05546000 SCRNEXR LA 5,3 Normal length: AID + cursor adr @SC91150 05546500 CLI SCRLSTIO,X'81' WRT STR FLD? @SC91150 05547000 BNE *+8 No, fine @SC91150 05547500 LA 5,1 Yes, expect only the AID @SC91150 05548000 SR 3,5 @SC91150 05548500 STH 3,GTMLEN Length of buffer needed @SC90264 05549000 LA 7,0(5,2) Ptr to data portion @SC91150 05549500 EXEC CICS HANDLE CONDITION LENGERR(RTRNM1), @SC90264 05550000 CLI SCRLSTIO,X'81' WRT STR FLD? @SC92016 05550050 BNE SCRNEXR0 No, fine @SC92016 05550100 L 4,SCRLSTIO @SC92016 05550150 EXEC CICS CONVERSE STRFIELD DEFRESP, @SC92016+05550200 FROM(0(,4)) FROMLENGTH(SCRLSTIO+6), @SC92016+05550250 INTO(0(,7)) TOLENGTH(GTMLEN), @SC92016 05550300 B SCRNEXR2 @SC92016 05550350 SCRNEXR0 DS 0H @SC92016 05550400 CLI CONSOPR,7 @SC90264 05550500 BE SCRNEXR1 @SC90264 05551000 EXEC CICS RECEIVE INTO(0(,7)) LENGTH(GTMLEN) ASIS, @SC91150 05551500 B SCRNEXR2 @SC90264 05552000 SCRNEXR1 EXEC CICS RECEIVE INTO(0(,7)) LENGTH(GTMLEN) ASIS, @SC91150+05552500 BUFFER, @SC90264 05553000 SCRNEXR2 DS 0H @SC90264 05553500 L DFHEIBR,DFHEIBP @SC90264 05554000 USING DFHEIBLK,DFHEIBR @SC90264 05554500 MVC 0(1,2),EIBAID Reconstruct data stream @SC90264 05555000 C 5,F1 @SC91150 05555500 BNH *+10 @SC91150 05556000 MVC 1(2,2),EIBCPOSN in our buffer @SC90264 05556500 DROP DFHEIBR @SC90264 05557000 AH 5,GTMLEN Data length reconstructed @SC91150 05557500 SCRNEXZ SR 15,15 For now... @SC90264 05558000 SCRNEXZZ ST 15,SCRRC @SC90222 05558500 MVC SCRLSTIO,0(8) Save code of last I/O @SC91150 05559000 LTR 15,15 @SC90222 05559500 BZ SCRNEXD Ok, log data @SC90222 05560000 LA 1,SCRRC @SC90222 05560500 LA 2,4 @SC90222 05561000 LA 0,C'e' "Error" label @SC90222 05561500 BAL 7,SCRLOG Log the return code @SC90222 05562000 SCRNEXD L 1,0(,8) Data address @SC90222 05562500 LA 0,C'd' "Data" label @SC89166 05563000 LR 2,5 Data size @SC90222 05563500 BAL 7,SCRLOG Log data @SC90222 05564000 LR 15,5 @LP88186 05564500 BR 9 Return to caller @LP88186 05565000 * 05565500 CONSOPRS DC C'?ocswrmg' Console command labels for log @SC91150 05566000 LOCALS , @SC86299 05566500 SCRPLST DS 2F Control block @SC90264 05567000 SCRRC DS F Return code from PUT/GET @SC90222 05567500 SCRLR1 DS F Saved R1 in SCRLOG @SC91172 05568000 CONSOPR DS XL1 Current I/O operation @SC89180 05568500 SCRCTLCH DS X WCC for next output op @SC91039 05569000 SCRNIO EXIT , @SC86299 05569500 TITLE 'SETMSG Routine - controls CP breakin' 05570000 * Entry: R1 selects operation 05570500 * Exit: R15=0 if ok 05571000 * 1-> Analyze user environment, determine if suitable. 05571500 * Save quantities needed and condition line for entering commands. 05572000 * Perform any system-dependent initialization. 05572500 * 2-> Condition line for protocol transfers. 05573000 * 3-> Decondition line at end of transfer. 05573500 * 4-> System-dependent clean-up at exit. 05574000 * 5-> Reperform system-dependent initialization after SET LINE. 05574500 * 05575000 IC EQU X'13' Insert Cursor @SC90264 05575500 SF EQU X'1D' Start Field @SC90264 05576000 SETMSG ENTER , @SC87015 05576500 BCT 1,STM2 Go if R1 not 1, so no init 05577000 OI FL1,REN Set "WARN" ON @SC90264 05577500 MVI CLSNFL,C'R' (both ways) @SC90264 05578000 MVI DESTL+1,1 Set to default @SC90264 05578500 MVI DEST,C'*' @SC90264 05579000 EXEC CICS ADDRESS CSA(1), @SC90264 05579500 ST 1,CSAPTR Save ptr to CSA @SC90264 05580000 L 15,CSATSATA-DFHCSABA(,1) @SC91150 05580500 USING DFHTSMAP,15 @SC91150 05581000 MVC KTSBPSEG,TSMBPSEG Log(seg size) @SC91150 05581500 MVC KTSGIDNE,TSMGIDNE Number of entries per TSGID @SC91150 05582000 DROP 15 @SC91150 05582500 EXEC CICS ASSIGN, @SC90264.05583000 OPID(COPID), @LM90264.05583500 SYSID(CSYSID), @LM90264.05584000 SCRNHT(CSCRNHT), @LM90264.05584500 SCRNWD(CSCRNWD), @LM90264.05585000 TERMCODE(TCTTETT), @SC90264 05585500 CLI TCTTETT,X'40' TTY? @SC90264 05586000 BL *+8 Yes @SC90264 05586500 OI FSCTRMF,X'80' No, mark it fullscreen @SC90264 05587000 L DFHEIBR,DFHEIBP @SC90264 05587500 USING DFHEIBLK,DFHEIBR @SC90264 05588000 ICM 2,15,DFHEICAP Any comm area? @SC90264 05589500 BZ STM1REC No, issue a read @SC90264 05590000 LH 1,EIBCALEN Length of comm area? @SC90264 05590500 LTR 1,1 @SC90264 05591000 BZ STM1REC Zero, issue a read @SC90264 05591500 CH 1,=H'256' Max allowed in buffer @SC91150 05592000 BNH *+8 @SC91150 05592500 LH 1,=H'256' Use max for length @SC91150 05593000 STH 1,LINLEN Ok, use the commarea as command @SC90264 05593500 LR 3,1 Set up MVCL @SC91150 05594000 L 0,GTLBUFP @SC91150 05594500 MVCL 0,2 Copy string to input cmd buffer @SC91150 05595000 B STM1RECZ Done setup of command @SC90264 05595500 DROP DFHEIBR @SC90264 05596000 STM1REC DS 0H @SC90264 05596500 MVC LINLEN,=H'256' @SC90264 05597000 L 2,GTLBUFP Get invocation buffer @SC90264 05597500 EXEC CICS IGNORE CONDITION LENGERR, @SC90264 05598000 EXEC CICS RECEIVE INTO(0(,2)) LENGTH(LINLEN) ASIS, @SC90264 05598500 STM1RECZ DS 0H @SC90264 05599000 MVI FSCOTP,X'FF' Flag for reformatting fullscreen @SC90264 05599500 L 2,QFNBP Ptr to ring of QFN buffers @SC90264 05600000 ST 2,QFNPTR 1st buffer to use @SC90264 05600500 LA 3,3-1 Number - 1 of buffers @SC90264 05601000 LA 4,QFNSIZ+4(,2) Chain together @SC90264 05601500 STCM 4,15,QFNSIZ(2) @SC90264 05602000 LR 2,4 @SC90264 05602500 BCT 3,*-10 Loop over buffers @SC90264 05603000 MVC QFNSIZ(4,2),QFNPTR Complete the ring @SC90264 05603500 SETUSER , @SC90264 05604000 KCALL KFLCWD,DESTL @SC90264 05604500 B STM5X @SC90173 05605000 * 05605500 STM2 BCT 1,STM3 Go if R1 was not 2, so not off 05606000 * @SC90264 05606500 TM FL1,TSTF @SC86295 05607000 BO RTRN0 Just testing, don't change it @SC86295 05607500 * @SC90264 05608000 B STMD 05608500 * 05609000 STM3 BCT 1,STM4 @SC86316 05609500 * @SC90264 05610000 STMD DS 0H @SC86316 05610500 B RTRN0 05611000 * 05611500 STM4 BCT 1,STM5 Special clean-up @SC87351 05612000 SR 0,0 @SC90264 05612500 KCALL SCRNIO Clear screen if fullscreen @SC90264 05613000 TM DSKFL,PLOAD Pgm loaded? @SC90264 05613500 BZ STM4A @SC90264 05614000 EXEC CICS RELEASE PROGRAM('IKXDYNAL') NOHANDLE, @SC90264 05614500 STM4A DS 0H @SC90264 05615000 KCALL KFLCWD,F0 Free all megablocks @SC90264 05615500 B RTRN0 Special clean-up done @SC87296 05616000 * 05616500 STM5 DS 0H Re-init after SET LINE @SC87351 05617000 MVI TRMTP,C'N' Assume bad until validated @SC90173 05617500 CLI TRMLIN,C' ' External line? @SC87351 05618000 BE STM5X No, use terminal @SC90173 05618500 B RTRN1 Other lines not allowed @SC90173 05619000 STM5X DS 0H Now set up controller type @SC90173 05619500 MVI TRMTP,C'&KCONT' 1st assume TTY @SC88309 05620000 TM FSCTRMF,X'80' TTY? @SC90264 05620500 BZ STMSTY Yes @SC86299 05621000 SR 1,1 Assume Query not allowed @SC91311 05622000 STMGRS DS 0H @SC91311 05623000 O 1,=A(&CONOPTS) Options @SC91311 05624000 KCALL SETCON Find out just what kind... @SC91311 05625000 B RTRN0 @SC90173 05649000 STMSTY DS 0H Set up TTY mode @SC90264 05649500 B RTRN0 @SC86295 05650000 * 05650500 LOCALS , @SC86295 05654500 TCTTETT DS 2X Terminal type and model codes @SC90264 05655000 SETMSG EXIT 05655500 TITLE 'DISKIO Routine - performs disk I/O functions' 05656000 * ERRNUM unchanged unless there is a disk error. 05656500 * Function selected on entry by R0: 05657000 * 0=> unnum read: R1->FAB. Return R1->buffer,R0=# and remove the 05657500 * sequence number (if any) from the buffer (used for TAKE files) 05658000 * 1=> open (in): R1->pattern FDB, R2->name. Returns R0->FAB, R1->FDB 05658500 * 2=> open (out): (same) 05659000 * 3=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05659500 * writable (else R15=1) @SC91269 05659600 * 4=> close file: R1->adr(FAB). 05660000 * 5=> set up search: R1->pattern name. 05660500 * 6=> return next file in list: Returns R1->FDB + sets up FILNAM 05661000 * 7=> close search (if any). 05661500 * 8=> test CWD string: R1->string. Returns R15=0 if ok, else =1. 05662000 * 9=> read: R1->FAB. Returns R15=12 if EOF, 0 if ok; R0=# data 05662500 * 10=> write: R1->FAB. Returns R15=13 if disk full, 0 if ok. 05663000 * 11=> test space: R1->pattern FDB (has size in Kbytes), 05663500 * R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok. 05664000 * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code 05664500 * always returns R15=1 05665000 * 13=> directory info on file: R1->name. Returns R15=0 if ok. 05665500 * 14=> delete file: R1->name. Returns R15=0 if ok. 05666000 * 15=> rename file: R1->name, R2->new name. Returns R15=0 if ok. 05666500 * 16=> copy file: R1->name, R2->new name. Returns R15=0 if ok. 05667000 * 17-> type file: R1-> name. Returns R15=0 if ok. 05667500 * 21=> save file status in directory: R1->FAB. (not used) @SC88168 05668000 * 22=> open library (in): R2->DDNAME. Return R15=0 if ok. @SC89073 05668500 * 23=> point for next read, R1->adr(FDB), R2=records to skip. @SC89218 05669000 * Return R15=0 if ok. @SC89218 05669500 * 24=> test name: R2->name. Returns R1->FDB if file found and @SC91269 05669550 * readable (else R15=1) @SC91269 05669600 DISKIO ENTER 05670000 USING DFHDCTDS,DCTCBAR Reinstate R8 addressing @SC90264 05670500 USING FABD,3 @SC86295 05671000 STC 0,DSKCOD Save for reference @SC88101 05671500 SR 4,4 Signal no block assigned @SC86295 05672000 LA 5,DISKIO+4095 @SC90264 05672500 USING DISKIO+4095,5 Secondary base register @SC90264 05673000 LR 15,0 @SC90264 05673500 AR 15,15 @SC90264 05674000 LH 15,DSK0(15) Get handler address @SC90264 05674500 B DSK0(15) Do the function @SC90264 05675000 DSK0 DC Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0) 0-2 @SC89073 05675500 DC Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0) 3-5 @SC89073 05676000 DC Y(DSKNXT-DSK0,DSKNSX-DSK0,DSKCWDF-DSK0) 6-8 @SC89073 05676500 DC Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0) 9-11 @SC89073 05677000 DC Y(DSKXXX-DSK0,DSKDIR-DSK0,DSKDEL-DSK0) 12-14 @SC89073 05677500 DC Y(DSKRNM-DSK0,DSKCPY-DSK0,DSKTYP-DSK0) 15-17 @SC89073 05678000 DC 3Y(DSKER1-DSK0) Spare utilities 18-20 @SC89073 05678500 DC 2Y(DSKER1-DSK0),Y(DSKPNT-DSK0) 21-23 @SC89218 05679000 DC Y(DSKVERF-DSK0) 24- @SC91269 05679050 DC 8Y(DSKER1-DSK0) spare @SC89073 05679500 * 05680000 * Open for input file whose name is at (R2), FDB at (R1) 05680500 DSKOPNI BAL 9,DSKALC Get FAB @SC86295 05681000 MVC FABCOMM,=CL8'OPEN I' @SC90264 05681500 DSKOP0 BAL 2,DSKVALID See if allowed @SC90264 05682000 BAL 2,DSKLKP Find file @SC90264 05682500 BNZ DSKER1 Not found @SC86295 05683000 BAL 14,DSKVALS @SC86295 05683500 CLI DSKCOD,1 Just testing? @SC90264 05684000 BNE RTRN0 Yes, we're done @SC90264 05684500 LA 0,4 Wait up to 3 sec @SC92126 05684600 BAL 9,DSKENQ @SC92126 05684700 B DSKER1 Can't get it now, give up @SC92126 05684800 CLI FDBFL2,X'40' Extra-partition queue? @SC90264 05685000 BNE RTRN0 No, don't need to close it first @SC90264 05685500 DSKTDCLO BAL 9,DSKTDOPE Close and open @SC90264 05686000 B DSKER1A Oops @SC92126 05686500 B RTRN0 @SC90264 05687000 * 05687500 DSKTDOPE MVC DSKEMTS,=CL15'SET Q( ) CLO' @SC90264 05688000 MVC DSKEMTS+6(4),FABFNAM @ML90264 05688500 EXEC CICS LINK PROGRAM('DFHEMTP') COMMAREA(DSKEMTS), @SC90264+05689000 LENGTH(15) NOHANDLE, @SC90264 05689500 BAL 14,DSKCHKER Test success @SC90264 05690000 BNZR 9 Oops @SC90264 05690500 MVC DSKEMTS+12(3),=CL3'OPE' @ML90264 05691000 EXEC CICS LINK PROGRAM('DFHEMTP') COMMAREA(DSKEMTS), @SC90264+05691500 LENGTH(15) NOHANDLE, @SC90264 05692000 BAL 14,DSKCHKER Test success @SC90264 05692500 BNZR 9 Oops @SC90264 05693000 B 4(,9) Return and skip @SC90264 05693500 * 05694000 * Open for output file whose name is at (R2), FDB at (R1) 05694500 DSKOPNO BAL 9,DSKALC Get FAB @SC86295 05695000 MVC FABCOMM,=CL8'OPEN O' @SC90264 05695500 BAL 2,DSKVALID See if allowed @SC90264 05696000 OI FABIOF,1 Signal output access @SC90264 05696500 BAL 2,DSKLKP Find file info @SC86295 05697000 BNZ DSKOPLR Not found, just writing new @SC87012 05697500 TM FDBFLGS,APPN+SVATT Should we keep attributes? @SC90033 05698000 BZ *+8 No @SC90033 05698500 BAL 14,DSKVALS Yes, copy old ones to FDB @SC90033 05699000 TM FDBFLGS,APPN @SC86295 05699500 BO DSKOPLR @SC90033 05700000 MVC DSKSTT+FABUWORD-FABD(4),FABUWORD Provide word @SC91150 05700500 ERASF FABFID Delete old @SC90264 05701000 MVC FABUWORD,DSKSTT+FABUWORD-FABD Restore word @SC91150 05701500 DSKOPLR LH 0,FDBLRC @SC88120 05702000 CLI FDBRCF,C'V' RECFM F limited to LRECL @SC88120 05702500 BNE DSKSTLR @SC88120 05703000 CLI TYPFIL,C'B' Binary? @SC88120 05703500 BE DSKSTLR4 Yes, always fold @SC91150 05704000 TM FABFLGS,FABFPGM+FABFSPL Pipe, spool or QFN? @SC91150 05704500 BNZ DSKSTLR4 Yes, be strict @SC91150 05705000 TM FABFLGS,FABFTD TD queue? @SC91150 05705500 BZ *+12 No, ok to use max @SC91150 05706000 TM FDBFL2,TDEXTRBM Extra? @SC91150 05706500 BO DSKSTLR4 Yes, must observe LRECL @SC91150 05707000 L 0,MAXLRC TEXT file, no limit @SC87012 05707500 DSKSTLR4 S 0,F4 Allow for RDW @SC91150 05708000 DSKSTLR ST 0,FABLRTR Set effective record length @SC88120 05708500 LA 0,4 Wait up to 3 sec @SC92126 05708600 BAL 9,DSKENQ @SC92126 05708700 B DSKER1 Can't get it now, give up @SC92126 05708800 TM FABFLGS,FABFTAK @SC90264 05709000 BZ RTRN0 @SC90264 05709500 KCALL KFILIO,(3),E=DSKER1A @SC92126 05710000 B RTRN0 @SC86295 05710500 * 05711000 * Test for existence of file whose name is at (R2) 05711500 DSKTEST XC DSKFDB,DSKFDB @SC90264 05712000 MVC FABCOMM-FABD+DSKSTT(8),=CL8'TEST' Check output @SC91269 05712100 DSKTEST1 DS 0H @SC91269 05712200 MVC DSKSTNM,0(2) @SC90264 05712500 LA 3,DSKSTT @SC86295 05713000 B DSKOP0 @SC86295 05714000 DSKVERF XC DSKFDB,DSKFDB @SC91269 05714100 MVC FABCOMM-FABD+DSKSTT(8),=CL8'VERIFY' Check input @SC91269 05714200 B DSKTEST1 @SC91269 05714300 * 05714500 * Test validity using external routine @SC90264 05715000 DSKVALID ICM 15,15,=A(KVALID) @SC90264 05715500 BZR 2 @SC90264 05716000 MVC FABRESP-FABD+DSKSTT(6),=X'123456' Odd err code @SC90264 05716500 KCALL (15),(3),EXT,E=DSKER1 Quit if it says so @SC90264 05717000 BR 2 @SC90264 05717500 * 05718000 * Close file whose ticket is at (R1), release block 05718500 DSKCLOS ICM 3,15,0(1) Get FAB ptr, if any @SC86295 05719000 BZ RTRN0 None, ignore @SC86295 05719500 XC 0(4,1),0(1) Yes, now clear ticket @SC86295 05720000 MVC FABCOMM,=CL8'CLOSE' @SC90264 05720500 TM FABFLGS,FABFPGM+FABFSPL Pipe? @SC90264 05721000 BZ *+8 @SC90264 05721500 BAL 2,DSKLKPG Yes, handle closing @SC90264 05722000 TM FABFLGS,FABFTAK Internal file? @SC90264 05722500 BZ DSKCLOS2 @SC90264 05723000 KCALL KFILIO,(3) Yes, handle closing @SC90264 05723500 DSKCLOS2 DS 0H @SC90264 05724000 BAL 9,DSKDEQ Release if TDQ @SC92126 05724200 * Close file @SC90264 05724500 LR 1,3 @SC86295 05725000 LA 0,FABDWDS @SC86295 05725500 DMSFRET DWORDS=(0),LOC=(1) @SC86295 05726000 B RTRN0 @SC86295 05726500 * 05727000 * Point past 1st N records of file at (R1) @SC89218 05727500 DSKPNT ICM 3,15,0(1) Get ticket @SC89218 05728000 BZ RTRN1 Not open @SC89218 05728500 LR 3,1 @SC89218 05729000 LTR 2,2 Number of records to skip @SC89218 05729500 BNP RTRN0 Never mind @SC89218 05730000 TM FABFLGS,FABFTS+FABFTAK Temp stor or TAKE? @SC90264 05730500 BZ DSKPNTL No, must read to skip @SC90264 05731000 STH 2,FABRN Yes, just set pointer @SC90264 05731500 B RTRN0 @SC90264 05732000 DSKPNTL READF 0(,3),E=RTRN1 Skip one @SC89218 05732500 BCT 2,DSKPNTL ... until finished @SC89218 05733000 B RTRN Return with completion code @SC89218 05733500 * 05734000 * Read from file whose ticket is at (R1) 05734500 DSKRED LTR 3,1 Get FAB ptr @SC86299 05735000 BNP RTRN1 Not defined anymore @SC86299 05735500 LA 1,1 @SC90264 05736000 AH 1,FABRN Bump record counter @SC90264 05736500 STH 1,FABRN @SC90264 05737000 MVC FABNORD,FDBLRC Set up length of reads @SC90264 05737500 L 6,FDBBUFF Use real buffer @SC90264 05738000 MVC FABCOMM,=CL8'READ' Op code for error message @SC90264 05738500 TM FABFLGS,FABFTS Temp stor? @SC90264 05739000 BO DSKREDS Yes, do it @SC90264 05739500 TM FABFLGS,FABFTD TD queue? @SC90264 05740000 BO DSKREDD Yes, do it @SC90264 05740500 TM FABFLGS,FABFTAK Internal file? @SC90264 05741000 BO DSKREDT Yes, do it @SC90264 05741500 TM FABFLGS,FABFPGM+FABFSPL Pipe? @SC90264 05742000 BZ DSKRER ??? @SC90264 05742500 BAL 2,DSKLKPG Yes, handle it @SC90264 05743000 LA 0,X'01' EOF signal @SR92148 05743200 B DSKRED2 @SC90264 05743500 DSKREDS DS 0H @SC90264 05744000 MVC FABCOMM,=CL8'READ TS' Op code for error message @SC90264 05744500 EXEC CICS READQ TS QUEUE(FABFNAM) ITEM(FABRN), @SC90264+05745000 INTO(0(,6)) LENGTH(FABNORD) NOHANDLE, @SC90264 05745500 LA 0,X'01' ITEMERR for TS queue @SC90264 05746000 B DSKRED1 @SC90264 05746500 DSKREDT KCALL KFILIO,(3) @SC90264 05747000 LTR 15,15 @SC90264 05747500 LA 0,X'81' NOTFND for VSAM @SC90264 05748000 B DSKRED2 @SC90264 05748500 DSKREDD MVC FABCOMM,=CL8'READ TD' Op code for error message @SC90264 05749000 EXEC CICS READQ TD QUEUE(FABFNAM) INTO(0(,6)), @SC90264+05749500 LENGTH(FABNORD) NOHANDLE, @SC90264 05750000 LA 0,X'01' QZERO for TD queue @SC90264 05750500 DSKRED1 BAL 14,DSKCHKER Test success @SC90264 05751000 DSKRED2 BNZ DSKRERX No, see if EOF @SC90264 05751500 LH 7,FABNORD Actual length @SC90264 05752000 L 1,FDBBUFF Ptr to data area @SC90264 05752500 LM 14,15,FDBBUFF Get buffer and size @SC90264 05753000 LR 0,7 Save length for number check @SC88101 05753500 AR 7,1 End of record @SC86299 05754000 CLI DSKCOD,0 NONUM? @SC88101 05754500 BNE DSKREDC No, use everything @SC88101 05755000 CLI FDBRCF,C'F' Fixed-length records? @SC88101 05755500 BNE DSKREDV No, line numbers at start (if any)@SC88101 05756000 CH 0,=H'80' See if F/80 @SC88101 05756500 BNE DSKREDC No @SC88101 05757000 MVZ NUMPAT(5),75(1) See if 76-80 are all numeric @SC88101 05757500 CLC NUMPAT(5),=8C'0' @SC88101 05758000 BNE DSKREDC No @SC88101 05758500 S 7,F8 Yes, move the end back @SC88101 05759000 B DSKREDC @SC88101 05759500 DSKREDV LA 0,8(1) Is length at least 8? @SC88101 05760000 CR 0,7 @SC88101 05760500 BNL DSKREDC No, can't be numbered @SC88101 05761000 MVZ NUMPAT(8),0(1) See if 1-8 all numeric @SC88101 05761500 CLC NUMPAT(8),=8C'0' @SC88101 05762000 BNE DSKREDC No, not numbered @SC88101 05762500 LA 1,8(1) Yes, skip over number @SC88101 05763000 DSKREDC DS 0H @SC88101 05763500 SR 7,1 Revised length @SC86299 05764000 LR 6,1 @SC86299 05764500 CR 7,15 @SC90264 05765000 BNL *+6 @SC86299 05765500 LR 15,7 Buffer not filled @SC90264 05766000 L 1,4(13) @SC86299 05766500 ST 15,20(1) Return length in R0 @SC90264 05767000 CLI DSKCOD,0 NONUM? @SC88101 05767500 BNE *+8 @SC88101 05768000 ST 14,24(,1) Yes, return R1 ptr @SC90264 05768500 CR 14,6 Already in place? @SC90264 05769000 BE *+6 Yes, don't copy @SC90264 05769500 MVCL 14,6 Copy to buffer @SC90264 05770000 B RTRN0 @SC86299 05770500 * Test for successful completion of CICS command @SC90264 05771000 DSKCHKER L 15,DFHEIBP Set up to copy EIB code @SC90264 05771500 USING DFHEIBLK,15 @SC90264 05772000 MVC FABRESP,EIBRCODE @SC90264 05772500 CLC F0,FABRESP Ok? @SC90264 05773000 BR 14 Return with CC @SC90264 05773500 DROP 15 @SC90264 05774000 * Error on input @SC90264 05774500 DSKRER LA 15,1 Return code for ordinary error @SC90264 05775000 DSKRER2 MVI ERRNUM,ERRDIE Disk I/O error @SC90264 05775500 B RTRN Indicate error @SC90264 05776000 DSKFUL LA 15,13 Indicate disk full @SC90264 05776500 B DSKRER2 @SC90264 05777000 * Error on read. See if just EOF @SC90264 05777500 DSKRERX CLM 0,1,FABRESP R0 has code that means EOF @SC90264 05778000 BNE DSKRER No, just ordinary error @SC90264 05778500 * End of file on input. Don't close it yet. @SC86295 05779000 DSKEOD LA 15,12 End return code @SC86295 05779500 B RTRN @SC86295 05780000 * 05780500 * Write to file whose ticket is at (R1) 05781000 DSKWRT LTR 3,1 Get FAB ptr @SC86299 05781500 BNP RTRN1 Not defined anymore @SC86299 05782000 LA 1,1 @SC90264 05782500 AH 1,FABRN Bump record counter @SC90264 05783000 STH 1,FABRN @SC90264 05783500 LM 6,7,FDBBUFF Get buffer and size @SC90264 05784000 STH 7,FABNORD Put length in temp var @SC90264 05784500 MVC FABCOMM,=CL8'WRITE' Op code for error message @SC90264 05785000 TM FABFLGS,FABFTS Temp stor? @SC90264 05785500 BO DSKWRTS Yes, do it @SC90264 05786000 TM FABFLGS,FABFTD TD queue? @SC90264 05786500 BO DSKWRTD Yes, do it @SC90264 05787000 TM FABFLGS,FABFTAK Internal file? @SC90264 05787500 BO DSKWRTT Yes, do it @SC90264 05788000 TM FABFLGS,FABFPGM+FABFSPL Pipe? @SC90264 05788500 BZ DSKRER Huh? @SC90264 05789000 BAL 2,DSKLKPG Yes, handle it @SC90264 05789500 LA 0,X'10' NOSPACE code for Extra TD queues @SC90264 05790000 B DSKWRT2 @SC90264 05790500 DSKWRTS DS 0H @SC90264 05791000 MVC FABCOMM,=CL8'WRIT TS' Op code for error message @SC90264 05791500 TM FABFLGS,FABFMAIN Main storage? @SC90264 05792000 BZ DSKWRTSA No, use AUX @SC90264 05792500 EXEC CICS WRITEQ TS QUEUE(FABFNAM) FROM(0(,6)) MAIN, @SC90264+05793000 LENGTH(FABNORD) NOHANDLE, @SC90264 05793500 LA 0,X'08' NOSPACE code for TS queues @SC90264 05794000 B DSKWRT1 Test success @SC90264 05794500 DSKWRTSA EXEC CICS WRITEQ TS QUEUE(FABFNAM) FROM(0(,6)), @SC90264+05795000 AUXILIARY LENGTH(FABNORD) NOHANDLE, @SC90264 05795500 LA 0,X'08' NOSPACE code for TS queues @SC90264 05796000 B DSKWRT1 Test success @SC90264 05796500 DSKWRTT KCALL KFILIO,(3) @SC90264 05797000 LTR 15,15 @SC90264 05797500 LA 0,X'83' NOSPACE code for VSAM WRITE @SC90264 05798000 B DSKWRT2 @SC90264 05798500 DSKWRTD MVC FABCOMM,=CL8'WRIT TD' Op code for error message @SC90264 05799000 EXEC CICS WRITEQ TD QUEUE(FABFNAM) FROM(0(,6)), @SC90264+05799500 LENGTH(FABNORD) NOHANDLE, @SC90264 05800000 LA 0,X'10' NOSPACE code for TD queues @SC90264 05800500 DSKWRT1 BAL 14,DSKCHKER Test success @SC90264 05801000 DSKWRT2 BZ RTRN0 @SC90264 05801500 CLM 0,1,FABRESP NOSPACE? @SC90264 05802000 BE DSKFUL Yes, treat it separately @SC90264 05802500 B DSKRER No, catch-all I/O error @SC90264 05803000 * 05803500 * Analyze error: code in FABRESP @SC90264 05804000 DSKXXX LR 3,1 @SC89073 05804500 MVI ERRNUM,ERRDIE Set Kermit error code @SC87338 05805000 L 2,EMSGP Ptr to msg buffer @SC87338 05805500 MVC 0(8,2),FABCOMM Copy oprn name @SC87338 05806000 MVC 8(2,2),=C'R=' @SC87338 05806500 UNPK 10(13,2),FABRESP(7) Copy error code @SC90264 05807000 TR 10(12,2),TRHEX Convert to hex @SC90264 05807500 MVC EMSGL,=F'22' Length of string @SC90264 05808000 B RTRN1 @SC87338 05808500 * 05808510 * Enqueue for working on a TDQ. Wait up to (R0)-1 sec if nec. @SC92126 05808520 DSKENQ TM FABFLGS,FABFTD TD? @SC92126 05808530 BZ 4(,9) No, queuing not needed @SC92126 05808540 MVC DSKQUE(4),FABFNAM Yes, set up resource name @SC92126 05808550 MVC DSKQUE+4(3),=C'.TD' @SC92126 05808560 STH 0,DSKENQCT @SC92126 05808570 EXEC CICS HANDLE CONDITION ENQBUSY(DSKENQNO), @SC92126 05808580 DSKENQLP EXEC CICS ENQ RESOURCE(DSKQUE) LENGTH(7), @SC92126 05808590 OI FDBFLGS,FDBENQ Now enqueued @SC92126 05808600 B 4(,9) Ok, proceed @SC92126 05808610 DSKENQNO LH 0,DSKENQCT Busy, see if we can wait... @SC92126 05808620 BCT 0,DSKENQNX Branch if we can @SC92126 05808630 BR 9 Give up, take error exit @SC92126 05808640 DSKENQNX STH 0,DSKENQCT Update counter @SC92126 05808650 EXEC CICS DELAY INTERVAL(1), @SC92126 05808660 B DSKENQLP @SC92126 05808670 * 05808680 * Release after working on a TDQ. Must not alter FABRESP. @SC92126 05808690 DSKDEQ TM FABFLGS,FABFTD TD? @SC92126 05808700 BZR 9 No, dequeuing not needed @SC92126 05808710 TM FDBFLGS,FDBENQ Queuing done? @SC92126 05808720 BZR 9 No, dequeuing not needed @SC92126 05808730 MVC DSKQUE(4),FABFNAM Yes, set up resource name @SC92126 05808740 MVC DSKQUE+4(3),=C'.TD' @SC92126 05808750 EXEC CICS DEQ RESOURCE(DSKQUE) LENGTH(7), @SC92126 05808760 NI FDBFLGS,255-FDBENQ @SC92126 05808770 BR 9 Ok, proceed @SC92126 05808780 * 05809000 * Directory Info on file R1->name, return R15=0 if OK 05809500 DSKDIR DS 0H @SC89073 05810000 NI DSKFL,255-NFFND @SC90264 05810500 NXTFSET E=DSKDRERR Set up search (name at R1) @SC88308 05811000 DSKDRLP NXTF E=DSKDRZ Find next entry @SC88308 05811500 LR 3,1 Move FDB ptr @SC90264 05812000 SH 3,=Y(FDBD-FABD) Set up addressability @SC90264 05812500 TM DSKFL,NFFND Found something already? @SC90264 05813000 BO DSKDRL1 @SC90264 05813500 WTEXT '&DIRHDNG' @SC92300 05814300 OI DSKFL,NFFND Found something, at least one @SC88308 05815000 DSKDRL1 DS 0H @SC90264 05815500 LA 7,CMD Make attr list in buffer @SC90264 05816000 LA 0,FFDSP Format the file name @SC90264 05816500 KCALL FSPEC,FABFID @SC90264 05817000 LA 2,24(,7) Allow enough room @SC92150 05817500 DSKDRBL MVI 0(15),C' ' @SC90264 05818000 LA 15,1(,15) @SC90264 05818500 CR 15,2 @SC90264 05819000 BNH DSKDRBL @SC90264 05819500 MVC 1(1,2),FDBRCF RECFM, if any 05820000 CLI 1(2),0 05820500 BNE *+8 05821000 MVI 1(2),C'?' 05821500 LA 2,2(,2) 05822000 LH 0,FDBLRC 05822500 BAL 9,DSKNUM Add the logical record length 05823000 LH 0,FDBNREC @SC90264 05823500 BAL 9,DSKNUM Add the record count @SC90264 05824000 L 0,FDBSIZE @SC90264 05824500 BAL 9,DSKNUM Add the file size @SC90264 05825000 MVC 0(2,2),=CL2' ' Leave some blanks 05825500 LA 2,2(,2) Bump the length @SC88308 05826000 ICM 0,8,FDBFL2 05826500 LA 15,4 @SC90264 05827000 LA 6,DSKTYPS 05827500 DSKDRTL LTR 0,0 05828000 BM DSKDRTP 05828500 LA 6,6(,6) 05829000 SLL 0,1 05829500 BCT 15,DSKDRTL @SC90264 05830000 DSKDRTP MVC 0(6,2),0(6) 05830500 LA 2,6(,2) 05831000 CLI FDBDATE,X'19' Validate century @SC91150 05831500 BL DSKDRDZ No good! @SC91150 05832000 CLI FDBDATE,X'20' @SC91150 05832500 BH DSKDRDZ @SC91150 05833000 MVC 0(DSKDRPTL,2),DSKDRPT @SC91150 05833500 ED 0(DSKDRPTL,2),FDBDATE @SC91150 05834000 LA 2,DSKDRPTL(,2) @SC91150 05834500 DSKDRDZ DS 0H @SC91150 05835000 * 05835500 SR 2,7 Get the output length @SC90264 05836000 WTEXT (7),(2) @SC90264 05836500 B DSKDRLP @SC88308 05837000 DSKDRPT DC C' ',4X'20',C'/',2X'20',C'/',2X'20',C' ' Date @SC91150 05837500 DC 2X'20',C':',2X'20',C':',2X'20' Time @SC91150 05838000 DSKDRPTL EQU *-DSKDRPT Length of pattern @SC91150 05838500 * @SC88308 05839000 DSKDRZ TM DSKFL,NFFND Any files found? @SC90264 05839500 BO RTRN0 Yes, return gracefully @SC88308 05840000 DSKDRERR B RTRN1 Not found or invalid @SC90264 05840500 * 05841000 DSKNUM CVD 0,TMPDW Pack the binary value 05841500 OI TMPDW+7,15 Set zone 05842000 UNPK 0(8,2),TMPDW Convert to printable 05842500 LA 15,7(,2) Point to end of string @SC90264 05843000 DSKNUM2 CLI 0(2),C'0' Remove leading zeros 05843500 BNE DSKNUM3 except for the first one. 05844000 MVI 0(2),C' ' 05844500 LA 2,1(2) 05845000 CR 2,15 @SC90264 05845500 BL DSKNUM2 05846000 DSKNUM3 LA 2,1(,15) Get the new ending address @SC90264 05846500 BR 9 05847000 * 05847500 DSKTYPS DC C'INTRA ' 05848000 DC C'EXTRA ' 05848500 DC C'INDIR.' 05849000 DC C'REMOTE' 05849500 DC CL6'&OTHERL6' @SC92300 05850000 * 05850500 * Delete file. R1-> name. Returns R15=0 if ok. 05851000 DSKDEL DS 0H @SC89073 05851500 LR 6,1 @SC90264 05852000 LA 3,DSKSTT @SC86295 05852500 MVC FABFID,0(6) Copy name into temp FAB @SC90264 05853000 MVC FABCOMM,=CL8'DELETE' @SC90264 05853500 BAL 2,DSKVALID See if allowed @SC90264 05854000 TM FABFLGS,FABFPGM+FABFSPL Pipe? @SC90264 05854500 BNZ DSKDELP Yes, do it @SC90264 05855000 TM FABFLGS,FABFTAK Internal file? @SC90264 05855500 BO DSKDELT Yes, do it @SC90264 05856000 TM FABFLGS,FABFTS Temp stor? @SC90264 05856500 BZ DSKDELD No, Transdat @SC90264 05857000 EXEC CICS DELETEQ TS QUEUE(FABFNAM) NOHANDLE, @SC90264 05857500 BAL 14,DSKCHKER Test success @SC90264 05858000 BNZ RTRN1 Oops @SC90264 05858500 B RTRN0 @SC90264 05859000 DSKDELP BAL 2,DSKLKPG Handle it @SC90264 05859500 BNZ RTRN1 Something was wrong @SC90264 05860000 B RTRN0 @SC90264 05860500 DSKDELT KCALL KFILIO,(3),E=RTRN1 @SC90264 05861000 B RTRN0 @SC90264 05861500 DSKDELD DS 0H @SC90264 05862000 BAL 2,DSKLKP See if it's there @SC90264 05862500 BNZ RTRN1 No, say error @SC90264 05863000 LA 0,4 Wait up to 3 sec @SC92126 05863100 BAL 9,DSKENQ @SC92126 05863200 B RTRN1 Can't get it now, give up @SC92126 05863300 TM TDDCTDT,TDINDTBM Intra-partition? @SC90264 05863500 BZ DSKDELDX No, shouldn't try to purge it @SC92126 05864000 EXEC CICS DELETEQ TD QUEUE(FABFNAM) NOHANDLE, @SC90264 05864500 BAL 14,DSKCHKER Test success @SC90264 05865000 B DSKDELDY @SC92126 05865080 DSKDELDX BAL 9,DSKTDOPE Close and open @SC92126 05865160 NOP 0 @SC92126 05865240 DSKDELDY BAL 9,DSKDEQ @SC92126 05865320 CLC F0,FABRESP See if succeeded @SC92126 05865400 BNZ RTRN1 Oops @SC90264 05865500 B RTRN0 @SC90264 05866000 * 05866500 * Rename file. R1-> name. R2-> new name. Returns R15=0 if ok. 05867000 DSKRNM DS 0H @SC89073 05867500 B RTRN1 05868000 * 05868500 * Copy file. R1-> name. R2-> new name. Returns R15=0 if ok. 05869000 DSKCPY DS 0H @SC89073 05869500 LR 6,1 Point to source file name @SC90264 05870000 LR 7,2 Point to new name @SC90264 05870500 NI FILFLGS,255-APPN Don't append @SC90264 05871000 OI FILFLGS,SVATT Use old attributes on output @SC90264 05871500 L 9,EMSGP Ptr to msg buffer @SC90264 05872000 INITSTR '&NOTFOUN',0(9) @SC92300 05872500 SR 15,9 @SC92300 05872700 ST 15,EMSGL Store length of string @SC92300 05872900 OPENF I,(6),FILFDB,FILPTR,E=DSKCPXX @SC90264 05873500 INITSTR '&TOOSHRT',0(9) @SC92300 05874000 SR 15,9 @SC92300 05874300 ST 15,EMSGL Store length of string @SC92300 05874600 POINTF FILPTR,IFOPTS-IFILE(6),E=DSKCPXX Skip if any @SC91150 05875000 INITSTR '&BADOUTF',0(9) @SC92300 05875500 SR 15,9 @SC92300 05875800 ST 15,EMSGL Store length of string @SC92300 05876100 LR 3,0 Pass input FDB to output @SC90264 05876500 OPENF O,(7),FDBD,DSKCPPTR,E=DSKCPXX @SC90264 05877000 LR 3,0 Point to output FAB @SC90264 05877500 DSKCPLP ICM 1,15,IFOPTS-IFILE(6) Get record counter @SC91150 05878000 AL 1,F1 @SC91150 05878500 STCM 1,15,IFOPTS-IFILE(6) Update record counter @SC91150 05879000 CLM 1,15,IFOPTS+4-IFILE(6) Passed end? @SC91150 05879500 BH DSKTYEOF Yes, quit now @SC91150 05880000 L 7,WBUF Point to data buffer @SC91150 05880500 READF FILPTR,BUFFER=(7),E=DSKTYP50 @SC91150 05881000 CLI FDBRCF,C'F' Fixed? @SC90264 05881500 BNE DSKCPWR No, just write what we got @SC90264 05882000 CH 0,FDBLRC Yes, see if correct length @SC90264 05882500 BE DSKCPWR Ok, do it @SC90264 05883000 LR 8,0 No, save actual length @SC90264 05883500 LH 0,FDBLRC Get correct length @SC90264 05884000 BH DSKCPWR Was too much, just truncate @SC90264 05884500 LR 9,0 @SC90264 05885000 SR 9,8 Was too little, get length to pad @SC90264 05885500 AR 8,7 @SC91150 05886000 SR 15,15 @SC90264 05886500 ICM 15,8,BLANK @SC90264 05887000 MVCL 8,14 @SC90264 05887500 DSKCPWR WRITF DSKCPPTR,BUFFER=(7),BSIZE=(0),E=DSKCPER @SC91150 05888000 B DSKCPLP @SC90264 05888500 * 05889000 * Type file. R1-> name. Returns R15=0 if ok. 05889500 * N.B. DSKCPPTR must be zero here to share code with DSKCPY @SC90264 05890000 DSKTYP DS 0H @SC89073 05890500 LR 6,1 Point to file name @SC90264 05891000 L 9,EMSGP Ptr to msg buffer @SC90264 05891500 INITSTR '&NOTFOUN',0(9) @SC92300 05892000 SR 15,9 @SC92300 05892300 ST 15,EMSGL Store length of string @SC92300 05892600 OPENF I,(6),FILFDB,FILPTR,E=DSKCPXX @SC90264 05893000 LR 3,0 Point to FAB @PG88335 05893500 INITSTR '&TOOSHRT',0(9) @SC92300 05894000 SR 15,9 @SC92300 05894300 ST 15,EMSGL Store length of string @SC92300 05894600 POINTF FILPTR,IFOPTS-IFILE(6),E=DSKCPXX Skip if any @SC91150 05895000 LH 1,FDBLRC @PG88335 05895500 CH 1,=H'130' Check record length !!! @PG88335 05896000 BL DSKTYP20 @PG88335 05896500 WTEXT '&ONLY130' @PG88335 05897000 DSKTYP20 ICM 1,15,IFOPTS-IFILE(6) Get record counter @SC91150 05897500 AL 1,F1 @SC91150 05898000 STCM 1,15,IFOPTS-IFILE(6) Update record counter @SC91150 05898500 CLM 1,15,IFOPTS+4-IFILE(6) Passed end? @SC91150 05899000 BH DSKTYEOF Yes, quit now @SC91150 05899500 L 3,RBUF Point to data buffer @SC91150 05900000 READF FILPTR,BUFFER=(3),E=DSKTYP50 @PG88335 05900500 CH 0,=H'130' Record too long ? @PG88335 05901000 BL DSKTYP30 @PG88335 05901500 LA 0,129 Yes, truncate... @PG88335 05902000 DSKTYP30 LTR 0,0 Is it null ? @PG88335 05902500 BNZ DSKTYP35 @PG88335 05903000 MVI 0(3),X'40' Then we must have at least @PG88335 05903500 LA 0,1 one character to output @PG88335 05904000 DSKTYP35 WTEXT (3) @PG88335 05904500 B DSKTYP20 @PG88335 05905000 DSKTYEOF L 15,F12 EOF code - hit end @SC91150 05905500 DSKTYP50 C 15,F12 EOF code ? @PG88335 05906000 LA 7,0 If so, no error @SC90264 05906500 BE DSKTYP70 @PG88335 05907000 DSKCPER ERRF , Analyze error code @SC90264 05907500 DSKCPXX LA 7,1 Set return code @SC90264 05908000 ICM 0,15,EMSGL Length of message @SC90264 05908500 BNP DSKTYP70 @SC90264 05909000 L 1,EMSGP @SC90264 05909500 WTEXT (1),(0) Show error message @SC90264 05910000 DSKTYP70 CLOSF FILPTR @PG88335 05910500 CLOSF DSKCPPTR @SC90264 05911000 LR 15,7 Copy return code @SC90264 05911500 B RTRN @SC90264 05912000 * 05912500 * Return on error, release useless block, if any 05913000 DSKER1A BAL 9,DSKDEQ Dequeue if enqueued @SC92126 05913200 DSKER1 LTR 1,4 Any block assigned? @SC86295 05913500 BZ RTRN1 No @SC86295 05914000 LA 0,FABDWDS Yes, release it @SC86295 05914500 DMSFRET DWORDS=(0),LOC=(4) @SC92126 05915000 B RTRN1 Flag error @SC86295 05915500 * 05916000 * Allocate new FAB and initialize with name at (R2) and with @SC90264 05916500 * FDB pattern at (R6); put name in DSKSTT; return FAB,FDB @SC90264 05917000 * ptrs to DISKIO caller as R0,R1; leave R3->FAB, R4->FAB, @SC90264 05917500 * R6->pattern; return via R9. @SC90264 05918000 DSKALC LR 6,1 Save FDB ptr @SC90264 05918500 MVC DSKSTNM,0(2) @SC86295 05919000 LA 0,FABDWDS Yes, release it @SC86295 05919500 DMSFREE DWORDS=(0),ERR=DSKER1 @SC86295 05920000 LR 3,1 New block ptr @SC86295 05920500 LA 4,FDBD FDB pointer @SC88120 05921000 RETREG (0,3),(1,4) Return (3) as R0, (4) as R1 @SC89218 05921500 LR 4,3 Indicate we have it @SC88120 05922000 XC 0(8*FABDWDS,3),0(3) @SC86295 05922500 MVC FDBD(FDBCOP),0(6) Copy user's FDB @SC90264 05923000 MVC FABFID,0(2) @SC90264 05923500 BR 9 @SC86295 05924000 * 05924500 * Look up file whose name is in FAB; return CC=Z if found. @SC90264 05925000 * Return via R2. Uses R0,R1,R8,R9,R14,R15. @SC90264 05925500 * Leaves DSKSECPL -> TDDCT or TSUTE or KFSBLK @SC90264 05926000 DSKLKP DS 0H @SC90264 05926500 TM FABFLGS,FABFTD TD queue? @SC90264 05927000 BO DSKLKPD Yes, do it @SC90264 05927500 TM FABFLGS,FABFPGM+FABFSPL Pipe? @SC90264 05928000 BNZ DSKLKPG Yes, do it @SC90264 05928500 TM FABFLGS,FABFTAK Internal file? @SC90264 05929000 BO DSKLKTK Yes, do it @SC90264 05929500 TM FABFLGS,FABFTS TS queue? @SC90264 05930000 BZ DSKLKNF No, something is wrong @SC90264 05930500 MVI FDBRCF,C'V' Enforce RECFM=V @SC91150 05931000 L 1,CSAPTR @NL90264 05931500 L 9,CSATSMTA-DFHCSABA(1) A(temp storage table) @NL90264 05932000 USING DFHTSUT,9 @SC90264 05932500 USING DFHTSUTE,1 @SC90264 05933000 DSKLKPSL LTR 9,9 @SC90264 05933500 BZ DSKLKNF Not found @SC90264 05934000 CLC TSUTCC,F0 Test for no entries @SC90264 05934500 BE DSKLKPSN @SC90264 05935000 L 1,TSUTAHI First on chain @SC90264 05935500 DSKLKPS1 CLC TSUTEID,FABFNAM Match? @SC90264 05936000 BE DSKLKSG Found it @SC90264 05936500 C 1,TSUTALI Any more on chain? @SC90264 05937000 BNL DSKLKPSN @SC90264 05937500 LA 1,TSUTELN(,1) Check next entry @SC90264 05938000 B DSKLKPS1 @SC90264 05938500 DSKLKPSN L 9,TSUTFC @SC90264 05939000 B DSKLKPSL @SC90264 05939500 DSKLKSG ST 1,DSKSECPL Ptr to TSUTE @SC90264 05940000 TM TSUTETC,TSUTEGID Is group id bit on? @ML90264 05940500 BO DSKLKFND Yes, all is well @SC90264 05941000 CLC FABCOMM(5),=CL8'OPEN I' @SC90264 05941500 BE DSKER1A Don't do it after all @SC92126 05942000 DSKLKFND CLR 2,2 Set CC=Z @SC90264 05942500 BR 2 @SC90264 05943000 DSKLKNF CLI *,0 Indicate error @SC90264 05943500 BR 2 @SC90264 05944000 DROP 1,9 @SC90264 05944500 DSKLKPD L 1,CSAPTR @SC90264 05945000 L DCTCBAR,CSADCTBA-DFHCSABA(,1) Start of DCT table@SC90264 05945500 DSKLKPL CLI TDDCTDID,254 Reached end? @SC90264 05946000 BHR 2 Yes, return CC=H @SC90264 05946500 CLC TDDCTDID,FABFNAM Found match? @SC90264 05947000 BE DSKLKDI Yes, verify contents @SC90264 05947500 AH DCTCBAR,TDDCTELN No, on to next item @SC90264 05948000 B DSKLKPL @SC90264 05948500 DSKLKDI ST DCTCBAR,DSKSECPL Ptr to DCT @SC90264 05949000 MVC FDBFL2,TDDCTDT Copy flags so we'll remember @SC91150 05949500 TM TDDCTDT,TDINDTBM INTRA? @SC90264 05950000 BZ DSKLKDX No, check EXTRA @SC90264 05950500 CLC TDDCTTQC,F0 Yes, any records in it? @SC90264 05951000 BE DSKLKNF None, say "not found" @SC90264 05951500 B DSKLKFND @SC90264 05952000 DSKLKDX TM TDDCTDT,TDEXTRBM EXTRA? @SC90264 05952500 MVI FDBRCF,C'V' Enforce RECFM=V if INTRA @SC91150 05953000 BZR 2 No, say "found" @SC90264 05953500 L 15,TDDCTSDS Ptr to SDSCI @SC90264 05954000 USING DCTSDSCI,15 @SC90264 05954500 MVC FDBXRCF,DCTSDSRF RECFM from extra TD @SC90264 05955000 MVC FDBXLRC,DCTSDSRL LRECL @SC90264 05955500 MVC FDBXBLK,DCTSDSBL BLKSI @SC90264 05956000 CLC FABCOMM(5),=CL8'OPEN I' @SC90264 05956500 BNE DSKLKDA Not going to open it @SC90264 05957000 OI FDBFLGS,SVATT Must observe predefined attrs @SC91150 05957500 LA 9,C'O' @SC90264 05958000 TM DCTSDSTF,DCTSDSOP Output? @SC90264 05958500 BO *+8 Yes @SC90264 05959000 LA 9,C'I' No, input @SC90264 05959500 CLM 9,1,FABCOMM+5 Does it match data set? @SC90264 05960000 BNE DSKER1A No, we're in trouble @SC92126 05960500 DSKLKDA TM DCTSDSTF,DCTSDSOP Output? @SC90264 05961000 BO DSKLKDO Yes, see if we want output @SC91269 05961500 LA 0,1 Don't wait @SC92126 05961600 BAL 9,DSKENQ @SC92126 05961700 B DSKLKFND Can't get it now, say it exists @SC92126 05961800 BAL 9,DSKTDOPE @SC90264 05962000 B DSKLKDD Failed, say it's not there @SC92126 05962500 EXEC CICS READQ TD QUEUE(FABFNAM) SET(1), @SC90264+05963000 LENGTH(FABNORD) NOHANDLE, @SC90264 05963500 BAL 14,DSKCHKER Test success @SC90264 05964000 BAL 9,DSKDEQ @SC92126 05964100 CLC F0,FABRESP Was the READQ Ok? @SC92126 05964200 BR 2 Return indication @SC90264 05964500 DSKLKDD BAL 9,DSKDEQ Dequeue now @SC92126 05964530 B DSKLKNF and say it's not there @SC92126 05964560 DSKLKDO CLC FABCOMM,=CL8'VERIFY' Looking for input file? @SC91269 05964600 BE DSKLKNF Yes, say it's not there after all @SC91269 05964700 B DSKLKFND No, admit it's there @SC91269 05964800 * Handle internal file @SC90264 05965000 DSKLKTK KCALL KFLLKP,(3) @SC90264 05965500 ST 1,DSKSECPL Ptr to KFS block @SC90264 05966000 LTR 15,15 @SC90264 05966500 BR 2 @SC90264 05967000 * Handle pipe (also called by other disk operations) @SC90264 05967500 DSKLKPG LA 8,FABFNAM Point to pgm in FAB @SC90264 05968000 TM FABFLGS,FABFPGM General pipe? @SC90264 05968500 BO *+8 Yes, use that @SC90264 05969000 LA 8,=CL8'IKXDYNAL' @SC90264 05969500 ICM 9,15,=A(KHOST) @SC90264 05970000 BZ DSKLKPGX @SC90264 05970500 LR 14,8 @SC90264 05971000 LR 15,3 String address @SC90264 05971500 LA 0,DSKFABLN Ptr to length @SC90264 05972000 STM 14,0,DSKSECPL Set up calling sequence @SC90264 05972500 KCALL (9),DSKSECPL,EXT,E=0(,2) @SC90264 05973000 DSKLKPGX CLC =CL8'IKXDYNAL',0(8) @SC90264 05973500 BNE DSKLKPGZ General pipe @SC90264 05974000 TM DSKFL,PLOAD Pgm loaded? @SC90264 05974500 BO DSKLKPGZ Yes, we're all set @SC90264 05975000 OI DSKFL,PLOAD Mark pgm loaded @SC90264 05975500 DSKLKPGY EXEC CICS LOAD PROGRAM(0(,8)) NOHANDLE, @SC90264 05976000 DSKLKPGZ EXEC CICS LINK PROGRAM(0(,8)) COMMAREA(0(,3)), @SC90264+05976500 LENGTH(DSKFABLN+2) NOHANDLE, @SC90264 05977000 L 15,DFHEIBP Set up to copy EIB code @SC90264 05977500 USING DFHEIBLK,15 @SC90264 05978000 CLC F0,EIBRCODE Did the LINK work? @SC90264 05978500 BE *+10 Yes @SC90264 05979000 MVC FABRESP,EIBRCODE No, save error code @SC90264 05979500 DROP 15 @SC90264 05980000 CLC F0,FABRESP Did the operation work? @SC90264 05980500 BR 2 @SC90264 05981000 * 05981500 * Set up search through list of files, pattern at (R1) 05982000 DSKNSET DS 0H @SC89073 05982500 MVC NXDEST,0(1) @SC90264 05983000 TM 0(1),FABFTS+FABFTD TS and TD are in memory @SC90264 05983500 BNZ DSKNSX Go scan list @SC90264 05984000 TM 0(1),FABFTAK @SC90264 05984500 BZ DSKNSWLD Not one of the types in memory @SC90264 05985000 CLC CURFUID,1(1) TAKE in memory only if current @SC90264 05985500 BE DSKNSX Yes, go scan list @SC90264 05986000 DSKNSWLD DS 0H @SC90264 05986500 MVI TRTBL+C'%',1 Want to catch a percent @SC86115 05987000 MVI TRTBL+C'*',1 Want to catch an asterisk @SC86115 05987500 TRT LFUID+1(LFFNM,1),TRTBL See if anything wild @SC90264 05988000 MVI TRTBL+C'%',0 Restore TRTBL @SC86115 05988500 MVI TRTBL+C'*',0 @SC86115 05989000 BZ DSKNSX No wild chars found, ok @SC90264 05989500 CLI 0(1),C' ' Did we just run off the end? @SC90264 05990000 BNE RTRN1 Wild char. Can't handle for TS @SC90264 05990500 * 05991000 * Flush previous file pattern 05991500 DSKNSX MVC NXPTR,=X'80000000' @SC90264 05992000 L 9,NXPTR2 @SC91150 05992500 DSKNSX1 LTR 9,9 @SC91150 05993000 BZ RTRN0 No more blocks @SC91150 05993500 L 9,TSUTFC-DFHTSUT(,9) @SC91150 05994000 L 6,NXPTR2 Free old fake block @SC91150 05994500 EXEC CICS FREEMAIN DATA(0(,6)), @SC91150 05995000 ST 9,NXPTR2 Reset ptr to current block @SC91150 05995500 B DSKNSX1 @SC91150 05996000 * 05996500 * Check CWD string, return code in R15 05997000 DSKCWDF DS 0H @SC89073 05997500 LA 3,DSKSTT @SC90264 05998000 MVC FABFID,0(1) Copy as much as possible of string@SC90264 05998500 MVC FABCOMM,=CL8'CWD' @SC90264 05999000 BAL 2,DSKVALID Check if allowed @SC90264 05999500 CLI FABFID+2,C'''' DSN? @SC90264 06000000 BE RTRN0 Yes, it can be anything @SC90264 06000500 LA 0,LFUID No, must be userid @SC90264 06001000 CLM 0,3,FABFID Is it the right length? @SC90264 06001500 BL RTRN1 Too long, reject it @SC90264 06002000 B RTRN0 Ok @SC90264 06002500 * 06003000 * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6) 06003500 DSKTSP L 4,FDBSIZE-FDBD(,1) Get actual size @SC92024 06004000 ICM 3,15,0(6) Get FAB ptr @SC90037 06004500 BZ DSKTSPX Not open yet @SC90037 06005000 DSKTSP0 DS 0H @SC90037 06005500 TM FABFLGS,FABFTAK Internal file? @SC90264 06006000 BZ RTRN0 No, can't say how much room @SC90264 06006500 CLC FABFUID,CURFUID Current directory? @SC90264 06007000 BNE RTRN0 No, don't know about them @SC90264 06007500 CLC FABFUID,SYSUID Global directory? @SC90264 06008000 BE RTRN0 Yes, don't limit that @SC90264 06008500 L 1,LIMKFS Total allowed @SC90264 06009000 SL 1,USRTOTL Amount already used @SC90264 06009500 SRL 1,10 Convert to Kbytes @SC86316 06010000 CLR 1,4 @SC92024 06010500 BL RTRN1 No room @SC86316 06011000 B RTRN0 Ok @SC86316 06011500 DSKTSPX MVC DSKSTNM,0(2) File not opened yet, look for it @SC90037 06012000 LA 3,DSKSTT Point to temporary FAB @SC90037 06012500 MVC FABCOMM,=CL8'TEST' @SC90264 06013000 BAL 2,DSKLKP @SC90037 06013500 BNZ DSKTSP0 Not found, nothing to erase @SC90037 06014000 MVC FDBSIZE,F0 Clear out old size, if any @SC90264 06014500 BAL 14,DSKVALS Compute size, if possible @SC90264 06015000 S 4,FDBSIZE Assume old file will be erased @SC92024 06015500 BNP RTRN0 Will release enough for new file @SC90037 06016500 B DSKTSP0 Not enough, check free blocks @SC90037 06017000 * 06017500 DSKNXT DS 0H @SC89073 06018000 XC DSKFDB,DSKFDB Clear out info @SC90264 06018500 MVC FILNAM,NXDEST Set up full fid @SC90264 06019000 LA 1,NXDEST Ptr to pattern with flags @SC90264 06019500 ST 1,DSKSECPL+4 Set up call to KHIDE @SC90264 06020000 L 9,NXPTR2 For TS chains @SC90264 06020500 ICM 1,15,NXPTR Current ptr @SC90264 06021000 BP NXFNEXT Already started, get next @SC90264 06021500 BZ RTRN1 Nothing else there @SC90264 06022000 MVI NXPTR,0 Clear to 0, in case "other" @SC90264 06022500 NI DSKFL,255-WFN Nothing wild yet @SC90264 06023000 L 1,CSAPTR Access CSA @SC90264 06023500 * Set up for scan of specific kind of file... @SC90264 06024000 TM NXDEST,FABFTS Is it a TS? @SC90264 06024500 BZ DSKNXTTD @SC90264 06025000 USING DFHTSUT,2 @SC91150 06025500 L 2,CSATSMTA-DFHCSABA(,1) Start of TS chain @SC91150 06026000 LA 9,NXPTR2+DFHTSUT-TSUTFC Start of fake chain @SC91150 06026500 DSKNXTS0 LH 6,TSUTCC @SC91150 06027000 LTR 6,6 Any entries in this block? @SC91150 06027500 BZ DSKNXTS9 No @SC91150 06028000 LA 1,TSUTELN Length of each entry @SC91150 06028500 MR 0,6 Compute size needed @SC91150 06029000 LA 1,TSUTEBA-DFHTSUT(,1) (including control offset@SC91150 06029500 ST 1,GTMLEN @SC91150 06030000 EXEC CICS GETMAIN FLENGTH(GTMLEN) SET(1), Get block @SC91150 06030500 L 7,TSUTAHI Start of real list @SC91150 06031000 DROP 2 @SC91150 06031500 USING DFHTSUT,9 @SC91150 06032000 ST 1,TSUTFC Add fake block to fake chain @SC91150 06032500 LR 9,1 Now address new block @SC91150 06033000 XC TSUTFC,TSUTFC Clear next forward ptr @SC91150 06033500 LA 1,TSUTEBA @SC91150 06034000 ST 1,TSUTAHI Start of fake list @SC91150 06034500 STH 6,TSUTCC Set number of entries @SC91150 06035000 DSKNXTS1 MVC 0(TSUTELN,1),0(7) Copy one entry from real list@SC91150 06035500 ST 1,TSUTALI Save as if last @SC91150 06036000 LA 1,TSUTELN(,1) @SC91150 06036500 LA 7,TSUTELN(,7) @SC91150 06037000 BCT 6,DSKNXTS1 Keep copying until done @SC91150 06037500 DROP 9 @SC91150 06038000 USING DFHTSUT,2 @SC91150 06038500 DSKNXTS9 L 2,TSUTFC See if another block @SC91150 06039000 LTR 2,2 @SC91150 06039500 BNZ DSKNXTS0 Yes, copy it as well @SC91150 06040000 DROP 2 @SC91150 06040500 LA 7,8-1 Length of TS name @SC90264 06041000 * MVC NXPTR2,CSATSMTA-DFHCSABA(1) Temp storage table@SC91150 06041500 B DSKNXT1 @SC90264 06042000 DSKNXTTD TM NXDEST,FABFTD Is it a TD? @SC90264 06042500 BZ DSKNXTTT Other @SC90264 06043000 LA 7,4-1 @SC90264 06043500 MVC NXPTR,CSADCTBA-DFHCSABA(1) Start of DCT table @SC90264 06044000 B DSKNXT1 @SC90264 06044500 DSKNXTTT TM NXDEST,FABFTAK Is it internal? @SC90264 06045000 BZ DSKNXTTO Other @SC90264 06045500 CLC CURFUID,NXDEST+1 TAKE in memory only if current @SC90264 06046000 BNE DSKNXTTO Not current, must look up @SC90264 06046500 LA 7,8-1 @SC91150 06047000 MVC NXPTR,PTRKFS Start of internal chain @SC90264 06047500 * Setup for scan: R7=length-1 of name field, NXPTR initialized @SC90264 06048000 DSKNXT1 LA 6,NXDNAM Start of name per se @SC90264 06048500 LA 1,1(7,6) End of field @SC90264 06049000 EX 7,NXFWTR Find first blank @SC90264 06049500 SR 1,6 Compute length @SC86295 06050000 ST 1,NXFFNL Length of pattern @SC90264 06050500 MVI TRTBL+C' ',0 Don't want to catch a blank @SC86115 06051000 MVI TRTBL+C'%',1 Want to catch a percent @SC86115 06051500 MVI TRTBL+C'*',1 Want to catch an asterisk @SC86115 06052000 EX 7,NXFWTR See if any % or * in name @SC90264 06052500 MVI TRTBL+C'%',0 Restore TRTBL @SC86115 06053000 MVI TRTBL+C'*',0 @SC86115 06053500 MVI TRTBL+C' ',1 @SC86115 06054000 BZ *+8 No wild chars found @SC86295 06054500 OI DSKFL,WFN @SC86295 06055000 L 1,NXPTR @SC90264 06055500 L 9,NXPTR2 For TS chains @SC90264 06056000 NXFNEXT TM NXDEST,FABFTS Is it a TS? @SC90264 06056500 BO NXFNXTS Yes, follow chains @SC90264 06057000 TM NXDEST,FABFTAK Is it internal? @SC90264 06057500 BO NXFNXTT Yes, follow chains @SC90264 06058000 * Advance to next TD block and setup R6,R7 @SC90264 06058500 LR DCTCBAR,1 Point to next item @SC90264 06059000 CLI TDDCTDID,255 Reached end? @SC90264 06059500 BE RTRN1 Yes, quit @SC90264 06060000 ST 1,DSKSECPL Ptr to DCT @SC90264 06060500 AH 1,TDDCTELN No match, keep at it @NL90264 06061000 LA 6,TDDCTDID Start of field @SC90264 06061500 LA 7,4-1 Length of field @SC90264 06062000 B NXFCHK Now compare names @SC90264 06062500 * Advance to next internal file and setup R6,R7 @SC90264 06063000 USING KFSBLK,9 @SC90264 06063500 NXFNXTT LTR 9,1 Reached end? @SC90264 06064000 BZ RTRN1 Yes, quit @SC90264 06064500 ST 1,DSKSECPL Ptr to KFS block @SC90264 06065000 L 1,KFSNEXT Ptr to next one @NL90264 06065500 LA 6,KFSFNAM Start of field @SC90264 06066000 LA 7,8-1 Length of field @SC90264 06066500 NXFCHK ST 1,NXPTR Save the ptr for the next @SC90264 06067000 STM 6,7,DSKCURN Save ptr,len-1 of current name @SC90264 06067500 TM DSKFL,WFN @SC86295 06068000 BO NXFWF Go if wild @SC86295 06068500 CLC 0(,6),NXDNAM @SC90264 06069000 EX 7,*-6 Compare name @SC90264 06069500 BNE NXFNEXT Keep trying @SC90264 06070000 NXFHAVE LA 14,FILNAM+LFUID+1 @SC90264 06070500 LA 15,LFFNM Length of name part @SC90264 06071000 LM 6,7,DSKCURN Get ptr,len-1 @SC90264 06071500 LA 7,1(,7) Convert to length @SC90264 06072000 ICM 7,8,BLANK @SC90264 06072500 MVCL 14,6 Copy to FILNAM with blank padding @SC90264 06073000 MVC DSKSTNM,FILNAM @SC90264 06073500 LA 3,DSKSTT @SC86295 06074000 TM FABFLGS,FABFTD TD queue? @SC91150 06074500 BZ NXFHVAL No, we're fine @SC91150 06075000 TM TDDCTDT,TDEXTRBM EXTRA? @SC91150 06075500 BZ NXFHVAL No, we're fine @SC91150 06076000 L 15,TDDCTSDS Ptr to SDSCI @SC91150 06076500 USING DCTSDSCI,15 @SC91150 06077000 MVC FDBXRCF,DCTSDSRF RECFM from extra TD @SC91150 06077500 MVC FDBXLRC,DCTSDSRL LRECL @SC91150 06078000 MVC FDBXBLK,DCTSDSBL BLKSI @SC91150 06078500 DROP 15 @SC91150 06079000 NXFHVAL DS 0H @SC91150 06079500 BAL 14,DSKVALS Copy out quantities @SC86295 06080000 B RTRN0 @SC86295 06080500 DSKNXTTO MVC DSKSTNM,FILNAM Other types: just do one @SC90264 06081000 LA 3,DSKSTT @SC86295 06081500 MVC FABCOMM,=CL8'VERIFY' @SC91269 06082000 BAL 2,DSKLKP Can't scan blocks, must look up @SC90264 06082500 BNZ RTRN1 File not found @SC90264 06083000 BAL 14,DSKVALS Copy out quantities @SC86295 06083500 B RTRN0 @SC86295 06084000 * Advance to next TS block and setup R6,R7 @SC90264 06084500 USING DFHTSUT,9 @SC90264 06085000 USING DFHTSUTE,1 @SC90264 06085500 NXFNXTS LTR 1,1 @SC90264 06086000 BNP NXFNXTSL @SC90264 06086500 C 1,TSUTALI Any more on chain? @SC90264 06087000 BNL NXFNXTSN @SC90264 06087500 LA 1,TSUTELN(,1) Check next entry @SC90264 06088000 NXFNXTS1 TM TSUTETC,TSUTEGID Is group id bit on? @ML90264 06088500 BZ NXFNXTS No, skip this one @SC90264 06089000 LA 6,TSUTEID @SC90264 06089500 LA 7,8-1 @SC90264 06090000 ST 1,DSKSECPL Ptr to TSUTE @SC90264 06090500 B NXFCHK @SC90264 06091000 NXFNXTSN L 9,TSUTFC @SC90264 06091500 L 6,NXPTR2 Free old fake block @SC91150 06092000 EXEC CICS FREEMAIN DATA(0(,6)), @SC91150 06092500 ST 9,NXPTR2 @SC90264 06093000 NXFNXTSL MVC NXPTR,F0 @SC90264 06093500 LTR 9,9 @SC90264 06094000 BZ RTRN1 Not found @SC90264 06094500 CLC TSUTCC,F0 Test for no entries @SC90264 06095000 BE NXFNXTSN @SC90264 06095500 L 1,TSUTAHI First on chain @SC90264 06096000 B NXFNXTS1 @SC90264 06096500 DROP 1,9 @SC90264 06097000 * 06097500 NXFWTR TRT 0(,6),TRTBL Look for first blank @SC90264 06098000 NXFWF ICM 15,15,=A(KHIDE) Check for secret names? @SC90264 06098500 BZ NXFWF2 Not needed @SC90264 06099000 KCALL (15),DSKSECPL,EXT See if it's allowed @SC90264 06099500 L 1,NXPTR Restore R1 @SC90264 06100000 BNZ NXFNEXT Skip it if not @SC90264 06100500 NXFWF2 LA 1,1(7,6) End of field @SC90264 06101000 EX 7,NXFWTR Find first blank @SC90264 06101500 SR 1,6 Compute length @SC86295 06102000 LR 7,1 Save length @SC86295 06102500 LA 14,NXDNAM Start of name per se @SC90264 06103000 L 15,NXFFNL Length of pattern @SC90264 06103500 L 1,NXPTR Restore ptr to next block @SC90264 06104000 * 06104500 * Enter here: R14,R15 contain the pattern address and length @SC90264 06105000 * and R6,R7 the source address and length @SC90264 06105500 * No other registers are used @SC90264 06106000 NI DSKFL,255-WARB Haven't seen any of these @SC86295 06106500 ICM 7,8,=C'*' Use * as the fill char 06107000 WLDLOOP CLCL 14,6 Compare them @SC90264 06107500 BE NXFHAVE They're equal, fine @SC86295 06108000 * 06108500 * String mismatch - so examine offending pattern character. If not 06109000 * % or * and we haven't seen any * yet, we fail. If it's % we just 06109500 * skip it; if it's * we skip it and remember we've seen it. Else 06110000 * back up to one past the last * and try again. 06110500 CLI 0(14),C'%' @SC90264 06111000 BE WLDLEN1 Go if % = LEN(1) pattern 06111500 CLI 0(14),C'*' @SC90264 06112000 BE WLDARB Go if * = ARB pattern 06112500 TM DSKFL,WARB @SC86295 06113000 BZ NXFNEXT Go if ARB already seen @SC86295 06113500 CLM 7,7,F0 More data to compare? 06114000 BE NXFNEXT Go if exhausted @SC86295 06114500 LM 14,15,WLDPAT Restore addr of old ARB char @SC90264 06115000 LM 6,7,WLDSRC Restore source addr too @SC90264 06115500 LA 6,1(,6) Push one past @SC90264 06116000 BCTR 7,0 Decrement length 06116500 STM 6,7,WLDSRC Store changed addr 06117000 B WLDLOOP And go compare again. 06117500 * 06118000 WLDLEN1 LA 14,1(,14) Increment pattern addr @SC90264 06118500 BCTR 15,0 Decrement pattern len @SC90264 06119000 CLM 7,7,F0 Length to compare more @SC86119 06119500 BE NXFNEXT None, pattern '%' is extra @SC86119 06120000 LA 6,1(,6) Increment source addr @SC90264 06120500 BCTR 7,0 Decrement source len 06121000 CLM 7,7,F0 Length to compare more @SC86119 06121500 BNE WLDLOOP Go if more data 06122000 LTR 15,15 Anything more in pattern? @SC90264 06122500 BZ NXFHAVE No, it's a match @SC86295 06123000 CLI 0(14),C'*' @SC90264 06123500 BE WLDLOOP Go if ARB 06124000 B NXFNEXT Failed @SC86295 06124500 * 06125000 * If pattern ends in ARB, then it will match anything. So return to 06125500 * caller if the pattern is exhausted. 06126000 WLDARB OI DSKFL,WARB Remember we saw one @SC86295 06126500 LA 14,1(,14) Pass the ARB @SC90264 06127000 BCTR 15,0 Decrement its length @SC90264 06127500 LTR 15,15 Any more left? @SC90264 06128000 BZ NXFHAVE No, it's a match @SC86295 06128500 STM 14,15,WLDPAT Save pattern ptrs @SC90264 06129000 STM 6,7,WLDSRC Save source ptrs @SC90264 06129500 B WLDLOOP 06130000 * 06130500 * Fill in FDB from DCT or TSUTE or KFSBLK (ptr in DSKSECPL) @SC90264 06131000 * Clobbers 0,1,2,6,7,8,15. Returns via 14. (note DCTCBAR=8) @SC90264 06131500 DSKVALS LA 0,FDBD Ptr to FDB @SC86295 06132000 RETREG (1,0) Return (0) as R1 to caller @SC89218 06132500 MVI FDBRCF,C'V' Usually V @SC90264 06133000 L 1,FDBBSIZ Use max length by default @SC90264 06133500 TM FABFLGS,FABFTS @SC90264 06134000 BZ DSKVLTT Not temp stor @SC90264 06134500 L 15,DSKSECPL Ptr to TSUTE @SC90264 06135000 USING DFHTSUTE,15 @SC90264 06135500 MVC TMPDW+7(1),TSUTETC Save flags @SC90264 06136000 L 15,TSUTEPTR Ptr to TSGID @SC90264 06136500 USING DFHTSGID,15 @SC90264 06137000 MVC FDBNREC,TSGIDTR Grab record count @SC90264 06137500 TM TMPDW+7,TSUTEASI+TSUTEVSI @SC90264 06138000 BZ DSKVLR Neither main nor aux? @SC90264 06138500 SR 0,0 @SC90264 06139000 ST 0,TMPDW @SC90264 06139500 SR 6,6 Clear tentative LRECL @SC91150 06140000 DSKVLSLP LH 2,KTSGIDNE Number of entries/block @SC91150 06140500 LA 7,TSGIDEBA Start of record ptrs @SC90264 06141000 DSKVLSLQ MVC TMPDW+3(1),3(7) Copy segment count @SC90264 06141500 TM TMPDW+7,TSUTEASI AUX? @SC90264 06142000 BO DSKVLSA Yes, use segment count @SC90264 06142500 TM 0(7),X'7F' No. Above the 16M line? @SC91150 06143000 BNZ DSKVLR Yes, can't calculate @SC91150 06143500 ICM 8,7,1(7) Ok, get ptr to record block @SC91150 06144000 BZ DSKVLSB No more ptrs, just round off @SC91150 06144500 MVC TMPDW+2(2),20(8) Grab length of record @SC91150 06145000 DSKVLSA A 0,TMPDW Accumulate total in R0 @SC90264 06145500 C 6,TMPDW Get maximum record size @SC91150 06146000 BNL *+8 @SC91150 06146500 L 6,TMPDW New maximum @SC91150 06147000 LA 7,4(,7) @SC90264 06147500 BCT 2,DSKVLSLQ @SC90264 06148000 ICM 15,15,TSGIDFC Next group of records @SC90264 06148500 BNZ DSKVLSLP @SC90264 06149000 TM TMPDW+7,TSUTEASI AUX? @SC90264 06149500 BZ DSKVLSB No, use byte count as is @SC90264 06150000 IC 15,KTSBPSEG Log(seg size) @SC91150 06150500 SLL 0,0(15) Convert segments to bytes @SC90264 06151000 SLL 6,0(15) Ditto for max record length @SC91150 06151500 DSKVLSB AL 0,=F'512' Round up @SC90264 06152000 SRL 0,10 Convert to Kbytes @SC90264 06152500 ST 0,FDBSIZE @SC90264 06153000 LR 1,6 Use observed max length for LRECL @SC91150 06153500 B DSKVLR @SC90264 06154000 DSKVLTT TM FABFLGS,FABFTAK @SC90264 06154500 BZ DSKVLTD Not internal file @SC90264 06155000 L 15,DSKSECPL Ptr to KFSBLK @SC90264 06155500 USING KFSBLK,15 @SC90264 06156000 LH 1,KFSLRC Use actual LRECL @SC90264 06156500 MVC FDBNREC,KFSNREC Grab record count @SC90264 06157000 MVC FDBDATE,KFSDATE Copy date/time @SC90264 06157500 L 0,KFSSIZE Get file size in bytes @SC90264 06158000 AL 0,=F'512' Round up @SC90264 06158500 SRL 0,10 Convert to Kbytes @SC90264 06159000 ST 0,FDBSIZE Copy to FDB @SC90264 06159500 B DSKVLR @SC90264 06160000 DROP 15 @SC91150 06160500 DSKVLTD DS 0H @SC90264 06161000 TM FABFLGS,FABFSPL @SC90264 06161500 BO DSKVLTX2 Spool file, use FDBX info @SC90264 06162000 TM FABFLGS,FABFTD @SC90264 06162500 BZ DSKVLR Other @SC90264 06163000 L DCTCBAR,DSKSECPL Ptr to info @SC90264 06163500 MVC FDBFL2,TDDCTDT Copy flags @SC90264 06164000 XC FDBSIZE,FDBSIZE Clear size (unknown) @SC90264 06164500 TM FDBFL2,TDINDTBM Intra? @SC90264 06165000 BZ DSKVLTX No, see if Extra @SC90264 06165500 MVC FDBNREC,TDDCTTQC+2 Yes, grab record count @SC91150 06166000 B DSKVLR Ok, we're done @SC90264 06166500 DSKVLTX DS 0H @SC90264 06167000 TM FDBFL2,TDEXTRBM Extra? @SC90264 06167500 BNO DSKVLR No @SC90264 06168000 DSKVLTX2 MVI FDBRCF,C'U' @SC86299 06168500 LH 1,FDBXBLK Use BLKSI if U @SC90264 06169000 TM FDBXRCF,X'C0' @SC90264 06169500 BO DSKVLR @SC86299 06170000 LH 1,FDBXLRC Use LRECL if F or V @SC90264 06170500 LTR 1,1 Make sure it's defined @SC91150 06171000 BP *+8 Yes, ok @SC91150 06171500 LH 1,FDBLRC No, keep old LRECL @SC91150 06172000 MVI FDBRCF,C'F' @SC86299 06172500 TM FDBXRCF,X'80' @SC90264 06173000 BO DSKVLR @SC86299 06173500 MVI FDBRCF,C'V' @SC86299 06174000 DSKVLR STH 1,FDBLRC @SC86299 06174500 L 7,4(13) Get previous stack frame @SC88048 06175000 L 1,4(7) and the one before @SC88076 06175500 CLC =A(SERVER),16(1) Was the caller SERVER? @SC89215 06176000 BE *+12 Yes, ok @SC88076 06176500 CLC =A(USNTRF),16(1) No, was it USNTRF? @SC89215 06177000 BNER 14 No, don't bother checking TAKE's @SC88076 06177500 USING SERVERSV,7 Assume SERVER or USNTRF @SC88048 06178000 ICM 0,15,TAKLEV Any TAKE files open? @SC88048 06178500 BNPR 14 No, that's fine @SC88048 06179000 CH 0,=Y(TAKMAX) Be sure this is valid @SC88048 06179500 BNLR 14 Oops, give up @SC88048 06180000 DSKVACT LR 6,0 @SC88048 06180500 SLA 6,2 @SC88048 06181000 L 6,TAKTAB-4(6) Fetch a file ticket @SC88048 06181500 CLC FABFID,FABFID-FABD(6) Does the name match? @SC88048 06182000 BE DSKVACS Yes, this file is in use @SC88048 06182500 BCT 0,DSKVACT No, keep looking @SC88048 06183000 BR 14 No match, that's ok @SC88048 06183500 DSKVACS OI FDBFLGS,FDBACTV Yes, turn on flag @SC88048 06184000 BR 14 @SC86295 06184500 DROP 7 @SC91150 06185000 * 06185500 DROP 3,5,DCTCBAR @SC91150 06186000 * 06186500 DSKFABLN DC A(FABDWDS*8) Length of FAB @SC90264 06187000 LOCALS , @SC86295 06187500 DSKEMTS DS 0CL15'SET Q( ) CLO' @ML90264 06188000 WLDPAT DS A Place in pattern of last ARB 06188500 DS F Length of pattern past ARB 06189000 WLDSRC DS A Place in source when ARB seen 06189500 DS F Length of source past WLDSRC 06190000 DSKCPPTR DS 0A Ticket for COPY output @SC90264 06190500 NUMPAT DS CL8 Work area for sequence numbers @SC90264 06191000 DSKSECPL DS 3A Plist for KHIDE or KHOST @SC90264 06191500 DSKCURN DS 2F Saved ptrs during DIR scan @SC90264 06192000 DSKENQCT DS H Count of seconds allowed to wait @SC92126 06192200 DSKCOD DS X Saved DISKIO function code @SC90264 06192500 DSKQUE DS CL4,C'.TD' ENQ resource name @SC92126 06192700 * 06193000 EXIT 06193500 TITLE 'KFILIO Routine - performs disk I/O functions' @SC90264 06194000 * ERRNUM unchanged unless there is a disk error. @SC90264 06194500 * Function selected on entry by FABCOMM (pointed to by R1) @SC90264 06195000 KFILIO ENTER , @SC90264 06195500 USING FABD,3 @SC90264 06196000 USING KFSBLK,4 @SC90264 06196500 USING DFHEIBLK,8 @SC90264 06197000 L 8,DFHEIBP Get addressability @SC90264 06197500 LR 3,1 @SC90264 06198000 XC FABRESP,FABRESP Clear error code @SC90264 06198500 LH 1,FABRN Convert rec no for key @SC90264 06199000 CVD 1,KFLDW @SC90264 06199500 OI KFLDW+7,15 @SC90264 06200000 UNPK KFLRN,KFLDW @SC90264 06200500 MVC KFLFUID(LFUID+LFFNM),FABFUID Copy name for key @SC90264 06201000 LM 6,7,FDBBUFF Adr and len of buffer @SC90264 06201500 STH 7,FABNORD Set up for read/write @SC90264 06202000 L 4,FABUWORD Ptr to KFSBLK @SC90264 06202500 * Read a record @SC90264 06203000 CLC =C'READ',FABCOMM @SC90264 06203500 BNE KFLWRT @SC90264 06204000 EXEC CICS READ DATASET(KFILE) RIDFLD(KFLFUID), @SC90264+06204500 INTO(0(,6)) LENGTH(FABNORD) NOHANDLE, @SC90264 06205000 CLC F0,EIBRCODE Any error? @SC90264 06205500 BNE KFLRDX Yes, note it @SC90264 06206000 LA 1,LFKEY Length of key @SC90264 06206500 LH 7,FABNORD Actual read length @SC90264 06207000 SR 7,1 Deduct @SC90264 06207500 STH 7,FABNORD Data length @SC90264 06208000 LA 0,0(1,6) Start of real data @SC90264 06208500 LR 1,7 @SC90264 06209000 MVCL 6,0 Move everything back @SC90264 06209500 B RTRN0 @SC90264 06210000 KFLRDX MVC FABRESP,EIBRCODE @SC90264 06210500 B RTRN1 @SC90264 06211000 * Write a record @SC90264 06211500 KFLWRT CLC =C'WRITE',FABCOMM @SC90264 06212000 BNE KFLDEL @SC90264 06212500 LR 0,7 Length of record @SC90264 06213000 AL 0,KFSSIZE Accumulate file size @SC90264 06213500 BC 12,*+8 @SC90264 06214000 SR 0,0 @SC90264 06214500 BCTR 0,0 Set to max if carry @SC90264 06215000 ST 0,KFSSIZE New size @SC90264 06215500 CH 7,KFSLRC Check for max lrecl @SC90264 06216000 BNH *+8 @SC90264 06216500 STH 7,KFSLRC New max lrecl @SC90264 06217000 *------------------------- Quota checking ------------ @SC90264 06217500 CLC FABFUID,CURFUID Current userid? @SC90264 06218000 BNE KFLWRT1 No, assume it's ok @SC90264 06218500 CLC FABFUID,SYSUID Global directory? @SC90264 06219000 BE KFLWRT1 Yes, never limit that @SC90264 06219500 AL 0,USRTOTL Get new total assuming success @SC90264 06220000 BC 3,KFLWRX Way too big @SC90264 06220500 CL 0,CUTKFS See if over cutoff limit @SC90264 06221000 BC 3,KFLWRX Yes, too big @SC90264 06221500 *------------------------- @SC90264 06222000 KFLWRT1 LA 1,LFKEY Length of key @SC90264 06222500 AR 7,1 @SC90264 06223000 STH 7,FABNORD Increase length @SC90264 06223500 SR 6,1 And back up start of buffer @SC90264 06224000 MVC 0(LFKEY,6),KFLFUID Copy key into data buffer @SC90264 06224500 KFLWRT2 EXEC CICS WRITE DATASET(KFILE) RIDFLD(KFLFUID), @SC90264+06225000 FROM(0(,6)) LENGTH(FABNORD) NOHANDLE, @SC90264 06225500 CLC F0,EIBRCODE Any error? @SC90264 06226000 BE RTRN0 @SC90264 06226500 MVC FABRESP,EIBRCODE @SC90264 06227000 B RTRN1 @SC90264 06227500 * 06228000 KFLWRX MVI FABRESP,X'83' Say it was NOSPACE @SC90264 06228500 B RTRN1 @SC90264 06229000 * Delete a file @SC90264 06229500 KFLDEL CLC =C'DELETE',FABCOMM @SC90264 06230000 BNE KFLCLO @SC90264 06230500 MVC FABUWORD,F0 Will no longer have KFSBLK @SC90264 06231000 ICM 4,15,TMPBLK Check saved temporary @SC91150 06231500 BZ KFLDEL0 None set @SC91150 06232000 CLC FABFUID(LFUID+LFFNM),KFSFUID Are we killing it? @SC91150 06232500 BNE KFLDEL0 No, fine @SC91150 06233000 MVI KFSFUID,0 Yes, disable that block @SC91150 06233500 KFLDEL0 DS 0H @SC91150 06234000 CLC FABFUID,CURFUID Current directory? @SC90264 06234500 BNE KFLDEL1 No, skip bookkeeping @SC90264 06235000 KCALL KFLLKP,(3),E=RTRN1 Find KFS block @SC90264 06235500 LR 4,1 Get ptr for addressability @SC90264 06236000 MVC FABUWORD,F0 Will no longer have KFSBLK @SC91150 06236500 L 0,USRTOTL Reduce storage total @SC90264 06237000 SL 0,KFSSIZE By amount used in this file @SC90264 06237500 BC 3,*+6 @SC91150 06238000 SLR 0,0 @SC90264 06238500 ST 0,USRTOTL @SC90264 06239000 LM 6,7,KFSNEXT Load ptrs to next and previous @SC90264 06239500 MVC KFSNEXT,PTRFRE Link to free chain @SC90264 06240000 ST 4,PTRFRE @SC90264 06240500 ST 6,KFSNEXT-KFSBLK(,7) Skip over forward ptrs @SC90264 06241000 LTR 4,6 End of chain? @SC90264 06241500 BZ *+8 Yes, just unlink this one @SC90264 06242000 ST 7,KFSPREV No, reattach rest of chain @SC90264 06242500 KFLDEL1 EXEC CICS DELETE DATASET(KFILE) RIDFLD(FABFUID), @SC90264+06243000 KEYLENGTH(=Y(LFUID+LFFNM)) GENERIC NOHANDLE, @SC90264 06243500 CLC F0,EIBRCODE Any error? @SC90264 06244000 BE RTRN0 @SC90264 06244500 B RTRN1 @SC90264 06245000 * Close a file @SC90264 06245500 KFLCLO CLC =C'CLOSE',FABCOMM @SC90264 06246000 BNE KFLOPO @SC90264 06246500 TM FABIOF,1 Output file? @SC90264 06247000 BZ RTRN0 No, nothing to do @SC90264 06247500 CLC FABFUID,CURFUID Current userid? @SC91150 06248000 BNE KFLCLO1 No, continue @SC91150 06248500 L 0,KFSSIZE Yes, accumulate size @SC91150 06249000 AL 0,USRTOTL of current directory @SC91150 06249500 ST 0,USRTOTL @SC91150 06250000 KFLCLO1 DS 0H @SC91150 06250500 EXEC CICS ASKTIME, @SC90264 06251000 MVC KFSDATE+1(1),EIBDATE+1 Copy year @SC90264 06251500 ZAP TMPDW,EIBDATE+2(2) @SC90264 06252000 CVB 7,TMPDW Get day-of-year in binary @SC90264 06252500 MVC KFLMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31) @SC86299 06253000 TM EIBDATE+1,1 Check for leap year @SC90264 06253500 BNZ KFLVNLP Not @SC90264 06254000 TM EIBDATE+1,X'12' @SC90264 06254500 BM KFLVNLP Not @SC92114 06255000 MVI KFLMNTH+9,29 Leap year, change Feb. @SC86299 06255500 KFLVNLP LA 6,11 @SC86299 06256000 SR 0,0 @SC86299 06256500 KFLVMDL IC 0,KFLMNTH-1(6) @SC86299 06257000 SR 7,0 Test if passed the right month @SC86299 06257500 BNP KFLVMDM Got it @SC86299 06258000 BCT 6,KFLVMDL @SC86299 06258500 SR 0,0 Hit December @SC86299 06259000 KFLVMDM AR 7,0 Get day of month @SC86299 06259500 LCR 6,6 @SC86299 06260000 LA 6,12(6) Get month @SC86299 06260500 MH 6,=H'100' @SC86299 06261000 AR 6,7 Combine MMDD @SC86299 06261500 MH 6,=H'10' @SC86299 06262000 CVD 6,TMPDW @SC86299 06262500 MVC KFSDATE+2(2),TMPDW+5 @SC86299 06263000 MVI KFSDATE,X'19' Assume 20th Cent @SC86295 06263500 CLI KFSDATE+1,X'50' @SC86295 06264000 BH *+8 Ok @SC86295 06264500 MVI KFSDATE,X'20' Must be 21st @SC86295 06265000 MVO TMPDW,EIBTIME Get time from 0hhmmss+ @SC91150 06265500 MVC KFSDATE+4(3),TMPDW+4 Copy just hhmmss @SC91150 06266000 MVC KFSNREC,FABRN Save number of records @SC90264 06266500 MVC KFLRN,=5C'0' Clear for key @SC90264 06267000 EXEC CICS DELETE DATASET(KFILE) RIDFLD(KFLFUID), @SC91150+06267500 NOHANDLE, Remove previous directory block @SC91150 06268000 UNPK KFLFDAT(15),KFSDAT(8) @SC90264 06268500 UNPK KFLFDAT+14(15),KFSDAT+7(8) @SC90264 06269000 UNPK KFLFDAT+28(3),KFSDAT+14(2) @SC90264 06269500 * - - - - - - Extend these UNPK instrs if KFSLEN grows @SC90264 06270000 TR KFLFDAT(2*KFSLEN),KFLHEXY-C'0' @SC90264 06270500 LA 6,KFLFUID @SC90264 06271000 MVC FABNORD,=Y(KFSLEN*2+LFKEY) @SC90264 06271500 B KFLWRT2 Write new dir block out @SC90264 06272000 * Open a file for output @SC90264 06272500 KFLOPO CLC =C'OPEN O',FABCOMM @SC90264 06273000 BNE KFLOPI @SC90264 06273500 *------------------------- Quota checking ------------ @SC90264 06274000 CLC FABFUID,CURFUID Current userid? @SC90264 06274500 BNE KFLOPO1 No, assume it's ok @SC90264 06275000 CLC FABFUID,SYSUID Global directory? @SC90264 06275500 BE KFLOPO1 Yes, never limit that @SC90264 06276000 CLC USRTOTL,LIMKFS See if over quota @SC90264 06276500 BNL RTRN1 Yes, quit @SC90264 06277000 *------------------------- @SC90264 06277500 KFLOPO1 LTR 4,4 Does it exist? @SC90264 06278000 BZ KFLOPO2 Not there, must create new block @SC90264 06278500 MVC FABRN,KFSNREC If it's there, we append @SC90264 06279000 L 0,USRTOTL @SC90264 06279500 SL 0,KFSSIZE ... but don't count twice in total@SC90264 06280000 ST 0,USRTOTL @SC90264 06280500 B RTRN0 @SC90264 06281000 KFLOPO2 L 4,TMPBLK Ptr to block if not current dir. @SC90264 06281500 CLC FABFUID,CURFUID Current? @SC90264 06282000 BNE KFLOPO3 No, just set it up @SC90264 06282500 LA 4,PTRKFS Yes, start through chain @SC90264 06283000 KFLOLP LR 6,4 Save ptr to this block @SC90264 06283500 ICM 4,15,KFSNEXT Get ptr to next block @SC90264 06284000 BZ KFLONEW Hit end, file not found @SC90264 06284500 CLC FABFNAM,KFSFNAM Match? @SC90264 06285000 BH KFLOLP No, keep looking @SC90264 06285500 KFLONEW BAL 2,KFLCGB Prepare new block @SC90264 06286000 MVC KFSNEXT,0(6) Link into chain: 6->previous @SC90264 06286500 ST 4,KFSNEXT-KFSBLK(,6) @SC90264 06287000 ST 6,KFSPREV Set backward ptr in new block @SC90264 06287500 ICM 7,15,KFSNEXT Added to end? @SC90264 06288000 BZ *+8 Yes, done linking @SC90264 06288500 ST 4,KFSPREV-KFSBLK(,7) No, set back ptr in next @SC90264 06289000 KFLOPO3 ST 4,FABUWORD Save ptr in FAB @SC90264 06289500 MVC KFSFUID(LFUID+LFFNM),FABFUID @SC90264 06290000 XC KFSDAT(KFSLEN),KFSDAT @SC90264 06290500 B RTRN0 @SC90264 06291000 * Open input file @SC90264 06291500 KFLOPI B RTRN0 @SC90264 06292000 * 06292500 * Look up file given in FAB. 1->FAB. Set up TMPBLK if nec. @SC90264 06293000 * Return 15=0 and 1->block if found, 15=1 otherwise. @SC90264 06293500 * 06294000 KFLLKP ENTER ALT @SC90264 06294500 L 8,DFHEIBP Get addressability @SC90264 06295000 LR 3,1 Address FAB @SC90264 06295500 MVI FDBRCF,C'V' Enforce RECFM=V @SC91150 06296000 CLC FABFUID,CURFUID File in current directory? @SC91150 06296500 BNE KFLLOTH No, must get individual block @SC90264 06297000 LA 4,PTRKFS Yes, start through chain @SC90264 06297500 KFLLLP LR 6,4 Save ptr to this block @SC90264 06298000 ICM 4,15,KFSNEXT Get ptr to next block @SC90264 06298500 BZ RTRN1 Hit end, file not found @SC90264 06299000 CLC FABFNAM,KFSFNAM Match? @SC90264 06299500 BH KFLLLP No, keep looking @SC90264 06300000 BL RTRN1 No, passed the right point @SC90264 06300500 KFLLRET RETREG (1,4) Found file, return ptr to block @SC90264 06301000 ST 4,FABUWORD Save ptr in FAB @SC90264 06301500 B RTRN0 @SC90264 06302000 KFLLOTH ICM 4,15,TMPBLK See if temp block already set up @SC90264 06302500 BNZ KFLLOTH2 Yes, use it @SC90264 06303000 BAL 2,KFLCGB No, get a block @SC90264 06303500 ST 4,TMPBLK @SC90264 06304000 MVI KFSFUID,0 Mark it unused @SC90264 06304500 KFLLOTH2 CLC KFSFUID(LFUID+LFFNM),FABFUID Same as before? @SC90264 06305000 BE KFLLRET Yes, just return @SC90264 06305500 MVC KFLFUID(LFUID+LFFNM),FABFUID Set key @SC90264 06306000 BAL 2,KFLCRED Read a directory block @SC90264 06306500 B RTRN1 @SC90264 06307000 CLC KFSFUID(LFUID+LFFNM),FABFUID Found right one? @SC90264 06307500 BNE RTRN1 No, too bad @SC90264 06308000 B KFLLRET Yes, return result @SC90264 06308500 * 06309000 * (Re)set current directory within Kermit file system @SC90264 06309500 * R1->H(length),CLn new directory name. If it begins with ', @SC90264 06310000 * the name is a prefix for external file names. If it is @SC90264 06310500 * just *, it is equivalent to the value in KUSERID. @SC90264 06311000 * 06311500 KFLCWD ENTER ALT @SC90264 06312000 L 8,DFHEIBP Get addressability @SC90264 06312500 LH 7,0(1) Get length @SC90264 06313000 LA 6,2(,1) And address @SC90264 06313500 LTR 7,7 Anything in the string? @SC90264 06314000 BZ KFLCDRP No, just drop old directory @SC90264 06314500 CLI 0(6),C'''' External names? @SC90264 06315000 BE KFLCDRP Yes, drop old @SC90264 06315500 C 7,F1 Is string just '*'? @SC90264 06316000 BNE KFLCCMP @SC90264 06316500 CLI 0(6),C'*' @SC90264 06317000 BNE KFLCCMP No @SC90264 06317500 LA 6,KUSERID Yes, use true userid instead @SC90264 06318000 KFLLAUID LA 7,LFUID @SC90264 06318500 KFLCCMP LA 15,0(7,6) Point past string @SC90264 06319000 CH 7,KFLLAUID+2 Shorter than usual? @SC90264 06319500 BNL *+10 No, that's ok @SC90264 06320000 MVC 0(LFUID,15),=CL(LFUID)' ' Yes, pad with blanks @SC90264 06320500 CLC CURFUID,0(6) Compare with current directory @SC90264 06321000 BE RTRN0 Matches, nothing to do @SC90264 06321500 KFLCDRP CLI CURFUID,0 Any current directory? @SC90264 06322000 BE KFLCSET No, nothing to drop @SC90264 06322500 BAL 2,KFLCRB Yes, drop all blocks @SC90264 06323000 MVI CURFUID,0 and wipe out name @SC90264 06323500 KFLCSET CLI 0(6),C'''' External names? @SC90264 06324000 BE RTRN0 Yes, no new directory @SC90264 06324500 MVC USRTOTL,F0 Clear total space used @SC90264 06325000 MVC CURFUID,0(6) Set new directory name @SC90264 06325500 CLI CURFUID,0 Final cleanup? @SC90264 06326000 BE KFLCLEAN Yes, release storage @SC90264 06326500 MVC KFLFUID,0(6) Set key for reading @SC90264 06327000 XC KFLFNAM(LFFNM),KFLFNAM @SC90264 06327500 LA 7,PTRKFS Anchor of chain @SC90264 06328000 KFLCLP BAL 2,KFLCGB Get a free block: ptr in R4 @SC90264 06328500 BAL 2,KFLCRED Read a directory block @SC90264 06329000 B KFLCLQ Couldn't, we must be finished @SC90264 06329500 ST 4,0(,7) Link onto chain @SC90264 06330000 ST 7,KFSPREV Link backwards, too @SC90264 06330500 LR 7,4 Set new end of chain @SC90264 06331000 AL 0,USRTOTL Add up space used @SC90264 06331500 BC 12,*+8 No carry @SC90264 06332000 SLR 0,0 @SC90264 06332500 BCTR 0,0 Set total to max @SC90264 06333000 ST 0,USRTOTL Keep new total @SC90264 06333500 LM 0,1,KFSFNAM Get name of file @SC90264 06334000 AL 1,F1 And bump 1 @SC90264 06334500 BC 12,*+8 No carry @SC90264 06335000 AL 0,F1 Carry @SC90264 06335500 STM 0,1,KFLFNAM Save as next key for search @SC90264 06336000 B KFLCLP Go get another @SC90264 06336500 KFLCLQ MVC KFSNEXT,PTRFRE This block is left over @SC90264 06337000 ST 4,PTRFRE @SC90264 06337500 B RTRN0 @SC90264 06338000 * 06338500 * Release all storage @SC90264 06339000 KFLCLEAN MVC PTRFRE,F0 @SC90264 06339500 MVC PTRKFS,F0 @SC90264 06340000 MVC TMPBLK,F0 @SC90264 06340500 KFLCLLP ICM 1,15,PTRFREM Get ptr to next megablock @SC90264 06341000 BZ RTRN0 No more, done freeing @SC90264 06341500 MVC PTRFREM,0(1) Unchain it @SC90264 06342000 LA 0,KFSDWDS*20+1 @SC90264 06342500 DMSFRET LOC=(1),DWORDS=(0) ... and free it @SC90264 06343000 B KFLCLLP @SC90264 06343500 * 06344000 * Read a directory block into buffer: key set up in KFLFUID. @SC90264 06344500 * Return to (2) if ok, else skip. Clobbers R5 @SC90264 06345000 * Returns R0 = size of file in bytes @SC90264 06345500 * 06346000 KFLCRED EXEC CICS READ DATASET(KFILE) RIDFLD(KFLFUID), @SC90264+06346500 KEYLENGTH(=Y(LFUID+LFFNM)) GENERIC GTEQ, @SC90264+06347000 SET(5) LENGTH(KFLBLN) NOHANDLE, @SC90264 06347500 CLC F0,EIBRCODE @SC90264 06348000 BNER 2 I/O error of some sort @SC90264 06348500 CLC KFLFUID,0(5) Did we get the right uid? @SC90264 06349000 BNER 2 No, we must be finished @SC90264 06349500 MVC KFSFUID(LFUID+LFFNM),0(5) Ok so far, copy name @SC90264 06350000 CLC KFLBLN,=Y(KFSLEN*2+LFKEY) Valid block? @SC90264 06350500 * BNL KFLCRPK Ok so far, verify it @SC90264 06351000 * - - - - - Insert code to compensate for missing info in any @SC90264 06351500 * supported shorter block length @SC90264 06352000 BLR 2 No, quit now @SC90264 06352500 KFLCRPK PACK KFSDAT(8),LFKEY(15,5) @SC90264 06353000 PACK KFSDAT+7(8),LFKEY+14(15,5) @SC90264 06353500 PACK KFSDAT+14(2),LFKEY+28(3,5) @SC90264 06354000 * - - - - - - Extend these PACK instrs if KFSLEN grows @SC90264 06354500 ICM 0,3,KFSNREC Is this a valid block? @SC90264 06355000 BNPR 2 No, stop here @SC90264 06355500 ICM 0,15,KFSSIZE ditto @SC90264 06356000 BNPR 2 @SC90264 06356500 B 4(,2) Return and skip @SC90264 06357000 * 06357500 * Get a free block for directory, create new if necessary @SC90264 06358000 * Return via R2, ptr in R4, uses R0,R1,R14,R15 @SC90264 06358500 KFLCGB ICM 4,15,PTRFRE Get a free block @SC90264 06359000 BNZ KFLCGB2 Ok, use it @SC90264 06359500 LA 0,KFSDWDS*20+1 No, must assign some more @SC90264 06360000 DMSFREE DWORDS=(0),ERR=RTRN1 @SC90264 06360500 MVC 0(4,1),PTRFREM Link to megablock chain @SC90264 06361000 ST 1,PTRFREM @SC90264 06361500 LA 4,4(,1) Skip over megablock ptr @SC90264 06362000 LA 15,20 Partition into 20 blocks @SC90264 06362500 KFLCGBLP MVC KFSNEXT,PTRFRE Link to free chain @SC90264 06363000 ST 4,PTRFRE @SC90264 06363500 LA 4,KFSDWDS*8(,4) Skip to next block @SC90264 06364000 BCT 15,KFLCGBLP @SC90264 06364500 B KFLCGB Now try again @SC90264 06365000 KFLCGB2 MVC PTRFRE,KFSNEXT Unchain the block @SC90264 06365500 MVC KFSNEXT,F0 @SC90264 06366000 BR 2 @SC90264 06366500 * 06367000 * Release all directory blocks in current directory @SC90264 06367500 * Return via R2. Uses R0,R14,R15 @SC90264 06368000 KFLCRB ICM 0,15,PTRKFS Any directory? @SC90264 06368500 BZR 2 No, all done @SC90264 06369000 MVC PTRKFS,F0 Yes, unchain all blocks @SC90264 06369500 LA 15,PTRFRE Start of free chain @SC90264 06370000 LR 14,15 @SC90264 06370500 ICM 15,15,0(14) Find end of free chain @SC90264 06371000 BNZ *-6 Saw another, keep looking @SC90264 06371500 ST 0,0(,14) Link whole directory onto end @SC90264 06372000 BR 2 @SC90264 06372500 * 06373000 DROP 3,4,8 @SC91150 06373500 * 06374000 KFLHEXY DC C'0123456789',X'7A7B7C7D7E7F' Printable codes @SC90264 06374500 * : # @ ' = " with proper digit @SC90264 06375000 LOCALS , @SC90264 06375500 KFLDW DS 0D Temporary @SC90264 06376000 KFLFUID DS CL(LFUID) Room for key @SC90264 06376500 KFLFNAM DS CL(LFFNM) (including this) @SC90264 06377000 KFLRN DS CL5 @SC90264 06377500 KFLFDAT DS CL(2*KFSLEN) @SC90264 06378000 KFLBLN DS H Length of record @SC90264 06378500 KFLMNTH DS XL11 Month length table @SC86299 06379000 * 06379500 EXIT , @SC90264 06380000