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