1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Menus --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2009,2011 Free Software Foundation, Inc. --
12 -- Permission is hereby granted, free of charge, to any person obtaining a --
13 -- copy of this software and associated documentation files (the --
14 -- "Software"), to deal in the Software without restriction, including --
15 -- without limitation the rights to use, copy, modify, merge, publish, --
16 -- distribute, distribute with modifications, sublicense, and/or sell --
17 -- copies of the Software, and to permit persons to whom the Software is --
18 -- furnished to do so, subject to the following conditions: --
20 -- The above copyright notice and this permission notice shall be included --
21 -- in all copies or substantial portions of the Software. --
23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
31 -- Except as contained in this notice, the name(s) of the above copyright --
32 -- holders shall not be used in advertising or otherwise to promote the --
33 -- sale, use or other dealings in this Software without prior written --
35 ------------------------------------------------------------------------------
36 -- Author: Juergen Pfeifer, 1996
39 -- $Date: 2011/03/22 23:38:12 $
40 -- Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with Ada
.Unchecked_Deallocation
;
43 with Terminal_Interface
.Curses
.Aux
; use Terminal_Interface
.Curses
.Aux
;
45 with Interfaces
.C
; use Interfaces
.C
;
46 with Interfaces
.C
.Strings
; use Interfaces
.C
.Strings
;
47 with Interfaces
.C
.Pointers
;
49 with Ada
.Unchecked_Conversion
;
51 package body Terminal_Interface
.Curses
.Menus
is
53 type C_Item_Array
is array (Natural range <>) of aliased Item
;
54 package I_Array
is new
55 Interfaces
.C
.Pointers
(Natural, Item
, C_Item_Array
, Null_Item
);
57 use type System
.Bit_Order
;
58 subtype chars_ptr
is Interfaces
.C
.Strings
.chars_ptr
;
60 function MOS_2_CInt
is new
61 Ada
.Unchecked_Conversion
(Menu_Option_Set
,
64 function CInt_2_MOS
is new
65 Ada
.Unchecked_Conversion
(C_Int
,
68 function IOS_2_CInt
is new
69 Ada
.Unchecked_Conversion
(Item_Option_Set
,
72 function CInt_2_IOS
is new
73 Ada
.Unchecked_Conversion
(C_Int
,
76 ------------------------------------------------------------------------------
77 procedure Request_Name
(Key
: Menu_Request_Code
;
80 function Request_Name
(Key
: C_Int
) return chars_ptr
;
81 pragma Import
(C
, Request_Name
, "menu_request_name");
83 Fill_String
(Request_Name
(C_Int
(Key
)), Name
);
86 function Request_Name
(Key
: Menu_Request_Code
) return String
88 function Request_Name
(Key
: C_Int
) return chars_ptr
;
89 pragma Import
(C
, Request_Name
, "menu_request_name");
91 return Fill_String
(Request_Name
(C_Int
(Key
)));
94 function Create
(Name
: String;
95 Description
: String := "") return Item
97 type Char_Ptr
is access all Interfaces
.C
.char
;
98 function Newitem
(Name
, Desc
: Char_Ptr
) return Item
;
99 pragma Import
(C
, Newitem
, "new_item");
101 type Name_String
is new char_array
(0 .. Name
'Length);
102 type Name_String_Ptr
is access Name_String
;
103 pragma Controlled
(Name_String_Ptr
);
105 type Desc_String
is new char_array
(0 .. Description
'Length);
106 type Desc_String_Ptr
is access Desc_String
;
107 pragma Controlled
(Desc_String_Ptr
);
109 Name_Str
: constant Name_String_Ptr
:= new Name_String
;
110 Desc_Str
: constant Desc_String_Ptr
:= new Desc_String
;
111 Name_Len
, Desc_Len
: size_t
;
114 To_C
(Name
, Name_Str
.all, Name_Len
);
115 To_C
(Description
, Desc_Str
.all, Desc_Len
);
116 Result
:= Newitem
(Name_Str
.all (Name_Str
.all'First)'Access,
117 Desc_Str
.all (Desc_Str
.all'First)'Access);
118 if Result
= Null_Item
then
119 raise Eti_System_Error
;
124 procedure Delete
(Itm
: in out Item
)
126 function Descname
(Itm
: Item
) return chars_ptr
;
127 pragma Import
(C
, Descname
, "item_description");
128 function Itemname
(Itm
: Item
) return chars_ptr
;
129 pragma Import
(C
, Itemname
, "item_name");
131 function Freeitem
(Itm
: Item
) return C_Int
;
132 pragma Import
(C
, Freeitem
, "free_item");
137 Ptr
:= Descname
(Itm
);
138 if Ptr
/= Null_Ptr
then
139 Interfaces
.C
.Strings
.Free
(Ptr
);
141 Ptr
:= Itemname
(Itm
);
142 if Ptr
/= Null_Ptr
then
143 Interfaces
.C
.Strings
.Free
(Ptr
);
145 Res
:= Freeitem
(Itm
);
151 -------------------------------------------------------------------------------
152 procedure Set_Value
(Itm
: Item
;
153 Value
: Boolean := True)
155 function Set_Item_Val
(Itm
: Item
;
156 Val
: C_Int
) return C_Int
;
157 pragma Import
(C
, Set_Item_Val
, "set_item_value");
159 Res
: constant Eti_Error
:= Set_Item_Val
(Itm
, Boolean'Pos (Value
));
166 function Value
(Itm
: Item
) return Boolean
168 function Item_Val
(Itm
: Item
) return C_Int
;
169 pragma Import
(C
, Item_Val
, "item_value");
171 if Item_Val
(Itm
) = Curses_False
then
178 -------------------------------------------------------------------------------
179 function Visible
(Itm
: Item
) return Boolean
181 function Item_Vis
(Itm
: Item
) return C_Int
;
182 pragma Import
(C
, Item_Vis
, "item_visible");
184 if Item_Vis
(Itm
) = Curses_False
then
190 -------------------------------------------------------------------------------
191 procedure Set_Options
(Itm
: Item
;
192 Options
: Item_Option_Set
)
194 function Set_Item_Opts
(Itm
: Item
;
195 Opt
: C_Int
) return C_Int
;
196 pragma Import
(C
, Set_Item_Opts
, "set_item_opts");
198 Opt
: constant C_Int
:= IOS_2_CInt
(Options
);
201 Res
:= Set_Item_Opts
(Itm
, Opt
);
207 procedure Switch_Options
(Itm
: Item
;
208 Options
: Item_Option_Set
;
209 On
: Boolean := True)
211 function Item_Opts_On
(Itm
: Item
;
212 Opt
: C_Int
) return C_Int
;
213 pragma Import
(C
, Item_Opts_On
, "item_opts_on");
214 function Item_Opts_Off
(Itm
: Item
;
215 Opt
: C_Int
) return C_Int
;
216 pragma Import
(C
, Item_Opts_Off
, "item_opts_off");
218 Opt
: constant C_Int
:= IOS_2_CInt
(Options
);
222 Err
:= Item_Opts_On
(Itm
, Opt
);
224 Err
:= Item_Opts_Off
(Itm
, Opt
);
231 procedure Get_Options
(Itm
: Item
;
232 Options
: out Item_Option_Set
)
234 function Item_Opts
(Itm
: Item
) return C_Int
;
235 pragma Import
(C
, Item_Opts
, "item_opts");
237 Res
: constant C_Int
:= Item_Opts
(Itm
);
239 Options
:= CInt_2_IOS
(Res
);
242 function Get_Options
(Itm
: Item
:= Null_Item
) return Item_Option_Set
244 Ios
: Item_Option_Set
;
246 Get_Options
(Itm
, Ios
);
249 -------------------------------------------------------------------------------
250 procedure Name
(Itm
: Item
;
253 function Itemname
(Itm
: Item
) return chars_ptr
;
254 pragma Import
(C
, Itemname
, "item_name");
256 Fill_String
(Itemname
(Itm
), Name
);
259 function Name
(Itm
: Item
) return String
261 function Itemname
(Itm
: Item
) return chars_ptr
;
262 pragma Import
(C
, Itemname
, "item_name");
264 return Fill_String
(Itemname
(Itm
));
267 procedure Description
(Itm
: Item
;
268 Description
: out String)
270 function Descname
(Itm
: Item
) return chars_ptr
;
271 pragma Import
(C
, Descname
, "item_description");
273 Fill_String
(Descname
(Itm
), Description
);
276 function Description
(Itm
: Item
) return String
278 function Descname
(Itm
: Item
) return chars_ptr
;
279 pragma Import
(C
, Descname
, "item_description");
281 return Fill_String
(Descname
(Itm
));
283 -------------------------------------------------------------------------------
284 procedure Set_Current
(Men
: Menu
;
287 function Set_Curr_Item
(Men
: Menu
;
288 Itm
: Item
) return C_Int
;
289 pragma Import
(C
, Set_Curr_Item
, "set_current_item");
291 Res
: constant Eti_Error
:= Set_Curr_Item
(Men
, Itm
);
298 function Current
(Men
: Menu
) return Item
300 function Curr_Item
(Men
: Menu
) return Item
;
301 pragma Import
(C
, Curr_Item
, "current_item");
303 Res
: constant Item
:= Curr_Item
(Men
);
305 if Res
= Null_Item
then
306 raise Menu_Exception
;
311 procedure Set_Top_Row
(Men
: Menu
;
312 Line
: Line_Position
)
314 function Set_Toprow
(Men
: Menu
;
315 Line
: C_Int
) return C_Int
;
316 pragma Import
(C
, Set_Toprow
, "set_top_row");
318 Res
: constant Eti_Error
:= Set_Toprow
(Men
, C_Int
(Line
));
325 function Top_Row
(Men
: Menu
) return Line_Position
327 function Toprow
(Men
: Menu
) return C_Int
;
328 pragma Import
(C
, Toprow
, "top_row");
330 Res
: constant C_Int
:= Toprow
(Men
);
332 if Res
= Curses_Err
then
333 raise Menu_Exception
;
335 return Line_Position
(Res
);
338 function Get_Index
(Itm
: Item
) return Positive
340 function Get_Itemindex
(Itm
: Item
) return C_Int
;
341 pragma Import
(C
, Get_Itemindex
, "item_index");
343 Res
: constant C_Int
:= Get_Itemindex
(Itm
);
345 if Res
= Curses_Err
then
346 raise Menu_Exception
;
348 return Positive (Natural (Res
) + Positive'First);
350 -------------------------------------------------------------------------------
351 procedure Post
(Men
: Menu
;
352 Post
: Boolean := True)
354 function M_Post
(Men
: Menu
) return C_Int
;
355 pragma Import
(C
, M_Post
, "post_menu");
356 function M_Unpost
(Men
: Menu
) return C_Int
;
357 pragma Import
(C
, M_Unpost
, "unpost_menu");
364 Res
:= M_Unpost
(Men
);
370 -------------------------------------------------------------------------------
371 procedure Set_Options
(Men
: Menu
;
372 Options
: Menu_Option_Set
)
374 function Set_Menu_Opts
(Men
: Menu
;
375 Opt
: C_Int
) return C_Int
;
376 pragma Import
(C
, Set_Menu_Opts
, "set_menu_opts");
378 Opt
: constant C_Int
:= MOS_2_CInt
(Options
);
381 Res
:= Set_Menu_Opts
(Men
, Opt
);
387 procedure Switch_Options
(Men
: Menu
;
388 Options
: Menu_Option_Set
;
389 On
: Boolean := True)
391 function Menu_Opts_On
(Men
: Menu
;
392 Opt
: C_Int
) return C_Int
;
393 pragma Import
(C
, Menu_Opts_On
, "menu_opts_on");
394 function Menu_Opts_Off
(Men
: Menu
;
395 Opt
: C_Int
) return C_Int
;
396 pragma Import
(C
, Menu_Opts_Off
, "menu_opts_off");
398 Opt
: constant C_Int
:= MOS_2_CInt
(Options
);
402 Err
:= Menu_Opts_On
(Men
, Opt
);
404 Err
:= Menu_Opts_Off
(Men
, Opt
);
411 procedure Get_Options
(Men
: Menu
;
412 Options
: out Menu_Option_Set
)
414 function Menu_Opts
(Men
: Menu
) return C_Int
;
415 pragma Import
(C
, Menu_Opts
, "menu_opts");
417 Res
: constant C_Int
:= Menu_Opts
(Men
);
419 Options
:= CInt_2_MOS
(Res
);
422 function Get_Options
(Men
: Menu
:= Null_Menu
) return Menu_Option_Set
424 Mos
: Menu_Option_Set
;
426 Get_Options
(Men
, Mos
);
429 -------------------------------------------------------------------------------
430 procedure Set_Window
(Men
: Menu
;
433 function Set_Menu_Win
(Men
: Menu
;
434 Win
: Window
) return C_Int
;
435 pragma Import
(C
, Set_Menu_Win
, "set_menu_win");
437 Res
: constant Eti_Error
:= Set_Menu_Win
(Men
, Win
);
444 function Get_Window
(Men
: Menu
) return Window
446 function Menu_Win
(Men
: Menu
) return Window
;
447 pragma Import
(C
, Menu_Win
, "menu_win");
449 W
: constant Window
:= Menu_Win
(Men
);
454 procedure Set_Sub_Window
(Men
: Menu
;
457 function Set_Menu_Sub
(Men
: Menu
;
458 Win
: Window
) return C_Int
;
459 pragma Import
(C
, Set_Menu_Sub
, "set_menu_sub");
461 Res
: constant Eti_Error
:= Set_Menu_Sub
(Men
, Win
);
468 function Get_Sub_Window
(Men
: Menu
) return Window
470 function Menu_Sub
(Men
: Menu
) return Window
;
471 pragma Import
(C
, Menu_Sub
, "menu_sub");
473 W
: constant Window
:= Menu_Sub
(Men
);
478 procedure Scale
(Men
: Menu
;
479 Lines
: out Line_Count
;
480 Columns
: out Column_Count
)
482 type C_Int_Access
is access all C_Int
;
483 function M_Scale
(Men
: Menu
;
484 Yp
, Xp
: C_Int_Access
) return C_Int
;
485 pragma Import
(C
, M_Scale
, "scale_menu");
487 X
, Y
: aliased C_Int
;
488 Res
: constant Eti_Error
:= M_Scale
(Men
, Y
'Access, X
'Access);
493 Lines
:= Line_Count
(Y
);
494 Columns
:= Column_Count
(X
);
496 -------------------------------------------------------------------------------
497 procedure Position_Cursor
(Men
: Menu
)
499 function Pos_Menu_Cursor
(Men
: Menu
) return C_Int
;
500 pragma Import
(C
, Pos_Menu_Cursor
, "pos_menu_cursor");
502 Res
: constant Eti_Error
:= Pos_Menu_Cursor
(Men
);
509 -------------------------------------------------------------------------------
510 procedure Set_Mark
(Men
: Menu
;
513 type Char_Ptr
is access all Interfaces
.C
.char
;
514 function Set_Mark
(Men
: Menu
;
515 Mark
: Char_Ptr
) return C_Int
;
516 pragma Import
(C
, Set_Mark
, "set_menu_mark");
518 Txt
: char_array
(0 .. Mark
'Length);
522 To_C
(Mark
, Txt
, Len
);
523 Res
:= Set_Mark
(Men
, Txt
(Txt
'First)'Access);
529 procedure Mark
(Men
: Menu
;
532 function Get_Menu_Mark
(Men
: Menu
) return chars_ptr
;
533 pragma Import
(C
, Get_Menu_Mark
, "menu_mark");
535 Fill_String
(Get_Menu_Mark
(Men
), Mark
);
538 function Mark
(Men
: Menu
) return String
540 function Get_Menu_Mark
(Men
: Menu
) return chars_ptr
;
541 pragma Import
(C
, Get_Menu_Mark
, "menu_mark");
543 return Fill_String
(Get_Menu_Mark
(Men
));
546 -------------------------------------------------------------------------------
547 procedure Set_Foreground
549 Fore
: Character_Attribute_Set
:= Normal_Video
;
550 Color
: Color_Pair
:= Color_Pair
'First)
552 function Set_Menu_Fore
(Men
: Menu
;
553 Attr
: C_Chtype
) return C_Int
;
554 pragma Import
(C
, Set_Menu_Fore
, "set_menu_fore");
556 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
559 Res
: constant Eti_Error
:= Set_Menu_Fore
(Men
, AttrChar_To_Chtype
(Ch
));
566 procedure Foreground
(Men
: Menu
;
567 Fore
: out Character_Attribute_Set
)
569 function Menu_Fore
(Men
: Menu
) return C_Chtype
;
570 pragma Import
(C
, Menu_Fore
, "menu_fore");
572 Fore
:= Chtype_To_AttrChar
(Menu_Fore
(Men
)).Attr
;
575 procedure Foreground
(Men
: Menu
;
576 Fore
: out Character_Attribute_Set
;
577 Color
: out Color_Pair
)
579 function Menu_Fore
(Men
: Menu
) return C_Chtype
;
580 pragma Import
(C
, Menu_Fore
, "menu_fore");
582 Fore
:= Chtype_To_AttrChar
(Menu_Fore
(Men
)).Attr
;
583 Color
:= Chtype_To_AttrChar
(Menu_Fore
(Men
)).Color
;
586 procedure Set_Background
588 Back
: Character_Attribute_Set
:= Normal_Video
;
589 Color
: Color_Pair
:= Color_Pair
'First)
591 function Set_Menu_Back
(Men
: Menu
;
592 Attr
: C_Chtype
) return C_Int
;
593 pragma Import
(C
, Set_Menu_Back
, "set_menu_back");
595 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
598 Res
: constant Eti_Error
:= Set_Menu_Back
(Men
, AttrChar_To_Chtype
(Ch
));
605 procedure Background
(Men
: Menu
;
606 Back
: out Character_Attribute_Set
)
608 function Menu_Back
(Men
: Menu
) return C_Chtype
;
609 pragma Import
(C
, Menu_Back
, "menu_back");
611 Back
:= Chtype_To_AttrChar
(Menu_Back
(Men
)).Attr
;
614 procedure Background
(Men
: Menu
;
615 Back
: out Character_Attribute_Set
;
616 Color
: out Color_Pair
)
618 function Menu_Back
(Men
: Menu
) return C_Chtype
;
619 pragma Import
(C
, Menu_Back
, "menu_back");
621 Back
:= Chtype_To_AttrChar
(Menu_Back
(Men
)).Attr
;
622 Color
:= Chtype_To_AttrChar
(Menu_Back
(Men
)).Color
;
625 procedure Set_Grey
(Men
: Menu
;
626 Grey
: Character_Attribute_Set
:= Normal_Video
;
627 Color
: Color_Pair
:= Color_Pair
'First)
629 function Set_Menu_Grey
(Men
: Menu
;
630 Attr
: C_Chtype
) return C_Int
;
631 pragma Import
(C
, Set_Menu_Grey
, "set_menu_grey");
633 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
637 Res
: constant Eti_Error
:= Set_Menu_Grey
(Men
, AttrChar_To_Chtype
(Ch
));
644 procedure Grey
(Men
: Menu
;
645 Grey
: out Character_Attribute_Set
)
647 function Menu_Grey
(Men
: Menu
) return C_Chtype
;
648 pragma Import
(C
, Menu_Grey
, "menu_grey");
650 Grey
:= Chtype_To_AttrChar
(Menu_Grey
(Men
)).Attr
;
653 procedure Grey
(Men
: Menu
;
654 Grey
: out Character_Attribute_Set
;
655 Color
: out Color_Pair
)
657 function Menu_Grey
(Men
: Menu
) return C_Chtype
;
658 pragma Import
(C
, Menu_Grey
, "menu_grey");
660 Grey
:= Chtype_To_AttrChar
(Menu_Grey
(Men
)).Attr
;
661 Color
:= Chtype_To_AttrChar
(Menu_Grey
(Men
)).Color
;
664 procedure Set_Pad_Character
(Men
: Menu
;
665 Pad
: Character := Space
)
667 function Set_Menu_Pad
(Men
: Menu
;
668 Ch
: C_Int
) return C_Int
;
669 pragma Import
(C
, Set_Menu_Pad
, "set_menu_pad");
671 Res
: constant Eti_Error
:= Set_Menu_Pad
(Men
,
672 C_Int
(Character'Pos (Pad
)));
677 end Set_Pad_Character
;
679 procedure Pad_Character
(Men
: Menu
;
682 function Menu_Pad
(Men
: Menu
) return C_Int
;
683 pragma Import
(C
, Menu_Pad
, "menu_pad");
685 Pad
:= Character'Val (Menu_Pad
(Men
));
687 -------------------------------------------------------------------------------
688 procedure Set_Spacing
(Men
: Menu
;
689 Descr
: Column_Position
:= 0;
690 Row
: Line_Position
:= 0;
691 Col
: Column_Position
:= 0)
693 function Set_Spacing
(Men
: Menu
;
694 D
, R
, C
: C_Int
) return C_Int
;
695 pragma Import
(C
, Set_Spacing
, "set_menu_spacing");
697 Res
: constant Eti_Error
:= Set_Spacing
(Men
,
707 procedure Spacing
(Men
: Menu
;
708 Descr
: out Column_Position
;
709 Row
: out Line_Position
;
710 Col
: out Column_Position
)
712 type C_Int_Access
is access all C_Int
;
713 function Get_Spacing
(Men
: Menu
;
714 D
, R
, C
: C_Int_Access
) return C_Int
;
715 pragma Import
(C
, Get_Spacing
, "menu_spacing");
717 D
, R
, C
: aliased C_Int
;
718 Res
: constant Eti_Error
:= Get_Spacing
(Men
,
726 Descr
:= Column_Position
(D
);
727 Row
:= Line_Position
(R
);
728 Col
:= Column_Position
(C
);
731 -------------------------------------------------------------------------------
732 function Set_Pattern
(Men
: Menu
;
733 Text
: String) return Boolean
735 type Char_Ptr
is access all Interfaces
.C
.char
;
736 function Set_Pattern
(Men
: Menu
;
737 Pattern
: Char_Ptr
) return C_Int
;
738 pragma Import
(C
, Set_Pattern
, "set_menu_pattern");
740 S
: char_array
(0 .. Text
'Length);
745 Res
:= Set_Pattern
(Men
, S
(S
'First)'Access);
747 when E_No_Match
=> return False;
748 when E_Ok
=> return True;
755 procedure Pattern
(Men
: Menu
;
758 function Get_Pattern
(Men
: Menu
) return chars_ptr
;
759 pragma Import
(C
, Get_Pattern
, "menu_pattern");
761 Fill_String
(Get_Pattern
(Men
), Text
);
763 -------------------------------------------------------------------------------
764 procedure Set_Format
(Men
: Menu
;
766 Columns
: Column_Count
)
768 function Set_Menu_Fmt
(Men
: Menu
;
770 Col
: C_Int
) return C_Int
;
771 pragma Import
(C
, Set_Menu_Fmt
, "set_menu_format");
773 Res
: constant Eti_Error
:= Set_Menu_Fmt
(Men
,
782 procedure Format
(Men
: Menu
;
783 Lines
: out Line_Count
;
784 Columns
: out Column_Count
)
786 type C_Int_Access
is access all C_Int
;
787 function Menu_Fmt
(Men
: Menu
;
788 Y
, X
: C_Int_Access
) return C_Int
;
789 pragma Import
(C
, Menu_Fmt
, "menu_format");
791 L
, C
: aliased C_Int
;
792 Res
: constant Eti_Error
:= Menu_Fmt
(Men
, L
'Access, C
'Access);
797 Lines
:= Line_Count
(L
);
798 Columns
:= Column_Count
(C
);
801 -------------------------------------------------------------------------------
802 procedure Set_Item_Init_Hook
(Men
: Menu
;
803 Proc
: Menu_Hook_Function
)
805 function Set_Item_Init
(Men
: Menu
;
806 Proc
: Menu_Hook_Function
) return C_Int
;
807 pragma Import
(C
, Set_Item_Init
, "set_item_init");
809 Res
: constant Eti_Error
:= Set_Item_Init
(Men
, Proc
);
814 end Set_Item_Init_Hook
;
816 procedure Set_Item_Term_Hook
(Men
: Menu
;
817 Proc
: Menu_Hook_Function
)
819 function Set_Item_Term
(Men
: Menu
;
820 Proc
: Menu_Hook_Function
) return C_Int
;
821 pragma Import
(C
, Set_Item_Term
, "set_item_term");
823 Res
: constant Eti_Error
:= Set_Item_Term
(Men
, Proc
);
828 end Set_Item_Term_Hook
;
830 procedure Set_Menu_Init_Hook
(Men
: Menu
;
831 Proc
: Menu_Hook_Function
)
833 function Set_Menu_Init
(Men
: Menu
;
834 Proc
: Menu_Hook_Function
) return C_Int
;
835 pragma Import
(C
, Set_Menu_Init
, "set_menu_init");
837 Res
: constant Eti_Error
:= Set_Menu_Init
(Men
, Proc
);
842 end Set_Menu_Init_Hook
;
844 procedure Set_Menu_Term_Hook
(Men
: Menu
;
845 Proc
: Menu_Hook_Function
)
847 function Set_Menu_Term
(Men
: Menu
;
848 Proc
: Menu_Hook_Function
) return C_Int
;
849 pragma Import
(C
, Set_Menu_Term
, "set_menu_term");
851 Res
: constant Eti_Error
:= Set_Menu_Term
(Men
, Proc
);
856 end Set_Menu_Term_Hook
;
858 function Get_Item_Init_Hook
(Men
: Menu
) return Menu_Hook_Function
860 function Item_Init
(Men
: Menu
) return Menu_Hook_Function
;
861 pragma Import
(C
, Item_Init
, "item_init");
863 return Item_Init
(Men
);
864 end Get_Item_Init_Hook
;
866 function Get_Item_Term_Hook
(Men
: Menu
) return Menu_Hook_Function
868 function Item_Term
(Men
: Menu
) return Menu_Hook_Function
;
869 pragma Import
(C
, Item_Term
, "item_term");
871 return Item_Term
(Men
);
872 end Get_Item_Term_Hook
;
874 function Get_Menu_Init_Hook
(Men
: Menu
) return Menu_Hook_Function
876 function Menu_Init
(Men
: Menu
) return Menu_Hook_Function
;
877 pragma Import
(C
, Menu_Init
, "menu_init");
879 return Menu_Init
(Men
);
880 end Get_Menu_Init_Hook
;
882 function Get_Menu_Term_Hook
(Men
: Menu
) return Menu_Hook_Function
884 function Menu_Term
(Men
: Menu
) return Menu_Hook_Function
;
885 pragma Import
(C
, Menu_Term
, "menu_term");
887 return Menu_Term
(Men
);
888 end Get_Menu_Term_Hook
;
889 -------------------------------------------------------------------------------
890 procedure Redefine
(Men
: Menu
;
891 Items
: Item_Array_Access
)
893 function Set_Items
(Men
: Menu
;
894 Items
: System
.Address
) return C_Int
;
895 pragma Import
(C
, Set_Items
, "set_menu_items");
899 pragma Assert
(Items
.all (Items
'Last) = Null_Item
);
900 if Items
.all (Items
'Last) /= Null_Item
then
901 raise Menu_Exception
;
903 Res
:= Set_Items
(Men
, Items
.all'Address);
910 function Item_Count
(Men
: Menu
) return Natural
912 function Count
(Men
: Menu
) return C_Int
;
913 pragma Import
(C
, Count
, "item_count");
915 return Natural (Count
(Men
));
918 function Items
(Men
: Menu
;
919 Index
: Positive) return Item
923 function C_Mitems
(Men
: Menu
) return Pointer
;
924 pragma Import
(C
, C_Mitems
, "menu_items");
926 P
: Pointer
:= C_Mitems
(Men
);
928 if P
= null or else Index
> Item_Count
(Men
) then
929 raise Menu_Exception
;
931 P
:= P
+ ptrdiff_t
(C_Int
(Index
) - 1);
936 -------------------------------------------------------------------------------
937 function Create
(Items
: Item_Array_Access
) return Menu
939 function Newmenu
(Items
: System
.Address
) return Menu
;
940 pragma Import
(C
, Newmenu
, "new_menu");
944 pragma Assert
(Items
.all (Items
'Last) = Null_Item
);
945 if Items
.all (Items
'Last) /= Null_Item
then
946 raise Menu_Exception
;
948 M
:= Newmenu
(Items
.all'Address);
949 if M
= Null_Menu
then
950 raise Menu_Exception
;
956 procedure Delete
(Men
: in out Menu
)
958 function Free
(Men
: Menu
) return C_Int
;
959 pragma Import
(C
, Free
, "free_menu");
961 Res
: constant Eti_Error
:= Free
(Men
);
969 ------------------------------------------------------------------------------
970 function Driver
(Men
: Menu
;
971 Key
: Key_Code
) return Driver_Result
973 function Driver
(Men
: Menu
;
974 Key
: C_Int
) return C_Int
;
975 pragma Import
(C
, Driver
, "menu_driver");
977 R
: constant Eti_Error
:= Driver
(Men
, C_Int
(Key
));
981 when E_Unknown_Command
=> return Unknown_Request
;
982 when E_No_Match
=> return No_Match
;
983 when E_Request_Denied |
984 E_Not_Selectable
=> return Request_Denied
;
992 procedure Free
(IA
: in out Item_Array_Access
;
993 Free_Items
: Boolean := False)
995 procedure Release
is new Ada
.Unchecked_Deallocation
996 (Item_Array
, Item_Array_Access
);
998 if IA
/= null and then Free_Items
then
999 for I
in IA
'First .. (IA
'Last - 1) loop
1000 if IA
.all (I
) /= Null_Item
then
1001 Delete
(IA
.all (I
));
1008 -------------------------------------------------------------------------------
1009 function Default_Menu_Options
return Menu_Option_Set
1012 return Get_Options
(Null_Menu
);
1013 end Default_Menu_Options
;
1015 function Default_Item_Options
return Item_Option_Set
1018 return Get_Options
(Null_Item
);
1019 end Default_Item_Options
;
1020 -------------------------------------------------------------------------------
1022 end Terminal_Interface
.Curses
.Menus
;