Ada95/samples/ncurses2-demo_forms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                                 ncurses                                  --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 2000 Free Software Foundation, Inc.                        --
  11 --                                                                          --
  12 -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13 -- copy of this software and associated documentation files (the            --
  14 -- "Software"), to deal in the Software without restriction, including      --
  15 -- without limitation the rights to use, copy, modify, merge, publish,      --
  16 -- distribute, distribute with modifications, sublicense, and/or sell       --
  17 -- copies of the Software, and to permit persons to whom the Software is    --
  18 -- furnished to do so, subject to the following conditions:                 --
  19 --                                                                          --
  20 -- The above copyright notice and this permission notice shall be included  --
  21 -- in all copies or substantial portions of the Software.                   --
  22 --                                                                          --
  23 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30 --                                                                          --
  31 -- Except as contained in this notice, the name(s) of the above copyright   --
  32 -- holders shall not be used in advertising or otherwise to promote the     --
  33 -- sale, use or other dealings in this Software without prior written       --
  34 -- authorization.                                                           --
  35 ------------------------------------------------------------------------------
  36 --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37 --  Version Control
  38 --  $Revision: 1.1 $
  39 --  Binding Version 01.00
  40 ------------------------------------------------------------------------------
  41 with ncurses2.util; use ncurses2.util;
  42 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  43 with Terminal_Interface.Curses.Forms; use Terminal_Interface.Curses.Forms;
  44 with Terminal_Interface.Curses.Forms.Field_User_Data;
  45 with Ada.Characters.Handling;
  46 with Ada.Strings;
  47 with Ada.Strings.Bounded;
  48
  49 procedure ncurses2.demo_forms is
  50    package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (80);
  51
  52    type myptr is access Integer;
  53
  54    --  The C version stores a pointer in the userptr and
  55    --  converts it into a long integer.
  56    --  The correct, but inconvenient  way to do it is to use a
  57    --  pointer to long and keep the pointer constant.
  58    --  It just adds one memory piece to allocate and deallocate (not done here)
  59
  60    package StringData is new
  61      Terminal_Interface.Curses.Forms.Field_User_Data (Integer, myptr);
  62
  63    function edit_secure (me : Field; c_in : Key_Code) return Key_Code;
  64    function form_virtualize (f : Form; w : Window) return Key_Code;
  65    function my_form_driver (f : Form; c : Key_Code) return Boolean;
  66    function make_label (frow  : Line_Position;
  67                         fcol  : Column_Position;
  68                         label : String) return Field;
  69    function make_field (frow   : Line_Position;
  70                         fcol   : Column_Position;
  71                         rows   : Line_Count;
  72                         cols   : Column_Count;
  73                         secure : Boolean) return Field;
  74    procedure display_form (f : Form);
  75    procedure erase_form (f : Form);
  76
  77    --  prints '*' instead of characters.
  78    --  Not that this keeps a bug from the C version:
  79    --  type in the psasword field then move off and back.
  80    --  the cursor is at position one, but
  81    --  this assumes it as at the end so text gets appended instead
  82    --  of overwtitting.
  83    function edit_secure (me : Field; c_in : Key_Code) return Key_Code is
  84       rows, frow : Line_Position;
  85       nrow : Natural;
  86       cols, fcol : Column_Position;
  87       nbuf : Buffer_Number;
  88       c : Key_Code := c_in;
  89       c2 :  Character;
  90
  91       use StringData;
  92    begin
  93       Info (me, rows, cols, frow, fcol, nrow, nbuf);
  94       --  TODO         if result = Form_Ok and nbuf > 0 then
  95       --  C version checked the return value
  96       --  of Info, the Ada binding throws an exception I think.
  97       if nbuf > 0 then
  98          declare
  99             temp : BS.Bounded_String;
 100             temps : String (1 .. 10);
 101             --  TODO Get_Buffer povides no information on the field length?
 102             len : myptr;
 103          begin
 104             Get_Buffer (me, 1, Str => temps);
 105             --  strcpy(temp, field_buffer(me, 1));
 106             Get_User_Data (me, len);
 107             temp := BS.To_Bounded_String (temps (1 .. len.all));
 108             if c <= Key_Max then
 109                c2 := Code_To_Char (c);
 110                if Ada.Characters.Handling.Is_Graphic (c2) then
 111                   BS.Append (temp, c2);
 112                   len.all := len.all + 1;
 113                   Set_Buffer (me, 1, BS.To_String (temp));
 114                   c := Character'Pos ('*');
 115                else
 116                   c := 0;
 117                end if;
 118             else
 119                case c is
 120                   when  REQ_BEG_FIELD |
 121                     REQ_CLR_EOF |
 122                     REQ_CLR_EOL |
 123                     REQ_DEL_LINE |
 124                     REQ_DEL_WORD |
 125                     REQ_DOWN_CHAR |
 126                     REQ_END_FIELD |
 127                     REQ_INS_CHAR |
 128                     REQ_INS_LINE |
 129                     REQ_LEFT_CHAR |
 130                     REQ_NEW_LINE |
 131                     REQ_NEXT_WORD |
 132                     REQ_PREV_WORD |
 133                     REQ_RIGHT_CHAR |
 134                     REQ_UP_CHAR =>
 135                      c := 0;         -- we don't want to do inline editing
 136                   when REQ_CLR_FIELD =>
 137                      if len.all /= 0 then
 138                         temp := BS.To_Bounded_String ("");
 139                         Set_Buffer (me, 1, BS.To_String (temp));
 140                         len.all := 0;
 141                      end if;
 142
 143                   when REQ_DEL_CHAR |
 144                     REQ_DEL_PREV =>
 145                      if len.all /= 0 then
 146                         BS.Delete (temp, BS.Length (temp), BS.Length (temp));
 147                         Set_Buffer (me, 1, BS.To_String (temp));
 148                         len.all := len.all - 1;
 149                      end if;
 150                   when others => null;
 151                end case;
 152             end if;
 153          end;
 154       end if;
 155       return c;
 156    end edit_secure;
 157
 158    mode : Key_Code := REQ_INS_MODE;
 159
 160    function form_virtualize (f : Form; w : Window) return Key_Code is
 161       type lookup_t is record
 162          code : Key_Code;
 163          result : Key_Code;
 164          --  should be Form_Request_Code, but we need MAX_COMMAND + 1
 165       end record;
 166
 167       lookup : constant array (Positive range <>) of lookup_t :=
 168         (
 169          (
 170           Character'Pos ('A') mod 16#20#, REQ_NEXT_CHOICE
 171           ),
 172          (
 173           Character'Pos ('B') mod 16#20#, REQ_PREV_WORD
 174           ),
 175          (
 176           Character'Pos ('C') mod 16#20#, REQ_CLR_EOL
 177           ),
 178          (
 179           Character'Pos ('D') mod 16#20#, REQ_DOWN_FIELD
 180           ),
 181          (
 182           Character'Pos ('E') mod 16#20#, REQ_END_FIELD
 183           ),
 184          (
 185           Character'Pos ('F') mod 16#20#, REQ_NEXT_PAGE
 186           ),
 187          (
 188           Character'Pos ('G') mod 16#20#, REQ_DEL_WORD
 189           ),
 190          (
 191           Character'Pos ('H') mod 16#20#, REQ_DEL_PREV
 192           ),
 193          (
 194           Character'Pos ('I') mod 16#20#, REQ_INS_CHAR
 195           ),
 196          (
 197           Character'Pos ('K') mod 16#20#, REQ_CLR_EOF
 198           ),
 199          (
 200           Character'Pos ('L') mod 16#20#, REQ_LEFT_FIELD
 201           ),
 202          (
 203           Character'Pos ('M') mod 16#20#, REQ_NEW_LINE
 204           ),
 205          (
 206           Character'Pos ('N') mod 16#20#, REQ_NEXT_FIELD
 207           ),
 208          (
 209           Character'Pos ('O') mod 16#20#, REQ_INS_LINE
 210           ),
 211          (
 212           Character'Pos ('P') mod 16#20#, REQ_PREV_FIELD
 213           ),
 214          (
 215           Character'Pos ('R') mod 16#20#, REQ_RIGHT_FIELD
 216           ),
 217          (
 218           Character'Pos ('S') mod 16#20#, REQ_BEG_FIELD
 219           ),
 220          (
 221           Character'Pos ('U') mod 16#20#, REQ_UP_FIELD
 222           ),
 223          (
 224           Character'Pos ('V') mod 16#20#, REQ_DEL_CHAR
 225           ),
 226          (
 227           Character'Pos ('W') mod 16#20#, REQ_NEXT_WORD
 228           ),
 229          (
 230           Character'Pos ('X') mod 16#20#, REQ_CLR_FIELD
 231           ),
 232          (
 233           Character'Pos ('Y') mod 16#20#, REQ_DEL_LINE
 234           ),
 235          (
 236           Character'Pos ('Z') mod 16#20#, REQ_PREV_CHOICE
 237           ),
 238          (
 239           Character'Pos ('[') mod 16#20#, --  ESCAPE
 240           Form_Request_Code'Last + 1
 241           ),
 242          (
 243           Key_Backspace, REQ_DEL_PREV
 244           ),
 245          (
 246           KEY_DOWN, REQ_DOWN_CHAR
 247           ),
 248          (
 249           Key_End, REQ_LAST_FIELD
 250           ),
 251          (
 252           Key_Home, REQ_FIRST_FIELD
 253           ),
 254          (
 255           KEY_LEFT, REQ_LEFT_CHAR
 256           ),
 257          (
 258           KEY_LL, REQ_LAST_FIELD
 259           ),
 260          (
 261           Key_Next, REQ_NEXT_FIELD
 262           ),
 263          (
 264           KEY_NPAGE, REQ_NEXT_PAGE
 265           ),
 266          (
 267           KEY_PPAGE, REQ_PREV_PAGE
 268           ),
 269          (
 270           Key_Previous, REQ_PREV_FIELD
 271           ),
 272          (
 273           KEY_RIGHT, REQ_RIGHT_CHAR
 274           ),
 275          (
 276           KEY_UP, REQ_UP_CHAR
 277           ),
 278          (
 279           Character'Pos ('Q') mod 16#20#, --  QUIT
 280           Form_Request_Code'Last + 1      --  TODO MAX_FORM_COMMAND + 1
 281           )
 282          );
 283
 284       c : Key_Code := Getchar (w);
 285       me : Field := Current (f);
 286
 287    begin
 288       if c = Character'Pos (']') mod 16#20# then
 289          if mode = REQ_INS_MODE then
 290             mode := REQ_OVL_MODE;
 291          else
 292             mode := REQ_INS_MODE;
 293          end if;
 294          c := mode;
 295       else
 296          for n in lookup'Range loop
 297             if lookup (n).code = c then
 298                c := lookup (n).result;
 299                exit;
 300             end if;
 301          end loop;
 302       end if;
 303
 304       --  Force the field that the user is typing into to be in reverse video,
 305       --  while the other fields are shown underlined.
 306       if c <= Key_Max then
 307          c := edit_secure (me, c);
 308          Set_Background (me, (Reverse_Video => True, others => False));
 309       elsif c <= Form_Request_Code'Last then
 310          c := edit_secure (me, c);
 311          Set_Background (me, (Under_Line => True, others => False));
 312       end if;
 313       return c;
 314    end form_virtualize;
 315
 316    function my_form_driver (f : Form; c : Key_Code) return Boolean is
 317       flag : Driver_Result := Driver (f, F_Validate_Field);
 318    begin
 319       if c = Form_Request_Code'Last + 1
 320         and flag = Form_Ok then
 321          return True;
 322       else
 323          Beep;
 324          return False;
 325       end if;
 326    end my_form_driver;
 327
 328    function make_label (frow  : Line_Position;
 329                         fcol  : Column_Position;
 330                         label : String) return Field is
 331       f : Field := Create (1, label'Length, frow, fcol, 0, 0);
 332       o : Field_Option_Set := Get_Options (f);
 333    begin
 334       if f /= Null_Field then
 335          Set_Buffer (f, 0, label);
 336          o.Active := False;
 337          Set_Options (f, o);
 338       end if;
 339       return f;
 340    end make_label;
 341
 342    function make_field (frow   : Line_Position;
 343                         fcol   : Column_Position;
 344                         rows   : Line_Count;
 345                         cols   : Column_Count;
 346                         secure : Boolean) return Field is
 347       f : Field;
 348       use StringData;
 349       len : myptr;
 350    begin
 351       if secure then
 352          f := Create (rows, cols, frow, fcol, 0, 1);
 353       else
 354          f := Create (rows, cols, frow, fcol, 0, 0);
 355       end if;
 356
 357       if f /= Null_Field then
 358          Set_Background (f, (Under_Line => True, others => False));
 359          len := new Integer;
 360          len.all := 0;
 361          Set_User_Data (f, len);
 362       end if;
 363       return f;
 364    end make_field;
 365
 366    procedure display_form (f : Form) is
 367       w : Window;
 368       rows : Line_Count;
 369       cols : Column_Count;
 370    begin
 371       Scale (f, rows, cols);
 372
 373       w := New_Window (rows + 2, cols + 4, 0, 0);
 374       if w /= Null_Window then
 375          Set_Window (f, w);
 376          Set_Sub_Window (f, Derived_Window (w, rows, cols, 1, 2));
 377          Box (w); -- 0,0
 378          Set_KeyPad_Mode (w, True);
 379       end if;
 380
 381       --  TODO if Post(f) /= Form_Ok then it's a procedure
 382       declare
 383       begin
 384          Post (f);
 385       exception
 386          when
 387            Eti_System_Error    |
 388            Eti_Bad_Argument    |
 389            Eti_Posted          |
 390            Eti_Connected       |
 391            Eti_Bad_State       |
 392            Eti_No_Room         |
 393            Eti_Not_Posted      |
 394            Eti_Unknown_Command |
 395            Eti_No_Match        |
 396            Eti_Not_Selectable  |
 397            Eti_Not_Connected   |
 398            Eti_Request_Denied  |
 399            Eti_Invalid_Field   |
 400            Eti_Current         =>
 401             Refresh (w);
 402       end;
 403       --  end if;
 404    end display_form;
 405
 406    procedure erase_form (f : Form) is
 407       w : Window := Get_Window (f);
 408       s : Window := Get_Sub_Window (f);
 409    begin
 410       Post (f, False);
 411       Erase (w);
 412       Refresh (w);
 413       Delete (s);
 414       Delete (w);
 415    end erase_form;
 416
 417    finished : Boolean := False;
 418    f : Field_Array_Access := new Field_Array (1 .. 12);
 419    secure : Field;
 420    myform : Form;
 421    w : Window;
 422    c : Key_Code;
 423    result : Driver_Result;
 424 begin
 425    Move_Cursor (Line => 18, Column => 0);
 426    Add (Str => "Defined form-traversal keys:   ^Q/ESC- exit form");
 427    Add (Ch => newl);
 428    Add (Str => "^N   -- go to next field       ^P  -- go to previous field");
 429    Add (Ch => newl);
 430    Add (Str => "Home -- go to first field      End -- go to last field");
 431    Add (Ch => newl);
 432    Add (Str => "^L   -- go to field to left    ^R  -- go to field to right");
 433    Add (Ch => newl);
 434    Add (Str => "^U   -- move upward to field   ^D  -- move downward to field");
 435    Add (Ch => newl);
 436    Add (Str => "^W   -- go to next word        ^B  -- go to previous word");
 437    Add (Ch => newl);
 438    Add (Str => "^S   -- go to start of field   ^E  -- go to end of field");
 439    Add (Ch => newl);
 440    Add (Str => "^H   -- delete previous char   ^Y  -- delete line");
 441    Add (Ch => newl);
 442    Add (Str => "^G   -- delete current word    ^C  -- clear to end of line");
 443    Add (Ch => newl);
 444    Add (Str => "^K   -- clear to end of field  ^X  -- clear field");
 445    Add (Ch => newl);
 446    Add (Str => "Arrow keys move within a field as you would expect.");
 447
 448    Add (Line => 4, Column => 57, Str => "Forms Entry Test");
 449
 450    Refresh;
 451
 452    --  describe the form
 453    f (1) := make_label (0, 15, "Sample Form");
 454    f (2) := make_label (2, 0, "Last Name");
 455    f (3) := make_field (3, 0, 1, 18, False);
 456    f (4) := make_label (2, 20, "First Name");
 457    f (5) := make_field (3, 20, 1, 12, False);
 458    f (6) := make_label (2, 34, "Middle Name");
 459    f (7) := make_field (3, 34, 1, 12, False);
 460    f (8) := make_label (5, 0, "Comments");
 461    f (9) := make_field (6, 0, 4, 46, False);
 462    f (10) := make_label (5, 20, "Password:");
 463    f (11) := make_field (5, 30, 1, 9, True);
 464    secure := f (11);
 465    f (12) := Null_Field;
 466
 467    myform := New_Form (f);
 468
 469    display_form (myform);
 470
 471    w := Get_Window (myform);
 472    Set_Raw_Mode (SwitchOn => True);
 473    Set_NL_Mode (SwitchOn => True);     --  lets us read ^M's
 474    while not finished loop
 475       c := form_virtualize (myform, w);
 476       result := Driver (myform, c);
 477       case result is
 478          when Form_Ok =>
 479             Add (Line => 5, Column => 57, Str => Get_Buffer (secure, 1));
 480             Clear_To_End_Of_Line;
 481             Refresh;
 482          when Unknown_Request =>
 483             finished := my_form_driver (myform, c);
 484          when others =>
 485             Beep;
 486       end case;
 487    end loop;
 488
 489    erase_form (myform);
 490
 491    --  TODO Free_Form(myform);
 492    --     for (c = 0; f[c] != 0; c++) free_field(f[c]);
 493    Set_Raw_Mode (SwitchOn => False);
 494    Set_NL_Mode (SwitchOn => True);
 495
 496 end ncurses2.demo_forms;