gcc:
[official-gcc.git] / gcc / ada / g-cgideb.adb
blob6b8020fb4cad0482c536c3ea6b3a06fdd704b89e
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-2006, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Ada.Strings.Unbounded;
36 package body GNAT.CGI.Debug is
38 use Ada.Strings.Unbounded;
40 -- Define the abstract type which act as a template for all debug IO modes.
41 -- To create a new IO mode you must:
42 -- 1. create a new package spec
43 -- 2. create a new type derived from IO.Format
44 -- 3. implement all the abstract rountines in IO
46 package IO is
48 type Format is abstract tagged null record;
50 function Output (Mode : Format'Class) return String;
52 function Variable
53 (Mode : Format;
54 Name : String;
55 Value : String) return String is abstract;
56 -- Returns variable Name and its associated value
58 function New_Line (Mode : Format) return String is abstract;
59 -- Returns a new line such as this concatenated between two strings
60 -- will display the strings on two lines.
62 function Title (Mode : Format; Str : String) return String is abstract;
63 -- Returns Str as a Title. A title must be alone and centered on a
64 -- line. Next output will be on the following line.
66 function Header
67 (Mode : Format;
68 Str : String) return String is abstract;
69 -- Returns Str as an Header. An header must be alone on its line. Next
70 -- output will be on the following line.
72 end IO;
74 ----------------------
75 -- IO for HTML Mode --
76 ----------------------
78 package HTML_IO is
80 -- See IO for comments about these routines
82 type Format is new IO.Format with null record;
84 function Variable
85 (IO : Format;
86 Name : String;
87 Value : String) return String;
89 function New_Line (IO : Format) return String;
91 function Title (IO : Format; Str : String) return String;
93 function Header (IO : Format; Str : String) return String;
95 end HTML_IO;
97 ----------------------------
98 -- IO for Plain Text Mode --
99 ----------------------------
101 package Text_IO is
103 -- See IO for comments about these routines
105 type Format is new IO.Format with null record;
107 function Variable
108 (IO : Format;
109 Name : String;
110 Value : String) return String;
112 function New_Line (IO : Format) return String;
114 function Title (IO : Format; Str : String) return String;
116 function Header (IO : Format; Str : String) return String;
118 end Text_IO;
120 --------------
121 -- Debug_IO --
122 --------------
124 package body IO is
126 ------------
127 -- Output --
128 ------------
130 function Output (Mode : Format'Class) return String is
131 Result : Unbounded_String;
133 begin
134 Result := Result
135 & Title (Mode, "CGI complete runtime environment");
137 Result := Result
138 & Header (Mode, "CGI parameters:")
139 & New_Line (Mode);
141 for K in 1 .. Argument_Count loop
142 Result := Result
143 & Variable (Mode, Key (K), Value (K))
144 & New_Line (Mode);
145 end loop;
147 Result := Result
148 & New_Line (Mode)
149 & Header (Mode, "CGI environment variables (Metavariables):")
150 & New_Line (Mode);
152 for P in Metavariable_Name'Range loop
153 if Metavariable_Exists (P) then
154 Result := Result
155 & Variable (Mode,
156 Metavariable_Name'Image (P),
157 Metavariable (P))
158 & New_Line (Mode);
159 end if;
160 end loop;
162 return To_String (Result);
163 end Output;
165 end IO;
167 -------------
168 -- HTML_IO --
169 -------------
171 package body HTML_IO is
173 NL : constant String := (1 => ASCII.LF);
175 function Bold (S : String) return String;
176 -- Returns S as an HTML bold string
178 function Italic (S : String) return String;
179 -- Returns S as an HTML italic string
181 ----------
182 -- Bold --
183 ----------
185 function Bold (S : String) return String is
186 begin
187 return "<b>" & S & "</b>";
188 end Bold;
190 ------------
191 -- Header --
192 ------------
194 function Header (IO : Format; Str : String) return String is
195 pragma Unreferenced (IO);
196 begin
197 return "<h2>" & Str & "</h2>" & NL;
198 end Header;
200 ------------
201 -- Italic --
202 ------------
204 function Italic (S : String) return String is
205 begin
206 return "<i>" & S & "</i>";
207 end Italic;
209 --------------
210 -- New_Line --
211 --------------
213 function New_Line (IO : Format) return String is
214 pragma Unreferenced (IO);
215 begin
216 return "<br>" & NL;
217 end New_Line;
219 -----------
220 -- Title --
221 -----------
223 function Title (IO : Format; Str : String) return String is
224 pragma Unreferenced (IO);
225 begin
226 return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
227 end Title;
229 --------------
230 -- Variable --
231 --------------
233 function Variable
234 (IO : Format;
235 Name : String;
236 Value : String) return String
238 pragma Unreferenced (IO);
239 begin
240 return Bold (Name) & " = " & Italic (Value);
241 end Variable;
243 end HTML_IO;
245 -------------
246 -- Text_IO --
247 -------------
249 package body Text_IO is
251 ------------
252 -- Header --
253 ------------
255 function Header (IO : Format; Str : String) return String is
256 begin
257 return "*** " & Str & New_Line (IO);
258 end Header;
260 --------------
261 -- New_Line --
262 --------------
264 function New_Line (IO : Format) return String is
265 pragma Unreferenced (IO);
266 begin
267 return String'(1 => ASCII.LF);
268 end New_Line;
270 -----------
271 -- Title --
272 -----------
274 function Title (IO : Format; Str : String) return String is
275 Spaces : constant Natural := (80 - Str'Length) / 2;
276 Indent : constant String (1 .. Spaces) := (others => ' ');
277 begin
278 return Indent & Str & New_Line (IO);
279 end Title;
281 --------------
282 -- Variable --
283 --------------
285 function Variable
286 (IO : Format;
287 Name : String;
288 Value : String) return String
290 pragma Unreferenced (IO);
291 begin
292 return " " & Name & " = " & Value;
293 end Variable;
295 end Text_IO;
297 -----------------
298 -- HTML_Output --
299 -----------------
301 function HTML_Output return String is
302 HTML : HTML_IO.Format;
303 begin
304 return IO.Output (Mode => HTML);
305 end HTML_Output;
307 -----------------
308 -- Text_Output --
309 -----------------
311 function Text_Output return String is
312 Text : Text_IO.Format;
313 begin
314 return IO.Output (Mode => Text);
315 end Text_Output;
317 end GNAT.CGI.Debug;