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