Ada95/ada_include/terminal_interface-curses-forms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                           GNAT ncurses Binding                           --
   4 --                                                                          --
   5 --                      Terminal_Interface.Curses.Forms                     --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 --  Version 00.92                                                           --
  10 --                                                                          --
  11 --  The ncurses Ada95 binding is copyrighted 1996 by                        --
  12 --  Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de                     --
  13 --                                                                          --
  14 --  Permission is hereby granted to reproduce and distribute this           --
  15 --  binding by any means and for any fee, whether alone or as part          --
  16 --  of a larger distribution, in source or in binary form, PROVIDED         --
  17 --  this notice is included with any such distribution, and is not          --
  18 --  removed from any of its header files. Mention of ncurses and the        --
  19 --  author of this binding in any applications linked with it is            --
  20 --  highly appreciated.                                                     --
  21 --                                                                          --
  22 --  This binding comes AS IS with no warranty, implied or expressed.        --
  23 ------------------------------------------------------------------------------
  24 --  Version Control:
  25 --  $Revision: 1.9 $
  26 ------------------------------------------------------------------------------
  27 with Ada.Tags; use Ada.Tags;
  28 with Ada.Unchecked_Deallocation;
  29 with Unchecked_Conversion;
  30
  31 with Interfaces.C; use Interfaces.C;
  32 with Interfaces.C.Strings; use Interfaces.C.Strings;
  33
  34 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
  35 with GNAT.Htable;
  36
  37 package body Terminal_Interface.Curses.Forms is
  38
  39 ------------------------------------------------------------------------------
  40    --  |
  41    --  |
  42    --  |
  43    --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
  44
  45    function FOS_2_CInt is new
  46      Unchecked_Conversion (Field_Option_Set,
  47                            C_Int);
  48
  49    function CInt_2_FOS is new
  50      Unchecked_Conversion (C_Int,
  51                            Field_Option_Set);
  52
  53    function FrmOS_2_CInt is new
  54      Unchecked_Conversion (Form_Option_Set,
  55                            C_Int);
  56
  57    function CInt_2_FrmOS is new
  58      Unchecked_Conversion (C_Int,
  59                            Form_Option_Set);
  60
  61    procedure Request_Name (Key  : in Form_Request_Code;
  62                                 Name : out String)
  63    is
  64       function Form_Request_Name (Key : C_Int) return chars_ptr;
  65       pragma Import (C, Form_Request_Name, "form_request_name");
  66    begin
  67       Fill_String (Form_Request_Name (C_Int (Key)), Name);
  68    end Request_Name;
  69 ------------------------------------------------------------------------------
  70    procedure Free_Field_User_Wrapper is
  71      new Ada.Unchecked_Deallocation (Field_User_Wrapper,
  72                                      Field_User_Wrapper_Access);
  73
  74    procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access);
  75    procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access);
  76
  77    procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access)
  78    is
  79    begin
  80       A.N := A.N - 1;
  81       if A.N = 0 then
  82          Free_Field_User_Wrapper (A);
  83       end if;
  84    end Release_User_Wrapper;
  85    pragma Inline (Release_User_Wrapper);
  86
  87    procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access)
  88    is
  89    begin
  90       A.N := A.N + 1;
  91    end Dup_User_Wrapper;
  92    pragma Inline (Dup_User_Wrapper);
  93 ------------------------------------------------------------------------------
  94    procedure Free_Form_User_Wrapper is
  95      new Ada.Unchecked_Deallocation (Form_User_Wrapper,
  96                                      Form_User_Wrapper_Access);
  97    --  |
  98    --  |
  99    --  |
 100    --  |
 101    --  |=====================================================================
 102    --  | man page form_field_new.3x
 103    --  |=====================================================================
 104    --  |
 105    --  |
 106    --  |
 107    function Create (Height       : Line_Count;
 108                     Width        : Column_Count;
 109                     Top          : Line_Position;
 110                     Left         : Column_Position;
 111                     Off_Screen   : Natural := 0;
 112                     More_Buffers : Buffer_Number := Buffer_Number'First)
 113                     return Field
 114    is
 115       function Newfield (H, W, T, L, O, M : C_Int) return Field;
 116       pragma Import (C, Newfield, "new_field");
 117       Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
 118                                         C_Int (Top), C_Int (Left),
 119                                         C_Int (Off_Screen),
 120                                         C_Int (More_Buffers));
 121
 122       A   : Field_User_Wrapper_Access;
 123       Res : Eti_Error;
 124    begin
 125       if Fld = Null_Field then
 126          raise Form_Exception;
 127       else
 128          A := new Field_User_Wrapper'(U => System.Null_Address,
 129                                       T => null,
 130                                       N => 1);
 131          Res := Set_Field_Userptr (Fld, A);
 132          if Res /= E_Ok then
 133             Free_Field_User_Wrapper (A);
 134             Eti_Exception (Res);
 135          end if;
 136       end if;
 137       return Fld;
 138    end Create;
 139 --  |
 140 --  |
 141 --  |
 142    procedure Delete (Fld : in out Field)
 143    is
 144       function Free_Field (Fld : Field) return C_Int;
 145       pragma Import (C, Free_Field, "free_field");
 146       procedure Free_Field_Type is
 147         new Ada.Unchecked_Deallocation (Field_Type'Class,
 148                                         Field_Type_Access);
 149
 150       A   : Field_User_Wrapper_Access := Field_Userptr (Fld);
 151       Res : Eti_Error;
 152    begin
 153       if A /= null then
 154          if A.T /= null then
 155             Free_Field_Type (A.T);
 156          end if;
 157          Release_User_Wrapper (A);
 158       end if;
 159       Res := Free_Field (Fld);
 160       if Res /= E_Ok then
 161          Eti_Exception (Res);
 162       end if;
 163       Fld := Null_Field;
 164    end Delete;
 165    --  |
 166    --  |
 167    --  |
 168    function Duplicate (Fld  : Field;
 169                        Top  : Line_Position;
 170                        Left : Column_Position) return Field
 171    is
 172       function Dup_Field (Fld  : Field;
 173                           Top  : C_Int;
 174                           Left : C_Int) return Field;
 175       pragma Import (C, Dup_Field, "dup_field");
 176
 177       A : Field_User_Wrapper_Access := Field_Userptr (Fld);
 178       F : constant Field := Dup_Field (Fld,
 179                                        C_Int (Top),
 180                                        C_Int (Left));
 181    begin
 182       if F = Null_Field then
 183          raise Form_Exception;
 184       else
 185          Dup_User_Wrapper (A);
 186       end if;
 187       return F;
 188    end Duplicate;
 189    --  |
 190    --  |
 191    --  |
 192    function Link (Fld  : Field;
 193                   Top  : Line_Position;
 194                   Left : Column_Position) return Field
 195    is
 196       function Lnk_Field (Fld  : Field;
 197                           Top  : C_Int;
 198                           Left : C_Int) return Field;
 199       pragma Import (C, Lnk_Field, "link_field");
 200
 201       A : Field_User_Wrapper_Access := Field_Userptr (Fld);
 202       F : constant Field := Lnk_Field (Fld,
 203                                        C_Int (Top),
 204                                        C_Int (Left));
 205    begin
 206       if F = Null_Field then
 207          raise Form_Exception;
 208       else
 209          Dup_User_Wrapper (A);
 210       end if;
 211       return F;
 212    end Link;
 213    --  |
 214    --  |=====================================================================
 215    --  | man page form_field_just.3x
 216    --  |=====================================================================
 217    --  |
 218    --  |
 219    --  |
 220    procedure Set_Justification (Fld  : in Field;
 221                                 Just : in Field_Justification := None)
 222    is
 223       function Set_Field_Just (Fld  : Field;
 224                                Just : C_Int) return C_Int;
 225       pragma Import (C, Set_Field_Just, "set_field_just");
 226
 227       Res : constant Eti_Error :=
 228         Set_Field_Just (Fld,
 229                         C_Int (Field_Justification'Pos (Just)));
 230    begin
 231       if Res /= E_Ok then
 232          Eti_Exception (Res);
 233       end if;
 234    end Set_Justification;
 235    --  |
 236    --  |
 237    --  |
 238    function Get_Justification (Fld : Field) return Field_Justification
 239    is
 240       function Field_Just (Fld : Field) return C_Int;
 241       pragma Import (C, Field_Just, "field_just");
 242    begin
 243       return Field_Justification'Val (Field_Just (Fld));
 244    end Get_Justification;
 245    --  |
 246    --  |=====================================================================
 247    --  | man page form_field_buffer.3x
 248    --  |=====================================================================
 249    --  |
 250    --  |
 251    --  |
 252    procedure Set_Buffer
 253      (Fld    : in Field;
 254       Buffer : in Buffer_Number := Buffer_Number'First;
 255       Str    : in String)
 256    is
 257       type Char_Ptr is access all Interfaces.C.Char;
 258       function Set_Fld_Buffer (Fld    : Field;
 259                                  Bufnum : C_Int;
 260                                  S      : Char_Ptr)
 261         return C_Int;
 262       pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
 263
 264       Txt : char_array (0 .. Str'Length);
 265       Len : size_t;
 266       Res : Eti_Error;
 267    begin
 268       To_C (Str, Txt, Len);
 269       Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
 270       if Res /= E_Ok then
 271          Eti_Exception (Res);
 272       end if;
 273    end Set_Buffer;
 274    --  |
 275    --  |
 276    --  |
 277    procedure Get_Buffer
 278      (Fld    : in Field;
 279       Buffer : in Buffer_Number := Buffer_Number'First;
 280       Str    : out String)
 281    is
 282       function Field_Buffer (Fld : Field;
 283                              B   : C_Int) return chars_ptr;
 284       pragma Import (C, Field_Buffer, "field_buffer");
 285    begin
 286       Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
 287    end Get_Buffer;
 288    --  |
 289    --  |
 290    --  |
 291    procedure Set_Status (Fld    : in Field;
 292                          Status : in Boolean := True)
 293    is
 294       function Set_Fld_Status (Fld : Field;
 295                                St  : C_Int) return C_Int;
 296       pragma Import (C, Set_Fld_Status, "set_field_status");
 297
 298       Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
 299    begin
 300       if Res /= E_Ok then
 301          raise Form_Exception;
 302       end if;
 303    end Set_Status;
 304    --  |
 305    --  |
 306    --  |
 307    function Changed (Fld : Field) return Boolean
 308    is
 309       function Field_Status (Fld : Field) return C_Int;
 310       pragma Import (C, Field_Status, "field_status");
 311
 312       Res : constant C_Int := Field_Status (Fld);
 313    begin
 314       if Res = Curses_False then
 315          return False;
 316       else
 317          return True;
 318       end if;
 319    end Changed;
 320    --  |
 321    --  |
 322    --  |
 323    procedure Set_Maximum_Size (Fld : in Field;
 324                                Max : in Natural := 0)
 325    is
 326       function Set_Field_Max (Fld : Field;
 327                               M   : C_Int) return C_Int;
 328       pragma Import (C, Set_Field_Max, "set_max_field");
 329
 330       Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
 331    begin
 332       if Res /= E_Ok then
 333          Eti_Exception (Res);
 334       end if;
 335    end Set_Maximum_Size;
 336    --  |
 337    --  |=====================================================================
 338    --  | man page form_field_opts.3x
 339    --  |=====================================================================
 340    --  |
 341    --  |
 342    --  |
 343    procedure Normalize_Field_Options (Options : in out C_Int);
 344    pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
 345
 346    procedure Set_Options (Fld     : in Field;
 347                           Options : in Field_Option_Set)
 348    is
 349       function Set_Field_Opts (Fld : Field;
 350                                Opt : C_Int) return C_Int;
 351       pragma Import (C, Set_Field_Opts, "set_field_opts");
 352
 353       Opt : C_Int := FOS_2_CInt (Options);
 354       Res : Eti_Error;
 355    begin
 356       Normalize_Field_Options (Opt);
 357       Res := Set_Field_Opts (Fld, Opt);
 358       if Res /= E_Ok then
 359          Eti_Exception (Res);
 360       end if;
 361    end Set_Options;
 362    --  |
 363    --  |
 364    --  |
 365    procedure Switch_Options (Fld     : in Field;
 366                              Options : in Field_Option_Set;
 367                              On      : Boolean := True)
 368    is
 369       function Field_Opts_On (Fld : Field;
 370                               Opt : C_Int) return C_Int;
 371       pragma Import (C, Field_Opts_On, "field_opts_on");
 372       function Field_Opts_Off (Fld : Field;
 373                                Opt : C_Int) return C_Int;
 374       pragma Import (C, Field_Opts_Off, "field_opts_off");
 375
 376       Err : Eti_Error;
 377       Opt : C_Int := FOS_2_CInt (Options);
 378    begin
 379       Normalize_Field_Options (Opt);
 380       if On then
 381          Err := Field_Opts_On (Fld, Opt);
 382       else
 383          Err := Field_Opts_Off (Fld, Opt);
 384       end if;
 385       if Err /= E_Ok then
 386          Eti_Exception (Err);
 387       end if;
 388    end Switch_Options;
 389    --  |
 390    --  |
 391    --  |
 392    procedure Get_Options (Fld     : in  Field;
 393                           Options : out Field_Option_Set)
 394    is
 395       function Field_Opts (Fld : Field) return C_Int;
 396       pragma Import (C, Field_Opts, "field_opts");
 397
 398       Res : C_Int := Field_Opts (Fld);
 399    begin
 400       Normalize_Field_Options (Res);
 401       Options := CInt_2_FOS (Res);
 402    end Get_Options;
 403    --  |
 404    --  |
 405    --  |
 406    function Get_Options (Fld : Field := Null_Field)
 407                          return Field_Option_Set
 408    is
 409       Fos : Field_Option_Set;
 410    begin
 411       Get_Options (Fld, Fos);
 412       return Fos;
 413    end Get_Options;
 414    --  |
 415    --  |=====================================================================
 416    --  | man page form_field_attributes.3x
 417    --  |=====================================================================
 418    --  |
 419    --  |
 420    --  |
 421    procedure Set_Foreground
 422      (Fld   : in Field;
 423       Fore  : in Character_Attribute_Set := Normal_Video;
 424       Color : in Color_Pair := Color_Pair'First)
 425    is
 426       function Set_Field_Fore (Fld  : Field;
 427                                Attr : C_Int) return C_Int;
 428       pragma Import (C, Set_Field_Fore, "set_field_fore");
 429
 430       Ch : constant Attributed_Character := (Ch    => Character'First,
 431                                              Color => Color,
 432                                              Attr  => Fore);
 433       Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
 434    begin
 435       if  Res /= E_Ok then
 436          Eti_Exception (Res);
 437       end if;
 438    end Set_Foreground;
 439    --  |
 440    --  |
 441    --  |
 442    procedure Foreground (Fld  : in  Field;
 443                          Fore : out Character_Attribute_Set)
 444    is
 445       function Field_Fore (Fld : Field) return C_Int;
 446       pragma Import (C, Field_Fore, "field_fore");
 447    begin
 448       Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
 449    end Foreground;
 450
 451    procedure Foreground (Fld   : in  Field;
 452                          Fore  : out Character_Attribute_Set;
 453                          Color : out Color_Pair)
 454    is
 455       function Field_Fore (Fld : Field) return C_Int;
 456       pragma Import (C, Field_Fore, "field_fore");
 457    begin
 458       Fore  := CInt_To_Chtype (Field_Fore (Fld)).Attr;
 459       Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
 460    end Foreground;
 461    --  |
 462    --  |
 463    --  |
 464    procedure Set_Background
 465      (Fld   : in Field;
 466       Back  : in Character_Attribute_Set := Normal_Video;
 467       Color : in Color_Pair := Color_Pair'First)
 468    is
 469       function Set_Field_Back (Fld  : Field;
 470                                Attr : C_Int) return C_Int;
 471       pragma Import (C, Set_Field_Back, "set_field_back");
 472
 473       Ch : constant Attributed_Character := (Ch    => Character'First,
 474                                              Color => Color,
 475                                              Attr  => Back);
 476       Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
 477    begin
 478       if  Res /= E_Ok then
 479          Eti_Exception (Res);
 480       end if;
 481    end Set_Background;
 482    --  |
 483    --  |
 484    --  |
 485    procedure Background (Fld  : in  Field;
 486                          Back : out Character_Attribute_Set)
 487    is
 488       function Field_Back (Fld : Field) return C_Int;
 489       pragma Import (C, Field_Back, "field_back");
 490    begin
 491       Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
 492    end Background;
 493
 494    procedure Background (Fld   : in  Field;
 495                          Back  : out Character_Attribute_Set;
 496                          Color : out Color_Pair)
 497    is
 498       function Field_Back (Fld : Field) return C_Int;
 499       pragma Import (C, Field_Back, "field_back");
 500    begin
 501       Back  := CInt_To_Chtype (Field_Back (Fld)).Attr;
 502       Color := CInt_To_Chtype (Field_Back (Fld)).Color;
 503    end Background;
 504    --  |
 505    --  |
 506    --  |
 507    procedure Set_Pad_Character (Fld : in Field;
 508                                 Pad : in Character := Space)
 509    is
 510       function Set_Field_Pad (Fld : Field;
 511                               Ch  : C_Int) return C_Int;
 512       pragma Import (C, Set_Field_Pad, "set_field_pad");
 513
 514       Res : constant Eti_Error := Set_Field_Pad (Fld,
 515                                                  C_Int (Character'Pos (Pad)));
 516    begin
 517       if Res /= E_Ok then
 518          Eti_Exception (Res);
 519       end if;
 520    end Set_Pad_Character;
 521    --  |
 522    --  |
 523    --  |
 524    procedure Pad_Character (Fld : in  Field;
 525                             Pad : out Character)
 526    is
 527       function Field_Pad (Fld : Field) return C_Int;
 528       pragma Import (C, Field_Pad, "field_pad");
 529    begin
 530       Pad := Character'Val (Field_Pad (Fld));
 531    end Pad_Character;
 532    --  |
 533    --  |=====================================================================
 534    --  | man page form_field_info.3x
 535    --  |=====================================================================
 536    --  |
 537    --  |
 538    --  |
 539    procedure Info (Fld                : in  Field;
 540                    Lines              : out Line_Count;
 541                    Columns            : out Column_Count;
 542                    First_Row          : out Line_Position;
 543                    First_Column       : out Column_Position;
 544                    Off_Screen         : out Natural;
 545                    Additional_Buffers : out Buffer_Number)
 546    is
 547       type C_Int_Access is access all C_Int;
 548       function Fld_Info (Fld : Field;
 549                          L, C, Fr, Fc, Os, Ab : C_Int_Access)
 550                          return C_Int;
 551       pragma Import (C, Fld_Info, "field_info");
 552
 553       L, C, Fr, Fc, Os, Ab : aliased C_Int;
 554       Res : constant Eti_Error := Fld_Info (Fld,
 555                                             L'Access, C'Access,
 556                                             Fr'Access, Fc'Access,
 557                                             Os'Access, Ab'Access);
 558    begin
 559       if Res /= E_Ok then
 560          Eti_Exception (Res);
 561       else
 562          Lines              := Line_Count (L);
 563          Columns            := Column_Count (C);
 564          First_Row          := Line_Position (Fr);
 565          First_Column       := Column_Position (Fc);
 566          Off_Screen         := Natural (Os);
 567          Additional_Buffers := Buffer_Number (Ab);
 568       end if;
 569    end Info;
 570 --  |
 571 --  |
 572 --  |
 573    procedure Dynamic_Info (Fld     : in Field;
 574                            Lines   : out Line_Count;
 575                            Columns : out Column_Count;
 576                            Max     : out Natural)
 577    is
 578       type C_Int_Access is access all C_Int;
 579       function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
 580       pragma Import (C, Dyn_Info, "dynamic_field_info");
 581
 582       L, C, M : aliased C_Int;
 583       Res : constant Eti_Error := Dyn_Info (Fld,
 584                                             L'Access, C'Access,
 585                                             M'Access);
 586    begin
 587       if Res /= E_Ok then
 588          Eti_Exception (Res);
 589       else
 590          Lines   := Line_Count (L);
 591          Columns := Column_Count (C);
 592          Max     := Natural (M);
 593       end if;
 594    end Dynamic_Info;
 595    --  |
 596    --  |=====================================================================
 597    --  | man page form_win.3x
 598    --  |=====================================================================
 599    --  |
 600    --  |
 601    --  |
 602    procedure Set_Window (Frm : in Form;
 603                          Win : in Window)
 604    is
 605       function Set_Form_Win (Frm : Form;
 606                              Win : Window) return C_Int;
 607       pragma Import (C, Set_Form_Win, "set_form_win");
 608
 609       Res : constant Eti_Error := Set_Form_Win (Frm, Win);
 610    begin
 611       if  Res /= E_Ok then
 612          Eti_Exception (Res);
 613       end if;
 614    end Set_Window;
 615    --  |
 616    --  |
 617    --  |
 618    function Get_Window (Frm : Form) return Window
 619    is
 620       function Form_Win (Frm : Form) return Window;
 621       pragma Import (C, Form_Win, "form_win");
 622
 623       W : constant Window := Form_Win (Frm);
 624    begin
 625       return W;
 626    end Get_Window;
 627    --  |
 628    --  |
 629    --  |
 630    procedure Set_Sub_Window (Frm : in Form;
 631                              Win : in Window)
 632    is
 633       function Set_Form_Sub (Frm : Form;
 634                              Win : Window) return C_Int;
 635       pragma Import (C, Set_Form_Sub, "set_form_sub");
 636
 637       Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
 638    begin
 639       if  Res /= E_Ok then
 640          Eti_Exception (Res);
 641       end if;
 642    end Set_Sub_Window;
 643    --  |
 644    --  |
 645    --  |
 646    function Get_Sub_Window (Frm : Form) return Window
 647    is
 648       function Form_Sub (Frm : Form) return Window;
 649       pragma Import (C, Form_Sub, "form_sub");
 650
 651       W : constant Window := Form_Sub (Frm);
 652    begin
 653       return W;
 654    end Get_Sub_Window;
 655    --  |
 656    --  |
 657    --  |
 658    procedure Scale (Frm     : in Form;
 659                     Lines   : out Line_Count;
 660                     Columns : out Column_Count)
 661    is
 662       type C_Int_Access is access all C_Int;
 663       function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
 664       pragma Import (C, M_Scale, "scale_form");
 665
 666       X, Y : aliased C_Int;
 667       Res  : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
 668    begin
 669       if Res /= E_Ok then
 670          Eti_Exception (Res);
 671       end if;
 672       Lines := Line_Count (Y);
 673       Columns := Column_Count (X);
 674    end Scale;
 675    --  |
 676    --  |=====================================================================
 677    --  | man page menu_hook.3x
 678    --  |=====================================================================
 679    --  |
 680    --  |
 681    --  |
 682    procedure Set_Field_Init_Hook (Frm  : in Form;
 683                                   Proc : in Form_Hook_Function)
 684    is
 685       function Set_Field_Init (Frm  : Form;
 686                                Proc : Form_Hook_Function) return C_Int;
 687       pragma Import (C, Set_Field_Init, "set_field_init");
 688
 689       Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
 690    begin
 691       if  Res /= E_Ok then
 692          Eti_Exception (Res);
 693       end if;
 694    end Set_Field_Init_Hook;
 695    --  |
 696    --  |
 697    --  |
 698    procedure Set_Field_Term_Hook (Frm  : in Form;
 699                                   Proc : in Form_Hook_Function)
 700    is
 701       function Set_Field_Term (Frm  : Form;
 702                                Proc : Form_Hook_Function) return C_Int;
 703       pragma Import (C, Set_Field_Term, "set_field_term");
 704
 705       Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
 706    begin
 707       if Res /= E_Ok then
 708          Eti_Exception (Res);
 709       end if;
 710    end Set_Field_Term_Hook;
 711    --  |
 712    --  |
 713    --  |
 714    procedure Set_Form_Init_Hook (Frm  : in Form;
 715                                  Proc : in Form_Hook_Function)
 716    is
 717       function Set_Form_Init (Frm  : Form;
 718                               Proc : Form_Hook_Function) return C_Int;
 719       pragma Import (C, Set_Form_Init, "set_form_init");
 720
 721       Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
 722    begin
 723       if  Res /= E_Ok then
 724          Eti_Exception (Res);
 725       end if;
 726    end Set_Form_Init_Hook;
 727    --  |
 728    --  |
 729    --  |
 730    procedure Set_Form_Term_Hook (Frm  : in Form;
 731                                  Proc : in Form_Hook_Function)
 732    is
 733       function Set_Form_Term (Frm  : Form;
 734                               Proc : Form_Hook_Function) return C_Int;
 735       pragma Import (C, Set_Form_Term, "set_form_term");
 736
 737       Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
 738    begin
 739       if Res /= E_Ok then
 740          Eti_Exception (Res);
 741       end if;
 742    end Set_Form_Term_Hook;
 743    --  |
 744    --  |=====================================================================
 745    --  | man page form_fields.3x
 746    --  |=====================================================================
 747    --  |
 748    --  |
 749    --  |
 750    procedure Free_Allocated_Fields is
 751      new Ada.Unchecked_Deallocation (Field_Array, Field_Array_Access);
 752    --  |
 753    --  |
 754    --  |
 755    --  This is a bit delicate if we want to manipulate an Ada created form
 756    --  from C routines or vice versa.
 757    --  In Ada created forms we use the low level user pointer to maintain
 758    --  binding internal additional informations about the form. This
 759    --  internal information contains a hook for the Ada provided user pointer.
 760    --  Unless you understand this implementation, the safest way in mixed
 761    --  language programs to deal with user pointers is, that only the language
 762    --  that created the form should also manipulate the user pointer for that
 763    --  form.
 764    procedure Redefine (Frm  : in Form;
 765                        Flds : in Field_Array)
 766    is
 767       function Set_Frm_Fields (Frm   : Form;
 768                                Items : Field_Array) return C_Int;
 769       pragma Import (C, Set_Frm_Fields, "set_form_fields");
 770
 771       A   : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
 772       I   : Field_Array_Access;
 773       Res : Eti_Error;
 774    begin
 775       if A = null or else A.I = null then raise Form_Exception;
 776       else
 777          I := new Field_Array (1 .. (Flds'Length + 1));
 778          I.all (1 .. Flds'Length) := Flds (Flds'First .. Flds'Last);
 779          I.all (Flds'Length + 1) := Null_Field;
 780          Res := Set_Frm_Fields (Frm, I.all);
 781          if  Res /= E_Ok then
 782             Free_Allocated_Fields (I);
 783             Eti_Exception (Res);
 784          else
 785             Free_Allocated_Fields (A.I);
 786             A.I := I;
 787          end if;
 788       end if;
 789    end Redefine;
 790    --  |
 791    --  |
 792    --  |
 793    function Fields (Frm : Form) return Field_Array_Access
 794    is
 795       A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
 796    begin
 797       if A = null or else A.I = null then
 798          raise Form_Exception;
 799       else
 800          return A.I;
 801       end if;
 802    end Fields;
 803    --  |
 804    --  |
 805    --  |
 806    function Field_Count (Frm : Form) return Natural
 807    is
 808       function Count (Frm : Form) return C_Int;
 809       pragma Import (C, Count, "field_count");
 810    begin
 811       return Natural (Count (Frm));
 812    end Field_Count;
 813    --  |
 814    --  |
 815    --  |
 816    procedure Move (Fld    : in Field;
 817                    Line   : in Line_Position;
 818                    Column : in Column_Position)
 819    is
 820       function Move (Fld : Field; L, C : C_Int) return C_Int;
 821       pragma Import (C, Move, "move_field");
 822
 823       Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
 824    begin
 825       if Res /= E_Ok then
 826          Eti_Exception (Res);
 827       end if;
 828    end Move;
 829    --  |
 830    --  |=====================================================================
 831    --  | man page form_new.3x
 832    --  |=====================================================================
 833    --  |
 834    --  |
 835    --  |
 836    function Create (Fields : Field_Array) return Form
 837    is
 838       function NewForm (Fields : Field_Array) return Form;
 839       pragma Import (C, NewForm, "new_form");
 840
 841       M   : Form;
 842       I   : Field_Array_Access;
 843       U   : Form_User_Wrapper_Access;
 844       Res : Eti_Error;
 845    begin
 846       I := new Field_Array (1 .. (Fields'Length + 1));
 847       I.all (1 .. Fields'Length) := Fields (Fields'First .. Fields'Last);
 848       I.all (Fields'Length + 1) := Null_Field;
 849       M := NewForm (I.all);
 850       if M = Null_Form then
 851          Free_Allocated_Fields (I);
 852          raise Form_Exception;
 853       end if;
 854       U := new Form_User_Wrapper'(U => System.Null_Address, I => I);
 855       Res := Set_Form_Userptr (M, U);
 856       if  Res /= E_Ok then
 857          Free_Allocated_Fields (I);
 858          Free_Form_User_Wrapper (U);
 859          Eti_Exception (Res);
 860       end if;
 861       return M;
 862    end Create;
 863    --  |
 864    --  |
 865    --  |
 866    procedure Delete (Frm : in out Form)
 867    is
 868       function Free (Frm : Form) return C_Int;
 869       pragma Import (C, Free, "free_form");
 870
 871       U   : Form_User_Wrapper_Access := Form_Userptr (Frm);
 872       Res : constant Eti_Error := Free (Frm);
 873    begin
 874       if Res /= E_Ok then
 875          Eti_Exception (Res);
 876       end if;
 877       if U = null or else U.I = null then
 878          raise Form_Exception;
 879       end if;
 880       Free_Allocated_Fields (U.I);
 881       Free_Form_User_Wrapper (U);
 882       Frm := Null_Form;
 883    end Delete;
 884    --  |
 885    --  |=====================================================================
 886    --  | man page form_opts.3x
 887    --  |=====================================================================
 888    --  |
 889    --  |
 890    --  |
 891    procedure Normalize_Form_Options (Options : in out C_Int);
 892    pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
 893
 894    procedure Set_Options (Frm     : in Form;
 895                           Options : in Form_Option_Set)
 896    is
 897       function Set_Form_Opts (Frm : Form;
 898                               Opt : C_Int) return C_Int;
 899       pragma Import (C, Set_Form_Opts, "set_form_opts");
 900
 901       Opt : C_Int := FrmOS_2_CInt (Options);
 902       Res : Eti_Error;
 903    begin
 904       Normalize_Form_Options (Opt);
 905       Res := Set_Form_Opts (Frm, Opt);
 906       if  Res /= E_Ok then
 907          Eti_Exception (Res);
 908       end if;
 909    end Set_Options;
 910    --  |
 911    --  |
 912    --  |
 913    procedure Switch_Options (Frm     : in Form;
 914                              Options : in Form_Option_Set;
 915                              On      : Boolean := True)
 916    is
 917       function Form_Opts_On (Frm : Form;
 918                              Opt : C_Int) return C_Int;
 919       pragma Import (C, Form_Opts_On, "form_opts_on");
 920       function Form_Opts_Off (Frm : Form;
 921                               Opt : C_Int) return C_Int;
 922       pragma Import (C, Form_Opts_Off, "form_opts_off");
 923
 924       Err : Eti_Error;
 925       Opt : C_Int := FrmOS_2_CInt (Options);
 926    begin
 927       Normalize_Form_Options (Opt);
 928       if On then
 929          Err := Form_Opts_On (Frm, Opt);
 930       else
 931          Err := Form_Opts_Off (Frm, Opt);
 932       end if;
 933       if Err /= E_Ok then
 934          Eti_Exception (Err);
 935       end if;
 936    end Switch_Options;
 937    --  |
 938    --  |
 939    --  |
 940    procedure Get_Options (Frm     : in  Form;
 941                           Options : out Form_Option_Set)
 942    is
 943       function Form_Opts (Frm : Form) return C_Int;
 944       pragma Import (C, Form_Opts, "form_opts");
 945
 946       Res : C_Int := Form_Opts (Frm);
 947    begin
 948       Normalize_Form_Options (Res);
 949       Options := CInt_2_FrmOS (Res);
 950    end Get_Options;
 951    --  |
 952    --  |
 953    --  |
 954    function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
 955    is
 956       Fos : Form_Option_Set;
 957    begin
 958       Get_Options (Frm, Fos);
 959       return Fos;
 960    end Get_Options;
 961    --  |
 962    --  |=====================================================================
 963    --  | man page form_post.3x
 964    --  |=====================================================================
 965    --  |
 966    --  |
 967    --  |
 968    procedure Post (Frm  : in Form;
 969                    Post : in Boolean := True)
 970    is
 971       function M_Post (Frm : Form) return C_Int;
 972       pragma Import (C, M_Post, "post_form");
 973       function M_Unpost (Frm : Form) return C_Int;
 974       pragma Import (C, M_Unpost, "unpost_form");
 975
 976       Res : Eti_Error;
 977    begin
 978       if Post then
 979          Res := M_Post (Frm);
 980       else
 981          Res := M_Unpost (Frm);
 982       end if;
 983       if Res /= E_Ok then
 984          Eti_Exception (Res);
 985       end if;
 986    end Post;
 987    --  |
 988    --  |=====================================================================
 989    --  | man page form_cursor.3x
 990    --  |=====================================================================
 991    --  |
 992    --  |
 993    --  |
 994    procedure Position_Cursor (Frm : Form)
 995    is
 996       function Pos_Form_Cursor (Frm : Form) return C_Int;
 997       pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
 998
 999       Res : constant Eti_Error := Pos_Form_Cursor (Frm);
1000    begin
1001       if  Res /= E_Ok then
1002          Eti_Exception (Res);
1003       end if;
1004    end Position_Cursor;
1005    --  |
1006    --  |=====================================================================
1007    --  | man page form_data.3x
1008    --  |=====================================================================
1009    --  |
1010    --  |
1011    --  |
1012    function Data_Ahead (Frm : Form) return Boolean
1013    is
1014       function Ahead (Frm : Form) return C_Int;
1015       pragma Import (C, Ahead, "data_ahead");
1016
1017       Res : constant C_Int := Ahead (Frm);
1018    begin
1019       if Res = Curses_False then
1020          return False;
1021       else
1022          return True;
1023       end if;
1024    end Data_Ahead;
1025    --  |
1026    --  |
1027    --  |
1028    function Data_Behind (Frm : Form) return Boolean
1029    is
1030       function Behind (Frm : Form) return C_Int;
1031       pragma Import (C, Behind, "data_behind");
1032
1033       Res : constant C_Int := Behind (Frm);
1034    begin
1035       if Res = Curses_False then
1036          return False;
1037       else
1038          return True;
1039       end if;
1040    end Data_Behind;
1041    --  |
1042    --  |=====================================================================
1043    --  | man page form_driver.3x
1044    --  |=====================================================================
1045    --  |
1046    --  |
1047    --  |
1048    function Driver (Frm : Form;
1049                     Key : Key_Code) return Driver_Result
1050    is
1051       function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
1052       pragma Import (C, Frm_Driver, "form_driver");
1053
1054       R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
1055    begin
1056       if R /= E_Ok then
1057          if R = E_Unknown_Command then
1058             return Unknown_Request;
1059          elsif R = E_Invalid_Field then
1060             return Invalid_Field;
1061          elsif R = E_Request_Denied then
1062             return Request_Denied;
1063          else
1064             Eti_Exception (R);
1065             return Form_Ok;
1066          end if;
1067       else
1068          return Form_Ok;
1069       end if;
1070    end Driver;
1071    --  |
1072    --  |=====================================================================
1073    --  | man page form_page.3x
1074    --  |=====================================================================
1075    --  |
1076    --  |
1077    --  |
1078    procedure Set_Current (Frm : in Form;
1079                           Fld : in Field)
1080    is
1081       function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
1082       pragma Import (C, Set_Current_Fld, "set_current_field");
1083
1084       Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
1085    begin
1086       if Res /= E_Ok then
1087          Eti_Exception (Res);
1088       end if;
1089    end Set_Current;
1090    --  |
1091    --  |
1092    --  |
1093    function Current (Frm : in Form) return Field
1094    is
1095       function Current_Fld (Frm : Form) return Field;
1096       pragma Import (C, Current_Fld, "current_field");
1097
1098       Fld : constant Field := Current_Fld (Frm);
1099    begin
1100       if Fld = Null_Field then
1101          raise Form_Exception;
1102       end if;
1103       return Fld;
1104    end Current;
1105    --  |
1106    --  |
1107    --  |
1108    procedure Set_Page (Frm  : in Form;
1109                        Page : in Page_Number := Page_Number'First)
1110    is
1111       function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
1112       pragma Import (C, Set_Frm_Page, "set_form_page");
1113
1114       Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
1115    begin
1116       if Res /= E_Ok then
1117          Eti_Exception (Res);
1118       end if;
1119    end Set_Page;
1120    --  |
1121    --  |
1122    --  |
1123    function Page (Frm : Form) return Page_Number
1124    is
1125       function Get_Page (Frm : Form) return C_Int;
1126       pragma Import (C, Get_Page, "form_page");
1127
1128       P : constant C_Int := Get_Page (Frm);
1129    begin
1130       if P < 0 then
1131          raise Form_Exception;
1132       else
1133          return Page_Number (P);
1134       end if;
1135    end Page;
1136
1137    function Get_Index (Fld : Field) return Positive
1138    is
1139       function Get_Fieldindex (Fld : Field) return C_Int;
1140       pragma Import (C, Get_Fieldindex, "field_index");
1141
1142       Res : constant C_Int := Get_Fieldindex (Fld);
1143    begin
1144       if Res = Curses_Err then
1145          raise Form_Exception;
1146       end if;
1147       return Positive (Natural (Res) + Positive'First);
1148    end Get_Index;
1149
1150    --  |
1151    --  |=====================================================================
1152    --  | man page form_new_page.3x
1153    --  |=====================================================================
1154    --  |
1155    --  |
1156    --  |
1157    procedure Set_New_Page (Fld      : in Field;
1158                            New_Page : in Boolean := True)
1159    is
1160       function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
1161       pragma Import (C, Set_Page, "set_new_page");
1162
1163       Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
1164    begin
1165       if Res /= E_Ok then
1166          Eti_Exception (Res);
1167       end if;
1168    end Set_New_Page;
1169    --  |
1170    --  |
1171    --  |
1172    function Is_New_Page (Fld : Field) return Boolean
1173    is
1174       function Is_New (Fld : Field) return C_Int;
1175       pragma Import (C, Is_New, "new_page");
1176
1177       Res : constant C_Int := Is_New (Fld);
1178    begin
1179       if Res = Curses_False then
1180          return False;
1181       else
1182          return True;
1183       end if;
1184    end Is_New_Page;
1185
1186 ------------------------------------------------------------------------------
1187    --  We use a GNAT internal hash table mechanism to create an association
1188    --  between an Ada_Defined_Field_Type and it's low level C_Field_Type
1189    --  peer.
1190    --  It shouldn´t be too complicated to reimplent this hashing mechanism
1191    --  for other compilers.
1192    --
1193    type Tag_Type_Pair;
1194    type Tag_Pair_Access is access all Tag_Type_Pair;
1195    pragma Controlled (Tag_Pair_Access);
1196
1197    Null_Tag_Pair : constant Tag_Pair_Access := Tag_Pair_Access'(null);
1198
1199    type Tag_Type_Pair is
1200       record
1201          Ada_Tag    : Tag;
1202          Cft        : C_Field_Type;
1203          Next       : Tag_Pair_Access;
1204       end record;
1205
1206    type Htable_Headers is range 1 .. 31;
1207    procedure Free_Tag_Type_Pair is
1208      new Ada.Unchecked_Deallocation (Tag_Type_Pair, Tag_Pair_Access);
1209
1210    procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access);
1211    function  Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access;
1212    function  Get_Pair_Tag  (T : Tag_Pair_Access) return Tag;
1213
1214    function Hash (T : Tag) return Htable_Headers;
1215    function Equal (A, B : Tag) return Boolean;
1216
1217    package External_Pair_Htable is new GNAT.Htable.Static_Htable
1218      (Header_Num => Htable_Headers,
1219       Element    => Tag_Type_Pair,
1220       Elmt_Ptr   => Tag_Pair_Access,
1221       Null_Ptr   => Null_Tag_Pair,
1222       Set_Next   => Set_Pair_Link,
1223       Next       => Get_Pair_Link,
1224       Key        => Tag,
1225       Get_Key    => Get_Pair_Tag,
1226       Hash       => Hash,
1227       Equal      => Equal);
1228
1229    procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access)
1230    is
1231    begin
1232       T.all.Next := Next;
1233    end Set_Pair_Link;
1234
1235    function  Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access
1236    is
1237    begin
1238       return T.all.Next;
1239    end Get_Pair_Link;
1240
1241    function  Get_Pair_Tag  (T : Tag_Pair_Access) return Tag
1242    is
1243    begin
1244       return T.all.Ada_Tag;
1245    end Get_Pair_Tag;
1246
1247    function Equal (A, B : Tag) return Boolean
1248    is
1249    begin
1250       return A = B;
1251    end Equal;
1252
1253    function Hash (T : Tag) return Htable_Headers
1254    is
1255       function H is new GNAT.Htable.Hash (Htable_Headers);
1256    begin
1257       return H (External_Tag (T));
1258    end Hash;
1259
1260    function Search_Type (T : Ada_Defined_Field_Type'Class)
1261                          return C_Field_Type
1262    is
1263       P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1264    begin
1265       if P /= null then
1266          return P.Cft;
1267       else
1268          return Null_Field_Type;
1269       end if;
1270    end Search_Type;
1271
1272    --  Register an Ada_Defined_Field_Type given by its Tag
1273    --  with it's associated C_Field_Type.
1274    procedure Register_Type (T   : in Ada_Defined_Field_Type'Class;
1275                             Cft : in C_Field_Type)
1276    is
1277       C : C_Field_Type := Search_Type (T);
1278       P : Tag_Pair_Access;
1279    begin
1280       if C /= Null_Field_Type then
1281          raise Form_Exception;
1282       else
1283          P := new Tag_Type_Pair'(T'Tag, Cft, null);
1284          External_Pair_Htable.Set (P);
1285       end if;
1286    end Register_Type;
1287
1288    --  Unregister an Ada_Defined_Field_Type given by it's tag
1289    procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
1290    is
1291       function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
1292       pragma Import (C, Free_Fieldtype, "free_fieldtype");
1293
1294       P   : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
1295       Ft  : C_Field_Type;
1296       Res : C_Int;
1297    begin
1298       if P = null then
1299          raise Form_Exception;
1300       else
1301          Ft := P.Cft;
1302          External_Pair_Htable.Remove (T'Tag);
1303          Free_Tag_Type_Pair (P);
1304          Res := Free_Fieldtype (Ft);
1305          if Res /= E_Ok then
1306             Eti_Exception (Res);
1307          end if;
1308       end if;
1309    end Unregister_Type;
1310
1311 ----------------------------------------------------------------------------
1312    --  |
1313    --  |
1314    --  |
1315    procedure Set_Type (Fld      : Field;
1316                        Fld_Type : Ada_Defined_Field_Type)
1317    is
1318       function Set_Fld_Type (F    : Field := Fld;
1319                              Ct   : C_Field_Type;
1320                              Arg1 : Ada_Defined_Field_Type'Class)
1321                              return C_Int;
1322       pragma Import (C, Set_Fld_Type, "set_field_type");
1323       function Field_Userptr (Fld : Field)
1324                               return Field_User_Wrapper_Access;
1325       pragma Import (C, Field_Userptr, "field_userptr");
1326
1327       Res : Eti_Error;
1328       C   : constant C_Field_Type := Search_Type (Fld_Type);
1329    begin
1330       if C = Null_Field_Type then
1331          raise Form_Exception;
1332       else
1333          Res := Set_Fld_Type (Fld, C, Fld_Type);
1334          if Res /= E_Ok then
1335             Eti_Exception (Res);
1336          end if;
1337       end if;
1338    end Set_Type;
1339    --  |
1340    --  |
1341    --  |
1342    function Native_Type (Ftype : Ada_Defined_Field_Type)
1343                          return C_Field_Type
1344    is
1345       C : constant C_Field_Type := Search_Type (Ftype);
1346    begin
1347       if C = Null_Field_Type then
1348          raise Form_Exception;
1349       else
1350          return C;
1351       end if;
1352    end Native_Type;
1353    --  |
1354    --  |
1355    --  |
1356    function Native_Type (Ftype : Alpha_Field)
1357                          return C_Field_Type
1358    is
1359       C_Alpha_Field_Type : C_Field_Type;
1360       pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
1361    begin
1362       return C_Alpha_Field_Type;
1363    end Native_Type;
1364    pragma Inline (Native_Type);
1365    --  |
1366    --  |
1367    --  |
1368    procedure Set_Type (Fld      : in Field;
1369                        Fld_Type : in Alpha_Field)
1370    is
1371       function Set_Fld_Type (F    : Field := Fld;
1372                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1373                              Arg1 : C_Int) return C_Int;
1374       pragma Import (C, Set_Fld_Type, "set_field_type");
1375       function Field_Userptr (Fld : Field)
1376                               return Field_User_Wrapper_Access;
1377       pragma Import (C, Field_Userptr, "field_userptr");
1378
1379       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1380       Res : Eti_Error;
1381    begin
1382       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1383       if Res /= E_Ok then
1384          Eti_Exception (Res);
1385       else
1386          A.T := new Alpha_Field'(Fld_Type);
1387       end if;
1388    end Set_Type;
1389    --  |
1390    --  |
1391    --  |
1392    function Native_Type (Ftype : Alpha_Numeric_Field)
1393                          return C_Field_Type
1394    is
1395       C_Alpha_Numeric_Field_Type : C_Field_Type;
1396       pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
1397    begin
1398       return C_Alpha_Numeric_Field_Type;
1399    end Native_Type;
1400    pragma Inline (Native_Type);
1401    --  |
1402    --  |
1403    --  |
1404    procedure Set_Type (Fld      : in Field;
1405                        Fld_Type : in Alpha_Numeric_Field)
1406    is
1407       function Set_Fld_Type (F    : Field := Fld;
1408                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1409                              Arg1 : C_Int) return C_Int;
1410       pragma Import (C, Set_Fld_Type, "set_field_type");
1411       function Field_Userptr (Fld : Field)
1412                               return Field_User_Wrapper_Access;
1413       pragma Import (C, Field_Userptr, "field_userptr");
1414
1415       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1416       Res : Eti_Error;
1417    begin
1418       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
1419       if Res /= E_Ok then
1420          Eti_Exception (Res);
1421       else
1422          A.T := new Alpha_Numeric_Field'(Fld_Type);
1423       end if;
1424    end Set_Type;
1425    --  |
1426    --  |
1427    --  |
1428    function Native_Type (Ftype : Integer_Field)
1429                          return C_Field_Type
1430    is
1431       C_Integer_Field_Type : C_Field_Type;
1432       pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
1433    begin
1434       return C_Integer_Field_Type;
1435    end Native_Type;
1436    pragma Inline (Native_Type);
1437    --  |
1438    --  |
1439    --  |
1440    procedure Set_Type (Fld      : in Field;
1441                        Fld_Type : in Integer_Field)
1442    is
1443       function Set_Fld_Type (F    : Field := Fld;
1444                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1445                              Arg1 : C_Int;
1446                              Arg2 : C_Long_Int;
1447                              Arg3 : C_Long_Int) return C_Int;
1448       pragma Import (C, Set_Fld_Type, "set_field_type");
1449       function Field_Userptr (Fld : Field)
1450                               return Field_User_Wrapper_Access;
1451       pragma Import (C, Field_Userptr, "field_userptr");
1452
1453       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1454       Res : Eti_Error;
1455    begin
1456       Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Precision),
1457                            Arg2 => C_Long_Int (Fld_Type.Lower_Limit),
1458                            Arg3 => C_Long_Int (Fld_Type.Upper_Limit));
1459       if Res /= E_Ok then
1460          Eti_Exception (Res);
1461       else
1462          A.T := new Integer_Field'(Fld_Type);
1463       end if;
1464    end Set_Type;
1465    --  |
1466    --  |
1467    --  |
1468    function Native_Type (Ftype : Numeric_Field)
1469                          return C_Field_Type
1470    is
1471       C_Numeric_Field_Type : C_Field_Type;
1472       pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
1473    begin
1474       return C_Numeric_Field_Type;
1475    end Native_Type;
1476    pragma Inline (Native_Type);
1477    --  |
1478    --  |
1479    --  |
1480    procedure Set_Type (Fld      : in Field;
1481                        Fld_Type : in Numeric_Field)
1482    is
1483       type Double is new Interfaces.C.double;
1484
1485    function Set_Fld_Type (F    : Field := Fld;
1486                           Cft  : C_Field_Type := Native_Type (Fld_Type);
1487                           Arg1 : Double;
1488                           Arg2 : Double;
1489                           Arg3 : Double) return C_Int;
1490       pragma Import (C, Set_Fld_Type, "set_field_type");
1491       function Field_Userptr (Fld : Field)
1492                               return Field_User_Wrapper_Access;
1493       pragma Import (C, Field_Userptr, "field_userptr");
1494
1495       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1496       Res : Eti_Error;
1497    begin
1498       Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
1499                            Arg2 => Double (Fld_Type.Lower_Limit),
1500                            Arg3 => Double (Fld_Type.Upper_Limit));
1501       if Res /= E_Ok then
1502          Eti_Exception (Res);
1503       else
1504          A.T := new Numeric_Field'(Fld_Type);
1505       end if;
1506    end Set_Type;
1507    --  |
1508    --  |
1509    --  |
1510    function Native_Type (Ftype : Regular_Expression_Field)
1511                          return C_Field_Type
1512    is
1513       C_Regexp_Field_Type : C_Field_Type;
1514       pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
1515    begin
1516       return C_Regexp_Field_Type;
1517    end Native_Type;
1518    pragma Inline (Native_Type);
1519    --  |
1520    --  |
1521    --  |
1522    procedure Set_Type (Fld      : in Field;
1523                        Fld_Type : in Regular_Expression_Field)
1524    is
1525       type Char_Ptr is access all Interfaces.C.Char;
1526       function Set_Fld_Type (F    : Field := Fld;
1527                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1528                              Arg1 : Char_Ptr) return C_Int;
1529       pragma Import (C, Set_Fld_Type, "set_field_type");
1530       function Field_Userptr (Fld : Field)
1531                               return Field_User_Wrapper_Access;
1532       pragma Import (C, Field_Userptr, "field_userptr");
1533
1534       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1535       Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
1536       Len : size_t;
1537       Res : Eti_Error;
1538    begin
1539       To_C (Fld_Type.Regular_Expression.all, Txt, Len);
1540       Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
1541       if Res /= E_Ok then
1542          Eti_Exception (Res);
1543       else
1544          A.T := new Regular_Expression_Field'(Fld_Type);
1545       end if;
1546    end Set_Type;
1547    --  |
1548    --  |
1549    --  |
1550    function Native_Type (Ftype : Enumeration_Field)
1551                          return C_Field_Type
1552    is
1553       C_Enum_Type : C_Field_Type;
1554       pragma Import (C, C_Enum_Type, "TYPE_ENUM");
1555    begin
1556       return C_Enum_Type;
1557    end Native_Type;
1558    pragma Inline (Native_Type);
1559    --  |
1560    --  |
1561    --  |
1562    function Create (Info               : Enumeration_Info;
1563                     Auto_Release_Names : Boolean := False)
1564      return Enumeration_Field
1565    is
1566       procedure Release_String is
1567         new Ada.Unchecked_Deallocation (String,
1568                                         String_Access);
1569       E : Enumeration_Field;
1570       L : constant size_t := 1 + size_t (Info.C);
1571       S : String_Access;
1572    begin
1573       E.Case_Sensitive       := Info.Case_Sensitive;
1574       E.Match_Must_Be_Unique := Info.Match_Must_Be_Unique;
1575       E.Arr := new chars_ptr_array (size_t (1) .. L);
1576       for I in 1 .. Positive (L - 1) loop
1577          if Info.Names (I) = null then
1578             raise Form_Exception;
1579          end if;
1580          E.Arr (size_t (I)) := New_String (Info.Names (I).all);
1581          if Auto_Release_Names then
1582             S := Info.Names (I);
1583             Release_String (S);
1584          end if;
1585       end loop;
1586       E.Arr (L) := Null_Ptr;
1587       return E;
1588    end Create;
1589
1590    procedure Release (Enum : in out Enumeration_Field)
1591    is
1592       I : size_t := 0;
1593       P : chars_ptr;
1594    begin
1595       loop
1596          P := Enum.Arr (I);
1597          exit when P = Null_Ptr;
1598          Free (P);
1599          Enum.Arr (I) := Null_Ptr;
1600          I := I + 1;
1601       end loop;
1602       Enum.Arr := null;
1603    end Release;
1604
1605    procedure Set_Type (Fld      : in Field;
1606                        Fld_Type : in Enumeration_Field)
1607    is
1608       function Set_Fld_Type (F    : Field := Fld;
1609                              Cft  : C_Field_Type := Native_Type (Fld_Type);
1610                              Arg1 : chars_ptr_array;
1611                              Arg2 : C_Int;  -- case
1612                              Arg3 : C_Int) return C_Int;
1613       pragma Import (C, Set_Fld_Type, "set_field_type");
1614       function Field_Userptr (Fld : Field)
1615                               return Field_User_Wrapper_Access;
1616       pragma Import (C, Field_Userptr, "field_userptr");
1617
1618       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1619       Res : Eti_Error;
1620    begin
1621       if Fld_Type.Arr = null then
1622          raise Form_Exception;
1623       end if;
1624       Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
1625                            Arg2 => C_Int (Boolean'Pos
1626                                           (Fld_Type.Case_Sensitive)),
1627                            Arg3 =>
1628                              C_Int (Boolean'Pos
1629                                     (Fld_Type.Match_Must_Be_Unique)));
1630       if Res /= E_Ok then
1631          Eti_Exception (Res);
1632       else
1633          A.T := new Enumeration_Field'(Fld_Type);
1634       end if;
1635    end Set_Type;
1636
1637
1638    function Native_Type (Ftype : Internet_V4_Address_Field)
1639                          return C_Field_Type
1640    is
1641       C_IPV4_Field_Type : C_Field_Type;
1642       pragma Import (C, C_IPV4_Field_Type, "TYPE_IPV4");
1643    begin
1644       return C_IPV4_Field_Type;
1645    end Native_Type;
1646    pragma Inline (Native_Type);
1647    --  |
1648    --  |
1649    --  |
1650    procedure Set_Type (Fld      : in Field;
1651                        Fld_Type : in Internet_V4_Address_Field)
1652    is
1653       function Set_Fld_Type (F    : Field := Fld;
1654                              Cft  : C_Field_Type := Native_Type (Fld_Type))
1655                              return C_Int;
1656       pragma Import (C, Set_Fld_Type, "set_field_type");
1657       function Field_Userptr (Fld : Field)
1658                               return Field_User_Wrapper_Access;
1659       pragma Import (C, Field_Userptr, "field_userptr");
1660
1661       A   : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1662       Res : Eti_Error;
1663    begin
1664       Res := Set_Fld_Type;
1665       if Res /= E_Ok then
1666          Eti_Exception (Res);
1667       else
1668          A.T := new Internet_V4_Address_Field'(Fld_Type);
1669       end if;
1670    end Set_Type;
1671
1672    --  |
1673    --  |=====================================================================
1674    --  | man page form_field_validation.3x
1675    --  |=====================================================================
1676    --  |
1677    --  |
1678    --  |
1679    function Get_Type (Fld : in Field) return Field_Type_Access
1680    is
1681       A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
1682    begin
1683       if A = null then
1684          return null;
1685       else
1686          return A.T;
1687       end if;
1688    end Get_Type;
1689
1690 begin
1691    Default_Field_Options := Get_Options (Null_Field);
1692    Default_Form_Options  := Get_Options (Null_Form);
1693 end Terminal_Interface.Curses.Forms;