home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
deleteme.tar.gz
/
deleteme.tar
/
ikxbim.asm
< prev
next >
Wrap
Assembly Source File
|
1993-10-28
|
15KB
|
384 lines
* 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