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