ncurses 5.6 - patch 20080726
[ncurses.git] / Ada95 / src / terminal_interface-curses-forms.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                           GNAT ncurses Binding                           --
4 --                                                                          --
5 --                      Terminal_Interface.Curses.Forms                     --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2004,2008 Free Software Foundation, Inc.              --
11 --                                                                          --
12 -- Permission is hereby granted, free of charge, to any person obtaining a  --
13 -- copy of this software and associated documentation files (the            --
14 -- "Software"), to deal in the Software without restriction, including      --
15 -- without limitation the rights to use, copy, modify, merge, publish,      --
16 -- distribute, distribute with modifications, sublicense, and/or sell       --
17 -- copies of the Software, and to permit persons to whom the Software is    --
18 -- furnished to do so, subject to the following conditions:                 --
19 --                                                                          --
20 -- The above copyright notice and this permission notice shall be included  --
21 -- in all copies or substantial portions of the Software.                   --
22 --                                                                          --
23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
30 --                                                                          --
31 -- Except as contained in this notice, the name(s) of the above copyright   --
32 -- holders shall not be used in advertising or otherwise to promote the     --
33 -- sale, use or other dealings in this Software without prior written       --
34 -- authorization.                                                           --
35 ------------------------------------------------------------------------------
36 --  Author:  Juergen Pfeifer, 1996
37 --  Version Control:
38 --  $Revision: 1.26 $
39 --  $Date: 2008/07/26 18:50:44 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with Ada.Unchecked_Deallocation;
43 with Ada.Unchecked_Conversion;
44
45 with Interfaces.C; use Interfaces.C;
46 with Interfaces.C.Strings; use Interfaces.C.Strings;
47 with Interfaces.C.Pointers;
48
49 with Terminal_Interface.Curses.Aux;
50
51 package body Terminal_Interface.Curses.Forms is
52
53    use Terminal_Interface.Curses.Aux;
54
55    type C_Field_Array is array (Natural range <>) of aliased Field;
56    package F_Array is new
57      Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field);
58
59 ------------------------------------------------------------------------------
60    --  |
61    --  |
62    --  |
63    --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
64
65    function FOS_2_CInt is new
66      Ada.Unchecked_Conversion (Field_Option_Set,
67                                C_Int);
68
69    function CInt_2_FOS is new
70      Ada.Unchecked_Conversion (C_Int,
71                                Field_Option_Set);
72
73    function FrmOS_2_CInt is new
74      Ada.Unchecked_Conversion (Form_Option_Set,
75                                C_Int);
76
77    function CInt_2_FrmOS is new
78      Ada.Unchecked_Conversion (C_Int,
79                                Form_Option_Set);
80
81    procedure Request_Name (Key  : in Form_Request_Code;
82                                 Name : out String)
83    is
84       function Form_Request_Name (Key : C_Int) return chars_ptr;
85       pragma Import (C, Form_Request_Name, "form_request_name");
86    begin
87       Fill_String (Form_Request_Name (C_Int (Key)), Name);
88    end Request_Name;
89
90    function Request_Name (Key : Form_Request_Code) return String
91    is
92       function Form_Request_Name (Key : C_Int) return chars_ptr;
93       pragma Import (C, Form_Request_Name, "form_request_name");
94    begin
95       return Fill_String (Form_Request_Name (C_Int (Key)));
96    end Request_Name;
97 ------------------------------------------------------------------------------
98    --  |
99    --  |
100    --  |
101    --  |
102    --  |=====================================================================
103    --  | man page form_field_new.3x
104    --  |=====================================================================
105    --  |
106    --  |
107    --  |
108    function Create (Height       : Line_Count;
109                     Width        : Column_Count;
110                     Top          : Line_Position;
111                     Left         : Column_Position;
112                     Off_Screen   : Natural := 0;
113                     More_Buffers : Buffer_Number := Buffer_Number'First)
114                     return Field
115    is
116       function Newfield (H, W, T, L, O, M : C_Int) return Field;
117       pragma Import (C, Newfield, "new_field");
118       Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
119                                         C_Int (Top), C_Int (Left),
120                                         C_Int (Off_Screen),
121                                         C_Int (More_Buffers));
122    begin
123       if Fld = Null_Field then
124          raise Form_Exception;
125       end if;
126       return Fld;
127    end Create;
128 --  |
129 --  |
130 --  |
131    procedure Delete (Fld : in out Field)
132    is
133       function Free_Field (Fld : Field) return C_Int;
134       pragma Import (C, Free_Field, "free_field");
135
136       Res : Eti_Error;
137    begin
138       Res := Free_Field (Fld);
139       if Res /= E_Ok then
140          Eti_Exception (Res);
141       end if;
142       Fld := Null_Field;
143    end Delete;
144    --  |
145    --  |
146    --  |
147    function Duplicate (Fld  : Field;
148                        Top  : Line_Position;
149                        Left : Column_Position) return Field
150    is
151       function Dup_Field (Fld  : Field;
152                           Top  : C_Int;
153                           Left : C_Int) return Field;
154       pragma Import (C, Dup_Field, "dup_field");
155
156       F : constant Field := Dup_Field (Fld,
157                                        C_Int (Top),
158                                        C_Int (Left));
159    begin
160       if F = Null_Field then
161          raise Form_Exception;
162       end if;
163       return F;
164    end Duplicate;
165    --  |
166    --  |
167    --  |
168    function Link (Fld  : Field;
169                   Top  : Line_Position;
170                   Left : Column_Position) return Field
171    is
172       function Lnk_Field (Fld  : Field;
173                           Top  : C_Int;
174                           Left : C_Int) return Field;
175       pragma Import (C, Lnk_Field, "link_field");
176
177       F : constant Field := Lnk_Field (Fld,
178                                        C_Int (Top),
179                                        C_Int (Left));
180    begin
181       if F = Null_Field then
182          raise Form_Exception;
183       end if;
184       return F;
185    end Link;
186    --  |
187    --  |=====================================================================
188    --  | man page form_field_just.3x
189    --  |=====================================================================
190    --  |
191    --  |
192    --  |
193    procedure Set_Justification (Fld  : in Field;
194                                 Just : in Field_Justification := None)
195    is
196       function Set_Field_Just (Fld  : Field;
197                                Just : C_Int) return C_Int;
198       pragma Import (C, Set_Field_Just, "set_field_just");
199
200       Res : constant Eti_Error :=
201         Set_Field_Just (Fld,
202                         C_Int (Field_Justification'Pos (Just)));
203    begin
204       if Res /= E_Ok then
205          Eti_Exception (Res);
206       end if;
207    end Set_Justification;
208    --  |
209    --  |
210    --  |
211    function Get_Justification (Fld : Field) return Field_Justification
212    is
213       function Field_Just (Fld : Field) return C_Int;
214       pragma Import (C, Field_Just, "field_just");
215    begin
216       return Field_Justification'Val (Field_Just (Fld));
217    end Get_Justification;
218    --  |
219    --  |=====================================================================
220    --  | man page form_field_buffer.3x
221    --  |=====================================================================
222    --  |
223    --  |
224    --  |
225    procedure Set_Buffer
226      (Fld    : in Field;
227       Buffer : in Buffer_Number := Buffer_Number'First;
228       Str    : in String)
229    is
230       type Char_Ptr is access all Interfaces.C.char;
231       function Set_Fld_Buffer (Fld    : Field;
232                                  Bufnum : C_Int;
233                                  S      : Char_Ptr)
234         return C_Int;
235       pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
236
237       Txt : char_array (0 .. Str'Length);
238       Len : size_t;
239       Res : Eti_Error;
240    begin
241       To_C (Str, Txt, Len);
242       Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
243       if Res /= E_Ok then
244          Eti_Exception (Res);
245       end if;
246    end Set_Buffer;
247    --  |
248    --  |
249    --  |
250    procedure Get_Buffer
251      (Fld    : in Field;
252       Buffer : in Buffer_Number := Buffer_Number'First;
253       Str    : out String)
254    is
255       function Field_Buffer (Fld : Field;
256                              B   : C_Int) return chars_ptr;
257       pragma Import (C, Field_Buffer, "field_buffer");
258    begin
259       Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
260    end Get_Buffer;
261
262    function Get_Buffer
263      (Fld    : in Field;
264       Buffer : in Buffer_Number := Buffer_Number'First) return String
265    is
266       function Field_Buffer (Fld : Field;
267                              B   : C_Int) return chars_ptr;
268       pragma Import (C, Field_Buffer, "field_buffer");
269    begin
270       return Fill_String (Field_Buffer (Fld, C_Int (Buffer)));
271    end Get_Buffer;
272    --  |
273    --  |
274    --  |
275    procedure Set_Status (Fld    : in Field;
276                          Status : in Boolean := True)
277    is
278       function Set_Fld_Status (Fld : Field;
279                                St  : C_Int) return C_Int;
280       pragma Import (C, Set_Fld_Status, "set_field_status");
281
282       Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
283    begin
284       if Res /= E_Ok then
285          raise Form_Exception;
286       end if;
287    end Set_Status;
288    --  |
289    --  |
290    --  |
291    function Changed (Fld : Field) return Boolean
292    is
293       function Field_Status (Fld : Field) return C_Int;
294       pragma Import (C, Field_Status, "field_status");
295
296       Res : constant C_Int := Field_Status (Fld);
297    begin
298       if Res = Curses_False then
299          return False;
300       else
301          return True;
302       end if;
303    end Changed;
304    --  |
305    --  |
306    --  |
307    procedure Set_Maximum_Size (Fld : in Field;
308                                Max : in Natural := 0)
309    is
310       function Set_Field_Max (Fld : Field;
311                               M   : C_Int) return C_Int;
312       pragma Import (C, Set_Field_Max, "set_max_field");
313
314       Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
315    begin
316       if Res /= E_Ok then
317          Eti_Exception (Res);
318       end if;
319    end Set_Maximum_Size;
320    --  |
321    --  |=====================================================================
322    --  | man page form_field_opts.3x
323    --  |=====================================================================
324    --  |
325    --  |
326    --  |
327    procedure Set_Options (Fld     : in Field;
328                           Options : in Field_Option_Set)
329    is
330       function Set_Field_Opts (Fld : Field;
331                                Opt : C_Int) return C_Int;
332       pragma Import (C, Set_Field_Opts, "set_field_opts");
333
334       Opt : constant C_Int := FOS_2_CInt (Options);
335       Res : Eti_Error;
336    begin
337       Res := Set_Field_Opts (Fld, Opt);
338       if Res /= E_Ok then
339          Eti_Exception (Res);
340       end if;
341    end Set_Options;
342    --  |
343    --  |
344    --  |
345    procedure Switch_Options (Fld     : in Field;
346                              Options : in Field_Option_Set;
347                              On      : Boolean := True)
348    is
349       function Field_Opts_On (Fld : Field;
350                               Opt : C_Int) return C_Int;
351       pragma Import (C, Field_Opts_On, "field_opts_on");
352       function Field_Opts_Off (Fld : Field;
353                                Opt : C_Int) return C_Int;
354       pragma Import (C, Field_Opts_Off, "field_opts_off");
355
356       Err : Eti_Error;
357       Opt : constant C_Int := FOS_2_CInt (Options);
358    begin
359       if On then
360          Err := Field_Opts_On (Fld, Opt);
361       else
362          Err := Field_Opts_Off (Fld, Opt);
363       end if;
364       if Err /= E_Ok then
365          Eti_Exception (Err);
366       end if;
367    end Switch_Options;
368    --  |
369    --  |
370    --  |
371    procedure Get_Options (Fld     : in  Field;
372                           Options : out Field_Option_Set)
373    is
374       function Field_Opts (Fld : Field) return C_Int;
375       pragma Import (C, Field_Opts, "field_opts");
376
377       Res : constant C_Int := Field_Opts (Fld);
378    begin
379       Options := CInt_2_FOS (Res);
380    end Get_Options;
381    --  |
382    --  |
383    --  |
384    function Get_Options (Fld : Field := Null_Field)
385                          return Field_Option_Set
386    is
387       Fos : Field_Option_Set;
388    begin
389       Get_Options (Fld, Fos);
390       return Fos;
391    end Get_Options;
392    --  |
393    --  |=====================================================================
394    --  | man page form_field_attributes.3x
395    --  |=====================================================================
396    --  |
397    --  |
398    --  |
399    procedure Set_Foreground
400      (Fld   : in Field;
401       Fore  : in Character_Attribute_Set := Normal_Video;
402       Color : in Color_Pair := Color_Pair'First)
403    is
404       function Set_Field_Fore (Fld  : Field;
405                                Attr : C_Chtype) return C_Int;
406       pragma Import (C, Set_Field_Fore, "set_field_fore");
407
408       Ch : constant Attributed_Character := (Ch    => Character'First,
409                                              Color => Color,
410                                              Attr  => Fore);
411       Res : constant Eti_Error :=
412         Set_Field_Fore (Fld, AttrChar_To_Chtype (Ch));
413    begin
414       if  Res /= E_Ok then
415          Eti_Exception (Res);
416       end if;
417    end Set_Foreground;
418    --  |
419    --  |
420    --  |
421    procedure Foreground (Fld  : in  Field;
422                          Fore : out Character_Attribute_Set)
423    is
424       function Field_Fore (Fld : Field) return C_Chtype;
425       pragma Import (C, Field_Fore, "field_fore");
426    begin
427       Fore := Chtype_To_AttrChar (Field_Fore (Fld)).Attr;
428    end Foreground;
429
430    procedure Foreground (Fld   : in  Field;
431                          Fore  : out Character_Attribute_Set;
432                          Color : out Color_Pair)
433    is
434       function Field_Fore (Fld : Field) return C_Chtype;
435       pragma Import (C, Field_Fore, "field_fore");
436    begin
437       Fore  := Chtype_To_AttrChar (Field_Fore (Fld)).Attr;
438       Color := Chtype_To_AttrChar (Field_Fore (Fld)).Color;
439    end Foreground;
440    --  |
441    --  |
442    --  |
443    procedure Set_Background
444      (Fld   : in Field;
445       Back  : in Character_Attribute_Set := Normal_Video;
446       Color : in Color_Pair := Color_Pair'First)
447    is
448       function Set_Field_Back (Fld  : Field;
449                                Attr : C_Chtype) return C_Int;
450       pragma Import (C, Set_Field_Back, "set_field_back");
451
452       Ch : constant Attributed_Character := (Ch    => Character'First,
453                                              Color => Color,
454                                              Attr  => Back);
455       Res : constant Eti_Error :=
456         Set_Field_Back (Fld, AttrChar_To_Chtype (Ch));
457    begin
458       if  Res /= E_Ok then
459          Eti_Exception (Res);
460       end if;
461    end Set_Background;
462    --  |
463    --  |
464    --  |
465    procedure Background (Fld  : in  Field;
466                          Back : out Character_Attribute_Set)
467    is
468       function Field_Back (Fld : Field) return C_Chtype;
469       pragma Import (C, Field_Back, "field_back");
470    begin
471       Back := Chtype_To_AttrChar (Field_Back (Fld)).Attr;
472    end Background;
473
474    procedure Background (Fld   : in  Field;
475                          Back  : out Character_Attribute_Set;
476                          Color : out Color_Pair)
477    is
478       function Field_Back (Fld : Field) return C_Chtype;
479       pragma Import (C, Field_Back, "field_back");
480    begin
481       Back  := Chtype_To_AttrChar (Field_Back (Fld)).Attr;
482       Color := Chtype_To_AttrChar (Field_Back (Fld)).Color;
483    end Background;
484    --  |
485    --  |
486    --  |
487    procedure Set_Pad_Character (Fld : in Field;
488                                 Pad : in Character := Space)
489    is
490       function Set_Field_Pad (Fld : Field;
491                               Ch  : C_Int) return C_Int;
492       pragma Import (C, Set_Field_Pad, "set_field_pad");
493
494       Res : constant Eti_Error := Set_Field_Pad (Fld,
495                                                  C_Int (Character'Pos (Pad)));
496    begin
497       if Res /= E_Ok then
498          Eti_Exception (Res);
499       end if;
500    end Set_Pad_Character;
501    --  |
502    --  |
503    --  |
504    procedure Pad_Character (Fld : in  Field;
505                             Pad : out Character)
506    is
507       function Field_Pad (Fld : Field) return C_Int;
508       pragma Import (C, Field_Pad, "field_pad");
509    begin
510       Pad := Character'Val (Field_Pad (Fld));
511    end Pad_Character;
512    --  |
513    --  |=====================================================================
514    --  | man page form_field_info.3x
515    --  |=====================================================================
516    --  |
517    --  |
518    --  |
519    procedure Info (Fld                : in  Field;
520                    Lines              : out Line_Count;
521                    Columns            : out Column_Count;
522                    First_Row          : out Line_Position;
523                    First_Column       : out Column_Position;
524                    Off_Screen         : out Natural;
525                    Additional_Buffers : out Buffer_Number)
526    is
527       type C_Int_Access is access all C_Int;
528       function Fld_Info (Fld : Field;
529                          L, C, Fr, Fc, Os, Ab : C_Int_Access)
530                          return C_Int;
531       pragma Import (C, Fld_Info, "field_info");
532
533       L, C, Fr, Fc, Os, Ab : aliased C_Int;
534       Res : constant Eti_Error := Fld_Info (Fld,
535                                             L'Access, C'Access,
536                                             Fr'Access, Fc'Access,
537                                             Os'Access, Ab'Access);
538    begin
539       if Res /= E_Ok then
540          Eti_Exception (Res);
541       else
542          Lines              := Line_Count (L);
543          Columns            := Column_Count (C);
544          First_Row          := Line_Position (Fr);
545          First_Column       := Column_Position (Fc);
546          Off_Screen         := Natural (Os);
547          Additional_Buffers := Buffer_Number (Ab);
548       end if;
549    end Info;
550 --  |
551 --  |
552 --  |
553    procedure Dynamic_Info (Fld     : in Field;
554                            Lines   : out Line_Count;
555                            Columns : out Column_Count;
556                            Max     : out Natural)
557    is
558       type C_Int_Access is access all C_Int;
559       function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
560       pragma Import (C, Dyn_Info, "dynamic_field_info");
561
562       L, C, M : aliased C_Int;
563       Res : constant Eti_Error := Dyn_Info (Fld,
564                                             L'Access, C'Access,
565                                             M'Access);
566    begin
567       if Res /= E_Ok then
568          Eti_Exception (Res);
569       else
570          Lines   := Line_Count (L);
571          Columns := Column_Count (C);
572          Max     := Natural (M);
573       end if;
574    end Dynamic_Info;
575    --  |
576    --  |=====================================================================
577    --  | man page form_win.3x
578    --  |=====================================================================
579    --  |
580    --  |
581    --  |
582    procedure Set_Window (Frm : in Form;
583                          Win : in Window)
584    is
585       function Set_Form_Win (Frm : Form;
586                              Win : Window) return C_Int;
587       pragma Import (C, Set_Form_Win, "set_form_win");
588
589       Res : constant Eti_Error := Set_Form_Win (Frm, Win);
590    begin
591       if  Res /= E_Ok then
592          Eti_Exception (Res);
593       end if;
594    end Set_Window;
595    --  |
596    --  |
597    --  |
598    function Get_Window (Frm : Form) return Window
599    is
600       function Form_Win (Frm : Form) return Window;
601       pragma Import (C, Form_Win, "form_win");
602
603       W : constant Window := Form_Win (Frm);
604    begin
605       return W;
606    end Get_Window;
607    --  |
608    --  |
609    --  |
610    procedure Set_Sub_Window (Frm : in Form;
611                              Win : in Window)
612    is
613       function Set_Form_Sub (Frm : Form;
614                              Win : Window) return C_Int;
615       pragma Import (C, Set_Form_Sub, "set_form_sub");
616
617       Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
618    begin
619       if  Res /= E_Ok then
620          Eti_Exception (Res);
621       end if;
622    end Set_Sub_Window;
623    --  |
624    --  |
625    --  |
626    function Get_Sub_Window (Frm : Form) return Window
627    is
628       function Form_Sub (Frm : Form) return Window;
629       pragma Import (C, Form_Sub, "form_sub");
630
631       W : constant Window := Form_Sub (Frm);
632    begin
633       return W;
634    end Get_Sub_Window;
635    --  |
636    --  |
637    --  |
638    procedure Scale (Frm     : in Form;
639                     Lines   : out Line_Count;
640                     Columns : out Column_Count)
641    is
642       type C_Int_Access is access all C_Int;
643       function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
644       pragma Import (C, M_Scale, "scale_form");
645
646       X, Y : aliased C_Int;
647       Res  : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
648    begin
649       if Res /= E_Ok then
650          Eti_Exception (Res);
651       end if;
652       Lines := Line_Count (Y);
653       Columns := Column_Count (X);
654    end Scale;
655    --  |
656    --  |=====================================================================
657    --  | man page menu_hook.3x
658    --  |=====================================================================
659    --  |
660    --  |
661    --  |
662    procedure Set_Field_Init_Hook (Frm  : in Form;
663                                   Proc : in Form_Hook_Function)
664    is
665       function Set_Field_Init (Frm  : Form;
666                                Proc : Form_Hook_Function) return C_Int;
667       pragma Import (C, Set_Field_Init, "set_field_init");
668
669       Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
670    begin
671       if  Res /= E_Ok then
672          Eti_Exception (Res);
673       end if;
674    end Set_Field_Init_Hook;
675    --  |
676    --  |
677    --  |
678    procedure Set_Field_Term_Hook (Frm  : in Form;
679                                   Proc : in Form_Hook_Function)
680    is
681       function Set_Field_Term (Frm  : Form;
682                                Proc : Form_Hook_Function) return C_Int;
683       pragma Import (C, Set_Field_Term, "set_field_term");
684
685       Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
686    begin
687       if Res /= E_Ok then
688          Eti_Exception (Res);
689       end if;
690    end Set_Field_Term_Hook;
691    --  |
692    --  |
693    --  |
694    procedure Set_Form_Init_Hook (Frm  : in Form;
695                                  Proc : in Form_Hook_Function)
696    is
697       function Set_Form_Init (Frm  : Form;
698                               Proc : Form_Hook_Function) return C_Int;
699       pragma Import (C, Set_Form_Init, "set_form_init");
700
701       Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
702    begin
703       if  Res /= E_Ok then
704          Eti_Exception (Res);
705       end if;
706    end Set_Form_Init_Hook;
707    --  |
708    --  |
709    --  |
710    procedure Set_Form_Term_Hook (Frm  : in Form;
711                                  Proc : in Form_Hook_Function)
712    is
713       function Set_Form_Term (Frm  : Form;
714                               Proc : Form_Hook_Function) return C_Int;
715       pragma Import (C, Set_Form_Term, "set_form_term");
716
717       Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
718    begin
719       if Res /= E_Ok then
720          Eti_Exception (Res);
721       end if;
722    end Set_Form_Term_Hook;
723    --  |
724    --  |=====================================================================
725    --  | man page form_fields.3x
726    --  |=====================================================================
727    --  |
728    --  |
729    --  |
730    procedure Redefine (Frm  : in Form;
731                        Flds : in Field_Array_Access)
732    is
733       function Set_Frm_Fields (Frm   : Form;
734                                Items : System.Address) return C_Int;
735       pragma Import (C, Set_Frm_Fields, "set_form_fields");
736
737       Res : Eti_Error;
738    begin
739       pragma Assert (Flds (Flds'Last) = Null_Field);
740       if Flds (Flds'Last) /= Null_Field then
741          raise Form_Exception;
742       else
743          Res := Set_Frm_Fields (Frm, Flds (Flds'First)'Address);
744          if  Res /= E_Ok then
745             Eti_Exception (Res);
746          end if;
747       end if;
748    end Redefine;
749    --  |
750    --  |
751    --  |
752    function Fields (Frm   : Form;
753                     Index : Positive) return Field
754    is
755       use F_Array;
756
757       function C_Fields (Frm : Form) return Pointer;
758       pragma Import (C, C_Fields, "form_fields");
759
760       P : Pointer := C_Fields (Frm);
761    begin
762       if P = null or else Index > Field_Count (Frm) then
763          raise Form_Exception;
764       else
765          P := P + ptrdiff_t (C_Int (Index) - 1);
766          return P.all;
767       end if;
768    end Fields;
769    --  |
770    --  |
771    --  |
772    function Field_Count (Frm : Form) return Natural
773    is
774       function Count (Frm : Form) return C_Int;
775       pragma Import (C, Count, "field_count");
776    begin
777       return Natural (Count (Frm));
778    end Field_Count;
779    --  |
780    --  |
781    --  |
782    procedure Move (Fld    : in Field;
783                    Line   : in Line_Position;
784                    Column : in Column_Position)
785    is
786       function Move (Fld : Field; L, C : C_Int) return C_Int;
787       pragma Import (C, Move, "move_field");
788
789       Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
790    begin
791       if Res /= E_Ok then
792          Eti_Exception (Res);
793       end if;
794    end Move;
795    --  |
796    --  |=====================================================================
797    --  | man page form_new.3x
798    --  |=====================================================================
799    --  |
800    --  |
801    --  |
802    function Create (Fields : Field_Array_Access) return Form
803    is
804       function NewForm (Fields : System.Address) return Form;
805       pragma Import (C, NewForm, "new_form");
806
807       M   : Form;
808    begin
809       pragma Assert (Fields (Fields'Last) = Null_Field);
810       if Fields (Fields'Last) /= Null_Field then
811          raise Form_Exception;
812       else
813          M := NewForm (Fields (Fields'First)'Address);
814          if M = Null_Form then
815             raise Form_Exception;
816          end if;
817          return M;
818       end if;
819    end Create;
820    --  |
821    --  |
822    --  |
823    procedure Delete (Frm : in out Form)
824    is
825       function Free (Frm : Form) return C_Int;
826       pragma Import (C, Free, "free_form");
827
828       Res : constant Eti_Error := Free (Frm);
829    begin
830       if Res /= E_Ok then
831          Eti_Exception (Res);
832       end if;
833       Frm := Null_Form;
834    end Delete;
835    --  |
836    --  |=====================================================================
837    --  | man page form_opts.3x
838    --  |=====================================================================
839    --  |
840    --  |
841    --  |
842    procedure Set_Options (Frm     : in Form;
843                           Options : in Form_Option_Set)
844    is
845       function Set_Form_Opts (Frm : Form;
846                               Opt : C_Int) return C_Int;
847       pragma Import (C, Set_Form_Opts, "set_form_opts");
848
849       Opt : constant C_Int := FrmOS_2_CInt (Options);
850       Res : Eti_Error;
851    begin
852       Res := Set_Form_Opts (Frm, Opt);
853       if  Res /= E_Ok then
854          Eti_Exception (Res);
855       end if;
856    end Set_Options;
857    --  |
858    --  |
859    --  |
860    procedure Switch_Options (Frm     : in Form;
861                              Options : in Form_Option_Set;
862                              On      : Boolean := True)
863    is
864       function Form_Opts_On (Frm : Form;
865                              Opt : C_Int) return C_Int;
866       pragma Import (C, Form_Opts_On, "form_opts_on");
867       function Form_Opts_Off (Frm : Form;
868                               Opt : C_Int) return C_Int;
869       pragma Import (C, Form_Opts_Off, "form_opts_off");
870
871       Err : Eti_Error;
872       Opt : constant C_Int := FrmOS_2_CInt (Options);
873    begin
874       if On then
875          Err := Form_Opts_On (Frm, Opt);
876       else
877          Err := Form_Opts_Off (Frm, Opt);
878       end if;
879       if Err /= E_Ok then
880          Eti_Exception (Err);
881       end if;
882    end Switch_Options;
883    --  |
884    --  |
885    --  |
886    procedure Get_Options (Frm     : in  Form;
887                           Options : out Form_Option_Set)
888    is
889       function Form_Opts (Frm : Form) return C_Int;
890       pragma Import (C, Form_Opts, "form_opts");
891
892       Res : constant C_Int := Form_Opts (Frm);
893    begin
894       Options := CInt_2_FrmOS (Res);
895    end Get_Options;
896    --  |
897    --  |
898    --  |
899    function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
900    is
901       Fos : Form_Option_Set;
902    begin
903       Get_Options (Frm, Fos);
904       return Fos;
905    end Get_Options;
906    --  |
907    --  |=====================================================================
908    --  | man page form_post.3x
909    --  |=====================================================================
910    --  |
911    --  |
912    --  |
913    procedure Post (Frm  : in Form;
914                    Post : in Boolean := True)
915    is
916       function M_Post (Frm : Form) return C_Int;
917       pragma Import (C, M_Post, "post_form");
918       function M_Unpost (Frm : Form) return C_Int;
919       pragma Import (C, M_Unpost, "unpost_form");
920
921       Res : Eti_Error;
922    begin
923       if Post then
924          Res := M_Post (Frm);
925       else
926          Res := M_Unpost (Frm);
927       end if;
928       if Res /= E_Ok then
929          Eti_Exception (Res);
930       end if;
931    end Post;
932    --  |
933    --  |=====================================================================
934    --  | man page form_cursor.3x
935    --  |=====================================================================
936    --  |
937    --  |
938    --  |
939    procedure Position_Cursor (Frm : Form)
940    is
941       function Pos_Form_Cursor (Frm : Form) return C_Int;
942       pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
943
944       Res : constant Eti_Error := Pos_Form_Cursor (Frm);
945    begin
946       if  Res /= E_Ok then
947          Eti_Exception (Res);
948       end if;
949    end Position_Cursor;
950    --  |
951    --  |=====================================================================
952    --  | man page form_data.3x
953    --  |=====================================================================
954    --  |
955    --  |
956    --  |
957    function Data_Ahead (Frm : Form) return Boolean
958    is
959       function Ahead (Frm : Form) return C_Int;
960       pragma Import (C, Ahead, "data_ahead");
961
962       Res : constant C_Int := Ahead (Frm);
963    begin
964       if Res = Curses_False then
965          return False;
966       else
967          return True;
968       end if;
969    end Data_Ahead;
970    --  |
971    --  |
972    --  |
973    function Data_Behind (Frm : Form) return Boolean
974    is
975       function Behind (Frm : Form) return C_Int;
976       pragma Import (C, Behind, "data_behind");
977
978       Res : constant C_Int := Behind (Frm);
979    begin
980       if Res = Curses_False then
981          return False;
982       else
983          return True;
984       end if;
985    end Data_Behind;
986    --  |
987    --  |=====================================================================
988    --  | man page form_driver.3x
989    --  |=====================================================================
990    --  |
991    --  |
992    --  |
993    function Driver (Frm : Form;
994                     Key : Key_Code) return Driver_Result
995    is
996       function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
997       pragma Import (C, Frm_Driver, "form_driver");
998
999       R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key));
1000    begin
1001       if R /= E_Ok then
1002          if R = E_Unknown_Command then
1003             return Unknown_Request;
1004          elsif R = E_Invalid_Field then
1005             return Invalid_Field;
1006          elsif R = E_Request_Denied then
1007             return Request_Denied;
1008          else
1009             Eti_Exception (R);
1010             return Form_Ok;
1011          end if;
1012       else
1013          return Form_Ok;
1014       end if;
1015    end Driver;
1016    --  |
1017    --  |=====================================================================
1018    --  | man page form_page.3x
1019    --  |=====================================================================
1020    --  |
1021    --  |
1022    --  |
1023    procedure Set_Current (Frm : in Form;
1024                           Fld : in Field)
1025    is
1026       function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
1027       pragma Import (C, Set_Current_Fld, "set_current_field");
1028
1029       Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
1030    begin
1031       if Res /= E_Ok then
1032          Eti_Exception (Res);
1033       end if;
1034    end Set_Current;
1035    --  |
1036    --  |
1037    --  |
1038    function Current (Frm : in Form) return Field
1039    is
1040       function Current_Fld (Frm : Form) return Field;
1041       pragma Import (C, Current_Fld, "current_field");
1042
1043       Fld : constant Field := Current_Fld (Frm);
1044    begin
1045       if Fld = Null_Field then
1046          raise Form_Exception;
1047       end if;
1048       return Fld;
1049    end Current;
1050    --  |
1051    --  |
1052    --  |
1053    procedure Set_Page (Frm  : in Form;
1054                        Page : in Page_Number := Page_Number'First)
1055    is
1056       function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
1057       pragma Import (C, Set_Frm_Page, "set_form_page");
1058
1059       Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
1060    begin
1061       if Res /= E_Ok then
1062          Eti_Exception (Res);
1063       end if;
1064    end Set_Page;
1065    --  |
1066    --  |
1067    --  |
1068    function Page (Frm : Form) return Page_Number
1069    is
1070       function Get_Page (Frm : Form) return C_Int;
1071       pragma Import (C, Get_Page, "form_page");
1072
1073       P : constant C_Int := Get_Page (Frm);
1074    begin
1075       if P < 0 then
1076          raise Form_Exception;
1077       else
1078          return Page_Number (P);
1079       end if;
1080    end Page;
1081
1082    function Get_Index (Fld : Field) return Positive
1083    is
1084       function Get_Fieldindex (Fld : Field) return C_Int;
1085       pragma Import (C, Get_Fieldindex, "field_index");
1086
1087       Res : constant C_Int := Get_Fieldindex (Fld);
1088    begin
1089       if Res = Curses_Err then
1090          raise Form_Exception;
1091       end if;
1092       return Positive (Natural (Res) + Positive'First);
1093    end Get_Index;
1094
1095    --  |
1096    --  |=====================================================================
1097    --  | man page form_new_page.3x
1098    --  |=====================================================================
1099    --  |
1100    --  |
1101    --  |
1102    procedure Set_New_Page (Fld      : in Field;
1103                            New_Page : in Boolean := True)
1104    is
1105       function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
1106       pragma Import (C, Set_Page, "set_new_page");
1107
1108       Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
1109    begin
1110       if Res /= E_Ok then
1111          Eti_Exception (Res);
1112       end if;
1113    end Set_New_Page;
1114    --  |
1115    --  |
1116    --  |
1117    function Is_New_Page (Fld : Field) return Boolean
1118    is
1119       function Is_New (Fld : Field) return C_Int;
1120       pragma Import (C, Is_New, "new_page");
1121
1122       Res : constant C_Int := Is_New (Fld);
1123    begin
1124       if Res = Curses_False then
1125          return False;
1126       else
1127          return True;
1128       end if;
1129    end Is_New_Page;
1130
1131    procedure Free (FA          : in out Field_Array_Access;
1132                    Free_Fields : in Boolean := False)
1133    is
1134       procedure Release is new Ada.Unchecked_Deallocation
1135         (Field_Array, Field_Array_Access);
1136    begin
1137       if FA /= null and then Free_Fields then
1138          for I in FA'First .. (FA'Last - 1) loop
1139             if FA (I) /= Null_Field then
1140                Delete (FA (I));
1141             end if;
1142          end loop;
1143       end if;
1144       Release (FA);
1145    end Free;
1146
1147    --  |=====================================================================
1148
1149    function Default_Field_Options return Field_Option_Set
1150    is
1151    begin
1152       return Get_Options (Null_Field);
1153    end Default_Field_Options;
1154
1155    function Default_Form_Options return Form_Option_Set
1156    is
1157    begin
1158       return Get_Options (Null_Form);
1159    end Default_Form_Options;
1160
1161 end Terminal_Interface.Curses.Forms;