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-2001 Ada Core Technologies, Inc.           --
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,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, 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------------------------------------------------------------------------------
33
34with Ada.Strings.Unbounded;
35
36package body GNAT.CGI.Debug is
37
38   use Ada.Strings.Unbounded;
39
40   --
41   --  Define the abstract type which act as a template for all debug IO mode.
42   --  To create a new IO mode you must:
43   --     1. create a new package spec
44   --     2. create a new type derived from IO.Format
45   --     3. implement all the abstract rountines in IO
46   --
47
48   package IO is
49
50      type Format is abstract tagged null record;
51
52      function Output (Mode : in Format'Class) return String;
53
54      function Variable
55        (Mode  : Format;
56         Name  : String;
57         Value : String)
58         return  String
59      is abstract;
60      --  Returns variable Name and its associated value.
61
62      function New_Line
63        (Mode : Format)
64         return String
65      is abstract;
66      --  Returns a new line such as this concatenated between two strings
67      --  will display the strings on two lines.
68
69      function Title
70        (Mode : Format;
71         Str  : String)
72         return String
73      is abstract;
74      --  Returns Str as a Title. A title must be alone and centered on a
75      --  line. Next output will be on the following line.
76
77      function Header
78        (Mode : Format;
79         Str  : String)
80         return String
81      is abstract;
82      --  Returns Str as an Header. An header must be alone on its line. Next
83      --  output will be on the following line.
84
85   end IO;
86
87   --
88   --  IO for HTML mode
89   --
90
91   package HTML_IO is
92
93      --  see IO for comments about these routines.
94
95      type Format is new IO.Format with null record;
96
97      function Variable
98        (IO    : Format;
99         Name  : String;
100         Value : String)
101         return  String;
102
103      function New_Line (IO : in Format) return String;
104
105      function Title (IO : in Format; Str : in String) return String;
106
107      function Header (IO : in Format; Str : in String) return String;
108
109   end HTML_IO;
110
111   --
112   --  IO for plain text mode
113   --
114
115   package Text_IO is
116
117      --  See IO for comments about these routines
118
119      type Format is new IO.Format with null record;
120
121      function Variable
122        (IO    : Format;
123         Name  : String;
124         Value : String)
125         return  String;
126
127      function New_Line (IO : in Format) return String;
128
129      function Title (IO : in Format; Str : in String) return String;
130
131      function Header (IO : in Format; Str : in String) return String;
132
133   end Text_IO;
134
135   --------------
136   -- Debug_IO --
137   --------------
138
139   package body IO is
140
141      ------------
142      -- Output --
143      ------------
144
145      function Output (Mode : in Format'Class) return String is
146         Result : Unbounded_String;
147
148      begin
149         Result := Result
150           & Title (Mode, "CGI complete runtime environment");
151
152         Result := Result
153           & Header (Mode, "CGI parameters:")
154           & New_Line (Mode);
155
156         for K in 1 .. Argument_Count loop
157            Result := Result
158              & Variable (Mode, Key (K), Value (K))
159              & New_Line (Mode);
160         end loop;
161
162         Result := Result
163           & New_Line (Mode)
164           & Header (Mode, "CGI environment variables (Metavariables):")
165           & New_Line (Mode);
166
167         for P in Metavariable_Name'Range loop
168            if Metavariable_Exists (P) then
169               Result := Result
170                 & Variable (Mode,
171                             Metavariable_Name'Image (P),
172                             Metavariable (P))
173                 & New_Line (Mode);
174            end if;
175         end loop;
176
177         return To_String (Result);
178      end Output;
179
180   end IO;
181
182   -------------
183   -- HTML_IO --
184   -------------
185
186   package body HTML_IO is
187
188      NL : constant String := (1 => ASCII.LF);
189
190      function Bold (S : in String) return String;
191      --  Returns S as an HTML bold string.
192
193      function Italic (S : in String) return String;
194      --  Returns S as an HTML italic string.
195
196      ----------
197      -- Bold --
198      ----------
199
200      function Bold (S : in String) return String is
201      begin
202         return "<b>" & S & "</b>";
203      end Bold;
204
205      ------------
206      -- Header --
207      ------------
208
209      function Header (IO : in Format; Str : in String) return String is
210         pragma Warnings (Off, IO);
211
212      begin
213         return "<h2>" & Str & "</h2>" & NL;
214      end Header;
215
216      ------------
217      -- Italic --
218      ------------
219
220      function Italic (S : in String) return String is
221      begin
222         return "<i>" & S & "</i>";
223      end Italic;
224
225      --------------
226      -- New_Line --
227      --------------
228
229      function New_Line (IO : in Format) return String is
230         pragma Warnings (Off, IO);
231
232      begin
233         return "<br>" & NL;
234      end New_Line;
235
236      -----------
237      -- Title --
238      -----------
239
240      function Title (IO : in Format; Str : in String) return String is
241         pragma Warnings (Off, IO);
242
243      begin
244         return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
245      end Title;
246
247      --------------
248      -- Variable --
249      --------------
250
251      function Variable
252        (IO    : Format;
253         Name  : String;
254         Value : String)
255         return  String
256      is
257         pragma Warnings (Off, IO);
258
259      begin
260         return Bold (Name) & " = " & Italic (Value);
261      end Variable;
262
263   end HTML_IO;
264
265   -------------
266   -- Text_IO --
267   -------------
268
269   package body Text_IO is
270
271      ------------
272      -- Header --
273      ------------
274
275      function Header (IO : in Format; Str : in String) return String is
276      begin
277         return "*** " & Str & New_Line (IO);
278      end Header;
279
280      --------------
281      -- New_Line --
282      --------------
283
284      function New_Line (IO : in Format) return String is
285         pragma Warnings (Off, IO);
286
287      begin
288         return String'(1 => ASCII.LF);
289      end New_Line;
290
291      -----------
292      -- Title --
293      -----------
294
295      function Title (IO : in Format; Str : in String) return String is
296         Spaces : constant Natural := (80 - Str'Length) / 2;
297         Indent : constant String (1 .. Spaces) := (others => ' ');
298
299      begin
300         return Indent & Str & New_Line (IO);
301      end Title;
302
303      --------------
304      -- Variable --
305      --------------
306
307      function Variable
308        (IO    : Format;
309         Name  : String;
310         Value : String)
311         return  String
312      is
313         pragma Warnings (Off, IO);
314
315      begin
316         return "   " & Name & " = " & Value;
317      end Variable;
318
319   end Text_IO;
320
321   -----------------
322   -- HTML_Output --
323   -----------------
324
325   function HTML_Output return String is
326      HTML : HTML_IO.Format;
327
328   begin
329      return IO.Output (Mode => HTML);
330   end HTML_Output;
331
332   -----------------
333   -- Text_Output --
334   -----------------
335
336   function Text_Output return String is
337      Text : Text_IO.Format;
338
339   begin
340      return IO.Output (Mode => Text);
341   end Text_Output;
342
343end GNAT.CGI.Debug;
344