ncurses 4.2
[ncurses.git] / Ada95 / ada_include / terminal_interface-curses-menus.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                           GNAT ncurses Binding                           --
4 --                                                                          --
5 --                      Terminal_Interface.Curses.Menus                     --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998 Free Software Foundation, Inc.                        --
11 --                                                                          --
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:                 --
19 --                                                                          --
20 -- The above copyright notice and this permission notice shall be included  --
21 -- in all copies or substantial portions of the Software.                   --
22 --                                                                          --
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.                               --
30 --                                                                          --
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       --
34 -- authorization.                                                           --
35 ------------------------------------------------------------------------------
36 --  Author: Juergen Pfeifer <Juergen.Pfeifer@T-Online.de> 1996
37 --  Version Control:
38 --  $Revision: 1.13 $
39 --  Binding Version 00.93
40 ------------------------------------------------------------------------------
41 with Ada.Unchecked_Deallocation;
42 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
43
44 with Interfaces.C; use Interfaces.C;
45 with Interfaces.C.Strings; use Interfaces.C.Strings;
46 with Terminal_Interface.Curses;
47
48 with Unchecked_Conversion;
49
50 package body Terminal_Interface.Curses.Menus is
51
52    use type System.Bit_Order;
53    subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
54
55    function MOS_2_CInt is new
56      Unchecked_Conversion (Menu_Option_Set,
57                            C_Int);
58
59    function CInt_2_MOS is new
60      Unchecked_Conversion (C_Int,
61                            Menu_Option_Set);
62
63    function IOS_2_CInt is new
64      Unchecked_Conversion (Item_Option_Set,
65                            C_Int);
66
67    function CInt_2_IOS is new
68      Unchecked_Conversion (C_Int,
69                            Item_Option_Set);
70
71 ------------------------------------------------------------------------------
72    procedure Request_Name (Key  : in Menu_Request_Code;
73                            Name : out String)
74    is
75       function Request_Name (Key : C_Int) return chars_ptr;
76       pragma Import (C, Request_Name, "menu_request_name");
77    begin
78       Fill_String (Request_Name (C_Int (Key)), Name);
79    end Request_Name;
80
81    function Request_Name (Key : Menu_Request_Code) return String
82    is
83       function Request_Name (Key : C_Int) return chars_ptr;
84       pragma Import (C, Request_Name, "menu_request_name");
85    begin
86       return Fill_String (Request_Name (C_Int (Key)));
87    end Request_Name;
88
89    function Create (Name        : String;
90                     Description : String := "") return Item
91    is
92       type Char_Ptr is access all Interfaces.C.Char;
93       function Newitem (Name, Desc : Char_Ptr) return Item;
94       pragma Import (C, Newitem, "new_item");
95
96       type Name_String is new char_array (0 .. Name'Length);
97       type Name_String_Ptr is access Name_String;
98       pragma Controlled (Name_String_Ptr);
99
100       type Desc_String is new char_array (0 .. Description'Length);
101       type Desc_String_Ptr is access Desc_String;
102       pragma Controlled (Desc_String_Ptr);
103
104       Name_Str : Name_String_Ptr := new Name_String;
105       Desc_Str : Desc_String_Ptr := new Desc_String;
106       Name_Len, Desc_Len : size_t;
107       Result : Item;
108    begin
109       To_C (Name, Name_Str.all, Name_Len);
110       To_C (Description, Desc_Str.all, Desc_Len);
111       Result := Newitem (Name_Str.all (Name_Str.all'First)'Access,
112                          Desc_Str.all (Desc_Str.all'First)'Access);
113       if Result = Null_Item then
114          raise Eti_System_Error;
115       end if;
116       return Result;
117    end Create;
118
119    procedure Delete (Itm : in out Item)
120    is
121       function Descname (Itm  : Item) return chars_ptr;
122       pragma Import (C, Descname, "item_description");
123       function Itemname (Itm  : Item) return chars_ptr;
124       pragma Import (C, Itemname, "item_name");
125
126       function Freeitem (Itm : Item) return C_Int;
127       pragma Import (C, Freeitem, "free_item");
128
129       Res : Eti_Error;
130       Ptr : chars_ptr;
131    begin
132       Ptr := Descname (Itm);
133       if Ptr /= Null_Ptr then
134          Interfaces.C.Strings.Free (Ptr);
135       end if;
136       Ptr := Itemname (Itm);
137       if Ptr /= Null_Ptr then
138          Interfaces.C.Strings.Free (Ptr);
139       end if;
140       Res := Freeitem (Itm);
141       if Res /= E_Ok then
142          Eti_Exception (Res);
143       end if;
144       Itm := Null_Item;
145    end Delete;
146 -------------------------------------------------------------------------------
147    procedure Set_Value (Itm   : in Item;
148                         Value : in Boolean := True)
149    is
150       function Set_Item_Val (Itm : Item;
151                              Val : C_Int) return C_Int;
152       pragma Import (C, Set_Item_Val, "set_item_value");
153
154       Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));
155    begin
156       if  Res /= E_Ok then
157          Eti_Exception (Res);
158       end if;
159    end Set_Value;
160
161    function Value (Itm : Item) return Boolean
162    is
163       function Item_Val (Itm : Item) return C_Int;
164       pragma Import (C, Item_Val, "item_value");
165    begin
166       if Item_Val (Itm) = Curses_False then
167          return False;
168       else
169          return True;
170       end if;
171    end Value;
172
173 -------------------------------------------------------------------------------
174    function Visible (Itm : Item) return Boolean
175    is
176       function Item_Vis (Itm : Item) return C_Int;
177       pragma Import (C, Item_Vis, "item_visible");
178    begin
179       if Item_Vis (Itm) = Curses_False then
180          return False;
181       else
182          return True;
183       end if;
184    end Visible;
185 -------------------------------------------------------------------------------
186    procedure Normalize_Item_Options (Options : in out C_Int);
187    pragma Import (C, Normalize_Item_Options, "_nc_ada_normalize_item_opts");
188
189    procedure Set_Options (Itm     : in Item;
190                           Options : in Item_Option_Set)
191    is
192       function Set_Item_Opts (Itm : Item;
193                               Opt : C_Int) return C_Int;
194       pragma Import (C, Set_Item_Opts, "set_item_opts");
195
196       Opt : C_Int := IOS_2_CInt (Options);
197       Res : Eti_Error;
198    begin
199       Normalize_Item_Options (Opt);
200       Res := Set_Item_Opts (Itm, Opt);
201       if Res /= E_Ok then
202          Eti_Exception (Res);
203       end if;
204    end Set_Options;
205
206    procedure Switch_Options (Itm     : in Item;
207                              Options : in Item_Option_Set;
208                              On      : Boolean := True)
209    is
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");
216
217       Opt : C_Int := IOS_2_CInt (Options);
218       Err : Eti_Error;
219    begin
220       Normalize_Item_Options (Opt);
221       if On then
222          Err := Item_Opts_On (Itm, Opt);
223       else
224          Err := Item_Opts_Off (Itm, Opt);
225       end if;
226       if Err /= E_Ok then
227          Eti_Exception (Err);
228       end if;
229    end Switch_Options;
230
231    procedure Get_Options (Itm     : in  Item;
232                           Options : out Item_Option_Set)
233    is
234       function Item_Opts (Itm : Item) return C_Int;
235       pragma Import (C, Item_Opts, "item_opts");
236
237       Res : C_Int := Item_Opts (Itm);
238    begin
239       Normalize_Item_Options (Res);
240       Options := CInt_2_IOS (Res);
241    end Get_Options;
242
243    function Get_Options (Itm : Item := Null_Item) return Item_Option_Set
244    is
245       Ios : Item_Option_Set;
246    begin
247       Get_Options (Itm, Ios);
248       return Ios;
249    end Get_Options;
250 -------------------------------------------------------------------------------
251    procedure Name (Itm  : in Item;
252                    Name : out String)
253    is
254       function Itemname (Itm : Item) return chars_ptr;
255       pragma Import (C, Itemname, "item_name");
256    begin
257       Fill_String (Itemname (Itm), Name);
258    end Name;
259
260    function Name (Itm : in Item) return String
261    is
262       function Itemname (Itm : Item) return chars_ptr;
263       pragma Import (C, Itemname, "item_name");
264    begin
265       return Fill_String (Itemname (Itm));
266    end Name;
267
268    procedure Description (Itm         : in Item;
269                           Description : out String)
270    is
271       function Descname (Itm  : Item) return chars_ptr;
272       pragma Import (C, Descname, "item_description");
273    begin
274       Fill_String (Descname (Itm), Description);
275    end Description;
276
277    function Description (Itm : in Item) return String
278    is
279       function Descname (Itm  : Item) return chars_ptr;
280       pragma Import (C, Descname, "item_description");
281    begin
282       return Fill_String (Descname (Itm));
283    end Description;
284 -------------------------------------------------------------------------------
285    procedure Set_Current (Men : in Menu;
286                           Itm : in Item)
287    is
288       function Set_Curr_Item (Men : Menu;
289                               Itm : Item) return C_Int;
290       pragma Import (C, Set_Curr_Item, "set_current_item");
291
292       Res : constant Eti_Error := Set_Curr_Item (Men, Itm);
293    begin
294       if Res /= E_Ok then
295          Eti_Exception (Res);
296       end if;
297    end Set_Current;
298
299    function Current (Men : Menu) return Item
300    is
301       function Curr_Item (Men : Menu) return Item;
302       pragma Import (C, Curr_Item, "current_item");
303
304       Res : constant Item := Curr_Item (Men);
305    begin
306       if Res = Null_Item then
307          raise Menu_Exception;
308       end if;
309       return Res;
310    end Current;
311
312    procedure Set_Top_Row (Men  : in Menu;
313                           Line : in Line_Position)
314    is
315       function Set_Toprow (Men  : Menu;
316                            Line : C_Int) return C_Int;
317       pragma Import (C, Set_Toprow, "set_top_row");
318
319       Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));
320    begin
321       if  Res /= E_Ok then
322          Eti_Exception (Res);
323       end if;
324    end Set_Top_Row;
325
326    function Top_Row (Men : Menu) return Line_Position
327    is
328       function Toprow (Men : Menu) return C_Int;
329       pragma Import (C, Toprow, "top_row");
330
331       Res : constant C_Int := Toprow (Men);
332    begin
333       if Res = Curses_Err then
334          raise Menu_Exception;
335       end if;
336       return Line_Position (Res);
337    end Top_Row;
338
339    function Get_Index (Itm : Item) return Positive
340    is
341       function Get_Itemindex (Itm : Item) return C_Int;
342       pragma Import (C, Get_Itemindex, "item_index");
343
344       Res : constant C_Int := Get_Itemindex (Itm);
345    begin
346       if Res = Curses_Err then
347          raise Menu_Exception;
348       end if;
349       return Positive (Natural (Res) + Positive'First);
350    end Get_Index;
351 -------------------------------------------------------------------------------
352    procedure Post (Men  : in Menu;
353                    Post : in Boolean := True)
354    is
355       function M_Post (Men : Menu) return C_Int;
356       pragma Import (C, M_Post, "post_menu");
357       function M_Unpost (Men : Menu) return C_Int;
358       pragma Import (C, M_Unpost, "unpost_menu");
359
360       Res : Eti_Error;
361    begin
362       if Post then
363          Res := M_Post (Men);
364       else
365          Res := M_Unpost (Men);
366       end if;
367       if Res /= E_Ok then
368          Eti_Exception (Res);
369       end if;
370    end Post;
371 -------------------------------------------------------------------------------
372    procedure Normalize_Menu_Options (Options : in out C_Int);
373    pragma Import (C, Normalize_Menu_Options, "_nc_ada_normalize_menu_opts");
374
375    procedure Set_Options (Men     : in Menu;
376                           Options : in Menu_Option_Set)
377    is
378       function Set_Menu_Opts (Men : Menu;
379                               Opt : C_Int) return C_Int;
380       pragma Import (C, Set_Menu_Opts, "set_menu_opts");
381
382       Opt : C_Int := MOS_2_CInt (Options);
383       Res : Eti_Error;
384    begin
385       Normalize_Menu_Options (Opt);
386       Res := Set_Menu_Opts (Men, Opt);
387       if  Res /= E_Ok then
388          Eti_Exception (Res);
389       end if;
390    end Set_Options;
391
392    procedure Switch_Options (Men     : in Menu;
393                              Options : in Menu_Option_Set;
394                              On      : in Boolean := True)
395    is
396       function Menu_Opts_On (Men : Menu;
397                              Opt : C_Int) return C_Int;
398       pragma Import (C, Menu_Opts_On, "menu_opts_on");
399       function Menu_Opts_Off (Men : Menu;
400                               Opt : C_Int) return C_Int;
401       pragma Import (C, Menu_Opts_Off, "menu_opts_off");
402
403       Opt : C_Int := MOS_2_CInt (Options);
404       Err : Eti_Error;
405    begin
406       Normalize_Menu_Options (Opt);
407       if On then
408          Err := Menu_Opts_On  (Men, Opt);
409       else
410          Err := Menu_Opts_Off (Men, Opt);
411       end if;
412       if Err /= E_Ok then
413          Eti_Exception (Err);
414       end if;
415    end Switch_Options;
416
417    procedure Get_Options (Men     : in  Menu;
418                                Options : out Menu_Option_Set)
419    is
420       function Menu_Opts (Men : Menu) return C_Int;
421       pragma Import (C, Menu_Opts, "menu_opts");
422
423       Res : C_Int := Menu_Opts (Men);
424    begin
425       Normalize_Menu_Options (Res);
426       Options := CInt_2_MOS (Res);
427    end Get_Options;
428
429    function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
430    is
431       Mos : Menu_Option_Set;
432    begin
433       Get_Options (Men, Mos);
434       return Mos;
435    end Get_Options;
436 -------------------------------------------------------------------------------
437    procedure Set_Window (Men : in Menu;
438                          Win : in Window)
439    is
440       function Set_Menu_Win (Men : Menu;
441                              Win : Window) return C_Int;
442       pragma Import (C, Set_Menu_Win, "set_menu_win");
443
444       Res : constant Eti_Error := Set_Menu_Win (Men, Win);
445    begin
446       if  Res /= E_Ok then
447          Eti_Exception (Res);
448       end if;
449    end Set_Window;
450
451    function Get_Window (Men : Menu) return Window
452    is
453       function Menu_Win (Men : Menu) return Window;
454       pragma Import (C, Menu_Win, "menu_win");
455
456       W : constant Window := Menu_Win (Men);
457    begin
458       return W;
459    end Get_Window;
460
461    procedure Set_Sub_Window (Men : in Menu;
462                              Win : in Window)
463    is
464       function Set_Menu_Sub (Men : Menu;
465                              Win : Window) return C_Int;
466       pragma Import (C, Set_Menu_Sub, "set_menu_sub");
467
468       Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
469    begin
470       if  Res /= E_Ok then
471          Eti_Exception (Res);
472       end if;
473    end Set_Sub_Window;
474
475    function Get_Sub_Window (Men : Menu) return Window
476    is
477       function Menu_Sub (Men : Menu) return Window;
478       pragma Import (C, Menu_Sub, "menu_sub");
479
480       W : constant Window := Menu_Sub (Men);
481    begin
482       return W;
483    end Get_Sub_Window;
484
485    procedure Scale (Men     : in Menu;
486                     Lines   : out Line_Count;
487                     Columns : out Column_Count)
488    is
489       type C_Int_Access is access all C_Int;
490       function M_Scale (Men    : Menu;
491                         Yp, Xp : C_Int_Access) return C_Int;
492       pragma Import (C, M_Scale, "scale_menu");
493
494       X, Y : aliased C_Int;
495       Res  : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
496    begin
497       if Res /= E_Ok then
498          Eti_Exception (Res);
499       end if;
500       Lines := Line_Count (Y);
501       Columns := Column_Count (X);
502    end Scale;
503 -------------------------------------------------------------------------------
504    procedure Position_Cursor (Men : Menu)
505    is
506       function Pos_Menu_Cursor (Men : Menu) return C_Int;
507       pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");
508
509       Res : constant Eti_Error := Pos_Menu_Cursor (Men);
510    begin
511       if  Res /= E_Ok then
512          Eti_Exception (Res);
513       end if;
514    end Position_Cursor;
515
516 -------------------------------------------------------------------------------
517    procedure Set_Mark (Men  : in Menu;
518                        Mark : in String)
519    is
520       type Char_Ptr is access all Interfaces.C.Char;
521       function Set_Mark (Men  : Menu;
522                          Mark : Char_Ptr) return C_Int;
523       pragma Import (C, Set_Mark, "set_menu_mark");
524
525       Txt : char_array (0 .. Mark'Length);
526       Len : size_t;
527       Res : Eti_Error;
528    begin
529       To_C (Mark, Txt, Len);
530       Res := Set_Mark (Men, Txt (Txt'First)'Access);
531       if Res /= E_Ok then
532          Eti_Exception (Res);
533       end if;
534    end Set_Mark;
535
536    procedure Mark (Men  : in  Menu;
537                    Mark : out String)
538    is
539       function Get_Menu_Mark (Men : Menu) return chars_ptr;
540       pragma Import (C, Get_Menu_Mark, "menu_mark");
541    begin
542       Fill_String (Get_Menu_Mark (Men), Mark);
543    end Mark;
544
545    function Mark (Men : Menu) return String
546    is
547       function Get_Menu_Mark (Men : Menu) return chars_ptr;
548       pragma Import (C, Get_Menu_Mark, "menu_mark");
549    begin
550       return Fill_String (Get_Menu_Mark (Men));
551    end Mark;
552
553 -------------------------------------------------------------------------------
554    procedure Set_Foreground
555      (Men   : in Menu;
556       Fore  : in Character_Attribute_Set := Normal_Video;
557       Color : in Color_Pair := Color_Pair'First)
558    is
559       function Set_Menu_Fore (Men  : Menu;
560                               Attr : C_Int) return C_Int;
561       pragma Import (C, Set_Menu_Fore, "set_menu_fore");
562
563       Ch : constant Attributed_Character := (Ch    => Character'First,
564                                              Color => Color,
565                                              Attr  => Fore);
566       Res : constant Eti_Error := Set_Menu_Fore (Men, Chtype_To_CInt (Ch));
567    begin
568       if  Res /= E_Ok then
569          Eti_Exception (Res);
570       end if;
571    end Set_Foreground;
572
573    procedure Foreground (Men  : in  Menu;
574                          Fore : out Character_Attribute_Set)
575    is
576       function Menu_Fore (Men : Menu) return C_Int;
577       pragma Import (C, Menu_Fore, "menu_fore");
578    begin
579       Fore := CInt_To_Chtype (Menu_Fore (Men)).Attr;
580    end Foreground;
581
582    procedure Foreground (Men   : in  Menu;
583                          Fore  : out Character_Attribute_Set;
584                          Color : out Color_Pair)
585    is
586       function Menu_Fore (Men : Menu) return C_Int;
587       pragma Import (C, Menu_Fore, "menu_fore");
588    begin
589       Fore  := CInt_To_Chtype (Menu_Fore (Men)).Attr;
590       Color := CInt_To_Chtype (Menu_Fore (Men)).Color;
591    end Foreground;
592
593    procedure Set_Background
594      (Men   : in Menu;
595       Back  : in Character_Attribute_Set := Normal_Video;
596       Color : in Color_Pair := Color_Pair'First)
597    is
598       function Set_Menu_Back (Men  : Menu;
599                               Attr : C_Int) return C_Int;
600       pragma Import (C, Set_Menu_Back, "set_menu_back");
601
602       Ch : constant Attributed_Character := (Ch    => Character'First,
603                                              Color => Color,
604                                              Attr  => Back);
605       Res : constant Eti_Error := Set_Menu_Back (Men, Chtype_To_CInt (Ch));
606    begin
607       if  Res /= E_Ok then
608          Eti_Exception (Res);
609       end if;
610    end Set_Background;
611
612    procedure Background (Men  : in  Menu;
613                          Back : out Character_Attribute_Set)
614    is
615       function Menu_Back (Men : Menu) return C_Int;
616       pragma Import (C, Menu_Back, "menu_back");
617    begin
618       Back := CInt_To_Chtype (Menu_Back (Men)).Attr;
619    end Background;
620
621    procedure Background (Men   : in  Menu;
622                          Back  : out Character_Attribute_Set;
623                          Color : out Color_Pair)
624    is
625       function Menu_Back (Men : Menu) return C_Int;
626       pragma Import (C, Menu_Back, "menu_back");
627    begin
628       Back  := CInt_To_Chtype (Menu_Back (Men)).Attr;
629       Color := CInt_To_Chtype (Menu_Back (Men)).Color;
630    end Background;
631
632    procedure Set_Grey (Men   : in Menu;
633                        Grey  : in Character_Attribute_Set := Normal_Video;
634                        Color : in Color_Pair := Color_Pair'First)
635    is
636       function Set_Menu_Grey (Men  : Menu;
637                               Attr : C_Int) return C_Int;
638       pragma Import (C, Set_Menu_Grey, "set_menu_grey");
639
640       Ch : constant Attributed_Character := (Ch    => Character'First,
641                                              Color => Color,
642                                              Attr  => Grey);
643
644       Res : constant Eti_Error := Set_Menu_Grey (Men, Chtype_To_CInt (Ch));
645    begin
646       if  Res /= E_Ok then
647          Eti_Exception (Res);
648       end if;
649    end Set_Grey;
650
651    procedure Grey (Men  : in  Menu;
652                    Grey : out Character_Attribute_Set)
653    is
654       function Menu_Grey (Men : Menu) return C_Int;
655       pragma Import (C, Menu_Grey, "menu_grey");
656    begin
657       Grey := CInt_To_Chtype (Menu_Grey (Men)).Attr;
658    end Grey;
659
660    procedure Grey (Men  : in  Menu;
661                    Grey : out Character_Attribute_Set;
662                    Color : out Color_Pair)
663    is
664       function Menu_Grey (Men : Menu) return C_Int;
665       pragma Import (C, Menu_Grey, "menu_grey");
666    begin
667       Grey  := CInt_To_Chtype (Menu_Grey (Men)).Attr;
668       Color := CInt_To_Chtype (Menu_Grey (Men)).Color;
669    end Grey;
670
671    procedure Set_Pad_Character (Men : in Menu;
672                                 Pad : in Character := Space)
673    is
674       function Set_Menu_Pad (Men : Menu;
675                              Ch  : C_Int) return C_Int;
676       pragma Import (C, Set_Menu_Pad, "set_menu_pad");
677
678       Res : constant Eti_Error := Set_Menu_Pad (Men,
679                                                 C_Int (Character'Pos (Pad)));
680    begin
681       if Res /= E_Ok then
682          Eti_Exception (Res);
683       end if;
684    end Set_Pad_Character;
685
686    procedure Pad_Character (Men : in  Menu;
687                             Pad : out Character)
688    is
689       function Menu_Pad (Men : Menu) return C_Int;
690       pragma Import (C, Menu_Pad, "menu_pad");
691    begin
692       Pad := Character'Val (Menu_Pad (Men));
693    end Pad_Character;
694 -------------------------------------------------------------------------------
695    procedure Set_Spacing (Men   : in Menu;
696                           Descr : in Column_Position := 0;
697                           Row   : in Line_Position   := 0;
698                           Col   : in Column_Position := 0)
699    is
700       function Set_Spacing (Men     : Menu;
701                             D, R, C : C_Int) return C_Int;
702       pragma Import (C, Set_Spacing, "set_menu_spacing");
703
704       Res : constant Eti_Error := Set_Spacing (Men,
705                                                C_Int (Descr),
706                                                C_Int (Row),
707                                                C_Int (Col));
708    begin
709       if Res /= E_Ok then
710          Eti_Exception (Res);
711       end if;
712    end Set_Spacing;
713
714    procedure Spacing (Men   : in Menu;
715                       Descr : out Column_Position;
716                       Row   : out Line_Position;
717                       Col   : out Column_Position)
718    is
719       type C_Int_Access is access all C_Int;
720       function Get_Spacing (Men     : Menu;
721                             D, R, C : C_Int_Access) return C_Int;
722       pragma Import (C, Get_Spacing, "menu_spacing");
723
724       D, R, C : aliased C_Int;
725       Res : constant Eti_Error := Get_Spacing (Men,
726                                                D'Access,
727                                                R'Access,
728                                                C'Access);
729    begin
730       if Res /= E_Ok then
731          Eti_Exception (Res);
732       else
733          Descr := Column_Position (D);
734          Row   := Line_Position (R);
735          Col   := Column_Position (C);
736       end if;
737    end Spacing;
738 -------------------------------------------------------------------------------
739    function Set_Pattern (Men  : Menu;
740                          Text : String) return Boolean
741    is
742       type Char_Ptr is access all Interfaces.C.Char;
743       function Set_Pattern (Men     : Menu;
744                             Pattern : Char_Ptr) return C_Int;
745       pragma Import (C, Set_Pattern, "set_menu_pattern");
746
747       S   : char_array (0 .. Text'Length);
748       L   : size_t;
749       Res : Eti_Error;
750    begin
751       To_C (Text, S, L);
752       Res := Set_Pattern (Men, S (S'First)'Access);
753       case Res is
754          when E_No_Match => return False;
755          when E_Ok       => return True;
756          when others =>
757             Eti_Exception (Res);
758             return False;
759       end case;
760    end Set_Pattern;
761
762    procedure Pattern (Men  : in  Menu;
763                       Text : out String)
764    is
765       function Get_Pattern (Men : Menu) return chars_ptr;
766       pragma Import (C, Get_Pattern, "menu_pattern");
767    begin
768       Fill_String (Get_Pattern (Men), Text);
769    end Pattern;
770 -------------------------------------------------------------------------------
771    procedure Set_Format (Men     : in Menu;
772                          Lines   : in Line_Count;
773                          Columns : in Column_Count)
774    is
775       function Set_Menu_Fmt (Men : Menu;
776                              Lin : C_Int;
777                              Col : C_Int) return C_Int;
778       pragma Import (C, Set_Menu_Fmt, "set_menu_format");
779
780       Res : constant Eti_Error := Set_Menu_Fmt (Men,
781                                                 C_Int (Lines),
782                                                 C_Int (Columns));
783    begin
784       if  Res /= E_Ok then
785          Eti_Exception (Res);
786       end if;
787    end Set_Format;
788
789    procedure Format (Men     : in  Menu;
790                      Lines   : out Line_Count;
791                      Columns : out Column_Count)
792    is
793       type C_Int_Access is access all C_Int;
794       function Menu_Fmt (Men  : Menu;
795                          Y, X : C_Int_Access) return C_Int;
796       pragma Import (C, Menu_Fmt, "menu_format");
797
798       L, C : aliased C_Int;
799       Res  : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
800    begin
801       if Res /= E_Ok then
802          Eti_Exception (Res);
803       else
804          Lines   := Line_Count (L);
805          Columns := Column_Count (C);
806       end if;
807    end Format;
808 -------------------------------------------------------------------------------
809    procedure Set_Item_Init_Hook (Men  : in Menu;
810                                  Proc : in Menu_Hook_Function)
811    is
812       function Set_Item_Init (Men  : Menu;
813                               Proc : Menu_Hook_Function) return C_Int;
814       pragma Import (C, Set_Item_Init, "set_item_init");
815
816       Res : constant Eti_Error := Set_Item_Init (Men, Proc);
817    begin
818       if  Res /= E_Ok then
819          Eti_Exception (Res);
820       end if;
821    end Set_Item_Init_Hook;
822
823    procedure Set_Item_Term_Hook (Men  : in Menu;
824                                  Proc : in Menu_Hook_Function)
825    is
826       function Set_Item_Term (Men  : Menu;
827                               Proc : Menu_Hook_Function) return C_Int;
828       pragma Import (C, Set_Item_Term, "set_item_term");
829
830       Res : constant Eti_Error := Set_Item_Term (Men, Proc);
831    begin
832       if Res /= E_Ok then
833          Eti_Exception (Res);
834       end if;
835    end Set_Item_Term_Hook;
836
837    procedure Set_Menu_Init_Hook (Men  : in Menu;
838                                  Proc : in Menu_Hook_Function)
839    is
840       function Set_Menu_Init (Men  : Menu;
841                               Proc : Menu_Hook_Function) return C_Int;
842       pragma Import (C, Set_Menu_Init, "set_menu_init");
843
844       Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
845    begin
846       if  Res /= E_Ok then
847          Eti_Exception (Res);
848       end if;
849    end Set_Menu_Init_Hook;
850
851    procedure Set_Menu_Term_Hook (Men  : in Menu;
852                                  Proc : in Menu_Hook_Function)
853    is
854       function Set_Menu_Term (Men  : Menu;
855                               Proc : Menu_Hook_Function) return C_Int;
856       pragma Import (C, Set_Menu_Term, "set_menu_term");
857
858       Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
859    begin
860       if Res /= E_Ok then
861          Eti_Exception (Res);
862       end if;
863    end Set_Menu_Term_Hook;
864
865    function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
866    is
867       function Item_Init (Men : Menu) return Menu_Hook_Function;
868       pragma Import (C, Item_Init, "item_init");
869    begin
870       return Item_Init (Men);
871    end Get_Item_Init_Hook;
872
873    function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
874    is
875       function Item_Term (Men : Menu) return Menu_Hook_Function;
876       pragma Import (C, Item_Term, "item_term");
877    begin
878       return Item_Term (Men);
879    end Get_Item_Term_Hook;
880
881    function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
882    is
883       function Menu_Init (Men : Menu) return Menu_Hook_Function;
884       pragma Import (C, Menu_Init, "menu_init");
885    begin
886       return Menu_Init (Men);
887    end Get_Menu_Init_Hook;
888
889    function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
890    is
891       function Menu_Term (Men : Menu) return Menu_Hook_Function;
892       pragma Import (C, Menu_Term, "menu_term");
893    begin
894       return Menu_Term (Men);
895    end Get_Menu_Term_Hook;
896 -------------------------------------------------------------------------------
897    procedure Redefine (Men   : in Menu;
898                        Items : in Item_Array_Access)
899    is
900       function Set_Items (Men   : Menu;
901                           Items : System.Address) return C_Int;
902       pragma Import (C, Set_Items, "set_menu_items");
903
904       Res : Eti_Error;
905    begin
906       pragma Assert (Items (Items'Last) = Null_Item);
907       if Items (Items'Last) /= Null_Item then
908          raise Menu_Exception;
909       else
910          Res := Set_Items (Men, Items (Items'First)'Address);
911          if  Res /= E_Ok then
912             Eti_Exception (Res);
913          end if;
914       end if;
915    end Redefine;
916
917    function Item_Count (Men : Menu) return Natural
918    is
919       function Count (Men : Menu) return C_Int;
920       pragma Import (C, Count, "item_count");
921    begin
922       return Natural (Count (Men));
923    end Item_Count;
924
925    function Items (Men   : Menu;
926                    Index : Positive) return Item
927    is
928       function M_Items (Men : Menu;
929                         Idx : C_Int) return Item;
930       pragma Import (C, M_Items, "_nc_get_item");
931    begin
932       if Men = Null_Menu or else Index not in 1 .. Item_Count (Men) then
933          raise Menu_Exception;
934       else
935          return M_Items (Men, C_Int (Index) - 1);
936       end if;
937    end Items;
938
939 -------------------------------------------------------------------------------
940    function Create (Items : Item_Array_Access) return Menu
941    is
942       function Newmenu (Items : System.Address) return Menu;
943       pragma Import (C, Newmenu, "new_menu");
944
945       M   : Menu;
946       I   : Item_Array_Access;
947    begin
948       pragma Assert (Items (Items'Last) = Null_Item);
949       if Items (Items'Last) /= Null_Item then
950          raise Menu_Exception;
951       else
952          M := Newmenu (Items (Items'First)'Address);
953          if M = Null_Menu then
954             raise Menu_Exception;
955          end if;
956          return M;
957       end if;
958    end Create;
959
960    procedure Delete (Men : in out Menu)
961    is
962       function Free (Men : Menu) return C_Int;
963       pragma Import (C, Free, "free_menu");
964
965       Res : constant Eti_Error := Free (Men);
966    begin
967       if Res /= E_Ok then
968          Eti_Exception (Res);
969       end if;
970       Men := Null_Menu;
971    end Delete;
972
973 ------------------------------------------------------------------------------
974    function Driver (Men : Menu;
975                     Key : Key_Code) return Driver_Result
976    is
977       function Driver (Men : Menu;
978                        Key : C_Int) return C_Int;
979       pragma Import (C, Driver, "menu_driver");
980
981       R : Eti_Error := Driver (Men, C_Int (Key));
982    begin
983       if R /= E_Ok then
984          case R is
985             when E_Unknown_Command  => return Unknown_Request;
986             when E_No_Match         => return No_Match;
987             when E_Request_Denied |
988                  E_Not_Selectable   => return Request_Denied;
989             when others =>
990                Eti_Exception (R);
991          end case;
992       end if;
993       return Menu_Ok;
994    end Driver;
995
996    procedure Free (IA         : in out Item_Array_Access;
997                    Free_Items : in Boolean := False)
998    is
999       procedure Release is new Ada.Unchecked_Deallocation
1000         (Item_Array, Item_Array_Access);
1001    begin
1002       if IA /= null and then Free_Items then
1003          for I in IA'First .. (IA'Last - 1) loop
1004             if (IA (I) /= Null_Item) then
1005                Delete (IA (I));
1006             end if;
1007          end loop;
1008       end if;
1009       Release (IA);
1010    end Free;
1011
1012 -------------------------------------------------------------------------------
1013    function Default_Menu_Options return Menu_Option_Set
1014    is
1015    begin
1016       return Get_Options (Null_Menu);
1017    end Default_Menu_Options;
1018
1019    function Default_Item_Options return Item_Option_Set
1020    is
1021    begin
1022       return Get_Options (Null_Item);
1023    end Default_Item_Options;
1024 -------------------------------------------------------------------------------
1025
1026 end Terminal_Interface.Curses.Menus;