Appendix F. The example program for the XTSEREQ global user exit, DFH$XTSE

This appendix lists the example global user exit program, DFH$XTSE. The example shows you how to:

Figure 115. Example exit program for the XTSEREQ exit
***********************************************************************
*                                                                     *
* MODULE NAME = DFH$XTSE                                              *
*                                                                     *
* FUNCTION =                                                          *
*   Example global user exit program to run at the XTSEREQ and        *
*   XTSEREQC exits.                                                   *
*                                                                     *
* DESCRIPTION =                                                       *
*   The program gives examples of:                                    *
*     1) Coding Exec Interface global user exits, showing how to      *
*        modify and add parameters to the Command Parameter List.     *
*     2) Issuing a mixture of EXEC CICS API and XPI calls within      *
*        the same global user exit program.                           *
*     3) Modifying Temporary Storage requests, by renaming the queue  *
*        name and allowing the SYSID to be added so that the request  *
*        is routed to a queue-owning region (QOR).                    *
*                                                                     *
* ------------------------------------------------------------------- *
*   NOTE that this program is only intended to DEMONSTRATE the use    *
*   of the TS request user exit XTSEREQ, and to show the sort of      *
*   information which can be obtained from the exit parameter list.   *
* IT SHOULD BE TAILORED BEFORE BEING USED IN A PRODUCTION ENVIRONMENT.*
* ------------------------------------------------------------------- *
*                                                                     *
* NOTES =                                                             *
*   The important notes to remember when coding similar global user   *
*   exits are:                                                        *
*                                                                     *
*   1) If the exit program modifies the Command Parameter List, you   *
*      MUST ensure that the storage used for additional fields such   *
*      as the SYSID is non-volatile. Here are examples of storage     *
*      that is safe:                                                  *
*        a) Shared storage obtained by GETMAIN.  This should be       *
*           obtained in the Request exit, and freed in the Request    *
*           Complete exit..  The shared storage address can be passed *
*           using the 4-byte token in the DFHUEPAR parameter list.    *
*        b) Shared global work area storage.                          *
*        c) Storage obtained by using the LOAD HOLD option.           *
*        d) TCTUA or CWA storage.                                     *
*                                                                     *
*      It is not safe to use the following storage:                   *
*           Program storage (DFHEISTG) since this is freed as soon    *
*           as the exit program returns control to CICS.              *
*                                                                     *
*   2) When adding or removing a field in the command parameter list, *
*      you must remember:                                             *
*        a) To set/clear the field's existence bit in the EID         *
*        b) To set/clear the appropriate address in the Addr_List     *
*        c) To set the hi-order bit in the LAST address in the        *
*           Addr_List.                                                *
*                                                                     *
*   3) If you are planning to use the CICS API in the exit, you       *
*      must:                                                          *
*        a) Use the DFHEIENT macro to control module entry.           *
*        b) Use the DFHEIRET macro to return control to CICS. However,*
*           the exit return code MUST be set in Register 15.          *
*        c) Issue an ADDRESS EIB command before issuing any EXEC CICS *
*           commands.                                                 *
*                                                                     *
*   4) If you are planning to use the API and XPI in the same         *
*      global user exit program, take care to ensure that Register    *
*      13 points to the kernel stack entry (UEPSTACK) for XPI calls,  *
*      and is restored for API calls if necessary.                    *
*                                                                     *
*                                                                     *
***********************************************************************
         EJECT ,
*---------------------------------------------------------------------*
*                                                                     *
* Copybook and DSECTS required by the exit program                    *
*                                                                     *
*---------------------------------------------------------------------*
         DFHUEXIT TYPE=EP,ID=(XTSEREQ,XTSEREQC)
         DFHUEXIT TYPE=XPIENV       Exit programming interface (XPI)
         COPY  DFHTRPTY             Trace XPI definitions
         COPY  DFHTSUED             Command Level Plist definitions
