*COPY                                                 IKMUTL            05000000
         CHECKVER IKCUTL,4.3                                   @SC90072 05000500
         TITLE 'CWDSET/DSPACE Routines - set/show working directory'    05001000
* Set new 'working directory', i.e., new code (need LSCAN or FILES)     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
         NTOKN N=CWDRSET,H=CWDERR                                       05006000
         C     7,F3                 Length MUST be 4                    05007000
         BNE   CWDERR                                                   05008000
         TM    UPRIVS,LSCAN+FILES   Need some priveleges to             05009000
         BZ    CWDPRV               change code                         05010000
         MVC   UCODE(4),0(6)        Save as new default code            05012000
         TR    UCODE(4),UPCASE     Upper case it               @SC91033 05012500
         MVI   DESTL,1              Yes, new code                       05013000
         B     RTRN0                                           @SC86295 05014000
CWDPRV   PTEXT '&CWDPRVS'                                      @SC92300 05015000
         B     SUBERR                                                   05016000
CWDRSET  MVI   DESTL,0              No more code. Default to user's     05017000
         MVC   UCODE(4),$USRCDE     Get user's code from locore         05018000
         B     RTRN0                                                    05019000
CWDERR   PTEXT '&CWDERRM'                                      @SC92300 05020000
         B     SUBERR               Go display error msg                05021000
* * * * * * * * * * * * * * * * * * * * * *                             05022000
*                                                                       05023000
*                                                                       05024000
*        DSPACE Routine - display available disk space         @SC86164 05025000
*                                                                       05026000
* Show space available in 'working directory' or other area             05027000
* Entry: SCANPTR string has option (none => working directory)          05028000
* Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged    05029000
DSPACE   ENTER ALT                                             @SC86164 05030000
         MFSET DSKST,USERCTL                                            05031000
         MFREQ DSKST              Get User Control Record               05032000
         LA    15,PARMAREA         Temporary output buffer              05033000
         L     4,MFMAXS           Calculate space in use                05034000
         S     4,MFACUR                                                 05035000
         BAL   2,EDDEC            Convert to printable                  05036000
         INITSTR '&KBYTFRE'                                    @SC92300 05037000
         LR    0,15                                            @SC92300 05038000
         LA    1,PARMAREA                                               05039000
         SR    0,1                                                      05040000
         WTEXT (1),(0)       Display the message                        05041000
         B     RTRN0                                                    05042000
         LOCALS ,                                              @SC86295 05043000
         EXIT  ,                                               @SC86295 05044000
         TITLE 'FSPEC Routine - extract filespec from scan string'      05045000
*                                                                       05046000
* Entry: R1->name field, R0=flags selecting operation (see below)       05047000
*        For parse operations, SCANPTR defines the input string.        05048000
*        For getting foreign or display filespec, R7->output buffer     05049000
* Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad.               05050000
*        For R15=1 or 2 R3,R4 give message.  ERRNUM may be leftover.    05051000
*                                                                       05052000
*                                 Flags:                  Notes:        05053000
*   Tasks:               FFRCF FFSND FFGET FFNEW                        05054000
* Parse RECV               X                     set ROVR properly      05055000
* Parse SEND 1st                 X                                      05056000
* Parse SEND 2nd           X     X                                      05057000
* Parse GET 1st                        X                                05058000
* Parse GET 2nd            X           X         set ROVR properly      05059000
* Parse F-packet   (FFHDR) X     X     X                                05060000
* Parse for Generic(FFUTL)       X     X         FFWLD: allow partial   05061000
* Parse TAKE                                                            05062000
*                                                                       05063000
* Get unique name                            X     R15: 0=>ok, 1=>bad   05064000
* Interactive name check               X     X     R15: 0=>ok, 1=>bad   05065000
* Get foreign name (FFENC) X                 X     R15->end of string   05066000
* Get display form (FFDSP)       X           X     R15->end of string   05067000
*                                                                       05068000
FSPEC    ENTER                                                 @SC86295 05069000
         STC   0,FSPFLG                                        @SC86295 05070000
         LR    5,0                                             @SC88049 05071000
         SRL   5,4           Convert flags to index            @SC88049 05072000
         AR    5,5                                             @SC88049 05073000
         LR    0,1           Copy ptr to filespec              @SC86295 05074000
         TM    FSPFLG,FFNEW                                    @SC86295 05075000
         BO    FSPWRN                                          @SC86295 05076000
         MVC   0(LFID,1),BLNAME  Clear the filename to blanks           05077000
         PTEXT '&BADFSPC'                                      @SC92300 05078000
         MVI   ERRNUM,ERRFNE Assume bad file name              @SC86158 05079000
         LH    5,FSP0(5)     Get dispatch adr                  @SC88049 05080000
         B     FSP0(5)       Go to proper handler              @SC88049 05081000
*                                                                       05082000
*                  Take        Get 1st     Send 1st    Generic          05083000
FSP0     DC    AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0)     05084000
*                                                                       05085000
*                  Receive    Get 2nd    Send 2nd    F-packet           05086000
         DC    AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0)        05087000
         SPACE                                                          05088000
FSPUTL   TM    FSPFLG,FFWLD  Utility: default to all files?    @SC88049 05089000
         BZ    FSPASC        No                                @SC86295 05090000
         MVC   0(5,1),UCODE  Default prefix                             05091000
         MVI   5(1),C'*'     Yes                               @SC88308 05092000
FSPSND   DS    0H                                                       05093000
FSPASC   TM    FL2,SRV       Server mode?                      @SC86295 05094000
         BZ    FSPCPY        No, don't need to convert         @SC86295 05095000
         ICM   15,15,LEN     Get length                        @SC86295 05096000
         BZ    FSPCPY                                          @SC86295 05097000
         BCTR  15,0          Correct for EX                    @SC86158 05098000
         L     5,ADR         Get string ptr                    @SC89215 05099000
         EX    15,FSPTRAE    Change to EBCDIC                  @SC89215 05100000
         EX    15,FSPTRUP    Upcase and dot to space           @SC89215 05101000
         B     FSPCPY                                          @SC86295 05102000
FSPTRAE  TR    0(,5),ATOED                                     @SC89301 05102300
FSPTRUP  TR    0(,5),UPCASE                                    @SC89215 05102600
FSPRC    NI    FL1,255-ROVR  Setup for RECEIVE                 @SC86295 05103000
         NI    FL4,255-NMOK-NMCHNG  Collision not checked yet  @SC90033 05104000
         MVI   0(1),C'$'     Default fn                        @SC88308 05105000
         B     FSPCPY                                          @SC86295 05106000
FSPHD    MVI   0(1),C'$'     Default fn                        @SC88308 05107000
         L     2,ADR                                           @SC86295 05108000
         IC    7,4(2)        Save possible code separator      @SC88308 05109000
         TR    0(256,2),FSPTAB  Make valid fn chars            @SC86295 05110000
         CLM   7,1,=C':'     Was it a separator?               @SC91316 05111000
         BNE   *+8                                             @SC88308 05112000
          STC  7,4(2)        Yes, change char. back to colon   @SC88308 05113000
         B     FSPCPY                                          @SC86295 05114000
FSPSN2   MVI   0(1),0        Clear JFSPEC length !!!                    05115000
         CLI   BRK,C','                                        @PG88306 05116000
         BE    RTRN0         Foreign name omitted              @PG88306 05117000
         NTOKN H=FSP2H,N=RTRN0                                          05118000
         LA    7,1(7)        Not machine length !                       05119000
         LA    1,L'JFNAM     Get maximum length                         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
         B     RTRN0                                           @SC86295 05128000
*                                                                       05129000
FSPTAK   DS    0H                                                       05130000
FSPCPY   NTOKN H=FSPH,N=FSPZ                                            05131000
         LR    8,0           Save start                                 05133000
         KCALL FOPSTR,LFID(,8),E=FSPINV                        @SC89218 05133300
         LA    1,LFID        Get max length                             05133600
         CLI   4(6),C':'     Code prefix ?                              05134000
         BE    FSPCPC                                                   05135000
         LR    2,0                                                      05136000
         MVC   0(5,2),UCODE  Add the user code                          05137000
         LA    0,5(2)        Point past code prefix                     05138000
         S     1,F5          Reduce receiving length                    05139000
FSPCPC   TM    FSPFLG,FFRCF                                             05140000
         BZ    FSPCPN                                          @SC86295 05141000
         OI    FL1,ROVR      Overwrite received fname          @SC86295 05142000
FSPCPN   LA    7,1(7)                                                   05143000
         ICM   7,8,BLANK                                                05144000
         MVCL  0,6           Copy token with padding                    05145000
         CLM   7,7,F0        Hope nothing left over!                    05146000
         BNE   FSPINV        Name was too long                          05147000
         TR    0(LFID,8),UPCASE   Ok, now upcase it                     05148000
         B     RTRN0                                           @SC86295 05149000
*                                                                       05150000
FSPZ     LR    14,0                                            @SC86295 05151000
         CLI   0(14),C' '    Any default given?                @SC86295 05152000
         BH    RTRN0         Yes, use it                       @SC86295 05153000
FSPMIS   PTEXT '&NOFSPEC'                                      @SC92300 05154000
FSPINV   LA    15,2                                            @SC86295 05155000
         B     FSPPTRS                                         @SC86295 05156000
*                                                                       05157000
FSPH     PTEXT '&FMTFSPC&FSPCPRM'                              @SC91224 05158000
         CLI   FSPFLG,FFSND  SEND 1st?                         @SC89218 05158200
         BE    *+8           Yes, use whole message            @SC89218 05158400
          SH   4,=H'&FMTOPT' Chop off option part              @SC92300 05158600
         B     FSP0H                                           @SC86295 05159000
FSP2H    PTEXT '&FORFSPC'                                      @SC86295 05160000
FSP0H    LA    15,1                                            @SC86295 05161000
FSPPTRS  RETREG 3,4          Return msg ptrs                   @SC86295 05162000
FSPRET   RET   ,                                               @SC86295 05164000
*                                                                       05165000
* Non-parsing functions . . .                                           05166000
*                                                                       05167000
* Get unique filespec                                                   05168000
FSPWRN   LR    4,1           Save name ptr                     @SC86295 05169000
         TM    FSPFLG,FFENC                                    @SC86295 05170000
         BO    FSPENC        Encode name into buffer           @SC86295 05171000
         TM    FSPFLG,FFDSP                                    @SC86295 05172000
         BO    FSPDSP        Copy name into buffer for display @SC86295 05173000
         TM    FL4,NMOK      Already checked?                  @SC87012 05174000
         BO    RTRN0         Yes, ok                           @SC87012 05175000
         MVC   XFILE,0(1)    Save original name                @SC90033 05175500
         LA    6,LFID-2(1)   End of FT                                  05176000
         BCTR  6,0                                             @BS86001 05177000
         CLI   0(6),C' '     Find end of token                 @BS86001 05178000
         BE    *-6                                             @BS86001 05179000
         LA    5,10+1        Allowed retries                   @BS86001 05180000
         LA    7,C'0'        Extra character                   @BS86001 05181000
         OI    FL4,NMOK      Assume it checks                  @SC87012 05182000
FSPSTA   OPENF T,(4),E=RTRN0 Does it exist already?            @SC86135 05183000
         OI    FL4,NMCHNG    Yes, remember collision occurred  @SC90033 05183500
         MVI   1(6),C'$'     Yes, modify Fn                             05184000
         STC   7,2(6)        Serialize                         @BS86001 05185000
         LA    7,1(7)        Bump counter                      @BS86001 05186000
         BCT   5,FSPSTA                                        @BS86001 05187000
         PTEXT '&FILCLSN'                                      @SC88049 05188000
         B     FSP0H         Return error code                 @SC88049 05189000
*                                                                       05190000
* Encode name at (R1) into (R7) buffer (in ASCII), possibly with        05191000
*  substitution from JFSPEC, but disable subsequent subst.              05192000
*  Return updated ptr in R15                                            05193000
FSPENC   LA    1,JFSPEC      Complex string?                   @SC86224 05194000
         BAL   14,PAKFOR                                       @SC86224 05195000
         LR    15,7          Save ptr                                   05196000
         BNZ   FSPFILS       Yes, tokens aren't used           @SC86224 05197000
         MVC   0(LFID,7),BLNAME                                         05198000
         MVC   0(17,7),5(4)     Copy filename Only                      05199000
         CLI   4(4),C':'        Is there a code prefix ???              05200000
         BE    *+10                                                     05201000
         MVC   0(LFID,7),0(4)   Copy token                              05202000
         LA    1,LFID(7)        End of token if no blanks               05203000
         TRT   0(LFID,7),TRTBL  Find 1st blank                          05204000
         TR    0(LFID,7),ETOAD  ASCII it                       @SC89301 05205000
         LR    15,1             New end of string                       05206000
