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