+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT ncurses Binding --
--- --
--- Terminal_Interface.Curses.Forms --
--- --
--- B O D Y --
--- --
-------------------------------------------------------------------------------
--- Copyright (c) 1998 Free Software Foundation, Inc. --
--- --
--- Permission is hereby granted, free of charge, to any person obtaining a --
--- copy of this software and associated documentation files (the --
--- "Software"), to deal in the Software without restriction, including --
--- without limitation the rights to use, copy, modify, merge, publish, --
--- distribute, distribute with modifications, sublicense, and/or sell --
--- copies of the Software, and to permit persons to whom the Software is --
--- furnished to do so, subject to the following conditions: --
--- --
--- The above copyright notice and this permission notice shall be included --
--- in all copies or substantial portions of the Software. --
--- --
--- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
--- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
--- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
--- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
--- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
--- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
--- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
--- --
--- Except as contained in this notice, the name(s) of the above copyright --
--- holders shall not be used in advertising or otherwise to promote the --
--- sale, use or other dealings in this Software without prior written --
--- authorization. --
-------------------------------------------------------------------------------
--- Author: Juergen Pfeifer <Juergen.Pfeifer@T-Online.de> 1996
--- Version Control:
--- $Revision: 1.13 $
--- Binding Version 00.93
-------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
-with Unchecked_Conversion;
-
-with Interfaces.C; use Interfaces.C;
-with Interfaces.C.Strings; use Interfaces.C.Strings;
-
-with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
-
-package body Terminal_Interface.Curses.Forms is
-
-------------------------------------------------------------------------------
- -- |
- -- |
- -- |
- -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
-
- function FOS_2_CInt is new
- Unchecked_Conversion (Field_Option_Set,
- C_Int);
-
- function CInt_2_FOS is new
- Unchecked_Conversion (C_Int,
- Field_Option_Set);
-
- function FrmOS_2_CInt is new
- Unchecked_Conversion (Form_Option_Set,
- C_Int);
-
- function CInt_2_FrmOS is new
- Unchecked_Conversion (C_Int,
- Form_Option_Set);
-
- procedure Request_Name (Key : in Form_Request_Code;
- Name : out String)
- is
- function Form_Request_Name (Key : C_Int) return chars_ptr;
- pragma Import (C, Form_Request_Name, "form_request_name");
- begin
- Fill_String (Form_Request_Name (C_Int (Key)), Name);
- end Request_Name;
-
- function Request_Name (Key : Form_Request_Code) return String
- is
- function Form_Request_Name (Key : C_Int) return chars_ptr;
- pragma Import (C, Form_Request_Name, "form_request_name");
- begin
- return Fill_String (Form_Request_Name (C_Int (Key)));
- end Request_Name;
-------------------------------------------------------------------------------
- -- |
- -- |
- -- |
- -- |
- -- |=====================================================================
- -- | man page form_field_new.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- function Create (Height : Line_Count;
- Width : Column_Count;
- Top : Line_Position;
- Left : Column_Position;
- Off_Screen : Natural := 0;
- More_Buffers : Buffer_Number := Buffer_Number'First)
- return Field
- is
- function Newfield (H, W, T, L, O, M : C_Int) return Field;
- pragma Import (C, Newfield, "new_field");
- Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
- C_Int (Top), C_Int (Left),
- C_Int (Off_Screen),
- C_Int (More_Buffers));
- begin
- if Fld = Null_Field then
- raise Form_Exception;
- end if;
- return Fld;
- end Create;
--- |
--- |
--- |
- procedure Delete (Fld : in out Field)
- is
- function Free_Field (Fld : Field) return C_Int;
- pragma Import (C, Free_Field, "free_field");
-
- Res : Eti_Error;
- begin
- Res := Free_Field (Fld);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- Fld := Null_Field;
- end Delete;
- -- |
- -- |
- -- |
- function Duplicate (Fld : Field;
- Top : Line_Position;
- Left : Column_Position) return Field
- is
- function Dup_Field (Fld : Field;
- Top : C_Int;
- Left : C_Int) return Field;
- pragma Import (C, Dup_Field, "dup_field");
-
- F : constant Field := Dup_Field (Fld,
- C_Int (Top),
- C_Int (Left));
- begin
- if F = Null_Field then
- raise Form_Exception;
- end if;
- return F;
- end Duplicate;
- -- |
- -- |
- -- |
- function Link (Fld : Field;
- Top : Line_Position;
- Left : Column_Position) return Field
- is
- function Lnk_Field (Fld : Field;
- Top : C_Int;
- Left : C_Int) return Field;
- pragma Import (C, Lnk_Field, "link_field");
-
- F : constant Field := Lnk_Field (Fld,
- C_Int (Top),
- C_Int (Left));
- begin
- if F = Null_Field then
- raise Form_Exception;
- end if;
- return F;
- end Link;
- -- |
- -- |=====================================================================
- -- | man page form_field_just.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Justification (Fld : in Field;
- Just : in Field_Justification := None)
- is
- function Set_Field_Just (Fld : Field;
- Just : C_Int) return C_Int;
- pragma Import (C, Set_Field_Just, "set_field_just");
-
- Res : constant Eti_Error :=
- Set_Field_Just (Fld,
- C_Int (Field_Justification'Pos (Just)));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Justification;
- -- |
- -- |
- -- |
- function Get_Justification (Fld : Field) return Field_Justification
- is
- function Field_Just (Fld : Field) return C_Int;
- pragma Import (C, Field_Just, "field_just");
- begin
- return Field_Justification'Val (Field_Just (Fld));
- end Get_Justification;
- -- |
- -- |=====================================================================
- -- | man page form_field_buffer.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First;
- Str : in String)
- is
- type Char_Ptr is access all Interfaces.C.Char;
- function Set_Fld_Buffer (Fld : Field;
- Bufnum : C_Int;
- S : Char_Ptr)
- return C_Int;
- pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
-
- Txt : char_array (0 .. Str'Length);
- Len : size_t;
- Res : Eti_Error;
- begin
- To_C (Str, Txt, Len);
- Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Buffer;
- -- |
- -- |
- -- |
- procedure Get_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First;
- Str : out String)
- is
- function Field_Buffer (Fld : Field;
- B : C_Int) return chars_ptr;
- pragma Import (C, Field_Buffer, "field_buffer");
- begin
- Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
- end Get_Buffer;
-
- function Get_Buffer
- (Fld : in Field;
- Buffer : in Buffer_Number := Buffer_Number'First) return String
- is
- function Field_Buffer (Fld : Field;
- B : C_Int) return chars_ptr;
- pragma Import (C, Field_Buffer, "field_buffer");
- begin
- return Fill_String (Field_Buffer (Fld, C_Int (Buffer)));
- end Get_Buffer;
- -- |
- -- |
- -- |
- procedure Set_Status (Fld : in Field;
- Status : in Boolean := True)
- is
- function Set_Fld_Status (Fld : Field;
- St : C_Int) return C_Int;
- pragma Import (C, Set_Fld_Status, "set_field_status");
-
- Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
- begin
- if Res /= E_Ok then
- raise Form_Exception;
- end if;
- end Set_Status;
- -- |
- -- |
- -- |
- function Changed (Fld : Field) return Boolean
- is
- function Field_Status (Fld : Field) return C_Int;
- pragma Import (C, Field_Status, "field_status");
-
- Res : constant C_Int := Field_Status (Fld);
- begin
- if Res = Curses_False then
- return False;
- else
- return True;
- end if;
- end Changed;
- -- |
- -- |
- -- |
- procedure Set_Maximum_Size (Fld : in Field;
- Max : in Natural := 0)
- is
- function Set_Field_Max (Fld : Field;
- M : C_Int) return C_Int;
- pragma Import (C, Set_Field_Max, "set_max_field");
-
- Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Maximum_Size;
- -- |
- -- |=====================================================================
- -- | man page form_field_opts.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Normalize_Field_Options (Options : in out C_Int);
- pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
-
- procedure Set_Options (Fld : in Field;
- Options : in Field_Option_Set)
- is
- function Set_Field_Opts (Fld : Field;
- Opt : C_Int) return C_Int;
- pragma Import (C, Set_Field_Opts, "set_field_opts");
-
- Opt : C_Int := FOS_2_CInt (Options);
- Res : Eti_Error;
- begin
- Normalize_Field_Options (Opt);
- Res := Set_Field_Opts (Fld, Opt);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Options;
- -- |
- -- |
- -- |
- procedure Switch_Options (Fld : in Field;
- Options : in Field_Option_Set;
- On : Boolean := True)
- is
- function Field_Opts_On (Fld : Field;
- Opt : C_Int) return C_Int;
- pragma Import (C, Field_Opts_On, "field_opts_on");
- function Field_Opts_Off (Fld : Field;
- Opt : C_Int) return C_Int;
- pragma Import (C, Field_Opts_Off, "field_opts_off");
-
- Err : Eti_Error;
- Opt : C_Int := FOS_2_CInt (Options);
- begin
- Normalize_Field_Options (Opt);
- if On then
- Err := Field_Opts_On (Fld, Opt);
- else
- Err := Field_Opts_Off (Fld, Opt);
- end if;
- if Err /= E_Ok then
- Eti_Exception (Err);
- end if;
- end Switch_Options;
- -- |
- -- |
- -- |
- procedure Get_Options (Fld : in Field;
- Options : out Field_Option_Set)
- is
- function Field_Opts (Fld : Field) return C_Int;
- pragma Import (C, Field_Opts, "field_opts");
-
- Res : C_Int := Field_Opts (Fld);
- begin
- Normalize_Field_Options (Res);
- Options := CInt_2_FOS (Res);
- end Get_Options;
- -- |
- -- |
- -- |
- function Get_Options (Fld : Field := Null_Field)
- return Field_Option_Set
- is
- Fos : Field_Option_Set;
- begin
- Get_Options (Fld, Fos);
- return Fos;
- end Get_Options;
- -- |
- -- |=====================================================================
- -- | man page form_field_attributes.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Foreground
- (Fld : in Field;
- Fore : in Character_Attribute_Set := Normal_Video;
- Color : in Color_Pair := Color_Pair'First)
- is
- function Set_Field_Fore (Fld : Field;
- Attr : C_Int) return C_Int;
- pragma Import (C, Set_Field_Fore, "set_field_fore");
-
- Ch : constant Attributed_Character := (Ch => Character'First,
- Color => Color,
- Attr => Fore);
- Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Foreground;
- -- |
- -- |
- -- |
- procedure Foreground (Fld : in Field;
- Fore : out Character_Attribute_Set)
- is
- function Field_Fore (Fld : Field) return C_Int;
- pragma Import (C, Field_Fore, "field_fore");
- begin
- Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
- end Foreground;
-
- procedure Foreground (Fld : in Field;
- Fore : out Character_Attribute_Set;
- Color : out Color_Pair)
- is
- function Field_Fore (Fld : Field) return C_Int;
- pragma Import (C, Field_Fore, "field_fore");
- begin
- Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
- Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
- end Foreground;
- -- |
- -- |
- -- |
- procedure Set_Background
- (Fld : in Field;
- Back : in Character_Attribute_Set := Normal_Video;
- Color : in Color_Pair := Color_Pair'First)
- is
- function Set_Field_Back (Fld : Field;
- Attr : C_Int) return C_Int;
- pragma Import (C, Set_Field_Back, "set_field_back");
-
- Ch : constant Attributed_Character := (Ch => Character'First,
- Color => Color,
- Attr => Back);
- Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Background;
- -- |
- -- |
- -- |
- procedure Background (Fld : in Field;
- Back : out Character_Attribute_Set)
- is
- function Field_Back (Fld : Field) return C_Int;
- pragma Import (C, Field_Back, "field_back");
- begin
- Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
- end Background;
-
- procedure Background (Fld : in Field;
- Back : out Character_Attribute_Set;
- Color : out Color_Pair)
- is
- function Field_Back (Fld : Field) return C_Int;
- pragma Import (C, Field_Back, "field_back");
- begin
- Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
- Color := CInt_To_Chtype (Field_Back (Fld)).Color;
- end Background;
- -- |
- -- |
- -- |
- procedure Set_Pad_Character (Fld : in Field;
- Pad : in Character := Space)
- is
- function Set_Field_Pad (Fld : Field;
- Ch : C_Int) return C_Int;
- pragma Import (C, Set_Field_Pad, "set_field_pad");
-
- Res : constant Eti_Error := Set_Field_Pad (Fld,
- C_Int (Character'Pos (Pad)));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Pad_Character;
- -- |
- -- |
- -- |
- procedure Pad_Character (Fld : in Field;
- Pad : out Character)
- is
- function Field_Pad (Fld : Field) return C_Int;
- pragma Import (C, Field_Pad, "field_pad");
- begin
- Pad := Character'Val (Field_Pad (Fld));
- end Pad_Character;
- -- |
- -- |=====================================================================
- -- | man page form_field_info.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Info (Fld : in Field;
- Lines : out Line_Count;
- Columns : out Column_Count;
- First_Row : out Line_Position;
- First_Column : out Column_Position;
- Off_Screen : out Natural;
- Additional_Buffers : out Buffer_Number)
- is
- type C_Int_Access is access all C_Int;
- function Fld_Info (Fld : Field;
- L, C, Fr, Fc, Os, Ab : C_Int_Access)
- return C_Int;
- pragma Import (C, Fld_Info, "field_info");
-
- L, C, Fr, Fc, Os, Ab : aliased C_Int;
- Res : constant Eti_Error := Fld_Info (Fld,
- L'Access, C'Access,
- Fr'Access, Fc'Access,
- Os'Access, Ab'Access);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- Lines := Line_Count (L);
- Columns := Column_Count (C);
- First_Row := Line_Position (Fr);
- First_Column := Column_Position (Fc);
- Off_Screen := Natural (Os);
- Additional_Buffers := Buffer_Number (Ab);
- end if;
- end Info;
--- |
--- |
--- |
- procedure Dynamic_Info (Fld : in Field;
- Lines : out Line_Count;
- Columns : out Column_Count;
- Max : out Natural)
- is
- type C_Int_Access is access all C_Int;
- function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
- pragma Import (C, Dyn_Info, "dynamic_field_info");
-
- L, C, M : aliased C_Int;
- Res : constant Eti_Error := Dyn_Info (Fld,
- L'Access, C'Access,
- M'Access);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- Lines := Line_Count (L);
- Columns := Column_Count (C);
- Max := Natural (M);
- end if;
- end Dynamic_Info;
- -- |
- -- |=====================================================================
- -- | man page form_win.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Window (Frm : in Form;
- Win : in Window)
- is
- function Set_Form_Win (Frm : Form;
- Win : Window) return C_Int;
- pragma Import (C, Set_Form_Win, "set_form_win");
-
- Res : constant Eti_Error := Set_Form_Win (Frm, Win);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Window;
- -- |
- -- |
- -- |
- function Get_Window (Frm : Form) return Window
- is
- function Form_Win (Frm : Form) return Window;
- pragma Import (C, Form_Win, "form_win");
-
- W : constant Window := Form_Win (Frm);
- begin
- return W;
- end Get_Window;
- -- |
- -- |
- -- |
- procedure Set_Sub_Window (Frm : in Form;
- Win : in Window)
- is
- function Set_Form_Sub (Frm : Form;
- Win : Window) return C_Int;
- pragma Import (C, Set_Form_Sub, "set_form_sub");
-
- Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Sub_Window;
- -- |
- -- |
- -- |
- function Get_Sub_Window (Frm : Form) return Window
- is
- function Form_Sub (Frm : Form) return Window;
- pragma Import (C, Form_Sub, "form_sub");
-
- W : constant Window := Form_Sub (Frm);
- begin
- return W;
- end Get_Sub_Window;
- -- |
- -- |
- -- |
- procedure Scale (Frm : in Form;
- Lines : out Line_Count;
- Columns : out Column_Count)
- is
- type C_Int_Access is access all C_Int;
- function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
- pragma Import (C, M_Scale, "scale_form");
-
- X, Y : aliased C_Int;
- Res : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- Lines := Line_Count (Y);
- Columns := Column_Count (X);
- end Scale;
- -- |
- -- |=====================================================================
- -- | man page menu_hook.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Field_Init_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
- is
- function Set_Field_Init (Frm : Form;
- Proc : Form_Hook_Function) return C_Int;
- pragma Import (C, Set_Field_Init, "set_field_init");
-
- Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Field_Init_Hook;
- -- |
- -- |
- -- |
- procedure Set_Field_Term_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
- is
- function Set_Field_Term (Frm : Form;
- Proc : Form_Hook_Function) return C_Int;
- pragma Import (C, Set_Field_Term, "set_field_term");
-
- Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Field_Term_Hook;
- -- |
- -- |
- -- |
- procedure Set_Form_Init_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
- is
- function Set_Form_Init (Frm : Form;
- Proc : Form_Hook_Function) return C_Int;
- pragma Import (C, Set_Form_Init, "set_form_init");
-
- Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Form_Init_Hook;
- -- |
- -- |
- -- |
- procedure Set_Form_Term_Hook (Frm : in Form;
- Proc : in Form_Hook_Function)
- is
- function Set_Form_Term (Frm : Form;
- Proc : Form_Hook_Function) return C_Int;
- pragma Import (C, Set_Form_Term, "set_form_term");
-
- Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Form_Term_Hook;
- -- |
- -- |=====================================================================
- -- | man page form_fields.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Redefine (Frm : in Form;
- Flds : in Field_Array_Access)
- is
- function Set_Frm_Fields (Frm : Form;
- Items : System.Address) return C_Int;
- pragma Import (C, Set_Frm_Fields, "set_form_fields");
-
- Res : Eti_Error;
- begin
- pragma Assert (Flds (Flds'Last) = Null_Field);
- if Flds (Flds'Last) /= Null_Field then
- raise Form_Exception;
- else
- Res := Set_Frm_Fields (Frm, Flds (Flds'First)'Address);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end if;
- end Redefine;
- -- |
- -- |
- -- |
- function Fields (Frm : Form;
- Index : Positive) return Field
- is
- function F_Fields (Frm : Form;
- Idx : C_Int) return Field;
- pragma Import (C, F_Fields, "_nc_get_field");
- begin
- if Frm = Null_Form or else Index not in 1 .. Field_Count (Frm) then
- raise Form_Exception;
- else
- return F_Fields (Frm, C_Int (Index) - 1);
- end if;
- end Fields;
- -- |
- -- |
- -- |
- function Field_Count (Frm : Form) return Natural
- is
- function Count (Frm : Form) return C_Int;
- pragma Import (C, Count, "field_count");
- begin
- return Natural (Count (Frm));
- end Field_Count;
- -- |
- -- |
- -- |
- procedure Move (Fld : in Field;
- Line : in Line_Position;
- Column : in Column_Position)
- is
- function Move (Fld : Field; L, C : C_Int) return C_Int;
- pragma Import (C, Move, "move_field");
-
- Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Move;
- -- |
- -- |=====================================================================
- -- | man page form_new.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- function Create (Fields : Field_Array_Access) return Form
- is
- function NewForm (Fields : System.Address) return Form;
- pragma Import (C, NewForm, "new_form");
-
- M : Form;
- begin
- pragma Assert (Fields (Fields'Last) = Null_Field);
- if Fields (Fields'Last) /= Null_Field then
- raise Form_Exception;
- else
- M := NewForm (Fields (Fields'First)'Address);
- if M = Null_Form then
- raise Form_Exception;
- end if;
- return M;
- end if;
- end Create;
- -- |
- -- |
- -- |
- procedure Delete (Frm : in out Form)
- is
- function Free (Frm : Form) return C_Int;
- pragma Import (C, Free, "free_form");
-
- Res : constant Eti_Error := Free (Frm);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- Frm := Null_Form;
- end Delete;
- -- |
- -- |=====================================================================
- -- | man page form_opts.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Normalize_Form_Options (Options : in out C_Int);
- pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
-
- procedure Set_Options (Frm : in Form;
- Options : in Form_Option_Set)
- is
- function Set_Form_Opts (Frm : Form;
- Opt : C_Int) return C_Int;
- pragma Import (C, Set_Form_Opts, "set_form_opts");
-
- Opt : C_Int := FrmOS_2_CInt (Options);
- Res : Eti_Error;
- begin
- Normalize_Form_Options (Opt);
- Res := Set_Form_Opts (Frm, Opt);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Options;
- -- |
- -- |
- -- |
- procedure Switch_Options (Frm : in Form;
- Options : in Form_Option_Set;
- On : Boolean := True)
- is
- function Form_Opts_On (Frm : Form;
- Opt : C_Int) return C_Int;
- pragma Import (C, Form_Opts_On, "form_opts_on");
- function Form_Opts_Off (Frm : Form;
- Opt : C_Int) return C_Int;
- pragma Import (C, Form_Opts_Off, "form_opts_off");
-
- Err : Eti_Error;
- Opt : C_Int := FrmOS_2_CInt (Options);
- begin
- Normalize_Form_Options (Opt);
- if On then
- Err := Form_Opts_On (Frm, Opt);
- else
- Err := Form_Opts_Off (Frm, Opt);
- end if;
- if Err /= E_Ok then
- Eti_Exception (Err);
- end if;
- end Switch_Options;
- -- |
- -- |
- -- |
- procedure Get_Options (Frm : in Form;
- Options : out Form_Option_Set)
- is
- function Form_Opts (Frm : Form) return C_Int;
- pragma Import (C, Form_Opts, "form_opts");
-
- Res : C_Int := Form_Opts (Frm);
- begin
- Normalize_Form_Options (Res);
- Options := CInt_2_FrmOS (Res);
- end Get_Options;
- -- |
- -- |
- -- |
- function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
- is
- Fos : Form_Option_Set;
- begin
- Get_Options (Frm, Fos);
- return Fos;
- end Get_Options;
- -- |
- -- |=====================================================================
- -- | man page form_post.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Post (Frm : in Form;
- Post : in Boolean := True)
- is
- function M_Post (Frm : Form) return C_Int;
- pragma Import (C, M_Post, "post_form");
- function M_Unpost (Frm : Form) return C_Int;
- pragma Import (C, M_Unpost, "unpost_form");
-
- Res : Eti_Error;
- begin
- if Post then
- Res := M_Post (Frm);
- else
- Res := M_Unpost (Frm);
- end if;
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Post;
- -- |
- -- |=====================================================================
- -- | man page form_cursor.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Position_Cursor (Frm : Form)
- is
- function Pos_Form_Cursor (Frm : Form) return C_Int;
- pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
-
- Res : constant Eti_Error := Pos_Form_Cursor (Frm);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Position_Cursor;
- -- |
- -- |=====================================================================
- -- | man page form_data.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- function Data_Ahead (Frm : Form) return Boolean
- is
- function Ahead (Frm : Form) return C_Int;
- pragma Import (C, Ahead, "data_ahead");
-
- Res : constant C_Int := Ahead (Frm);
- begin
- if Res = Curses_False then
- return False;
- else
- return True;
- end if;
- end Data_Ahead;
- -- |
- -- |
- -- |
- function Data_Behind (Frm : Form) return Boolean
- is
- function Behind (Frm : Form) return C_Int;
- pragma Import (C, Behind, "data_behind");
-
- Res : constant C_Int := Behind (Frm);
- begin
- if Res = Curses_False then
- return False;
- else
- return True;
- end if;
- end Data_Behind;
- -- |
- -- |=====================================================================
- -- | man page form_driver.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- function Driver (Frm : Form;
- Key : Key_Code) return Driver_Result
- is
- function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
- pragma Import (C, Frm_Driver, "form_driver");
-
- R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
- begin
- if R /= E_Ok then
- if R = E_Unknown_Command then
- return Unknown_Request;
- elsif R = E_Invalid_Field then
- return Invalid_Field;
- elsif R = E_Request_Denied then
- return Request_Denied;
- else
- Eti_Exception (R);
- return Form_Ok;
- end if;
- else
- return Form_Ok;
- end if;
- end Driver;
- -- |
- -- |=====================================================================
- -- | man page form_page.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_Current (Frm : in Form;
- Fld : in Field)
- is
- function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
- pragma Import (C, Set_Current_Fld, "set_current_field");
-
- Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Current;
- -- |
- -- |
- -- |
- function Current (Frm : in Form) return Field
- is
- function Current_Fld (Frm : Form) return Field;
- pragma Import (C, Current_Fld, "current_field");
-
- Fld : constant Field := Current_Fld (Frm);
- begin
- if Fld = Null_Field then
- raise Form_Exception;
- end if;
- return Fld;
- end Current;
- -- |
- -- |
- -- |
- procedure Set_Page (Frm : in Form;
- Page : in Page_Number := Page_Number'First)
- is
- function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
- pragma Import (C, Set_Frm_Page, "set_form_page");
-
- Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_Page;
- -- |
- -- |
- -- |
- function Page (Frm : Form) return Page_Number
- is
- function Get_Page (Frm : Form) return C_Int;
- pragma Import (C, Get_Page, "form_page");
-
- P : constant C_Int := Get_Page (Frm);
- begin
- if P < 0 then
- raise Form_Exception;
- else
- return Page_Number (P);
- end if;
- end Page;
-
- function Get_Index (Fld : Field) return Positive
- is
- function Get_Fieldindex (Fld : Field) return C_Int;
- pragma Import (C, Get_Fieldindex, "field_index");
-
- Res : constant C_Int := Get_Fieldindex (Fld);
- begin
- if Res = Curses_Err then
- raise Form_Exception;
- end if;
- return Positive (Natural (Res) + Positive'First);
- end Get_Index;
-
- -- |
- -- |=====================================================================
- -- | man page form_new_page.3x
- -- |=====================================================================
- -- |
- -- |
- -- |
- procedure Set_New_Page (Fld : in Field;
- New_Page : in Boolean := True)
- is
- function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
- pragma Import (C, Set_Page, "set_new_page");
-
- Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
- begin
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end Set_New_Page;
- -- |
- -- |
- -- |
- function Is_New_Page (Fld : Field) return Boolean
- is
- function Is_New (Fld : Field) return C_Int;
- pragma Import (C, Is_New, "new_page");
-
- Res : constant C_Int := Is_New (Fld);
- begin
- if Res = Curses_False then
- return False;
- else
- return True;
- end if;
- end Is_New_Page;
-
- procedure Free (FA : in out Field_Array_Access;
- Free_Fields : in Boolean := False)
- is
- procedure Release is new Ada.Unchecked_Deallocation
- (Field_Array, Field_Array_Access);
- begin
- if FA /= null and then Free_Fields then
- for I in FA'First .. (FA'Last - 1) loop
- if (FA (I) /= Null_Field) then
- Delete (FA (I));
- end if;
- end loop;
- end if;
- Release (FA);
- end Free;
-
- -- |=====================================================================
-
- function Default_Field_Options return Field_Option_Set
- is
- begin
- return Get_Options (Null_Field);
- end Default_Field_Options;
-
- function Default_Form_Options return Form_Option_Set
- is
- begin
- return Get_Options (Null_Form);
- end Default_Form_Options;
-
-end Terminal_Interface.Curses.Forms;
projects / ncurses.git / blobdiff