*
*  PROGRAM:    ZFAM001
*  AUTHOR:     Rich Jackson and Randy Frerking
*  COMMENTS:   zFAM - z/OS Frerking Access Manager
*
*              This program is executed as the initial zFAM HTTP/HTTPS
*              request to determine which zFAM execution mode.
*
*              When the query string is not zQl (or is not present),
*              this is Basic Mode.
*
*              When the query string is zQL,
*              this is Query Mode.
*
*              Basic Authentication is managed in this program for both
*              modes of operation.  Row and field level security are
*              performed in this program.
*
*              HTTP in Basic Mode is allowed under the following rules:
*                1).  Only for GET requests, and
*                2).  Only when Basic Mode Read Only is enabled
*
*              HTTP in Query Mode is allowed under the following rules:
*                1).  Only for GET requests, and
*                2).  Only when Query Mode Read Only is enabled
*
*              After performing Basic Authentication, field/row level
*              security, zQL parsing, field containers, etc, control
*              will be transfered to the following programs:
*
*              ZFAM002 - Basic Mode row level access
*                 POST   LINK to ZFAM011   When Column Index defined
*                 PUT    LINK to ZFAM031   When Column Index defined
*                 DELETE LINK to ZFAM041   When Column Index defined
*
*              ZFAM010 - Query Mode POST
*              ZFAM020 - Query Mode GET
*              ZFAM022 - Query Mode GET    when Column Index requested
*              ZFAM030 - Query Mode PUT
*              ZFAM040 - Query Mode DELETE
*
*
***********************************************************************
* Start Dynamic Storage Area                                          *
***********************************************************************
DFHEISTG DSECT
REGSAVE  DS    16F                Register Save Area
APPLID   DS    CL08               CICS Applid
SYSID    DS    CL04               CICS SYSID
SD_GM    DS    F                  FAxxSD GETMAIN address
FD_GM    DS    F                  FAxxFD GETMAIN address
SD_LEN   DS    F                  FAxxSD GETMAIN length
FD_LEN   DS    F                  FAxxFD GETMAIN length
PA_GM    DS    F                  Parser Array address
PA_LEN   DS    F                  Parser Array length
SD_RESP  DS    F                  FAxxSD DOCUMENT CREATE EIBRESP
FD_RESP  DS    F                  FAxxFD DOCUMENT CREATE EIBRESP
WR_ADDR  DS    F                  WEB RECEIVE buffer address
WR_LEN   DS    F                  WEB RECEIVE buffer address
QS_ADDR  DS    F                  Query string address
BAS_REG  DS    F                  BAS return register
         DS   0F
BM_PROG  DS    CL08               Basic Mode service program
QM_PROG  DS    CL08               Query Mode service program
W_ADDR   DS    F                  Beginning field/where address
W_LEN    DS    CL04               Packed  decimal field length
W_TOTAL  DS    CL08               Packed  decimal total length
W_COLUMN DS    CL08               Packed  decimal column number
W_PACK   DS    CL08               Packed  decimal work field
         DS   0F
X_NAME   DS    CL16               Field Name   (during search)
         DS   0F
W_NAME   DS    CL16               Field Name   (container name)
W_LENGTH DS    F                  Field Length (container data)
W_INDEX  DS    F                  Parser array index
         DS   0F
W_FIELDS DS    CL01               Command indicator
W_WHERE  DS    CL01               Command indicator
W_WITH   DS    CL01               Command indicator
W_TTL    DS    CL01               Command indicator
W_OPTION DS    CL01               Command indicator
W_FORM   DS    CL01               Command indicator
W_DIST   DS    CL01               Command indicator
W_MODE   DS    CL01               Command indicator
W_SORT   DS    CL01               Command indicator
W_ROWS   DS    CL01               Command indicator
*
W_CI     DS    CL01               FAxxFD CI indicator
*
W_SIGN   DS    CL01               Where sign
*
W_PREFIX DS    CL01               URI prefix
*                                 When a replicate request is sent
*                                 in the URI prefix, set this byte to
*                                 X'FF'.  This will be used to allow
*                                 HTTP requests for both BM and QM
*
***********************************************************************
* WEB EXTRACT fields                                                  *
***********************************************************************
         DS   0F
W_SCHEME DS    F                  Scheme (HTTP/HTTPS)
L_METHOD DS    F                  Method length
L_PATH   DS    F                  Path length
L_QUERY  DS    F                  Query string length
         DS   0F
W_METHOD DS    CL06               Method (GET, PUT, POST, DELETE)
E_METHOD EQU   *-W_METHOD         Method field length
         DS   0F
W_PATH   DS    CL512              Path information
E_PATH   EQU   *-W_PATH           Path field length
W_QUERY  DS    CL03               Query string information
E_QUERY  EQU   *-W_QUERY          Query field length
***********************************************************************
* READ HTTPHEADER fields - Authorization                              *
***********************************************************************
         DS   0F
L_HEADER DS    F                  HTTP header length
V_LENGTH DS    F                  HTTP header value length
*
A_VALUE  DS    CL64               HTTP header value
A_VAL_L  EQU   *-A_VALUE          HTTP header value field length
***********************************************************************
* READ HTTPHEADER fields - zFAM-Stream                                *
***********************************************************************
         DS   0F
Z_VALUE  DS    CL03               HTTP header value
Z_VAL_L  EQU   *-Z_VALUE          HTTP header value field length
***********************************************************************
* WEB RECEIVE fields                                                  *
***********************************************************************
         DS   0F
R_LENGTH DS    F                  WEB RECEIVE length
R_MAX    DS    F                  WEB RECEIVE maximum length
R_MEDIA  DS    CL56               WEB RECEIVE media type
***********************************************************************
* zDECODE communication area                                          *
* Base64Binary decoding of Basic Authentication credentials           *
***********************************************************************
C_DECODE DS   0F
C_RC     DS    CL02               Return code
         DS    CL02               Not used
C_USER   DS    CL08               UserID
C_PASS   DS    CL08               Password
C_ECODE  DS    CL24               Encoded UserID:Password
         DS    CL04               Not used
C_DCODE  DS    CL18               Decoded UserID:Password
E_DECODE EQU   *-C_DECODE         Communication data length
*
***********************************************************************
* zFAM090 communication area                                          *
* Logging for zFAM001 exceptional conditions                          *
***********************************************************************
C_LOG    DS   0F
C_STATUS DS    CL03               HTTP Status code
C_REASON DS    CL02               Reason Code
C_USERID DS    CL08               UserID
C_PROG   DS    CL08               Service program name
C_FILE   DS    CL08               File name
C_FIELD  DS    CL16               zQL field name in 412 condition
E_LOG    EQU   *-C_LOG            Commarea Data length
L_LOG    DS    H                  Commarea length
*
***********************************************************************
* Document Template names.                                            *
***********************************************************************
         DS   0F
SD_TOKEN DS    CL16               SD document token
SD_DOCT  DS   0CL48
SD_TRAN  DS    CL04               SD EIBTRNID
SD_TYPE  DS    CL02               SD Type
SD_SPACE DS    CL42               SD Spaces
         DS   0F
FD_TOKEN DS    CL16               FD document token
FD_DOCT  DS   0CL48
FD_TRAN  DS    CL04               FD EIBTRNID
FD_TYPE  DS    CL02               FD Type
FD_SPACE DS    CL42               FD Spaces
*
***********************************************************************
* SELECT options.                                                     *
* Primary Key attributes must be included for SELECT requests using   *
* secondary column index.  This is necessary as the Primary Key must  *
* be returned on all SELECT requests.                                 *
***********************************************************************
O_TABLE  DS   0F
O_P_COL  DS    PL04               Primary Key column number
O_P_LEN  DS    PL04               Primary Key field length
O_P_TYPE DS    CL01               Primary Key field type
         DS    CL03               Alignment
O_P_NAME DS    CL16               Primary Key field name
*
O_FORM   DS    CL09               Format message
*                                 FIXED     - delimited by field size
*                                 XML       - tags using field name
*                                 JSON      - tags using field name
*                                 DELIMITER - field delimiter
*                                 Default   - FIXED
*
         DS    CL03               Alignment
*
O_DIST   DS    CL03               Distinct messages returned
*                                 YES       - Duplicates not returned
*                                 NO        - Duplicates returned
*                                 Default   - NO
*
         DS    CL01               Alignment
*
O_MODE   DS    CL08               Type of SELECT process
*                                 ONLINE    - Synchronous  request
*                                 OFFLINE   - Asynchronous request
*                                 Default   - ONLINE
*
O_SORT   DS    CL16               Sort order by field name
*                                 FieldName - Ascending sort by field
*                                 Default   - Primary key
*
O_ROWS   DS    CL06               Maximum rows returned
*                                 0         - All available rows
*                                 1-999999  - Maximum rows returned
*                                 Default   - 0 (All available)
*
         DS    CL02               Alignment
O_WITH   DS    CL02               Type of Read (WITH)
*                                 UR        - Uncommitted Read
*                                 CR        - Committed   Read
*                                 Default   - UR
*
         DS    CL02               Alignment
E_TABLE  EQU   *-O_TABLE          Length of Option table
*
***********************************************************************
* End   Dynamic Storage Area                                          *
***********************************************************************
*
***********************************************************************
* Start FAxxSD DOCTEMPLATE buffer (Security Definitions)              *
***********************************************************************
*
SD_DSECT DSECT
B_TEXT   DS    CL22               Basic Mode Read Only - text
B_STATUS DS    CL03               Basic Mode Read Only - status
         DS    CL02               CRLF
Q_TEXT   DS    CL22               Query Mode Read Only - text
Q_STATUS DS    CL03               Query Mode Read Only - status
         DS    CL02               CRLF
E_PREFIX EQU   *-B_TEXT           Security Definition prefix length
*
SD_USER  DSECT
B_USER   DS    CL05               User=
S_USER   DS    CL08               UserID
         DS    CL01               ,
S_TYPE   DS    CL06               Type (Read, Write, Delete)
         DS    CL01               ,
E_SD     EQU   *-B_USER           Security levels displacement
S_LEVELS DS    CL33               Security levels
         DS    CL01               space
         DS    CL01               end of field marker
         DS    CL02               CRLF
E_USER   EQU   *-B_USER           User entry length
***********************************************************************
* End   FAxxSD DOCTEMPLATE buffer                                     *
***********************************************************************
*
***********************************************************************
* Start FAxxFD DOCTEMPLATE buffer (Field Definitions)                 *
***********************************************************************
*
FD_DSECT DSECT
         DS    CL03               ID=
F_ID     DS    CL03               Field ID
         DS    CL05               ,Col=
F_COL    DS    CL07               Field column number
         DS    CL05               ,Len=
F_LEN    DS    CL06               Field length
         DS    CL06               ,Type=
F_TYPE   DS    CL01               Field type (Character or Numeric)
         DS    CL05               ,Sec=
F_SEC    DS    CL02               Field security level
         DS    CL06               ,Name=
F_NAME   DS    CL16               Field name
         DS    CL01               end of field marker
         DS    CL02               CRLF
E_FD     EQU   *-FD_DSECT         Field Definition entry length
***********************************************************************
* End   FAxxSD DOCTEMPLATE buffer                                     *
***********************************************************************
*
***********************************************************************
* Start Parser Array (maximum 256 fields)                             *
***********************************************************************
*
PA_DSECT DSECT
P_ID     DS    PL02               Field ID
P_SEC    DS    PL02               Field level security
P_COL    DS    PL04               Field column
P_LEN    DS    PL04               Field length
P_TYPE   DS    CL01               Field type
P_WHERE  DS    CL01               WHERE indicator
P_SEG    DS    H                  Field record segment
P_NAME   DS    CL16               Field Name
E_PA     EQU   *-P_ID             PA entry length
***********************************************************************
* End   Parser Array                                                  *
***********************************************************************
*
***********************************************************************
* Start WEB RECEIVE buffer                                            *
***********************************************************************
*
WR_DSECT DSECT
***********************************************************************
* End   WEB RECEIVE buffer                                            *
***********************************************************************
*
***********************************************************************
* Start Data Container buffer                                         *
***********************************************************************
*
DC_DSECT DSECT
***********************************************************************
* End   Data Container buffer                                         *
***********************************************************************
*
***********************************************************************
* Start DFHCOMMAREA                                                   *
***********************************************************************
*
DFHCA    DSECT
C_QUERY  DS    CL8192             Query string information
***********************************************************************
* End   DFHCOMMAREA                                                   *
***********************************************************************
*
***********************************************************************
* Control Section - ZFAM001                                           *
***********************************************************************
***********************************************************************
ZFAM001  DFHEIENT CODEREG=(R2,R3,12),DATAREG=R10,EIBREG=R11
ZFAM001  AMODE 31
ZFAM001  RMODE 31
         B     SYSDATE                 BRANCH AROUND LITERALS
         DC    CL08'ZFAM001 '
         DC    CL48' -- Initial zFAM control service                '
         DC    CL08'        '
         DC    CL08'&SYSDATE'
         DC    CL08'        '
         DC    CL08'&SYSTIME'
SYSDATE  DS   0H
***********************************************************************
* Extract relevant WEB information regarding this request.            *
* Since the WEB EXTRACT command moves the Query String 'into' an area *
* instead of setting a pointer, only a three byte area is defined for *
* the EXTRACT command.  The three bytes are used to determine whether *
* the request is basic mode or query mode (zQL).  When query mode,    *
* parse the DFHCOMMAREA for the beginning of the query string and     *
* save the pointer address.  This reduces the amount of DFHEISTG      *
* storage required for the Query String and eliminates a GETMAIN.     *
*                                                                     *
* Create Access-Control-Allow-Origin HTTP Header for all zFAM modules.*
*                                                                     *
***********************************************************************
SY_0010  DS   0H
         EXEC CICS WEB WRITE                                           X
               HTTPHEADER (H_ACAO)                                     X
               NAMELENGTH (H_ACAO_L)                                   X
               VALUE      (M_ACAO)                                     X
               VALUELENGTH(M_ACAO_L)                                   X
               NOHANDLE
*
         LA    R1,E_PATH               Load path   field length
         ST    R1,L_PATH               Save path   field length
         LA    R1,E_METHOD             Load method field length
         ST    R1,L_METHOD             Save method field length
         LA    R1,E_QUERY              Load query  field length
         ST    R1,L_QUERY              Save query  field length
*
         EXEC CICS WEB EXTRACT                                         X
               SCHEME(W_SCHEME)                                        X
               HTTPMETHOD(W_METHOD)                                    X
               METHODLENGTH(L_METHOD)                                  X
               PATH(W_PATH)                                            X
               PATHLENGTH(L_PATH)                                      X
               QUERYSTRING(W_QUERY)                                    X
               QUERYSTRLEN(L_QUERY)                                    X
               NOHANDLE
*
         CLC   W_PATH(10),REPLIC8      URI '/replicate' prefix?
         BC    B'0111',*+8             ... no,  continue
         MVI   W_PREFIX,X'FF'          ... yes, set replicate flag
*
         CLC   L_QUERY,MAX_QS          Query string maximum exceeded?
         BC    B'0010',ER_41401        ... yes, set return code
*
         CLC   EIBRESP2,=F'30'         Path length exceeded?
         BC    B'1000',ER_41402        ... yes, set return code
*
         CLC   W_SCHEME,DFHVALUE(HTTP) HTTP (non-SSL) request?
         BC    B'1000',SY_0050         ... yes, skip READ HTTPHEADER
*
         CLC   W_PATH(10),URI_DS       /datastore request?
         BC    B'0111',SY_0050         ... no,  skip HTTPHEADER