FSPFILS  MVI   JFSPEC,0      Turn off string                   @SC86224 05207000
         B     FSPRET                                          @SC86295 05208000
*                                                                       05209000
* Copy name at (R1) into (R7) buffer in display form                    05210000
*  Return updated ptr in R15                                            05211000
FSPDSP   MVC   0(LFID,7),0(4)   Copy token                              05212000
         CLI   4(4),C':'        Prefix already ?                        05213000
         BE    FSPDTK3                                                  05214000
         MVC   0(5,7),UCODE     Get prefix                              05215000
         MVC   5(LFID-5,7),0(4)                                         05216000
FSPDTK3  LA    1,LFID(7)        End of token if no blanks               05217000
         TRT   0(LFID,7),TRTBL  Find 1st blank                          05218000
         LR    15,1             New end of string                       05219000
         B     FSPRET                                                   05220000
*                                                                       05221000
* Valid MUSIC file name characters                                      05222000
FSPTAB   DC    75C'$',C'.'           dot                                05223000
         DC    15C'$',C'$'           dollar sign                        05224000
         DC    31C'$',C'#@'          pound sign, at sign       @SC88308 05225000
         DC    04C'$',C'ABCDEFGHI'   a-i                                05226000
         DC    07C'$',C'JKLMNOPQR'   j-r                                05227000
         DC    08C'$',C'STUVWXYZ'    s-z                                05228000
         DC    23C'$',C'ABCDEFGHI'   A-I                                05229000
         DC    07C'$',C'JKLMNOPQR'   J-R                                05230000
         DC    08C'$',C'STUVWXYZ'    S-Z                                05231000
         DC    06C'$',C'0123456789'  0-9                                05232000
         DC    06C'$'                                                   05233000
         LOCALS ,                                              @SC86295 05234000
FSPFLG   DS    X             Filespec flags                    @SC86295 05235000
FSPEC    EXIT                                                  @SC86295 05236000
         TITLE 'KHELP routine - perform HELP command'                   05237000
* Handle HELP command, rest of string given by SCANPTR.                 05238000
KHELP    ENTER ,                                               @SC86355 05239000
         PTEXT 'LIST *COM:SYSTEM.KERMHELP',AREG=0,LREG=6       @SC88308 05240000
         NI    FL4,255-UCMD  Signal ptrs in R0,R6              @SC88308 05241000
         KCALL SUPFNC,3      Execute HOST command              @SC88308 05242000
         B     RTRN                                            @SC88308 05243000
         LOCALS ,                                                       05244000
KHELP    EXIT  ,                                               @SC87007 05245000
         TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05246000
