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