*
*---------------------------------------------------------------------*
* The following DSECT maps the shared storage obtained by the         *
* EXEC CICS GETMAIN API call. This storage is used to store the       *
* modified SYSID and/or TS QNAME that is passed to CICS on return     *
* from the exit program.                                              *
*---------------------------------------------------------------------*
SHARED_STORAGE    DSECT
SHARED_EYECATCHER DS CL16
SHARED_NAME       DS CL8
SHARED_SYSID      DS CL4
*
*---------------------------------------------------------------------*
* The TS Routing table is made up of a set of entries. Each entry     *
* can be mapped by the TABLE_ENTRY DSECT                              *
*---------------------------------------------------------------------*
TABLE_ENTRY  DSECT
ENTRY_NAME   DS CL8
NEW_NAME     DS CL8
NEW_SYSID    DS CL4
ENTRY_ACTION DS XL1
FILLER       DS CL3
*
*---------------------------------------------------------------------*
* The following definitions are for program working storage.          *
*---------------------------------------------------------------------*
DFHEISTG DSECT
RETCODE      DS XL4                    Program Return Code
TR_ERROR_N   DS X                      Error Number for Trace Entry
RESP         DS X                      API Response
         EJECT ,
***********************************************************************
*  PROGRAM REGISTER USAGE :                                           *
*  R0 - Work Register                                                 *
*  R1 - Points to DFHUEPAR plist on entry                             *
*       Work Register                                                 *
*  R2 - DFHUEPAR parameter List                                       *
*  R3 - Code Base Register                                            *
*  R4 -  <unused>                                                     *
*  R5 -  <unused>                                                     *
*  R6 - Subroutine Linkage Register                                   *
*  R7 - Address of TS Queue Name from Command Plist                   *
*  R8 - Command Parameter list UEPCLPS                                *
*  R9 - Address of Table_Entry in TS_Routing_Table                    *
*  R10-  <unused>                                                     *
*  R11- EIB Register                                                  *
*  R12- Work Register                                                 *
*  R13- DFHEISTG for API calls                                        *
*       Kernel Stack for XPI calls                                    *
*  R14- Work Register                                                 *
*  R15- Work Register                                                 *
***********************************************************************
         EJECT ,
***********************************************************************
*  DFH$XTSE - Main Routine                                            *
*    This is the entry point for the exit program. Control is passed  *
*    to the TS_REQUEST or TS_REQUEST_COMPLETE routines depending      *
*    on whether the exit was invoked at the XTSEREQ or XTSEREQC exit  *
*    points.                                                          *
*                                                                     *
*  Registers:                                                         *
*    R1 = UEPAR plist (set on entry)                                  *
*       = Work register                                               *
*    R2 = UEPAR plist                                                 *
*    R3 = Program base register (set by DFHEIENT)                     *
*    R6 = Linkage register                                            *
*    R11= EIB register                                                *
*    R13= EISTG register (set by DFHEIENT)                            *
*    R15= Work register                                               *
*         User Exit Return Code                                       *
*                                                                     *
*  Logic:                                                             *
*    DFH$XTSE:                                                        *
*      Exec Interface Entry                                           *
*      Address DFHUEPAR plist                                         *
*      Set OK Return Code                                             *
*      Address the EIB                                                *
*      Trace entry                                                    *
*      Select Exitid                                                  *
*        When(XTSEREQ) then call TS_Request                           *
*        When(XTSEREQC) then call TS_Request_Complete                 *
*        Otherwise call Error(Invalid_Exit)                           *
*      End Select                                                     *
*      Trace exit                                                     *
*      Set Exit return code                                           *
*    Return                                                           *
***********************************************************************
DFH$XTSE DFHEIENT
DFH$XTSE AMODE 31
DFH$XTSE RMODE ANY
         LR    R2,R1               DFHUEPAR plist provided by caller
         USING DFHUEPAR,R2         Use R2 to address UEPAR PLIST
*
         LA    R15,UERCNORM        Set OK Response
         ST    R15,RETCODE           in working storage
*
         EXEC CICS ADDRESS EIB(R11)
         USING DFHEIBLK,R11
*
         BAL   R6,TRACE_ENTRY      Trace program entry
*
         L     R1,UEPEXN           Address of the 1 byte Exit Id
         CLI   0(R1),XTSEREQ       Is this XTSEREQ exit?
         BE    TS_REQUEST          ..Yes Branch to routine
         CLI   0(R1),XTSEREQC      Is this XTSEREQC exit?
         BE    TS_REQUEST_COMPLETE .. Yes Branch to routine
         B     ERROR1              Otherwise Branch to error routine
*
RETURN   DS    0H                  Return point
         BAL   R6,TRACE_EXIT       Trace program exit
