|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . C G I . D E B U G --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 2000-2017, AdaCore --
|
|
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Strings.Unbounded;
|
|
|
33
|
|
|
34 package body GNAT.CGI.Debug is
|
|
|
35
|
|
|
36 use Ada.Strings.Unbounded;
|
|
|
37
|
|
|
38 -- Define the abstract type which act as a template for all debug IO modes.
|
|
|
39 -- To create a new IO mode you must:
|
|
|
40 -- 1. create a new package spec
|
|
|
41 -- 2. create a new type derived from IO.Format
|
|
|
42 -- 3. implement all the abstract routines in IO
|
|
|
43
|
|
|
44 package IO is
|
|
|
45
|
|
|
46 type Format is abstract tagged null record;
|
|
|
47
|
|
|
48 function Output (Mode : Format'Class) return String;
|
|
|
49
|
|
|
50 function Variable
|
|
|
51 (Mode : Format;
|
|
|
52 Name : String;
|
|
|
53 Value : String) return String is abstract;
|
|
|
54 -- Returns variable Name and its associated value
|
|
|
55
|
|
|
56 function New_Line (Mode : Format) return String is abstract;
|
|
|
57 -- Returns a new line such as this concatenated between two strings
|
|
|
58 -- will display the strings on two lines.
|
|
|
59
|
|
|
60 function Title (Mode : Format; Str : String) return String is abstract;
|
|
|
61 -- Returns Str as a Title. A title must be alone and centered on a
|
|
|
62 -- line. Next output will be on the following line.
|
|
|
63
|
|
|
64 function Header
|
|
|
65 (Mode : Format;
|
|
|
66 Str : String) return String is abstract;
|
|
|
67 -- Returns Str as an Header. An header must be alone on its line. Next
|
|
|
68 -- output will be on the following line.
|
|
|
69
|
|
|
70 end IO;
|
|
|
71
|
|
|
72 ----------------------
|
|
|
73 -- IO for HTML Mode --
|
|
|
74 ----------------------
|
|
|
75
|
|
|
76 package HTML_IO is
|
|
|
77
|
|
|
78 -- See IO for comments about these routines
|
|
|
79
|
|
|
80 type Format is new IO.Format with null record;
|
|
|
81
|
|
|
82 function Variable
|
|
|
83 (IO : Format;
|
|
|
84 Name : String;
|
|
|
85 Value : String) return String;
|
|
|
86
|
|
|
87 function New_Line (IO : Format) return String;
|
|
|
88
|
|
|
89 function Title (IO : Format; Str : String) return String;
|
|
|
90
|
|
|
91 function Header (IO : Format; Str : String) return String;
|
|
|
92
|
|
|
93 end HTML_IO;
|
|
|
94
|
|
|
95 ----------------------------
|
|
|
96 -- IO for Plain Text Mode --
|
|
|
97 ----------------------------
|
|
|
98
|
|
|
99 package Text_IO is
|
|
|
100
|
|
|
101 -- See IO for comments about these routines
|
|
|
102
|
|
|
103 type Format is new IO.Format with null record;
|
|
|
104
|
|
|
105 function Variable
|
|
|
106 (IO : Format;
|
|
|
107 Name : String;
|
|
|
108 Value : String) return String;
|
|
|
109
|
|
|
110 function New_Line (IO : Format) return String;
|
|
|
111
|
|
|
112 function Title (IO : Format; Str : String) return String;
|
|
|
113
|
|
|
114 function Header (IO : Format; Str : String) return String;
|
|
|
115
|
|
|
116 end Text_IO;
|
|
|
117
|
|
|
118 --------------
|
|
|
119 -- Debug_IO --
|
|
|
120 --------------
|
|
|
121
|
|
|
122 package body IO is
|
|
|
123
|
|
|
124 ------------
|
|
|
125 -- Output --
|
|
|
126 ------------
|
|
|
127
|
|
|
128 function Output (Mode : Format'Class) return String is
|
|
|
129 Result : Unbounded_String;
|
|
|
130
|
|
|
131 begin
|
|
|
132 Result :=
|
|
|
133 To_Unbounded_String
|
|
|
134 (Title (Mode, "CGI complete runtime environment")
|
|
|
135 & Header (Mode, "CGI parameters:")
|
|
|
136 & New_Line (Mode));
|
|
|
137
|
|
|
138 for K in 1 .. Argument_Count loop
|
|
|
139 Result := Result
|
|
|
140 & Variable (Mode, Key (K), Value (K))
|
|
|
141 & New_Line (Mode);
|
|
|
142 end loop;
|
|
|
143
|
|
|
144 Result := Result
|
|
|
145 & New_Line (Mode)
|
|
|
146 & Header (Mode, "CGI environment variables (Metavariables):")
|
|
|
147 & New_Line (Mode);
|
|
|
148
|
|
|
149 for P in Metavariable_Name'Range loop
|
|
|
150 if Metavariable_Exists (P) then
|
|
|
151 Result := Result
|
|
|
152 & Variable (Mode,
|
|
|
153 Metavariable_Name'Image (P),
|
|
|
154 Metavariable (P))
|
|
|
155 & New_Line (Mode);
|
|
|
156 end if;
|
|
|
157 end loop;
|
|
|
158
|
|
|
159 return To_String (Result);
|
|
|
160 end Output;
|
|
|
161
|
|
|
162 end IO;
|
|
|
163
|
|
|
164 -------------
|
|
|
165 -- HTML_IO --
|
|
|
166 -------------
|
|
|
167
|
|
|
168 package body HTML_IO is
|
|
|
169
|
|
|
170 NL : constant String := (1 => ASCII.LF);
|
|
|
171
|
|
|
172 function Bold (S : String) return String;
|
|
|
173 -- Returns S as an HTML bold string
|
|
|
174
|
|
|
175 function Italic (S : String) return String;
|
|
|
176 -- Returns S as an HTML italic string
|
|
|
177
|
|
|
178 ----------
|
|
|
179 -- Bold --
|
|
|
180 ----------
|
|
|
181
|
|
|
182 function Bold (S : String) return String is
|
|
|
183 begin
|
|
|
184 return "<b>" & S & "</b>";
|
|
|
185 end Bold;
|
|
|
186
|
|
|
187 ------------
|
|
|
188 -- Header --
|
|
|
189 ------------
|
|
|
190
|
|
|
191 function Header (IO : Format; Str : String) return String is
|
|
|
192 pragma Unreferenced (IO);
|
|
|
193 begin
|
|
|
194 return "<h2>" & Str & "</h2>" & NL;
|
|
|
195 end Header;
|
|
|
196
|
|
|
197 ------------
|
|
|
198 -- Italic --
|
|
|
199 ------------
|
|
|
200
|
|
|
201 function Italic (S : String) return String is
|
|
|
202 begin
|
|
|
203 return "<i>" & S & "</i>";
|
|
|
204 end Italic;
|
|
|
205
|
|
|
206 --------------
|
|
|
207 -- New_Line --
|
|
|
208 --------------
|
|
|
209
|
|
|
210 function New_Line (IO : Format) return String is
|
|
|
211 pragma Unreferenced (IO);
|
|
|
212 begin
|
|
|
213 return "<br>" & NL;
|
|
|
214 end New_Line;
|
|
|
215
|
|
|
216 -----------
|
|
|
217 -- Title --
|
|
|
218 -----------
|
|
|
219
|
|
|
220 function Title (IO : Format; Str : String) return String is
|
|
|
221 pragma Unreferenced (IO);
|
|
|
222 begin
|
|
|
223 return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
|
|
|
224 end Title;
|
|
|
225
|
|
|
226 --------------
|
|
|
227 -- Variable --
|
|
|
228 --------------
|
|
|
229
|
|
|
230 function Variable
|
|
|
231 (IO : Format;
|
|
|
232 Name : String;
|
|
|
233 Value : String) return String
|
|
|
234 is
|
|
|
235 pragma Unreferenced (IO);
|
|
|
236 begin
|
|
|
237 return Bold (Name) & " = " & Italic (Value);
|
|
|
238 end Variable;
|
|
|
239
|
|
|
240 end HTML_IO;
|
|
|
241
|
|
|
242 -------------
|
|
|
243 -- Text_IO --
|
|
|
244 -------------
|
|
|
245
|
|
|
246 package body Text_IO is
|
|
|
247
|
|
|
248 ------------
|
|
|
249 -- Header --
|
|
|
250 ------------
|
|
|
251
|
|
|
252 function Header (IO : Format; Str : String) return String is
|
|
|
253 begin
|
|
|
254 return "*** " & Str & New_Line (IO);
|
|
|
255 end Header;
|
|
|
256
|
|
|
257 --------------
|
|
|
258 -- New_Line --
|
|
|
259 --------------
|
|
|
260
|
|
|
261 function New_Line (IO : Format) return String is
|
|
|
262 pragma Unreferenced (IO);
|
|
|
263 begin
|
|
|
264 return String'(1 => ASCII.LF);
|
|
|
265 end New_Line;
|
|
|
266
|
|
|
267 -----------
|
|
|
268 -- Title --
|
|
|
269 -----------
|
|
|
270
|
|
|
271 function Title (IO : Format; Str : String) return String is
|
|
|
272 Spaces : constant Natural := (80 - Str'Length) / 2;
|
|
|
273 Indent : constant String (1 .. Spaces) := (others => ' ');
|
|
|
274 begin
|
|
|
275 return Indent & Str & New_Line (IO);
|
|
|
276 end Title;
|
|
|
277
|
|
|
278 --------------
|
|
|
279 -- Variable --
|
|
|
280 --------------
|
|
|
281
|
|
|
282 function Variable
|
|
|
283 (IO : Format;
|
|
|
284 Name : String;
|
|
|
285 Value : String) return String
|
|
|
286 is
|
|
|
287 pragma Unreferenced (IO);
|
|
|
288 begin
|
|
|
289 return " " & Name & " = " & Value;
|
|
|
290 end Variable;
|
|
|
291
|
|
|
292 end Text_IO;
|
|
|
293
|
|
|
294 -----------------
|
|
|
295 -- HTML_Output --
|
|
|
296 -----------------
|
|
|
297
|
|
|
298 function HTML_Output return String is
|
|
|
299 HTML : HTML_IO.Format;
|
|
|
300 begin
|
|
|
301 return IO.Output (Mode => HTML);
|
|
|
302 end HTML_Output;
|
|
|
303
|
|
|
304 -----------------
|
|
|
305 -- Text_Output --
|
|
|
306 -----------------
|
|
|
307
|
|
|
308 function Text_Output return String is
|
|
|
309 Text : Text_IO.Format;
|
|
|
310 begin
|
|
|
311 return IO.Output (Mode => Text);
|
|
|
312 end Text_Output;
|
|
|
313
|
|
|
314 end GNAT.CGI.Debug;
|
