home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
ibm370.zip
/
ikxutl.asm
< prev
Wrap
Assembly Source File
|
1993-10-21
|
234KB
|
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