*
         L     R15,RETCODE         Fetch return code
         DFHEIRET RCREG=15         Return to CICS
         EJECT ,
*=====================================================================*
*  TS_REQUEST - Invoked at XTSEREQ exit point                         *
*    Determine the TS Queue Name and scan the TS_Routing_Table for    *
*    a match. If an entry exists in the table, then check the action  *
*    field and call the ROUTE_REQUEST or LOCAL_REQUEST routines.      *
*                                                                     *
*    The TS_Routing_Table is made up of entries with the following    *
*    structure:                                                       *
*                                                                     *
*   TABLE_ENTRY:                                                      *
*    ----------------------------------------------------------       *
*   | Entry_Name | New_Name |  QOR_Sysid |  Action |  *filler* |      *
*   | Char 8     | Char 8   |  Char 4    |  Bin 1  |  Char 3   |      *
*    ----------------------------------------------------------       *
*    Last Entry is indicated by special TS_Queue Name                 *
*                                                                     *
*  Registers:                                                         *
*    R1 = Work register                                               *
*    R7 = Set to the TS Queue Name                                    *
*    R8 = Command Parameter List (CLPS)                               *
*    R9 = Points to the next entry in the TS_Routing_Table            *
*    R15= Work register                                               *
*                                                                     *
*  Logic:                                                             *
*    TS_Request:                                                      *
*       If called recursively then                                    *
*         call Error(Recursive_Call1)                                 *
*       Else                                                          *
*         If the Command GROUP code is not a TS request then          *
*           call Error(Invalid_Group_Code1)                           *
*         Else                                                        *
*           Clear the UEPTQTOK                                        *
*           Address the Command Plist UEPCLPS                         *
*           Fetch tsq_name                                            *
*           Fetch start of TS_Routing_Table                           *
*    Check_Next_Entry:                                                *
*           Get the next table entry                                  *
*           Select (entry_name)                                       *
*             When (last_entry) call Entry_Not_Found                  *
*             When (tsq_name)                                         *
*               Select (entry_action)                                 *
*                 When (Route) call Route_Request                     *
*                 When (Local) call Local_Request                     *
*                 Otherwise call Error(Invalid_Table_Action)          *
*               End Select                                            *
*             Otherwise                                               *
*               Goto Check_Next_Entry                                 *
*           End Select                                                *
*         End If                                                      *
*       End If                                                        *
*    Return                                                           *
*=====================================================================*
TS_REQUEST DS  0H
*        Check for possible recursion
         L     R1,UEPRECUR         Address of recursive count
         LH    R1,0(R1)            Fetch count
         LTR   R1,R1               Has exit been invoked recursively?
         BNZ   ERROR2              ..Yes Branch to error routine
*
*        Extract pointer to the EID and TS queue name from CLPS
         L     R8,UEPCLPS          Fetch address of Command Plist
         USING TS_ADDR_LIST,R8     Use R8 to address CLPS
         L     R1,TS_ADDR0         Address the EID..
         L     R7,TS_ADDR1         Fetch address of TS QUEUE
         DROP  R8                  Drop addressability to CLPS
*
*        Check that the Command GROUP code corresponds to a TS request
         USING TS_EID,R1           ..with Register 1
         CLI   TS_GROUP,TS_TEMPSTOR_GROUP Is this a TS request?
         BNE   ERROR3              ..No  Branch to error routine
         DROP  R1                  Drop addressability to EID
*
*        Clear the TS Request token
         L     R1,UEPTQTOK         Fetch address of token
         XC    0(4,R1),0(R1)       Clear Token for XTSEREQC
*
*
*---------------------------------------------------------------------*
* Start scan of TS_Routing Table                                      *
*---------------------------------------------------------------------*
         LA    R9,TS_ROUTING_TABLE Fetch address of routing table
         USING TABLE_ENTRY,R9      Address entries from R9
*
CHECK_NEXT_ENTRY DS 0H
         CLC   ENTRY_NAME,ENTRY_NAME_LAST Is this the last entry
         BE    ENTRY_NOT_FOUND     ..Yes Take default routing action
         CLC   ENTRY_NAME,0(R7)    Is this the wanted TS queue name?
         BE    ENTRY_FOUND         ..Yes Check for the action required
         LA    R9,24(R9)           Point to next entry
         B     CHECK_NEXT_ENTRY    Start search again
