PDP-10 Archive: uetp/dtvrb2.cbl from BB-4148F-BM

Trailing-Edge - PDP-10 Archives - BB-4148F-BM_1984 - uetp/dtvrb2.cbl
There is 1 other file named dtvrb2.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. DTVRB2.

*	Program DTVRB2 - Basic DML Verb Test Sub-Program
*	(offshoot of BAS02C.TDM)
*	Part of the UETP and verify test system for DBMS-20

*                     Copyright (C) 1984 by
*             Digital Equipment Corporation, Maynard, Mass.
* 
*      This software is furnished under a license, and may be used
*      or copied only in accordance with the terms of that license.

*	SUBROUTINE DTVRB2 - DELETE MANIPS - 2ND SUB-SCHEMA
*	PART OF LARGE DML TEST, MAIN PROGRAM DTVRB1.CBL
*	USED TO TEST DML VERB PROCESSORS, AND DBCS IN GENERAL
*	  SEE DTVRB1 FOR LAST UNIQUE ERROR NUMBER

ENVIRONMENT DIVISION.
DATA DIVISION.
SCHEMA SECTION.

*	******************************************
*	*  FULL BLOWN INVOKE, SECOND SUB-SCHEMA  *
*	******************************************
	INVOKE SUB-SCHEMA DTSSV2 OF SCHEMA DTVRB PRIVACY KEY
		FOR COMPILE B2.
WORKING-STORAGE SECTION.
01 I USAGE COMP PIC S9(10).
01 ILEFT USAGE COMP PIC S9(10).
01 D1 USAGE COMP PIC S9(10).
01 DD1 USAGE COMP PIC S9(18).
01 DD2 REDEFINES DD1 USAGE COMP.
   02 FILLER PIC S9(10).
   02 D3 PIC S9(10).
01 IER USAGE COMP PIC S9(10).
01 IGN USAGE COMP PIC S9(10).
LINKAGE SECTION.
01 ICASE USAGE COMP PIC S9(10).
PROCEDURE DIVISION.

DECLARATIVES.

*	********************************
*	*  USE PROCEDURE DECLARATIONS  *
*	*  WILL NOT ACTUALLY BE USED   *
*	*  W/O COMPLIER EDIT 1414      *
*	********************************
USE-EON SECTION.
	USE IF ERROR-STATUS IS 0307,0326.
EEON.
*	PROCESS ESA (0307) AND NRS (0326) ONLY
	IF ERROR-STATUS NOT = 307 AND ERROR-STATUS NOT = 326 GO TO EEON-1.
	IF IGN NOT = 0 AND IGN NOT = ERROR-STATUS GO TO EEON-2.
	MOVE ERROR-STATUS TO IER.
	GO TO EEON-EXIT.
EEON-1.
	DISPLAY '?TRAPPING EXCEPTION 307 OR 326, RECEIVED ',ERROR-STATUS.
	STOP RUN.
EEON-2.
	DISPLAY '?UNEXPECTED EXCEPTION ',ERROR-STATUS.
	STOP RUN.
EEON-EXIT.
	EXIT.
USE-UMR SECTION.
	USE IF ERROR-STATUS 0009.
EUMR.
*	PROCESS ALL UMR (**09) EXCEPTIONS
	DIVIDE ERROR-STATUS BY 100 GIVING D1.
	MULTIPLY D1 BY 100 GIVING DD1.
	SUBTRACT D3 FROM ERROR-STATUS GIVING D1.
	IF D1 NOT = 9 GO TO EUMR-1.
	IF ERROR-STATUS NOT = 209 AND ERROR-STATUS NOT = 809 GO TO EUMR-2.
	IF IGN NOT = 209 AND IGN NOT = 809 GO TO EUMR-3.
	MOVE ERROR-STATUS TO IER.
	GO TO EUMR-EXIT.
EUMR-1.
	DISPLAY '?TRAPPING EXCEPTION **09, RECEIVED ',ERROR-STATUS.
	STOP RUN.
EUMR-2.
	DISPLAY '?EXPECTING EXCEPTION 0209 OR 0809, RECEIVED ',ERROR-STATUS.
	STOP RUN.
