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 ------------------------------------------------------------------------------
  10 -- Copyright (c) 1998 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: Juergen Pfeifer <Juergen.Pfeifer@T-Online.de> 1996
  37 --  Version Control:
  38 --  $Revision: 1.13 $
  39 --  Binding Version 00.93
  40 ------------------------------------------------------------------------------
  41 with Ada.Unchecked_Deallocation;
  42 with Unchecked_Conversion;
  43
  44 with Interfaces.C; use Interfaces.C;
  45 with Interfaces.C.Strings; use Interfaces.C.Strings;
  46
  47 with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
  48
  49 package body Terminal_Interface.Curses.Forms is
  50
  51 ------------------------------------------------------------------------------
  52    --  |
  53    --  |
  54    --  |
  55    --  subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
  56
  57    function FOS_2_CInt is new
  58      Unchecked_Conversion (Field_Option_Set,
  59                            C_Int);
  60
  61    function CInt_2_FOS is new
  62      Unchecked_Conversion (C_Int,
  63                            Field_Option_Set);
  64
  65    function FrmOS_2_CInt is new
  66      Unchecked_Conversion (Form_Option_Set,
  67                            C_Int);
  68
  69    function CInt_2_FrmOS is new
  70      Unchecked_Conversion (C_Int,
  71                            Form_Option_Set);
  72
  73    procedure Request_Name (Key  : in Form_Request_Code;
  74                                 Name : out String)
  75    is
  76       function Form_Request_Name (Key : C_Int) return chars_ptr;
  77       pragma Import (C, Form_Request_Name, "form_request_name");
  78    begin
  79       Fill_String (Form_Request_Name (C_Int (Key)), Name);
  80    end Request_Name;
  81
  82    function Request_Name (Key : Form_Request_Code) return String
  83    is
  84       function Form_Request_Name (Key : C_Int) return chars_ptr;
  85       pragma Import (C, Form_Request_Name, "form_request_name");
  86    begin
  87       return Fill_String (Form_Request_Name (C_Int (Key)));
  88    end Request_Name;
  89 ------------------------------------------------------------------------------
  90    --  |
  91    --  |
  92    --  |
  93    --  |
  94    --  |=====================================================================
  95    --  | man page form_field_new.3x
  96    --  |=====================================================================
  97    --  |
  98    --  |
  99    --  |
 100    function Create (Height       : Line_Count;
 101                     Width        : Column_Count;
 102                     Top          : Line_Position;
 103                     Left         : Column_Position;
 104                     Off_Screen   : Natural := 0;
 105                     More_Buffers : Buffer_Number := Buffer_Number'First)
 106                     return Field
 107    is
 108       function Newfield (H, W, T, L, O, M : C_Int) return Field;
 109       pragma Import (C, Newfield, "new_field");
 110       Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
 111                                         C_Int (Top), C_Int (Left),
 112                                         C_Int (Off_Screen),
 113                                         C_Int (More_Buffers));
 114    begin
 115       if Fld = Null_Field then
 116          raise Form_Exception;
 117       end if;
 118       return Fld;
 119    end Create;
 120 --  |
 121 --  |
 122 --  |
 123    procedure Delete (Fld : in out Field)
 124    is
 125       function Free_Field (Fld : Field) return C_Int;
 126       pragma Import (C, Free_Field, "free_field");
 127
 128       Res : Eti_Error;
 129    begin
 130       Res := Free_Field (Fld);
 131       if Res /= E_Ok then
 132          Eti_Exception (Res);
 133       end if;
 134       Fld := Null_Field;
 135    end Delete;
 136    --  |
 137    --  |
 138    --  |
 139    function Duplicate (Fld  : Field;
 140                        Top  : Line_Position;
 141                        Left : Column_Position) return Field
 142    is
 143       function Dup_Field (Fld  : Field;
 144                           Top  : C_Int;
 145                           Left : C_Int) return Field;
 146       pragma Import (C, Dup_Field, "dup_field");
 147
 148       F : constant Field := Dup_Field (Fld,
 149                                        C_Int (Top),
 150                                        C_Int (Left));
 151    begin
 152       if F = Null_Field then
 153          raise Form_Exception;
 154       end if;
 155       return F;
 156    end Duplicate;
 157    --  |
 158    --  |
 159    --  |
 160    function Link (Fld  : Field;
 161                   Top  : Line_Position;
 162                   Left : Column_Position) return Field
 163    is
 164       function Lnk_Field (Fld  : Field;
 165                           Top  : C_Int;
 166                           Left : C_Int) return Field;
 167       pragma Import (C, Lnk_Field, "link_field");
 168
 169       F : constant Field := Lnk_Field (Fld,
 170                                        C_Int (Top),
 171                                        C_Int (Left));
 172    begin
 173       if F = Null_Field then
 174          raise Form_Exception;
 175       end if;
 176       return F;
 177    end Link;
 178    --  |
 179    --  |=====================================================================
 180    --  | man page form_field_just.3x
 181    --  |=====================================================================
 182    --  |
 183    --  |
 184    --  |
 185    procedure Set_Justification (Fld  : in Field;
 186                                 Just : in Field_Justification := None)
 187    is
 188       function Set_Field_Just (Fld  : Field;
 189                                Just : C_Int) return C_Int;
 190       pragma Import (C, Set_Field_Just, "set_field_just");
 191
 192       Res : constant Eti_Error :=
 193         Set_Field_Just (Fld,
 194                         C_Int (Field_Justification'Pos (Just)));
 195    begin
 196       if Res /= E_Ok then
 197          Eti_Exception (Res);
 198       end if;
 199    end Set_Justification;
 200    --  |
 201    --  |
 202    --  |
 203    function Get_Justification (Fld : Field) return Field_Justification
 204    is
 205       function Field_Just (Fld : Field) return C_Int;
 206       pragma Import (C, Field_Just, "field_just");
 207    begin
 208       return Field_Justification'Val (Field_Just (Fld));
 209    end Get_Justification;
 210    --  |
 211    --  |=====================================================================
 212    --  | man page form_field_buffer.3x
 213    --  |=====================================================================
 214    --  |
 215    --  |
 216    --  |
 217    procedure Set_Buffer
 218      (Fld    : in Field;
 219       Buffer : in Buffer_Number := Buffer_Number'First;
 220       Str    : in String)
 221    is
 222       type Char_Ptr is access all Interfaces.C.Char;
 223       function Set_Fld_Buffer (Fld    : Field;
 224                                  Bufnum : C_Int;
 225                                  S      : Char_Ptr)
 226         return C_Int;
 227       pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
 228
 229       Txt : char_array (0 .. Str'Length);
 230       Len : size_t;
 231       Res : Eti_Error;
 232    begin
 233       To_C (Str, Txt, Len);
 234       Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
 235       if Res /= E_Ok then
 236          Eti_Exception (Res);
 237       end if;
 238    end Set_Buffer;
 239    --  |
 240    --  |
 241    --  |
 242    procedure Get_Buffer
 243      (Fld    : in Field;
 244       Buffer : in Buffer_Number := Buffer_Number'First;
 245       Str    : out String)
 246    is
 247       function Field_Buffer (Fld : Field;
 248                              B   : C_Int) return chars_ptr;
 249       pragma Import (C, Field_Buffer, "field_buffer");
 250    begin
 251       Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
 252    end Get_Buffer;
 253
 254    function Get_Buffer
 255      (Fld    : in Field;
 256       Buffer : in Buffer_Number := Buffer_Number'First) return String
 257    is
 258       function Field_Buffer (Fld : Field;
 259                              B   : C_Int) return chars_ptr;
 260       pragma Import (C, Field_Buffer, "field_buffer");
 261    begin
 262       return Fill_String (Field_Buffer (Fld, C_Int (Buffer)));
 263    end Get_Buffer;
 264    --  |
 265    --  |
 266    --  |
 267    procedure Set_Status (Fld    : in Field;
 268                          Status : in Boolean := True)
 269    is
 270       function Set_Fld_Status (Fld : Field;
 271                                St  : C_Int) return C_Int;
 272       pragma Import (C, Set_Fld_Status, "set_field_status");
 273
 274       Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
 275    begin
 276       if Res /= E_Ok then
 277          raise Form_Exception;
 278       end if;
 279    end Set_Status;
 280    --  |
 281    --  |
 282    --  |
 283    function Changed (Fld : Field) return Boolean
 284    is
 285       function Field_Status (Fld : Field) return C_Int;
 286       pragma Import (C, Field_Status, "field_status");
 287
 288       Res : constant C_Int := Field_Status (Fld);
 289    begin
 290       if Res = Curses_False then
 291          return False;
 292       else
 293          return True;
 294       end if;
 295    end Changed;
 296    --  |
 297    --  |
 298    --  |
 299    procedure Set_Maximum_Size (Fld : in Field;
 300                                Max : in Natural := 0)
 301    is
 302       function Set_Field_Max (Fld : Field;
 303                               M   : C_Int) return C_Int;
 304       pragma Import (C, Set_Field_Max, "set_max_field");
 305
 306       Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
 307    begin
 308       if Res /= E_Ok then
 309          Eti_Exception (Res);
 310       end if;
 311    end Set_Maximum_Size;
 312    --  |
 313    --  |=====================================================================
 314    --  | man page form_field_opts.3x
 315    --  |=====================================================================
 316    --  |
 317    --  |
 318    --  |
 319    procedure Normalize_Field_Options (Options : in out C_Int);
 320    pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
 321
 322    procedure Set_Options (Fld     : in Field;
 323                           Options : in Field_Option_Set)
 324    is
 325       function Set_Field_Opts (Fld : Field;
 326                                Opt : C_Int) return C_Int;
 327       pragma Import (C, Set_Field_Opts, "set_field_opts");
 328
 329       Opt : C_Int := FOS_2_CInt (Options);
 330       Res : Eti_Error;
 331    begin
 332       Normalize_Field_Options (Opt);
 333       Res := Set_Field_Opts (Fld, Opt);
 334       if Res /= E_Ok then
 335          Eti_Exception (Res);
 336       end if;
 337    end Set_Options;
 338    --  |
 339    --  |
 340    --  |
 341    procedure Switch_Options (Fld     : in Field;
 342                              Options : in Field_Option_Set;
 343                              On      : Boolean := True)
 344    is
 345       function Field_Opts_On (Fld : Field;
 346                               Opt : C_Int) return C_Int;
 347       pragma Import (C, Field_Opts_On, "field_opts_on");
 348       function Field_Opts_Off (Fld : Field;
 349                                Opt : C_Int) return C_Int;
 350       pragma Import (C, Field_Opts_Off, "field_opts_off");
 351
 352       Err : Eti_Error;
 353       Opt : C_Int := FOS_2_CInt (Options);
 354    begin
 355       Normalize_Field_Options (Opt);
 356       if On then
 357          Err := Field_Opts_On (Fld, Opt);
 358       else
 359          Err := Field_Opts_Off (Fld, Opt);
 360       end if;
 361       if Err /= E_Ok then
 362          Eti_Exception (Err);
 363       end if;
 364    end Switch_Options;
 365    --  |
 366    --  |
 367    --  |
 368    procedure Get_Options (Fld     : in  Field;
 369                           Options : out Field_Option_Set)
 370    is
 371       function Field_Opts (Fld : Field) return C_Int;
 372       pragma Import (C, Field_Opts, "field_opts");
 373
 374       Res : C_Int := Field_Opts (Fld);
 375    begin
 376       Normalize_Field_Options (Res);
 377       Options := CInt_2_FOS (Res);
 378    end Get_Options;
 379    --  |
 380    --  |
 381    --  |
 382    function Get_Options (Fld : Field := Null_Field)
 383                          return Field_Option_Set
 384    is
 385       Fos : Field_Option_Set;
 386    begin
 387       Get_Options (Fld, Fos);
 388       return Fos;
 389    end Get_Options;
 390    --  |
 391    --  |=====================================================================
 392    --  | man page form_field_attributes.3x
 393    --  |=====================================================================
 394    --  |
 395    --  |
 396    --  |
 397    procedure Set_Foreground
 398      (Fld   : in Field;
 399       Fore  : in Character_Attribute_Set := Normal_Video;
 400       Color : in Color_Pair := Color_Pair'First)
 401    is
 402       function Set_Field_Fore (Fld  : Field;
 403                                Attr : C_Int) return C_Int;
 404       pragma Import (C, Set_Field_Fore, "set_field_fore");
 405
 406       Ch : constant Attributed_Character := (Ch    => Character'First,
 407                                              Color => Color,
 408                                              Attr  => Fore);
 409       Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
 410    begin
 411       if  Res /= E_Ok then
 412          Eti_Exception (Res);
 413       end if;
 414    end Set_Foreground;
 415    --  |
 416    --  |
 417    --  |
 418    procedure Foreground (Fld  : in  Field;
 419                          Fore : out Character_Attribute_Set)
 420    is
 421       function Field_Fore (Fld : Field) return C_Int;
 422       pragma Import (C, Field_Fore, "field_fore");
 423    begin
 424       Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
 425    end Foreground;
 426
 427    procedure Foreground (Fld   : in  Field;
 428                          Fore  : out Character_Attribute_Set;
 429                          Color : out Color_Pair)
 430    is
 431       function Field_Fore (Fld : Field) return C_Int;
 432       pragma Import (C, Field_Fore, "field_fore");
 433    begin
 434       Fore  := CInt_To_Chtype (Field_Fore (Fld)).Attr;
 435       Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
 436    end Foreground;
 437    --  |
 438    --  |
 439    --  |
 440    procedure Set_Background
 441      (Fld   : in Field;
 442       Back  : in Character_Attribute_Set := Normal_Video;
 443       Color : in Color_Pair := Color_Pair'First)
 444    is
 445       function Set_Field_Back (Fld  : Field;
 446                                Attr : C_Int) return C_Int;
 447       pragma Import (C, Set_Field_Back, "set_field_back");
 448
 449       Ch : constant Attributed_Character := (Ch    => Character'First,
 450                                              Color => Color,
 451                                              Attr  => Back);
 452       Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
 453    begin
 454       if  Res /= E_Ok then
 455          Eti_Exception (Res);
 456       end if;
 457    end Set_Background;
 458    --  |
 459    --  |
 460    --  |
 461    procedure Background (Fld  : in  Field;
 462                          Back : out Character_Attribute_Set)
 463    is
 464       function Field_Back (Fld : Field) return C_Int;
 465       pragma Import (C, Field_Back, "field_back");
 466    begin
 467       Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
 468    end Background;
 469
 470    procedure Background (Fld   : in  Field;
 471                          Back  : out Character_Attribute_Set;
 472                          Color : out Color_Pair)
 473    is
 474       function Field_Back (Fld : Field) return C_Int;
 475       pragma Import (C, Field_Back, "field_back");
 476    begin
 477       Back  := CInt_To_Chtype (Field_Back (Fld)).Attr;
 478       Color := CInt_To_Chtype (Field_Back (Fld)).Color;
 479    end Background;
 480    --  |
 481    --  |
 482    --  |
 483    procedure Set_Pad_Character (Fld : in Field;
 484                                 Pad : in Character := Space)
 485    is
 486       function Set_Field_Pad (Fld : Field;
 487                               Ch  : C_Int) return C_Int;
 488       pragma Import (C, Set_Field_Pad, "set_field_pad");
 489
 490       Res : constant Eti_Error := Set_Field_Pad (Fld,
 491                                                  C_Int (Character'Pos (Pad)));
 492    begin
 493       if Res /= E_Ok then
 494          Eti_Exception (Res);
 495       end if;
 496    end Set_Pad_Character;
 497    --  |
 498    --  |
 499    --  |
 500    procedure Pad_Character (Fld : in  Field;
 501                             Pad : out Character)
 502    is
 503       function Field_Pad (Fld : Field) return C_Int;
 504       pragma Import (C, Field_Pad, "field_pad");
 505    begin
 506       Pad := Character'Val (Field_Pad (Fld));
 507    end Pad_Character;
 508    --  |
 509    --  |=====================================================================
 510    --  | man page form_field_info.3x
 511    --  |=====================================================================
 512    --  |
 513    --  |
 514    --  |
 515    procedure Info (Fld                : in  Field;
 516                    Lines              : out Line_Count;
 517                    Columns            : out Column_Count;
 518                    First_Row          : out Line_Position;
 519                    First_Column       : out Column_Position;
 520                    Off_Screen         : out Natural;
 521                    Additional_Buffers : out Buffer_Number)
 522    is
 523       type C_Int_Access is access all C_Int;
 524       function Fld_Info (Fld : Field;
 525                          L, C, Fr, Fc, Os, Ab : C_Int_Access)
 526                          return C_Int;
 527       pragma Import (C, Fld_Info, "field_info");
 528
 529       L, C, Fr, Fc, Os, Ab : aliased C_Int;
 530       Res : constant Eti_Error := Fld_Info (Fld,
 531                                             L'Access, C'Access,
 532                                             Fr'Access, Fc'Access,
 533                                             Os'Access, Ab'Access);
 534    begin
 535       if Res /= E_Ok then
 536          Eti_Exception (Res);
 537       else
 538          Lines              := Line_Count (L);
 539          Columns            := Column_Count (C);
 540          First_Row          := Line_Position (Fr);
 541          First_Column       := Column_Position (Fc);
 542          Off_Screen         := Natural (Os);
 543          Additional_Buffers := Buffer_Number (Ab);
 544       end if;
 545    end Info;
 546 --  |
 547 --  |
 548 --  |
 549    procedure Dynamic_Info (Fld     : in Field;
 550                            Lines   : out Line_Count;
 551                            Columns : out Column_Count;
 552                            Max     : out Natural)
 553    is
 554       type C_Int_Access is access all C_Int;
 555       function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
 556       pragma Import (C, Dyn_Info, "dynamic_field_info");
 557
 558       L, C, M : aliased C_Int;
 559       Res : constant Eti_Error := Dyn_Info (Fld,
 560                                             L'Access, C'Access,
 561                                             M'Access);
 562    begin
 563       if Res /= E_Ok then
 564          Eti_Exception (Res);
 565       else
 566          Lines   := Line_Count (L);
 567          Columns := Column_Count (C);
 568          Max     := Natural (M);
 569       end if;
 570    end Dynamic_Info;
 571    --  |
 572    --  |=====================================================================
 573    --  | man page form_win.3x
 574    --  |=====================================================================
 575    --  |
 576    --  |
 577    --  |
 578    procedure Set_Window (Frm : in Form;
 579                          Win : in Window)
 580    is
 581       function Set_Form_Win (Frm : Form;
 582                              Win : Window) return C_Int;
 583       pragma Import (C, Set_Form_Win, "set_form_win");
 584
 585       Res : constant Eti_Error := Set_Form_Win (Frm, Win);
 586    begin
 587       if  Res /= E_Ok then
 588          Eti_Exception (Res);
 589       end if;
 590    end Set_Window;
 591    --  |
 592    --  |
 593    --  |
 594    function Get_Window (Frm : Form) return Window
 595    is
 596       function Form_Win (Frm : Form) return Window;
 597       pragma Import (C, Form_Win, "form_win");
 598
 599       W : constant Window := Form_Win (Frm);
 600    begin
 601       return W;
 602    end Get_Window;
 603    --  |
 604    --  |
 605    --  |
 606    procedure Set_Sub_Window (Frm : in Form;
 607                              Win : in Window)
 608    is
 609       function Set_Form_Sub (Frm : Form;
 610                              Win : Window) return C_Int;
 611       pragma Import (C, Set_Form_Sub, "set_form_sub");
 612
 613       Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
 614    begin
 615       if  Res /= E_Ok then
 616          Eti_Exception (Res);
 617       end if;
 618    end Set_Sub_Window;
 619    --  |
 620    --  |
 621    --  |
 622    function Get_Sub_Window (Frm : Form) return Window
 623    is
 624       function Form_Sub (Frm : Form) return Window;
 625       pragma Import (C, Form_Sub, "form_sub");
 626
 627       W : constant Window := Form_Sub (Frm);
 628    begin
 629       return W;
 630    end Get_Sub_Window;
 631    --  |
 632    --  |
 633    --  |
 634    procedure Scale (Frm     : in Form;
 635                     Lines   : out Line_Count;
 636                     Columns : out Column_Count)
 637    is
 638       type C_Int_Access is access all C_Int;
 639       function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
 640       pragma Import (C, M_Scale, "scale_form");
 641
 642       X, Y : aliased C_Int;
 643       Res  : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
 644    begin
 645       if Res /= E_Ok then
 646          Eti_Exception (Res);
 647       end if;
 648       Lines := Line_Count (Y);
 649       Columns := Column_Count (X);
 650    end Scale;
 651    --  |
 652    --  |=====================================================================
 653    --  | man page menu_hook.3x
 654    --  |=====================================================================
 655    --  |
 656    --  |
 657    --  |
 658    procedure Set_Field_Init_Hook (Frm  : in Form;
 659                                   Proc : in Form_Hook_Function)
 660    is
 661       function Set_Field_Init (Frm  : Form;
 662                                Proc : Form_Hook_Function) return C_Int;
 663       pragma Import (C, Set_Field_Init, "set_field_init");
 664
 665       Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
 666    begin
 667       if  Res /= E_Ok then
 668          Eti_Exception (Res);
 669       end if;
 670    end Set_Field_Init_Hook;
 671    --  |
 672    --  |
 673    --  |
 674    procedure Set_Field_Term_Hook (Frm  : in Form;
 675                                   Proc : in Form_Hook_Function)
 676    is
 677       function Set_Field_Term (Frm  : Form;
 678                                Proc : Form_Hook_Function) return C_Int;
 679       pragma Import (C, Set_Field_Term, "set_field_term");
 680
 681       Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
 682    begin
 683       if Res /= E_Ok then
 684          Eti_Exception (Res);
 685       end if;
 686    end Set_Field_Term_Hook;
 687    --  |
 688    --  |
 689    --  |
 690    procedure Set_Form_Init_Hook (Frm  : in Form;
 691                                  Proc : in Form_Hook_Function)
 692    is
 693       function Set_Form_Init (Frm  : Form;
 694                               Proc : Form_Hook_Function) return C_Int;
 695       pragma Import (C, Set_Form_Init, "set_form_init");
 696
 697       Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
 698    begin
 699       if  Res /= E_Ok then
 700          Eti_Exception (Res);
 701       end if;
 702    end Set_Form_Init_Hook;
 703    --  |
 704    --  |
 705    --  |
 706    procedure Set_Form_Term_Hook (Frm  : in Form;
 707                                  Proc : in Form_Hook_Function)
 708    is
 709       function Set_Form_Term (Frm  : Form;
 710                               Proc : Form_Hook_Function) return C_Int;
 711       pragma Import (C, Set_Form_Term, "set_form_term");
 712
 713       Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
 714    begin
 715       if Res /= E_Ok then
 716          Eti_Exception (Res);
 717       end if;
 718    end Set_Form_Term_Hook;
 719    --  |
 720    --  |=====================================================================
 721    --  | man page form_fields.3x
 722    --  |=====================================================================
 723    --  |
 724    --  |
 725    --  |
 726    procedure Redefine (Frm  : in Form;
 727                        Flds : in Field_Array_Access)
 728    is
 729       function Set_Frm_Fields (Frm   : Form;
 730                                Items : System.Address) return C_Int;
 731       pragma Import (C, Set_Frm_Fields, "set_form_fields");
 732
 733       Res : Eti_Error;
 734    begin
 735       pragma Assert (Flds (Flds'Last) = Null_Field);
 736       if Flds (Flds'Last) /= Null_Field then
 737          raise Form_Exception;
 738       else
 739          Res := Set_Frm_Fields (Frm, Flds (Flds'First)'Address);
 740          if  Res /= E_Ok then
 741             Eti_Exception (Res);
 742          end if;
 743       end if;
 744    end Redefine;
 745    --  |
 746    --  |
 747    --  |
 748    function Fields (Frm   : Form;
 749                     Index : Positive) return Field
 750    is
 751       function F_Fields (Frm : Form;
 752                          Idx : C_Int) return Field;
 753       pragma Import (C, F_Fields, "_nc_get_field");
 754    begin
 755       if Frm = Null_Form or else Index not in 1 .. Field_Count (Frm) then
 756          raise Form_Exception;
 757       else
 758          return F_Fields (Frm, C_Int (Index) - 1);
 759       end if;
 760    end Fields;
 761    --  |
 762    --  |
 763    --  |
 764    function Field_Count (Frm : Form) return Natural
 765    is
 766       function Count (Frm : Form) return C_Int;
 767       pragma Import (C, Count, "field_count");
 768    begin
 769       return Natural (Count (Frm));
 770    end Field_Count;
 771    --  |
 772    --  |
 773    --  |
 774    procedure Move (Fld    : in Field;
 775                    Line   : in Line_Position;
 776                    Column : in Column_Position)
 777    is
 778       function Move (Fld : Field; L, C : C_Int) return C_Int;
 779       pragma Import (C, Move, "move_field");
 780
 781       Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
 782    begin
 783       if Res /= E_Ok then
 784          Eti_Exception (Res);
 785       end if;
 786    end Move;
 787    --  |
 788    --  |=====================================================================
 789    --  | man page form_new.3x
 790    --  |=====================================================================
 791    --  |
 792    --  |
 793    --  |
 794    function Create (Fields : Field_Array_Access) return Form
 795    is
 796       function NewForm (Fields : System.Address) return Form;
 797       pragma Import (C, NewForm, "new_form");
 798
 799       M   : Form;
 800    begin
 801       pragma Assert (Fields (Fields'Last) = Null_Field);
 802       if Fields (Fields'Last) /= Null_Field then
 803          raise Form_Exception;
 804       else
 805          M := NewForm (Fields (Fields'First)'Address);
 806          if M = Null_Form then
 807             raise Form_Exception;
 808          end if;
 809          return M;
 810       end if;
 811    end Create;
 812    --  |
 813    --  |
 814    --  |
 815    procedure Delete (Frm : in out Form)
 816    is
 817       function Free (Frm : Form) return C_Int;
 818       pragma Import (C, Free, "free_form");
 819
 820       Res : constant Eti_Error := Free (Frm);
 821    begin
 822       if Res /= E_Ok then
 823          Eti_Exception (Res);
 824       end if;
 825       Frm := Null_Form;
 826    end Delete;
 827    --  |
 828    --  |=====================================================================
 829    --  | man page form_opts.3x
 830    --  |=====================================================================
 831    --  |
 832    --  |
 833    --  |
 834    procedure Normalize_Form_Options (Options : in out C_Int);
 835    pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
 836
 837    procedure Set_Options (Frm     : in Form;
 838                           Options : in Form_Option_Set)
 839    is
 840       function Set_Form_Opts (Frm : Form;
 841                               Opt : C_Int) return C_Int;
 842       pragma Import (C, Set_Form_Opts, "set_form_opts");
 843
 844       Opt : C_Int := FrmOS_2_CInt (Options);
 845       Res : Eti_Error;
 846    begin
 847       Normalize_Form_Options (Opt);
 848       Res := Set_Form_Opts (Frm, Opt);
 849       if  Res /= E_Ok then
 850          Eti_Exception (Res);
 851       end if;
 852    end Set_Options;
 853    --  |
 854    --  |
 855    --  |
 856    procedure Switch_Options (Frm     : in Form;
 857                              Options : in Form_Option_Set;
 858                              On      : Boolean := True)
 859    is
 860       function Form_Opts_On (Frm : Form;
 861                              Opt : C_Int) return C_Int;
 862       pragma Import (C, Form_Opts_On, "form_opts_on");
 863       function Form_Opts_Off (Frm : Form;
 864                               Opt : C_Int) return C_Int;
 865       pragma Import (C, Form_Opts_Off, "form_opts_off");
 866
 867       Err : Eti_Error;
 868       Opt : C_Int := FrmOS_2_CInt (Options);
 869    begin
 870       Normalize_Form_Options (Opt);
 871       if On then
 872          Err := Form_Opts_On (Frm, Opt);
 873       else
 874          Err := Form_Opts_Off (Frm, Opt);
 875       end if;
 876       if Err /= E_Ok then
 877          Eti_Exception (Err);
 878       end if;
 879    end Switch_Options;
 880    --  |
 881    --  |
 882    --  |
 883    procedure Get_Options (Frm     : in  Form;
 884                           Options : out Form_Option_Set)
 885    is
 886       function Form_Opts (Frm : Form) return C_Int;
 887       pragma Import (C, Form_Opts, "form_opts");
 888
 889       Res : C_Int := Form_Opts (Frm);
 890    begin
 891       Normalize_Form_Options (Res);
 892       Options := CInt_2_FrmOS (Res);
 893    end Get_Options;
 894    --  |
 895    --  |
 896    --  |
 897    function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
 898    is
 899       Fos : Form_Option_Set;
 900    begin
 901       Get_Options (Frm, Fos);
 902       return Fos;
 903    end Get_Options;
 904    --  |
 905    --  |=====================================================================
 906    --  | man page form_post.3x
 907    --  |=====================================================================
 908    --  |
 909    --  |
 910    --  |
 911    procedure Post (Frm  : in Form;
 912                    Post : in Boolean := True)
 913    is
 914       function M_Post (Frm : Form) return C_Int;
 915       pragma Import (C, M_Post, "post_form");
 916       function M_Unpost (Frm : Form) return C_Int;
 917       pragma Import (C, M_Unpost, "unpost_form");
 918
 919       Res : Eti_Error;
 920    begin
 921       if Post then
 922          Res := M_Post (Frm);
 923       else
 924          Res := M_Unpost (Frm);
 925       end if;
 926       if Res /= E_Ok then
 927          Eti_Exception (Res);
 928       end if;
 929    end Post;
 930    --  |
 931    --  |=====================================================================
 932    --  | man page form_cursor.3x
 933    --  |=====================================================================
 934    --  |
 935    --  |
 936    --  |
 937    procedure Position_Cursor (Frm : Form)
 938    is
 939       function Pos_Form_Cursor (Frm : Form) return C_Int;
 940       pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
 941
 942       Res : constant Eti_Error := Pos_Form_Cursor (Frm);
 943    begin
 944       if  Res /= E_Ok then
 945          Eti_Exception (Res);
 946       end if;
 947    end Position_Cursor;
 948    --  |
 949    --  |=====================================================================
 950    --  | man page form_data.3x
 951    --  |=====================================================================
 952    --  |
 953    --  |
 954    --  |
 955    function Data_Ahead (Frm : Form) return Boolean
 956    is
 957       function Ahead (Frm : Form) return C_Int;
 958       pragma Import (C, Ahead, "data_ahead");
 959
 960       Res : constant C_Int := Ahead (Frm);
 961    begin
 962       if Res = Curses_False then
 963          return False;
 964       else
 965          return True;
 966       end if;
 967    end Data_Ahead;
 968    --  |
 969    --  |
 970    --  |
 971    function Data_Behind (Frm : Form) return Boolean
 972    is
 973       function Behind (Frm : Form) return C_Int;
 974       pragma Import (C, Behind, "data_behind");
 975
 976       Res : constant C_Int := Behind (Frm);
 977    begin
 978       if Res = Curses_False then
 979          return False;
 980       else
 981          return True;
 982       end if;
 983    end Data_Behind;
 984    --  |
 985    --  |=====================================================================
 986    --  | man page form_driver.3x
 987    --  |=====================================================================
 988    --  |
 989    --  |
 990    --  |
 991    function Driver (Frm : Form;
 992                     Key : Key_Code) return Driver_Result
 993    is
 994       function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
 995       pragma Import (C, Frm_Driver, "form_driver");
 996
 997       R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
 998    begin
 999       if R /= E_Ok then
1000          if R = E_Unknown_Command then
1001             return Unknown_Request;
1002          elsif R = E_Invalid_Field then
1003             return Invalid_Field;
1004          elsif R = E_Request_Denied then
1005             return Request_Denied;
1006          else
1007             Eti_Exception (R);
1008             return Form_Ok;
1009          end if;
1010       else
1011          return Form_Ok;
1012       end if;
1013    end Driver;
1014    --  |
1015    --  |=====================================================================
1016    --  | man page form_page.3x
1017    --  |=====================================================================
1018    --  |
1019    --  |
1020    --  |
1021    procedure Set_Current (Frm : in Form;
1022                           Fld : in Field)
1023    is
1024       function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
1025       pragma Import (C, Set_Current_Fld, "set_current_field");
1026
1027       Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
1028    begin
1029       if Res /= E_Ok then
1030          Eti_Exception (Res);
1031       end if;
1032    end Set_Current;
1033    --  |
1034    --  |
1035    --  |
1036    function Current (Frm : in Form) return Field
1037    is
1038       function Current_Fld (Frm : Form) return Field;
1039       pragma Import (C, Current_Fld, "current_field");
1040
1041       Fld : constant Field := Current_Fld (Frm);
1042    begin
1043       if Fld = Null_Field then
1044          raise Form_Exception;
1045       end if;
1046       return Fld;
1047    end Current;
1048    --  |
1049    --  |
1050    --  |
1051    procedure Set_Page (Frm  : in Form;
1052                        Page : in Page_Number := Page_Number'First)
1053    is
1054       function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
1055       pragma Import (C, Set_Frm_Page, "set_form_page");
1056
1057       Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
1058    begin
1059       if Res /= E_Ok then
1060          Eti_Exception (Res);
1061       end if;
1062    end Set_Page;
1063    --  |
1064    --  |
1065    --  |
1066    function Page (Frm : Form) return Page_Number
1067    is
1068       function Get_Page (Frm : Form) return C_Int;
1069       pragma Import (C, Get_Page, "form_page");
1070
1071       P : constant C_Int := Get_Page (Frm);
1072    begin
1073       if P < 0 then
1074          raise Form_Exception;
1075       else
1076          return Page_Number (P);
1077       end if;
1078    end Page;
1079
1080    function Get_Index (Fld : Field) return Positive
1081    is
1082       function Get_Fieldindex (Fld : Field) return C_Int;
1083       pragma Import (C, Get_Fieldindex, "field_index");
1084
1085       Res : constant C_Int := Get_Fieldindex (Fld);
1086    begin
1087       if Res = Curses_Err then
1088          raise Form_Exception;
1089       end if;
1090       return Positive (Natural (Res) + Positive'First);
1091    end Get_Index;
1092
1093    --  |
1094    --  |=====================================================================
1095    --  | man page form_new_page.3x
1096    --  |=====================================================================
1097    --  |
1098    --  |
1099    --  |
1100    procedure Set_New_Page (Fld      : in Field;
1101                            New_Page : in Boolean := True)
1102    is
1103       function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
1104       pragma Import (C, Set_Page, "set_new_page");
1105
1106       Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
1107    begin
1108       if Res /= E_Ok then
1109          Eti_Exception (Res);
1110       end if;
1111    end Set_New_Page;
1112    --  |
1113    --  |
1114    --  |
1115    function Is_New_Page (Fld : Field) return Boolean
1116    is
1117       function Is_New (Fld : Field) return C_Int;
1118       pragma Import (C, Is_New, "new_page");
1119
1120       Res : constant C_Int := Is_New (Fld);
1121    begin
1122       if Res = Curses_False then
1123          return False;
1124       else
1125          return True;
1126       end if;
1127    end Is_New_Page;
1128
1129    procedure Free (FA          : in out Field_Array_Access;
1130                    Free_Fields : in Boolean := False)
1131    is
1132       procedure Release is new Ada.Unchecked_Deallocation
1133         (Field_Array, Field_Array_Access);
1134    begin
1135       if FA /= null and then Free_Fields then
1136          for I in FA'First .. (FA'Last - 1) loop
1137             if (FA (I) /= Null_Field) then
1138                Delete (FA (I));
1139             end if;
1140          end loop;
1141       end if;
1142       Release (FA);
1143    end Free;
1144
1145    --  |=====================================================================
1146
1147    function Default_Field_Options return Field_Option_Set
1148    is
1149    begin
1150       return Get_Options (Null_Field);
1151    end Default_Field_Options;
1152
1153    function Default_Form_Options return Form_Option_Set
1154    is
1155    begin
1156       return Get_Options (Null_Form);
1157    end Default_Form_Options;
1158
1159 end Terminal_Interface.Curses.Forms;