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