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