ncurses2-util.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                       GNAT ncurses Binding Samples                       --
--                                                                          --
--                               ncurses2.util                              --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 2000-2006,2008 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: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
--  Version Control
--  $Revision: 1.7 $
--  $Date: 2008/07/26 18:51:20 $
--  Binding Version 01.00
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;

pragma Warnings (Off);
with Terminal_Interface.Curses.Aux;
pragma Warnings (On);

with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;

with Interfaces.C;
with Interfaces.C.Strings;

with Ada.Characters.Handling;

with ncurses2.genericPuts;

package body ncurses2.util is

   --  #defines from C
   --  #define CTRL(x)         ((x) & 0x1f)
   function CTRL (c : Character) return Key_Code is
   begin
      return Character'Pos (c) mod 16#20#;
      --  uses a property of ASCII
      --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
   end CTRL;

   function CTRL (c : Character) return Character is
   begin
      return Character'Val (Character'Pos (c) mod 16#20#);
      --  uses a property of ASCII
      --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
   end CTRL;

   save_trace : Trace_Attribute_Set;
   --  Common function to allow ^T to toggle trace-mode in the middle of a test
   --  so that trace-files can be made smaller.
   function Getchar (win : Window := Standard_Window) return Key_Code is
      c : Key_Code;
   begin
      --  #ifdef TRACE
      c := Get_Keystroke (win);
      while c = CTRL ('T') loop
         --  if _nc_tracing  in C
         if Current_Trace_Setting /= Trace_Disable then
            save_trace := Current_Trace_Setting;
            Trace_Put ("TOGGLE-TRACING OFF");
            Current_Trace_Setting := Trace_Disable;
         else
            Current_Trace_Setting := save_trace;
         end if;
         Trace_On (Current_Trace_Setting);
         if Current_Trace_Setting /= Trace_Disable then
            Trace_Put ("TOGGLE-TRACING ON");
         end if;
      end loop;
      --  #else c := Get_Keystroke;
      return c;
   end Getchar;

   procedure Getchar (win : Window := Standard_Window) is
   begin
      if Getchar (win) < 0 then
         Beep;
      end if;
   end Getchar;

   procedure Pause is
   begin
      Move_Cursor (Line => Lines - 1, Column => 0);
      Add (Str => "Press any key to continue... ");
      Getchar;
   end Pause;

   procedure Cannot (s : String) is
      use Interfaces.C;
      use Interfaces.C.Strings;
      use Terminal_Interface.Curses.Aux;
      function getenv (x : char_array)  return chars_ptr;
      pragma Import (C, getenv, "getenv");
      tmp1 : char_array (0 .. 10);
      package p is new ncurses2.genericPuts (1024);
      use p;
      use p.BS;

      tmpb : BS.Bounded_String;

      Length : size_t;
   begin
      To_C ("TERM", tmp1, Length);
      Fill_String (getenv (tmp1), tmpb);
      Add (Ch => newl);
      myAdd (Str => "This " & tmpb & " terminal " & s);
      Pause;
   end Cannot;

   procedure ShellOut (message : Boolean) is
      use Interfaces.C;
      Txt : char_array (0 .. 10);
      Length : size_t;
      procedure system (x : char_array);
      pragma Import (C, system, "system");
   begin
      To_C ("sh", Txt,  Length);
      if message then
         Add (Str => "Shelling out...");
      end if;
      Save_Curses_Mode (Mode => Curses);
      End_Windows;
      system (Txt);
      if message then
         Add (Str => "returned from shellout.");
         Add (Ch => newl);
      end if;
      Refresh;
   end ShellOut;

   function Is_Digit (c : Key_Code) return Boolean is
   begin
      if c >= 16#100# then
         return False;
      else
         return Ada.Characters.Handling.Is_Digit (Character'Val (c));
      end if;
   end Is_Digit;

   procedure P (s : String) is
   begin
      Add (Str => s);
      Add (Ch => newl);
   end P;

   function Code_To_Char (c : Key_Code) return Character is
   begin
      if c > Character'Pos (Character'Last) then
         return Character'Val (0);
         --  maybe raise exception?
      else
         return Character'Val (c);
      end if;
   end Code_To_Char;

   --  This was untestable due to a bug in GNAT (3.12p)
   --  Hmm, what bug? I don't remember.
   function ctoi (c : Character) return Integer is
   begin
      return Character'Pos (c) - Character'Pos ('0');
   end ctoi;

end ncurses2.util;