*
ENTRY_FOUND DS 0H
         CLI   ENTRY_ACTION,ROUTE  Is the action to route request?
         BE    ROUTE_REQUEST       ..Yes Branch to Route routine
         CLI   ENTRY_ACTION,LOCAL  Is the action to rename queue?
         BE    LOCAL_REQUEST       ..Yes Branch to Local routine
         B     ERROR4              Otherwise Branch to error routine
         DROP  R9                  Drop addressability to Entry
         EJECT ,
*
*=====================================================================*
*  TS_REQUEST_COMPLETE - Invoked at XTSEREQC exit point               *
*    Free any shared storage that was acquired during previous        *
*    invocation at XTSEREQ.                                           *
*                                                                     *
*  Registers:                                                         *
*    R1 = Work register                                               *
*    R6 = Linkage register                                            *
*    R8 = Command Parameter List (CLPS)                               *
*                                                                     *
*  Logic:                                                             *
*    TS_Request_Complete:                                             *
*      If called recursively then                                     *
*        call Error(Recursive_Call2)                                  *
*      Else                                                           *
*        If the Command GROUP code is not a TS request then           *
*          call Error(Invalid_Group_Code2)                            *
*        Else                                                         *
*          If UEPTQTOK->token ¬= 0 then Call Freemain_Shared_Plist    *
*        End If                                                       *
*      End If                                                         *
*    Return                                                           *
*=====================================================================*
TS_REQUEST_COMPLETE DS  0H
*        Check for possible recursion
         L     R1,UEPRECUR         Address of recursive count
         LH    R1,0(R1)            Fetch count
         LTR   R1,R1               Has exit been invoked recursively?
         BNZ   ERROR5              ..Yes Branch to error routine
*
*        Check that the Command GROUP code corresponds to a TS request
         L     R8,UEPCLPS          Fetch address of Command Plist
         USING TS_ADDR_LIST,R8     Use R8 to address CLPS
         L     R1,TS_ADDR0         Address the EID..
         USING TS_EID,R1           ..with Register 1
         CLI   TS_GROUP,TS_TEMPSTOR_GROUP Is this a TS request?
         BNE   ERROR6              ..No  Branch to error routine
         DROP  R1                  Drop addressability to EID
         DROP  R8                  Drop addressability to CLPS
*
         L     R1,UEPTQTOK         Fetch address of Token
         L     R1,0(R1)            Fetch actual token
         LTR   R1,R1               Did XTSEREQ GETMAIN any storage?
         BZ    RETURN              ..No  Return to caller
         BAL   R6,FREEMAIN_SHARED  ..Yes Issue FREEMAIN
         B     RETURN              Return to caller
         EJECT ,
*
*=====================================================================*
* LOCAL_REQUEST: Process Local TS Queues                              *
*   An entry has been found in the TS_Routing Table for this TS       *
*   Queue Name. If required, rename the TS Queue Name, but do not     *
*   modify the SYSID.                                                 *
*                                                                     *
*  Registers:                                                         *
*    R1 = Work register                                               *
*    R6 = Link Register                                               *
*    R7 = Address of current Queue name       (Set on entry)          *
*    R8 = Command Parameter List (CLPS)                               *
*    R9 = Address of table entry              (Set on entry)          *
*    R12= Work register (Shared_storage)                              *
*                                                                     *
*  Logic:                                                             *
*    Local_Request:                                                   *
*      If entry_name ¬= new_name then                                 *
*        Call Getmain_Shared                                          *
*        Copy new_name into shared storage                            *
*        Address the command plist                                    *
*        Update ADDR1 to point to address of the new TS QUEUE name    *
*        Set the Hi-order bit if last address in CLPS                 *
*      End If                                                         *
*    Return                                                           *
*=====================================================================*
LOCAL_REQUEST DS 0H
         USING TABLE_ENTRY,R9      R9 points to the table entry
         CLC   NEW_NAME,0(R7)      Is the new_name=current_queue name?
         BE    RETURN              ..Yes Return
*
*        Obtain Shared storage to hold the new queue name
         BAL   R6,GETMAIN_SHARED   GETMAIN SHARED storage
         L     R12,UEPTQTOK        Fetch address of token
         L     R12,0(R12)          Fetch shared storage pointer
         USING SHARED_STORAGE,R12  Address using R12
         MVC   SHARED_NAME,NEW_NAME Copy QNAME into shared storage