SUPFNC   ENTER                                                 @SC86295 05247000
*  On entry, R1 = operation code, R0 = possible ptr            @SC86158 05248000
* Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends)             05249000
*       ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11)       05250000
* 1 -> Start typeout interception.  N.B.  &MAXLR >> 2048 for this       05251000
* 2 -> Clean up afterwards and stop interception                        05252000
* 3 -> Execute host command with or without interception                05253000
*      If UCMD set, SCANPTR gives text, else R0->text,R6=len            05254000
* 4 -> Execute CP command with or without interception                  05255000
*      R0->text, R6=len                                                 05256000
* 5 -> Stop interception if going                                       05257000
* 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null)      05258000
* 7 -> Test for stacked lines, return number in R15                     05259000
* 8 -> Log off (doesn't return!)                                        05260000
* 9 -> Wait specified time                                              05261000
* 10-> Return clock time in R15 (centisec)                              05262000
* 11-> Setup up new prompt string at (R0)                               05263000
         BCT   1,ICPFIN                                        @SC86158 05264000
* Start interception, initialize ptrs                          @SC86158 05265000
         MVI   ERRNUM,ERRNOE OK                                @SC86158 05266000
         L     1,WBUF        Output buffer                     @SC90264 05267000
         LA    0,2048(,1)    Skip over some, to be safe        @SC90264 05268000
         A     1,F64KP       End of buffer                     @SC90264 05269000
         LR    15,0                                            @SC86158 05270000
         STM   15,0,TXTPTR   Save                              @SC86158 05271000
         STM   0,1,SVCOPTR                                     @SC86158 05272000
         SR    1,0           Get length                        @SC86158 05273000
         L     15,=X'15000000'                                 @SC86158 05274000
         MVCL  0,14          Fill with NL (X'15')              @SC86158 05275000
         OI    SVCFLG,INTERCPT    Interception in Progress              05276000
         B     RTRN0                                           @SC86295 05277000
* Clean up after interception                                  @SC86295 05278000
ICPFIN   BCT   1,ICPHST                                        @SC86158 05279000
         L     5,SVCOPTR     End of text                       @SC86158 05280000
         ST    5,TXTPTR+4    Save                              @SC86158 05281000
         NI    SVCFLG,255-INTERCPT  Stop interception                   05282000
         B     RTRN0                                                    05283000
* Stop interception if going                                            05284000
ICPRST   BCT   1,SFCLIN                                                 05285000
         NI    SVCFLG,255-INTERCPT  Stop interception                   05286000
         B     RTRN0                                                    05287000
* Execute host command.  Save return code.                     @SC88308 05288000
ICPHST   BCT   1,ICPCP                                         @SC86158 05289000
         TM    FL4,UCMD                                        @SC88308 05290000
         BO    *+12                                            @SC88308 05291000
          ST   0,ADR         Ptrs are in R0,R6                 @SC88308 05292000
          ST   6,LEN                                           @SC88308 05293000
         NTOKN N=SFCHBAD                                       @SC88308 05294000
         SCAN  HSTCMDS,RTRN0 Dispatch to handler               @SC88308 05295000
SFCHBAD  MVI   ERRNUM,ERRSYS Illegal system command            @SC90223 05296000
         HELP  HSTCMDS,RTRNM1                                  @SC90223 05296500
*                                                                       05297000
HSTCMDS  KW    'LIBRARY',SFCDIR,MIN=3                          @SC88308 05298000
         KW    'COPY',SFCCOP,MIN=4                             @SC88308 05299000
         KW    'PURGE',SFCDEL,MIN=3                            @SC88308 05300000
         KW    'RENAME',SFCREN,MIN=3                           @SC88308 05301000
         KW    'LIST',SFCTYP                                   @SC88308 05302000
         KW    ,                                               @SC88308 05303000
*                                                                       05304000
SFCDIR   LA    3,13          DISKIO dir function code          @SC88308 05305000
         B     SFCUTL                                          @SC88308 05306000
SFCDEL   LA    3,14          DISKIO del function code          @SC88308 05307000
         B     SFCUTL                                          @SC88308 05308000
SFCREN   LA    3,15          DISKIO ren function code          @SC88308 05309000
         B     SFCUTL                                          @SC88308 05310000
SFCCOP   LA    3,16          DISKIO cop function code          @SC88308 05311000
         B     SFCUTL                                          @SC88308 05312000
SFCTYP   LA    3,17          DISKIO typ function code          @SC88308 05313000
*        B     SFCUTL                                          @SC88308 05314000
SFCUTL   SR    0,0                                             @SC88308 05315000
         KCALL FSPEC,FILNAM,E=SUBERR                           @SC88308 05316000
         CH    3,=H'14'                                        @SC88308 05317000
         BNH   SFCUT1        Dir/lib or del/pur                @SC88308 05318000
         CH    3,=H'17'                                        @SC88308 05319000
         BE    SFCUT1        Type/list                         @SC88308 05320000
         SR    0,0                                             @SC88308 05321000
         KCALL FSPEC,IFILE,E=SUBERR Get 2nd file name          @SC88308 05322000
SFCUT1   FTOKN N=SFCUT6      See if anything else in command   @SC88308 05323000
         PTEXT '&NOOPERS'                                      @SC88308 05324000
         B     SUBERR                                          @SC88308 05325000
SFCUT6   LR    0,3           Get function code                 @SC88308 05326000
         LA    2,IFILE       Optional 2nd name                 @SC88308 05327000
         KCALL DISKIO,FILNAM Do it                             @SC88308 05328000
* Issue return code msg if needed                              @SC86295 05328060
SFCRC    LTR   4,15          Check RC                          @SC90264 05328120
         BZ    SFCZRC        RC=0                              @SC86158 05328180
         TM    FL4,UCMD      User cmd?                         @SC86316 05328240
         BZ    RTRN          No. No message, just rc in R15    @SC90264 05328300
         MVC   CMD(2),=C'R(' Set up message                    @SC86209 05328360
         LA    15,CMD+2                                        @SC86209 05328420
         BAL   2,EDDEC       Edit RC into msg                  @SC86295 05328480
         MVI   0(15),C')'    Format is R(rc)                   @SC86209 05328540
         LA    0,1(15)                                         @SC86268 05328600
         LA    1,CMD         Start of edited string            @SC86209 05328660
         SR    0,1           Length                            @SC86268 05328720
         WTEXT (1),(0)                                         @SC86268 05328780
SFCZRC   LR    15,6                                            @SC86295 05328840
         MVI   ERRNUM,ERRNOE No errors                         @SC86295 05328900
         B     RTRN                                            @SC88308 05329000
* Execute CP command at (R0) with text interception            @SC86158 05330000
ICPCP    BCT   1,ICPRST                                        @SC86158 05331000
         WTEXT '&NOCPCMD'                                      @SC92300 05332000
         B     RTRN0                                                    05333000
*                                                                       05334000
SFCLIN   BCT   1,SFCSTK                                        @SC86295 05335000
* Retrieve original command line arguments, if any             @SC86295 05336000
*   Return code =0 if yes, =1 if no                            @SC86295 05337000
*   Leave string in CBUF buffer (up to 256), length in CLEN    @SC86295 05338000
         L     1,ORGR1       Get original R1                            05339000
         L     1,0(,1)                                                  05340000
         LH    2,0(,1)       Get command line parm length               05341000
         LA    3,2(,1)       Get address of parms                       05342000
         LTR   5,2           Any parms?                        @SC91121 05343000
         BZ    RTRN1                                                    05344000
         LA    3,0(2,3)      Now, backscan the command line             05348000
SFCLIN3  BCTR  3,0           buffer to check if there is really         05349000
         CLI   0(3),C' '     something. MUSIC should have set the       05350000
         BNE   SFCLIN4       length to 0, but under DEBUG, we           05351000
         BCT   2,SFCLIN3     get a blank line of length 80 !!!          05352000
         B     RTRN1                                                    05353000
SFCLIN4  L     6,GTPB        Start of save buffer              @SC91121 05353200
         MVC   0(128,6),2(1) Copy maximum chunk                @SC91121 05353400
         STM   5,6,GTPB+4    Save new length and starting point@SC91121 05353600
         B     RTRN0                                           @SC91121 05353800
*                                                                       05354000
* Test for stacked commands                                    @SC86295 05355000
*   return code = number of stacked lines                      @SC86295 05356000
SFCSTK   BCT   1,SFCKIL                                        @SC86295 05357000
         ICM   15,15,GTPB+4  Anything in line buffer?                   05358000
         BH    RTRN1         There's one line, at least                 05359000
         B     RTRN0         Nothing stacked                            05360000
*                                                                       05361000
* Log out                                                      @SC86295 05362000
SFCKIL   BCT   1,SFCWT                                         @SC86295 05363000
         LA    1,OFFARG      Schedule a signoff to the system           05364000
         SVC   237               $SETSAV                                05365000
         LA    15,0          And abort the job right away.              05366000
         SVC   $EOJ                                                     05367000
         B     RTRN                                                     05368000
*                                                                       05369000
* Wait specified time in R0 (sec)                                       05370000
SFCWT    BCT   1,SFCCLK      Tell MUSIC to delay for x seconds          05371000
         SVC   $DLYEXC                                                  05372000
         B     RTRN0                                           @SC86295 05373000
*                                                                       05374000
* Return time in centisec in R15                                        05375000
SFCCLK   BCT   1,SFCPRP                                        @SC87351 05376000
         STCK  TMPDW         Store TOD clock                   @SC86295 05377000
         LM    14,15,TMPDW                                     @SC86295 05378000
         SLDL  14,8          Take mod 204 days                 @SC86295 05379000
         SRDL  14,20         Get in microsec                   @SC86295 05380000
         D     14,=F'10000'  Get in centisec                   @SC86295 05381000
         B     RTRN                                            @SC86295 05382000
*                                                                       05383000
SFCPRP   B     RTRN0         No action for prompting           @SC87351 05384000
OFFARG   DC    CL6'/OFF**',X'A0'                                        05385000
         LOCALS ,                                              @SC86295 05386000
SUPFNC   EXIT                                                  @SC86158 05387000
         TITLE 'Interception Code'                                      05388000
*                                                                       05389000
*  Entry:  R0->Length of string to write, R1->Address of string         05390000
*                                                                       05391000
*  Exit:   Always R15=0                                                 05392000
*                                                                       05393000
ICPTYP   ENTER                                                          05394000
         LR    2,0                Get length in R2                      05395000
         LM    3,4,SVCOPTR        Yes, then add the line just           05396000
         SR    4,3                built to the interception buffer      05397000
         CR    2,4                Any room left ?                       05398000
         BH    RTRN0                                                    05399000
         BCTR  2,0                                                      05400000
         EX    2,ICPMV            Move the line to the output buffer    05401000
         LA    2,1(2)                                                   05402000
         LA    3,1(2,3)           Update the source pointer             05403000
         ST    3,SVCOPTR          Save it                               05404000
         B     RTRN0                                                    05405000
ICPMV    MVC   0(0,3),0(1)                                              05406000
         LOCALS ,                                                       05407000
ICPTYP   EXIT   ,                                                       05408000
         TITLE 'SETMSG Routine - controls CP breakin'                   05409000
* Entry: R1 selects operation                                           05410000
* Exit: R15=0 if ok                                                     05411000
* 1-> Analyze user environment, determine if suitable.                  05412000
*     Save quantities needed and condition line for entering commands.  05413000
*     Perform any system-dependent initialization.                      05414000
* 2-> Condition line for protocol transfers.                            05415000
* 3-> Decondition line at end of transfer.                              05416000
* 4-> System-dependent clean-up at exit.                                05417000
* 5-> Reperform system-dependent initialization after SET LINE.         05418000
SETMSG   ENTER ,                                                        05419000
         BCT   1,STM2                Go if R1 not 1, so no init         05420000
         MFARG 0,RLAB=ZRC,ULAB=ZLU                             @PG90057 05421000
         MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG         05422000
         MFARG PHYS=ZPHYS,UCTL=ZUCTL,UINFO=ZUINFO,TAG=MFTAG             05423000
         MFARG XINFO=ZXINFO                                    @SC92086 05423500
         MFARG EOFPT=ZEOFPT,FSARG=ZFSARG                                05424000
         MFGEN AREA=DSKST                                               05425000
         MVC   UCODE(4),$USRCDE   Get the user's code                   05426000
         MVI   UCODE+4,C':'  Set up 5-char prefix string                05427000
         MVI   SCODE+4,C':'  Ditto                             @SC88308 05428000
         LA    1,STMNOPR                                                05429000
         SVC   $SETOPT            Disable prompting                     05430000
         LA    1,STMTXLC                                                05431000
         SVC   $SETOPT            Allow lower case input                05432000
*                                                                       05432300
STM5X    DS    0H            Now set up controller type        @SC90173 05432600
         MVI   TRMTP,C'T'    1st assume TTY                    @SC88203 05433000
         TM    $TRMTYP,X'20'      Check the terminal type               05434000
         BZ    RTRN0                                                    05435000
         SR    1,1           Assume Query not allowed          @SC91311 05436000
         O     1,=A(&CONOPTS)                        Options   @SC91311 05437000
         KCALL SETCON        Find out just what kind...        @SC91311 05438000
         B     RTRN0                                                    05456000
*  Condition Line for protocol transfers                                05457000
STM2     BCT   1,STM3                                                   05458000
         CLI   S1HND,XON          User want special one anyway ?        05461000
         BNE   STM2X                                                    05462000
         BAL   14,TTYCHK     TTY terminals can't change hndshk @SC92030 05463000
          MVI  S1HND,0       System provides the handshake     @SC87343 05463500
STM2X    B     RTRN0                                                    05464000
*  Decondition line at end of transfer                                  05465000
STM3     BCT   1,STM4                                          @SC86316 05466000
         B     RTRN0                                                    05467000
*  System cleanup at exit                                               05468000
STM4     BCT   1,STM5        Special clean-up                  @SC87351 05469000
         LA    1,STMPRMT     Turn on prompting                          05470000
         SVC   $SETOPT                                                  05471000
         LA    1,STMTXUC     Fold lower case to upper case              05472000
         SVC   $SETOPT                                                  05473000
         B     RTRN0         Special clean-up done                      05474000
*                                                                       05475000
STM5     DS    0H            Re-init after SET LINE            @SC87351 05476000
         MVI   TRMTP,C'N'    Assume bad until validated        @SC90173 05476100
         CLI   TRMLIN,C' '   External line?                    @SC87351 05476200
         BE    STM5X         No, use terminal                  @SC90173 05476300
         B     RTRN1         Other lines not allowed           @SC90173 05476400
*                                                                       05477000
STMNOPR  DC    X'A0',AL1(1,3,6) Turn off Prompting                      05478000
STMPRMT  DC    X'A0',AL1(0,3,6) Turn on Prompting                       05479000
STMTXLC  DC    X'A0',AL1(1,1,6) Text Lower Case Input                   05480000
STMTXUC  DC    X'A0',AL1(0,1,6) Text Upper Case Input                   05481000
*                                                                       05482000
         LOCALS ,                                                       05485000
SETMSG   EXIT                                                           05486000
         TITLE 'GETLIN Routine - Get a line from terminal'     @SC87015 05487000
* Entry: R1->buffer of length 256                              @SC87015 05488000
* Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1.     @SC87015 05489000
GETLIN   ENTER                                                 @SC87015 05490000
         LR    8,1           Save buffer ptr                   @SC88095 05491000
         LA    9,256         For copying                       @SC88095 05492000
         LM    4,6,GTPB      Saved ptrs: start, length, current         05493000
         LTR   5,5           Already got something?            @SC88095 05494000
         BNZ   GTL1          Yes, return it                    @SC87015 05495000
         TGET  (4),130       Read a line from the terminal              05496000
         SLR   2,2           Clear length for return                    05497000
         LA    5,0(1,4)      Point past the end                         05498000
         BCTR  5,0           Scan back for a non-blank                  05499000
         CLI   0(5),C' '                                                05500000
         BE    *-6                                                      05501000
         LA    5,1(,5)                                                  05502000
         SR    5,4           Stripped length                            05503000
         BNH   GTLA          Null input                                 05504000
         LR    6,4           Set current read ptr                       05505000
         ST    5,GTPB+4      Save new length                            05506000
GTL1     LR    1,5           Length of stuff                   @SC88095 05507000
         AR    1,4           End of buffer                     @SC88095 05508000
         LR    0,1           Save end                          @SC88095 05509000
         LR    2,1                                             @SC88095 05510000
         SR    2,6           Length of text remaining          @SC88095 05511000
         BNP   GTLA          None, return length 0             @SC88095 05512000
         SLR   4,4                                             @SC88095 05513000
         IC    4,LNDLM       Get delimiter                     @SC88095 05514000
         LA    4,TRTBL(4)    Ptr to delimiter char             @SC88095 05515000
         MVI   0(4),1        Set up to snag delims             @SC88095 05516000
         MVI   TRTBL+C' ',0  And ignore blanks                 @SC88095 05517000
         CR    2,9           Get shorter of 256 and string     @SC88095 05518000
         BNH   *+6                                             @SC88095 05519000
          LR   2,9                                             @SC88095 05520000
         BCTR  2,0           Set up for EX                     @SC88095 05521000
         EX    2,GTLTRT                                        @SC88095 05522000
         MVI   0(4),0        Now clear out table               @SC88095 05523000
         MVI   TRTBL+C' ',1  And restore                       @SC88095 05524000
         SR    1,6           Length of line                    @SC88095 05525000
         LR    7,1           Set up MVCL                       @SC88095 05526000
         CR    9,7           Get shorter of 256 and string     @SC88095 05527000
         BNH   *+6                                             @SC88095 05528000
          LR   9,7                                             @SC88095 05529000
         LR    2,9           Length actually copied            @SC88095 05530000
         MVCL  8,6                                             @SC88095 05531000
         AR    6,7           In case we couldn't use it all    @SC88095 05532000
         CR    6,0           Finished input?                   @SC88095 05533000
         BNL   GTLA          Yes, release it                   @SC88095 05534000
         LA    6,1(,6)       Skip over linend char             @SC88095 05535000
         ST    6,GTPB+8      Next read ptr                     @SC88095 05536000
         B     GTLZ          Return                            @SC88095 05537000
GTLA     MVC   GTPB+4,F0     Clear input indicator             @SC87015 05538000
GTLZ     RETREG (0,2)        Return (2) as R0                  @SC89218 05539000
         B     RTRN0                                           @SC87015 05541000
GTLTRT   TRT   0(,6),TRTBL   Find a delimiter                  @SC88095 05542000
         LOCALS ,                                              @SC87015 05543000
GETLIN   EXIT  ,                                               @SC87015 05544000
         TITLE 'TERMIO Routine - Handle terminal I/O'                   05545000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05546000
* successfull, R15 returns transferred byte count (else returns -1).    05547000
*               Command code is in R0:                                  05548000
* 1 => Open line for I/O            4 => Write packet                   05549000
* 2 => Close line                   5 => Read packet                    05550000
* 3 => Reset line status after    ( 6 => Write message ) not used       05551000
*      environment changes                                              05552000
*                                                                       05553000
TERMIO   ENTER                                                          05554000
         STC   0,CONSOPR     Save command code                 @SC92180 05554500
         SR    15,15         OK                                @SC86295 05555000
         BCT   0,TRMCLS                                        @SC86295 05556000
* Open terminal line for protocol                                       05557000
         MVI   RIOC,X'80'    Nothing saved                     @SC86295 05558000
         MVI   TRMFLG,X'FF'  Initialize w/r flag               @SC87275 05559000
         CLI   TRMTP,C'F'                                      @SC92030 05559300
         BE    TRMSETF       Full-screen stuff only            @SC92030 05559600
         LA    1,STMNOCR                                                05560000
         SVC   $SETOPT       No CRLF added                              05561000
         LA    1,STMNOTR                                                05562000
         SVC   $SETOPT       No translate Input                         05563000
         LA    1,STMNOER                                                05564000
         SVC   $SETOPT       No *TRANSMISSION ERROR messages            05565000
         CLI   TIMOUT,0      Timeout wanted ???                         05566000
         BE    RTRN0                                                    05567000
         LA    1,STMTMOU                                                05568000
         SVC   $SETOPT       Timeout on reads                           05569000
         B     RTRN0                                                    05570000
TRMSETF  LA    1,STMNOEC                                       @SC92030 05570200
         SVC   $SETOPT       No echo of input                  @SC92030 05570400
         B     RTRN0                                           @SC92030 05570600
* Close terminal line after protocol transfer                           05571000
TRMCLS   BCT   0,TRMRSET                                       @SC86295 05572000
         LA    1,STMCRLF     Reenable CRLF                              05573000
         SVC   $SETOPT                                                  05574000
         LA    1,STMTRIN     Reenable translation                       05575000
         SVC   $SETOPT                                                  05576000
         LA    1,STMNOTM     No timeouts                                05577000
         SVC   $SETOPT                                                  05578000
         LA    1,STMTRER                                                05579000
         SVC   $SETOPT       *TRANSMISSION ERROR messages allowed       05580000
         LA    1,STMECHO                                       @SC92030 05580300
         SVC   $SETOPT       Allow echo of input               @SC92030 05580600
         B     RTRN0                                           @SC86295 05581000
* (Re)set terminal characteristics to suit environment                  05582000
TRMRSET  BCT   0,TRMRW                                         @SC86295 05583000
         B     RTRN0                                           @SC86295 05584000
*                                                                       05585000
*  Perform I/O request                                                  05586000
TRMRW    BCT   0,TRMRD                                         @SC87275 05587000
         CLI   WRRD,0        Write/read?                       @SC87275 05588000
         BNE   *+8           No, do it immediately                      05589000
         MVI   TRMFLG,0      Indicate no action on follow-up            05590000
         LM    2,3,0(1)      Get buffer address + length                05591000
         CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 05591070
         BNE   TRMRWW        No                                @SC92030 05591140
         SR    0,0           Clear before every packet         @SC92030 05591210
         KCALL SCRNIO                                          @SC92030 05591280
         XI    FL3,FCLRF     Flip switch for skipping          @SC92030 05591350
         TM    FL3,FCLRF     Skipping now?                     @SC92030 05591420
         BZ    TRMRWX        Not this time                     @SC92030 05591490
         PTEXT ' ',LREG=4,AREG=5 Yes                           @SC92030 05591560
         TPUT  (5),(4)       Skip two lines                    @SC92030 05591630
         TPUT  (5),(4)                                         @SC92030 05591700
         B     TRMRWX        Omit the special translation      @SC92030 05591770
TRMRWW   DS    0H                                              @SC92030 05591840
         BCTR  2,0           Backup to insert carriage control          05592000
         MVI   0(2),X'41'    No output translate PLEASE !               05593000
         LA    3,1(3)        Fixup length for CC added                  05595000
TRMRWX   ST    2,TRMRBUF     Set up I/O buffer for MFIO        @SC92030 05595500
         ST    3,TRMRLEN     Set I/O length                             05596000
         MFREQ PRT                                                      05597000
         B     TRMRWLG                                         @SC92180 05598000
*                                                                       05599000
TRMRD    TS    TRMFLG                                          @SC87275 05600000
         BZ    RTRN0         Just a follow-up. 0-length read   @SC87275 05601000
         LM    2,3,0(1)                                                 05602000
         C     3,AMAXRT      Check for maximum length                   05603000
         BL    TRMRD3                                                   05604000
         L     3,AMAXRT      Not too long please...                     05605000
TRMRD3   ST    2,TRMRBUF     Setup I/O buffer for MFIO                  05606000
         ST    3,TRMRLEN     Set I/O length                             05607000
         SLR   4,4                                                      05608000
         SLR   5,5                                                      05609000
         MVCL  2,4           Clear the input buffer                     05610000
         MFREQ TRM                                                      05611000
TRMRWLG  LA    1,TRMARG      I/O block                         @SC92180 05612000
         BAL   7,SCRLOGCM    Log it                            @SC92180 05612100
         L     5,TRMARSZ     Get number of bytes read          @SC92180 05612200
         L     1,TRMRBUF     Ptr to I/O buffer                 @SC92180 05612300
         LR    2,5           I/O length                        @SC92180 05612400
         BAL   7,SCRLOGD     Log it                            @SC92180 05612500
         TM    CONSOPR,1                                       @SC92180 05612600
         BZ    RTRN0         Not a read, just say OK           @SC92180 05612700
         LTR   15,5          Get number of bytes read          @SC92180 05612800
         BNZ   RTRN          Ok, got a buffer                           05613000
         L     2,TRMRBUF                                                05614000
         MVI   0(2),X'2B'    Timeout !!!                                05615000
         B     RTRN1         Return Length 1                            05616000
*                                                                       05617000
STMNOCR  DC    X'A0',AL1(1,1,5) Turn off CRLF                           05618000
STMCRLF  DC    X'A0',AL1(0,1,5) Turn on CRLF                            05619000
STMNOTR  DC    X'A0',AL1(1,1,4) Turn off input translation              05620000
STMTRIN  DC    X'A0',AL1(0,1,4) Turn on input translation               05621000
STMTMOU  DC    X'A0',AL1(1,1,0) Turn on Timeout                         05622000
STMNOTM  DC    X'A0',AL1(0,1,0) Turn off Timeout                        05623000
STMNOER  DC    X'A0',AL1(0,1,7) Don't allow *TRANSMISSION ERROR msg     05624000
STMTRER  DC    X'A0',AL1(1,1,7) Allow *TRANSMISSION ERROR msg           05625000
STMNOEC  DC    X'A0',AL1(1,1,2) Don't echo input               @SC92030 05625300
STMECHO  DC    X'A0',AL1(0,1,2) Echo input                     @SC92030 05625600
         SPACE                                                          05626000
*********************************************************************** 05627000
*                                                                     * 05628000
*    Reversing Table. Translate ASCII to reverse ASCII                * 05629000
*                                                                     * 05630000
*********************************************************************** 05631000
         SPACE 1                                                        05632000
*                0 1 2 3 4 5 6 7 8 9 A B C D E F                        05633000
ATORA    DC    X'008040C020A060E0109050D030B070F0' 0                    05634000
         DC    X'088848C828A868E8189858D838B878F8' 1                    05635000
         DC    X'048444C424A464E4149454D434B474F4' 2                    05636000
         DC    X'0C8C4CCC2CAC6CEC1C9C5CDC3CBC7CFC' 3                    05637000
         DC    X'028242C222A262E2129252D232B272F2' 4                    05638000
         DC    X'0A8A4ACA2AAA6AEA1A9A5ADA3ABA7AFA' 5                    05639000
         DC    X'068646C626A666E6169656D636B676F6' 6                    05640000
         DC    X'0E8E4ECE2EAE6EEE1E9E5EDE3EBE7EFE' 7                    05641000
         DC    X'018141C121A161E1119151D131B171F1' 8                    05642000
         DC    X'098949C929A969E9199959D939B979F9' 9                    05643000
         DC    X'058545C525A565E5159555D535B575F5' A                    05644000
         DC    X'0D8D4DCD2DAD6DED1D9D5DDD3DBD7DFD' B                    05645000
         DC    X'038343C323A363E3139353D333B373F3' C                    05646000
         DC    X'0B8B4BCB2BAB6BEB1B9B5BDB3BBB7BFB' D                    05647000
         DC    X'078747C727A767E7179757D737B777F7' E                    05648000
         DC    X'0F8F4FCF2FAF6FEF1F9F5FDF3FBF7FFF' F                    05649000
*********************************************************************** 05650000
*                                                                     * 05651000
*    Reversing Table. Reverse ASCII to ASCII. Lose high order bit.    * 05652000
*                                                                     * 05653000
*********************************************************************** 05654000
         SPACE 1                                                        05655000
*                0 1 2 3 4 5 6 7 8 9 A B C D E F                        05656000
RATOA    DC    X'00004040202060601010505030307070' 0                    05657000
         DC    X'08084848282868681818585838387878' 1                    05658000
         DC    X'04044444242464641414545434347474' 2                    05659000
         DC    X'0C0C4C4C2C2C6C6C1C1C5C5C3C3C7C7C' 3                    05660000
         DC    X'02024242222262621212525232327272' 4                    05661000
         DC    X'0A0A4A4A2A2A6A6A1A1A5A5A3A3A7A7A' 5                    05662000
         DC    X'06064646262666661616565636367676' 6                    05663000
         DC    X'0E0E4E4E2E2E6E6E1E1E5E5E3E3E7E7E' 7                    05664000
         DC    X'01014141212161611111515131317171' 8                    05665000
         DC    X'09094949292969691919595939397979' 9                    05666000
         DC    X'05054545252565651515555535357575' A                    05667000
         DC    X'0D0D4D4D2D2D6D6D1D1D5D5D3D3D7D7D' B                    05668000
         DC    X'03034343232363631313535333337373' C                    05669000
         DC    X'0B0B4B4B2B2B6B6B1B1B5B5B3B3B7B7B' D                    05670000
         DC    X'07074747272767671717575737377777' E                    05671000
         DC    X'0F0F4F4F2F2F6F6F1F1F5F5F3F3F7F7F' F                    05672000
         TITLE 'SCRNIO Routine - Handle screen I/O via Series/1'        05675000
* R1 points to a pair of (adr,len) for read or write.  If I/O is        05676000
* successfull, R15 returns transferred byte count (else returns -1).    05677000
*               Command code is in R0:                                  05678000
* 0 => Clear screen on console (not comm line)                 @SC90045 05678500
* 1 => Open screen for I/O            4 => Write packet (gets ATTN)     05679000
* 2 => Close screen                   5 => Read packet                  05680000
* 3 => Reset screen status after      6 => Write message (no ATTN)      05681000
*      environment changes                                              05682000
*                                                                       05683000
SCRNIO   ENTER ALT                                             @SC92180 05684000
         XC    ZFSARG(20),ZFSARG  Clear FSIO Control Block              05685000
         LR    6,1           Save ptr to plist                 @SC90222 05685100
         LTR   0,0                                             @SC90045 05685300
         BZ    SCRCLR                                          @SC90045 05685600
         STC   0,CONSOPR     Save command code                 @LP88158 05685700
         BCT   0,SCRCLS                                        @SC86295 05686000
* Set up for transparent I/O                                            05686020
         L     1,=A(IDEFS)   CSECT of initializations          @SC90173 05686040
         USING DEFS,1        Mapped via DSECT                  @SC90173 05686060
         LA    2,S1DATA      Series/1 introducer               @SC90173 05686080
         LA    3,S1ORDL+2    Length + 2                        @SC90173 05686100
         CLI   TRMTP,C'S'                                      @SC90173 05686120
         BE    SCRPRSET      Do it                             @SC90173 05686140
         LA    2,GRDATA      Graphics introducer               @SC90173 05686160
         LA    3,GRDL+2      Length + 2                        @SC90173 05686180
         CLI   TRMTP,C'G'                                      @SC90173 05686200
         BE    SCRPRSET      Do it                             @SC90173 05686220
         LA    2,AEADAT      AEA introducer                    @SC90173 05686240
         LA    3,AEAL+2                                        @SC90173 05686260
         DROP  1                                               @SC90173 05686280
SCRPRSET LR    5,3                                             @SC90173 05686300
         LA    4,S1EOL+2     Get start of command buffer       @SC90173 05686320
         SR    4,5                                             @SC90173 05686340
         STM   4,5,S1XOPL    Set up prompt plist               @SC90173 05686360
         S     5,F2          Deduct stuff already there        @SC90173 05686380
         MVCL  4,2                                             @SC90173 05686400
         MVI   TRMFLG,X'FF'       Initialize W/R flag          @PG90058 05686500
         MVI   RIOPRP+4,255  Flag no interrupt pending         @SC90222 05686700
SCRCLRA  MVI   FSFSFG,X'84'  Write erase needed to setup FSIO  @SC90045 05687000
         MVI   FSFSFG+1,X'60'     No data Compression                   05688000
         BAL   9,SCRNEX      Clear screan                      @SC90222 05689000
         B     RTRN0                                           @SC86295 05692000
*                                                                       05692100
SCRCLR   CLI   TRMTP,C'T'    Is it a TTY terminal?             @SC90045 05692200
         BE    RTRN0         Yes, can't clear screen           @SC90045 05692300
         CLI   TRMTP,C'V'    Is it a TTY terminal?             @SC90045 05692400
         BE    RTRN0         Yes, can't clear screen           @SC90045 05692500
         CLI   TRMTP,C'F'    Is it some full-screen?           @SC92030 05692530
         BE    *+12          Yes, must clear frequently        @SC92030 05692560
         TM    FL2,PROTO     In protocol mode?                 @SC90045 05692600
         BO    RTRN0         Yes, skip clearing screen         @SC90045 05692700
         B     SCRCLRA       Do it                             @SC90045 05692800
*                                                                       05693000
SCRCLS   BCT   0,SCRRSET                                       @SC86295 05694000
         B     RTRN0                                           @SC86295 05695000
* (Re)set device characteristics to suit environment                    05696000
SCRRSET  BCT   0,SCRRW                                         @SC86295 05697000
         B     RTRN0                                                    05698000
*                                                                       05699000
*  Perform I/O request                                                  05700000
SCRRW    LR    5,0                                             @SC90173 05701000
         AR    5,0                                             @SC90173 05701100
         CLI   TRMTP,C'A'    AEA?                              @SC90173 05701200
         BNE   *+8                                             @SC90173 05701300
          LA   5,6(,5)       Yes, use 2nd table                @SC90173 05701400
         LH    5,SCRFGS-2(5) Get proper screen I/O flags       @SC90173 05701500
         STCM  5,3,FSFSFG                                      @SC90173 05701600
         BCT   0,SCRRD                                         @SC90173 05701700
*  Write                                                       @SC90173 05701800
         CLI   WRRD,0             Write/Read ?                 @PG90058 05702000
         BE    SCRWO                                           @PG90058 05702200
         MVC   RIOPRP(8),0(1)     Save Write data as Read Prmp @PG90058 05702400
         B     RTRN0                                           @PG90058 05702600
SCRWO    DS    0H            Write without expecting response  @SC90173 05703000
         MVC   FSFSWL,4(1)   Copy buffer length (assume Write) @SC90173 05704000
         MVC   FSFSWB,0(1)   Copy buffer address               @SC90173 05705000
         MVI   TRMFLG,0           Indicate no actn on followup @PG90058 05706500
         BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05707000
         LM    1,2,0(6)      Get buffer,len                    @SC90222 05707500
         BAL   7,SCRLOGD     Log the data                      @SC90222 05708000
         B     RTRN0                                                    05709000
*                                                                       05709500
SCRRD    BCT   0,SCRWM                                                  05710000
         TS    TRMFLG             Do we have to really read?   @PG90058 05711000
         BZ    RTRN0              Just a follow up. 0-len read @PG90058 05711300
         MVC   FSFSRL(4),4(1)     Get buffer length Read       @PG90058 05713000
         MVC   FSFSRB(4),0(1)     Get buffer address Read      @PG90058 05713500
         CLI   RIOPRP+4,255  Interrupt pending?                @SC90222 05713600
         BE    SCRRDM        No, just issue READ MOD           @SC90222 05713700
         MVC   FSFSWL(4),RIOPRP+4 Get buffer length Write      @PG90058 05714000
         MVC   FSFSWB(4),RIOPRP   Get buffer address Write     @PG90058 05714500
         BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05715000
         LM    1,2,RIOPRP    Get buffer,len written            @SC90222 05715300
         BAL   7,SCRLOGD     Log the data                      @SC90222 05715600
         MVI   RIOPRP+4,255  Flag no interrupt pending         @SC90222 05715900
         B     SCRRD2        Now rejoin                        @SC90222 05716200
SCRRDM   MVI   FSFSFG,X'0C'  Do immediate READ MOD             @SC90222 05716500
         BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05716800
SCRRD2   L     1,0(,6)       Get input buffer                  @SC90222 05717100
         LR    2,5           Get length read                   @SC90222 05717400
         BAL   7,SCRLOGD     Log the data                      @SC90222 05717700
         LR    15,5          Get length of data read           @SC90222 05718000
         S     15,WRCMDL+4   Deduct 3 for buffer adr           @SC90173 05718100
         B     RTRN          Return                            @SC86299 05719000
*                                                                       05719200
* SCRLOG: Hexadecimal log of (R2) bytes at address (R1)        @LP88158 05719400
* Log label is taken from R0 low order byte.                   @SC89166 05719600
* Return via R7.  R0-R3 and R15 destroyed.                     @SC89166 05719800
SCRLOGD  LA    0,C'd'        "Data" label                      @SC89166 05720000
         B     SCRLOG                                          @SC92180 05720020
* Enter here with (1)->control block of length 20              @SC92180 05720040
SCRLOGCM SLR   2,2           Convert op. code to log label     @SC92180 05720060
         IC    2,CONSOPR                                       @SC92180 05720080
         LA    2,CONSOPRS(2)                                   @SC92180 05720100
         IC    0,0(,2)                                         @SC92180 05720120
         LA    2,20          Size of plist                     @SC92180 05720140
SCRLOG   TM    FL1,DEBUG     Logging in effect?                @SC87286 05720200
         BZR   7             No, that's all                    @SC89166 05720400
         TM    DBGFLG,DBGIO  I/O stuff requested?              @SC88168 05720600
         BZR   7             No, skip it                       @SC89166 05720800
         L     3,LOGBUF      Ptr to buffer                     @LP88158 05721000
         STC   0,0(,3)       Set log label                     @SC89166 05721200
         LA    3,2(,3)       Start of data area                @SC91172 05721400
         TM    DBGFLG,DBGTI  Times requested?                  @SC91172 05721410
         BZ    SCRLOGA       No, just do hex dump              @SC91172 05721420
         ST    1,SCRLR1      Save ptr to block                 @SC91172 05721430
         BAL   14,ACCTTOD    Get time of day in seconds        @SC91172 05721440
         MVI   0(3),C' '     Leave a space                     @SC91172 05721450
         KCALL DUMPTOD,1(3)  Format time into buffer           @SC91172 05721460
         LR    3,15          Get ptr to end of string          @SC91172 05721470
         L     1,SCRLR1      Restore R1                        @SC91172 05721480
SCRLOGA  LA    0,6*9(,3)     End of line buffer                @SC91172 05721490
         TM    DBGFLG,DBGLO  Long buffer requested?            @SC90222 05721600
         BZ    *+8                                             @SC90222 05721800
          LA   0,50*9(,3)    Yes, long buffer                  @SC91172 05722000
SCRLOGLP MVI   0(3),C' '     Add for readability               @LP88158 05722400
         UNPK  1(9,3),0(5,1) Unpack into buffer                @SC88168 05722600
         TR    1(8,3),TRHEX  Convert to printable hex          @SC88168 05722800
         LA    3,9(3)        Advance text ptr                  @SC88168 05723000
         LA    1,4(1)        and data source                   @LP88158 05723200
         S     2,F4          Finished data?                    @SC88168 05723400
         BNP   SCRLGEND      Yes, go write                     @LP88158 05723600
         CR    3,0           Reached text limit?               @LP88158 05723800
         BL    SCRLOGLP      no, loop for more slices          @LP88158 05724000
         MVC   0(3,3),=C'...' Show incomplete                  @LP88158 05724200
         LA    3,3(3)                                          @SC88168 05724400
SCRLGEND DS    0H                                              @LP88158 05724600
         AR    2,2           Check for incomplete slice        @SC88168 05724800
         BNM   *+6           No, ok                            @SC88168 05725000
         AR    3,2           Yes, adjust end of text           @SC88168 05725200
         S     3,LOGBUF      Get length of text                @SC88168 05725400
         WRITF LOGPTR,BSIZE=(3) Log it                         @LP88158 05725600
         TM    DBGFLG,DBGSV  SAVE requested?                   @SC88168 05725800
         BZR   7             No, skip closing log file         @SC89166 05726000
         SAVEF LOGPTR        Update disk directory             @SC88168 05726200
         BR    7                                               @SC89166 05726400
*                                                                       05726600
* Execute (and log) screen I/O already set up                  @SC90222 05726800
* Return via R9 with length read in R5.                        @SC90222 05727000
SCRNEX   MVI   ZLU,9         Specify unit 9                    @SC90222 05727200
         MFSET DSKST,FSIO                                      @SC90222 05727400
         MFREQ DSKST         Do it                             @SC90222 05727600
         L     5,MFARSZ      Fetch length of read              @SC90222 05727800
         MVC   SCRRC,ZRC     Save return code                  @SC90222 05728000
         LA    1,ZFSARG      I/O block                         @SC90222 05729000
         BAL   7,SCRLOGCM    Log it                            @SC92180 05729200
         CLI   SCRRC,0                                         @SC90222 05729600
         BER   9             Ok, just return                   @SC90222 05729800
         LA    1,SCRRC                                         @SC90222 05730000
         LA    2,1                                             @SC90222 05730200
         LA    0,C'e'        "Error" label                     @SC90222 05730400
         BAL   7,SCRLOG      Log the return code               @SC90222 05730600
         BR    9             Return                            @SC90222 05730800
*                                                                       05735000
SCRWM    DS    0H                                              @SC90173 05737000
         MVC   FSFSWL,4(1)   Copy buffer length                @SC90173 05738000
         MVC   FSFSWB,0(1)   Copy buffer address               @SC90173 05739000
         BAL   9,SCRNEX      Write it                          @SC90222 05740000
         LM    1,2,0(6)      Get buffer,len                    @SC90222 05740500
         BAL   7,SCRLOGD     Log the data                      @SC90222 05741000
         B     RTRN0                                                    05743000
*          Halfword-aligned table of I/O flags           code  @SC90173 05743050
SCRFGS   DC    X'06',X'A0'   WCC, Skip read / No comp      4   @SC90173 05743100
         DC    X'02',X'80'   WCC, Write/Read / No comp     5   @SC90173 05743150
         DC    X'86',X'A0'   EW, WCC, Skip Read / No comp  6   @SC90173 05743200
*          2nd table for WSF I/O                               @SC90173 05743250
         DC    X'24',X'A0'   Skip read / No comp           4   @SC90173 05743300
         DC    X'20',X'80'   Write/Read / No comp          5   @SC90173 05743350
         DC    X'86',X'A0'   EW, WCC, Skip Read / No comp  6   @SC90173 05743400
RIOPRP   DC    A(0,1)                                          @PG90058 05743500
CONSOPRS DC    C'?ocswrmg'   Console commands labels for log   @SC91150 05743600
         LOCALS ,                                                       05744000
SCRRC    DS    F             Return code from I/O              @SC90222 05744300
SCRLR1   DS    F             Saved R1 in SCRLOG                @SC91172 05744400
CONSOPR  DS    XL1           Current I/O operation             @SC89180 05744600
SCRNIO   EXIT  ,                                                        05745000
         TITLE 'DISKIO Routine - performs disk I/O functions'           05746000
* Function selected on entry by R0:                                     05747000
* 0=> unnum: R1->FAB.  Return R1->buffer,R0=# and remove the sequence   05748000
*   number (if any) from the buffer (used for TAKE files)               05749000
* 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   05750000
* 2=> open (out): (same)                                                05751000
* 3=> test name: R2->name.  Returns R1->FDB if file found and  @SC91269 05752000
*     writable (else R15=1)                                    @SC91269 05752100
* 4=> close file: R1->adr(FAB).                                         05753000
* 5=> set up search: R1->pattern name.                                  05754000
* 6=> return next file in list:  Returns R1->FDB + sets up FILNAM       05755000
* 7=> close search (if any).                                            05756000
* 8=> test CWD string: R1->string.  Returns R15=0 if ok, else =1.       05757000
* 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         05758000
* 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           05759000
* 11=> test space: R1->pattern FDB (has size in Kbytes),                05760000
*  R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok.  05760500
* 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code    05761000
*      always returns R15=1                                             05762000
* 13=> directory info on file: R1->name.  Returns R15=0 if ok.          05763000
* 14=> delete file: R1->name.  Returns R15=0 if ok.                     05764000
* 15=> rename file: R1->name, R2->new name.  Returns R15=0 if ok.       05765000
* 16=> copy file: R1->name, R2->new name.  Returns R15=0 if ok.         05766000
* 17-> type file: R1-> name. Returns R15=0 if ok.                       05767000
* 21=> save file status in directory: R1->FAB.                 @SC88168 05768000
* 22=> open library (in): R2->DDNAME.  Return R15=0 if ok.     @SC89073 05768200
* 23=> point for next read, R1->adr(FDB), R2=records to skip.  @SC89218 05768300
*      Return R15=0 if ok.                                     @SC89218 05768400
* 24=> test name: R2->name.  Returns R1->FDB if file found and @SC91269 05768450
*      readable (else R15=1)                                   @SC91269 05768500
DISKIO   ENTER                                                          05769000
         USING FABD,3                                          @SC86295 05770000
         SR    4,4           Signal no block assigned          @SC86295 05771000
         STC   0,DSKCOD      Save function code (for now)      @SC88101 05772000
         LR    5,0                                             @SC89073 05773000
         AR    5,5                                             @SC89073 05773200
         LH    5,DSK0(5)     Get handler address               @SC89073 05773400
         B     DSK0(5)       Do the function                   @SC89073 05773600
DSK0     DC    Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0)   0-2  @SC89073 05773800
         DC    Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0)  3-5  @SC89073 05774000
         DC    Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0)   6-8  @SC89073 05774200
         DC    Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0)     9-11 @SC89073 05774400
         DC    Y(DSKXXX-DSK0,DSKDIR-DSK0,DSKDEL-DSK0)    12-14 @SC89073 05774600
         DC    Y(DSKRNM-DSK0,DSKCPY-DSK0,DSKTYP-DSK0)    15-17 @SC89073 05774800
         DC    3Y(DSKER1-DSK0)   Spare utilities         18-20 @SC89073 05775000
         DC    2Y(DSKER1-DSK0),Y(DSKPNT-DSK0)            21-23 @SC89218 05775200
         DC    Y(DSKTEST-DSK0)                           24-   @SC91269 05775250
         DC    8Y(DSKER1-DSK0)   Spares                        @SC89073 05775400
