*COPY                                                 IKCUTL            05000000
         TITLE 'CWDSET/DSPACE Routines - set/show working directory'    05001000
* Set new 'working directory', i.e., filemode letter                    05002000
* Entry: SCANPTR string has option                                      05003000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged.   05004000
CWDSET   ENTER                                                 @SC86164 05005000
*  CMS filespec parts                                          @SC86295 05006000
FN       EQU   FILNAM,8                                        @SC86295 05007000
FT       EQU   FN+8,8                                          @SC86295 05008000
FM       EQU   FT+8,2                                          @SC86295 05009000
*                                                                       05010000
IFN      EQU   IFILE,8                                         @SC86295 05011000
IFT      EQU   IFN+8,8                                         @SC86295 05012000
IFM      EQU   IFT+8,2                                         @SC86295 05013000
*                                                                       05014000
JFN      EQU   JFNAM,8       Foreign FN for SEND               @SC86295 05015000
JFT      EQU   JFN+8,8       Foreign FT for SEND               @SC86295 05016000
*                                                                       05017000
         NTOKN N=CWDERR,H=CWDERR                               @SC86164 05018000
         LTR   7,7           Length of token                   @SC86164 05019000
         BNZ   CWDERR        >1                                @SC86164 05020000
         TR    0(1,6),UPCASE                                   @SC87034 05021000
         MVC   IFM(1),0(6)   Copy mode letter                  @SC86164 05022000
       NXTFSET IFILE,CWD,E=CWDERR                              @SC86295 05023000
         MVC   DEST(1),IFM    Save new mode                    @SC86316 05024000
         B     RTRN0                                           @SC86295 05025000
CWDERR   PTEXT 'Must be valid CMS mode letter'                 @SC86295 05026000
         B     SUBERR                                          @SC86295 05027000
*                                                                       05028000
*        DSPACE Routine - display available disk space         @SC86164 05029000
*                                                                       05030000
* Show space in 'working directory' or other minidisk                   05031000
* Entry: SCANPTR string has option (none => working directory)          05032000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged    05033000
DSPACE   ENTER ALT                                             @SC86164 05034000
         MVC   QDISK+16(1),DEST Default filemode               @SC86164 05035000
         NTOKN N=DSPACEX                                       @SC86164 05036000
         TR    0(1,6),UPCASE                                   @SC87034 05037000
         MVC   QDISK+16(1),0(6)                                @SC86164 05038000
DSPACEX  HOST  QDISK,E=RTRN1                                   @SC86295 05039000
         B     RTRN0                                           @SC86295 05040000
         LOCALS ,                                              @SC86295 05041000
         EXIT  ,                                               @SC86295 05042000
         TITLE 'FSPEC Routine - extract filespec from scan string'      05043000
*                                                                       05044000
* Entry: R1->name field, R0=flags selecting operation (see below)       05045000
*        For parse operations, SCANPTR defines the input string.        05046000
*        For getting foreign or display filespec, R7->output buffer     05047000
* Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad.               05048000
*        For R15=1 or 2 R3,R4 give message.  ERRNUM may be leftover.    05049000
*                                                                       05050000
*                                 Flags:                  Notes:        05051000
*   Tasks:               FFRCF FFSND FFGET FFNEW                        05052000
* Parse RECV               X                     set ROVR properly      05053000
* Parse SEND 1st                 X                                      05054000
* Parse SEND 2nd           X     X                                      05055000
* Parse GET 1st            X           X                                05056000
* Parse GET 2nd                        X         set ROVR properly      05057000
* Parse F-packet   (FFHDR) X     X     X                                05058000
* Parse for Generic(FFUTL)       X     X         FFWLD: allow partial   05059000
* Parse TAKE                                                            05060000
*                                                                       05061000
* Get unique name                            X     R15: 0=>ok, 1=>bad   05062000
* Interactive name check               X     X     R15: 0=>ok, 1=>bad   05063000
* Get foreign name (FFENC) X                 X     R15->end of string   05064000
* Get display form (FFDSP)       X           X     R15->end of string   05065000
*                                                                       05066000
FSPEC    ENTER                                                 @SC86295 05067000
         STC   0,FSPFLG                                        @SC86295 05068000
         LR    0,1           Copy ptr to filespec              @SC86295 05069000
         TM    FSPFLG,FFNEW                                    @SC86295 05070000
         BO    FSPWRN                                          @SC86295 05071000
         XC    0(18,1),0(1)  Clear filespec                    @SC86295 05072000
         MVC   FSPBAD(16),=C'Invalid filename'                 @SC86295 05073000
         PTEXT FSPBAD,16     Standard msg form                 @SC86295 05074000
         MVI   ERRNUM,ERRFNE Assume bad file name              @SC86158 05075000
         MVC   16(2,1),DEST  Default FM                        @SC86295 05076000
         TM    FSPFLG,FFHDR                                    @SC86295 05077000
         BO    FSPHD                                           @SC86295 05078000
         TM    FSPFLG,FFUTL                                    @SC86295 05079000
         BNO   FSPTR                                           @SC86295 05080000
         TM    FSPFLG,FFWLD  Utility: default to all files?    @SC86295 05081000
         BZ    FSPASC        No                                @SC86295 05082000
         MVC   0(8,1),ASTER  Yes                               @SC86295 05083000
         MVC   8(8,1),ASTER                                    @SC86295 05084000
FSPASC   TM    FL2,SRV       Server mode?                      @SC86295 05085000
         BZ    FSPCPY        No, don't need to convert         @SC86295 05086000
         ICM   15,15,LEN     Get length                        @SC86295 05087000
         BZ    FSPCPY                                          @SC86295 05088000
         BCTR  15,0          Correct for EX                    @SC86158 05089000
         L     1,ADR         Get string ptr                    @SC86295 05090000
         EX    15,TRATOE     Change to EBCDIC                  @SC86158 05091000
         MVI   UPCASE+C'.',C' '                                @SC86158 05092000
         EX    15,TRUPCAS    Upcase and dot to space           @SC86158 05093000
         MVI   UPCASE+C'.',C'.'                                @SC86158 05094000
         B     FSPCPY                                          @SC86295 05095000
FSPTR    TM    FSPFLG,FFRCF                                    @SC86295 05096000
         BZ    FSPTS                                           @SC86295 05097000
         TM    FSPFLG,FFSND+FFGET                              @SC86295 05098000
         BNZ   FSPSN2        Foreign filespec for SEND or GET  @SC86295 05099000
FSPRC    NI    FL1,255-ROVR  Setup for RECEIVE                 @SC86295 05100000
         NI    FL4,255-NMOK  Collision not checked yet         @SC87012 05101000
         MVI   0(1),C'$'     Default FN                        @SC86295 05102000
         MVC   UFM,DEST      Default FM, can change by = = x   @SC86295 05103000
         B     FSPCPY                                          @SC86295 05104000
FSPHD    MVC   0(8,1),=CL8'$' Default fn                       @SC86295 05105000
         MVC   8(8,1),0(1)   Default ft                        @SC86295 05106000
         MVC   16(2,1),UFM   Default fm                        @SC86295 05107000
         L     2,ADR                                           @SC86295 05108000
         TR    0(256,2),FSPTAB  Make valid fn chars            @SC86295 05109000
         B     FSPCPY                                          @SC86295 05110000
FSPTS    TM    FSPFLG,FFSND                                    @SC86295 05111000
         BZ    FSPTG                                           @SC86295 05112000
         TM    FL5,SALL                                        @SC86295 05113000
         BZ    *+10                                            @SC86295 05114000
         MVC   16(2,1),ASTER Default FM for SEND               @SC86295 05115000
         B     FSPASC                                          @SC86295 05116000
FSPSN2   MVI   1(1),C'='     Foreign file name is same         @SC86295 05117000
         MVI   9(1),C'='                                       @SC86295 05118000
         CTOKN H=FSP2H,N=RTRN0                                 @SC86295 05119000
         LA    1,L'JFNAM                                       @SC86295 05120000
         CLM   7,3,*-2       Does it fit?                      @SC86224 05121000
         BNH   *+6           Yes                               @SC86224 05122000
         LR    7,1           Use what we can                   @SC86224 05123000
         LR    3,0                                             @SC86295 05124000
         STC   7,0(3)        Save length                       @SC86224 05125000
         LA    0,1(3)                                          @SC86295 05126000
         MVCL  0,6           Get fn, at least                  @SC86224 05127000
         MVI   TRTBL+C'.',2  See if valid CMS token            @SC86224 05128000
         MVI   TRTBL+C'/',2                                    @SC86224 05129000
         SR    2,2                                             @SC86224 05130000
         TRT   1(9,3),TRTBL                                    @SC86295 05131000
         MVI   TRTBL+C'.',0                                    @SC86224 05132000
         MVI   TRTBL+C'/',0                                    @SC86224 05133000
         BCT   2,RTRN0       Not valid: must be complex string @SC86224 05134000
         MVC   FSPPTR,SCANPTR                                  @SC86295 05135000
         LA    2,3                                             @SC86295 05136000
FSPCNT   NTOKN N=FSPCNZ                                        @SC86295 05137000
         BCT   2,FSPCNT                                        @SC86295 05138000
FSPCNZ   MVC   SCANPTR,FSPPTR Restore ptrs                     @SC86295 05139000
         N     2,F1                                            @SC86295 05140000
         BNZ   RTRN0         Single token string               @SC86295 05141000
         LA    0,9(3)        Get 2nd token                     @SC86295 05142000
         MVI   0(3),0        Clear length again                @SC86295 05143000
         MVC   FSPBADX,=C'type'                                @SC86295 05144000
         CTOKN H=FSP2H,N=FSPMIS                                @SC86295 05145000
         MVCL  0,6                                             @SC86295 05146000
         B     RTRN0                                           @SC86295 05147000
FSPTG    TM    FSPFLG,FFGET                                    @SC86295 05148000
         BO    FSPRC                                           @SC86295 05149000
         TM    FSPFLG,FFGIV  GIVE command?                     @SC87117 05150000
         BO    *+10          Yes, keep specific FM             @SC87117 05151000
         MVC   16(2,1),ASTER Default FM for TAKE               @SC86295 05152000
         MVC   8(8,1),=CL8'TAKE'                               @SC86295 05153000
FSPCPY   CTOKN H=FSPH,N=FSPZ                                   @SC86295 05154000
         TM    FSPFLG,FFRCF                                    @SC86295 05155000
         BZ    FSPCPN                                          @SC86295 05156000
         CLI   0(6),C'='                                       @SC86224 05157000
         BE    FSPREQ        Go if RECEIVE = ...               @SC86295 05158000
         CLI   0(6),C'*'                                       @SC86224 05159000
         BE    FSPINV                                          @SC86295 05160000
FSPCPN   BAL   14,FSPTOK     Get fn                            @SC87034 05161000
         MVC   FSPBADX,=C'type'                                @SC86295 05162000
         CTOKN H=FSPH,N=FSPZ                                   @SC86295 05163000
         CLI   0(6),C'='                                       @SC86224 05164000
         BE    FSPINV        Go if RECEIVE xxx =               @SC86295 05165000
         TM    FSPFLG,FFRCF                                    @SC86295 05166000
         BZ    FSPCPT                                          @SC86295 05167000
         CLI   0(6),C'*'                                       @SC86224 05168000
         BE    FSPINV        Go if RECEIVE xxx *               @SC86295 05169000
         OI    FL1,ROVR      Overwrite received fname          @SC86295 05170000
FSPCPT   BAL   14,FSPTOK     Get ft                            @SC87034 05171000
         TM    FSPFLG,FFHDR  Getting name from packet?         @SC86295 05172000
         BO    RTRN0         Yes, done                         @SC86295 05173000
         MVC   FSPBADX,=C'mode'                                @SC86295 05174000
         CTOKN H=FSPH,N=FSPZ                                   @SC86295 05175000
         TM    FSPFLG,FFRCF                                    @SC86295 05176000
         BZ    FSPCPM                                          @SC86295 05177000
         CLI   0(6),C'*'                                       @SC86224 05178000
         BE    FSPINV                                          @SC86295 05179000
FSPCPM   LA    1,L'FM                                          @SC86224 05180000
         BAL   14,FSPTOK     Get fm                            @SC87034 05181000
         B     RTRN0                                           @SC86295 05182000
