Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/g-cgideb.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;