*                                                                       05776000
* Open for input file whose name is at (R2), FDB at (R1)                05777000
DSKOPNI  DS    0H                                              @SC89073 05777500
         BAL   9,DSKALC      Get FAB                           @SC86295 05778000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05779000
         MFREQ DSKST                        Try to open file            05780000
         CLI   ZRC,0                        Errors ???                  05781000
         BNZ   DSKER1        Not found                         @SC86295 05782000
         MVC   FABRC,ZRC                                                05783000
         BAL   9,DSKCHKNM          Check if allowed to do I/O           05784000
          B     DSKER1                                                  05785000
         BAL   14,DSKVALS          Go copy info to FDBD                 05786000
         MVC   FABUNIT(1),ZLU      Save file unit number                05787000
         B     RTRN0                                           @SC86295 05788000
*                                                                       05789000
* Open for output file whose name is at (R2), FDB at (R1)               05790000
DSKOPNO  DS    0H                                              @SC89073 05791000
         BAL   9,DSKALC      Get FAB                           @SC86295 05792000
         MVC   FABCOMM,=CL8'Open'  In case of error            @SC88308 05793000
         MFSET DSKST,EXTRACT                                   @SC88308 05796000
         MFREQ DSKST         Get file attributes               @SC88308 05797000
         CLI   ZRC,0         Did it work?                      @SC88308 05798000
         BNE   DSKOP2        Not found, just writing new       @SC87012 05799000
         TM    FDBFLGS,APPN+SVATT  Should we keep attributes?  @SC90033 05799500
         BZ    *+8           No                                @SC90033 05800000
          BAL  14,DSKVALS    Yes, copy old ones to FDB         @SC90033 05800500
         TM    FDBFLGS,APPN  Appending?                        @SC90033 05801000
         BO    DSKOP2        Yes, keep old file                @SC90033 05801500
