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