tldm-universe/Ardent/UV/APP.PROGS/DO.MNU.BAR.B

359 lines
9.8 KiB
Plaintext
Raw Normal View History

2024-09-09 21:51:08 +00:00
*******************************************************************************
*
* New System Admin - This routine, given the data structure for a menu
* bar, will allow the user to activate it, and select items from
* it.
*
* Module %M% Version %I% Date %H%
*
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
* This is unpublished proprietary source code of Ardent Software Inc.
* The copyright notice above does not evidence any actual or intended
* publication of such source code.
*
*******************************************************************************
*
* Maintenence log - insert most recent change descriptions at top
*
* Date.... GTAR# WHO Description.........................................
* 10/14/98 23801 SAP Change copyrights.
* 05/20/96 18330 LDG Changed LEN() function to LENDP() for NLS DBCS.
* 05/13/91 8345 DTM changed print to tprint
* 03/14/91 7673 DTM Changed a few flow statements
* 11/05/90 7393 DPB Routine first created and admin'd.
*******************************************************************************
SUBROUTINE DO.MNU.BAR.B(menu.bar, action.code,form.size,form,temp.form)
$INCLUDE UNIVERSE.INCLUDE MTF.INCL.H
EQU TKC TO 6 ;* Top Key Count = # of keys used for top level menu.
EQU SKC TO 9 ;* Sub Key Count = # of keys used in submenu.
DIM top.alpha(TKC)
DIM top.codes(TKC)
DIM sub.alpha(SKC)
DIM sub.codes(SKC)
input.code = ""
mnemos = ""
left.over = ""
GOSUB init
TTYGET tty$ ELSE NULL
tmptty=tty$
CRMODE.ICRNL=0
CRMODE.ONLCR=0
TTYSET tty$ ELSE NULL
label1:
GOSUB hilight.item
label2:
CALL *GET.TOKEN.B(25, 25, 75, TKC, mat top.alpha, mat top.codes, ESC.KEY, MNEMONIC, 0, num.items, M.MNEMOS, left.over,input.code, mnemos)
label3:
BEGIN CASE
CASE input.code = ESCAPE
action.code = -1
GOSUB unlight.item
GOTO end.stuff
RETURN
CASE input.code = RIGHT.ARROW
GOSUB unlight.item
item.no += 1
IF item.no > num.items THEN
item.no = 1
END
GOTO label1
CASE input.code = LEFT.ARROW
GOSUB unlight.item
item.no -= 1
IF item.no < 1 THEN
item.no = num.items
END
GOTO label1
CASE input.code = SEL.ACTION
GOTO sub.menu
GOTO label1
CASE input.code = MNEMONIC
GOSUB unlight.item
item.no = mnemos
GOSUB hilight.item
input.code = SEL.ACTION
GOTO sub.menu
CASE input.code = F.1
IF menu.bar<item.no+1,1,3> # "" THEN
CALL *HELP.BOX.B(5,0,0,menu.bar<item.no+1,1,3>)
GOSUB update.screen
END
GOTO label2
CASE 1
GOTO label2
END CASE
RETURN
sub.menu:
GOSUB init.submenu
GOSUB draw.sub.menu
label5:
GOSUB hi.sub.menu
label6:
CALL *GET.TOKEN.B(25, 25, 75, SKC, mat sub.alpha, mat sub.codes, SUB.ESC.KEY, MNEMONIC, 0, sub.menu.num, sub.mnemos, left.over, input.code, mnemos)
label7:
BEGIN CASE
CASE input.code = ESCAPE
GOSUB clear.sub.menu
GOSUB unlight.item
action.code = -1
GOTO end.stuff
CASE input.code = SEL.ACTION
GOSUB clear.sub.menu
GOSUB unlight.item
action.code = menu.bar<item.no+1, sub.menu.no+1,2>
GOTO end.stuff
CASE input.code = MNEMONIC
GOSUB clear.sub.menu
GOSUB unlight.item
action.code = menu.bar<item.no+1, sub.menu.no+mnemos,2>
GOTO end.stuff
CASE input.code = F.1
IF menu.bar<item.no+1,sub.menu.no+1,3> # "" THEN
CALL *HELP.BOX.B(5,0,0,menu.bar<item.no+1,sub.menu.no+1,3>)
GOSUB update.screen
GOSUB draw.sub.menu
END
GOTO label5
CASE input.code = F.10
GOSUB clear.sub.menu
GOSUB update.screen
GOTO label2
CASE input.code = RIGHT.ARROW
GOSUB clear.sub.menu
GOSUB unlight.item
item.no += 1
IF item.no > num.items THEN
item.no = 1
END
GOSUB update.screen
GOSUB hilight.item
GOTO sub.menu
CASE input.code = LEFT.ARROW
GOSUB clear.sub.menu
GOSUB unlight.item
item.no -= 1
IF item.no < 1 THEN
item.no = num.items
END
GOSUB update.screen
GOSUB hilight.item
GOTO sub.menu
CASE input.code = UP.ARROW
GOSUB un.sub.menu
sub.menu.no -= 1
IF sub.menu.no < 1 THEN
sub.menu.no = sub.menu.num
END
GOTO label5
CASE input.code = DOWN.ARROW
GOSUB un.sub.menu
sub.menu.no += 1
IF sub.menu.no > sub.menu.num THEN
sub.menu.no = 1
END
GOTO label5
CASE 1
GOTO label6
END CASE
RETURN
init.submenu:
sub.menu.num = menu.bar<item.no+1,1,2> ;* # of items in submenu
sub.menu.no = 1 ;* Current item
sub.menu.width = 0
sub.mnemos = ""
FOR I = 1 to sub.menu.num
sub.mnemos<I>=menu.bar<item.no+1,sub.menu.no+I,1>[1,1]
FOR J = 1 to LEN(menu.bar<item.no+1,sub.menu.no+I,1>)
IF SEQ(menu.bar<item.no+1,sub.menu.no+I,1>[J,1]) >= 65 AND SEQ(menu.bar<item.no+1,sub.menu.no+I,1>[J,1]) <= 90 THEN
sub.mnemos<I>=menu.bar<item.no+1,sub.menu.no+I,1>[J,1]
END
NEXT J
IF LENDP(menu.bar<item.no+1,sub.menu.no + I,1>) > sub.menu.width THEN
sub.menu.width = LENDP(menu.bar<item.no+1,sub.menu.no+I,1>)
END
NEXT I
sub.menu.width += 4
sub.menu.col = ((item.no*offset)-int(sub.menu.width/2))
sub.menu.line = lineno+2
RETURN
draw.sub.menu:
CALL *DRAW.BOX.B(lineno+2, sub.menu.col-1, sub.menu.num, sub.menu.width,1)
FOR I = 1 TO sub.menu.num
TPRINT @(sub.menu.col+2,sub.menu.line+I):menu.bar<item.no+1,I+1,1>:
NEXT I
RETURN
clear.sub.menu:
CALL *DRAW.BOX.B(lineno+2, sub.menu.col-1, sub.menu.num, sub.menu.width,0)
RETURN
hi.sub.menu:
TPRINT @(sub.menu.col+sub.menu.width-1,sub.menu.line+sub.menu.no):
CALL *INVERSE.B(0)
TPRINT @(sub.menu.col,sub.menu.line+sub.menu.no):
CALL *INVERSE.B(1)
TPRINT " ":menu.bar<item.no+1,sub.menu.no+1,1>:STR(" ",sub.menu.width-(LENDP(menu.bar<item.no+1,sub.menu.no+1,1>)+3)):
CALL *INVERSE.B(0)
RETURN
un.sub.menu:
TPRINT @(sub.menu.col+sub.menu.width-1,sub.menu.line+sub.menu.no):
CALL *INVERSE.B(0)
TPRINT @(sub.menu.col,sub.menu.line+sub.menu.no):
CALL *INVERSE.B(0)
TPRINT " ":menu.bar<item.no+1,sub.menu.no+1,1>:STR(" ",sub.menu.width-(LENDP(menu.bar<item.no+1,sub.menu.no+1,1>)+3)):
CALL *INVERSE.B(0)
RETURN
hilight.item:
tprint @(((item.no*offset)-int(LENDP(menu.bar<item.no+1,1,1>)/2)-2)+3+LENDP(menu.bar<item.no+1,1,1>),lineno):
CALL *INVERSE.B(0)
tprint @((item.no*offset)-int(LENDP(menu.bar<item.no+1,1,1>)/2)-2,lineno):
CALL *INVERSE.B(1)
tprint " ":menu.bar<item.no+1,1,1>:" ":
CALL *INVERSE.B(0)
RETURN
unlight.item:
tprint @((item.no*offset)-int(LENDP(menu.bar<item.no+1,1,1>)/2)-2,lineno):
tprint " ":menu.bar<item.no+1,1,1>:" ":
CALL *INVERSE.B(0)
RETURN
init:
num.items = menu.bar<1,1>
offset = int(80/(num.items+1))
lineno= menu.bar<1,2>
item.no = action.code
IF item.no > num.items THEN item.no = 1
GOSUB init.top.menu
RETURN
init.top.menu:
OPEN "","INCLUDE" TO alt.key.file ELSE GOTO end.loop
alt.record=""
READ alt.record FROM alt.key.file,"ALT.MTF.KEYS" ELSE GOTO end.loop
alt.rec.count=COUNT(alt.record,@FM)+1
FOR i=1 TO alt.rec.count STEP 2
BEGIN CASE
CASE alt.record<i>="ALT.RT.ARROW"
KEY.MOVE.CURSOR.RIGHT=alt.record<i+1>
CASE alt.record<i>="ALT.LT.ARROW"
KEY.MOVE.CURSOR.LEFT=alt.record<i+1>
CASE alt.record<i>="ALT.UP.ARROW"
KEY.MOVE.CURSOR.UP=alt.record<i+1>
CASE alt.record<i>="ALT.DN.ARROW"
KEY.MOVE.CURSOR.DOWN=alt.record<i+1>
CASE alt.record<i>="ALT.F.1"
KEY.FUNCTION.1=alt.record<i+1>
CASE alt.record<i>="ALT.F.10"
KEY.FUNCTION.10=alt.record<i+1>
END CASE
NEXT i
CLOSE alt.record
end.loop:
top.alpha(1) = KEY.MOVE.CURSOR.RIGHT
top.alpha(2) = KEY.MOVE.CURSOR.LEFT
top.alpha(3) = " "
top.alpha(4) = CHAR(27)
top.alpha(5) = CARRIAGE.RETURN
top.alpha(6) = KEY.FUNCTION.1
top.codes(1) = RIGHT.ARROW
top.codes(2) = LEFT.ARROW
top.codes(3) = SEL.ACTION
top.codes(4) = ESCAPE
top.codes(5) = SEL.ACTION
top.codes(6) = F.1
CALL *TOKEN.SORT.B(TKC, mat top.alpha, mat top.codes)
ESC.KEY = 0
FOR I = 1 TO TKC
IF top.codes(I) = ESCAPE then ESC.KEY = I
NEXT I
M.MNEMOS = ""
FOR I = 1 TO menu.bar<1,1>
M.MNEMOS<I> = menu.bar<I+1,1,1>[1,1]
NEXT I
sub.alpha(1) = KEY.MOVE.CURSOR.RIGHT
sub.alpha(2) = KEY.MOVE.CURSOR.LEFT
sub.alpha(3) = KEY.MOVE.CURSOR.UP
sub.alpha(4) = KEY.MOVE.CURSOR.DOWN
sub.alpha(5) = " "
sub.alpha(6) = CHAR(27)
sub.alpha(7) = KEY.FUNCTION.1
sub.alpha(8) = KEY.FUNCTION.10
sub.alpha(9) = CARRIAGE.RETURN
sub.codes(1) = RIGHT.ARROW
sub.codes(2) = LEFT.ARROW
sub.codes(3) = UP.ARROW
sub.codes(4) = DOWN.ARROW
sub.codes(5) = SEL.ACTION
sub.codes(6) = ESCAPE
sub.codes(7) = F.1
sub.codes(8) = F.10
sub.codes(9) = SEL.ACTION
CALL *TOKEN.SORT.B(SKC, mat sub.alpha, mat sub.codes)
SUB.ESC.KEY = 0
FOR I = 1 TO SKC
IF sub.codes(I) = ESCAPE then SUB.ESC.KEY = I
NEXT I
RETURN
update.screen:
IF form.size # 0 THEN
CALL *PUT.FORM.B(form.size,form,temp.form,PRMPT,1)
END
RETURN
end.stuff:
TTYGET tty$ ELSE NULL
tty$=tmptty
TTYSET tty$ ELSE NULL
RETURN
END