summaryrefslogtreecommitdiff
path: root/ncurses-5.3/Ada95/samples/ncurses2-m.adb
diff options
context:
space:
mode:
Diffstat (limited to 'ncurses-5.3/Ada95/samples/ncurses2-m.adb')
-rw-r--r--ncurses-5.3/Ada95/samples/ncurses2-m.adb460
1 files changed, 0 insertions, 460 deletions
diff --git a/ncurses-5.3/Ada95/samples/ncurses2-m.adb b/ncurses-5.3/Ada95/samples/ncurses2-m.adb
deleted file mode 100644
index 5506f91..0000000
--- a/ncurses-5.3/Ada95/samples/ncurses2-m.adb
+++ /dev/null
@@ -1,460 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT ncurses Binding Samples --
--- --
--- ncurses --
--- --
--- B O D Y --
--- --
-------------------------------------------------------------------------------
--- Copyright (c) 2000 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 <aldomel@ix.netcom.com> 2000
--- Version Control
--- $Revision$
--- 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.
- type stringa is access String;
- 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 Integer (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;
-
-
-
-
-
-
-
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-07 04:41:01 +0000