ncurses 5.7 - patch 20091226
[ncurses.git] / Ada95 / samples / sample-function_key_setting.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                       GNAT ncurses Binding Samples                       --
4 --                                                                          --
5 --                         Sample.Function_Key_Setting                      --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright (c) 1998-2004,2009 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.14 $
39 --  $Date: 2009/12/26 17:38:58 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 with Ada.Unchecked_Deallocation;
43 with Sample.Manifest; use  Sample.Manifest;
44
45 --  This package implements a simple stack of function key label environments.
46 --
47 package body Sample.Function_Key_Setting is
48
49    Max_Label_Length : constant Positive := 8;
50    Number_Of_Keys   : Label_Number := Label_Number'Last;
51    Justification    : Label_Justification := Left;
52
53    subtype Label is String (1 .. Max_Label_Length);
54    type Label_Array is array (Label_Number range <>) of Label;
55
56    type Key_Environment (N : Label_Number := Label_Number'Last);
57    type Env_Ptr is access Key_Environment;
58    pragma Controlled (Env_Ptr);
59
60    type String_Access is access String;
61    pragma Controlled (String_Access);
62
63    Active_Context : String_Access := new String'("MAIN");
64    Active_Notepad : Panel := Null_Panel;
65
66    type Key_Environment  (N : Label_Number := Label_Number'Last) is
67       record
68          Prev    : Env_Ptr;
69          Help    : String_Access;
70          Notepad : Panel;
71          Labels  : Label_Array (1 .. N);
72       end record;
73
74    procedure Release_String is
75      new Ada.Unchecked_Deallocation (String,
76                                      String_Access);
77
78    procedure Release_Environment is
79       new Ada.Unchecked_Deallocation (Key_Environment,
80                                       Env_Ptr);
81
82    Top_Of_Stack : Env_Ptr := null;
83
84    procedure Push_Environment (Key   : String;
85                                Reset : Boolean := True)
86    is
87       P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
88    begin
89       --  Store the current labels in the environment
90       for I in 1 .. Number_Of_Keys loop
91          Get_Soft_Label_Key (I, P.Labels (I));
92          if Reset then
93             Set_Soft_Label_Key (I, " ");
94          end if;
95       end loop;
96       P.Prev := Top_Of_Stack;
97       --  now store active help context and notepad
98       P.Help := Active_Context;
99       P.Notepad := Active_Notepad;
100       --  The notepad must now vanish and the new notepad is empty.
101       if P.Notepad /= Null_Panel then
102          Hide (P.Notepad);
103          Update_Panels;
104       end if;
105       Active_Notepad := Null_Panel;
106       Active_Context := new String'(Key);
107
108       Top_Of_Stack := P;
109       if Reset then
110          Refresh_Soft_Label_Keys_Without_Update;
111       end if;
112    end Push_Environment;
113
114    procedure Pop_Environment
115    is
116       P : Env_Ptr := Top_Of_Stack;
117    begin
118       if Top_Of_Stack = null then
119          raise Function_Key_Stack_Error;
120       else
121          for I in 1 .. Number_Of_Keys loop
122             Set_Soft_Label_Key (I, P.Labels (I), Justification);
123          end loop;
124          pragma Assert (Active_Context /= null);
125          Release_String (Active_Context);
126          Active_Context := P.Help;
127          Refresh_Soft_Label_Keys_Without_Update;
128          Notepad_To_Context (P.Notepad);
129          Top_Of_Stack := P.Prev;
130          Release_Environment (P);
131       end if;
132    end Pop_Environment;
133
134    function Context return String
135    is
136    begin
137       if Active_Context /= null then
138          return Active_Context.all;
139       else
140          return "";
141       end if;
142    end Context;
143
144    function Find_Context (Key : String) return Boolean
145    is
146       P : Env_Ptr := Top_Of_Stack;
147    begin
148       if Active_Context.all = Key then
149          return True;
150       else
151          loop
152             exit when P = null;
153             if P.Help.all = Key then
154                return True;
155             else
156                P := P.Prev;
157             end if;
158          end loop;
159          return False;
160       end if;
161    end Find_Context;
162
163    procedure Notepad_To_Context (Pan : Panel)
164    is
165       W : Window;
166    begin
167       if Active_Notepad /= Null_Panel then
168          W := Get_Window (Active_Notepad);
169          Clear (W);
170          Delete (Active_Notepad);
171          Delete (W);
172       end if;
173       Active_Notepad := Pan;
174       if Pan /= Null_Panel then
175          Top  (Pan);
176       end if;
177       Update_Panels;
178       Update_Screen;
179    end Notepad_To_Context;
180
181    procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
182                          Just : Label_Justification := Left)
183    is
184    begin
185       case Mode is
186          when PC_Style .. PC_Style_With_Index
187            => Number_Of_Keys := 12;
188          when others
189            => Number_Of_Keys := 8;
190       end case;
191       Init_Soft_Label_Keys (Mode);
192       Justification := Just;
193    end Initialize;
194
195    procedure Default_Labels
196    is
197    begin
198       Set_Soft_Label_Key (FKEY_QUIT, "Quit");
199       Set_Soft_Label_Key (FKEY_HELP, "Help");
200       Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
201       Refresh_Soft_Label_Keys_Without_Update;
202    end Default_Labels;
203
204    function Notepad_Window return Window
205    is
206    begin
207       if Active_Notepad /= Null_Panel then
208          return Get_Window (Active_Notepad);
209       else
210          return Null_Window;
211       end if;
212    end Notepad_Window;
213
214 end Sample.Function_Key_Setting;