1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Menus --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2011,2014 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: 2014/05/24 21:31:05 $
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 package body Terminal_Interface
.Curses
.Menus
is
51 type C_Item_Array
is array (Natural range <>) of aliased Item
;
52 package I_Array
is new
53 Interfaces
.C
.Pointers
(Natural, Item
, C_Item_Array
, Null_Item
);
55 use type System
.Bit_Order
;
56 subtype chars_ptr
is Interfaces
.C
.Strings
.chars_ptr
;
58 ------------------------------------------------------------------------------
59 procedure Request_Name
(Key
: Menu_Request_Code
;
62 function Request_Name
(Key
: C_Int
) return chars_ptr
;
63 pragma Import
(C
, Request_Name
, "menu_request_name");
65 Fill_String
(Request_Name
(C_Int
(Key
)), Name
);
68 function Request_Name
(Key
: Menu_Request_Code
) return String
70 function Request_Name
(Key
: C_Int
) return chars_ptr
;
71 pragma Import
(C
, Request_Name
, "menu_request_name");
73 return Fill_String
(Request_Name
(C_Int
(Key
)));
76 function Create
(Name
: String;
77 Description
: String := "") return Item
79 type Char_Ptr
is access all Interfaces
.C
.char
;
80 function Newitem
(Name
, Desc
: Char_Ptr
) return Item
;
81 pragma Import
(C
, Newitem
, "new_item");
83 type Name_String
is new char_array
(0 .. Name
'Length);
84 type Name_String_Ptr
is access Name_String
;
85 pragma Controlled
(Name_String_Ptr
);
87 type Desc_String
is new char_array
(0 .. Description
'Length);
88 type Desc_String_Ptr
is access Desc_String
;
89 pragma Controlled
(Desc_String_Ptr
);
91 Name_Str
: constant Name_String_Ptr
:= new Name_String
;
92 Desc_Str
: constant Desc_String_Ptr
:= new Desc_String
;
93 Name_Len
, Desc_Len
: size_t
;
96 To_C
(Name
, Name_Str
.all, Name_Len
);
97 To_C
(Description
, Desc_Str
.all, Desc_Len
);
98 Result
:= Newitem
(Name_Str
.all (Name_Str
.all'First)'Access,
99 Desc_Str
.all (Desc_Str
.all'First)'Access);
100 if Result
= Null_Item
then
101 raise Eti_System_Error
;
106 procedure Delete
(Itm
: in out Item
)
108 function Descname
(Itm
: Item
) return chars_ptr
;
109 pragma Import
(C
, Descname
, "item_description");
110 function Itemname
(Itm
: Item
) return chars_ptr
;
111 pragma Import
(C
, Itemname
, "item_name");
113 function Freeitem
(Itm
: Item
) return Eti_Error
;
114 pragma Import
(C
, Freeitem
, "free_item");
118 Ptr
:= Descname
(Itm
);
119 if Ptr
/= Null_Ptr
then
120 Interfaces
.C
.Strings
.Free
(Ptr
);
122 Ptr
:= Itemname
(Itm
);
123 if Ptr
/= Null_Ptr
then
124 Interfaces
.C
.Strings
.Free
(Ptr
);
126 Eti_Exception
(Freeitem
(Itm
));
129 -------------------------------------------------------------------------------
130 procedure Set_Value
(Itm
: Item
;
131 Value
: Boolean := True)
133 function Set_Item_Val
(Itm
: Item
;
134 Val
: C_Int
) return Eti_Error
;
135 pragma Import
(C
, Set_Item_Val
, "set_item_value");
138 Eti_Exception
(Set_Item_Val
(Itm
, Boolean'Pos (Value
)));
141 function Value
(Itm
: Item
) return Boolean
143 function Item_Val
(Itm
: Item
) return C_Int
;
144 pragma Import
(C
, Item_Val
, "item_value");
146 if Item_Val
(Itm
) = Curses_False
then
153 -------------------------------------------------------------------------------
154 function Visible
(Itm
: Item
) return Boolean
156 function Item_Vis
(Itm
: Item
) return C_Int
;
157 pragma Import
(C
, Item_Vis
, "item_visible");
159 if Item_Vis
(Itm
) = Curses_False
then
165 -------------------------------------------------------------------------------
166 procedure Set_Options
(Itm
: Item
;
167 Options
: Item_Option_Set
)
169 function Set_Item_Opts
(Itm
: Item
;
170 Opt
: Item_Option_Set
) return Eti_Error
;
171 pragma Import
(C
, Set_Item_Opts
, "set_item_opts");
174 Eti_Exception
(Set_Item_Opts
(Itm
, Options
));
177 procedure Switch_Options
(Itm
: Item
;
178 Options
: Item_Option_Set
;
179 On
: Boolean := True)
181 function Item_Opts_On
(Itm
: Item
;
182 Opt
: Item_Option_Set
) return Eti_Error
;
183 pragma Import
(C
, Item_Opts_On
, "item_opts_on");
184 function Item_Opts_Off
(Itm
: Item
;
185 Opt
: Item_Option_Set
) return Eti_Error
;
186 pragma Import
(C
, Item_Opts_Off
, "item_opts_off");
190 Eti_Exception
(Item_Opts_On
(Itm
, Options
));
192 Eti_Exception
(Item_Opts_Off
(Itm
, Options
));
196 procedure Get_Options
(Itm
: Item
;
197 Options
: out Item_Option_Set
)
199 function Item_Opts
(Itm
: Item
) return Item_Option_Set
;
200 pragma Import
(C
, Item_Opts
, "item_opts");
203 Options
:= Item_Opts
(Itm
);
206 function Get_Options
(Itm
: Item
:= Null_Item
) return Item_Option_Set
208 Ios
: Item_Option_Set
;
210 Get_Options
(Itm
, Ios
);
213 -------------------------------------------------------------------------------
214 procedure Name
(Itm
: Item
;
217 function Itemname
(Itm
: Item
) return chars_ptr
;
218 pragma Import
(C
, Itemname
, "item_name");
220 Fill_String
(Itemname
(Itm
), Name
);
223 function Name
(Itm
: Item
) return String
225 function Itemname
(Itm
: Item
) return chars_ptr
;
226 pragma Import
(C
, Itemname
, "item_name");
228 return Fill_String
(Itemname
(Itm
));
231 procedure Description
(Itm
: Item
;
232 Description
: out String)
234 function Descname
(Itm
: Item
) return chars_ptr
;
235 pragma Import
(C
, Descname
, "item_description");
237 Fill_String
(Descname
(Itm
), Description
);
240 function Description
(Itm
: Item
) return String
242 function Descname
(Itm
: Item
) return chars_ptr
;
243 pragma Import
(C
, Descname
, "item_description");
245 return Fill_String
(Descname
(Itm
));
247 -------------------------------------------------------------------------------
248 procedure Set_Current
(Men
: Menu
;
251 function Set_Curr_Item
(Men
: Menu
;
252 Itm
: Item
) return Eti_Error
;
253 pragma Import
(C
, Set_Curr_Item
, "set_current_item");
256 Eti_Exception
(Set_Curr_Item
(Men
, Itm
));
259 function Current
(Men
: Menu
) return Item
261 function Curr_Item
(Men
: Menu
) return Item
;
262 pragma Import
(C
, Curr_Item
, "current_item");
264 Res
: constant Item
:= Curr_Item
(Men
);
266 if Res
= Null_Item
then
267 raise Menu_Exception
;
272 procedure Set_Top_Row
(Men
: Menu
;
273 Line
: Line_Position
)
275 function Set_Toprow
(Men
: Menu
;
276 Line
: C_Int
) return Eti_Error
;
277 pragma Import
(C
, Set_Toprow
, "set_top_row");
280 Eti_Exception
(Set_Toprow
(Men
, C_Int
(Line
)));
283 function Top_Row
(Men
: Menu
) return Line_Position
285 function Toprow
(Men
: Menu
) return C_Int
;
286 pragma Import
(C
, Toprow
, "top_row");
288 Res
: constant C_Int
:= Toprow
(Men
);
290 if Res
= Curses_Err
then
291 raise Menu_Exception
;
293 return Line_Position
(Res
);
296 function Get_Index
(Itm
: Item
) return Positive
298 function Get_Itemindex
(Itm
: Item
) return C_Int
;
299 pragma Import
(C
, Get_Itemindex
, "item_index");
301 Res
: constant C_Int
:= Get_Itemindex
(Itm
);
303 if Res
= Curses_Err
then
304 raise Menu_Exception
;
306 return Positive (Natural (Res
) + Positive'First);
308 -------------------------------------------------------------------------------
309 procedure Post
(Men
: Menu
;
310 Post
: Boolean := True)
312 function M_Post
(Men
: Menu
) return Eti_Error
;
313 pragma Import
(C
, M_Post
, "post_menu");
314 function M_Unpost
(Men
: Menu
) return Eti_Error
;
315 pragma Import
(C
, M_Unpost
, "unpost_menu");
319 Eti_Exception
(M_Post
(Men
));
321 Eti_Exception
(M_Unpost
(Men
));
324 -------------------------------------------------------------------------------
325 procedure Set_Options
(Men
: Menu
;
326 Options
: Menu_Option_Set
)
328 function Set_Menu_Opts
(Men
: Menu
;
329 Opt
: Menu_Option_Set
) return Eti_Error
;
330 pragma Import
(C
, Set_Menu_Opts
, "set_menu_opts");
333 Eti_Exception
(Set_Menu_Opts
(Men
, Options
));
336 procedure Switch_Options
(Men
: Menu
;
337 Options
: Menu_Option_Set
;
338 On
: Boolean := True)
340 function Menu_Opts_On
(Men
: Menu
;
341 Opt
: Menu_Option_Set
) return Eti_Error
;
342 pragma Import
(C
, Menu_Opts_On
, "menu_opts_on");
343 function Menu_Opts_Off
(Men
: Menu
;
344 Opt
: Menu_Option_Set
) return Eti_Error
;
345 pragma Import
(C
, Menu_Opts_Off
, "menu_opts_off");
349 Eti_Exception
(Menu_Opts_On
(Men
, Options
));
351 Eti_Exception
(Menu_Opts_Off
(Men
, Options
));
355 procedure Get_Options
(Men
: Menu
;
356 Options
: out Menu_Option_Set
)
358 function Menu_Opts
(Men
: Menu
) return Menu_Option_Set
;
359 pragma Import
(C
, Menu_Opts
, "menu_opts");
362 Options
:= Menu_Opts
(Men
);
365 function Get_Options
(Men
: Menu
:= Null_Menu
) return Menu_Option_Set
367 Mos
: Menu_Option_Set
;
369 Get_Options
(Men
, Mos
);
372 -------------------------------------------------------------------------------
373 procedure Set_Window
(Men
: Menu
;
376 function Set_Menu_Win
(Men
: Menu
;
377 Win
: Window
) return Eti_Error
;
378 pragma Import
(C
, Set_Menu_Win
, "set_menu_win");
381 Eti_Exception
(Set_Menu_Win
(Men
, Win
));
384 function Get_Window
(Men
: Menu
) return Window
386 function Menu_Win
(Men
: Menu
) return Window
;
387 pragma Import
(C
, Menu_Win
, "menu_win");
389 W
: constant Window
:= Menu_Win
(Men
);
394 procedure Set_Sub_Window
(Men
: Menu
;
397 function Set_Menu_Sub
(Men
: Menu
;
398 Win
: Window
) return Eti_Error
;
399 pragma Import
(C
, Set_Menu_Sub
, "set_menu_sub");
402 Eti_Exception
(Set_Menu_Sub
(Men
, Win
));
405 function Get_Sub_Window
(Men
: Menu
) return Window
407 function Menu_Sub
(Men
: Menu
) return Window
;
408 pragma Import
(C
, Menu_Sub
, "menu_sub");
410 W
: constant Window
:= Menu_Sub
(Men
);
415 procedure Scale
(Men
: Menu
;
416 Lines
: out Line_Count
;
417 Columns
: out Column_Count
)
419 type C_Int_Access
is access all C_Int
;
420 function M_Scale
(Men
: Menu
;
421 Yp
, Xp
: C_Int_Access
) return Eti_Error
;
422 pragma Import
(C
, M_Scale
, "scale_menu");
424 X
, Y
: aliased C_Int
;
426 Eti_Exception
(M_Scale
(Men
, Y
'Access, X
'Access));
427 Lines
:= Line_Count
(Y
);
428 Columns
:= Column_Count
(X
);
430 -------------------------------------------------------------------------------
431 procedure Position_Cursor
(Men
: Menu
)
433 function Pos_Menu_Cursor
(Men
: Menu
) return Eti_Error
;
434 pragma Import
(C
, Pos_Menu_Cursor
, "pos_menu_cursor");
437 Eti_Exception
(Pos_Menu_Cursor
(Men
));
440 -------------------------------------------------------------------------------
441 procedure Set_Mark
(Men
: Menu
;
444 type Char_Ptr
is access all Interfaces
.C
.char
;
445 function Set_Mark
(Men
: Menu
;
446 Mark
: Char_Ptr
) return Eti_Error
;
447 pragma Import
(C
, Set_Mark
, "set_menu_mark");
449 Txt
: char_array
(0 .. Mark
'Length);
452 To_C
(Mark
, Txt
, Len
);
453 Eti_Exception
(Set_Mark
(Men
, Txt
(Txt
'First)'Access));
456 procedure Mark
(Men
: Menu
;
459 function Get_Menu_Mark
(Men
: Menu
) return chars_ptr
;
460 pragma Import
(C
, Get_Menu_Mark
, "menu_mark");
462 Fill_String
(Get_Menu_Mark
(Men
), Mark
);
465 function Mark
(Men
: Menu
) return String
467 function Get_Menu_Mark
(Men
: Menu
) return chars_ptr
;
468 pragma Import
(C
, Get_Menu_Mark
, "menu_mark");
470 return Fill_String
(Get_Menu_Mark
(Men
));
473 -------------------------------------------------------------------------------
474 procedure Set_Foreground
476 Fore
: Character_Attribute_Set
:= Normal_Video
;
477 Color
: Color_Pair
:= Color_Pair
'First)
479 function Set_Menu_Fore
(Men
: Menu
;
480 Attr
: Attributed_Character
) return Eti_Error
;
481 pragma Import
(C
, Set_Menu_Fore
, "set_menu_fore");
483 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
487 Eti_Exception
(Set_Menu_Fore
(Men
, Ch
));
490 procedure Foreground
(Men
: Menu
;
491 Fore
: out Character_Attribute_Set
)
493 function Menu_Fore
(Men
: Menu
) return Attributed_Character
;
494 pragma Import
(C
, Menu_Fore
, "menu_fore");
496 Fore
:= Menu_Fore
(Men
).Attr
;
499 procedure Foreground
(Men
: Menu
;
500 Fore
: out Character_Attribute_Set
;
501 Color
: out Color_Pair
)
503 function Menu_Fore
(Men
: Menu
) return Attributed_Character
;
504 pragma Import
(C
, Menu_Fore
, "menu_fore");
506 Fore
:= Menu_Fore
(Men
).Attr
;
507 Color
:= Menu_Fore
(Men
).Color
;
510 procedure Set_Background
512 Back
: Character_Attribute_Set
:= Normal_Video
;
513 Color
: Color_Pair
:= Color_Pair
'First)
515 function Set_Menu_Back
(Men
: Menu
;
516 Attr
: Attributed_Character
) return Eti_Error
;
517 pragma Import
(C
, Set_Menu_Back
, "set_menu_back");
519 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
523 Eti_Exception
(Set_Menu_Back
(Men
, Ch
));
526 procedure Background
(Men
: Menu
;
527 Back
: out Character_Attribute_Set
)
529 function Menu_Back
(Men
: Menu
) return Attributed_Character
;
530 pragma Import
(C
, Menu_Back
, "menu_back");
532 Back
:= Menu_Back
(Men
).Attr
;
535 procedure Background
(Men
: Menu
;
536 Back
: out Character_Attribute_Set
;
537 Color
: out Color_Pair
)
539 function Menu_Back
(Men
: Menu
) return Attributed_Character
;
540 pragma Import
(C
, Menu_Back
, "menu_back");
542 Back
:= Menu_Back
(Men
).Attr
;
543 Color
:= Menu_Back
(Men
).Color
;
546 procedure Set_Grey
(Men
: Menu
;
547 Grey
: Character_Attribute_Set
:= Normal_Video
;
548 Color
: Color_Pair
:= Color_Pair
'First)
550 function Set_Menu_Grey
(Men
: Menu
;
551 Attr
: Attributed_Character
) return Eti_Error
;
552 pragma Import
(C
, Set_Menu_Grey
, "set_menu_grey");
554 Ch
: constant Attributed_Character
:= (Ch
=> Character'First,
559 Eti_Exception
(Set_Menu_Grey
(Men
, Ch
));
562 procedure Grey
(Men
: Menu
;
563 Grey
: out Character_Attribute_Set
)
565 function Menu_Grey
(Men
: Menu
) return Attributed_Character
;
566 pragma Import
(C
, Menu_Grey
, "menu_grey");
568 Grey
:= Menu_Grey
(Men
).Attr
;
571 procedure Grey
(Men
: Menu
;
572 Grey
: out Character_Attribute_Set
;
573 Color
: out Color_Pair
)
575 function Menu_Grey
(Men
: Menu
) return Attributed_Character
;
576 pragma Import
(C
, Menu_Grey
, "menu_grey");
578 Grey
:= Menu_Grey
(Men
).Attr
;
579 Color
:= Menu_Grey
(Men
).Color
;
582 procedure Set_Pad_Character
(Men
: Menu
;
583 Pad
: Character := Space
)
585 function Set_Menu_Pad
(Men
: Menu
;
586 Ch
: C_Int
) return Eti_Error
;
587 pragma Import
(C
, Set_Menu_Pad
, "set_menu_pad");
590 Eti_Exception
(Set_Menu_Pad
(Men
, C_Int
(Character'Pos (Pad
))));
591 end Set_Pad_Character
;
593 procedure Pad_Character
(Men
: Menu
;
596 function Menu_Pad
(Men
: Menu
) return C_Int
;
597 pragma Import
(C
, Menu_Pad
, "menu_pad");
599 Pad
:= Character'Val (Menu_Pad
(Men
));
601 -------------------------------------------------------------------------------
602 procedure Set_Spacing
(Men
: Menu
;
603 Descr
: Column_Position
:= 0;
604 Row
: Line_Position
:= 0;
605 Col
: Column_Position
:= 0)
607 function Set_Spacing
(Men
: Menu
;
608 D
, R
, C
: C_Int
) return Eti_Error
;
609 pragma Import
(C
, Set_Spacing
, "set_menu_spacing");
612 Eti_Exception
(Set_Spacing
(Men
,
618 procedure Spacing
(Men
: Menu
;
619 Descr
: out Column_Position
;
620 Row
: out Line_Position
;
621 Col
: out Column_Position
)
623 type C_Int_Access
is access all C_Int
;
624 function Get_Spacing
(Men
: Menu
;
625 D
, R
, C
: C_Int_Access
) return Eti_Error
;
626 pragma Import
(C
, Get_Spacing
, "menu_spacing");
628 D
, R
, C
: aliased C_Int
;
630 Eti_Exception
(Get_Spacing
(Men
,
634 Descr
:= Column_Position
(D
);
635 Row
:= Line_Position
(R
);
636 Col
:= Column_Position
(C
);
638 -------------------------------------------------------------------------------
639 function Set_Pattern
(Men
: Menu
;
640 Text
: String) return Boolean
642 type Char_Ptr
is access all Interfaces
.C
.char
;
643 function Set_Pattern
(Men
: Menu
;
644 Pattern
: Char_Ptr
) return Eti_Error
;
645 pragma Import
(C
, Set_Pattern
, "set_menu_pattern");
647 S
: char_array
(0 .. Text
'Length);
652 Res
:= Set_Pattern
(Men
, S
(S
'First)'Access);
662 procedure Pattern
(Men
: Menu
;
665 function Get_Pattern
(Men
: Menu
) return chars_ptr
;
666 pragma Import
(C
, Get_Pattern
, "menu_pattern");
668 Fill_String
(Get_Pattern
(Men
), Text
);
670 -------------------------------------------------------------------------------
671 procedure Set_Format
(Men
: Menu
;
673 Columns
: Column_Count
)
675 function Set_Menu_Fmt
(Men
: Menu
;
677 Col
: C_Int
) return Eti_Error
;
678 pragma Import
(C
, Set_Menu_Fmt
, "set_menu_format");
681 Eti_Exception
(Set_Menu_Fmt
(Men
,
687 procedure Format
(Men
: Menu
;
688 Lines
: out Line_Count
;
689 Columns
: out Column_Count
)
691 type C_Int_Access
is access all C_Int
;
692 function Menu_Fmt
(Men
: Menu
;
693 Y
, X
: C_Int_Access
) return Eti_Error
;
694 pragma Import
(C
, Menu_Fmt
, "menu_format");
696 L
, C
: aliased C_Int
;
698 Eti_Exception
(Menu_Fmt
(Men
, L
'Access, C
'Access));
699 Lines
:= Line_Count
(L
);
700 Columns
:= Column_Count
(C
);
702 -------------------------------------------------------------------------------
703 procedure Set_Item_Init_Hook
(Men
: Menu
;
704 Proc
: Menu_Hook_Function
)
706 function Set_Item_Init
(Men
: Menu
;
707 Proc
: Menu_Hook_Function
) return Eti_Error
;
708 pragma Import
(C
, Set_Item_Init
, "set_item_init");
711 Eti_Exception
(Set_Item_Init
(Men
, Proc
));
712 end Set_Item_Init_Hook
;
714 procedure Set_Item_Term_Hook
(Men
: Menu
;
715 Proc
: Menu_Hook_Function
)
717 function Set_Item_Term
(Men
: Menu
;
718 Proc
: Menu_Hook_Function
) return Eti_Error
;
719 pragma Import
(C
, Set_Item_Term
, "set_item_term");
722 Eti_Exception
(Set_Item_Term
(Men
, Proc
));
723 end Set_Item_Term_Hook
;
725 procedure Set_Menu_Init_Hook
(Men
: Menu
;
726 Proc
: Menu_Hook_Function
)
728 function Set_Menu_Init
(Men
: Menu
;
729 Proc
: Menu_Hook_Function
) return Eti_Error
;
730 pragma Import
(C
, Set_Menu_Init
, "set_menu_init");
733 Eti_Exception
(Set_Menu_Init
(Men
, Proc
));
734 end Set_Menu_Init_Hook
;
736 procedure Set_Menu_Term_Hook
(Men
: Menu
;
737 Proc
: Menu_Hook_Function
)
739 function Set_Menu_Term
(Men
: Menu
;
740 Proc
: Menu_Hook_Function
) return Eti_Error
;
741 pragma Import
(C
, Set_Menu_Term
, "set_menu_term");
744 Eti_Exception
(Set_Menu_Term
(Men
, Proc
));
745 end Set_Menu_Term_Hook
;
747 function Get_Item_Init_Hook
(Men
: Menu
) return Menu_Hook_Function
749 function Item_Init
(Men
: Menu
) return Menu_Hook_Function
;
750 pragma Import
(C
, Item_Init
, "item_init");
752 return Item_Init
(Men
);
753 end Get_Item_Init_Hook
;
755 function Get_Item_Term_Hook
(Men
: Menu
) return Menu_Hook_Function
757 function Item_Term
(Men
: Menu
) return Menu_Hook_Function
;
758 pragma Import
(C
, Item_Term
, "item_term");
760 return Item_Term
(Men
);
761 end Get_Item_Term_Hook
;
763 function Get_Menu_Init_Hook
(Men
: Menu
) return Menu_Hook_Function
765 function Menu_Init
(Men
: Menu
) return Menu_Hook_Function
;
766 pragma Import
(C
, Menu_Init
, "menu_init");
768 return Menu_Init
(Men
);
769 end Get_Menu_Init_Hook
;
771 function Get_Menu_Term_Hook
(Men
: Menu
) return Menu_Hook_Function
773 function Menu_Term
(Men
: Menu
) return Menu_Hook_Function
;
774 pragma Import
(C
, Menu_Term
, "menu_term");
776 return Menu_Term
(Men
);
777 end Get_Menu_Term_Hook
;
778 -------------------------------------------------------------------------------
779 procedure Redefine
(Men
: Menu
;
780 Items
: Item_Array_Access
)
782 function Set_Items
(Men
: Menu
;
783 Items
: System
.Address
) return Eti_Error
;
784 pragma Import
(C
, Set_Items
, "set_menu_items");
787 pragma Assert
(Items
.all (Items
'Last) = Null_Item
);
788 if Items
.all (Items
'Last) /= Null_Item
then
789 raise Menu_Exception
;
791 Eti_Exception
(Set_Items
(Men
, Items
.all'Address));
795 function Item_Count
(Men
: Menu
) return Natural
797 function Count
(Men
: Menu
) return C_Int
;
798 pragma Import
(C
, Count
, "item_count");
800 return Natural (Count
(Men
));
803 function Items
(Men
: Menu
;
804 Index
: Positive) return Item
808 function C_Mitems
(Men
: Menu
) return Pointer
;
809 pragma Import
(C
, C_Mitems
, "menu_items");
811 P
: Pointer
:= C_Mitems
(Men
);
813 if P
= null or else Index
> Item_Count
(Men
) then
814 raise Menu_Exception
;
816 P
:= P
+ ptrdiff_t
(C_Int
(Index
) - 1);
821 -------------------------------------------------------------------------------
822 function Create
(Items
: Item_Array_Access
) return Menu
824 function Newmenu
(Items
: System
.Address
) return Menu
;
825 pragma Import
(C
, Newmenu
, "new_menu");
829 pragma Assert
(Items
.all (Items
'Last) = Null_Item
);
830 if Items
.all (Items
'Last) /= Null_Item
then
831 raise Menu_Exception
;
833 M
:= Newmenu
(Items
.all'Address);
834 if M
= Null_Menu
then
835 raise Menu_Exception
;
841 procedure Delete
(Men
: in out Menu
)
843 function Free
(Men
: Menu
) return Eti_Error
;
844 pragma Import
(C
, Free
, "free_menu");
847 Eti_Exception
(Free
(Men
));
851 ------------------------------------------------------------------------------
852 function Driver
(Men
: Menu
;
853 Key
: Key_Code
) return Driver_Result
855 function Driver
(Men
: Menu
;
856 Key
: C_Int
) return Eti_Error
;
857 pragma Import
(C
, Driver
, "menu_driver");
859 R
: constant Eti_Error
:= Driver
(Men
, C_Int
(Key
));
862 when E_Unknown_Command
=>
863 return Unknown_Request
;
866 when E_Request_Denied | E_Not_Selectable
=>
867 return Request_Denied
;
874 procedure Free
(IA
: in out Item_Array_Access
;
875 Free_Items
: Boolean := False)
877 procedure Release
is new Ada
.Unchecked_Deallocation
878 (Item_Array
, Item_Array_Access
);
880 if IA
/= null and then Free_Items
then
881 for I
in IA
'First .. (IA
'Last - 1) loop
882 if IA
.all (I
) /= Null_Item
then
890 -------------------------------------------------------------------------------
891 function Default_Menu_Options
return Menu_Option_Set
894 return Get_Options
(Null_Menu
);
895 end Default_Menu_Options
;
897 function Default_Item_Options
return Item_Option_Set
900 return Get_Options
(Null_Item
);
901 end Default_Item_Options
;
902 -------------------------------------------------------------------------------
904 end Terminal_Interface
.Curses
.Menus
;