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 32with Ada.Text_IO; 33with Ada.Strings.Fixed; 34with Ada.Characters.Handling; 35with Ada.Strings.Maps; 36 37with GNAT.OS_Lib; 38with GNAT.Table; 39 40package 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 490begin 491 492 Initialize; 493 494end GNAT.CGI; 495