DSKOP1   DS    0H                                              @SC88308 05802000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05803000
         MFREQ DSKST                                                    05804000
         MVC   FABRC(1),ZRC                                             05805000
         CLI   ZRC,30              Error deleting file ?                05806000
         BE    DSKOP2              Yup, ignore it.                      05807000
         BAL   9,DSKCHKNM          Check if allowed to do I/O           05808000
          B     DSKER1                                                  05809000
         MFSET DSKST,CLOSE,R=(DEL)                                      05810000
         MFREQ DSKST               Delete the file...                   05811000
         MVC   FABRC(1),ZRC                                             05812000
DSKOP2   MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         05813000
         SR    0,0                                                      05814000
         ICM   0,3,FDBLRC    Insert logical record length               05815000
         STH   0,MFIRSIZ                                                05816000
         CLI   FDBRCF,C'V'   If not variable, then truncate             05817000
         BNE   DSKSTLR                                         @SC88120 05818000
         CLI   TYPFIL,C'B'   If variabel BUT binary, truncate           05819000
         BE    DSKSTLR                                                  05820000
         L     0,MAXLRC      TEXT file, no limit               @SC87012 05821000
DSKSTLR  ST    0,FABLRTR     Set output buffer limit                    05822000
         CLI   FDBRCF,C'F'   Fixed format ?                             05823000
         BNE   *+8                                                      05824000
         MVI   MFIRFM,X'02'  Yup, set to Fixed Compressed               05825000
         MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK)                          05826000
         TM    FDBFLGS,APPN   Append to file ?                          05827000
         BZ    *+8                                                      05828000
         OI    DSKST+1,X'20'  Manually specify APPOK !                  05829000
         MFREQ DSKST          Do the I/O                                05830000
         CLI   ZRC,0          Any errors ?                              05831000
         BNZ   DSKER1                                                   05832000
         MVC   FABRC,ZRC     Save return code                           05833000
         MVC   ZINFOUT(LZINFDEF),ZINFIN  Copy creation file parms       05834000
         BAL   14,DSKVALS          Copy parms to FDBD                   05835000
         OI    FDBFLGS,FWRITE      Write mode file                      05836000
         MVC   FABUNIT(1),ZLU      Save the Unit number                 05837000
         B     RTRN0                                           @SC86295 05838000