*
***********************************************************************
* Read HTTPHEADER to obtain Basic Authentication credentials.         *
***********************************************************************
SY_0020  DS   0H
         LA    R1,A_LENGTH             Load header name  length
         ST    R1,L_HEADER             Save header name  length
         LA    R1,A_VAL_L              Load value  field length
         ST    R1,V_LENGTH             Save value  field length
*
         EXEC CICS WEB READ HTTPHEADER(A_HEADER)                       X
               NAMELENGTH(L_HEADER)                                    X
               VALUE(A_VALUE)                                          X
               VALUELENGTH(V_LENGTH)                                   X
               NOHANDLE
*
         OC    EIBRESP,EIBRESP         Normal response?
         BC    B'0111',ER_40101        ... no,  set return message
*
         CLC   V_LENGTH,SIX            Value length greater than six?
         BC    B'1100',ER_40102        ... no,  set return message
*
***********************************************************************
* Call zDECODE.                                                       *
* Base64Binary decoding of Basic Authentication credentials           *
***********************************************************************
SY_0030  DS   0H
         MVC   C_ECODE,A_VALUE+6       Move encoded UserID:Password
         LA    R1,C_DECODE             Load zDECODE communication area
         ST    R13,DFHEIR13            Save R13 (old RSA)
         LA    R13,DFHEISA             Load R13 (new RSA)
         L     R15,DECODE              Load zDECODE address
         BASR  R14,R15                 Call zDECODE routine
         L     R13,DFHEIR13            Load R13
*
         OC    C_USER,HEX_40           Set upper case bits on
         MVC   C_USERID,C_USER         Move UserID to logging COMMAREA
*
         CLI   C_RC+1,X'F0'            Return Code zero?
         BC    B'0111',ER_40102        ... no,  STATUS(401)
*
         EXEC CICS VERIFY USERID(C_USER) PASSWORD(C_PASS)              X
               NOHANDLE
         OC    EIBRESP,EIBRESP         Return Code zero?
         BC    B'0111',ER_40103        ... no,  STATUS(401)
*
***********************************************************************
* Get Security DOCTEMPLATE (FAxxSD)                                   *
***********************************************************************
SY_0050  DS   0H
         EXEC CICS GETMAIN                                             X
               SET(R9)                                                 X
               FLENGTH(SD_GM_L)                                        X
               INITIMG(HEX_00)                                         X
               NOHANDLE
*
         ST    R9,SD_GM                Save GETMAIN address
         USING SD_DSECT,R9             ... tell assembler
*
         MVC   SD_LEN,SD_GM_L          Set document length
         MVC   SD_TRAN(2),FA_PRE       Set document TransId prefix
         MVC   SD_TRAN+2(2),EIBTRNID+2 Set document TransID suffix
         MVC   SD_TYPE,=C'SD'          Set document type
         MVI   SD_SPACE,X'40'          Set first byte
         MVC   SD_SPACE+1(41),SD_SPACE Set remainder of bytes
*
         EXEC CICS DOCUMENT CREATE DOCTOKEN(SD_TOKEN)                  X
               TEMPLATE(SD_DOCT)                                       X
               RESP    (SD_RESP)                                       X
               NOHANDLE
*
         OC    EIBRESP,EIBRESP         Normal response?
         BC    B'0111',SY_0060         ... no,  bypass RETRIEVE
*
         EXEC CICS DOCUMENT RETRIEVE DOCTOKEN(SD_TOKEN)                X
               INTO     (SD_DSECT)                                     X
               LENGTH   (SD_LEN)                                       X
               MAXLENGTH(SD_LEN)                                       X
               RESP     (SD_RESP)                                      X
               DATAONLY                                                X
               NOHANDLE
*
         DROP  R9                      ... tell assembler
*
***********************************************************************
* Get Field    DOCTEMPLATE (FAxxFD)                                   *
***********************************************************************
SY_0060  DS   0H
         EXEC CICS GETMAIN                                             X
               SET(R9)                                                 X
               FLENGTH(FD_GM_L)                                        X
               INITIMG(HEX_00)                                         X
               NOHANDLE
*
         ST    R9,FD_GM                Save GETMAIN address
         USING FD_DSECT,R9             ... tell assembler
*
         MVC   FD_LEN,FD_GM_L          Set document length
         MVC   FD_TRAN(2),FA_PRE       Set document TransId prefix
         MVC   FD_TRAN+2(2),EIBTRNID+2 Set document TransID suffix
         MVC   FD_TYPE,=C'FD'          Set document type
         MVI   FD_SPACE,X'40'          Set first byte
         MVC   FD_SPACE+1(41),FD_SPACE Set remainder of bytes
*
         EXEC CICS DOCUMENT CREATE DOCTOKEN(FD_TOKEN)                  X
               TEMPLATE(FD_DOCT)                                       X
               RESP    (FD_RESP)                                       X
               NOHANDLE
*
         OC    EIBRESP,EIBRESP         Normal response?
         BC    B'0111',SY_0090         ... no,  bypass RETRIEVE
*
         EXEC CICS DOCUMENT RETRIEVE DOCTOKEN(FD_TOKEN)                X
               INTO     (FD_DSECT)                                     X
               LENGTH   (FD_LEN)                                       X
               MAXLENGTH(FD_LEN)                                       X
               RESP     (FD_RESP)                                      X
               DATAONLY                                                X
               NOHANDLE
*
         OC    EIBRESP,EIBRESP         Normal response?
         BC    B'0111',SY_0090         ... no,  bypass PUT CONTAINER
*
***********************************************************************
* This routine intentionally left blank.                              *
* The PUT CONTAINER for FAxxFD has been moved to BM_0400.             *
***********************************************************************
SY_0070  DS   0H
SY_0080  DS   0H
         BC    B'1111',SY_0090         Bypass PUT CONTAINER
         DROP  R9                      ... tell assembler
*
***********************************************************************
* Check mode of operation and branch accordingly.                     *
***********************************************************************
SY_0090  DS   0H
         CLC   L_QUERY,=F'3'           Three bytes present?
         BC    B'0100',BM_0010         ... no,  Basic mode request
*
         OC    W_QUERY(3),HEX_40       Set upper case bits
         CLC   W_QUERY(3),ZQL          Query Mode specified?
         BC    B'1000',QM_0010         ... yes, Query Mode request
         BC    B'0111',BM_0010         ... no,  Basic Mode request
*
***********************************************************************
* Basic Mode                                                          *
*                                                                     *
* Begin  security                                                     *
*                                                                     *
* When SCHEME is HTTP                                                 *
*     When GET                                                        *
*         When FAxxSD not defined (development only)                  *
*             XCTL ZFAM002                                            *
*         When FAxxSD is  defined (QA and production)                 *
*             When Basic Mode Read Only is enabled                    *
*                 XCTL ZFAM002                                        *
*             When Basic Mode Read Only is disabled                   *
*                 WEB SEND STATUS(401)                                *
*     When PUT, POST, DELETE                                          *
*         When FAxxSD is  defined (QA and production)                 *
*             WEB SEND STATUS(401)                                    *
*                                                                     *
* When SCHEME is HTTPS                                                *
*     When FAxxSD is defined (QA and production)                      *
*         Compare UserID with FAxxSD                                  *
*         When UserID not equal security level for type of access     *
*             WEB SEND STATUS(401)                                    *
*                                                                     *
* End of security                                                     *
*                                                                     *
* When FAxxFD and CI defined, ZFAM002 (Basic Mode) will perform the   *
*   appropriate process, then will transfer control to the following: *
*                                                                     *
*     When POST                                                       *
*         XCTL ZFAM011                                                *
*     When PUT                                                        *
*         XCTL ZFAM031                                                *
*     When DELETE                                                     *
*         XCTL ZFAM041                                                *
*                                                                     *
* At this point (all conditions confirm Basic Mode processing)        *
*     XCTL ZFAM002                                                    *
*                                                                     *
***********************************************************************
BM_0010  DS   0H
         CLI   W_PREFIX,X'FF'          URI '/replicate' prefix?
         BC    B'1000',BM_0300         ... yes, bypass security
*
         L     R9,SD_GM                Load FAxxSD address
         USING SD_DSECT,R9             ... tell assembler
         CLC   W_SCHEME,DFHVALUE(HTTP) HTTP request?
         BC    B'1000',BM_0100         ... yes, execute HTTP  security
         BC    B'0111',BM_0200         ... no,  execute HTTPS security
***********************************************************************
* SCHEME is HTTP.   Determine appropriate action                      *
***********************************************************************
BM_0100  DS   0H
         CLC   W_METHOD(3),S_GET       GET request?
         BC    B'0111',BM_0120         ... no,  check other methods
***********************************************************************
* SCHEME is HTTP  and this is a GET request                           *
***********************************************************************
BM_0110  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'0111',BM_0300         ... no,  Check for FAxxFD
*        BC    B'0111',BM_0500         ... no,  XCTL to ZFAM002
         OC    B_STATUS,HEX_40         Set upper case bits
         CLC   B_STATUS,S_YEA          BM Read Only enabled?
         BC    B'1000',BM_0300         ... yes, Check for FAxxFD
*        BC    B'1000',BM_0500         ... yes, XCTL to ZFAM002
         BC    B'0111',ER_40104        ... no,  STATUS(401)
***********************************************************************
* SCHEME is HTTP  and this is a PUT, POST, DELETE request             *
***********************************************************************
BM_0120  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'1000',ER_40105        ... yes, STATUS(401)
         BC    B'0111',BM_0300         ... no,  continue validation
***********************************************************************
* SCHEME is HTTPS.  Determine appropriate action                      *
***********************************************************************
BM_0200  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'0111',BM_0300         ... no,  continue validation
*
         LA    R4,E_USER               Load user  entry length
         L     R5,SD_LEN               Load SD template length
         LA    R6,E_PREFIX             Load SD prefix length
         SR    R5,R6                   Subtract prefix length
         AR    R9,R6                   Point to User entry
         USING SD_USER,R9              ... tell assembler
*
***********************************************************************
* Parse SD entry until EOT or a UserID match                          *
***********************************************************************
BM_0210  DS   0H
         CLC   S_USER,C_USER           UserID match FAxxSD?
         BC    B'1000',BM_0220         ... yes, check access level
BM_0211  DS    0H
         LA    R9,0(R4,R9)             Point to next entry
         SR    R5,R4                   Subtract user entry length
         BC    B'0010',BM_0210         Continue search
         BC    B'1111',ER_40106        EOT, STATUS(401)
***********************************************************************
* UserID matches FAxxSD entry.                                        *
* Now check HTTP METHOD and branch to compare with security entry     *
***********************************************************************
BM_0220  DS   0H
         OC    S_TYPE,HEX_40           Set upper case bits
         CLC   W_METHOD(4),S_POST      POST   request?
         BC    B'1000',BM_0221         ... yes, check SD type
         CLC   W_METHOD(3),S_GET       GET    request?
         BC    B'1000',BM_0222         ... yes, check SD type
         CLC   W_METHOD(3),S_PUT       PUT    request?
         BC    B'1000',BM_0223         ... yes, check SD type
         CLC   W_METHOD(6),S_DELETE    DELETE request?
         BC    B'1000',BM_0224         ... yes, check SD type
         BC    B'0111',ER_40001        ... no,  WEB SEND STATUS(400)
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* POST   must match request type of 'Write '                          *
***********************************************************************
BM_0221  DS   0H
         CLC   S_TYPE,S_WRITE          Security entry for 'Write'?
         BC    B'0111',BM_0211         ... no,  continue search
         OI    S_LEVELS,X'40'          Set upper case bit
         CLI   S_LEVELS,C'X'           Row level (0) set?
         BC    B'1000',BM_0300         ... yes, continue validation
         BC    B'1111',ER_40107        ... no,  STATUS(401)
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* GET    must match request type of 'Read  '                          *
***********************************************************************
BM_0222  DS   0H
         CLC   S_TYPE,S_READ           Security entry for 'Read'?
         BC    B'0111',BM_0211         ... no,  continue search
         OI    S_LEVELS,X'40'          Set upper case bit
         CLI   S_LEVELS,C'X'           Row level (0) set?
         BC    B'1000',BM_0300         ... yes, continue validation
         BC    B'1111',ER_40108        ... no,  STATUS(401)
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* PUT    must match request type of 'Write '                          *
***********************************************************************
BM_0223  DS   0H
         CLC   S_TYPE,S_WRITE          Security entry for 'Write'?
         BC    B'0111',BM_0211         ... no,  continue search
         OI    S_LEVELS,X'40'          Set upper case bit
         CLI   S_LEVELS,C'X'           Row level (0) set?
         BC    B'1000',BM_0300         ... yes, continue validation
         BC    B'1111',ER_40109        ... no,  STATUS(401)
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* DELETE must match request type of 'Delete'                          *
***********************************************************************
BM_0224  DS   0H
         CLC   S_TYPE,S_DELETE         Security entry for 'Delete'?
         BC    B'0111',BM_0211         ... no,  continue search
         OI    S_LEVELS,X'40'          Set upper case bit
         CLI   S_LEVELS,C'X'           Row level (0) set?
         BC    B'1000',BM_0300         ... yes, continue validation
         BC    B'1111',ER_40110        ... no,  STATUS(401)
*
***********************************************************************
* At this point, all validation rules have been performed for         *
* Basic Mode.  Prior to this routine, a BRANCH could have been made   *
* to XCTL to ZFAM002.  All other cases fall thru to this routine to   *
* determine if Basic Mode is being requested for a table that has     *
* fields defined.  If any of the fields are defined as Column Index,  *
* issue PUT CONTAINER for FAxxFD, which will be used by zFAM002 to    *
* LINK to program to process secondary column indexes.                *
***********************************************************************
BM_0300  DS   0H
         DROP  R9                      ... tell assembler
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         OC    FD_RESP,FD_RESP         FAxxFD defined?
         BC    B'0111',BM_0500         ... no,  XCTL ZFAM002
         LA    R4,E_FD                 Load field entry length
         L     R5,FD_LEN               Load FD template length
***********************************************************************
* Parse FD entry until EOT or a column index is encountered           *
***********************************************************************
BM_0310  DS   0H
         CLC   F_COL,=C'0000001'       Column number 1 (primary key)?
         BC    B'1000',BM_0320         ... yes, skip this one
         CLC   F_ID,=C'000'            Field ID number?
         BC    B'0010',BM_0400         ... no,  Basic Mode CI process
***********************************************************************
* Point to next entry until EOT                                       *
***********************************************************************
BM_0320  DS   0H
         LA    R9,0(R4,R9)             Point to next entry
         SR    R5,R4                   Subtract field entry length
         BC    B'0010',BM_0310         Continue search
         BC    B'1111',BM_0500         EOT, standard Basic Mode
***********************************************************************
* Basic Mode with FAxxFD and column index defined.                    *
* Transfer control to Basic Mode (row level) service program and      *
* provide the FXxxFD.  This will signal ZFAM002 to transfer control   *
* to the Column Index service program to insert/update the secondary  *
* Column Index stores.                                                *
***********************************************************************
BM_0400  DS   0H
         MVC   W_ADDR,FD_GM            Move FAxxFD address
         MVC   W_LENGTH,FD_LEN         Move FAxxFD length
         MVC   W_NAME,C_FAXXFD         Move FAxxFD container name
         BAS   R14,PC_0010             Issue PUT CONTAINER
***********************************************************************
* Basic Mode primary program.                                         *
***********************************************************************
BM_0500  DS   0H
         MVC   BM_PROG,ZFAM002         Move Basic Mode primary program
*
***********************************************************************
* Transfer control to Basic Mode (row level) program                  *
***********************************************************************
BM_0600  DS   0H
         EXEC CICS XCTL PROGRAM(BM_PROG)                               X
               CHANNEL(C_CHAN)                                         X
               NOHANDLE
         BC    B'1111',ER_50001        Oops, something's wrong!
