* KERMBIM - Kermit I/O driver program
*
*  Brett Raymond, Seattle University, May 1992
*          modified to use the 8-byte fileclass
*
*         THIS PROGRAM INTERFACES KERMIT TO BIM-EDIT.
*
* To use this program: assemble and link (under any suitable name,
* such as KERMBIM) and include in the CICS PPT.  It can be used to
* read or write a BIM-EDIT file called "filename" by speciifying
* "filename/KERMBIM.PGM" to Kermit-CICS.
*
*
)INCL BI$APL
*
* CICS EXECUTION INTERFACE DSECTS
*
DFHEISTG DSECT
*
* COMMAREA DSECT
*
FABD     DSECT                                                 @SC86295
FABRESP  DS    XL6           Saved response code               @SC90264
FABNORD  DS    H             Byte count of last transfer       @SC90264
FDBD     DS    0F            Beginning of short descriptor     @SC86295
FDBBUFF  DS    A             Buffer ptr                        @SC86295
FDBBSIZ  DS    F             Max record length                 @SC86295
FDBRCF   DS    C             Record format                     @SC86295
FDBFLGS  DS    X             Flags                             @SC86295
FDBACTV  EQU   X'80'         File is already open              @SC86295
* SVATT  EQU   X'40'         Preserve attributes               @SC90033
* APPN   EQU   X'10'         DISP=MOD                          @SC86295
FDBLRC   DS    H             File record length                @SC86295
FDBSIZE  DS    F             File size in Kbytes               @SC86299
FDBCOP   EQU   *-FDBD        Length to copy for OPEN           @SC86295
FDBDATE  DS    XL7           Time stamp: packed yyyymmddhhmmss @SC88235
* Must align FABFID to abut FABRN (halfword)                   @SC90264
FABFID   DS    0CL17         File designator                   @SC90264
FABFLGS  DS    X             Flags indicating type of file     @SC90264
FABFMAIN EQU   X'01'         Flag for MAIN TS queue            @SC90264
FABFTS   EQU   X'02'         Flag for TS queue                 @SC90264
FABFTD   EQU   X'04'         Flag for TD queue                 @SC90264
FABFPGM  EQU   X'08'         Flag for pipe file                @SC90264
FABFSPL  EQU   X'10'         Flag for spool file               @SC90264
FABFTAK  EQU   X'20'         Flag for internal Kermit file     @SC90264
FABFUID  DS    CL8           User name                         @SC90264
FABFNAM  DS    CL8           File name                         @SC90264
FABRN    DS    H             Record number                     @SC90264
FDBNREC  DS    H             Number of records                 @SC90264
FDBFL2   DS    X             More flags                        @SC90264
FDBXRCF  DS    X             External format flags             @SC90264
FDBXLRC  DS    H             External old LRECL                @SC90264
FDBXBLK  DS    H             External old block size           @SC90264
FDBINFO  EQU   *-FDBD        Length of info returned           @SC86295
FABIOF   DS    X             More flags                        @SC90264
FABLRTR  DS    F             Record length for truncation      @SC88120
FABUWORD DS    F             Reserved for user applications    @SC90264
FABCOMM  DS    CL8           Command name                      @SC87351
*  CLOSE     Close file named in FABFID                        @SC90264
*  CWD       Set new user directory or QFN prefix: string is at@SC90264
*            FABFID+2 with 2-byte unsigned length at FABFID    @SC90264
*  DELETE    Delete file named in FABFID                       @SC90264
*  OPEN I    Open file named in FABFID for input               @SC90264
*  OPEN O    Open file named in FABFID for output              @SC90264
*  READ      Read a record from (already open) file            @SC90264
*  READ TD   Read a record from (already open) TD queue        @SC90264
*  READ TS   Read a record from (already open) TS queue        @SC90264
*  TEST      Check whether file named in FABFID exists         @SC90264
*  WRIT TD   Write a record to (already open) TD queue         @SC90264
*  WRIT TS   Write a record to (already open) TS queue         @SC90264
*  WRITE     Write a record to (already open) file             @SC90264
FABDWDS  EQU   (*-FABD+7)/8                                    @SC86295
XBUF     DSECT
XDATA    DS    CL256
*
BIMAREA  DSECT
CSASAVE  DS    F
GPR10    DS    F
REGSAVE  DS    18F
PARM     DS    F
         DS    F
         DS    F
         DS    F
