ˆ PROCESS APOST, XREF, FULLOPT
ˆ IDENTIFICATION DIVISION.
ˆ PROGRAM-ID. SEUDRIVER.
ˆ AUTHOR. Richard Silvers.
ˆ DATE-WRITTEN. 02/26/01.
ˆ DATE-COMPILED.
‚ *---------------------------------------------------------------*
‚ *--------------------- PROGRAM OVERVIEW ------------------------*
‚ *---------------------------------------------------------------*
‚ * *
‚ * SYSTEM ID. SEUDRIVER *
‚ * *
‚ * PROGRAM TITLE. Driver program to call user defined line *
‚ * command programs. *
‚ * *
‚ * PURPOSE. The purpose of this program is to call other *
‚ * user defined line command programs. *
‚ * *
‚ * *
‚ * This program makes use of the following AS/400 APIs. *
‚ * *
‚ * QUSRTVUS - Retrieve entry information from the SEU user space *
‚ * QSUSPC. *
‚ * *
‚ * MAINTENANCE CONSIDERATIONS *
‚ * ----------- -------------- *
‚ * *NONE *
‚ * *
‚ * FILE DESCRIPTIONS *
‚ * ---- ------------ *
‚ * *NONE *
‚ * *
‚ * I/O FILE DESCRIPTION AS/400 NAME *
‚ * --- ----------------------------------- ----------- *
‚ * INPUT Workstation N/A *
‚ * *
‚ * OUTPUT Cobol source program N/A *
‚ * *
‚ * MAINTENANCE LOG *
‚ * ----------- --- *
‚ * *
‚ * CHANGE DATE CHGID PROGRAMMER CHANGE DESCRIPTION *
‚ * ----------- ----- ----------- --------------------------*
‚ * 26 Feb 2001 R. Silvers Original Development *
‚ * *
‚ *---------------------------------------------------------------*
‚ *--------------------- PROGRAM OVERVIEW END --------------------*
‚ *---------------------------------------------------------------*
ˆ ENVIRONMENT DIVISION.
ˆ CONFIGURATION SECTION.
ˆ SOURCE-COMPUTER. IBM-AS400.
ˆ OBJECT-COMPUTER. IBM-AS400.
ˆ INPUT-OUTPUT SECTION.
ˆ FILE-CONTROL.
ˆ DATA DIVISION.
ˆ FILE SECTION.
‚ *---------------------------------------------------------------*
‚ * Working Storage. *
‚ *---------------------------------------------------------------*
WORKING-STORAGE SECTION.
01 PGM-ID PIC X(10) VALUE 'SEUDRIVER '.
01 ATTRIBUTE-BYTE PIC X(10) VALUE SPACES.
01 COMMAND-CODE PIC X(05) VALUE SPACES.
01 LINEPRFX-LEN PIC S9(05) VALUE +20 COMP-3.
01 IDX PIC S9(05) VALUE +0 COMP-3.
01 J PIC S9(05) VALUE +0 COMP-3.
01 K PIC S9(05) VALUE +0 COMP-3.
‚ *---------------------------------------------------------------*
‚ * Variables used for retrieving SEU's user space (QSUSPC) *
‚ *---------------------------------------------------------------*
01 USRSPC-SIZE PIC S9(09) VALUE +0 BINARY.
01 USRSPC-OFFSET PIC S9(09) VALUE +0 BINARY.
01 USRSPC-NAME.
05 USRSPC-ID PIC X(10) VALUE 'QSUSPC '.
05 USRSPC-LIBRARY PIC X(10) VALUE 'QTEMP '.
‚ *---------------------------------------------------------------*
‚ * The following is copied from QSYSINC/QCBLLESRC.QUSEC so that *
‚ * the variable length field EXCEPTION-DATA can be defined as *
‚ * 100 bytes for exception data. *
‚ *---------------------------------------------------------------*
01 QUS-EC.
05 BYTES-PROVIDED PIC S9(00009) VALUE +0 BINARY.
05 BYTES-AVAILABLE PIC S9(00009) VALUE +0 BINARY.
05 EXCEPTION-ID PIC X(00007) VALUE SPACES.
05 RESERVED PIC X(00001) VALUE SPACES.
05 EXCEPTION-DATA PIC X(100) VALUE SPACES.
‚ *---------------------------------------------------------------*
‚ * Structure of USER SPACE (QSUSPC in QTEMP) as a Single Block. *
‚ *---------------------------------------------------------------*
01 HEADER-SPACE.
05 HDR-RCDLEN PIC S9(09) VALUE 0 BINARY.
05 HDR-CURRRN PIC S9(09) VALUE 0 BINARY.
05 HDR-CURPOS PIC S9(09) VALUE 0 BINARY.
05 HDR-CCSID PIC S9(09) VALUE 0 BINARY.
05 HDR-RCDSIN PIC S9(09) VALUE 0 BINARY.
05 HDR-MBRNAME PIC X(10) VALUE SPACES.
05 HDR-SRCFILE PIC X(10) VALUE SPACES.
05 HDR-LIBNAME PIC X(10) VALUE SPACES.
05 HDR-MBRTYPE PIC X(10) VALUE SPACES.
05 HDR-PFKEY PIC X(01) VALUE SPACES.
05 HDR-MODE PIC X(01) VALUE SPACES.
05 HDR-SPLIT PIC X(01) VALUE SPACES.
05 FILLER PIC X(01) VALUE SPACES.
05 HDR-RTNCODE PIC X(01) VALUE SPACES.
05 FILLER PIC X(03) VALUE SPACES.
05 HDR-RCDSOUT PIC S9(09) VALUE 0 BINARY.
05 HDR-SEQINS PIC X(07) VALUE SPACES.
05 FILLER PIC X(21) VALUE SPACES.
‚ *---------------------------------------------------------------*
‚ * Layout of the text line area in SEU user space QTEMP/QSUSPC *
‚ * (See QB3AGX00 - Source Entry Utility, Appendix E) *
‚ *---------------------------------------------------------------*
01 TEXT-SPACE.
05 TXT-LINECMD PIC X(08) VALUE SPACES.
05 TXT-RTNCODE PIC X(01) VALUE SPACES.
05 TXT-SEQNBR PIC 9(06) VALUE 0.
05 TXT-CHGDATE PIC 9(06) VALUE 0.
05 TXT-SRCLINE PIC X(256) VALUE SPACES.
‚ *---------------------------------------------------------------*
‚ * Passed pointer parameters sent by SEU - we don't use them! *
‚ *---------------------------------------------------------------*
LINKAGE SECTION.
01 PTR-BLOCK1 USAGE IS POINTER.
01 PTR-BLOCK2 USAGE IS POINTER.
01 PTR-BLOCK3 USAGE IS POINTER.
‚ *---------------------------------------------------------------*
‚ * Procedure Division. *
‚ *---------------------------------------------------------------*
PROCEDURE DIVISION USING PTR-BLOCK1
PTR-BLOCK2
PTR-BLOCK3.
‚ *---------------------------------------------------------------*
‚ * Mainline of program. *
‚ *---------------------------------------------------------------*
000-MAINLINE.
‚ *---------------------------------------------------------------*
‚ * Get the header block in QSUSPC. *
‚ *---------------------------------------------------------------*
MOVE +1 TO USRSPC-OFFSET.
MOVE LENGTH OF HEADER-SPACE TO USRSPC-SIZE.
CALL 'QUSRTVUS' USING USRSPC-NAME
USRSPC-OFFSET
USRSPC-SIZE
HEADER-SPACE
QUS-EC.
‚ *---------------------------------------------------------------*
‚ * Point to 1st line. *
‚ *---------------------------------------------------------------*
MOVE +101 TO USRSPC-OFFSET.
‚ *---------------------------------------------------------------*
‚ * Skip thru lines one-by-one. *
‚ *---------------------------------------------------------------*
PERFORM VARYING IDX FROM 1 BY 1
UNTIL IDX > (HDR-RCDSIN - 1)
COMPUTE USRSPC-SIZE = HDR-RCDLEN
+ LINEPRFX-LEN
CALL 'QUSRTVUS' USING USRSPC-NAME
USRSPC-OFFSET
USRSPC-SIZE
TEXT-SPACE
QUS-EC
PERFORM 200-GET-COMMAND THRU 200-EXIT
END-PERFORM.
‚ *---------------------------------------------------------------*
‚ * Tell SEU we're done updating. *
‚ *---------------------------------------------------------------*
GOBACK.
‚ *---------------------------------------------------------------*
‚ * Examine the command line looking for a single line command *
‚ * or a block command. *
‚ *---------------------------------------------------------------*
200-GET-COMMAND.
INSPECT TXT-LINECMD REPLACING ALL LOW-VALUES BY SPACES
MOVE SPACES TO COMMAND-CODE.
MOVE 1 TO K.
PERFORM VARYING J FROM 1 BY 1
UNTIL J > 7
IF TXT-LINECMD (J:1) NOT = SPACE
THEN
IF TXT-LINECMD (J:1) = '0'
THEN
CONTINUE
ELSE
MOVE TXT-LINECMD (J:1) TO COMMAND-CODE (K:1)
COMPUTE K = K + 1
END-IF
END-IF
END-PERFORM.
‚ *---------------------------------------------------------------*
‚ * Determine which program to call. *
‚ *---------------------------------------------------------------*
EVALUATE COMMAND-CODE
WHEN 'HRG '
CALL 'SEUUSRDEFA'
WHEN 'HHRG '
CALL 'SEUUSRDEFA'
WHEN 'HW '
CALL 'SEUUSRDEFA'
WHEN 'HHW '
CALL 'SEUUSRDEFA'
WHEN 'HRW '
CALL 'SEUUSRDEFA'
WHEN 'HHRW '
CALL 'SEUUSRDEFA'
WHEN 'HUG '
CALL 'SEUUSRDEFA'
WHEN 'HHUG '
CALL 'SEUUSRDEFA'
WHEN 'HURG '
CALL 'SEUUSRDEFA'
WHEN 'HHURG'
CALL 'SEUUSRDEFA'
WHEN 'HURW '
CALL 'SEUUSRDEFA'
WHEN 'HHURW'
CALL 'SEUUSRDEFA'
WHEN 'HR '
CALL 'SEUUSRDEFA'
WHEN 'HHR '
CALL 'SEUUSRDEFA'
WHEN 'HRR '
CALL 'SEUUSRDEFA'
WHEN 'HHRR '
CALL 'SEUUSRDEFA'
WHEN 'HT '
CALL 'SEUUSRDEFA'
WHEN 'HHT '
CALL 'SEUUSRDEFA'
WHEN 'HRT '
CALL 'SEUUSRDEFA'
WHEN 'HHRT '
CALL 'SEUUSRDEFA'
WHEN 'HY '
CALL 'SEUUSRDEFA'
WHEN 'HHY '
CALL 'SEUUSRDEFA'
WHEN 'HRY '
CALL 'SEUUSRDEFA'
WHEN 'HHRY '
CALL 'SEUUSRDEFA'
WHEN 'HUT '
CALL 'SEUUSRDEFA'
WHEN 'HHUT '
CALL 'SEUUSRDEFA'
WHEN 'HURT '
CALL 'SEUUSRDEFA'
WHEN 'HHURT'
CALL 'SEUUSRDEFA'
WHEN 'HUY '
CALL 'SEUUSRDEFA'
WHEN 'HHUY '
CALL 'SEUUSRDEFA'
WHEN 'HP '
CALL 'SEUUSRDEFA'
WHEN 'HHP '
CALL 'SEUUSRDEFA'
WHEN 'HRP '
CALL 'SEUUSRDEFA'
WHEN 'HHRP '
CALL 'SEUUSRDEFA'
WHEN 'HB '
CALL 'SEUUSRDEFA'
WHEN 'HHB '
CALL 'SEUUSRDEFA'
WHEN 'HG '
CALL 'SEUUSRDEFA'
WHEN 'HHG '
CALL 'SEUUSRDEFA'
WHEN 'AD '
CALL 'SEUUSRDEFB'
WHEN 'AAD '
CALL 'SEUUSRDEFB'
WHEN 'UC '
CALL 'SEUUSRDEFC'
WHEN 'UUC '
CALL 'SEUUSRDEFC'
WHEN 'LC '
CALL 'SEUUSRDEFD'
WHEN 'LLC '
CALL 'SEUUSRDEFD'
WHEN 'AC '
CALL 'SEUUSRDEFE'
WHEN 'AAC '
CALL 'SEUUSRDEFE'
WHEN 'BC '
CALL 'SEUUSRDEFE'
WHEN 'BBC '
CALL 'SEUUSRDEFE'
WHEN 'RAC '
CALL 'SEUUSRDEFF'
WHEN 'RAAC '
CALL 'SEUUSRDEFF'
WHEN 'RBC '
CALL 'SEUUSRDEFF'
WHEN 'RBBC '
CALL 'SEUUSRDEFF'
WHEN OTHER
CONTINUE
END-EVALUATE.
200-EXIT.
EXIT.
|