mirror of
https://github.com/Aigor44/ncursesw-morphos.git
synced 2024-12-21 07:39:06 +08:00
746490c7ab
+ build-fixes for gcc8. + correct order of WINDOW._ttytype versus WINDOW._windowlist in report_offsets. + fix a case where tiparm could return null if the format-string was empty (Debian #902630).
712 lines
26 KiB
Ada
712 lines
26 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT ncurses Binding Samples --
|
|
-- --
|
|
-- ncurses --
|
|
-- --
|
|
-- B O D Y --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
-- Copyright (c) 2000-2011,2018 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: 1.12 $
|
|
-- $Date: 2018/07/07 23:31:55 $
|
|
-- Binding Version 01.00
|
|
------------------------------------------------------------------------------
|
|
-- Windows and scrolling tester.
|
|
-- Demonstrate windows
|
|
|
|
with Ada.Strings.Fixed;
|
|
with Ada.Strings;
|
|
|
|
with ncurses2.util; use ncurses2.util;
|
|
with ncurses2.genericPuts;
|
|
with Terminal_Interface.Curses; use Terminal_Interface.Curses;
|
|
with Terminal_Interface.Curses.Mouse; use Terminal_Interface.Curses.Mouse;
|
|
with Terminal_Interface.Curses.PutWin; use Terminal_Interface.Curses.PutWin;
|
|
|
|
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
|
|
with Ada.Streams; use Ada.Streams;
|
|
|
|
procedure ncurses2.acs_and_scroll is
|
|
|
|
Macro_Quit : constant Key_Code := Character'Pos ('Q') mod 16#20#;
|
|
Macro_Escape : constant Key_Code := Character'Pos ('[') mod 16#20#;
|
|
|
|
Quit : constant Key_Code := CTRL ('Q');
|
|
Escape : constant Key_Code := CTRL ('[');
|
|
|
|
Botlines : constant Line_Position := 4;
|
|
|
|
type pair is record
|
|
y : Line_Position;
|
|
x : Column_Position;
|
|
end record;
|
|
|
|
type Frame;
|
|
type FrameA is access Frame;
|
|
|
|
f : File_Type;
|
|
dumpfile : constant String := "screendump";
|
|
|
|
procedure Outerbox (ul, lr : pair; onoff : Boolean);
|
|
function HaveKeyPad (w : Window) return Boolean;
|
|
function HaveScroll (w : Window) return Boolean;
|
|
procedure newwin_legend (curpw : Window);
|
|
procedure transient (curpw : Window; msg : String);
|
|
procedure newwin_report (win : Window := Standard_Window);
|
|
procedure selectcell (uli : Line_Position;
|
|
ulj : Column_Position;
|
|
lri : Line_Position;
|
|
lrj : Column_Position;
|
|
p : out pair;
|
|
b : out Boolean);
|
|
function getwindow return Window;
|
|
procedure newwin_move (win : Window;
|
|
dy : Line_Position;
|
|
dx : Column_Position);
|
|
function delete_framed (fp : FrameA; showit : Boolean) return FrameA;
|
|
|
|
-- A linked list
|
|
-- I wish there was a standard library linked list. Oh well.
|
|
type Frame is record
|
|
next, last : FrameA;
|
|
do_scroll : Boolean;
|
|
do_keypad : Boolean;
|
|
wind : Window;
|
|
end record;
|
|
|
|
current : FrameA;
|
|
|
|
c : Key_Code;
|
|
|
|
procedure Outerbox (ul, lr : pair; onoff : Boolean) is
|
|
begin
|
|
if onoff then
|
|
-- Note the fix of an obscure bug
|
|
-- try making a 1x1 box then enlarging it, the is a blank
|
|
-- upper left corner!
|
|
Add (Line => ul.y - 1, Column => ul.x - 1,
|
|
Ch => ACS_Map (ACS_Upper_Left_Corner));
|
|
Add (Line => ul.y - 1, Column => lr.x + 1,
|
|
Ch => ACS_Map (ACS_Upper_Right_Corner));
|
|
Add (Line => lr.y + 1, Column => lr.x + 1,
|
|
Ch => ACS_Map (ACS_Lower_Right_Corner));
|
|
Add (Line => lr.y + 1, Column => ul.x - 1,
|
|
Ch => ACS_Map (ACS_Lower_Left_Corner));
|
|
|
|
Move_Cursor (Line => ul.y - 1, Column => ul.x);
|
|
Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
|
|
Line_Size => Integer (lr.x - ul.x) + 1);
|
|
Move_Cursor (Line => ul.y, Column => ul.x - 1);
|
|
Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
|
|
Line_Size => Integer (lr.y - ul.y) + 1);
|
|
Move_Cursor (Line => lr.y + 1, Column => ul.x);
|
|
Horizontal_Line (Line_Symbol => ACS_Map (ACS_Horizontal_Line),
|
|
Line_Size => Integer (lr.x - ul.x) + 1);
|
|
Move_Cursor (Line => ul.y, Column => lr.x + 1);
|
|
Vertical_Line (Line_Symbol => ACS_Map (ACS_Vertical_Line),
|
|
Line_Size => Integer (lr.y - ul.y) + 1);
|
|
else
|
|
Add (Line => ul.y - 1, Column => ul.x - 1, Ch => ' ');
|
|
Add (Line => ul.y - 1, Column => lr.x + 1, Ch => ' ');
|
|
Add (Line => lr.y + 1, Column => lr.x + 1, Ch => ' ');
|
|
Add (Line => lr.y + 1, Column => ul.x - 1, Ch => ' ');
|
|
|
|
Move_Cursor (Line => ul.y - 1, Column => ul.x);
|
|
Horizontal_Line (Line_Symbol => Blank2,
|
|
Line_Size => Integer (lr.x - ul.x) + 1);
|
|
Move_Cursor (Line => ul.y, Column => ul.x - 1);
|
|
Vertical_Line (Line_Symbol => Blank2,
|
|
Line_Size => Integer (lr.y - ul.y) + 1);
|
|
Move_Cursor (Line => lr.y + 1, Column => ul.x);
|
|
Horizontal_Line (Line_Symbol => Blank2,
|
|
Line_Size => Integer (lr.x - ul.x) + 1);
|
|
Move_Cursor (Line => ul.y, Column => lr.x + 1);
|
|
Vertical_Line (Line_Symbol => Blank2,
|
|
Line_Size => Integer (lr.y - ul.y) + 1);
|
|
end if;
|
|
end Outerbox;
|
|
|
|
function HaveKeyPad (w : Window) return Boolean is
|
|
begin
|
|
return Get_KeyPad_Mode (w);
|
|
exception
|
|
when Curses_Exception => return False;
|
|
end HaveKeyPad;
|
|
|
|
function HaveScroll (w : Window) return Boolean is
|
|
begin
|
|
return Scrolling_Allowed (w);
|
|
exception
|
|
when Curses_Exception => return False;
|
|
end HaveScroll;
|
|
|
|
procedure newwin_legend (curpw : Window) is
|
|
|
|
package p is new genericPuts (200);
|
|
use p;
|
|
use p.BS;
|
|
|
|
type string_a is access String;
|
|
|
|
type rrr is record
|
|
msg : string_a;
|
|
code : Integer range 0 .. 3;
|
|
end record;
|
|
|
|
legend : constant array (Positive range <>) of rrr :=
|
|
(
|
|
(
|
|
new String'("^C = create window"), 0
|
|
),
|
|
(
|
|
new String'("^N = next window"), 0
|
|
),
|
|
(
|
|
new String'("^P = previous window"), 0
|
|
),
|
|
(
|
|
new String'("^F = scroll forward"), 0
|
|
),
|
|
(
|
|
new String'("^B = scroll backward"), 0
|
|
),
|
|
(
|
|
new String'("^K = keypad(%s)"), 1
|
|
),
|
|
(
|
|
new String'("^S = scrollok(%s)"), 2
|
|
),
|
|
(
|
|
new String'("^W = save window to file"), 0
|
|
),
|
|
(
|
|
new String'("^R = restore window"), 0
|
|
),
|
|
(
|
|
new String'("^X = resize"), 0
|
|
),
|
|
(
|
|
new String'("^Q%s = exit"), 3
|
|
)
|
|
);
|
|
|
|
buf : Bounded_String;
|
|
do_keypad : constant Boolean := HaveKeyPad (curpw);
|
|
do_scroll : constant Boolean := HaveScroll (curpw);
|
|
|
|
pos : Natural;
|
|
|
|
mypair : pair;
|
|
|
|
begin
|
|
Move_Cursor (Line => Lines - 4, Column => 0);
|
|
for n in legend'Range loop
|
|
pos := Ada.Strings.Fixed.Index (Source => legend (n).msg.all,
|
|
Pattern => "%s");
|
|
buf := To_Bounded_String (legend (n).msg.all);
|
|
case legend (n).code is
|
|
when 0 => null;
|
|
when 1 =>
|
|
if do_keypad then
|
|
Replace_Slice (buf, pos, pos + 1, "yes");
|
|
else
|
|
Replace_Slice (buf, pos, pos + 1, "no");
|
|
end if;
|
|
when 2 =>
|
|
if do_scroll then
|
|
Replace_Slice (buf, pos, pos + 1, "yes");
|
|
else
|
|
Replace_Slice (buf, pos, pos + 1, "no");
|
|
end if;
|
|
when 3 =>
|
|
if do_keypad then
|
|
Replace_Slice (buf, pos, pos + 1, "/ESC");
|
|
else
|
|
Replace_Slice (buf, pos, pos + 1, "");
|
|
end if;
|
|
end case;
|
|
Get_Cursor_Position (Line => mypair.y, Column => mypair.x);
|
|
if Columns < mypair.x + 3 + Column_Position (Length (buf)) then
|
|
Add (Ch => newl);
|
|
elsif n /= 1 then -- n /= legen'First
|
|
Add (Str => ", ");
|
|
end if;
|
|
myAdd (Str => buf);
|
|
end loop;
|
|
Clear_To_End_Of_Line;
|
|
end newwin_legend;
|
|
|
|
procedure transient (curpw : Window; msg : String) is
|
|
begin
|
|
newwin_legend (curpw);
|
|
if msg /= "" then
|
|
Add (Line => Lines - 1, Column => 0, Str => msg);
|
|
Refresh;
|
|
Nap_Milli_Seconds (1000);
|
|
end if;
|
|
|
|
Move_Cursor (Line => Lines - 1, Column => 0);
|
|
|
|
if HaveKeyPad (curpw) then
|
|
Add (Str => "Non-arrow");
|
|
else
|
|
Add (Str => "All other");
|
|
end if;
|
|
Add (Str => " characters are echoed, window should ");
|
|
if not HaveScroll (curpw) then
|
|
Add (Str => "not ");
|
|
end if;
|
|
Add (Str => "scroll");
|
|
|
|
Clear_To_End_Of_Line;
|
|
end transient;
|
|
|
|
procedure newwin_report (win : Window := Standard_Window) is
|
|
y : Line_Position;
|
|
x : Column_Position;
|
|
use Int_IO;
|
|
tmp2a : String (1 .. 2);
|
|
tmp2b : String (1 .. 2);
|
|
begin
|
|
if win /= Standard_Window then
|
|
transient (win, "");
|
|
end if;
|
|
Get_Cursor_Position (win, y, x);
|
|
Move_Cursor (Line => Lines - 1, Column => Columns - 17);
|
|
Put (tmp2a, Integer (y));
|
|
Put (tmp2b, Integer (x));
|
|
Add (Str => "Y = " & tmp2a & " X = " & tmp2b);
|
|
if win /= Standard_Window then
|
|
Refresh;
|
|
else
|
|
Move_Cursor (win, y, x);
|
|
end if;
|
|
end newwin_report;
|
|
|
|
procedure selectcell (uli : Line_Position;
|
|
ulj : Column_Position;
|
|
lri : Line_Position;
|
|
lrj : Column_Position;
|
|
p : out pair;
|
|
b : out Boolean) is
|
|
c : Key_Code;
|
|
res : pair;
|
|
i : Line_Position := 0;
|
|
j : Column_Position := 0;
|
|
si : constant Line_Position := lri - uli + 1;
|
|
sj : constant Column_Position := lrj - ulj + 1;
|
|
begin
|
|
res.y := uli;
|
|
res.x := ulj;
|
|
loop
|
|
Move_Cursor (Line => uli + i, Column => ulj + j);
|
|
newwin_report;
|
|
|
|
c := Getchar;
|
|
case c is
|
|
when
|
|
Macro_Quit |
|
|
Macro_Escape =>
|
|
-- on the same line macro calls interfere due to the # comment
|
|
-- this is needed because keypad off affects all windows.
|
|
-- try removing the ESCAPE and see what happens.
|
|
b := False;
|
|
return;
|
|
when KEY_UP =>
|
|
i := i + si - 1;
|
|
-- same as i := i - 1 because of Modulus arithmetic,
|
|
-- on Line_Position, which is a Natural
|
|
-- the C version uses this form too, interestingly.
|
|
when KEY_DOWN =>
|
|
i := i + 1;
|
|
when KEY_LEFT =>
|
|
j := j + sj - 1;
|
|
when KEY_RIGHT =>
|
|
j := j + 1;
|
|
when Key_Mouse =>
|
|
declare
|
|
event : Mouse_Event;
|
|
y : Line_Position;
|
|
x : Column_Position;
|
|
Button : Mouse_Button;
|
|
State : Button_State;
|
|
|
|
begin
|
|
event := Get_Mouse;
|
|
Get_Event (Event => event,
|
|
Y => y,
|
|
X => x,
|
|
Button => Button,
|
|
State => State);
|
|
if y > uli and x > ulj then
|
|
i := y - uli;
|
|
j := x - ulj;
|
|
-- same as when others =>
|
|
res.y := uli + i;
|
|
res.x := ulj + j;
|
|
p := res;
|
|
b := True;
|
|
return;
|
|
else
|
|
Beep;
|
|
end if;
|
|
end;
|
|
when others =>
|
|
res.y := uli + i;
|
|
res.x := ulj + j;
|
|
p := res;
|
|
b := True;
|
|
return;
|
|
end case;
|
|
i := i mod si;
|
|
j := j mod sj;
|
|
end loop;
|
|
end selectcell;
|
|
|
|
function getwindow return Window is
|
|
rwindow : Window;
|
|
ul, lr : pair;
|
|
result : Boolean;
|
|
begin
|
|
Move_Cursor (Line => 0, Column => 0);
|
|
Clear_To_End_Of_Line;
|
|
Add (Str => "Use arrows to move cursor, anything else to mark corner 1");
|
|
Refresh;
|
|
selectcell (2, 1, Lines - Botlines - 2, Columns - 2, ul, result);
|
|
if not result then
|
|
return Null_Window;
|
|
end if;
|
|
Add (Line => ul.y - 1, Column => ul.x - 1,
|
|
Ch => ACS_Map (ACS_Upper_Left_Corner));
|
|
Move_Cursor (Line => 0, Column => 0);
|
|
Clear_To_End_Of_Line;
|
|
Add (Str => "Use arrows to move cursor, anything else to mark corner 2");
|
|
Refresh;
|
|
selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2, lr, result);
|
|
if not result then
|
|
return Null_Window;
|
|
end if;
|
|
|
|
rwindow := Sub_Window (Number_Of_Lines => lr.y - ul.y + 1,
|
|
Number_Of_Columns => lr.x - ul.x + 1,
|
|
First_Line_Position => ul.y,
|
|
First_Column_Position => ul.x);
|
|
|
|
Outerbox (ul, lr, True);
|
|
Refresh;
|
|
|
|
Refresh (rwindow);
|
|
|
|
Move_Cursor (Line => 0, Column => 0);
|
|
Clear_To_End_Of_Line;
|
|
return rwindow;
|
|
end getwindow;
|
|
|
|
procedure newwin_move (win : Window;
|
|
dy : Line_Position;
|
|
dx : Column_Position) is
|
|
cur_y, max_y : Line_Position;
|
|
cur_x, max_x : Column_Position;
|
|
begin
|
|
Get_Cursor_Position (win, cur_y, cur_x);
|
|
Get_Size (win, max_y, max_x);
|
|
cur_x := Column_Position'Min (Column_Position'Max (cur_x + dx, 0),
|
|
max_x - 1);
|
|
cur_y := Line_Position'Min (Line_Position'Max (cur_y + dy, 0),
|
|
max_y - 1);
|
|
|
|
Move_Cursor (win, Line => cur_y, Column => cur_x);
|
|
end newwin_move;
|
|
|
|
function delete_framed (fp : FrameA; showit : Boolean) return FrameA is
|
|
np : FrameA;
|
|
begin
|
|
fp.all.last.all.next := fp.all.next;
|
|
fp.all.next.all.last := fp.all.last;
|
|
|
|
if showit then
|
|
Erase (fp.all.wind);
|
|
Refresh (fp.all.wind);
|
|
end if;
|
|
Delete (fp.all.wind);
|
|
|
|
if fp = fp.all.next then
|
|
np := null;
|
|
else
|
|
np := fp.all.next;
|
|
end if;
|
|
-- TODO free(fp);
|
|
return np;
|
|
end delete_framed;
|
|
|
|
Mask : Event_Mask := No_Events;
|
|
Mask2 : Event_Mask;
|
|
|
|
usescr : Window;
|
|
|
|
begin
|
|
if Has_Mouse then
|
|
Register_Reportable_Event (
|
|
Button => Left,
|
|
State => Clicked,
|
|
Mask => Mask);
|
|
Mask2 := Start_Mouse (Mask);
|
|
end if;
|
|
c := CTRL ('C');
|
|
Set_Raw_Mode (SwitchOn => True);
|
|
loop
|
|
transient (Standard_Window, "");
|
|
case c is
|
|
when Character'Pos ('c') mod 16#20# => -- Ctrl('c')
|
|
declare
|
|
neww : constant FrameA := new Frame'(null, null,
|
|
False, False,
|
|
Null_Window);
|
|
begin
|
|
neww.all.wind := getwindow;
|
|
if neww.all.wind = Null_Window then
|
|
exit;
|
|
-- was goto breakout; ha ha ha
|
|
else
|
|
|
|
if current = null then
|
|
neww.all.next := neww;
|
|
neww.all.last := neww;
|
|
else
|
|
neww.all.next := current.all.next;
|
|
neww.all.last := current;
|
|
neww.all.last.all.next := neww;
|
|
neww.all.next.all.last := neww;
|
|
end if;
|
|
current := neww;
|
|
|
|
Set_KeyPad_Mode (current.all.wind, True);
|
|
current.all.do_keypad := HaveKeyPad (current.all.wind);
|
|
current.all.do_scroll := HaveScroll (current.all.wind);
|
|
end if;
|
|
end;
|
|
when Character'Pos ('N') mod 16#20# => -- Ctrl('N')
|
|
if current /= null then
|
|
current := current.all.next;
|
|
end if;
|
|
when Character'Pos ('P') mod 16#20# => -- Ctrl('P')
|
|
if current /= null then
|
|
current := current.all.last;
|
|
end if;
|
|
when Character'Pos ('F') mod 16#20# => -- Ctrl('F')
|
|
if current /= null and then HaveScroll (current.all.wind) then
|
|
Scroll (current.all.wind, 1);
|
|
end if;
|
|
when Character'Pos ('B') mod 16#20# => -- Ctrl('B')
|
|
if current /= null and then HaveScroll (current.all.wind) then
|
|
-- The C version of Scroll may return ERR which is ignored
|
|
-- we need to avoid the exception
|
|
-- with the 'and HaveScroll(current.wind)'
|
|
Scroll (current.all.wind, -1);
|
|
end if;
|
|
when Character'Pos ('K') mod 16#20# => -- Ctrl('K')
|
|
if current /= null then
|
|
current.all.do_keypad := not current.all.do_keypad;
|
|
Set_KeyPad_Mode (current.all.wind, current.all.do_keypad);
|
|
end if;
|
|
when Character'Pos ('S') mod 16#20# => -- Ctrl('S')
|
|
if current /= null then
|
|
current.all.do_scroll := not current.all.do_scroll;
|
|
Allow_Scrolling (current.all.wind, current.all.do_scroll);
|
|
end if;
|
|
when Character'Pos ('W') mod 16#20# => -- Ctrl('W')
|
|
if current /= current.all.next then
|
|
Create (f, Name => dumpfile); -- TODO error checking
|
|
if not Is_Open (f) then
|
|
raise Curses_Exception;
|
|
end if;
|
|
Put_Window (current.all.wind, f);
|
|
Close (f);
|
|
current := delete_framed (current, True);
|
|
end if;
|
|
when Character'Pos ('R') mod 16#20# => -- Ctrl('R')
|
|
declare
|
|
neww : FrameA := new Frame'(null, null, False, False,
|
|
Null_Window);
|
|
begin
|
|
Open (f, Mode => In_File, Name => dumpfile);
|
|
neww := new Frame'(null, null, False, False, Null_Window);
|
|
|
|
neww.all.next := current.all.next;
|
|
neww.all.last := current;
|
|
neww.all.last.all.next := neww;
|
|
neww.all.next.all.last := neww;
|
|
|
|
neww.all.wind := Get_Window (f);
|
|
Close (f);
|
|
|
|
Refresh (neww.all.wind);
|
|
end;
|
|
when Character'Pos ('X') mod 16#20# => -- Ctrl('X')
|
|
if current /= null then
|
|
declare
|
|
tmp, ul, lr : pair;
|
|
mx : Column_Position;
|
|
my : Line_Position;
|
|
tmpbool : Boolean;
|
|
begin
|
|
Move_Cursor (Line => 0, Column => 0);
|
|
Clear_To_End_Of_Line;
|
|
Add (Str => "Use arrows to move cursor, anything else " &
|
|
"to mark new corner");
|
|
Refresh;
|
|
|
|
Get_Window_Position (current.all.wind, ul.y, ul.x);
|
|
|
|
selectcell (ul.y, ul.x, Lines - Botlines - 2, Columns - 2,
|
|
tmp, tmpbool);
|
|
if not tmpbool then
|
|
-- the C version had a goto. I refuse gotos.
|
|
Beep;
|
|
else
|
|
Get_Size (current.all.wind, lr.y, lr.x);
|
|
lr.y := lr.y + ul.y - 1;
|
|
lr.x := lr.x + ul.x - 1;
|
|
Outerbox (ul, lr, False);
|
|
Refresh_Without_Update;
|
|
|
|
Get_Size (current.all.wind, my, mx);
|
|
if my > tmp.y - ul.y then
|
|
Get_Cursor_Position (current.all.wind, lr.y, lr.x);
|
|
Move_Cursor (current.all.wind, tmp.y - ul.y + 1, 0);
|
|
Clear_To_End_Of_Screen (current.all.wind);
|
|
Move_Cursor (current.all.wind, lr.y, lr.x);
|
|
end if;
|
|
if mx > tmp.x - ul.x then
|
|
for i in 0 .. my - 1 loop
|
|
Move_Cursor (current.all.wind, i, tmp.x - ul.x + 1);
|
|
Clear_To_End_Of_Line (current.all.wind);
|
|
end loop;
|
|
end if;
|
|
Refresh_Without_Update (current.all.wind);
|
|
|
|
lr := tmp;
|
|
-- The C version passes invalid args to resize
|
|
-- which returns an ERR. For Ada we avoid the exception.
|
|
if lr.y /= ul.y and lr.x /= ul.x then
|
|
Resize (current.all.wind, lr.y - ul.y + 0,
|
|
lr.x - ul.x + 0);
|
|
end if;
|
|
|
|
Get_Window_Position (current.all.wind, ul.y, ul.x);
|
|
Get_Size (current.all.wind, lr.y, lr.x);
|
|
lr.y := lr.y + ul.y - 1;
|
|
lr.x := lr.x + ul.x - 1;
|
|
Outerbox (ul, lr, True);
|
|
Refresh_Without_Update;
|
|
|
|
Refresh_Without_Update (current.all.wind);
|
|
Move_Cursor (Line => 0, Column => 0);
|
|
Clear_To_End_Of_Line;
|
|
Update_Screen;
|
|
end if;
|
|
end;
|
|
end if;
|
|
when Key_F10 =>
|
|
declare tmp : pair; tmpbool : Boolean;
|
|
begin
|
|
-- undocumented --- use this to test area clears
|
|
selectcell (0, 0, Lines - 1, Columns - 1, tmp, tmpbool);
|
|
Clear_To_End_Of_Screen;
|
|
Refresh;
|
|
end;
|
|
when Key_Cursor_Up =>
|
|
newwin_move (current.all.wind, -1, 0);
|
|
when Key_Cursor_Down =>
|
|
newwin_move (current.all.wind, 1, 0);
|
|
when Key_Cursor_Left =>
|
|
newwin_move (current.all.wind, 0, -1);
|
|
when Key_Cursor_Right =>
|
|
newwin_move (current.all.wind, 0, 1);
|
|
when Key_Backspace | Key_Delete_Char =>
|
|
declare
|
|
y : Line_Position;
|
|
x : Column_Position;
|
|
tmp : Line_Position;
|
|
begin
|
|
Get_Cursor_Position (current.all.wind, y, x);
|
|
-- x := x - 1;
|
|
-- I got tricked by the -1 = Max_Natural - 1 result
|
|
-- y := y - 1;
|
|
if not (x = 0 and y = 0) then
|
|
if x = 0 then
|
|
y := y - 1;
|
|
Get_Size (current.all.wind, tmp, x);
|
|
end if;
|
|
x := x - 1;
|
|
Delete_Character (current.all.wind, y, x);
|
|
end if;
|
|
end;
|
|
when others =>
|
|
-- TODO c = '\r' ?
|
|
if current /= null then
|
|
declare
|
|
begin
|
|
Add (current.all.wind, Ch => Code_To_Char (c));
|
|
exception
|
|
when Curses_Exception => null;
|
|
-- this happens if we are at the
|
|
-- lower right of a window and add a character.
|
|
end;
|
|
else
|
|
Beep;
|
|
end if;
|
|
end case;
|
|
newwin_report (current.all.wind);
|
|
if current /= null then
|
|
usescr := current.all.wind;
|
|
else
|
|
usescr := Standard_Window;
|
|
end if;
|
|
Refresh (usescr);
|
|
c := Getchar (usescr);
|
|
exit when c = Quit or (c = Escape and HaveKeyPad (usescr));
|
|
-- TODO when does c = ERR happen?
|
|
end loop;
|
|
|
|
-- TODO while current /= null loop
|
|
-- current := delete_framed(current, False);
|
|
-- end loop;
|
|
|
|
Allow_Scrolling (Mode => True);
|
|
|
|
End_Mouse (Mask2);
|
|
Set_Raw_Mode (SwitchOn => True);
|
|
Erase;
|
|
End_Windows;
|
|
|
|
end ncurses2.acs_and_scroll;
|