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 --                                                                          --
  10 --            Copyright (C) 2000-2001 Ada Core Technologies, Inc.           --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Strings.Unbounded;
  35
  36 package 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
 343 end GNAT.CGI.Debug;