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