gcc/ada/g-cgideb.adb

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