*
***********************************************************************
* Query Mode                                                          *
*                                                                     *
* When POST/PUT                                                       *
*     WEB RECEIVE                                                     *
*                                                                     *
* GETMAIN parser array storage                                        *
*                                                                     *
* Parse querystring (GET/DELETE) or buffer (POST/PUT)                 *
* Create primary key container                                        *
* Create field/data containers                                        *
* Create array of container names                                     *
* Create array container                                              *
* Create WITH UR/CR container (for LOCK logic)                        *
*                                                                     *
* Begin  Query Mode security                                          *
*                                                                     *
* When SCHEME is HTTP                                                 *
*     When GET                                                        *
*         When FAxxSD is  defined (QA and production)                 *
*             When Query Mode Read Only is disabled                   *
*                 WEB SEND STATUS(401)                                *
*             When Query Mode Read Only is enabled                    *
*                 Bypass field level security                         *
*         When FAxxSD not defined (development)                       *
*             Bypass security                                         *
*                                                                     *
*     When PUT, POST, DELETE                                          *
*         When FAxxSD is  defined (QA and production)                 *
*             WEB SEND STATUS(401)                                    *
*         When FAxxSD not defined (development)                       *
*             Bypass security                                         *
*                                                                     *
* When SCHEME is HTTPS                                                *
*     When FAxxSD is  defined (QA and production                      *
*         Parse FAxxSD until match on UserID                          *
*         When UserID not equal security level for type of access     *
*             WEB SEND STATUS(401)                                    *
*     When FAxxSD not defined (development)                           *
*         Bypass security                                             *
*                                                                     *
* End of Query Mode security                                          *
*                                                                     *
*                                                                     *
*                                                                     *
* When POST                                                           *
*         XCTL ZFAM010                                                *
*                                                                     *
* When GET                                                            *
*     When SELECT specifies primary column index                      *
*         XCTL ZFAM020                                                *
*     When SELECT specifies secondary column index                    *
*         XCTL ZFAM022                                                *
*                                                                     *
* When PUT                                                            *
*         XCTL ZFAM030                                                *
*                                                                     *
* When DELETE                                                         *
*         XCTL ZFAM040                                                *
*                                                                     *
*                                                                     *
***********************************************************************
***********************************************************************
* Query Mode process.                                                 *
***********************************************************************
***********************************************************************
*                                                                     *
***********************************************************************
* Issue GETMAIN for parser array                                      *
***********************************************************************
QM_0010  DS   0H
         OC    FD_RESP,FD_RESP         FAxxFD defined?
         BC    B'0111',ER_40505        ... no,  Query Mode not allowed
*
         EXEC CICS GETMAIN                                             X
               SET(R8)                                                 X
               FLENGTH(PA_GM_L)                                        X
               INITIMG(HEX_00)                                         X
               NOHANDLE
*
         ST    R8,PA_GM                Save GETMAIN address
         MVC   PA_LEN,PA_GM_L          Save GETMAIN length
***********************************************************************
* When POST/PUT requests, issue WEB RECEIVE                           *
***********************************************************************
QM_0020  DS   0H
         CLC   W_METHOD(6),S_DELETE    DELETE request?
         BC    B'1000',QM_0030         ... yes, nothing to receive
         CLC   W_METHOD(3),S_GET       GET    request?
         BC    B'1000',QM_0030         ... yes, nothing to receive
*
         MVC   R_LENGTH,S_WR_LEN       Move WEB RECEIVE length
         MVC   R_MAX,S_WR_LEN          Move WEB RECEIVE length
*
         EXEC CICS WEB RECEIVE                                         X
               SET(R8)                                                 X
               LENGTH   (R_LENGTH)                                     X
               MAXLENGTH(R_MAX)                                        X
               MEDIATYPE(R_MEDIA)                                      X
               SRVCONVERT                                              X
               NOHANDLE
         ST    R8,WR_ADDR              Save WEB RECEIVE buffer address
*
         CLC   EIBRESP2,=F'16'         MAXLENGTH exceeded?
         BC    B'1000',ER_41301        ... yes, set return code
*
         CLC   R_LENGTH,=F'00'         Length received is zero?
         BC    B'1000',ER_41101        ... yes, set return code
*
         OC    EIBRESP,EIBRESP         Normal response?
         BC    B'0111',ER_40003        ... no,  set return code
***********************************************************************
* Check method and branch accordingly                                 *
***********************************************************************
QM_0030  DS   0H
         CLC   W_METHOD(4),S_POST      POST   request?
         BC    B'1000',QM_0100         ... yes, parse POST   request
         CLC   W_METHOD(3),S_GET       GET    request?
         BC    B'1000',QM_0200         ... yes, parse GET    request
         CLC   W_METHOD(3),S_PUT       PUT    request?
         BC    B'1000',QM_0300         ... yes, parse PUT    request
         CLC   W_METHOD(6),S_DELETE    DELETE request?
         BC    B'1000',QM_0400         ... yes, parse DELETE request
         BC    B'1111',ER_40004        ... no,  send STATUS(400)
*
***********************************************************************
* Parse POST   request, using WEB RECEIVE input                       *
***********************************************************************
QM_0100  DS   0H
         L     R4,R_LENGTH             Load RECEIVE length
         L     R5,WR_ADDR              Load RECEIVE address
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(6,R5),S_INSERT        Is this an INSERT command?
         BC    B'0111',ER_40501        ... no,  invalid command
         LA    R5,6(,R5)               Point to next byte
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',QM_0500         INSERT with no fields
*                                      ... this is actually ok
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40006        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
***********************************************************************
* Check POST   request for zQL commands.                              *
* Valid commands are FIELDS and TTL.                                  *
***********************************************************************
QM_0110  DS   0H
         LA    R0,QM_0110              Mark the spot
         CLI   0(R5),C'('              Open parenthesis?
         BC    B'0111',ER_40006        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(3,R5),S_TTL           Is this a TTL    command?
         BC    B'1000',QM_0120         ... yes, process
         CLC   0(6,R5),S_FIELDS        Is this a FIELDS command?
         BC    B'1000',QM_0130         ... yes, process
         BC    B'1111',ER_40006        ... no,  syntax error
***********************************************************************
* Process TTL command                                                 *
***********************************************************************
QM_0120  DS   0H
         CLI   W_TTL,C'Y'              TTL   command performed?
         BC    B'1000',ER_40006        ... yes, syntax error
***********************************************************************
* Begin parsing TTL command                                           *
***********************************************************************
QM_0121  DS   0H
         LA    R0,QM_0121              Mark the spot
         LA    R5,3(,R5)               Point past command
         S     R4,=F'03'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
*
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40006        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
         XR    R1,R1                   Clear counter
         ST    R5,W_ADDR               Save beginning TTL address
***********************************************************************
* Determine length of TTL and perform editing.                        *
***********************************************************************
QM_0122  DS   0H
         LA    R0,QM_0122              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0123         ... yes, continue process
         CLI   0(R5),X'F0'             Compare TTL byte to zero
         BC    B'0100',ER_40006        ... when less, syntax error
         CLI   0(R5),X'FA'             Compare TTL byte to FA+
         BC    B'1010',ER_40006        ... when more, syntax error
         C     R1,=F'5'                Maximum TTL length?
         BC    B'0010',ER_40006        ... yes, syntax error
*
         LA    R1,1(,R1)               Increment TTL length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0122              Continue parsing
         BC    B'1100',ER_40006        Syntax error when EOQS
***********************************************************************
* Issue PUT CONTAINER for TTL field                                   *
***********************************************************************
QM_0123  DS   0H
         LA    R0,QM_0123              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
*
         CLI   0(R5),C')'              Close parenthesis?
         BC    B'0111',ER_40006        ... no,  syntax error
*
         MVI   W_TTL,C'Y'              Mark TTL command complete
*
         MVC   W_NAME,C_TTL            Move TTL container name
         ST    R1,W_LENGTH             Save data length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0123              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1000',QM_0500         When zero, parsing complete
*
         CLI   0(R5),C','              Comma?
         BC    B'0111',ER_40006        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
         BC    B'1111',QM_0110         Continue POST parsing
***********************************************************************
* FIELDS command                                                      *
***********************************************************************
QM_0130  DS   0H
         CLI   W_FIELDS,C'Y'           FIELDS  command performed?
         BC    B'1000',ER_40006        ... yes, syntax error
*
         LA    R5,6(,R5)               Point past command
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
***********************************************************************
* Begin parsing FIELDS command                                        *
***********************************************************************
QM_0131  DS   0H
         LA    R0,QM_0131              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40006        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1 (counter)
         ST    R5,W_ADDR               Save beginning address
         LR    R15,R5                  Load beginning address
***********************************************************************
* Determine field name length.                                        *
***********************************************************************
QM_0132  DS    0H
         LA    R0,QM_0132              Mark the spot
         CLI   0(R5),C'='              Equal sign?
         BC    B'1000',QM_0133         ... yes, process
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40006        ... yes, syntax error
         LA    R1,1(,R1)               Increment field name length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0132              Continue evaluation
         BC    B'1111',ER_40006        EOF, syntax error
***********************************************************************
* Address FAxxFD table                                                *
***********************************************************************
QM_0133  DS    0H
         LA    R0,QM_0133              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         L     R7,FD_LEN               Load FD table length
         LA    R6,E_FD                 Load FD entry length
         S     R1,ONE                  Adjust before EX command
***********************************************************************
* Verify the field name is in FAxxFD                                  *
***********************************************************************
QM_0134  DS    0H
         LA    R0,QM_0134              Mark the spot
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0134             Field name match?
         BC    B'1000',QM_0135         ... yes, process
         LA    R9,0(R6,R9)             Point to next FD entry
         SR    R7,R6                   Reduce total length by an entry
         BC    B'0010',QM_0134         Continue search
         MVC   C_FIELD,HEX_40          Move spaces to field name
         LA    R14,C_FIELD             Point to field name
         EX    R1,MVC_0134             Move field name to diagnostics
         BC    B'1111',ER_41201        ... EOF, syntax error
CLC_0134 CLC   0(0,R14),0(R15)         Check field name
MVC_0134 MVC   0(0,R14),0(R15)         Move  field name
***********************************************************************
* Move field name to parser array                                     *
***********************************************************************
QM_0135  DS    0H
         LA    R0,QM_0135              Mark the spot
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0135             Set container name
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         LA    R8,0(R7,R8)             Point to current PA entry
*
         LA    R1,1(,R1)               Increment PA index
         ST    R1,W_INDEX              Save PA index
         C     R1,MAX_PA               PA index exceeded?
         BC    B'0010',ER_41403        ... yes, STATUS(414)
*
         MVC   P_NAME,F_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
         BC    B'1111',QM_0136         Determine field length
*
MVC_0135 MVC   0(0,R14),0(R15)         Set container name
***********************************************************************
* Determine length of data for this field                             *
***********************************************************************
QM_0136  DS   0H
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0137         ... yes, PUT CONTAINER
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field length
         C     R1,MAX_LEN              Field length exceed maximum?
         BCT   R4,QM_0136              Continue parsing
         BC    B'1111',ER_40006        Syntax error when zero
***********************************************************************
* Issue PUT CONTAINER for this field data                             *
***********************************************************************
QM_0137  DS   0H
         LA    R0,QM_0137              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when zero
*
         ST    R1,W_LENGTH             Save data length
         BAS   R14,PC_0010             Issue PUT CONTAINER
***********************************************************************
* When Column ID is 001, issue PUT CONTAINER for primary key          *
***********************************************************************
         CP    P_ID,S_ONE_PD           Primary Column ID?
         BC    B'0111',QM_0138         ... no,  continue process
         MVC   W_NAME,C_KEY            Move KEY container name
         BAS   R14,PC_0010             PUT CONTAINER with PRIMARY key
***********************************************************************
* Continue field syntax editing.                                      *
***********************************************************************
QM_0138  DS   0H
         LA    R0,QM_0138              Mark the spot
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'1000',QM_0139         ... yes, prepare to parse
*
         CLI   0(R5),C')'              Close Parenthesis?
         BC    B'0111',ER_40006        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing is complete
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40006        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40006        When zero, syntax error
         MVI   W_FIELDS,C'Y'           Set FIELDS command complete
         BC    B'1111',QM_0110         Continue parsing
*
***********************************************************************
* Prepare to parse next FIELDS request                                *
***********************************************************************
QM_0139  DS   0H
         LA    R0,QM_0139              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40006        Syntax error when EOQS
         BC    B'1111',QM_0131         Continue with FIELDS
*
***********************************************************************
* Parse GET    request, using Query String                            *
* Since the WEB EXTRACT command moves the Query String 'into' an area *
* instead of setting a pointer, only a three byte area is defined for *
* the EXTRACT command.  The three bytes are used to determine whether *
* the request is basic mode or query mode (zQL).  When query mode,    *
* parse the DFHCOMMAREA for the beginning of the query string and     *
* save the pointer address.  This reduces the amount of DFHEISTG      *
* storage required for the Query String and eliminates a GETMAIN.     *
***********************************************************************
QM_0200  DS   0H
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
*
         MVC   O_P_NAME,F_NAME         Move field name     to OT
         MVC   O_P_TYPE,F_TYPE         Move field type     to OT
         PACK  O_P_COL,F_COL           Pack field column   to OT
         PACK  O_P_LEN,F_LEN           Pack field length   to OT
*
         MVC   O_FORM,S_FIXED          Set default OPTIONS FORMAT
         MVC   O_DIST,S_NO             Set default OPTIONS DISTINCT
         MVC   O_MODE,S_ON             Set default OPTIONS MODE
         MVC   O_ROWS,S_ZEROES         Set default OPTIONS ROWS
         MVC   O_SORT,HEX_40           Set default OPTIONS SORT
         MVC   O_WITH,S_UR             Set default OPTIONS WITH
*
         BAS   R14,TR_0010             Execute Trace entry
*
         BAS   R14,CA_0010             Parse DFHCOMMAREA for QS
         USING DFHCA,R5                ... tell assembler
         L     R4,L_QUERY              Load query string length
         LA    R5,3(,R5)               Skip past the ZQl command
         S     R4,=F'03'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(6,R5),S_SELECT        Is this a SELECT command?
         BC    B'0111',ER_40502        ... no,  invalid command
         LA    R5,6(,R5)               Point to next byte
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
***********************************************************************
* Check GET    request for zQL commands.                              *
* Valid commands are WHERE, WITH, FIELDS, and OPTIONS                 *
***********************************************************************
QM_0210  DS   0H
         LA    R0,QM_0210              Mark the spot
         CLI   0(R5),C'('              Open parenthesis?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         OC    0(4,R5),HEX_40          Set upper case bits
         CLC   0(4,R5),S_WITH          Is this a  WITH    command?
         BC    B'1000',QM_0220         ... yes, process
*
         OC    0(5,R5),HEX_40          Set upper case bits
         CLC   0(5,R5),S_WHERE         Is this a  WHERE   command?
         BC    B'1000',QM_0240         ... yes, process
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(6,R5),S_FIELDS        Is this a  FIELDS  command?
         BC    B'1000',QM_0230         ... yes, process
*
         OC    0(7,R5),HEX_40          Set upper case bits
         CLC   0(7,R5),S_OPTION        Is this an OPTIONS command?
         BC    B'1000',QM_0250         ... yes, process
         BC    B'1000',ER_40007        ... no,  syntax error
***********************************************************************
* WITH command                                                        *
***********************************************************************
QM_0220  DS   0H
         LA    R0,QM_0220              Mark the spot
         CLI   W_WITH,C'Y'             WITH   command performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,4(,R5)               Point past command
         S     R4,=F'04'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         OC    0(2,R5),HEX_40          Set upper case bits
         CLC   0(2,R5),S_UR            Uncommitted read request?
         BC    B'1000',QM_0221         ... yes, continue
         CLC   0(2,R5),S_CR            Committed   read request?
         BC    B'1000',QM_0221         ... yes, continue
         BC    B'1111',ER_40007        ... no,  syntax error
***********************************************************************
* Save WITH request and prepare for next parm.                        *
***********************************************************************
QM_0221  DS    0H
         LA    R0,QM_0221              Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,2(,R5)               Point to next byte
         S     R4,=F'02'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C')'              Close parenthesis
         BC    B'0111',ER_40007        ... no,  syntax error
*
***********************************************************************
* Move WITH UR/CR to OPTIONS table.                                   *
***********************************************************************
QM_0222  DS    0H
         MVI   W_WITH,C'Y'             Mark WITH command complete
*
         L     R1,W_ADDR               Load WITH address
         MVC   O_WITH,0(R1)            Move WITh parameter
*
         LA    R0,QM_0222              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1000',QM_0500         When zero, parsing complete
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0210         Continue parsing
***********************************************************************
* FIELDS command                                                      *
***********************************************************************
QM_0230  DS   0H
         LA    R0,QM_0230              Mark the spot
         CLI   W_FIELDS,C'Y'           FIELDS  command performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,6(,R5)               Point past command
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
***********************************************************************
* Begin parsing FIELDS command                                        *
***********************************************************************
QM_0231  DS   0H
         LA    R0,QM_0231              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1 (counter)
         ST    R5,W_ADDR               Save beginning address
         LR    R15,R5                  Load beginning address
***********************************************************************
* Determine field name length.                                        *
***********************************************************************
QM_0232  DS    0H
         LA    R0,QM_0232              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0233         ... yes, process
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40007        ... yes, syntax error
         LA    R1,1(,R1)               Increment field name length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0232              Continue evaluation
         BC    B'1111',ER_40007        EOF, syntax error
***********************************************************************
* Address FAxxFD table                                                *
***********************************************************************
QM_0233  DS    0H
         LA    R0,QM_0233              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         L     R7,FD_LEN               Load FD table length
         LA    R6,E_FD                 Load FD entry length
         S     R1,ONE                  Adjust before EX command
***********************************************************************
* Verify the field name is in FAxxFD                                  *
***********************************************************************
QM_0234  DS    0H
         LA    R0,QM_0234              Mark the spot
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0234             Field name match?
         BC    B'1000',QM_0235         ... yes, process
         LA    R9,0(R6,R9)             Point to next FD entry
         SR    R7,R6                   Reduce total length by an entry
         BC    B'0010',QM_0234         Continue search
         MVC   C_FIELD,HEX_40          Move spaces to field name
         LA    R14,C_FIELD             Point to field name
         EX    R1,MVC_0234             Move field name to diagnostics
         BC    B'1111',ER_41202        ... EOF, syntax error
CLC_0234 CLC   0(0,R14),0(R15)         Check field name
MVC_0234 MVC   0(0,R14),0(R15)         Move  field name
*
***********************************************************************
* Move field name to parser array                                     *
***********************************************************************
QM_0235  DS    0H
         LA    R0,QM_0235              Mark the spot
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0235             Set container name
*
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         LA    R8,0(R7,R8)             Point to current PA entry
*
         LA    R1,1(,R1)               Increment PA index
         ST    R1,W_INDEX              Save PA index
         C     R1,MAX_PA               PA index exceeded?
         BC    B'0010',ER_41404        ... yes, STATUS(414)
*
         MVI   P_WHERE,C'N'            Move WHERE indicator (no)
         MVC   P_NAME,F_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'1000',QM_0236         ... yes, prepare to parse
*
         CLI   0(R5),C')'              Close Parenthesis?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing is complete
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        When zero, syntax error
         MVI   W_FIELDS,C'Y'           Set FIELDS command complete
         BC    B'1111',QM_0210         Continue parsing
*
MVC_0235 MVC   0(0,R14),0(R15)         Set container name
***********************************************************************
* Prepare to parse next FIELDS request                                *
***********************************************************************
QM_0236  DS   0H
         LA    R0,QM_0236              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0231         Continue with FIELDS
***********************************************************************
* WHERE  command                                                      *
***********************************************************************
QM_0240  DS   0H
         CLI   W_WHERE,C'Y'            WHERE  command performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,5(,R5)               Point past command
         S     R4,=F'05'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
***********************************************************************
* Begin parsing WHERE command                                         *
***********************************************************************
QM_0241  DS   0H
         LA    R0,QM_0241              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1 (counter)
         ST    R5,W_ADDR               Save beginning address
         LR    R15,R5                  Load beginning address
***********************************************************************
* Determine field name length.                                        *
***********************************************************************
QM_0242  DS    0H
         LA    R0,QM_0242              Mark the spot
         CLI   0(R5),C'='              Equal sign (end of field)?
         BC    B'1000',QM_0243         ... yes, process
*
         CLI   0(R5),C'>'              Greater Than sign (EOF)?
         BC    B'1000',QM_0243         ... yes, process
*
         CLI   0(R5),C'+'              GTEQ sign (EOF)?
         BC    B'1000',QM_0243         ... yes, process
*
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40007        ... yes, syntax error
         LA    R1,1(,R1)               Increment field name length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0242              Continue evaluation
         BC    B'1111',ER_40007        EOF, syntax error
***********************************************************************
* Address FAxxFD table                                                *
***********************************************************************
QM_0243  DS    0H
         MVC   W_SIGN,0(R5)            Move type of sign (= > +)
         LA    R0,QM_0243              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         L     R7,FD_LEN               Load FD table length
         LA    R6,E_FD                 Load FD entry length
         S     R1,ONE                  Adjust before EX command
***********************************************************************
* Verify the field name is in FAxxFD                                  *
***********************************************************************
QM_0244  DS    0H
         LA    R0,QM_0244              Mark the spot
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0244             Field name match?
         BC    B'1000',QM_0245         ... yes, process
         LA    R9,0(R6,R9)             Point to next FD entry
         SR    R7,R6                   Reduce total length by an entry
         BC    B'0010',QM_0244         Continue search
         BC    B'1111',ER_40007        EOF, syntax error
CLC_0244 CLC   0(0,R14),0(R15)         Check field name
***********************************************************************
* Move field name to parser array                                     *
***********************************************************************
QM_0245  DS    0H
         LA    R0,QM_0245              Mark the spot
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0245             Set container name
*
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         LA    R8,0(R7,R8)             Point to current PA entry
*
         LA    R1,1(,R1)               Increment PA index
         ST    R1,W_INDEX              Save PA index
         C     R1,MAX_PA               PA index exceeded?
         BC    B'0010',ER_41405        ... yes, STATUS(414)
*
*        MVI   P_WHERE,C'Y'            Move WHERE indicator
         MVC   P_WHERE,W_SIGN          Move WHERE sign     to PA
*
         MVC   P_NAME,F_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
         BC    B'1111',QM_0246         Determine field length
MVC_0245 MVC   0(0,R14),0(R15)         Set container name
***********************************************************************
* Determine length of data for this field                             *
***********************************************************************
QM_0246  DS   0H
         LA    R0,QM_0246              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0247         ... yes, PUT CONTAINER
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field length
         C     R1,MAX_LEN              Field length exceed maximum?
         BC    B'1000',ER_40007        ... yes, syntax error
         BCT   R4,QM_0246              Continue parsing
         BC    B'1111',ER_40007        Syntax error when zero
***********************************************************************
* Issue PUT CONTAINER for field data                                  *
***********************************************************************
QM_0247  DS   0H
         LA    R0,QM_0247              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         ST    R1,W_LENGTH             Save field length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0247              Mark the spot
*
         CLC   0(3,R5),S_AND           AND clause?
         BC    B'1000',QM_0248         ... yes, adjust address/length
*
         CLI   0(R5),C','              Is this byte a comma?
         BC    B'1000',QM_0249         ... yes, adjust address/length
*
         CLI   0(R5),C')'              Close parenthesis?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing is complete
         CLI   0(R5),C','              Is the next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        When zero, sytax error
         MVI   W_WHERE,C'Y'            Set WHERE  command complete
         BC    B'1111',QM_0210         Continue parsing
*
***********************************************************************
* AND clause on WHERE statement                                       *
***********************************************************************
QM_0248  DS   0H
         LA    R0,QM_0248              Mark the spot
         LA    R5,3(,R5)               Point to past AND
         S     R4,=F'3'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0241         Continue WHERE parsing
***********************************************************************
* Comma between WHERE statements                                      *
***********************************************************************
QM_0249  DS   0H
         LA    R0,QM_0249              Mark the spot
         LA    R5,1(,R5)               Point to past AND
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0241         Continue WHERE parsing
***********************************************************************
* OPTIONS command                                                     *
***********************************************************************
QM_0250  DS   0H
         CLI   W_OPTION,C'Y'           OPTIONS command performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,7(,R5)               Point past command
         S     R4,=F'07'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
***********************************************************************
* Begin parsing OPTIONS command                                       *
* Valid parameters are FORMAT, DISTINCT, MODE, SORT and ROWS.         *
***********************************************************************
QM_0251  DS   0H
         LA    R0,QM_0251              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLC   0(6,R5),S_FORMAT        Is this a  FORMAT   parm?
         BC    B'1000',QM_0252         ... yes, process
         CLC   0(8,R5),S_DIST          Is this a  DISTINCT parm?
         BC    B'1000',QM_0253         ... yes, process
         CLC   0(4,R5),S_MODE          Is this a  MODE     parm?
         BC    B'1000',QM_0254         ... yes, process
         CLC   0(4,R5),S_SORT          Is this a  SORT     parm?
         BC    B'1000',QM_0255         ... yes, process
         CLC   0(4,R5),S_ROWS          Is this a  ROWS     parm?
         BC    B'1000',QM_0256         ... yes, process
         BC    B'1111',ER_40007        ... no,  syntax error
*
***********************************************************************
* FORMAT   parameter specified.                                       *
***********************************************************************
QM_0252  DS   0H
         LA    R0,QM_0252              Mark the spot
         CLI   W_FORM,C'Y'             FORMAT   parm performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,6(,R5)               Point past command
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'='              Equal sign?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLC   0(5,R5),S_FIXED         FIXED format?
         BC    B'1000',QM_0252A        ... yes, continue
         CLC   0(3,R5),S_XML           XML format?
         BC    B'1000',QM_0252B        ... yes, continue
         CLC   0(4,R5),S_JSON          JSON format?
         BC    B'1000',QM_0252C        ... yes, continue
         CLC   0(9,R5),S_DELIM         DELIMITER format?
         BC    B'1000',QM_0252D        ... yes, continue
*
         BC    B'1111',ER_40007        ... no,  syntax error
***********************************************************************
* Move FIXED format parameter to OPTIONS table                        *
***********************************************************************
QM_0252A DS    0H
         LA    R0,QM_0252A             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,5(,R5)               Point to next byte
         S     R4,=F'05'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_FORM,C'Y'             Mark FORMAT   parm complete
         MVC   O_FORM,S_FIXED          Move FIXED parm
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
***********************************************************************
* Move XML   format parameter to OPTIONS table                        *
***********************************************************************
QM_0252B DS    0H
         LA    R0,QM_0252B             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,3(,R5)               Point to next byte
         S     R4,=F'03'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_FORM,C'Y'             Mark FORMAT   parm complete
         MVC   O_FORM,S_XML            Move XML   parm
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
***********************************************************************
* Move JSON  format parameter to OPTIONS table                        *
***********************************************************************
QM_0252C DS    0H
         LA    R0,QM_0252C             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,4(,R5)               Point to next byte
         S     R4,=F'04'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_FORM,C'Y'             Mark FORMAT   parm complete
         MVC   O_FORM,S_JSON           Move JSON  parm
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
***********************************************************************
* Move DELIMITER format parameter to OPTIONS table                    *
***********************************************************************
QM_0252D DS    0H
         LA    R0,QM_0252D             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,9(,R5)               Point to next byte
         S     R4,=F'09'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_FORM,C'Y'             Mark FORMAT   parm complete
         MVC   O_FORM,S_DELIM          Move DELIMITER parm
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
***********************************************************************
* DISTINCT parameter specified.                                       *
***********************************************************************
QM_0253  DS   0H
         LA    R0,QM_0253              Mark the spot
         CLI   W_DIST,C'Y'             DISTINCT parm performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,8(,R5)               Point past command
         S     R4,=F'08'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'='              Equal sign?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLC   0(3,R5),S_YES           DISTINCT=YES?
         BC    B'1000',QM_0253A        ... yes, continue
         CLC   0(2,R5),S_NO            DISTINCT=NO?
         BC    B'1000',QM_0253B        ... yes, continue
*
         BC    B'1111',ER_40007        ... no,  syntax error
***********************************************************************
* Move DISTINCT=YES to OPTIONS table                                  *
***********************************************************************
QM_0253A DS    0H
         LA    R0,QM_0253A             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,3(,R5)               Point to next byte
         S     R4,=F'03'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_DIST,C'Y'             Mark DISTINCT parm complete
         MVC   O_DIST,S_YES            Move DISTINCT=YES
         BC    B'1111',QM_025X         Continue FORMAT parsing
***********************************************************************
* Move DISTINCT=NO  to OPTIONS table                                  *
***********************************************************************
QM_0253B DS    0H
         LA    R0,QM_0253B             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,2(,R5)               Point to next byte
         S     R4,=F'02'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_DIST,C'Y'             Mark DISTINCT parm complete
         MVC   O_DIST,S_NO             Move DISTINCT=NO
         BC    B'1111',QM_025X         Continue FORMAT parsing
***********************************************************************
* MODE parameter specified.                                           *
***********************************************************************
QM_0254  DS   0H
         LA    R0,QM_0254              Mark the spot
         CLI   W_MODE,C'Y'             MODE     parm performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,4(,R5)               Point past command
         S     R4,=F'04'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'='              Equal sign?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLC   0(6,R5),S_ON            MODE=ONLINE?
         BC    B'1000',QM_0254A        ... yes, continue
         CLC   0(7,R5),S_OFF           MODE=OFFLINE?
         BC    B'1000',QM_0254B        ... yes, continue
*
         BC    B'1111',ER_40007        ... no,  syntax error
***********************************************************************
* Move MODE=ONLINE  to OPTIONS table                                  *
***********************************************************************
QM_0254A DS    0H
         LA    R0,QM_0254A             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,6(,R5)               Point to next byte
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_MODE,C'Y'             Mark MODE     parm complete
         MVC   O_MODE,S_ON             Move MODE=ONLINE
         BC    B'1111',QM_025X         Continue FORMAT parsing
***********************************************************************
* Move MODE=OFLINE  to OPTIONS table                                  *
***********************************************************************
QM_0254B DS    0H
         LA    R0,QM_0254B             Mark the spot
         ST    R5,W_ADDR               Save current pointer address
         LA    R5,7(,R5)               Point to next byte
         S     R4,=F'07'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         CLI   0(R5),C')'              End bracket?
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         MVI   W_MODE,C'Y'             Mark MODE     parm complete
         MVC   O_MODE,S_OFF            Move MODE=OFFLINE
         BC    B'1111',QM_025X         Continue FORMAT parsing
***********************************************************************
* SORT parameter specified.                                           *
***********************************************************************
QM_0255  DS   0H
         LA    R0,QM_0255              Mark the spot
         CLI   W_SORT,C'Y'             SORT     parm performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,4(,R5)               Point past command
         S     R4,=F'04'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'='              Equal sign?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
***********************************************************************
* Determine field name length for SORT                                *
***********************************************************************
QM_0255A DS   0H
         LA    R0,QM_0255A             Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0255B        ... yes, move to OPTIONS table
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field name length
         C     R1,MAX_LEN              Field length exceed maximum?
         BC    B'1000',ER_40007        ... yes, syntax error
         BCT   R4,QM_0255A             Continue parsing
         BC    B'1111',ER_40007        Syntax error when zero
***********************************************************************
* Move field name to SORT entry of OPTIONS table                      *
***********************************************************************
QM_0255B DS   0H
         LA    R0,QM_0255B             Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         S     R1,=F'1'                Adjust field length
         L     R15,W_ADDR              Load field data address
         LA    R14,O_SORT              Load SORT field name
         EX    R1,MVC_0255             ... and move to OPTIONS table
*
         MVI   W_SORT,C'Y'             Mark MODE     parm complete
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
MVC_0255 MVC   0(0,R14),0(R15)         Move field to OPTIONS table
*
***********************************************************************
* ROWS parameter specified.                                           *
***********************************************************************
QM_0256  DS   0H
         LA    R0,QM_0256              Mark the spot
         CLI   W_ROWS,C'Y'             ROWS     parm performed?
         BC    B'1000',ER_40007        ... yes, syntax error
*
         LA    R5,4(,R5)               Point past command
         S     R4,=F'04'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C'='              Equal sign?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
***********************************************************************
* Determine value of ROWS= parameter                                  *
***********************************************************************
QM_0256A DS   0H
         LA    R0,QM_0256A             Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0256B        ... yes, move to OPTIONS table
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment ROWS value length
         C     R1,=F'6'                Value exceed maximum?
         BC    B'1000',ER_40007        ... yes, syntax error
         BCT   R4,QM_0256A             Continue parsing
         BC    B'1111',ER_40007        Syntax error when zero
***********************************************************************
* Move value to ROWS entry of OPTIONS table                           *
***********************************************************************
QM_0256B DS   0H
         LA    R0,QM_0256B             Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         LA    R15,6                   Load max ROWS field length
         SR    R15,R1                  Subtract length
         LA    R14,O_ROWS              Load ROWS address in Object
         LA    R14,0(R15,R14)          Set target field
         L     R15,W_ADDR              Set source field
         S     R1,=F'1'                Adjust for MVC
         EX    R1,MVC_0256             Move ROWS to Oject table
*
         MVI   W_ROWS,C'Y'             Mark ROWS     parm complete
         BC    B'1111',QM_025X         Continue FORMAT parsing
*
MVC_0256 MVC   0(0,R14),0(R15)         Move ROWS to ZD work field
*
***********************************************************************
* When a comma is the next byte, continue with FORMAT parsing         *
***********************************************************************
QM_025X  DS    0H
         LA    R0,QM_025X              Mark the spot
         CLI   0(R5),C','              Comma?
         BC    B'0111',QM_025Z         ... no,  continue
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0251         Get next OPTIONS parm
***********************************************************************
* When a end parenthesis is the next byte,                            *
*   1).  When EOQS, parsing is complete                               *
*   2).  When not EOQS, continue SELECT parsing                       *
***********************************************************************
QM_025Z  DS    0H
         LA    R0,QM_025Z              Mark the spot
         CLI   0(R5),C')'              Close parenthesis
         BC    B'0111',ER_40007        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1000',QM_0500         When zero, parsing complete
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
         BC    B'1111',QM_0210         Continue parsing
