release/src/router/libncurses/Ada95/samples/sample-explanation.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                       GNAT ncurses Binding Samples                       --
   4 --                                                                          --
   5 --                           Sample.Explanation                             --
   6 --                                                                          --
   7 --                                 B O D Y                                  --
   8 --                                                                          --
   9 ------------------------------------------------------------------------------
  10 -- Copyright (c) 1998-2011,2014 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.27 $
  39 --  $Date: 2014/09/13 19:10:18 $
  40 --  Binding Version 01.00
  41 ------------------------------------------------------------------------------
  42 --  Poor mans help system. This scans a sequential file for key lines and
  43 --  then reads the lines up to the next key. Those lines are presented in
  44 --  a window as help or explanation.
  45 --
  46 with Ada.Text_IO; use Ada.Text_IO;
  47 with Ada.Unchecked_Deallocation;
  48 with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  49 with Terminal_Interface.Curses.Panels; use Terminal_Interface.Curses.Panels;
  50
  51 with Sample.Keyboard_Handler; use Sample.Keyboard_Handler;
  52 with Sample.Manifest; use Sample.Manifest;
  53 with Sample.Function_Key_Setting; use Sample.Function_Key_Setting;
  54 with Sample.Helpers; use Sample.Helpers;
  55
  56 package body Sample.Explanation is
  57
  58    Help_Keys : constant String := "HELPKEYS";
  59    In_Help   : constant String := "INHELP";
  60
  61    File_Name : constant String := "explain.txt";
  62    F : File_Type;
  63
  64    type Help_Line;
  65    type Help_Line_Access is access Help_Line;
  66    pragma Controlled (Help_Line_Access);
  67    type String_Access is access String;
  68    pragma Controlled (String_Access);
  69
  70    type Help_Line is
  71       record
  72          Prev, Next : Help_Line_Access;
  73          Line : String_Access;
  74       end record;
  75
  76    procedure Explain (Key : String;
  77                       Win : Window);
  78
  79    procedure Release_String is
  80      new Ada.Unchecked_Deallocation (String,
  81                                      String_Access);
  82    procedure Release_Help_Line is
  83      new Ada.Unchecked_Deallocation (Help_Line,
  84                                      Help_Line_Access);
  85
  86    function Search (Key : String) return Help_Line_Access;
  87    procedure Release_Help (Root : in out Help_Line_Access);
  88
  89    function Check_File (Name : String) return Boolean;
  90
  91    procedure Explain (Key : String)
  92    is
  93    begin
  94       Explain (Key, Null_Window);
  95    end Explain;
  96
  97    procedure Explain (Key : String;
  98                       Win : Window)
  99    is
 100       --  Retrieve the text associated with this key and display it in this
 101       --  window. If no window argument is passed, the routine will create
 102       --  a temporary window and use it.
 103
 104       function Filter_Key return Real_Key_Code;
 105       procedure Unknown_Key;
 106       procedure Redo;
 107       procedure To_Window (C   : in out Help_Line_Access;
 108                           More : in out Boolean);
 109
 110       Frame : Window := Null_Window;
 111
 112       W : Window := Win;
 113       K : Real_Key_Code;
 114       P : Panel;
 115
 116       Height   : Line_Count;
 117       Width    : Column_Count;
 118       Help     : Help_Line_Access := Search (Key);
 119       Current  : Help_Line_Access;
 120       Top_Line : Help_Line_Access;
 121
 122       Has_More : Boolean := True;
 123
 124       procedure Unknown_Key
 125       is
 126       begin
 127          Add (W, "Help message with ID ");
 128          Add (W, Key);
 129          Add (W, " not found.");
 130          Add (W, Character'Val (10));
 131          Add (W, "Press the Function key labeled 'Quit' key to continue.");
 132       end Unknown_Key;
 133
 134       procedure Redo
 135       is
 136          H : Help_Line_Access := Top_Line;
 137       begin
 138          if Top_Line /= null then
 139             for L in 0 .. (Height - 1) loop
 140                Add (W, L, 0, H.all.Line.all);
 141                exit when H.all.Next = null;
 142                H := H.all.Next;
 143             end loop;
 144          else
 145             Unknown_Key;
 146          end if;
 147       end Redo;
 148
 149       function Filter_Key return Real_Key_Code
 150       is
 151          K : Real_Key_Code;
 152       begin
 153          loop
 154             K := Get_Key (W);
 155             if K in Special_Key_Code'Range then
 156                case K is
 157                   when HELP_CODE =>
 158                      if not Find_Context (In_Help) then
 159                         Push_Environment (In_Help, False);
 160                         Explain (In_Help, W);
 161                         Pop_Environment;
 162                         Redo;
 163                      end if;
 164                   when EXPLAIN_CODE =>
 165                      if not Find_Context (Help_Keys) then
 166                         Push_Environment (Help_Keys, False);
 167                         Explain (Help_Keys, W);
 168                         Pop_Environment;
 169                         Redo;
 170                      end if;
 171                   when others => exit;
 172                end case;
 173             else
 174                exit;
 175             end if;
 176          end loop;
 177          return K;
 178       end Filter_Key;
 179
 180       procedure To_Window (C   : in out Help_Line_Access;
 181                           More : in out Boolean)
 182       is
 183          L : Line_Position := 0;
 184       begin
 185          loop
 186             Add (W, L, 0, C.all.Line.all);
 187             L := L + 1;
 188             exit when C.all.Next = null or else L = Height;
 189             C := C.all.Next;
 190          end loop;
 191          if C.all.Next /= null then
 192             pragma Assert (L = Height);
 193             More := True;
 194          else
 195             More := False;
 196          end if;
 197       end To_Window;
 198
 199    begin
 200       if W = Null_Window then
 201          Push_Environment ("HELP");
 202          Default_Labels;
 203          Frame := New_Window (Lines - 2, Columns, 0, 0);
 204          if Has_Colors then
 205             Set_Background (Win => Frame,
 206                             Ch  => (Ch    => ' ',
 207                                     Color => Help_Color,
 208                                     Attr  => Normal_Video));
 209             Set_Character_Attributes (Win   => Frame,
 210                                       Attr  => Normal_Video,
 211                                       Color => Help_Color);
 212             Erase (Frame);
 213          end if;
 214          Box (Frame);
 215          Set_Character_Attributes (Frame, (Reverse_Video => True,
 216                                            others        => False));
 217          Add (Frame, Lines - 3, 2, "Cursor Up/Down scrolls");
 218          Set_Character_Attributes (Frame); -- Back to default.
 219          Window_Title (Frame, "Explanation");
 220          W := Derived_Window (Frame, Lines - 4, Columns - 2, 1, 1);
 221          Refresh_Without_Update (Frame);
 222          Get_Size (W, Height, Width);
 223          Set_Meta_Mode (W);
 224          Set_KeyPad_Mode (W);
 225          Allow_Scrolling (W, True);
 226          Set_Echo_Mode (False);
 227          P := Create (Frame);
 228          Top (P);
 229          Update_Panels;
 230       else
 231          Clear (W);
 232          Refresh_Without_Update (W);
 233       end if;
 234
 235       Current := Help; Top_Line := Help;
 236
 237       if null = Help then
 238          Unknown_Key;
 239          loop
 240             K := Filter_Key;
 241             exit when K = QUIT_CODE;
 242          end loop;
 243       else
 244          To_Window (Current, Has_More);
 245          if Has_More then
 246             --  This means there are more lines available, so we have to go
 247             --  into a scroll manager.
 248             loop
 249                K := Filter_Key;
 250                if K in Special_Key_Code'Range then
 251                   case K is
 252                      when Key_Cursor_Down =>
 253                         if Current.all.Next /= null then
 254                            Move_Cursor (W, Height - 1, 0);
 255                            Scroll (W, 1);
 256                            Current := Current.all.Next;
 257                            Top_Line := Top_Line.all.Next;
 258                            Add (W, Current.all.Line.all);
 259                         end if;
 260                      when Key_Cursor_Up =>
 261                         if Top_Line.all.Prev /= null then
 262                            Move_Cursor (W, 0, 0);
 263                            Scroll (W, -1);
 264                            Top_Line := Top_Line.all.Prev;
 265                            Current := Current.all.Prev;
 266                            Add (W, Top_Line.all.Line.all);
 267                         end if;
 268                      when QUIT_CODE => exit;
 269                         when others => null;
 270                   end case;
 271                end if;
 272             end loop;
 273          else
 274             loop
 275                K := Filter_Key;
 276                exit when K = QUIT_CODE;
 277             end loop;
 278          end if;
 279       end if;
 280
 281       Clear (W);
 282
 283       if Frame /= Null_Window then
 284          Clear (Frame);
 285          Delete (P);
 286          Delete (W);
 287          Delete (Frame);
 288          Pop_Environment;
 289       end if;
 290
 291       Update_Panels;
 292       Update_Screen;
 293
 294       Release_Help (Help);
 295
 296    end Explain;
 297
 298    function Search (Key : String) return Help_Line_Access
 299    is
 300       Last    : Natural;
 301       Buffer  : String (1 .. 256);
 302       Root    : Help_Line_Access := null;
 303       Current : Help_Line_Access;
 304       Tail    : Help_Line_Access := null;
 305
 306       function Next_Line return Boolean;
 307
 308       function Next_Line return Boolean
 309       is
 310          H_End : constant String := "#END";
 311       begin
 312          Get_Line (F, Buffer, Last);
 313          if Last = H_End'Length and then H_End = Buffer (1 .. Last) then
 314             return False;
 315          else
 316             return True;
 317          end if;
 318       end Next_Line;
 319    begin
 320       Reset (F);
 321       Outer :
 322       loop
 323          exit Outer when not Next_Line;
 324          if Last = (1 + Key'Length)
 325            and then Key = Buffer (2 .. Last)
 326            and then Buffer (1) = '#'
 327          then
 328             loop
 329                exit when not Next_Line;
 330                exit when Buffer (1) = '#';
 331                Current := new Help_Line'(null, null,
 332                                          new String'(Buffer (1 .. Last)));
 333                if Tail = null then
 334                   Release_Help (Root);
 335                   Root := Current;
 336                else
 337                   Tail.all.Next := Current;
 338                   Current.all.Prev := Tail;
 339                end if;
 340                Tail := Current;
 341             end loop;
 342             exit Outer;
 343          end if;
 344       end loop Outer;
 345       return Root;
 346    end Search;
 347
 348    procedure Release_Help (Root : in out Help_Line_Access)
 349    is
 350       Next : Help_Line_Access;
 351    begin
 352       loop
 353          exit when Root = null;
 354          Next := Root.all.Next;
 355          Release_String (Root.all.Line);
 356          Release_Help_Line (Root);
 357          Root := Next;
 358       end loop;
 359    end Release_Help;
 360
 361    procedure Explain_Context
 362    is
 363    begin
 364       Explain (Context);
 365    end Explain_Context;
 366
 367    procedure Notepad (Key : String)
 368    is
 369       H : constant Help_Line_Access := Search (Key);
 370       T : Help_Line_Access := H;
 371       N : Line_Count := 1;
 372       L : Line_Position := 0;
 373       W : Window;
 374       P : Panel;
 375    begin
 376       if H /= null then
 377          loop
 378             T := T.all.Next;
 379             exit when T = null;
 380             N := N + 1;
 381          end loop;
 382          W := New_Window (N + 2, Columns, Lines - N - 2, 0);
 383          if Has_Colors then
 384             Set_Background (Win => W,
 385                             Ch  => (Ch    => ' ',
 386                                     Color => Notepad_Color,
 387                                     Attr  => Normal_Video));
 388             Set_Character_Attributes (Win   => W,
 389                                       Attr  => Normal_Video,
 390                                       Color => Notepad_Color);
 391             Erase (W);
 392          end if;
 393          Box (W);
 394          Window_Title (W, "Notepad");
 395          P := New_Panel (W);
 396          T := H;
 397          loop
 398             Add (W, L + 1, 1, T.all.Line.all, Integer (Columns - 2));
 399             L := L + 1;
 400             T := T.all.Next;
 401             exit when T = null;
 402          end loop;
 403          T := H;
 404          Release_Help (T);
 405          Refresh_Without_Update (W);
 406          Notepad_To_Context (P);
 407       end if;
 408    end Notepad;
 409
 410    function Check_File (Name : String) return Boolean is
 411       The_File : File_Type;
 412    begin
 413       Open (The_File, In_File, Name);
 414       Close (The_File);
 415       return True;
 416    exception
 417       when Name_Error =>
 418          return False;
 419    end Check_File;
 420
 421 begin
 422    if Check_File ("/usr/share/AdaCurses/" & File_Name) then
 423       Open (F, In_File, "/usr/share/AdaCurses/" & File_Name);
 424    elsif Check_File (File_Name) then
 425       Open (F, In_File, File_Name);
 426    else
 427       Put_Line (Standard_Error,
 428                 "The file explain.txt was not found in the current directory."
 429                 );
 430       raise Name_Error;
 431    end if;
 432 end Sample.Explanation;