*
*        Update the Queue Name in CLPS
         L     R8,UEPCLPS          Address the CLPS.
         USING TS_ADDR_LIST,R8     ..with Register 8
         LA    R1,SHARED_NAME      Fetch address of the new QNAME
         TM    TS_ADDR1,X'80'      Is the hi-order bit on?
         BZ    LOCAL1              ..No continue
         O     R1,=X'80000000'     Indicate ADDR1 is last parameter
LOCAL1   DS    0H
         ST    R1,TS_ADDR1         Store address in TS_ADDR1
         B     RETURN              Return
         DROP  R8                  Drop TS_ADDR_LIST
         DROP  R12                 Drop SHARED_STORAGE
         DROP  R9                  Drop addressability to Entry
         EJECT ,
*
*=====================================================================*
* ROUTE_REQUEST: Ship request to remote system                        *
*   An entry has been found in the TS_Routing Table for this TS       *
*   Queue Name. The request is modified by adding a SYSID to the      *
*   command and renaming the queue if required.                       *
*                                                                     *
*  Registers:                                                         *
*    R1 = Work register                                               *
*    R6 = Link Register                                               *
*    R7 = Address of current Queue name       (Set on entry)          *
*    R8 = Command Parameter List (CLPS)                               *
*    R9 = Address of table entry              (Set on entry)          *
*    R12= Work register (Shared_storage)                              *
*                                                                     *
*  Logic:                                                             *
*    Route_Request:                                                   *
*      Call Getmain_Shared                                            *
*      If entry_name ¬= new_name then                                 *
*        Copy new_name into shared storage                            *
*        Address the command plist                                    *
*        Update ADDR1 to point to address of the new TS QUEUE name    *
*      End If                                                         *
*      Copy new_sysid into shared storage                             *
*      Address the command plist                                      *
*      Update ADDR7 to point to the address of the new SYSID          *
*      Set the SYSID existence bit in the EID                         *
*      Set the Hi-order bit in last address in CLPS                   *
*    Return                                                           *
*=====================================================================*
ROUTE_REQUEST DS 0H
         BAL   R6,GETMAIN_SHARED   GETMAIN SHARED storage
         L     R12,UEPTQTOK        Fetch address of token
         L     R12,0(R12)          Fetch Shared storage address
         USING SHARED_STORAGE,R12  Address using R12
*
*        Update the Queue Name in CLPS
         USING TABLE_ENTRY,R9      R9 points to the table entry
         CLC   NEW_NAME,0(R7)      Is the new_name=current_queue name?
         BE    ROUTE1              ..Yes No need to update Queue Name
         MVC   SHARED_NAME,NEW_NAME Copy QNAME into shared storage
         L     R8,UEPCLPS          Address the CLPS..
         USING TS_ADDR_LIST,R8     ..with Register 8
         LA    R1,SHARED_NAME      Fetch address of the new QNAME
         ST    R1,TS_ADDR1         Store address in TS_ADDR1
         DROP  R8                  Drop TS_ADDR_LIST
*
*        Update the Sysid in CLPS
ROUTE1   DS    0H
         MVC   SHARED_SYSID,NEW_SYSID Copy SYSID into shared storage
         L     R8,UEPCLPS          Address the CLPS..
         USING TS_ADDR_LIST,R8     ..with Register 8
         L     R1,TS_ADDR0         Address the EID..
         USING TS_EID,R1           ..with Register 1
         OI    TS_BITS1,TS_SYSID_V Indicate SYSID now present in CLPS
         DROP  R1                  Drop addressability to EID
         LA    R1,SHARED_SYSID     Fetch address of the new SYSID
         ST    R1,TS_ADDR7         Store address in TS_ADDR7
         OI    TS_ADDR7,X'80'      Indicate SYSID is end of plist
*
*        Clear hi-order bits in ARGs 1 to 5
         NI    TS_ADDR1,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR2,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR3,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR4,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR5,X'7F'      Indicate not last parameter in CLPS
         B     RETURN              Return
         DROP  R8                  Drop TS_ADDR_LIST
         DROP  R12                 Drop SHARED_STORAGE
         DROP  R9                  Drop addressability to Entry
         EJECT ,