EUMR-3.
	DISPLAY '?UNEXPECTED EXCEPTION ',ERROR-STATUS.
	STOP RUN.
EUMR-EXIT.
	EXIT.
USE-DEL SECTION.
	USE IF ERROR-STATUS IS 0200.
EDEL.
*	PROCESS ANY DELETE VERB (02**) ERROR
	IF ERROR-STATUS LESS THAN 200 OR
		ERROR-STATUS GREATER THAN 299 GO TO EDEL-1.
	IF ERROR-STATUS NOT = 230 GO TO EDEL-2.
	IF ERROR-STATUS NOT = IGN GO TO EDEL-3.
	MOVE 230 TO IER.
	GO TO EDEL-EXIT.
EDEL-1.
	DISPLAY '?TRAPPING EXCEPTION 02**, RECEIVED ',ERROR-STATUS.
	STOP RUN.
EDEL-2.
	DISPLAY '?EXPECTING EXCEPTION 0230, RECEIVED ',ERROR-STATUS.
	STOP RUN.
EDEL-3.
	DISPLAY '?UNEXPECTED EXCEPTION 0230'.
	STOP RUN.
EDEL-EXIT.
	EXIT.
USE-GEN SECTION.
	USE IF ERROR-STATUS.
EGEN.
*	HANDLE ALL EXCEPS NOT HANDLED ABOVE
	IF ERROR-STATUS NOT = IGN GO TO EGEN-1.
	MOVE ERROR-STATUS TO IER.
	GO TO EGEN-EXIT.
EGEN-1.
	DISPLAY '?UNEXPECTED EXCEPTION ',ERROR-STATUS.
	STOP RUN.
EGEN-EXIT.
	EXIT.

END DECLARATIVES.

*	MAIN ENTRY DTVRB2.

*	INIT CASE, INVOKE, USE PROC SETUP, OPEN, 1ST REC
P6100.
	ENTER MACRO JMNAME USING 'DSK:DTVRB.JRN'.
	OPEN AREA TESTA2 USAGE-MODE UPDATE.
	MOVE 'TESTA2' TO P1AREA.
	STORE P1.
	GO TO P6900.

*	*************************************************
*	*  DELETES, ALL NON TRIVIAL FORMS               *
*	*  USE COMMON SUBROUTINES FOR SETUP AND CHECKS  *
*	*************************************************
	ENTRY DELCAS USING ICASE.

P6200.
	IF ICASE LESS THAN 1 OR ICASE GREATER THAN 10 GO TO P6950.
	ENTER MACRO SETDB USING 'DTSSV2'.
	GO TO P6210,P6220,P6230,P6240,P6250,P6260,P6270,P6280,P6290,
		P6300 DEPENDING ON ICASE.

*	DELETE SPECIFIC RECORD, THEN ALL
P6210.
	PERFORM DELINI THRU DELINI-EXIT.
	MOVE 230 TO IGN.
	MOVE 0 TO IER.
	DELETE DL1.
	IF ERROR-STATUS NOT = 230 STOP '?8846B1'.
*	IF IER NOT = 230 STOP '?88133B1'.
	IF IER NOT = 230 DISPLAY '%ERROR 230 NOT TRAPPED BY SUB DTVRB2'.
	MOVE 0 TO IGN.
	DELETE DL1 ALL.
*	NOTHING LEFT
	MOVE 0 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE SELECTIVE
P6220.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE  SELECTIVE.
	MOVE 5 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE RECORD ONLY
P6230.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE DL1 ONLY.
	MOVE 12 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE MEMBERS (WILL FAIL) THEN ADD SET
P6240.
	PERFORM DELINI THRU DELINI-EXIT.
	MOVE 230 TO IGN.
	MOVE 0 TO IER.
	DELETE MEMBERS.
	IF ERROR-STATUS NOT = 230 STOP '?88234B1'.
*	IF IER NOT = 230 STOP '?88235B1'.
	IF IER NOT = 230 DISPLAY '%ERROR 230 NOT TRAPPED BY SUB DTVRB2'.
	MOVE 0 TO IGN.
	DELETE MEMBERS FROM L12MAN2.
	MOVE 17 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE RECORD ALL MEMBERS
