+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . C G I . C O O K I E --
--- --
--- B o d y --
--- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc.
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Strings.Fixed;
-with Ada.Strings.Maps;
-with Ada.Text_IO;
-with Ada.Integer_Text_IO;
-
-with GNAT.Table;
-
-package body GNAT.CGI.Cookie is
-
- use Ada;
-
- Valid_Environment : Boolean := False;
- -- This boolean will be set to True if the initialization was fine.
-
- Header_Sent : Boolean := False;
- -- Will be set to True when the header will be sent.
-
- -- Cookie data that have been added.
-
- type String_Access is access String;
-
- type Cookie_Data is record
- Key : String_Access;
- Value : String_Access;
- Comment : String_Access;
- Domain : String_Access;
- Max_Age : Natural;
- Path : String_Access;
- Secure : Boolean := False;
- end record;
-
- type Key_Value is record
- Key, Value : String_Access;
- end record;
-
- package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
- -- This is the table to keep all cookies to be sent back to the server.
-
- package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
- -- This is the table to keep all cookies received from the server.
-
- procedure Check_Environment;
- pragma Inline (Check_Environment);
- -- This procedure will raise Data_Error if Valid_Environment is False.
-
- procedure Initialize;
- -- Initialize CGI package by reading the runtime environment. This
- -- procedure is called during elaboration. All exceptions raised during
- -- this procedure are deferred.
-
- -----------------------
- -- Check_Environment --
- -----------------------
-
- procedure Check_Environment is
- begin
- if not Valid_Environment then
- raise Data_Error;
- end if;
- end Check_Environment;
-
- -----------
- -- Count --
- -----------
-
- function Count return Natural is
- begin
- return Key_Value_Table.Last;
- end Count;
-
- ------------
- -- Exists --
- ------------
-
- function Exists (Key : String) return Boolean is
- begin
- Check_Environment;
-
- for K in 1 .. Key_Value_Table.Last loop
- if Key_Value_Table.Table (K).Key.all = Key then
- return True;
- end if;
- end loop;
-
- return False;
- end Exists;
-
- ----------------------
- -- For_Every_Cookie --
- ----------------------
-
- procedure For_Every_Cookie is
- Quit : Boolean;
-
- begin
- Check_Environment;
-
- for K in 1 .. Key_Value_Table.Last loop
- Quit := False;
-
- Action (Key_Value_Table.Table (K).Key.all,
- Key_Value_Table.Table (K).Value.all,
- K,
- Quit);
-
- exit when Quit;
- end loop;
- end For_Every_Cookie;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
-
- HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
-
- procedure Set_Parameter_Table (Data : String);
- -- Parse Data and insert information in Key_Value_Table.
-
- -------------------------
- -- Set_Parameter_Table --
- -------------------------
-
- procedure Set_Parameter_Table (Data : String) is
-
- procedure Add_Parameter (K : Positive; P : String);
- -- Add a single parameter into the table at index K. The parameter
- -- format is "key=value".
-
- Count : constant Positive
- := 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
- -- Count is the number of parameters in the string. Parameters are
- -- separated by ampersand character.
-
- Index : Positive := Data'First;
- Sep : Natural;
-
- -------------------
- -- Add_Parameter --
- -------------------
-
- procedure Add_Parameter (K : Positive; P : String) is
- Equal : constant Natural := Strings.Fixed.Index (P, "=");
- begin
- if Equal = 0 then
- raise Data_Error;
- else
- Key_Value_Table.Table (K) :=
- Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
- new String'(Decode (P (Equal + 1 .. P'Last))));
- end if;
- end Add_Parameter;
-
- begin
- Key_Value_Table.Set_Last (Count);
-
- for K in 1 .. Count - 1 loop
- Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
-
- Add_Parameter (K, Data (Index .. Sep - 1));
-
- Index := Sep + 2;
- end loop;
-
- -- add last parameter
-
- Add_Parameter (Count, Data (Index .. Data'Last));
- end Set_Parameter_Table;
-
- begin
- if HTTP_COOKIE /= "" then
- Set_Parameter_Table (HTTP_COOKIE);
- end if;
-
- Valid_Environment := True;
-
- exception
- when others =>
- Valid_Environment := False;
- end Initialize;
-
- ---------
- -- Key --
- ---------
-
- function Key (Position : Positive) return String is
- begin
- Check_Environment;
-
- if Position <= Key_Value_Table.Last then
- return Key_Value_Table.Table (Position).Key.all;
- else
- raise Cookie_Not_Found;
- end if;
- end Key;
-
- --------
- -- Ok --
- --------
-
- function Ok return Boolean is
- begin
- return Valid_Environment;
- end Ok;
-
- ----------------
- -- Put_Header --
- ----------------
-
- procedure Put_Header
- (Header : String := Default_Header;
- Force : Boolean := False)
- is
-
- procedure Output_Cookies;
- -- Iterate through the list of cookies to be sent to the server
- -- and output them.
-
- --------------------
- -- Output_Cookies --
- --------------------
-
- procedure Output_Cookies is
-
- procedure Output_One_Cookie
- (Key : String;
- Value : String;
- Comment : String;
- Domain : String;
- Max_Age : Natural;
- Path : String;
- Secure : Boolean);
- -- Output one cookie in the CGI header.
-
- -----------------------
- -- Output_One_Cookie --
- -----------------------
-
- procedure Output_One_Cookie
- (Key : String;
- Value : String;
- Comment : String;
- Domain : String;
- Max_Age : Natural;
- Path : String;
- Secure : Boolean)
- is
- begin
- Text_IO.Put ("Set-Cookie: ");
- Text_IO.Put (Key & '=' & Value);
-
- if Comment /= "" then
- Text_IO.Put ("; Comment=" & Comment);
- end if;
-
- if Domain /= "" then
- Text_IO.Put ("; Domain=" & Domain);
- end if;
-
- if Max_Age /= Natural'Last then
- Text_IO.Put ("; Max-Age=");
- Integer_Text_IO.Put (Max_Age, Width => 0);
- end if;
-
- if Path /= "" then
- Text_IO.Put ("; Path=" & Path);
- end if;
-
- if Secure then
- Text_IO.Put ("; Secure");
- end if;
-
- Text_IO.New_Line;
- end Output_One_Cookie;
-
- -- Start of processing for Output_Cookies
-
- begin
- for C in 1 .. Cookie_Table.Last loop
- Output_One_Cookie (Cookie_Table.Table (C).Key.all,
- Cookie_Table.Table (C).Value.all,
- Cookie_Table.Table (C).Comment.all,
- Cookie_Table.Table (C).Domain.all,
- Cookie_Table.Table (C).Max_Age,
- Cookie_Table.Table (C).Path.all,
- Cookie_Table.Table (C).Secure);
- end loop;
- end Output_Cookies;
-
- -- Start of processing for Put_Header
-
- begin
- if Header_Sent = False or else Force then
- Check_Environment;
- Text_IO.Put_Line (Header);
- Output_Cookies;
- Text_IO.New_Line;
- Header_Sent := True;
- end if;
- end Put_Header;
-
- ---------
- -- Set --
- ---------
-
- procedure Set
- (Key : String;
- Value : String;
- Comment : String := "";
- Domain : String := "";
- Max_Age : Natural := Natural'Last;
- Path : String := "/";
- Secure : Boolean := False) is
- begin
- Cookie_Table.Increment_Last;
-
- Cookie_Table.Table (Cookie_Table.Last) :=
- Cookie_Data'(new String'(Key),
- new String'(Value),
- new String'(Comment),
- new String'(Domain),
- Max_Age,
- new String'(Path),
- Secure);
- end Set;
-
- -----------
- -- Value --
- -----------
-
- function Value
- (Key : String;
- Required : Boolean := False)
- return String
- is
- begin
- Check_Environment;
-
- for K in 1 .. Key_Value_Table.Last loop
- if Key_Value_Table.Table (K).Key.all = Key then
- return Key_Value_Table.Table (K).Value.all;
- end if;
- end loop;
-
- if Required then
- raise Cookie_Not_Found;
- else
- return "";
- end if;
- end Value;
-
- function Value (Position : Positive) return String is
- begin
- Check_Environment;
-
- if Position <= Key_Value_Table.Last then
- return Key_Value_Table.Table (Position).Value.all;
- else
- raise Cookie_Not_Found;
- end if;
- end Value;
-
--- Elaboration code for package
-
-begin
- -- Initialize unit by reading the HTTP_COOKIE metavariable and fill
- -- Key_Value_Table structure.
-
- Initialize;
-end GNAT.CGI.Cookie;
projects / msp430-gcc.git / blobdiff