cgi-flags.adb


------------------------------------------------------------------------------
--
--  package CGI.Flags (body)
--
------------------------------------------------------------------------------
--  Update information:
--
--  1996.05.15 (Jacob Sparre Andersen)
--    Written.
--    Child of David A. Wheeler's CGI package.
--
--  1996.07.07 (Jacob Sparre Andersen)
--    Written a new version of Language_Priority_List.
--
--  1996.07.08 (Jacob Sparre Andersen)
--    Changed Version_Type to HTML_Version_Type. Now it's an enumerated type.
--    Added Use_Images.
--
--  1996.07.11 (Jacob Sparre Andersen)
--    The client address is in the environment variable REMOTE_HOST.
--
--  (Insert additional update information above this line.)
------------------------------------------------------------------------------

with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Text_IO;

with In_List;

package body CGI.Flags is

   use Ada.Text_IO;

   ---------------------------------------------------------------------------
   --  Language (private):

   --  Exceptions:
   --    Bad_Language_Format

   function Language (Item               : in String;
                      Exception_On_Error : in Boolean := True)
     return Language_Type is

      use Ada.Characters.Handling;

   begin -- Language
      case Item'Length is
         when 2 => --  two letters
            return (1 => To_Lower (Item (Item'First)),
                    2 => To_Lower (Item (Item'First + 1)));
         when 5 => --  two letters - dot - two letters
            if Item (Item'First + 2) = '.' then
               return (1 => To_Lower (Item (Item'First)),
                       2 => To_Lower (Item (Item'First + 1)));
            else
               raise Bad_Language_Format;
            end if;
         when others =>
            raise Bad_Language_Format;
      end case;
   exception
      when Constraint_Error =>
         if Exception_On_Error then
            raise Bad_Language_Format;
         else
            return English;
         end if;
      when others =>
         Put_Line (Current_Error,
                   "CGI.Flags.Language: Unexpected exception.");

         if Exception_On_Error then
            raise;
         else
            return English;
         end if;
   end Language;

   ---------------------------------------------------------------------------
   --  Reduce_Language_List (private):

   function Reduce_Language_List (List : in Language_List_Type)
     return Language_List_Type is

      Result  : Language_List_Type (1 .. List'Length);

      Counted : array (List'Range) of Boolean := (others => False);

      Unique_Count : Natural := 0;

   begin --  Reduce_Language_List
      for Index in List'Range loop
         if not Counted (Index) then
            Unique_Count := Unique_Count + 1;
            Result (Unique_Count) := List (Index);

            for Compare_Index in Index .. List'Last loop
               Counted (Compare_Index) := List (Index) = List (Compare_Index);
            end loop;
         end if;
      end loop;

      return Result (1 .. Unique_Count);
   end Reduce_Language_List;

   ---------------------------------------------------------------------------
   --  function Location_Dependent_Language:
   --
   --  Guesses the preferred language from the client address.

   function Location_Dependent_Language return Language_Type is

      use Ada.Strings;
      use Ada.Strings.Fixed;

      Client_Address : String := CGI.Get_Environment ("REMOTE_HOST");
      First, Last    : Natural;

   begin --  Location_Dependent_Language
      Last := Client_Address'Last;
      First := Index (Source  => Client_Address,
                      Pattern => ".",
                      Going   => Backward) + 1;

      if Client_Address (First .. Last) = "fo" then
         return "fo";
      elsif Client_Address (First .. Last) = "dk" then
         return "da";
      else
         return English;
      end if;
   end Location_Dependent_Language;

   ---------------------------------------------------------------------------
   --  function Language_Priority_List:
   --
   --  Returns the set of suggested languages.

   function Language_Priority_List return Language_List_Type is

      Result : Language_List_Type (1 .. Key_Count (Language_Arg) + 2) :=
        (others => English);

   begin --  Language_Priority_List
      for Index in 1 .. Key_Count (Language_Arg) loop
         Result (Index) := Language (Value (Language_Arg, Index));
      end loop;

      Result (Result'Last - 1) := Location_Dependent_Language;

      return Reduce_Language_List (Result);
   end Language_Priority_List;

   ---------------------------------------------------------------------------
   --  function Language_Priority_List:
   --
   --  Returns the subset of suggested languages, that are in the list
   --  Accepted_Languages.

   function Language_Priority_List
     (Accepted_Languages : in Language_List_Type) return Language_List_Type is

      function In_Language_List is new In_List
        (Element_Type => Language_Type,
         List_Type    => Language_List_Type);

      Buffer       : Language_List_Type := Language_Priority_List;
      Accept_Count : Integer := Buffer'First - 1;

   begin --  Language_Priority_List
      for Index in Buffer'Range loop
         if In_Language_List (Item => Buffer (Index),
                              List => Accepted_Languages) then
            Accept_Count := Accept_Count + 1;
            Buffer (Accept_Count) := Buffer (Index);
         end if;
      end loop;

      return Buffer (Buffer'First .. Accept_Count);
   end Language_Priority_List;

   ---------------------------------------------------------------------------
   --  HTML_Version:

   function HTML_Version return HTML_Version_Type is

      use Ada.Strings.Fixed;

   begin --  HTML_Version
      if Key_Exists (HTML_Version_Arg) then
         if Value (HTML_Version_Arg) = "2" then
            return HTML_2;
         elsif Value (HTML_Version_Arg) = "3.2" then
            return HTML_3_2;
         elsif Value (HTML_Version_Arg) = "3" then
            return HTML_3;
         else
            raise Invalid_HTML_Version_Argument;
         end if;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Mozilla") = 1 then
         return Netscape;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Lynx") = 1 then
         return HTML_2;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Mosaic") = 1 then
         return HTML_2;
      else
         return HTML_3_2;
      end if;
   end HTML_Version;

   ---------------------------------------------------------------------------
   --  Table_Rendering_Mode:

   function Table_Rendering_Mode return Table_Rendering_Type is

   begin --  Table_Rendering_Mode
      if Key_Exists (Tables_Arg) then
         if Value (Tables_Arg) = "yes" then
            return As_Table;
         elsif Value (Tables_Arg) = "no" then
            return As_Preformatted_Text;
         elsif Value (Tables_Arg) = "dl" then
            return As_Definition_List;
         elsif Value (Tables_Arg) = "pre" then
            return As_Preformatted_Text;
         else
            raise Invalid_Table_Rendering_Argument;
         end if;
      else
         if HTML_Version = HTML_2 then
            return As_Preformatted_Text;
         else
            return As_Table;
         end if;
      end if;
   end Table_Rendering_Mode;

   ---------------------------------------------------------------------------
   --  Use_Frames:

   function Use_Frames return Boolean is

      use Ada.Strings.Fixed;

   begin --  Use_Frames
      if Key_Exists (Frames_Arg) then
         if Value (Frames_Arg) = "yes" then
            return True;
         elsif Value (Frames_Arg) = "no" then
            return False;
         else
            raise Invalid_Frame_Mode_Argument;
         end if;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Mozilla") = 1 then
         return True;
      else
         return False;
      end if;
   end Use_Frames;

   ---------------------------------------------------------------------------
   --  function Use_Images:

   function Use_Images return Boolean is

      use Ada.Strings.Fixed;

   begin --  Use_Images
      if Key_Exists (Images_Arg) then
         if Value (Images_Arg) = "yes" then
            return True;
         elsif Value (Images_Arg) = "no" then
            return False;
         else
            raise Invalid_Frame_Mode_Argument;
         end if;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Mosaic") = 1 then
         return True;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Mozilla") = 1 then
         return True;
      elsif Index (Source  => Get_Environment ("HTTP_USER_AGENT"),
                   Pattern => "Lynx") = 1 then
         return False;
      else
         return True;
      end if;
   end Use_Images;

   ---------------------------------------------------------------------------

end CGI.Flags;

Typeset with Ada_To_HTML (Jacob and Jesper)