*                                                                       05183000
FSPREQ   MVC   FSPBADX,=C'type'                                @SC86295 05184000
         CTOKN H=FSPH,N=FSPZ   Pick ft for RECEIVE =           @SC86295 05185000
         CLI   0(6),C'='                                       @SC86224 05186000
         BNE   FSPINV        Go if FT is not =                 @SC86295 05187000
         CLI   0(6),C'*'                                       @SC86224 05188000
         BE    FSPINV        Bad FM                            @SC86295 05189000
         MVC   FSPBADX,=C'mode'                                @SC86295 05190000
         CTOKN H=FSPH,N=FSPZ Pick fm for RECEIVE = =           @SC86295 05191000
         LA    1,L'FM                                          @SC86224 05192000
         BAL   14,FSPTOK     Use FM they specified             @SC87034 05193000
         MVC   UFM,0(1)      Use for all of file group         @SC87034 05194000
         B     RTRN0                                           @SC87034 05195000
*                                                                       05196000
FSPTOK   LR    8,0           Save start                        @SC87034 05197000
         LR    9,1           And length                        @SC87034 05198000
         MVCL  0,6           Copy token with padding           @SC87034 05199000
         LR    1,8                                             @SC87034 05200000
         BCTR  9,0           Fix for TR                        @SC87034 05201000
         EX    9,TRUPCAS     Upcase the token                  @SC87034 05202000
         BR    14                                              @SC87034 05203000
*                                                                       05204000
FSPZ     LR    14,0                                            @SC86295 05205000
         CLI   0(14),C' '    Any default given?                @SC86295 05206000
         BH    RTRN0         Yes, use it                       @SC86295 05207000
FSPMIS   MVC   FSPBAD,=C'Missing'                              @SC86295 05208000
FSPINV   LA    15,2                                            @SC86295 05209000
         B     FSPPTRS                                         @SC86295 05210000
*                                                                       05211000
FSPH     PTEXT 'Filespec has format: fn ft [fm]'               @SC86295 05212000
         B     FSP0H                                           @SC86295 05213000
FSP2H    PTEXT 'Enter foreign filespec'                        @SC86295 05214000
FSP0H    LA    15,1                                            @SC86295 05215000
FSPPTRS  L     14,4(13)                                        @SC86295 05216000
         STM   3,4,32(14)    Return msg ptrs                   @SC86295 05217000
FSPRET   RET   ,                                               @SC86295 05218000
*                                                                       05219000
* Non-parsing functions . . .                                           05220000
*                                                                       05221000
* Get unique filespec                                                   05222000
FSPWRN   LR    4,1           Save name ptr                     @SC86295 05223000
         TM    FSPFLG,FFENC                                    @SC86295 05224000
         BO    FSPENC        Encode name into buffer           @SC86295 05225000
         TM    FSPFLG,FFDSP                                    @SC86295 05226000
         BO    FSPDSP        Copy name into buffer for display @SC86295 05227000
         TM    FL4,NMOK      Already checked?                  @SC87012 05228000
         BO    RTRN0         Yes, ok                           @SC87012 05229000
         LA    6,8+6(1)      End of FT                         @BS86001 05230000
         BCTR  6,0                                             @BS86001 05231000
         CLI   0(6),C' '     Find end of token                 @BS86001 05232000
         BE    *-6                                             @BS86001 05233000
         LA    5,10+1        Allowed retries                   @BS86001 05234000
         LA    7,C'0'        Extra character                   @BS86001 05235000
         OI    FL4,NMOK      Assume it checks                  @SC87012 05236000
FSPSTA   OPENF T,(4),E=RTRN0 Does it exist already?            @SC86135 05237000
         MVI   1(6),C'$'     Yes, modify FT                    @BS86001 05238000
         STC   7,2(6)        Serialize                         @BS86001 05239000
         LA    7,1(7)        Bump counter                      @BS86001 05240000
         BCT   5,FSPSTA                                        @BS86001 05241000
         B     RTRN1         Failed                            @SC86295 05242000
*                                                                       05243000
* Encode name at (R1) into (R7) buffer (in ASCII), possibly with        05244000
*  substitution from JFSPEC, but disable subsequent subst.              05245000
*  Return updated ptr in R15                                            05246000
FSPENC   LA    1,JFSPEC      Complex string?                   @SC86224 05247000
         LA    5,JFNAM       Remote file-spec                  @SC86155 05248000
         BAL   14,PAKFOR                                       @SC86224 05249000
         BNZ   FSPFILS       Yes, tokens aren't used           @SC86224 05250000
         BAL   14,FSPFID     Filename                          @HF86223 05251000
         LA    7,1(7)        Skip over period                  @HF86223 05252000
         BAL   14,FSPFID     Filetype                          @HF86223 05253000
FSPFILS  MVI   JFSPEC,0      Turn off string                   @SC86224 05254000
         CLI   JFN,C'='      Partial renaming?                 @SC86224 05255000
         BE    FSPENR        Yes, keep it                      @SC86224 05256000
         CLI   JFT,C'='                                        @SC86224 05257000
         BE    FSPENR                                          @SC86224 05258000
         MVI   JFN,C'='      Now use original name             @SC86171 05259000
         MVI   JFT,C'='                                        @SC86171 05260000
FSPENR   LR    15,7          Save ptr                          @SC86295 05261000
         B     FSPRET                                          @SC86295 05262000
*                                                                       05263000
* Copy name at (R1) into (R7) buffer in display form                    05264000
*  Return updated ptr in R15                                            05265000
FSPDSP   BAL   14,FSPDTK     Filename                          @SC86295 05266000
         BAL   14,FSPDTK     Filetype                          @SC86295 05267000
         MVC   0(2,7),0(4)   Filemode                          @SC86295 05268000
         LA    7,2(7)                                          @SC86295 05269000
         B     FSPENR                                          @SC86295 05270000
*                                                                       05271000
* Subroutine to detokenize a list into ASCII                   @SC86135 05272000
FSPFID   MVC   0(8,7),0(4)   Copy token                        @SC86135 05273000
         CLI   0(5),C'='     Keep true name?                   @SC86171 05274000
         BE    *+10          Yes                               @SC86171 05275000
         MVC   0(8,7),0(5)   No, use override                  @SC86171 05276000
         LA    1,8(7)        End of token if no blanks         @SC86135 05277000
         TRT   0(8,7),TRTBL  Find 1st blank                    @SC86135 05278000
         TR    0(8,7),ETOA   Ascii it                          @SC86135 05279000
         LR    7,1           New end of string                 @SC86135 05280000
         LA    4,8(4)        Next token                        @SC86135 05281000
         LA    5,8(5)                                          @SC86171 05282000
         MVI   0(7),ADOT     Add an ASCII dot, just in case    @SC86135 05283000
         BR    14                                              @SC86135 05284000
*                                                                       05285000
* Subroutine to detokenize a list in EBCDIC                    @SC86295 05286000
FSPDTK   MVC   0(8,7),0(4)   Copy token                        @SC86135 05287000
         LA    1,8(7)        End of token if no blanks         @SC86135 05288000
         TRT   0(8,7),TRTBL  Find 1st blank                    @SC86135 05289000
         MVI   0(1),C' '     Add a BLANK                       @SC86295 05290000
         LA    7,1(1)        New end of string                 @SC86135 05291000
         LA    4,8(4)        Next token                        @SC86135 05292000
         BR    14                                              @SC86135 05293000
*                                                                       05294000
* Subroutine to set up CMS token for copying                   @SC86224 05295000
CMSTOK8  LA    7,1(7)                                          @SC86224 05296000
         ICM   7,8,BLANK                                       @SC86224 05297000
         LA    1,8                                             @SC86224 05298000
         BR    14                                              @SC86224 05299000
*                                                                       05300000
* Valid CMS file name characters                               @SC86295 05301000
FSPTAB   DC    64C'_',C' '           space                     @SC86295 05302000
         DC    10C'_',C' '           dot                       @SC86295 05303000
         DC    02C'_',C'+'           plus                      @SC86295 05304000
         DC    12C'_',C'$'           dollar sign               @SC86295 05305000
         DC    04C'_',C'-'           dash                      @SC86295 05306000
         DC    12C'_',C'_'           underscore                @SC86295 05307000
         DC    12C'_',C':#@'         colon, pound sign, at sign@SC86295 05308000
         DC    04C'_',C'ABCDEFGHI'   a-i                       @SC86295 05309000
         DC    07C'_',C'JKLMNOPQR'   j-r                       @SC86295 05310000
         DC    08C'_',C'STUVWXYZ'    s-z                       @SC86295 05311000
         DC    23C'_',C'ABCDEFGHI'   A-I                       @SC86295 05312000
         DC    07C'_',C'JKLMNOPQR'   J-R                       @SC86295 05313000
         DC    08C'_',C'STUVWXYZ'    S-Z                       @SC86295 05314000
         DC    06C'_',C'0123456789'  0-9                       @SC86295 05315000
         DC    06C'_'                                          @SC86295 05316000
         LOCALS ,                                              @SC86295 05317000
FSPBAD   DS    C'Invalid',C' file'                             @SC86295 05318000
FSPBADX  DS    C'name'                                         @SC86295 05319000
FSPPTR   DS    XL8           Saved scan ptrs                   @SC86295 05320000
FSPFLG   DS    X             Filespec flags                    @SC86295 05321000
FSPEC    EXIT                                                  @SC86295 05322000
         TITLE 'KHELP routine - perform HELP command'                   05323000
* Handle HELP command, rest of string given by SCANPTR.                 05324000
KHELP    ENTER ,                                               @SC86355 05325000
* CMS version ignores any extra operands on HELP command       @SC86355 05326000
         L     2,ORGR1       Ptr to original command           @SC86355 05327000
         CLI   0(2),C'*'     Was it a START?                   @SC86355 05328000
         BE    KHLDF         Yes, use default                  @SC86355 05329000
         CLI   0(2),X'FF'    Nothing at all?                   @SC86355 05330000
         BNE   KHLI          Something, use it                 @SC87007 05331000
KHLDF    LA    2,=CL8'KERMIT'                                  @SC86355 05332000
KHLI     LA    1,CMD         Command buffer                    @SC87007 05333000
         MVC   0(5,1),=CL5'HELP'                               @SC86355 05334000
         MVC   5(30,1),0(2)  Copy operand                      @SC86355 05335000
         LA    0,5+8         Length of command                 @SC86355 05336000
         STM   0,1,SCANPTR   Set up for system                 @SC86355 05337000
         OI    FL4,UCMD                                        @SC86355 05338000
         KCALL SUPFNC,3      Do it                             @SC86355 05339000
         RET   ,                                               @SC86355 05340000
         LOCALS ,                                                       05341000
KHELP    EXIT  ,                                               @SC87007 05342000
         TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05343000
