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