|
Do you have source some source that you want to share? Is there some source that you want to see posted here? If so, Contact Us and we'll be more than happy to help. |
Hdebug
*---------------------------------------------------------------*
* *
* CRTBNDRPG PGM(SOCKET/MAIN1) SRCFILE(SOCKET/RPG) DFTACTGRP(*NO)*
* *
* Program - MAIN1 *
* Main server program example *
* *
* Revisions *
* Date Pgmr Revision *
* *
*---------------------------------------------------------------*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
*
* Prototypes...
*
* socket() -------------------------------------------------------
D Socket PR 10I 0 ExtProc('socket')
D prSockFam 10I 0 Value
D prAddrType 10I 0 Value
D prProtocol 10I 0 Value
*
* bind() ---------------------------------------------------------
D Bind PR 10I 0 ExtProc('bind')
D prBindSock 10I 0 Value
D prBindSA * Value
D prBindSize 10I 0 Value
*
* listen() -------------------------------------------------------
D Listen PR 10I 0 ExtProc('listen')
D prListenSD 10I 0 Value
D prListenBL 10I 0 Value
*
* accept() -------------------------------------------------------
D Accept PR 10I 0 ExtProc('accept')
D prAcceptSD 10I 0 Value
D prAcceptSA * Value
D prAcceptSz * Value
*
* read() -------------------------------------------------------
D ReadSock PR 10I 0 ExtProc('read')
D prReadSD 10I 0 Value
D prReadBuf * Value
D prReadSize 10I 0 Value
*
* write() ------------------------------------------------------
D WriteSock PR 10I 0 ExtProc('write')
D prWriteSD 10I 0 Value
D prWriteBuf * Value
D prWriteSiz 10I 0 Value
*
* close() --------------------------------------------------------
D Close PR 10I 0 ExtProc('close')
D prSockDesc 10I 0 Value
*
* setsockopt() ---------------------------------------------------
D SetSock PR 10I 0 ExtProc('setsockopt')
D prSetDesc 10I 0 Value
D prSetLevel 10I 0 Value
D prSetOption 10I 0 Value
D prSetValue * Value
D prSetLength 10I 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 PORT S 5u 0 Inz(27850)
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 stream...
D #BufferIDS DS
D #BufferI 1 1024a Dim(1024)
D #sBufferI 1 1024a
*
* #BufferWDS - Incoming request string - work fields
D #BufferWDS DS
D #sWork1024 1 1024a
D #Test 1 4a
*
* #BufferODS - outgoing request string and stream...
D #BufferODS DS
D #BufferO 1 1024a Dim(1024)
D #sBufferO 1 1024a
*
* #PortDS - Port number used...
D #PortDS DS
D #PortA 5
D #PortN 5 0 Inz(0) Overlay(#PortA)
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* DALock - Data area used to prevent multiple submits...
D DALock DS 128 DtaAra
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
* Standalone work fields...
*
D #BufferSz S 10u 0 Inz(1024)
*
D #Cmd S 256
D #CmdLen S 15 5 Inz(256)
D #CL S 100 Dim(7) CTData
*
D #Socket1 S 9b 0 Inz(0)
D #Socket2 S 9b 0 Inz(0)
D #Socket3 S 9b 0 Inz(0)
*
D #Port S 5u 0 Inz(0)
D #uRC S 10u 0 Inz(0)
D #iRC S 9b 0 Inz(0)
D #iWork S 9b 0 Inz(0)
D #iWork2 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 #uWork S 10u 0 Inz(0)
D #sWork S 1a
D #AmtRecd S 10i 0 Inz(0)
D #Handle S 12a
*
D #UserID S 10a
D #PassWord S 10a
D #Lib S 10a
D #Pgm S 10a
*
* -- Place password encryptian structure here, if desired...
* ---------------------------------------------------------------
* Check for subsystem shutdown...
C ShtDn 90
C DoW *In90 = *Off
*
C If #Test <> 'test' And
C #Test <> ' ' And
C #Test <> *AllX'00'
* 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 EndIf
*
* Read the request...
*
* Clear the incoming buffer string and work field...
C Eval #sBufferI = *Blanks
C Eval #sWork1024 = *Blanks
*
* Initialize counters used to control reading of stream data...
C Eval #BufferSz = 1024
C Eval #AmtRecd = 0
*
* Keep reading until 1024 bytes have been received...
C DoW #AmtRecd < 1024
*
* #uRC will contain the number of bytes read...
C Eval #uRC = ReadSock(#Socket2:
C %Addr(#BufferI):
C #BufferSz)
*
* If #uRC = 0 the client has issued a close...
C If #uRC < 1 Or #uRC > 1024
C Leave
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
*
* If #uRC = 0 the client has issued a close...
C If #uRC = 0
C Eval #iWork = Close(#Socket2)
C Eval #Test = '(ok)'
C Iter
C EndIf
*
* If #uRC > 1024 error condition exists...
C If #uRC > 1024 or #uRC < 0
C Eval #iWork = Close(#Socket2)
C Leave
C EndIf
*
* Else translate from ASCII to EBCDIC...
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sWork1024
C Parm #AtoETabl
C Parm #XLateLib
*
* If #Test = 'stop' the operator has ended the server...
C If #Test = 'stop'
C Leave
C EndIf
*
* If #Test = 'new ' the client has requested a new server job...
C If #Test = 'new '
*
* Extract the userid & password...
C Eval #UserID = %Subst(#sWork1024:16:10)
C Eval #PassWord = %Subst(#sWork1024:26:10)
C Eval #Pgm = %Subst(#sWork1024:36:10)
C Eval #Lib = %Subst(#sWork1024:46:10)
C #Pgm IfEq *Blanks
C Eval #Pgm = 'SPAWN1 '
C EndIF #Pgm
C #Lib IfEq *Blanks
C Eval #Lib = '*LIBL '
C EndIF #Lib
* Decode the encrypted userid & password here if desired...
*
*
* Check the user profile and password...
C Eval #Handle = *Allx'00'
C Call 'QSYGETPH' 77
C Parm #UserID
C Parm #PassWord
C Parm #Handle
*
* If you couldn't get a handle send 'invalid' message...
C If #Handle = *Allx'00'
C Eval #sBufferO = '(INVALID)'
*
C Else
*
* Release the profile handle...
C Call 'QSYRLSPH' 77
C Parm #Handle
*
* Create a socket descriptor...
*
C Eval #Socket3 = Socket(AF_INET:
C SOCK_STRM:
C PROTOCOL)
* Set message to 'invalid' as default...
C Eval #sBufferO = '(INVALID)'
C Eval #Port = PORT + 1
*
* Keep trying to bind to a port until you find one that's not busy...
C DoW #Port < PORT + 100
*
* Attempt to bind to the port...
*
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(#Socket3:
C %Addr(ServerAddr):
C #iWork)
* Bind OK. Move port number to outgoing buffer...
C If #iRC = 0
C Eval #iWork = Close(#Socket3)
C Eval #PortN = #Port
C Eval %Subst(#sBufferO:1:9) = #PortA + ' '
C Leave
C EndIf
*
* Couldn't bind. Get next port number...
C Eval #Port = #Port + 1
C EndDo
*
C If #sBufferO <> '(INVALID)'
*
* Submit a server job...
*
C Select
C #Test WhenEQ 'new '
C Eval #Cmd = %Trim(#CL(1)) +
C %Trim(#Lib) +
C '/' +
C %Trim(#Pgm) +
C %Trim(#CL(2)) +
C #PortA +
C %Trim(#CL(3)) +
C 'SOCK' + #PortA +
C %Trim(#CL(4)) +
C #UserID +
C %Trim(#CL(5))
C** #Test WhenEQ --something else--
**
C EndSl
*
* Submit the job...
C Call 'QCMDEXC' 77
C Parm #Cmd
C Parm #CmdLen
*
* Error submitting the job - inform client...
C If *In77 = *On
C Eval #sBufferO = '(INVALID)'
*
C Else
*
* Delay job - give the submitted job time to bind to the socket...
C Eval #Cmd = %Trim(#CL(7))
C Call 'QCMDEXC' 77
C Parm #Cmd
C Parm #CmdLen
*
C Endif
C Endif
C EndIf
*
* Write back to the client...
*
* Translate return string from EBCDIC to ASCII...
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sBufferO
C Parm #EtoATabl
C Parm #XLateLib
*
C dump
* Write...
C Eval #BufferSz = 1024
C Eval #uRC = WriteSock(#Socket2:
C %Addr(#BufferO):
C #BufferSz)
*
* Read the acknowledgement...
*
* Initialize...
C Eval #sBufferI = *Blanks
C Eval #sWork1024 = *Blanks
*
C Eval #BufferSz = 1024
C Eval #AmtRecd = 0
*
* Read until 1024 bytes are received...
C DoW #AmtRecd < 1024
C Eval #uRC = ReadSock(#Socket2:
C %Addr(#BufferI):
C #BufferSz)
*
* If #uRC = 0 the client has issued a close...
C If #uRC = 0 Or #uRC > 1024
C Leave
C EndIf
*
* Lay the bytes received into work field #sWork1024...
C Eval %Subst(#SWork1024:#AmtRecd + 1:#uRC) =
C %Subst(#sBufferI:1:#uRC)
*
C Eval #AmtRecd = #AmtRecd + #uRC
C Eval #BufferSz = 1024 - #AmtRecd
C EndDo
*
* If #uRC = 0 the client has issued a close...
C If #uRC = 0 Or #uRC > 1024
C Eval #iWork = Close(#Socket2)
C Iter
C EndIf
*
* Translate...
C Call 'QDCXLATE'
C Parm #iWork5
C Parm #sWork1024
C Parm #AtoETabl
C Parm #XLateLib
*
* Acknowledgement received...
C If #Test = '(ok)'
C Eval #iWork = Close(#Socket2)
C EndIf
*
C EndIf
*
* Test for operator shutdown...
C ShtDn 90
C EndDo
*
* Close socket...
C Eval #iWork = Close(#Socket1)
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C Eval *InLR = *On
C Return
*---------------------------------------------------------------*
C *InzSR BegSr
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
*
* Add to library list, if necessary...
C Eval #Cmd = %Trim(#CL(6))
C Call 'QCMDEXC' 77
C Parm #Cmd
C Parm #CmdLen
*
* Lock the data area so the job can only be started once...
C *Lock In DALock 77
C If *In77 = *On
C Eval *InLR = *On
C Return
C EndIf
*
* Get socket descriptor...
C Eval #Socket1 = Socket(AF_INET:
C SOCK_STRM:
C PROTOCOL)
*
* Set socket reuse option...
C Eval #sWork = '1'
C Eval #iWork = %Size(#iRC)
C Eval #iRC = SetSock(#Socket1:
C SOL_SOCK:
C SO_REUSE:
C %Addr(#sWork):
C #iWork)
*
* 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 to well-known socket...
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)
*
* Bind failed - end...
C If #iRC <> 0
C Eval #iWork = Close(#Socket1)
C Eval *InLR = *On
C Return
C EndIf
*
* Listen...
C Eval #iWork = 10
C Eval #iRC = Listen(#Socket1:
C #iWork)
*
C Eval #Test = 'inz'
*
*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
C EndSr
*---------------------------------------------------------------*
** #CL
SBMJOB CMD(CALL PGM(
) PARM('
')) JOB(
) JOBQ(*LIBL/QSYSNOMAX) USER(
) INLLIBL(*CURRENT)
ADDLIBLE LIB(QTEMP)
DLYJOB DLY(8)
|