*                                                                       05839000
* Test for existence of file whose name is at (R2)                      05840000
DSKTEST  DS    0H                                              @SC89073 05841000
         MVC   MFNAME(LFID),0(2)   Get filename to test                 05842000
DSKTST2  LA    3,DSKSTT      Get temporary FDB                 @SC88308 05843000
         MFSET DSKST,EXTRACT                                   @SC88308 05844000
         MFREQ DSKST               Get the file info...                 05845000
         MVI   ZLU,0               Safety check...                      05846000
         CLI   ZRC,0               Any errors ?                         05847000
         BNZ   DSKER1                                                   05848000
         BAL   14,DSKVALS          Go copy info to FDBD                 05849000
         B     RTRN0                                                    05850000
*                                                                       05851000
* Close file whose ticket is at (R1), release block                     05852000
DSKCLOS  DS    0H                                              @SC89073 05853000
         ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 05854000
         BZ    RTRN0         None, ignore                      @SC86295 05855000
         XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 05856000
         MVC   ZLU(1),FABUNIT      Copy file Unit number                05857000
         LR    6,3                 Save the address of the FAB          05858000
         MFSET DSKST,CLOSE                                              05859000
         TM    FDBFLGS,FWRITE      Write mode file ?                    05860000
         BZ    DSKCLS2                                                  05861000
         OI    DSKST+1,X'10'       Yes, add RLSE option !               05862000
DSKCLS2  MFREQ DSKST               Close the file                       05863000
         LR    1,6                 Get FAB address                      05864000
         LA    0,FABDWDS                                       @SC86295 05865000
       DMSFRET DWORDS=(0),LOC=(1)  Free up the FAB                      05866000
         B     RTRN0                                           @SC86295 05867000
*                                                                       05867080
* Point past 1st N records of file at (R1)                     @SC89218 05867160
DSKPNT   ICM   3,15,0(1)     Get ticket                        @SC89218 05867240
         BZ    RTRN1         Not open                          @SC89218 05867320
         LR    3,1                                             @SC89218 05867400
         LTR   2,2           Number of records to skip         @SC89218 05867480
         BNP   RTRN0         Never mind                        @SC89218 05867560
DSKPNTL  READF 0(,3),E=RTRN1 Skip one                          @SC89218 05867640
         BCT   2,DSKPNTL     ... until finished                @SC89218 05867720
         B     RTRN0         Return with completion code       @SC89218 05867800
*                                                                       05868000
* Read from file   R1->FAB                                              05869000
DSKRED   DS    0H                                              @SC89073 05870000
DSKRED2  LR    3,1                 Point to FAB                         05871000
         MVC   FABCOMM(8),=CL8'Read'  I/O Operation                     05872000
         L     0,FDBBUFF           Get buffer address                   05873000
         ST    0,MFRBUF                                                 05874000
         L     0,FDBBSIZ           Get I/O Length                       05875000
         ST    0,MFRLEN                                                 05876000
         MVC   ZLU(1),FABUNIT      Get unit number                      05877000
         MFSET DSKST,IO,R=(RD)                                          05878000
         MFREQ DSKST               Do the I/O                           05879000
         MVC   FABRC(1),ZRC        Save the return code                 05880000
         L     0,MFARSZ            Get length read from Save file.      05881000
         RETREG 0            Return length as R0               @SC89218 05882000
         CLI   ZRC,0               Any errors ???                       05884000
         BE    RTRN0                                                    05885000
         LA    15,12               End of file.                         05886000
         CLI   ZRC,1               End of file maybe ???                05887000
         BE    RTRN                                                     05888000
         B     RTRN1               Well, just another error...          05889000
*                                                                       05890000
* Write to file    R1->FAB                                              05891000
DSKWRT   DS    0H                                              @SC89073 05892000
         LR    3,1                 Point to FAB                         05893000
         MVC   FABCOMM(8),=CL8'Write'  I/O Operation                    05894000
         L     0,FDBBUFF           Get buffer address                   05895000
         ST    0,MFRBUF                                                 05896000
         L     0,FDBBSIZ           Get I/O Length                       05897000
         ST    0,MFRLEN                                                 05898000
         MVC   ZLU(1),FABUNIT      Get unit number                      05899000
         MFSET DSKST,IO,R=(WR)                                          05900000
         MFREQ DSKST               Do the I/O                           05901000
         MVC   FABRC(1),ZRC        Save the return code                 05902000
         CLI   ZRC,0               Any errors ???                       05903000
         BE    RTRN0                                                    05904000
         LA    15,13               Disk full error code.                05905000
         CLI   ZRC,40              Well, is it full ?                   05906000
         BL    RTRN1                                                    05907000
         CLI   ZRC,42              Three possible return codes          05908000
         BH    RTRN1                                                    05909000
         B     RTRN                                                     05910000
*                                                                       05911000
* Analyze error: Get error code from FABRC field of FAB !               05912000
DSKXXX   DS    0H                                              @SC89073 05913000
         LR    3,1                 Get address of FAB                   05914000
         MVI   ERRNUM,ERRDIE       Set Kermit DISKIO error code         05915000
         L     2,EMSGP             Ptr to msg buffer                    05916000
         MVC   0(8,2),FABCOMM      Copy oprn name                       05917000
         MVC   ZRC(1),FABRC        Get the error code                   05918000
         LA    0,8(2)              Get address of where to pad          05919000
         ST    0,MFRBUF            message                              05920000
         LA    0,70                Maximum length of message            05921000
         ST    0,MFRLEN                                                 05922000
         MFSET DSKST,MSG           Convert RC to real message           05923000
         MFREQ DSKST                                                    05924000
         LA    0,79                Return maximum length of msg.        05925000
         ST    0,EMSGL                                                  05926000
         B     RTRN1                                           @SC87338 05927000
*                                                                       05928000
* Delete file R1->name, Return R15=0 if ok                              05929000
DSKDEL   DS    0H                                              @SC89073 05930000
         LA    3,DSKSTT             Temporary FAB needed                05931000
         MVC   MFNAME(LFID),0(1)    Copy file name to delete            05932000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05933000
         MFREQ DSKST              Try to open the file                  05934000
         CLI   ZRC,0              Error ?                               05935000
         BNE   DSKER2                                                   05936000
         BAL   9,DSKCHKNM          Check if allowed to do I/O           05937000
          B     DSKER2                                                  05938000
         MFSET DSKST,CLOSE,R=(DEL)                                      05939000
         MFREQ DSKST              Delete the file                       05940000
         CLI   ZRC,0              Error ?                               05941000
         BNE   DSKER2                                                   05942000
         LA    15,0          File deleted message              @SC92300 05943000
*                                                                       05944000
DSKMSG   LA    0,L'DSKMTAB   Length of msg                     @SC92300 05945000
         MR    14,0          Get the address of the message    @SC92300 05946000
         LA    1,DSKMTAB(15)                                   @SC92300 05947000
         WTEXT (1),(0)                                         @SC88308 05948000
         MVI   ERRNUM,ERRNOE      No Errors                             05949000
         B     RTRN0                                                    05950000
*                                                                       05951000
* Rename file R1->name, R2->newname,  Return R15=0 if ok                05952000
DSKRNM   DS    0H                                              @SC89073 05953000
         LA    3,DSKSTT             Temporary FAB needed                05954000
         MVC   MFNAME(LFID),0(1)    Copy file name to delete            05955000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05956000
         MFREQ DSKST                Try to open the file                05957000
         CLI   ZRC,0                Error ?                             05958000
         BNE   DSKER2                                                   05959000
         BAL   9,DSKCHKNM          Check if allowed to do I/O           05960000
          B     DSKER2                                                  05961000
         MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         05962000
         MVC   MFNAME(LFID),0(2)         Get new name                   05963000
         MFSET DSKST,CLOSE,R=(RENAME)                                   05964000
         MFREQ DSKST              Rename it !                           05965000
         LA    15,1          File renamed message              @SC92300 05966000
         CLI   ZRC,0              Error on rename ?                     05967000
         BE    DSKMSG                                                   05968000
         CLI   ZLU,0              Is an additional close required ?     05969000
         BE    DSKER2                                                   05970000
         MFSET DSKST,CLOSE        Yes, close the file normally.         05971000
         MFREQ DSKST              Rename failed.                        05972000
         B     DSKER2                                                   05973000
*                                                                       05974000
* Copy file.  R1->name, R2->newname.  Return R15=0 if ok                05975000
DSKCPY   DS    0H                                              @SC89073 05976000
         LA    3,DSKSTT             Temporary FAB needed                05977000
         LA    7,1                  Error by default !!!                05978000
         MVC   MFNAME(LFID),0(1)    Get file name to copy               05979000
         MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05980000
         MFREQ DSKST              Try to open the file                  05981000
         CLI   ZRC,0              Error ?                               05982000
         BNE   DSKER2                                                   05983000
         BAL   9,DSKCHKNM          Check if allowed to do I/O           05984000
          B     DSKER2                                                  05985000
         SLR   8,8                                                      05986000
         ICM   8,1,ZLU             Save Read Unit Number                05987000
         L     9,MFEOFB            Get number of blks to copy           05988000
         MVC   PARMAREA(2),MFORSIZ     Save record size                 05989000
         MVC   PARMAREA+2(4),MFNLRC    Save Line count                  05990000
         MVC   PARMAREA+6(4),MFEOFB    Save last blk written            05991000
         MVC   PARMAREA+10(4),MFEOFD   Save displacement                05992000
         MVC   CMD(64),MFTAG Save tag                          @SC88308 05993000
