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