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