ncurses2-m.adb

ncurses 库 可能有用酒用 没用就算了 我觉得还可以用

------------------------------------------------------------------------------
--                                                                          --
--                       GNAT ncurses Binding Samples                       --
--                                                                          --
--                                 ncurses                                  --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 2000,2004 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 <[e-mail]> 2000
--  Version Control
--  $Revision: 1.5 $
--  $Date: 2004/08/21 21:37:00 $
--  Binding Version 01.00
------------------------------------------------------------------------------
--  TODO use Default_Character where appropriate

--  This is an Ada version of ncurses
--  I translated this because it tests the most features.

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

with Ada.Text_IO; use Ada.Text_IO;

with Ada.Characters.Latin_1;
--  with Ada.Characters.Handling;

with Ada.Command_Line; use Ada.Command_Line;

with Ada.Strings.Unbounded;


with ncurses2.util; use ncurses2.util;
with ncurses2.getch_test;
with ncurses2.attr_test;
with ncurses2.color_test;
with ncurses2.demo_panels;
with ncurses2.color_edit;
with ncurses2.slk_test;
with ncurses2.acs_display;
with ncurses2.color_edit;
with ncurses2.acs_and_scroll;
with ncurses2.flushinp_test;
with ncurses2.test_sgr_attributes;
with ncurses2.menu_test;
with ncurses2.demo_pad;
with ncurses2.demo_forms;
with ncurses2.overlap_test;
with ncurses2.trace_set;

with ncurses2.getopt; use ncurses2.getopt;

package body ncurses2.m is
   use Int_IO;

   function To_trace (n : Integer) return Trace_Attribute_Set;
   procedure usage;
   procedure Set_Terminal_Modes;
   function Do_Single_Test (c : Character) return Boolean;

   function To_trace (n : Integer) return Trace_Attribute_Set is
      a : Trace_Attribute_Set := (others => False);
      m : Integer;
      rest : Integer;
   begin
      m := n  mod 2;
      if 1 = m then
         a.Times := True;
      end if;
      rest := n / 2;

      m := rest mod 2;
      if 1 = m then
         a.Tputs := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Update := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Cursor_Move := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Character_Output := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Calls := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Virtual_Puts := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Input_Events := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.TTY_State := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Internal_Calls := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Character_Calls := True;
      end if;
      rest := rest / 2;
      m := rest mod 2;
      if 1 = m then
         a.Termcap_TermInfo := True;
      end if;

      return a;
   end To_trace;

   --   these are type Stdscr_Init_Proc;

   function rip_footer (
                        Win : Window;
                        Columns : Column_Count) return Integer;
   pragma Convention (C, rip_footer);

   function rip_footer (
                        Win : Window;
                        Columns : Column_Count) return Integer is
   begin
      Set_Background (Win, (Ch => ' ',
                            Attr => (Reverse_Video => True, others => False),
                            Color => 0));
      Erase (Win);
      Move_Cursor (Win, 0, 0);
      Add (Win, "footer:"  & Columns'Img & " columns");
      Refresh_Without_Update (Win);
      return 0; -- Curses_OK;
   end rip_footer;


   function rip_header (
                        Win : Window;
                        Columns : Column_Count) return Integer;
   pragma Convention (C, rip_header);

   function rip_header (
                        Win : Window;
                        Columns : Column_Count) return Integer is
   begin
      Set_Background (Win, (Ch => ' ',
                            Attr => (Reverse_Video => True, others => False),
                            Color => 0));
      Erase (Win);
      Move_Cursor (Win, 0, 0);
      Add (Win, "header:"  & Columns'Img & " columns");
      --  'Img is a GNAT extention
      Refresh_Without_Update (Win);
      return 0; -- Curses_OK;
   end rip_header;

   procedure usage is
      --  type Stringa is access String;
      use Ada.Strings.Unbounded;
      --  tbl : constant array (Positive range <>) of Stringa := (
      tbl : constant array (Positive range <>) of Unbounded_String
        := (
            To_Unbounded_String ("Usage: ncurses [options]"),
            To_Unbounded_String (""),
            To_Unbounded_String ("Options:"),
            To_Unbounded_String ("  -a f,b   set default-colors " &
                                 "(assumed white-on-black)"),
            To_Unbounded_String ("  -d       use default-colors if terminal " &
                                 "supports them"),
            To_Unbounded_String ("  -e fmt   specify format for soft-keys " &
                                 "test (e)"),
            To_Unbounded_String ("  -f       rip-off footer line " &
                                 "(can repeat)"),
            To_Unbounded_String ("  -h       rip-off header line " &
                                 "(can repeat)"),
            To_Unbounded_String ("  -s msec  specify nominal time for " &
                                 "panel-demo (default: 1, to hold)"),
            To_Unbounded_String ("  -t mask  specify default trace-level " &
                                 "(may toggle with ^T)")
            );
   begin
      for n in tbl'Range loop
         Put_Line (Standard_Error, To_String (tbl (n)));
      end loop;
      --     exit(EXIT_FAILURE);
      --  TODO should we use Set_Exit_Status and throw and exception?
   end usage;

   procedure Set_Terminal_Modes is begin