*
*=====================================================================*
* ENTRY_NOT_FOUND - No entry was found in the TS_Routing_Table        *
*   No entry found in Routing Table for this TS Queue Name. In the    *
*   sample program, all such requests are routed.                     *
*                                                                     *
*  Registers:                                                         *
*    R1 = Work register                                               *
*    R6 = Link Register                                               *
*    R8 = Command Parameter List (CLPS)                               *
*    R12= Work register (Shared_storage)                              *
*                                                                     *
*  Logic:                                                             *
*    Entry_Not_Found:                                                 *
*      Call Getmain_Shared                                            *
*      Copy default_sysid into shared storage                         *
*      Address the command plist                                      *
*      Update ADDR7 to point to the address of the default SYSID      *
*      Set the SYSID existence bit in the EID                         *
*      Set the Hi-order bit in last address in CLPS                   *
*    Return                                                           *
*=====================================================================*
ENTRY_NOT_FOUND DS 0H
         BAL   R6,GETMAIN_SHARED   GETMAIN SHARED storage
         L     R12,UEPTQTOK        Fetch address of token
         L     R12,0(R12)          Fetch shared storage address
         USING SHARED_STORAGE,R12  Address using R12
*
*        Update the Sysid in CLPS
         MVC   SHARED_SYSID,DEFAULT_SYSID Copy SYSID to shared storage
         L     R8,UEPCLPS          Address the CLPS..
         USING TS_ADDR_LIST,R8     ..with Register 8
         L     R1,TS_ADDR0         Address the EID..
         USING TS_EID,R1           ..with Register 1
         OI    TS_BITS1,TS_SYSID_V Indicate SYSID now present in CLPS
         DROP  R1                  Drop addressability to EID
         LA    R1,SHARED_SYSID     Fetch address of the new SYSID
         ST    R1,TS_ADDR7         Store address in TS_ADDR7
         OI    TS_ADDR7,X'80'      Indicate SYSID is end of plist
*
*        Clear hi-order bits in ARGs 1 to 5
         NI    TS_ADDR1,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR2,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR3,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR4,X'7F'      Indicate not last parameter in CLPS
         NI    TS_ADDR5,X'7F'      Indicate not last parameter in CLPS
         B     RETURN              Return
         DROP  R8                  Drop TS_ADDR_LIST
         DROP  R12                 Drop SHARED_STORAGE
         EJECT ,
*
*=====================================================================*
*  GETMAIN_SHARED - Obtain Shared storage                             *
*                                                                     *
*  Registers:                                                         *
*    R0 = Used by EXEC CICS call                                      *
*    R1 = Used by EXEC CICS call                                      *
*         Work Register                                               *
*    R6 = Link Register - Return Address                              *
*    R11= EIB register   (set on entry)                               *
*    R12= Work register                                               *
*    R14= Used by EXEC CICS call                                      *
*    R15= Used by EXEC CICS call                                      *
*                                                                     *
*  Logic:                                                             *
*    Getmain_Shared:                                                  *
*      EXEC CICS GETMAIN LENGTH(32) SET(UEPTQTOK) SHARED RESP(resp)   *
*      If resp ¬= OK then                                             *
*        Call Error(Getmain_Failed)                                   *
*      Else                                                           *
*        Address shared storage                                       *
*        Set eyecatcher 'XTSEREQ Storage'                             *
*      End If                                                         *
*    Return                                                           *
*=====================================================================*
GETMAIN_SHARED DS 0H
         L     R12,UEPTQTOK            Fetch address of token
         L     R12,0(R12)              Fetch shared storage anchor
         LTR   R12,R12                 Is the storage already present?
         BNZR  R6                      ..Yes Return
         EXEC CICS GETMAIN LENGTH(32) SET(R12) SHARED                  X
                   INITIMG(X'00') RESP(RESP)
         CLC   RESP,DFHRESP(NORMAL)    GETMAIN worked OK?
         BNE   ERROR7                  ..No Goto Error routine
         L     R1,UEPTQTOK             Fetch address of token
         ST    R12,0(R1)               Save address of storage
         USING SHARED_STORAGE,R12
         MVC   SHARED_EYECATCHER,EYE_CATCHER Set Eyecatcher
         DROP  R12                     Drop R12
         BR    R6                      Return to caller
         EJECT ,
