1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 2000-2006,2011 Free Software Foundation, Inc. --
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: --
20 -- The above copyright notice and this permission notice shall be included --
21 -- in all copies or substantial portions of the Software. --
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. --
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 --
35 ------------------------------------------------------------------------------
36 -- Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
39 -- $Date: 2011/03/23 00:44:12 $
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
;
48 with Ada
.Strings
.Bounded
;
50 procedure ncurses2
.demo_forms
is
51 package BS
is new Ada
.Strings
.Bounded
.Generic_Bounded_Length
(80);
53 type myptr
is access Integer;
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)
61 package StringData
is new
62 Terminal_Interface
.Curses
.Forms
.Field_User_Data
(Integer, myptr
);
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
;
74 secure
: Boolean) return Field
;
75 procedure display_form
(f
: Form
);
76 procedure erase_form
(f
: Form
);
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
84 function edit_secure
(me
: Field
; c_in
: Key_Code
) return Key_Code
is
85 rows
, frow
: Line_Position
;
87 cols
, fcol
: Column_Position
;
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.
100 temp
: BS
.Bounded_String
;
101 temps
: String (1 .. 10);
102 -- TODO Get_Buffer povides no information on the field length?
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));
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 ('*');
136 c
:= 0; -- we don't want to do inline editing
137 when REQ_CLR_FIELD
=>
139 temp
:= BS
.To_Bounded_String
("");
140 Set_Buffer
(me
, 1, BS
.To_String
(temp
));
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;
159 mode
: Key_Code
:= REQ_INS_MODE
;
161 function form_virtualize
(f
: Form
; w
: Window
) return Key_Code
is
162 type lookup_t
is record
165 -- should be Form_Request_Code, but we need MAX_COMMAND + 1
168 lookup
: constant array (Positive range <>) of lookup_t
:=
171 Character'Pos ('A') mod 16#
20#
, REQ_NEXT_CHOICE
174 Character'Pos ('B') mod 16#
20#
, REQ_PREV_WORD
177 Character'Pos ('C') mod 16#
20#
, REQ_CLR_EOL
180 Character'Pos ('D') mod 16#
20#
, REQ_DOWN_FIELD
183 Character'Pos ('E') mod 16#
20#
, REQ_END_FIELD
186 Character'Pos ('F') mod 16#
20#
, REQ_NEXT_PAGE
189 Character'Pos ('G') mod 16#
20#
, REQ_DEL_WORD
192 Character'Pos ('H') mod 16#
20#
, REQ_DEL_PREV
195 Character'Pos ('I') mod 16#
20#
, REQ_INS_CHAR
198 Character'Pos ('K') mod 16#
20#
, REQ_CLR_EOF
201 Character'Pos ('L') mod 16#
20#
, REQ_LEFT_FIELD
204 Character'Pos ('M') mod 16#
20#
, REQ_NEW_LINE
207 Character'Pos ('N') mod 16#
20#
, REQ_NEXT_FIELD
210 Character'Pos ('O') mod 16#
20#
, REQ_INS_LINE
213 Character'Pos ('P') mod 16#
20#
, REQ_PREV_FIELD
216 Character'Pos ('R') mod 16#
20#
, REQ_RIGHT_FIELD
219 Character'Pos ('S') mod 16#
20#
, REQ_BEG_FIELD
222 Character'Pos ('U') mod 16#
20#
, REQ_UP_FIELD
225 Character'Pos ('V') mod 16#
20#
, REQ_DEL_CHAR
228 Character'Pos ('W') mod 16#
20#
, REQ_NEXT_WORD
231 Character'Pos ('X') mod 16#
20#
, REQ_CLR_FIELD
234 Character'Pos ('Y') mod 16#
20#
, REQ_DEL_LINE
237 Character'Pos ('Z') mod 16#
20#
, REQ_PREV_CHOICE
240 Character'Pos ('[') mod 16#
20#
, -- ESCAPE
241 Form_Request_Code
'Last + 1
244 Key_Backspace
, REQ_DEL_PREV
247 KEY_DOWN
, REQ_DOWN_CHAR
250 Key_End
, REQ_LAST_FIELD
253 Key_Home
, REQ_FIRST_FIELD
256 KEY_LEFT
, REQ_LEFT_CHAR
259 KEY_LL
, REQ_LAST_FIELD
262 Key_Next
, REQ_NEXT_FIELD
265 KEY_NPAGE
, REQ_NEXT_PAGE
268 KEY_PPAGE
, REQ_PREV_PAGE
271 Key_Previous
, REQ_PREV_FIELD
274 KEY_RIGHT
, REQ_RIGHT_CHAR
280 Character'Pos ('Q') mod 16#
20#
, -- QUIT
281 Form_Request_Code
'Last + 1 -- TODO MAX_FORM_COMMAND + 1
285 c
: Key_Code
:= Getchar
(w
);
286 me
: constant Field
:= Current
(f
);
289 if c
= Character'Pos (']') mod 16#
20#
then
290 if mode
= REQ_INS_MODE
then
291 mode
:= REQ_OVL_MODE
;
293 mode
:= REQ_INS_MODE
;
297 for n
in lookup
'Range loop
298 if lookup
(n
).code
= c
then
299 c
:= lookup
(n
).result
;
305 -- Force the field that the user is typing into to be in reverse video,
306 -- while the other fields are shown underlined.
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));
317 function my_form_driver
(f
: Form
; c
: Key_Code
) return Boolean is
318 flag
: constant Driver_Result
:= Driver
(f
, F_Validate_Field
);
320 if c
= Form_Request_Code
'Last + 1
321 and flag
= Form_Ok
then
329 function make_label
(frow
: Line_Position
;
330 fcol
: Column_Position
;
331 label
: String) return Field
is
332 f
: constant Field
:= Create
(1, label
'Length, frow
, fcol
, 0, 0);
333 o
: Field_Option_Set
:= Get_Options
(f
);
335 if f
/= Null_Field
then
336 Set_Buffer
(f
, 0, label
);
343 function make_field
(frow
: Line_Position
;
344 fcol
: Column_Position
;
347 secure
: Boolean) return Field
is
353 f
:= Create
(rows
, cols
, frow
, fcol
, 0, 1);
355 f
:= Create
(rows
, cols
, frow
, fcol
, 0, 0);
358 if f
/= Null_Field
then
359 Set_Background
(f
, (Under_Line
=> True, others => False));
362 Set_User_Data
(f
, len
);
367 procedure display_form
(f
: Form
) is
372 Scale
(f
, rows
, cols
);
374 w
:= New_Window
(rows
+ 2, cols
+ 4, 0, 0);
375 if w
/= Null_Window
then
377 Set_Sub_Window
(f
, Derived_Window
(w
, rows
, cols
, 1, 2));
379 Set_KeyPad_Mode
(w
, True);
382 -- TODO if Post(f) /= Form_Ok then it's a procedure
395 Eti_Unknown_Command |
407 procedure erase_form
(f
: Form
) is
408 w
: Window
:= Get_Window
(f
);
409 s
: Window
:= Get_Sub_Window
(f
);
418 finished
: Boolean := False;
419 f
: constant Field_Array_Access
:= new Field_Array
(1 .. 12);
424 result
: Driver_Result
;
426 Move_Cursor
(Line
=> 18, Column
=> 0);
427 Add
(Str
=> "Defined form-traversal keys: ^Q/ESC- exit form");
429 Add
(Str
=> "^N -- go to next field ^P -- go to previous field");
431 Add
(Str
=> "Home -- go to first field End -- go to last field");
433 Add
(Str
=> "^L -- go to field to left ^R -- go to field to right");
435 Add
(Str
=> "^U -- move upward to field ^D -- move downward to field");
437 Add
(Str
=> "^W -- go to next word ^B -- go to previous word");
439 Add
(Str
=> "^S -- go to start of field ^E -- go to end of field");
441 Add
(Str
=> "^H -- delete previous char ^Y -- delete line");
443 Add
(Str
=> "^G -- delete current word ^C -- clear to end of line");
445 Add
(Str
=> "^K -- clear to end of field ^X -- clear field");
447 Add
(Str
=> "Arrow keys move within a field as you would expect.");
449 Add
(Line
=> 4, Column
=> 57, Str
=> "Forms Entry Test");
454 f
.all (1) := make_label
(0, 15, "Sample Form");
455 f
.all (2) := make_label
(2, 0, "Last Name");
456 f
.all (3) := make_field
(3, 0, 1, 18, False);
457 f
.all (4) := make_label
(2, 20, "First Name");
458 f
.all (5) := make_field
(3, 20, 1, 12, False);
459 f
.all (6) := make_label
(2, 34, "Middle Name");
460 f
.all (7) := make_field
(3, 34, 1, 12, False);
461 f
.all (8) := make_label
(5, 0, "Comments");
462 f
.all (9) := make_field
(6, 0, 4, 46, False);
463 f
.all (10) := make_label
(5, 20, "Password:");
464 f
.all (11) := make_field
(5, 30, 1, 9, True);
465 secure
:= f
.all (11);
466 f
.all (12) := Null_Field
;
468 myform
:= New_Form
(f
);
470 display_form
(myform
);
472 w
:= Get_Window
(myform
);
473 Set_Raw_Mode
(SwitchOn
=> True);
474 Set_NL_Mode
(SwitchOn
=> True); -- lets us read ^M's
475 while not finished
loop
476 c
:= form_virtualize
(myform
, w
);
477 result
:= Driver
(myform
, c
);
480 Add
(Line
=> 5, Column
=> 57, Str
=> Get_Buffer
(secure
, 1));
481 Clear_To_End_Of_Line
;
483 when Unknown_Request
=>
484 finished
:= my_form_driver
(myform
, c
);
492 -- TODO Free_Form(myform);
493 -- for (c = 0; f[c] != 0; c++) free_field(f[c]);
494 Set_Raw_Mode
(SwitchOn
=> False);
495 Set_NL_Mode
(SwitchOn
=> True);
497 end ncurses2
.demo_forms
;