059ae23817b9b77c491489d93a0d870bdc1839be
[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 --  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.9 $
26 ------------------------------------------------------------------------------
27 with Ada.Tags; use Ada.Tags;
28 with Ada.Unchecked_Deallocation;
29 with Unchecked_Conversion;
30
31 with Interfaces.C; use Interfaces.C;
32 with Interfaces.C.Strings; use Interfaces.C.Strings;
33
34 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
35 with GNAT.Htable;
36
37 package body Terminal_Interface.Curses.Forms is
38
39 ------------------------------------------------------------------------------
40    --  |
41    --  |
42    --  |
43    --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
44
45    function FOS_2_CInt is new
46      Unchecked_Conversion (Field_Option_Set,
47                            C_Int);
48
49    function CInt_2_FOS is new
50      Unchecked_Conversion (C_Int,
51                            Field_Option_Set);
52
53    function FrmOS_2_CInt is new
54      Unchecked_Conversion (Form_Option_Set,
55                            C_Int);
56
57    function CInt_2_FrmOS is new
58      Unchecked_Conversion (C_Int,
59                            Form_Option_Set);
60
61    procedure Request_Name (Key  : in Form_Request_Code;
62                                 Name : out String)
63    is
64       function Form_Request_Name (Key : C_Int) return chars_ptr;
65       pragma Import (C, Form_Request_Name, "form_request_name");
66    begin
67       Fill_String (Form_Request_Name (C_Int (Key)), Name);
68    end Request_Name;
69 ------------------------------------------------------------------------------
70    procedure Free_Field_User_Wrapper is
71      new Ada.Unchecked_Deallocation (Field_User_Wrapper,
72                                      Field_User_Wrapper_Access);
73
74    procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access);
75    procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access);
76
77    procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access)
78    is
79    begin
80       A.N := A.N - 1;
81       if A.N = 0 then
82          Free_Field_User_Wrapper (A);
83       end if;
84    end Release_User_Wrapper;
85    pragma Inline (Release_User_Wrapper);
86
87    procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access)
88    is
89    begin
90       A.N := A.N + 1;
91    end Dup_User_Wrapper;
92    pragma Inline (Dup_User_Wrapper);
93 ------------------------------------------------------------------------------
94    procedure Free_Form_User_Wrapper is
95      new Ada.Unchecked_Deallocation (Form_User_Wrapper,
96                                      Form_User_Wrapper_Access);
97    --  |
98    --  |
99    --  |
100    --  |
101    --  |=====================================================================
102    --  | man page form_field_new.3x
103    --  |=====================================================================
104    --  |
105    --  |
106    --  |
107    function Create (Height       : Line_Count;
108                     Width        : Column_Count;
109                     Top          : Line_Position;
110                     Left         : Column_Position;
111                     Off_Screen   : Natural := 0;
112                     More_Buffers : Buffer_Number := Buffer_Number'First)
113                     return Field
114    is
115       function Newfield (H, W, T, L, O, M : C_Int) return Field;
116       pragma Import (C, Newfield, "new_field");
117       Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
118                                         C_Int (Top), C_Int (Left),
119                                         C_Int (Off_Screen),
120                                         C_Int (More_Buffers));
121
122       A   : Field_User_Wrapper_Access;
123       Res : Eti_Error;
124    begin
125       if Fld = Null_Field then
126          raise Form_Exception;
127       else
128          A := new Field_User_Wrapper'(U => System.Null_Address,
129                                       T => null,
130                                       N => 1);
131          Res := Set_Field_Userptr (Fld, A);
132          if Res /= E_Ok then
133             Free_Field_User_Wrapper (A);
134             Eti_Exception (Res);
135          end if;
136       end if;
137       return Fld;
138    end Create;
139 --  |
140 --  |
141 --  |
142    procedure Delete (Fld : in out Field)
143    is
144       function Free_Field (Fld : Field) return C_Int;
145       pragma Import (C, Free_Field, "free_field");
146       procedure Free_Field_Type is
147         new Ada.Unchecked_Deallocation (Field_Type'Class,
148                                         Field_Type_Access);
149
150       A   : Field_User_Wrapper_Access := Field_Userptr (Fld);
151       Res : Eti_Error;
152    begin
153       if A /= null then
154          if A.T /= null then
155             Free_Field_Type (A.T);
156          end if;
157          Release_User_Wrapper (A);
158       end if;
159       Res := Free_Field (Fld);
160       if Res /= E_Ok then
161          Eti_Exception (Res);
162       end if;
163       Fld := Null_Field;
164    end Delete;
165    --  |
166    --  |
167    --  |
168    function Duplicate (Fld  : Field;
169                        Top  : Line_Position;
170                        Left : Column_Position) return Field
171    is
172       function Dup_Field (Fld  : Field;
173                           Top  : C_Int;
174                           Left : C_Int) return Field;
175       pragma Import (C, Dup_Field, "dup_field");
176
177       A : Field_User_Wrapper_Access := Field_Userptr (Fld);
178       F : constant Field := Dup_Field (Fld,
179                                        C_Int (Top),
180                                        C_Int (Left));
181    begin
182       if F = Null_Field then
183          raise Form_Exception;
184       else
185          Dup_User_Wrapper (A);
186       end if;
187       return F;
188    end Duplicate;
189    --  |
190    --  |
191    --  |
192    function Link (Fld  : Field;
193                   Top  : Line_Position;
194                   Left : Column_Position) return Field
195    is
196       function Lnk_Field (Fld  : Field;
197                           Top  : C_Int;
198                           Left : C_Int) return Field;
199       pragma Import (C, Lnk_Field, "link_field");
200
201       A : Field_User_Wrapper_Access := Field_Userptr (Fld);
202       F : constant Field := Lnk_Field (Fld,
203                                        C_Int (Top),
204                                        C_Int (Left));
205    begin
206       if F = Null_Field then
207          raise Form_Exception;
208       else
209          Dup_User_Wrapper (A);
210       end if;
211       return F;
212    end Link;
213    --  |
214    --  |=====================================================================
215    --  | man page form_field_just.3x
216    --  |=====================================================================
217    --  |
218    --  |
219    --  |
220    procedure Set_Justification (Fld  : in Field;
221                                 Just : in Field_Justification := None)
222    is
223       function Set_Field_Just (Fld  : Field;
224                                Just : C_Int) return C_Int;
225       pragma Import (C, Set_Field_Just, "set_field_just");
226
227       Res : constant Eti_Error :=
228         Set_Field_Just (Fld,
229                         C_Int (Field_Justification'Pos (Just)));
230    begin
231       if Res /= E_Ok then
232          Eti_Exception (Res);
233       end if;
234    end Set_Justification;
235    --  |
236    --  |
237    --  |
238    function Get_Justification (Fld : Field) return Field_Justification
239    is
240       function Field_Just (Fld : Field) return C_Int;
241       pragma Import (C, Field_Just, "field_just");
242    begin
243       return Field_Justification'Val (Field_Just (Fld));
244    end Get_Justification;
245    --  |
246    --  |=====================================================================
247    --  | man page form_field_buffer.3x
248    --  |=====================================================================
249    --  |
250    --  |
251    --  |
252    procedure Set_Buffer
253      (Fld    : in Field;
254       Buffer : in Buffer_Number := Buffer_Number'First;
255       Str    : in String)
256    is
257       type Char_Ptr is access all Interfaces.C.Char;
258       function Set_Fld_Buffer (Fld    : Field;
259                                  Bufnum : C_Int;
260                                  S      : Char_Ptr)
261         return C_Int;
262       pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
263
264       Txt : char_array (0 .. Str'Length);
265       Len : size_t;
266       Res : Eti_Error;
267    begin
268       To_C (Str, Txt, Len);
269       Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
270       if Res /= E_Ok then
271          Eti_Exception (Res);
272       end if;
273    end Set_Buffer;
274    --  |
275    --  |
276    --  |
277    procedure Get_Buffer
278      (Fld    : in Field;
279       Buffer : in Buffer_Number := Buffer_Number'First;
280       Str    : out String)
281    is
282       function Field_Buffer (Fld : Field;
283                              B   : C_Int) return chars_ptr;
284       pragma Import (C, Field_Buffer, "field_buffer");
285    begin
286       Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
287    end Get_Buffer;
288    --  |
289    --  |
290    --  |
291    procedure Set_Status (Fld    : in Field;
292                          Status : in Boolean := True)
293    is
294       function Set_Fld_Status (Fld : Field;
295                                St  : C_Int) return C_Int;
296       pragma Import (C, Set_Fld_Status, "set_field_status");
297
298       Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
299    begin
300       if Res /= E_Ok then
301          raise Form_Exception;
302       end if;
303    end Set_Status;
304    --  |
305    --  |
306    --  |
307    function Changed (Fld : Field) return Boolean
308    is
309       function Field_Status (Fld : Field) return C_Int;
310       pragma Import (C, Field_Status, "field_status");
311
312       Res : constant C_Int := Field_Status (Fld);
313    begin
314       if Res = Curses_False then
315          return False;
316       else
317          return True;
318       end if;
319    end Changed;
320    --  |
321    --  |
322    --  |
323    procedure Set_Maximum_Size (Fld : in Field;
324                                Max : in Natural := 0)
325    is
326       function Set_Field_Max (Fld : Field;
327                               M   : C_Int) return C_Int;
328       pragma Import (C, Set_Field_Max, "set_max_field");
329
330       Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
331    begin
332       if Res /= E_Ok then
333          Eti_Exception (Res);
334       end if;
335    end Set_Maximum_Size;
336    --  |
337    --  |=====================================================================
338    --  | man page form_field_opts.3x
339    --  |=====================================================================
340    --  |
341    --  |
342    --  |
343    procedure Normalize_Field_Options (Options : in out C_Int);
344    pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
345
346    procedure Set_Options (Fld     : in Field;
347                           Options : in Field_Option_Set)
348    is
349       function Set_Field_Opts (Fld : Field;
350                                Opt : C_Int) return C_Int;
351       pragma Import (C, Set_Field_Opts, "set_field_opts");
352
353       Opt : C_Int := FOS_2_CInt (Options);
354       Res : Eti_Error;
355    begin
356       Normalize_Field_Options (Opt);
357       Res := Set_Field_Opts (Fld, Opt);
358       if Res /= E_Ok then
359          Eti_Exception (Res);
360       end if;
361    end Set_Options;
362    --  |
363    --  |
364    --  |
365    procedure Switch_Options (Fld     : in Field;
366                              Options : in Field_Option_Set;
367                              On      : Boolean := True)
368    is
369       function Field_Opts_On (Fld : Field;
370                               Opt : C_Int) return C_Int;
371       pragma Import (C, Field_Opts_On, "field_opts_on");
372       function Field_Opts_Off (Fld : Field;
373                                Opt : C_Int) return C_Int;
374       pragma Import (C, Field_Opts_Off, "field_opts_off");
375
376       Err : Eti_Error;
377       Opt : C_Int := FOS_2_CInt (Options);
378    begin
379       Normalize_Field_Options (Opt);
380       if On then
381          Err := Field_Opts_On (Fld, Opt);
382       else
383          Err := Field_Opts_Off (Fld, Opt);
384       end if;
385       if Err /= E_Ok then
386          Eti_Exception (Err);
387       end if;
388    end Switch_Options;
389    --  |
390    --  |
391    --  |
392    procedure Get_Options (Fld     : in  Field;
393                           Options : out Field_Option_Set)
394    is
395       function Field_Opts (Fld : Field) return C_Int;
396       pragma Import (C, Field_Opts, "field_opts");
397
398       Res : C_Int := Field_Opts (Fld);
399    begin
400       Normalize_Field_Options (Res);
401       Options := CInt_2_FOS (Res);
402    end Get_Options;
403    --  |
404    --  |
405    --  |
406    function Get_Options (Fld : Field := Null_Field)
407                          return Field_Option_Set
408    is
409       Fos : Field_Option_Set;
410    begin
411       Get_Options (Fld, Fos);
412       return Fos;
413    end Get_Options;
414    --  |
415    --  |=====================================================================
416    --  | man page form_field_attributes.3x
417    --  |=====================================================================
418    --  |
419    --  |
420    --  |
421    procedure Set_Foreground
422      (Fld   : in Field;
423       Fore  : in Character_Attribute_Set := Normal_Video;
424       Color : in Color_Pair := Color_Pair'First)
425    is
426       function Set_Field_Fore (Fld  : Field;
427                                Attr : C_Int) return C_Int;
428       pragma Import (C, Set_Field_Fore, "set_field_fore");
429
430       Ch : constant Attributed_Character := (Ch    => Character'First,
431                                              Color => Color,
432                                              Attr  => Fore);
433       Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
434    begin
435       if  Res /= E_Ok then
436          Eti_Exception (Res);
437       end if;
438    end Set_Foreground;
439    --  |
440    --  |
441    --  |
442    procedure Foreground (Fld  : in  Field;
443                          Fore : out Character_Attribute_Set)
444    is
445       function Field_Fore (Fld : Field) return C_Int;
446       pragma Import (C, Field_Fore, "field_fore");
447    begin
448       Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
449    end Foreground;
450
451    procedure Foreground (Fld   : in  Field;
452                          Fore  : out Character_Attribute_Set;
453                          Color : out Color_Pair)
454    is
455       function Field_Fore (Fld : Field) return C_Int;
456       pragma Import (C, Field_Fore, "field_fore");
457    begin
458       Fore  := CInt_To_Chtype (Field_Fore (Fld)).Attr;
459       Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
460    end Foreground;
461    --  |
462    --  |
463    --  |
464    procedure Set_Background
465      (Fld   : in Field;
466       Back  : in Character_Attribute_Set := Normal_Video;
467       Color : in Color_Pair := Color_Pair'First)
468    is
469       function Set_Field_Back (Fld  : Field;
470                                Attr : C_Int) return C_Int;
471       pragma Import (C, Set_Field_Back, "set_field_back");
472
473       Ch : constant Attributed_Character := (Ch    => Character'First,
474                                              Color => Color,
475                                              Attr  => Back);
476       Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
477    begin
478       if  Res /= E_Ok then
479          Eti_Exception (Res);
480       end if;
481    end Set_Background;
482    --  |
483    --  |
484    --  |
485    procedure Background (Fld  : in  Field;
486                          Back : out Character_Attribute_Set)
487    is
488       function Field_Back (Fld : Field) return C_Int;
489       pragma Import (C, Field_Back, "field_back");
490    begin
491       Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
492    end Background;
493
494    procedure Background (Fld   : in  Field;
495                          Back  : out Character_Attribute_Set;
496                          Color : out Color_Pair)
497    is
498       function Field_Back (Fld : Field) return C_Int;
499       pragma Import (C, Field_Back, "field_back");
500    begin
501       Back  := CInt_To_Chtype (Field_Back (Fld)).Attr;
502       Color := CInt_To_Chtype (Field_Back (Fld)).Color;
503    end Background;
504    --  |
505    --  |
506    --  |
507    procedure Set_Pad_Character (Fld : in Field;
508                                 Pad : in Character := Space)
509    is
510       function Set_Field_Pad (Fld : Field;
511                               Ch  : C_Int) return C_Int;
512       pragma Import (C, Set_Field_Pad, "set_field_pad");
513
514       Res : constant Eti_Error := Set_Field_Pad (Fld,
515                                                  C_Int (Character'Pos (Pad)));
516    begin
517       if Res /= E_Ok then
518          Eti_Exception (Res);
519       end if;
520    end Set_Pad_Character;
521    --  |
522    --  |
523    --  |
524    procedure Pad_Character (Fld : in  Field;
525                             Pad : out Character)
526    is
527       function Field_Pad (Fld : Field) return C_Int;
528       pragma Import (C, Field_Pad, "field_pad");
529    begin
530       Pad := Character'Val (Field_Pad (Fld));
531    end Pad_Character;
532    --  |
533    --  |=====================================================================
534    --  | man page form_field_info.3x
535    --  |=====================================================================
536    --  |
537    --  |
538    --  |
539    procedure Info (Fld                : in  Field;
540                    Lines              : out Line_Count;
541                    Columns            : out Column_Count;
542                    First_Row          : out Line_Position;
543                    First_Column       : out Column_Position;
544                    Off_Screen         : out Natural;
545                    Additional_Buffers : out Buffer_Number)
546    is
547       type C_Int_Access is access all C_Int;
548       function Fld_Info (Fld : Field;
549                          L, C, Fr, Fc, Os, Ab : C_Int_Access)
550                          return C_Int;
551       pragma Import (C, Fld_Info, "field_info");
552
553       L, C, Fr, Fc, Os, Ab : aliased C_Int;
554       Res : constant Eti_Error := Fld_Info (Fld,
555                                             L'Access, C'Access,
556                                             Fr'Access, Fc'Access,
557                                             Os'Access, Ab'Access);
558    begin
559       if Res /= E_Ok then
560          Eti_Exception (Res);
561       else
562          Lines              := Line_Count (L);
563          Columns            := Column_Count (C);
564          First_Row          := Line_Position (Fr);
565          First_Column       := Column_Position (Fc);
566          Off_Screen         := Natural (Os);
567          Additional_Buffers := Buffer_Number (Ab);
568       end if;
569    end Info;
570 --  |
571 --  |
572 --  |
573    procedure Dynamic_Info (Fld     : in Field;
574                            Lines   : out Line_Count;
575                            Columns : out Column_Count;
576                            Max     : out Natural)
577    is
578       type C_Int_Access is access all C_Int;
579       function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
580       pragma Import (C, Dyn_Info, "dynamic_field_info");
581
582       L, C, M : aliased C_Int;
583       Res : constant Eti_Error := Dyn_Info (Fld,
584                                             L'Access, C'Access,
585                                             M'Access);
586    begin
587       if Res /= E_Ok then
588          Eti_Exception (Res);
589       else
590          Lines   := Line_Count (L);
591          Columns := Column_Count (C);
592          Max     := Natural (M);
593       end if;
594    end Dynamic_Info;
595    --  |
596    --  |=====================================================================
597    --  | man page form_win.3x
598    --  |=====================================================================
599    --  |
600    --  |
601    --  |
602    procedure Set_Window (Frm : in Form;
603                          Win : in Window)
604    is
605       function Set_Form_Win (Frm : Form;
606                              Win : Window) return C_Int;
607       pragma Import (C, Set_Form_Win, "set_form_win");
608
609       Res : constant Eti_Error := Set_Form_Win (Frm, Win);
610    begin
611       if  Res /= E_Ok then
612          Eti_Exception (Res);
613       end if;
614    end Set_Window;
615    --  |
616    --  |
617    --  |
618    function Get_Window (Frm : Form) return Window
619    is
620       function Form_Win (Frm : Form) return Window;
621       pragma Import (C, Form_Win, "form_win");
622
623       W : constant Window := Form_Win (Frm);
624    begin
625       return W;
626    end Get_Window;
627    --  |
628    --  |
629    --  |
630    procedure Set_Sub_Window (Frm : in Form;
631                              Win : in Window)
632    is
633       function Set_Form_Sub (Frm : Form;
634                              Win : Window) return C_Int;
635       pragma Import (C, Set_Form_Sub, "set_form_sub");
636
637       Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
638    begin
639       if  Res /= E_Ok then
640          Eti_Exception (Res);
641       end if;
642    end Set_Sub_Window;
643    --  |
644    --  |
645    --  |
646    function Get_Sub_Window (Frm : Form) return Window
647    is
648       function Form_Sub (Frm : Form) return Window;
649       pragma Import (C, Form_Sub, "form_sub");
650
651       W : constant Window := Form_Sub (Frm);
652    begin
653       return W;
654    end Get_Sub_Window;
655    --  |
656    --  |
657    --  |
658    procedure Scale (Frm     : in Form;
659                     Lines   : out Line_Count;
660                     Columns : out Column_Count)
661    is
662       type C_Int_Access is access all C_Int;
663       function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
664       pragma Import (C, M_Scale, "scale_form");
665
666       X, Y : aliased C_Int;
667       Res  : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
668    begin
669       if Res /= E_Ok then
670          Eti_Exception (Res);
671       end if;
672       Lines := Line_Count (Y);
673       Columns := Column_Count (X);
674    end Scale;
675    --  |
676    --  |=====================================================================
677    --  | man page menu_hook.3x
678    --  |=====================================================================
679    --  |
680    --  |
681    --  |
682    procedure Set_Field_Init_Hook (Frm  : in Form;
683                                   Proc : in Form_Hook_Function)
684    is
685       function Set_Field_Init (Frm  : Form;
686                                Proc : Form_Hook_Function) return C_Int;
687       pragma Import (C, Set_Field_Init, "set_field_init");
688
689       Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
690    begin
691       if  Res /= E_Ok then
692          Eti_Exception (Res);
693       end if;
694    end Set_Field_Init_Hook;
695    --  |
696    --  |
697    --  |
698    procedure Set_Field_Term_Hook (Frm  : in Form;
699                                   Proc : in Form_Hook_Function)
700    is
701       function Set_Field_Term (Frm  : Form;
702                                Proc : Form_Hook_Function) return C_Int;
703       pragma Import (C, Set_Field_Term, "set_field_term");
704
705       Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
706    begin
707       if Res /= E_Ok then
708          Eti_Exception (Res);
709       end if;
710    end Set_Field_Term_Hook;
711    --  |
712    --  |
713    --  |
714    procedure Set_Form_Init_Hook (Frm  : in Form;
715                                  Proc : in Form_Hook_Function)
716    is
717       function Set_Form_Init (Frm  : Form;
718                               Proc : Form_Hook_Function) return C_Int;
719       pragma Import (C, Set_Form_Init, "set_form_init");
720
721       Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
722    begin
723       if  Res /= E_Ok then
724          Eti_Exception (Res);
725       end if;
726    end Set_Form_Init_Hook;
727    --  |
728    --  |
729    --  |
730    procedure Set_Form_Term_Hook (Frm  : in Form;
731                                  Proc : in Form_Hook_Function)
732    is
733       function Set_Form_Term (Frm  : Form;
734                               Proc : Form_Hook_Function) return C_Int;
735       pragma Import (C, Set_Form_Term, "set_form_term");
736
737       Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
738    begin
739       if Res /= E_Ok then
740          Eti_Exception (Res);
741       end if;
742    end Set_Form_Term_Hook;
743    --  |
744    --  |=====================================================================
745    --  | man page form_fields.3x
746    --  |=====================================================================
747    --  |
748    --  |
749    --  |
750    procedure Free_Allocated_Fields is
751      new Ada.Unchecked_Deallocation (Field_Array, Field_Array_Access);
752    --  |
753    --  |
754    --  |
755    --  This is a bit delicate if we want to manipulate an Ada created form
756    --  from C routines or vice versa.
757    --  In Ada created forms we use the low level user pointer to maintain
758    --  binding internal additional informations about the form. This
759    --  internal information contains a hook for the Ada provided user pointer.
760    --  Unless you understand this implementation, the safest way in mixed
761    --  language programs to deal with user pointers is, that only the language
762    --  that created the form should also manipulate the user pointer for that
763    --  form.
764    procedure Redefine (Frm  : in Form;
765                        Flds : in Field_Array)
766    is
767       function Set_Frm_Fields (Frm   : Form;
768                                Items : Field_Array) return C_Int;
769       pragma Import (C, Set_Frm_Fields, "set_form_fields");
770
771       A   : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
772       I   : Field_Array_Access;
773       Res : Eti_Error;
774    begin
775       if A = null or else A.I = null then raise Form_Exception;
776       else
777          I := new Field_Array (1 .. (Flds'Length + 1));
778          I.all (1 .. Flds'Length) := Flds (Flds'First .. Flds'Last);
779          I.all (Flds'Length + 1) := Null_Field;
780          Res := Set_Frm_Fields (Frm, I.all);
781          if  Res /= E_Ok then
782             Free_Allocated_Fields (I);
783             Eti_Exception (Res);
784          else
785             Free_Allocated_Fields (A.I);
786             A.I := I;
787          end if;
788       end if;
789    end Redefine;
790    --  |
791    --  |
792    --  |
793    function Fields (Frm : Form) return Field_Array_Access
794    is
795       A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
796    begin
797       if A = null or else A.I = null then
798          raise Form_Exception;
799       else
800          return A.I;
801       end if;
802    end Fields;
803    --  |
804    --  |
805    --  |
806    function Field_Count (Frm : Form) return Natural
807    is
808       function Count (Frm : Form) return C_Int;
809       pragma Import (C, Count, "field_count");
810    begin
811       return Natural (Count (Frm));
812    end Field_Count;
813    --  |
814    --  |
815    --  |
816    procedure Move (Fld    : in Field;
817                    Line   : in Line_Position;
818                    Column : in Column_Position)
819    is
820       function Move (Fld : Field; L, C : C_Int) return C_Int;
821       pragma Import (C, Move, "move_field");
822
823       Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
824    begin
825       if Res /= E_Ok then
826          Eti_Exception (Res);
827       end if;
828    end Move;
829    --  |
830    --  |=====================================================================
831    --  | man page form_new.3x
832    --  |=====================================================================
833    --  |
834    --  |
835    --  |
836    function Create (Fields : Field_Array) return Form
837    is
838       function NewForm (Fields : Field_Array) return Form;
839       pragma Import (C, NewForm, "new_form");
840
841       M   : Form;
842       I   : Field_Array_Access;
843       U   : Form_User_Wrapper_Access;
844       Res : Eti_Error;
845    begin
846       I := new Field_Array (1 .. (Fields'Length + 1));
847       I.all (1 .. Fields'Length) := Fields (Fields'First .. Fields'Last);
848       I.all (Fields'Length + 1) := Null_Field;
849       M := NewForm (I.all);
850       if M = Null_Form then
851          Free_Allocated_Fields (I);
852          raise Form_Exception;
853       end if;
854       U := new Form_User_Wrapper'(U => System.Null_Address, I => I);
855       Res := Set_Form_Userptr (M, U);
856       if  Res /= E_Ok then
857          Free_Allocated_Fields (I);
858          Free_Form_User_Wrapper (U);
859          Eti_Exception (Res);
860       end if;
861       return M;
862    end Create;
863    --  |
864    --  |
865    --  |
866    procedure Delete (Frm : in out Form)
867    is
868       function Free (Frm : Form) return C_Int;
869       pragma Import (C, Free, "free_form");
870
871       U   : Form_User_Wrapper_Access := Form_Userptr (Frm);
872       Res : constant Eti_Error := Free (Frm);
873    begin
874       if Res /= E_Ok then
875          Eti_Exception (Res);
876       end if;
877       if U = null or else U.I = null then
878          raise Form_Exception;
879       end if;
880       Free_Allocated_Fields (U.I);
881       Free_Form_User_Wrapper (U);
882       Frm := Null_Form;
883    end Delete;
884    --  |
885    --  |=====================================================================
886    --  | man page form_opts.3x
887    --  |=====================================================================
888    --  |
889    --  |
890    --  |
891    procedure Normalize_Form_Options (Options : in out C_Int);
892    pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
893
894    procedure Set_Options (Frm     : in Form;
895                           Options : in Form_Option_Set)
896    is
897       function Set_Form_Opts (Frm : Form;
898                               Opt : C_Int) return C_Int;
899       pragma Import (C, Set_Form_Opts, "set_form_opts");
900
901       Opt : C_Int := FrmOS_2_CInt (Options);
902       Res : Eti_Error;
903    begin
904       Normalize_Form_Options (Opt);
905       Res := Set_Form_Opts (Frm, Opt);
906       if  Res /= E_Ok then
907          Eti_Exception (Res);
908       end if;
909    end Set_Options;
910    --  |
911    --  |
912    --  |
913    procedure Switch_Options (Frm     : in Form;
914                              Options : in Form_Option_Set;
915                              On      : Boolean := True)
916    is
917       function Form_Opts_On (Frm : Form;
918                              Opt : C_Int) return C_Int;
919       pragma Import (C, Form_Opts_On, "form_opts_on");
920       function Form_Opts_Off (Frm : Form;
921                               Opt : C_Int) return C_Int;
922       pragma Import (C, Form_Opts_Off, "form_opts_off");
923
924       Err : Eti_Error;
925       Opt : C_Int := FrmOS_2_CInt (Options);
926    begin
927       Normalize_Form_Options (Opt);
928       if On then
929          Err := Form_Opts_On (Frm, Opt);
930       else
931          Err := Form_Opts_Off (Frm, Opt);
932       end if;
933       if Err /= E_Ok then
934          Eti_Exception (Err);
935       end if;
936    end Switch_Options;
937    --  |
938    --  |
939    --  |
940    procedure Get_Options (Frm     : in  Form;
941                           Options : out Form_Option_Set)
942    is
943       function Form_Opts (Frm : Form) return C_Int;
944       pragma Import (C, Form_Opts, "form_opts");
945
946       Res : C_Int := Form_Opts (Frm);
947    begin
948       Normalize_Form_Options (Res);
949       Options := CInt_2_FrmOS (Res);
950    end Get_Options;
951    --  |
952    --  |
953    --  |
954    function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
955    is
956       Fos : Form_Option_Set;
957    begin
958       Get_Options (Frm, Fos);
959       return Fos;
960    end Get_Options;
961    --  |
962    --  |=====================================================================
963    --  | man page form_post.3x
964    --  |=====================================================================
965    --  |
966    --  |
967    --  |
968    procedure Post (Frm  : in Form;
969                    Post : in Boolean := True)
970    is
971       function M_Post (Frm : Form) return C_Int;
972       pragma Import (C, M_Post, "post_form");
973       function M_Unpost (Frm : Form) return C_Int;
974       pragma Import (C, M_Unpost, "unpost_form");
975
976       Res : Eti_Error;
977    begin
978       if Post then
979          Res := M_Post (Frm);
980       else
981          Res := M_Unpost (Frm);
982       end if;
983       if Res /= E_Ok then
984          Eti_Exception (Res);
985       end if;
986    end Post;
987    --  |
988    --  |=====================================================================
989    --  | man page form_cursor.3x
990    --  |=====================================================================
991    --  |
992    --  |
993    --  |
994    procedure Position_Cursor (Frm : Form)
995    is
996       function Pos_Form_Cursor (Frm : Form) return C_Int;
997       pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
998
999       Res : constant Eti_Error := Pos_Form_Cursor (Frm);
1000    begin
1001       if  Res /= E_Ok then
1002          Eti_Exception (Res);
1003       end if;
1004    end Position_Cursor;
1005    --  |
1006    --  |=====================================================================
1007    --  | man page form_data.3x
1008    --  |=====================================================================
1009    --  |
1010    --  |
1011    --  |
1012    function Data_Ahead (Frm : Form) return Boolean
1013    is
1014       function Ahead (Frm : Form) return C_Int;
1015       pragma Import (C, Ahead, "data_ahead");
1016
1017       Res : constant C_Int := Ahead (Frm);
1018    begin
1019       if Res = Curses_False then
1020          return False;
1021       else
1022          return True;
1023       end if;
1024    end Data_Ahead;
1025    --  |
1026    --  |
1027    --  |
1028    function Data_Behind (Frm : Form) return Boolean
1029    is
1030       function Behind (Frm : Form) return C_Int;
1031       pragma Import (C, Behind, "data_behind");
1032
1033       Res : constant C_Int := Behind (Frm);
1034    begin
1035       if Res = Curses_False then
1036          return False;
1037       else
1038          return True;
1039       end if;
1040    end Data_Behind;
1041    --  |
1042    --  |=====================================================================
1043    --  | man page form_driver.3x
1044    --  |=====================================================================
1045    --  |
1046    --  |
1047    --  |
1048    function Driver (Frm : Form;
1049                     Key : Key_Code) return Driver_Result
1050    is
1051       function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
1052       pragma Import (C, Frm_Driver, "form_driver");
1053
1054       R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
1055    begin
1056       if R /= E_Ok then
1057          if R = E_Unknown_Command then
1058             return Unknown_Request;
1059          elsif R = E_Invalid_Field then
1060             return Invalid_Field;
1061          elsif R = E_Request_Denied then
1062             return Request_Denied;
1063          else
1064             Eti_Exception (R);
1065             return Form_Ok;
1066          end if;
1067       else
1068          return Form_Ok;
1069       end if;
1070    end Driver;
1071    --  |
1072    --  |=====================================================================
1073    --  | man page form_page.3x
1074    --  |=====================================================================
1075    --  |
1076    --  |
1077    --  |
1078    procedure Set_Current (Frm : in Form;
1079                           Fld : in Field)
1080    is
1081       function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
1082       pragma Import (C, Set_Current_Fld, "set_current_field");
1083
1084       Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
1085    begin
1086       if Res /= E_Ok then
1087          Eti_Exception (Res);
1088       end if;
1089    end Set_Current;
1090    --  |
1091    --  |
1092    --  |
1093    function Current (Frm : in Form) return Field
1094    is
1095       function Current_Fld (Frm : Form) return Field;
1096       pragma Import (C, Current_Fld, "current_field");
1097
1098       Fld : constant Field := Current_Fld (Frm);
1099    begin
1100       if Fld = Null_Field then
1101          raise Form_Exception;
1102       end if;
1103       return Fld;
1104    end Current;
1105    --  |
1106    --  |
1107    --  |
1108    procedure Set_Page (Frm  : in Form;
1109                        Page : in Page_Number := Page_Number'First)
1110    is
1111       function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
1112       pragma Import (C, Set_Frm_Page, "set_form_page");
1113
1114       Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
1115    begin
1116       if Res /= E_Ok then
1117          Eti_Exception (Res);
1118       end if;
1119    end Set_Page;
1120    --  |
1121    --  |
1122    --  |
1123    function Page (Frm : Form) return Page_Number
1124    is
1125       function Get_Page (Frm : Form) return C_Int;
1126       pragma Import (C, Get_Page, "form_page");
1127
1128       P : constant C_Int := Get_Page (Frm);
1129    begin
1130       if P < 0 then
1131          raise Form_Exception;
1132       else
1133          return Page_Number (P);
1134       end if;
1135    end Page;
1136
1137    function Get_Index (Fld : Field) return Positive
1138    is
1139       function Get_Fieldindex (Fld : Field) return C_Int;
1140       pragma Import (C, Get_Fieldindex, "field_index");
1141
1142       Res : constant C_Int := Get_Fieldindex (Fld);
1143    begin
1144       if Res = Curses_Err then
1145          raise Form_Exception;
1146       end if;
1147       return Positive (Natural (Res) + Positive'First);
1148    end Get_Index;
1149
1150    --  |
1151    --  |=====================================================================
1152    --  | man page form_new_page.3x
1153    --  |=====================================================================
1154    --  |
1155    --  |
1156    --  |
1157    procedure Set_New_Page (Fld      : in Field;
1158                            New_Page : in Boolean := True)
1159    is
1160       function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
1161       pragma Import (C, Set_Page, "set_new_page");
1162
1163       Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
1164    begin
1165       if Res /= E_Ok then
1166          Eti_Exception (Res);
1167       end if;
1168    end Set_New_Page;
1169    --  |
1170    --  |
1171    --  |
1172    function Is_New_Page (Fld : Field) return Boolean
1173    is
1174       function Is_New (Fld : Field) return C_Int;
1175       pragma Import (C, Is_New, "new_page");
1176
1177       Res : constant C_Int := Is_New (Fld);
1178    begin
1179       if Res = Curses_False then
1180          return False;
1181       else
1182          return True;
1183       end if;
1184    end Is_New_Page;
1185
1186 ------------------------------------------------------------------------------
1187    --  We use a GNAT internal hash table mechanism to create an association
1188    --  between an Ada_Defined_Field_Type and it's low level C_Field_Type
1189    --  peer.
1190    --  It shouldn´t be too complicated to reimplent this hashing mechanism
1191    --  for other compilers.
1192    --
1193    type Tag_Type_Pair;
1194    type Tag_Pair_Access is access all Tag_Type_Pair;
1195    pragma Controlled (Tag_Pair_Access);
1196
1197    Null_Tag_Pair : constant Tag_Pair_Access := Tag_Pair_Access'(null);
1198
1199    type Tag_Type_Pair is
1200       record
1201          Ada_Tag    : Tag;
1202          Cft        : C_Field_Type;
1203          Next       : Tag_Pair_Access;
1204       end record;
1205
1206    type Htable_Headers is range 1 .. 31;
1207    procedure Free_Tag_Type_Pair is
1208      new Ada.Unchecked_Deallocation (Tag_Type_Pair, Tag_Pair_Access);
1209
1210    procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access);
1211    function  Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access;
1212    function  Get_Pair_Tag  (T : Tag_Pair_Access) return Tag;
1213
1214    function Hash (T : Tag) return Htable_Headers;
1215    function Equal (A, B : Tag) return Boolean;
1216
1217    package External_Pair_Htable is new GNAT.Htable.Static_Htable
1218      (Header_Num => Htable_Headers,
1219       Element    => Tag_Type_Pair,
1220       Elmt_Ptr   => Tag_Pair_Access,
1221       Null_Ptr   => Null_Tag_Pair,
1222       Set_Next   => Set_Pair_Link,
1223       Next       => Get_Pair_Link,
1224       Key        => Tag,
1225       Get_Key    => Get_Pair_Tag,
1226       Hash       => Hash,
1227       Equal      => Equal);
1228
1229    procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access)
1230    is
1231    begin
1232       T.all.Next := Next;
1233    end Set_Pair_Link;
1234
1235    function  Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access
1236    is
1237    begin
1238       return T.all.Next;
1239    end Get_Pair_Link;
1240
1241    function  Get_Pair_Tag  (T : Tag_Pair_Access) return Tag
1242    is
1243    begin
1244       return T.all.Ada_Tag;
1245    end Get_Pair_Tag;
1246
1247    function Equal (A, B : Tag) return Boolean
1248    is
1249    begin
1250       return A = B;
1251    end Equal;
1252
1253    function Hash (T : Tag) return Htable_Headers
1254    is
1255       function H is new GNAT.Htable.Hash (Htable_Headers);
1256    begin
1257       return H (External_Tag (T));
1258    end Hash;
1259
1260    function Search_Type (T : Ada_Defined_Field_Type'Class)
1261                          return C_Field_Type
1262    is
1263       P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1264    begin
1265       if P /= null then
1266          return P.Cft;
1267       else
1268          return Null_Field_Type;
1269       end if;
1270    end Search_Type;
1271
1272    --  Register an Ada_Defined_Field_Type given by its Tag
1273    --  with it's associated C_Field_Type.
1274    procedure Register_Type (T   : in Ada_Defined_Field_Type'Class;
1275                             Cft : in C_Field_Type)
1276    is
1277       C : C_Field_Type := Search_Type (T);
1278       P : Tag_Pair_Access;
1279    begin
1280       if C /= Null_Field_Type then
1281          raise Form_Exception;
1282       else
1283          P := new Tag_Type_Pair'(T'Tag, Cft, null);
1284          External_Pair_Htable.Set (P);
1285       end if;
1286    end Register_Type;
1287
1288    --  Unregister an Ada_Defined_Field_Type given by it's tag
1289    procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
1290    is
1291       function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
1292       pragma Import (C, Free_Fieldtype, "free_fieldtype");
1293
1294       P   : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1295       Ft  : C_Field_Type;
1296       Res : C_Int;
1297    begin
1298       if P = null then
1299          raise Form_Exception;
1300       else
1301          Ft := P.Cft;
1302          External_Pair_Htable.Remove (T'Tag);
1303          Free_Tag_Type_Pair (P);
1304          Res := Free_Fieldtype (Ft);
1305          if Res /= E_Ok then
1306             Eti_Exception (Res);
1307          end if;
1308       end if;
1309    end Unregister_Type;
1310
1311 ----------------------------------------------------------------------------
1312    --  |
1313    --  |
1314    --  |
1315    procedure Set_Type (Fld      : Field;
1316                        Fld_Type : Ada_Defined_Field_Type)
1317    is
1318       function Set_Fld_Type (F    : Field := Fld;
1319                              Ct   : C_Field_Type;
1320                              Arg1 : Ada_Defined_Field_Type'Class)
1321                              return C_Int;
1322       pragma Import (C, Set_Fld_Type, "set_field_type");
1323       function Field_Userptr (Fld : Field)
1324                               return Field_User_Wrapper_Access;
1325       pragma Import (C, Field_Userptr, "field_userptr");
1326
1327       Res : Eti_Error;
1328       C   : constant C_Field_Type := Search_Type (Fld_Type);
1329    begin
1330       if C = Null_Field_Type then
1331          raise Form_Exception;
1332       else
1333          Res := Set_Fld_Type (Fld, C, Fld_Type);
1334          if Res /= E_Ok then
1335             Eti_Exception (Res);
1336          end if;
1337       end if;
1338    end Set_Type;
1339    --  |
1340    --  |
1341    --  |
1342    function Native_Type (Ftype : Ada_Defined_Field_Type)
1343                          return C_Field_Type
1344    is
1345       C : constant C_Field_Type := Search_Type (Ftype);
1346    begin
1347       if C = Null_Field_Type then
1348          raise Form_Exception;
1349       else
1350          return C;
1351       end if;
1352    end Native_Type;
1353    --  |
1354    --  |
1355    --  |
1356    function Native_Type (Ftype : Alpha_Field)
1357                          return C_Field_Type
1358    is
1359       C_Alpha_Field_Type : C_Field_Type;
1360       pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
1361    begin
1362       return C_Alpha_Field_Type;
1363    end Native_Type;
1364    pragma Inline (Native_Type);
1365    --  |
1366    --  |
1367    --  |
1368    procedure Set_Type (Fld      : in Field;
1369                        Fld_Type : in Alpha_Field)
1370    is
1371       function Set_Fld_Type (F    : Field := Fld;
1372                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1373                              Arg1 : C_Int) return C_Int;
1374       pragma Import (C, Set_Fld_Type, "set_field_type");
1375       function Field_Userptr (Fld : Field)
1376                               return Field_User_Wrapper_Access;
1377       pragma Import (C, Field_Userptr, "field_userptr");
1378
1379       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1380       Res : Eti_Error;
1381    begin
1382       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1383       if Res /= E_Ok then
1384          Eti_Exception (Res);
1385       else
1386          A.T := new Alpha_Field'(Fld_Type);
1387       end if;
1388    end Set_Type;
1389    --  |
1390    --  |
1391    --  |
1392    function Native_Type (Ftype : Alpha_Numeric_Field)
1393                          return C_Field_Type
1394    is
1395       C_Alpha_Numeric_Field_Type : C_Field_Type;
1396       pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
1397    begin
1398       return C_Alpha_Numeric_Field_Type;
1399    end Native_Type;
1400    pragma Inline (Native_Type);
1401    --  |
1402    --  |
1403    --  |
1404    procedure Set_Type (Fld      : in Field;
1405                        Fld_Type : in Alpha_Numeric_Field)
1406    is
1407       function Set_Fld_Type (F    : Field := Fld;
1408                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1409                              Arg1 : C_Int) return C_Int;
1410       pragma Import (C, Set_Fld_Type, "set_field_type");
1411       function Field_Userptr (Fld : Field)
1412                               return Field_User_Wrapper_Access;
1413       pragma Import (C, Field_Userptr, "field_userptr");
1414
1415       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1416       Res : Eti_Error;
1417    begin
1418       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1419       if Res /= E_Ok then
1420          Eti_Exception (Res);
1421       else
1422          A.T := new Alpha_Numeric_Field'(Fld_Type);
1423       end if;
1424    end Set_Type;
1425    --  |
1426    --  |
1427    --  |
1428    function Native_Type (Ftype : Integer_Field)
1429                          return C_Field_Type
1430    is
1431       C_Integer_Field_Type : C_Field_Type;
1432       pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
1433    begin
1434       return C_Integer_Field_Type;
1435    end Native_Type;
1436    pragma Inline (Native_Type);
1437    --  |
1438    --  |
1439    --  |
1440    procedure Set_Type (Fld      : in Field;
1441                        Fld_Type : in Integer_Field)
1442    is
1443       function Set_Fld_Type (F    : Field := Fld;
1444                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1445                              Arg1 : C_Int;
1446                              Arg2 : C_Long_Int;
1447                              Arg3 : C_Long_Int) return C_Int;
1448       pragma Import (C, Set_Fld_Type, "set_field_type");
1449       function Field_Userptr (Fld : Field)
1450                               return Field_User_Wrapper_Access;
1451       pragma Import (C, Field_Userptr, "field_userptr");
1452
1453       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1454       Res : Eti_Error;
1455    begin
1456       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Precision),
1457                            Arg2 => C_Long_Int (Fld_Type.Lower_Limit),
1458                            Arg3 => C_Long_Int (Fld_Type.Upper_Limit));
1459       if Res /= E_Ok then
1460          Eti_Exception (Res);
1461       else
1462          A.T := new Integer_Field'(Fld_Type);
1463       end if;
1464    end Set_Type;
1465    --  |
1466    --  |
1467    --  |
1468    function Native_Type (Ftype : Numeric_Field)
1469                          return C_Field_Type
1470    is
1471       C_Numeric_Field_Type : C_Field_Type;
1472       pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
1473    begin
1474       return C_Numeric_Field_Type;
1475    end Native_Type;
1476    pragma Inline (Native_Type);
1477    --  |
1478    --  |
1479    --  |
1480    procedure Set_Type (Fld      : in Field;
1481                        Fld_Type : in Numeric_Field)
1482    is
1483       type Double is new Interfaces.C.double;
1484
1485    function Set_Fld_Type (F    : Field := Fld;
1486                           Cft  : C_Field_Type := Native_Type (Fld_Type);
1487                           Arg1 : Double;
1488                           Arg2 : Double;
1489                           Arg3 : Double) return C_Int;
1490       pragma Import (C, Set_Fld_Type, "set_field_type");
1491       function Field_Userptr (Fld : Field)
1492                               return Field_User_Wrapper_Access;
1493       pragma Import (C, Field_Userptr, "field_userptr");
1494
1495       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1496       Res : Eti_Error;
1497    begin
1498       Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
1499                            Arg2 => Double (Fld_Type.Lower_Limit),
1500                            Arg3 => Double (Fld_Type.Upper_Limit));
1501       if Res /= E_Ok then
1502          Eti_Exception (Res);
1503       else
1504          A.T := new Numeric_Field'(Fld_Type);
1505       end if;
1506    end Set_Type;
1507    --  |
1508    --  |
1509    --  |
1510    function Native_Type (Ftype : Regular_Expression_Field)
1511                          return C_Field_Type
1512    is
1513       C_Regexp_Field_Type : C_Field_Type;
1514       pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
1515    begin
1516       return C_Regexp_Field_Type;
1517    end Native_Type;
1518    pragma Inline (Native_Type);
1519    --  |
1520    --  |
1521    --  |
1522    procedure Set_Type (Fld      : in Field;
1523                        Fld_Type : in Regular_Expression_Field)
1524    is
1525       type Char_Ptr is access all Interfaces.C.Char;
1526       function Set_Fld_Type (F    : Field := Fld;
1527                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1528                              Arg1 : Char_Ptr) return C_Int;
1529       pragma Import (C, Set_Fld_Type, "set_field_type");
1530       function Field_Userptr (Fld : Field)
1531                               return Field_User_Wrapper_Access;
1532       pragma Import (C, Field_Userptr, "field_userptr");
1533
1534       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1535       Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
1536       Len : size_t;
1537       Res : Eti_Error;
1538    begin
1539       To_C (Fld_Type.Regular_Expression.all, Txt, Len);
1540       Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
1541       if Res /= E_Ok then
1542          Eti_Exception (Res);
1543       else
1544          A.T := new Regular_Expression_Field'(Fld_Type);
1545       end if;
1546    end Set_Type;
1547    --  |
1548    --  |
1549    --  |
1550    function Native_Type (Ftype : Enumeration_Field)
1551                          return C_Field_Type
1552    is
1553       C_Enum_Type : C_Field_Type;
1554       pragma Import (C, C_Enum_Type, "TYPE_ENUM");
1555    begin
1556       return C_Enum_Type;
1557    end Native_Type;
1558    pragma Inline (Native_Type);
1559    --  |
1560    --  |
1561    --  |
1562    function Create (Info               : Enumeration_Info;
1563                     Auto_Release_Names : Boolean := False)
1564      return Enumeration_Field
1565    is
1566       procedure Release_String is
1567         new Ada.Unchecked_Deallocation (String,
1568                                         String_Access);
1569       E : Enumeration_Field;
1570       L : constant size_t := 1 + size_t (Info.C);
1571       S : String_Access;
1572    begin
1573       E.Case_Sensitive       := Info.Case_Sensitive;
1574       E.Match_Must_Be_Unique := Info.Match_Must_Be_Unique;
1575       E.Arr := new chars_ptr_array (size_t (1) .. L);
1576       for I in 1 .. Positive (L - 1) loop
1577          if Info.Names (I) = null then
1578             raise Form_Exception;
1579          end if;
1580          E.Arr (size_t (I)) := New_String (Info.Names (I).all);
1581          if Auto_Release_Names then
1582             S := Info.Names (I);
1583             Release_String (S);
1584          end if;
1585       end loop;
1586       E.Arr (L) := Null_Ptr;
1587       return E;
1588    end Create;
1589
1590    procedure Release (Enum : in out Enumeration_Field)
1591    is
1592       I : size_t := 0;
1593       P : chars_ptr;
1594    begin
1595       loop
1596          P := Enum.Arr (I);
1597          exit when P = Null_Ptr;
1598          Free (P);
1599          Enum.Arr (I) := Null_Ptr;
1600          I := I + 1;
1601       end loop;
1602       Enum.Arr := null;
1603    end Release;
1604
1605    procedure Set_Type (Fld      : in Field;
1606                        Fld_Type : in Enumeration_Field)
1607    is
1608       function Set_Fld_Type (F    : Field := Fld;
1609                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1610                              Arg1 : chars_ptr_array;
1611                              Arg2 : C_Int;  -- case
1612                              Arg3 : C_Int) return C_Int;
1613       pragma Import (C, Set_Fld_Type, "set_field_type");
1614       function Field_Userptr (Fld : Field)
1615                               return Field_User_Wrapper_Access;
1616       pragma Import (C, Field_Userptr, "field_userptr");
1617
1618       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1619       Res : Eti_Error;
1620    begin
1621       if Fld_Type.Arr = null then
1622          raise Form_Exception;
1623       end if;
1624       Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
1625                            Arg2 => C_Int (Boolean'Pos
1626                                           (Fld_Type.Case_Sensitive)),
1627                            Arg3 =>
1628                              C_Int (Boolean'Pos
1629                                     (Fld_Type.Match_Must_Be_Unique)));
1630       if Res /= E_Ok then
1631          Eti_Exception (Res);
1632       else
1633          A.T := new Enumeration_Field'(Fld_Type);
1634       end if;
1635    end Set_Type;
1636
1637
1638    function Native_Type (Ftype : Internet_V4_Address_Field)
1639                          return C_Field_Type
1640    is
1641       C_IPV4_Field_Type : C_Field_Type;
1642       pragma Import (C, C_IPV4_Field_Type, "TYPE_IPV4");
1643    begin
1644       return C_IPV4_Field_Type;
1645    end Native_Type;
1646    pragma Inline (Native_Type);
1647    --  |
1648    --  |
1649    --  |
1650    procedure Set_Type (Fld      : in Field;
1651                        Fld_Type : in Internet_V4_Address_Field)
1652    is
1653       function Set_Fld_Type (F    : Field := Fld;
1654                              Cft  : C_Field_Type := Native_Type (Fld_Type))
1655                              return C_Int;
1656       pragma Import (C, Set_Fld_Type, "set_field_type");
1657       function Field_Userptr (Fld : Field)
1658                               return Field_User_Wrapper_Access;
1659       pragma Import (C, Field_Userptr, "field_userptr");
1660
1661       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1662       Res : Eti_Error;
1663    begin
1664       Res := Set_Fld_Type;
1665       if Res /= E_Ok then
1666          Eti_Exception (Res);
1667       else
1668          A.T := new Internet_V4_Address_Field'(Fld_Type);
1669       end if;
1670    end Set_Type;
1671
1672    --  |
1673    --  |=====================================================================
1674    --  | man page form_field_validation.3x
1675    --  |=====================================================================
1676    --  |
1677    --  |
1678    --  |
1679    function Get_Type (Fld : in Field) return Field_Type_Access
1680    is
1681       A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1682    begin
1683       if A = null then
1684          return null;
1685       else
1686          return A.T;
1687       end if;
1688    end Get_Type;
1689
1690 begin
1691    Default_Field_Options := Get_Options (Null_Field);
1692    Default_Form_Options  := Get_Options (Null_Form);
1693 end Terminal_Interface.Curses.Forms;