*
*=====================================================================*
*  FREEMAIN_SHARED - Free shared storage                              *
*    Free the shared storage associated with this command.            *
*  Registers:                                                         *
*    R0 = Used by EXEC CICS call                                      *
*    R1 = Used by EXEC CICS call                                      *
*    R6 = Link Register - Return Address                              *
*    R11= EIB register   (set on entry)                               *
*    R12= Work register                                               *
*    R14= Used by EXEC CICS call                                      *
*    R15= Used by EXEC CICS call                                      *
*  Logic:                                                             *
*    Freemain_Shared:                                                 *
*      Address shared storage                                         *
*      If eyecatcher ¬= 'XTSEREQ Storage' then                        *
*        Call Error(Freemain_Logic_Error)                             *
*      Else                                                           *
*        EXEC CICS FREEMAIN DATAPOINTER(UEPTQTOK) RESP(resp)          *
*        If resp ¬= OK then                                           *
*          Call Error(Freemain_Failed)                                *
*        End If                                                       *
*      End If                                                         *
*    Return                                                           *
*=====================================================================*
FREEMAIN_SHARED DS 0H
         L     R12,UEPTQTOK            Fetch token address
         L     R12,0(R12)              Address shared storage address
         USING SHARED_STORAGE,R12      ..Using R12
         CLC   SHARED_EYECATCHER,EYE_CATCHER Is this our storage?
         BNE   ERROR8                  ..No Goto Error routine
         DROP  R12                     Drop R12
         EXEC CICS FREEMAIN DATAPOINTER(R12) RESP(RESP)
         CLC   RESP,DFHRESP(NORMAL)    FREEMAIN worked OK?
         BNE   ERROR9                  ..No Goto Error routine
         L     R12,UEPTQTOK            Fetch token address
         XC    0(4,R12),0(R12)         Clear token address
         BR    R6                      Return to caller
         EJECT ,
*=====================================================================*
*  Trace Routines                                                     *
*    Issue a Trace XPI call                                           *
*                                                                     *
*  Registers:                                                         *
*    R0 = Used by XPI call                                            *
*    R1 = DFHTRPT plist                                               *
*    R6 = Link Register - Return Address                              *
*    R12= Work register                                               *
*    R13= EISTG register (set by DFHEIENT)                            *
*         Kernel Stack entry                                          *
*    R14= Used by XPI call                                            *
*    R15= Used by XPI call                                            *
*=====================================================================*
         USING DFHTRPT_ARG,R1
TRACE_ENTRY DS 0H
         L     R1,UEPXSTOR         Prepare for XPI call
         DFHTRPTX CLEAR,                                               X
               POINT_ID(TR_ENTRY)
         B     ISSUE_TRACE
TRACE_EXIT DS  0H
         L     R1,UEPXSTOR         Prepare for XPI call
         DFHTRPTX CLEAR,                                               X
               POINT_ID(TR_EXIT)
         B     ISSUE_TRACE
TRACE_ERROR DS 0H
         L     R1,UEPXSTOR         Prepare for XPI call
         DFHTRPTX CLEAR,                                               X
               POINT_ID(TR_ERROR),                                     X
               DATA1(TR_ERROR_N,1)
         BAL   R6,ISSUE_TRACE
         B     RETURN
*
*---------------------------------------------------------------------*
* Issue the Trace XPI call                                            *
*---------------------------------------------------------------------*
ISSUE_TRACE DS 0H
         L     R8,UEPTRACE         Address of trace flag
         TM    0(R8),UEPTRON       Is trace on?
         BZ    NO_TRACE            No - do not issue trace then
         LR    R12,R13             Save R13 round XPI call
         L     R13,UEPSTACK
         DFHTRPTX CALL,                                                X
               IN,                                                     X
               FUNCTION(TRACE_PUT),                                    X
               POINT_ID(*),                                            X
               OUT,                                                    X
               RESPONSE(*),                                            X
               REASON(*)
         LR    R13,R12             Restore R13 (DFHEISTG)
NO_TRACE DS    0H
         BR    R6                  Return to caller
         DROP  R1
*
*=====================================================================*
*  ERRORn                                                             *
*    Error has occurred during processing                             *
*    Issue a trace point and return to the CICS                       *
*=====================================================================*
ERROR1   DS    0H
         MVI   TR_ERROR_N,1
         B     TRACE_ERROR
