--------------------------------------------------------------------------------                                                                          ----                           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, 1996--  Version Control:--  $Revision: 1.22 $--  Binding Version 01.00------------------------------------------------------------------------------with Ada.Unchecked_Deallocation;with Ada.Unchecked_Conversion;with Interfaces.C; use Interfaces.C;with Interfaces.C.Strings; use Interfaces.C.Strings;with Interfaces.C.Pointers;with Terminal_Interface.Curses.Aux;package body Terminal_Interface.Curses.Forms is   use Terminal_Interface.Curses.Aux;   type C_Field_Array is array (Natural range <>) of aliased Field;   package F_Array is new     Interfaces.C.Pointers (Natural, Field, C_Field_Array, Null_Field);------------------------------------------------------------------------------   --  |   --  |   --  |   --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;   function FOS_2_CInt is new     Ada.Unchecked_Conversion (Field_Option_Set,                               C_Int);   function CInt_2_FOS is new     Ada.Unchecked_Conversion (C_Int,                               Field_Option_Set);   function FrmOS_2_CInt is new     Ada.Unchecked_Conversion (Form_Option_Set,                               C_Int);   function CInt_2_FrmOS is new     Ada.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 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      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      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      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