ncurses2-demo_forms.adb

ncurses-5.4 需要的就来下把 一定会有用的哦

------------------------------------------------------------------------------
--                                                                          --
--                       GNAT ncurses Binding Samples                       --
--                                                                          --
--                                 ncurses                                  --
--                                                                          --
--                                 B O D Y                                  --
--                                                                          --
------------------------------------------------------------------------------
-- Copyright (c) 2000 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.1 $
--  Binding Version 01.00
------------------------------------------------------------------------------
with ncurses2.util; use ncurses2.util;
with Terminal_Interface.Curses; use Terminal_Interface.Curses;
with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms;
with Terminal_Interface.Curses.Forms.Field_User_Data;
with Ada.Characters.Handling;
with Ada.Strings;
with Ada.Strings.Bounded;

procedure ncurses2.demo_forms is
   package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (80);

   type myptr is access Integer;

   --  The C version stores a pointer in the userptr and
   --  converts it into a long integer.
   --  The correct, but inconvenient  way to do it is to use a
   --  pointer to long and keep the pointer constant.
   --  It just adds one memory piece to allocate and deallocate (not done here)

   package StringData is new
     Terminal_Interface.Curses.Forms.Field_User_Data (Integer, myptr);

   function edit_secure (me : Field; c_in : Key_Code) return Key_Code;
   function form_virtualize (f : Form; w : Window) return Key_Code;
   function my_form_driver (f : Form; c : Key_Code) return Boolean;
   function make_label (frow  : Line_Position;
                        fcol  : Column_Position;
                        label : String) return Field;
   function make_field (frow   : Line_Position;
                        fcol   : Column_Position;
                        rows   : Line_Count;
                        cols   : Column_Count;
                        secure : Boolean) return Field;
   procedure display_form (f : Form);
   procedure erase_form (f : Form);

   --  prints '*' instead of characters.
   --  Not that this keeps a bug from the C version:
   --  type in the psasword field then move off and back.
   --  the cursor is at position one, but
   --  this assumes it as at the end so text gets appended instead
   --  of overwtitting.
   function edit_secure (me : Field; c_in : Key_Code) return Key_Code is
      rows, frow : Line_Position;
      nrow : Natural;
      cols, fcol : Column_Position;
      nbuf : Buffer_Number;
      c : Key_Code := c_in;
      c2 :  Character;

      use StringData;
   begin
      Info (me, rows, cols, frow, fcol, nrow, nbuf);
      --  TODO         if result = Form_Ok and nbuf > 0 then
      --  C version checked the return value
      --  of Info, the Ada binding throws an exception I think.
      if nbuf > 0 then
         declare
            temp : BS.Bounded_String;
            temps : String (1 .. 10);
            --  TODO Get_Buffer povides no information on the field length?
            len : myptr;
         begin
            Get_Buffer (me, 1, Str => temps);
            --  strcpy(temp, field_buffer(me, 1));
            Get_User_Data (me, len);
            temp := BS.To_Bounded_String (temps (1 .. len.all));
            if c <= Key_Max then
               c2 := Code_To_Char (c);
               if Ada.Characters.Handling.Is_Graphic (c2) then
                  BS.Append (temp, c2);
                  len.all := len.all + 1;
                  Set_Buffer (me, 1, BS.To_String (temp));
                  c := Character'Pos ('*');
               else
                  c := 0;
               end if;
            else
               case c is
                  when  REQ_BEG_FIELD |
                    REQ_CLR_EOF |
                    REQ_CLR_EOL |
                    REQ_DEL_LINE |
                    REQ_DEL_WORD |
                    REQ_DOWN_CHAR |
                    REQ_END_FIELD |
                    REQ_INS_CHAR |
                    REQ_INS_LINE |
                    REQ_LEFT_CHAR |
                    REQ_NEW_LINE |
                    REQ_NEXT_WORD |
                    REQ_PREV_WORD |
                    REQ_RIGHT_CHAR |
                    REQ_UP_CHAR =>
                     c := 0;         -- we don't want to do inline editing
                  when REQ_CLR_FIELD =>
                     if len.all /= 0 then
                        temp := BS.To_Bounded_String ("");
                        Set_Buffer (me, 1, BS.To_String (temp));
                        len.all := 0;
                     end if;

                  when REQ_DEL_CHAR |
                    REQ_DEL_PREV =>
                     if len.all /= 0 then
                        BS.Delete (temp, BS.Length (temp), BS.Length (temp));
                        Set_Buffer (me, 1, BS.To_String (temp));
                        len.all := len.all - 1;
                     end if;
                  when others => null;
               end case;
            end if;
         end;
      end if;
      return c;
   end edit_secure;

   mode : Key_Code := REQ_INS_MODE;

   function form_virtualize (f : Form; w : Window) return Key_Code is
      type lookup_t is record
         code : Key_Code;
         result : Key_Code;
         --  should be Form_Request_Code, but we need MAX_COMMAND + 1
      end record;

      lookup : constant array (Positive range <>) of lookup_t :=
        (
         (
          Character'Pos ('A') mod 16#20#, REQ_NEXT_CHOICE
          ),
         (
          Character'Pos ('B') mod 16#20#, REQ_PREV_WORD
          ),
         (
          Character'Pos ('C') mod 16#20#, REQ_CLR_EOL
          ),
         (
          Character'Pos ('D') mod 16#20#, REQ_DOWN_FIELD
          ),
         (
          Character'Pos ('E') mod 16#20#, REQ_END_FIELD
          ),
         (
          Character'Pos ('F') mod 16#20#, REQ_NEXT_PAGE
          ),
         (
          Character'Pos ('G') mod 16#20#, REQ_DEL_WORD
          ),
         (
          Character'Pos ('H') mod 16#20#, REQ_DEL_PREV
          ),
         (
          Character'Pos ('I') mod 16#20#, REQ_INS_CHAR
          ),
         (
          Character'Pos ('K') mod 16#20#, REQ_CLR_EOF
          ),
         (
          Character'Pos ('L') mod 16#20#, REQ_LEFT_FIELD
          ),
         (
          Character'Pos ('M') mod 16#20#, REQ_NEW_LINE
          ),
         (
          Character'Pos ('N') mod 16#20#, REQ_NEXT_FIELD
          ),
         (
          Character'Pos ('O') mod 16#20#, REQ_INS_LINE
          ),
         (
          Character'Pos ('P') mod 16#20#, REQ_PREV_FIELD
          ),
         (
          Character'Pos ('R') mod 16#20#, REQ_RIGHT_FIELD
          ),
         (
          Character'Pos ('S') mod 16#20#, REQ_BEG_FIELD
          ),
         (
          Character'Pos ('U') mod 16#20#, REQ_UP_FIELD
          ),
         (
          Character'Pos ('V') mod 16#20#, REQ_DEL_CHAR
          ),
         (
          Character'Pos ('W') mod 16#20#, REQ_NEXT_WORD
          ),
         (
          Character'Pos ('X') mod 16#20#, REQ_CLR_FIELD
          ),
         (
          Character'Pos ('Y') mod 16#20#, REQ_DEL_LINE
          ),
         (
          Character'Pos ('Z') mod 16#20#, REQ_PREV_CHOICE
          ),
         (
          Character'Pos ('[') mod 16#20#, --  ESCAPE
          Form_Request_Code'Last + 1
          ),
         (
          Key_Backspace, REQ_DEL_PREV
          ),
         (
          KEY_DOWN, REQ_DOWN_CHAR
          ),
         (
          Key_End, REQ_LAST_FIELD