home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / ibm370.tar.gz / ibm370.tar / ikmutl.asm < prev    next >
Assembly Source File  |  1993-10-21  |  128KB  |  1,578 lines

  1. *COPY                                                 IKMUTL            05000000
  2.          CHECKVER IKCUTL,4.3                                   @SC90072 05000500
  3.          TITLE 'CWDSET/DSPACE Routines - set/show working directory'    05001000
  4. * Set new 'working directory', i.e., new code (need LSCAN or FILES)     05002000
  5. * Entry: SCANPTR string has option                                      05003000
  6. * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged.   05004000
  7. CWDSET   ENTER                                                 @SC86164 05005000
  8.          NTOKN N=CWDRSET,H=CWDERR                                       05006000
  9.          C     7,F3                 Length MUST be 4                    05007000
  10.          BNE   CWDERR                                                   05008000
  11.          TM    UPRIVS,LSCAN+FILES   Need some priveleges to             05009000
  12.          BZ    CWDPRV               change code                         05010000
  13.          MVC   UCODE(4),0(6)        Save as new default code            05012000
  14.          TR    UCODE(4),UPCASE     Upper case it               @SC91033 05012500
  15.          MVI   DESTL,1              Yes, new code                       05013000
  16.          B     RTRN0                                           @SC86295 05014000
  17. CWDPRV   PTEXT '&CWDPRVS'                                      @SC92300 05015000
  18.          B     SUBERR                                                   05016000
  19. CWDRSET  MVI   DESTL,0              No more code. Default to user's     05017000
  20.          MVC   UCODE(4),$USRCDE     Get user's code from locore         05018000
  21.          B     RTRN0                                                    05019000
  22. CWDERR   PTEXT '&CWDERRM'                                      @SC92300 05020000
  23.          B     SUBERR               Go display error msg                05021000
  24. * * * * * * * * * * * * * * * * * * * * * *                             05022000
  25. *                                                                       05023000
  26. *                                                                       05024000
  27. *        DSPACE Routine - display available disk space         @SC86164 05025000
  28. *                                                                       05026000
  29. * Show space available in 'working directory' or other area             05027000
  30. * Entry: SCANPTR string has option (none => working directory)          05028000
  31. * Exit: R15=0 if ok, R15=1 if error or help needed. ERRNUM unchanged    05029000
  32. DSPACE   ENTER ALT                                             @SC86164 05030000
  33.          MFSET DSKST,USERCTL                                            05031000
  34.          MFREQ DSKST              Get User Control Record               05032000
  35.          LA    15,PARMAREA         Temporary output buffer              05033000
  36.          L     4,MFMAXS           Calculate space in use                05034000
  37.          S     4,MFACUR                                                 05035000
  38.          BAL   2,EDDEC            Convert to printable                  05036000
  39.          INITSTR '&KBYTFRE'                                    @SC92300 05037000
  40.          LR    0,15                                            @SC92300 05038000
  41.          LA    1,PARMAREA                                               05039000
  42.          SR    0,1                                                      05040000
  43.          WTEXT (1),(0)       Display the message                        05041000
  44.          B     RTRN0                                                    05042000
  45.          LOCALS ,                                              @SC86295 05043000
  46.          EXIT  ,                                               @SC86295 05044000
  47.          TITLE 'FSPEC Routine - extract filespec from scan string'      05045000
  48. *                                                                       05046000
  49. * Entry: R1->name field, R0=flags selecting operation (see below)       05047000
  50. *        For parse operations, SCANPTR defines the input string.        05048000
  51. *        For getting foreign or display filespec, R7->output buffer     05049000
  52. * Exit: if not FFNEW, then R15=0 if ok, 1 if ?, 2 if bad.               05050000
  53. *        For R15=1 or 2 R3,R4 give message.  ERRNUM may be leftover.    05051000
  54. *                                                                       05052000
  55. *                                 Flags:                  Notes:        05053000
  56. *   Tasks:               FFRCF FFSND FFGET FFNEW                        05054000
  57. * Parse RECV               X                     set ROVR properly      05055000
  58. * Parse SEND 1st                 X                                      05056000
  59. * Parse SEND 2nd           X     X                                      05057000
  60. * Parse GET 1st                        X                                05058000
  61. * Parse GET 2nd            X           X         set ROVR properly      05059000
  62. * Parse F-packet   (FFHDR) X     X     X                                05060000
  63. * Parse for Generic(FFUTL)       X     X         FFWLD: allow partial   05061000
  64. * Parse TAKE                                                            05062000
  65. *                                                                       05063000
  66. * Get unique name                            X     R15: 0=>ok, 1=>bad   05064000
  67. * Interactive name check               X     X     R15: 0=>ok, 1=>bad   05065000
  68. * Get foreign name (FFENC) X                 X     R15->end of string   05066000
  69. * Get display form (FFDSP)       X           X     R15->end of string   05067000
  70. *                                                                       05068000
  71. FSPEC    ENTER                                                 @SC86295 05069000
  72.          STC   0,FSPFLG                                        @SC86295 05070000
  73.          LR    5,0                                             @SC88049 05071000
  74.          SRL   5,4           Convert flags to index            @SC88049 05072000
  75.          AR    5,5                                             @SC88049 05073000
  76.          LR    0,1           Copy ptr to filespec              @SC86295 05074000
  77.          TM    FSPFLG,FFNEW                                    @SC86295 05075000
  78.          BO    FSPWRN                                          @SC86295 05076000
  79.          MVC   0(LFID,1),BLNAME  Clear the filename to blanks           05077000
  80.          PTEXT '&BADFSPC'                                      @SC92300 05078000
  81.          MVI   ERRNUM,ERRFNE Assume bad file name              @SC86158 05079000
  82.          LH    5,FSP0(5)     Get dispatch adr                  @SC88049 05080000
  83.          B     FSP0(5)       Go to proper handler              @SC88049 05081000
  84. *                                                                       05082000
  85. *                  Take        Get 1st     Send 1st    Generic          05083000
  86. FSP0     DC    AL2(FSPTAK-FSP0,FSPSN2-FSP0,FSPSND-FSP0,FSPUTL-FSP0)     05084000
  87. *                                                                       05085000
  88. *                  Receive    Get 2nd    Send 2nd    F-packet           05086000
  89.          DC    AL2(FSPRC-FSP0,FSPRC-FSP0,FSPSN2-FSP0,FSPHD-FSP0)        05087000
  90.          SPACE                                                          05088000
  91. FSPUTL   TM    FSPFLG,FFWLD  Utility: default to all files?    @SC88049 05089000
  92.          BZ    FSPASC        No                                @SC86295 05090000
  93.          MVC   0(5,1),UCODE  Default prefix                             05091000
  94.          MVI   5(1),C'*'     Yes                               @SC88308 05092000
  95. FSPSND   DS    0H                                                       05093000
  96. FSPASC   TM    FL2,SRV       Server mode?                      @SC86295 05094000
  97.          BZ    FSPCPY        No, don't need to convert         @SC86295 05095000
  98.          ICM   15,15,LEN     Get length                        @SC86295 05096000
  99.          BZ    FSPCPY                                          @SC86295 05097000
  100.          BCTR  15,0          Correct for EX                    @SC86158 05098000
  101.          L     5,ADR         Get string ptr                    @SC89215 05099000
  102.          EX    15,FSPTRAE    Change to EBCDIC                  @SC89215 05100000
  103.          EX    15,FSPTRUP    Upcase and dot to space           @SC89215 05101000
  104.          B     FSPCPY                                          @SC86295 05102000
  105. FSPTRAE  TR    0(,5),ATOED                                     @SC89301 05102300
  106. FSPTRUP  TR    0(,5),UPCASE                                    @SC89215 05102600
  107. FSPRC    NI    FL1,255-ROVR  Setup for RECEIVE                 @SC86295 05103000
  108.          NI    FL4,255-NMOK-NMCHNG  Collision not checked yet  @SC90033 05104000
  109.          MVI   0(1),C'$'     Default fn                        @SC88308 05105000
  110.          B     FSPCPY                                          @SC86295 05106000
  111. FSPHD    MVI   0(1),C'$'     Default fn                        @SC88308 05107000
  112.          L     2,ADR                                           @SC86295 05108000
  113.          IC    7,4(2)        Save possible code separator      @SC88308 05109000
  114.          TR    0(256,2),FSPTAB  Make valid fn chars            @SC86295 05110000
  115.          CLM   7,1,=C':'     Was it a separator?               @SC91316 05111000
  116.          BNE   *+8                                             @SC88308 05112000
  117.           STC  7,4(2)        Yes, change char. back to colon   @SC88308 05113000
  118.          B     FSPCPY                                          @SC86295 05114000
  119. FSPSN2   MVI   0(1),0        Clear JFSPEC length !!!                    05115000
  120.          CLI   BRK,C','                                        @PG88306 05116000
  121.          BE    RTRN0         Foreign name omitted              @PG88306 05117000
  122.          NTOKN H=FSP2H,N=RTRN0                                          05118000
  123.          LA    7,1(7)        Not machine length !                       05119000
  124.          LA    1,L'JFNAM     Get maximum length                         05120000
  125.          CLM   7,3,*-2       Does it fit?                      @SC86224 05121000
  126.          BNH   *+6           Yes                               @SC86224 05122000
  127.          LR    7,1           Use what we can                   @SC86224 05123000
  128.          LR    3,0                                             @SC86295 05124000
  129.          STC   7,0(3)        Save length                       @SC86224 05125000
  130.          LA    0,1(3)                                          @SC86295 05126000
  131.          MVCL  0,6           Get fn, at least                  @SC86224 05127000
  132.          B     RTRN0                                           @SC86295 05128000
  133. *                                                                       05129000
  134. FSPTAK   DS    0H                                                       05130000
  135. FSPCPY   NTOKN H=FSPH,N=FSPZ                                            05131000
  136.          LR    8,0           Save start                                 05133000
  137.          KCALL FOPSTR,LFID(,8),E=FSPINV                        @SC89218 05133300
  138.          LA    1,LFID        Get max length                             05133600
  139.          CLI   4(6),C':'     Code prefix ?                              05134000
  140.          BE    FSPCPC                                                   05135000
  141.          LR    2,0                                                      05136000
  142.          MVC   0(5,2),UCODE  Add the user code                          05137000
  143.          LA    0,5(2)        Point past code prefix                     05138000
  144.          S     1,F5          Reduce receiving length                    05139000
  145. FSPCPC   TM    FSPFLG,FFRCF                                             05140000
  146.          BZ    FSPCPN                                          @SC86295 05141000
  147.          OI    FL1,ROVR      Overwrite received fname          @SC86295 05142000
  148. FSPCPN   LA    7,1(7)                                                   05143000
  149.          ICM   7,8,BLANK                                                05144000
  150.          MVCL  0,6           Copy token with padding                    05145000
  151.          CLM   7,7,F0        Hope nothing left over!                    05146000
  152.          BNE   FSPINV        Name was too long                          05147000
  153.          TR    0(LFID,8),UPCASE   Ok, now upcase it                     05148000
  154.          B     RTRN0                                           @SC86295 05149000
  155. *                                                                       05150000
  156. FSPZ     LR    14,0                                            @SC86295 05151000
  157.          CLI   0(14),C' '    Any default given?                @SC86295 05152000
  158.          BH    RTRN0         Yes, use it                       @SC86295 05153000
  159. FSPMIS   PTEXT '&NOFSPEC'                                      @SC92300 05154000
  160. FSPINV   LA    15,2                                            @SC86295 05155000
  161.          B     FSPPTRS                                         @SC86295 05156000
  162. *                                                                       05157000
  163. FSPH     PTEXT '&FMTFSPC&FSPCPRM'                              @SC91224 05158000
  164.          CLI   FSPFLG,FFSND  SEND 1st?                         @SC89218 05158200
  165.          BE    *+8           Yes, use whole message            @SC89218 05158400
  166.           SH   4,=H'&FMTOPT' Chop off option part              @SC92300 05158600
  167.          B     FSP0H                                           @SC86295 05159000
  168. FSP2H    PTEXT '&FORFSPC'                                      @SC86295 05160000
  169. FSP0H    LA    15,1                                            @SC86295 05161000
  170. FSPPTRS  RETREG 3,4          Return msg ptrs                   @SC86295 05162000
  171. FSPRET   RET   ,                                               @SC86295 05164000
  172. *                                                                       05165000
  173. * Non-parsing functions . . .                                           05166000
  174. *                                                                       05167000
  175. * Get unique filespec                                                   05168000
  176. FSPWRN   LR    4,1           Save name ptr                     @SC86295 05169000
  177.          TM    FSPFLG,FFENC                                    @SC86295 05170000
  178.          BO    FSPENC        Encode name into buffer           @SC86295 05171000
  179.          TM    FSPFLG,FFDSP                                    @SC86295 05172000
  180.          BO    FSPDSP        Copy name into buffer for display @SC86295 05173000
  181.          TM    FL4,NMOK      Already checked?                  @SC87012 05174000
  182.          BO    RTRN0         Yes, ok                           @SC87012 05175000
  183.          MVC   XFILE,0(1)    Save original name                @SC90033 05175500
  184.          LA    6,LFID-2(1)   End of FT                                  05176000
  185.          BCTR  6,0                                             @BS86001 05177000
  186.          CLI   0(6),C' '     Find end of token                 @BS86001 05178000
  187.          BE    *-6                                             @BS86001 05179000
  188.          LA    5,10+1        Allowed retries                   @BS86001 05180000
  189.          LA    7,C'0'        Extra character                   @BS86001 05181000
  190.          OI    FL4,NMOK      Assume it checks                  @SC87012 05182000
  191. FSPSTA   OPENF T,(4),E=RTRN0 Does it exist already?            @SC86135 05183000
  192.          OI    FL4,NMCHNG    Yes, remember collision occurred  @SC90033 05183500
  193.          MVI   1(6),C'$'     Yes, modify Fn                             05184000
  194.          STC   7,2(6)        Serialize                         @BS86001 05185000
  195.          LA    7,1(7)        Bump counter                      @BS86001 05186000
  196.          BCT   5,FSPSTA                                        @BS86001 05187000
  197.          PTEXT '&FILCLSN'                                      @SC88049 05188000
  198.          B     FSP0H         Return error code                 @SC88049 05189000
  199. *                                                                       05190000
  200. * Encode name at (R1) into (R7) buffer (in ASCII), possibly with        05191000
  201. *  substitution from JFSPEC, but disable subsequent subst.              05192000
  202. *  Return updated ptr in R15                                            05193000
  203. FSPENC   LA    1,JFSPEC      Complex string?                   @SC86224 05194000
  204.          BAL   14,PAKFOR                                       @SC86224 05195000
  205.          LR    15,7          Save ptr                                   05196000
  206.          BNZ   FSPFILS       Yes, tokens aren't used           @SC86224 05197000
  207.          MVC   0(LFID,7),BLNAME                                         05198000
  208.          MVC   0(17,7),5(4)     Copy filename Only                      05199000
  209.          CLI   4(4),C':'        Is there a code prefix ???              05200000
  210.          BE    *+10                                                     05201000
  211.          MVC   0(LFID,7),0(4)   Copy token                              05202000
  212.          LA    1,LFID(7)        End of token if no blanks               05203000
  213.          TRT   0(LFID,7),TRTBL  Find 1st blank                          05204000
  214.          TR    0(LFID,7),ETOAD  ASCII it                       @SC89301 05205000
  215.          LR    15,1             New end of string                       05206000
  216. FSPFILS  MVI   JFSPEC,0      Turn off string                   @SC86224 05207000
  217.          B     FSPRET                                          @SC86295 05208000
  218. *                                                                       05209000
  219. * Copy name at (R1) into (R7) buffer in display form                    05210000
  220. *  Return updated ptr in R15                                            05211000
  221. FSPDSP   MVC   0(LFID,7),0(4)   Copy token                              05212000
  222.          CLI   4(4),C':'        Prefix already ?                        05213000
  223.          BE    FSPDTK3                                                  05214000
  224.          MVC   0(5,7),UCODE     Get prefix                              05215000
  225.          MVC   5(LFID-5,7),0(4)                                         05216000
  226. FSPDTK3  LA    1,LFID(7)        End of token if no blanks               05217000
  227.          TRT   0(LFID,7),TRTBL  Find 1st blank                          05218000
  228.          LR    15,1             New end of string                       05219000
  229.          B     FSPRET                                                   05220000
  230. *                                                                       05221000
  231. * Valid MUSIC file name characters                                      05222000
  232. FSPTAB   DC    75C'$',C'.'           dot                                05223000
  233.          DC    15C'$',C'$'           dollar sign                        05224000
  234.          DC    31C'$',C'#@'          pound sign, at sign       @SC88308 05225000
  235.          DC    04C'$',C'ABCDEFGHI'   a-i                                05226000
  236.          DC    07C'$',C'JKLMNOPQR'   j-r                                05227000
  237.          DC    08C'$',C'STUVWXYZ'    s-z                                05228000
  238.          DC    23C'$',C'ABCDEFGHI'   A-I                                05229000
  239.          DC    07C'$',C'JKLMNOPQR'   J-R                                05230000
  240.          DC    08C'$',C'STUVWXYZ'    S-Z                                05231000
  241.          DC    06C'$',C'0123456789'  0-9                                05232000
  242.          DC    06C'$'                                                   05233000
  243.          LOCALS ,                                              @SC86295 05234000
  244. FSPFLG   DS    X             Filespec flags                    @SC86295 05235000
  245. FSPEC    EXIT                                                  @SC86295 05236000
  246.          TITLE 'KHELP routine - perform HELP command'                   05237000
  247. * Handle HELP command, rest of string given by SCANPTR.                 05238000
  248. KHELP    ENTER ,                                               @SC86355 05239000
  249.          PTEXT 'LIST *COM:SYSTEM.KERMHELP',AREG=0,LREG=6       @SC88308 05240000
  250.          NI    FL4,255-UCMD  Signal ptrs in R0,R6              @SC88308 05241000
  251.          KCALL SUPFNC,3      Execute HOST command              @SC88308 05242000
  252.          B     RTRN                                            @SC88308 05243000
  253.          LOCALS ,                                                       05244000
  254. KHELP    EXIT  ,                                               @SC87007 05245000
  255.          TITLE 'SUPFNC Routine - various supervisor functions' @SC86158 05246000
  256. SUPFNC   ENTER                                                 @SC86295 05247000
  257. *  On entry, R1 = operation code, R0 = possible ptr            @SC86158 05248000
  258. * Exit: R15 set (0 => ok, <0 => illegal cmd, >0 => depends)             05249000
  259. *       ERRNUM set appropriately (R1=1,3,4) or unchanged (2,5-11)       05250000
  260. * 1 -> Start typeout interception.  N.B.  &MAXLR >> 2048 for this       05251000
  261. * 2 -> Clean up afterwards and stop interception                        05252000
  262. * 3 -> Execute host command with or without interception                05253000
  263. *      If UCMD set, SCANPTR gives text, else R0->text,R6=len            05254000
  264. * 4 -> Execute CP command with or without interception                  05255000
  265. *      R0->text, R6=len                                                 05256000
  266. * 5 -> Stop interception if going                                       05257000
  267. * 6 -> Retrieve original cmd parm string into CBUF (R15=1 if null)      05258000
  268. * 7 -> Test for stacked lines, return number in R15                     05259000
  269. * 8 -> Log off (doesn't return!)                                        05260000
  270. * 9 -> Wait specified time                                              05261000
  271. * 10-> Return clock time in R15 (centisec)                              05262000
  272. * 11-> Setup up new prompt string at (R0)                               05263000
  273.          BCT   1,ICPFIN                                        @SC86158 05264000
  274. * Start interception, initialize ptrs                          @SC86158 05265000
  275.          MVI   ERRNUM,ERRNOE OK                                @SC86158 05266000
  276.          L     1,WBUF        Output buffer                     @SC90264 05267000
  277.          LA    0,2048(,1)    Skip over some, to be safe        @SC90264 05268000
  278.          A     1,F64KP       End of buffer                     @SC90264 05269000
  279.          LR    15,0                                            @SC86158 05270000
  280.          STM   15,0,TXTPTR   Save                              @SC86158 05271000
  281.          STM   0,1,SVCOPTR                                     @SC86158 05272000
  282.          SR    1,0           Get length                        @SC86158 05273000
  283.          L     15,=X'15000000'                                 @SC86158 05274000
  284.          MVCL  0,14          Fill with NL (X'15')              @SC86158 05275000
  285.          OI    SVCFLG,INTERCPT    Interception in Progress              05276000
  286.          B     RTRN0                                           @SC86295 05277000
  287. * Clean up after interception                                  @SC86295 05278000
  288. ICPFIN   BCT   1,ICPHST                                        @SC86158 05279000
  289.          L     5,SVCOPTR     End of text                       @SC86158 05280000
  290.          ST    5,TXTPTR+4    Save                              @SC86158 05281000
  291.          NI    SVCFLG,255-INTERCPT  Stop interception                   05282000
  292.          B     RTRN0                                                    05283000
  293. * Stop interception if going                                            05284000
  294. ICPRST   BCT   1,SFCLIN                                                 05285000
  295.          NI    SVCFLG,255-INTERCPT  Stop interception                   05286000
  296.          B     RTRN0                                                    05287000
  297. * Execute host command.  Save return code.                     @SC88308 05288000
  298. ICPHST   BCT   1,ICPCP                                         @SC86158 05289000
  299.          TM    FL4,UCMD                                        @SC88308 05290000
  300.          BO    *+12                                            @SC88308 05291000
  301.           ST   0,ADR         Ptrs are in R0,R6                 @SC88308 05292000
  302.           ST   6,LEN                                           @SC88308 05293000
  303.          NTOKN N=SFCHBAD                                       @SC88308 05294000
  304.          SCAN  HSTCMDS,RTRN0 Dispatch to handler               @SC88308 05295000
  305. SFCHBAD  MVI   ERRNUM,ERRSYS Illegal system command            @SC90223 05296000
  306.          HELP  HSTCMDS,RTRNM1                                  @SC90223 05296500
  307. *                                                                       05297000
  308. HSTCMDS  KW    'LIBRARY',SFCDIR,MIN=3                          @SC88308 05298000
  309.          KW    'COPY',SFCCOP,MIN=4                             @SC88308 05299000
  310.          KW    'PURGE',SFCDEL,MIN=3                            @SC88308 05300000
  311.          KW    'RENAME',SFCREN,MIN=3                           @SC88308 05301000
  312.          KW    'LIST',SFCTYP                                   @SC88308 05302000
  313.          KW    ,                                               @SC88308 05303000
  314. *                                                                       05304000
  315. SFCDIR   LA    3,13          DISKIO dir function code          @SC88308 05305000
  316.          B     SFCUTL                                          @SC88308 05306000
  317. SFCDEL   LA    3,14          DISKIO del function code          @SC88308 05307000
  318.          B     SFCUTL                                          @SC88308 05308000
  319. SFCREN   LA    3,15          DISKIO ren function code          @SC88308 05309000
  320.          B     SFCUTL                                          @SC88308 05310000
  321. SFCCOP   LA    3,16          DISKIO cop function code          @SC88308 05311000
  322.          B     SFCUTL                                          @SC88308 05312000
  323. SFCTYP   LA    3,17          DISKIO typ function code          @SC88308 05313000
  324. *        B     SFCUTL                                          @SC88308 05314000
  325. SFCUTL   SR    0,0                                             @SC88308 05315000
  326.          KCALL FSPEC,FILNAM,E=SUBERR                           @SC88308 05316000
  327.          CH    3,=H'14'                                        @SC88308 05317000
  328.          BNH   SFCUT1        Dir/lib or del/pur                @SC88308 05318000
  329.          CH    3,=H'17'                                        @SC88308 05319000
  330.          BE    SFCUT1        Type/list                         @SC88308 05320000
  331.          SR    0,0                                             @SC88308 05321000
  332.          KCALL FSPEC,IFILE,E=SUBERR Get 2nd file name          @SC88308 05322000
  333. SFCUT1   FTOKN N=SFCUT6      See if anything else in command   @SC88308 05323000
  334.          PTEXT '&NOOPERS'                                      @SC88308 05324000
  335.          B     SUBERR                                          @SC88308 05325000
  336. SFCUT6   LR    0,3           Get function code                 @SC88308 05326000
  337.          LA    2,IFILE       Optional 2nd name                 @SC88308 05327000
  338.          KCALL DISKIO,FILNAM Do it                             @SC88308 05328000
  339. * Issue return code msg if needed                              @SC86295 05328060
  340. SFCRC    LTR   4,15          Check RC                          @SC90264 05328120
  341.          BZ    SFCZRC        RC=0                              @SC86158 05328180
  342.          TM    FL4,UCMD      User cmd?                         @SC86316 05328240
  343.          BZ    RTRN          No. No message, just rc in R15    @SC90264 05328300
  344.          MVC   CMD(2),=C'R(' Set up message                    @SC86209 05328360
  345.          LA    15,CMD+2                                        @SC86209 05328420
  346.          BAL   2,EDDEC       Edit RC into msg                  @SC86295 05328480
  347.          MVI   0(15),C')'    Format is R(rc)                   @SC86209 05328540
  348.          LA    0,1(15)                                         @SC86268 05328600
  349.          LA    1,CMD         Start of edited string            @SC86209 05328660
  350.          SR    0,1           Length                            @SC86268 05328720
  351.          WTEXT (1),(0)                                         @SC86268 05328780
  352. SFCZRC   LR    15,6                                            @SC86295 05328840
  353.          MVI   ERRNUM,ERRNOE No errors                         @SC86295 05328900
  354.          B     RTRN                                            @SC88308 05329000
  355. * Execute CP command at (R0) with text interception            @SC86158 05330000
  356. ICPCP    BCT   1,ICPRST                                        @SC86158 05331000
  357.          WTEXT '&NOCPCMD'                                      @SC92300 05332000
  358.          B     RTRN0                                                    05333000
  359. *                                                                       05334000
  360. SFCLIN   BCT   1,SFCSTK                                        @SC86295 05335000
  361. * Retrieve original command line arguments, if any             @SC86295 05336000
  362. *   Return code =0 if yes, =1 if no                            @SC86295 05337000
  363. *   Leave string in CBUF buffer (up to 256), length in CLEN    @SC86295 05338000
  364.          L     1,ORGR1       Get original R1                            05339000
  365.          L     1,0(,1)                                                  05340000
  366.          LH    2,0(,1)       Get command line parm length               05341000
  367.          LA    3,2(,1)       Get address of parms                       05342000
  368.          LTR   5,2           Any parms?                        @SC91121 05343000
  369.          BZ    RTRN1                                                    05344000
  370.          LA    3,0(2,3)      Now, backscan the command line             05348000
  371. SFCLIN3  BCTR  3,0           buffer to check if there is really         05349000
  372.          CLI   0(3),C' '     something. MUSIC should have set the       05350000
  373.          BNE   SFCLIN4       length to 0, but under DEBUG, we           05351000
  374.          BCT   2,SFCLIN3     get a blank line of length 80 !!!          05352000
  375.          B     RTRN1                                                    05353000
  376. SFCLIN4  L     6,GTPB        Start of save buffer              @SC91121 05353200
  377.          MVC   0(128,6),2(1) Copy maximum chunk                @SC91121 05353400
  378.          STM   5,6,GTPB+4    Save new length and starting point@SC91121 05353600
  379.          B     RTRN0                                           @SC91121 05353800
  380. *                                                                       05354000
  381. * Test for stacked commands                                    @SC86295 05355000
  382. *   return code = number of stacked lines                      @SC86295 05356000
  383. SFCSTK   BCT   1,SFCKIL                                        @SC86295 05357000
  384.          ICM   15,15,GTPB+4  Anything in line buffer?                   05358000
  385.          BH    RTRN1         There's one line, at least                 05359000
  386.          B     RTRN0         Nothing stacked                            05360000
  387. *                                                                       05361000
  388. * Log out                                                      @SC86295 05362000
  389. SFCKIL   BCT   1,SFCWT                                         @SC86295 05363000
  390.          LA    1,OFFARG      Schedule a signoff to the system           05364000
  391.          SVC   237               $SETSAV                                05365000
  392.          LA    15,0          And abort the job right away.              05366000
  393.          SVC   $EOJ                                                     05367000
  394.          B     RTRN                                                     05368000
  395. *                                                                       05369000
  396. * Wait specified time in R0 (sec)                                       05370000
  397. SFCWT    BCT   1,SFCCLK      Tell MUSIC to delay for x seconds          05371000
  398.          SVC   $DLYEXC                                                  05372000
  399.          B     RTRN0                                           @SC86295 05373000
  400. *                                                                       05374000
  401. * Return time in centisec in R15                                        05375000
  402. SFCCLK   BCT   1,SFCPRP                                        @SC87351 05376000
  403.          STCK  TMPDW         Store TOD clock                   @SC86295 05377000
  404.          LM    14,15,TMPDW                                     @SC86295 05378000
  405.          SLDL  14,8          Take mod 204 days                 @SC86295 05379000
  406.          SRDL  14,20         Get in microsec                   @SC86295 05380000
  407.          D     14,=F'10000'  Get in centisec                   @SC86295 05381000
  408.          B     RTRN                                            @SC86295 05382000
  409. *                                                                       05383000
  410. SFCPRP   B     RTRN0         No action for prompting           @SC87351 05384000
  411. OFFARG   DC    CL6'/OFF**',X'A0'                                        05385000
  412.          LOCALS ,                                              @SC86295 05386000
  413. SUPFNC   EXIT                                                  @SC86158 05387000
  414.          TITLE 'Interception Code'                                      05388000
  415. *                                                                       05389000
  416. *  Entry:  R0->Length of string to write, R1->Address of string         05390000
  417. *                                                                       05391000
  418. *  Exit:   Always R15=0                                                 05392000
  419. *                                                                       05393000
  420. ICPTYP   ENTER                                                          05394000
  421.          LR    2,0                Get length in R2                      05395000
  422.          LM    3,4,SVCOPTR        Yes, then add the line just           05396000
  423.          SR    4,3                built to the interception buffer      05397000
  424.          CR    2,4                Any room left ?                       05398000
  425.          BH    RTRN0                                                    05399000
  426.          BCTR  2,0                                                      05400000
  427.          EX    2,ICPMV            Move the line to the output buffer    05401000
  428.          LA    2,1(2)                                                   05402000
  429.          LA    3,1(2,3)           Update the source pointer             05403000
  430.          ST    3,SVCOPTR          Save it                               05404000
  431.          B     RTRN0                                                    05405000
  432. ICPMV    MVC   0(0,3),0(1)                                              05406000
  433.          LOCALS ,                                                       05407000
  434. ICPTYP   EXIT   ,                                                       05408000
  435.          TITLE 'SETMSG Routine - controls CP breakin'                   05409000
  436. * Entry: R1 selects operation                                           05410000
  437. * Exit: R15=0 if ok                                                     05411000
  438. * 1-> Analyze user environment, determine if suitable.                  05412000
  439. *     Save quantities needed and condition line for entering commands.  05413000
  440. *     Perform any system-dependent initialization.                      05414000
  441. * 2-> Condition line for protocol transfers.                            05415000
  442. * 3-> Decondition line at end of transfer.                              05416000
  443. * 4-> System-dependent clean-up at exit.                                05417000
  444. * 5-> Reperform system-dependent initialization after SET LINE.         05418000
  445. SETMSG   ENTER ,                                                        05419000
  446.          BCT   1,STM2                Go if R1 not 1, so no init         05420000
  447.          MFARG 0,RLAB=ZRC,ULAB=ZLU                             @PG90057 05421000
  448.          MFARG NAME=MFNAME,INFIN=ZINFIN,INFOUT=ZINFOUT,ARG=ZARG         05422000
  449.          MFARG PHYS=ZPHYS,UCTL=ZUCTL,UINFO=ZUINFO,TAG=MFTAG             05423000
  450.          MFARG XINFO=ZXINFO                                    @SC92086 05423500
  451.          MFARG EOFPT=ZEOFPT,FSARG=ZFSARG                                05424000
  452.          MFGEN AREA=DSKST                                               05425000
  453.          MVC   UCODE(4),$USRCDE   Get the user's code                   05426000
  454.          MVI   UCODE+4,C':'  Set up 5-char prefix string                05427000
  455.          MVI   SCODE+4,C':'  Ditto                             @SC88308 05428000
  456.          LA    1,STMNOPR                                                05429000
  457.          SVC   $SETOPT            Disable prompting                     05430000
  458.          LA    1,STMTXLC                                                05431000
  459.          SVC   $SETOPT            Allow lower case input                05432000
  460. *                                                                       05432300
  461. STM5X    DS    0H            Now set up controller type        @SC90173 05432600
  462.          MVI   TRMTP,C'T'    1st assume TTY                    @SC88203 05433000
  463.          TM    $TRMTYP,X'20'      Check the terminal type               05434000
  464.          BZ    RTRN0                                                    05435000
  465.          SR    1,1           Assume Query not allowed          @SC91311 05436000
  466.          O     1,=A(&CONOPTS)                        Options   @SC91311 05437000
  467.          KCALL SETCON        Find out just what kind...        @SC91311 05438000
  468.          B     RTRN0                                                    05456000
  469. *  Condition Line for protocol transfers                                05457000
  470. STM2     BCT   1,STM3                                                   05458000
  471.          CLI   S1HND,XON          User want special one anyway ?        05461000
  472.          BNE   STM2X                                                    05462000
  473.          BAL   14,TTYCHK     TTY terminals can't change hndshk @SC92030 05463000
  474.           MVI  S1HND,0       System provides the handshake     @SC87343 05463500
  475. STM2X    B     RTRN0                                                    05464000
  476. *  Decondition line at end of transfer                                  05465000
  477. STM3     BCT   1,STM4                                          @SC86316 05466000
  478.          B     RTRN0                                                    05467000
  479. *  System cleanup at exit                                               05468000
  480. STM4     BCT   1,STM5        Special clean-up                  @SC87351 05469000
  481.          LA    1,STMPRMT     Turn on prompting                          05470000
  482.          SVC   $SETOPT                                                  05471000
  483.          LA    1,STMTXUC     Fold lower case to upper case              05472000
  484.          SVC   $SETOPT                                                  05473000
  485.          B     RTRN0         Special clean-up done                      05474000
  486. *                                                                       05475000
  487. STM5     DS    0H            Re-init after SET LINE            @SC87351 05476000
  488.          MVI   TRMTP,C'N'    Assume bad until validated        @SC90173 05476100
  489.          CLI   TRMLIN,C' '   External line?                    @SC87351 05476200
  490.          BE    STM5X         No, use terminal                  @SC90173 05476300
  491.          B     RTRN1         Other lines not allowed           @SC90173 05476400
  492. *                                                                       05477000
  493. STMNOPR  DC    X'A0',AL1(1,3,6) Turn off Prompting                      05478000
  494. STMPRMT  DC    X'A0',AL1(0,3,6) Turn on Prompting                       05479000
  495. STMTXLC  DC    X'A0',AL1(1,1,6) Text Lower Case Input                   05480000
  496. STMTXUC  DC    X'A0',AL1(0,1,6) Text Upper Case Input                   05481000
  497. *                                                                       05482000
  498.          LOCALS ,                                                       05485000
  499. SETMSG   EXIT                                                           05486000
  500.          TITLE 'GETLIN Routine - Get a line from terminal'     @SC87015 05487000
  501. * Entry: R1->buffer of length 256                              @SC87015 05488000
  502. * Exit: Buffer filled, R0=length, R15=0 if ok. Else R15=1.     @SC87015 05489000
  503. GETLIN   ENTER                                                 @SC87015 05490000
  504.          LR    8,1           Save buffer ptr                   @SC88095 05491000
  505.          LA    9,256         For copying                       @SC88095 05492000
  506.          LM    4,6,GTPB      Saved ptrs: start, length, current         05493000
  507.          LTR   5,5           Already got something?            @SC88095 05494000
  508.          BNZ   GTL1          Yes, return it                    @SC87015 05495000
  509.          TGET  (4),130       Read a line from the terminal              05496000
  510.          SLR   2,2           Clear length for return                    05497000
  511.          LA    5,0(1,4)      Point past the end                         05498000
  512.          BCTR  5,0           Scan back for a non-blank                  05499000
  513.          CLI   0(5),C' '                                                05500000
  514.          BE    *-6                                                      05501000
  515.          LA    5,1(,5)                                                  05502000
  516.          SR    5,4           Stripped length                            05503000
  517.          BNH   GTLA          Null input                                 05504000
  518.          LR    6,4           Set current read ptr                       05505000
  519.          ST    5,GTPB+4      Save new length                            05506000
  520. GTL1     LR    1,5           Length of stuff                   @SC88095 05507000
  521.          AR    1,4           End of buffer                     @SC88095 05508000
  522.          LR    0,1           Save end                          @SC88095 05509000
  523.          LR    2,1                                             @SC88095 05510000
  524.          SR    2,6           Length of text remaining          @SC88095 05511000
  525.          BNP   GTLA          None, return length 0             @SC88095 05512000
  526.          SLR   4,4                                             @SC88095 05513000
  527.          IC    4,LNDLM       Get delimiter                     @SC88095 05514000
  528.          LA    4,TRTBL(4)    Ptr to delimiter char             @SC88095 05515000
  529.          MVI   0(4),1        Set up to snag delims             @SC88095 05516000
  530.          MVI   TRTBL+C' ',0  And ignore blanks                 @SC88095 05517000
  531.          CR    2,9           Get shorter of 256 and string     @SC88095 05518000
  532.          BNH   *+6                                             @SC88095 05519000
  533.           LR   2,9                                             @SC88095 05520000
  534.          BCTR  2,0           Set up for EX                     @SC88095 05521000
  535.          EX    2,GTLTRT                                        @SC88095 05522000
  536.          MVI   0(4),0        Now clear out table               @SC88095 05523000
  537.          MVI   TRTBL+C' ',1  And restore                       @SC88095 05524000
  538.          SR    1,6           Length of line                    @SC88095 05525000
  539.          LR    7,1           Set up MVCL                       @SC88095 05526000
  540.          CR    9,7           Get shorter of 256 and string     @SC88095 05527000
  541.          BNH   *+6                                             @SC88095 05528000
  542.           LR   9,7                                             @SC88095 05529000
  543.          LR    2,9           Length actually copied            @SC88095 05530000
  544.          MVCL  8,6                                             @SC88095 05531000
  545.          AR    6,7           In case we couldn't use it all    @SC88095 05532000
  546.          CR    6,0           Finished input?                   @SC88095 05533000
  547.          BNL   GTLA          Yes, release it                   @SC88095 05534000
  548.          LA    6,1(,6)       Skip over linend char             @SC88095 05535000
  549.          ST    6,GTPB+8      Next read ptr                     @SC88095 05536000
  550.          B     GTLZ          Return                            @SC88095 05537000
  551. GTLA     MVC   GTPB+4,F0     Clear input indicator             @SC87015 05538000
  552. GTLZ     RETREG (0,2)        Return (2) as R0                  @SC89218 05539000
  553.          B     RTRN0                                           @SC87015 05541000
  554. GTLTRT   TRT   0(,6),TRTBL   Find a delimiter                  @SC88095 05542000
  555.          LOCALS ,                                              @SC87015 05543000
  556. GETLIN   EXIT  ,                                               @SC87015 05544000
  557.          TITLE 'TERMIO Routine - Handle terminal I/O'                   05545000
  558. * R1 points to a pair of (adr,len) for read or write.  If I/O is        05546000
  559. * successfull, R15 returns transferred byte count (else returns -1).    05547000
  560. *               Command code is in R0:                                  05548000
  561. * 1 => Open line for I/O            4 => Write packet                   05549000
  562. * 2 => Close line                   5 => Read packet                    05550000
  563. * 3 => Reset line status after    ( 6 => Write message ) not used       05551000
  564. *      environment changes                                              05552000
  565. *                                                                       05553000
  566. TERMIO   ENTER                                                          05554000
  567.          STC   0,CONSOPR     Save command code                 @SC92180 05554500
  568.          SR    15,15         OK                                @SC86295 05555000
  569.          BCT   0,TRMCLS                                        @SC86295 05556000
  570. * Open terminal line for protocol                                       05557000
  571.          MVI   RIOC,X'80'    Nothing saved                     @SC86295 05558000
  572.          MVI   TRMFLG,X'FF'  Initialize w/r flag               @SC87275 05559000
  573.          CLI   TRMTP,C'F'                                      @SC92030 05559300
  574.          BE    TRMSETF       Full-screen stuff only            @SC92030 05559600
  575.          LA    1,STMNOCR                                                05560000
  576.          SVC   $SETOPT       No CRLF added                              05561000
  577.          LA    1,STMNOTR                                                05562000
  578.          SVC   $SETOPT       No translate Input                         05563000
  579.          LA    1,STMNOER                                                05564000
  580.          SVC   $SETOPT       No *TRANSMISSION ERROR messages            05565000
  581.          CLI   TIMOUT,0      Timeout wanted ???                         05566000
  582.          BE    RTRN0                                                    05567000
  583.          LA    1,STMTMOU                                                05568000
  584.          SVC   $SETOPT       Timeout on reads                           05569000
  585.          B     RTRN0                                                    05570000
  586. TRMSETF  LA    1,STMNOEC                                       @SC92030 05570200
  587.          SVC   $SETOPT       No echo of input                  @SC92030 05570400
  588.          B     RTRN0                                           @SC92030 05570600
  589. * Close terminal line after protocol transfer                           05571000
  590. TRMCLS   BCT   0,TRMRSET                                       @SC86295 05572000
  591.          LA    1,STMCRLF     Reenable CRLF                              05573000
  592.          SVC   $SETOPT                                                  05574000
  593.          LA    1,STMTRIN     Reenable translation                       05575000
  594.          SVC   $SETOPT                                                  05576000
  595.          LA    1,STMNOTM     No timeouts                                05577000
  596.          SVC   $SETOPT                                                  05578000
  597.          LA    1,STMTRER                                                05579000
  598.          SVC   $SETOPT       *TRANSMISSION ERROR messages allowed       05580000
  599.          LA    1,STMECHO                                       @SC92030 05580300
  600.          SVC   $SETOPT       Allow echo of input               @SC92030 05580600
  601.          B     RTRN0                                           @SC86295 05581000
  602. * (Re)set terminal characteristics to suit environment                  05582000
  603. TRMRSET  BCT   0,TRMRW                                         @SC86295 05583000
  604.          B     RTRN0                                           @SC86295 05584000
  605. *                                                                       05585000
  606. *  Perform I/O request                                                  05586000
  607. TRMRW    BCT   0,TRMRD                                         @SC87275 05587000
  608.          CLI   WRRD,0        Write/read?                       @SC87275 05588000
  609.          BNE   *+8           No, do it immediately                      05589000
  610.          MVI   TRMFLG,0      Indicate no action on follow-up            05590000
  611.          LM    2,3,0(1)      Get buffer address + length                05591000
  612.          CLI   TRMTP,C'F'    Full-screen non-transparent?      @SC92030 05591070
  613.          BNE   TRMRWW        No                                @SC92030 05591140
  614.          SR    0,0           Clear before every packet         @SC92030 05591210
  615.          KCALL SCRNIO                                          @SC92030 05591280
  616.          XI    FL3,FCLRF     Flip switch for skipping          @SC92030 05591350
  617.          TM    FL3,FCLRF     Skipping now?                     @SC92030 05591420
  618.          BZ    TRMRWX        Not this time                     @SC92030 05591490
  619.          PTEXT ' ',LREG=4,AREG=5 Yes                           @SC92030 05591560
  620.          TPUT  (5),(4)       Skip two lines                    @SC92030 05591630
  621.          TPUT  (5),(4)                                         @SC92030 05591700
  622.          B     TRMRWX        Omit the special translation      @SC92030 05591770
  623. TRMRWW   DS    0H                                              @SC92030 05591840
  624.          BCTR  2,0           Backup to insert carriage control          05592000
  625.          MVI   0(2),X'41'    No output translate PLEASE !               05593000
  626.          LA    3,1(3)        Fixup length for CC added                  05595000
  627. TRMRWX   ST    2,TRMRBUF     Set up I/O buffer for MFIO        @SC92030 05595500
  628.          ST    3,TRMRLEN     Set I/O length                             05596000
  629.          MFREQ PRT                                                      05597000
  630.          B     TRMRWLG                                         @SC92180 05598000
  631. *                                                                       05599000
  632. TRMRD    TS    TRMFLG                                          @SC87275 05600000
  633.          BZ    RTRN0         Just a follow-up. 0-length read   @SC87275 05601000
  634.          LM    2,3,0(1)                                                 05602000
  635.          C     3,AMAXRT      Check for maximum length                   05603000
  636.          BL    TRMRD3                                                   05604000
  637.          L     3,AMAXRT      Not too long please...                     05605000
  638. TRMRD3   ST    2,TRMRBUF     Setup I/O buffer for MFIO                  05606000
  639.          ST    3,TRMRLEN     Set I/O length                             05607000
  640.          SLR   4,4                                                      05608000
  641.          SLR   5,5                                                      05609000
  642.          MVCL  2,4           Clear the input buffer                     05610000
  643.          MFREQ TRM                                                      05611000
  644. TRMRWLG  LA    1,TRMARG      I/O block                         @SC92180 05612000
  645.          BAL   7,SCRLOGCM    Log it                            @SC92180 05612100
  646.          L     5,TRMARSZ     Get number of bytes read          @SC92180 05612200
  647.          L     1,TRMRBUF     Ptr to I/O buffer                 @SC92180 05612300
  648.          LR    2,5           I/O length                        @SC92180 05612400
  649.          BAL   7,SCRLOGD     Log it                            @SC92180 05612500
  650.          TM    CONSOPR,1                                       @SC92180 05612600
  651.          BZ    RTRN0         Not a read, just say OK           @SC92180 05612700
  652.          LTR   15,5          Get number of bytes read          @SC92180 05612800
  653.          BNZ   RTRN          Ok, got a buffer                           05613000
  654.          L     2,TRMRBUF                                                05614000
  655.          MVI   0(2),X'2B'    Timeout !!!                                05615000
  656.          B     RTRN1         Return Length 1                            05616000
  657. *                                                                       05617000
  658. STMNOCR  DC    X'A0',AL1(1,1,5) Turn off CRLF                           05618000
  659. STMCRLF  DC    X'A0',AL1(0,1,5) Turn on CRLF                            05619000
  660. STMNOTR  DC    X'A0',AL1(1,1,4) Turn off input translation              05620000
  661. STMTRIN  DC    X'A0',AL1(0,1,4) Turn on input translation               05621000
  662. STMTMOU  DC    X'A0',AL1(1,1,0) Turn on Timeout                         05622000
  663. STMNOTM  DC    X'A0',AL1(0,1,0) Turn off Timeout                        05623000
  664. STMNOER  DC    X'A0',AL1(0,1,7) Don't allow *TRANSMISSION ERROR msg     05624000
  665. STMTRER  DC    X'A0',AL1(1,1,7) Allow *TRANSMISSION ERROR msg           05625000
  666. STMNOEC  DC    X'A0',AL1(1,1,2) Don't echo input               @SC92030 05625300
  667. STMECHO  DC    X'A0',AL1(0,1,2) Echo input                     @SC92030 05625600
  668.          SPACE                                                          05626000
  669. *********************************************************************** 05627000
  670. *                                                                     * 05628000
  671. *    Reversing Table. Translate ASCII to reverse ASCII                * 05629000
  672. *                                                                     * 05630000
  673. *********************************************************************** 05631000
  674.          SPACE 1                                                        05632000
  675. *                0 1 2 3 4 5 6 7 8 9 A B C D E F                        05633000
  676. ATORA    DC    X'008040C020A060E0109050D030B070F0' 0                    05634000
  677.          DC    X'088848C828A868E8189858D838B878F8' 1                    05635000
  678.          DC    X'048444C424A464E4149454D434B474F4' 2                    05636000
  679.          DC    X'0C8C4CCC2CAC6CEC1C9C5CDC3CBC7CFC' 3                    05637000
  680.          DC    X'028242C222A262E2129252D232B272F2' 4                    05638000
  681.          DC    X'0A8A4ACA2AAA6AEA1A9A5ADA3ABA7AFA' 5                    05639000
  682.          DC    X'068646C626A666E6169656D636B676F6' 6                    05640000
  683.          DC    X'0E8E4ECE2EAE6EEE1E9E5EDE3EBE7EFE' 7                    05641000
  684.          DC    X'018141C121A161E1119151D131B171F1' 8                    05642000
  685.          DC    X'098949C929A969E9199959D939B979F9' 9                    05643000
  686.          DC    X'058545C525A565E5159555D535B575F5' A                    05644000
  687.          DC    X'0D8D4DCD2DAD6DED1D9D5DDD3DBD7DFD' B                    05645000
  688.          DC    X'038343C323A363E3139353D333B373F3' C                    05646000
  689.          DC    X'0B8B4BCB2BAB6BEB1B9B5BDB3BBB7BFB' D                    05647000
  690.          DC    X'078747C727A767E7179757D737B777F7' E                    05648000
  691.          DC    X'0F8F4FCF2FAF6FEF1F9F5FDF3FBF7FFF' F                    05649000
  692. *********************************************************************** 05650000
  693. *                                                                     * 05651000
  694. *    Reversing Table. Reverse ASCII to ASCII. Lose high order bit.    * 05652000
  695. *                                                                     * 05653000
  696. *********************************************************************** 05654000
  697.          SPACE 1                                                        05655000
  698. *                0 1 2 3 4 5 6 7 8 9 A B C D E F                        05656000
  699. RATOA    DC    X'00004040202060601010505030307070' 0                    05657000
  700.          DC    X'08084848282868681818585838387878' 1                    05658000
  701.          DC    X'04044444242464641414545434347474' 2                    05659000
  702.          DC    X'0C0C4C4C2C2C6C6C1C1C5C5C3C3C7C7C' 3                    05660000
  703.          DC    X'02024242222262621212525232327272' 4                    05661000
  704.          DC    X'0A0A4A4A2A2A6A6A1A1A5A5A3A3A7A7A' 5                    05662000
  705.          DC    X'06064646262666661616565636367676' 6                    05663000
  706.          DC    X'0E0E4E4E2E2E6E6E1E1E5E5E3E3E7E7E' 7                    05664000
  707.          DC    X'01014141212161611111515131317171' 8                    05665000
  708.          DC    X'09094949292969691919595939397979' 9                    05666000
  709.          DC    X'05054545252565651515555535357575' A                    05667000
  710.          DC    X'0D0D4D4D2D2D6D6D1D1D5D5D3D3D7D7D' B                    05668000
  711.          DC    X'03034343232363631313535333337373' C                    05669000
  712.          DC    X'0B0B4B4B2B2B6B6B1B1B5B5B3B3B7B7B' D                    05670000
  713.          DC    X'07074747272767671717575737377777' E                    05671000
  714.          DC    X'0F0F4F4F2F2F6F6F1F1F5F5F3F3F7F7F' F                    05672000
  715.          TITLE 'SCRNIO Routine - Handle screen I/O via Series/1'        05675000
  716. * R1 points to a pair of (adr,len) for read or write.  If I/O is        05676000
  717. * successfull, R15 returns transferred byte count (else returns -1).    05677000
  718. *               Command code is in R0:                                  05678000
  719. * 0 => Clear screen on console (not comm line)                 @SC90045 05678500
  720. * 1 => Open screen for I/O            4 => Write packet (gets ATTN)     05679000
  721. * 2 => Close screen                   5 => Read packet                  05680000
  722. * 3 => Reset screen status after      6 => Write message (no ATTN)      05681000
  723. *      environment changes                                              05682000
  724. *                                                                       05683000
  725. SCRNIO   ENTER ALT                                             @SC92180 05684000
  726.          XC    ZFSARG(20),ZFSARG  Clear FSIO Control Block              05685000
  727.          LR    6,1           Save ptr to plist                 @SC90222 05685100
  728.          LTR   0,0                                             @SC90045 05685300
  729.          BZ    SCRCLR                                          @SC90045 05685600
  730.          STC   0,CONSOPR     Save command code                 @LP88158 05685700
  731.          BCT   0,SCRCLS                                        @SC86295 05686000
  732. * Set up for transparent I/O                                            05686020
  733.          L     1,=A(IDEFS)   CSECT of initializations          @SC90173 05686040
  734.          USING DEFS,1        Mapped via DSECT                  @SC90173 05686060
  735.          LA    2,S1DATA      Series/1 introducer               @SC90173 05686080
  736.          LA    3,S1ORDL+2    Length + 2                        @SC90173 05686100
  737.          CLI   TRMTP,C'S'                                      @SC90173 05686120
  738.          BE    SCRPRSET      Do it                             @SC90173 05686140
  739.          LA    2,GRDATA      Graphics introducer               @SC90173 05686160
  740.          LA    3,GRDL+2      Length + 2                        @SC90173 05686180
  741.          CLI   TRMTP,C'G'                                      @SC90173 05686200
  742.          BE    SCRPRSET      Do it                             @SC90173 05686220
  743.          LA    2,AEADAT      AEA introducer                    @SC90173 05686240
  744.          LA    3,AEAL+2                                        @SC90173 05686260
  745.          DROP  1                                               @SC90173 05686280
  746. SCRPRSET LR    5,3                                             @SC90173 05686300
  747.          LA    4,S1EOL+2     Get start of command buffer       @SC90173 05686320
  748.          SR    4,5                                             @SC90173 05686340
  749.          STM   4,5,S1XOPL    Set up prompt plist               @SC90173 05686360
  750.          S     5,F2          Deduct stuff already there        @SC90173 05686380
  751.          MVCL  4,2                                             @SC90173 05686400
  752.          MVI   TRMFLG,X'FF'       Initialize W/R flag          @PG90058 05686500
  753.          MVI   RIOPRP+4,255  Flag no interrupt pending         @SC90222 05686700
  754. SCRCLRA  MVI   FSFSFG,X'84'  Write erase needed to setup FSIO  @SC90045 05687000
  755.          MVI   FSFSFG+1,X'60'     No data Compression                   05688000
  756.          BAL   9,SCRNEX      Clear screan                      @SC90222 05689000
  757.          B     RTRN0                                           @SC86295 05692000
  758. *                                                                       05692100
  759. SCRCLR   CLI   TRMTP,C'T'    Is it a TTY terminal?             @SC90045 05692200
  760.          BE    RTRN0         Yes, can't clear screen           @SC90045 05692300
  761.          CLI   TRMTP,C'V'    Is it a TTY terminal?             @SC90045 05692400
  762.          BE    RTRN0         Yes, can't clear screen           @SC90045 05692500
  763.          CLI   TRMTP,C'F'    Is it some full-screen?           @SC92030 05692530
  764.          BE    *+12          Yes, must clear frequently        @SC92030 05692560
  765.          TM    FL2,PROTO     In protocol mode?                 @SC90045 05692600
  766.          BO    RTRN0         Yes, skip clearing screen         @SC90045 05692700
  767.          B     SCRCLRA       Do it                             @SC90045 05692800
  768. *                                                                       05693000
  769. SCRCLS   BCT   0,SCRRSET                                       @SC86295 05694000
  770.          B     RTRN0                                           @SC86295 05695000
  771. * (Re)set device characteristics to suit environment                    05696000
  772. SCRRSET  BCT   0,SCRRW                                         @SC86295 05697000
  773.          B     RTRN0                                                    05698000
  774. *                                                                       05699000
  775. *  Perform I/O request                                                  05700000
  776. SCRRW    LR    5,0                                             @SC90173 05701000
  777.          AR    5,0                                             @SC90173 05701100
  778.          CLI   TRMTP,C'A'    AEA?                              @SC90173 05701200
  779.          BNE   *+8                                             @SC90173 05701300
  780.           LA   5,6(,5)       Yes, use 2nd table                @SC90173 05701400
  781.          LH    5,SCRFGS-2(5) Get proper screen I/O flags       @SC90173 05701500
  782.          STCM  5,3,FSFSFG                                      @SC90173 05701600
  783.          BCT   0,SCRRD                                         @SC90173 05701700
  784. *  Write                                                       @SC90173 05701800
  785.          CLI   WRRD,0             Write/Read ?                 @PG90058 05702000
  786.          BE    SCRWO                                           @PG90058 05702200
  787.          MVC   RIOPRP(8),0(1)     Save Write data as Read Prmp @PG90058 05702400
  788.          B     RTRN0                                           @PG90058 05702600
  789. SCRWO    DS    0H            Write without expecting response  @SC90173 05703000
  790.          MVC   FSFSWL,4(1)   Copy buffer length (assume Write) @SC90173 05704000
  791.          MVC   FSFSWB,0(1)   Copy buffer address               @SC90173 05705000
  792.          MVI   TRMFLG,0           Indicate no actn on followup @PG90058 05706500
  793.          BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05707000
  794.          LM    1,2,0(6)      Get buffer,len                    @SC90222 05707500
  795.          BAL   7,SCRLOGD     Log the data                      @SC90222 05708000
  796.          B     RTRN0                                                    05709000
  797. *                                                                       05709500
  798. SCRRD    BCT   0,SCRWM                                                  05710000
  799.          TS    TRMFLG             Do we have to really read?   @PG90058 05711000
  800.          BZ    RTRN0              Just a follow up. 0-len read @PG90058 05711300
  801.          MVC   FSFSRL(4),4(1)     Get buffer length Read       @PG90058 05713000
  802.          MVC   FSFSRB(4),0(1)     Get buffer address Read      @PG90058 05713500
  803.          CLI   RIOPRP+4,255  Interrupt pending?                @SC90222 05713600
  804.          BE    SCRRDM        No, just issue READ MOD           @SC90222 05713700
  805.          MVC   FSFSWL(4),RIOPRP+4 Get buffer length Write      @PG90058 05714000
  806.          MVC   FSFSWB(4),RIOPRP   Get buffer address Write     @PG90058 05714500
  807.          BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05715000
  808.          LM    1,2,RIOPRP    Get buffer,len written            @SC90222 05715300
  809.          BAL   7,SCRLOGD     Log the data                      @SC90222 05715600
  810.          MVI   RIOPRP+4,255  Flag no interrupt pending         @SC90222 05715900
  811.          B     SCRRD2        Now rejoin                        @SC90222 05716200
  812. SCRRDM   MVI   FSFSFG,X'0C'  Do immediate READ MOD             @SC90222 05716500
  813.          BAL   9,SCRNEX      Do the I/O (and log)              @SC90222 05716800
  814. SCRRD2   L     1,0(,6)       Get input buffer                  @SC90222 05717100
  815.          LR    2,5           Get length read                   @SC90222 05717400
  816.          BAL   7,SCRLOGD     Log the data                      @SC90222 05717700
  817.          LR    15,5          Get length of data read           @SC90222 05718000
  818.          S     15,WRCMDL+4   Deduct 3 for buffer adr           @SC90173 05718100
  819.          B     RTRN          Return                            @SC86299 05719000
  820. *                                                                       05719200
  821. * SCRLOG: Hexadecimal log of (R2) bytes at address (R1)        @LP88158 05719400
  822. * Log label is taken from R0 low order byte.                   @SC89166 05719600
  823. * Return via R7.  R0-R3 and R15 destroyed.                     @SC89166 05719800
  824. SCRLOGD  LA    0,C'd'        "Data" label                      @SC89166 05720000
  825.          B     SCRLOG                                          @SC92180 05720020
  826. * Enter here with (1)->control block of length 20              @SC92180 05720040
  827. SCRLOGCM SLR   2,2           Convert op. code to log label     @SC92180 05720060
  828.          IC    2,CONSOPR                                       @SC92180 05720080
  829.          LA    2,CONSOPRS(2)                                   @SC92180 05720100
  830.          IC    0,0(,2)                                         @SC92180 05720120
  831.          LA    2,20          Size of plist                     @SC92180 05720140
  832. SCRLOG   TM    FL1,DEBUG     Logging in effect?                @SC87286 05720200
  833.          BZR   7             No, that's all                    @SC89166 05720400
  834.          TM    DBGFLG,DBGIO  I/O stuff requested?              @SC88168 05720600
  835.          BZR   7             No, skip it                       @SC89166 05720800
  836.          L     3,LOGBUF      Ptr to buffer                     @LP88158 05721000
  837.          STC   0,0(,3)       Set log label                     @SC89166 05721200
  838.          LA    3,2(,3)       Start of data area                @SC91172 05721400
  839.          TM    DBGFLG,DBGTI  Times requested?                  @SC91172 05721410
  840.          BZ    SCRLOGA       No, just do hex dump              @SC91172 05721420
  841.          ST    1,SCRLR1      Save ptr to block                 @SC91172 05721430
  842.          BAL   14,ACCTTOD    Get time of day in seconds        @SC91172 05721440
  843.          MVI   0(3),C' '     Leave a space                     @SC91172 05721450
  844.          KCALL DUMPTOD,1(3)  Format time into buffer           @SC91172 05721460
  845.          LR    3,15          Get ptr to end of string          @SC91172 05721470
  846.          L     1,SCRLR1      Restore R1                        @SC91172 05721480
  847. SCRLOGA  LA    0,6*9(,3)     End of line buffer                @SC91172 05721490
  848.          TM    DBGFLG,DBGLO  Long buffer requested?            @SC90222 05721600
  849.          BZ    *+8                                             @SC90222 05721800
  850.           LA   0,50*9(,3)    Yes, long buffer                  @SC91172 05722000
  851. SCRLOGLP MVI   0(3),C' '     Add for readability               @LP88158 05722400
  852.          UNPK  1(9,3),0(5,1) Unpack into buffer                @SC88168 05722600
  853.          TR    1(8,3),TRHEX  Convert to printable hex          @SC88168 05722800
  854.          LA    3,9(3)        Advance text ptr                  @SC88168 05723000
  855.          LA    1,4(1)        and data source                   @LP88158 05723200
  856.          S     2,F4          Finished data?                    @SC88168 05723400
  857.          BNP   SCRLGEND      Yes, go write                     @LP88158 05723600
  858.          CR    3,0           Reached text limit?               @LP88158 05723800
  859.          BL    SCRLOGLP      no, loop for more slices          @LP88158 05724000
  860.          MVC   0(3,3),=C'...' Show incomplete                  @LP88158 05724200
  861.          LA    3,3(3)                                          @SC88168 05724400
  862. SCRLGEND DS    0H                                              @LP88158 05724600
  863.          AR    2,2           Check for incomplete slice        @SC88168 05724800
  864.          BNM   *+6           No, ok                            @SC88168 05725000
  865.          AR    3,2           Yes, adjust end of text           @SC88168 05725200
  866.          S     3,LOGBUF      Get length of text                @SC88168 05725400
  867.          WRITF LOGPTR,BSIZE=(3) Log it                         @LP88158 05725600
  868.          TM    DBGFLG,DBGSV  SAVE requested?                   @SC88168 05725800
  869.          BZR   7             No, skip closing log file         @SC89166 05726000
  870.          SAVEF LOGPTR        Update disk directory             @SC88168 05726200
  871.          BR    7                                               @SC89166 05726400
  872. *                                                                       05726600
  873. * Execute (and log) screen I/O already set up                  @SC90222 05726800
  874. * Return via R9 with length read in R5.                        @SC90222 05727000
  875. SCRNEX   MVI   ZLU,9         Specify unit 9                    @SC90222 05727200
  876.          MFSET DSKST,FSIO                                      @SC90222 05727400
  877.          MFREQ DSKST         Do it                             @SC90222 05727600
  878.          L     5,MFARSZ      Fetch length of read              @SC90222 05727800
  879.          MVC   SCRRC,ZRC     Save return code                  @SC90222 05728000
  880.          LA    1,ZFSARG      I/O block                         @SC90222 05729000
  881.          BAL   7,SCRLOGCM    Log it                            @SC92180 05729200
  882.          CLI   SCRRC,0                                         @SC90222 05729600
  883.          BER   9             Ok, just return                   @SC90222 05729800
  884.          LA    1,SCRRC                                         @SC90222 05730000
  885.          LA    2,1                                             @SC90222 05730200
  886.          LA    0,C'e'        "Error" label                     @SC90222 05730400
  887.          BAL   7,SCRLOG      Log the return code               @SC90222 05730600
  888.          BR    9             Return                            @SC90222 05730800
  889. *                                                                       05735000
  890. SCRWM    DS    0H                                              @SC90173 05737000
  891.          MVC   FSFSWL,4(1)   Copy buffer length                @SC90173 05738000
  892.          MVC   FSFSWB,0(1)   Copy buffer address               @SC90173 05739000
  893.          BAL   9,SCRNEX      Write it                          @SC90222 05740000
  894.          LM    1,2,0(6)      Get buffer,len                    @SC90222 05740500
  895.          BAL   7,SCRLOGD     Log the data                      @SC90222 05741000
  896.          B     RTRN0                                                    05743000
  897. *          Halfword-aligned table of I/O flags           code  @SC90173 05743050
  898. SCRFGS   DC    X'06',X'A0'   WCC, Skip read / No comp      4   @SC90173 05743100
  899.          DC    X'02',X'80'   WCC, Write/Read / No comp     5   @SC90173 05743150
  900.          DC    X'86',X'A0'   EW, WCC, Skip Read / No comp  6   @SC90173 05743200
  901. *          2nd table for WSF I/O                               @SC90173 05743250
  902.          DC    X'24',X'A0'   Skip read / No comp           4   @SC90173 05743300
  903.          DC    X'20',X'80'   Write/Read / No comp          5   @SC90173 05743350
  904.          DC    X'86',X'A0'   EW, WCC, Skip Read / No comp  6   @SC90173 05743400
  905. RIOPRP   DC    A(0,1)                                          @PG90058 05743500
  906. CONSOPRS DC    C'?ocswrmg'   Console commands labels for log   @SC91150 05743600
  907.          LOCALS ,                                                       05744000
  908. SCRRC    DS    F             Return code from I/O              @SC90222 05744300
  909. SCRLR1   DS    F             Saved R1 in SCRLOG                @SC91172 05744400
  910. CONSOPR  DS    XL1           Current I/O operation             @SC89180 05744600
  911. SCRNIO   EXIT  ,                                                        05745000
  912.          TITLE 'DISKIO Routine - performs disk I/O functions'           05746000
  913. * Function selected on entry by R0:                                     05747000
  914. * 0=> unnum: R1->FAB.  Return R1->buffer,R0=# and remove the sequence   05748000
  915. *   number (if any) from the buffer (used for TAKE files)               05749000
  916. * 1=> open (in): R1->pattern FDB, R2->name.  Returns R0->FAB, R1->FDB   05750000
  917. * 2=> open (out): (same)                                                05751000
  918. * 3=> test name: R2->name.  Returns R1->FDB if file found and  @SC91269 05752000
  919. *     writable (else R15=1)                                    @SC91269 05752100
  920. * 4=> close file: R1->adr(FAB).                                         05753000
  921. * 5=> set up search: R1->pattern name.                                  05754000
  922. * 6=> return next file in list:  Returns R1->FDB + sets up FILNAM       05755000
  923. * 7=> close search (if any).                                            05756000
  924. * 8=> test CWD string: R1->string.  Returns R15=0 if ok, else =1.       05757000
  925. * 9=> read: R1->FAB.  Returns R15=12 if EOF, 0 if ok; R0=# data         05758000
  926. * 10=> write: R1->FAB.  Returns R15=13 if disk full, 0 if ok.           05759000
  927. * 11=> test space: R1->pattern FDB (has size in Kbytes),                05760000
  928. *  R2->name (used if FAB not found), R6->adr(FAB). Return R15=0 if ok.  05760500
  929. * 12=> analyze R/W error, set ERRNUM, make EMSG: R1->FAB, TMPDW=code    05761000
  930. *      always returns R15=1                                             05762000
  931. * 13=> directory info on file: R1->name.  Returns R15=0 if ok.          05763000
  932. * 14=> delete file: R1->name.  Returns R15=0 if ok.                     05764000
  933. * 15=> rename file: R1->name, R2->new name.  Returns R15=0 if ok.       05765000
  934. * 16=> copy file: R1->name, R2->new name.  Returns R15=0 if ok.         05766000
  935. * 17-> type file: R1-> name. Returns R15=0 if ok.                       05767000
  936. * 21=> save file status in directory: R1->FAB.                 @SC88168 05768000
  937. * 22=> open library (in): R2->DDNAME.  Return R15=0 if ok.     @SC89073 05768200
  938. * 23=> point for next read, R1->adr(FDB), R2=records to skip.  @SC89218 05768300
  939. *      Return R15=0 if ok.                                     @SC89218 05768400
  940. * 24=> test name: R2->name.  Returns R1->FDB if file found and @SC91269 05768450
  941. *      readable (else R15=1)                                   @SC91269 05768500
  942. DISKIO   ENTER                                                          05769000
  943.          USING FABD,3                                          @SC86295 05770000
  944.          SR    4,4           Signal no block assigned          @SC86295 05771000
  945.          STC   0,DSKCOD      Save function code (for now)      @SC88101 05772000
  946.          LR    5,0                                             @SC89073 05773000
  947.          AR    5,5                                             @SC89073 05773200
  948.          LH    5,DSK0(5)     Get handler address               @SC89073 05773400
  949.          B     DSK0(5)       Do the function                   @SC89073 05773600
  950. DSK0     DC    Y(DSKRED-DSK0,DSKOPNI-DSK0,DSKOPNO-DSK0)   0-2  @SC89073 05773800
  951.          DC    Y(DSKTEST-DSK0,DSKCLOS-DSK0,DSKNSET-DSK0)  3-5  @SC89073 05774000
  952.          DC    Y(DSKNXT-DSK0,DSKXSET-DSK0,DSKCWDF-DSK0)   6-8  @SC89073 05774200
  953.          DC    Y(DSKRED-DSK0,DSKWRT-DSK0,DSKTSP-DSK0)     9-11 @SC89073 05774400
  954.          DC    Y(DSKXXX-DSK0,DSKDIR-DSK0,DSKDEL-DSK0)    12-14 @SC89073 05774600
  955.          DC    Y(DSKRNM-DSK0,DSKCPY-DSK0,DSKTYP-DSK0)    15-17 @SC89073 05774800
  956.          DC    3Y(DSKER1-DSK0)   Spare utilities         18-20 @SC89073 05775000
  957.          DC    2Y(DSKER1-DSK0),Y(DSKPNT-DSK0)            21-23 @SC89218 05775200
  958.          DC    Y(DSKTEST-DSK0)                           24-   @SC91269 05775250
  959.          DC    8Y(DSKER1-DSK0)   Spares                        @SC89073 05775400
  960. *                                                                       05776000
  961. * Open for input file whose name is at (R2), FDB at (R1)                05777000
  962. DSKOPNI  DS    0H                                              @SC89073 05777500
  963.          BAL   9,DSKALC      Get FAB                           @SC86295 05778000
  964.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05779000
  965.          MFREQ DSKST                        Try to open file            05780000
  966.          CLI   ZRC,0                        Errors ???                  05781000
  967.          BNZ   DSKER1        Not found                         @SC86295 05782000
  968.          MVC   FABRC,ZRC                                                05783000
  969.          BAL   9,DSKCHKNM          Check if allowed to do I/O           05784000
  970.           B     DSKER1                                                  05785000
  971.          BAL   14,DSKVALS          Go copy info to FDBD                 05786000
  972.          MVC   FABUNIT(1),ZLU      Save file unit number                05787000
  973.          B     RTRN0                                           @SC86295 05788000
  974. *                                                                       05789000
  975. * Open for output file whose name is at (R2), FDB at (R1)               05790000
  976. DSKOPNO  DS    0H                                              @SC89073 05791000
  977.          BAL   9,DSKALC      Get FAB                           @SC86295 05792000
  978.          MVC   FABCOMM,=CL8'Open'  In case of error            @SC88308 05793000
  979.          MFSET DSKST,EXTRACT                                   @SC88308 05796000
  980.          MFREQ DSKST         Get file attributes               @SC88308 05797000
  981.          CLI   ZRC,0         Did it work?                      @SC88308 05798000
  982.          BNE   DSKOP2        Not found, just writing new       @SC87012 05799000
  983.          TM    FDBFLGS,APPN+SVATT  Should we keep attributes?  @SC90033 05799500
  984.          BZ    *+8           No                                @SC90033 05800000
  985.           BAL  14,DSKVALS    Yes, copy old ones to FDB         @SC90033 05800500
  986.          TM    FDBFLGS,APPN  Appending?                        @SC90033 05801000
  987.          BO    DSKOP2        Yes, keep old file                @SC90033 05801500
  988. DSKOP1   DS    0H                                              @SC88308 05802000
  989.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05803000
  990.          MFREQ DSKST                                                    05804000
  991.          MVC   FABRC(1),ZRC                                             05805000
  992.          CLI   ZRC,30              Error deleting file ?                05806000
  993.          BE    DSKOP2              Yup, ignore it.                      05807000
  994.          BAL   9,DSKCHKNM          Check if allowed to do I/O           05808000
  995.           B     DSKER1                                                  05809000
  996.          MFSET DSKST,CLOSE,R=(DEL)                                      05810000
  997.          MFREQ DSKST               Delete the file...                   05811000
  998.          MVC   FABRC(1),ZRC                                             05812000
  999. DSKOP2   MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         05813000
  1000.          SR    0,0                                                      05814000
  1001.          ICM   0,3,FDBLRC    Insert logical record length               05815000
  1002.          STH   0,MFIRSIZ                                                05816000
  1003.          CLI   FDBRCF,C'V'   If not variable, then truncate             05817000
  1004.          BNE   DSKSTLR                                         @SC88120 05818000
  1005.          CLI   TYPFIL,C'B'   If variabel BUT binary, truncate           05819000
  1006.          BE    DSKSTLR                                                  05820000
  1007.          L     0,MAXLRC      TEXT file, no limit               @SC87012 05821000
  1008. DSKSTLR  ST    0,FABLRTR     Set output buffer limit                    05822000
  1009.          CLI   FDBRCF,C'F'   Fixed format ?                             05823000
  1010.          BNE   *+8                                                      05824000
  1011.          MVI   MFIRFM,X'02'  Yup, set to Fixed Compressed               05825000
  1012.          MFSET DSKST,OPEN,R=(OKOLD,OKNEW,WROK)                          05826000
  1013.          TM    FDBFLGS,APPN   Append to file ?                          05827000
  1014.          BZ    *+8                                                      05828000
  1015.          OI    DSKST+1,X'20'  Manually specify APPOK !                  05829000
  1016.          MFREQ DSKST          Do the I/O                                05830000
  1017.          CLI   ZRC,0          Any errors ?                              05831000
  1018.          BNZ   DSKER1                                                   05832000
  1019.          MVC   FABRC,ZRC     Save return code                           05833000
  1020.          MVC   ZINFOUT(LZINFDEF),ZINFIN  Copy creation file parms       05834000
  1021.          BAL   14,DSKVALS          Copy parms to FDBD                   05835000
  1022.          OI    FDBFLGS,FWRITE      Write mode file                      05836000
  1023.          MVC   FABUNIT(1),ZLU      Save the Unit number                 05837000
  1024.          B     RTRN0                                           @SC86295 05838000
  1025. *                                                                       05839000
  1026. * Test for existence of file whose name is at (R2)                      05840000
  1027. DSKTEST  DS    0H                                              @SC89073 05841000
  1028.          MVC   MFNAME(LFID),0(2)   Get filename to test                 05842000
  1029. DSKTST2  LA    3,DSKSTT      Get temporary FDB                 @SC88308 05843000
  1030.          MFSET DSKST,EXTRACT                                   @SC88308 05844000
  1031.          MFREQ DSKST               Get the file info...                 05845000
  1032.          MVI   ZLU,0               Safety check...                      05846000
  1033.          CLI   ZRC,0               Any errors ?                         05847000
  1034.          BNZ   DSKER1                                                   05848000
  1035.          BAL   14,DSKVALS          Go copy info to FDBD                 05849000
  1036.          B     RTRN0                                                    05850000
  1037. *                                                                       05851000
  1038. * Close file whose ticket is at (R1), release block                     05852000
  1039. DSKCLOS  DS    0H                                              @SC89073 05853000
  1040.          ICM   3,15,0(1)     Get FAB ptr, if any               @SC86295 05854000
  1041.          BZ    RTRN0         None, ignore                      @SC86295 05855000
  1042.          XC    0(4,1),0(1)   Yes, now clear ticket             @SC86295 05856000
  1043.          MVC   ZLU(1),FABUNIT      Copy file Unit number                05857000
  1044.          LR    6,3                 Save the address of the FAB          05858000
  1045.          MFSET DSKST,CLOSE                                              05859000
  1046.          TM    FDBFLGS,FWRITE      Write mode file ?                    05860000
  1047.          BZ    DSKCLS2                                                  05861000
  1048.          OI    DSKST+1,X'10'       Yes, add RLSE option !               05862000
  1049. DSKCLS2  MFREQ DSKST               Close the file                       05863000
  1050.          LR    1,6                 Get FAB address                      05864000
  1051.          LA    0,FABDWDS                                       @SC86295 05865000
  1052.        DMSFRET DWORDS=(0),LOC=(1)  Free up the FAB                      05866000
  1053.          B     RTRN0                                           @SC86295 05867000
  1054. *                                                                       05867080
  1055. * Point past 1st N records of file at (R1)                     @SC89218 05867160
  1056. DSKPNT   ICM   3,15,0(1)     Get ticket                        @SC89218 05867240
  1057.          BZ    RTRN1         Not open                          @SC89218 05867320
  1058.          LR    3,1                                             @SC89218 05867400
  1059.          LTR   2,2           Number of records to skip         @SC89218 05867480
  1060.          BNP   RTRN0         Never mind                        @SC89218 05867560
  1061. DSKPNTL  READF 0(,3),E=RTRN1 Skip one                          @SC89218 05867640
  1062.          BCT   2,DSKPNTL     ... until finished                @SC89218 05867720
  1063.          B     RTRN0         Return with completion code       @SC89218 05867800
  1064. *                                                                       05868000
  1065. * Read from file   R1->FAB                                              05869000
  1066. DSKRED   DS    0H                                              @SC89073 05870000
  1067. DSKRED2  LR    3,1                 Point to FAB                         05871000
  1068.          MVC   FABCOMM(8),=CL8'Read'  I/O Operation                     05872000
  1069.          L     0,FDBBUFF           Get buffer address                   05873000
  1070.          ST    0,MFRBUF                                                 05874000
  1071.          L     0,FDBBSIZ           Get I/O Length                       05875000
  1072.          ST    0,MFRLEN                                                 05876000
  1073.          MVC   ZLU(1),FABUNIT      Get unit number                      05877000
  1074.          MFSET DSKST,IO,R=(RD)                                          05878000
  1075.          MFREQ DSKST               Do the I/O                           05879000
  1076.          MVC   FABRC(1),ZRC        Save the return code                 05880000
  1077.          L     0,MFARSZ            Get length read from Save file.      05881000
  1078.          RETREG 0            Return length as R0               @SC89218 05882000
  1079.          CLI   ZRC,0               Any errors ???                       05884000
  1080.          BE    RTRN0                                                    05885000
  1081.          LA    15,12               End of file.                         05886000
  1082.          CLI   ZRC,1               End of file maybe ???                05887000
  1083.          BE    RTRN                                                     05888000
  1084.          B     RTRN1               Well, just another error...          05889000
  1085. *                                                                       05890000
  1086. * Write to file    R1->FAB                                              05891000
  1087. DSKWRT   DS    0H                                              @SC89073 05892000
  1088.          LR    3,1                 Point to FAB                         05893000
  1089.          MVC   FABCOMM(8),=CL8'Write'  I/O Operation                    05894000
  1090.          L     0,FDBBUFF           Get buffer address                   05895000
  1091.          ST    0,MFRBUF                                                 05896000
  1092.          L     0,FDBBSIZ           Get I/O Length                       05897000
  1093.          ST    0,MFRLEN                                                 05898000
  1094.          MVC   ZLU(1),FABUNIT      Get unit number                      05899000
  1095.          MFSET DSKST,IO,R=(WR)                                          05900000
  1096.          MFREQ DSKST               Do the I/O                           05901000
  1097.          MVC   FABRC(1),ZRC        Save the return code                 05902000
  1098.          CLI   ZRC,0               Any errors ???                       05903000
  1099.          BE    RTRN0                                                    05904000
  1100.          LA    15,13               Disk full error code.                05905000
  1101.          CLI   ZRC,40              Well, is it full ?                   05906000
  1102.          BL    RTRN1                                                    05907000
  1103.          CLI   ZRC,42              Three possible return codes          05908000
  1104.          BH    RTRN1                                                    05909000
  1105.          B     RTRN                                                     05910000
  1106. *                                                                       05911000
  1107. * Analyze error: Get error code from FABRC field of FAB !               05912000
  1108. DSKXXX   DS    0H                                              @SC89073 05913000
  1109.          LR    3,1                 Get address of FAB                   05914000
  1110.          MVI   ERRNUM,ERRDIE       Set Kermit DISKIO error code         05915000
  1111.          L     2,EMSGP             Ptr to msg buffer                    05916000
  1112.          MVC   0(8,2),FABCOMM      Copy oprn name                       05917000
  1113.          MVC   ZRC(1),FABRC        Get the error code                   05918000
  1114.          LA    0,8(2)              Get address of where to pad          05919000
  1115.          ST    0,MFRBUF            message                              05920000
  1116.          LA    0,70                Maximum length of message            05921000
  1117.          ST    0,MFRLEN                                                 05922000
  1118.          MFSET DSKST,MSG           Convert RC to real message           05923000
  1119.          MFREQ DSKST                                                    05924000
  1120.          LA    0,79                Return maximum length of msg.        05925000
  1121.          ST    0,EMSGL                                                  05926000
  1122.          B     RTRN1                                           @SC87338 05927000
  1123. *                                                                       05928000
  1124. * Delete file R1->name, Return R15=0 if ok                              05929000
  1125. DSKDEL   DS    0H                                              @SC89073 05930000
  1126.          LA    3,DSKSTT             Temporary FAB needed                05931000
  1127.          MVC   MFNAME(LFID),0(1)    Copy file name to delete            05932000
  1128.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05933000
  1129.          MFREQ DSKST              Try to open the file                  05934000
  1130.          CLI   ZRC,0              Error ?                               05935000
  1131.          BNE   DSKER2                                                   05936000
  1132.          BAL   9,DSKCHKNM          Check if allowed to do I/O           05937000
  1133.           B     DSKER2                                                  05938000
  1134.          MFSET DSKST,CLOSE,R=(DEL)                                      05939000
  1135.          MFREQ DSKST              Delete the file                       05940000
  1136.          CLI   ZRC,0              Error ?                               05941000
  1137.          BNE   DSKER2                                                   05942000
  1138.          LA    15,0          File deleted message              @SC92300 05943000
  1139. *                                                                       05944000
  1140. DSKMSG   LA    0,L'DSKMTAB   Length of msg                     @SC92300 05945000
  1141.          MR    14,0          Get the address of the message    @SC92300 05946000
  1142.          LA    1,DSKMTAB(15)                                   @SC92300 05947000
  1143.          WTEXT (1),(0)                                         @SC88308 05948000
  1144.          MVI   ERRNUM,ERRNOE      No Errors                             05949000
  1145.          B     RTRN0                                                    05950000
  1146. *                                                                       05951000
  1147. * Rename file R1->name, R2->newname,  Return R15=0 if ok                05952000
  1148. DSKRNM   DS    0H                                              @SC89073 05953000
  1149.          LA    3,DSKSTT             Temporary FAB needed                05954000
  1150.          MVC   MFNAME(LFID),0(1)    Copy file name to delete            05955000
  1151.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05956000
  1152.          MFREQ DSKST                Try to open the file                05957000
  1153.          CLI   ZRC,0                Error ?                             05958000
  1154.          BNE   DSKER2                                                   05959000
  1155.          BAL   9,DSKCHKNM          Check if allowed to do I/O           05960000
  1156.           B     DSKER2                                                  05961000
  1157.          MVC   ZINFIN(LZINFDEF),ZINFDEF  Get default file attrs         05962000
  1158.          MVC   MFNAME(LFID),0(2)         Get new name                   05963000
  1159.          MFSET DSKST,CLOSE,R=(RENAME)                                   05964000
  1160.          MFREQ DSKST              Rename it !                           05965000
  1161.          LA    15,1          File renamed message              @SC92300 05966000
  1162.          CLI   ZRC,0              Error on rename ?                     05967000
  1163.          BE    DSKMSG                                                   05968000
  1164.          CLI   ZLU,0              Is an additional close required ?     05969000
  1165.          BE    DSKER2                                                   05970000
  1166.          MFSET DSKST,CLOSE        Yes, close the file normally.         05971000
  1167.          MFREQ DSKST              Rename failed.                        05972000
  1168.          B     DSKER2                                                   05973000
  1169. *                                                                       05974000
  1170. * Copy file.  R1->name, R2->newname.  Return R15=0 if ok                05975000
  1171. DSKCPY   DS    0H                                              @SC89073 05976000
  1172.          LA    3,DSKSTT             Temporary FAB needed                05977000
  1173.          LA    7,1                  Error by default !!!                05978000
  1174.          MVC   MFNAME(LFID),0(1)    Get file name to copy               05979000
  1175.          MFSET DSKST,OPEN,R=(OKOLD,RDOK)                                05980000
  1176.          MFREQ DSKST              Try to open the file                  05981000
  1177.          CLI   ZRC,0              Error ?                               05982000
  1178.          BNE   DSKER2                                                   05983000
  1179.          BAL   9,DSKCHKNM          Check if allowed to do I/O           05984000
  1180.           B     DSKER2                                                  05985000
  1181.          SLR   8,8                                                      05986000
  1182.          ICM   8,1,ZLU             Save Read Unit Number                05987000
  1183.          L     9,MFEOFB            Get number of blks to copy           05988000
  1184.          MVC   PARMAREA(2),MFORSIZ     Save record size                 05989000
  1185.          MVC   PARMAREA+2(4),MFNLRC    Save Line count                  05990000
  1186.          MVC   PARMAREA+6(4),MFEOFB    Save last blk written            05991000
  1187.          MVC   PARMAREA+10(4),MFEOFD   Save displacement                05992000
  1188.          MVC   CMD(64),MFTAG Save tag                          @SC88308 05993000
  1189. *                                                                       05994000
  1190.          MVC   MFNAME(LFID),0(2)    Get destination                     05995000
  1191.          MVC   ZINFIN(LZINFDEF),ZINFOUT                                 05996000
  1192.          NI    MFIGCTL,X'7F'        Turn off common bit !!!             05997000
  1193.          MFSET DSKST,OPEN,R=(OKNEW,WROK)                                05998000
  1194.          MFREQ DSKST              Try to open the file                  05999000
  1195.          CLI   ZRC,0                                                    06000000
  1196.          BNE   DSKCP55            Error. New file open failed !         06001000
  1197.          ICM   8,2,ZLU            Save Write Unit Number                06002000
  1198. *                                                                       06003000
  1199.          LA    4,1                Starting blk number                   06004000
  1200.          LA    5,512              Number of blks to copy                06005000
  1201.          LA    6,2048             Address of buffer                     06006000
  1202.          A     6,WBUF                                                   06007000
  1203.          LTR   9,9                Anything left to do ???               06008000
  1204.          BZ    DSKCP50                                                  06009000
  1205. DSKCP20  STCM  8,1,ZLU            Set Unit number                       06010000
  1206.          STM   4,6,MFSBNU         Set read args                         06011000
  1207.          MFSET DSKST,UIO,R=(RD)                                         06012000
  1208.          MFREQ DSKST              Read a block                          06013000
  1209.          CLI   ZRC,0              Error reading ?                       06014000
  1210.          BNE   DSKCP55                                                  06015000
  1211.          STCM  8,2,ZLU            Set unit number                       06016000
  1212.          STM   4,6,MFSBNU         Set read args                         06017000
  1213.          MFSET DSKST,UIO,R=(WR)                                         06018000
  1214.          MFREQ DSKST              Write the block back                  06019000
  1215.          CLI   ZRC,0         Error writing?                    @SC88308 06020000
  1216.          BNE   DSKCP55                                                  06021000
  1217.          LA    4,1(4)             Next block                            06022000
  1218.          BCT   9,DSKCP20          until all done                        06023000
  1219. *                                                                       06024000
  1220. DSKCP50  SLR   7,7           Clear return code !                        06025000
  1221. DSKCP55  STCM  8,1,ZLU                                                  06026000
  1222.          CLI   ZLU,0         Is the input file open ???                 06027000
  1223.          BE    DSKCP60                                                  06028000
  1224.          MFSET DSKST,CLOSE   Yes, close the input file.                 06029000
  1225.          MFREQ DSKST                                                    06030000
  1226.          ICM   7,2,ZRC       Save the return code                       06031000
  1227. DSKCP60  STCM  8,2,ZLU                                                  06032000
  1228.          CLI   ZLU,0         Is the output file open ?                  06033000
  1229.          BE    DSKCP80                                                  06034000
  1230.          LTR   7,7           Any errors so far ?                        06035000
  1231.          BNZ   DSKCP65                                                  06036000
  1232.          MFSET DSKST,CLOSE,R=(SETEFP)  No, close and save file          06037000
  1233.          MVC   MFORSIZ(2),PARMAREA     Set record size                  06038000
  1234.          MVC   MFNLRC(4),PARMAREA+2    Set Line count                   06039000
  1235.          MVC   MFEOFB(4),PARMAREA+6    Set last blk written             06040000
  1236.          MVC   MFEOFD(4),PARMAREA+10   Set displacement                 06041000
  1237.          MVC   MFTAG(64),CMD Restore tag                       @SC88308 06042000
  1238.          B     DSKCP70                                                  06043000
  1239. DSKCP65  MFSET DSKST,CLOSE,R=(DEL)  Errors, delete file !               06044000
  1240. DSKCP70  MFREQ DSKST                                                    06045000
  1241.          ICM   7,4,ZRC       Get return code on Close                   06046000
  1242. DSKCP80  LR    15,7          Return it to Kermit !                      06047000
  1243.          B     RTRN                                                     06048000
  1244. *                                                                       06049000
  1245. * Type file.   R1-> name. Returns R15=0 if ok.                          06050000
  1246. DSKTYP   DS    0H                                              @SC89073 06051000
  1247.          LR    4,1           Point to file name                @PG88335 06052000
  1248.          OPENF I,(4),FILFDB,FILPTR,E=RTRN1                     @PG88335 06053000
  1249.          LR    3,0           Point to FAB                      @PG88335 06054000
  1250.          LH    1,FDBLRC                                        @PG88335 06055000
  1251.          CH    1,=H'130'     Check record length !!!           @PG88335 06056000
  1252.          BL    DSKTYP20                                        @PG88335 06057000
  1253.          WTEXT '&ONLY130'                                      @PG88335 06058000
  1254. DSKTYP20 L     3,RBUF        Point to data buffer              @PG88335 06059000
  1255.          READF FILPTR,BUFFER=(3),E=DSKTYP50                    @PG88335 06060000
  1256.          CH    0,=H'130'     Record too long ?                 @PG88335 06061000
  1257.          BL    DSKTYP30                                        @PG88335 06062000
  1258.          LA    0,129         Yes, truncate...                  @PG88335 06063000
  1259. DSKTYP30 LTR   0,0           Is it null ?                      @PG88335 06064000
  1260.          BNZ   DSKTYP35                                        @PG88335 06065000
  1261.          MVI   0(3),X'40'    Then we must have at least        @PG88335 06066000
  1262.          LA    0,1           one character to output           @PG88335 06067000
  1263. DSKTYP35 WTEXT (3)                                             @PG88335 06068000
  1264.          B     DSKTYP20                                        @PG88335 06069000
  1265. DSKTYP50 C     15,F12        EOF code ?                        @PG88335 06070000
  1266.          BE    DSKTYP70                                        @PG88335 06071000
  1267.          ERRF  ,             Analyze error code                @PG88335 06072000
  1268.          CLOSF FILPTR                                          @PG88335 06073000
  1269.          B     RTRN1                                           @PG88335 06074000
  1270. DSKTYP70 CLOSF FILPTR                                          @PG88335 06075000
  1271.          B     RTRN0                                           @PG88335 06076000
  1272. *                                                                       06077000
  1273. * Return on error, release useless block, if any                        06078000
  1274. DSKER1   LTR   1,4           Any block assigned?               @SC86295 06079000
  1275.          BZ    RTRN1         No                                @SC86295 06080000
  1276.          LA    0,FABDWDS     Yes, release it                   @SC86295 06081000
  1277.        DMSFRET DWORDS=(0),LOC=(1)                              @SC86295 06082000
  1278.          B     RTRN1         Flag error                        @SC86295 06083000
  1279. * Error return from disk utilities. Set ERRNUM properly.                06084000
  1280. DSKER2   CLI   ZRC,12                                                   06085000
  1281.          BNE   DSKER3                                                   06086000
  1282.          MVI   ERRNUM,ERRFNE  Invalid filename                          06087000
  1283.          B     RTRN1                                                    06088000
  1284. DSKER3   CLI   ZRC,30                                                   06089000
  1285.          BNE   DSKER4                                                   06090000
  1286.          MVI   ERRNUM,ERRFNF  File not found                            06091000
  1287.          B     RTRN1                                                    06092000
  1288. DSKER4   MVI   ERRNUM,ERRDIE  Disk I/O Error                            06093000
  1289.          B     RTRN1                                                    06094000
  1290. * Allocate FAB and copy default FDB                                     06095000
  1291. DSKALC   LR    5,1           Save FDB ptr                      @SC86295 06096000
  1292.          MVC   MFNAME,0(2)                                              06097000
  1293.          LA    0,FABDWDS                                       @SC86295 06098000
  1294.        DMSFREE DWORDS=(0),ERR=DSKER1                           @SC86295 06099000
  1295.          LR    3,1           New block ptr                     @SC86295 06100000
  1296.          LA    4,FDBD        FDB pointer                       @SC88120 06101000
  1297.          RETREG (0,3),(1,4)  Return FAB ptr in R0, FDB in R1   @SC89218 06102000
  1298.          LR    4,3           Indicate we have it               @SC88120 06104000
  1299.          XC    0(8*FABDWDS,3),0(3)                             @SC86295 06105000
  1300.          MVC   FDBD(FDBCOP),0(5) Copy user's FDB               @SC86295 06106000
  1301.          MVC   FABFN(LFID),0(2)  Copy filename to FAB                   06107000
  1302.          BR    9                                               @SC86295 06108000
  1303. *                                                                       06109000
  1304. * Set up search through list of files, pattern at (R1)                  06110000
  1305. DSKNSET  DS    0H                                              @SC89073 06111000
  1306.          MVC   SCODE,UCODE        Get default user code                 06112000
  1307.          MVC   NXFN(LFID),0(1)    Save pattern name                     06113000
  1308.          CLI   4(1),C':'          Code specified in filename ?          06114000
  1309.          BNE   DSKNS4             Nope.                                 06115000
  1310.          MVC   SCODE(4),0(1)      Get the new code for search           06116000
  1311.          MVC   NXFN(LFID),BLNAME  Clear the filename pattern            06117000
  1312.          MVC   NXFN(17),5(1)      Copy filename part only               06118000
  1313. DSKNS4   CLC   SCODE(4),=CL4'*USR' Do we really want the user's code ?  06119000
  1314.          BNE   DSKNS6                                                   06120000
  1315.          MVC   SCODE(4),$USRCDE   Yes, then put in the real thing       06121000
  1316. DSKNS6   MVI   NXFLG,NFSOK        Clear flag byte                       06122000
  1317.          LA    2,LFID             Max length of filename                06123000
  1318.          LA    3,NXFN+LFID                                              06124000
  1319. DSKNS8   BCTR  3,0                                                      06125000
  1320.          CLI   0(3),C'?'          Is it a wildcard ?                    06126000
  1321.          BE    DSKNS10                                                  06127000
  1322.          CLI   0(3),C'*'          Is it a wildcard ?                    06128000
  1323.          BE    DSKNS10                                                  06129000
  1324.          BCT   2,DSKNS8                                                 06130000
  1325.          B     RTRN0              No wildcards, Grreat !!!              06131000
  1326. *                                                                       06132000
  1327. DSKNS10  CLC   SCODE(4),$USRCDE   Are we searching our library ?        06133000
  1328.          BE    DSKNS12                                                  06134000
  1329.          TM    UPRIVS,FILES+LSCAN No, then we need some privs !!!       06135000
  1330.          BZ    DSKNS15                                                  06136000
  1331. DSKNS12  LA    1,NXFN+LFID        End of token if no blanks             06137000
  1332.          TRT   NXFN(LFID),TRTBL   Find 1st blank                        06138000
  1333.          LA    2,NXFN                                                   06139000
  1334.          SR    1,2                Calc length of string                 06140000
  1335.          ST    1,NXFNL            Save it...                            06141000
  1336.          OI    NXFLG,NFWLD        Wildcard search necessary !           06142000
  1337.          L     2,MFINDBUF                                               06143000
  1338.          CALL  MFIND1,((2),F10,SCODE,F0,ZRC),VL,MF=(E,PARMAREA)         06144000
  1339.          LTR   15,15              Any errors ???                        06145000
  1340.          BZ    RTRN0                                                    06146000
  1341. DSKNS15  OI    NXFLG,NFERR        Error on MFIND1 call                  06147000
  1342.          B     RTRN1                                                    06148000
  1343. *                                                                       06149000
  1344. * Flush previous file pattern                                           06150000
  1345. DSKXSET  DS    0H                                              @SC89073 06151000
  1346.          MVI   NXFLG,0            Clear flag byte                       06152000
  1347.          B     RTRN0                                                    06153000
  1348. *                                                                       06154000
  1349. * Check CWD string, return code in R15                                  06155000
  1350. DSKCWDF  DS    0H                                              @SC89073 06156000
  1351.          B     RTRN0                                                    06157000
  1352. *                                                                       06158000
  1353. * Check disk space for proposed file: FDB at (R1), FAB ptr at (R6)      06159000
  1354. DSKTSP   L     5,FDBSIZE-FDBD(,1)  Get actual size             @SC90037 06159200
  1355.          ICM   3,15,0(6)     Get FAB ptr                       @SC90037 06159400
  1356.          BNZ   DSKTSP0       Not open yet                      @SC90037 06159600
  1357.          MVC   MFNAME(LFID),0(2)   Get filename                @SC90037 06159800
  1358.          LA    3,DSKSTT      Get temporary FDB                 @SC90037 06160000
  1359.          MFSET DSKST,EXTRACT                                   @SC90037 06160200
  1360.          MFREQ DSKST         Get the file info                 @SC90037 06160400
  1361.          MVI   ZLU,0         For safety                        @SC90037 06160600
  1362.          CLI   ZRC,0         Found it?                         @SC90037 06160800
  1363.          BNE   DSKTSP0       Not found, nothing to erase       @SC90037 06161000
  1364.          L     1,MFOPRM      Old file size in KBytes           @SC90037 06161200
  1365.          SR    5,1           Assume old file will be erased    @SC90037 06161400
  1366.          BNP   RTRN0         Will release enough for new file  @SC90037 06161600
  1367. DSKTSP0  DS    0H            Check free space                  @SC90037 06161800
  1368.          MFSET DSKST,USERCTL    Get User Control Record to              06163000
  1369.          MFREQ DSKST            determine how much space the            06164000
  1370.          MVC   FABRC(1),ZRC     user has left. Save return code !       06165000
  1371.          L     1,MFMAXS         Get max allocation space                06166000
  1372.          S     1,MFACUR         Subtract amt allocated                  06167000
  1373.          CLR   1,5                                             @SC90037 06168000
  1374.          BL    RTRN1         No room                           @SC86316 06169000
  1375.          B     RTRN0         Ok                                @SC86316 06170000
  1376. *                                                                       06171000
  1377. DSKVALS  LA    0,FDBD        Ptr to FDB                        @SC86295 06172000
  1378.          RETREG (1,0)        Return FDB ptr as R1              @SC89218 06173000
  1379. ***  GET FILE'S DATE...                                                 06175000
  1380.          SR    7,7                                             @SC87296 06176000
  1381.          ICM   7,3,MFUIMD    Mod date as (y-1970)*366+d        @SC92086 06177000
  1382.          BNZ   *+8                                             @SC92086 06177100
  1383.           ICM  7,3,MFUICD    Try for creation date             @SC92086 06177200
  1384.          BZ    DSKVDTZ       No date available (?)             @SC92086 06177300
  1385.          BCTR  7,0           Keep day 366 in same year         @SC92086 06177400
  1386.          SR    6,6                                             @SC92086 06177500
  1387.          D     6,=F'366'     Get d and y-1970                  @SC92086 06177600
  1388.          LA    7,1970(,7)                                      @SC92086 06177700
  1389.          CVD   7,TMPDW                                         @SC87296 06178000
  1390.          MVO   FDBDATE(3),TMPDW Copy year                      @SC92086 06179000
  1391.          MVC   DSKMNTH,=AL1(30,31,30,31,31,30,31,30,31,28,31)  @SC86299 06181000
  1392.          N     7,F3          See if leap year                  @SC92086 06182000
  1393.          BNZ   *+8                                             @SC87296 06183000
  1394.          MVI   DSKMNTH+9,29  Leap year, change Feb.            @SC86299 06184000
  1395.          LA    7,1(,6)       Now get day of year               @SC92086 06184500
  1396.          LA    6,11                                            @SC86299 06185000
  1397.          SR    0,0                                             @SC86299 06186000
  1398. DSKVMDL  IC    0,DSKMNTH-1(6)                                  @SC86299 06187000
  1399.          SR    7,0           Test if passed the right month    @SC86299 06188000
  1400.          BNP   DSKVMDM       Got it                            @SC86299 06189000
  1401.          BCT   6,DSKVMDL                                       @SC86299 06190000
  1402.          SR    0,0           Hit December                      @SC86299 06191000
  1403. DSKVMDM  AR    7,0           Get day of month                  @SC86299 06192000
  1404.          LCR   6,6                                             @SC86299 06193000
  1405.          LA    6,12(6)       Get month                         @SC86299 06194000
  1406.          MH    6,=H'100'                                       @SC86299 06195000
  1407.          AR    6,7           Combine MMDD                      @SC86299 06196000
  1408.          MH    6,=H'10'                                        @SC86299 06197000
  1409.          CVD   6,TMPDW                                         @SC86299 06198000
  1410.          MVC   FDBDATE+2(2),TMPDW+5                            @SC86299 06199000
  1411.          ICM   7,15,MFXITD   Get time of day, if any           @SC92086 06200000
  1412.          BZ    DSKVDTZ       Not specified, leave it out       @SC92086 06200200
  1413.          SLR   6,6                                             @SC92086 06200400
  1414.          D     6,=F'300'     Convert to seconds                @SC92086 06200600
  1415.          SLR   6,6                                             @SC92086 06200800
  1416.          D     6,=F'60'      Get minutes                       @SC92086 06201000
  1417.          LR    0,6           Save remainder = seconds          @SC92086 06201200
  1418.          SLR   6,6                                             @SC92086 06201400
  1419.          D     6,=F'60'      Get hours in R7, minutes in R6    @SC92086 06201600
  1420.          MH    7,=H'100'     Put together into hhmmss form     @SC92086 06201800
  1421.          AR    7,6                                             @SC92086 06202000
  1422.          MH    7,=H'100'                                       @SC92086 06202200
  1423.          AR    7,0                                             @SC92086 06202400
  1424.          MH    7,=H'10'      Shift left one digit              @SC92086 06202600
  1425.          CVD   7,TMPDW       Convert to hhmmss0+               @SC92086 06202800
  1426.          MVC   FDBDATE+4(3),TMPDW+4                            @SC92086 06203000
  1427. DSKVDTZ  DS    0H                                              @SC92086 06203200
  1428.          L     1,MFOPRM      Set file size in KBytes                    06204000
  1429.          ST    1,FDBSIZE                                                06205000
  1430.          SLR   1,1           Set record format character                06206000
  1431.          IC    1,MFORFM      Ignore 'Compressed' modes.                 06207000
  1432.          SLL   1,1                                                      06208000
  1433.          LA    0,RFMTAB                                                 06209000
  1434.          AR    1,0                                                      06210000
  1435.          MVC   FDBRCF,0(1)                                              06211000
  1436.          MVC   FDBLRC(2),MFORSIZ  Get logical record length             06212000
  1437.          NI    FDBFLGS,255-FWRITE Clear the write mode flag             06213000
  1438.          BR    14                                                       06214000
  1439. *                                                                       06215000
  1440. *        NXTFST Routine - searches through Save Library Index           06216000
  1441. *                                                                       06217000
  1442. DSKNXT   DS    0H                                              @SC89073 06218000
  1443.          TM    NXFLG,NFSOK        Was a search set up ???               06219000
  1444.          BZ    RTRN1                                                    06220000
  1445.          TM    NXFLG,NFERR+NFEND  Error or End of search ???            06221000
  1446.          BNZ   RTRN1                                                    06222000
  1447. *                                                                       06223000
  1448.          TM    NXFLG,NFWLD        Do we need to call MFINDX ?           06224000
  1449.          BO    DSKSRCH                                                  06225000
  1450.          OI    NXFLG,NFEND        End of search...                      06226000
  1451.          LA    1,NXFN             Source name was good. Use it!         06227000
  1452. DSKFND   MVC   MFNAME(5),SCODE  Rebuild the complete filename  @SC88308 06228000
  1453.          MVC   MFNAME+5(17),0(1)  info on the file.                     06229000
  1454.          MVC   FILNAM(LFID),MFNAME  Setup FILNAM !!!                    06230000
  1455.          B     DSKTST2                                                  06231000
  1456. *                                                                       06232000
  1457. DSKSRCH  CALL  MFINDX,(FCODE,LCFN,NXFLTYP,NXSVFLG,NXBKNUM,NXDIRLOC),VL,+06233000
  1458.                MF=(E,PARMAREA)                                          06234000
  1459.          C     15,F4              End of library search ?               06235000
  1460.          BNE   NXT20                                                    06236000
  1461.          OI    NXFLG,NFEND        Yes, end of search                    06237000
  1462.          B     RTRN1                                                    06238000
  1463. NXT20    LTR   15,15              Error in search ?                     06239000
  1464.          BZ    NXT30                                                    06240000
  1465.          OI    NXFLG,NFSERRS+NFERR Yes, error in search        @SC88308 06241000
  1466.          B     RTRN1                                                    06242000
  1467. NXT30    CLC   NXFLTYP,F0         Skip over common entries              06243000
  1468.          BNE   DSKSRCH                                                  06244000
  1469.          CLI   LCFN,C'.'          Skip over temporary files             06245000
  1470.          BE    DSKSRCH                                                  06246000
  1471.          CLC   FCODE(4),SCODE     Is this the right code ???            06247000
  1472.          BNE   DSKSRCH                                                  06248000
  1473.          CALL  MATCH,(LCFN,FM17,NXFN,NXFNL,ASTER,QUEST),VL,            +06249000
  1474.                MF=(E,PARMAREA)                                          06250000
  1475.          LTR   0,0                Well, did they match ???              06251000
  1476.          BZ    DSKSRCH                                                  06252000
  1477.          LA    1,LCFN             Point to name found and go            06253000
  1478.          B     DSKFND             copy it and set FDB                   06254000
  1479. *                                                                       06255000
  1480. * Directory Info on file R1->name, return R15=0 if OK                   06256000
  1481. DSKDIR   DS    0H                                              @SC89073 06257000
  1482.          NXTFSET E=DSKDRERR  Set up search (name at R1)        @SC88308 06258000
  1483. DSKDRLP  NXTF  E=DSKDRZ      Find next entry                   @SC88308 06259000
  1484.          TM    NXFLG,NFFND   Found something already?          @SC90264 06259200
  1485.          BO    DSKDRL1                                         @SC90264 06259400
  1486.          WTEXT '&DIRHDNG'                                      @SC92300 06259600
  1487.          OI    NXFLG,NFFND   Found something, at least one     @SC88308 06260000
  1488. DSKDRL1  DS    0H                                              @SC90264 06260500
  1489.          LA    1,CMD         Yes, build the filename with      @SC88308 06261000
  1490.          LR    2,1                the attributes we want in a           06262000
  1491.          LA    3,LFID        Length of name buffer             @SC88308 06263000
  1492.          LA    4,MFNAME                                        @SC88308 06264000
  1493.          LR    5,3                                             @SC88308 06265000
  1494.          CLC   0(4,4),$USRCDE   User's code?                   @SC88308 06266000
  1495.          BNE   *+12          No                                @SC88308 06267000
  1496.           A    4,F5          Yes, skip over it for output      @SC88308 06268000
  1497.           S    5,F5                                            @SC92301 06269000
  1498.          ICM   4,8,F64+3     Get blank for padding             @SC92086 06269500
  1499.          MVCL  2,4                                             @SC88308 06270000
  1500.          ICM   0,3,MFORSIZ                                              06271000
  1501.          BAL   9,DSKNUM           Add the logical record length         06272000
  1502.          MVC   0(2,2),BLNAME Leave some blanks                 @SC88308 06273000
  1503.          SLR   3,3                                                      06274000
  1504.          IC    3,MFORFM           Get record format                     06275000
  1505.          SLL   3,1                                                      06276000
  1506.          LA    3,RFMTAB(3)        Get address of printable value        06277000
  1507.          MVC   2(2,2),0(3)   Add to line                       @SC88308 06278000
  1508.          LA    2,4(2)        Bump the length                   @SC88308 06279000
  1509.          ICM   0,15,MFOPRM                                              06280000
  1510.          BAL   9,DSKNUM           Add the file size in Kbytes           06281000
  1511.          ICM   0,15,MFNLRC        Add the number of lines               06284000
  1512.          BAL   9,DSKNUM                                                 06285000
  1513.          LA    3,DSKSTT      Point to temp FDB                 @SC92086 06285200
  1514.          CLI   FDBDATE,X'19' Validate century                  @SC92086 06285400
  1515.          BL    DSKDRDZ       No good!                          @SC92086 06285600
  1516.          CLI   FDBDATE,X'20'                                   @SC92086 06285800
  1517.          BH    DSKDRDZ                                         @SC92086 06286000
  1518.          MVC   0(DSKDRTL,2),DSKDRDT Copy whole pattern         @SC92086 06286200
  1519.          ED    0(DSKDRTL,2),FDBDATE and make it printable      @SC92086 06286400
  1520.          LA    2,DSKDRDL(,2) Length of just date portion       @SC92086 06286600
  1521.          CLC   FDBDATE+4(3),F0                                 @SC92086 06286800
  1522.          BE    *+8           No time given                     @SC92086 06287000
  1523.           LA   2,DSKDRTL-DSKDRDL(,2) Include time portion      @SC92086 06287200
  1524. DSKDRDZ  DS    0H                                              @SC92086 06287400
  1525. *                                                                       06288000
  1526.          SR    2,1                Get the output length                 06289000
  1527.          WTEXT (1),(2)                                                  06290000
  1528.          B     DSKDRLP                                         @SC88308 06291000
  1529. *                                                              @SC88308 06292000
  1530. DSKDRZ   TM    NXFLG,NFSERRS+NFERR                             @SC88308 06293000
  1531.          BNZ   DSKDRERR      Report error                      @SC88308 06294000
  1532.          TM    NXFLG,NFFND   Any files found?                  @SC88308 06295000
  1533.          BO    RTRN0         Yes, return gracefully            @SC88308 06296000
  1534. DSKDRERR B     RTRN1         Not found or invalid              @SC90264 06297000
  1535. *                                                                       06299000
  1536. DSKNUM   CVD   0,TMPDW            Pack the binary value                 06300000
  1537.          OI    TMPDW+7,15         Set zone                              06301000
  1538.          UNPK  0(8,2),TMPDW       Convert to printable                  06302000
  1539.          LA    5,7(2)             Point to end of string                06303000
  1540. DSKNUM2  CLI   0(2),C'0'          Remove leading zeros                  06304000
  1541.          BNE   DSKNUM3            except for the first one.             06305000
  1542.          MVI   0(2),C' '                                                06306000
  1543.          LA    2,1(2)                                                   06307000
  1544.          CR    2,5                                                      06308000
  1545.          BL    DSKNUM2                                                  06309000
  1546. DSKNUM3  LA    2,1(5)             Get the new ending address            06310000
  1547.          BR    9                                                        06311000
  1548. *                                                                       06312000
  1549. *  Check for privs to open filename                                     06313000
  1550. *  R3->FAB,  R9->returns                                       @SC88308 06314000
  1551. DSKCHKNM TM    UPRIVS,FILES+LSCAN If FILES, never any problems          06315000
  1552.          BNZ   4(9)                                                     06316000
  1553.          CLC   MFUIFC(4),$USRCDE  If our own code, then no problem      06317000
  1554.          BE    4(9)                                                     06318000
  1555.          TM    MFOACNB,X'A0'      Allowed to read file ???              06319000
  1556.          BZ    4(9)                                                     06320000
  1557.          MVI   FABRC,21           Not your library error.               06321000
  1558.          CLI   ZLU,0              Is the file still open ?              06322000
  1559.          BER   9                                                        06323000
  1560.          MFSET DSKST,CLOSE        Yes, close it normally...             06324000
  1561.          MFREQ DSKST                                                    06325000
  1562.          BR    9                  Error return                          06326000
  1563. *                                                                       06327000
  1564. RFMTAB   DC    C'U F FCV VC'      Record Format Table                   06328000
  1565. DSKMTAB  DC    CL25'&FILDELT'                                  @SC92300 06329000
  1566.          DC    CL25'&FILRENM'                                  @SC92300 06329500
  1567.          DC    CL25'&FILCOPY'                                  @SC92300 06330000
  1568. DSKDRDT  DC    C'  ',4X'20',C'/',2X'20',C'/',2X'20'      Date  @SC92086 06331200
  1569. DSKDRDL  EQU   *-DSKDRDT     Length of date portion            @SC92086 06331400
  1570.          DC    C' ',2X'20',C':',2X'20',C':',2X'20'       Time  @SC92086 06331600
  1571. DSKDRTL  EQU   *-DSKDRDT     Length of whole pattern           @SC92086 06331800
  1572.          LOCALS ,                                                       06332000
  1573. DSKMNTH  DS    XL11          Month length table                @SC86299 06334000
  1574. DSKCOD   DS    X             Saved DISKIO code                 @SC88308 06335000
  1575.          DROP  R3                                                       06336000
  1576.          EXIT                                                           06337000
  1577.          EJECT                                                          06338000
  1578.