HP 3000 Manuals HP 3000 Manuals
Pascal Example Program
$standard_level 'HP3000'$
(*******************************************************************)
(* *)
(* This Pascal program gives examples of calling System Dictionary *)
(* intrinsics. The examples in this program include: *)
(* *)
(* Procedure Example *)
(* ----------------- ------------------------------------------ *)
(* OpenDictionary Shows how to open a System Dictionary *)
(* *)
(* CloseDictionary Shows how to close a System Dictionary *)
(* *)
(* FindElements Shows how to find relationships, when *)
(* only one of the entities is known, using *)
(* the SDFindRelList intrinsic. *)
(* *)
(* FindByNumber The same example as FindElements, but *)
(* using internal numbers *)
(* *)
(* CreateElement Shows how to create an entity occurrence *)
(* using both internal and external names *)
(* *)
(* LinkElement Shows how to link a local domain entity *)
(* to a common domain entity *)
(* *)
(* RemoveRelationshipLink Shows how to remove a link between a *)
(* local domain relationship and a common *)
(* domain relationship *)
(* *)
(*******************************************************************)
program PascalExample(input, output);
const
EndOfListStatus = 24;
GoodStatus = 0;
type
DcbType = array[1 .. 30] of integer;
NameType = packed array[1 .. 32] of char;
NewNameType = array[1 .. 2] of NameType;
RetrievalIDType = array[1 .. 20] of integer;
StatusType = array[1 .. 7] of integer;
var
Dcb : DcbType;
$page$
procedure SDCreateEnt; intrinsic;
procedure SDFindRelList; intrinsic;
procedure SDGetAttr; intrinsic;
procedure SDGetEnt; intrinsic;
procedure SDGetEntType; intrinsic;
procedure SDModifyEnt; intrinsic;
procedure SDModifyRel; intrinsic;
procedure SDOpen; intrinsic;
procedure SDClose; intrinsic;
$page$
(*******************************************************************)
(* *)
(* procedure FindElement *)
(* *)
(* This procedure finds all elements related to the record *)
(* ACCOUNTS-RECORD. It uses the intrinsic SDFindRelList to search *)
(* for the elements. The procedure then calls SDGetEnt to retrieve*)
(* the COUNT, ELEMENT-TYPE, and BYTE-LENGTH attributes of the *)
(* element. *)
(* *)
(*******************************************************************)
procedure FindElements;
type
ElementAttributesType = record
Count : integer;
ByteLength : integer;
ElementType : packed array[1 .. 2] of char;
end;
var
AttributeList : packed array[1 .. 31] of char;
CommonEntity : NameType;
ElementAttributes : ElementAttributesType;
EntityList : array[1 .. 3] of NameType;
EntitySearchList : packed array[1 .. 18] of char;
EntityType : NameType;
RelationshipClass : NameType;
RelationshipType : packed array[1 .. 15] of char;
RetrievalID : RetrievalIDType;
Status : StatusType;
begin
writeln;
writeln('*** Elements related to ACCOUNTS-RECORD ***');
writeln;
writeln('Element Count Type Length');
writeln;
RelationshipType := 'RECORD ELEMENT;';
RelationshipClass := 'CONTAINS ';
EntitySearchList := 'ACCOUNTS-RECORD ?;';
RetrievalID[1] := 0;
EntityType := 'ELEMENT ';
AttributeList := 'COUNT BYTE-LENGTH ELEMENT-TYPE;';
repeat
SDFindRelList(Dcb, RelationshipType, RelationshipClass, EntitySearchList,
RetrievalID, EntityList, Status);
if (Status[1] = GoodStatus) then
begin
SDGetEnt(Dcb, EntityType, EntityList[2], AttributeList,
ElementAttributes, CommonEntity, Status);
if (Status[1] <> GoodStatus) then
begin
writeln('System Dictionary Error #', Status[1]);
end;
with ElementAttributes do
writeln(EntityList[2], Count:5, ' ', ElementType, ' ',
ByteLength:5);
end;
until Status[1] <> GoodStatus;
end;
$page$
(*******************************************************************)
(* *)
(* procedure OpenDictionary *)
(* *)
(* This procedure opens the System Dictionary SYSDIC.PUB.SYS with *)
(* the PROGRAMMER scope, local domain D, and test version. *)
(* *)
(*******************************************************************)
procedure OpenDictionary;
var
Dictionary : packed array[1 .. 26] of char;
Scope : NameType;
Password : NameType;
Domain : NameType;
Version : NameType;
Status : StatusType;
begin
Dictionary := 'SYSDIC.PUB.SYS ';
Scope := 'PROGRAMMER ';
Password := 'SECRET ';
Domain := 'D ';
Version := ' ';
SDOpen(Dictionary, Scope, Password, 3, 2, Domain, Version, 1, Dcb, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
end;
$page$
(*******************************************************************)
(* *)
(* procedure CloseDictionary *)
(* *)
(* This procedure closes the System Dictionary. *)
(* *)
(*******************************************************************)
procedure CloseDictionary;
var
Status : StatusType;
begin
SDClose(Dcb, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
end;
$page$
(*******************************************************************)
(* *)
(* procedure FindByNumber *)
(* *)
(* This procedure finds all elements related to the ACCOUNTS-RECORD*)
(* record. It does this by calling the intrinsic SDFindRelList. *)
(* It is similar to the previous example, FindElement procedure, *)
(* except internal numbers are used whenever possible. *)
(* *)
(* The use of internal numbers will improve the performance of *)
(* System Dictionary intrinsic calls. *)
(* *)
(*******************************************************************)
procedure FindByNumber;
type
ElementAttributesType = record
Count : integer;
ByteLength : integer;
ElementType : packed array[1 .. 2] of char;
end;
var
Attribute : NameType;
AttributeEdits : packed array[1 .. 255] of char;
AttributeNumberList: array[1 .. 4] of integer;
AttributeParms : array[1 .. 2] of integer;
CommonEntity : NameType;
EditsLength : Integer;
ElementAttributes : ElementAttributesType;
EntityList : array[1 .. 3] of NameType;
EntityNumber : array[1 .. 2] of integer;
EntitySearchList : packed array[1 .. 18] of char;
EntityType : NameType;
EntityTypeNumber : array[1 .. 2] of integer;
OwnerScope : NameType;
RelationshipClass : NameType;
RelationshipType : packed array[1 .. 15] of char;
RetrievalID : RetrievalIDType;
Status : StatusType;
begin
writeln;
writeln('*** Elements related to ACCOUNTS-RECORD ***');
writeln;
writeln('Element Count Type Length');
writeln;
RelationshipType := 'RECORD ELEMENT;';
RelationshipClass := 'CONTAINS ';
EntitySearchList := 'ACCOUNTS-RECORD ?;';
RetrievalID[1] := 0;
EntityType := 'ELEMENT ';
SDGetEntType(Dcb, EntityType, OwnerScope, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
EntityTypeNumber[1] := 1;
EntityTypeNumber[2] := Status[5];
AttributeNumberList[1] := 3;
Attribute := 'COUNT ';
SDGetAttr(Dcb, Attribute, AttributeParms, AttributeEdits, EditsLength,
OwnerScope, Status);
AttributeNumberList[2] := Status[5];
Attribute := 'BYTE-LENGTH ';
SDGetAttr(Dcb, Attribute, AttributeParms, AttributeEdits, EditsLength,
OwnerScope, Status);
AttributeNumberList[3] := Status[5];
Attribute := 'ELEMENT-TYPE ';
SDGetAttr(Dcb, Attribute, AttributeParms, AttributeEdits, EditsLength,
OwnerScope, Status);
AttributeNumberList[4] := Status[5];
repeat
SDFindRelList(Dcb, RelationshipType, RelationshipClass, EntitySearchList,
RetrievalID, EntityList, Status);
if (Status[1] = GoodStatus) then
begin
EntityNumber[1] := 1;
EntityNumber[2] := Status[6];
SDGetEnt(Dcb, EntityTypeNumber, EntityNumber, AttributeNumberList,
ElementAttributes, CommonEntity, Status);
if (Status[1] <> GoodStatus) then
begin
writeln('System Dictionary Error #', Status[1]);
end;
with ElementAttributes do
writeln(EntityList[2], Count:5, ' ', ElementType, ' ',
ByteLength:5);
end;
until Status[1] <> GoodStatus;
end;
$page$
(*******************************************************************)
(* *)
(* procedure CreateElement *)
(* *)
(* This procedure creates an entity occurrence by calling the *)
(* intrinsic SDCreateEnt. The entity being created has both an *)
(* internal and external name specified. *)
(* *)
(*******************************************************************)
procedure CreateElement;
type
ElementAttributesType = record
Count : integer;
ByteLength : integer;
ElementType : packed array[1 .. 2] of char;
end;
var
AttributeList : packed array[1 .. 31] of char;
CommonEntity : NameType;
ElementAttributes : ElementAttributesType;
EntityType : NameType;
Entity : NewNameType;
Status : StatusType;
begin
EntityType := 'ELEMENT ';
Entity[1] := 'DATE ';
Entity[2] := 'DELIVERY-DATE ';
AttributeList := 'COUNT BYTE-LENGTH ELEMENT-TYPE ;';
with ElementAttributes do
begin
Count := 1;
ByteLength := 6;
ElementType := 'X ';
end;
CommonEntity := ' ';
SDCreateEnt(Dcb, EntityType, Entity, AttributeList, ElementAttributes,
CommonEntity, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
end;
$page$
(*******************************************************************)
(* *)
(* procedure LinkEntity *)
(* *)
(* This procedure links a local domain entity to a common domain *)
(* entity. The procedure calls SDModifyEnt to link the entities. *)
(* Note that the existing attribute values are removed, and the *)
(* attribute values will now be retrieved from the common entity. *)
(* *)
(*******************************************************************)
procedure LinkEntity;
type
ElementAttributesType = record
Count : integer;
ByteLength : integer;
ElementType: packed array[1 .. 2] of char;
end;
var
AttributeList : packed array[1 .. 4] of char;
CommonEntity : NameType;
ElementAttributes : ElementAttributesType;
EntityType : NameType;
Entity : NameType;
NewEntityName : NameType;
Status : StatusType;
begin
EntityType := 'ELEMENT ';
Entity:= 'P-NUM ';
NewEntityName := ' ';
AttributeList := '; ';
CommonEntity := 'PART-NUMBER ';
SDModifyEnt(Dcb, EntityType, Entity, NewEntityName,
AttributeList, ElementAttributes, CommonEntity, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
end;
$page$
(*******************************************************************)
(* *)
(* procedure RemoveRelationshipLink *)
(* *)
(* This procedure removes the link between a relationship in a *)
(* local domain and a relationship in the common domain. The *)
(* procedure calls SDModifyRel to remove the link; the parameter *)
(* CommonEntityList is set to '/;' to instruct SDModifyRel to *)
(* remove the link. If a user does not want to remove the link, *)
(* then the parameter CommonEntityList should be set to a'; '. *)
(* *)
(*******************************************************************)
procedure RemoveRelationshipLink;
var
AttributeList : packed array[1 .. 4] of char;
AttributeValues : integer;
CommonEntityList : packed array[1 .. 2] of char;
EntityList : packed array[1 .. 31] of char;
RelationshipClass : NameType;
RelationshipType : packed array[1 .. 15] of char;
Status : StatusType;
begin
RelationshipType := 'RECORD ELEMENT;';
RelationshipClass := 'CONTAINS ';
EntityList := 'ACCOUNTS-RECORD ACCOUNT-NUMBER;';
AttributeList := '; ';
CommonEntityList := '/;';
SDModifyRel(Dcb, RelationshipType, RelationshipClass, EntityList,
AttributeList, AttributeValues, CommonEntityList, Status);
if Status[1] <> 0 then
begin
writeln('System Dictionary Error #', Status[1]);
end;
end;
$page$
(*******************************************************************)
(* *)
(* Outer block of Pascal Example program *)
(* *)
(*******************************************************************)
begin
OpenDictionary;
FindElements;
FindByNumber;
CreateElement;
LinkEntity;
RemoveRelationshipLink;
CloseDictionary;
end.