ncurses 6.2 - patch 20200627
[ncurses.git] / Ada95 / src / terminal_interface-curses-text_io.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                           GNAT ncurses Binding                           --
4 --                                                                          --
5 --                     Terminal_Interface.Curses.Text_IO                    --
6 --                                                                          --
7 --                                 B O D Y                                  --
8 --                                                                          --
9 ------------------------------------------------------------------------------
10 -- Copyright 2020 Thomas E. Dickey                                          --
11 -- Copyright 1999-2011,2014 Free Software Foundation, Inc.                  --
12 --                                                                          --
13 -- Permission is hereby granted, free of charge, to any person obtaining a  --
14 -- copy of this software and associated documentation files (the            --
15 -- "Software"), to deal in the Software without restriction, including      --
16 -- without limitation the rights to use, copy, modify, merge, publish,      --
17 -- distribute, distribute with modifications, sublicense, and/or sell       --
18 -- copies of the Software, and to permit persons to whom the Software is    --
19 -- furnished to do so, subject to the following conditions:                 --
20 --                                                                          --
21 -- The above copyright notice and this permission notice shall be included  --
22 -- in all copies or substantial portions of the Software.                   --
23 --                                                                          --
24 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
25 -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
26 -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
27 -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
28 -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
29 -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
30 -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
31 --                                                                          --
32 -- Except as contained in this notice, the name(s) of the above copyright   --
33 -- holders shall not be used in advertising or otherwise to promote the     --
34 -- sale, use or other dealings in this Software without prior written       --
35 -- authorization.                                                           --
36 ------------------------------------------------------------------------------
37 --  Author:  Juergen Pfeifer, 1996
38 --  Version Control:
39 --  $Revision: 1.23 $
40 --  $Date: 2020/02/02 23:34:34 $
41 --  Binding Version 01.00
42 ------------------------------------------------------------------------------
43 package body Terminal_Interface.Curses.Text_IO is
44
45    Default_Window : Window := Null_Window;
46
47    procedure Set_Window (Win : Window)
48    is
49    begin
50       Default_Window := Win;
51    end Set_Window;
52
53    function Get_Window return Window
54    is
55    begin
56       if Default_Window = Null_Window then
57          return Standard_Window;
58       else
59          return Default_Window;
60       end if;
61    end Get_Window;
62    pragma Inline (Get_Window);
63
64    procedure Flush (Win : Window)
65    is
66    begin
67       Refresh (Win);
68    end Flush;
69
70    procedure Flush
71    is
72    begin
73       Flush (Get_Window);
74    end Flush;
75
76    --------------------------------------------
77    -- Specification of line and page lengths --
78    --------------------------------------------
79
80    --  There are no set routines in this package. I assume, that you allocate
81    --  the window with an appropriate size.
82    --  A scroll-window is interpreted as an page with unbounded page length,
83    --  i.e. it returns the conventional 0 as page length.
84
85    function Line_Length (Win : Window) return Count
86    is
87       N_Lines : Line_Count;
88       N_Cols  : Column_Count;
89    begin
90       Get_Size (Win, N_Lines, N_Cols);
91       --  if Natural (N_Cols) > Natural (Count'Last) then
92       --     raise Layout_Error;
93       --  end if;
94       return Count (N_Cols);
95    end Line_Length;
96
97    function Line_Length return Count
98    is
99    begin
100       return Line_Length (Get_Window);
101    end Line_Length;
102
103    function Page_Length (Win : Window) return Count
104    is
105       N_Lines : Line_Count;
106       N_Cols  : Column_Count;
107    begin
108       if Scrolling_Allowed (Win) then
109          return 0;
110       else
111          Get_Size (Win, N_Lines, N_Cols);
112          --  if Natural (N_Lines) > Natural (Count'Last) then
113          --     raise Layout_Error;
114          --  end if;
115          return Count (N_Lines);
116       end if;
117    end Page_Length;
118
119    function Page_Length return Count
120    is
121    begin
122       return Page_Length (Get_Window);
123    end Page_Length;
124
125    ------------------------------------
126    -- Column, Line, and Page Control --
127    ------------------------------------
128    procedure New_Line (Win : Window; Spacing : Positive_Count := 1)
129    is
130       P_Size : constant Count := Page_Length (Win);
131    begin
132       if not Spacing'Valid then
133          raise Constraint_Error;
134       end if;
135
136       for I in 1 .. Spacing loop
137          if P_Size > 0 and then Line (Win) >= P_Size then
138             New_Page (Win);
139          else
140             Add (Win, ASCII.LF);
141          end if;
142       end loop;
143    end New_Line;
144
145    procedure New_Line (Spacing : Positive_Count := 1)
146    is
147    begin
148       New_Line (Get_Window, Spacing);
149    end New_Line;
150
151    procedure New_Page (Win : Window)
152    is
153    begin
154       Clear (Win);
155    end New_Page;
156
157    procedure New_Page
158    is
159    begin
160       New_Page (Get_Window);
161    end New_Page;
162
163    procedure Set_Col (Win : Window;  To : Positive_Count)
164    is
165       Y  : Line_Position;
166       X1 : Column_Position;
167       X2 : Column_Position;
168       N  : Natural;
169    begin
170       if not To'Valid then
171          raise Constraint_Error;
172       end if;
173
174       Get_Cursor_Position (Win, Y, X1);
175       N  := Natural (To); N := N - 1;
176       X2 := Column_Position (N);
177       if X1 > X2 then
178          New_Line (Win, 1);
179          X1 := 0;
180       end if;
181       if X1 < X2 then
182          declare
183             Filler : constant String (Integer (X1) .. (Integer (X2) - 1))
184               := (others => ' ');
185          begin
186             Put (Win, Filler);
187          end;
188       end if;
189    end Set_Col;
190
191    procedure Set_Col (To : Positive_Count)
192    is
193    begin
194       Set_Col (Get_Window, To);
195    end Set_Col;
196
197    procedure Set_Line (Win : Window; To : Positive_Count)
198    is
199       Y1 : Line_Position;
200       Y2 : Line_Position;
201       X  : Column_Position;
202       N  : Natural;
203    begin
204       if not To'Valid then
205          raise Constraint_Error;
206       end if;
207
208       Get_Cursor_Position (Win, Y1, X);
209       pragma Warnings (Off, X);         --  unreferenced
210       N  := Natural (To); N := N - 1;
211       Y2 := Line_Position (N);
212       if Y2 < Y1 then
213          New_Page (Win);
214          Y1 := 0;
215       end if;
216       if Y1 < Y2 then
217          New_Line (Win, Positive_Count (Y2 - Y1));
218       end if;
219    end Set_Line;
220
221    procedure Set_Line (To : Positive_Count)
222    is
223    begin
224       Set_Line (Get_Window, To);
225    end Set_Line;
226
227    function Col (Win : Window) return Positive_Count
228    is
229       Y : Line_Position;
230       X : Column_Position;
231       N : Natural;
232    begin
233       Get_Cursor_Position (Win, Y, X);
234       N := Natural (X); N := N + 1;
235       --  if N > Natural (Count'Last) then
236       --     raise Layout_Error;
237       --  end if;
238       return Positive_Count (N);
239    end Col;
240
241    function Col return Positive_Count
242    is
243    begin
244       return Col (Get_Window);
245    end Col;
246
247    function Line (Win : Window) return Positive_Count
248    is
249       Y : Line_Position;
250       X : Column_Position;
251       N : Natural;
252    begin
253       Get_Cursor_Position (Win, Y, X);
254       N := Natural (Y); N := N + 1;
255       --  if N > Natural (Count'Last) then
256       --     raise Layout_Error;
257       --  end if;
258       return Positive_Count (N);
259    end Line;
260
261    function Line return Positive_Count
262    is
263    begin
264       return Line (Get_Window);
265    end Line;
266
267    -----------------------
268    -- Characters Output --
269    -----------------------
270
271    procedure Put (Win  : Window; Item : Character)
272    is
273       P_Size : constant Count := Page_Length (Win);
274       Y : Line_Position;
275       X : Column_Position;
276       L : Line_Count;
277       C : Column_Count;
278    begin
279       if P_Size > 0 then
280          Get_Cursor_Position (Win, Y, X);
281          Get_Size (Win, L, C);
282          if (Y + 1) = L and then (X + 1) = C then
283             New_Page (Win);
284          end if;
285       end if;
286       Add (Win, Item);
287    end Put;
288
289    procedure Put (Item : Character)
290    is
291    begin
292       Put (Get_Window, Item);
293    end Put;
294
295    --------------------
296    -- Strings-Output --
297    --------------------
298
299    procedure Put (Win  : Window; Item : String)
300    is
301       P_Size : constant Count := Page_Length (Win);
302       Y : Line_Position;
303       X : Column_Position;
304       L : Line_Count;
305       C : Column_Count;
306    begin
307       if P_Size > 0 then
308          Get_Cursor_Position (Win, Y, X);
309          Get_Size (Win, L, C);
310          if (Y + 1) = L and then (X + 1 + Item'Length) >= C then
311             New_Page (Win);
312          end if;
313       end if;
314       Add (Win, Item);
315    end Put;
316
317    procedure Put (Item : String)
318    is
319    begin
320       Put (Get_Window, Item);
321    end Put;
322
323    procedure Put_Line
324      (Win  : Window;
325       Item : String)
326    is
327    begin
328       Put (Win, Item);
329       New_Line (Win, 1);
330    end Put_Line;
331
332    procedure Put_Line
333      (Item : String)
334    is
335    begin
336       Put_Line (Get_Window, Item);
337    end Put_Line;
338
339 end Terminal_Interface.Curses.Text_IO;