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