| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT ncurses Binding Samples -- |
| -- -- |
| -- Sample.Explanation -- |
| -- -- |
| -- B O D Y -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| -- Copyright (c) 1998-2004,2006 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.20 $ |
| -- $Date: 2006/06/25 14:30:22 $ |
| -- Binding Version 01.00 |
| ------------------------------------------------------------------------------ |
| -- Poor mans help system. This scans a sequential file for key lines and |
| -- then reads the lines up to the next key. Those lines are presented in |
| -- a window as help or explanation. |
| -- |
| with Ada.Text_IO; use Ada.Text_IO; |
| with Ada.Unchecked_Deallocation; |
| with Terminal_Interface.Curses; use Terminal_Interface.Curses; |
| with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels; |
| |
| with Sample.Keyboard_Handler; use Sample.Keyboard_Handler; |
| with Sample.Manifest; use Sample.Manifest; |
| with Sample.Function_Key_Setting; use Sample.Function_Key_Setting; |
| with Sample.Helpers; use Sample.Helpers; |
| |
| package body Sample.Explanation is |
| |
| Help_Keys : constant String := "HELPKEYS"; |
| In_Help : constant String := "INHELP"; |
| |
| File_Name : constant String := "explain.msg"; |
| F : File_Type; |
| |
| type Help_Line; |
| type Help_Line_Access is access Help_Line; |
| pragma Controlled (Help_Line_Access); |
| type String_Access is access String; |
| pragma Controlled (String_Access); |
| |
| type Help_Line is |
| record |
| Prev, Next : Help_Line_Access; |
| Line : String_Access; |
| end record; |
| |
| procedure Explain (Key : in String; |
| Win : in Window); |
| |
| procedure Release_String is |
| new Ada.Unchecked_Deallocation (String, |
| String_Access); |
| procedure Release_Help_Line is |
| new Ada.Unchecked_Deallocation (Help_Line, |
| Help_Line_Access); |
| |
| function Search (Key : String) return Help_Line_Access; |
| procedure Release_Help (Root : in out Help_Line_Access); |
| |
| procedure Explain (Key : in String) |
| is |
| begin |
| Explain (Key, Null_Window); |
| end Explain; |
| |
| procedure Explain (Key : in String; |
| Win : in Window) |
| is |
| -- Retrieve the text associated with this key and display it in this |
| -- window. If no window argument is passed, the routine will create |
| -- a temporary window and use it. |
| |
| function Filter_Key return Real_Key_Code; |
| procedure Unknown_Key; |
| procedure Redo; |
| procedure To_Window (C : in out Help_Line_Access; |
| More : in out Boolean); |
| |
| Frame : Window := Null_Window; |
| |
| W : Window := Win; |
| K : Real_Key_Code; |
| P : Panel; |
| |
| Height : Line_Count; |
| Width : Column_Count; |
| Help : Help_Line_Access := Search (Key); |
| Current : Help_Line_Access; |
| Top_Line : Help_Line_Access; |
| |
| Has_More : Boolean := True; |
| |
| procedure Unknown_Key |
| is |
| begin |
| Add (W, "Help message with ID "); |
| Add (W, Key); |
| Add (W, " not found."); |
| Add (W, Character'Val (10)); |
| Add (W, "Press the Function key labelled 'Quit' key to continue."); |
| end Unknown_Key; |
| |
| procedure Redo |
| is |
| H : Help_Line_Access := Top_Line; |
| begin |
| if Top_Line /= null then |
| for L in 0 .. (Height - 1) loop |
| Add (W, L, 0, H.Line.all); |
| exit when H.Next = null; |
| H := H.Next; |
| end loop; |
| else |
| Unknown_Key; |
| end if; |
| end Redo; |
| |
| function Filter_Key return Real_Key_Code |
| is |
| K : Real_Key_Code; |
| begin |
| loop |
| K := Get_Key (W); |
| if K in Special_Key_Code'Range then |
| case K is |
| when HELP_CODE => |
| if not Find_Context (In_Help) then |
| Push_Environment (In_Help, False); |
| Explain (In_Help, W); |
| Pop_Environment; |
| Redo; |
| end if; |
| when EXPLAIN_CODE => |
| if not Find_Context (Help_Keys) then |
| Push_Environment (Help_Keys, False); |
| Explain (Help_Keys, W); |
| Pop_Environment; |
| Redo; |
| end if; |
| when others => exit; |
| end case; |
| else |
| exit; |
| end if; |
| end loop; |
| return K; |
| end Filter_Key; |
| |
| procedure To_Window (C : in out Help_Line_Access; |
| More : in out Boolean) |
| is |
| L : Line_Position := 0; |
| begin |
| loop |
| Add (W, L, 0, C.Line.all); |
| L := L + 1; |
| exit when C.Next = null or else L = Height; |
| C := C.Next; |
| end loop; |
| if C.Next /= null then |
| pragma Assert (L = Height); |
| More := True; |
| else |
| More := False; |
| end if; |
| end To_Window; |
| |
| begin |
| if W = Null_Window then |
| Push_Environment ("HELP"); |
| Default_Labels; |
| Frame := New_Window (Lines - 2, Columns, 0, 0); |
| if Has_Colors then |
| Set_Background (Win => Frame, |
| Ch => (Ch => ' ', |
| Color => Help_Color, |
| Attr => Normal_Video)); |
| Set_Character_Attributes (Win => Frame, |
| Attr => Normal_Video, |
| Color => Help_Color); |
| Erase (Frame); |
| end if; |
| Box (Frame); |
| Set_Character_Attributes (Frame, (Reverse_Video => True, |
| others => False)); |
| Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls"); |
| Set_Character_Attributes (Frame); -- Back to default. |
| Window_Title (Frame, "Explanation"); |
| W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1); |
| Refresh_Without_Update (Frame); |
| Get_Size (W, Height, Width); |
| Set_Meta_Mode (W); |
| Set_KeyPad_Mode (W); |
| Allow_Scrolling (W, True); |
| Set_Echo_Mode (False); |
| P := Create (Frame); |
| Top (P); |
| Update_Panels; |
| else |
| Clear (W); |
| Refresh_Without_Update (W); |
| end if; |
| |
| Current := Help; Top_Line := Help; |
| |
| if null = Help then |
| Unknown_Key; |
| loop |
| K := Filter_Key; |
| exit when K = QUIT_CODE; |
| end loop; |
| else |
| To_Window (Current, Has_More); |
| if Has_More then |
| -- This means there are more lines available, so we have to go |
| -- into a scroll manager. |
| loop |
| K := Filter_Key; |
| if K in Special_Key_Code'Range then |
| case K is |
| when Key_Cursor_Down => |
| if Current.Next /= null then |
| Move_Cursor (W, Height - 1, 0); |
| Scroll (W, 1); |
| Current := Current.Next; |
| Top_Line := Top_Line.Next; |
| Add (W, Current.Line.all); |
| end if; |
| when Key_Cursor_Up => |
| if Top_Line.Prev /= null then |
| Move_Cursor (W, 0, 0); |
| Scroll (W, -1); |
| Top_Line := Top_Line.Prev; |
| Current := Current.Prev; |
| Add (W, Top_Line.Line.all); |
| end if; |
| when QUIT_CODE => exit; |
| when others => null; |
| end case; |
| end if; |
| end loop; |
| else |
| loop |
| K := Filter_Key; |
| exit when K = QUIT_CODE; |
| end loop; |
| end if; |
| end if; |
| |
| Clear (W); |
| |
| if Frame /= Null_Window then |
| Clear (Frame); |
| Delete (P); |
| Delete (W); |
| Delete (Frame); |
| Pop_Environment; |
| end if; |
| |
| Update_Panels; |
| Update_Screen; |
| |
| Release_Help (Help); |
| |
| end Explain; |
| |
| function Search (Key : String) return Help_Line_Access |
| is |
| Last : Natural; |
| Buffer : String (1 .. 256); |
| Root : Help_Line_Access := null; |
| Current : Help_Line_Access; |
| Tail : Help_Line_Access := null; |
| |
| function Next_Line return Boolean; |
| |
| function Next_Line return Boolean |
| is |
| H_End : constant String := "#END"; |
| begin |
| Get_Line (F, Buffer, Last); |
| if Last = H_End'Length and then H_End = Buffer (1 .. Last) then |
| return False; |
| else |
| return True; |
| end if; |
| end Next_Line; |
| begin |
| Reset (F); |
| Outer : |
| loop |
| exit Outer when not Next_Line; |
| if Last = (1 + Key'Length) and then Key = Buffer (2 .. Last) |
| and then Buffer (1) = '#' then |
| loop |
| exit when not Next_Line; |
| exit when Buffer (1) = '#'; |
| Current := new Help_Line'(null, null, |
| new String'(Buffer (1 .. Last))); |
| if Tail = null then |
| Release_Help (Root); |
| Root := Current; |
| else |
| Tail.Next := Current; |
| Current.Prev := Tail; |
| end if; |
| Tail := Current; |
| end loop; |
| exit Outer; |
| end if; |
| end loop Outer; |
| return Root; |
| end Search; |
| |
| procedure Release_Help (Root : in out Help_Line_Access) |
| is |
| Next : Help_Line_Access; |
| begin |
| loop |
| exit when Root = null; |
| Next := Root.Next; |
| Release_String (Root.Line); |
| Release_Help_Line (Root); |
| Root := Next; |
| end loop; |
| end Release_Help; |
| |
| procedure Explain_Context |
| is |
| begin |
| Explain (Context); |
| end Explain_Context; |
| |
| procedure Notepad (Key : in String) |
| is |
| H : constant Help_Line_Access := Search (Key); |
| T : Help_Line_Access := H; |
| N : Line_Count := 1; |
| L : Line_Position := 0; |
| W : Window; |
| P : Panel; |
| begin |
| if H /= null then |
| loop |
| T := T.Next; |
| exit when T = null; |
| N := N + 1; |
| end loop; |
| W := New_Window (N + 2, Columns, Lines - N - 2, 0); |
| if Has_Colors then |
| Set_Background (Win => W, |
| Ch => (Ch => ' ', |
| Color => Notepad_Color, |
| Attr => Normal_Video)); |
| Set_Character_Attributes (Win => W, |
| Attr => Normal_Video, |
| Color => Notepad_Color); |
| Erase (W); |
| end if; |
| Box (W); |
| Window_Title (W, "Notepad"); |
| P := New_Panel (W); |
| T := H; |
| loop |
| Add (W, L + 1, 1, T.Line.all, Integer (Columns - 2)); |
| L := L + 1; |
| T := T.Next; |
| exit when T = null; |
| end loop; |
| T := H; |
| Release_Help (T); |
| Refresh_Without_Update (W); |
| Notepad_To_Context (P); |
| end if; |
| end Notepad; |
| |
| begin |
| Open (F, In_File, File_Name); |
| end Sample.Explanation; |
