1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001 Ada Core Technologies, Inc. --
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. --
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. --
29 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
34 with Ada
.Strings
.Fixed
;
35 with Ada
.Characters
.Handling
;
36 with Ada
.Strings
.Maps
;
41 package body GNAT
.CGI
is
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.
51 Current_Method
: Method_Type
;
52 -- This is the current method used to pass CGI parameters.
54 Header_Sent
: Boolean := False;
55 -- Will be set to True when the header will be sent.
57 -- Key/Value table declaration
59 type String_Access
is access String;
61 type Key_Value
is record
63 Value
: String_Access
;
66 package Key_Value_Table
is new Table
(Key_Value
, Positive, 1, 1, 50);
68 -----------------------
69 -- Local subprograms --
70 -----------------------
72 procedure Check_Environment
;
73 pragma Inline
(Check_Environment
);
74 -- This procedure will raise Data_Error if Valid_Environment is False.
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.
85 function Argument_Count
return Natural is
88 return Key_Value_Table
.Last
;
91 -----------------------
92 -- Check_Environment --
93 -----------------------
95 procedure Check_Environment
is
97 if not Valid_Environment
then
100 end Check_Environment
;
106 function Decode
(S
: String) return String is
107 Result
: String (S
'Range);
108 K
: Positive := S
'First;
109 J
: Positive := Result
'First;
112 while K
<= S
'Last loop
115 and then Characters
.Handling
.Is_Hexadecimal_Digit
(S
(K
+ 1))
116 and then Characters
.Handling
.Is_Hexadecimal_Digit
(S
(K
+ 2))
118 -- Here we have '%HH' which is an encoded character where 'HH' is
119 -- the character number in hexadecimal.
121 Result
(J
) := Character'Val
122 (Natural'Value ("16#" & S
(K
+ 1 .. K
+ 2) & '#'));
133 return Result
(Result
'First .. J
- 1);
136 -------------------------
137 -- For_Every_Parameter --
138 -------------------------
140 procedure For_Every_Parameter
is
146 for K
in 1 .. Key_Value_Table
.Last
loop
150 Action
(Key_Value_Table
.Table
(K
).Key
.all,
151 Key_Value_Table
.Table
(K
).Value
.all,
158 end For_Every_Parameter
;
164 procedure Initialize
is
166 Request_Method
: constant String :=
167 Characters
.Handling
.To_Upper
168 (Metavariable
(CGI
.Request_Method
));
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.
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.
179 procedure Set_Parameter_Table
(Data
: String);
180 -- Parse the parameter data and set the parameter table.
186 procedure Initialize_GET
is
187 Data
: constant String := Metavariable
(Query_String
);
189 Current_Method
:= Get
;
191 Set_Parameter_Table
(Data
);
195 ---------------------
196 -- Initialize_POST --
197 ---------------------
199 procedure Initialize_POST
is
200 Content_Length
: constant Natural :=
201 Natural'Value (Metavariable
(CGI
.Content_Length
));
202 Data
: String (1 .. Content_Length
);
205 Current_Method
:= Post
;
207 if Content_Length
/= 0 then
209 Set_Parameter_Table
(Data
);
213 -------------------------
214 -- Set_Parameter_Table --
215 -------------------------
217 procedure Set_Parameter_Table
(Data
: String) is
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".
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.
228 Index
: Positive := Data
'First;
235 procedure Add_Parameter
(K
: Positive; P
: String) is
236 Equal
: constant Natural := Strings
.Fixed
.Index
(P
, "=");
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))));
249 -- Start of processing for Set_Parameter_Table
252 Key_Value_Table.Set_Last (Count);
254 for K in 1 .. Count - 1 loop
255 Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
257 Add_Parameter (K, Data (Index .. Amp - 1));
262 -- add last parameter
264 Add_Parameter (Count, Data (Index .. Data'Last));
265 end Set_Parameter_Table;
267 -- Start of processing for Initialize
270 if Request_Method = "GET" then
273 elsif Request_Method = "POST" then
277 Valid_Environment := False;
283 -- If we have an exception during initialization of this unit we
284 -- just declare it invalid.
286 Valid_Environment := False;
293 function Key (Position : Positive) return String is
297 if Position <= Key_Value_Table.Last then
298 return Key_Value_Table.Table (Position).Key.all;
300 raise Parameter_Not_Found;
308 function Key_Exists (Key : String) return Boolean is
312 for K in 1 .. Key_Value_Table.Last loop
313 if Key_Value_Table.Table (K).Key.all = Key then
325 function Metavariable
326 (Name : Metavariable_Name;
327 Required : Boolean := False) return String
329 function Get_Environment (Variable_Name : String) return String;
330 -- Returns the environment variable content.
332 ---------------------
333 -- Get_Environment --
334 ---------------------
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;
345 Result : constant String :=
346 Get_Environment (Metavariable_Name'Image (Name));
348 -- Start of processing for Metavariable
353 if Result = "" and then Required then
354 raise Parameter_Not_Found;
360 -------------------------
361 -- Metavariable_Exists --
362 -------------------------
364 function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
368 if Metavariable (Name) = "" then
373 end Metavariable_Exists;
379 function Method return Method_Type is
382 return Current_Method;
389 function Ok return Boolean is
391 return Valid_Environment;
399 (Header : String := Default_Header;
400 Force : Boolean := False)
403 if Header_Sent = False or else Force then
405 Text_IO.Put_Line (Header);
415 function URL return String is
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).
421 -----------------------
422 -- Exists_And_Not_80 --
423 -----------------------
425 function Exists_And_Not_80 (Server_Port : String) return String is
427 if Server_Port = "80" then
430 return ':' & Server_Port;
432 end Exists_And_Not_80;
434 -- Start of processing for URL
440 & Metavariable (Server_Name)
441 & Exists_And_Not_80 (Metavariable (Server_Port))
442 & Metavariable (Script_Name);
451 Required : Boolean := False)
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;
464 raise Parameter_Not_Found;
474 function Value (Position : Positive) return String is
478 if Position <= Key_Value_Table.Last then
479 return Key_Value_Table.Table (Position).Value.all;
481 raise Parameter_Not_Found;