TCP/IP Programming Examples › COBOL Examples › COBOL TCP/IP Generic Listener Server Program
COBOL TCP/IP Generic Listener Server Program
RETRIEVAL
NO-ACTIVITY-LOG
DMLIST
*****************************************************************
The following program is an example of a TCP/IP generic *
listener server program written in COBOL. *
The processing is the following: *
- read a message from the client (first 4 bytes = data length)*
- send the message back to the client program *
- if the message text is equal to "STOP" or if the connection *
is closed, then it closes its socket and return to the *
generic listener service. *
- if the message text is not equal to "STOP", then it returns *
to the generic listener service without closing its socket. *
*****************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. COBLIS.
ENVIRONMENT DIVISION.
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS IDMS-DC DEBUG
IDMS-RECORDS MANUAL.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 COPY IDMS SUBSCHEMA-CTRL.
01 COPY IDMS RECORD SOCKET-CALL-INTERFACE.
01 MSG01 PIC X(20) VALUE ' Parameter string :'.
01 MSG02 PIC X(20) VALUE ' Socket descriptor :'.
01 MSG03 PIC X(20) VALUE ' Resume count :'.
01 MSG04 PIC X(15) VALUE ' Starting read.'.
01 MSG05 PIC X(16) VALUE ' Starting write.'.
01 MSG06 PIC X(16) VALUE ' Closing socket.'.
01 MSG07 PIC X(20) VALUE ' Socket return code:'.
01 MSG08 PIC X(20) VALUE ' Socket reason code:'.
01 MSG09 PIC X(20) VALUE ' Socket errno :'.
01 MSG10 PIC X(20) VALUE ' Buffer length :'.
01 MSG11 PIC X(08) VALUE ' Buffer:'.
01 MSG12 PIC X(22) VALUE ' Data length too long.'.
01 RETLEN PIC S9(8) COMP.
01 WK-LENGTH PIC S9(8) COMP.
01 WK-SUBSCRIPT PIC S9(4) COMP.
01 TERM-FLAG PIC S9(8) COMP VALUE 0.
01 BUFFER.
03 BUFFER-ARRAY PIC X(1) OCCURS 84 TIMES.
01 BUFFER-REDEF REDEFINES BUFFER.
03 BUFLEN PIC 9(8) COMP.
03 BUFTXT80 PIC X(80).
03 BUFTXT80-REDEF REDEFINES BUFTXT80.
05 BUFTXT04 PIC X(4).
05 BUFTXT76 PIC X(76).
01 WORKW.
03 WORK-WCC PIC X.
03 WORK PIC X(80).
LINKAGE SECTION.
*****************************************************************
Parameter list with which a listener program receives control *
*****************************************************************
01 SOCKET-PARMS PIC X(80).
01 SOCKET-DESCRIPTOR PIC S9(8) COMP.
01 SOCKET-RESUME-COUNT PIC S9(8) COMP.
PROCEDURE DIVISION USING SOCKET-PARMS,
SOCKET-DESCRIPTOR,
SOCKET-RESUME-COUNT.
*****************************************************************
Display the 3 input parameters *
*****************************************************************
TCP-START.
*****************************************************************
Read the first 4 bytes: will contain the remaining length *
*****************************************************************
MOVE 4 TO WK-LENGTH.
MOVE 0 TO BUFLEN.
MOVE 1 TO WK-SUBSCRIPT.
PERFORM TCP-READ THRU TCP-READ-EXIT.
IF TERM-FLAG = 1 GO TO TCP-EXIT.
*****************************************************************
Read the remaining data (maximum 80 characters are allowed) *
*****************************************************************
IF BUFLEN GREATER THAN 80
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG12 LENGTH 22
PERFORM TCP-CLOSE THRU TCP-CLOSE-EXIT
GO TO TCP-EXIT.
MOVE BUFLEN TO WK-LENGTH.
MOVE 5 TO WK-SUBSCRIPT.
PERFORM TCP-READ THRU TCP-READ-EXIT.
IF TERM-FLAG = 1 GO TO TCP-EXIT.
MOVE BUFLEN TO WORK.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG10 LENGTH 20
FROM WORKW LENGTH 9.
MOVE BUFTXT80 TO WORK.
MOVE BUFLEN TO WK-LENGTH.
ADD 1 TO WK-LENGTH.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG11 LENGTH 8
FROM WORKW LENGTH WK-LENGTH.
*****************************************************************
Send the message back to the client *
*****************************************************************
MOVE BUFLEN TO WK-LENGTH.
ADD 4 TO WK-LENGTH.
MOVE 1 TO WK-SUBSCRIPT.
PERFORM TCP-WRITE THRU TCP-WRITE-EXIT.
IF BUFLEN = 4 AND BUFTXT04 = 'STOP'
PERFORM TCP-CLOSE THRU TCP-CLOSE-EXIT.
TCP-EXIT.
GOBACK.
*****************************************************************
Procedure to read a message from the client *
*****************************************************************
TCP-READ.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG04 LENGTH 15.
PERFORM UNTIL WK-LENGTH = 0
CALL 'IDMSOCKI' USING SOCKET-FUNCTION-READ,
SOCKET-RETCD,
SOCKET-ERRNO,
SOCKET-RSNCD,
SOCKET-DESCRIPTOR,
BUFFER-ARRAY(WK-SUBSCRIPT),
WK-LENGTH,
RETLEN
MOVE SOCKET-RETCD TO WORK
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG07 LENGTH 20
FROM WORKW LENGTH 9
IF SOCKET-RETCD NOT = 0 OR RETLEN = 0
PERFORM TCP-ERROR THRU TCP-ERROR-EXIT
GO TO TCP-READ-EXIT
END-IF
ADD RETLEN TO WK-SUBSCRIPT
SUBTRACT RETLEN FROM WK-LENGTH
END-PERFORM.
TCP-READ-EXIT.
EXIT.
*****************************************************************
Procedure to send a message to the client *
*****************************************************************
TCP-WRITE.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG05 LENGTH 16.
PERFORM UNTIL WK-LENGTH = 0
CALL 'IDMSOCKI' USING SOCKET-FUNCTION-WRITE,
SOCKET-RETCD,
SOCKET-ERRNO,
SOCKET-RSNCD,
SOCKET-DESCRIPTOR,
BUFFER-ARRAY(WK-SUBSCRIPT),
WK-LENGTH,
RETLEN
MOVE SOCKET-RETCD TO WORK
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG07 LENGTH 20
FROM WORKW LENGTH 9
IF SOCKET-RETCD NOT = 0 OR RETLEN = 0
PERFORM TCP-ERROR THRU TCP-ERROR-EXIT
GO TO TCP-WRITE-EXIT
END-IF
ADD RETLEN TO WK-SUBSCRIPT
SUBTRACT RETLEN FROM WK-LENGTH
END-PERFORM.
TCP-WRITE-EXIT.
EXIT.
*****************************************************************
Procedure to close the socket *
*****************************************************************
TCP-CLOSE.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG06 LENGTH 16.
CALL 'IDMSOCKI' USING SOCKET-FUNCTION-CLOSE,
SOCKET-RETCD,
SOCKET-ERRNO,
SOCKET-RSNCD,
SOCKET-DESCRIPTOR.
MOVE SOCKET-RETCD TO WORK.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG07 LENGTH 20
FROM WORKW LENGTH 9.
TCP-CLOSE-EXIT.
EXIT.
*****************************************************************
Procedure to process the socket call errors *
*****************************************************************
TCP-ERROR.
MOVE SOCKET-RSNCD TO WORK.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG08 LENGTH 20
FROM WORKW LENGTH 9.
MOVE SOCKET-ERRNO TO WORK.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG09 LENGTH 20
FROM WORKW LENGTH 9.
MOVE RETLEN TO WORK.
WRITE LOG MESSAGE ID 9060300
PARMS FROM MSG10 LENGTH 20
FROM WORKW LENGTH 9.
PERFORM TCP-CLOSE THRU TCP-CLOSE-EXIT.
MOVE 1 TO TERM-FLAG.
TCP-ERROR-EXIT.
EXIT.
*****************************************************************
COPY IDMS IDMS-STATUS.
IDMS-ABORT SECTION.
IDMS-ABORT-EXIT.
EXIT.
Copyright © 2014 CA.
All rights reserved.
|
|