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-2010, 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
32with Ada.Strings.Unbounded;
33
34package 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
314end GNAT.CGI.Debug;
315