------------------------------------------------------------------------------ -- -- -- GNAT ncurses Binding Samples -- -- -- -- ncurses -- -- -- -- B O D Y -- -- -- ------------------------------------------------------------------------------ -- Copyright (c) 2000,2004 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: Eugene V. Melaragno 2000 -- Version Control -- $Revision$ -- $Date$ -- Binding Version 01.00 ------------------------------------------------------------------------------ -- TODO use Default_Character where appropriate -- This is an Ada version of ncurses -- I translated this because it tests the most features. with Terminal_Interface.Curses; use Terminal_Interface.Curses; with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace; with Ada.Text_IO; use Ada.Text_IO; with Ada.Characters.Latin_1; -- with Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Strings.Unbounded; with ncurses2.util; use ncurses2.util; with ncurses2.getch_test; with ncurses2.attr_test; with ncurses2.color_test; with ncurses2.demo_panels; with ncurses2.color_edit; with ncurses2.slk_test; with ncurses2.acs_display; with ncurses2.color_edit; with ncurses2.acs_and_scroll; with ncurses2.flushinp_test; with ncurses2.test_sgr_attributes; with ncurses2.menu_test; with ncurses2.demo_pad; with ncurses2.demo_forms; with ncurses2.overlap_test; with ncurses2.trace_set; with ncurses2.getopt; use ncurses2.getopt; package body ncurses2.m is use Int_IO; function To_trace (n : Integer) return Trace_Attribute_Set; procedure usage; procedure Set_Terminal_Modes; function Do_Single_Test (c : Character) return Boolean; function To_trace (n : Integer) return Trace_Attribute_Set is a : Trace_Attribute_Set := (others => False); m : Integer; rest : Integer; begin m := n mod 2; if 1 = m then a.Times := True; end if; rest := n / 2; m := rest mod 2; if 1 = m then a.Tputs := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Update := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Cursor_Move := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Character_Output := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Calls := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Virtual_Puts := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Input_Events := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.TTY_State := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Internal_Calls := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Character_Calls := True; end if; rest := rest / 2; m := rest mod 2; if 1 = m then a.Termcap_TermInfo := True; end if; return a; end To_trace; -- these are type Stdscr_Init_Proc; function rip_footer ( Win : Window; Columns : Column_Count) return Integer; pragma Convention (C, rip_footer); function rip_footer ( Win : Window; Columns : Column_Count) return Integer is begin Set_Background (Win, (Ch => ' ', Attr => (Reverse_Video => True, others => False), Color => 0)); Erase (Win); Move_Cursor (Win, 0, 0); Add (Win, "footer:" & Columns'Img & " columns"); Refresh_Without_Update (Win); return 0; -- Curses_OK; end rip_footer; function rip_header ( Win : Window; Columns : Column_Count) return Integer; pragma Convention (C, rip_header); function rip_header ( Win : Window; Columns : Column_Count) return Integer is begin Set_Background (Win, (Ch => ' ', Attr => (Reverse_Video => True, others => False), Color => 0)); Erase (Win); Move_Cursor (Win, 0, 0); Add (Win, "header:" & Columns'Img & " columns"); -- 'Img is a GNAT extention Refresh_Without_Update (Win); return 0; -- Curses_OK; end rip_header; procedure usage is -- type Stringa is access String; use Ada.Strings.Unbounded; -- tbl : constant array (Positive range <>) of Stringa := ( tbl : constant array (Positive range <>) of Unbounded_String := ( To_Unbounded_String ("Usage: ncurses [options]"), To_Unbounded_String (""), To_Unbounded_String ("Options:"), To_Unbounded_String (" -a f,b set default-colors " & "(assumed white-on-black)"), To_Unbounded_String (" -d use default-colors if terminal " & "supports them"), To_Unbounded_String (" -e fmt specify format for soft-keys " & "test (e)"), To_Unbounded_String (" -f rip-off footer line " & "(can repeat)"), To_Unbounded_String (" -h rip-off header line " & "(can repeat)"), To_Unbounded_String (" -s msec specify nominal time for " & "panel-demo (default: 1, to hold)"), To_Unbounded_String (" -t mask specify default trace-level " & "(may toggle with ^T)") ); begin for n in tbl'Range loop Put_Line (Standard_Error, To_String (tbl (n))); end loop; -- exit(EXIT_FAILURE); -- TODO should we use Set_Exit_Status and throw and exception? end usage; procedure Set_Terminal_Modes is begin Set_Raw_Mode (SwitchOn => False); Set_Cbreak_Mode (SwitchOn => True); Set_Echo_Mode (SwitchOn => False); Allow_Scrolling (Mode => True); Use_Insert_Delete_Line (Do_Idl => True); Set_KeyPad_Mode (SwitchOn => True); end Set_Terminal_Modes; nap_msec : Integer := 1; function Do_Single_Test (c : Character) return Boolean is begin case c is when 'a' => getch_test; when 'b' => attr_test; when 'c' => if not Has_Colors then Cannot ("does not support color."); else color_test; end if; when 'd' => if not Has_Colors then Cannot ("does not support color."); elsif not Can_Change_Color then Cannot ("has hardwired color values."); else color_edit; end if; when 'e' => slk_test; when 'f' => acs_display; when 'o' => demo_panels (nap_msec); when 'g' => acs_and_scroll; when 'i' => flushinp_test (Standard_Window); when 'k' => test_sgr_attributes; when 'm' => menu_test; when 'p' => demo_pad; when 'r' => demo_forms; when 's' => overlap_test; when 't' => trace_set; when '?' => null; when others => return False; end case; return True; end Do_Single_Test; command : Character; my_e_param : Soft_Label_Key_Format := Four_Four; assumed_colors : Boolean := False; default_colors : Boolean := False; default_fg : Color_Number := White; default_bg : Color_Number := Black; -- nap_msec was an unsigned long integer in the C version, -- yet napms only takes an int! c : Integer; c2 : Character; optind : Integer := 1; -- must be initialized to one. optarg : getopt.stringa; length : Integer; tmpi : Integer; package myio is new Ada.Text_IO.Integer_IO (Integer); use myio; save_trace : Integer := 0; save_trace_set : Trace_Attribute_Set; function main return Integer is begin loop Qgetopt (c, Argument_Count, Argument'Access, "a:de:fhs:t:", optind, optarg); exit when c = -1; c2 := Character'Val (c); case c2 is when 'a' => -- Ada doesn't have scanf, it doesn't even have a -- regular expression library. assumed_colors := True; myio.Get (optarg.all, Integer (default_fg), length); myio.Get (optarg.all (length + 2 .. optarg.all'Length), Integer (default_bg), length); when 'd' => default_colors := True; when 'e' => myio.Get (optarg.all, tmpi, length); if tmpi > 3 then usage; return 1; end if; my_e_param := Soft_Label_Key_Format'Val (tmpi); when 'f' => Rip_Off_Lines (-1, rip_footer'Access); when 'h' => Rip_Off_Lines (1, rip_header'Access); when 's' => myio.Get (optarg.all, nap_msec, length); when 't' => myio.Get (optarg.all, save_trace, length); when others => usage; return 1; end case; end loop; -- the C version had a bunch of macros here. -- if (!isatty(fileno(stdin))) -- isatty is not available in the standard Ada so skip it. save_trace_set := To_trace (save_trace); Trace_On (save_trace_set); Init_Soft_Label_Keys (my_e_param); Init_Screen; Set_Background (Ch => (Ch => Blank, Attr => Normal_Video, Color => Color_Pair'First)); if Has_Colors then Start_Color; if default_colors then Use_Default_Colors; elsif assumed_colors then Assume_Default_Colors (default_fg, default_bg); end if; end if; Set_Terminal_Modes; Save_Curses_Mode (Curses); End_Windows; -- TODO add macro #if blocks. Put_Line ("Welcome to " & Curses_Version & ". Press ? for help."); loop Put_Line ("This is the ncurses main menu"); Put_Line ("a = keyboard and mouse input test"); Put_Line ("b = character attribute test"); Put_Line ("c = color test pattern"); Put_Line ("d = edit RGB color values"); Put_Line ("e = exercise soft keys"); Put_Line ("f = display ACS characters"); Put_Line ("g = display windows and scrolling"); Put_Line ("i = test of flushinp()"); Put_Line ("k = display character attributes"); Put_Line ("m = menu code test"); Put_Line ("o = exercise panels library"); Put_Line ("p = exercise pad features"); Put_Line ("q = quit"); Put_Line ("r = exercise forms code"); Put_Line ("s = overlapping-refresh test"); Put_Line ("t = set trace level"); Put_Line ("? = repeat this command summary"); Put ("> "); Flush; command := Ada.Characters.Latin_1.NUL; -- get_input: -- loop declare Ch : Character; begin Get (Ch); -- TODO if read(ch) <= 0 -- TODO ada doesn't have an Is_Space function command := Ch; -- TODO if ch = '\n' or '\r' are these in Ada? end; -- end loop get_input; declare begin if Do_Single_Test (command) then Flush_Input; Set_Terminal_Modes; Reset_Curses_Mode (Curses); Clear; Refresh; End_Windows; if command = '?' then Put_Line ("This is the ncurses capability tester."); Put_Line ("You may select a test from the main menu by " & "typing the"); Put_Line ("key letter of the choice (the letter to left " & "of the =)"); Put_Line ("at the > prompt. The commands `x' or `q' will " & "exit."); end if; -- continue; --why continue in the C version? end if; exception when Curses_Exception => End_Windows; end; exit when command = 'q'; end loop; return 0; -- TODO ExitProgram(EXIT_SUCCESS); end main; end ncurses2.m;