vasilito
ff4ff35918
Red Bear OS is a full fork. All sources must be available from git clone with zero network access. Removed gitignore rules that excluded fetched source trees under recipes/*/source/, local/recipes/kde/*/source/, local/recipes/qt/*/source/, and vendor source trees. Build artifacts (target/, build/, source.tar, *.o, *.so) remain excluded. 127291 files added — kernel, relibc, base, bootloader, pkgar, all KDE/Qt frameworks, mesa, wayland, DRM drivers, and every other recipe source.
1033 lines
32 KiB
Ada
1033 lines
32 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT ncurses Binding --
|
|
-- --
|
|
-- Terminal_Interface.Curses.Forms --
|
|
-- --
|
|
-- B O D Y --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
-- Copyright 2020,2025 Thomas E. Dickey --
|
|
-- Copyright 1999-2011,2014 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.34 $
|
|
-- $Date: 2025/01/24 20:39:23 $
|
|
-- Binding Version 01.00
|
|
------------------------------------------------------------------------------
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
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;
|
|
|
|
procedure Request_Name (Key : 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 Eti_Error;
|
|
pragma Import (C, Free_Field, "free_field");
|
|
|
|
begin
|
|
Eti_Exception (Free_Field (Fld));
|
|
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 : Field;
|
|
Just : Field_Justification := None)
|
|
is
|
|
function Set_Field_Just (Fld : Field;
|
|
Just : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Field_Just, "set_field_just");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Just (Fld,
|
|
C_Int (Field_Justification'Pos (Just))));
|
|
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 : Field;
|
|
Buffer : Buffer_Number := Buffer_Number'First;
|
|
Str : String)
|
|
is
|
|
function Set_Fld_Buffer (Fld : Field;
|
|
Bufnum : C_Int;
|
|
S : char_array)
|
|
return Eti_Error;
|
|
pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
|
|
|
|
begin
|
|
Eti_Exception (Set_Fld_Buffer (Fld, C_Int (Buffer), To_C (Str)));
|
|
end Set_Buffer;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Get_Buffer
|
|
(Fld : Field;
|
|
Buffer : 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 : Field;
|
|
Buffer : 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 : Field;
|
|
Status : Boolean := True)
|
|
is
|
|
function Set_Fld_Status (Fld : Field;
|
|
St : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Fld_Status, "set_field_status");
|
|
|
|
begin
|
|
if Set_Fld_Status (Fld, Boolean'Pos (Status)) /= 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 : Field;
|
|
Max : Natural := 0)
|
|
is
|
|
function Set_Field_Max (Fld : Field;
|
|
M : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Field_Max, "set_max_field");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Max (Fld, C_Int (Max)));
|
|
end Set_Maximum_Size;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_field_opts.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Options (Fld : Field;
|
|
Options : Field_Option_Set)
|
|
is
|
|
function Set_Field_Opts (Fld : Field;
|
|
Opt : Field_Option_Set) return Eti_Error;
|
|
pragma Import (C, Set_Field_Opts, "set_field_opts");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Opts (Fld, Options));
|
|
end Set_Options;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Switch_Options (Fld : Field;
|
|
Options : Field_Option_Set;
|
|
On : Boolean := True)
|
|
is
|
|
function Field_Opts_On (Fld : Field;
|
|
Opt : Field_Option_Set) return Eti_Error;
|
|
pragma Import (C, Field_Opts_On, "field_opts_on");
|
|
function Field_Opts_Off (Fld : Field;
|
|
Opt : Field_Option_Set) return Eti_Error;
|
|
pragma Import (C, Field_Opts_Off, "field_opts_off");
|
|
|
|
begin
|
|
if On then
|
|
Eti_Exception (Field_Opts_On (Fld, Options));
|
|
else
|
|
Eti_Exception (Field_Opts_Off (Fld, Options));
|
|
end if;
|
|
end Switch_Options;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Get_Options (Fld : Field;
|
|
Options : out Field_Option_Set)
|
|
is
|
|
function Field_Opts (Fld : Field) return Field_Option_Set;
|
|
pragma Import (C, Field_Opts, "field_opts");
|
|
|
|
begin
|
|
Options := Field_Opts (Fld);
|
|
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 : Field;
|
|
Fore : Character_Attribute_Set := Normal_Video;
|
|
Color : Color_Pair := Color_Pair'First)
|
|
is
|
|
function Set_Field_Fore (Fld : Field;
|
|
Attr : Attributed_Character) return Eti_Error;
|
|
pragma Import (C, Set_Field_Fore, "set_field_fore");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Fore (Fld, (Ch => Character'First,
|
|
Color => Color,
|
|
Attr => Fore)));
|
|
end Set_Foreground;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Foreground (Fld : Field;
|
|
Fore : out Character_Attribute_Set)
|
|
is
|
|
function Field_Fore (Fld : Field) return Attributed_Character;
|
|
pragma Import (C, Field_Fore, "field_fore");
|
|
begin
|
|
Fore := Field_Fore (Fld).Attr;
|
|
end Foreground;
|
|
|
|
procedure Foreground (Fld : Field;
|
|
Fore : out Character_Attribute_Set;
|
|
Color : out Color_Pair)
|
|
is
|
|
function Field_Fore (Fld : Field) return Attributed_Character;
|
|
pragma Import (C, Field_Fore, "field_fore");
|
|
begin
|
|
Fore := Field_Fore (Fld).Attr;
|
|
Color := Field_Fore (Fld).Color;
|
|
end Foreground;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Background
|
|
(Fld : Field;
|
|
Back : Character_Attribute_Set := Normal_Video;
|
|
Color : Color_Pair := Color_Pair'First)
|
|
is
|
|
function Set_Field_Back (Fld : Field;
|
|
Attr : Attributed_Character) return Eti_Error;
|
|
pragma Import (C, Set_Field_Back, "set_field_back");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Back (Fld, (Ch => Character'First,
|
|
Color => Color,
|
|
Attr => Back)));
|
|
end Set_Background;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Background (Fld : Field;
|
|
Back : out Character_Attribute_Set)
|
|
is
|
|
function Field_Back (Fld : Field) return Attributed_Character;
|
|
pragma Import (C, Field_Back, "field_back");
|
|
begin
|
|
Back := Field_Back (Fld).Attr;
|
|
end Background;
|
|
|
|
procedure Background (Fld : Field;
|
|
Back : out Character_Attribute_Set;
|
|
Color : out Color_Pair)
|
|
is
|
|
function Field_Back (Fld : Field) return Attributed_Character;
|
|
pragma Import (C, Field_Back, "field_back");
|
|
begin
|
|
Back := Field_Back (Fld).Attr;
|
|
Color := Field_Back (Fld).Color;
|
|
end Background;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Pad_Character (Fld : Field;
|
|
Pad : Character := Space)
|
|
is
|
|
function Set_Field_Pad (Fld : Field;
|
|
Ch : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Field_Pad, "set_field_pad");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Pad (Fld,
|
|
C_Int (Character'Pos (Pad))));
|
|
end Set_Pad_Character;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Pad_Character (Fld : 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 : 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 Eti_Error;
|
|
pragma Import (C, Fld_Info, "field_info");
|
|
|
|
L, C, Fr, Fc, Os, Ab : aliased C_Int;
|
|
begin
|
|
Eti_Exception (Fld_Info (Fld,
|
|
L'Access, C'Access,
|
|
Fr'Access, Fc'Access,
|
|
Os'Access, Ab'Access));
|
|
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 Info;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Dynamic_Info (Fld : 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 Eti_Error;
|
|
pragma Import (C, Dyn_Info, "dynamic_field_info");
|
|
|
|
L, C, M : aliased C_Int;
|
|
begin
|
|
Eti_Exception (Dyn_Info (Fld,
|
|
L'Access, C'Access,
|
|
M'Access));
|
|
Lines := Line_Count (L);
|
|
Columns := Column_Count (C);
|
|
Max := Natural (M);
|
|
end Dynamic_Info;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_win.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Window (Frm : Form;
|
|
Win : Window)
|
|
is
|
|
function Set_Form_Win (Frm : Form;
|
|
Win : Window) return Eti_Error;
|
|
pragma Import (C, Set_Form_Win, "set_form_win");
|
|
|
|
begin
|
|
Eti_Exception (Set_Form_Win (Frm, Win));
|
|
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 : Form;
|
|
Win : Window)
|
|
is
|
|
function Set_Form_Sub (Frm : Form;
|
|
Win : Window) return Eti_Error;
|
|
pragma Import (C, Set_Form_Sub, "set_form_sub");
|
|
|
|
begin
|
|
Eti_Exception (Set_Form_Sub (Frm, Win));
|
|
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 : 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 Eti_Error;
|
|
pragma Import (C, M_Scale, "scale_form");
|
|
|
|
X, Y : aliased C_Int;
|
|
begin
|
|
Eti_Exception (M_Scale (Frm, Y'Access, X'Access));
|
|
Lines := Line_Count (Y);
|
|
Columns := Column_Count (X);
|
|
end Scale;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page menu_hook.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Field_Init_Hook (Frm : Form;
|
|
Proc : Form_Hook_Function)
|
|
is
|
|
function Set_Field_Init (Frm : Form;
|
|
Proc : Form_Hook_Function) return Eti_Error;
|
|
pragma Import (C, Set_Field_Init, "set_field_init");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Init (Frm, Proc));
|
|
end Set_Field_Init_Hook;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Field_Term_Hook (Frm : Form;
|
|
Proc : Form_Hook_Function)
|
|
is
|
|
function Set_Field_Term (Frm : Form;
|
|
Proc : Form_Hook_Function) return Eti_Error;
|
|
pragma Import (C, Set_Field_Term, "set_field_term");
|
|
|
|
begin
|
|
Eti_Exception (Set_Field_Term (Frm, Proc));
|
|
end Set_Field_Term_Hook;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Form_Init_Hook (Frm : Form;
|
|
Proc : Form_Hook_Function)
|
|
is
|
|
function Set_Form_Init (Frm : Form;
|
|
Proc : Form_Hook_Function) return Eti_Error;
|
|
pragma Import (C, Set_Form_Init, "set_form_init");
|
|
|
|
begin
|
|
Eti_Exception (Set_Form_Init (Frm, Proc));
|
|
end Set_Form_Init_Hook;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Form_Term_Hook (Frm : Form;
|
|
Proc : Form_Hook_Function)
|
|
is
|
|
function Set_Form_Term (Frm : Form;
|
|
Proc : Form_Hook_Function) return Eti_Error;
|
|
pragma Import (C, Set_Form_Term, "set_form_term");
|
|
|
|
begin
|
|
Eti_Exception (Set_Form_Term (Frm, Proc));
|
|
end Set_Form_Term_Hook;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_fields.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Redefine (Frm : Form;
|
|
Flds : Field_Array_Access)
|
|
is
|
|
function Set_Frm_Fields (Frm : Form;
|
|
Items : System.Address) return Eti_Error;
|
|
pragma Import (C, Set_Frm_Fields, "set_form_fields");
|
|
|
|
begin
|
|
pragma Assert (Flds.all (Flds'Last) = Null_Field);
|
|
if Flds.all (Flds'Last) /= Null_Field then
|
|
raise Form_Exception;
|
|
else
|
|
Eti_Exception (Set_Frm_Fields (Frm, Flds.all (Flds'First)'Address));
|
|
end if;
|
|
end Redefine;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
function Fields (Frm : Form;
|
|
Index : Positive) return Field
|
|
is
|
|
use F_Array;
|
|
|
|
function C_Fields (Frm : Form) return Pointer;
|
|
pragma Import (C, C_Fields, "form_fields");
|
|
|
|
P : Pointer := C_Fields (Frm);
|
|
begin
|
|
if P = null or else Index > Field_Count (Frm) then
|
|
raise Form_Exception;
|
|
else
|
|
P := P + ptrdiff_t (C_Int (Index) - 1);
|
|
return P.all;
|
|
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 : Field;
|
|
Line : Line_Position;
|
|
Column : Column_Position)
|
|
is
|
|
function Move (Fld : Field; L, C : C_Int) return Eti_Error;
|
|
pragma Import (C, Move, "move_field");
|
|
|
|
begin
|
|
Eti_Exception (Move (Fld, C_Int (Line), C_Int (Column)));
|
|
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.all (Fields'Last) = Null_Field);
|
|
if Fields.all (Fields'Last) /= Null_Field then
|
|
raise Form_Exception;
|
|
else
|
|
M := NewForm (Fields.all (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 Eti_Error;
|
|
pragma Import (C, Free, "free_form");
|
|
|
|
begin
|
|
Eti_Exception (Free (Frm));
|
|
Frm := Null_Form;
|
|
end Delete;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_opts.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Options (Frm : Form;
|
|
Options : Form_Option_Set)
|
|
is
|
|
function Set_Form_Opts (Frm : Form;
|
|
Opt : Form_Option_Set) return Eti_Error;
|
|
pragma Import (C, Set_Form_Opts, "set_form_opts");
|
|
|
|
begin
|
|
Eti_Exception (Set_Form_Opts (Frm, Options));
|
|
end Set_Options;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Switch_Options (Frm : Form;
|
|
Options : Form_Option_Set;
|
|
On : Boolean := True)
|
|
is
|
|
function Form_Opts_On (Frm : Form;
|
|
Opt : Form_Option_Set) return Eti_Error;
|
|
pragma Import (C, Form_Opts_On, "form_opts_on");
|
|
function Form_Opts_Off (Frm : Form;
|
|
Opt : Form_Option_Set) return Eti_Error;
|
|
pragma Import (C, Form_Opts_Off, "form_opts_off");
|
|
|
|
begin
|
|
if On then
|
|
Eti_Exception (Form_Opts_On (Frm, Options));
|
|
else
|
|
Eti_Exception (Form_Opts_Off (Frm, Options));
|
|
end if;
|
|
end Switch_Options;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Get_Options (Frm : Form;
|
|
Options : out Form_Option_Set)
|
|
is
|
|
function Form_Opts (Frm : Form) return Form_Option_Set;
|
|
pragma Import (C, Form_Opts, "form_opts");
|
|
|
|
begin
|
|
Options := Form_Opts (Frm);
|
|
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 : Form;
|
|
Post : Boolean := True)
|
|
is
|
|
function M_Post (Frm : Form) return Eti_Error;
|
|
pragma Import (C, M_Post, "post_form");
|
|
function M_Unpost (Frm : Form) return Eti_Error;
|
|
pragma Import (C, M_Unpost, "unpost_form");
|
|
|
|
begin
|
|
if Post then
|
|
Eti_Exception (M_Post (Frm));
|
|
else
|
|
Eti_Exception (M_Unpost (Frm));
|
|
end if;
|
|
end Post;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_cursor.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Position_Cursor (Frm : Form)
|
|
is
|
|
function Pos_Form_Cursor (Frm : Form) return Eti_Error;
|
|
pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
|
|
|
|
begin
|
|
Eti_Exception (Pos_Form_Cursor (Frm));
|
|
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 Eti_Error;
|
|
pragma Import (C, Frm_Driver, "form_driver");
|
|
|
|
R : constant Eti_Error := Frm_Driver (Frm, C_Int (Key));
|
|
begin
|
|
case R is
|
|
when E_Unknown_Command =>
|
|
return Unknown_Request;
|
|
when E_Invalid_Field =>
|
|
return Invalid_Field;
|
|
when E_Request_Denied =>
|
|
return Request_Denied;
|
|
when others =>
|
|
Eti_Exception (R);
|
|
return Form_Ok;
|
|
end case;
|
|
end Driver;
|
|
-- |
|
|
-- |=====================================================================
|
|
-- | man page form_page.3x
|
|
-- |=====================================================================
|
|
-- |
|
|
-- |
|
|
-- |
|
|
procedure Set_Current (Frm : Form;
|
|
Fld : Field)
|
|
is
|
|
function Set_Current_Fld (Frm : Form; Fld : Field) return Eti_Error;
|
|
pragma Import (C, Set_Current_Fld, "set_current_field");
|
|
|
|
begin
|
|
Eti_Exception (Set_Current_Fld (Frm, Fld));
|
|
end Set_Current;
|
|
-- |
|
|
-- |
|
|
-- |
|
|
function Current (Frm : 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 : Form;
|
|
Page : Page_Number := Page_Number'First)
|
|
is
|
|
function Set_Frm_Page (Frm : Form; Pg : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Frm_Page, "set_form_page");
|
|
|
|
begin
|
|
Eti_Exception (Set_Frm_Page (Frm, C_Int (Page)));
|
|
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 : Field;
|
|
New_Page : Boolean := True)
|
|
is
|
|
function Set_Page (Fld : Field; Flg : C_Int) return Eti_Error;
|
|
pragma Import (C, Set_Page, "set_new_page");
|
|
|
|
begin
|
|
Eti_Exception (Set_Page (Fld, Boolean'Pos (New_Page)));
|
|
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 : 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.all (I) /= Null_Field then
|
|
Delete (FA.all (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;
|