ncurses 5.3
[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 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;