ncurses 6.0 - patch 20150808
[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 (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.22 $
39 --  $Date: 2014/05/24 21:32:18 $
40 --  Binding Version 01.00
41 ------------------------------------------------------------------------------
42 package body Terminal_Interface.Curses.Text_IO is
43
44    Default_Window : Window := Null_Window;
45
46    procedure Set_Window (Win : Window)
47    is
48    begin
49       Default_Window := Win;
50    end Set_Window;
51
52    function Get_Window return Window
53    is
54    begin
55       if Default_Window = Null_Window then
56          return Standard_Window;
57       else
58          return Default_Window;
59       end if;
60    end Get_Window;
61    pragma Inline (Get_Window);
62
63    procedure Flush (Win : Window)
64    is
65    begin
66       Refresh (Win);
67    end Flush;
68
69    procedure Flush
70    is
71    begin
72       Flush (Get_Window);
73    end Flush;
74
75    --------------------------------------------
76    -- Specification of line and page lengths --
77    --------------------------------------------
78
79    --  There are no set routines in this package. I assume, that you allocate
80    --  the window with an appropriate size.
81    --  A scroll-window is interpreted as an page with unbounded page length,
82    --  i.e. it returns the conventional 0 as page length.
83
84    function Line_Length (Win : Window) return Count
85    is
86       N_Lines : Line_Count;
87       N_Cols  : Column_Count;
88    begin
89       Get_Size (Win, N_Lines, N_Cols);
90       --  if Natural (N_Cols) > Natural (Count'Last) then
91       --     raise Layout_Error;
92       --  end if;
93       return Count (N_Cols);
94    end Line_Length;
95
96    function Line_Length return Count
97    is
98    begin
99       return Line_Length (Get_Window);
100    end Line_Length;
101
102    function Page_Length (Win : Window) return Count
103    is
104       N_Lines : Line_Count;
105       N_Cols  : Column_Count;
106    begin
107       if Scrolling_Allowed (Win) then
108          return 0;
109       else
110          Get_Size (Win, N_Lines, N_Cols);
111          --  if Natural (N_Lines) > Natural (Count'Last) then
112          --     raise Layout_Error;
113          --  end if;
114          return Count (N_Lines);
115       end if;
116    end Page_Length;
117
118    function Page_Length return Count
119    is
120    begin
121       return Page_Length (Get_Window);
122    end Page_Length;
123
124    ------------------------------------
125    -- Column, Line, and Page Control --
126    ------------------------------------
127    procedure New_Line (Win : Window; Spacing : Positive_Count := 1)
128    is
129       P_Size : constant Count := Page_Length (Win);
130    begin
131       if not Spacing'Valid then
132          raise Constraint_Error;
133       end if;
134
135       for I in 1 .. Spacing loop
136          if P_Size > 0 and then Line (Win) >= P_Size then
137             New_Page (Win);
138          else
139             Add (Win, ASCII.LF);
140          end if;
141       end loop;
142    end New_Line;
143
144    procedure New_Line (Spacing : Positive_Count := 1)
145    is
146    begin
147       New_Line (Get_Window, Spacing);
148    end New_Line;
149
150    procedure New_Page (Win : Window)
151    is
152    begin
153       Clear (Win);
154    end New_Page;
155
156    procedure New_Page
157    is
158    begin
159       New_Page (Get_Window);
160    end New_Page;
161
162    procedure Set_Col (Win : Window;  To : Positive_Count)
163    is
164       Y  : Line_Position;
165       X1 : Column_Position;
166       X2 : Column_Position;
167       N  : Natural;
168    begin
169       if not To'Valid then
170          raise Constraint_Error;
171       end if;
172
173       Get_Cursor_Position (Win, Y, X1);
174       N  := Natural (To); N := N - 1;
175       X2 := Column_Position (N);
176       if X1 > X2 then
177          New_Line (Win, 1);
178          X1 := 0;
179       end if;
180       if X1 < X2 then
181          declare
182             Filler : constant String (Integer (X1) .. (Integer (X2) - 1))
183               := (others => ' ');
184          begin
185             Put (Win, Filler);
186          end;
187       end if;
188    end Set_Col;
189
190    procedure Set_Col (To : Positive_Count)
191    is
192    begin
193       Set_Col (Get_Window, To);
194    end Set_Col;
195
196    procedure Set_Line (Win : Window; To : Positive_Count)
197    is
198       Y1 : Line_Position;
199       Y2 : Line_Position;
200       X  : Column_Position;
201       N  : Natural;
202    begin
203       if not To'Valid then
204          raise Constraint_Error;
205       end if;
206
207       Get_Cursor_Position (Win, Y1, X);
208       pragma Warnings (Off, X);         --  unreferenced
209       N  := Natural (To); N := N - 1;
210       Y2 := Line_Position (N);
211       if Y2 < Y1 then
212          New_Page (Win);
213          Y1 := 0;
214       end if;
215       if Y1 < Y2 then
216          New_Line (Win, Positive_Count (Y2 - Y1));
217       end if;
218    end Set_Line;
219
220    procedure Set_Line (To : Positive_Count)
221    is
222    begin
223       Set_Line (Get_Window, To);
224    end Set_Line;
225
226    function Col (Win : Window) return Positive_Count
227    is
228       Y : Line_Position;
229       X : Column_Position;
230       N : Natural;
231    begin
232       Get_Cursor_Position (Win, Y, X);
233       N := Natural (X); N := N + 1;
234       --  if N > Natural (Count'Last) then
235       --     raise Layout_Error;
236       --  end if;
237       return Positive_Count (N);
238    end Col;
239
240    function Col return Positive_Count
241    is
242    begin
243       return Col (Get_Window);
244    end Col;
245
246    function Line (Win : Window) return Positive_Count
247    is
248       Y : Line_Position;
249       X : Column_Position;
250       N : Natural;
251    begin
252       Get_Cursor_Position (Win, Y, X);
253       N := Natural (Y); N := N + 1;
254       --  if N > Natural (Count'Last) then
255       --     raise Layout_Error;
256       --  end if;
257       return Positive_Count (N);
258    end Line;
259
260    function Line return Positive_Count
261    is
262    begin
263       return Line (Get_Window);
264    end Line;
265
266    -----------------------
267    -- Characters Output --
268    -----------------------
269
270    procedure Put (Win  : Window; Item : Character)
271    is
272       P_Size : constant Count := Page_Length (Win);
273       Y : Line_Position;
274       X : Column_Position;
275       L : Line_Count;
276       C : Column_Count;
277    begin
278       if P_Size > 0 then
279          Get_Cursor_Position (Win, Y, X);
280          Get_Size (Win, L, C);
281          if (Y + 1) = L and then (X + 1) = C then
282             New_Page (Win);
283          end if;
284       end if;
285       Add (Win, Item);
286    end Put;
287
288    procedure Put (Item : Character)
289    is
290    begin
291       Put (Get_Window, Item);
292    end Put;
293
294    --------------------
295    -- Strings-Output --
296    --------------------
297
298    procedure Put (Win  : Window; Item : String)
299    is
300       P_Size : constant Count := Page_Length (Win);
301       Y : Line_Position;
302       X : Column_Position;
303       L : Line_Count;
304       C : Column_Count;
305    begin
306       if P_Size > 0 then
307          Get_Cursor_Position (Win, Y, X);
308          Get_Size (Win, L, C);
309          if (Y + 1) = L and then (X + 1 + Item'Length) >= C then
310             New_Page (Win);
311          end if;
312       end if;
313       Add (Win, Item);
314    end Put;
315
316    procedure Put (Item : String)
317    is
318    begin
319       Put (Get_Window, Item);
320    end Put;
321
322    procedure Put_Line
323      (Win  : Window;
324       Item : String)
325    is
326    begin
327       Put (Win, Item);
328       New_Line (Win, 1);
329    end Put_Line;
330
331    procedure Put_Line
332      (Item : String)
333    is
334    begin
335       Put_Line (Get_Window, Item);
336    end Put_Line;
337
338 end Terminal_Interface.Curses.Text_IO;