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