terminal_interface-curses.adb

ncurses-5.4

------------------------------------------------------------------------------
--                                                                          --
--                           GNAT ncurses Binding                           --
--                                                                          --
--                        Terminal_Interface.Curses                         --
--                                                                          --
--                                 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.29 $
--  Binding Version 01.00
------------------------------------------------------------------------------
with System;

with Terminal_Interface.Curses.Aux;
with Interfaces.C;                  use Interfaces.C;
with Interfaces.C.Strings;          use Interfaces.C.Strings;
with Interfaces.C.Pointers;
with Ada.Characters.Handling;       use Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Unchecked_Conversion;

package body Terminal_Interface.Curses is

   use Aux;
   use type System.Bit_Order;

   package ASF renames Ada.Strings.Fixed;

   type chtype_array is array (size_t range <>)
      of aliased Attributed_Character;
   pragma Convention (C, chtype_array);

------------------------------------------------------------------------------
   generic
      type Element is (<>);
   function W_Get_Element (Win    : in Window;
                           Offset : in Natural) return Element;

   function W_Get_Element (Win    : in Window;
                           Offset : in Natural) return Element is
      type E_Array is array (Natural range <>) of aliased Element;
      package C_E_Array is new
        Interfaces.C.Pointers (Natural, Element, E_Array, Element'Val (0));
      use C_E_Array;

      function To_Pointer is new
        Ada.Unchecked_Conversion (Window, Pointer);

      P : Pointer := To_Pointer (Win);
   begin
      if Win = Null_Window then
         raise Curses_Exception;
      else
         P := P + ptrdiff_t (Offset);
         return P.all;
      end if;
   end W_Get_Element;

   function W_Get_Int   is new W_Get_Element (C_Int);
   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
      function Keyname (K : C_Int) return chars_ptr;
      pragma Import (C, Keyname, "keyname");

      Ch : Character;
   begin
      if Key <= Character'Pos (Character'Last) then
         Ch := Character'Val (Key);
         if Is_Control (Ch) then
            return Un_Control (Attributed_Character'(Ch    => Ch,
                                                     Color => Color_Pair'First,
                                                     Attr  => Normal_Video));
         elsif Is_Graphic (Ch) then
            declare
               S : String (1 .. 1);
            begin
               S (1) := Ch;
               return S;
            end;
         else
            return "";
         end if;
      else
         return Fill_String (Keyname (C_Int (Key)));
      end if;
   end Key_Name;

   procedure Key_Name (Key  : in  Real_Key_Code;
                       Name : out String)
   is
   begin
      ASF.Move (Key_Name (Key), Name);
   end Key_Name;

------------------------------------------------------------------------------
   procedure Init_Screen
   is
      function Initscr return Window;
      pragma Import (C, Initscr, "initscr");

      W : Window;
   begin
      W := Initscr;
      if W = Null_Window then
         raise Curses_Exception;
      end if;
   end Init_Screen;

   procedure End_Windows
   is
      function Endwin return C_Int;
      pragma Import (C, Endwin, "endwin");
   begin
      if Endwin = Curses_Err then
         raise Curses_Exception;
      end if;
   end End_Windows;

   function Is_End_Window return Boolean
   is
      function Isendwin return Curses_Bool;
      pragma Import (C, Isendwin, "isendwin");
   begin
      if Isendwin = Curses_Bool_False then
         return False;
      else
         return True;
      end if;
   end Is_End_Window;
------------------------------------------------------------------------------
   procedure Move_Cursor (Win    : in Window := Standard_Window;
                          Line   : in Line_Position;
                          Column : in Column_Position)
   is
      function Wmove (Win    : Window;
                      Line   : C_Int;
                      Column : C_Int
                     ) return C_Int;
      pragma Import (C, Wmove, "wmove");
   begin
      if Wmove (Win, C_Int (Line), C_Int (Column)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Move_Cursor;
------------------------------------------------------------------------------
   procedure Add (Win : in Window := Standard_Window;
                  Ch  : in Attributed_Character)
   is
      function Waddch (W  : Window;
                       Ch : C_Chtype) return C_Int;
      pragma Import (C, Waddch, "waddch");
   begin
      if Waddch (Win, AttrChar_To_Chtype (Ch)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Add;

   procedure Add (Win : in Window := Standard_Window;
                  Ch  : in Character)
   is
   begin
      Add (Win,
           Attributed_Character'(Ch    => Ch,
                                 Color => Color_Pair'First,
                                 Attr  => Normal_Video));
   end Add;

   procedure Add
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Ch     : in Attributed_Character)
   is
      function mvwaddch (W  : Window;
                         Y  : C_Int;
                         X  : C_Int;
                         Ch : C_Chtype) return C_Int;
      pragma Import (C, mvwaddch, "mvwaddch");
   begin
      if mvwaddch (Win, C_Int (Line),
                   C_Int (Column),
                   AttrChar_To_Chtype (Ch)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Add;

   procedure Add
     (Win    : in Window := Standard_Window;
      Line   : in Line_Position;
      Column : in Column_Position;
      Ch     : in Character)
   is
   begin
      Add (Win,
           Line,
           Column,
           Attributed_Character'(Ch    => Ch,
                                 Color => Color_Pair'First,
                                 Attr  => Normal_Video));
   end Add;

   procedure Add_With_Immediate_Echo
     (Win : in Window := Standard_Window;
      Ch  : in Attributed_Character)
   is
      function Wechochar (W  : Window;
                          Ch : C_Chtype) return C_Int;
      pragma Import (C, Wechochar, "wechochar");
   begin
      if Wechochar (Win, AttrChar_To_Chtype (Ch)) = Curses_Err then
         raise Curses_Exception;
      end if;
   end Add_With_Immediate_Echo;

   procedure Add_With_Immediate_Echo
     (Win : in Window := Standard_Window;
      Ch  : in Character)
   is
   begin
      Add_With_Immediate_Echo
        (Win,
         Attributed_Character'(Ch    => Ch,
                               Color => Color_Pair'First,
                               Attr  => Normal_Video));
   end Add_With_Immediate_Echo;
