315 lines
9 KiB
Ada
315 lines
9 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT COMPILER COMPONENTS --
|
||
|
|
-- --
|
||
|
|
-- G N A T . C G I . D E B U G --
|
||
|
|
-- --
|
||
|
|
-- B o d y --
|
||
|
|
-- --
|
||
|
|
-- Copyright (C) 2000-2010, AdaCore --
|
||
|
|
-- --
|
||
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||
|
|
-- --
|
||
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
||
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
||
|
|
-- --
|
||
|
|
-- You should have received a copy of the GNU General Public License and --
|
||
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||
|
|
-- <http://www.gnu.org/licenses/>. --
|
||
|
|
-- --
|
||
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
||
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
||
|
|
-- --
|
||
|
|
------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
with Ada.Strings.Unbounded;
|
||
|
|
|
||
|
|
package body GNAT.CGI.Debug is
|
||
|
|
|
||
|
|
use Ada.Strings.Unbounded;
|
||
|
|
|
||
|
|
-- Define the abstract type which act as a template for all debug IO modes.
|
||
|
|
-- To create a new IO mode you must:
|
||
|
|
-- 1. create a new package spec
|
||
|
|
-- 2. create a new type derived from IO.Format
|
||
|
|
-- 3. implement all the abstract routines in IO
|
||
|
|
|
||
|
|
package IO is
|
||
|
|
|
||
|
|
type Format is abstract tagged null record;
|
||
|
|
|
||
|
|
function Output (Mode : Format'Class) return String;
|
||
|
|
|
||
|
|
function Variable
|
||
|
|
(Mode : Format;
|
||
|
|
Name : String;
|
||
|
|
Value : String) return String is abstract;
|
||
|
|
-- Returns variable Name and its associated value
|
||
|
|
|
||
|
|
function New_Line (Mode : Format) return String is abstract;
|
||
|
|
-- Returns a new line such as this concatenated between two strings
|
||
|
|
-- will display the strings on two lines.
|
||
|
|
|
||
|
|
function Title (Mode : Format; Str : String) return String is abstract;
|
||
|
|
-- Returns Str as a Title. A title must be alone and centered on a
|
||
|
|
-- line. Next output will be on the following line.
|
||
|
|
|
||
|
|
function Header
|
||
|
|
(Mode : Format;
|
||
|
|
Str : String) return String is abstract;
|
||
|
|
-- Returns Str as an Header. An header must be alone on its line. Next
|
||
|
|
-- output will be on the following line.
|
||
|
|
|
||
|
|
end IO;
|
||
|
|
|
||
|
|
----------------------
|
||
|
|
-- IO for HTML Mode --
|
||
|
|
----------------------
|
||
|
|
|
||
|
|
package HTML_IO is
|
||
|
|
|
||
|
|
-- See IO for comments about these routines
|
||
|
|
|
||
|
|
type Format is new IO.Format with null record;
|
||
|
|
|
||
|
|
function Variable
|
||
|
|
(IO : Format;
|
||
|
|
Name : String;
|
||
|
|
Value : String) return String;
|
||
|
|
|
||
|
|
function New_Line (IO : Format) return String;
|
||
|
|
|
||
|
|
function Title (IO : Format; Str : String) return String;
|
||
|
|
|
||
|
|
function Header (IO : Format; Str : String) return String;
|
||
|
|
|
||
|
|
end HTML_IO;
|
||
|
|
|
||
|
|
----------------------------
|
||
|
|
-- IO for Plain Text Mode --
|
||
|
|
----------------------------
|
||
|
|
|
||
|
|
package Text_IO is
|
||
|
|
|
||
|
|
-- See IO for comments about these routines
|
||
|
|
|
||
|
|
type Format is new IO.Format with null record;
|
||
|
|
|
||
|
|
function Variable
|
||
|
|
(IO : Format;
|
||
|
|
Name : String;
|
||
|
|
Value : String) return String;
|
||
|
|
|
||
|
|
function New_Line (IO : Format) return String;
|
||
|
|
|
||
|
|
function Title (IO : Format; Str : String) return String;
|
||
|
|
|
||
|
|
function Header (IO : Format; Str : String) return String;
|
||
|
|
|
||
|
|
end Text_IO;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- Debug_IO --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
package body IO is
|
||
|
|
|
||
|
|
------------
|
||
|
|
-- Output --
|
||
|
|
------------
|
||
|
|
|
||
|
|
function Output (Mode : Format'Class) return String is
|
||
|
|
Result : Unbounded_String;
|
||
|
|
|
||
|
|
begin
|
||
|
|
Result :=
|
||
|
|
To_Unbounded_String
|
||
|
|
(Title (Mode, "CGI complete runtime environment")
|
||
|
|
& Header (Mode, "CGI parameters:")
|
||
|
|
& New_Line (Mode));
|
||
|
|
|
||
|
|
for K in 1 .. Argument_Count loop
|
||
|
|
Result := Result
|
||
|
|
& Variable (Mode, Key (K), Value (K))
|
||
|
|
& New_Line (Mode);
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
Result := Result
|
||
|
|
& New_Line (Mode)
|
||
|
|
& Header (Mode, "CGI environment variables (Metavariables):")
|
||
|
|
& New_Line (Mode);
|
||
|
|
|
||
|
|
for P in Metavariable_Name'Range loop
|
||
|
|
if Metavariable_Exists (P) then
|
||
|
|
Result := Result
|
||
|
|
& Variable (Mode,
|
||
|
|
Metavariable_Name'Image (P),
|
||
|
|
Metavariable (P))
|
||
|
|
& New_Line (Mode);
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
return To_String (Result);
|
||
|
|
end Output;
|
||
|
|
|
||
|
|
end IO;
|
||
|
|
|
||
|
|
-------------
|
||
|
|
-- HTML_IO --
|
||
|
|
-------------
|
||
|
|
|
||
|
|
package body HTML_IO is
|
||
|
|
|
||
|
|
NL : constant String := (1 => ASCII.LF);
|
||
|
|
|
||
|
|
function Bold (S : String) return String;
|
||
|
|
-- Returns S as an HTML bold string
|
||
|
|
|
||
|
|
function Italic (S : String) return String;
|
||
|
|
-- Returns S as an HTML italic string
|
||
|
|
|
||
|
|
----------
|
||
|
|
-- Bold --
|
||
|
|
----------
|
||
|
|
|
||
|
|
function Bold (S : String) return String is
|
||
|
|
begin
|
||
|
|
return "<b>" & S & "</b>";
|
||
|
|
end Bold;
|
||
|
|
|
||
|
|
------------
|
||
|
|
-- Header --
|
||
|
|
------------
|
||
|
|
|
||
|
|
function Header (IO : Format; Str : String) return String is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return "<h2>" & Str & "</h2>" & NL;
|
||
|
|
end Header;
|
||
|
|
|
||
|
|
------------
|
||
|
|
-- Italic --
|
||
|
|
------------
|
||
|
|
|
||
|
|
function Italic (S : String) return String is
|
||
|
|
begin
|
||
|
|
return "<i>" & S & "</i>";
|
||
|
|
end Italic;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- New_Line --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
function New_Line (IO : Format) return String is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return "<br>" & NL;
|
||
|
|
end New_Line;
|
||
|
|
|
||
|
|
-----------
|
||
|
|
-- Title --
|
||
|
|
-----------
|
||
|
|
|
||
|
|
function Title (IO : Format; Str : String) return String is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return "<p align=center><font size=+2>" & Str & "</font></p>" & NL;
|
||
|
|
end Title;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- Variable --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
function Variable
|
||
|
|
(IO : Format;
|
||
|
|
Name : String;
|
||
|
|
Value : String) return String
|
||
|
|
is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return Bold (Name) & " = " & Italic (Value);
|
||
|
|
end Variable;
|
||
|
|
|
||
|
|
end HTML_IO;
|
||
|
|
|
||
|
|
-------------
|
||
|
|
-- Text_IO --
|
||
|
|
-------------
|
||
|
|
|
||
|
|
package body Text_IO is
|
||
|
|
|
||
|
|
------------
|
||
|
|
-- Header --
|
||
|
|
------------
|
||
|
|
|
||
|
|
function Header (IO : Format; Str : String) return String is
|
||
|
|
begin
|
||
|
|
return "*** " & Str & New_Line (IO);
|
||
|
|
end Header;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- New_Line --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
function New_Line (IO : Format) return String is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return String'(1 => ASCII.LF);
|
||
|
|
end New_Line;
|
||
|
|
|
||
|
|
-----------
|
||
|
|
-- Title --
|
||
|
|
-----------
|
||
|
|
|
||
|
|
function Title (IO : Format; Str : String) return String is
|
||
|
|
Spaces : constant Natural := (80 - Str'Length) / 2;
|
||
|
|
Indent : constant String (1 .. Spaces) := (others => ' ');
|
||
|
|
begin
|
||
|
|
return Indent & Str & New_Line (IO);
|
||
|
|
end Title;
|
||
|
|
|
||
|
|
--------------
|
||
|
|
-- Variable --
|
||
|
|
--------------
|
||
|
|
|
||
|
|
function Variable
|
||
|
|
(IO : Format;
|
||
|
|
Name : String;
|
||
|
|
Value : String) return String
|
||
|
|
is
|
||
|
|
pragma Unreferenced (IO);
|
||
|
|
begin
|
||
|
|
return " " & Name & " = " & Value;
|
||
|
|
end Variable;
|
||
|
|
|
||
|
|
end Text_IO;
|
||
|
|
|
||
|
|
-----------------
|
||
|
|
-- HTML_Output --
|
||
|
|
-----------------
|
||
|
|
|
||
|
|
function HTML_Output return String is
|
||
|
|
HTML : HTML_IO.Format;
|
||
|
|
begin
|
||
|
|
return IO.Output (Mode => HTML);
|
||
|
|
end HTML_Output;
|
||
|
|
|
||
|
|
-----------------
|
||
|
|
-- Text_Output --
|
||
|
|
-----------------
|
||
|
|
|
||
|
|
function Text_Output return String is
|
||
|
|
Text : Text_IO.Format;
|
||
|
|
begin
|
||
|
|
return IO.Output (Mode => Text);
|
||
|
|
end Text_Output;
|
||
|
|
|
||
|
|
end GNAT.CGI.Debug;
|