H
*---------------------------------------------------------------*
* *
* CRTBNDRPG PGM(SOCKET/SPAWN1) SRCFILE(SOCKET/RPG) DFTACTGRP(*NO)
* *
* Program - SPAWN1 *
* Spawned server program example *
* *
* Revisions *
* Date Pgmr Revision *
* *
*---------------------------------------------------------------*
FQDDSSRC IF E Disk
F Rename(QDDSSRC:SOURCE)
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* Prototypes...
*
* socket() -------------------------------------------------------
*
* Prototypes...
D Socket PR 9b 0 ExtProc('socket')
D prSockFam 9b 0 Value
D prAddrType 9b 0 Value
D prProtocol 9b 0 Value
*
* bind() ---------------------------------------------------------
* Prototype...
D Bind PR 9b 0 ExtProc('bind')
D prBindSock 9b 0 Value
D prBindSA * Value
D prBindSize 9b 0 Value
*
* listen() -------------------------------------------------------
D Listen PR 9b 0 ExtProc('listen')
D prListenSD 9b 0 Value
D prListenBL 9b 0 Value
*
* accept() -------------------------------------------------------
D Accept PR 9b 0 ExtProc('accept')
D prAcceptSD 9b 0 Value
D prAcceptSA * Value
D prAcceptSz * Value
*
* read() -------------------------------------------------------
D ReadSock PR 10u 0 ExtProc('read')
D prReadSD 9b 0 Value
D prReadBuf * Value
D prReadSize 10u 0 Value
*
* write() ------------------------------------------------------
D WriteSock PR 10u 0 ExtProc('write')
D prWriteSD 9b 0 Value
D prWriteBuf * Value
D prWriteSiz 10u 0 Value
*
* close() --------------------------------------------------------
D Close PR 9b 0 ExtProc('close')
D prSockDesc 9b 0 Value
*
* setsockopt() ---------------------------------------------------
D SetSock PR 9b 0 ExtProc('setsockopt')
D prSetDesc 9b 0 Value
D prSetLevel 9b 0 Value
D prSetOption 9b 0 Value
D prSetValue * Value
D prSetLength 9b 0 Value
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* Symbolic values...
*
D AF_INET S 9b 0 Inz(2)
D SOCK_STRM S 9b 0 Inz(1)
D PROTOCOL S 9b 0 Inz(0)
D SOL_SOCK S 9b 0 Inz(-1)
D SO_REUSE S 9b 0 Inz(55)
D SO_LINGER S 9b 0 Inz(30)
D IPPROTO S 9b 0 Inz(6)
D TCP_NODLY S 9b 0 Inz(10)
D INADDR_ANY S 10u 0 Inz(0)
D NULL S 1 Inz(X'00')
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* Structures for interfacing with the sockets API...
* SockAddr - Used by 'accept'
* Specifies the IP family, port and IP address
D SockAddr DS
D sa_family 5i 0 Inz(0)
D sa_port 5u 0 Inz(0)
D sa_addr 10u 0 Inz(0)
D sa_zero 1a Dim(8) Inz(X'00')
*
* ServerAddr - Used by 'bind'
* Specifies the IP family, port and IP address
D ServerAddr DS
D sin_family 5i 0 Inz(0)
D sin_port 5u 0 Inz(0)
D sin_addr 10u 0 Inz(0)
D sin_zero 1a Dim(8) Inz(X'00')
*
* #BufferIDS - Incoming request string and stream...
D #BufferIDS DS
D #BufferI 1 1024a Dim(1024)
D #sBufferI 1 1024a
*
D #RQRecord DS
D #RQData 1 1000
D #RQMsg 1001 1024
D #RQRRN 1 10 0
D #RQType 11 11
D #Test 1 4
*
* #BufferODS - outgoing request string and stream...
D #BufferODS DS
D #BufferO 1 1024a Dim(1024)
D #sBufferO 1 1024a
*
* #RSRecord is the general container for outgoing responses...
D #RSRecord DS 1024
D #RSData 1 1000
D #RSMsg 1001 1024
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* Standalone fields...
*
D #Cmd S 256
D #CmdLen S 15 5 Inz(256)
D #CL S 100 Dim(2) CTData
*
D #Socket1 S 9b 0 Inz(0)
D #Socket2 S 9b 0 Inz(0)
*
D #PortDS DS
D #PortA 5
D #PortN 5 0 Inz(0) Overlay(#PortA)
*
D #Port S 5u 0 Inz(0)
D #PortParm S 5a
D #uRC S 10u 0 Inz(0)
D #iRC S 9b 0 Inz(0)
D #iWork S 9b 0 Inz(0)
D #iWork5 S 5p 0 Inz(1024)
D #EtoATabl S 10a Inz('QASCII ')
D #AtoETabl S 10a Inz('QEBCDIC ')
D #XLateLib S 10a Inz('*LIBL ')
D #sWork S 1a
D #BufferSz S 10u 0 Inz(1024)
D #AmtRecd S 10i 0 Inz(0)
D #Count S 5 0 Inz
D #sWork1024 S 1024a
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
*
D @MORE C Const('(MORE)')
D @END C Const('(END)')
D @OK C Const('(OK)')
D @INVALID C Const('(INVALID)')
D @ALL C Const('*ALL')
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
*
C *Entry PList
C Parm #PortParm
*
* Read the incoming request...
*
* Clear the work fields...
C Eval #sBufferI= *Blanks
C Eval #sWork1024 = *Blanks
*
* Initialize the stream data control counters...
C Eval #BufferSz = 1024
C Eval #AmtRecd = 0
*
* Keep reading until 1024 bytes have been received...
C DoW #AmtRecd < 1024
*
C Eval #uRC = ReadSock(#Socket2:
C %Addr(#BufferI):
C #BufferSz)
*
* If #uRC = 0 the client has issued a close,
* if #uRC > 1024, an error has occured...
C If #uRC < 1 Or #uRC > 1024
C ExSr #Release
C EndIf
*
* Lay the bytes received into work field #sWork1024...
C Eval %Subst(#SWork1024:#AmtRecd + 1:#uRC) =
C %Subst(#sBufferI:1:#uRC)
*
* Increase the number of bytes received...
C Eval #AmtRecd = #AmtRecd + #uRC
* Decrease the number of bytes needed to reach 1024...
C Eval #BufferSz = 1024 - #AmtRecd
C EndDo
*
* Translate ASCII to EBCDIC...
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sWork1024
C Parm #AtoETabl
C Parm #XLateLib
*
C Eval #RQRecord = #sWork1024
*
C DoW #RQMsg <> @END
*
* Requested data types . . .
C Select
* Get all example records...
C When #RQType = 'A'
C ExSR ASubr
* Get one example...
C When #RQType = 'S'
C ExSR SSubr
C EndSL
*
C ExSr #Write
*
C EndDo
*
* Request to end received . . .
C ExSr #Release
*
*---------------------------------------------------------------*
C #Write BegSr
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* Write subroutine . . .
*
* Write to the client...
C If #test <> 'test'
C Eval #sBufferO = #RSRecord
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sBufferO
C Parm #EtoATabl
C Parm #XLateLib
*
C Eval #BufferSz = 1024
C Eval #uRC = WriteSock(#Socket2:
C %Addr(#BufferO):
C #BufferSz)
*
C Clear #RSData
C Clear #RSMsg
*
C EndIf
* Read . . .
C Eval #sBufferI = *Blanks
C Eval #sWork1024 = *Blanks
*
C Eval #BufferSz = 1024
C Eval #AmtRecd = 0
*
C DoW #AmtRecd < 1024
C Eval #uRC = ReadSock(#Socket2:
C %Addr(#BufferI):
C #BufferSz)
*
C If #uRC < 1
C ExSr #Release
C EndIf
*
C Eval %Subst(#SWork1024:#AmtRecd + 1:#uRC) =
C %Subst(#sBufferI:1:#uRC)
*
C Eval #AmtRecd = #AmtRecd + #uRC
C Eval #BufferSz = 1024 - #AmtRecd
C EndDo
*
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sWork1024
C Parm #AtoETabl
C Parm #XLateLib
*
C Eval #RqRecord = #sWork1024
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
C EndSR
*---------------------------------------------------------------*
* Get all records...
C ASubr BegSr
*
C Eval #Count = 0
*
C 1 SetLL SOURCE
C Read SOURCE 20
C DoW *In20 = *Off
C Eval %SubSt(#RSData:80 * #Count +
C 1:80) = SRCDTA
C Eval #Count = #Count + 1
C If #Count = 12
C Eval #RSMsg = @MORE
C ExSR #Write
C Eval #Count = 0
C EndIf
*
C Read SOURCE 20
C EndDo
*
C Eval #RSMsg = @END
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
C EndSR
*---------------------------------------------------------------*
C SSubr BegSR
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
* This subr gets a single record...
*
C #RQRRN Chain SOURCE 30
*
C If *In30 = *Off
C Eval %SubSt(#RSData:1:80) = SRCDTA
* Set message = "(END)"...
C Eval #RSMsg = @END
*
C Else
*
* No record found...
C Eval #RSMsg = @INVALID
*
C EndIf
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
C EndSr
*---------------------------------------------------------------*
C #Release BegSr
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
*
C Eval #iWork = Close(#Socket1)
C Eval #iWork = Close(#Socket2)
*
C Eval *InLR = *On
C Return
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
C EndSr
*---------------------------------------------------------------*
C *InzSR BegSr
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* Add QTEMP to library list if necessary...
C Eval #Cmd = %Trim(#CL(2))
C Call 'QCMDEXC' 77
C Parm #Cmd
C Parm #CmdLen
* Add to library list, if necessary...
C*** Eval #Cmd = %Trim(#CL(1))
C*** Call 'QCMDEXC' 77
C*** Parm #Cmd
C*** Parm #CmdLen
*
* Get socket descriptor...
C Eval #Socket1 = Socket(AF_INET:
C SOCK_STRM:
C PROTOCOL)
*
* Set socket buffer option...
C Eval #sWork = '1'
C Eval #iWork = %Size(#iRC)
C Eval #iRC = SetSock(#Socket1:
C IPPROTO:
C TCP_NODLY:
C %Addr(#sWork):
C #iWork)
*
* Bind...
C Eval #PortA = #PortParm
C Eval #Port = #PortN
C Eval sin_family = AF_INET
C Eval sin_addr = INADDR_ANY
C Eval sin_port = #Port
C Eval #iWork = %Size(ServerAddr)
C Eval #iRC = Bind(#Socket1:
C %Addr(ServerAddr):
C #iWork)
*
* Listen...
C Eval #iWork = 1
C Eval #iRC = Listen(#Socket1:
C #iWork)
*
* Accept a new client connection...
C Eval SockAddr = *AllX'00'
C Eval #iWork = 0
C Eval #Socket2 = Accept(#Socket1:
C %Addr(SockAddr):
C %Addr(#iWork))
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
C EndSr
*---------------------------------------------------------------*
**
ADDLIBLE LIB( )
ADDLIBLE LIB(QTEMP)
|