*
***********************************************************************
* Parse PUT    request, using WEB RECEIVE input                       *
***********************************************************************
QM_0300  DS   0H
         L     R4,R_LENGTH             Load RECEIVE length
         L     R5,WR_ADDR              Load RECEIVE address
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(6,R5),S_UPDATE        Is this an UPDATE command?
         BC    B'0111',ER_40503        ... no,  invalid command
         LA    R5,6(,R5)               Point to next byte
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40007        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40007        Syntax error when EOQS
***********************************************************************
* Check PUT    request for zQL commands.                              *
* Valid commands are FIELDS, TTL and WHERE.                           *
***********************************************************************
QM_0310  DS   0H
         LA    R0,QM_0310              Mark the spot
         CLI   0(R5),C'('              Open parenthesis?
         BC    B'0111',ER_40008        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(3,R5),S_TTL           Is this a TTL    command?
         BC    B'1000',QM_0320         ... yes, process
         CLC   0(6,R5),S_FIELDS        Is this a FIELDS command?
         BC    B'1000',QM_0330         ... yes, process
         CLC   0(5,R5),S_WHERE         Is this a WHERE  command?
         BC    B'1000',QM_0340         ... yes, process
         BC    B'1000',ER_40008        ... no,  syntax error
***********************************************************************
* Process TTL command                                                 *
***********************************************************************
QM_0320  DS   0H
         CLI   W_TTL,C'Y'              TTL   command performed?
         BC    B'1000',ER_40008        ... yes, syntax error