*                                                                       05994000
         MVC   MFNAME(LFID),0(2)    Get destination                     05995000
         MVC   ZINFIN(LZINFDEF),ZINFOUT                                 05996000
         NI    MFIGCTL,X'7F'        Turn off common bit !!!             05997000
         MFSET DSKST,OPEN,R=(OKNEW,WROK)                                05998000
         MFREQ DSKST              Try to open the file                  05999000
         CLI   ZRC,0                                                    06000000
         BNE   DSKCP55            Error. New file open failed !         06001000
         ICM   8,2,ZLU            Save Write Unit Number                06002000
*                                                                       06003000
         LA    4,1                Starting blk number                   06004000
         LA    5,512              Number of blks to copy                06005000
         LA    6,2048             Address of buffer                     06006000
         A     6,WBUF                                                   06007000
         LTR   9,9                Anything left to do ???               06008000
         BZ    DSKCP50                                                  06009000
DSKCP20  STCM  8,1,ZLU            Set Unit number                       06010000
         STM   4,6,MFSBNU         Set read args                         06011000
         MFSET DSKST,UIO,R=(RD)                                         06012000
         MFREQ DSKST              Read a block                          06013000
         CLI   ZRC,0              Error reading ?                       06014000
         BNE   DSKCP55                                                  06015000
         STCM  8,2,ZLU            Set unit number                       06016000
         STM   4,6,MFSBNU         Set read args                         06017000
         MFSET DSKST,UIO,R=(WR)                                         06018000
         MFREQ DSKST              Write the block back                  06019000
         CLI   ZRC,0         Error writing?                    @SC88308 06020000
         BNE   DSKCP55                                                  06021000
         LA    4,1(4)             Next block                            06022000
         BCT   9,DSKCP20          until all done                        06023000
*                                                                       06024000
DSKCP50  SLR   7,7           Clear return code !                        06025000
DSKCP55  STCM  8,1,ZLU                                                  06026000
         CLI   ZLU,0         Is the input file open ???                 06027000
         BE    DSKCP60                                                  06028000
         MFSET DSKST,CLOSE   Yes, close the input file.                 06029000
         MFREQ DSKST                                                    06030000
         ICM   7,2,ZRC       Save the return code                       06031000
DSKCP60  STCM  8,2,ZLU                                                  06032000
         CLI   ZLU,0         Is the output file open ?                  06033000
         BE    DSKCP80                                                  06034000
         LTR   7,7           Any errors so far ?                        06035000
         BNZ   DSKCP65                                                  06036000
         MFSET DSKST,CLOSE,R=(SETEFP)  No, close and save file          06037000
         MVC   MFORSIZ(2),PARMAREA     Set record size                  06038000
         MVC   MFNLRC(4),PARMAREA+2    Set Line count                   06039000
         MVC   MFEOFB(4),PARMAREA+6    Set last blk written             06040000
         MVC   MFEOFD(4),PARMAREA+10   Set displacement                 06041000
         MVC   MFTAG(64),CMD Restore tag                       @SC88308 06042000
         B     DSKCP70                                                  06043000
DSKCP65  MFSET DSKST,CLOSE,R=(DEL)  Errors, delete file !               06044000
DSKCP70  MFREQ DSKST                                                    06045000
         ICM   7,4,ZRC       Get return code on Close                   06046000
DSKCP80  LR    15,7          Return it to Kermit !                      06047000
         B     RTRN                                                     06048000
*                                                                       06049000
* Type file.   R1-> name. Returns R15=0 if ok.                          06050000
DSKTYP   DS    0H                                              @SC89073 06051000
         LR    4,1           Point to file name                @PG88335 06052000
         OPENF I,(4),FILFDB,FILPTR,E=RTRN1                     @PG88335 06053000
         LR    3,0           Point to FAB                      @PG88335 06054000
         LH    1,FDBLRC                                        @PG88335 06055000
         CH    1,=H'130'     Check record length !!!           @PG88335 06056000
         BL    DSKTYP20                                        @PG88335 06057000
         WTEXT '&ONLY130'                                      @PG88335 06058000
DSKTYP20 L     3,RBUF        Point to data buffer              @PG88335 06059000
         READF FILPTR,BUFFER=(3),E=DSKTYP50                    @PG88335 06060000
         CH    0,=H'130'     Record too long ?                 @PG88335 06061000
         BL    DSKTYP30                                        @PG88335 06062000
         LA    0,129         Yes, truncate...                  @PG88335 06063000
DSKTYP30 LTR   0,0           Is it null ?                      @PG88335 06064000
         BNZ   DSKTYP35                                        @PG88335 06065000
         MVI   0(3),X'40'    Then we must have at least        @PG88335 06066000
         LA    0,1           one character to output           @PG88335 06067000
DSKTYP35 WTEXT (3)                                             @PG88335 06068000
         B     DSKTYP20                                        @PG88335 06069000
DSKTYP50 C     15,F12        EOF code ?                        @PG88335 06070000
         BE    DSKTYP70                                        @PG88335 06071000
         ERRF  ,             Analyze error code                @PG88335 06072000
         CLOSF FILPTR                                          @PG88335 06073000
         B     RTRN1                                           @PG88335 06074000
DSKTYP70 CLOSF FILPTR                                          @PG88335 06075000
         B     RTRN0                                           @PG88335 06076000
*                                                                       06077000
* Return on error, release useless block, if any                        06078000
DSKER1   LTR   1,4           Any block assigned?               @SC86295 06079000
         BZ    RTRN1         No                                @SC86295 06080000
         LA    0,FABDWDS     Yes, release it                   @SC86295 06081000
       DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 06082000
         B     RTRN1         Flag error                        @SC86295 06083000
* Error return from disk utilities. Set ERRNUM properly.                06084000
DSKER2   CLI   ZRC,12                                                   06085000
         BNE   DSKER3                                                   06086000
         MVI   ERRNUM,ERRFNE  Invalid filename                          06087000
         B     RTRN1                                                    06088000
DSKER3   CLI   ZRC,30                                                   06089000
         BNE   DSKER4                                                   06090000
         MVI   ERRNUM,ERRFNF  File not found                            06091000
         B     RTRN1                                                    06092000
DSKER4   MVI   ERRNUM,ERRDIE  Disk I/O Error                            06093000
         B     RTRN1                                                    06094000
* Allocate FAB and copy default FDB                                     06095000
DSKALC   LR    5,1           Save FDB ptr                      @SC86295 06096000
         MVC   MFNAME,0(2)                                              06097000
         LA    0,FABDWDS                                       @SC86295 06098000
       DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 06099000
         LR    3,1           New block ptr                     @SC86295 06100000
         LA    4,FDBD        FDB pointer                       @SC88120 06101000
         RETREG (0,3),(1,4)  Return FAB ptr in R0, FDB in R1   @SC89218 06102000
         LR    4,3           Indicate we have it               @SC88120 06104000
         XC    0(8*FABDWDS,3),0(3)                             @SC86295 06105000
         MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 06106000
         MVC   FABFN(LFID),0(2)  Copy filename to FAB                   06107000
         BR    9                                               @SC86295 06108000
*                                                                       06109000
* Set up search through list of files, pattern at (R1)                  06110000
DSKNSET  DS    0H                                              @SC89073 06111000
         MVC   SCODE,UCODE        Get default user code                 06112000
         MVC   NXFN(LFID),0(1)    Save pattern name                     06113000
         CLI   4(1),C':'          Code specified in filename ?          06114000
         BNE   DSKNS4             Nope.                                 06115000
         MVC   SCODE(4),0(1)      Get the new code for search           06116000
         MVC   NXFN(LFID),BLNAME  Clear the filename pattern            06117000
         MVC   NXFN(17),5(1)      Copy filename part only               06118000
DSKNS4   CLC   SCODE(4),=CL4'*USR' Do we really want the user's code ?  06119000
         BNE   DSKNS6                                                   06120000
         MVC   SCODE(4),$USRCDE   Yes, then put in the real thing       06121000
DSKNS6   MVI   NXFLG,NFSOK        Clear flag byte                       06122000
         LA    2,LFID             Max length of filename                06123000
         LA    3,NXFN+LFID                                              06124000
DSKNS8   BCTR  3,0                                                      06125000
         CLI   0(3),C'?'          Is it a wildcard ?                    06126000
         BE    DSKNS10                                                  06127000
         CLI   0(3),C'*'          Is it a wildcard ?                    06128000
         BE    DSKNS10                                                  06129000
         BCT   2,DSKNS8                                                 06130000
         B     RTRN0              No wildcards, Grreat !!!              06131000
*                                                                       06132000
DSKNS10  CLC   SCODE(4),$USRCDE   Are we searching our library ?        06133000
         BE    DSKNS12                                                  06134000
         TM    UPRIVS,FILES+LSCAN No, then we need some privs !!!       06135000
         BZ    DSKNS15                                                  06136000
DSKNS12  LA    1,NXFN+LFID        End of token if no blanks             06137000
         TRT   NXFN(LFID),TRTBL   Find 1st blank                        06138000
         LA    2,NXFN                                                   06139000
         SR    1,2                Calc length of string                 06140000
         ST    1,NXFNL            Save it...                            06141000
         OI    NXFLG,NFWLD        Wildcard search necessary !           06142000
         L     2,MFINDBUF                                               06143000
         CALL  MFIND1,((2),F10,SCODE,F0,ZRC),VL,MF=(E,PARMAREA)         06144000
         LTR   15,15              Any errors ???                        06145000
         BZ    RTRN0                                                    06146000
DSKNS15  OI    NXFLG,NFERR        Error on MFIND1 call                  06147000
         B     RTRN1                                                    06148000
*                                                                       06149000
* Flush previous file pattern                                           06150000
DSKXSET  DS    0H                                              @SC89073 06151000
         MVI   NXFLG,0            Clear flag byte                       06152000
         B     RTRN0                                                    06153000
*                                                                       06154000
* Check CWD string, return code in R15                                  06155000
DSKCWDF  DS    0H                                              @SC89073 06156000
         B     RTRN0                                                    06157000
*                                                                       06158000
* Check disk space for proposed file: FDB at (R1), FAB ptr at (R6)      06159000
DSKTSP   L     5,FDBSIZE-FDBD(,1)  Get actual size             @SC90037 06159200
         ICM   3,15,0(6)     Get FAB ptr                       @SC90037 06159400
         BNZ   DSKTSP0       Not open yet                      @SC90037 06159600
         MVC   MFNAME(LFID),0(2)   Get filename                @SC90037 06159800
         LA    3,DSKSTT      Get temporary FDB                 @SC90037 06160000
         MFSET DSKST,EXTRACT                                   @SC90037 06160200
         MFREQ DSKST         Get the file info                 @SC90037 06160400
         MVI   ZLU,0         For safety                        @SC90037 06160600
         CLI   ZRC,0         Found it?                         @SC90037 06160800
         BNE   DSKTSP0       Not found, nothing to erase       @SC90037 06161000
         L     1,MFOPRM      Old file size in KBytes           @SC90037 06161200
         SR    5,1           Assume old file will be erased    @SC90037 06161400
         BNP   RTRN0         Will release enough for new file  @SC90037 06161600
DSKTSP0  DS    0H            Check free space                  @SC90037 06161800
         MFSET DSKST,USERCTL    Get User Control Record to              06163000
         MFREQ DSKST            determine how much space the            06164000
         MVC   FABRC(1),ZRC     user has left. Save return code !       06165000
         L     1,MFMAXS         Get max allocation space                06166000
         S     1,MFACUR         Subtract amt allocated                  06167000
         CLR   1,5                                             @SC90037 06168000
         BL    RTRN1         No room                           @SC86316 06169000
         B     RTRN0         Ok                                @SC86316 06170000
*                                                                       06171000
DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 06172000
         RETREG (1,0)        Return FDB ptr as R1              @SC89218 06173000
