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