SUPFNC   ENTER                                                 @SC86295 05344000
*  On entry, R1 = operation code, R0 = possible ptr            @SC86158 05345000
* Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends)             05346000
*       ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-9)        05347000
* 1 -> Start typeout interception.  N.B.  &MAXLR >> 2048 for this       05348000
* 2 -> Clean up afterwards and stop interception                        05349000
* 3 -> Execute host command with or without interception                05350000
*      If UCMD set, SCANPTR gives text, else R0->text,R6=len            05351000
* 4 -> Execute CP command with or without interception                  05352000
*      R0->text, R6=len                                                 05353000
* 5 -> Stop interception if going                                       05354000
* 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null)      05355000
* 7 -> Test for stacked lines, return number in R15                     05356000
* 8 -> Log off (doesn't return!)                                        05357000
* 9 -> Wait specified time                                              05358000
* 10-> Return clock time in R15 (centisec)                              05359000
* 11-> Seup up new prompt string at (R0)                                05360000
         BCT   1,ICPFIN                                        @SC86158 05361000
* Start interception, initialize ptrs                          @SC86158 05362000
         MVI   ERRNUM,ERRNOE OK                                @SC86158 05363000
         LA    0,2048        Suitable offset                   @SC86158 05364000
         A     0,WBUF        Output buffer                     @SC86158 05365000
         L     1,TSENT       Limit                             @SC86158 05366000
         LR    15,0                                            @SC86158 05367000
         STM   15,0,TXTPTR   Save                              @SC86158 05368000
         STM   0,1,SVCOPTR                                     @SC86158 05369000
         SR    1,0           Get length                        @SC86158 05370000
         L     15,=X'15000000'                                 @SC86158 05371000
         MVCL  0,14          Fill with NL (X'15')              @SC86158 05372000
         CLC   SVCNPSW,SVCSNAG  Already set up?                @SC86158 05373000
         BE    RTRN0         Yes, but how?                     @SC86295 05374000
         MVC   SAVENPSW,SVCNPSW                                @SC86158 05375000
         MVC   TYPSAV,ADMSCWR                                  @SC86283 05376000
        DMSKEY NUCLEUS                                         @SC86283 05377000
         MVC   SVCNPSW,SVCSNAG Set up interception (SVC)       @SC86283 05378000
         MVC   ADMSCWR,=A(ICPTYP)  (BALR)                      @SC86283 05379000
        DMSKEY RESET                                           @SC86283 05380000
         B     RTRN0                                           @SC86295 05381000
* Clean up after interception                                  @SC86295 05382000
ICPFIN   BCT   1,ICPHST                                        @SC86158 05383000
         L     5,SVCOPTR     End of text                       @SC86158 05384000
         ST    5,TXTPTR+4    Save                              @SC86158 05385000
         B     ICPRST1       Now restore interrupts            @SC86295 05386000
* Restore SVC interrupt vector                                 @SC86158 05387000
ICPRST   BCT   1,SFCLIN                                        @SC86295 05388000
ICPRST1  CLC   SVCNPSW,SVCSNAG                                 @SC86295 05389000
         BNE   RTRN0         OK                                @SC86295 05390000
        DMSKEY NUCLEUS                                         @SC86283 05391000
         MVC   SVCNPSW,SAVENPSW                                @SC86283 05392000
         MVC   ADMSCWR,TYPSAV                                  @SC86283 05393000
        DMSKEY RESET                                           @SC86283 05394000
         B     RTRN0                                                    05395000
* Avoid user-area CMS commands, otherwise execute command at   @SC86158 05396000
*  (R0) already tokenized. Save return code.                   @SC86158 05397000
ICPHST   BCT   1,ICPCP                                         @SC86158 05398000
         TM    FL4,UCMD      User CMS command?                 @SC86295 05399000
         BZ    ICPCMS0       No, already tokenized             @SC86295 05400000
         LM    0,1,SCANPTR                                     @SC86295 05401000
         LTR   15,0                                            @SC87034 05402000
         BNP   ICPCMIL       Nothing there                     @SC87034 05403000
         BCTR  15,0          Get length for TR                 @SC87034 05404000
         EX    15,TRUPCAS    Convert to upper case             @SC87034 05405000
        DMSKEY NUCLEUS       Enter Key 0                       @SC86295 05406000
         L     15,ASCANN                                       @SC86295 05407000
         BALR  14,15         Tokenize data                     @SC86295 05408000
         LR    0,15                                            @SC86295 05409000
        DMSKEY RESET         Restore user key                  @SC86295 05410000
         LTR   15,0          Did SCANN fail?                   @SC86295 05411000
         BNZ   ICPCMIL       Yes                               @SC86295 05412000
         LR    0,1                                             @SC86295 05413000
ICPCMS0  LR    3,0                                             @SC86295 05414000
         CLC   =C'CP ',0(3)  CP command?                       @SC86158 05415000
         BE    ICPCMSCP      Yes, do it                        @SC86158 05416000
         MVC   IFT,=CL8'EXEC'                                  @SC86158 05417000
         MVC   IFM,ASTER     Search all disks                  @SC86158 05418000
         TM    OPTFLAGS,NOIMPEX  EXEC's allowed?               @SC86158 05419000
         BO    ICPCMSM       No, try for module                @SC86158 05420000
         TM    FL4,UCMD      User CMS command?                 @SC86158 05421000
         BZ    ICPCMSM       No, avoid EXEC's                  @SC86158 05422000
ICPCMSA  MVC   IFN,0(3)                                        @SC86158 05423000
         LA    4,1                                             @SC86158 05424000
ICPCMSS NXTFSET IFILE                                          @SC86295 05425000
         NXTF  E=ICPABBR     Get name                          @SC86295 05426000
         LR    5,1                                             @SC86295 05427000
         USING FDBD,5                                          @SC86295 05428000
         TM    FDBFLGS,WFN   Any wild chars?                   @SC86295 05429000
         BO    ICPCMIL       Yes, illegal                      @SC86158 05430000
        DMSEXS MVC,0(8,3),IFN Found, copy full name            @SC86158 05431000
         CLI   IFT,C'E'      EXEC?                             @SC86158 05432000
         BNE   ICPCMSU       No, module. Check it              @SC86158 05433000
         S     3,F8          Back up to EXEC in COMBUF         @SC86158 05434000
         B     ICPCMSX       Do it                             @SC86158 05435000
ICPABBR  LTR   4,4           Already tried abbrev?             @SC86158 05436000
         BZ    ICPCMSM       Yes, give up                      @SC86158 05437000
         TM    OPTFLAGS,NOABBREV Allowed?                      @SC86158 05438000
         BO    ICPCMSM       No, just do it                    @SC86158 05439000
        DMSKEY NUCLEUS                                         @SC86158 05440000
         LM    0,1,0(3)      Get name entered                  @SC86158 05441000
         L     15,AABBREV    Look up abbreviation              @SC86158 05442000
         BALR  14,15                                           @SC86158 05443000
         LR    4,15          Save RC                           @SC86158 05444000
        DMSKEY RESET         Return to normal                  @SC86158 05445000
         LTR   4,4           Did we find one?                  @SC86158 05446000
         BNZ   ICPCMSM       No, give up                       @SC86158 05447000
         STM   0,1,IFN       Yes, try it                       @SC86158 05448000
         B     ICPCMSS       Now R4=0, don't loop              @SC86158 05449000
ICPCMSM  CLI   IFT,C'M'                                        @SC86158 05450000
         BE    ICPCMSX       Already looked                    @SC86158 05451000
         MVC   IFT,=CL8'MODULE'                                @SC86158 05452000
         B     ICPCMSA       Start over again                  @SC86158 05453000
ICPCMSU  CLI   FDBRCF,C'F'   System-key transient?             @SC86295 05454000
         DROP  5                                               @SC86295 05455000
         BE    ICPCMSX       OK, no problem                    @SC86158 05456000
         MVC   IFM,FM        Get right mode letter             @SC86158 05457000
         LA    2,CMD         Buffer for 1st record of module   @SC86295 05458000
         MVC   4(4,2),=A(KERMIT)  In case of failure           @SC86295 05459000
         MVC   IFSCB+8(18),IFILE                               @SC86295 05460000
        FSREAD FSCB=IFSCB,BUFFER=(2)  Get header record        @SC86295 05461000
       FSCLOSE FSCB=IFSCB                                      @SC86158 05462000
         CLC   =A(KERMIT),CMD+4 Check beginning adr            @SC86158 05463000
         BNH   ICPCMIL       User-area, forbid it              @SC86158 05464000
ICPCMSX  HOST  0(3),E=*+4    Accept errors                     @SC86158 05465000
         LTR   6,15          Save return code                  @SC86295 05466000
         BNM   SFCRC                                           @SC86295 05467000
         TM    OPTFLAGS,NOIMPCP                                @SC86295 05468000
         BO    ICPCMIL       No implied CP commands            @SC86295 05469000
         TM    FL4,UCMD      User command?                     @SC86295 05470000
         BO    ICPCMSCP      Yes, maybe it's for CP            @SC86295 05471000
ICPCMIL  MVI   ERRNUM,ERRSYS Illegal system command            @SC86295 05472000
         B     RTRNM1                                          @SC86295 05473000
ICPCMP   CLC   1(,4),0(3)    Partial token matching            @SC86158 05474000
IFSCB    FSCB  'X X',BSIZE=80,RECNO=1,RECFM=V                  @SC86158 05475000
* Execute CP command sent to CMS (assumed SCANN'ed)            @SC86158 05476000
ICPCMSCP L     0,NUCPLCMD    Get cmd ptr                       @SC86158 05477000
         L     6,NUCPLEND                                      @SC86158 05478000
         SR    6,0           Get length                        @SC86158 05479000
         LA    1,1           Simulate normal entry             @SC86158 05480000
* Execute CP command at (R0) with text interception            @SC86158 05481000
ICPCP    BCT   1,ICPRST                                        @SC86158 05482000
         LR    1,0           Copy ptr for upcasing             @SC87034 05483000
         LTR   4,6                                             @SC87034 05484000
         BNP   ICPCMIL       Nothing there                     @SC87034 05485000
         BCTR  4,0                                             @SC87034 05486000
         EX    4,TRUPCAS                                       @SC87034 05487000
         CLC   SVCNPSW,SVCSNAG                                 @SC86283 05488000
         BNE   ICPCDG        Not intercepting, just do it      @SC86283 05489000
         KCALL SETMSG,3      Restore CP settings               @SC86158 05490000
         LM    1,2,SVCOPTR   Response buffer                   @SC86158 05491000
         SR    2,1           Get buffer length                 @SC86158 05492000
         L     7,=F'8192'    Max length from CP                @SC86158 05493000
         CR    7,2           Do we have that much?             @SC86158 05494000
         BNH   *+6                                             @SC86158 05495000
         LR    7,2           Use what we have                  @SC86158 05496000
         LR    2,7           Remember                          @SC86158 05497000
         ICM   6,8,BLANK                                       @SC86158 05498000
         DIAG  0,6,8         Issue command                     @SC86158 05499000
         BZ    *+6                                             @SC86158 05500000
         LR    7,2           Not likely: filled buffer         @SC86158 05501000
         A     7,SVCOPTR                                       @SC86158 05502000
         BCTR  7,0           Scan back over any extra X'15'    @SC86158 05503000
         CLI   0(7),X'15'                                      @SC86158 05504000
         BE    *-6                                             @SC86158 05505000
         LA    7,2(7)        Keep one X'15'                    @SC86158 05506000
         C     7,SVCOPTR+4   Be careful of end                 @SC86158 05507000
         BNH   *+8           OK                                @SC86158 05508000
         L     7,SVCOPTR+4   Got past it somehow               @SC86158 05509000
         ST    7,SVCOPTR                                       @SC86158 05510000
         KCALL SETMSG,2      Change CP settings again          @SC86158 05511000
         B     ICPRC                                           @SC86295 05512000
*                                                                       05513000
ICPCDG   DIAG  0,6,8         Issue command                     @SC86283 05514000
ICPRC    C     6,F1          Illegal command?                  @SC86295 05515000
         BE    ICPCMIL       Yes                               @SC86295 05516000
* Issue return code msg if needed                              @SC86295 05517000
SFCRC    LTR   4,6           Check RC                          @SC86295 05518000
         BZ    SFCZRC        RC=0                              @SC86158 05519000
         TM    FL4,UCMD      User cmd?                         @SC86316 05520000
         BZ    SFCZRC        No, don't issue message           @SC86316 05521000
         MVC   CMD(2),=C'R(' Set up message                    @SC86209 05522000
         LA    15,CMD+2                                        @SC86209 05523000
         BAL   2,EDDEC       Edit RC into msg                  @SC86295 05524000
         MVI   0(15),C')'    Format is R(rc)                   @SC86209 05525000
         LA    0,1(15)                                         @SC86268 05526000
         LA    1,CMD         Start of edited string            @SC86209 05527000
         SR    0,1           Length                            @SC86268 05528000
         WTEXT (1),(0)                                         @SC86268 05529000
SFCZRC   LR    15,6                                            @SC86295 05530000
         MVI   ERRNUM,ERRNOE No errors                         @SC86295 05531000
         B     RTRN                                            @SC86295 05532000
*                                                                       05533000
SFCLIN   BCT   1,SFCSTK                                        @SC86295 05534000
* Retrieve original command line arguments, if any             @SC86295 05535000
*   Return code =0 if yes, =1 if no                            @SC86295 05536000
*   Leave string in CBUF buffer (up to 256), length in CLEN    @SC86295 05537000
         LM    5,6,ORGR0     Original R0,R1                    @SC87253 05538000
         CLI   0(6),255                                        @SC86171 05539000
         BE    RTRN1         Go if, e.g., just 'START'         @SC86171 05540000
         LA    6,8(6)        Ok, point to arguments            @SC86171 05541000
         CLI   0(6),255                                        @SC86171 05542000
         BE    RTRN1         Go if nothing on cmd                       05543000
         L     3,CBUF        A safe data area                           05544000
         CLI   ORGR1,1                                         @SC87253 05545000
         BL    SFCCMDK       R1 hi order byte is 0                      05546000
         CLI   ORGR1,11                                        @SC87253 05547000
         BH    SFCCMDK       R1 hi order byte is > X'0B'                05548000
         L     6,4(5)        Address of arguments              @SC87253 05549000
         MVC   0(256,3),0(6) Copy this, instead                         05550000
         S     6,8(5)        End address of command            @SC87253 05551000
         LPR   3,6           Make it positive                  @SC86295 05552000
         B     SFCCMDS                                         @SC86295 05553000
*                                                                       05554000
SFCCMDK  MVC   0(8,3),0(6)   Copy token                                 05555000
         LA    1,8(3)        Char after token                  @SC86295 05556000
         TRT   0(8,3),TRTBL  Find blank                        @SC86295 05557000
         MVI   0(1),C' '     Add a blank, in case              @SC86295 05558000
         LA    3,1(1)        Skip over blank                   @SC86295 05559000
         LA    6,8(6)        Skip a CMS token                           05560000
         CLI   0(6),255                                                 05561000
         BNE   SFCCMDK       Loop if not end                            05562000
         S     3,CBUF        Length = current pos - beginning           05563000
SFCCMDS  C     3,F256        Is it too long?                            05564000
         BNH   *+8           No, OK length                              05565000
         L     3,F256        Truncate past CMD length                   05566000
         ST    3,CLEN        Save command length                        05567000
         B     RTRN0                                           @SC86295 05568000
*                                                                       05569000
* Test for stacked commands                                    @SC86295 05570000
*   return code = number of stacked lines                      @SC86295 05571000
SFCSTK   BCT   1,SFCKIL                                        @SC86295 05572000
         LH    15,NUMFINRD   Pending lines                     @SC86295 05573000
         A     15,NUCNLSTK   Lines in program stack            @SC86295 05574000
         B     RTRN                                            @SC86295 05575000
*                                                                       05576000
* Log out                                                      @SC86295 05577000
SFCKIL   BCT   1,SFCWT                                         @SC86295 05578000
         CPCMD 1,0,'LOGOFF'                                    @SC86295 05579000
*                                                                       05580000
* Wait specified time in R0 (sec)                                       05581000
SFCWT    BCT   1,SFCCLK                                        @SC86295 05582000
       LINEDIT TEXT='SL ..... SEC',DOT=NO,DISP=CPCOMM,                 +05583000
               SUB=(DEC,(0))                                   @SC86184 05584000
         B     RTRN0                                           @SC86295 05585000
*                                                                       05586000
* Return time in centisec in R15                                        05587000
SFCCLK   BCT   1,SFCPRP                                        @SC87351 05588000
         STCK  TMPDW         Store TOD clock                   @SC86295 05589000
         LM    14,15,TMPDW                                     @SC86295 05590000
         SLDL  14,8          Take mod 204 days                 @SC86295 05591000
         SRDL  14,20         Get in microsec                   @SC86295 05592000
         D     14,=F'10000'  Get in centisec                   @SC86295 05593000
         B     RTRN                                            @SC86295 05594000
*                                                                       05595000
SFCPRP   B     RTRN0         No action for prompting           @SC87351 05596000
         TITLE 'SVC interceptor,  executed in system protect key'       05597000
         USING ICPTYP,15                                       @SC86283 05598000
ICPTYP   STM   12,14,SVCSV1  Save regs                         @SC86283 05599000
         L     13,SVCSNAG+4  Addressability                    @SC86283 05600000
         DROP  15                                                       05601000
         USING SVCEXIT,13                                      @SC86283 05602000
         B     ICPTGO        Grab it                           @SC86283 05603000
SVCEXIT  STM   12,13,0       Save regs                         @SC86158 05604000
         BALR  13,0          Addressability                    @SC86158 05605000
         USING *,13                                            @SC86158 05606000
         L     13,SVCSNAG+4  Addressability                    @SC86283 05607000
         USING SVCEXIT,13                                      @SC86283 05608000
         ICM   13,8,SVCEXIT  Flag for SVC entry                @SC86283 05609000
         MVC   SVCSV1(8),0                                     @SC86158 05610000
         STM   14,15,SVCSV2                                    @SC86158 05611000
         L     12,AFVS                                         @SC86158 05612000
         USING FVSECT,12                                       @SC86158 05613000
         TM    UFDBUSY,ABNBIT  ABEND in progress?              @SC86158 05614000
         BO    SVCCNCL                                         @SC86158 05615000
         CLI   SVCOPSW+3,13  ABEND?                            @SC86158 05616000
         BE    SVCCNCL                                         @SC86158 05617000
         CLI   SVCOPSW+3,203                                   @SC86158 05618000
         BE    SVC203T       Could be DMSABN                   @SC86158 05619000
         CLI   SVCOPSW+3,202                                   @SC86158 05620000
         BNE   SVCGO         Ok, do it                         @SC86158 05621000
         CLC   =CL8'TYPLIN',0(1)  WRTERM?                      @SC86158 05622000
         BNE   SVCGO         No, do it                         @SC86158 05623000
ICPTGO   LM    14,15,SVCOPTR Output ptrs                       @SC86158 05624000
         SR    15,14         Length left                       @SC86158 05625000
         LA    12,255        Limit                             @SC86158 05626000
         CH    12,14(1)      Buffer length                     @SC86295 05627000
         BNH   *+8           Too big                           @SC86158 05628000
         LH    12,14(1)      Ok, use it                        @SC86295 05629000
         LTR   12,12                                           @SC86158 05630000
         BNP   ICPTRET                                         @SC86283 05631000
         CR    12,15         Enough room?                      @SC86283 05632000
         BH    ICPTRET       No                                @SC86283 05633000
         ICM   15,7,9(1)     Buffer address                    @SC86295 05634000
         BCTR  12,0          Set up for mvc                    @SC86158 05635000
         EX    12,SVCCOPY    Move to WBUF                      @SC86158 05636000
         LA    14,2(12,14)   New end                           @SC86158 05637000
         ST    14,SVCOPTR                                      @SC86158 05638000
ICPTRET  SR    15,15         Success                           @SC86283 05639000
         CLM   13,8,SVCEXIT  Was it an SVC?                    @SC86283 05640000
         BE    SVCDONE       Yes                               @SC86283 05641000
         LM    12,14,SVCSV1  Restore regs                      @SC86283 05642000
         BR    14            Return                            @SC86283 05643000
SVCDONE  L     12,SVCOPSW+4  Return adr                        @SC86158 05644000
         CLI   0(12),0       Error adr given?                  @SC86158 05645000
         BNE   SVCRET                                          @SC86158 05646000
         LA    14,4(12)      Yes, skip over                    @SC86158 05647000
SVCSKP   STCM  14,7,SVCOPSW+5                                  @SC86158 05648000
SVCRET   LM    12,14,SVCSV1  Restore                           @SC86158 05649000
         SR    15,15         'success'                         @SC86158 05650000
         LPSW  SVCOPSW       Return                            @SC86158 05651000
SVCCOPY  MVC   0(,14),0(15)                                    @SC86158 05652000
*                                                                       05653000
SVC203T  L     12,SVCOPSW+4  Code ptr                          @SC86158 05654000
SVCABNT  CLI   1(12),11      DMSABN?                           @SC86158 05655000
         BNE   SVCGO         No, do it                         @SC86158 05656000
SVCCNCL  MVC   SVCNPSW,SAVENPSW  Cancel interception           @SC86158 05657000
         MVC   ADMSCWR,TYPSAV                                  @SC86283 05658000
SVCGO    MVC   0(8,0),SAVENPSW   Proper SVC handler            @SC86158 05659000
         LM    12,15,SVCSV1                                    @SC86158 05660000
         LPSW  0                                               @SC86158 05661000
* Storage for SVC interception                                 @SC86158 05662000
SAVENPSW DS    D             SYSTEM  SVC NPSW                  @SC86158 05663000
SVCSNAG  DC    A(0,SVCEXIT)  My replacement                    @SC86158 05664000
SVCSV1   DS    2F            Saved 12,13                       @SC86158 05665000
SVCSV2   DS    2F            Saved 14,15                       @SC86158 05666000
SVCOPTR  DS    2F            Buffer output and end ptrs        @SC86158 05667000
TYPSAV   DS    F             Saved system address              @SC86283 05668000
         LOCALS ,                                              @SC86295 05669000
SUPFNC   EXIT                                                  @SC86158 05670000
         TITLE 'TERMIO Routine - Handle terminal I/O'                   05671000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05672000
* successfull, R15 returns transferred byte count (else returns -1).    05673000
*               Command code is in R0:                                  05674000
* 1 => Open line for I/O            4 => Write packet                   05675000
* 2 => Close line                   5 => Read packet                    05676000
* 3 => Reset line status after    ( 6 => Write message ) not used       05677000
*      environment changes                                              05678000
*                                                                       05679000
TERMIO   ENTER                                                          05680000
         SR    15,15         OK                                @SC86295 05681000
         BCT   0,TRMCLS                                        @SC86295 05682000
* Open terminal line for protocol                                       05683000
         WAITT                                                          05684000
         STAX  BR14          Ingore attention interrupts                05685000
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05686000
         MVI   TRMFLG,X'FF'  Initialize w/r flag               @SC87275 05687000
         B     TRMSPRP                                         @SC87275 05688000
* Close terminal line after protocol transfer                           05689000
TRMCLS   BCT   0,TRMRSET                                       @SC86295 05690000
         STAX                                                           05691000
         B     RTRN0                                           @SC86295 05692000
* (Re)set terminal characteristics to suit environment                  05693000
TRMRSET  BCT   0,TRMRW                                         @SC86295 05694000
         B     RTRN0                                           @SC86295 05695000
*                                                                       05696000
*  Perform I/O request                                                  05697000
TRMRW    BCT   0,TRMRD                                         @SC87275 05698000
         CLI   WRRD,0        Write/read?                       @SC87275 05699000
         BE    TRMWO         No, do it immediately             @SC87275 05700000
         MVC   RIOPRP(8),0(1)  Yes, save stuff for prompt      @SC87275 05701000
         B     RTRN0                                           @SC87275 05702000
TRMWO    MVI   TRMFLG,0      Indicate no action on follow-up   @SC87275 05703000
         B     TRMEX         Do the write                      @SC87275 05704000
TRMRD    TS    TRMFLG                                          @SC87275 05705000
         BZ    RTRN0         Just a follow-up. 0-length read   @SC87275 05706000
*                                                                       05707000
TRMEX    SLA   0,4                                             @SC87275 05708000
         LA    8,TRMPLS                                        @SC87275 05709000
         AR    8,0           Get appropriate CCW skeleton      @SC86295 05710000
         MVC   9(3,8),1(1)   Copy adr                          @SC86295 05711000
         MVC   14(2,8),6(1)  Copy len                          @SC86295 05712000
         HOST  0(8)          Issue command                     @SC86295 05713000
         LH    15,14(8)      Number of chars xfer'd            @SC86295 05714000
TRMSPRP  LA    0,S1EOL       Reinstate "normal" prompt         @SC87275 05715000
         LA    1,2                                             @SC87275 05716000
         CLI   S1HND,0       Handshake desired?                @SC87275 05717000
         BNE   *+6           Yes, ok                           @SC87275 05718000
         BCTR  1,0           No, send just the EOL             @SC87275 05719000
         STM   0,1,RIOPRP                                      @SC87275 05720000
         RET                                                   @SC86295 05721000
*                                                                       05722000
TRMPLS   DS    0F            Terminal I/O plists               @SC86295 05723000
* WRTERM Plist during Kermit protocol                                   05724000
         DC    CL8'TYPLIN'                                              05725000
         DC    X'01',AL3(*-*) Send buffer address              @SC86190 05726000
         DC    C'B',X'92'    B=Black,02=No xlate,90=Long       @TB86218 05727000
         DC    H'0'          Buffer length                              05728000
* RDTERM plist during RPACK                                             05729000
         DC    CL8'WAITRD'                                              05730000
         DC    X'01',AL3(*-*) Rcv buffer addr                  @SC86190 05731000
         DC    C'*',C'B'     *:long, B:prompt/direct           @SC87201 05732000
         DC    AL2(0)        Input data length                          05733000
RIOPRP   DC    A(0,1)        Prompt                            @SC87275 05734000
         LOCALS ,                                              @SC86295 05735000
         EXIT                                                           05736000
         TITLE 'SCRNIO Routine - Handle screen I/O via Series/1'        05737000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05738000
* successfull, R15 returns transferred byte count (else returns -1).    05739000
*               Command code is in R0:                                  05740000
* 1 => Open screen for I/O            4 => Write packet                 05741000
* 2 => Close screen                   5 => Read packet                  05742000
* 3 => Reset screen status after      6 => Write message                05743000
*      environment changes                                              05744000
*                                                                       05745000
* CCW Flags, WCC flag bits, CSW flags:                                  05746000
CC       EQU   X'40'         Command chaining                  @SC86159 05747000
SLI      EQU   X'20'         Suppress Incorr Len Ind                    05748000
ATN      EQU   X'80'         Attention                                  05749000
CE       EQU   X'08'         Channel end                                05750000
DE       EQU   X'04'         Device end                                 05751000
UC       EQU   X'02'         Unit check                                 05752000
UE       EQU   X'01'         Unit exception                             05753000
CPBRK    EQU   ATN+CE+DE+UC  CP break-in                                05754000
*                                                                       05755000
SCRNIO   ENTER                                                          05756000
         BCT   0,SCRCLS                                        @SC86295 05757000
         XC    CONSCSW(8),CONSCSW Clear any previous data      @SC86135 05758000
         WAITT ,             Make CMS happy                             05759000
         HOST  HNDINTPL      Issue HNDINT                      @SC86295 05760000
         LA    8,SCRCCWCL    Clear screen now                  @SC86295 05761000
         BAL   9,SCRNEX                                        @SC86295 05762000
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05763000
         ICM   0,15,LCLDLY                                     @SC87268 05764000
         BZ    RTRN0         Skip extra delay                  @SC87268 05765000
         CPCMD 6,7,'SL 1 SEC' This seems useful                @HF86233 05766000
         B     RTRN0                                           @SC86295 05767000
SCRCLS   BCT   0,SCRRSET                                       @SC86295 05768000
         LA    8,SCRCCWVM    Release screen                    @SC86295 05769000
         BAL   9,SCRNEX                                        @SC86295 05770000
         HNDINT CLR,(CON1)                                              05771000
         LA    5,=C'READY ...' Make sure hanging writes appear @SC86159 05772000
         MVC   6(3,5),CONSADH Use console vaddr                @SC86159 05773000
         LA    7,9           String length                     @SC86159 05774000
         CPCMD 5,7,RESP=YES  Suppress reply                    @SC86159 05775000
         B     RTRN0                                           @SC86295 05776000
* (Re)set device characteristics to suit environment                    05777000
SCRRSET  BCT   0,SCRRW                                         @SC86295 05778000
         B     RTRN0                                                    05779000
*                                                                       05780000
*  Perform I/O request                                                  05781000
SCRRW    SLA   0,3                                             @SC86295 05782000
         LA    8,SCRCCWS-8                                     @SC86295 05783000
         AR    8,0           Get appropriate CCW skeleton      @SC86295 05784000
         MVC   1(3,8),1(1)   Copy adr                          @SC86295 05785000
         MVC   6(2,8),6(1)   Copy len                          @SC86295 05786000
         BAL   9,SCRNEX      Execute internal subr             @SC86295 05787000
         C     8,=A(SCRWCCW+8) Write or Read?                  @SC87286 05788000
         BE    SCRLOG        Read: log the AID                 @SC87286 05789000
         BH    RTRN          No, just return                   @SC87286 05790000
         CLI   TRMTP,C'G'                                      @SC87215 05791000
         BE    RTRN          No interrupt if graphics          @SC87215 05792000
* Wait for attention interrupt                                          05793000
SCRWLP   CLI   CONSUNIT,ATN                                    @SC86295 05794000
         BE    RTRN          Read if last int was an ATTN      @SC86295 05795000
         LR    9,15          Save byte count                   @SC86295 05796000
         WAITD CON1          Wait for ATTN intrpt                       05797000
         LR    15,9                                            @SC86295 05798000
         B     SCRWLP                                          @SC86295 05799000
*                                                                       05800000
SCRLOG   TM    FL1,DEBUG     Logging in effect?                @SC87286 05801000
         BZ    RTRN          No, that's all                    @SC87286 05802000
         L     2,LOGBUF      Ptr to buffer                     @SC87286 05803000
         MVI   0(2),C'A'     Set label                         @SC87286 05804000
         L     3,0(8)        Ptr to AID                        @SC87286 05805000
         MVC   2(3,2),0(3)   Copy into buffer                  @SC87286 05806000
         LR    9,15          Save data length                  @SC87286 05807000
         WRITF LOGPTR,BSIZE=5 Log it                           @SC87286 05808000
         LR    15,9          Return data length                @SC87286 05809000
         B     RTRN                                            @SC87286 05810000
*                                                                       05811000
SCRNEX   LR    1,8           Get CCW ptr                       @SC86295 05812000
         LA    4,1           Allow retry                       @SC86159 05813000
         LH    2,CONSADDR            Console address                    05814000
         TIO   0(2)                  See if usable                      05815000
         BC    6,*-4                 Loop if busy or CSW stored         05816000
         BC    1,SCRERR              not operational: error             05817000
SCRDIAG  DIAG  1,2,X'0058'   Start I/O via diagnose            @SC86159 05818000
         BNZ   SCRERR                Error                              05819000
SCRWAIT  WAITD CON1                  Wait for I/O to complete           05820000
         CLI   CONSCHAN,0                                               05821000
         BNE   SCRERR                Go if ch error                     05822000
         CLI   CONSUNIT,CE                                              05823000
         BE    SCRWAIT               Wait if just a ch end              05824000
         CLI   CONSUNIT,CPBRK                                           05825000
         BE    SCRBRK        Possible error if CP broke in     @SC86159 05826000
         LH    15,6(8)       Buffer size                       @SC86295 05827000
         LH    1,CONSBYTC    Residual count                    @SC86295 05828000
         LTR   1,1                                             @SC86295 05829000
         BZ    *+8           0 => was a write                  @SC86295 05830000
         LA    1,3(1)        Deduct 3 for buffer adr           @SC86295 05831000
         SR    15,1          Bytes read                        @SC86295 05832000
         CLI   CONSUNIT,DE                                              05833000
         BER   9             Go if dev end                     @SC86295 05834000
         CLI   CONSUNIT,CE+DE                                           05835000
         BER   9             Go if chan and dev end            @SC86295 05836000
         CLI   CONSUNIT,ATN                                             05837000
         BER   9             Go if attn                        @SC86295 05838000
SCRERR   SR    15,15                                           @SC86295 05839000
         BCTR  15,0          Return error code of -1           @SC86295 05840000
         BR    9                                               @SC86295 05841000
SCRBRK   BCT   4,SCRERR      Quit after one retry              @SC86159 05842000
         LA    5,=C'RESET ...'                                 @SC86159 05843000
         MVC   6(3,5),CONSADH Use console vaddr                @SC86159 05844000
         LA    7,9           String length                     @SC86159 05845000
         CPCMD 5,7,RESP=YES  Suppress reply                    @SC86159 05846000
         LA    6,RTRYIO                                        @SC86159 05847000
         DIAG  6,2,X'0058'   Take the screen back              @SC86159 05848000
         BNZ   SCRERR                                          @SC86159 05849000
SCRTWT   WAITD CON1          Wait for I/O to complete          @SC86159 05850000
         CLI   CONSCHAN,0                                      @SC86159 05851000
         BNE   SCRERR        Go if ch error                    @SC86159 05852000
         CLI   CONSUNIT,CE                                     @SC86159 05853000
         BE    SCRTWT        Wait if just a ch end             @SC86159 05854000
         LR    1,8           Retrieve R1                       @SC86159 05855000
         B     SCRDIAG       Try again                         @SC86159 05856000
         DS    0D                                                       05857000
SCRCCWCL DC    X'19',AL3(0),AL1(SLI),X'FF',AL2(1)                       05858000
SCRCCWVM DC    X'19',AL3(0),AL1(SLI),X'FE',AL2(1)                       05859000
*                                                                       05860000
SCRCCWS  DS    0D            Pattern commands                  @SC86295 05861000
SCRWCCW  DC    X'29',AL3(0),AL1(SLI),X'00',AL2(0)  Write       @SC86295 05862000
         DC    X'2A',AL3(0),AL1(SLI),X'80',AL2(0)  Read mod    @SC86295 05863000
         DC    X'29',AL3(0),AL1(SLI),X'80',AL2(0)  Write mod   @SC86295 05864000
RTRYIO   DC    0D'0',X'19',AL3(0),AL1(CC+SLI),X'FF',AL2(1)     @SC86159 05865000
         DC    X'29',AL3(RTRYCM),AL1(SLI),X'80',AL2(1)         @SC86159 05866000
RTRYCM   DC    X'C0'                                           @SC86159 05867000
         TITLE 'SETMSG Routine - controls CP breakin'                   05868000
* Entry: R1 selects operation                                           05869000
* Exit: R15=0 if ok                                                     05870000
* 1-> Analyze user environment, determine if suitable.                  05871000
*     Save quantities needed and condition line for entering commands.  05872000
*     Perform any system-dependent initialization.                      05873000
* 2-> Condition line for protocol transfers.                            05874000
* 3-> Decondition line at end of transfer.                              05875000
* 4-> System-dependent clean-up at exit.                                05876000
* 5-> Reperform system-dependent intialization after SET LINE.          05877000
SETMSG   ENTER ALT                                             @SC86295 05878000
         BCT   1,STM2                Go if R1 not 1, so no init         05879000
STMSTY   L     2,CBUF        Put diag result here                       05880000
         LA    3,32          Get this much info                         05881000
         DIAG  2,3,X'00'     Identify                                   05882000
         MVC   USRTAKE,16(2) Move userid to our buffer                  05883000
         L     1,ASTMUSET                                      @SC87117 05884000
         MVC   0(STMUL+STMLL,1),STMUOFF Set up pattern         @SC87117 05885000
         CPCMD 2,4,'Q SET',RESP=YES                            @SC86148 05886000
         MVC   ADR,CBUF              Response address for parser        05887000
         ST    5,LEN                 Response length for parser         05888000
         MVC   STMSCNS(8),SCANPTR Save string ptrs             @SC87117 05889000
         S     1,F4          Start of list: back 8, up L'SET +1@SC87117 05890000
         SR    5,5           Length of previous data           @SC86148 05891000
         LA    8,STMLEN-2    Descriptor list                   @SC86148 05892000
         LA    4,6           Number of items in QUERY SET      @SC86148 05893000
         BAL   2,STMGET                                        @SC86295 05894000
         BCT   4,*-4                                           @SC86148 05895000
         MVC   SCANPTR(8),STMSCNS                              @SC87117 05896000
         BAL   2,STMGET      Scan again for LINEDIT            @SC87117 05897000
         CPCMD 2,6,'Q TERM',RESP=YES                           @SC86148 05898000
         MVC   ADR,CBUF              Response address for parser        05899000
         ST    7,LEN         Response length for parser        @SC87117 05900000
         LA    1,1(1)        One extra: L'TERM - L'SET         @SC87117 05901000
         BAL   2,STMGET                                        @SC86295 05902000
         BAL   2,STMGET      (if more: put S 1,F4 in loop)     @SC87295 05903000
         STM   10,11,STMSAVR Save base registers               @SC87117 05904000
         HOST  STMEXC        Set up subcommand environment     @SC87117 05905000
         B     STM5X                                           @SC87351 05906000
         DS    0F                                              @SC87117 05907000
STMEXC   DC    CL8'SUBCOM',CL8'KERMIT'                         @SC87117 05908000
         DC    F'0',A(STMSUBC,0)                               @SC87117 05909000
*                                                                       05910000
STM2     BCT   1,STM3                Go if R1 was not 2, so not off     05911000
         TM    FL1,TSTF                                        @SC86295 05912000
         BO    RTRN0         Just testing, don't change it     @SC86295 05913000
         CLI   TRMLIN,C' '   Alternate comm line?              @SC87300 05914000
         BNE   RTRN1         Not allowed!                      @SC87300 05915000
         LA    2,STMUOFF             Set everything off                 05916000
         MVC   STMUOTB,AOUTRTBL Save user's table ptrs         @SC87201 05917000
         MVC   STMUITB,AINTRTBL                                @SC87201 05918000
         LA    7,F0          Set to turn off translation       @SC87201 05919000
         LR    8,7                                             @SC87201 05920000
         B     STMD                                                     05921000
*                                                                       05922000
STM3     BCT   1,STM4                                          @SC86316 05923000
         L     2,ASTMUSET    Restore user's settings           @SC87117 05924000
         LA    7,STMUITB     Restore user's table ptrs         @SC87201 05925000
         LA    8,STMUOTB                                       @SC87201 05926000
STMD     LA    4,STMUL       Length of 1st batch               @SC87117 05927000
         LA    5,0(2,4)      Start of 2nd                      @SC87117 05928000
         CPCMD 2,4           Issue a bunch of CP commands      @SC87117 05929000
         CLI   TRMTP,C'T'    Fullscreen mode?                  @SC87166 05930000
         BNE   RTRN0         Yes, skip linemode stuff          @CR86321 05931000
         DMSEXS MVC,AINTRTBL,0(7)   Restore input table        @SC87201 05932000
         DMSEXS MVC,AOUTRTBL,0(8)   Restore output table       @SC87201 05933000
         LA    7,STMLL                                         @SC87295 05934000
         CPCMD 5,7,RESP=YES  No, do linemode stuff             @SC87295 05935000
         B     RTRN0                                                    05936000
*                                                                       05937000
STM4     BCT   1,STM5        Special clean-up                  @SC87351 05938000
         B     RTRN0         Special clean-up not needed       @SC87351 05939000
*                                                                       05940000
STM5     DS    0H            Re-init after SET LINE            @SC87351 05941000
STM5X    SR    2,2                                             @SC86295 05942000
         BCTR  2,0                                             @SC86295 05943000
         CLI   TRMLIN,C' '   External line?                    @SC87351 05944000
         BE    STM5D         No, use console                   @SC87351 05945000
         LA    5,3+1         Allow no more than 3 hex digits   @SC87351 05946000
         SR    2,2           Init value                        @SC87351 05947000
         LA    1,TRMLIN      Ptr to string                     @SC87351 05948000
STM5L    CLI   0(1),C' '     Look for end of value             @SC87351 05949000
         BE    STM5D         Ok, got number                    @SC87351 05950000
         IC    3,0(1)                                          @SC87351 05951000
         CLI   0(1),C'0'     0-9?                              @SC87351 05952000
         BL    STM5LA                                          @SC87351 05953000
         CLI   0(1),C'9'                                       @SC87351 05954000
         BH    RTRN1         Bad digit                         @SC87351 05955000
         B     STM5LS        Ok, use it                        @SC87351 05956000
STM5LA   CLI   0(1),C'A'     A-F?                              @SC87351 05957000
         BL    RTRN1         Bad                               @SC87351 05958000
         CLI   0(1),C'F'                                       @SC87351 05959000
         BH    RTRN1         Bad                               @SC87351 05960000
         LA    3,9(3)        OK, get in binary                 @SC87351 05961000
STM5LS   SLL   3,28          Convert to nybble                 @SC87351 05962000
         SLDL  2,4                                             @SC87351 05963000
         BCT   5,STM5L                                         @SC87351 05964000
         B     RTRN1         String too long                   @SC87351 05965000
STM5D    DIAG  2,3,X'0024'   Get console flags                          05966000
         BO    RTRN1         Bad device(?)                     @SC87351 05967000
         CLM   3,8,=X'8020'  Is this a terminal?               @SC87351 05968000
         BNE   RTRN1         No, bad device                    @SC87351 05969000
         STH   2,CONSADDR    Save console addr (CUU)                    05970000
         UNPK  CONSADH(4),CONSADDR(3)                          @SC86159 05971000
         TR    CONSADH(3),TRHEX  Save as chars                 @SC86159 05972000
         CLM   4,12,=X'8020' Is this a TTY?                    @SC86295 05973000
         BE    *+8           Yes                               @SC87351 05974000
         MVI   TRMTP,C'S'    Remember going via S/1            @SC87166 05975000
         B     RTRN0                                                    05976000
*                                                                       05977000
* Parse CP response for token pointed by R1:  <len-1> token             05978000
* On entry:    R1 = ptr-8-R5 of name in user list              @SC86148 05979000
*              R5 = length of previous token                   @SC86148 05980000
*              R8 = ptr to previous len-1 of name,data         @SC86148 05981000
* On exit:     R1,R5,R8 updated                                @SC86148 05982000
*              value copied into user list                     @SC86148 05983000
*                                                                       05984000
STMGET   LA    8,2(8)        Point to next descriptor          @SC86148 05985000
         LA    1,8(5,1)      Advance to next name              @SC86148 05986000
         IC    5,1(8)        Get length of data                @SC86148 05987000
STMGET1  NTOKN N=0(2)        Pick next token                   @SC86295 05988000
         CLM   7,1,0(8)      Is this the same size we want?    @SC86148 05989000
         BNE   STMGET1       Not the size we want              @SC86148 05990000
         EX    7,STMGETC             is it right one?                   05991000
         BNE   STMGET1       Nope, keep on looking             @SC86148 05992000
         AR    1,7           Space over name                   @SC86148 05993000
         NTOKN N=0(2)        Use the next token                @SC86316 05994000
         EX    5,STMGETM     Copy value                        @SC86148 05995000
         BR    2                                               @SC86295 05996000
*                                                                       05997000
STMGETC  CLC   0(,1),0(6)    Check token against list          @SC86148 05998000
STMGETM  MVC   2(,1),0(6)    Save value in list                @SC86148 05999000
*                                                                       06000000
*                  MSG  WNG  ACNT RUN  TIME IMSG EDIT SIZE SCRL@SC87295 06001000
STMLEN   DC    AL1(02,3,02,3,03,2,02,2,04,3,03,3,06,2,07,2,05,3) C87295 06002000
*                                                                       06003000
STMUOFF  DC    C'SET MSG OFF ',X'15' CP commands to set all off         06004000
         DC    C'SET WNG OFF ',X'15' (in order of CP msgs)              06005000
         DC    C'SET ACNT OFF',X'15'                                    06006000
         DC    C'SET RUN ON ',X'15'                                     06007000
         DC    C'SET TIMER OFF ',X'15'                         @SC87117 06008000
         DC    C'SET IMSG OFF ',X'15'                          @SC87117 06009000
STMUL    EQU   *-STMUOFF                                       @CR86321 06010000
         DC    C'SET LINEDIT OFF',X'15' Separate batch of SET's@SC87117 06011000
STMLOFF  DC    C'TERM LINESIZE OFF'                            @CR86321 06012000
         DC    CL5' ',C'SCROLL CONT'  (if more, cut to 1 sp)   @SC87295 06013000
STMLL    EQU   *-STMUOFF-STMUL                                 @SC87117 06014000
         TITLE 'STMSUBC Routine - subcommand environment handler'       06015000
         USING STMSUBC,15                                      @SC87117 06016000
STMSUBC  STM   14,12,12(13)  Save registers                    @SC87117 06017000
         LM    10,11,STMSAVR Get base registers                @SC87117 06018000
         LA    0,USNTRFLX    Length of locals                  @SC87117 06019000
         BAL   14,SUBENT     Set up entry                      @SC87117 06020000
         LR    15,12         Recover local base register       @SC87117 06021000
         LR    2,0           Save ptr to EPLIST                @SC87117 06022000
         LA    0,RTRNUM      Set to return error code          @SC87117 06023000
         L     1,=A(USNCMDX) All commands but QUIT             @SC87117 06024000
         BAL   14,LOOPS                                        @SC87117 06025000
         L     12,AUSNTRF    Ptr to main loop routine          @SC87117 06026000
         LM    15,0,4(2)     Ptrs to command and end           @SC87117 06027000
         SR    0,15          Get length                        @SC87117 06028000
         LA    1,CMD                                           @SC87117 06029000
         MVC   0(256,1),0(15) Copy to buffer                   @SC87117 06030000
         OI    KFLG-USNTRFSV(13),CMDC+SIGN Indicate just 1 cmd @SC87117 06031000
         B     LUPPRS                                          @SC87117 06032000
STMSAVR  DS    2F                                              @SC87117 06033000
         TITLE 'S1INT Routine - interrupt handler'                      06034000
         USING S1INT,15                                        @SC86295 06035000
S1INT    STM   2,3,CONSCSW   Save CSW from interrupt                    06036000
         CLI   CONSUNIT,CE                                              06037000
         BNE   S1IOK         Go if not a ch end int            @SC86295 06038000
         LA    15,1          Flag we expect another                     06039000
         BR    14                                              @SC86295 06040000
S1IOK    SR    15,15         R15=0-> intrpt proc complete               06041000
         BR    14                                              @SC86295 06042000
         DROP  15                                              @SC86295 06043000
*                                                                       06044000
* HNDINT Plist for Series/1 interrupt handling                          06045000
HNDINTPL DC    CL8'HNDINT'   HNDINT plist                               06046000
         DC    CL4'SET'      Set function                               06047000
         DC    CL4'CON1'     Symbolic device                            06048000
         DC    AL4(S1INT)    S1 Interrupt handler                       06049000
CONSADDR DC    AL2(9)        Console address                            06050000
         DC    CL2'WC'                                                  06051000
         DC    8X'FF'                                                   06052000
*                                                                       06053000
CONSCSW  DS    A             (key + cc)(1) + CCW addr(3)                06054000
CONSUNIT DS    X             Unit status                                06055000
CONSCHAN DS    X             Channel status                             06056000
CONSBYTC DS    H             Byte count                                 06057000
CONSADH  DC    C'...',C' '   Unpacked vaddr + pad              @SC86159 06058000
         LOCALS ,                                              @SC86295 06059000
STMSCNS  DS    2F            Saved scan ptrs                   @SC87117 06060000
SETMSG   EXIT                                                           06061000
         TITLE 'DISKIO Routine - performs disk I/O functions'           06062000
* Function selected on entry by R0:                                     06063000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   06064000
* 2=> open (out): (same, but no complete FDB if new file)               06065000
* 3=> test name: R2->name.  Returns R1->FDB if found (else R15=1)       06066000
* 4=> close file: R1->adr(FAB).                                         06067000
* 5=> set up search: R1->pattern name.                                  06068000
* 6=> return next file in list:  Returns R1->FDB + sets up FILNAM       06069000
* 7=> close search (if any).                                            06070000
* 8=> test CWD string: R1->string.  Returns R15=0 if ok, else =1.       06071000
* 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         06072000
* 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           06073000
* 11=> test space: R1->adr(FAB), R2=est. Kbytes.  Return R15=0 if ok.   06074000
* 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code    06075000
*      always returns R15=1                                             06076000
* 13=> directory info on file: R1->name.  Returns R15=0 if ok.          06077000
* 14=> delete file: R1->name.  Returns R15=0 if ok.                     06078000
* 15=> rename file: R1->name, R2->new name.  Returns R15=0 if ok.       06079000
* 16=> copy file: R1->name, R2->new name.  Returns R15=0 if ok.         06080000
DISKIO   ENTER                                                          06081000
         USING FABD,3                                          @SC86295 06082000
         SR    4,4           Signal no block assigned          @SC86295 06083000
         BCT   0,DSKOPNO                                       @SC86295 06084000
*                                                                       06085000
* Open for input file whose name is at (R2), FDB at (R1)                06086000
         BAL   9,DSKALC      Get FAB                           @SC86295 06087000
DSKOP0   BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 06088000
         BNZ   DSKER1        Not found                         @SC86295 06089000
         BAL   14,DSKVALS                                      @SC86295 06090000
         B     RTRN0                                           @SC86295 06091000
*                                                                       06092000
* Open for output file whose name is at (R2), FDB at (R1)               06093000
DSKOPNO  BCT   0,DSKTEST                                       @SC86295 06094000
         BAL   9,DSKALC      Get FAB                           @SC86295 06095000
         TM    FDBFLGS,APPN                                    @SC86295 06096000
         BO    DSKOP2                                          @SC86295 06097000
       FSERASE FSCB=(3)                                        @SC86295 06098000
         B     DSKOPLR                                         @SC87012 06099000
DSKOP2   BAL   2,DSKLKP      Get FST, ADT ptrs                 @SC86295 06100000
         BNZ   DSKOPLR       Not found, just writing new       @SC87012 06101000
         BAL   14,DSKVALS                                      @SC86295 06102000
DSKOPLR  SR    0,0                                             @SC87012 06103000
         ICM   0,3,FDBLRC    File LRECL                        @SC87012 06104000
         TM    FL1,BINF                                        @SC87012 06105000
         BO    *+8                                             @SC87012 06106000
         L     0,MAXLRC      TEXT file, no limit               @SC87012 06107000
         ST    0,MAXOUT      Set output buffer limit           @SC87012 06108000
         B     RTRN0                                           @SC86295 06109000
*                                                                       06110000
* Test for existence of file whose name is at (R2)                      06111000
DSKTEST  BCT   0,DSKCLOS                                       @SC86295 06112000
         MVC   DSKSTNM,0(2)                                    @SC86295 06113000
         LA    3,DSKSTT                                        @SC86295 06114000
         B     DSKOP0        Test file                         @SC86295 06115000
*                                                                       06116000
* Close file whose ticket is at (R1), release block                     06117000
DSKCLOS  BCT   0,DSKNSET                                       @SC86295 06118000
         ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 06119000
         BZ    RTRN0         None, ignore                      @SC86295 06120000
         XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 06121000
       FSCLOSE FSCB=(3)                                        @SC86295 06122000
         LA    0,FABDWDS                                       @SC86295 06123000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 06124000
         B     RTRN0                                           @SC86295 06125000
*                                                                       06126000
* Read from file whose ticket is at (R1)                                06127000
DSKRED   BCT   0,DSKWRT                                        @SC86295 06128000
* - - - not used - - -                                         @SC86295 06129000
         B     RTRN1                                           @SC87320 06130000
*                                                                       06131000
* Write to file whose ticket is at (R1)                                 06132000
DSKWRT   BCT   0,DSKTSP                                        @SC86316 06133000
* - - - not used - - -                                         @SC86295 06134000
         B     RTRN1                                           @SC87320 06135000
*                                                                       06136000
* Analyze error: packed dec. code in TMPDW                              06137000
DSKXXX   BCT   0,DSKUTL                                        @SC86316 06138000
         MVI   ERRNUM,ERRDIE Set Kermit error code             @SC87338 06139000
         L     2,EMSGP       Ptr to msg buffer                 @SC87338 06140000
         MVC   0(8,2),0(1)   Copy oprn name                    @SC87338 06141000
         MVC   8(2,2),=C'R='                                   @SC87338 06142000
         OI    TMPDW+7,15    Set zone                          @SC87338 06143000
         UNPK  10(2,2),TMPDW Copy error code                   @SC87338 06144000
         MVC   EMSGL,F12     Length of string                  @SC87338 06145000
         B     RTRN1                                           @SC87338 06146000
*                                                                       06147000
* Disk utility for file(s) at (R1) and (R2)                             06148000
DSKUTL   LR    8,0           Save code-12                      @SC86316 06149000
         BCTR  0,0           Code-13: DIR,DEL,REN,COP          @SC86316 06150000
         SLA   0,3                                             @SC86295 06151000
         LA    5,DSKCMDS                                       @SC86295 06152000
         AR    5,0           Ptr to command name               @SC86295 06153000
         LA    4,CMD         Buffer for tokenized command      @SC86295 06154000
         MVC   0(8,4),0(5)                                     @SC86295 06155000
         LA    4,8(4)                                          @SC86295 06156000
         LR    6,1           1st file                          @SC86295 06157000
         BAL   3,DSKUTCP                                       @SC86295 06158000
         SRA   0,4                                             @SC86295 06159000
         BZ    *+10                                            @SC86295 06160000
         LR    6,2           2nd file                          @SC86295 06161000
         BAL   3,DSKUTCP                                       @SC86295 06162000
         BCT   8,*+14        Go if not LISTFILE                @SC86295 06163000
         MVC   0(16,4),=CL16'(       DATE'                     @SC86295 06164000
         LA    4,16(4)                                         @SC86295 06165000
         MVI   0(4),X'FF'    Insert fence                      @SC86295 06166000
         MVC   1(7,4),0(4)                                     @SC86295 06167000
         LA    0,CMD                                           @SC86295 06168000
         NI    FL4,255-UCMD  Not user command: already tokens  @SC86295 06169000
         KCALL SUPFNC,3      Execute it                        @SC86295 06170000
         B     RTRN                                            @SC86295 06171000
*                                                                       06172000
DSKUTCP  LA    7,LFID        Length of name                    @SC86295 06173000
         ICM   7,8,BLANK     Blank fill                        @SC86295 06174000
         LA    5,24                                            @SC86295 06175000
         MVCL  4,6           Copy name and update R4           @SC86295 06176000
         BR    3                                               @SC86295 06177000
*                                                                       06178000
DSKCMDS  DC    C'LISTFILE'   Utility command names             @SC86295 06179000
         DC    C'ERASE   '                                     @SC86295 06180000
         DC    C'RENAME  '                                     @SC86295 06181000
         DC    C'COPYFILE'                                     @SC86295 06182000
*                                                                       06183000
* Return on error, release useless block, if any                        06184000
DSKER1   LTR   1,4           Any block assigned?               @SC86295 06185000
         BZ    RTRN1         No                                @SC86295 06186000
         LA    0,FABDWDS     Yes, release it                   @SC86295 06187000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 06188000
         B     RTRN1         Flag error                        @SC86295 06189000
*                                                                       06190000
DSKALC   LR    5,1           Save FDB ptr                      @SC86295 06191000
         MVC   DSKSTNM,0(2)                                    @SC86295 06192000
         LA    0,FABDWDS                                       @SC86295 06193000
       DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 06194000
         LR    3,1           New block ptr                     @SC86295 06195000
         LR    4,1                                             @SC86295 06196000
         L     1,4(13)                                         @SC86295 06197000
         ST    3,20(1)       Return R0                         @SC86295 06198000
         XC    0(8*FABDWDS,3),0(3)                             @SC86295 06199000
         MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 06200000
         MVC   FABFN(18),0(2)                                  @SC86295 06201000
         OI    FDBFLGS,FDBEPL                                  @SC86295 06202000
         MVI   FABANIT+3,1                                     @SC86295 06203000
         BR    9                                               @SC86295 06204000
*                                                                       06205000
DSKLKP  DMSKEY NUCLEUS                                         @SC86295 06206000
        GETFST DSKSTT        Call system routine for FST       @SC86295 06207000
         LR    9,0           Save ADT ptr                      @SC86295 06208000
         LR    8,1           And FST ptr                       @SC86295 06209000
         LTR   1,15          Save return code                  @SC86295 06210000
        DMSKEY RESET                                           @SC86295 06211000
         LTR   15,1          Test return code                  @SC86295 06212000
         BR    2                                               @SC86295 06213000
*                                                                       06214000
* Set up search through list of files, pattern at (R1)                  06215000
DSKNSET  BCT   0,DSKNXT                                        @SC86295 06216000
         NI    DSKFL,255-CWDF Find files                       @SC86295 06217000
         MVC   NXFN(18),0(1)                                   @SC86295 06218000
DSKNSX   MVI   ADT,X'80'     Start over                        @SC86295 06219000
         B     RTRN0                                           @SC86295 06220000
*                                                                       06221000
* Flush previous file pattern                                           06222000
DSKXSET  BCT   0,DSKCWDF                                       @SC86295 06223000
         B     DSKNSX                                          @SC86295 06224000
*                                                                       06225000
* Check CWD string, return code in R15                                  06226000
DSKCWDF  BCT   0,DSKRED                                        @SC86295 06227000
         OI    DSKFL,CWDF    Find disk                         @SC86295 06228000
         MVC   NXFN(18),0(1)                                   @SC86295 06229000
         MVI   ADT,X'80'     Start over                        @SC86295 06230000
         B     NXTFST                                          @SC86295 06231000
*                                                                       06232000
* Check disk space for proposed file: FAB ptr at (R1)                   06233000
DSKTSP   BCT   0,DSKXXX                                        @SC86316 06234000
         ICM   3,15,0(1)     Get FAB ptr                       @SC86316 06235000
         BZ    RTRN1         ??                                @SC86316 06236000
         USING ADTSECT,9                                       @SC86316 06237000
         L     9,IADT        Look at 1st ADT                   @SC86316 06238000
DSKTSP1  CLC   ADTM,FABFM    Find right disk                   @SC86316 06239000
         BE    DSKTSP2                                         @SC86316 06240000
         ICM   9,15,ADTPTR   Try next                          @SC86316 06241000
         BNZ   DSKTSP1                                         @SC86316 06242000
         B     RTRN0         Disk not found!                   @SC86316 06243000
DSKTSP2  L     1,ADTNUM      Total blocks                      @SC86316 06244000
         S     1,ADTUSED     Less used                         @SC86316 06245000
         M     0,ADTDBSIZ    Times block size                  @SC86316 06246000
         SRDA  0,10          Convert to Kbytes                 @SC86316 06247000
         CLR   1,2                                             @SC87012 06248000
         BL    RTRN1         No room                           @SC86316 06249000
         B     RTRN0         Ok                                @SC86316 06250000
*                                                                       06251000
*        NXTFST Routine - searches the ADT and FST chains               06252000
DSKNXT   BCT   0,DSKXSET                                       @SC86295 06253000
* Carl Kass and Jeff Damens, CUCCA User Services, 12/80                 06254000
* Modified for Kermit-CMS by Vace Kundakci, 12/85                       06255000
* Copyright (C) 1980 Columbia University                                06256000
* Permission is granted to any individual or institution to copy        06257000
* or use this program, except for explicitly commercial purposes.       06258000
*                                                                       06259000
* IFN, IFT, IFM contains a CMS filename, possibly containing wildcard   06260000
* characters, and FST and ADT contain pointers to a valid ADT & FST     06261000
* or are null (negative ADT), return the next FST matching the given    06262000
* filename in FST and the address of the corresponding ADT in ADT.      06263000
* Also move the matched filename into FN, FT, FM.                       06264000
* Also return info in a File Descriptor Block                  @SC86151 06265000
*                                                                       06266000
         USING FSTSECT,8                                                06267000
         USING DCHSECT,1                                                06268000
NXTFST   ICM   9,15,ADT      Supplied ADT                               06269000
         BP    NXFNEXT               Use it if there's one              06270000
         L     9,IADT        Else, start with first ADT        @SC86295 06271000
         NI    DSKFL,255-WFM-WFT-WFN   Nothing wild yet                 06272000
         LA    3,NXFN                                          @SC86295 06273000
         BAL   14,NXFPAT                                       @SC86295 06274000
           OI  DSKFL,WFN                                       @SC86295 06275000
         LA    3,NXFT                                          @SC86295 06276000
         BAL   14,NXFPAT                                       @SC86295 06277000
           OI  DSKFL,WFT                                       @SC86295 06278000
         CLI   NXFM,C'A'                                       @SC86115 06279000
         BNL   NXFAFM                Go if mode letter is A or more     06280000
         MVI   NXFM,C'%'     Set to % if it was blank          @SC86115 06281000
         OI    DSKFL,WFM                                                06282000
NXFAFM   CLI   NXFM+1,C'0'                                     @SC86115 06283000
         BNL   NXFADT                Go if mode number is numeric       06284000
         MVI   NXFM+1,C'%'   Set to % if was blank or *        @SC86115 06285000
NXFADT   TM    ADTFLG1,ADTFRO+ADTFRW                                    06286000
         BZ    NXFNADT                                                  06287000
         CLI   NXFM,C'%'                                       @SC86115 06288000
         BE    NXFFFST               Go if he can use any               06289000
         CLC   ADTM,NXFM                                                06290000
         BE    NXFFFST               Go if it is this disk              06291000
         TM    DSKFL,CWDF    Called for CWD?                   @SC86295 06292000
         BO    NXFNADT       Just looking for disk             @SC86222 06293000
         CLC   ADTMX,NXFM    Check for read-only extension     @SC86222 06294000
         BE    NXFFFST       Yes, search here too              @SC86222 06295000
NXFNADT  ICM   9,15,ADTPTR   Use next ADT                      @SC86295 06296000
         BNZ   NXFADT                But ony if it exists               06297000
NXFER    MVI   ADT,255               For next time, start all over      06298000
         B     RTRN1         Bad return code                   @SC86295 06299000
*                                                                       06300000
NXFPAT   LA    1,8(3)        End addr of FN or FT              @SC86295 06301000
         TRT   0(8,3),TRTBL  Look for space                    @SC86295 06302000
         SR    1,3           Compute length                    @SC86295 06303000
         ST    1,NXFFNL-NXFN(3) Length of pattern              @SC86295 06304000
         MVI   TRTBL+C' ',0  Don't want to catch a blank       @SC86115 06305000
         MVI   TRTBL+C'%',1  Want to catch a percent           @SC86115 06306000
         MVI   TRTBL+C'*',1  Want to catch an asterisk         @SC86115 06307000
         TRT   0(8,3),TRTBL  See if any % or * in FN           @SC86295 06308000
         MVI   TRTBL+C'%',0  Restore TRTBL                     @SC86115 06309000
         MVI   TRTBL+C'*',0                                    @SC86115 06310000
         MVI   TRTBL+C' ',1                                    @SC86115 06311000
         BZ    4(14)         No wild chars found               @SC86295 06312000
         BR    14                                              @SC86295 06313000
*                                                                       06314000
NXFFFST  L     1,ADTFDA              Grab hyperblock ptr                06315000
         TM    DSKFL,CWDF    Called for CWD?                   @SC86295 06316000
         BO    NXFHSV        Yes, found it                     @SC86164 06317000
NXFHYP   ST    1,NXFHYPE             Save for later                     06318000
         LA    8,DCHDATA             Point to first FST                 06319000
         L     3,DCHDWSIZ            Get size of hyperblock             06320000
         SLL   3,3                   Convert to bytes                   06321000
         LA    2,DCHSECT(3)          Add to get end of hyperblk         06322000
         ST    2,NXFHEND             Save it                            06323000
*                                                                       06324000
* All initialized. Ready to step through files. R8 contains current     06325000
* FST, R9 contains current ADT, NXFHYPE contains current hyperblock     06326000
* NXFHEND has end of hyperblock.                                        06327000
*                                                                       06328000
NXFFST   CLC   F0,FSTN                                                  06329000
         BE    NXFNHYP               Go try next hyperblock             06330000
         CLC   F0,FSTN+4                                                06331000
         BE    NXFNFST               Go if directory or Alocmap         06332000
         LA    4,NXFN                                          @SC86295 06333000
         LA    5,FSTN                                          @SC86295 06334000
         TM    DSKFL,WFN                                       @SC86295 06335000
         BAL   14,NXFCOMP    Test pattern against token        @SC86295 06336000
         LA    4,NXFT                                          @SC86295 06337000
         LA    5,FSTT                                          @SC86295 06338000
         TM    DSKFL,WFT                                       @SC86295 06339000
         BAL   14,NXFCOMP    Test pattern against token        @SC86295 06340000
*                                                                       06341000
         CLI   NXFM+1,C'%'                                     @SC86115 06342000
         BE    NXFHAVE               Go if any FM is ok                 06343000
         CLC   NXFM+1(1),FSTM+1                                @SC86295 06344000
         BNE   NXFNFST               Go if no match                     06345000
NXFHAVE  MVC   FN,FSTN       Return FN                         @SC86164 06346000
         MVC   FT,FSTT               Return FT                          06347000
         MVC   FM+1(1),FSTM+1        Return FM number                   06348000
         LA    3,DSKSTT                                        @SC86295 06349000
         BAL   14,DSKVALS    Copy out quantities               @SC86295 06350000
NXFHSV   MVC   FM(1),ADTM    Return FM letter                  @SC86164 06351000
         ST    9,ADT         Save ADT for him                  @SC86295 06352000
         ST    8,FST         Ditto for FST                     @SC86164 06353000
         B     RTRN0                                           @SC86295 06354000
*                                                                       06355000
* Come to NXFNFST to step to next file.                                 06356000
*                                                                       06357000
NXFNEXT  L     8,FST                                                    06358000
NXFNFST  TM    ADTFLG4,ADTEDF                                           06359000
         BZ    NXFNEDF               Go if not EDF                      06360000
         LA    8,FSTL2(8)            Point to next EDF FST              06361000
         B     NXFEDF                                                   06362000
*                                                                       06363000
NXFNEDF  LA    8,FSTL(8)             Point to next non-EDF FST          06364000
NXFEDF   C     8,NXFHEND             End of hyperblock?                 06365000
         BL    NXFFST                No, there are more FSTs still      06366000
NXFNHYP  L     1,NXFHYPE             Point to current hyperblock        06367000
         ICM   1,B'1111',DCHFWPTR    Next hyperblock                    06368000
         BNZ   NXFHYP                Go use next hyperblock if any      06369000
         B     NXFNADT               Need to use next disk              06370000
*                                                                       06371000
DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 06372000
         L     1,4(13)                                         @SC86295 06373000
         ST    0,24(1)       Return ptr to caller              @SC86295 06374000
         NI    DSKFL,255-WARB                                  @SC86295 06375000
         TM    ADTFLG4,ADTEDF  Extended format?                @SC86149 06376000
         BZ    DSKVNEF                                         @SC86149 06377000
         L     1,ADTDBSIZ    Block size                        @SC86149 06378000
         M     0,FSTADBC     Number of blocks                  @SC86149 06379000
         L     7,FSTAIC      Get item count                    @SC86239 06380000
         MVC   FDBDATE+1(3),FSTADATI Copy file date            @SC86295 06381000
         B     DSKVEF                                          @SC86149 06382000
DSKVNEF  SR    0,0                                             @SC86149 06383000
         LA    1,800         Block size                        @SC86149 06384000
         MH    1,FSTDBC                                        @SC86149 06385000
         LH    7,FSTIC       Get item count                    @SC86239 06386000
         PACK  FDBDATE+1(2),FSTYR(3) Copy file year            @SC86295 06387000
         MVC   FDBDATE+2(2),FSTD     Copy file date            @SC86295 06388000
DSKVEF   SRDA  0,10          Convert to kbytes                 @SC86149 06389000
         M     6,FSTIL       Compute byte count (approx. if V) @SC86239 06390000
         AL    7,=F'1023'    Round up                          @SC87007 06391000
         BNO   *+8           No overflow                       @SC86239 06392000
         LA    6,1(6)                                          @SC86239 06393000
         SRDA  6,10                                            @SC86239 06394000
         CLR   1,7           Compare with official length      @SC86239 06395000
         BL    *+6                                             @SC86239 06396000
         LR    1,7           Use computed length instead       @SC86239 06397000
         LTR   1,1                                             @SC86239 06398000
         BNZ   *+8                                             @SC86239 06399000
         LA    1,1           Never say zero length             @SC86239 06400000
         ST    1,FDBSIZE     File size                         @SC86295 06401000
         MVI   FDBDATE,X'19' Assume 20th Cent                  @SC86295 06402000
         CLI   FDBDATE+1,X'50'                                 @SC86295 06403000
         BH    *+8           Ok                                @SC86295 06404000
         MVI   FDBDATE,X'20' Must be 21st                      @SC86295 06405000
         MVC   FDBRCF,FSTFV  Copy format                       @SC86295 06406000
         MVC   FDBLRC,FSTIL+2 No, copy from FST                @SC86295 06407000
         LR    7,14                                            @SC86295 06408000
         SR    0,0           Search from start                 @SC86295 06409000
         LR    1,3           Filename in FAB                   @SC86295 06410000
         A     13,F8         Preserve chain ptr in save area   @SC86295 06411000
         L     15,AACTLKP    Find if active file               @SC86295 06412000
         BALR  14,15                                           @SC86295 06413000
         S     13,F8         Resume ptr to save area           @SC86295 06414000
         LTR   15,15         Is it active?                     @SC86295 06415000
         BNZR  7                                               @SC86295 06416000
         OI    FDBFLGS,FDBACTV Yes                             @SC86295 06417000
         BR    7                                               @SC86295 06418000
*                                                                       06419000
DSKFL    EQU   DSKSTT+FDBFLGS-FABD   Flags for operation       @SC86295 06420000
CWDF     EQU   X'80'         Looking only for disk             @SC86295 06421000
WARB     EQU   X'40'         Wild char seen                    @SC86295 06422000
*                                                                       06423000
         DROP  1,8,9                                           @SC86295 06424000
*                                                                       06425000
NXFCOMP  MVC   NXFSTR,0(5)   Copy name in                      @SC86295 06426000
         BO    NXFWF         Go if wild FN or FT               @SC86295 06427000
         CLC   NXFSTR,0(4)                                     @SC86295 06428000
         BNE   NXFNFST       Go if no match                    @SC86295 06429000
         BR    14                                              @SC86295 06430000
*                                                                       06431000
NXFWF    LA    1,8(5)        Assume end                        @SC86295 06432000
         TRT   0(8,5),TRTBL  Look for first non-space          @SC86295 06433000
         SR    1,5           Compute length                    @SC86295 06434000
         LR    7,1           Save length                       @SC86295 06435000
         L     5,NXFFNL-NXFN(4)                                @SC86295 06436000
         LA    6,NXFSTR                                        @SC86295 06437000
*                                                                       06438000
* Enter here with R4-R7 containing:                                     06439000
*    pattern address and length                                         06440000
*    source address and length                                          06441000
*                                                                       06442000
         NI    DSKFL,255-WARB Haven't seen any of these        @SC86295 06443000
         ICM   7,B'1000',ASTER       Use * as the fill char             06444000
WLDLOOP  CLCL  4,6                   Compare them                       06445000
         BER   14            They're equal, fine               @SC86295 06446000
*                                                                       06447000
* String mismatch - so examine offending pattern character.  If not     06448000
* % or * and we haven't seen any * yet, we fail.  If it's % we just     06449000
* skip it; if it's * we skip it and remember we've seen it.  Else       06450000
* back up to one past the last * and try again.                         06451000
*                                                                       06452000
         CLI   0(4),C'%'                                       @SC86115 06453000
         BE    WLDLEN1               Go if % = LEN(1) pattern           06454000
         CLI   0(4),C'*'                                       @SC86115 06455000
         BE    WLDARB                Go if * = ARB pattern              06456000
         TM    DSKFL,WARB                                      @SC86295 06457000
         BZ    NXFNFST       Go if ARB already seen            @SC86295 06458000
         CLM   7,B'0111',F0          More data to compare?              06459000
         BE    NXFNFST       Go if exhausted                   @SC86295 06460000
         LM    4,7,WLDPAT            Restore addr of old ARB char       06461000
         LA    6,1(6)                Push one past                      06462000
         BCTR  7,0                   Decrement length                   06463000
         STM   6,7,WLDSRC            Store changed addr                 06464000
         B     WLDLOOP               And go compare again.              06465000
*                                                                       06466000
WLDLEN1  LA    4,1(4)                Increment pattern addr             06467000
         BCTR  5,0                   Decrement pattern len              06468000
         CLM   7,7,F0        Length to compare more            @SC86119 06469000
         BE    NXFNFST       None, pattern '%' is extra        @SC86119 06470000
         LA    6,1(6)                Increment source addr              06471000
         BCTR  7,0                   Decrement source len               06472000
         CLM   7,7,F0        Length to compare more            @SC86119 06473000
         BNE   WLDLOOP               Go if more data                    06474000
         LTR   5,5                   Anything more in pattern?          06475000
         BZR   14            No, it's a match                  @SC86295 06476000
         CLI   0(4),C'*'                                       @SC86115 06477000
         BE    WLDLOOP               Go if ARB                          06478000
         B     NXFNFST       Failed                            @SC86295 06479000
*                                                                       06480000
* If pattern ends in ARB, then it will match anything.  So return to    06481000
* caller if the pattern is exhausted.                                   06482000
*                                                                       06483000
WLDARB   OI    DSKFL,WARB    Remember we saw one               @SC86295 06484000
         LA    4,1(4)                Pass the ARB                       06485000
         BCTR  5,0                   Decrement its length               06486000
         LTR   5,5                   Any more left?                     06487000
         BZR   14            No, it's a match                  @SC86295 06488000
         STM   4,7,WLDPAT            Save where they were               06489000
         B     WLDLOOP                                                  06490000
*                                                                       06491000
         LOCALS ,                                              @SC86295 06492000
WLDPAT   DS    A                     Place in pattern of last ARB       06493000
         DS    F                     Length of pattern past ARB         06494000
WLDSRC   DS    A                     Place in source when ARB seen      06495000
         DS    F                     Length of source past WLDSRC       06496000
*                                                                       06497000
WILD     EXIT                                                           06498000