LINEL    DC    XL2'0'
LINED    DC    CL256' '
STATUS   DC    CL2'  '
WORKAREA DS    8400XL1
*
* MAIN CONTROL SECTION
*
KRMK0000 DFHEIENT CODEREG=(3)
         L     R4,DFHEICAP             - GET ADDRESS OF COMMAREA
         USING FABD,R4
         MVC   FABRESP(6),=X'000000000000'
         CLC   FABCOMM,=CL8'TEST'      - IS THIS A TEST REQUEST?
         BE    KRMK0100                - ...YES, SET FILE ATTRIBS
         CLC   FABCOMM,=CL8'VERIFY'    - IS THIS A VERIFY REQUEST?
         BE    KRMK0100                - ...YES, SET FILE ATTRIBS
         CLC   FABCOMM,=CL8'OPEN I'    - IS THIS AN OPENI REQUEST?
         BE    KRMK0150                - ...YES, OPEN INPUT
         CLC   FABCOMM,=CL8'OPEN O'    - IS THIS AN OPENO REQUEST?
         BE    KRMK0180                - ...YES, OPEN OUTPUT
         L     R6,FABUWORD
         USING BIMAREA,R6
         CLC   FABCOMM,=CL8'DELETE'    - IS THIS A DELETE REQUEST?
         BE    KRMK0220                - ...YES, SET FILE ATTRIBS
         CLC   FABCOMM,=CL8'READ'      - IS THIS A READ REQUEST?
         BE    KRMK0200                - ...YES, READ A RECORD
         CLC   FABCOMM,=CL8'WRITE'     - IS THIS A WRITE REQUEST?
         BE    KRMK0250                - ...YES, WRITE A RECORD
         CLC   FABCOMM,=CL8'CLOSE'     - IS THIS A CLOSE REQUEST?
         BE    KRMK0300                - ...YES, CLOSE THE FILE
         MVI   FABRESP,X'77'           - INVALID REQUEST
         B     KRMK0999
         DC    C'KERMBIM V=1.0.0'
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* SET FILE ATTRIBUTES                                                 *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0100 DS    0H
         CLI   FABIOF,X'01'          - IS THIS AN OUTPUT FILE?
         BE    KRMK0999                ...YES, DON'T SET VALUES
         MVI   FDBXRCF,C'V'
         LA    R5,132
         STH   R5,FDBXLRC
         ST    R5,FDBBSIZ
         SR    R5,R5
         STH   R5,FDBNREC
         MVI   FDBRCF,C'V'
         B     KRMK0999
         DC    C'KRMK0100'             - EYECATCHER
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* OPEN A FILE AS INPUT                                                *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0150 DS    0H
         EXEC CICS HANDLE CONDITION NOSTG,
         EXEC CICS GETMAIN SET(R6) LENGTH(8756),
         EXEC CICS IGNORE CONDITION LENGERR,
         ST    R6,FABUWORD
         ST    R10,GPR10
         BAL   R10,KRMKOPNS      INITIALIZE WORK AREA
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL9'ATT $USR.'
         EXEC CICS ASSIGN USERID(LINED+9)
         MVI   LINED+13,C' '
         MVC   LINED+14(242),LINED+13
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL5'SEND '
         MVC   LINED+5(8),FABFUID
         MVI   LINED+13,C' '
         MVC   LINED+14(242),LINED+13
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         L     R10,GPR10
         MVI   FDBXRCF,C'V'
         LA    R5,132
         STH   R5,FDBXLRC
         ST    R5,FDBBSIZ
         SR    R5,R5
         STH   R5,FDBNREC
         MVI   FDBRCF,C'V'
         B     KRMK0999
         DC    C'KRMK0150'             - EYECATCHER
*
KRMKOPNS DS    0H            INITIALIZE WORK AREA
         LA    R14,LINED
         ST    R14,PARM
         LA    R14,LINEL
         ST    R14,PARM+4
         LA    R14,STATUS
         ST    R14,PARM+8
         LA    R14,WORKAREA
         ST    R14,PARM+12
         MVI   PARM+12,X'80'
         MVC   LINED(8),=C'BIMEDIT '
         MVC   LINEL,=H'08'
*        CALL  BIUAPOP,(LINED,LINEL,STATUS,WORKAREA)
         L     R15,=V(BIUAPOP)
         BAL   R14,KRMKCALL
         L     R13,CSASAVE       RESTORE CSA REGISTER
         CLC   STATUS,=C'OK'     RESPONSE OK?
         BNE   KRMK0900          IF NOT, BRANCH TO ERR LOGIC
         MVC   LINED,=CL15'LOGON $SYS,PASS'
         MVI   LINED+15,C' '
         MVC   LINED+16(240),LINED+15
         MVC   LINEL,=H'80'
         BR    R10
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* OPEN A FILE AS OUTPUT                                               *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0180 DS    0H
         EXEC CICS HANDLE CONDITION NOSTG,
         EXEC CICS GETMAIN SET(R6) LENGTH(8756),
         EXEC CICS IGNORE CONDITION LENGERR,
         ST    R6,FABUWORD
         USING BIMAREA,R6
         ST    R10,GPR10
         BAL   R10,KRMKOPNS      INITIALIZE WORK AREA
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL9'ATT $USR.'
         EXEC CICS ASSIGN USERID(LINED+9)
         MVI   LINED+13,C' '
         MVC   LINED+14(242),LINED+13
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL6'PURGE '
         MVC   LINED+6(8),FABFUID
         MVI   LINED+14,C' '
         MVC   LINED+15(241),LINED+14
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         MVC   LINED,BIMDEFN
         MVC   LINED+6(8),FABFUID
         MVI   LINED+44,C' '
         MVC   LINED+45(211),LINED+44
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         L     R10,GPR10
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL4'EDIT'
         MVI   LINED+4,C' '
         MVC   LINED+5(251),LINED+4
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         MVC   LINED,=CL7'INSERTF'
         MVI   LINED+7,C' '
         MVC   LINED+8(248),LINED+7
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         L     R10,GPR10
         B     KRMK0999
         DC    C'KRMK0185'             - EYECATCHER
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* READ A RECORD                                                       *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0200 DS    0H
         L     R7,FDBBUFF
         USING XBUF,R7
         ST    R10,GPR10
         MVC   STATUS,=C'  '
         MVI   LINED,C' '
         MVC   LINED+1(255),LINED
         MVC   LINEL,=H'132'
         BAL   R10,KRMK08RC
         L     R10,GPR10
         CLC   STATUS,=C'EF'     LAST LINE?
         BE    KRMK0201
         CLC   STATUS,=C'OK'     LAST LINE?
         BNE   KRMK0900
         MVC   XDATA(132),LINED
         LH    R5,LINEL
         STH   R5,FABNORD
         B     KRMK0999
         DC    C'KRMK0200'             - EYECATCHER