------------------------------------------------------------------------------
   function Create (Number_Of_Lines       : Line_Count;
                    Number_Of_Columns     : Column_Count;
                    First_Line_Position   : Line_Position;
                    First_Column_Position : Column_Position) return Window
   is
      function Newwin (Number_Of_Lines       : C_Int;
                       Number_Of_Columns     : C_Int;
                       First_Line_Position   : C_Int;
                       First_Column_Position : C_Int) return Window;
      pragma Import (C, Newwin, "newwin");

      W : Window;
   begin
      W := Newwin (C_Int (Number_Of_Lines),
                   C_Int (Number_Of_Columns),
                   C_Int (First_Line_Position),
                   C_Int (First_Column_Position));
      if W = Null_Window then
         raise Curses_Exception;
      end if;
      return W;
   end Create;

   procedure Delete (Win : in out Window)
   is
      function Wdelwin (W : Window) return C_Int;
      pragma Import (C, Wdelwin, "delwin");
   begin
      if Wdelwin (Win) = Curses_Err then
         raise Curses_Exception;
      end if;
      Win := Null_Window;
   end Delete;

   function Sub_Window
     (Win                   : Window := Standard_Window;
      Number_Of_Lines       : Line_Count;
      Number_Of_Columns     : Column_Count;
      First_Line_Position   : Line_Position;
      First_Column_Position : Column_Position) return Window
   is
      function Subwin
        (Win                   : Window;
         Number_Of_Lines       : C_Int;
         Number_Of_Columns     : C_Int;
         First_Line_Position   : C_Int;
         First_Column_Position : C_Int) return Window;
      pragma Import (C, Subwin, "subwin");

      W : Window;
   begin
      W := Subwin (Win,
                   C_Int (Number_Of_Lines),
                   C_Int (Number_Of_Columns),
                   C_Int (First_Line_Position),
                   C_Int (First_Column_Position));
      if W = Null_Window then
         raise Curses_Exception;
      end if;
      return W;
   end Sub_Window;

   function Derived_Window
     (Win                   : Window := Standard_Window;
      Number_Of_Lines       : Line_Count;
      Number_Of_Columns     : Column_Count;
      First_Line_Position   : Line_Position;
      First_Column_Position : Column_Position) return Window
   is
      function Derwin
        (Win                   : Window;
         Number_Of_Lines       : C_Int;
         Number_Of_Columns     : C_Int;
         First_Line_Position   : C_Int;
         First_Column_Position : C_Int) return Window;
      pragma Import (C, Derwin, "derwin");

      W : Window;
   begin
      W := Derwin (Win,
                   C_Int (Number_Of_Lines),
                   C_Int (Number_Of_Columns),
                   C_Int (First_Line_Position),
                   C_Int (First_Column_Position));
      if W = Null_Window then
         raise Curses_Exception;
      end if;
      return W;
   end Derived_Window;

   function Duplicate (Win : Window) return Window
   is
      function Dupwin (Win : Window) return Window;
      pragma Import (C, Dupwin, "dupwin");

      W : Window := Dupwin (Win);
   begin
      if W = Null_Window then
         raise Curses_Exception;
      end if;
      return W;
   end Duplicate;

   procedure Move_Window (Win    : in Window;
                          Line   : in Line_Position;
                          Column : in Column_Position)
   is
      function Mvwin (Win    : Window;
                      Line   : C_Int;
                      Column : C_Int) return C_Int;
      pragma Import (C, Mvwin, "mvwin");
   begin
      if Mvwin (Win, C_Int (Line), C_Int (Column)) = Curses_Err then