File : 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 -- --
19 -- --
20 -- --
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;