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