mirror of
https://github.com/Aigor44/ncursesw-morphos.git
synced 2024-12-27 07:49:06 +08:00
f36e772702
+ add bterm terminfo entry, based on bogl 0.1.18 -TD + minor fix to rxvt+pcfkeys terminfo entry -TD + build-fixes for Ada95 tree for gnat 4.4 "style".
215 lines
7.6 KiB
Ada
215 lines
7.6 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT ncurses Binding Samples --
|
|
-- --
|
|
-- Sample.Function_Key_Setting --
|
|
-- --
|
|
-- B O D Y --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
-- Copyright (c) 1998-2004,2009 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.14 $
|
|
-- $Date: 2009/12/26 17:38:58 $
|
|
-- Binding Version 01.00
|
|
------------------------------------------------------------------------------
|
|
with Ada.Unchecked_Deallocation;
|
|
with Sample.Manifest; use Sample.Manifest;
|
|
|
|
-- This package implements a simple stack of function key label environments.
|
|
--
|
|
package body Sample.Function_Key_Setting is
|
|
|
|
Max_Label_Length : constant Positive := 8;
|
|
Number_Of_Keys : Label_Number := Label_Number'Last;
|
|
Justification : Label_Justification := Left;
|
|
|
|
subtype Label is String (1 .. Max_Label_Length);
|
|
type Label_Array is array (Label_Number range <>) of Label;
|
|
|
|
type Key_Environment (N : Label_Number := Label_Number'Last);
|
|
type Env_Ptr is access Key_Environment;
|
|
pragma Controlled (Env_Ptr);
|
|
|
|
type String_Access is access String;
|
|
pragma Controlled (String_Access);
|
|
|
|
Active_Context : String_Access := new String'("MAIN");
|
|
Active_Notepad : Panel := Null_Panel;
|
|
|
|
type Key_Environment (N : Label_Number := Label_Number'Last) is
|
|
record
|
|
Prev : Env_Ptr;
|
|
Help : String_Access;
|
|
Notepad : Panel;
|
|
Labels : Label_Array (1 .. N);
|
|
end record;
|
|
|
|
procedure Release_String is
|
|
new Ada.Unchecked_Deallocation (String,
|
|
String_Access);
|
|
|
|
procedure Release_Environment is
|
|
new Ada.Unchecked_Deallocation (Key_Environment,
|
|
Env_Ptr);
|
|
|
|
Top_Of_Stack : Env_Ptr := null;
|
|
|
|
procedure Push_Environment (Key : String;
|
|
Reset : Boolean := True)
|
|
is
|
|
P : constant Env_Ptr := new Key_Environment (Number_Of_Keys);
|
|
begin
|
|
-- Store the current labels in the environment
|
|
for I in 1 .. Number_Of_Keys loop
|
|
Get_Soft_Label_Key (I, P.Labels (I));
|
|
if Reset then
|
|
Set_Soft_Label_Key (I, " ");
|
|
end if;
|
|
end loop;
|
|
P.Prev := Top_Of_Stack;
|
|
-- now store active help context and notepad
|
|
P.Help := Active_Context;
|
|
P.Notepad := Active_Notepad;
|
|
-- The notepad must now vanish and the new notepad is empty.
|
|
if P.Notepad /= Null_Panel then
|
|
Hide (P.Notepad);
|
|
Update_Panels;
|
|
end if;
|
|
Active_Notepad := Null_Panel;
|
|
Active_Context := new String'(Key);
|
|
|
|
Top_Of_Stack := P;
|
|
if Reset then
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end if;
|
|
end Push_Environment;
|
|
|
|
procedure Pop_Environment
|
|
is
|
|
P : Env_Ptr := Top_Of_Stack;
|
|
begin
|
|
if Top_Of_Stack = null then
|
|
raise Function_Key_Stack_Error;
|
|
else
|
|
for I in 1 .. Number_Of_Keys loop
|
|
Set_Soft_Label_Key (I, P.Labels (I), Justification);
|
|
end loop;
|
|
pragma Assert (Active_Context /= null);
|
|
Release_String (Active_Context);
|
|
Active_Context := P.Help;
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
Notepad_To_Context (P.Notepad);
|
|
Top_Of_Stack := P.Prev;
|
|
Release_Environment (P);
|
|
end if;
|
|
end Pop_Environment;
|
|
|
|
function Context return String
|
|
is
|
|
begin
|
|
if Active_Context /= null then
|
|
return Active_Context.all;
|
|
else
|
|
return "";
|
|
end if;
|
|
end Context;
|
|
|
|
function Find_Context (Key : String) return Boolean
|
|
is
|
|
P : Env_Ptr := Top_Of_Stack;
|
|
begin
|
|
if Active_Context.all = Key then
|
|
return True;
|
|
else
|
|
loop
|
|
exit when P = null;
|
|
if P.Help.all = Key then
|
|
return True;
|
|
else
|
|
P := P.Prev;
|
|
end if;
|
|
end loop;
|
|
return False;
|
|
end if;
|
|
end Find_Context;
|
|
|
|
procedure Notepad_To_Context (Pan : Panel)
|
|
is
|
|
W : Window;
|
|
begin
|
|
if Active_Notepad /= Null_Panel then
|
|
W := Get_Window (Active_Notepad);
|
|
Clear (W);
|
|
Delete (Active_Notepad);
|
|
Delete (W);
|
|
end if;
|
|
Active_Notepad := Pan;
|
|
if Pan /= Null_Panel then
|
|
Top (Pan);
|
|
end if;
|
|
Update_Panels;
|
|
Update_Screen;
|
|
end Notepad_To_Context;
|
|
|
|
procedure Initialize (Mode : Soft_Label_Key_Format := PC_Style;
|
|
Just : Label_Justification := Left)
|
|
is
|
|
begin
|
|
case Mode is
|
|
when PC_Style .. PC_Style_With_Index
|
|
=> Number_Of_Keys := 12;
|
|
when others
|
|
=> Number_Of_Keys := 8;
|
|
end case;
|
|
Init_Soft_Label_Keys (Mode);
|
|
Justification := Just;
|
|
end Initialize;
|
|
|
|
procedure Default_Labels
|
|
is
|
|
begin
|
|
Set_Soft_Label_Key (FKEY_QUIT, "Quit");
|
|
Set_Soft_Label_Key (FKEY_HELP, "Help");
|
|
Set_Soft_Label_Key (FKEY_EXPLAIN, "Keys");
|
|
Refresh_Soft_Label_Keys_Without_Update;
|
|
end Default_Labels;
|
|
|
|
function Notepad_Window return Window
|
|
is
|
|
begin
|
|
if Active_Notepad /= Null_Panel then
|
|
return Get_Window (Active_Notepad);
|
|
else
|
|
return Null_Window;
|
|
end if;
|
|
end Notepad_Window;
|
|
|
|
end Sample.Function_Key_Setting;
|