***  GET FILE'S DATE...                                                 06175000
         SR    7,7                                             @SC87296 06176000
         ICM   7,3,MFUIMD    Mod date as (y-1970)*366+d        @SC92086 06177000
         BNZ   *+8                                             @SC92086 06177100
          ICM  7,3,MFUICD    Try for creation date             @SC92086 06177200
         BZ    DSKVDTZ       No date available (?)             @SC92086 06177300
         BCTR  7,0           Keep day 366 in same year         @SC92086 06177400
         SR    6,6                                             @SC92086 06177500
         D     6,=F'366'     Get d and y-1970                  @SC92086 06177600
         LA    7,1970(,7)                                      @SC92086 06177700
         CVD   7,TMPDW                                         @SC87296 06178000
         MVO   FDBDATE(3),TMPDW Copy year                      @SC92086 06179000
         MVC   DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31)  @SC86299 06181000
         N     7,F3          See if leap year                  @SC92086 06182000
         BNZ   *+8                                             @SC87296 06183000
         MVI   DSKMNTH+9,29  Leap year, change Feb.            @SC86299 06184000
         LA    7,1(,6)       Now get day of year               @SC92086 06184500
         LA    6,11                                            @SC86299 06185000
         SR    0,0                                             @SC86299 06186000
DSKVMDL  IC    0,DSKMNTH-1(6)                                  @SC86299 06187000
         SR    7,0           Test if passed the right month    @SC86299 06188000
         BNP   DSKVMDM       Got it                            @SC86299 06189000
         BCT   6,DSKVMDL                                       @SC86299 06190000
         SR    0,0           Hit December                      @SC86299 06191000
DSKVMDM  AR    7,0           Get day of month                  @SC86299 06192000
         LCR   6,6                                             @SC86299 06193000
         LA    6,12(6)       Get month                         @SC86299 06194000
         MH    6,=H'100'                                       @SC86299 06195000
         AR    6,7           Combine MMDD                      @SC86299 06196000
         MH    6,=H'10'                                        @SC86299 06197000
         CVD   6,TMPDW                                         @SC86299 06198000
         MVC   FDBDATE+2(2),TMPDW+5                            @SC86299 06199000
         ICM   7,15,MFXITD   Get time of day, if any           @SC92086 06200000
         BZ    DSKVDTZ       Not specified, leave it out       @SC92086 06200200
         SLR   6,6                                             @SC92086 06200400
         D     6,=F'300'     Convert to seconds                @SC92086 06200600
         SLR   6,6                                             @SC92086 06200800
         D     6,=F'60'      Get minutes                       @SC92086 06201000
         LR    0,6           Save remainder = seconds          @SC92086 06201200
         SLR   6,6                                             @SC92086 06201400
         D     6,=F'60'      Get hours in R7, minutes in R6    @SC92086 06201600
         MH    7,=H'100'     Put together into hhmmss form     @SC92086 06201800
         AR    7,6                                             @SC92086 06202000
         MH    7,=H'100'                                       @SC92086 06202200
         AR    7,0                                             @SC92086 06202400
         MH    7,=H'10'      Shift left one digit              @SC92086 06202600
         CVD   7,TMPDW       Convert to hhmmss0+               @SC92086 06202800
         MVC   FDBDATE+4(3),TMPDW+4                            @SC92086 06203000
DSKVDTZ  DS    0H                                              @SC92086 06203200
         L     1,MFOPRM      Set file size in KBytes                    06204000
         ST    1,FDBSIZE                                                06205000
         SLR   1,1           Set record format character                06206000
         IC    1,MFORFM      Ignore 'Compressed' modes.                 06207000
         SLL   1,1                                                      06208000
         LA    0,RFMTAB                                                 06209000
         AR    1,0                                                      06210000
         MVC   FDBRCF,0(1)                                              06211000
         MVC   FDBLRC(2),MFORSIZ  Get logical record length             06212000
         NI    FDBFLGS,255-FWRITE Clear the write mode flag             06213000
         BR    14                                                       06214000
*                                                                       06215000
*        NXTFST Routine - searches through Save Library Index           06216000
*                                                                       06217000
DSKNXT   DS    0H                                              @SC89073 06218000
         TM    NXFLG,NFSOK        Was a search set up ???               06219000
         BZ    RTRN1                                                    06220000
         TM    NXFLG,NFERR+NFEND  Error or End of search ???            06221000
         BNZ   RTRN1                                                    06222000
*                                                                       06223000
         TM    NXFLG,NFWLD        Do we need to call MFINDX ?           06224000
         BO    DSKSRCH                                                  06225000
         OI    NXFLG,NFEND        End of search...                      06226000
         LA    1,NXFN             Source name was good. Use it!         06227000
DSKFND   MVC   MFNAME(5),SCODE  Rebuild the complete filename  @SC88308 06228000
         MVC   MFNAME+5(17),0(1)  info on the file.                     06229000
         MVC   FILNAM(LFID),MFNAME  Setup FILNAM !!!                    06230000
         B     DSKTST2                                                  06231000
*                                                                       06232000
DSKSRCH  CALL  MFINDX,(FCODE,LCFN,NXFLTYP,NXSVFLG,NXBKNUM,NXDIRLOC),VL,+06233000
               MF=(E,PARMAREA)                                          06234000
         C     15,F4              End of library search ?               06235000
         BNE   NXT20                                                    06236000
         OI    NXFLG,NFEND        Yes, end of search                    06237000
         B     RTRN1                                                    06238000
NXT20    LTR   15,15              Error in search ?                     06239000
         BZ    NXT30                                                    06240000
         OI    NXFLG,NFSERRS+NFERR Yes, error in search        @SC88308 06241000
         B     RTRN1                                                    06242000
NXT30    CLC   NXFLTYP,F0         Skip over common entries              06243000
         BNE   DSKSRCH                                                  06244000
         CLI   LCFN,C'.'          Skip over temporary files             06245000
         BE    DSKSRCH                                                  06246000
         CLC   FCODE(4),SCODE     Is this the right code ???            06247000
         BNE   DSKSRCH                                                  06248000
         CALL  MATCH,(LCFN,FM17,NXFN,NXFNL,ASTER,QUEST),VL,            +06249000
               MF=(E,PARMAREA)                                          06250000
         LTR   0,0                Well, did they match ???              06251000
         BZ    DSKSRCH                                                  06252000
         LA    1,LCFN             Point to name found and go            06253000
         B     DSKFND             copy it and set FDB                   06254000
*                                                                       06255000
* Directory Info on file R1->name, return R15=0 if OK                   06256000
DSKDIR   DS    0H                                              @SC89073 06257000
         NXTFSET E=DSKDRERR  Set up search (name at R1)        @SC88308 06258000
DSKDRLP  NXTF  E=DSKDRZ      Find next entry                   @SC88308 06259000
         TM    NXFLG,NFFND   Found something already?          @SC90264 06259200
         BO    DSKDRL1                                         @SC90264 06259400
         WTEXT '&DIRHDNG'                                      @SC92300 06259600
         OI    NXFLG,NFFND   Found something, at least one     @SC88308 06260000
DSKDRL1  DS    0H                                              @SC90264 06260500
         LA    1,CMD         Yes, build the filename with      @SC88308 06261000
         LR    2,1                the attributes we want in a           06262000
         LA    3,LFID        Length of name buffer             @SC88308 06263000
         LA    4,MFNAME                                        @SC88308 06264000
         LR    5,3                                             @SC88308 06265000
         CLC   0(4,4),$USRCDE   User's code?                   @SC88308 06266000
         BNE   *+12          No                                @SC88308 06267000
          A    4,F5          Yes, skip over it for output      @SC88308 06268000
          S    5,F5                                            @SC92301 06269000
         ICM   4,8,F64+3     Get blank for padding             @SC92086 06269500
         MVCL  2,4                                             @SC88308 06270000
         ICM   0,3,MFORSIZ                                              06271000
         BAL   9,DSKNUM           Add the logical record length         06272000
         MVC   0(2,2),BLNAME Leave some blanks                 @SC88308 06273000
         SLR   3,3                                                      06274000
         IC    3,MFORFM           Get record format                     06275000
         SLL   3,1                                                      06276000
         LA    3,RFMTAB(3)        Get address of printable value        06277000
         MVC   2(2,2),0(3)   Add to line                       @SC88308 06278000
         LA    2,4(2)        Bump the length                   @SC88308 06279000
         ICM   0,15,MFOPRM                                              06280000
         BAL   9,DSKNUM           Add the file size in Kbytes           06281000
         ICM   0,15,MFNLRC        Add the number of lines               06284000
         BAL   9,DSKNUM                                                 06285000
         LA    3,DSKSTT      Point to temp FDB                 @SC92086 06285200
         CLI   FDBDATE,X'19' Validate century                  @SC92086 06285400
         BL    DSKDRDZ       No good!                          @SC92086 06285600
         CLI   FDBDATE,X'20'                                   @SC92086 06285800
         BH    DSKDRDZ                                         @SC92086 06286000
         MVC   0(DSKDRTL,2),DSKDRDT Copy whole pattern         @SC92086 06286200
         ED    0(DSKDRTL,2),FDBDATE and make it printable      @SC92086 06286400
         LA    2,DSKDRDL(,2) Length of just date portion       @SC92086 06286600
         CLC   FDBDATE+4(3),F0                                 @SC92086 06286800
         BE    *+8           No time given                     @SC92086 06287000
          LA   2,DSKDRTL-DSKDRDL(,2) Include time portion      @SC92086 06287200
DSKDRDZ  DS    0H                                              @SC92086 06287400
*                                                                       06288000
         SR    2,1                Get the output length                 06289000
         WTEXT (1),(2)                                                  06290000
         B     DSKDRLP                                         @SC88308 06291000
*                                                              @SC88308 06292000
DSKDRZ   TM    NXFLG,NFSERRS+NFERR                             @SC88308 06293000
         BNZ   DSKDRERR      Report error                      @SC88308 06294000
         TM    NXFLG,NFFND   Any files found?                  @SC88308 06295000
         BO    RTRN0         Yes, return gracefully            @SC88308 06296000
DSKDRERR B     RTRN1         Not found or invalid              @SC90264 06297000
*                                                                       06299000
DSKNUM   CVD   0,TMPDW            Pack the binary value                 06300000
         OI    TMPDW+7,15         Set zone                              06301000
         UNPK  0(8,2),TMPDW       Convert to printable                  06302000
         LA    5,7(2)             Point to end of string                06303000
DSKNUM2  CLI   0(2),C'0'          Remove leading zeros                  06304000
         BNE   DSKNUM3            except for the first one.             06305000
         MVI   0(2),C' '                                                06306000
         LA    2,1(2)                                                   06307000
         CR    2,5                                                      06308000
         BL    DSKNUM2                                                  06309000
DSKNUM3  LA    2,1(5)             Get the new ending address            06310000
         BR    9                                                        06311000
*                                                                       06312000
*  Check for privs to open filename                                     06313000
*  R3->FAB,  R9->returns                                       @SC88308 06314000
DSKCHKNM TM    UPRIVS,FILES+LSCAN If FILES, never any problems          06315000
         BNZ   4(9)                                                     06316000
         CLC   MFUIFC(4),$USRCDE  If our own code, then no problem      06317000
         BE    4(9)                                                     06318000
         TM    MFOACNB,X'A0'      Allowed to read file ???              06319000
         BZ    4(9)                                                     06320000
         MVI   FABRC,21           Not your library error.               06321000
         CLI   ZLU,0              Is the file still open ?              06322000
         BER   9                                                        06323000
         MFSET DSKST,CLOSE        Yes, close it normally...             06324000
         MFREQ DSKST                                                    06325000
         BR    9                  Error return                          06326000
*                                                                       06327000
RFMTAB   DC    C'U F FCV VC'      Record Format Table                   06328000
DSKMTAB  DC    CL25'&FILDELT'                                  @SC92300 06329000
         DC    CL25'&FILRENM'                                  @SC92300 06329500
         DC    CL25'&FILCOPY'                                  @SC92300 06330000
DSKDRDT  DC    C'  ',4X'20',C'/',2X'20',C'/',2X'20'      Date  @SC92086 06331200
DSKDRDL  EQU   *-DSKDRDT     Length of date portion            @SC92086 06331400
         DC    C' ',2X'20',C':',2X'20',C':',2X'20'       Time  @SC92086 06331600
DSKDRTL  EQU   *-DSKDRDT     Length of whole pattern           @SC92086 06331800
         LOCALS ,                                                       06332000
DSKMNTH  DS    XL11          Month length table                @SC86299 06334000
DSKCOD   DS    X             Saved DISKIO code                 @SC88308 06335000
         DROP  R3                                                       06336000
         EXIT                                                           06337000
         EJECT                                                          06338000
