1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding --
5 -- Terminal_Interface.Curses.Forms --
11 -- The ncurses Ada95 binding is copyrighted 1996 by --
12 -- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
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. --
22 -- This binding comes AS IS with no warranty, implied or expressed. --
23 ------------------------------------------------------------------------------
26 ------------------------------------------------------------------------------
27 with Ada.Tags; use Ada.Tags;
28 with Ada.Unchecked_Deallocation;
29 with Unchecked_Conversion;
31 with Interfaces.C; use Interfaces.C;
32 with Interfaces.C.Strings; use Interfaces.C.Strings;
34 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
37 package body Terminal_Interface.Curses.Forms is
39 ------------------------------------------------------------------------------
43 -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
45 function FOS_2_CInt is new
46 Unchecked_Conversion (Field_Option_Set,
49 function CInt_2_FOS is new
50 Unchecked_Conversion (C_Int,
53 function FrmOS_2_CInt is new
54 Unchecked_Conversion (Form_Option_Set,
57 function CInt_2_FrmOS is new
58 Unchecked_Conversion (C_Int,
61 procedure Request_Name (Key : in Form_Request_Code;
64 function Form_Request_Name (Key : C_Int) return chars_ptr;
65 pragma Import (C, Form_Request_Name, "form_request_name");
67 Fill_String (Form_Request_Name (C_Int (Key)), Name);
69 ------------------------------------------------------------------------------
70 procedure Free_Field_User_Wrapper is
71 new Ada.Unchecked_Deallocation (Field_User_Wrapper,
72 Field_User_Wrapper_Access);
74 procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access);
75 procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access);
77 procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access)
82 Free_Field_User_Wrapper (A);
84 end Release_User_Wrapper;
85 pragma Inline (Release_User_Wrapper);
87 procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access)
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);
101 -- |=====================================================================
102 -- | man page form_field_new.3x
103 -- |=====================================================================
107 function Create (Height : Line_Count;
108 Width : Column_Count;
110 Left : Column_Position;
111 Off_Screen : Natural := 0;
112 More_Buffers : Buffer_Number := Buffer_Number'First)
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),
120 C_Int (More_Buffers));
122 A : Field_User_Wrapper_Access;
125 if Fld = Null_Field then
126 raise Form_Exception;
128 A := new Field_User_Wrapper'(U => System.Null_Address,
131 Res := Set_Field_Userptr (Fld, A);
133 Free_Field_User_Wrapper (A);
142 procedure Delete (Fld : in out Field)
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,
150 A : Field_User_Wrapper_Access := Field_Userptr (Fld);
155 Free_Field_Type (A.T);
157 Release_User_Wrapper (A);
159 Res := Free_Field (Fld);
168 function Duplicate (Fld : Field;
170 Left : Column_Position) return Field
172 function Dup_Field (Fld : Field;
174 Left : C_Int) return Field;
175 pragma Import (C, Dup_Field, "dup_field");
177 A : Field_User_Wrapper_Access := Field_Userptr (Fld);
178 F : constant Field := Dup_Field (Fld,
182 if F = Null_Field then
183 raise Form_Exception;
185 Dup_User_Wrapper (A);
192 function Link (Fld : Field;
194 Left : Column_Position) return Field
196 function Lnk_Field (Fld : Field;
198 Left : C_Int) return Field;
199 pragma Import (C, Lnk_Field, "link_field");
201 A : Field_User_Wrapper_Access := Field_Userptr (Fld);
202 F : constant Field := Lnk_Field (Fld,
206 if F = Null_Field then
207 raise Form_Exception;
209 Dup_User_Wrapper (A);
214 -- |=====================================================================
215 -- | man page form_field_just.3x
216 -- |=====================================================================
220 procedure Set_Justification (Fld : in Field;
221 Just : in Field_Justification := None)
223 function Set_Field_Just (Fld : Field;
224 Just : C_Int) return C_Int;
225 pragma Import (C, Set_Field_Just, "set_field_just");
227 Res : constant Eti_Error :=
229 C_Int (Field_Justification'Pos (Just)));
234 end Set_Justification;
238 function Get_Justification (Fld : Field) return Field_Justification
240 function Field_Just (Fld : Field) return C_Int;
241 pragma Import (C, Field_Just, "field_just");
243 return Field_Justification'Val (Field_Just (Fld));
244 end Get_Justification;
246 -- |=====================================================================
247 -- | man page form_field_buffer.3x
248 -- |=====================================================================
254 Buffer : in Buffer_Number := Buffer_Number'First;
257 type Char_Ptr is access all Interfaces.C.Char;
258 function Set_Fld_Buffer (Fld : Field;
262 pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
264 Txt : char_array (0 .. Str'Length);
268 To_C (Str, Txt, Len);
269 Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
279 Buffer : in Buffer_Number := Buffer_Number'First;
282 function Field_Buffer (Fld : Field;
283 B : C_Int) return chars_ptr;
284 pragma Import (C, Field_Buffer, "field_buffer");
286 Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
291 procedure Set_Status (Fld : in Field;
292 Status : in Boolean := True)
294 function Set_Fld_Status (Fld : Field;
295 St : C_Int) return C_Int;
296 pragma Import (C, Set_Fld_Status, "set_field_status");
298 Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
301 raise Form_Exception;
307 function Changed (Fld : Field) return Boolean
309 function Field_Status (Fld : Field) return C_Int;
310 pragma Import (C, Field_Status, "field_status");
312 Res : constant C_Int := Field_Status (Fld);
314 if Res = Curses_False then
323 procedure Set_Maximum_Size (Fld : in Field;
324 Max : in Natural := 0)
326 function Set_Field_Max (Fld : Field;
327 M : C_Int) return C_Int;
328 pragma Import (C, Set_Field_Max, "set_max_field");
330 Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
335 end Set_Maximum_Size;
337 -- |=====================================================================
338 -- | man page form_field_opts.3x
339 -- |=====================================================================
343 procedure Normalize_Field_Options (Options : in out C_Int);
344 pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
346 procedure Set_Options (Fld : in Field;
347 Options : in Field_Option_Set)
349 function Set_Field_Opts (Fld : Field;
350 Opt : C_Int) return C_Int;
351 pragma Import (C, Set_Field_Opts, "set_field_opts");
353 Opt : C_Int := FOS_2_CInt (Options);
356 Normalize_Field_Options (Opt);
357 Res := Set_Field_Opts (Fld, Opt);
365 procedure Switch_Options (Fld : in Field;
366 Options : in Field_Option_Set;
367 On : Boolean := True)
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");
377 Opt : C_Int := FOS_2_CInt (Options);
379 Normalize_Field_Options (Opt);
381 Err := Field_Opts_On (Fld, Opt);
383 Err := Field_Opts_Off (Fld, Opt);
392 procedure Get_Options (Fld : in Field;
393 Options : out Field_Option_Set)
395 function Field_Opts (Fld : Field) return C_Int;
396 pragma Import (C, Field_Opts, "field_opts");
398 Res : C_Int := Field_Opts (Fld);
400 Normalize_Field_Options (Res);
401 Options := CInt_2_FOS (Res);
406 function Get_Options (Fld : Field := Null_Field)
407 return Field_Option_Set
409 Fos : Field_Option_Set;
411 Get_Options (Fld, Fos);
415 -- |=====================================================================
416 -- | man page form_field_attributes.3x
417 -- |=====================================================================
421 procedure Set_Foreground
423 Fore : in Character_Attribute_Set := Normal_Video;
424 Color : in Color_Pair := Color_Pair'First)
426 function Set_Field_Fore (Fld : Field;
427 Attr : C_Int) return C_Int;
428 pragma Import (C, Set_Field_Fore, "set_field_fore");
430 Ch : constant Attributed_Character := (Ch => Character'First,
433 Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
442 procedure Foreground (Fld : in Field;
443 Fore : out Character_Attribute_Set)
445 function Field_Fore (Fld : Field) return C_Int;
446 pragma Import (C, Field_Fore, "field_fore");
448 Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
451 procedure Foreground (Fld : in Field;
452 Fore : out Character_Attribute_Set;
453 Color : out Color_Pair)
455 function Field_Fore (Fld : Field) return C_Int;
456 pragma Import (C, Field_Fore, "field_fore");
458 Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
459 Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
464 procedure Set_Background
466 Back : in Character_Attribute_Set := Normal_Video;
467 Color : in Color_Pair := Color_Pair'First)
469 function Set_Field_Back (Fld : Field;
470 Attr : C_Int) return C_Int;
471 pragma Import (C, Set_Field_Back, "set_field_back");
473 Ch : constant Attributed_Character := (Ch => Character'First,
476 Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
485 procedure Background (Fld : in Field;
486 Back : out Character_Attribute_Set)
488 function Field_Back (Fld : Field) return C_Int;
489 pragma Import (C, Field_Back, "field_back");
491 Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
494 procedure Background (Fld : in Field;
495 Back : out Character_Attribute_Set;
496 Color : out Color_Pair)
498 function Field_Back (Fld : Field) return C_Int;
499 pragma Import (C, Field_Back, "field_back");
501 Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
502 Color := CInt_To_Chtype (Field_Back (Fld)).Color;
507 procedure Set_Pad_Character (Fld : in Field;
508 Pad : in Character := Space)
510 function Set_Field_Pad (Fld : Field;
511 Ch : C_Int) return C_Int;
512 pragma Import (C, Set_Field_Pad, "set_field_pad");
514 Res : constant Eti_Error := Set_Field_Pad (Fld,
515 C_Int (Character'Pos (Pad)));
520 end Set_Pad_Character;
524 procedure Pad_Character (Fld : in Field;
527 function Field_Pad (Fld : Field) return C_Int;
528 pragma Import (C, Field_Pad, "field_pad");
530 Pad := Character'Val (Field_Pad (Fld));
533 -- |=====================================================================
534 -- | man page form_field_info.3x
535 -- |=====================================================================
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)
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)
551 pragma Import (C, Fld_Info, "field_info");
553 L, C, Fr, Fc, Os, Ab : aliased C_Int;
554 Res : constant Eti_Error := Fld_Info (Fld,
556 Fr'Access, Fc'Access,
557 Os'Access, Ab'Access);
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);
573 procedure Dynamic_Info (Fld : in Field;
574 Lines : out Line_Count;
575 Columns : out Column_Count;
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");
582 L, C, M : aliased C_Int;
583 Res : constant Eti_Error := Dyn_Info (Fld,
590 Lines := Line_Count (L);
591 Columns := Column_Count (C);
596 -- |=====================================================================
597 -- | man page form_win.3x
598 -- |=====================================================================
602 procedure Set_Window (Frm : in Form;
605 function Set_Form_Win (Frm : Form;
606 Win : Window) return C_Int;
607 pragma Import (C, Set_Form_Win, "set_form_win");
609 Res : constant Eti_Error := Set_Form_Win (Frm, Win);
618 function Get_Window (Frm : Form) return Window
620 function Form_Win (Frm : Form) return Window;
621 pragma Import (C, Form_Win, "form_win");
623 W : constant Window := Form_Win (Frm);
630 procedure Set_Sub_Window (Frm : in Form;
633 function Set_Form_Sub (Frm : Form;
634 Win : Window) return C_Int;
635 pragma Import (C, Set_Form_Sub, "set_form_sub");
637 Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
646 function Get_Sub_Window (Frm : Form) return Window
648 function Form_Sub (Frm : Form) return Window;
649 pragma Import (C, Form_Sub, "form_sub");
651 W : constant Window := Form_Sub (Frm);
658 procedure Scale (Frm : in Form;
659 Lines : out Line_Count;
660 Columns : out Column_Count)
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");
666 X, Y : aliased C_Int;
667 Res : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
672 Lines := Line_Count (Y);
673 Columns := Column_Count (X);
676 -- |=====================================================================
677 -- | man page menu_hook.3x
678 -- |=====================================================================
682 procedure Set_Field_Init_Hook (Frm : in Form;
683 Proc : in Form_Hook_Function)
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");
689 Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
694 end Set_Field_Init_Hook;
698 procedure Set_Field_Term_Hook (Frm : in Form;
699 Proc : in Form_Hook_Function)
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");
705 Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
710 end Set_Field_Term_Hook;
714 procedure Set_Form_Init_Hook (Frm : in Form;
715 Proc : in Form_Hook_Function)
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");
721 Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
726 end Set_Form_Init_Hook;
730 procedure Set_Form_Term_Hook (Frm : in Form;
731 Proc : in Form_Hook_Function)
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");
737 Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
742 end Set_Form_Term_Hook;
744 -- |=====================================================================
745 -- | man page form_fields.3x
746 -- |=====================================================================
750 procedure Free_Allocated_Fields is
751 new Ada.Unchecked_Deallocation (Field_Array, Field_Array_Access);
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
764 procedure Redefine (Frm : in Form;
765 Flds : in Field_Array)
767 function Set_Frm_Fields (Frm : Form;
768 Items : Field_Array) return C_Int;
769 pragma Import (C, Set_Frm_Fields, "set_form_fields");
771 A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
772 I : Field_Array_Access;
775 if A = null or else A.I = null then raise Form_Exception;
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);
782 Free_Allocated_Fields (I);
785 Free_Allocated_Fields (A.I);
793 function Fields (Frm : Form) return Field_Array_Access
795 A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
797 if A = null or else A.I = null then
798 raise Form_Exception;
806 function Field_Count (Frm : Form) return Natural
808 function Count (Frm : Form) return C_Int;
809 pragma Import (C, Count, "field_count");
811 return Natural (Count (Frm));
816 procedure Move (Fld : in Field;
817 Line : in Line_Position;
818 Column : in Column_Position)
820 function Move (Fld : Field; L, C : C_Int) return C_Int;
821 pragma Import (C, Move, "move_field");
823 Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
830 -- |=====================================================================
831 -- | man page form_new.3x
832 -- |=====================================================================
836 function Create (Fields : Field_Array) return Form
838 function NewForm (Fields : Field_Array) return Form;
839 pragma Import (C, NewForm, "new_form");
842 I : Field_Array_Access;
843 U : Form_User_Wrapper_Access;
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;
854 U := new Form_User_Wrapper'(U => System.Null_Address, I => I);
855 Res := Set_Form_Userptr (M, U);
857 Free_Allocated_Fields (I);
858 Free_Form_User_Wrapper (U);
866 procedure Delete (Frm : in out Form)
868 function Free (Frm : Form) return C_Int;
869 pragma Import (C, Free, "free_form");
871 U : Form_User_Wrapper_Access := Form_Userptr (Frm);
872 Res : constant Eti_Error := Free (Frm);
877 if U = null or else U.I = null then
878 raise Form_Exception;
880 Free_Allocated_Fields (U.I);
881 Free_Form_User_Wrapper (U);
885 -- |=====================================================================
886 -- | man page form_opts.3x
887 -- |=====================================================================
891 procedure Normalize_Form_Options (Options : in out C_Int);
892 pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
894 procedure Set_Options (Frm : in Form;
895 Options : in Form_Option_Set)
897 function Set_Form_Opts (Frm : Form;
898 Opt : C_Int) return C_Int;
899 pragma Import (C, Set_Form_Opts, "set_form_opts");
901 Opt : C_Int := FrmOS_2_CInt (Options);
904 Normalize_Form_Options (Opt);
905 Res := Set_Form_Opts (Frm, Opt);
913 procedure Switch_Options (Frm : in Form;
914 Options : in Form_Option_Set;
915 On : Boolean := True)
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");
925 Opt : C_Int := FrmOS_2_CInt (Options);
927 Normalize_Form_Options (Opt);
929 Err := Form_Opts_On (Frm, Opt);
931 Err := Form_Opts_Off (Frm, Opt);
940 procedure Get_Options (Frm : in Form;
941 Options : out Form_Option_Set)
943 function Form_Opts (Frm : Form) return C_Int;
944 pragma Import (C, Form_Opts, "form_opts");
946 Res : C_Int := Form_Opts (Frm);
948 Normalize_Form_Options (Res);
949 Options := CInt_2_FrmOS (Res);
954 function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
956 Fos : Form_Option_Set;
958 Get_Options (Frm, Fos);
962 -- |=====================================================================
963 -- | man page form_post.3x
964 -- |=====================================================================
968 procedure Post (Frm : in Form;
969 Post : in Boolean := True)
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");
981 Res := M_Unpost (Frm);
988 -- |=====================================================================
989 -- | man page form_cursor.3x
990 -- |=====================================================================
994 procedure Position_Cursor (Frm : Form)
996 function Pos_Form_Cursor (Frm : Form) return C_Int;
997 pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
999 Res : constant Eti_Error := Pos_Form_Cursor (Frm);
1002 Eti_Exception (Res);
1004 end Position_Cursor;
1006 -- |=====================================================================
1007 -- | man page form_data.3x
1008 -- |=====================================================================
1012 function Data_Ahead (Frm : Form) return Boolean
1014 function Ahead (Frm : Form) return C_Int;
1015 pragma Import (C, Ahead, "data_ahead");
1017 Res : constant C_Int := Ahead (Frm);
1019 if Res = Curses_False then
1028 function Data_Behind (Frm : Form) return Boolean
1030 function Behind (Frm : Form) return C_Int;
1031 pragma Import (C, Behind, "data_behind");
1033 Res : constant C_Int := Behind (Frm);
1035 if Res = Curses_False then
1042 -- |=====================================================================
1043 -- | man page form_driver.3x
1044 -- |=====================================================================
1048 function Driver (Frm : Form;
1049 Key : Key_Code) return Driver_Result
1051 function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
1052 pragma Import (C, Frm_Driver, "form_driver");
1054 R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
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;
1072 -- |=====================================================================
1073 -- | man page form_page.3x
1074 -- |=====================================================================
1078 procedure Set_Current (Frm : in Form;
1081 function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
1082 pragma Import (C, Set_Current_Fld, "set_current_field");
1084 Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
1087 Eti_Exception (Res);
1093 function Current (Frm : in Form) return Field
1095 function Current_Fld (Frm : Form) return Field;
1096 pragma Import (C, Current_Fld, "current_field");
1098 Fld : constant Field := Current_Fld (Frm);
1100 if Fld = Null_Field then
1101 raise Form_Exception;
1108 procedure Set_Page (Frm : in Form;
1109 Page : in Page_Number := Page_Number'First)
1111 function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
1112 pragma Import (C, Set_Frm_Page, "set_form_page");
1114 Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
1117 Eti_Exception (Res);
1123 function Page (Frm : Form) return Page_Number
1125 function Get_Page (Frm : Form) return C_Int;
1126 pragma Import (C, Get_Page, "form_page");
1128 P : constant C_Int := Get_Page (Frm);
1131 raise Form_Exception;
1133 return Page_Number (P);
1137 function Get_Index (Fld : Field) return Positive
1139 function Get_Fieldindex (Fld : Field) return C_Int;
1140 pragma Import (C, Get_Fieldindex, "field_index");
1142 Res : constant C_Int := Get_Fieldindex (Fld);
1144 if Res = Curses_Err then
1145 raise Form_Exception;
1147 return Positive (Natural (Res) + Positive'First);
1151 -- |=====================================================================
1152 -- | man page form_new_page.3x
1153 -- |=====================================================================
1157 procedure Set_New_Page (Fld : in Field;
1158 New_Page : in Boolean := True)
1160 function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
1161 pragma Import (C, Set_Page, "set_new_page");
1163 Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
1166 Eti_Exception (Res);
1172 function Is_New_Page (Fld : Field) return Boolean
1174 function Is_New (Fld : Field) return C_Int;
1175 pragma Import (C, Is_New, "new_page");
1177 Res : constant C_Int := Is_New (Fld);
1179 if Res = Curses_False then
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
1190 -- It shouldn´t be too complicated to reimplent this hashing mechanism
1191 -- for other compilers.
1194 type Tag_Pair_Access is access all Tag_Type_Pair;
1195 pragma Controlled (Tag_Pair_Access);
1197 Null_Tag_Pair : constant Tag_Pair_Access := Tag_Pair_Access'(null);
1199 type Tag_Type_Pair is
1203 Next : Tag_Pair_Access;
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);
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;
1214 function Hash (T : Tag) return Htable_Headers;
1215 function Equal (A, B : Tag) return Boolean;
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,
1225 Get_Key => Get_Pair_Tag,
1229 procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access)
1235 function Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access
1241 function Get_Pair_Tag (T : Tag_Pair_Access) return Tag
1244 return T.all.Ada_Tag;
1247 function Equal (A, B : Tag) return Boolean
1253 function Hash (T : Tag) return Htable_Headers
1255 function H is new GNAT.Htable.Hash (Htable_Headers);
1257 return H (External_Tag (T));
1260 function Search_Type (T : Ada_Defined_Field_Type'Class)
1263 P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1268 return Null_Field_Type;
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)
1277 C : C_Field_Type := Search_Type (T);
1278 P : Tag_Pair_Access;
1280 if C /= Null_Field_Type then
1281 raise Form_Exception;
1283 P := new Tag_Type_Pair'(T'Tag, Cft, null);
1284 External_Pair_Htable.Set (P);
1288 -- Unregister an Ada_Defined_Field_Type given by it's tag
1289 procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
1291 function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
1292 pragma Import (C, Free_Fieldtype, "free_fieldtype");
1294 P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1299 raise Form_Exception;
1302 External_Pair_Htable.Remove (T'Tag);
1303 Free_Tag_Type_Pair (P);
1304 Res := Free_Fieldtype (Ft);
1306 Eti_Exception (Res);
1309 end Unregister_Type;
1311 ----------------------------------------------------------------------------
1315 procedure Set_Type (Fld : Field;
1316 Fld_Type : Ada_Defined_Field_Type)
1318 function Set_Fld_Type (F : Field := Fld;
1320 Arg1 : Ada_Defined_Field_Type'Class)
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");
1328 C : constant C_Field_Type := Search_Type (Fld_Type);
1330 if C = Null_Field_Type then
1331 raise Form_Exception;
1333 Res := Set_Fld_Type (Fld, C, Fld_Type);
1335 Eti_Exception (Res);
1342 function Native_Type (Ftype : Ada_Defined_Field_Type)
1345 C : constant C_Field_Type := Search_Type (Ftype);
1347 if C = Null_Field_Type then
1348 raise Form_Exception;
1356 function Native_Type (Ftype : Alpha_Field)
1359 C_Alpha_Field_Type : C_Field_Type;
1360 pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
1362 return C_Alpha_Field_Type;
1364 pragma Inline (Native_Type);
1368 procedure Set_Type (Fld : in Field;
1369 Fld_Type : in Alpha_Field)
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");
1379 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1382 Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1384 Eti_Exception (Res);
1386 A.T := new Alpha_Field'(Fld_Type);
1392 function Native_Type (Ftype : Alpha_Numeric_Field)
1395 C_Alpha_Numeric_Field_Type : C_Field_Type;
1396 pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
1398 return C_Alpha_Numeric_Field_Type;
1400 pragma Inline (Native_Type);
1404 procedure Set_Type (Fld : in Field;
1405 Fld_Type : in Alpha_Numeric_Field)
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");
1415 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1418 Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1420 Eti_Exception (Res);
1422 A.T := new Alpha_Numeric_Field'(Fld_Type);
1428 function Native_Type (Ftype : Integer_Field)
1431 C_Integer_Field_Type : C_Field_Type;
1432 pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
1434 return C_Integer_Field_Type;
1436 pragma Inline (Native_Type);
1440 procedure Set_Type (Fld : in Field;
1441 Fld_Type : in Integer_Field)
1443 function Set_Fld_Type (F : Field := Fld;
1444 Cft : C_Field_Type := Native_Type (Fld_Type);
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");
1453 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
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));
1460 Eti_Exception (Res);
1462 A.T := new Integer_Field'(Fld_Type);
1468 function Native_Type (Ftype : Numeric_Field)
1471 C_Numeric_Field_Type : C_Field_Type;
1472 pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
1474 return C_Numeric_Field_Type;
1476 pragma Inline (Native_Type);
1480 procedure Set_Type (Fld : in Field;
1481 Fld_Type : in Numeric_Field)
1483 type Double is new Interfaces.C.double;
1485 function Set_Fld_Type (F : Field := Fld;
1486 Cft : C_Field_Type := Native_Type (Fld_Type);
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");
1495 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1498 Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
1499 Arg2 => Double (Fld_Type.Lower_Limit),
1500 Arg3 => Double (Fld_Type.Upper_Limit));
1502 Eti_Exception (Res);
1504 A.T := new Numeric_Field'(Fld_Type);
1510 function Native_Type (Ftype : Regular_Expression_Field)
1513 C_Regexp_Field_Type : C_Field_Type;
1514 pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
1516 return C_Regexp_Field_Type;
1518 pragma Inline (Native_Type);
1522 procedure Set_Type (Fld : in Field;
1523 Fld_Type : in Regular_Expression_Field)
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");
1534 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1535 Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
1539 To_C (Fld_Type.Regular_Expression.all, Txt, Len);
1540 Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
1542 Eti_Exception (Res);
1544 A.T := new Regular_Expression_Field'(Fld_Type);
1550 function Native_Type (Ftype : Enumeration_Field)
1553 C_Enum_Type : C_Field_Type;
1554 pragma Import (C, C_Enum_Type, "TYPE_ENUM");
1558 pragma Inline (Native_Type);
1562 function Create (Info : Enumeration_Info;
1563 Auto_Release_Names : Boolean := False)
1564 return Enumeration_Field
1566 procedure Release_String is
1567 new Ada.Unchecked_Deallocation (String,
1569 E : Enumeration_Field;
1570 L : constant size_t := 1 + size_t (Info.C);
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;
1580 E.Arr (size_t (I)) := New_String (Info.Names (I).all);
1581 if Auto_Release_Names then
1582 S := Info.Names (I);
1586 E.Arr (L) := Null_Ptr;
1590 procedure Release (Enum : in out Enumeration_Field)
1597 exit when P = Null_Ptr;
1599 Enum.Arr (I) := Null_Ptr;
1605 procedure Set_Type (Fld : in Field;
1606 Fld_Type : in Enumeration_Field)
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");
1618 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1621 if Fld_Type.Arr = null then
1622 raise Form_Exception;
1624 Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
1625 Arg2 => C_Int (Boolean'Pos
1626 (Fld_Type.Case_Sensitive)),
1629 (Fld_Type.Match_Must_Be_Unique)));
1631 Eti_Exception (Res);
1633 A.T := new Enumeration_Field'(Fld_Type);
1638 function Native_Type (Ftype : Internet_V4_Address_Field)
1641 C_IPV4_Field_Type : C_Field_Type;
1642 pragma Import (C, C_IPV4_Field_Type, "TYPE_IPV4");
1644 return C_IPV4_Field_Type;
1646 pragma Inline (Native_Type);
1650 procedure Set_Type (Fld : in Field;
1651 Fld_Type : in Internet_V4_Address_Field)
1653 function Set_Fld_Type (F : Field := Fld;
1654 Cft : C_Field_Type := Native_Type (Fld_Type))
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");
1661 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1664 Res := Set_Fld_Type;
1666 Eti_Exception (Res);
1668 A.T := new Internet_V4_Address_Field'(Fld_Type);
1673 -- |=====================================================================
1674 -- | man page form_field_validation.3x
1675 -- |=====================================================================
1679 function Get_Type (Fld : in Field) return Field_Type_Access
1681 A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1691 Default_Field_Options := Get_Options (Null_Field);
1692 Default_Form_Options := Get_Options (Null_Form);
1693 end Terminal_Interface.Curses.Forms;