ˆ PROCESS APOST, XREF, FULLOPT
ˆ IDENTIFICATION DIVISION.
ˆ PROGRAM-ID. SEUUSRDEFF.
ˆ AUTHOR. Richard Silvers.
ˆ DATE-WRITTEN. 02/26/2001.
ˆ DATE-COMPILED.
‚ *---------------------------------------------------------------*
‚ *--------------------- PROGRAM OVERVIEW ------------------------*
‚ *---------------------------------------------------------------*
‚ * *
‚ * SYSTEM ID. SEUUSRDEFF *
‚ * *
‚ * PROGRAM TITLE. User defined line command for SEU: *
‚ * RAC and RAAC - Remove comment line *
‚ * RBC and RBBC - Remove blank comment line *
‚ * *
‚ * PURPOSE. The purpose of this program is to let the user *
‚ * delete a comment line or delete a blank *
‚ * comment line. *
‚ * *
‚ * This program makes use of the following AS/400 APIs. *
‚ * *
‚ * QUSRTVUS - Retrieve entry information from the SEU user space *
‚ * QSUSPC. *
‚ * QUSCHGUS - Change 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 *
‚ * ----------- ----- ----------- --------------------------*
‚ * 16 Jan 2001 R. Silvers Original Development *
‚ * *
‚ * 18 Jan 2001 R. Silvers Added option for REXX * A-011901
‚ * source. * A-011901
‚ * *
‚ * 26 Feb 2001 R. Silvers Created from SEUUSRDEFE. * A-011901
‚ * *
‚ *---------------------------------------------------------------*
‚ *--------------------- 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 'SEUUSRDEFF'.
01 ASTERISK PIC X(01) VALUE '*'.
01 SLASH-ASTERISK PIC X(02) VALUE '/*'.
01 ASTERISK-SLASH PIC X(02) VALUE '*/'.
01 COMMENT-CLP PIC X(71) VALUE '/*--------------
- '-----------------------------------------------------*/'.
01 COMMENT-COBOL PIC X(65) VALUE '*---------------
- '------------------------------------------------*'.
01 FORCE-CHANGE PIC X(01) VALUE '0'.
01 COMMAND-CODE PIC X(04) 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 '.
‚ *---------------------------------------------------------------*
‚ * Member types have the hilite attribute set in different *
‚ * columns when they're being edited in SEU -- most notably *
‚ * are columns 6 (ILE/RPG) and column 1 (all others listed). *
‚ *---------------------------------------------------------------*
01 MEMBER-TYPE PIC X(10) VALUE SPACE.
88 COBOL-PGM VALUE 'CBLLE '
'SQLCBLLE '
'CBL '
'CPY '
'SQLCBL '.
88 CL-PGM VALUE 'CLP '
'CLLE '
'REXX '. A-011901
88 DDS-FILE VALUE 'DSPF '
'PRTF '
'PF '
'LF '.
‚ *---------------------------------------------------------------*
‚ * Set the processing MODE of the line we're working on. *
‚ *---------------------------------------------------------------*
01 PROCESS-MODE PIC X(01) VALUE SPACE.
88 BLOCK-MODE VALUE 'B'.
88 SINGLE-MODE VALUE 'S'.
88 DONT-PROCESS VALUE SPACE.
‚ *---------------------------------------------------------------*
‚ * Set the kind of comment line *
‚ *---------------------------------------------------------------*
01 COMMENT-MODE PIC X(03) VALUE SPACE.
88 ADD-COMMENT VALUE 'AC '.
88 ADD-COMMENT-BLOCK VALUE 'ACC'.
88 ADD-COMMENT-BLANK VALUE 'BC'.
88 ADD-COMMENT-BLANK-BLOCK VALUE 'BBC'.
‚ *---------------------------------------------------------------*
‚ * Switch to determine if the command line should be CLEARED. *
‚ *---------------------------------------------------------------*
01 COMMAND-MODE PIC X(01) VALUE SPACE.
88 CLEAR-COMMAND VALUE 'Y'.
88 LEAVE-COMMAND VALUE 'N'.
‚ *---------------------------------------------------------------*
‚ * 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(07) 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(80) VALUE SPACES.
‚ *---------------------------------------------------------------*
‚ * Color Byte Work Area *
‚ * *
‚ * Notes: -Hex codes 27 & 37 are dark and not permitted. *
‚ * -Hex codes 21-23 may cause the line to be shifted one *
‚ * character to the left when printed on some printers. *
‚ *---------------------------------------------------------------*
‚ *---------------------------------------------------------------*
‚ * White *
‚ *---------------------------------------------------------------*
01 HEX-22 PIC X(01) VALUE X'22'.
‚ *---------------------------------------------------------------*
‚ * Passed POINTER PARAMETERS sent by SEU - We don't USE. *
‚ *---------------------------------------------------------------*
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.
PERFORM 100-RTV-USER-SPACE THRU
100-RTV-USER-SPACE-EXIT.
MOVE +101 TO USRSPC-OFFSET.
SET DONT-PROCESS TO TRUE.
PERFORM 200-GET-COMMAND THRU
200-GET-COMMAND-EXIT
VARYING IDX FROM 1 BY 1
UNTIL IDX > (HDR-RCDSIN - 1).
PERFORM 400-UPDATE-HEADER THRU
400-UPDATE-HEADER-EXIT.
GOBACK.
‚ *---------------------------------------------------------------*
‚ * Retrieve the User Space as a single block *
‚ *---------------------------------------------------------------*
100-RTV-USER-SPACE.
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.
100-RTV-USER-SPACE-EXIT.
EXIT.
‚ *---------------------------------------------------------------*
‚ * Get line to change. *
‚ *---------------------------------------------------------------*
200-GET-COMMAND.
COMPUTE USRSPC-SIZE = HDR-RCDLEN
+ LINEPRFX-LEN
CALL 'QUSRTVUS' USING USRSPC-NAME
USRSPC-OFFSET
USRSPC-SIZE
TEXT-SPACE
QUS-EC.
INSPECT TXT-LINECMD REPLACING ALL LOW-VALUES BY SPACES.
INSPECT TXT-LINECMD REPLACING ALL '0' 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 if its one line or multiple lines (block). *
‚ *---------------------------------------------------------------*
MOVE HDR-MBRTYPE TO MEMBER-TYPE.
EVALUATE COMMAND-CODE
WHEN 'RAC '
SET ADD-COMMENT TO TRUE
SET SINGLE-MODE TO TRUE
SET CLEAR-COMMAND TO TRUE
IF COBOL-PGM OR DDS-FILE
THEN
MOVE SPACES TO TXT-SRCLINE (7:65)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
IF CL-PGM
THEN
MOVE SPACES TO TXT-SRCLINE (1:71)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
PERFORM 300-CHANGE-LINE THRU 300-EXIT
WHEN 'RAAC'
SET ADD-COMMENT-BLOCK TO TRUE
SET CLEAR-COMMAND TO TRUE
IF BLOCK-MODE
SET DONT-PROCESS TO TRUE
ELSE
SET BLOCK-MODE TO TRUE
END-IF
IF COBOL-PGM OR DDS-FILE
THEN
MOVE SPACES TO TXT-SRCLINE (7:65)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
IF CL-PGM
THEN
MOVE SPACES TO TXT-SRCLINE (1:71)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
PERFORM 300-CHANGE-LINE THRU 300-EXIT
WHEN 'RBC '
SET ADD-COMMENT-BLANK TO TRUE
SET SINGLE-MODE TO TRUE
SET CLEAR-COMMAND TO TRUE
IF COBOL-PGM OR DDS-FILE
THEN
MOVE SPACES TO TXT-SRCLINE (7:1)
MOVE SPACES TO TXT-SRCLINE (71:1)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
IF CL-PGM
THEN
MOVE SPACES TO TXT-SRCLINE (1:2)
MOVE SPACES TO TXT-SRCLINE (70:2)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
PERFORM 300-CHANGE-LINE THRU 300-EXIT
WHEN 'RBBC'
SET ADD-COMMENT-BLANK-BLOCK TO TRUE
SET CLEAR-COMMAND TO TRUE
IF BLOCK-MODE
SET DONT-PROCESS TO TRUE
ELSE
SET BLOCK-MODE TO TRUE
END-IF
IF COBOL-PGM OR DDS-FILE
THEN
MOVE SPACES TO TXT-SRCLINE (7:1)
MOVE SPACES TO TXT-SRCLINE (71:1)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
IF CL-PGM
THEN
MOVE SPACES TO TXT-SRCLINE (1:2)
MOVE SPACES TO TXT-SRCLINE (70:2)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
PERFORM 300-CHANGE-LINE THRU 300-EXIT
WHEN OTHER
SET LEAVE-COMMAND TO TRUE
IF BLOCK-MODE
IF COBOL-PGM OR DDS-FILE
IF ADD-COMMENT OR ADD-COMMENT-BLOCK
THEN
MOVE SPACES TO TXT-SRCLINE (7:65)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
END-IF
IF BLOCK-MODE
IF CL-PGM
IF ADD-COMMENT OR ADD-COMMENT-BLOCK
THEN
MOVE SPACES TO TXT-SRCLINE (1:71)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
END-IF
IF BLOCK-MODE
IF COBOL-PGM OR DDS-FILE
IF ADD-COMMENT-BLANK OR ADD-COMMENT-BLANK-BLOCK
THEN
MOVE SPACES TO TXT-SRCLINE (7:1)
MOVE SPACES TO TXT-SRCLINE (71:1)
MOVE SPACES TO TXT-SRCLINE (1:1)
END-IF
END-IF
IF BLOCK-MODE
IF CL-PGM
IF ADD-COMMENT-BLANK OR ADD-COMMENT-BLANK-BLOCK
THEN
MOVE SPACES TO TXT-SRCLINE (1:2)
MOVE SPACES TO TXT-SRCLINE (70:2)
MOVE SPACES TO TXT-SRCLINE (3:1)
END-IF
END-IF
PERFORM 300-CHANGE-LINE THRU 300-EXIT
ELSE
SET DONT-PROCESS TO TRUE
END-IF
END-IF
END-IF
END-IF
END-EVALUATE.
COMPUTE USRSPC-OFFSET = USRSPC-OFFSET
+ HDR-RCDLEN
+ LINEPRFX-LEN.
200-GET-COMMAND-EXIT.
EXIT.
‚ *---------------------------------------------------------------*
‚ * Clear prefix area. *
‚ *---------------------------------------------------------------*
300-CHANGE-LINE.
IF CLEAR-COMMAND
MOVE SPACES TO TXT-LINECMD
END-IF.
‚ *---------------------------------------------------------------*
‚ * Change QSUSPC. *
‚ *---------------------------------------------------------------*
MOVE '0' TO FORCE-CHANGE.
COMPUTE USRSPC-SIZE = HDR-RCDLEN
+ LINEPRFX-LEN
CALL 'QUSCHGUS' USING USRSPC-NAME
USRSPC-OFFSET
USRSPC-SIZE
TEXT-SPACE
FORCE-CHANGE
QUS-EC.
300-EXIT.
EXIT.
‚ *---------------------------------------------------------------*
‚ * Update the user space HEADER area telling SEU *
‚ * that the update is complete. *
‚ *---------------------------------------------------------------*
400-UPDATE-HEADER.
MOVE '0' TO HDR-RTNCODE.
MOVE 'U' TO HDR-MODE.
COMPUTE HDR-RCDSOUT = HDR-RCDSIN - 1.
MOVE +1 TO USRSPC-OFFSET.
MOVE LENGTH OF HEADER-SPACE TO USRSPC-SIZE.
MOVE '0' TO FORCE-CHANGE.
CALL 'QUSCHGUS' USING USRSPC-NAME
USRSPC-OFFSET
USRSPC-SIZE
HEADER-SPACE
FORCE-CHANGE
QUS-EC.
400-UPDATE-HEADER-EXIT.
EXIT.
|