SET219Y
* =======================================================
* Process ........: SET_219
* Function .......: SET219Y
* Created on .....: 7th November, 2001
* Description ....: Caller Marshal
* Version.........: 1
*
* Full Description:
* This function is used on client and server systems. It
* has 2 main functions:
*
* (1). To marshal information that is to being sent
* between client and server systems in XML format.
*
* (2). To manage a general purpose symbolic name/value
* list that is used exchange information between client
* and server systems.
*
* =======================================================
* ============== D E F I N I T I O N S ================
* =======================================================
*
Function Options(*HEAVYUSAGE *DIRECT)
*
* This list stores a list of composite symbolic names.
*
* Each composite name is actually made up of the symbolic
* name (S_219NAM1 and NAM2), the type (S_219NAMT) and the
* instance (S_219NAMI) as shown by the following overlays
*
Define Field(#X_219NAMC) Reffld(#S_219NAMC)
Define Field(#X_219VROW) Reffld(#STD_NUM)
Define Field(#SYM_FOUND) Type(*CHAR) Length(001)
Def_Cond Name(*SYM_FOUND) Cond('#SYM_FOUND = Y')
Define Field(#SYM_ORDER) Type(*CHAR) Length(001)
Def_List Name(#SYM_NAME) Fields(#X_219NAMC #X_219VROW) Type(*WORKING) Entrys(0009999)
*
Override Field(#S_219NAM1) To_Overlay(#S_219NAMC 001)
Override Field(#S_219NAM2) To_Overlay(#S_219NAMC 011)
Override Field(#S_219NAMT) To_Overlay(#S_219NAMC 021)
Override Field(#S_219NAMI) To_Overlay(#S_219NAMC 022)
*
* This list stores the values associated with each
* composite symbolic name in list #SYN_NAME.
*
* When the symbolic name is alphanumeric (#S_219NAMT = A)
* the value is in S_219AVAL. When the symbolic value
* is numeric (#S_219NAMT = N) the numeric value is
* defined by #S_219NDIG + #S_219NDEC as a positive
* value. The sign in #S_219NSGN needs to be applied.
*
Define Field(#X_219AVAL) Reffld(#S_219AVAL)
Define Field(#SYM_COUNT) Reffld(#STD_NUM)
Def_List Name(#SYM_VALUE) Fields(#X_219AVAL) Counter(#SYM_COUNT) Type(*WORKING) Entrys(0009999)
*
Define Field(#EXCH_NUMB) Reffld(#S_219AVAL)
Override Field(#S_219NSGN) To_Overlay(#EXCH_NUMB 001)
Override Field(#S_219NDIG) To_Overlay(#EXCH_NUMB 002)
Override Field(#S_219NDEC) To_Overlay(#EXCH_NUMB 023)
Change Field(#S_219NSGN #S_219NDIG #S_219NDEC) To(*NULL)
*
* This list is used exchange messages
*
Define Field(#MESSCOUNT) Reffld(#STD_NUM)
Def_List Name(#SYM_MESS) Fields(#S_219MSGT) Counter(#MESSCOUNT) Type(*WORKING) Entrys(0009999)
*
* Other field definitions
*
Define Field(#JSM_OPEN) Type(*CHAR) Length(001) Desc('JSM is currently open and loaded') Default(N)
Define Field(#RETCODE) Type(*CHAR) Length(002) Desc('Standard char(2) Return Code')
*
* =======================================================
* ================ M A I N L O G I C ===============
* =======================================================
*
* The caller must exchange field #S_219OPER into this
* function to tell it what is to be done ....
*
Case Of_Field(#S_219OPER)
When Value_Is('= CLEAR')
Execute Subroutine(CLEAR)
When Value_Is('= SETALP')
Execute Subroutine(SETALP)
When Value_Is('= SETNUM')
Execute Subroutine(SETNUM)
When Value_Is('= GETALP')
Execute Subroutine(GETALP)
When Value_Is('= GETNUM')
Execute Subroutine(GETNUM)
When Value_Is('= CLIENTCALL')
Execute Subroutine(CLIENTCALL)
When Value_Is('= OPEN')
Execute Subroutine(OPEN)
When Value_Is('= CLOSE')
Execute Subroutine(CLOSE)
When Value_Is('= SEND')
Execute Subroutine(SEND)
When Value_Is('= RECEIVE')
Execute Subroutine(RECEIVE)
When Value_Is('= ADDMSGQ')
Execute Subroutine(ADDMSGQ)
Otherwise
Abort Msgtxt('SET219Y - Unknown operation requested in field #S_219OPER')
Endcase
*
* Finished ... return control to caller
*
Return
*
* =======================================================
* ============== S U B R O U T I N E S ==============
* =======================================================
*
* -------------------------------------------------------
* Handle a "CLEAR" request
* -------------------------------------------------------
Subroutine Name(CLEAR)
Clr_List Named(#SYM_NAME)
Clr_List Named(#SYM_VALUE)
Change Field(#SYM_ORDER) To(N)
Endroutine
* -------------------------------------------------------
* Handle a "SETALP" request
* -------------------------------------------------------
Subroutine Name(SETALP)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(A)
* Create new entries in the #SYM_NAME & #SYM_VALUE lists
Change Field(#X_219NAMC) To(#S_219NAMC)
Change Field(#X_219VROW) To('#SYM_COUNT + 1')
Change Field(#SYM_ORDER) To(N)
Add_Entry To_List(#SYM_NAME)
Change Field(#X_219AVAL) To(#S_219AVAL)
Add_Entry To_List(#SYM_VALUE)
Endroutine
* -------------------------------------------------------
* Handle a "SETNUM" request
* -------------------------------------------------------
Subroutine Name(SETNUM)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(N)
* Build up the numeric value in exchange format
Change Field(#EXCH_NUMB) To(*NULL)
If Cond('#S_219NVAL >= 0')
Change Field(#S_219NSGN) To(P)
Else
Change Field(#S_219NSGN) To(N)
Change Field(#S_219NVAL) To('0 - #S_219NVAL')
Endif
Change Field(#S_219NDIG) To(#S_219NVAL)
Change Field(#S_219NDEC) To(#S_219NVAL)
* Create new entries in the #SYM_NAME & #SYM_VALUE lists
Change Field(#X_219NAMC) To(#S_219NAMC)
Change Field(#X_219VROW) To('#SYM_COUNT + 1')
Change Field(#SYM_ORDER) To(N)
Add_Entry To_List(#SYM_NAME)
Change Field(#X_219AVAL) To(#EXCH_NUMB)
Add_Entry To_List(#SYM_VALUE)
Endroutine
* -------------------------------------------------------
* Handle a "GETALP" request
* -------------------------------------------------------
Subroutine Name(GETALP)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(A)
* See if it already exists
Execute Subroutine(LOCATE) With_Parms(#S_219NAMC)
* If it was found return the value
If Cond(*SYM_FOUND)
Change Field(#S_219AVAL) To(#X_219AVAL)
Exchange Fields(#S_219AVAL)
Endif
Endroutine
* -------------------------------------------------------
* Handle a "GETNUM" request
* -------------------------------------------------------
Subroutine Name(GETNUM)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(N)
* See if it already exists
Execute Subroutine(LOCATE) With_Parms(#S_219NAMC)
* If it was found return the value
If Cond(*SYM_FOUND)
Change Field(#EXCH_NUMB) To(#X_219AVAL)
Change Field(#S_219NVAL) To('#S_219NDIG + #S_219NDEC')
If Cond('#S_219NSGN = N')
Change Field(#S_219NVAL) To('0 - #S_219NVAL')
Endif
Exchange Fields(#S_219NVAL)
Endif
Endroutine
* -------------------------------------------------------
* Handle an internal request to locate a symbolic name
* -------------------------------------------------------
Subroutine Name(LOCATE) Parms((#K_219NAMC *RECEIVED))
Define Field(#K_219NAMC) Reffld(#S_219NAMC)
Define Field(#BOTTOM) Reffld(#STD_NUM)
Define Field(#TOP) Reffld(#STD_NUM)
Define Field(#MID) Reffld(#STD_NUM)
*
* (Re)Sort the name list (if required)
*
If Cond('#SYM_ORDER *NE Y')
Sort_List Named(#SYM_NAME) By_Fields(#X_219NAMC)
Change Field(#SYM_ORDER) To(Y)
Endif
*
* Now use a binary chop to locate the entry
*
Change Field(#SYM_FOUND) To(N)
Change Field(#BOTTOM) To(1)
Change Field(#TOP) To(#SYM_COUNT)
*
Dowhile Cond('#TOP >= #BOTTOM')
Change Field(#MID) To('(#TOP + #BOTTOM) / 2')
Get_Entry Number(#MID) From_List(#SYM_NAME)
Leave If('#IO$STS *NE OK')
If Cond('#K_219NAMC = #X_219NAMC')
Change Field(#SYM_FOUND) To(Y)
Leave
Else
If Cond('#K_219NAMC > #X_219NAMC')
Change Field(#BOTTOM) To('#MID + 1')
Else
Change Field(#TOP) To('#MID - 1')
Endif
Endif
Endwhile
*
* Get the associated value entry if the name was found
*
If Cond(*SYM_FOUND)
Get_Entry Number(#X_219VROW) From_List(#SYM_VALUE)
Endif
*
Endroutine
* -------------------------------------------------------
* Use SET_ALPHA to set an alphanumeric value
* -------------------------------------------------------
Subroutine Name(SET_ALPHA) Parms((#S_219NAM1 *RECEIVED) (#S_219NAM2 *RECEIVED) (#S_219NAMI *RECEIVED) (#S_219AVAL *RECEIVED))
Execute Subroutine(SETALP)
Endroutine
* -------------------------------------------------------
* Handle an "ADDMSGQ" request
* -------------------------------------------------------
Subroutine Name(ADDMSGQ)
*
* Add a message to the message list
*
Add_Entry To_List(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "CLIENTCALL" request
* -------------------------------------------------------
Subroutine Name(CLIENTCALL)
*
* Insert the name of the function to be called
* into the list of values using the special
* symbolic name =FUNCTION=. See SET219Z for details
* of how this is used by the server system.
*
Execute Subroutine(SET_ALPHA) With_Parms('=FUNCTION=' *BLANKS 1 #S_219FUNC)
*
* Now send the list details to the remote server
*
Execute Subroutine(SEND)
*
* Get the results back again from the server
*
Execute Subroutine(RECEIVE)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "SEND" request
* -------------------------------------------------------
Subroutine Name(SEND)
Def_Cond Name(*TO_SERVER) Cond('#S_219HOST *ne ''=CALLER=''')
Define Field(#U_HANDLER) Type(*CHAR) Length(004) Desc('JSM Handler to be used')
*
* Open the JSM connection and load the HTTP client
* service (if it is not already loaded and ready)
*
Execute Subroutine(OPEN)
*
* The host name is in S_219HOST. If it is '=CALLER='
* then the send is from a server back to the client
* otherwise the send is from a client to the server
* and S_219HOST contains the host URL details.
*
* Decide on which handler to use
*
If Cond(*TO_SERVER)
Change Field(#U_HANDLER) To(OXML)
Else
Change Field(#U_HANDLER) To(IXML)
Endif
*
* Send the #SYM_NAME list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_NAMES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219NAMC,X_219VROW')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT NAMESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_NAME)
Execute Subroutine(CHECK_STS)
*
* Send the #SYM_VALUE list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_VALUES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219AVAL')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT VALUESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_VALUE)
Execute Subroutine(CHECK_STS)
*
* Send the #SYM_MESS list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_MESSAGES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'S_219MSGT')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT MESSAGESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_MESS)
Execute Subroutine(CHECK_STS)
*
* Now send the whole lot
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_NAMEVALUEMSG')
Execute Subroutine(ADDKEYWORD) With_Parms(METHOD '*POST')
If Cond(*TO_SERVER)
Execute Subroutine(ADDKEYWORD) With_Parms(HOST #S_219HOST)
Execute Subroutine(ADDKEYWORD) With_Parms(URI '/cgi-bin/jsmdirect?set219_remote_service')
Endif
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Clear this programs message queue and the message
* list as we have routed all the messages now
*
Clr_List Named(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "RECEIVE" request
* -------------------------------------------------------
Subroutine Name(RECEIVE)
*
* Open the JSM connection and load the HTTP client
* service (if it is not already loaded and ready)
*
Execute Subroutine(OPEN)
*
* Clear all the lists ready to get their values back
*
Execute Subroutine(CLEAR)
*
* Receive the names list #SYM_NAME
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_NAMES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219NAMC,X_219VROW')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_NAME)
Execute Subroutine(CHECK_STS)
*
* Receive the values list #SYM_VALUE
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_VALUES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219AVAL')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_VALUE)
Execute Subroutine(CHECK_STS)
*
* Receive the messages list #SYM_MESS
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_MESSAGES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'S_219MSGT')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_MESS)
Execute Subroutine(CHECK_STS)
*
* The lists may be out of order now
*
Change Field(#SYM_ORDER) To(N)
*
* (Re)Issue any messages received back in the #SYM_MESS
* list onto this program's message queue. These will end
* up on the callers message queue. This way the messages
* have seamlessly crossed between the systems
*
Selectlist Named(#SYM_MESS)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#S_219MSGT)
Endselect
*
* Now clear the message list as we have finished with it
*
Clr_List Named(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "OPEN" request
* -------------------------------------------------------
Subroutine Name(OPEN)
*
* Open the JSM if required ....
*
If Cond('#JSM_OPEN *NE Y')
*
* Open the JSM
*
Use Builtin(JSM_OPEN) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Load the HTTP Client service
*
Execute Subroutine(NEWCOMMAND) With_Parms('SERVICE_LOAD')
Execute Subroutine(ADDKEYWORD) With_Parms(SERVICE HTTPCLIENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Flag as now open
*
Change Field(#JSM_OPEN) To(Y)
Endif
*
Endroutine
* -------------------------------------------------------
* Handle a "CLOSE" request
* -------------------------------------------------------
Subroutine Name(CLOSE)
*
* Close the JSM if required ....
*
If Cond('#JSM_OPEN = Y')
*
* Close the JSM. Note that the HTTPClient service
* is specifically not unloaded
*
Use Builtin(JSM_CLOSE) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Flag as now closed
*
Change Field(#JSM_OPEN) To(N)
Endif
*
* Clear all lists
*
Execute Subroutine(CLEAR)
Endroutine
* -------------------------------------------------------
* Start a new JSM command
* -------------------------------------------------------
Subroutine Name(NEWCOMMAND) Parms((#STD_TEXTS *RECEIVED))
Change Field(#S_JSMCMD) To(#STD_TEXTS)
Endroutine
* -------------------------------------------------------
* Add a JSM keyword to a JSM command
* -------------------------------------------------------
Subroutine Name(ADDKEYWORD) Parms(#KEYWORD #KEYW_VAL1)
Define Field(#KEYWORD) Reffld(#STD_TEXT)
Define Field(#KEYW_VAL1) Reffld(#STD_TEXTL)
Use Builtin(BCONCAT) With_Args(#S_JSMCMD #KEYWORD) To_Get(#S_JSMCMD)
Use Builtin(TCONCAT) With_Args(#S_JSMCMD '(' #KEYW_VAL1 ')') To_Get(#S_JSMCMD)
Endroutine
* -------------------------------------------------------
* Check status of last JSM call made
* -------------------------------------------------------
Subroutine Name(CHECK_STS)
Define Field(#MSGDTA) Type(*CHAR) Length(132)
If Cond('#S_JSMSTS *NE OK')
Use Builtin(BCONCAT) With_Args('Error Status Code: ' #S_JSMSTS) To_Get(#MSGDTA)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Use Builtin(BCONCAT) With_Args('Error Message: ' #S_JSMMSG) To_Get(#MSGDTA)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Use Builtin(BCONCAT) With_Args(*FUNCTION 'ended in error. Review previous messages.') To_Get(#MSGDTA)
Abort Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Endif
Endroutine
* =======================================================
* Process ........: SET_219
* Function .......: SET219Y
* Created on .....: 7th November, 2001
* Description ....: Caller Marshal
* Version.........: 1
*
* Full Description:
* This function is used on client and server systems. It
* has 2 main functions:
*
* (1). To marshal information that is to being sent
* between client and server systems in XML format.
*
* (2). To manage a general purpose symbolic name/value
* list that is used exchange information between client
* and server systems.
*
* =======================================================
* ============== D E F I N I T I O N S ================
* =======================================================
*
Function Options(*HEAVYUSAGE *DIRECT)
*
* This list stores a list of composite symbolic names.
*
* Each composite name is actually made up of the symbolic
* name (S_219NAM1 and NAM2), the type (S_219NAMT) and the
* instance (S_219NAMI) as shown by the following overlays
*
Define Field(#X_219NAMC) Reffld(#S_219NAMC)
Define Field(#X_219VROW) Reffld(#STD_NUM)
Define Field(#SYM_FOUND) Type(*CHAR) Length(001)
Def_Cond Name(*SYM_FOUND) Cond('#SYM_FOUND = Y')
Define Field(#SYM_ORDER) Type(*CHAR) Length(001)
Def_List Name(#SYM_NAME) Fields(#X_219NAMC #X_219VROW) Type(*WORKING) Entrys(0009999)
*
Override Field(#S_219NAM1) To_Overlay(#S_219NAMC 001)
Override Field(#S_219NAM2) To_Overlay(#S_219NAMC 011)
Override Field(#S_219NAMT) To_Overlay(#S_219NAMC 021)
Override Field(#S_219NAMI) To_Overlay(#S_219NAMC 022)
*
* This list stores the values associated with each
* composite symbolic name in list #SYN_NAME.
*
* When the symbolic name is alphanumeric (#S_219NAMT = A)
* the value is in S_219AVAL. When the symbolic value
* is numeric (#S_219NAMT = N) the numeric value is
* defined by #S_219NDIG + #S_219NDEC as a positive
* value. The sign in #S_219NSGN needs to be applied.
*
Define Field(#X_219AVAL) Reffld(#S_219AVAL)
Define Field(#SYM_COUNT) Reffld(#STD_NUM)
Def_List Name(#SYM_VALUE) Fields(#X_219AVAL) Counter(#SYM_COUNT) Type(*WORKING) Entrys(0009999)
*
Define Field(#EXCH_NUMB) Reffld(#S_219AVAL)
Override Field(#S_219NSGN) To_Overlay(#EXCH_NUMB 001)
Override Field(#S_219NDIG) To_Overlay(#EXCH_NUMB 002)
Override Field(#S_219NDEC) To_Overlay(#EXCH_NUMB 023)
Change Field(#S_219NSGN #S_219NDIG #S_219NDEC) To(*NULL)
*
* This list is used exchange messages
*
Define Field(#MESSCOUNT) Reffld(#STD_NUM)
Def_List Name(#SYM_MESS) Fields(#S_219MSGT) Counter(#MESSCOUNT) Type(*WORKING) Entrys(0009999)
*
* Other field definitions
*
Define Field(#JSM_OPEN) Type(*CHAR) Length(001) Desc('JSM is currently open and loaded') Default(N)
Define Field(#RETCODE) Type(*CHAR) Length(002) Desc('Standard char(2) Return Code')
*
* =======================================================
* ================ M A I N L O G I C ===============
* =======================================================
*
* The caller must exchange field #S_219OPER into this
* function to tell it what is to be done ....
*
Case Of_Field(#S_219OPER)
When Value_Is('= CLEAR')
Execute Subroutine(CLEAR)
When Value_Is('= SETALP')
Execute Subroutine(SETALP)
When Value_Is('= SETNUM')
Execute Subroutine(SETNUM)
When Value_Is('= GETALP')
Execute Subroutine(GETALP)
When Value_Is('= GETNUM')
Execute Subroutine(GETNUM)
When Value_Is('= CLIENTCALL')
Execute Subroutine(CLIENTCALL)
When Value_Is('= OPEN')
Execute Subroutine(OPEN)
When Value_Is('= CLOSE')
Execute Subroutine(CLOSE)
When Value_Is('= SEND')
Execute Subroutine(SEND)
When Value_Is('= RECEIVE')
Execute Subroutine(RECEIVE)
When Value_Is('= ADDMSGQ')
Execute Subroutine(ADDMSGQ)
Otherwise
Abort Msgtxt('SET219Y - Unknown operation requested in field #S_219OPER')
Endcase
*
* Finished ... return control to caller
*
Return
*
* =======================================================
* ============== S U B R O U T I N E S ==============
* =======================================================
*
* -------------------------------------------------------
* Handle a "CLEAR" request
* -------------------------------------------------------
Subroutine Name(CLEAR)
Clr_List Named(#SYM_NAME)
Clr_List Named(#SYM_VALUE)
Change Field(#SYM_ORDER) To(N)
Endroutine
* -------------------------------------------------------
* Handle a "SETALP" request
* -------------------------------------------------------
Subroutine Name(SETALP)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(A)
* Create new entries in the #SYM_NAME & #SYM_VALUE lists
Change Field(#X_219NAMC) To(#S_219NAMC)
Change Field(#X_219VROW) To('#SYM_COUNT + 1')
Change Field(#SYM_ORDER) To(N)
Add_Entry To_List(#SYM_NAME)
Change Field(#X_219AVAL) To(#S_219AVAL)
Add_Entry To_List(#SYM_VALUE)
Endroutine
* -------------------------------------------------------
* Handle a "SETNUM" request
* -------------------------------------------------------
Subroutine Name(SETNUM)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(N)
* Build up the numeric value in exchange format
Change Field(#EXCH_NUMB) To(*NULL)
If Cond('#S_219NVAL >= 0')
Change Field(#S_219NSGN) To(P)
Else
Change Field(#S_219NSGN) To(N)
Change Field(#S_219NVAL) To('0 - #S_219NVAL')
Endif
Change Field(#S_219NDIG) To(#S_219NVAL)
Change Field(#S_219NDEC) To(#S_219NVAL)
* Create new entries in the #SYM_NAME & #SYM_VALUE lists
Change Field(#X_219NAMC) To(#S_219NAMC)
Change Field(#X_219VROW) To('#SYM_COUNT + 1')
Change Field(#SYM_ORDER) To(N)
Add_Entry To_List(#SYM_NAME)
Change Field(#X_219AVAL) To(#EXCH_NUMB)
Add_Entry To_List(#SYM_VALUE)
Endroutine
* -------------------------------------------------------
* Handle a "GETALP" request
* -------------------------------------------------------
Subroutine Name(GETALP)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(A)
* See if it already exists
Execute Subroutine(LOCATE) With_Parms(#S_219NAMC)
* If it was found return the value
If Cond(*SYM_FOUND)
Change Field(#S_219AVAL) To(#X_219AVAL)
Exchange Fields(#S_219AVAL)
Endif
Endroutine
* -------------------------------------------------------
* Handle a "GETNUM" request
* -------------------------------------------------------
Subroutine Name(GETNUM)
* Build up the symbolic name as a full composite name
Use Builtin(UPPERCASE) With_Args(#S_219NAM1) To_Get(#S_219NAM1)
Use Builtin(UPPERCASE) With_Args(#S_219NAM2) To_Get(#S_219NAM2)
Change Field(#S_219NAMT) To(N)
* See if it already exists
Execute Subroutine(LOCATE) With_Parms(#S_219NAMC)
* If it was found return the value
If Cond(*SYM_FOUND)
Change Field(#EXCH_NUMB) To(#X_219AVAL)
Change Field(#S_219NVAL) To('#S_219NDIG + #S_219NDEC')
If Cond('#S_219NSGN = N')
Change Field(#S_219NVAL) To('0 - #S_219NVAL')
Endif
Exchange Fields(#S_219NVAL)
Endif
Endroutine
* -------------------------------------------------------
* Handle an internal request to locate a symbolic name
* -------------------------------------------------------
Subroutine Name(LOCATE) Parms((#K_219NAMC *RECEIVED))
Define Field(#K_219NAMC) Reffld(#S_219NAMC)
Define Field(#BOTTOM) Reffld(#STD_NUM)
Define Field(#TOP) Reffld(#STD_NUM)
Define Field(#MID) Reffld(#STD_NUM)
*
* (Re)Sort the name list (if required)
*
If Cond('#SYM_ORDER *NE Y')
Sort_List Named(#SYM_NAME) By_Fields(#X_219NAMC)
Change Field(#SYM_ORDER) To(Y)
Endif
*
* Now use a binary chop to locate the entry
*
Change Field(#SYM_FOUND) To(N)
Change Field(#BOTTOM) To(1)
Change Field(#TOP) To(#SYM_COUNT)
*
Dowhile Cond('#TOP >= #BOTTOM')
Change Field(#MID) To('(#TOP + #BOTTOM) / 2')
Get_Entry Number(#MID) From_List(#SYM_NAME)
Leave If('#IO$STS *NE OK')
If Cond('#K_219NAMC = #X_219NAMC')
Change Field(#SYM_FOUND) To(Y)
Leave
Else
If Cond('#K_219NAMC > #X_219NAMC')
Change Field(#BOTTOM) To('#MID + 1')
Else
Change Field(#TOP) To('#MID - 1')
Endif
Endif
Endwhile
*
* Get the associated value entry if the name was found
*
If Cond(*SYM_FOUND)
Get_Entry Number(#X_219VROW) From_List(#SYM_VALUE)
Endif
*
Endroutine
* -------------------------------------------------------
* Use SET_ALPHA to set an alphanumeric value
* -------------------------------------------------------
Subroutine Name(SET_ALPHA) Parms((#S_219NAM1 *RECEIVED) (#S_219NAM2 *RECEIVED) (#S_219NAMI *RECEIVED) (#S_219AVAL *RECEIVED))
Execute Subroutine(SETALP)
Endroutine
* -------------------------------------------------------
* Handle an "ADDMSGQ" request
* -------------------------------------------------------
Subroutine Name(ADDMSGQ)
*
* Add a message to the message list
*
Add_Entry To_List(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "CLIENTCALL" request
* -------------------------------------------------------
Subroutine Name(CLIENTCALL)
*
* Insert the name of the function to be called
* into the list of values using the special
* symbolic name =FUNCTION=. See SET219Z for details
* of how this is used by the server system.
*
Execute Subroutine(SET_ALPHA) With_Parms('=FUNCTION=' *BLANKS 1 #S_219FUNC)
*
* Now send the list details to the remote server
*
Execute Subroutine(SEND)
*
* Get the results back again from the server
*
Execute Subroutine(RECEIVE)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "SEND" request
* -------------------------------------------------------
Subroutine Name(SEND)
Def_Cond Name(*TO_SERVER) Cond('#S_219HOST *ne ''=CALLER=''')
Define Field(#U_HANDLER) Type(*CHAR) Length(004) Desc('JSM Handler to be used')
*
* Open the JSM connection and load the HTTP client
* service (if it is not already loaded and ready)
*
Execute Subroutine(OPEN)
*
* The host name is in S_219HOST. If it is '=CALLER='
* then the send is from a server back to the client
* otherwise the send is from a client to the server
* and S_219HOST contains the host URL details.
*
* Decide on which handler to use
*
If Cond(*TO_SERVER)
Change Field(#U_HANDLER) To(OXML)
Else
Change Field(#U_HANDLER) To(IXML)
Endif
*
* Send the #SYM_NAME list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_NAMES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219NAMC,X_219VROW')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT NAMESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_NAME)
Execute Subroutine(CHECK_STS)
*
* Send the #SYM_VALUE list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_VALUES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219AVAL')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT VALUESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_VALUE)
Execute Subroutine(CHECK_STS)
*
* Send the #SYM_MESS list as a fragment ....
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_MESSAGES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'S_219MSGT')
Execute Subroutine(ADDKEYWORD) With_Parms(FRAGMENT MESSAGESFRAGMENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_MESS)
Execute Subroutine(CHECK_STS)
*
* Now send the whole lot
*
Execute Subroutine(NEWCOMMAND) With_Parms(SEND)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER #U_HANDLER)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_OUTBOUND_NAMEVALUEMSG')
Execute Subroutine(ADDKEYWORD) With_Parms(METHOD '*POST')
If Cond(*TO_SERVER)
Execute Subroutine(ADDKEYWORD) With_Parms(HOST #S_219HOST)
Execute Subroutine(ADDKEYWORD) With_Parms(URI '/cgi-bin/jsmdirect?set219_remote_service')
Endif
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Clear this programs message queue and the message
* list as we have routed all the messages now
*
Clr_List Named(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "RECEIVE" request
* -------------------------------------------------------
Subroutine Name(RECEIVE)
*
* Open the JSM connection and load the HTTP client
* service (if it is not already loaded and ready)
*
Execute Subroutine(OPEN)
*
* Clear all the lists ready to get their values back
*
Execute Subroutine(CLEAR)
*
* Receive the names list #SYM_NAME
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_NAMES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219NAMC,X_219VROW')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_NAME)
Execute Subroutine(CHECK_STS)
*
* Receive the values list #SYM_VALUE
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_VALUES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'X_219AVAL')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_VALUE)
Execute Subroutine(CHECK_STS)
*
* Receive the messages list #SYM_MESS
*
Execute Subroutine(NEWCOMMAND) With_Parms(RECEIVE)
Execute Subroutine(ADDKEYWORD) With_Parms(HANDLER IXML)
Execute Subroutine(ADDKEYWORD) With_Parms(XSL 'SET219_INBOUND_MESSAGES')
Execute Subroutine(ADDKEYWORD) With_Parms('SERVICE_LIST' 'S_219MSGT')
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG #SYM_MESS)
Execute Subroutine(CHECK_STS)
*
* The lists may be out of order now
*
Change Field(#SYM_ORDER) To(N)
*
* (Re)Issue any messages received back in the #SYM_MESS
* list onto this program's message queue. These will end
* up on the callers message queue. This way the messages
* have seamlessly crossed between the systems
*
Selectlist Named(#SYM_MESS)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#S_219MSGT)
Endselect
*
* Now clear the message list as we have finished with it
*
Clr_List Named(#SYM_MESS)
*
* Finished
*
Endroutine
* -------------------------------------------------------
* Handle a "OPEN" request
* -------------------------------------------------------
Subroutine Name(OPEN)
*
* Open the JSM if required ....
*
If Cond('#JSM_OPEN *NE Y')
*
* Open the JSM
*
Use Builtin(JSM_OPEN) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Load the HTTP Client service
*
Execute Subroutine(NEWCOMMAND) With_Parms('SERVICE_LOAD')
Execute Subroutine(ADDKEYWORD) With_Parms(SERVICE HTTPCLIENT)
Use Builtin(JSM_COMMAND) With_Args(#S_JSMCMD) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Flag as now open
*
Change Field(#JSM_OPEN) To(Y)
Endif
*
Endroutine
* -------------------------------------------------------
* Handle a "CLOSE" request
* -------------------------------------------------------
Subroutine Name(CLOSE)
*
* Close the JSM if required ....
*
If Cond('#JSM_OPEN = Y')
*
* Close the JSM. Note that the HTTPClient service
* is specifically not unloaded
*
Use Builtin(JSM_CLOSE) To_Get(#S_JSMSTS #S_JSMMSG)
Execute Subroutine(CHECK_STS)
*
* Flag as now closed
*
Change Field(#JSM_OPEN) To(N)
Endif
*
* Clear all lists
*
Execute Subroutine(CLEAR)
Endroutine
* -------------------------------------------------------
* Start a new JSM command
* -------------------------------------------------------
Subroutine Name(NEWCOMMAND) Parms((#STD_TEXTS *RECEIVED))
Change Field(#S_JSMCMD) To(#STD_TEXTS)
Endroutine
* -------------------------------------------------------
* Add a JSM keyword to a JSM command
* -------------------------------------------------------
Subroutine Name(ADDKEYWORD) Parms(#KEYWORD #KEYW_VAL1)
Define Field(#KEYWORD) Reffld(#STD_TEXT)
Define Field(#KEYW_VAL1) Reffld(#STD_TEXTL)
Use Builtin(BCONCAT) With_Args(#S_JSMCMD #KEYWORD) To_Get(#S_JSMCMD)
Use Builtin(TCONCAT) With_Args(#S_JSMCMD '(' #KEYW_VAL1 ')') To_Get(#S_JSMCMD)
Endroutine
* -------------------------------------------------------
* Check status of last JSM call made
* -------------------------------------------------------
Subroutine Name(CHECK_STS)
Define Field(#MSGDTA) Type(*CHAR) Length(132)
If Cond('#S_JSMSTS *NE OK')
Use Builtin(BCONCAT) With_Args('Error Status Code: ' #S_JSMSTS) To_Get(#MSGDTA)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Use Builtin(BCONCAT) With_Args('Error Message: ' #S_JSMMSG) To_Get(#MSGDTA)
Message Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Use Builtin(BCONCAT) With_Args(*FUNCTION 'ended in error. Review previous messages.') To_Get(#MSGDTA)
Abort Msgid(DCM9899) Msgf(DC@M01) Msgdta(#MSGDTA)
Endif
Endroutine