***********************************************************************
* Begin parsing TTL command                                           *
***********************************************************************
QM_0321  DS   0H
         LA    R0,QM_0321              Mark the spot
         LA    R5,3(,R5)               Point past command
         S     R4,=F'03'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40008        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
         XR    R1,R1                   Clear counter
         ST    R5,W_ADDR               Save beginning TTL address
         LR    R15,R5                  Load beginning TTL address
***********************************************************************
* Determine length of TTL and perform editing.                        *
***********************************************************************
QM_0322  DS   0H
         LA    R0,QM_0322              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0323         ... yes, continue process
         CLI   0(R5),X'F0'             Compare TTL byte to zero
         BC    B'0100',ER_40008        ... when less, syntax error
         CLI   0(R5),X'FA'             Compare TTL byte to FA+
         BC    B'1010',ER_40008        ... when more, syntax error
         C     R1,=F'5'                Maximum TTL length?
         BC    B'0010',ER_40008        ... yes, syntax error
*
         LA    R1,1(,R1)               Increment TTL length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0322              Continue parsing
         BC    B'1100',ER_40008        Syntax error when EOQS
***********************************************************************
* Issue PUT CONTAINER for TTL field                                   *
***********************************************************************
QM_0323  DS   0H
         LA    R0,QM_0323              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         CLI   0(R5),C')'              Close parenthesis?
         BC    B'0111',ER_40008        ... no,  syntax error
*
         MVI   W_TTL,C'Y'              Mark TTL command complete
*
         MVC   W_NAME,C_TTL            Move TTL container name
         ST    R1,W_LENGTH             Save data length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0323              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1000',QM_0500         When zero, parsing complete
*
         CLI   0(R5),C','              Comma?
         BC    B'0111',ER_40008        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
         BC    B'1111',QM_0310         Continue PUT  parsing
***********************************************************************
* FIELDS command                                                      *
***********************************************************************
QM_0330  DS   0H
         CLI   W_FIELDS,C'Y'           FIELDS  command performed?
         BC    B'1000',ER_40008        ... yes, syntax error
*
         LA    R5,6(,R5)               Point past command
         S     R4,=F'06'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
***********************************************************************
* Begin parsing FIELDS command                                        *
***********************************************************************
QM_0331  DS   0H
         LA    R0,QM_0331              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40008        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1 (counter)
         ST    R5,W_ADDR               Save beginning address
         LR    R15,R5                  Load beginning address
***********************************************************************
* Determine field name length.                                        *
***********************************************************************
QM_0332  DS    0H
         LA    R0,QM_0332              Mark the spot
         CLI   0(R5),C'='              Equal sign (end of field)?
         BC    B'1000',QM_0333         ... yes, process
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40008        ... yes, syntax error
         LA    R1,1(,R1)               Increment field name length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0332              Continue evaluation
         BC    B'1111',ER_40008        EOF, syntax error
***********************************************************************
* Address FAxxFD table                                                *
***********************************************************************
QM_0333  DS    0H
         LA    R0,QM_0332              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         L     R7,FD_LEN               Load FD table length
         LA    R6,E_FD                 Load FD entry length
         S     R1,ONE                  Adjust before EX command
***********************************************************************
* Verify the field name is in FAxxFD                                  *
***********************************************************************
QM_0334  DS    0H
         LA    R0,QM_0334              Mark the spot
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0334             Field name match?
         BC    B'1000',QM_0335         ... yes, process
         LA    R9,0(R6,R9)             Point to next FD entry
         SR    R7,R6                   Reduce total length by an entry
         BC    B'0010',QM_0334         Continue search
         MVC   C_FIELD,HEX_40          Move spaces to field name
         LA    R14,C_FIELD             Point to field name
         EX    R1,MVC_0334             Move field name to diagnostics
         BC    B'1111',ER_41203        ... EOF, syntax error
CLC_0334 CLC   0(0,R14),0(R15)         Check field name
MVC_0334 MVC   0(0,R14),0(R15)         Move  field name
*
***********************************************************************
* Move field name to parser array                                     *
***********************************************************************
QM_0335  DS    0H
         LA    R0,QM_0335              Mark the spot
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0335             Set container name
*
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         LA    R8,0(R7,R8)             Point to current PA entry
*
         LA    R1,1(,R1)               Increment PA index
         ST    R1,W_INDEX              Save PA index
         C     R1,MAX_PA               PA index exceeded?
         BC    B'0010',ER_41406        ... yes, STATUS(414)
*
         MVC   P_NAME,F_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
         BC    B'1111',QM_0336         Determine field length
MVC_0335 MVC   0(0,R14),0(R15)         Set container name
***********************************************************************
* Determine length of data for this field                             *
***********************************************************************
QM_0336  DS   0H
         LA    R0,QM_0336              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0337         ... yes, PUT CONTAINER
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field length
         C     R1,MAX_LEN              Field length exceed maximum?
         BC    B'1000',ER_40008        ... yes, syntax error
         BCT   R4,QM_0336              Continue parsing
         BC    B'1111',ER_40008        Syntax error when zero
***********************************************************************
* Issue PUT CONTAINER for this data field                             *
***********************************************************************
QM_0337  DS   0H
         LA    R0,QM_0337              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         ST    R1,W_LENGTH             Save field length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0337              Mark the spot
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'1000',QM_0338         ... yes, prepare to parse
*
         CLI   0(R5),C')'              Close Parenthesis?
         BC    B'0111',ER_40008        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing is complete
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40008        ... yes, prepar to parse
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40008        When zero, syntax error
         MVI   W_FIELDS,C'Y'           Set FIELDS command complete
         BC    B'1111',QM_0310         Continue parsing
*
***********************************************************************
* Prepare to parse next FIELDS request                                *
***********************************************************************
QM_0338  DS   0H
         LA    R0,QM_0336              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
         BC    B'1111',QM_0331         Continue with FIELDS
***********************************************************************
* WHERE  command                                                      *
***********************************************************************
QM_0340  DS   0H
         CLI   W_WHERE,C'Y'            WHERE  command performed?
         BC    B'1000',ER_40008        ... yes, syntax error
*
         LA    R5,5(,R5)               Point past command
         S     R4,=F'05'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
***********************************************************************
* Begin parsing WHERE command                                         *
***********************************************************************
QM_0341  DS   0H
         LA    R0,QM_0341              Mark the spot
         CLI   0(R5),C'('              Begin bracket?
         BC    B'0111',ER_40008        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1 (counter)
         ST    R5,W_ADDR               Save beginning address
         LR    R15,R5                  Load beginning address
***********************************************************************
* Determine field name length.                                        *
***********************************************************************
QM_0342  DS    0H
         LA    R0,QM_0342              Mark the spot
         CLI   0(R5),C'='              Equal sign (end of field)?
         BC    B'1000',QM_0343         ... yes, process
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40008        ... yes, syntax error
         LA    R1,1(,R1)               Increment field name length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0342              Continue evaluation
         BC    B'1111',ER_40008        EOF, syntax error
***********************************************************************
* Address FAxxFD table                                                *
***********************************************************************
QM_0343  DS    0H
         LA    R0,QM_0343              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         L     R7,FD_LEN               Load FD table length
         LA    R6,E_FD                 Load FD entry length
         S     R1,ONE                  Adjust before EX command
***********************************************************************
* Verify the field name is in FAxxFD                                  *
***********************************************************************
QM_0344  DS    0H
         LA    R0,QM_0344              Mark the spot
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0344             Field name match?
         BC    B'1000',QM_0345         ... yes, process
         LA    R9,0(R6,R9)             Point to next FD entry
         SR    R7,R6                   Reduce total length by an entry
         BC    B'0010',QM_0344         Continue search
         BC    B'1111',ER_40008        EOF, syntax error
CLC_0344 CLC   0(0,R14),0(R15)         Check field name
***********************************************************************
* Move field name to parser array                                     *
***********************************************************************
QM_0345  DS    0H
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0345             Set container name
*
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         LA    R8,0(R7,R8)             Point to current PA entry
*
         LA    R1,1(,R1)               Increment PA index
         ST    R1,W_INDEX              Save PA index
         C     R1,MAX_PA               PA index exceeded?
         BC    B'0010',ER_41407        ... yes, STATUS(414)
*
         MVC   P_NAME,F_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
         BC    B'1111',QM_0346         Determine field length
MVC_0345 MVC   0(0,R14),0(R15)         Set container name
***********************************************************************
* Determine length of data for this field                             *
***********************************************************************
QM_0346  DS    0H
         LA    R0,QM_0346              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0347         ... yes, PUT CONTAINER
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field length
         C     R1,MAX_LEN              Field length exceed maximum?
         BC    B'1000',ER_40008        ... yes, syntax error
         BCT   R4,QM_0336              Continue parsing
         BC    B'1111',ER_40008        Syntax error when zero
***********************************************************************
* Issue PUT CONTAINER for this data field                             *
***********************************************************************
QM_0347  DS   0H
         LA    R0,QM_0337              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'01'               Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
*
         ST    R1,W_LENGTH             Save field length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0347              Mark the spot
*
         CLI   0(R5),C')'              Close parenthesis?
         BC    B'0111',ER_40008        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing complete
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40008        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40008        Syntax error when EOQS
         MVI   W_WHERE,C'Y'            Set WHERE  command complete
         BC    B'1111',QM_0310         Continue parsing
*
***********************************************************************
* Parse DELETE request, using the Query String                        *
* Since the WEB EXTRACT command moves the Query String 'into' an area *
* instead of setting a pointer, only a three byte area is defined for *
* the EXTRACT command.  The three bytes are used to determine whether *
* the request is basic mode or query mode (zQL).  When query mode,    *
* parse the DFHCOMMAREA for the beginning of the query string and     *
* save the pointer address.  This reduces the amount of DFHEISTG      *
* storage required for the Query String and eliminates a GETMAIN.     *
***********************************************************************
QM_0400  DS   0H
         LA    R0,QM_0400              Mark the spot
         BAS   R14,CA_0010             Parse DFHCOMMAREA for QS
         USING DFHCA,R5                ... tell assembler
         L     R4,L_QUERY              Load query string length
         LA    R5,3(,R5)               Skip past the zQL command
         S     R4,=F'3'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40009        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         OC    0(6,R5),HEX_40          Set upper case bits
         CLC   0(6,R5),S_DELETE        Is this a DELETE command?
         BC    B'0111',ER_40504        ... no,  invalid command
         LA    R5,6(,R5)               Point to next byte
         S     R4,=F'6'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         CLI   0(R5),C','              Is next byte a comma?
         BC    B'0111',ER_40009        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         CLI   0(R5),C'('              Open parenthesis?
         BC    B'0111',ER_40009        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         OC    0(5,R5),HEX_40          Set upper case bits
         CLC   0(5,R5),S_WHERE         Is this a WHERE statement?
         BC    B'0111',ER_40009        ... no,  syntax error
         LA    R5,5(,R5)               Point to next byte
         S     R4,=F'5'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         CLI   0(R5),C'('              Begin Bracket?
         BC    B'0111',ER_40009        ... no,  syntax error
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field name address
         LR    R15,R5                  Load field name address
