home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / ibm370 / ikxbim.asm < prev    next >
Assembly Source File  |  2020-01-01  |  15KB  |  384 lines
  1. * KERMBIM - Kermit I/O driver program
  2. *
  3. *  Brett Raymond, Seattle University, May 1992
  4. *          modified to use the 8-byte fileclass
  5. *
  6. *         THIS PROGRAM INTERFACES KERMIT TO BIM-EDIT.
  7. *
  8. * To use this program: assemble and link (under any suitable name,
  9. * such as KERMBIM) and include in the CICS PPT.  It can be used to
  10. * read or write a BIM-EDIT file called "filename" by speciifying
  11. * "filename/KERMBIM.PGM" to Kermit-CICS.
  12. *
  13. *
  14. )INCL BI$APL
  15. *
  16. * CICS EXECUTION INTERFACE DSECTS
  17. *
  18. DFHEISTG DSECT
  19. *
  20. * COMMAREA DSECT
  21. *
  22. FABD     DSECT                                                 @SC86295
  23. FABRESP  DS    XL6           Saved response code               @SC90264
  24. FABNORD  DS    H             Byte count of last transfer       @SC90264
  25. FDBD     DS    0F            Beginning of short descriptor     @SC86295
  26. FDBBUFF  DS    A             Buffer ptr                        @SC86295
  27. FDBBSIZ  DS    F             Max record length                 @SC86295
  28. FDBRCF   DS    C             Record format                     @SC86295
  29. FDBFLGS  DS    X             Flags                             @SC86295
  30. FDBACTV  EQU   X'80'         File is already open              @SC86295
  31. * SVATT  EQU   X'40'         Preserve attributes               @SC90033
  32. * APPN   EQU   X'10'         DISP=MOD                          @SC86295
  33. FDBLRC   DS    H             File record length                @SC86295
  34. FDBSIZE  DS    F             File size in Kbytes               @SC86299
  35. FDBCOP   EQU   *-FDBD        Length to copy for OPEN           @SC86295
  36. FDBDATE  DS    XL7           Time stamp: packed yyyymmddhhmmss @SC88235
  37. * Must align FABFID to abut FABRN (halfword)                   @SC90264
  38. FABFID   DS    0CL17         File designator                   @SC90264
  39. FABFLGS  DS    X             Flags indicating type of file     @SC90264
  40. FABFMAIN EQU   X'01'         Flag for MAIN TS queue            @SC90264
  41. FABFTS   EQU   X'02'         Flag for TS queue                 @SC90264
  42. FABFTD   EQU   X'04'         Flag for TD queue                 @SC90264
  43. FABFPGM  EQU   X'08'         Flag for pipe file                @SC90264
  44. FABFSPL  EQU   X'10'         Flag for spool file               @SC90264
  45. FABFTAK  EQU   X'20'         Flag for internal Kermit file     @SC90264
  46. FABFUID  DS    CL8           User name                         @SC90264
  47. FABFNAM  DS    CL8           File name                         @SC90264
  48. FABRN    DS    H             Record number                     @SC90264
  49. FDBNREC  DS    H             Number of records                 @SC90264
  50. FDBFL2   DS    X             More flags                        @SC90264
  51. FDBXRCF  DS    X             External format flags             @SC90264
  52. FDBXLRC  DS    H             External old LRECL                @SC90264
  53. FDBXBLK  DS    H             External old block size           @SC90264
  54. FDBINFO  EQU   *-FDBD        Length of info returned           @SC86295
  55. FABIOF   DS    X             More flags                        @SC90264
  56. FABLRTR  DS    F             Record length for truncation      @SC88120
  57. FABUWORD DS    F             Reserved for user applications    @SC90264
  58. FABCOMM  DS    CL8           Command name                      @SC87351
  59. *  CLOSE     Close file named in FABFID                        @SC90264
  60. *  CWD       Set new user directory or QFN prefix: string is at@SC90264
  61. *            FABFID+2 with 2-byte unsigned length at FABFID    @SC90264
  62. *  DELETE    Delete file named in FABFID                       @SC90264
  63. *  OPEN I    Open file named in FABFID for input               @SC90264
  64. *  OPEN O    Open file named in FABFID for output              @SC90264
  65. *  READ      Read a record from (already open) file            @SC90264
  66. *  READ TD   Read a record from (already open) TD queue        @SC90264
  67. *  READ TS   Read a record from (already open) TS queue        @SC90264
  68. *  TEST      Check whether file named in FABFID exists         @SC90264
  69. *  WRIT TD   Write a record to (already open) TD queue         @SC90264
  70. *  WRIT TS   Write a record to (already open) TS queue         @SC90264
  71. *  WRITE     Write a record to (already open) file             @SC90264
  72. FABDWDS  EQU   (*-FABD+7)/8                                    @SC86295
  73. XBUF     DSECT
  74. XDATA    DS    CL256
  75. *
  76. BIMAREA  DSECT
  77. CSASAVE  DS    F
  78. GPR10    DS    F
  79. REGSAVE  DS    18F
  80. PARM     DS    F
  81.          DS    F
  82.          DS    F
  83.          DS    F
  84. LINEL    DC    XL2'0'
  85. LINED    DC    CL256' '
  86. STATUS   DC    CL2'  '
  87. WORKAREA DS    8400XL1
  88. *
  89. * MAIN CONTROL SECTION
  90. *
  91. KRMK0000 DFHEIENT CODEREG=(3)
  92.          L     R4,DFHEICAP             - GET ADDRESS OF COMMAREA
  93.          USING FABD,R4
  94.          MVC   FABRESP(6),=X'000000000000'
  95.          CLC   FABCOMM,=CL8'TEST'      - IS THIS A TEST REQUEST?
  96.          BE    KRMK0100                - ...YES, SET FILE ATTRIBS
  97.          CLC   FABCOMM,=CL8'VERIFY'    - IS THIS A VERIFY REQUEST?
  98.          BE    KRMK0100                - ...YES, SET FILE ATTRIBS
  99.          CLC   FABCOMM,=CL8'OPEN I'    - IS THIS AN OPENI REQUEST?
  100.          BE    KRMK0150                - ...YES, OPEN INPUT
  101.          CLC   FABCOMM,=CL8'OPEN O'    - IS THIS AN OPENO REQUEST?
  102.          BE    KRMK0180                - ...YES, OPEN OUTPUT
  103.          L     R6,FABUWORD
  104.          USING BIMAREA,R6
  105.          CLC   FABCOMM,=CL8'DELETE'    - IS THIS A DELETE REQUEST?
  106.          BE    KRMK0220                - ...YES, SET FILE ATTRIBS
  107.          CLC   FABCOMM,=CL8'READ'      - IS THIS A READ REQUEST?
  108.          BE    KRMK0200                - ...YES, READ A RECORD
  109.          CLC   FABCOMM,=CL8'WRITE'     - IS THIS A WRITE REQUEST?
  110.          BE    KRMK0250                - ...YES, WRITE A RECORD
  111.          CLC   FABCOMM,=CL8'CLOSE'     - IS THIS A CLOSE REQUEST?
  112.          BE    KRMK0300                - ...YES, CLOSE THE FILE
  113.          MVI   FABRESP,X'77'           - INVALID REQUEST
  114.          B     KRMK0999
  115.          DC    C'KERMBIM V=1.0.0'
  116. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  117. * SET FILE ATTRIBUTES                                                 *
  118. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  119. KRMK0100 DS    0H
  120.          CLI   FABIOF,X'01'          - IS THIS AN OUTPUT FILE?
  121.          BE    KRMK0999                ...YES, DON'T SET VALUES
  122.          MVI   FDBXRCF,C'V'
  123.          LA    R5,132
  124.          STH   R5,FDBXLRC
  125.          ST    R5,FDBBSIZ
  126.          SR    R5,R5
  127.          STH   R5,FDBNREC
  128.          MVI   FDBRCF,C'V'
  129.          B     KRMK0999
  130.          DC    C'KRMK0100'             - EYECATCHER
  131. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  132. * OPEN A FILE AS INPUT                                                *
  133. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  134. KRMK0150 DS    0H
  135.          EXEC CICS HANDLE CONDITION NOSTG,
  136.          EXEC CICS GETMAIN SET(R6) LENGTH(8756),
  137.          EXEC CICS IGNORE CONDITION LENGERR,
  138.          ST    R6,FABUWORD
  139.          ST    R10,GPR10
  140.          BAL   R10,KRMKOPNS      INITIALIZE WORK AREA
  141.          BAL   R10,KRMK08SD
  142.          BAL   R10,KRMK08RC
  143.          CLC   STATUS,=C'OK'
  144.          BNE   KRMK0900
  145.          MVC   LINED,=CL9'ATT $USR.'
  146.          EXEC CICS ASSIGN USERID(LINED+9)
  147.          MVI   LINED+13,C' '
  148.          MVC   LINED+14(242),LINED+13
  149.          MVC   LINEL,=H'80'
  150.          BAL   R10,KRMK08SD
  151.          BAL   R10,KRMK08RC
  152.          CLC   STATUS,=C'OK'
  153.          BNE   KRMK0900
  154.          MVC   LINED,=CL5'SEND '
  155.          MVC   LINED+5(8),FABFUID
  156.          MVI   LINED+13,C' '
  157.          MVC   LINED+14(242),LINED+13
  158.          MVC   LINEL,=H'80'
  159.          BAL   R10,KRMK08SD
  160.          BAL   R10,KRMK08RC
  161.          CLC   STATUS,=C'OK'
  162.          BNE   KRMK0900
  163.          L     R10,GPR10
  164.          MVI   FDBXRCF,C'V'
  165.          LA    R5,132
  166.          STH   R5,FDBXLRC
  167.          ST    R5,FDBBSIZ
  168.          SR    R5,R5
  169.          STH   R5,FDBNREC
  170.          MVI   FDBRCF,C'V'
  171.          B     KRMK0999
  172.          DC    C'KRMK0150'             - EYECATCHER
  173. *
  174. KRMKOPNS DS    0H            INITIALIZE WORK AREA
  175.          LA    R14,LINED
  176.          ST    R14,PARM
  177.          LA    R14,LINEL
  178.          ST    R14,PARM+4
  179.          LA    R14,STATUS
  180.          ST    R14,PARM+8
  181.          LA    R14,WORKAREA
  182.          ST    R14,PARM+12
  183.          MVI   PARM+12,X'80'
  184.          MVC   LINED(8),=C'BIMEDIT '
  185.          MVC   LINEL,=H'08'
  186. *        CALL  BIUAPOP,(LINED,LINEL,STATUS,WORKAREA)
  187.          L     R15,=V(BIUAPOP)
  188.          BAL   R14,KRMKCALL
  189.          L     R13,CSASAVE       RESTORE CSA REGISTER
  190.          CLC   STATUS,=C'OK'     RESPONSE OK?
  191.          BNE   KRMK0900          IF NOT, BRANCH TO ERR LOGIC
  192.          MVC   LINED,=CL15'LOGON $SYS,PASS'
  193.          MVI   LINED+15,C' '
  194.          MVC   LINED+16(240),LINED+15
  195.          MVC   LINEL,=H'80'
  196.          BR    R10
  197. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  198. * OPEN A FILE AS OUTPUT                                               *
  199. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  200. KRMK0180 DS    0H
  201.          EXEC CICS HANDLE CONDITION NOSTG,
  202.          EXEC CICS GETMAIN SET(R6) LENGTH(8756),
  203.          EXEC CICS IGNORE CONDITION LENGERR,
  204.          ST    R6,FABUWORD
  205.          USING BIMAREA,R6
  206.          ST    R10,GPR10
  207.          BAL   R10,KRMKOPNS      INITIALIZE WORK AREA
  208.          BAL   R10,KRMK08SD
  209.          BAL   R10,KRMK08RC
  210.          CLC   STATUS,=C'OK'
  211.          BNE   KRMK0900
  212.          MVC   LINED,=CL9'ATT $USR.'
  213.          EXEC CICS ASSIGN USERID(LINED+9)
  214.          MVI   LINED+13,C' '
  215.          MVC   LINED+14(242),LINED+13
  216.          MVC   LINEL,=H'80'
  217.          BAL   R10,KRMK08SD
  218.          BAL   R10,KRMK08RC
  219.          CLC   STATUS,=C'OK'
  220.          BNE   KRMK0900
  221.          MVC   LINED,=CL6'PURGE '
  222.          MVC   LINED+6(8),FABFUID
  223.          MVI   LINED+14,C' '
  224.          MVC   LINED+15(241),LINED+14
  225.          MVC   LINEL,=H'80'
  226.          BAL   R10,KRMK08SD
  227.          BAL   R10,KRMK08RC
  228.          MVC   LINED,BIMDEFN
  229.          MVC   LINED+6(8),FABFUID
  230.          MVI   LINED+44,C' '
  231.          MVC   LINED+45(211),LINED+44
  232.          MVC   LINEL,=H'80'
  233.          BAL   R10,KRMK08SD
  234.          BAL   R10,KRMK08RC
  235.          L     R10,GPR10
  236.          CLC   STATUS,=C'OK'
  237.          BNE   KRMK0900
  238.          MVC   LINED,=CL4'EDIT'
  239.          MVI   LINED+4,C' '
  240.          MVC   LINED+5(251),LINED+4
  241.          MVC   LINEL,=H'80'
  242.          BAL   R10,KRMK08SD
  243.          BAL   R10,KRMK08RC
  244.          CLC   STATUS,=C'OK'
  245.          BNE   KRMK0900
  246.          MVC   LINED,=CL7'INSERTF'
  247.          MVI   LINED+7,C' '
  248.          MVC   LINED+8(248),LINED+7
  249.          MVC   LINEL,=H'80'
  250.          BAL   R10,KRMK08SD
  251.          BAL   R10,KRMK08RC
  252.          CLC   STATUS,=C'OK'
  253.          BNE   KRMK0900
  254.          L     R10,GPR10
  255.          B     KRMK0999
  256.          DC    C'KRMK0185'             - EYECATCHER
  257. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  258. * READ A RECORD                                                       *
  259. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  260. KRMK0200 DS    0H
  261.          L     R7,FDBBUFF
  262.          USING XBUF,R7
  263.          ST    R10,GPR10
  264.          MVC   STATUS,=C'  '
  265.          MVI   LINED,C' '
  266.          MVC   LINED+1(255),LINED
  267.          MVC   LINEL,=H'132'
  268.          BAL   R10,KRMK08RC
  269.          L     R10,GPR10
  270.          CLC   STATUS,=C'EF'     LAST LINE?
  271.          BE    KRMK0201
  272.          CLC   STATUS,=C'OK'     LAST LINE?
  273.          BNE   KRMK0900
  274.          MVC   XDATA(132),LINED
  275.          LH    R5,LINEL
  276.          STH   R5,FABNORD
  277.          B     KRMK0999
  278.          DC    C'KRMK0200'             - EYECATCHER
  279. KRMK0201 DS    0H
  280.          MVI   FABRESP,X'01'
  281.          B     KRMK0999
  282.          DC    C'KRMK0201'             - EYECATCHER
  283. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  284. * DELETE A FILE                                                       *
  285. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  286. KRMK0220 DS    0H
  287.          B     KRMK0999
  288.          DC    C'KRMK0220'             - EYECATCHER
  289. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  290. * WRITE A RECORD                                                      *
  291. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  292. KRMK0250 DS    0H
  293.          L     R7,FDBBUFF
  294.          USING XBUF,R7
  295.          LA    R5,256
  296.          CH    R5,FABNORD          TOO LARGE FOR BIM
  297.          BL    KRMK0251
  298.          MVC   LINED(256),XDATA
  299.          LH    R5,FABNORD
  300.          STH   R5,LINEL
  301.          ST    R10,GPR10
  302.          BAL   R10,KRMK08SD
  303.          L     R10,GPR10
  304.          CLC   STATUS,=C'OK'
  305.          BNE   KRMK0900
  306.          B     KRMK0999
  307.          DC    C'KRMK0250'             - EYECATCHER
  308. KRMK0251 DS    0H
  309.          MVI   FABRESP,X'88'
  310.          B     KRMK0999
  311.          DC    C'KRMK0251'             - EYECATCHER
  312. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  313. * CLOSE THE FILE                                                      *
  314. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  315. KRMK0300 DS    0H
  316.          CLI   FABIOF,X'01'          - IS THIS AN OUTPUT FILE?
  317.          BNE   KRMK0301                ...NO, SKIP FILE SAVE
  318.          MVC   LINED(256),C' '
  319.          MVC   LINEL,=H'80'
  320.          MVC   STATUS,=CL2'EF'
  321.          ST    R10,GPR10
  322.          BAL   R10,KRMK08SD
  323.          MVC   LINED,=CL4'SAVE'
  324.          MVI   LINED+4,C' '
  325.          MVC   LINED+5(251),LINED+4
  326.          MVC   LINEL,=H'80'
  327.          BAL   R10,KRMK08SD
  328.          BAL   R10,KRMK08RC
  329.          L     R10,GPR10
  330.          CLC   STATUS,=C'OK'
  331.          BNE   KRMK0900
  332.          B     KRMK0301
  333.          DC    C'KRMK0300'             - EYECATCHER
  334. KRMK0301 DS    0H
  335. *        CALL  BIUAPCL,(LINED,LINEL,STATUS,WORKAREA)
  336.          L     R15,=V(BIUAPCL)
  337.          BAL   R14,KRMKCALL
  338.          L     R13,CSASAVE       RESTORE CSA REGISTER
  339.          CLC   STATUS,=C'OK'     RESPONSE OK?
  340.          BNE   KRMK0900          IF NOT, BRANCH TO ERR LOGIC
  341.          EXEC CICS FREEMAIN DATA(0(,R6)),
  342.          B     KRMK0999
  343.          DC    C'KRMK0301'             - EYECATCHER
  344. KRMKCALL DS    0H
  345.          ST    R13,CSASAVE
  346.          LA    R13,REGSAVE
  347.          LA    R1,PARM
  348.          BR    R15
  349. KRMK08RC DS    0H
  350. *        CALL  BIUAPRC,(LINED,LINEL,STATUS,WORKAREA)
  351.          L     R15,=V(BIUAPRC)
  352.          BAL   R14,KRMKCALL
  353.          L     R13,CSASAVE       RESTORE CSA REGISTER
  354.          CLC   STATUS,=C'XP'
  355.          BE    KRMK0900
  356.          CLC   STATUS,=C'EF'
  357.          BER   R10
  358.          BR    R10
  359. KRMK08SD DS    0H
  360. *        CALL  BIUAPSD,(LINED,LINEL,STATUS,WORKAREA)
  361.          L     R15,=V(BIUAPSD)
  362.          BAL   R14,KRMKCALL
  363.          L     R13,CSASAVE       RESTORE CSA REGISTER
  364.          CLC   STATUS,=C'XP'
  365.          BE    KRMK0900
  366.          BR    R10
  367. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  368. * SAY WE GOT AN ERROR                                                 *
  369. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  370. KRMK0900 DS    0H
  371.          MVC   FABRESP(2),STATUS
  372. KRMK0999 DS    0H
  373.          EXEC CICS RETURN
  374. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  375. * CONSTANTS AND STORAGE                                               *
  376. * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  377.          DC    C'KERMBIM LITRALS'
  378. BIMDEFN  DC    CL44'DEF   XXXXXXXX,DATA,UPLOAD,CASE=M,ZONE=1-132'
  379.          LTORG
  380.          DFHEIRET
  381.          DFHEISTG
  382.          DFHEIEND
  383.          END
  384.