gcc/ada/g-cgi.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G N A T . C G I                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --              Copyright (C) 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.Text_IO;
  34 with Ada.Strings.Fixed;
  35 with Ada.Characters.Handling;
  36 with Ada.Strings.Maps;
  37
  38 with GNAT.OS_Lib;
  39 with GNAT.Table;
  40
  41 package body GNAT.CGI is
  42
  43    use Ada;
  44
  45    Valid_Environment : Boolean := True;
  46    --  This boolean will be set to False if the initialization was not
  47    --  completed correctly. It must be set to true there because the
  48    --  Initialize routine (called during elaboration) will use some of the
  49    --  services exported by this unit.
  50
  51    Current_Method : Method_Type;
  52    --  This is the current method used to pass CGI parameters.
  53
  54    Header_Sent : Boolean := False;
  55    --  Will be set to True when the header will be sent.
  56
  57    --  Key/Value table declaration
  58
  59    type String_Access is access String;
  60
  61    type Key_Value is record
  62       Key   : String_Access;
  63       Value : String_Access;
  64    end record;
  65
  66    package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
  67
  68    -----------------------
  69    -- Local subprograms --
  70    -----------------------
  71
  72    procedure Check_Environment;
  73    pragma Inline (Check_Environment);
  74    --  This procedure will raise Data_Error if Valid_Environment is False.
  75
  76    procedure Initialize;
  77    --  Initialize CGI package by reading the runtime environment. This
  78    --  procedure is called during elaboration. All exceptions raised during
  79    --  this procedure are deferred.
  80
  81    --------------------
  82    -- Argument_Count --
  83    --------------------
  84
  85    function Argument_Count return Natural is
  86    begin
  87       Check_Environment;
  88       return Key_Value_Table.Last;
  89    end Argument_Count;
  90
  91    -----------------------
  92    -- Check_Environment --
  93    -----------------------
  94
  95    procedure Check_Environment is
  96    begin
  97       if not Valid_Environment then
  98          raise Data_Error;
  99       end if;
 100    end Check_Environment;
 101
 102    ------------
 103    -- Decode --
 104    ------------
 105
 106    function Decode (S : String) return String is
 107       Result : String (S'Range);
 108       K      : Positive := S'First;
 109       J      : Positive := Result'First;
 110
 111    begin
 112       while K <= S'Last loop
 113          if K + 2 <= S'Last
 114            and then  S (K) = '%'
 115            and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
 116            and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
 117          then
 118             --  Here we have '%HH' which is an encoded character where 'HH' is
 119             --  the character number in hexadecimal.
 120
 121             Result (J) := Character'Val
 122               (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#'));
 123             K := K + 3;
 124
 125          else
 126             Result (J) := S (K);
 127             K := K + 1;
 128          end if;
 129
 130          J := J + 1;
 131       end loop;
 132
 133       return Result (Result'First .. J - 1);
 134    end Decode;
 135
 136    -------------------------
 137    -- For_Every_Parameter --
 138    -------------------------
 139
 140    procedure For_Every_Parameter is
 141       Quit : Boolean;
 142
 143    begin
 144       Check_Environment;
 145
 146       for K in 1 .. Key_Value_Table.Last loop
 147
 148          Quit := False;
 149
 150          Action (Key_Value_Table.Table (K).Key.all,
 151                  Key_Value_Table.Table (K).Value.all,
 152                  K,
 153                  Quit);
 154
 155          exit when Quit;
 156
 157       end loop;
 158    end For_Every_Parameter;
 159
 160    ----------------
 161    -- Initialize --
 162    ----------------
 163
 164    procedure Initialize is
 165
 166       Request_Method : constant String :=
 167                          Characters.Handling.To_Upper
 168                            (Metavariable (CGI.Request_Method));
 169
 170       procedure Initialize_GET;
 171       --  Read CGI parameters for a GET method. In this case the parameters
 172       --  are passed into QUERY_STRING environment variable.
 173
 174       procedure Initialize_POST;
 175       --  Read CGI parameters for a POST method. In this case the parameters
 176       --  are passed with the standard input. The total number of characters
 177       --  for the data is passed in CONTENT_LENGTH environment variable.
 178
 179       procedure Set_Parameter_Table (Data : String);
 180       --  Parse the parameter data and set the parameter table.
 181
 182       --------------------
 183       -- Initialize_GET --
 184       --------------------
 185
 186       procedure Initialize_GET is
 187          Data : constant String := Metavariable (Query_String);
 188       begin
 189          Current_Method := Get;
 190          if Data /= "" then
 191             Set_Parameter_Table (Data);
 192          end if;
 193       end Initialize_GET;
 194
 195       ---------------------
 196       -- Initialize_POST --
 197       ---------------------
 198
 199       procedure Initialize_POST is
 200          Content_Length : constant Natural :=
 201                             Natural'Value (Metavariable (CGI.Content_Length));
 202          Data : String (1 .. Content_Length);
 203
 204       begin
 205          Current_Method := Post;
 206
 207          if Content_Length /= 0 then
 208             Text_IO.Get (Data);
 209             Set_Parameter_Table (Data);
 210          end if;
 211       end Initialize_POST;
 212
 213       -------------------------
 214       -- Set_Parameter_Table --
 215       -------------------------
 216
 217       procedure Set_Parameter_Table (Data : String) is
 218
 219          procedure Add_Parameter (K : Positive; P : String);
 220          --  Add a single parameter into the table at index K. The parameter
 221          --  format is "key=value".
 222
 223          Count : constant Positive :=
 224                    1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&"));
 225          --  Count is the number of parameters in the string. Parameters are
 226          --  separated by ampersand character.
 227
 228          Index : Positive := Data'First;
 229          Amp   : Natural;
 230
 231          -------------------
 232          -- Add_Parameter --
 233          -------------------
 234
 235          procedure Add_Parameter (K : Positive; P : String) is
 236             Equal : constant Natural := Strings.Fixed.Index (P, "=");
 237
 238          begin
 239             if Equal = 0 then
 240                raise Data_Error;
 241
 242             else
 243                Key_Value_Table.Table (K) :=
 244                  Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
 245                             new String'(Decode (P (Equal + 1 .. P'Last))));
 246             end if;
 247          end Add_Parameter;
 248
 249       --  Start of processing for Set_Parameter_Table
 250
 251       begin
 252          Key_Value_Table.Set_Last (Count);
 253
 254          for K in 1 .. Count - 1 loop
 255             Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
 256
 257             Add_Parameter (K, Data (Index .. Amp - 1));
 258
 259             Index := Amp + 1;
 260          end loop;
 261
 262          --  add last parameter
 263
 264          Add_Parameter (Count, Data (Index .. Data'Last));
 265       end Set_Parameter_Table;
 266
 267    --  Start of processing for Initialize
 268
 269    begin
 270       if Request_Method = "GET" then
 271          Initialize_GET;
 272
 273       elsif Request_Method = "POST" then
 274          Initialize_POST;
 275
 276       else
 277          Valid_Environment := False;
 278       end if;
 279
 280    exception
 281       when others =>
 282
 283          --  If we have an exception during initialization of this unit we
 284          --  just declare it invalid.
 285
 286          Valid_Environment := False;
 287    end Initialize;
 288
 289    ---------
 290    -- Key --
 291    ---------
 292
 293    function Key (Position : Positive) return String is
 294    begin
 295       Check_Environment;
 296
 297       if Position <= Key_Value_Table.Last then
 298          return Key_Value_Table.Table (Position).Key.all;
 299       else
 300          raise Parameter_Not_Found;
 301       end if;
 302    end Key;
 303
 304    ----------------
 305    -- Key_Exists --
 306    ----------------
 307
 308    function Key_Exists (Key : String) return Boolean is
 309    begin
 310       Check_Environment;
 311
 312       for K in 1 .. Key_Value_Table.Last loop
 313          if Key_Value_Table.Table (K).Key.all = Key then
 314             return True;
 315          end if;
 316       end loop;
 317
 318       return False;
 319    end Key_Exists;
 320
 321    ------------------
 322    -- Metavariable --
 323    ------------------
 324
 325    function Metavariable
 326      (Name     : Metavariable_Name;
 327       Required : Boolean := False) return String
 328    is
 329       function Get_Environment (Variable_Name : String) return String;
 330       --  Returns the environment variable content.
 331
 332       ---------------------
 333       -- Get_Environment --
 334       ---------------------
 335
 336       function Get_Environment (Variable_Name : String) return String is
 337          Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
 338          Result : constant String := Value.all;
 339
 340       begin
 341          OS_Lib.Free (Value);
 342          return Result;
 343       end Get_Environment;
 344
 345       Result : constant String :=
 346                  Get_Environment (Metavariable_Name'Image (Name));
 347
 348    --  Start of processing for Metavariable
 349
 350    begin
 351       Check_Environment;
 352
 353       if Result = "" and then Required then
 354          raise Parameter_Not_Found;
 355       else
 356          return Result;
 357       end if;
 358    end Metavariable;
 359
 360    -------------------------
 361    -- Metavariable_Exists --
 362    -------------------------
 363
 364    function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
 365    begin
 366       Check_Environment;
 367
 368       if Metavariable (Name) = "" then
 369          return False;
 370       else
 371          return True;
 372       end if;
 373    end Metavariable_Exists;
 374
 375    ------------
 376    -- Method --
 377    ------------
 378
 379    function Method return Method_Type is
 380    begin
 381       Check_Environment;
 382       return Current_Method;
 383    end Method;
 384
 385    --------
 386    -- Ok --
 387    --------
 388
 389    function Ok return Boolean is
 390    begin
 391       return Valid_Environment;
 392    end Ok;
 393
 394    ----------------
 395    -- Put_Header --
 396    ----------------
 397
 398    procedure Put_Header
 399      (Header : String  := Default_Header;
 400       Force  : Boolean := False)
 401    is
 402    begin
 403       if Header_Sent = False or else Force then
 404          Check_Environment;
 405          Text_IO.Put_Line (Header);
 406          Text_IO.New_Line;
 407          Header_Sent := True;
 408       end if;
 409    end Put_Header;
 410
 411    ---------
 412    -- URL --
 413    ---------
 414
 415    function URL return String is
 416
 417       function Exists_And_Not_80 (Server_Port : String) return String;
 418       --  Returns ':' & Server_Port if Server_Port is not "80" and the empty
 419       --  string otherwise (80 is the default sever port).
 420
 421       -----------------------
 422       -- Exists_And_Not_80 --
 423       -----------------------
 424
 425       function Exists_And_Not_80 (Server_Port : String) return String is
 426       begin
 427          if Server_Port = "80" then
 428             return "";
 429          else
 430             return ':' & Server_Port;
 431          end if;
 432       end Exists_And_Not_80;
 433
 434    --  Start of processing for URL
 435
 436    begin
 437       Check_Environment;
 438
 439       return "http://"
 440         & Metavariable (Server_Name)
 441         & Exists_And_Not_80 (Metavariable (Server_Port))
 442         & Metavariable (Script_Name);
 443    end URL;
 444
 445    -----------
 446    -- Value --
 447    -----------
 448
 449    function Value
 450      (Key      : String;
 451       Required : Boolean := False)
 452       return     String
 453    is
 454    begin
 455       Check_Environment;
 456
 457       for K in 1 .. Key_Value_Table.Last loop
 458          if Key_Value_Table.Table (K).Key.all = Key then
 459             return Key_Value_Table.Table (K).Value.all;
 460          end if;
 461       end loop;
 462
 463       if Required then
 464          raise Parameter_Not_Found;
 465       else
 466          return "";
 467       end if;
 468    end Value;
 469
 470    -----------
 471    -- Value --
 472    -----------
 473
 474    function Value (Position : Positive) return String is
 475    begin
 476       Check_Environment;
 477
 478       if Position <= Key_Value_Table.Last then
 479          return Key_Value_Table.Table (Position).Value.all;
 480       else
 481          raise Parameter_Not_Found;
 482       end if;
 483    end Value;
 484
 485 begin
 486
 487    Initialize;
 488
 489 end GNAT.CGI;