***********************************************************************
* Determine primary key field length                                  *
***********************************************************************
QM_0410  DS   0H
         LA    R0,QM_0410              Mark the spot
         CLI   0(R5),C'='              Equal sign (end of field)?
         BC    B'1000',QM_0420         ... yes, continue
         C     R1,=F'16'               Exceed maximum field length?
         BC    B'0011',ER_40009        ... yes, syntax error
         LA    R1,1(,R1)               Add one to field length
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,QM_0410              Continue parsing
         BC    B'1111',ER_40009        EOF, syntax error
***********************************************************************
* Address FAxxFD table.                                               *
* Validate  primary key field selected.                               *
***********************************************************************
QM_0420  DS   0H
         LA    R0,QM_0420              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error wehn EOQS
*
         L     R9,FD_GM                Load FAxxFD address
         USING FD_DSECT,R9             ... tell assembler
         S     R1,ONE                  Adjust before EX command
         LA    R14,F_NAME              Point to field name
         EX    R1,CLC_0420             Primary key selected?
         BC    B'0111',ER_40009        ... no,  syntax error
*
         MVC   W_NAME,HEX_40           Clear field
         LA    R14,W_NAME              Point to field name
         EX    R1,MVC_0420             Set container name
*
         L     R8,PA_GM                Load parser array address
         USING PA_DSECT,R8             ... tell assembler
         MVC   P_NAME,W_NAME           Move field name     to PA
         MVC   P_TYPE,F_TYPE           Move field type     to PA
         PACK  P_SEC,F_SEC             Pack field security to PA
         PACK  P_ID,F_ID               Pack field ID       to PA
         PACK  P_COL,F_COL             Pack field column   to PA
         PACK  P_LEN,F_LEN             Pack field length   to PA
         MVC   W_INDEX,=F'1'           Set PA index to one
*
         XR    R1,R1                   Clear R1
         ST    R5,W_ADDR               Save field data address
         BC    B'1111',QM_0430         Determine field length
CLC_0420 CLC   0(0,R14),0(R15)         Check field name
MVC_0420 MVC   0(0,R14),0(R15)         Move  field name
***********************************************************************
* Determine length of primary key data                                *
***********************************************************************
QM_0430  DS   0H
         LA    R0,QM_0430              Mark the spot
         CLI   0(R5),C')'              End bracket?
         BC    B'1000',QM_0440         ... yes, PUT CONTAINER
         LA    R5,1(,R5)               Point to next byte
         LA    R1,1(,R1)               Increment field length
         C     R1,MAX_LEN              Field length exceed maximum?
         BC    B'1010',ER_40009        ... yes, syntax error
         BCT   R4,QM_0430              Continue parse
         BC    B'1111',ER_40009        Syntax error when zero
***********************************************************************
* Issue PUT CONTAINER for primary key field                           *
***********************************************************************
QM_0440  DS   0H
         LA    R0,QM_0440              Mark the spot
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',ER_40009        Syntax error when EOQS
*
         ST    R1,W_LENGTH             Save data length
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R0,QM_0440              Mark the spot
         CLI   0(R5),C')'              Close parenthesis?
         BC    B'0111',ER_40009        ... no,  syntax error
*
         LA    R5,1(,R5)               Point to next byte
         S     R4,=F'1'                Adjust remaining length
         BC    B'1100',QM_0500         When zero, parsing is complete
         BC    B'0011',ER_40009        Syntax error when more available
*
***********************************************************************
* Issue PUT CONTAINER for parsing array                               *
***********************************************************************
QM_0500  DS   0H
         MVC   W_NAME,C_ARRAY          Move ARRAY   container name
         MVC   W_ADDR,PA_GM            Move parser array address
*
         LA    R7,E_PA                 Load parser array entry length
         XR    R6,R6                   Clear even register
         L     R1,W_INDEX              Load PA index
         MR    R6,R1                   Multiply by entry length
         ST    R7,W_LENGTH             Save parser array length
*
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
***********************************************************************
* Issue PUT CONTAINER for Options table                               *
***********************************************************************
QM_0510  DS   0H
         MVC   W_NAME,C_OPTION         Move OPTIONS container name
         LA    R1,E_TABLE              Load OPTIONS table length
         ST    R1,W_LENGTH             Save OPTIONS table length
*
         LA    R6,O_TABLE              Load OPTIONS table address
         ST    R6,W_ADDR               Save OPTIONS table adress
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
***********************************************************************
***********************************************************************
* Query Security process.                                             *
***********************************************************************
***********************************************************************
QS_0010  DS   0H
         DROP  R9                      ... tell assembler
         CLI   W_PREFIX,X'FF'          URI '/replicate' prefix?
         BC    B'1000',QS_0400         ... yes, bypass security
*
         L     R9,SD_GM                Load FAxxSD address
         USING SD_DSECT,R9             ... tell assembler
         CLC   W_SCHEME,DFHVALUE(HTTP) HTTP request?
         BC    B'1000',QS_0100         ... yes, execute HTTP  security
         BC    B'0111',QS_0200         ... no,  execute HTTPS security
***********************************************************************
* SCHEME is HTTP.   Determine appropriate action                      *
***********************************************************************
QS_0100  DS   0H
         CLC   W_METHOD(3),S_GET       GET request?
         BC    B'0111',QS_0120         ... no,  check other methods
***********************************************************************
* SCHEME is HTTP  and this is a GET request                           *
***********************************************************************
QS_0110  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'0111',QS_0400         ... no,  bypass security
         OC    Q_STATUS,HEX_40         Set upper case bits
         CLC   Q_STATUS,S_YEA          QM Read Only enabled?
         BC    B'1000',QS_0400         ... yes, bypass security
         BC    B'0111',ER_40111        ... no,  STATUS(401)
***********************************************************************
* SCHEME is HTTP  and this is a PUT, POST, DELETE request             *
***********************************************************************
QS_0120  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'1000',ER_40112        ... yes, STATUS(401)
         BC    B'0111',QS_0400         ... no,  bypass security
***********************************************************************
* SCHEME is HTTPS.  Determine appropriate action                      *
***********************************************************************
QS_0200  DS   0H
         OC    SD_RESP,SD_RESP         FAxxSD defined?
         BC    B'0111',QS_0400         ... no,  bypass security
*
         LA    R4,E_USER               Load user  entry length
         L     R5,SD_LEN               Load SD template length
         LA    R6,E_PREFIX             Load SD prefix length
         SR    R5,R6                   Subtract prefix length
         AR    R9,R6                   Point to User entry
         USING SD_USER,R9              ... tell assembler
***********************************************************************
* Parse SD entry until EOT or a UserID match                          *
***********************************************************************
QS_0210  DS   0H
         CLC   S_USER,C_USER           UserID match FAxxSD?
         BC    B'1000',QS_0220         ... yes, check request type
QS_0211  DS   0H
         LA    R9,0(R4,R9)             Point to next entry
         SR    R5,R4                   Subtract user entry length
         BC    B'0010',QS_0210         Continue search
         BC    B'1111',ER_40113        EOT, STATUS(401)
***********************************************************************
* UserID matches FAxxSD entry.                                        *
* Now check HTTP METHOD and branch to compare with security entry     *
***********************************************************************
QS_0220  DS   0H
         OC    S_TYPE,HEX_40           Set upper case bits
         CLC   W_METHOD(4),S_POST      POST   request?
         BC    B'1000',QS_0221         ... yes, check SD type
         CLC   W_METHOD(3),S_GET       GET    request?
         BC    B'1000',QS_0222         ... yes, check SD type
         CLC   W_METHOD(3),S_PUT       PUT    request?
         BC    B'1000',QS_0223         ... yes, check SD type
         CLC   W_METHOD(6),S_DELETE    DELETE request?
         BC    B'1000',QS_0224         ... yes, check SD type
         BC    B'0111',ER_40005        ... no,  WEB SEND STATUS(400)
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* POST   must match security type of 'Write '                         *
***********************************************************************
QS_0221  DS   0H
         CLC   S_TYPE,S_WRITE          Security entry for 'Write'?
         BC    B'0111',QS_0211         ... no,  continue search
         BC    B'1111',QS_0300         ... yes, field level security
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* GET    must match security type of 'Read  '                         *
***********************************************************************
QS_0222  DS   0H
         CLC   S_TYPE,S_READ           Security entry for 'Read'?
         BC    B'0111',QS_0211         ... no,  continue search
         BC    B'1111',QS_0300         ... yes, field level security
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* PUT    must match security type of 'Write '                         *
***********************************************************************
QS_0223  DS   0H
         CLC   S_TYPE,S_WRITE          Security entry for 'Write'?
         BC    B'0111',QS_0211         ... no,  continue search
         BC    B'1111',QS_0300         ... yes, field level security
***********************************************************************
* FAxxSD security entry must match HTTP METHOD                        *
* DELETE must match security type of 'Delete'                         *
***********************************************************************
QS_0224  DS   0H
         CLC   S_TYPE,S_DELETE         Security entry for 'Delete'?
         BC    B'0111',QS_0211         ... no,  continue search
         BC    B'1111',QS_0300         ... yes, field level security
***********************************************************************
* At this point, the Parser Array has every field presented in the    *
* zQL request along with the security level.                          *
* Compare the UserID security level with each field level in the      *
* Parser Array.                                                       *
***********************************************************************
QS_0300  DS   0H
         L     R4,W_INDEX              Load PA index (# of entries)
         LA    R6,E_PA                 Load PA entry length
         L     R8,PA_GM                Load PA entry address
         LTR   R9,R9                   R9 points to current UserID
***********************************************************************
* The field security level is in the Parser Array.  Use this security *
* level as a displacement into the UserID security level array.       *
***********************************************************************
QS_0310  DS   0H
         LA    R5,S_LEVELS             Load UserID security levels
         ZAP   W_PACK,P_SEC            Pack field security level
         CVB   R7,W_PACK               Convert to index
         LA    R5,0(R7,R5)             Point to UserID security byte
         OI    0(R5),X'40'             Set upper case
         CLI   0(R5),C'X'              Field level permitted?
         BC    B'0111',ER_40114        ... no,  set reason code
         LA    R8,0(R6,R8)             Point to next PA entry
         BCT   R4,QS_0310              Continue PA scan
         BC    B'1111',QS_0400         CI and segment validation
***********************************************************************
* Check method and branch accordingly to set the appropriate          *
* Query Mode service program.                                         *
***********************************************************************
QS_0400  DS   0H
         CLC   W_METHOD(4),S_POST      POST   request?
         BC    B'1000',QS_0410         ... yes, set service name
         CLC   W_METHOD(3),S_GET       GET    request?
         BC    B'1000',QS_0420         ... yes, set service name
         CLC   W_METHOD(3),S_PUT       PUT    request?
         BC    B'1000',QS_0430         ... yes, set service name
         CLC   W_METHOD(6),S_DELETE    DELETE request?
         BC    B'1000',QS_0440         ... yes, set service name
***********************************************************************
* Query Mode POST   service program                                   *
***********************************************************************
QS_0410  DS   0H
         MVC   W_ADDR,FD_GM            Move FAxxFD address
         MVC   W_LENGTH,FD_LEN         Move FAxxFD length
         MVC   W_NAME,C_FAXXFD         Move FAxxFD container name
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         LA    R1,R_MEDIA              Load media address
         ST    R1,W_ADDR               Save media address
         MVC   W_LENGTH,L_MEDIA        Move media length
         MVC   W_NAME,C_MEDIA          Move media container name
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         MVC   QM_PROG,ZFAM010         Set Query Mode POST   program
         BC    B'1111',QS_0500         Branch to XCTL routine
***********************************************************************
* Query Mode GET    service program                                   *
* Use Column Index indicator, which is set to 0 or 1, as the          *
* program suffix.  The CI indicator is set when a WHERE statement     *
* specifies a secondary column index.                                 *
***********************************************************************
QS_0420  DS   0H
         BAS   R14,QS_0480             Scan PA for column index
*
         MVC   QM_PROG,ZFAM020         Set Query Mode GET    program
         MVC   QM_PROG+6(1),W_CI       Set CI indicator
         BC    B'1111',QS_0500         Branch to XCTL routine
***********************************************************************
* Query Mode PUT    service program                                   *
*                                                                     *
* Check the fields in the parser array for the following conditions   *
*                                                                     *
* 1).  Field larger than 32,000                                       *
* 2).  Field spans a 32,000 byte segment                              *
* *).  Update to a secondary column index                             *
*                                                                     *
* If any of these conditions occur for a PUT request, control is      *
* transferred to a Query Mode program to handle spanned segment       *
* records.                                                            *
***********************************************************************
QS_0430  DS   0H
         DROP  R9                      ... tell assemmbler
         LA    R4,E_PA                 Load Parser Array entry length
         L     R5,W_INDEX              Load Parser Array index (count)
         L     R8,PA_GM                Load Parser Array address
         USING PA_DSECT,R8             ... tell assembler
***********************************************************************
* When a secondary CI is updated, branch to XCTL routine.             *
* segments.                                                           *
***********************************************************************
QS_0431  DS   0H
         XR    R6,R6                   Clear R6
         ZAP   W_COLUMN,P_COL          Load column number
         CVB   R7,W_COLUMN             Convert column to binary
         D     R6,=F'32000'            Divide column by segment size
*                                      Giving relative segment
         XR    R6,R6                   Clear R6
         M     R6,=F'32000'            Multiply by segment size
*                                      Giving segment displacement
         CVB   R6,W_COLUMN             Convert column to binary
         SR    R6,R7                   Subtract segment displacement
*                                      from column giving
*                                      relative displacement
         S     R7,=F'1'                Make relative to zero
         ZAP   W_PACK,P_LEN            Load field length
         CVB   R7,W_PACK               Convert length to binary
         AR    R6,R7                   Add field length to relative
*                                      displacement giving width
         C     R6,=F'32000'            Width greater than a segment?
         BC    B'0010',QS_0434         ... branch when spanned segment
*
***********************************************************************
* Point to parser array entry and continue to scan                    *
***********************************************************************
QS_0432  DS   0H
         LA    R8,0(R4,R8)             Point to next entry
         BCT   R5,QS_0431              Continue parser array scan
         BC    B'1111',QS_0433         EOT,  no spanned segments
***********************************************************************
* Query Mode PUT    service program                                   *
***********************************************************************
QS_0433  DS   0H
         MVC   QM_PROG,ZFAM030         Set Query Mode PUT    program
         BC    B'1111',QS_0500         Branch to XCTL routine
***********************************************************************
* Query Mode PUT    service program for these conditions:             *
* Secondary CI updates                                                *
* Updated fields span segments                                        *
***********************************************************************
QS_0434  DS   0H
         MVC   QM_PROG,ZFAM030         Set Query Mode PUT    program
         BC    B'1111',QS_0500         Branch to XCTL routine
***********************************************************************
* Query Mode DELETE service program                                   *
***********************************************************************
QS_0440  DS   0H
         MVC   W_ADDR,FD_GM            Move FAxxFD address
         MVC   W_LENGTH,FD_LEN         Move FAxxFD length
         MVC   W_NAME,C_FAXXFD         Move FAxxFD container name
         BAS   R14,PC_0010             Issue PUT CONTAINER
*
         MVC   QM_PROG,ZFAM040         Set Query Mode DELETE program
         BC    B'1111',QS_0500         Branch to XCTL routine
***********************************************************************
* Check the fields in the Parser Array for any CI definitions in a    *
* WHERE statement.                                                    *
***********************************************************************
QS_0480  DS   0H
         ST    R14,BAS_REG             Save return register
