HP 3000 Manuals HP 3000 Manuals
ORDERS Database Model Program (Cont.)
COBOL II (Cont.)
Updating an Entry.
This paragraph implements the UPDATE-A-CUSTOMER routine of the sample
program. The update process takes place in two phases.
In the first phase, the requested entry is located and retrieved. This
is achieved by a call to DBGET in mode 7. Then, the user provides the
new values.
In the second phase, the recently modified values replace the existing
entry. This is implemented using a call to DBUPDATE. Before this call,
the paragraph starts a TurboIMAGE/XL transaction bracketed by calls for
locking the volatile item. To retrieve the entry, DBGET is called in
mode 1. This call retrieves the entry located in the previous stage.
The paragraph must confirm that values retrieved in the first stage are
still residing in the same entry. This should be done before the actual
update. If the contents of the buffers are the same, the paragraph can
continue with the operation. Otherwise, it should end the transaction
and release the locks.
The exceptional condition for this paragraph is status 17. This
indicates that the requested entry does not exist or is empty.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBGET in mode 7 (calculated)
* DBLOCK in mode 5 (unconditional)
* DBBEGIN in mode 1 (transaction begin)
* DBGET in mode 1 (re-read)
* DBUPDATE in mode 1 (update)
* DBEND in mode 1 (transaction end)
* DBUNLOCK in mode 1 (unlock)
* 1100-GET-ERROR-AND-EXPLAIN
700-UPDATE-A-CUSTOMER.
SET NOT-FOUND TO TRUE
DISPLAY CLEAR SCREEN
DISPLAY "Enter the Account # for The Customer Master"
NO ADVANCING
DISPLAY "---------> " NO ADVANCING
ACCEPT KEY-ITEM-VALUE FREE
MOVE 7 TO DB-MODE
MOVE 0 TO LIST-NO-ITEM
MOVE "@;" TO LIST
MOVE "CUSTOMER;" TO CUSTOMER-MASTER
CALL "DBGET" USING DBNAME, CUSTOMER-MASTER, DB-MODE, STATUS1,
LIST, CUSTOMER-BUFFER, KEY-ITEM-VALUE
IF CONDITION = 0 THEN
SET FOUND TO TRUE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Data On Account # = ", KEY-ITEM-VALUE
DISPLAY "****************************************"
DISPLAY "* *"
DISPLAY "* Account # = ", ACCOUNT-NUMBER
OF CUSTOMER-BUFFER
DISPLAY "* Last Name = ", LAST-NAME
OF CUSTOMER-BUFFER
DISPLAY "* First Name = ", FIRST-NAME
OF CUSTOMER-BUFFER
DISPLAY "* Initial = ", INITIAL1
OF CUSTOMER-BUFFER
DISPLAY "* Address = ", STREET-ADDRESS
OF CUSTOMER-BUFFER
DISPLAY "* City = ", CITY OF CUSTOMER-BUFFER
DISPLAY "* State = ", STATE OF CUSTOMER-BUFFER
DISPLAY "* Zip = ", ZIP OF CUSTOMER-BUFFER
DISPLAY "* *"
DISPLAY "****************************************"
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Press Enter to Continue ------------------>"
NO ADVANCING
ACCEPT OPTION FREE
ELSE
IF CONDITION = NO-SUCH-ENTRY THEN
DISPLAY CLEAR SCREEN
DISPLAY "*****************************************"
DISPLAY "* No Such Entry in the Customer Data Set."
DISPLAY "* Please Try Again. "
DISPLAY "*****************************************"
DISPLAY "Enter to Continue --------->" NO ADVANCING
ACCEPT ANSWER FREE
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF
IF FOUND THEN
MOVE CORRESPONDING CUSTOMER-BUFFER TO CUSTOMER-BUFFER-OLD
MOVE 0 TO ANSWER
PERFORM WITH TEST BEFORE UNTIL ANSWER = 1
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Provide New Values For the Following"
DISPLAY "****************************************"
DISPLAY "* *"
DISPLAY "* Account # = " NO ADVANCING
ACCEPT ACCOUNT-NUMBER OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* Last Name = " NO ADVANCING
ACCEPT LAST-NAME OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* First Name = " NO ADVANCING
ACCEPT FIRST-NAME OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* Initial = " NO ADVANCING
ACCEPT INITIAL1 OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* Address = " NO ADVANCING
ACCEPT STREET-ADDRESS OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* City = " NO ADVANCING
ACCEPT CITY OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* State = " NO ADVANCING
ACCEPT STATE OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* Zip = " NO ADVANCING
ACCEPT ZIP OF CUSTOMER-BUFFER-NEW FREE
DISPLAY "* *"
DISPLAY "****************************************"
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "Enter <1> to Continue, <2> to Retry >"
NO ADVANCING
ACCEPT ANSWER FREE
IF ANSWER = 2 THEN
DISPLAY CLEAR SCREEN
END-IF
END-PERFORM
MOVE 1 TO NUM-OF-ELEMENTS
MOVE 22 TO LENGTH-OF-DESCRIPTOR
MOVE "CUSTOMER;" TO DATA-SET-OF-DESCRIPTOR
MOVE "ACCOUNT;" TO DATA-ITEM-OF-DESCRIPTOR
MOVE " =" TO RELOP-FOR-DATA-ITEM
MOVE KEY-ITEM-VALUE TO NUM-VALUE-FOR-DATA-ITEM
MOVE 5 TO DB-MODE
CALL "DBLOCK" USING DBNAME, LOCK-DESCRIPTOR-ARRAY, DB-MODE,
STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE "Update Entry In Customer Set Begin" TO TEXT1
MOVE 17 TO TEXTLEN
MOVE 1 TO DB-MODE
CALL "DBBEGIN" USING DBNAME, TEXT1, DB-MODE, STATUS1,
TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
CALL "DBGET" USING DBNAME, CUSTOMER-MASTER, DB-MODE,
STATUS1, LIST, CUSTOMER-BUFFER,
NOT-USED-PARM-32
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
ELSE
IF CUSTOMER-BUFFER = CUSTOMER-BUFFER-OLD THEN
CALL "DBUPDATE" USING DBNAME, CUSTOMER-MASTER,
DB-MODE, STATUS1, LIST,
CUSTOMER-BUFFER-NEW
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
ELSE
DISPLAY CLEAR SCREEN
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "***************************************"
DISPLAY "** During Terminal Interaction *"
DISPLAY "** Data On Account Number ",
KEY-ITEM-VALUE
DISPLAY "** Has Been Modified."
DISPLAY "** *"
DISPLAY "** Please Try Again. *"
DISPLAY "Press Enter to Continue ---------->"
NO ADVANCING
ACCEPT OPTION FREE
END-IF
END-IF
MOVE "Update Entry On Customer Set End" TO TEXT1
MOVE 16 TO TEXTLEN
CALL "DBEND" USING DBNAME, TEXT1, DB-MODE, STATUS1, TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
CALL "DBUNLOCK" USING DBNAME, CUSTOMER-MASTER, DB-MODE,
STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
END-IF.
Deleting an Entry.
This paragraph implements the DELETE-A-PRODUCT routine of the sample
program. The delete operation is achieved by a call to DBDELETE. This
call is preceded by a call to DBGET in mode 7, which locates the entry
for the delete operation. These calls are bracketed by calls to DBBEGIN
and DBEND, which designate the beginning and the end of a TurboIMAGE/XL
transaction.
Using calls to DBLOCK and DBUNLOCK in mode 3, the required resources are
locked before the start of the transaction and released after its end.
Exceptional condition code 17 is trapped after the DBGET call. This
indicates that the requested entry does not exist in the Product data
set.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBLOCK in mode 3 (unconditional)
* DBBEGIN in mode 1 (transaction begin)
* DBGET in mode 7 (calculated read)
* DBDELETE in mode 1 (delete)
* DBEND in mode 1 (transaction end)
* DBUNLOCK in mode 1 (unlock)
* 1100-GET-ERROR-AND-EXPLAIN
800-DELETE-A-PRODUCT.
DISPLAY CLEAR SCREEN
DISPLAY "Enter the stock # in the Product Master ----> "
NO ADVANCING
ACCEPT KEY-ITEM-VALUE-PRODUCT FREE
MOVE 3 TO DB-MODE
MOVE "@;" TO LIST
MOVE "PRODUCT;" TO PRODUCT-MASTER
CALL "DBLOCK" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE 1 TO DB-MODE
MOVE "Delete Entry From The Product Set Begin " TO TEXT1
MOVE 18 TO TEXTLEN
CALL "DBBEGIN" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1,
TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE 7 TO DB-MODE
CALL "DBGET" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1,
LIST, PRODUCT-BUFFER,
KEY-ITEM-VALUE-PRODUCT
IF CONDITION NOT = 0 THEN
IF CONDITION = NO-CHAIN-HEAD THEN
DISPLAY CLEAR SCREEN
DISPLAY "*****************************************"
DISPLAY "* No Such Entry in the Product Data Set. *"
DISPLAY "* Please Try Again. *"
DISPLAY "*****************************************"
ELSE
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
ELSE
MOVE 1 TO DB-MODE
CALL "DBDELETE" USING DBNAME, PRODUCT-MASTER, DB-MODE,
STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
ELSE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY "*****************************************"
DISPLAY "Product Record ", KEY-ITEM-VALUE-PRODUCT
NO ADVANCING
DISPLAY "Was Successfully Deleted."
DISPLAY "*****************************************"
END-IF
END-IF
MOVE 1 TO DB-MODE
MOVE "Delete Entry From the Product Set End" TO TEXT1
MOVE 18 TO TEXTLEN
CALL "DBEND" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1,
TEXTLEN
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
MOVE 1 TO DB-MODE
CALL "DBUNLOCK" USING DBNAME, PRODUCT-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
DISPLAY "Press Enter to Continue -----------> " NO ADVANCING
ACCEPT OPTION FREE.
Rewinding a Data Set.
This paragraph implements the REWIND-CUSTOMER-SET routine of the sample
program. Resetting the data set pointer is achieved by a call to DBCLOSE
in mode 2. No special condition is trapped.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBCLOSE in mode 2 (rewind)
* 1100-GET-ERROR-AND-EXPLAIN
900-REWIND-CUSTOMER-SET.
MOVE "CUSTOMER;" TO CUSTOMER-MASTER
MOVE 2 TO DB-MODE
CALL "DBCLOSE" USING DBNAME, CUSTOMER-MASTER, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.
Obtaining Database Information.
This paragraph implements the GET-DATA-ITEM-INFO routine of the sample
program. This information is obtained using a call to DBINFO in mode
102. The data item name passed through the DBINFO buffer identifies the
data item under inquiry.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBINFO in mode 102 (item access)
* 1100-GET-ERROR-AND-EXPLAIN
1000-GET-DATA-ITEM-INFO.
DISPLAY CLEAR SCREEN
DISPLAY "Enter your data item name------> " NO ADVANCING
ACCEPT DATA-ITEM-NAME-IN FREE
MOVE 102 TO DB-MODE
CALL "DBINFO" USING DBNAME, DATA-ITEM-NAME-IN, DB-MODE, STATUS1,
M-102-BUFFER
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF
DISPLAY SPACE
DISPLAY SPACE
DISPLAY SPACE
DISPLAY DATA-ITEM-NAME-IN, " Data Item"
DISPLAY "----------------------------------------"
DISPLAY "Data Item Name = ", DATA-ITEM-NAME
DISPLAY "Data Item Type = ", DATA-ITEM-TYPE
DISPLAY "Data Item Length = ", DATA-ITEM-LENGTH
DISPLAY "Data Item Count = ", DATA-ITEM-COUNT
DISPLAY "----------------------------------------"
DISPLAY "Press Enter to Continue... " NO ADVANCING
ACCEPT OPTION FREE.
Obtaining Error Messages and Explanations.
The following paragraph implements the GET-ERROR-AND-EXPLAIN routine of
the sample program. This paragraph calls DBEXPLAIN and DBERROR.
DBEXPLAIN interprets the contents of the Status parameter and prints a
message on $STDLIST. DBERROR returns a message in the ERROR-BUFFER,
explaining the condition code returned by TurboIMAGE/XL. At the end the
paragraph, users can choose to abort or continue the execution of this
program.
******************************************************************
* Access : Mode 1 - Shared Modified Access
*
* Called by: 100-OPEN-THE-DATABASE
* 200-GET-SALES-FOR-DATE
* 300-GET-A-CUSTOMER-RECORD
* 400-GET-PRODUCT-RECORD
* 500-LIST-ALL-CUSTOMERS
* 600-ADD-A-PROUDCT
* 700-UPDATE-A-CUSTOMER
* 800-DELETE-A-PRODUCT
* 900-REWIND-CUSTOMER-SET
* 1000-GET-DATA-ITEM-INFO
* 1200-CLOSE-THE-DATABASE
*
* Calls : DBERROR
* DBEXPLAIN
1100-GET-ERROR-AND-EXPLAIN.
MOVE SPACES TO ERROR-BUFFER
CALL "DBERROR" USING STATUS1, ERROR-BUFFER, ERROR-LENGTH
DISPLAY "---------------------------------------------------"
DISPLAY ERROR-BUFFER
DISPLAY "---------------------------------------------------"
DISPLAY SPACE
CALL "DBEXPLAIN" USING STATUS1
MOVE ZERO TO ANSWER
DISPLAY "---Enter, <1> to Abort..., <2> to Continue > "
NO ADVANCING
ACCEPT ANSWER FREE
IF ANSWER NOT = 1 THEN
DISPLAY "Continuing....."
ELSE
STOP RUN
END-IF.
Closing the Database.
This paragraph implements the CLOSE-THE-DATABASE routine of the sample
program. Closing the database is achieved by a call to DBCLOSE in mode
1. Error handling is done by referring all non-zero returned conditions
to the 1100-GET-ERROR-AND-EXPLAIN paragraph.
******************************************************************
* ACCESS : Mode 1 - Shared Modify Access
*
* Called By: 30-DO-ACTION
*
* Calls : DBCLOSE in mode 1 (close)
* 1100-GET-ERROR-AND-EXPLAIN
1200-CLOSE-THE-DATABASE.
MOVE 1 TO DB-MODE
CALL "DBCLOSE" USING DBNAME, PASSWORD, DB-MODE, STATUS1
IF CONDITION NOT = 0 THEN
PERFORM 1100-GET-ERROR-AND-EXPLAIN
END-IF.
FORTRAN 77
Portions of the model program presented at the beginning of this chapter
are now shown here in FORTRAN 77. The examples perform specific tasks to
illustrate the use of TurboIMAGE/XL intrinsics.
Data items are defined at the beginning of the sample program. Explicit
declaration of intrinsics is not required. Other global variables in
this program are placed in a COMMON file.
NOTE Because the Schema Processor, DBSCHEMA, upshifts alphabetic
characters, programs must specify data set and data item names in
all uppercase characters. Take note of this if FORTRAN 77 does not
require that you use uppercase characters.
For information on TurboIMAGE/XL data item lengths and type designators,
refer to chapter 3. Tables 3-2 and 3-3 show the TurboIMAGE/XL type
designators, sub-item lengths, and data types typically used to process
them in Pascal.
NOTE All parameters must be on halfword boundaries.
Because FORTRAN 77 requires that the parameters be on halfword
boundaries, they must be integer arrays equivalent to character strings
if necessary.
Defining Data Types, Variables, and Intrinsics.
The following declarations are placed in a FORTRAN 77 COMMON file. This
file enables different subroutines to import all necessary declarations.
In this program, the COMMON file is called comon1 and is included with
the directive $Include 'comon1'.
C**** TurboIMAGE/XL's Global Declaration
C**** Set up for the Database name parameter.
Integer*2 DBname(10)
Character BaseName*16
Equivalence(DBname(1),BaseName)
Common /Database_Name_Type / DBname
C**** Set up for the Password parameter.
Character Pass_Word*10
Integer*2 Password(5)
Equivalence (Password(1),Pass_Word)
Common /Database_password_type/ password
C**** Set up for the Mode parameter.
Integer In,Out,Not_Used_Parm
Integer*2 Mode
Integer*2 Mode1_SMA, Mode5_Unconditional, Mode1_Chained_Read
Integer*2 Mode5_Forward, Mode1_Unlock
C**** Set up for the Status parameter.
Integer*2 Status(10)
Integer*2 Condition
Integer*2 Length
Integer*4 Record_Number
Integer*4 Chain_Count
Integer*4 Back_Pointer
Integer*4 Forward_Pointer
Equivalence(Status(1),Condition),(Status(2),Length)
Equivalence(Status(3),Record_Number),(Status(5),Chain_Count)
Equivalence(Status(7),Back_Pointer),(Status(9),Forward_Pointer)
Common /Database_Status_Type/ Status
C**** Set up for the Lock_Descriptor_Array of the Sales data set.
Integer*2 Lock_Descriptor_Array(22)
Integer*2 Length_Of_Descriptor, Num_Of_Elements
Character Data_Set_Of_Descriptor*16
Character Data_Item_Of_Descriptor*16
Character Relative_Operator*2
Character Value_For_Data_Item*6
Equivalence (Lock_Descriptor_Array(1), Num_Of_Elements)
Equivalence (Lock_Descriptor_Array(2), Length_Of_Descriptor)
Equivalence (Lock_Descriptor_Array(3), Data_Set_Of_Descriptor)
Equivalence (Lock_Descriptor_Array(11),Data_Item_Of_Descriptor)
Equivalence (Lock_Descriptor_Array(19),Relative_Operator)
Equivalence (Lock_Descriptor_Array(20),Value_For_Data_Item)
C**** Set up for the Sales_Buffer of the Sales data set.
Integer*2 Sales_Buffer(19)
Integer*4 Account_Number
Character Stock_Number*8
Integer*2 Quantity
Integer*4 Price
Integer*4 Tax
Integer*4 Total
Character Purch_Date*6
Character Deliv_Date*6
Equivalence (Sales_Buffer(1), Account_Number)
Equivalence (Sales_Buffer(3), Stock_Number)
Equivalence (Sales_Buffer(7), Quantity)
Equivalence (Sales_Buffer(8), Price)
Equivalence (Sales_Buffer(10),Tax)
Equivalence (Sales_Buffer(12),Total)
Equivalence (Sales_Buffer(14),Purch_Date)
Equivalence (Sales_Buffer(17),Deliv_Date)