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 2020 Thomas E. Dickey                                          --
  11 -- Copyright 1998-2009,2011 Free Software Foundation, Inc.                  --
  12 --                                                                          --
  13 -- Permission is hereby granted, free of charge, to any person obtaining a  --
  14 -- copy of this software and associated documentation files (the            --
  15 -- "Software"), to deal in the Software without restriction, including      --
  16 -- without limitation the rights to use, copy, modify, merge, publish,      --
  17 -- distribute, distribute with modifications, sublicense, and/or sell       --
  18 -- copies of the Software, and to permit persons to whom the Software is    --
  19 -- furnished to do so, subject to the following conditions:                 --
  20 --                                                                          --
  21 -- The above copyright notice and this permission notice shall be included  --
  22 -- in all copies or substantial portions of the Software.                   --
  23 --                                                                          --
  24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  31 --                                                                          --
  32 -- Except as contained in this notice, the name(s) of the above copyright   --
  33 -- holders shall not be used in advertising or otherwise to promote the     --
  34 -- sale, use or other dealings in this Software without prior written       --
  35 -- authorization.                                                           --
  36 ------------------------------------------------------------------------------
  37 --  Author:  Juergen Pfeifer, 1996
  38 --  Version Control
  39 --  $Revision: 1.16 $
  40 --  $Date: 2020/02/02 23:34:34 $
  41 --  Binding Version 01.00
  42 ------------------------------------------------------------------------------
  43 with Ada.Unchecked_Deallocation;
  44 with Sample.Manifest; use  Sample.Manifest;
  45
  46 --  This package implements a simple stack of function key label environments.
  47 --
  48 package body Sample.Function_Key_Setting is
  49
  50    Max_Label_Length : constant Positive := 8;
  51    Number_Of_Keys   : Label_Number := Label_Number'Last;
  52    Justification    : Label_Justification := Left;
  53
  54    subtype Label is String (1 .. Max_Label_Length);
  55    type Label_Array is array (Label_Number range <>) of Label;
  56
  57    type Key_Environment (N : Label_Number := Label_Number'Last);
  58    type Env_Ptr is access Key_Environment;
  59    pragma Controlled (Env_Ptr);
  60
  61    type String_Access is access String;
  62    pragma Controlled (String_Access);
  63
  64    Active_Context : String_Access := new String'("MAIN");
  65    Active_Notepad : Panel := Null_Panel;
  66
  67    type Key_Environment  (N : Label_Number := Label_Number'Last) is
  68       record
  69          Prev    : Env_Ptr;
  70          Help    : String_Access;
  71          Notepad : Panel;
  72          Labels  : Label_Array (1 .. N);
  73       end record;
  74
  75    procedure Release_String is
  76      new Ada.Unchecked_Deallocation (String,
  77                                      String_Access);
  78
  79    procedure Release_Environment is
  80       new Ada.Unchecked_Deallocation (Key_Environment,
  81                                       Env_Ptr);
  82
  83    Top_Of_Stack : Env_Ptr := null;
  84
  85    procedure Push_Environment (Key   : String;
  86                                Reset : Boolean := True)
  87    is
  88       P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
  89    begin
  90       --  Store the current labels in the environment
  91       for I in 1 .. Number_Of_Keys loop
  92          Get_Soft_Label_Key (I, P.all.Labels (I));
  93          if Reset then
  94             Set_Soft_Label_Key (I, " ");
  95          end if;
  96       end loop;
  97       P.all.Prev := Top_Of_Stack;
  98       --  now store active help context and notepad
  99       P.all.Help := Active_Context;
 100       P.all.Notepad := Active_Notepad;
 101       --  The notepad must now vanish and the new notepad is empty.
 102       if P.all.Notepad /= Null_Panel then
 103          Hide (P.all.Notepad);
 104          Update_Panels;
 105       end if;
 106       Active_Notepad := Null_Panel;
 107       Active_Context := new String'(Key);
 108
 109       Top_Of_Stack := P;
 110       if Reset then
 111          Refresh_Soft_Label_Keys_Without_Update;
 112       end if;
 113    end Push_Environment;
 114
 115    procedure Pop_Environment
 116    is
 117       P : Env_Ptr := Top_Of_Stack;
 118    begin
 119       if Top_Of_Stack = null then
 120          raise Function_Key_Stack_Error;
 121       else
 122          for I in 1 .. Number_Of_Keys loop
 123             Set_Soft_Label_Key (I, P.all.Labels (I), Justification);
 124          end loop;
 125          pragma Assert (Active_Context /= null);
 126          Release_String (Active_Context);
 127          Active_Context := P.all.Help;
 128          Refresh_Soft_Label_Keys_Without_Update;
 129          Notepad_To_Context (P.all.Notepad);
 130          Top_Of_Stack := P.all.Prev;
 131          Release_Environment (P);
 132       end if;
 133    end Pop_Environment;
 134
 135    function Context return String
 136    is
 137    begin
 138       if Active_Context /= null then
 139          return Active_Context.all;
 140       else
 141          return "";
 142       end if;
 143    end Context;
 144
 145    function Find_Context (Key : String) return Boolean
 146    is
 147       P : Env_Ptr := Top_Of_Stack;
 148    begin
 149       if Active_Context.all = Key then
 150          return True;
 151       else
 152          loop
 153             exit when P = null;
 154             if P.all.Help.all = Key then
 155                return True;
 156             else
 157                P := P.all.Prev;
 158             end if;
 159          end loop;
 160          return False;
 161       end if;
 162    end Find_Context;
 163
 164    procedure Notepad_To_Context (Pan : Panel)
 165    is
 166       W : Window;
 167    begin
 168       if Active_Notepad /= Null_Panel then
 169          W := Get_Window (Active_Notepad);
 170          Clear (W);
 171          Delete (Active_Notepad);
 172          Delete (W);
 173       end if;
 174       Active_Notepad := Pan;
 175       if Pan /= Null_Panel then
 176          Top  (Pan);
 177       end if;
 178       Update_Panels;
 179       Update_Screen;
 180    end Notepad_To_Context;
 181
 182    procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
 183                          Just : Label_Justification := Left)
 184    is
 185    begin
 186       case Mode is
 187          when PC_Style .. PC_Style_With_Index
 188            => Number_Of_Keys := 12;
 189          when others
 190            => Number_Of_Keys := 8;
 191       end case;
 192       Init_Soft_Label_Keys (Mode);
 193       Justification := Just;
 194    end Initialize;
 195
 196    procedure Default_Labels
 197    is
 198    begin
 199       Set_Soft_Label_Key (FKEY_QUIT, "Quit");
 200       Set_Soft_Label_Key (FKEY_HELP, "Help");
 201       Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
 202       Refresh_Soft_Label_Keys_Without_Update;
 203    end Default_Labels;
 204
 205    function Notepad_Window return Window
 206    is
 207    begin
 208       if Active_Notepad /= Null_Panel then
 209          return Get_Window (Active_Notepad);
 210       else
 211          return Null_Window;
 212       end if;
 213    end Notepad_Window;
 214
 215 end Sample.Function_Key_Setting;