*
         LA    R4,E_PA                 Load Parser Array entry length
         L     R5,W_INDEX              Load Parser Array index (count)
         L     R8,PA_GM                Load Parser Array address
         USING PA_DSECT,R8             ... tell assembler
         MVI   W_CI,C'0'               Set CI indicator off
***********************************************************************
* Check fiels for WHERE indicator and when the field is a secondary   *
* column index, mark it.                                              *
***********************************************************************
QS_0481  DS   0H
         CLI   P_WHERE,C'N'            WHERE indicator set?
         BC    B'1000',QS_0482         ... no,  must be a FIELD
         CP    P_ID,S_ONE_PD           Primary CI or field?
         BC    B'1100',QS_0482         ... yes, continue
         MVI   W_CI,C'1'               Set CI indicator on
***********************************************************************
* Point to parser array entry and continue to scan                    *
***********************************************************************
QS_0482  DS   0H
         LA    R8,0(R4,R8)             Point to next entry
         BCT   R5,QS_0481              Continue parser array scan
         CLI   W_CI,C'1'               Secondary CI indicator set?
         BC    B'0100',QS_0489         ... no,  bypass HTTP header
*
***********************************************************************
* Read HTTPHEADER for zFAM-Stream option.                             *
***********************************************************************
QS_0483  DS   0H
         LA    R1,Z_LENGTH             Load header name  length
         ST    R1,L_HEADER             Save header name  length
         LA    R1,Z_VAL_L              Load value  field length
         ST    R1,V_LENGTH             Save value  field length
*
         EXEC CICS WEB READ HTTPHEADER(Z_HEADER)                       X
               NAMELENGTH(L_HEADER)                                    X
               VALUE(Z_VALUE)                                          X
               VALUELENGTH(V_LENGTH)                                   X
               NOHANDLE
*
***********************************************************************
* Set program suffix for zFAM022, which will process WHERE requests   *
* with secondary column indexes as the first field in the statement.  *
**********************************************************************
         MVI   W_CI,C'2'               Set zFAM022 program suffix
***********************************************************************
* Return to calling routine.                                          *
***********************************************************************
QS_0489  DS   0H
         L     R14,BAS_REG             Load return register
         BCR   B'1111',R14             Return to caller
*
***********************************************************************
* Transfer control (XCTL) to Query mode process                       *
***********************************************************************
QS_0500  DS   0H
         EXEC CICS XCTL PROGRAM(QM_PROG)                               X
               CHANNEL(C_CHAN)                                         X
               NOHANDLE
         BC    B'1111',ER_50002        Houston, we have a problem
*
***********************************************************************
* Return to caller                                                    *
**********************************************************************
RETURN   DS   0H
         EXEC CICS RETURN
*
***********************************************************************
* Issue TRACE command.                                                *
***********************************************************************
TR_0010  DS   0H
         ST    R14,BAS_REG             Save return register
*
         EXEC CICS ENTER TRACENUM(T_46)                                X
               FROM(T_46_M)                                            X
               FROMLENGTH(T_LEN)                                       X
               RESOURCE(T_RES)                                         X
               NOHANDLE
*
         L     R14,BAS_REG             Load return register
         BCR   B'1111',R14             Return to caller
*
***********************************************************************
* Issue PUT CONTAINER for various artifacts.                          *
* Note:  Artifacts is a cool 'architect' buzz term, which according   *
*        to Thesaurus means objects, articles, items, things, pieces, *
*        relics, etc.  Not sure why architects use such big words.  I *
*        had to look this up to see what 'artifacts' really means.    *
***********************************************************************
PC_0010  DS   0H
         ST    R14,BAS_REG             Save return register
         L     R6,W_ADDR               Load field data address
         USING DC_DSECT,R6             ... tell assembler
         EXEC CICS PUT CONTAINER(W_NAME)                               X
               FROM(DC_DSECT)                                          X
               FLENGTH(W_LENGTH)                                       X
               CHANNEL(C_CHAN)                                         X
               NOHANDLE
         L     R14,BAS_REG             Load return register
         BCR   B'1111',R14             Return to caller
*
***********************************************************************
* Parse DFHCOMMAREA to find query string on POST/PUT requests         *
* This routine will only be called when the EXTRACT command receives  *
* a QUERYSTRLEN between 3 and 8192 bytes.                             *
***********************************************************************
CA_0010  DS   0H
         ST    R14,BAS_REG             Save return register
         LH    R4,EIBCALEN             Load DFHCOMMAREA length
         L     R5,DFHEICAP             Load DFHCOMMAREA address
***********************************************************************
* Query string begins with '?'.                                       *
***********************************************************************
CA_0020  DS   0H
         CLI   0(R5),C'?'              Query string?
         BC    B'1000',CA_0030         ... yes, save the address
         LA    R5,1(,R5)               Point to next byte
         BCT   R4,CA_0020              Continue QS search
         BC    B'1111',ER_40010        Malformed syntax
***********************************************************************
* Point past '?' to first byte of query string                        *
***********************************************************************
CA_0030  DS   0H
         LA    R5,1(,R5)               Point to next byte
         ST    R5,QS_ADDR              Save Query String address
         L     R14,BAS_REG             Load return register
         BCR   B'1111',R14             Return to calling routine
*
***********************************************************************
* Transfer control (XCTL) to Logging program.                         *
***********************************************************************
ER_XCTL  DS   0H
         STM   R0,R15,REGSAVE          Save registers
         LA    R1,E_LOG                Load COMMAREA length
         STH   R1,L_LOG                Save COMMAREA length
*
         EXEC CICS XCTL PROGRAM(ZFAM090)                               X
               COMMAREA(C_LOG)                                         X
               LENGTH(L_LOG)                                           X
               NOHANDLE
*
         EXEC CICS WEB SEND                                            X
               FROM      (H_CRLF)                                      X
               FROMLENGTH(H_TWO)                                       X
               ACTION    (H_ACTION)                                    X
               MEDIATYPE (H_MEDIA)                                     X
               STATUSCODE(H_STAT)                                      X
               STATUSTEXT(H_TEXT)                                      X
               STATUSLEN (H_LEN)                                       X
               SRVCONVERT                                              X
               NOHANDLE
*
         BC    B'1111',RETURN          Return (if XCTL fails)
*
***********************************************************************
* STATUS(400) RETURN CODE(01)                                         *
***********************************************************************
ER_40001 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(02)                                         *
***********************************************************************
ER_40002 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(03)                                         *
***********************************************************************
ER_40003 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'03'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(04)                                         *
***********************************************************************
ER_40004 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'04'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(05)                                         *
***********************************************************************
ER_40005 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'05'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(06)                                         *
***********************************************************************
ER_40006 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'06'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(07)                                         *
***********************************************************************
ER_40007 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'07'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(08)                                         *
***********************************************************************
ER_40008 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'08'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(09)                                         *
***********************************************************************
ER_40009 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'09'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(400) RETURN CODE(10)                                         *
***********************************************************************
ER_40010 DS   0H
         MVC   C_STATUS,S_400          Set STATUS
         MVC   C_REASON,=C'10'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(01)                                         *
***********************************************************************
ER_40101 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(02)                                         *
***********************************************************************
ER_40102 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(03)                                         *
***********************************************************************
ER_40103 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'03'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(04)                                         *
***********************************************************************
ER_40104 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'04'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(05)                                         *
***********************************************************************
ER_40105 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'05'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(06)                                         *
***********************************************************************
ER_40106 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'06'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(07)                                         *
***********************************************************************
ER_40107 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'07'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(08)                                         *
***********************************************************************
ER_40108 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'08'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(09)                                         *
***********************************************************************
ER_40109 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'09'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(10)                                         *
***********************************************************************
ER_40110 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'10'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(11)                                         *
***********************************************************************
ER_40111 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'11'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(12)                                         *
***********************************************************************
ER_40112 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'12'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(13)                                         *
***********************************************************************
ER_40113 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'13'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(401) RETURN CODE(14)                                         *
***********************************************************************
ER_40114 DS   0H
         MVC   C_STATUS,S_401          Set STATUS
         MVC   C_REASON,=C'14'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(405) RETURN CODE(01)                                         *
***********************************************************************
ER_40501 DS   0H
         MVC   C_STATUS,S_405          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(402) RETURN CODE(02)                                         *
***********************************************************************
ER_40502 DS   0H
         MVC   C_STATUS,S_405          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(403) RETURN CODE(01)                                         *
***********************************************************************
ER_40503 DS   0H
         MVC   C_STATUS,S_405          Set STATUS
         MVC   C_REASON,=C'03'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(404) RETURN CODE(01)                                         *
***********************************************************************
ER_40504 DS   0H
         MVC   C_STATUS,S_405          Set STATUS
         MVC   C_REASON,=C'04'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(405) RETURN CODE(05)                                         *
***********************************************************************
ER_40505 DS   0H
         MVC   C_STATUS,S_405          Set STATUS
         MVC   C_REASON,=C'05'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(411) RETURN CODE(01)                                         *
***********************************************************************
ER_41101 DS   0H
         MVC   C_STATUS,S_411          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(412) RETURN CODE(01)                                         *
***********************************************************************
ER_41201 DS   0H
         MVC   C_STATUS,S_412          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(412) RETURN CODE(02)                                         *
***********************************************************************
ER_41202 DS   0H
         MVC   C_STATUS,S_412          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(412) RETURN CODE(03)                                         *
***********************************************************************
ER_41203 DS   0H
         MVC   C_STATUS,S_412          Set STATUS
         MVC   C_REASON,=C'03'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(413) RETURN CODE(01)                                         *
***********************************************************************
ER_41301 DS   0H
         MVC   C_STATUS,S_413          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(01)                                         *
***********************************************************************
ER_41401 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(02)                                         *
***********************************************************************
ER_41402 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(03)                                         *
***********************************************************************
ER_41403 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'03'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(04)                                         *
***********************************************************************
ER_41404 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'04'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(05)                                         *
***********************************************************************
ER_41405 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'05'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(06)                                         *
***********************************************************************
ER_41406 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'06'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(414) RETURN CODE(07)                                         *
***********************************************************************
ER_41407 DS   0H
         MVC   C_STATUS,S_414          Set STATUS
         MVC   C_REASON,=C'07'         Set REASON
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(500) RETURN CODE(01)                                         *
***********************************************************************
ER_50001 DS   0H
         MVC   C_STATUS,S_500          Set STATUS
         MVC   C_REASON,=C'01'         Set REASON
         MVC   C_PROG,BM_PROG          Set Basic Mode program name
         BC    B'1111',ER_XCTL         Transfer control to logging
***********************************************************************
* STATUS(500) RETURN CODE(02)                                         *
***********************************************************************
ER_50002 DS   0H
         MVC   C_STATUS,S_500          Set STATUS
         MVC   C_REASON,=C'02'         Set REASON
         MVC   C_PROG,QM_PROG          Set Query Mode program name
         BC    B'1111',ER_XCTL         Transfer control to logging
*
***********************************************************************
* Define Constant fields                                              *
***********************************************************************
*
         DS   0F
DECODE   DC    V(ZDECODE)              ZDECODE subroutine
         DS   0F
REPLIC8  DC    CL10'/replicate'        zFAM replication
URI_DS   DC    CL10'/datastore'        datastore URI
         DS   0H
FA_PRE   DC    CL02'FA'                zFAM transaction prefix
HEX_00   DC    XL01'00'                Nulls
         DS   0F
HEX_40   DC    16XL01'40'              Spaces
         DS   0F
ZQL      DC    CL03'ZQL'               zQL query string
         DS   0F
S_400    DC    CL03'400'               HTTP STATUS(400)
         DS   0F
S_401    DC    CL03'401'               HTTP STATUS(401)
         DS   0F
S_403    DC    CL03'403'               HTTP STATUS(403)
         DS   0F
S_405    DC    CL03'405'               HTTP STATUS(405)
         DS   0F
S_411    DC    CL03'411'               HTTP STATUS(411)
         DS   0F
S_412    DC    CL03'412'               HTTP STATUS(412)
         DS   0F
S_413    DC    CL03'413'               HTTP STATUS(413)
         DS   0F
S_414    DC    CL03'414'               HTTP STATUS(414)
         DS   0F
S_500    DC    CL03'500'               HTTP STATUS(500)
         DS   0F
ONE      DC    F'00001'                One
SIX      DC    F'00006'                Six
SD_GM_L  DC    F'16384'                FAxxSD GETMAIN length
FD_GM_L  DC    F'68000'                FAxxFD GETMAIN length
PA_GM_L  DC    F'8192'                 Parser array length
MAX_QS   DC    F'8192'                 Query String maximum length
MAX_PA   DC    F'256'                  Parser array maximum entries
MAX_LEN  DC    F'64000'                Field data   maximum length
S_WR_LEN DC    F'3200000'              Set maximum receive length
         DS   0F
S_ONE_PD DC    PL2'1'                  Packed decimal one
S_ZEROPD DC    PL4'0'                  Packed decimal zeroes
S_32K    DC    PL4'32000'              Packed decimal 32,000
         DS   0F
ZBASIC   DC    CL08'ZBASIC  '          zBASIC Basic Authentication
ZFAM002  DC    CL08'ZFAM002 '          Basic mode
ZFAM010  DC    CL08'ZFAM010 '          Query mode POST
ZFAM011  DC    CL08'ZFAM011 '          Basic mode POST   (CI defined)
ZFAM020  DC    CL08'ZFAM020 '          Query mode GET
ZFAM021  DC    CL08'ZFAM021 '          Query mode GET    (not used)
ZFAM022  DC    CL08'ZFAM022 '          Query mode GET    (CI requested)
ZFAM030  DC    CL08'ZFAM030 '          Query mode PUT
ZFAM031  DC    CL08'ZFAM031 '          Basic mode PUT    (CI defined)
ZFAM040  DC    CL08'ZFAM040 '          Query mode DELETE
ZFAM041  DC    CL08'ZFAM041 '          Basic mode DELETE (CI defined)
ZFAM090  DC    CL08'ZFAM090 '          Logging program for zFAM001
*
         DS   0F
S_YEA    DC    CL03'YEA'               Read Only enabled
         DS   0F
S_NAY    DC    CL03'NAY'               Read Only disabled
*
         DS   0F
S_FIELDS DC    CL06'FIELDS'            FIELDS  command
         DS   0F
S_WHERE  DC    CL05'WHERE'             WHERE   command
         DS   0F
S_VIEW   DC    CL04'VIEW'              VIEW    command
         DS   0F
S_WITH   DC    CL04'WITH'              WITH    command
         DS   0F
S_AND    DC    CL03'AND'               AND     command
         DS   0F
S_TTL    DC    CL03'TTL'               TTL     command
         DS   0F
S_GET    DC    CL06'GET   '            GET     request
         DS   0F
S_SELECT DC    CL06'SELECT'            SELECT  request
         DS   0F
S_PUT    DC    CL06'PUT   '            PUT     request
         DS   0F
S_UPDATE DC    CL06'UPDATE'            UPDATE  request
         DS   0F
S_POST   DC    CL06'POST  '            POST    request
         DS   0F
S_INSERT DC    CL06'INSERT'            INSERT  request
         DS   0F
S_DELETE DC    CL06'DELETE'            DELETE  request
*                                      DELETE  security type
         DS   0F
S_READ   DC    CL06'READ  '            READ    security type
         DS   0F
S_WRITE  DC    CL06'WRITE '            WRITE   security type
         DS   0F
S_OPTION DC    CL07'OPTIONS'           OPTIONS command
         DS   0F
S_CR     DC    CL02'CR'                WITH CR (Committed   Reads)
         DS   0F
