HP 3000 Manuals HP 3000 Manuals
ORDERS Database Model Program (Cont.)
Pascal (Cont.)
Opening the Database.
This procedure implements the Open_The_Database procedure of the sample
program. All required values, such as the password, are provided by the
routine. Note that the password DO-ALL is followed by a semicolon
because it is less than eight characters long; a blank can be substituted
for the semicolon. Open_The_Database uses open mode 1, which is the
shared modify access mode. Error trapping is done by referring all
non-zero conditions to the Get_Error_And_Explain procedure.
$Page$
Procedure Open_The_Database;
(* Access : Mode 1 - Shared Modify Access (SMA) with locking required
Called By: Main Line
Calls : DBOPEN in mode 1 (SMA)
Get_Error_And_Explain *)
Begin
Mode1_SMA : Integer;
DBname.BaseID :=' ';
DBname.BaseName :='ORDERS; ';
Password :='DO-ALL;';
Mode1_SMA :=1;
DBOPEN (DBname,Password,Mode1_SMA,Status);
If Status.Condition <> 0 Then
Get_Error_And_Explain;
End;
Retrieving All the Records on a Chain (with Item Level Locking).
This procedure implements the Get_Sales_For_Date routine of the sample
program. Chained access is achieved using a call to DBFIND. The search
item used for this call is Purch-Date. An item level lock is obtained on
the value of the search item before the DBFIND call. After that,
individual chain items are retrieved, until the end of chain is
encountered. This is done using multiple calls to the DBGET procedure.
The routine traps two exceptional conditions:
1. Status condition 17 from the DBFIND call, indicating that the
chain head cannot be located.
2. Status 15 from the DBGET call, indicating the end of chain.
The status interpretation routine permits you to either abort or continue
with the execution of the program after viewing all error messages.
$Page$
Procedure Get_Sales_For_Date;
(* Access : Mode 1 - Shared Modify Access
The Orders database was opened in mode 1.
Called By: Main Line
Calls : DBLOCK in mode 5 (unconditional item level locking)
DBFIND in mode 1 (chained access)
DBGET in mode 5 (forward chained read)
DBUNLOCK in mode 1 (unlock)
Get_Error_And_Explain *)
Var
Lock_Descriptor_Array : Lock_Descriptor_Sales_Array_Type;
Sales_Detail : Data_Set_Name_Type;
Search_Item_Name : Data_Item_Name_Type;
Search_Item_Value : Packed Array [1..6]of Char;
Sales_Buffer : Sales_Data_Set_Type;
Not_Used_Parm : Shortint;
Mode1_Chained_Read : Shortint;
Mode5_Unconditional : Shortint;
Mode5_Forward : Shortint;
Mode1_Unlock : Shortint;
Begin
(* Prepare the lock descriptor buffer for obtaining item level *)
(* locks on the Sales data set. *)
With Lock_Descriptor_Array Do
Begin
Num_Of_Elements := 1;
With Lock_Descriptor_Sales Do
Begin
Length_Of_Descriptor := 21;
Data_Set_Of_Descriptor :='SALES;';
Data_Item_Of_Descriptor :='PURCH-DATE;';
Relative_Operator :=' =';
End;
End;
Prompt (' Enter The Date of Purchase as (YYMMDD) >>> ');
Readln (Search_Item_Value);
Mode5_Unconditional :=5; (* Request item level locks. *)
(* Append the user's input to the lock descriptor buffer. *)
Lock_Descriptor_Array. Lock_Descriptor_Sales.Value_For_Data_Item
:=Search_Item_Value;
(* Place item level locks on all entries identified by *)
(* the value in the Search_Item_Value. *)
DBLOCK (DBname,Lock_Descriptor_Array,Mode5_Unconditional,Status);
If Status.Condition <> 0 then
Get_Error_And_Explain;
Sales_Detail :='SALES;';
Search_Item_Name :='PURCH-DATE;';
Mode1_Chained_Read :=1;
(* Locate the chain identified by the value in the *)
(* Search_Item_Value. *)
DBFIND (DBname,Sales_Detail,Mode1_Chained_Read,Status,
Search_Item_Name,Search_Item_Value);
If Status.Condition <>0 Then
Begin
If Status.Condition = No_Chain_Head Then
Begin
Writeln('***************************************');
Writeln('* No Such Entry in the Sales Dataset *');
Writeln('* Please Try Again. *');
Writeln('***************************************');
Prompt ('Hit Enter To Continue ---------------->');
Readln;
End
Else Get_Error_And_Explain;
End
Else
Begin
Write('Acct-Number');
Write('Stock-Number':14);
Write('Qty':6);
Write('Price':7 );
Write('Tax':5);
Write('Total':8);
Write('Purch-Date':12);
Write('Delive-Date':14);
Write('---------------------------------------------------);
Write('---------------------------');
Writeln;
(* Start retrieving all records in the current chain. *)
Mode5_Forward :=5;
List :='@;';
While Status.Condition <> End_Of_Chain Do
Begin
(* Retrieve the contents of the entry which is at the *)
(* current record pointer. *)
DBGET (DBname,Sales_Detail,Mode5_Forward,Status,List,Sales_Buffer,
Not_Used_Parm);
If Status.Condition= 0 Then
Begin
With Sales_Buffer Do
Begin
Writeln;
Write(Account_Number:10);
Write(Stock_Number:15);
Write(Quantity:6);
Write(Price:7 );
Write(Tax:5 );
Write(Total:7);
Write(Purch_Date:12);
Write(Deliv_Date:12);
End;
End (* Check the status buffer for any condition *)
Else (* codes not equal to zero. *)
Begin
If Status.Condition= End_Of_Chain Then
Begin
Writeln;
Writeln;
Writeln;
Prompt ('----> End Of Chain, Hit Enter to Continue');
Readln;
End
Else Get_Error_And_Explain;
End;
End;
End;
(* Release all locks acquired at the beginning of the process. *)
Mode1_Unlock :=1;
DBUNLOCK (DBname,Sales_Detail,Mode1_Unlock,Status);
If Status.Condition<>0 Then
Get_Error_And_Explain
End;
$Page$
RPG
RPG contains language constructs that make calls to TurboIMAGE/XL
intrinsics, rather than having the user code do the intrinsic calls
directly. For example, RPG opens all files at the beginning of program
execution, thereby calling DBOPEN for any databases named on File
Description specifications. Likewise, DBCLOSE is automatically called
for databases at the end of program execution. Another example is the
RPG CHAIN operation which calls DBFIND and/or DBGET, depending on its
usage.
A small set of TurboIMAGE/XL intrinsics have no RPG language equivalent
and so cannot be accessed at the present time. These include DBERROR,
DBEXPLAIN, DBBEGIN, DBEND, and DBMEMO. Because the sample program on
which this RPG program is based contains calls to DBERROR and DBEXPLAIN,
the RPG version cannot exactly match the functionality of the sample
program. Instead, it displays the status value returned by TurboIMAGE/XL
when an error occurs.
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 as RPG does not
require that you use uppercase characters.
For information of 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 RPG.
Defining Data Types, Variables, and Intrinsics.
The first five F-specs implement the OPEN-THE-DATABASE routine of the
sample program in RPG. RPG automatically opens all databases (by calling
DBOPEN) at the beginning of program execution. F-specs are used to
declare how each database/set is to be opened and accessed.
In this program, the database is opened with mode 1 (shared modify
access) by entry of L in column 66 on the KIMAGE line. This entry also
allows user-controlled locking of the database/set/item to occur.
The data set is opened for chained sequential read accesses by entry of C
in column 67 of the KIMAGE line. If an error occurs during opening of
the database, the program will abort.
Note that RPG also closes all databases (by calling DBCLOSE) at the end
of program execution, so there is no need for the user to call a separate
routine to do this.
$CONTROL NOINFO,MAP,NAME=RTURBO
H L 1
****************************************************************
* Program name: RTURBO *
* Description : Example of RPG access to TurboIMAGE/XL *
****************************************************************
FSALES IC F 38R 6AI 27 DISC
F KIMAGE ORDERSLC
F KITEM PURCH-DATE
F KLEVEL DO-ALL
F KSTATUSSTAT
FTERMIN ID F 79 $STDIN
FTERMOUT O V 79 $STDLST
****************************************************************
* TABLE/ARRAY DECLARATIONS *
****************************************************************
E ESC 1 1 1 Escape = 27
****************************************************************
* INPUT RECORD LAYOUTS *
****************************************************************
ISALES NS
I B 1 40ACCT#
I 5 12 STOCK#
I 6 13 140QTY
I 7 15 180$PRICE
I 5 19 220$TAX
I 8 23 260$TOTAL
I 27 320PDATE
I 33 380DDATE
ITERMIN NS
I 1 8 OPTION
Main Body of Program.
****************************************************************
* CALCULATIONS MAINLINE *
****************************************************************
C* Execute GETSAL subroutine, then end program.
C*
C EXSR GETSAL
C SETON LR
Retrieving All the Records on a Chain (with Item Level Locking).
This subroutine implements the GET-SALES-FOR-DATE routine of the sample
program. Chained access is achieved using the CHAIN operation which
performs a DBFIND call and a DBGET call on the first execution, and then
DBGET calls on subsequent executions for the same search value. Thus a
loop is done on the CHAIN operation in order to retrieve all the entries
in the data item chain. The routine traps two exceptional conditions:
failure to find a chain head, and reaching end-of-chain.
****************************************************************
* G E T S A L S U B R O U T I N E *
****************************************************************
C GETSAL BEGSR
C*--------------------------------------------------------------
C* Display prompt for date and read user input from screen.
C*
C EXCPT CLEAR
C EXCPT GETDAT
C READ TERMIN H0
C MOVELOPTION DATE 6
C*--------------------------------------------------------------
C* Do unconditional data item lock on DATE.
C*
C DATE LOCK SALES 21
C 21 EXSR GETERR
C LR GOTO END1
C*--------------------------------------------------------------
C* Loop on CHAIN operation to get all entries in chain. On
C* first occurrence of CHAIN for a unique value of DATE, RPG
C* calls DBFIND, followed by DBGET. On subsequent uses of
C* CHAIN with the same value for DATE, only DBGET is called.
C*
C SETOF 202122
C LOOP1 TAG
C DATE CHAINSALES 2122
C*--------------------------------------------------------------
C* No chain head found.
C*
C 21 EXCPT CLEAR
C 21 EXCPT NOHEAD
C 21 READ TERMIN H0
C 21 GOTO SKIP
C*--------------------------------------------------------------
C* End-of-chain found.
C*
C 22 EXCPT EOC
C 22 READ TERMIN H0
C 22 GOTO SKIP
C*--------------------------------------------------------------
C* Any other error.
C*
C STAT,1 IFGT 0
C EXSR GETERR
C LR GOTO END1
C END
C*--------------------------------------------------------------
C* Print headings and data record.
C*
C N20 EXCPT CLEAR
C N20 EXCPT SALHDR
C N20 EXCPT LINHDR
C N20 SETON 20
C EXCPT SALREC
C*--------------------------------------------------------------
C* Loop back to do another CHAIN operation (DBGET).
C*
C GOTO LOOP1
C SKIP TAG
C*--------------------------------------------------------------
C* Unlock the data item.
C*
C DATE UNLCKSALES 24
C N24 EXSR GETERR
C*
C END1 ENDSR
Obtaining Error Messages and Explanations.
The following subroutine implements the GET-ERROR-AND-EXPLAIN routine of
the sample program. Because RPG as yet does not have access to DBEXPLAIN
and DBERROR, this subroutine simply displays the TurboIMAGE/XL error
number from the status array and then allows the user to either abort the
the program or continue its execution. If the user elects to abort, the
LR indicator is set ON and the code which called this subroutine must
test for LR and exit immediately to its caller, which in turn must exit
to its caller, and so on.
****************************************************************
* G E T E R R S U B R O U T I N E *
****************************************************************
C GETERR BEGSR
C EXCPT ERRBUF
C GETOPT TAG
C READ TERMIN H0
C OPTION IFEQ "1"
C SETON LR
C ELSE
C OPTION IFEQ "2"
C EXCPT ERRCON
C ELSE
C EXCPT BADOPT
C GOTO GETOPT
C END
C END
C*
C ENDSR
Defining Output.
****************************************************************
* OUTPUT RECORD LAYOUTS *
****************************************************************
O*--------------------------------------------------------------
O* Display message for entry of invalid option.
O*
OTERMOUT E 1 BADOPT
O 23 "Invalid option - please"
O 33 " re-enter."
O*--------------------------------------------------------------
O* Send 'Home' (Escape h) and 'Clear' (Escape J) to screen.
O*
O E 1 CLEAR
O ESC 1
O 2 "h"
O ESC 3
O 4 "J"
O*--------------------------------------------------------------
O* Display message for IMAGE End-Of-Chain condition.
O*
O E 31 EOC
O 21 "-----> End of Chain, "
O 42 "Hit Enter to Continue"
O*--------------------------------------------------------------
O* Display error message.
O*
O E 1 ERRBUF
O 23 "-----------------------"
O 30 "-------"
O E 1 ERRBUF
O 11 "IMAGE ERROR"
O STAT,1 21 " *"
O 35 " HAS OCCURRED."
O E 2 ERRBUF
O 23 "-----------------------"
O 30 "-------"
O E 1 ERRBUF
O 23 "---Enter, <1> to Abort."
O 43 ".., <2> TO Continue"
O*--------------------------------------------------------------
O* Display message for continuing execution after error.
O*
O E 1 ERRCON
O 15 "Continuing....."
O*--------------------------------------------------------------
O* Display prompt for input of DATE.
O*
O E 1 GETDAT
O 23 "Enter The DATE of Purch"
O 38 "ase as (YYMMDD)"
O*--------------------------------------------------------------
O* Display Line Header (dashes).
O*
O E 1 LINHDR
O 23 "-----------------------"
O *PLACE 46
O *PLACE 69
O 76 "-------"
O*--------------------------------------------------------------
O* Display message that no IMAGE chain head was found.
O*
O E 1 NOHEAD
O 23 "***********************"
O 39 "****************"
O E 1 NOHEAD
O 23 "* No Such Entry in the "
O 39 "Sales Dataset *"
O E 1 NOHEAD
O 23 "* Please Try Again. "
O 39 " *"
O E 1 NOHEAD
O 23 "***********************"
O 39 "****************"
O E 1 NOHEAD
O 23 "Press Enter To Continue"
O*--------------------------------------------------------------
O* Display Header line for listing of Sales records.
O*
O E 1 SALHDR
O 13 "Acct-Number "
O 28 "Stock-Number "
O 33 "QTY "
O 40 "Price "
O 46 "Tax "
O 53 "Total "
O 66 "Purch-Date "
O 79 "Deliv-Date "
O*--------------------------------------------------------------
O* Display Sales record line.
O*
O E 1 SALREC
O ACCT# 10 " 0 "
O STOCK# 25
O QTY 31 " 0 "
O $PRICE 38 " 0 "
O $TAX 43 " 0 "
O $TOTAL 51 " 0 "
O PDATE Y 62
O DDATE Y 75
** Following record contains Escape character (ASCII 27) in column 1
<--- ASCII 27