* 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