terminal_interface-curses.adb

ncurses-5.4

      Add_Character_To_Pad_And_Echo_It
        (Pad,
         Attributed_Character'(Ch    => Ch,
                               Color => Color_Pair'First,
                               Attr  => Normal_Video));
   end Add_Character_To_Pad_And_Echo_It;
------------------------------------------------------------------------------
   procedure Scroll (Win    : in Window := Standard_Window;
                     Amount : in Integer := 1)
   is
      function Wscrl (Win : Window; N : C_Int) return C_Int;
      pragma Import (C, Wscrl, "wscrl");

   begin
      if Wscrl (Win, C_Int (Amount)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Scroll;

------------------------------------------------------------------------------
   procedure Delete_Character (Win : in Window := Standard_Window)
   is
      function Wdelch (Win : Window) return C_Int;
      pragma Import (C, Wdelch, "wdelch");
   begin
      if Wdelch (Win) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Delete_Character;

   procedure Delete_Character
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position)
   is
      function Mvwdelch (Win : Window;
                         Lin : C_Int;
                         Col : C_Int) return C_Int;
      pragma Import (C, Mvwdelch, "mvwdelch");
   begin
      if Mvwdelch (Win, C_Int (Line), C_Int (Column)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Delete_Character;
------------------------------------------------------------------------------
   function Peek (Win : Window := Standard_Window)
     return Attributed_Character
   is
      function Winch (Win : Window) return C_Chtype;
      pragma Import (C, Winch, "winch");
   begin
      return Chtype_To_AttrChar (Winch (Win));
   end Peek;

   function Peek
     (Win    : Window := Standard_Window;
      Line   : Line_Position;
      Column : Column_Position) return Attributed_Character
   is
      function Mvwinch (Win : Window;
                        Lin : C_Int;
                        Col : C_Int) return C_Chtype;
      pragma Import (C, Mvwinch, "mvwinch");
   begin
      return Chtype_To_AttrChar (Mvwinch (Win, C_Int (Line), C_Int (Column)));
   end Peek;
------------------------------------------------------------------------------
   procedure Insert (Win : in Window := Standard_Window;
                     Ch  : in Attributed_Character)
   is
      function Winsch (Win : Window; Ch : C_Chtype) return C_Int;
      pragma Import (C, Winsch, "winsch");
   begin
      if Winsch (Win, AttrChar_To_Chtype (Ch)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Insert;

   procedure Insert
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Ch     : in Attributed_Character)
   is
      function Mvwinsch (Win : Window;
                         Lin : C_Int;
                         Col : C_Int;
                         Ch  : C_Chtype) return C_Int;
      pragma Import (C, Mvwinsch, "mvwinsch");
   begin
      if Mvwinsch (Win,
                   C_Int (Line),
                   C_Int (Column),
                   AttrChar_To_Chtype (Ch)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Insert;
------------------------------------------------------------------------------
   procedure Insert (Win : in Window := Standard_Window;
                     Str : in String;
                     Len : in Integer := -1)
   is
      function Winsnstr (Win : Window;
                         Str : char_array;
                         Len : Integer := -1) return C_Int;
      pragma Import (C, Winsnstr, "winsnstr");

      Txt    : char_array (0 .. Str'Length);
      Length : size_t;
   begin
      To_C (Str, Txt, Length);
      if Winsnstr (Win, Txt, Len) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Insert;

   procedure Insert
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Str    : in String;
      Len    : in Integer := -1)
   is
      function Mvwinsnstr (Win    : Window;
                           Line   : C_Int;
                           Column : C_Int;
                           Str    : char_array;
                           Len    : C_Int) return C_Int;
      pragma Import (C, Mvwinsnstr, "mvwinsnstr");

      Txt    : char_array (0 .. Str'Length);
      Length : size_t;
   begin
      To_C (Str, Txt, Length);
      if Mvwinsnstr (Win, C_Int (Line), C_Int (Column), Txt, C_Int (Len))
        = Curses_Err then
         raise Curses_Exception;
      end if;
   end Insert;
------------------------------------------------------------------------------
   procedure Peek (Win : in  Window := Standard_Window;
                   Str : out String;
                   Len : in  Integer := -1)
   is
      function Winnstr (Win : Window;
                        Str : char_array;
                        Len : C_Int) return C_Int;
      pragma Import (C, Winnstr, "winnstr");

      N   : Integer := Len;
      Txt : char_array (0 .. Str'Length);
      Cnt : Natural;
   begin
      if N < 0 then
         N := Str'Length;
      end if;
      if N > Str'Length then
         raise Constraint_Error;
      end if;
      Txt (0) := Interfaces.C.char'First;
      if Winnstr (Win, Txt, C_Int (N)) = Curses_Err then
         raise Curses_Exception;
      end if;
      To_Ada (Txt, Str, Cnt, True);
      if Cnt < Str'Length then
         Str ((Str'First + Cnt) .. Str'Last) := (others => ' ');
      end if;
   end Peek;

   procedure Peek
     (Win    : in  Window := Standard_Window;
      Line   : in  Line_Position;
      Column : in  Column_Position;
      Str    : out String;
      Len    : in  Integer := -1)
   is
   begin
      Move_Cursor (Win, Line, Column);
      Peek (Win, Str, Len);
   end Peek;
------------------------------------------------------------------------------
   procedure Peek
     (Win : in  Window := Standard_Window;
      Str : out Attributed_String;
      Len : in  Integer := -1)
   is
      function Winchnstr (Win : Window;
                          Str : chtype_array;             -- out
                          Len : C_Int) return C_Int;
      pragma Import (C, Winchnstr, "winchnstr");

      N   : Integer := Len;
      Txt : chtype_array (0 .. Str'Length) := (0 => Default_Character);
      Cnt : Natural := 0;
   begin
      if N < 0 then
         N := Str'Length;
      end if;
      if N > Str'Length then
         raise Constraint_Error;
      end if;
      if Winchnstr (Win, Txt, C_Int (N)) = Curses_Err then
         raise Curses_Exception;
      end if;
      for To in Str'Range loop
         exit when Txt (size_t (Cnt)) = Default_Character;
         Str (To) := Txt (size_t (Cnt));
         Cnt := Cnt + 1;
      end loop;
      if Cnt < Str'Length then
         Str ((Str'First + Cnt) .. Str'Last) :=
           (others => (Ch => ' ',
                       Color => Color_Pair'First,
                       Attr => Normal_Video));
      end if;
   end Peek;

   procedure Peek
     (Win    : in  Window := Standard_Window;
      Line   : in  Line_Position;
      Column : in  Column_Position;
      Str    : out Attributed_String;
      Len    : in Integer := -1)
   is
   begin
      Move_Cursor (Win, Line, Column);
      Peek (Win, Str, Len);
   end Peek;
------------------------------------------------------------------------------
   procedure Get (Win : in  Window := Standard_Window;
                  Str : out String;
                  Len : in  Integer := -1)
   is
      function Wgetnstr (Win : Window;
                         Str : char_array;
                         Len : C_Int) return C_Int;
      pragma Import (C, Wgetnstr, "wgetnstr");

      N   : Integer := Len;
      Txt : char_array (0 .. Str'Length);
      Cnt : Natural;
   begin
      if N < 0 then
         N := Str'Length;
      end if;
      if N > Str'Length then
         raise Constraint_Error;
      end if;
      Txt (0) := Interfaces.C.char'First;
      if Wgetnstr (Win, Txt, C_Int (N)) = Curses_Err then
         raise Curses_Exception;
      end if;
      To_Ada (Txt, Str, Cnt, True);
      if Cnt < Str'Length then
         Str ((Str'First + Cnt) .. Str'Last) := (others => ' ');
      end if;
   end Get;

   procedure Get
     (Win    : in  Window := Standard_Window;
      Line   : in  Line_Position;
      Column : in  Column_Position;
      Str    : out String;
      Len    : in  Integer := -1)
   is
   begin
      Move_Cursor (Win, Line, Column);
      Get (Win, Str, Len);
   end Get;
------------------------------------------------------------------------------
   procedure Init_Soft_Label_Keys
     (Format : in Soft_Label_Key_Format := Three_Two_Three)
   is
      function Slk_Init (Fmt : C_Int) return C_Int;
      pragma Import (C, Slk_Init, "slk_init");
   begin
      if Slk_Init (Soft_Label_Key_Format'Pos (Format)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Init_Soft_Label_Keys;

   procedure Set_Soft_Label_Key (Label : in Label_Number;
                                 Text  : in String;
                                 Fmt   : in Label_Justification := Left)
   is
      function Slk_Set (Label : C_Int;
                        Txt   : char_array;
                        Fmt   : C_Int) return C_Int;
      pragma Import (C, Slk_Set, "slk_set");

      Txt : char_array (0 .. Text'Length);
      Len : size_t;
   begin
      To_C (Text, Txt, Len);
      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;

   procedure Refresh_Soft_Label_Keys
   is
      function Slk_Refresh return C_Int;
      pragma Import (C, Slk_Refresh, "slk_refresh");
   begin
      if Slk_Refresh = Curses_Err then
         raise Curses_Exception;
      end if;
   end Refresh_Soft_Label_Keys;

   procedure Refresh_Soft_Label_Keys_Without_Update
   is
      function Slk_Noutrefresh return C_Int;
      pragma Import (C, Slk_Noutrefresh, "slk_noutrefresh");
   begin
      if Slk_Noutrefresh = Curses_Err then
         raise Curses_Exception;
      end if;
   end Refresh_Soft_Label_Keys_Without_Update;

   procedure Get_Soft_Label_Key (Label : in Label_Number;
                                 Text  : out String)
   is
      function Slk_Label (Label : C_Int) return chars_ptr;
      pragma Import (C, Slk_Label, "slk_label");
   begin
      Fill_String (Slk_Label (C_Int (Label)), Text);
   end Get_Soft_Label_Key;

   function Get_Soft_Label_Key (Label : in Label_Number) return String
   is
      function Slk_Label (Label : C_Int) return chars_ptr;
      pragma Import (C, Slk_Label, "slk_label");
   begin
      return Fill_String (Slk_Label (C_Int (Label)));
   end Get_Soft_Label_Key;

   procedure Clear_Soft_Label_Keys
   is
      function Slk_Clear return C_Int;
      pragma Import (C, Slk_Clear, "slk_clear");
   begin
      if Slk_Clear = Curses_Err then
         raise Curses_Exception;
      end if;
   end Clear_Soft_Label_Keys;

   procedure Restore_Soft_Label_Keys
   is
      function Slk_Restore return C_Int;
      pragma Import (C, Slk_Restore, "slk_restore");
   begin
      if Slk_Restore = Curses_Err then
         raise Curses_Exception;
      end if;
   end Restore_Soft_Label_Keys;

   procedure Touch_Soft_Label_Keys
   is
      function Slk_Touch return C_Int;
      pragma Import (C, Slk_Touch, "slk_touch");
   begin
      if Slk_Touch = Curses_Err then
         raise Curses_Exception;
      end if;
   end Touch_Soft_Label_Keys;

   procedure Switch_Soft_Label_Key_Attributes
     (Attr : in Character_Attribute_Set;
      On   : in Boolean := True)
   is
      function Slk_Attron (Ch : C_Chtype) return C_Int;
      pragma Import (C, Slk_Attron, "slk_attron");
      function Slk_Attroff (Ch : C_Chtype) return C_Int;
      pragma Import (C, Slk_Attroff, "slk_attroff");

      Err : C_Int;
      Ch  : constant Attributed_Character := (Ch    => Character'First,
                                              Attr  => Attr,
                                              Color => Color_Pair'First);
   begin
      if On then
         Err := Slk_Attron  (AttrChar_To_Chtype (Ch));
      else
         Err := Slk_Attroff (AttrChar_To_Chtype (Ch));
      end if;
      if Err = Curses_Err then
         raise Curses_Exception;
      end if;
   end Switch_Soft_Label_Key_Attributes;

   proce