S_UR     DC    CL02'UR'                WITH UR (Uncommitted Reads)
*                                      Default OPTION WITH
         DS   0F
S_FORMAT DC    CL06'FORMAT'            OPTION FORMAT
         DS   0F
S_DIST   DC    CL08'DISTINCT'          OPTION DISTINCT
         DS   0F
S_MODE   DC    CL04'MODE'              OPTION MODE
         DS   0F
S_SORT   DC    CL04'SORT'              OPTION SORT
         DS   0F
S_ROWS   DC    CL04'ROWS'              OPTION ROWS
         DS   0F
S_FIXED  DC    CL09'FIXED    '         OPTION FORMAT   (default)
         DS   0F
S_XML    DC    CL09'XML      '         OPTION FORMAT
         DS   0F
S_JSON   DC    CL09'JSON     '         OPTION FORMAT
         DS   0F
S_DELIM  DC    CL09'DELIMITER'         OPTION FORMAT
         DS   0F
S_NO     DC    CL02'NO'                OPTION DISTINCT (default)
         DS   0F
S_YES    DC    CL03'YES'               OPTION DISTINCT
*
         DS   0F
S_ON     DC    CL08'ONLINE  '          OPTION MODE     (default)
         DS   0F
S_OFF    DC    CL08'OFFLINE '          OPTION MODE
         DS   0F
S_ZEROES DC    CL06'000000'            OPTION ROWS     (default)
         DS   0F
*
         DS   0F
A_HEADER DC    CL13'Authorization'     HTTP Header (Authorization)
A_LENGTH EQU   *-A_HEADER              HTTP header field length
         DS   0F
Z_HEADER DC    CL11'zFAM-Stream'       HTTP header (zFAM-Stream)
Z_LENGTH EQU   *-Z_HEADER              HTTP header field length
         DS   0F
M_ACAO_L DC    F'01'                   HTTP value  length
M_ACAO   DC    CL01'*'                 HTTP value  field
H_ACAO_L DC    F'27'                   HTTP header length
H_ACAO   DC    CL16'Access-Control-A'  HTTP header field
         DC    CL11'llow-Origin'       HTTP header field
         DS   0F
C_CHAN   DC    CL16'ZFAM-CHANNEL    '  zFAM channel
C_OPTION DC    CL16'ZFAM-OPTIONS    '  OPTIONS container
C_TTL    DC    CL16'ZFAM-TTL        '  TTL container
C_ARRAY  DC    CL16'ZFAM-ARRAY      '  ARRAY container
C_FAXXFD DC    CL16'ZFAM-FAXXFD     '  Field Description document
C_KEY    DC    CL16'ZFAM-KEY        '  Primary CI key
C_MEDIA  DC    CL16'ZFAM-MEDIA      '  Media type
         DS   0F
***********************************************************************
* Trace resources                                                     *
***********************************************************************
T_46     DC    H'46'                   Trace number
T_46_M   DC    CL08'OBJECTS '          Trace message
T_RES    DC    CL08'zFAM001 '          Trace resource
T_LEN    DC    H'08'                   Trace resource length
***********************************************************************
* Internal error resources                                            *
***********************************************************************
H_TWO    DC    F'2'                    Length of CRLF
H_CRLF   DC    XL02'0D25'              Carriage Return Line Feed
H_STAT   DC    H'500'                  HTTP STATUS(500)
H_ACTION DC    F'02'                   HTTP SEND ACTION(IMMEDIATE)
H_LEN    DC    F'48'                   HTTP STATUS TEXT Length
H_TEXT   DC    CL16'03-001 Service u'  HTTP STATUS TEXT Length
         DC    CL16'navailable and l'  ... continued
         DC    CL16'ogging disabled '  ... and complete
H_MEDIA  DC    CL56'text/plain'        HTTP Media type
         DS   0F
L_MEDIA  DC    F'00056'                Media type length
         DS   0F
*
***********************************************************************
* Literal Pool                                                        *
***********************************************************************
         LTORG
*
***********************************************************************
* Communication area between zFAM001 and ZDECODE                      *
***********************************************************************
ZFAM_CA  DSECT
ZD_RC    DS    CL02               Return Code
         DS    CL02               not used (alignment)
ZD_USER  DS    CL08               UserID
ZD_PASS  DS    CL08               Password
ZD_ENC   DS    CL24               Encoded field (max 24 bytes)
         DS    CL04               not used (alignment)
ZD_DEC   DS    CL18               Decoded field (max 18 byte)
ZD_L     EQU   *-ZD_RC            ZFAM_CA length
*
*
***********************************************************************
* Control Section - ZDECODE                                           *
***********************************************************************
ZDECODE  AMODE 31
ZDECODE  RMODE 31
ZDECODE  CSECT
***********************************************************************
* Establish addressibility                                            *
***********************************************************************
ZD_0010  DS   0H
         STM   R14,R12,12(R13)         Save registers
         LR    R10,R15                 Load base register
         USING ZDECODE,R10             ... tell assembler
         LR    R9,R1                   Load work area address
         USING ZFAM_CA,R9              ... tell assembler
         B     ZD_DATE                 Branch around literals
         DC    CL08'ZDECODE '
         DC    CL48' -- Base64Binary decode Basic Authentication    '
         DC    CL08'        '
         DC    CL08'&SYSDATE'
         DC    CL08'        '
         DC    CL08'&SYSTIME'
ZD_DATE  DS   0H
***********************************************************************
* Decode Base64Binary UserID:Password                                 *
***********************************************************************
ZD_0020  DS   0H
         MVC   ZD_DEC,ASCII_20         Initialize to ASCII spaces
         LA    R2,6                    Load Octet count
         LA    R3,ZD_ENC               Address encoded field (source)
         LA    R6,ZD_DEC               Address decoded field (target)
*
***********************************************************************
* Process six octets                                                  *
* R4 and R5 are used as the even/odd pair registers for SLL and SLDL  *
* instructions.                                                       *
***********************************************************************
ZD_0030  DS   0H
         SR    R4,R4                   Clear R4
         SR    R5,R5                   Clear R5
*
         BAS   R14,ZD_1000             Decode four bytes into three
         BCT   R2,ZD_0030              ... for each octet
***********************************************************************
* At this point, the UserID:Password has been decoded and converted   *
* from ASCII to EBCDIC.                                               *
* Move decoded and converted UserID                                   *
***********************************************************************
ZD_0100  DS   0H
         MVC   ZD_USER,EIGHT_40        Initialize to spaces
         MVC   ZD_PASS,EIGHT_40        Initialize to spaces
*
         LA    R2,8                    Set max field length
         LA    R3,ZD_DEC               Address decoded field (source)
         LA    R6,ZD_USER              Address UserID  field (target)
*
***********************************************************************
* Move decoded/converted field until ':' has been encountered.        *
***********************************************************************
ZD_0110  DS   0H
         MVC   0(1,R6),0(R3)           Move byte to UserId
         LA    R3,1(,R3)               Increment source field
         LA    R6,1(,R6)               Increment target field
         CLI   0(R3),C':'              Colon?
         BC    B'1000',ZD_0200         ... yes, process Password
         BCT   R2,ZD_0110              ... no,  continue
***********************************************************************
* At this point, the UserID has been moved.  Now, move the Password   *
***********************************************************************
ZD_0200  DS   0H
         LA    R2,8                    Set max field length
         LA    R3,1(,R3)               skip past ':'
         LA    R6,ZD_PASS              Address Password field (target)
***********************************************************************
* Move decoded/converted field until spaces or nulls are encountered. *
***********************************************************************
ZD_0210  DS   0H
         MVC   0(1,R6),0(R3)           Move byte to UserId
         LA    R3,1(,R3)               Increment source field
         LA    R6,1(,R6)               Increment target field
         CLI   0(R3),X'00'             Null?
         BC    B'1000',ZD_0300         ... yes, decode complete
         CLI   0(R3),X'40'             Space?
         BC    B'1000',ZD_0300         ... yes, decode complete
         BCT   R2,ZD_0210              ... no,  continue
***********************************************************************
* At this point, the UserID and Password have been moved.             *
***********************************************************************
ZD_0300  DS   0H
         MVC   ZD_RC,=C'00'            Set default return code
*
***********************************************************************
* Return to calling routine                                           *
***********************************************************************
ZD_0900  DS   0H
         LM    R14,R12,12(R13)         Load registers
         BCR   B'1111',R14             Return to caller
*
***********************************************************************
* Decode Base64Binary                                                 *
***********************************************************************
ZD_1000  DS   0H
*
***********************************************************************
* This routine will convert the first of four encoded bytes.          *
***********************************************************************
ZD_1010  DS   0H
         CLI   0(R3),X'7E'             EOF (=)?
         BC    B'1000',RC_0012         ... yes, invalid encode
         SR    R5,R5                   Clear odd register
         IC    R5,0(R3)                Load first encoded byte
         LA    R3,1(,R3)               Point to next encoded byte
         IC    R5,B64XLT(R5)           Translate from B64 alphabet
         SLL   R5,26                   Shift out the 2 Hi order bits
         SLDL  R4,6                    Merge 6 bits of R5 into R4
*
***********************************************************************
* This routine will convert the second of four encoded bytes.         *
***********************************************************************
ZD_1020  DS   0H
         CLI   0(R3),X'7E'             EOF (=)?
         BC    B'1000',RC_0012         ... yes, invalid encode
         SR    R5,R5                   Clear odd register
         IC    R5,0(R3)                Load first encoded byte
         LA    R3,1(,R3)               Point to next encoded byte
         IC    R5,B64XLT(R5)           Translate from B64 alphabet
         SLL   R5,26                   Shift out the 2 Hi order bits
         SLDL  R4,6                    Merge 6 bits of R5 into R4
***********************************************************************
* This routine will convert the third of four encoded bytes.          *
***********************************************************************
ZD_1030  DS   0H
         CLI   0(R3),X'7E'             EOF (=)?
         BC    B'1000',ZD_1100         ... yes, process one octet
         SR    R5,R5                   Clear odd register
         IC    R5,0(R3)                Load first encoded byte
         LA    R3,1(,R3)               Point to next encoded byte
         IC    R5,B64XLT(R5)           Translate from B64 alphabet
         SLL   R5,26                   Shift out the 2 Hi order bits
         SLDL  R4,6                    Merge 6 bits of R5 into R4
***********************************************************************
* This routine will convert the fourth of four encoded bytes.         *
***********************************************************************
ZD_1040  DS   0H
         CLI   0(R3),X'7E'             EOF (=)?
         BC    B'1000',ZD_1200         ... yes, process two octets
         SR    R5,R5                   Clear odd register
         IC    R5,0(R3)                Load first encoded byte
         LA    R3,1(,R3)               Point to next encoded byte
         IC    R5,B64XLT(R5)           Translate from B64 alphabet
         SLL   R5,26                   Shift out the 2 Hi order bits
         SLDL  R4,6                    Merge 6 bits of R5 into R4
***********************************************************************
* Process the three decoded bytes.                                    *
***********************************************************************
ZD_1050  DS   0H
         STCM  R4,7,0(R6)              Save three decoded bytes
         TR    0(3,R6),A_TO_E          Convert to EBCDIC
         LA    R6,3(R6)                Increment pointer
         BCR   B'1111',R14             Return to caller
***********************************************************************
* Process single octet                                                *
***********************************************************************
ZD_1100  DS   0H
         SLL   R4,12                   Shift a null digit into R4
         STCM  R4,4,0(R6)              Save single octet
         TR    0(3,R6),A_TO_E          Convert to EBCDIC
         LA    R2,1                    Set counter to end process
         BCR   B'1111',R14             Return to caller
***********************************************************************
* Process double octet                                                *
***********************************************************************
ZD_1200  DS   0H
         SLL   R4,6                    Shift a null digit into R4
         STCM  R4,6,0(R6)              Save double octet
         TR    0(3,R6),A_TO_E          Convert to EBCDIC
         LA    R2,1                    Set counter to end process
         BCR   B'1111',R14             Return to caller
***********************************************************************
* Return code 12 - Invalid encode field provided                      *
***********************************************************************
RC_0012  DS   0H
         MVC   ZD_RC,=C'12'            Set return code 12
         BC    B'1111',ZD_0900         Return to caller
*
*
***********************************************************************
* Literal Pool                                                        *
***********************************************************************
         LTORG
*
         DS   0F
EIGHT_40 DC    08XL01'40'              EBCDIC spaces
ASCII_20 DC    18XL01'20'              ASCII  spaces
*
         DS   0F
*
***********************************************************************
* Translate table                                                     *
* Base64Binary alphabet and corresponding six bit representation      *
***********************************************************************
         DS   0F
B64XLT   DC    XL16'00000000000000000000000000000000'       00-0F
         DC    XL16'00000000000000000000000000000000'       10-1F
         DC    XL16'00000000000000000000000000000000'       20-2F
         DC    XL16'00000000000000000000000000000000'       30-3F
         DC    XL16'00000000000000000000000000003E00'       40-4F
         DC    XL16'00000000000000000000000000000000'       50-5F
         DC    XL16'003F0000000000000000000000000000'       60-6F
         DC    XL16'00000000000000000000000000000000'       70-7F
         DC    XL16'001A1B1C1D1E1F202122000000000000'       80-8F
         DC    XL16'00232425262728292A2B000000000000'       90-9F
         DC    XL16'00002C2D2E2F30313233000000000000'       A0-AF
         DC    XL16'00000000000000000000000000000000'       B0-BF
         DC    XL16'00000102030405060708000000000000'       C0-CF
         DC    XL16'00090A0B0C0D0E0F1011000000000000'       D0-DF
         DC    XL16'00001213141516171819000000000000'       E0-EF
         DC    XL16'3435363738393A3B3C3D000000000000'       F0-FF
*
***********************************************************************
* Translate table                                                     *
* ASCII to EBCDIC                                                     *
***********************************************************************
         DS   0F
A_TO_E   DC    XL16'00000000000000000000000000000000'       00-0F
         DC    XL16'00000000000000000000000000000000'       10-1F
         DC    XL16'405A7F7B5B6C507D4D5D5C4E6B604B61'       20-2F
         DC    XL16'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'       30-3F
         DC    XL16'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'       40-4F
         DC    XL16'D7D8D9E2E3E4E5E6E7E8E9BAE0BB5F6D'       50-5F
         DC    XL16'79818283848586878889919293949596'       60-6F
         DC    XL16'979899A2A3A4A5A6A7A8A9C06AD0A107'       70-7F
         DC    XL16'00000000000000000000000000000000'       80-8F
         DC    XL16'00000000000000000000000000000000'       90-9F
         DC    XL16'00000000000000000000000000000000'       A0-AF
         DC    XL16'00000000000000000000000000000000'       B0-BF
         DC    XL16'00000000000000000000000000000000'       C0-CF
         DC    XL16'00000000000000000000000000000000'       D0-DF
         DC    XL16'00000000000000000000000000000000'       E0-EF
         DC    XL16'00000000000000000000000000000000'       F0-FF
*
         DS   0F
*
         PRINT ON
***********************************************************************
* End of Program - ZDECODE                                            *
**********************************************************************
*
***********************************************************************
* Register assignment                                                 *
***********************************************************************
         DS   0F
R0       EQU   0
R1       EQU   1
R2       EQU   2
R3       EQU   3
R4       EQU   4
R5       EQU   5
R6       EQU   6
R7       EQU   7
R8       EQU   8
R9       EQU   9
R10      EQU   10
R11      EQU   11
R12      EQU   12
R13      EQU   13
R14      EQU   14
R15      EQU   15
*
         PRINT ON
***********************************************************************
* End of Program - ZFAM001                                            *
**********************************************************************
         END   ZFAM001
