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