P6250.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE DL1 ALL MEMBERS.
	MOVE 1 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE RECORD SELECTIVE MEMBERS
P6260.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE DL1 SELECTIVE MEMBERS.
	MOVE 2 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE ONLY MEMBERS FROM SET
P6270.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE ONLY MEMBERS FROM L12MAND.
	MOVE 15 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE RECORD SELECTIVE MEMBERS SET
P6280.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE DL1 SELECTIVE MEMBERS FROM L12OPT.
	MOVE 11 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	DELETE ONLY MEMBERS SET1,SET2
P6290.
	PERFORM DELINI THRU DELINI-EXIT.
	DELETE ONLY MEMBERS FROM L12MAND,L12OPT.
	MOVE 9 TO ILEFT.
	PERFORM DELCHK THRU DELCHK-EXIT.
	GO TO P6900.

*	CLOSE
P6300.
	CLOSE AREA TESTA2.
	CLOSE JOURNAL.
	GO TO P6900.

P6900.
	ENTER MACRO UNSET.
P6950.
*	GO BACK.	CBL68
	EXIT PROGRAM.

*	SUBROUTINE DELINI
DELINI.
*	BUILD THREE LEVEL STRUCTURE TO BE DELETED

	OPEN TRANSACTION TUA2.
	STORE DL1.
	STORE DL2MAN2.
	STORE DL2MAND.
*	FORCE OWNER LINK TO BE USED ON NEXT STORE
	  STORE DL3OPT SUPPRESS ALL.
*	CHANGE CURR OF SET...WITH NON-SET OPER SO THAT
	  FIND DL3OPT.
	IF ERROR-STATUS NOT = 0 STOP '?88134B1'.
*	APPLIC OF ORDER PRIOR CLAUSE WILL USE OWNER PTR
*	...RATHER THAN OB.COWN
	  STORE DL3OPT.
	  INSERT INTO P1L3.
	  STORE DL3MAN2.
	STORE DL2MAN2.
	STORE DL2MAND.
	  STORE DL3OPT.
	  STORE DL3MAN2.
	  STORE DL3OPT.
	STORE DL2OPT.
	  STORE DL3OPT2.
	  STORE DL3MAND.
	  STORE DL3MAND.
	STORE DL2OPT.
	INSERT DL2OPT INTO ALL SETS.
	  STORE DL3MAND.
	  STORE DL3MAND.
	  STORE DL3OPT2.
*	SO DELETE WILL APPLY TO RIGHT RECORD
	FIND FIRST DL1 RECORD OF TESTA2 AREA.
	IF ERROR-STATUS NOT = 0 STOP '?88135B1'.
	CLOSE TRANSACTION.
DELINI-EXIT.
	EXIT.

*	SUBROUTINE DELCHK USING ILEFT.
DELCHK.
*	COUNT RECS (EXCEPT P1) IN AREA AFTER DELETE
	FIND FIRST RECORD OF TESTA2 AREA.
	IF ERROR-STATUS NOT = 0 STOP '?88136B1'.

	OPEN TRANSACTION TRCA2.
	MOVE 0 TO I.
P10.
	FIND NEXT RECORD OF TESTA2 AREA.
	IF ERROR-STATUS NOT = 0 GO TO P11.
	ADD 1 TO I.
	GO TO P10.
P11.
	IF ERROR-STATUS NOT = 307 STOP '?8850B1'.
	IF I NOT = ILEFT STOP '?8851B1'.
	CLOSE TRANSACTION TRCA2.

*	NOW RE-INIT ENVIR
	FIND FIRST RECORD OF TESTA2 AREA.
	IF ERROR-STATUS NOT = 0 STOP '?88137B1'.
P12.
	FIND NEXT RECORD OF TESTA2 AREA.
	IF ERROR-STATUS = 307 GO TO P13.
	IF ERROR-STATUS NOT = 0 STOP '?8852B1'.
	DELETE ALL.
	GO TO P12.
P13.
*	DONE
DELCHK-EXIT.
	EXIT.