KRMK0201 DS    0H
         MVI   FABRESP,X'01'
         B     KRMK0999
         DC    C'KRMK0201'             - EYECATCHER
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* DELETE A FILE                                                       *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0220 DS    0H
         B     KRMK0999
         DC    C'KRMK0220'             - EYECATCHER
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* WRITE A RECORD                                                      *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0250 DS    0H
         L     R7,FDBBUFF
         USING XBUF,R7
         LA    R5,256
         CH    R5,FABNORD          TOO LARGE FOR BIM
         BL    KRMK0251
         MVC   LINED(256),XDATA
         LH    R5,FABNORD
         STH   R5,LINEL
         ST    R10,GPR10
         BAL   R10,KRMK08SD
         L     R10,GPR10
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         B     KRMK0999
         DC    C'KRMK0250'             - EYECATCHER
KRMK0251 DS    0H
         MVI   FABRESP,X'88'
         B     KRMK0999
         DC    C'KRMK0251'             - EYECATCHER
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* CLOSE THE FILE                                                      *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0300 DS    0H
         CLI   FABIOF,X'01'          - IS THIS AN OUTPUT FILE?
         BNE   KRMK0301                ...NO, SKIP FILE SAVE
         MVC   LINED(256),C' '
         MVC   LINEL,=H'80'
         MVC   STATUS,=CL2'EF'
         ST    R10,GPR10
         BAL   R10,KRMK08SD
         MVC   LINED,=CL4'SAVE'
         MVI   LINED+4,C' '
         MVC   LINED+5(251),LINED+4
         MVC   LINEL,=H'80'
         BAL   R10,KRMK08SD
         BAL   R10,KRMK08RC
         L     R10,GPR10
         CLC   STATUS,=C'OK'
         BNE   KRMK0900
         B     KRMK0301
         DC    C'KRMK0300'             - EYECATCHER
KRMK0301 DS    0H
*        CALL  BIUAPCL,(LINED,LINEL,STATUS,WORKAREA)
         L     R15,=V(BIUAPCL)
         BAL   R14,KRMKCALL
         L     R13,CSASAVE       RESTORE CSA REGISTER
         CLC   STATUS,=C'OK'     RESPONSE OK?
         BNE   KRMK0900          IF NOT, BRANCH TO ERR LOGIC
         EXEC CICS FREEMAIN DATA(0(,R6)),
         B     KRMK0999
         DC    C'KRMK0301'             - EYECATCHER
KRMKCALL DS    0H
         ST    R13,CSASAVE
         LA    R13,REGSAVE
         LA    R1,PARM
         BR    R15
KRMK08RC DS    0H
*        CALL  BIUAPRC,(LINED,LINEL,STATUS,WORKAREA)
         L     R15,=V(BIUAPRC)
         BAL   R14,KRMKCALL
         L     R13,CSASAVE       RESTORE CSA REGISTER
         CLC   STATUS,=C'XP'
         BE    KRMK0900
         CLC   STATUS,=C'EF'
         BER   R10
         BR    R10
KRMK08SD DS    0H
*        CALL  BIUAPSD,(LINED,LINEL,STATUS,WORKAREA)
         L     R15,=V(BIUAPSD)
         BAL   R14,KRMKCALL
         L     R13,CSASAVE       RESTORE CSA REGISTER
         CLC   STATUS,=C'XP'
         BE    KRMK0900
         BR    R10
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* SAY WE GOT AN ERROR                                                 *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
KRMK0900 DS    0H
         MVC   FABRESP(2),STATUS
KRMK0999 DS    0H
         EXEC CICS RETURN
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* CONSTANTS AND STORAGE                                               *
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
         DC    C'KERMBIM LITRALS'
BIMDEFN  DC    CL44'DEF   XXXXXXXX,DATA,UPLOAD,CASE=M,ZONE=1-132'
         LTORG
         DFHEIRET
         DFHEISTG
         DFHEIEND
         END
