1 ------------------------------------------------------------------------------
3 -- GNAT ncurses Binding Samples --
5 -- Sample.Function_Key_Setting --
11 -- The ncurses Ada95 binding is copyrighted 1996 by --
12 -- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
14 -- Permission is hereby granted to reproduce and distribute this --
15 -- binding by any means and for any fee, whether alone or as part --
16 -- of a larger distribution, in source or in binary form, PROVIDED --
17 -- this notice is included with any such distribution, and is not --
18 -- removed from any of its header files. Mention of ncurses and the --
19 -- author of this binding in any applications linked with it is --
20 -- highly appreciated. --
22 -- This binding comes AS IS with no warranty, implied or expressed. --
23 ------------------------------------------------------------------------------
26 ------------------------------------------------------------------------------
27 with Ada.Unchecked_Deallocation;
28 with Sample.Manifest; use Sample.Manifest;
30 -- This package implements a simple stack of function key label environments.
32 package body Sample.Function_Key_Setting is
34 Max_Label_Length : constant Positive := 8;
35 Number_Of_Keys : Label_Number := Label_Number'Last;
36 Justification : Label_Justification := Left;
38 subtype Label is String (1 .. Max_Label_Length);
39 type Label_Array is array (Label_Number range <>) of Label;
41 type Key_Environment (N : Label_Number := Label_Number'Last);
42 type Env_Ptr is access Key_Environment;
43 pragma Controlled (Env_Ptr);
45 type String_Access is access String;
46 pragma Controlled (String_Access);
48 Active_Context : String_Access := new String'("MAIN");
49 Active_Notepad : Panel := Null_Panel;
51 type Key_Environment (N : Label_Number := Label_Number'Last) is
56 Labels : Label_Array (1 .. N);
59 procedure Release_String is
60 new Ada.Unchecked_Deallocation (String,
63 procedure Release_Environment is
64 new Ada.Unchecked_Deallocation (Key_Environment,
67 Top_Of_Stack : Env_Ptr := null;
69 procedure Push_Environment (Key : in String;
70 Reset : in Boolean := True)
72 P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
74 -- Store the current labels in the environment
75 for I in 1 .. Number_Of_Keys loop
76 Get_Soft_Label_Key (I, P.Labels (I));
78 Set_Soft_Label_Key (I, " ");
81 P.Prev := Top_Of_Stack;
82 -- now store active help context and notepad
83 P.Help := Active_Context;
84 P.Notepad := Active_Notepad;
85 -- The notepad must now vanish and the new notepad is empty.
86 if (P.Notepad /= Null_Panel) then
90 Active_Notepad := Null_Panel;
91 Active_Context := new String'(Key);
95 Refresh_Soft_Label_Keys_Without_Update;
99 procedure Pop_Environment
101 P : Env_Ptr := Top_Of_Stack;
103 if Top_Of_Stack = null then
104 raise Function_Key_Stack_Error;
106 for I in 1 .. Number_Of_Keys loop
107 Set_Soft_Label_Key (I, P.Labels (I), Justification);
109 pragma Assert (Active_Context /= null);
110 Release_String (Active_Context);
111 Active_Context := P.Help;
112 Refresh_Soft_Label_Keys_Without_Update;
113 Notepad_To_Context (P.Notepad);
114 Top_Of_Stack := P.Prev;
115 Release_Environment (P);
119 function Context return String
122 if Active_Context /= null then
123 return Active_Context.all;
129 function Find_Context (Key : String) return Boolean
131 P : Env_Ptr := Top_Of_Stack;
133 if Active_Context.all = Key then
138 if P.Help.all = Key then
148 procedure Notepad_To_Context (Pan : in Panel)
152 if Active_Notepad /= Null_Panel then
153 W := Get_Window (Active_Notepad);
155 Delete (Active_Notepad);
158 Active_Notepad := Pan;
159 if Pan /= Null_Panel then
164 end Notepad_To_Context;
166 procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
167 Just : Label_Justification := Left)
171 when PC_Style .. PC_Style_With_Index
172 => Number_Of_Keys := 12;
174 => Number_Of_Keys := 8;
176 Init_Soft_Label_Keys (Mode);
177 Justification := Just;
180 procedure Default_Labels
183 Set_Soft_Label_Key (FKEY_QUIT, "Quit");
184 Set_Soft_Label_Key (FKEY_HELP, "Help");
185 Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
186 Refresh_Soft_Label_Keys_Without_Update;
189 function Notepad_Window return Window
192 if Active_Notepad /= Null_Panel then
193 return Get_Window (Active_Notepad);
199 end Sample.Function_Key_Setting;