mirror of
https://github.com/Aigor44/ncursesw-morphos.git
synced 2024-12-27 07:49:06 +08:00
2b635f090e
+ add special check in Ada95/configure script for ncurses6 reentrant code. + regen Ada html documentation. + build-fix for Ada shared libraries versus the varargs workaround. + add rpm and dpkg scripts for Ada95 and test directories, for test builds. + update test/configure macros CF_CURSES_LIBS, CF_XOPEN_SOURCE and CF_X_ATHENA_LIBS. + add configure check to determine if gnat's project feature supports libraries, i.e., collections of .ali files. + make all dereferences in Ada95 samples explicit. + fix typo in comment in lib_add_wch.c (patch by Petr Pavlu). + add configure check for, ifdef's for math.h which is in a separate package on Solaris and potentially not installed (report by Petr Pavlu). > fixes for Ada95 binding (Nicolas Boulenguez): + improve type-checking in Ada95 by eliminating a few warning-suppress pragmas. + suppress unreferenced warnings. + make all dereferences in binding explicit.
397 lines
14 KiB
Ada
397 lines
14 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT ncurses Binding Samples --
|
|
-- --
|
|
-- Sample.Menu_Demo --
|
|
-- --
|
|
-- B O D Y --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
-- Copyright (c) 1998-2008,2011 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- Permission is hereby granted, free of charge, to any person obtaining a --
|
|
-- copy of this software and associated documentation files (the --
|
|
-- "Software"), to deal in the Software without restriction, including --
|
|
-- without limitation the rights to use, copy, modify, merge, publish, --
|
|
-- distribute, distribute with modifications, sublicense, and/or sell --
|
|
-- copies of the Software, and to permit persons to whom the Software is --
|
|
-- furnished to do so, subject to the following conditions: --
|
|
-- --
|
|
-- The above copyright notice and this permission notice shall be included --
|
|
-- in all copies or substantial portions of the Software. --
|
|
-- --
|
|
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS --
|
|
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF --
|
|
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. --
|
|
-- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, --
|
|
-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR --
|
|
-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR --
|
|
-- THE USE OR OTHER DEALINGS IN THE SOFTWARE. --
|
|
-- --
|
|
-- Except as contained in this notice, the name(s) of the above copyright --
|
|
-- holders shall not be used in advertising or otherwise to promote the --
|
|
-- sale, use or other dealings in this Software without prior written --
|
|
-- authorization. --
|
|
------------------------------------------------------------------------------
|
|
-- Author: Juergen Pfeifer, 1996
|
|
-- Version Control
|
|
-- $Revision: 1.19 $
|
|
-- $Date: 2011/03/23 00:44:12 $
|
|
-- Binding Version 01.00
|
|
------------------------------------------------------------------------------
|
|
with Terminal_Interface.Curses; use Terminal_Interface.Curses;
|
|
with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels;
|
|
with Terminal_Interface.Curses.Menus; use Terminal_Interface.Curses.Menus;
|
|
with Terminal_Interface.Curses.Menus.Menu_User_Data;
|
|
with Terminal_Interface.Curses.Menus.Item_User_Data;
|
|
|
|
with Sample.Manifest; use Sample.Manifest;
|
|
with Sample.Function_Key_Setting; use Sample.Function_Key_Setting;
|
|
with Sample.Menu_Demo.Handler;
|
|
with Sample.Helpers; use Sample.Helpers;
|
|
with Sample.Explanation; use Sample.Explanation;
|
|
|
|
package body Sample.Menu_Demo is
|
|
|
|
package Spacing_Demo is
|
|
procedure Spacing_Test;
|
|
end Spacing_Demo;
|
|
|
|
package body Spacing_Demo is
|
|
|
|
procedure Spacing_Test
|
|
is
|
|
function My_Driver (M : Menu;
|
|
K : Key_Code;
|
|
P : Panel) return Boolean;
|
|
|
|
procedure Set_Option_Key;
|
|
procedure Set_Select_Key;
|
|
procedure Set_Description_Key;
|
|
procedure Set_Hide_Key;
|
|
|
|
package Mh is new Sample.Menu_Demo.Handler (My_Driver);
|
|
|
|
I : Item_Array_Access := new Item_Array'
|
|
(New_Item ("January", "31 Days"),
|
|
New_Item ("February", "28/29 Days"),
|
|
New_Item ("March", "31 Days"),
|
|
New_Item ("April", "30 Days"),
|
|
New_Item ("May", "31 Days"),
|
|
New_Item ("June", "30 Days"),
|
|
New_Item ("July", "31 Days"),
|
|
New_Item ("August", "31 Days"),
|
|
New_Item ("September", "30 Days"),
|
|
New_Item ("October", "31 Days"),
|
|
New_Item ("November", "30 Days"),
|
|
New_Item ("December", "31 Days"),
|
|
Null_Item);
|
|
|
|
M : Menu := New_Menu (I);
|
|
Flip_State : Boolean := True;
|
|
Hide_Long : Boolean := False;
|
|
|
|
type Format_Code is (Four_By_1, Four_By_2, Four_By_3);
|
|
type Operations is (Flip, Reorder, Reformat, Reselect, Describe);
|
|
|
|
type Change is array (Operations) of Boolean;
|
|
pragma Pack (Change);
|
|
No_Change : constant Change := Change'(others => False);
|
|
|
|
Current_Format : Format_Code := Four_By_1;
|
|
To_Change : Change := No_Change;
|
|
|
|
function My_Driver (M : Menu;
|
|
K : Key_Code;
|
|
P : Panel) return Boolean
|
|
is
|
|
begin
|
|
if M = Null_Menu then
|
|
raise Menu_Exception;
|
|
end if;
|
|
if P = Null_Panel then
|
|
raise Panel_Exception;
|
|
end if;
|
|
To_Change := No_Change;
|
|
if K in User_Key_Code'Range then
|
|
if K = QUIT then
|
|
return True;
|
|
end if;
|
|
end if;
|
|
if K in Special_Key_Code'Range then
|
|
case K is
|
|
when Key_F4 =>
|
|
To_Change (Flip) := True;
|
|
return True;
|
|
when Key_F5 =>
|
|
To_Change (Reformat) := True;
|
|
Current_Format := Four_By_1;
|
|
return True;
|
|
when Key_F6 =>
|
|
To_Change (Reformat) := True;
|
|
Current_Format := Four_By_2;
|
|
return True;
|
|
when Key_F7 =>
|
|
To_Change (Reformat) := True;
|
|
Current_Format := Four_By_3;
|
|
return True;
|
|
when Key_F8 =>
|
|
To_Change (Reorder) := True;
|
|
return True;
|
|
when Key_F9 =>
|
|
To_Change (Reselect) := True;
|
|
return True;
|
|
when Key_F10 =>
|
|
if Current_Format /= Four_By_3 then
|
|
To_Change (Describe) := True;
|
|
return True;
|
|
else
|
|
return False;
|
|
end if;
|
|
when Key_F11 =>
|
|
Hide_Long := not Hide_Long;
|
|
declare
|
|
O : Item_Option_Set;
|
|
begin
|
|
for J in I'Range loop
|
|
Get_Options (I.all (J), O);
|
|
O.Selectable := True;
|
|
if Hide_Long then
|
|
case J is
|
|
when 1 | 3 | 5 | 7 | 8 | 10 | 12 =>
|
|
O.Selectable := False;
|
|
when others => null;
|
|
end case;
|
|
end if;
|
|
Set_Options (I.all (J), O);
|
|
end loop;
|
|
end;
|
|
return False;
|
|
when others => null;
|
|
end case;
|
|
end if;
|
|
return False;
|
|
end My_Driver;
|
|
|
|
procedure Set_Option_Key
|
|
is
|
|
O : Menu_Option_Set;
|
|
begin
|
|
if Current_Format = Four_By_1 then
|
|
Set_Soft_Label_Key (8, "");
|
|
else
|
|
Get_Options (M, O);
|
|
if O.Row_Major_Order then
|
|
Set_Soft_Label_Key (8, "O-Col");
|
|
else
|
|
Set_Soft_Label_Key (8, "O-Row");
|
|
end if;
|
|
end if;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end Set_Option_Key;
|
|
|
|
procedure Set_Select_Key
|
|
is
|
|
O : Menu_Option_Set;
|
|
begin
|
|
Get_Options (M, O);
|
|
if O.One_Valued then
|
|
Set_Soft_Label_Key (9, "Multi");
|
|
else
|
|
Set_Soft_Label_Key (9, "Singl");
|
|
end if;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end Set_Select_Key;
|
|
|
|
procedure Set_Description_Key
|
|
is
|
|
O : Menu_Option_Set;
|
|
begin
|
|
if Current_Format = Four_By_3 then
|
|
Set_Soft_Label_Key (10, "");
|
|
else
|
|
Get_Options (M, O);
|
|
if O.Show_Descriptions then
|
|
Set_Soft_Label_Key (10, "-Desc");
|
|
else
|
|
Set_Soft_Label_Key (10, "+Desc");
|
|
end if;
|
|
end if;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end Set_Description_Key;
|
|
|
|
procedure Set_Hide_Key
|
|
is
|
|
begin
|
|
if Hide_Long then
|
|
Set_Soft_Label_Key (11, "Enab");
|
|
else
|
|
Set_Soft_Label_Key (11, "Disab");
|
|
end if;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end Set_Hide_Key;
|
|
|
|
begin
|
|
Push_Environment ("MENU01");
|
|
Notepad ("MENU-PAD01");
|
|
Default_Labels;
|
|
Set_Soft_Label_Key (4, "Flip");
|
|
Set_Soft_Label_Key (5, "4x1");
|
|
Set_Soft_Label_Key (6, "4x2");
|
|
Set_Soft_Label_Key (7, "4x3");
|
|
Set_Option_Key;
|
|
Set_Select_Key;
|
|
Set_Description_Key;
|
|
Set_Hide_Key;
|
|
|
|
Set_Format (M, 4, 1);
|
|
loop
|
|
Mh.Drive_Me (M);
|
|
exit when To_Change = No_Change;
|
|
if To_Change (Flip) then
|
|
if Flip_State then
|
|
Flip_State := False;
|
|
Set_Spacing (M, 3, 2, 0);
|
|
else
|
|
Flip_State := True;
|
|
Set_Spacing (M);
|
|
end if;
|
|
elsif To_Change (Reformat) then
|
|
case Current_Format is
|
|
when Four_By_1 => Set_Format (M, 4, 1);
|
|
when Four_By_2 => Set_Format (M, 4, 2);
|
|
when Four_By_3 =>
|
|
declare
|
|
O : Menu_Option_Set;
|
|
begin
|
|
Get_Options (M, O);
|
|
O.Show_Descriptions := False;
|
|
Set_Options (M, O);
|
|
Set_Format (M, 4, 3);
|
|
end;
|
|
end case;
|
|
Set_Option_Key;
|
|
Set_Description_Key;
|
|
elsif To_Change (Reorder) then
|
|
declare
|
|
O : Menu_Option_Set;
|
|
begin
|
|
Get_Options (M, O);
|
|
O.Row_Major_Order := not O.Row_Major_Order;
|
|
Set_Options (M, O);
|
|
Set_Option_Key;
|
|
end;
|
|
elsif To_Change (Reselect) then
|
|
declare
|
|
O : Menu_Option_Set;
|
|
begin
|
|
Get_Options (M, O);
|
|
O.One_Valued := not O.One_Valued;
|
|
Set_Options (M, O);
|
|
Set_Select_Key;
|
|
end;
|
|
elsif To_Change (Describe) then
|
|
declare
|
|
O : Menu_Option_Set;
|
|
begin
|
|
Get_Options (M, O);
|
|
O.Show_Descriptions := not O.Show_Descriptions;
|
|
Set_Options (M, O);
|
|
Set_Description_Key;
|
|
end;
|
|
else
|
|
null;
|
|
end if;
|
|
end loop;
|
|
Set_Spacing (M);
|
|
|
|
Pop_Environment;
|
|
pragma Assert (Get_Index (Items (M, 1)) = Get_Index (I (1)));
|
|
Delete (M);
|
|
Free (I, True);
|
|
end Spacing_Test;
|
|
end Spacing_Demo;
|
|
|
|
procedure Demo
|
|
is
|
|
-- We use this datatype only to test the instantiation of
|
|
-- the Menu_User_Data generic package. No functionality
|
|
-- behind it.
|
|
type User_Data is new Integer;
|
|
type User_Data_Access is access User_Data;
|
|
|
|
-- Those packages are only instantiated to test the usability.
|
|
-- No real functionality is shown in the demo.
|
|
package MUD is new Menu_User_Data (User_Data, User_Data_Access);
|
|
package IUD is new Item_User_Data (User_Data, User_Data_Access);
|
|
|
|
function My_Driver (M : Menu;
|
|
K : Key_Code;
|
|
P : Panel) return Boolean;
|
|
|
|
package Mh is new Sample.Menu_Demo.Handler (My_Driver);
|
|
|
|
Itm : Item_Array_Access := new Item_Array'
|
|
(New_Item ("Menu Layout Options"),
|
|
New_Item ("Demo of Hook functions"),
|
|
Null_Item);
|
|
M : Menu := New_Menu (Itm);
|
|
|
|
U1 : constant User_Data_Access := new User_Data'(4711);
|
|
U2 : User_Data_Access;
|
|
U3 : constant User_Data_Access := new User_Data'(4712);
|
|
U4 : User_Data_Access;
|
|
|
|
function My_Driver (M : Menu;
|
|
K : Key_Code;
|
|
P : Panel) return Boolean
|
|
is
|
|
Idx : constant Positive := Get_Index (Current (M));
|
|
begin
|
|
if K in User_Key_Code'Range then
|
|
if K = QUIT then
|
|
return True;
|
|
elsif K = SELECT_ITEM then
|
|
if Idx in Itm'Range then
|
|
Hide (P);
|
|
Update_Panels;
|
|
end if;
|
|
case Idx is
|
|
when 1 => Spacing_Demo.Spacing_Test;
|
|
when others => Not_Implemented;
|
|
end case;
|
|
if Idx in Itm'Range then
|
|
Top (P);
|
|
Show (P);
|
|
Update_Panels;
|
|
Update_Screen;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
return False;
|
|
end My_Driver;
|
|
begin
|
|
Push_Environment ("MENU00");
|
|
Notepad ("MENU-PAD00");
|
|
Default_Labels;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
Set_Pad_Character (M, '|');
|
|
|
|
MUD.Set_User_Data (M, U1);
|
|
IUD.Set_User_Data (Itm.all (1), U3);
|
|
|
|
Mh.Drive_Me (M);
|
|
|
|
MUD.Get_User_Data (M, U2);
|
|
pragma Assert (U1 = U2 and U1.all = 4711);
|
|
|
|
IUD.Get_User_Data (Itm.all (1), U4);
|
|
pragma Assert (U3 = U4 and U3.all = 4712);
|
|
|
|
Pop_Environment;
|
|
Delete (M);
|
|
Free (Itm, True);
|
|
end Demo;
|
|
|
|
end Sample.Menu_Demo;
|