X-Git-Url: http://ncurses.scripts.mit.edu/?p=ncurses.git;a=blobdiff_plain;f=Ada95%2Fsrc%2Fterminal_interface-curses.adb;h=f196f3b5e1d3b70037b4e8485305184a1e0f4aeb;hp=1f536d141c15a673e1298be94249bf72b998c543;hb=46722468f47c2b77b3987729b4bcf2321cccfd01;hpb=0eb88fc5281804773e2a0c7a488a4452463535ce diff --git a/Ada95/src/terminal_interface-curses.adb b/Ada95/src/terminal_interface-curses.adb index 1f536d14..f196f3b5 100644 --- a/Ada95/src/terminal_interface-curses.adb +++ b/Ada95/src/terminal_interface-curses.adb @@ -33,9 +33,10 @@ -- sale, use or other dealings in this Software without prior written -- -- authorization. -- ------------------------------------------------------------------------------ --- Author: Juergen Pfeifer 1996 +-- Author: Juergen Pfeifer, 1996 +-- Contact: http://www.familiepfeifer.de/Contact.aspx?Lang=en -- Version Control: --- $Revision: 1.25 $ +-- $Revision: 1.28 $ -- Binding Version 01.00 ------------------------------------------------------------------------------ with System; @@ -89,6 +90,27 @@ package body Terminal_Interface.Curses is function W_Get_Short is new W_Get_Element (C_Short); function W_Get_Byte is new W_Get_Element (Interfaces.C.unsigned_char); + function Get_Flag (Win : Window; + Offset : Natural) return Boolean; + + function Get_Flag (Win : Window; + Offset : Natural) return Boolean + is + Res : C_Int; + begin + case Sizeof_bool is + when 1 => Res := C_Int (W_Get_Byte (Win, Offset)); + when 2 => Res := C_Int (W_Get_Short (Win, Offset)); + when 4 => Res := C_Int (W_Get_Int (Win, Offset)); + when others => raise Curses_Exception; + end case; + + case Res is + when 0 => return False; + when others => return True; + end case; + end Get_Flag; + ------------------------------------------------------------------------------ function Key_Name (Key : in Real_Key_Code) return String is @@ -404,9 +426,8 @@ package body Terminal_Interface.Curses is Str : in String; Len : in Integer := -1) is - type Char_Ptr is access all Interfaces.C.char; function Waddnstr (Win : Window; - Str : Char_Ptr; + Str : char_array; Len : C_Int := -1) return C_Int; pragma Import (C, Waddnstr, "waddnstr"); @@ -414,7 +435,7 @@ package body Terminal_Interface.Curses is Length : size_t; begin To_C (Str, Txt, Length); - if Waddnstr (Win, Txt (Txt'First)'Access, C_Int (Len)) = Curses_Err then + if Waddnstr (Win, Txt, C_Int (Len)) = Curses_Err then raise Curses_Exception; end if; end Add; @@ -436,9 +457,8 @@ package body Terminal_Interface.Curses is Str : in Attributed_String; Len : in Integer := -1) is - type Chtype_Ptr is access all Attributed_Character; function Waddchnstr (Win : Window; - Str : Chtype_Ptr; + Str : chtype_array; Len : C_Int := -1) return C_Int; pragma Import (C, Waddchnstr, "waddchnstr"); @@ -449,7 +469,7 @@ package body Terminal_Interface.Curses is end loop; Txt (Str'Length) := Default_Character; if Waddchnstr (Win, - Txt (Txt'First)'Access, + Txt, C_Int (Len)) = Curses_Err then raise Curses_Exception; end if; @@ -616,6 +636,26 @@ package body Terminal_Interface.Curses is return Real_Key_Code (Natural (Key_F0) + Natural (Key)); end Function_Key_Code; ------------------------------------------------------------------------------ + procedure Standout (Win : Window := Standard_Window; + On : Boolean := True) + is + function wstandout (Win : Window) return C_Int; + pragma Import (C, wstandout, "wstandout"); + function wstandend (Win : Window) return C_Int; + pragma Import (C, wstandend, "wstandend"); + + Err : C_Int; + begin + if On then + Err := wstandout (Win); + else + Err := wstandend (Win); + end if; + if Err = Curses_Err then + raise Curses_Exception; + end if; + end Standout; + procedure Switch_Character_Attribute (Win : in Window := Standard_Window; Attr : in Character_Attribute_Set := Normal_Video; @@ -858,6 +898,13 @@ package body Terminal_Interface.Curses is end if; end Set_KeyPad_Mode; + function Get_KeyPad_Mode (Win : in Window := Standard_Window) + return Boolean + is + begin + return Get_Flag (Win, Offset_use_keypad); + end Get_KeyPad_Mode; + procedure Half_Delay (Amount : in Half_Delay_Amount) is function Halfdelay (Amount : C_Int) return C_Int; @@ -922,7 +969,7 @@ package body Terminal_Interface.Curses is when Non_Blocking => Time := 0; when Delayed => if Amount = 0 then - raise CONSTRAINT_ERROR; + raise Constraint_Error; end if; Time := C_Int (Amount); end case; @@ -1036,21 +1083,11 @@ package body Terminal_Interface.Curses is end if; end Allow_Scrolling; - function Scrolling_Allowed (Win : Window := Standard_Window) return Boolean + function Scrolling_Allowed (Win : Window := Standard_Window) + return Boolean is - Res : C_Int; begin - case Sizeof_bool is - when 1 => Res := C_Int (W_Get_Byte (Win, Offset_scroll)); - when 2 => Res := C_Int (W_Get_Short (Win, Offset_scroll)); - when 4 => Res := C_Int (W_Get_Int (Win, Offset_scroll)); - when others => raise Curses_Exception; - end case; - - case Res is - when 0 => return False; - when others => return True; - end case; + return Get_Flag (Win, Offset_scroll); end Scrolling_Allowed; procedure Set_Scroll_Region @@ -1636,9 +1673,8 @@ package body Terminal_Interface.Curses is Str : in String; Len : in Integer := -1) is - type Char_Ptr is access all Interfaces.C.char; function Winsnstr (Win : Window; - Str : Char_Ptr; + Str : char_array; Len : Integer := -1) return C_Int; pragma Import (C, Winsnstr, "winsnstr"); @@ -1646,7 +1682,7 @@ package body Terminal_Interface.Curses is Length : size_t; begin To_C (Str, Txt, Length); - if Winsnstr (Win, Txt (Txt'First)'Access, Len) = Curses_Err then + if Winsnstr (Win, Txt, Len) = Curses_Err then raise Curses_Exception; end if; end Insert; @@ -1658,11 +1694,10 @@ package body Terminal_Interface.Curses is Str : in String; Len : in Integer := -1) is - type Char_Ptr is access all Interfaces.C.char; function Mvwinsnstr (Win : Window; Line : C_Int; Column : C_Int; - Str : Char_Ptr; + Str : char_array; Len : C_Int) return C_Int; pragma Import (C, Mvwinsnstr, "mvwinsnstr"); @@ -1670,8 +1705,7 @@ package body Terminal_Interface.Curses is Length : size_t; begin To_C (Str, Txt, Length); - if Mvwinsnstr (Win, C_Int (Line), C_Int (Column), - Txt (Txt'First)'Access, C_Int (Len)) + if Mvwinsnstr (Win, C_Int (Line), C_Int (Column), Txt, C_Int (Len)) = Curses_Err then raise Curses_Exception; end if; @@ -1723,14 +1757,13 @@ package body Terminal_Interface.Curses is Str : out Attributed_String; Len : in Integer := -1) is - type Chtype_Ptr is access all Attributed_Character; function Winchnstr (Win : Window; - Str : Chtype_Ptr; + Str : chtype_array; -- out Len : C_Int) return C_Int; pragma Import (C, Winchnstr, "winchnstr"); N : Integer := Len; - Txt : chtype_array (0 .. Str'Length); + Txt : chtype_array (0 .. Str'Length) := (0 => Default_Character); Cnt : Natural := 0; begin if N < 0 then @@ -1739,7 +1772,7 @@ package body Terminal_Interface.Curses is if N > Str'Length then raise Constraint_Error; end if; - if Winchnstr (Win, Txt (Txt'First)'Access, C_Int (N)) = Curses_Err then + if Winchnstr (Win, Txt, C_Int (N)) = Curses_Err then raise Curses_Exception; end if; for To in Str'Range loop @@ -1823,9 +1856,8 @@ package body Terminal_Interface.Curses is Text : in String; Fmt : in Label_Justification := Left) is - type Char_Ptr is access all Interfaces.C.char; function Slk_Set (Label : C_Int; - Txt : Char_Ptr; + Txt : char_array; Fmt : C_Int) return C_Int; pragma Import (C, Slk_Set, "slk_set"); @@ -1833,10 +1865,8 @@ package body Terminal_Interface.Curses is Len : size_t; begin To_C (Text, Txt, Len); - if Slk_Set (C_Int (Label), - Txt (Txt'First)'Access, - C_Int (Label_Justification'Pos (Fmt))) - = Curses_Err then + if Slk_Set (C_Int (Label), Txt, + C_Int (Label_Justification'Pos (Fmt))) = Curses_Err then raise Curses_Exception; end if; end Set_Soft_Label_Key; @@ -1995,8 +2025,7 @@ package body Terminal_Interface.Curses is procedure Define_Key (Definition : in String; Key : in Special_Key_Code) is - type Char_Ptr is access all Interfaces.C.char; - function Defkey (Def : Char_Ptr; + function Defkey (Def : char_array; Key : C_Int) return C_Int; pragma Import (C, Defkey, "define_key"); @@ -2004,7 +2033,7 @@ package body Terminal_Interface.Curses is Length : size_t; begin To_C (Definition, Txt, Length); - if Defkey (Txt (Txt'First)'Access, C_Int (Key)) = Curses_Err then + if Defkey (Txt, C_Int (Key)) = Curses_Err then raise Curses_Exception; end if; end Define_Key; @@ -2410,5 +2439,123 @@ package body Terminal_Interface.Curses is Column := Column_Position (X); end if; end Transform_Coordinates; +------------------------------------------------------------------------------ + procedure Use_Default_Colors is + function C_Use_Default_Colors return C_Int; + pragma Import (C, C_Use_Default_Colors, "use_default_colors"); + Err : constant C_Int := C_Use_Default_Colors; + begin + if Err = Curses_Err then + raise Curses_Exception; + end if; + end Use_Default_Colors; + + procedure Assume_Default_Colors (Fore : Color_Number := Default_Color; + Back : Color_Number := Default_Color) + is + function C_Assume_Default_Colors (Fore : C_Int; + Back : C_Int) return C_Int; + pragma Import (C, C_Assume_Default_Colors, "assume_default_colors"); + + Err : constant C_Int := C_Assume_Default_Colors (C_Int (Fore), + C_Int (Black)); + begin + if Err = Curses_Err then + raise Curses_Exception; + end if; + end Assume_Default_Colors; +------------------------------------------------------------------------------ + function Curses_Version return String + is + function curses_versionC return chars_ptr; + pragma Import (C, curses_versionC, "curses_version"); + Result : constant chars_ptr := curses_versionC; + begin + return Fill_String (Result); + end Curses_Version; +------------------------------------------------------------------------------ + function Use_Extended_Names (Enable : Boolean) return Boolean + is + function use_extended_namesC (e : Curses_Bool) return C_Int; + pragma Import (C, use_extended_namesC, "use_extended_names"); + + Res : constant C_Int := + use_extended_namesC (Curses_Bool (Boolean'Pos (Enable))); + begin + if Res = C_Int (Curses_Bool_False) then + return False; + else + return True; + end if; + end Use_Extended_Names; +------------------------------------------------------------------------------ + procedure Screen_Dump_To_File (Filename : in String) + is + function scr_dump (f : char_array) return C_Int; + pragma Import (C, scr_dump, "scr_dump"); + Txt : char_array (0 .. Filename'Length); + Length : size_t; + begin + To_C (Filename, Txt, Length); + if Curses_Err = scr_dump (Txt) then + raise Curses_Exception; + end if; + end Screen_Dump_To_File; + + procedure Screen_Restore_From_File (Filename : in String) + is + function scr_restore (f : char_array) return C_Int; + pragma Import (C, scr_restore, "scr_restore"); + Txt : char_array (0 .. Filename'Length); + Length : size_t; + begin + To_C (Filename, Txt, Length); + if Curses_Err = scr_restore (Txt) then + raise Curses_Exception; + end if; + end Screen_Restore_From_File; + + procedure Screen_Init_From_File (Filename : in String) + is + function scr_init (f : char_array) return C_Int; + pragma Import (C, scr_init, "scr_init"); + Txt : char_array (0 .. Filename'Length); + Length : size_t; + begin + To_C (Filename, Txt, Length); + if Curses_Err = scr_init (Txt) then + raise Curses_Exception; + end if; + end Screen_Init_From_File; + + procedure Screen_Set_File (Filename : in String) + is + function scr_set (f : char_array) return C_Int; + pragma Import (C, scr_set, "scr_set"); + Txt : char_array (0 .. Filename'Length); + Length : size_t; + begin + To_C (Filename, Txt, Length); + if Curses_Err = scr_set (Txt) then + raise Curses_Exception; + end if; + end Screen_Set_File; +------------------------------------------------------------------------------ + procedure Resize (Win : Window := Standard_Window; + Number_Of_Lines : Line_Count; + Number_Of_Columns : Column_Count) is + function wresize (win : Window; + lines : C_Int; + columns : C_Int) return C_Int; + pragma Import (C, wresize); + begin + if wresize (Win, + C_Int (Number_Of_Lines), + C_Int (Number_Of_Columns)) = Curses_Err then + raise Curses_Exception; + end if; + end Resize; +------------------------------------------------------------------------------ end Terminal_Interface.Curses; +