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