*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