ERROR2   DS    0H
         MVI   TR_ERROR_N,2
         B     TRACE_ERROR
ERROR3   DS    0H
         MVI   TR_ERROR_N,3
         B     TRACE_ERROR
ERROR4   DS    0H
         MVI   TR_ERROR_N,4
         B     TRACE_ERROR
ERROR5   DS    0H
         MVI   TR_ERROR_N,5
         B     TRACE_ERROR
ERROR6   DS    0H
         MVI   TR_ERROR_N,6
         B     TRACE_ERROR
ERROR7   DS    0H
         MVI   TR_ERROR_N,7
         B     TRACE_ERROR
ERROR8   DS    0H
         MVI   TR_ERROR_N,7
         B     TRACE_ERROR
ERROR9   DS    0H
         MVI   TR_ERROR_N,7
         B     TRACE_ERROR
         EJECT ,
         DROP  R2                      Drop DFHUEPAR
         DROP  R11                     Drop EIB
         LTORG ,
***********************************************************************
* CONSTANTS                                                           *
***********************************************************************
                 DS 0D
EYE_CATCHER      DC CL16'XTSEREQ Storage '
DEFAULT_SYSID    DC CL4'MQ1 '
LOCAL            EQU X'01'
ROUTE            EQU X'02'
*
* Trace point ids
TR_ENTRY         DC XL2'120'
TR_EXIT          DC XL2'121'
TR_ERROR         DC XL2'122'
*
*---------------------------------------------------------------------*
*   TABLE_ENTRY:                                                      *
*    ----------------------------------------------------------       *
*   | Entry_Name | New_Name |  QOR_Sysid |  Action |  *filler* |      *
*   | Char 8     | Char 8   |  Char 4    |  Bin 1  |  Char 3   |      *
*    ----------------------------------------------------------       *
*    Last Entry is indicated by special TS_Queue Name                 *
*---------------------------------------------------------------------*
TS_ROUTING_TABLE DS 0D
ENTRY_NAME_1     DC CL8'AAAAAAAA'         Rename Queue AAAAAAAA as
NEW_NAME_1       DC CL8'BBBBBBBB'         BBBBBBBBB
QOR_SYSID_1      DC CL4' '
ACTION_1         DC XL1'01'               Local request
FILLER_1         DC CL3' '
ENTRY_NAME_2     DC CL8'A1      '         Rename Queue A1 as
NEW_NAME_2       DC CL8'B1      '         B1
QOR_SYSID_2      DC CL4' '
ACTION_2         DC XL1'01'               Local request
FILLER_2         DC CL3' '
ENTRY_NAME_3     DC CL8'A2      '         Rename Queue A2 as
NEW_NAME_3       DC CL8'B2      '         B2
QOR_SYSID_3      DC CL4' '
ACTION_3         DC XL1'01'               Local request
FILLER_3         DC CL3' '
ENTRY_NAME_4     DC CL8'RRRRRRRR'         Rename Queue RRRRRRRR as
NEW_NAME_4       DC CL8'REMOTE  '         REMOTE and ship request
QOR_SYSID_4      DC CL4'MQ1 '             to System MQ1
ACTION_4         DC XL1'02'
FILLER_4         DC CL3' '
ENTRY_NAME_5     DC CL8'R1      '         Don't rename Queue R1, but
NEW_NAME_5       DC CL8'R1      '         ship request to System MQ1
QOR_SYSID_5      DC CL4'MQ1 '
ACTION_5         DC XL1'02'
FILLER_5         DC CL3' '
ENTRY_NAME_LAST  DC XL8'FFFFFFFFFFFFFFFF'
NEW_NAME_LAST    DC CL8' '
QOR_SYSID_LAST   DC CL4' '
ACTION_LAST      DC XL1'00'
FILLER_LAST      DC CL3' '
         END   DFH$XTSE

Before using the sample program in a production environment, you would need to customize it to suit your installation.

Related concepts
Overview -- what is a global user exit?
Overview of the XPI
Global user exit XPI examples, showing the use of storage
Related tasks
Writing global user exit programs
Making an XPI call
Related reference
Temporary storage EXEC interface program exits XTSEREQ and XTSEREQC
[[ Contents Previous Page | Next Page Index ]]