1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Menus --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998 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 -- Binding Version 01.00
40 ------------------------------------------------------------------------------
41 with Ada.Unchecked_Deallocation;
42 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
44 with Interfaces.C; use Interfaces.C;
45 with Interfaces.C.Strings; use Interfaces.C.Strings;
46 with Interfaces.C.Pointers;
48 with Ada.Unchecked_Conversion;
50 package body Terminal_Interface.Curses.Menus is
52 type C_Item_Array is array (Natural range <>) of aliased Item;
53 package I_Array is new
54 Interfaces.C.Pointers (Natural, Item, C_Item_Array, Null_Item);
56 use type System.Bit_Order;
57 subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
59 function MOS_2_CInt is new
60 Ada.Unchecked_Conversion (Menu_Option_Set,
63 function CInt_2_MOS is new
64 Ada.Unchecked_Conversion (C_Int,
67 function IOS_2_CInt is new
68 Ada.Unchecked_Conversion (Item_Option_Set,
71 function CInt_2_IOS is new
72 Ada.Unchecked_Conversion (C_Int,
75 ------------------------------------------------------------------------------
76 procedure Request_Name (Key : in Menu_Request_Code;
79 function Request_Name (Key : C_Int) return chars_ptr;
80 pragma Import (C, Request_Name, "menu_request_name");
82 Fill_String (Request_Name (C_Int (Key)), Name);
85 function Request_Name (Key : Menu_Request_Code) return String
87 function Request_Name (Key : C_Int) return chars_ptr;
88 pragma Import (C, Request_Name, "menu_request_name");
90 return Fill_String (Request_Name (C_Int (Key)));
93 function Create (Name : String;
94 Description : String := "") return Item
96 type Char_Ptr is access all Interfaces.C.char;
97 function Newitem (Name, Desc : Char_Ptr) return Item;
98 pragma Import (C, Newitem, "new_item");
100 type Name_String is new char_array (0 .. Name'Length);
101 type Name_String_Ptr is access Name_String;
102 pragma Controlled (Name_String_Ptr);
104 type Desc_String is new char_array (0 .. Description'Length);
105 type Desc_String_Ptr is access Desc_String;
106 pragma Controlled (Desc_String_Ptr);
108 Name_Str : Name_String_Ptr := new Name_String;
109 Desc_Str : Desc_String_Ptr := new Desc_String;
110 Name_Len, Desc_Len : size_t;
113 To_C (Name, Name_Str.all, Name_Len);
114 To_C (Description, Desc_Str.all, Desc_Len);
115 Result := Newitem (Name_Str.all (Name_Str.all'First)'Access,
116 Desc_Str.all (Desc_Str.all'First)'Access);
117 if Result = Null_Item then
118 raise Eti_System_Error;
123 procedure Delete (Itm : in out Item)
125 function Descname (Itm : Item) return chars_ptr;
126 pragma Import (C, Descname, "item_description");
127 function Itemname (Itm : Item) return chars_ptr;
128 pragma Import (C, Itemname, "item_name");
130 function Freeitem (Itm : Item) return C_Int;
131 pragma Import (C, Freeitem, "free_item");
136 Ptr := Descname (Itm);
137 if Ptr /= Null_Ptr then
138 Interfaces.C.Strings.Free (Ptr);
140 Ptr := Itemname (Itm);
141 if Ptr /= Null_Ptr then
142 Interfaces.C.Strings.Free (Ptr);
144 Res := Freeitem (Itm);
150 -------------------------------------------------------------------------------
151 procedure Set_Value (Itm : in Item;
152 Value : in Boolean := True)
154 function Set_Item_Val (Itm : Item;
155 Val : C_Int) return C_Int;
156 pragma Import (C, Set_Item_Val, "set_item_value");
158 Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));
165 function Value (Itm : Item) return Boolean
167 function Item_Val (Itm : Item) return C_Int;
168 pragma Import (C, Item_Val, "item_value");
170 if Item_Val (Itm) = Curses_False then
177 -------------------------------------------------------------------------------
178 function Visible (Itm : Item) return Boolean
180 function Item_Vis (Itm : Item) return C_Int;
181 pragma Import (C, Item_Vis, "item_visible");
183 if Item_Vis (Itm) = Curses_False then
189 -------------------------------------------------------------------------------
190 procedure Set_Options (Itm : in Item;
191 Options : in Item_Option_Set)
193 function Set_Item_Opts (Itm : Item;
194 Opt : C_Int) return C_Int;
195 pragma Import (C, Set_Item_Opts, "set_item_opts");
197 Opt : C_Int := IOS_2_CInt (Options);
200 Res := Set_Item_Opts (Itm, Opt);
206 procedure Switch_Options (Itm : in Item;
207 Options : in Item_Option_Set;
208 On : Boolean := True)
210 function Item_Opts_On (Itm : Item;
211 Opt : C_Int) return C_Int;
212 pragma Import (C, Item_Opts_On, "item_opts_on");
213 function Item_Opts_Off (Itm : Item;
214 Opt : C_Int) return C_Int;
215 pragma Import (C, Item_Opts_Off, "item_opts_off");
217 Opt : C_Int := IOS_2_CInt (Options);
221 Err := Item_Opts_On (Itm, Opt);
223 Err := Item_Opts_Off (Itm, Opt);
230 procedure Get_Options (Itm : in Item;
231 Options : out Item_Option_Set)
233 function Item_Opts (Itm : Item) return C_Int;
234 pragma Import (C, Item_Opts, "item_opts");
236 Res : C_Int := Item_Opts (Itm);
238 Options := CInt_2_IOS (Res);
241 function Get_Options (Itm : Item := Null_Item) return Item_Option_Set
243 Ios : Item_Option_Set;
245 Get_Options (Itm, Ios);
248 -------------------------------------------------------------------------------
249 procedure Name (Itm : in Item;
252 function Itemname (Itm : Item) return chars_ptr;
253 pragma Import (C, Itemname, "item_name");
255 Fill_String (Itemname (Itm), Name);
258 function Name (Itm : in Item) return String
260 function Itemname (Itm : Item) return chars_ptr;
261 pragma Import (C, Itemname, "item_name");
263 return Fill_String (Itemname (Itm));
266 procedure Description (Itm : in Item;
267 Description : out String)
269 function Descname (Itm : Item) return chars_ptr;
270 pragma Import (C, Descname, "item_description");
272 Fill_String (Descname (Itm), Description);
275 function Description (Itm : in Item) return String
277 function Descname (Itm : Item) return chars_ptr;
278 pragma Import (C, Descname, "item_description");
280 return Fill_String (Descname (Itm));
282 -------------------------------------------------------------------------------
283 procedure Set_Current (Men : in Menu;
286 function Set_Curr_Item (Men : Menu;
287 Itm : Item) return C_Int;
288 pragma Import (C, Set_Curr_Item, "set_current_item");
290 Res : constant Eti_Error := Set_Curr_Item (Men, Itm);
297 function Current (Men : Menu) return Item
299 function Curr_Item (Men : Menu) return Item;
300 pragma Import (C, Curr_Item, "current_item");
302 Res : constant Item := Curr_Item (Men);
304 if Res = Null_Item then
305 raise Menu_Exception;
310 procedure Set_Top_Row (Men : in Menu;
311 Line : in Line_Position)
313 function Set_Toprow (Men : Menu;
314 Line : C_Int) return C_Int;
315 pragma Import (C, Set_Toprow, "set_top_row");
317 Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));
324 function Top_Row (Men : Menu) return Line_Position
326 function Toprow (Men : Menu) return C_Int;
327 pragma Import (C, Toprow, "top_row");
329 Res : constant C_Int := Toprow (Men);
331 if Res = Curses_Err then
332 raise Menu_Exception;
334 return Line_Position (Res);
337 function Get_Index (Itm : Item) return Positive
339 function Get_Itemindex (Itm : Item) return C_Int;
340 pragma Import (C, Get_Itemindex, "item_index");
342 Res : constant C_Int := Get_Itemindex (Itm);
344 if Res = Curses_Err then
345 raise Menu_Exception;
347 return Positive (Natural (Res) + Positive'First);
349 -------------------------------------------------------------------------------
350 procedure Post (Men : in Menu;
351 Post : in Boolean := True)
353 function M_Post (Men : Menu) return C_Int;
354 pragma Import (C, M_Post, "post_menu");
355 function M_Unpost (Men : Menu) return C_Int;
356 pragma Import (C, M_Unpost, "unpost_menu");
363 Res := M_Unpost (Men);
369 -------------------------------------------------------------------------------
370 procedure Set_Options (Men : in Menu;
371 Options : in Menu_Option_Set)
373 function Set_Menu_Opts (Men : Menu;
374 Opt : C_Int) return C_Int;
375 pragma Import (C, Set_Menu_Opts, "set_menu_opts");
377 Opt : C_Int := MOS_2_CInt (Options);
380 Res := Set_Menu_Opts (Men, Opt);
386 procedure Switch_Options (Men : in Menu;
387 Options : in Menu_Option_Set;
388 On : in Boolean := True)
390 function Menu_Opts_On (Men : Menu;
391 Opt : C_Int) return C_Int;
392 pragma Import (C, Menu_Opts_On, "menu_opts_on");
393 function Menu_Opts_Off (Men : Menu;
394 Opt : C_Int) return C_Int;
395 pragma Import (C, Menu_Opts_Off, "menu_opts_off");
397 Opt : C_Int := MOS_2_CInt (Options);
401 Err := Menu_Opts_On (Men, Opt);
403 Err := Menu_Opts_Off (Men, Opt);
410 procedure Get_Options (Men : in Menu;
411 Options : out Menu_Option_Set)
413 function Menu_Opts (Men : Menu) return C_Int;
414 pragma Import (C, Menu_Opts, "menu_opts");
416 Res : C_Int := Menu_Opts (Men);
418 Options := CInt_2_MOS (Res);
421 function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
423 Mos : Menu_Option_Set;
425 Get_Options (Men, Mos);
428 -------------------------------------------------------------------------------
429 procedure Set_Window (Men : in Menu;
432 function Set_Menu_Win (Men : Menu;
433 Win : Window) return C_Int;
434 pragma Import (C, Set_Menu_Win, "set_menu_win");
436 Res : constant Eti_Error := Set_Menu_Win (Men, Win);
443 function Get_Window (Men : Menu) return Window
445 function Menu_Win (Men : Menu) return Window;
446 pragma Import (C, Menu_Win, "menu_win");
448 W : constant Window := Menu_Win (Men);
453 procedure Set_Sub_Window (Men : in Menu;
456 function Set_Menu_Sub (Men : Menu;
457 Win : Window) return C_Int;
458 pragma Import (C, Set_Menu_Sub, "set_menu_sub");
460 Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
467 function Get_Sub_Window (Men : Menu) return Window
469 function Menu_Sub (Men : Menu) return Window;
470 pragma Import (C, Menu_Sub, "menu_sub");
472 W : constant Window := Menu_Sub (Men);
477 procedure Scale (Men : in Menu;
478 Lines : out Line_Count;
479 Columns : out Column_Count)
481 type C_Int_Access is access all C_Int;
482 function M_Scale (Men : Menu;
483 Yp, Xp : C_Int_Access) return C_Int;
484 pragma Import (C, M_Scale, "scale_menu");
486 X, Y : aliased C_Int;
487 Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
492 Lines := Line_Count (Y);
493 Columns := Column_Count (X);
495 -------------------------------------------------------------------------------
496 procedure Position_Cursor (Men : Menu)
498 function Pos_Menu_Cursor (Men : Menu) return C_Int;
499 pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");
501 Res : constant Eti_Error := Pos_Menu_Cursor (Men);
508 -------------------------------------------------------------------------------
509 procedure Set_Mark (Men : in Menu;
512 type Char_Ptr is access all Interfaces.C.char;
513 function Set_Mark (Men : Menu;
514 Mark : Char_Ptr) return C_Int;
515 pragma Import (C, Set_Mark, "set_menu_mark");
517 Txt : char_array (0 .. Mark'Length);
521 To_C (Mark, Txt, Len);
522 Res := Set_Mark (Men, Txt (Txt'First)'Access);
528 procedure Mark (Men : in Menu;
531 function Get_Menu_Mark (Men : Menu) return chars_ptr;
532 pragma Import (C, Get_Menu_Mark, "menu_mark");
534 Fill_String (Get_Menu_Mark (Men), Mark);
537 function Mark (Men : Menu) return String
539 function Get_Menu_Mark (Men : Menu) return chars_ptr;
540 pragma Import (C, Get_Menu_Mark, "menu_mark");
542 return Fill_String (Get_Menu_Mark (Men));
545 -------------------------------------------------------------------------------
546 procedure Set_Foreground
548 Fore : in Character_Attribute_Set := Normal_Video;
549 Color : in Color_Pair := Color_Pair'First)
551 function Set_Menu_Fore (Men : Menu;
552 Attr : C_Chtype) return C_Int;
553 pragma Import (C, Set_Menu_Fore, "set_menu_fore");
555 Ch : constant Attributed_Character := (Ch => Character'First,
558 Res : constant Eti_Error := Set_Menu_Fore (Men, AttrChar_To_Chtype (Ch));
565 procedure Foreground (Men : in Menu;
566 Fore : out Character_Attribute_Set)
568 function Menu_Fore (Men : Menu) return C_Chtype;
569 pragma Import (C, Menu_Fore, "menu_fore");
571 Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
574 procedure Foreground (Men : in Menu;
575 Fore : out Character_Attribute_Set;
576 Color : out Color_Pair)
578 function Menu_Fore (Men : Menu) return C_Chtype;
579 pragma Import (C, Menu_Fore, "menu_fore");
581 Fore := Chtype_To_AttrChar (Menu_Fore (Men)).Attr;
582 Color := Chtype_To_AttrChar (Menu_Fore (Men)).Color;
585 procedure Set_Background
587 Back : in Character_Attribute_Set := Normal_Video;
588 Color : in Color_Pair := Color_Pair'First)
590 function Set_Menu_Back (Men : Menu;
591 Attr : C_Chtype) return C_Int;
592 pragma Import (C, Set_Menu_Back, "set_menu_back");
594 Ch : constant Attributed_Character := (Ch => Character'First,
597 Res : constant Eti_Error := Set_Menu_Back (Men, AttrChar_To_Chtype (Ch));
604 procedure Background (Men : in Menu;
605 Back : out Character_Attribute_Set)
607 function Menu_Back (Men : Menu) return C_Chtype;
608 pragma Import (C, Menu_Back, "menu_back");
610 Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
613 procedure Background (Men : in Menu;
614 Back : out Character_Attribute_Set;
615 Color : out Color_Pair)
617 function Menu_Back (Men : Menu) return C_Chtype;
618 pragma Import (C, Menu_Back, "menu_back");
620 Back := Chtype_To_AttrChar (Menu_Back (Men)).Attr;
621 Color := Chtype_To_AttrChar (Menu_Back (Men)).Color;
624 procedure Set_Grey (Men : in Menu;
625 Grey : in Character_Attribute_Set := Normal_Video;
626 Color : in Color_Pair := Color_Pair'First)
628 function Set_Menu_Grey (Men : Menu;
629 Attr : C_Chtype) return C_Int;
630 pragma Import (C, Set_Menu_Grey, "set_menu_grey");
632 Ch : constant Attributed_Character := (Ch => Character'First,
636 Res : constant Eti_Error := Set_Menu_Grey (Men, AttrChar_To_Chtype (Ch));
643 procedure Grey (Men : in Menu;
644 Grey : out Character_Attribute_Set)
646 function Menu_Grey (Men : Menu) return C_Chtype;
647 pragma Import (C, Menu_Grey, "menu_grey");
649 Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
652 procedure Grey (Men : in Menu;
653 Grey : out Character_Attribute_Set;
654 Color : out Color_Pair)
656 function Menu_Grey (Men : Menu) return C_Chtype;
657 pragma Import (C, Menu_Grey, "menu_grey");
659 Grey := Chtype_To_AttrChar (Menu_Grey (Men)).Attr;
660 Color := Chtype_To_AttrChar (Menu_Grey (Men)).Color;
663 procedure Set_Pad_Character (Men : in Menu;
664 Pad : in Character := Space)
666 function Set_Menu_Pad (Men : Menu;
667 Ch : C_Int) return C_Int;
668 pragma Import (C, Set_Menu_Pad, "set_menu_pad");
670 Res : constant Eti_Error := Set_Menu_Pad (Men,
671 C_Int (Character'Pos (Pad)));
676 end Set_Pad_Character;
678 procedure Pad_Character (Men : in Menu;
681 function Menu_Pad (Men : Menu) return C_Int;
682 pragma Import (C, Menu_Pad, "menu_pad");
684 Pad := Character'Val (Menu_Pad (Men));
686 -------------------------------------------------------------------------------
687 procedure Set_Spacing (Men : in Menu;
688 Descr : in Column_Position := 0;
689 Row : in Line_Position := 0;
690 Col : in Column_Position := 0)
692 function Set_Spacing (Men : Menu;
693 D, R, C : C_Int) return C_Int;
694 pragma Import (C, Set_Spacing, "set_menu_spacing");
696 Res : constant Eti_Error := Set_Spacing (Men,
706 procedure Spacing (Men : in Menu;
707 Descr : out Column_Position;
708 Row : out Line_Position;
709 Col : out Column_Position)
711 type C_Int_Access is access all C_Int;
712 function Get_Spacing (Men : Menu;
713 D, R, C : C_Int_Access) return C_Int;
714 pragma Import (C, Get_Spacing, "menu_spacing");
716 D, R, C : aliased C_Int;
717 Res : constant Eti_Error := Get_Spacing (Men,
725 Descr := Column_Position (D);
726 Row := Line_Position (R);
727 Col := Column_Position (C);
730 -------------------------------------------------------------------------------
731 function Set_Pattern (Men : Menu;
732 Text : String) return Boolean
734 type Char_Ptr is access all Interfaces.C.char;
735 function Set_Pattern (Men : Menu;
736 Pattern : Char_Ptr) return C_Int;
737 pragma Import (C, Set_Pattern, "set_menu_pattern");
739 S : char_array (0 .. Text'Length);
744 Res := Set_Pattern (Men, S (S'First)'Access);
746 when E_No_Match => return False;
747 when E_Ok => return True;
754 procedure Pattern (Men : in Menu;
757 function Get_Pattern (Men : Menu) return chars_ptr;
758 pragma Import (C, Get_Pattern, "menu_pattern");
760 Fill_String (Get_Pattern (Men), Text);
762 -------------------------------------------------------------------------------
763 procedure Set_Format (Men : in Menu;
764 Lines : in Line_Count;
765 Columns : in Column_Count)
767 function Set_Menu_Fmt (Men : Menu;
769 Col : C_Int) return C_Int;
770 pragma Import (C, Set_Menu_Fmt, "set_menu_format");
772 Res : constant Eti_Error := Set_Menu_Fmt (Men,
781 procedure Format (Men : in Menu;
782 Lines : out Line_Count;
783 Columns : out Column_Count)
785 type C_Int_Access is access all C_Int;
786 function Menu_Fmt (Men : Menu;
787 Y, X : C_Int_Access) return C_Int;
788 pragma Import (C, Menu_Fmt, "menu_format");
790 L, C : aliased C_Int;
791 Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
796 Lines := Line_Count (L);
797 Columns := Column_Count (C);
800 -------------------------------------------------------------------------------
801 procedure Set_Item_Init_Hook (Men : in Menu;
802 Proc : in Menu_Hook_Function)
804 function Set_Item_Init (Men : Menu;
805 Proc : Menu_Hook_Function) return C_Int;
806 pragma Import (C, Set_Item_Init, "set_item_init");
808 Res : constant Eti_Error := Set_Item_Init (Men, Proc);
813 end Set_Item_Init_Hook;
815 procedure Set_Item_Term_Hook (Men : in Menu;
816 Proc : in Menu_Hook_Function)
818 function Set_Item_Term (Men : Menu;
819 Proc : Menu_Hook_Function) return C_Int;
820 pragma Import (C, Set_Item_Term, "set_item_term");
822 Res : constant Eti_Error := Set_Item_Term (Men, Proc);
827 end Set_Item_Term_Hook;
829 procedure Set_Menu_Init_Hook (Men : in Menu;
830 Proc : in Menu_Hook_Function)
832 function Set_Menu_Init (Men : Menu;
833 Proc : Menu_Hook_Function) return C_Int;
834 pragma Import (C, Set_Menu_Init, "set_menu_init");
836 Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
841 end Set_Menu_Init_Hook;
843 procedure Set_Menu_Term_Hook (Men : in Menu;
844 Proc : in Menu_Hook_Function)
846 function Set_Menu_Term (Men : Menu;
847 Proc : Menu_Hook_Function) return C_Int;
848 pragma Import (C, Set_Menu_Term, "set_menu_term");
850 Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
855 end Set_Menu_Term_Hook;
857 function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
859 function Item_Init (Men : Menu) return Menu_Hook_Function;
860 pragma Import (C, Item_Init, "item_init");
862 return Item_Init (Men);
863 end Get_Item_Init_Hook;
865 function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
867 function Item_Term (Men : Menu) return Menu_Hook_Function;
868 pragma Import (C, Item_Term, "item_term");
870 return Item_Term (Men);
871 end Get_Item_Term_Hook;
873 function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
875 function Menu_Init (Men : Menu) return Menu_Hook_Function;
876 pragma Import (C, Menu_Init, "menu_init");
878 return Menu_Init (Men);
879 end Get_Menu_Init_Hook;
881 function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
883 function Menu_Term (Men : Menu) return Menu_Hook_Function;
884 pragma Import (C, Menu_Term, "menu_term");
886 return Menu_Term (Men);
887 end Get_Menu_Term_Hook;
888 -------------------------------------------------------------------------------
889 procedure Redefine (Men : in Menu;
890 Items : in Item_Array_Access)
892 function Set_Items (Men : Menu;
893 Items : System.Address) return C_Int;
894 pragma Import (C, Set_Items, "set_menu_items");
898 pragma Assert (Items (Items'Last) = Null_Item);
899 if Items (Items'Last) /= Null_Item then
900 raise Menu_Exception;
902 Res := Set_Items (Men, Items.all'Address);
909 function Item_Count (Men : Menu) return Natural
911 function Count (Men : Menu) return C_Int;
912 pragma Import (C, Count, "item_count");
914 return Natural (Count (Men));
917 function Items (Men : Menu;
918 Index : Positive) return Item
922 function C_Mitems (Men : Menu) return Pointer;
923 pragma Import (C, C_Mitems, "menu_items");
925 P : Pointer := C_Mitems (Men);
927 if P = null or else Index not in 1 .. Item_Count (Men) then
928 raise Menu_Exception;
930 P := P + ptrdiff_t (C_Int (Index) - 1);
935 -------------------------------------------------------------------------------
936 function Create (Items : Item_Array_Access) return Menu
938 function Newmenu (Items : System.Address) return Menu;
939 pragma Import (C, Newmenu, "new_menu");
943 pragma Assert (Items (Items'Last) = Null_Item);
944 if Items (Items'Last) /= Null_Item then
945 raise Menu_Exception;
947 M := Newmenu (Items.all'Address);
948 if M = Null_Menu then
949 raise Menu_Exception;
955 procedure Delete (Men : in out Menu)
957 function Free (Men : Menu) return C_Int;
958 pragma Import (C, Free, "free_menu");
960 Res : constant Eti_Error := Free (Men);
968 ------------------------------------------------------------------------------
969 function Driver (Men : Menu;
970 Key : Key_Code) return Driver_Result
972 function Driver (Men : Menu;
973 Key : C_Int) return C_Int;
974 pragma Import (C, Driver, "menu_driver");
976 R : Eti_Error := Driver (Men, C_Int (Key));
980 when E_Unknown_Command => return Unknown_Request;
981 when E_No_Match => return No_Match;
982 when E_Request_Denied |
983 E_Not_Selectable => return Request_Denied;
991 procedure Free (IA : in out Item_Array_Access;
992 Free_Items : in Boolean := False)
994 procedure Release is new Ada.Unchecked_Deallocation
995 (Item_Array, Item_Array_Access);
997 if IA /= null and then Free_Items then
998 for I in IA'First .. (IA'Last - 1) loop
999 if (IA (I) /= Null_Item) then
1007 -------------------------------------------------------------------------------
1008 function Default_Menu_Options return Menu_Option_Set
1011 return Get_Options (Null_Menu);
1012 end Default_Menu_Options;
1014 function Default_Item_Options return Item_Option_Set
1017 return Get_Options (Null_Item);
1018 end Default_Item_Options;
1019 -------------------------------------------------------------------------------
1021 end Terminal_Interface.Curses.Menus;