The program below uses the Repository subroutine library to display a selection window. Program 2 illustrates how to traverse fields and groups in a structure.
Program 1
; This program displays a selection window containing a list of all
; structures in a repository. From that window, the user can then select
; a structure and a second selection window displays, containing a list
; of all fields in that structure.
; Script for Repository information subroutine demo
.column c_select , "Select"
.entry o_exit, "Exit", key(f4)
.entry o_nxtpg, "Next page", key(next)
.entry o_prvpg, "Previous page", key(prev)
.entry s_up, "Move up", key(up)
.entry s_down, "Move down", key(down)
.end
; dddemo.dbl - Demo Repository information subroutines
.include "RPSLIB:ddinfo.def" ;.defines and data structures
.include "WND:tools.def"
.include "WND:windows.def"
.define SELWND_SIZE ,10 ;# rows in selection window
.define MAX_PAGE ,98 ;Max pages in selection window
record
struct ,a30 ;A structure name
structs ,SELWND_SIZE a30 ;Structure names
sinfo ,SELWND_SIZE a62 ;Selection window items
st_base ,MAX_PAGE a30 ;Base struct for selection page
field ,a30 ;A field name
fields ,SELWND_SIZE a30 ;Field names
finfo ,SELWND_SIZE a49 ;Selection window items
fld_base ,MAX_PAGE a30 ;Base field for selection page
colid ,i4 ;Selection window column ID
st_id ,i4 ;Structure selection window ID
fld_id ,i4 ;Field selection window id
;Selection window titles
nmstrcts ,d5 ;Number of structures
nmflds ,d5 ;Number of fields
ret ,d2 ;Number of items retrieved
sx ,d3 ;Structure index
fx ,d3 ;Field index
record st_title
,a*,' Structures - Page '
st_page ,d2
,a*,' of '
st_last ,d2
record st_info
st_name ,a30 ;Structure name
,a4
st_filtyp ,a15 ;File type
,a3
st_desc ,a10 ;First 10 chars of short description
record fld_title
,a*,' Fields in '
fld_sname ,a30
,a*,' - Page '
fld_page ,d2
,a*,' of '
fld_last ,d2
record fld_info
fld_name ,a30 ;Field name
,a2
fld_type ,a1 ;Field type
fld_size ,a4 ;Field size
,a2
fld_desc ,a10 ;First 10 chars of short description
proc
xcall u_start("dddemo") ;Start UI Toolkit
xcall m_ldcol(colid, g_utlib, "c_select")
;Load selection column
xcall dd_init(dcs) ;Start repository routines
if (error) ;Check error state in dcs
call error
;Get count of structures
xcall dd_name(dcs, DDN_COUNT, DDN_STRUCT, nmstrcts)
if (error)
call error
st_page = 1 ;Start at the beginning (novel)
st_last = nmstrcts/SELWND_SIZE ;Compute last page
if (st_last*SELWND_SIZE .lt. nmstrcts)
incr st_last
call load_structs ;Load a selection page
do
call process_structs ;Process selection window
until (g_select) ;Unsatisfied menu entry = Exit
xcall dd_exit(dcs) ;Shut down repository routines
xcall u_finish ;Shut down UI Toolkit
stop
;
; Description: Load the selection window for structures
;
load_structs,
;Get a page full of names
xcall dd_name(dcs, DDN_LIST, DDN_STRUCT, SELWND_SIZE,
& structs, st_base(st_page), ret)
if (error) ;Check error state
call error
for sx from 1 thru ret ;Get info about each structure
begin
st_name = structs(sx)
xcall dd_struct(dcs, DDS_INFO, st_name, s_info)
if (error)
call error
st_filtyp = si_filtyp ;Load the file type
if (si_desc) then ;Is there a short description?
begin
xcall dd_struct(dcs, DDS_TEXT, si_desc, st_desc)
if (error)
call error
end
else ;No short description,
if (si_ldesc) then ;Is there a long description?
begin
xcall dd_struct(dcs, DDS_TEXT, si_ldesc, st_desc)
if (error)
call error
end
else ;No short or long description,
clear st_desc ; clear it
sinfo(sx) = st_info ;Load array for the selection wnd
end
sx = 1 ;Start with the first one
if (st_id)
xcall u_window (D_DELETE, st_id) ;Delete any previous
; version and build the window
xcall s_selbld(st_id, "STRUCTS", ret, ret, sinfo)
;Put the title on it
xcall w_brdr(st_id, WB_TITLE, st_title, WB_TPOS, WBT_TOP,
& WBT_CENTER)
xcall u_logwnd(st_id) ;Log it with UI Toolkit
xcall u_window(D_PLACE, st_id, 3, 10) ;Place it at 3,10
return
;
; Description: Process the structure selection window
;
process_structs,
xcall s_select(st_id, sx, struct,, sx);Let user select one
if (g_select) then ;If user chose a menu entry
begin
case g_entnam of
begincase
'O_EXIT ':
return ;Exit
'O_NXTPG ':
call next_struct_page ;Load next page
'O_PRVPG ':
call prev_struct_page ;Load previous page
endcase
end ;Note that any other menu entry
; returns as well
else
begin ;Select the structure
xcall dd_struct(dcs, DDS_INFO, struct, s_info)
if (error)
call error
nmflds = si_nmflds ;Load number of fields
fld_page = 1 ;Start at the first page
clear fld_base(1)
fld_last = nmflds/SELWND_SIZE ;Compute last page
if (fld_last*SELWND_SIZE .lt. nmflds)
incr fld_last
fld_sname = struct ;Load structure name in title
call load_fields ;Load a selection window page
do
call process_fields ;Process selection window
until (g_select) ;Until unsatisfied menu entry
if (g_entnam .eq. "O_EXIT ") ;Exit only one level
clear g_select
xcall u_window(D_DELETE, fld_id) ;Delete fields window
end
return
;
; Description: Go to the next page of structures
;
next_struct_page,
if (st_page .ge. st_last) then ;Check for overflow
call ding
else
begin
incr st_page
st_base(st_page) = structs(SELWND_SIZE ;Start w/ last
; structure on prev page
call load_structs ;Load the window
end
clear g_select ;Menu entry satisfied
return
;
; Description: Go to the previous page of structures
;
prev_struct_page,
if (st_page .le. 1) then ;Avoid underflow
call ding
else
begin
decr st_page
call load_structs ;Load the window
end
clear g_select ;Menu entry satisfied
return
;
; Description: Load a page of fields into a selection window
;
load_fields,
;Load a page of field names
xcall dd_field(dcs, DDF_LIST, SELWND_SIZE, fields,
& fld_base(fld_page), ret)
if (error)
call error
for fx from 1 thru ret ;For each field loaded
begin
fld_name = fields(fx) ;Get field information
xcall dd_field(dcs, DDF_INFO, fld_name, f_info)
if (error)
call error
fld_type = fi_type
fld_size = fi_size [left]
if (fi_desc) then ;Is there a short description?
begin
xcall dd_field(dcs, DDF_TEXT, fi_desc, fld_desc)
if (error)
call error
end
else if (fi_ldesc) then ;No, is there a long description?
begin
xcall dd_field(dcs, DDF_TEXT, fi_ldesc, fld_desc)
if (error)
call error
end
else
clear fld_desc
finfo(fx) = fld_info ;Load selection window array
end
fx = 1 ;So we start with the first one
if (fld_id)
xcall u_window (D_DELETE, fld_id) ;Delete any prev version
;and build the window
xcall s_selbld(fld_id, "FIELDS", ret, ret, finfo)
;Put the title on it
xcall w_brdr(fld_id, WB_TITLE, fld_title, WB_TPOS, WBT_TOP,
& WBT_CENTER)
xcall u_logwnd(fld_id) ;Log it with UI Toolkit
xcall u_window(D_PLACE, fld_id, 5, 20) ;Place it at 5,20
return
;
; Description: Process the field selection window
;
process_fields,
xcall s_select(fld_id, fx, field,, fx) ;Let user select one
if (g_select) then ;If user chose a menu entry
begin
case g_entnam of
begincase
'O_EXIT ':
return ;Exit
'O_NXTPG ':
call next_field_page ;Load next page
'O_PRVPG ':
call prev_field_page ;Load previous page
endcase
end ;Note that any other menu entry
; returns also
else
begin ;Select the structure
xcall dd_field(dcs, DDF_INFO, field, f_info)
if (error)
call error
end
return
;
; Description: Go to the next page of fields
;
next_field_page,
if (fld_page .ge. fld_last) then ;Check for overflow
call ding
else
begin
incr fld_page
fld_base(fld_page) = fields(SELWND_SIZE)
call load_fields ;Load the window
end
clear g_select ;Menu entry satisfied
return
;
; Description: Go to the previous page of fields
;
prev_field_page,
if (fld_page .le. 1) then ;Avoid underflow
call ding
else
begin
decr fld_page
call load_fields ;Load the window
end
clear g_select ;Menu entry satisfied
return
;
; Description: Abort on a repository access error. This
; routine is called to provide a full traceback of where
; the error occurred.
;
error,
xcall u_abort("Error in Repository info routines", %a(error))
;
; Description: Ring the terminal bell
;
ding,
display (g_terminal, 7)
return
.end
; This program traverses all fields and groups in a structure. It assumes
; all groups are explicit groups.
;
.include "RPSLIB:ddinfo.def"
.define MAX_FLDS ,99
.define MAX_LVLS ,10
.define PUTOUT(msg) writes(chan, (msg))
.define ERROUT(msg) PUTOUT("Error # " + %string(error) + " " + (msg))
common
chan ,i4
proc
xcall u_start
xcall u_open(chan, "o:s", "TST:output.txt")
xcall dd_init(dcs, "TST:testmain.ism", "TST:testtext.ism")
if (error)
begin
xcall u_message("Cannot open repository file due to error " +
& %string(error))
xcall u_finish
stop
end
xcall dd_struct(dcs, DDS_INFO, "COMPANY", s_info)
if (error) then
ERROUT("Cannot load COMPANY")
else
PUTOUT("Structure COMPANY")
; Traverse the structure
xcall check_level(dcs)
xcall u_close(chan)
xcall u_finish
stop
.end
subroutine check_level, reentrant, stack
a_dcs ,a
.include "RPSLIB:ddinfo.def"
common
chan ,i4
record clear_a
ix ,d4 ;Loop index
num_fields ,d3 ;Number of fields returned
field_names ,MAX_FLDS a30 ;Array of field names
name ,a30 ;Current name for optimization
static record
level ,i4 ;Group level (1 = main structure)
proc
clear clear_a
dcs = a_dcs
incr level
xcall dd_field(dcs, DDF_SLIST, MAX_FLDS, field_names(1),, num_fields)
if (error)
ERROUT("Cannot load level " + %string(level))
for ix from 1 thru num_fields
begin
name = field_names(ix)
xcall dd_field(dcs, DDF_INFO, name, f_info)
if (fi_group) then
begin
PUTOUT("Group " + (name))
xcall dd_field(dcs, DDF_GROUP, name)
xcall check_level(dcs) ;Recurse to its members
xcall dd_field(dcs, DDF_ENDGROUP)
PUTOUT("Endgroup")
end
else
PUTOUT("Field " + (name))
end
decr level
a_dcs = dcs
xreturn
endsubroutine
