]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- G N A T . C G I -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
38cbfe40 RK |
9 | -- Copyright (C) 2001 Ada Core Technologies, Inc. -- |
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, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, 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 | -- -- | |
fbf5a39b AC |
29 | -- GNAT was originally developed by the GNAT team at New York University. -- |
30 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
38cbfe40 RK |
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 | else | |
127 | Result (J) := S (K); | |
128 | K := K + 1; | |
129 | end if; | |
130 | ||
131 | J := J + 1; | |
132 | end loop; | |
133 | ||
134 | return Result (Result'First .. J - 1); | |
135 | end Decode; | |
136 | ||
137 | ------------------------- | |
138 | -- For_Every_Parameter -- | |
139 | ------------------------- | |
140 | ||
141 | procedure For_Every_Parameter is | |
142 | Quit : Boolean; | |
143 | ||
144 | begin | |
145 | Check_Environment; | |
146 | ||
147 | for K in 1 .. Key_Value_Table.Last loop | |
148 | ||
149 | Quit := False; | |
150 | ||
151 | Action (Key_Value_Table.Table (K).Key.all, | |
152 | Key_Value_Table.Table (K).Value.all, | |
153 | K, | |
154 | Quit); | |
155 | ||
156 | exit when Quit; | |
157 | ||
158 | end loop; | |
159 | end For_Every_Parameter; | |
160 | ||
161 | ---------------- | |
162 | -- Initialize -- | |
163 | ---------------- | |
164 | ||
165 | procedure Initialize is | |
166 | ||
167 | Request_Method : constant String := | |
168 | Characters.Handling.To_Upper | |
169 | (Metavariable (CGI.Request_Method)); | |
170 | ||
171 | procedure Initialize_GET; | |
172 | -- Read CGI parameters for a GET method. In this case the parameters | |
173 | -- are passed into QUERY_STRING environment variable. | |
174 | ||
175 | procedure Initialize_POST; | |
176 | -- Read CGI parameters for a POST method. In this case the parameters | |
177 | -- are passed with the standard input. The total number of characters | |
178 | -- for the data is passed in CONTENT_LENGTH environment variable. | |
179 | ||
180 | procedure Set_Parameter_Table (Data : String); | |
181 | -- Parse the parameter data and set the parameter table. | |
182 | ||
183 | -------------------- | |
184 | -- Initialize_GET -- | |
185 | -------------------- | |
186 | ||
187 | procedure Initialize_GET is | |
188 | Data : constant String := Metavariable (Query_String); | |
189 | begin | |
190 | Current_Method := Get; | |
191 | if Data /= "" then | |
192 | Set_Parameter_Table (Data); | |
193 | end if; | |
194 | end Initialize_GET; | |
195 | ||
196 | --------------------- | |
197 | -- Initialize_POST -- | |
198 | --------------------- | |
199 | ||
200 | procedure Initialize_POST is | |
201 | Content_Length : constant Natural := | |
202 | Natural'Value (Metavariable (CGI.Content_Length)); | |
203 | Data : String (1 .. Content_Length); | |
204 | ||
205 | begin | |
206 | Current_Method := Post; | |
207 | ||
208 | if Content_Length /= 0 then | |
209 | Text_IO.Get (Data); | |
210 | Set_Parameter_Table (Data); | |
211 | end if; | |
212 | end Initialize_POST; | |
213 | ||
214 | ------------------------- | |
215 | -- Set_Parameter_Table -- | |
216 | ------------------------- | |
217 | ||
218 | procedure Set_Parameter_Table (Data : String) is | |
219 | ||
220 | procedure Add_Parameter (K : Positive; P : String); | |
221 | -- Add a single parameter into the table at index K. The parameter | |
222 | -- format is "key=value". | |
223 | ||
224 | Count : constant Positive := | |
225 | 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&")); | |
226 | -- Count is the number of parameters in the string. Parameters are | |
227 | -- separated by ampersand character. | |
228 | ||
229 | Index : Positive := Data'First; | |
230 | Amp : Natural; | |
231 | ||
232 | ------------------- | |
233 | -- Add_Parameter -- | |
234 | ------------------- | |
235 | ||
236 | procedure Add_Parameter (K : Positive; P : String) is | |
237 | Equal : constant Natural := Strings.Fixed.Index (P, "="); | |
238 | ||
239 | begin | |
240 | if Equal = 0 then | |
241 | raise Data_Error; | |
242 | ||
243 | else | |
244 | Key_Value_Table.Table (K) := | |
245 | Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), | |
246 | new String'(Decode (P (Equal + 1 .. P'Last)))); | |
247 | end if; | |
248 | end Add_Parameter; | |
249 | ||
250 | -- Start of processing for Set_Parameter_Table | |
251 | ||
252 | begin | |
253 | Key_Value_Table.Set_Last (Count); | |
254 | ||
255 | for K in 1 .. Count - 1 loop | |
256 | Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); | |
257 | ||
258 | Add_Parameter (K, Data (Index .. Amp - 1)); | |
259 | ||
260 | Index := Amp + 1; | |
261 | end loop; | |
262 | ||
263 | -- add last parameter | |
264 | ||
265 | Add_Parameter (Count, Data (Index .. Data'Last)); | |
266 | end Set_Parameter_Table; | |
267 | ||
268 | -- Start of processing for Initialize | |
269 | ||
270 | begin | |
271 | if Request_Method = "GET" then | |
272 | Initialize_GET; | |
273 | ||
274 | elsif Request_Method = "POST" then | |
275 | Initialize_POST; | |
276 | ||
277 | else | |
278 | Valid_Environment := False; | |
279 | end if; | |
280 | ||
281 | exception | |
282 | when others => | |
283 | ||
284 | -- If we have an exception during initialization of this unit we | |
285 | -- just declare it invalid. | |
286 | ||
287 | Valid_Environment := False; | |
288 | end Initialize; | |
289 | ||
290 | --------- | |
291 | -- Key -- | |
292 | --------- | |
293 | ||
294 | function Key (Position : Positive) return String is | |
295 | begin | |
296 | Check_Environment; | |
297 | ||
298 | if Position <= Key_Value_Table.Last then | |
299 | return Key_Value_Table.Table (Position).Key.all; | |
300 | else | |
301 | raise Parameter_Not_Found; | |
302 | end if; | |
303 | end Key; | |
304 | ||
305 | ---------------- | |
306 | -- Key_Exists -- | |
307 | ---------------- | |
308 | ||
309 | function Key_Exists (Key : String) return Boolean is | |
310 | begin | |
311 | Check_Environment; | |
312 | ||
313 | for K in 1 .. Key_Value_Table.Last loop | |
314 | if Key_Value_Table.Table (K).Key.all = Key then | |
315 | return True; | |
316 | end if; | |
317 | end loop; | |
318 | ||
319 | return False; | |
320 | end Key_Exists; | |
321 | ||
322 | ------------------ | |
323 | -- Metavariable -- | |
324 | ------------------ | |
325 | ||
326 | function Metavariable | |
327 | (Name : Metavariable_Name; | |
328 | Required : Boolean := False) return String | |
329 | is | |
330 | function Get_Environment (Variable_Name : String) return String; | |
331 | -- Returns the environment variable content. | |
332 | ||
333 | --------------------- | |
334 | -- Get_Environment -- | |
335 | --------------------- | |
336 | ||
337 | function Get_Environment (Variable_Name : String) return String is | |
338 | Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); | |
339 | Result : constant String := Value.all; | |
340 | ||
341 | begin | |
342 | OS_Lib.Free (Value); | |
343 | return Result; | |
344 | end Get_Environment; | |
345 | ||
346 | Result : constant String := | |
347 | Get_Environment (Metavariable_Name'Image (Name)); | |
348 | ||
349 | -- Start of processing for Metavariable | |
350 | ||
351 | begin | |
352 | Check_Environment; | |
353 | ||
354 | if Result = "" and then Required then | |
355 | raise Parameter_Not_Found; | |
356 | else | |
357 | return Result; | |
358 | end if; | |
359 | end Metavariable; | |
360 | ||
361 | ------------------------- | |
362 | -- Metavariable_Exists -- | |
363 | ------------------------- | |
364 | ||
365 | function Metavariable_Exists (Name : Metavariable_Name) return Boolean is | |
366 | begin | |
367 | Check_Environment; | |
368 | ||
369 | if Metavariable (Name) = "" then | |
370 | return False; | |
371 | else | |
372 | return True; | |
373 | end if; | |
374 | end Metavariable_Exists; | |
375 | ||
376 | ------------ | |
377 | -- Method -- | |
378 | ------------ | |
379 | ||
380 | function Method return Method_Type is | |
381 | begin | |
382 | Check_Environment; | |
383 | return Current_Method; | |
384 | end Method; | |
385 | ||
386 | -------- | |
387 | -- Ok -- | |
388 | -------- | |
389 | ||
390 | function Ok return Boolean is | |
391 | begin | |
392 | return Valid_Environment; | |
393 | end Ok; | |
394 | ||
395 | ---------------- | |
396 | -- Put_Header -- | |
397 | ---------------- | |
398 | ||
399 | procedure Put_Header | |
400 | (Header : String := Default_Header; | |
401 | Force : Boolean := False) | |
402 | is | |
403 | begin | |
404 | if Header_Sent = False or else Force then | |
405 | Check_Environment; | |
406 | Text_IO.Put_Line (Header); | |
407 | Text_IO.New_Line; | |
408 | Header_Sent := True; | |
409 | end if; | |
410 | end Put_Header; | |
411 | ||
412 | --------- | |
413 | -- URL -- | |
414 | --------- | |
415 | ||
416 | function URL return String is | |
417 | ||
418 | function Exists_And_Not_80 (Server_Port : String) return String; | |
419 | -- Returns ':' & Server_Port if Server_Port is not "80" and the empty | |
420 | -- string otherwise (80 is the default sever port). | |
421 | ||
422 | ----------------------- | |
423 | -- Exists_And_Not_80 -- | |
424 | ----------------------- | |
425 | ||
426 | function Exists_And_Not_80 (Server_Port : String) return String is | |
427 | begin | |
428 | if Server_Port = "80" then | |
429 | return ""; | |
430 | else | |
431 | return ':' & Server_Port; | |
432 | end if; | |
433 | end Exists_And_Not_80; | |
434 | ||
435 | -- Start of processing for URL | |
436 | ||
437 | begin | |
438 | Check_Environment; | |
439 | ||
440 | return "http://" | |
441 | & Metavariable (Server_Name) | |
442 | & Exists_And_Not_80 (Metavariable (Server_Port)) | |
443 | & Metavariable (Script_Name); | |
444 | end URL; | |
445 | ||
446 | ----------- | |
447 | -- Value -- | |
448 | ----------- | |
449 | ||
450 | function Value | |
451 | (Key : String; | |
452 | Required : Boolean := False) | |
453 | return String | |
454 | is | |
455 | begin | |
456 | Check_Environment; | |
457 | ||
458 | for K in 1 .. Key_Value_Table.Last loop | |
459 | if Key_Value_Table.Table (K).Key.all = Key then | |
460 | return Key_Value_Table.Table (K).Value.all; | |
461 | end if; | |
462 | end loop; | |
463 | ||
464 | if Required then | |
465 | raise Parameter_Not_Found; | |
466 | else | |
467 | return ""; | |
468 | end if; | |
469 | end Value; | |
470 | ||
471 | ----------- | |
472 | -- Value -- | |
473 | ----------- | |
474 | ||
475 | function Value (Position : Positive) return String is | |
476 | begin | |
477 | Check_Environment; | |
478 | ||
479 | if Position <= Key_Value_Table.Last then | |
480 | return Key_Value_Table.Table (Position).Value.all; | |
481 | else | |
482 | raise Parameter_Not_Found; | |
483 | end if; | |
484 | end Value; | |
485 | ||
486 | begin | |
487 | ||
488 | Initialize; | |
489 | ||
490 | end GNAT.CGI; |