-----------------------------------------------------------------------
--  awa-workspaces-tests -- Unit tests for workspaces and invitations
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Test_Caller;
with Util.Strings;
with ADO;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
with ASF.Helpers.Beans;
with ASF.Tests;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with Security.Contexts;
with AWA.Workspaces.Beans;

package body AWA.Workspaces.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   function Get_Invitation_Bean is
     new ASF.Helpers.Beans.Get_Request_Bean (Element_Type   => Beans.Invitation_Bean,
                                             Element_Access => Beans.Invitation_Bean_Access);

   package Caller is new Util.Test_Caller (Test, "Workspaces.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Send",
                       Test_Invite_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Delete",
                       Test_Delete_Member'Access);
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Accept",
                       Test_Accept_Invitation'Access);
   end Add_Tests;

   --  ------------------------------
   --  Verify the anonymous access for the invitation page.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Key  : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html", "invitation-view.html");
      ASF.Tests.Assert_Contains (T, "Bad or invalid invitation", Reply,
                                 "This invitation is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=test", "invitation-bad.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired", Reply,
                                 "This invitation is invalid (key)");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=x" & key,
                        "invitation-bad2.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired",
                                 Reply, "This invitation is invalid (key)");

      if Key = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=" & Key, "invitation-ok.html");
      ASF.Tests.Assert_Contains (T, "Accept invitation", Reply,
                                 "Accept invitation page is invalid");

   end Verify_Anonymous;

   --  ------------------------------
   --  Test sending an invitation.
   --  ------------------------------
   procedure Test_Invite_User (T : in out Test) is
      use type ADO.Identifier;
      use type AWA.Workspaces.Beans.Invitation_Bean_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Invite    : AWA.Workspaces.Beans.Invitation_Bean_Access;
      Check     : AWA.Workspaces.Beans.Invitation_Bean;
   begin
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      Request.Set_Parameter ("email", "invited-user@test.com");
      Request.Set_Parameter ("message", "I invite you to this application");
      Request.Set_Parameter ("send", "1");
      Request.Set_Parameter ("invite", "1");
      ASF.Tests.Do_Post (Request, Reply, "/workspaces/invite.html", "invite.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Invalid response after invitation creation");

      --  Verify the invitation by looking at the inviteUser bean.
      Invite := Get_Invitation_Bean (Request, "inviteUser");
      T.Assert (Invite /= null, "Null inviteUser bean");
      T.Assert (Invite.Get_Id /= ADO.NO_IDENTIFIER, "The invite ID is invalid");
      T.Assert (not Invite.Get_Access_Key.Is_Null, "The invite access key is null");
      T.Assert (Invite.Get_Member.Is_Inserted, "The invitation has a workspace member");
      Check.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Verify_Anonymous (Invite.Get_Access_Key.Get_Access_Key);

      T.Member_ID := Invite.Get_Member.Get_Id;
   end Test_Invite_User;

   --  ------------------------------
   --  Test deleting the member.
   --  ------------------------------
   procedure Test_Delete_Member (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      T.Test_Invite_User;
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      declare
         Id : constant String := ADO.Identifier'Image (T.Member_Id);
      begin
         Request.Set_Parameter ("member-id", Id);
         Request.Set_Parameter ("delete", "1");
         Request.Set_Parameter ("delete-member-form", "1");
         ASF.Tests.Do_Post (Request, Reply, "/workspaces/forms/delete-member.html",
                            "delete-member.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_OK,
                   "Invalid response after delete member operation");
         ASF.Tests.Assert_Contains (T, "deleteDialog_" & Id (Id'First + 1 .. Id'Last), Reply,
                                    "Delete member dialog operation response is invalid");
      end;
   end Test_Delete_Member;

   --  ------------------------------
   --  Test accepting the invitation.
   --  ------------------------------
   procedure Test_Accept_Invitation (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      T.Test_Invite_User;
      AWA.Tests.Helpers.Users.Recover_Password ("invited-user@test.com");
      AWA.Tests.Helpers.Users.Login ("invited-user@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/workspaces/accept-invitation.html?key="
                        & To_String (T.Key),
                        "accept-member.html");
      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Accept invitation page failed");
      Util.Tests.Assert_Equals (T, "/asfunit/workspaces/main.html", Reply.Get_Header ("Location"),
                                "The accept invitation page must redirect to the workspace");
   end Test_Accept_Invitation;

end AWA.Workspaces.Tests;

-----------------------------------------------------------------------
--  awa-workspaces-tests -- Unit tests for workspaces and invitations
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Test_Caller;
with Util.Strings;
with ADO;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
with ASF.Helpers.Beans;
with ASF.Tests;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with Security.Contexts;
with AWA.Workspaces.Beans;

package body AWA.Workspaces.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   function Get_Invitation_Bean is
     new ASF.Helpers.Beans.Get_Request_Bean (Element_Type   => Beans.Invitation_Bean,
                                             Element_Access => Beans.Invitation_Bean_Access);

   package Caller is new Util.Test_Caller (Test, "Workspaces.Beans");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Send",
                       Test_Invite_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Delete",
                       Test_Delete_Member'Access);
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Accept",
                       Test_Accept_Invitation'Access);
      Caller.Add_Test (Suite, "Test AWA.Workspaces.Beans.Member_List",
                       Test_List_Members'Access);
   end Add_Tests;

   --  ------------------------------
   --  Verify the anonymous access for the invitation page.
   --  ------------------------------
   procedure Verify_Anonymous (T    : in out Test;
                               Key  : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html", "invitation-view.html");
      ASF.Tests.Assert_Contains (T, "Bad or invalid invitation", Reply,
                                 "This invitation is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=test", "invitation-bad.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired", Reply,
                                 "This invitation is invalid (key)");

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=x" & key,
                        "invitation-bad2.html");
      ASF.Tests.Assert_Contains (T, "This invitation is invalid or has expired",
                                 Reply, "This invitation is invalid (key)");

      if Key = "" then
         return;
      end if;

      ASF.Tests.Do_Get (Request, Reply, "/auth/invitation.html?key=" & Key, "invitation-ok.html");
      ASF.Tests.Assert_Contains (T, "Accept invitation", Reply,
                                 "Accept invitation page is invalid");

   end Verify_Anonymous;

   --  ------------------------------
   --  Test sending an invitation.
   --  ------------------------------
   procedure Test_Invite_User (T : in out Test) is
      use type ADO.Identifier;
      use type AWA.Workspaces.Beans.Invitation_Bean_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Invite    : AWA.Workspaces.Beans.Invitation_Bean_Access;
      Check     : AWA.Workspaces.Beans.Invitation_Bean;
   begin
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      Request.Set_Parameter ("email", "invited-user@test.com");
      Request.Set_Parameter ("message", "I invite you to this application");
      Request.Set_Parameter ("send", "1");
      Request.Set_Parameter ("invite", "1");
      ASF.Tests.Do_Post (Request, Reply, "/workspaces/invite.html", "invite.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Invalid response after invitation creation");

      --  Verify the invitation by looking at the inviteUser bean.
      Invite := Get_Invitation_Bean (Request, "inviteUser");
      T.Assert (Invite /= null, "Null inviteUser bean");
      T.Assert (Invite.Get_Id /= ADO.NO_IDENTIFIER, "The invite ID is invalid");
      T.Assert (not Invite.Get_Access_Key.Is_Null, "The invite access key is null");
      T.Assert (Invite.Get_Member.Is_Inserted, "The invitation has a workspace member");
      Check.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Key := Invite.Get_Access_Key.Get_Access_Key;
      T.Verify_Anonymous (Invite.Get_Access_Key.Get_Access_Key);

      T.Member_ID := Invite.Get_Member.Get_Id;
   end Test_Invite_User;

   --  ------------------------------
   --  Test deleting the member.
   --  ------------------------------
   procedure Test_Delete_Member (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      T.Test_Invite_User;
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      declare
         Id : constant String := ADO.Identifier'Image (T.Member_Id);
      begin
         Request.Set_Parameter ("member-id", Id);
         Request.Set_Parameter ("delete", "1");
         Request.Set_Parameter ("delete-member-form", "1");
         ASF.Tests.Do_Post (Request, Reply, "/workspaces/forms/delete-member.html",
                            "delete-member.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_OK,
                   "Invalid response after delete member operation");
         ASF.Tests.Assert_Contains (T, "deleteDialog_" & Id (Id'First + 1 .. Id'Last), Reply,
                                    "Delete member dialog operation response is invalid");
      end;
   end Test_Delete_Member;

   --  ------------------------------
   --  Test accepting the invitation.
   --  ------------------------------
   procedure Test_Accept_Invitation (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      T.Test_Invite_User;
      AWA.Tests.Helpers.Users.Recover_Password ("invited-user@test.com");
      AWA.Tests.Helpers.Users.Login ("invited-user@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/workspaces/accept-invitation.html?key="
                        & To_String (T.Key),
                        "accept-member.html");
      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY,
                "Accept invitation page failed");
      Util.Tests.Assert_Equals (T, "/asfunit/workspaces/main.html", Reply.Get_Header ("Location"),
                                "The accept invitation page must redirect to the workspace");
   end Test_Accept_Invitation;

   --  ------------------------------
   --  Test listing the members of the workspace.
   --  ------------------------------
   procedure Test_List_Members (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      T.Test_Invite_User;
      AWA.Tests.Helpers.Users.Login ("test-invite@test.com", Request);
      ASF.Tests.Do_Get (Request, Reply, "/workspaces/members.html",
                        "member-list.html");
      ASF.Tests.Assert_Contains (T, "invited-user@test.com", Reply,
                                 "The invited user is listed in the members page");
      ASF.Tests.Assert_Contains (T, "test-invite@test.com", Reply,
                                 "The invite user (owner) is listed in the members page");
   end Test_List_Members;

end AWA.Workspaces.Tests;

Implement the Test_List_Members procedure to check the list of members


with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Exceptions;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Opentoken.Recognizer.Character_Set;
with Opentoken.Recognizer.Identifier;
with Opentoken.Recognizer.Integer;
with Opentoken.Recognizer.Keyword;
with Opentoken.Recognizer.Line_Comment;
with Opentoken.Recognizer.Real;
with Opentoken.Recognizer.Separator;
with Opentoken.Recognizer.Single_Character_Set;
with Opentoken.Recognizer.String;
with OpenToken.Text_Feeder.String;
with Opentoken.Token.Enumerated.Analyzer;
with Smart_Pointers;

package body Reader is

   package ACL renames Ada.Characters.Latin_1;

   type Lexemes is (Whitespace, Comment,
                    Int, Float_Tok, Sym,
                    Nil, True_Tok, False_Tok,
                    LE_Tok, GE_Tok, Exp_Tok, Splice_Unq,
                    Str, Atom);

   package Lisp_Tokens is
     new Opentoken.Token.Enumerated (Lexemes, Lexemes'Image, 10);

   package Tokenizer is new Lisp_Tokens.Analyzer (Int, Atom);

   LE_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("<="));

   GE_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get (">="));

   Exp_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("**"));

   Splice_Unq_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("~@"));

   Nil_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("nil"));

   True_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("true"));

   False_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Keyword.Get ("false"));

   Int_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Integer.Get);

   Float_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Real.Get);

   -- Use the C style for escaped strings.
   String_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.String.Get
         (Escapeable => True,
          Double_Delimiter => False));

   -- Atom definition
   -- Note Start_Chars includes : for keywords.
   Start_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Letter_Set,
        Ada.Strings.Maps.To_Set (":*"));

   Body_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Alphanumeric_Set,
        Ada.Strings.Maps.To_Set ("-!*?"));

   Atom_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.Identifier.Get (Start_Chars, Body_Chars));

   Lisp_Syms : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set ("[]{}()'`~^@&+-*/<>=");

   Sym_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Single_Character_Set.Get (Lisp_Syms));

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set
       (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma);

   Whitesp_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Character_Set.Get (Lisp_Whitespace));

   Comment_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Line_Comment.Get (";"));

   Syntax : constant Tokenizer.Syntax :=
     (Int        => Int_Recognizer,
      Float_Tok  => Float_Recognizer,
      Sym        => Sym_Recognizer,
      Nil        => Nil_Recognizer,
      True_Tok   => True_Recognizer,
      False_Tok  => False_Recognizer,
      LE_Tok     => LE_Recognizer,
      GE_Tok     => GE_Recognizer,
      Exp_Tok    => Exp_Recognizer,
      Splice_Unq => Splice_Unq_Recognizer,
      Str        => String_Recognizer,
      Atom       => Atom_Recognizer,
      Whitespace => Whitesp_Recognizer,
      Comment    => Comment_Recognizer);

   Input_Feeder : aliased OpenToken.Text_Feeder.String.Instance;

   Analyzer : Tokenizer.Instance :=
     Tokenizer.Initialize (Syntax, Input_Feeder'access);

   -- This is raised if an invalid character is encountered
   Lexical_Error : exception;

   -- The unterminated string error
   String_Error : exception;

   function Get_Token_String return String is
   begin
      return Tokenizer.Lexeme (Analyzer);
   end Get_Token_String;

   function Get_Token_Char return Character is
      S : String := Tokenizer.Lexeme (Analyzer);
   begin
      return S (S'First);
   end Get_Token_Char;

   function Convert_String (S : String) return String is
      use Ada.Strings.Unbounded;
      Res : Unbounded_String;
      I : Positive;
      Str_Last : Natural;
   begin
      Str_Last := S'Last;
      I := S'First;
      while I <= Str_Last loop
         if S (I) = '\' then
            if I+1 > Str_Last then
               Append (Res, S (I));
               I := I + 1;
            elsif S (I+1) = 'n' then
               Append (Res, Ada.Characters.Latin_1.LF);
               I := I + 2;
            elsif S (I+1) = '"' then
               Append (Res, S (I+1));
               I := I + 2;
            elsif S (I+1) = '\' then
               Append (Res, S (I+1));
               I := I + 2;
            else
               Append (Res, S (I));
               I := I + 1;
            end if;
         else
            Append (Res, S (I));
            I := I + 1;
         end if;
      end loop;
      return To_String (Res);
   end Convert_String;

   -- Saved_Line is needed to detect the unterminated string error.
   Saved_Line : String (1..Max_Line_Len);

   function Get_Token return Types.Mal_Handle is
      use Types;
      Res : Types.Mal_Handle;
   begin
      Tokenizer.Find_Next (Analyzer);
      case Tokenizer.ID (Analyzer) is
         when Int =>
            Res := New_Int_Mal_Type
              (Int => Mal_Integer'Value (Get_Token_String));
         when Float_Tok =>
            Res := New_Float_Mal_Type
              (Floating => Mal_Float'Value (Get_Token_String));
         when Sym =>
            Res := New_Atom_Mal_Type (Str => Get_Token_Char & "");
         when Nil =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when True_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when False_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when LE_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when GE_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when Exp_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when Splice_Unq =>
            Res := New_Unitary_Mal_Type
              (Func => Splice_Unquote,
               Op => Smart_Pointers.Null_Smart_Pointer);
         when Str =>
            Res := New_String_Mal_Type
              (Str => Convert_String (Get_Token_String));
         when Atom =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
      end case;
      return Res;

   exception

      when E : OpenToken.Syntax_Error =>

-- Extra debug info
--         declare
--            Err_Pos : Integer := Analyzer.Column + 1;
--         begin
--            for J in 1..Err_Pos + 5 loop
--               Ada.Text_IO.Put (Ada.Text_IO.Standard_Error, ' ');
--            end loop;
--            Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, "^");
--         end;
--
--         Ada.Text_IO.Put_Line
--           (Ada.Text_IO.Standard_Error,
--            Ada.Exceptions.Exception_Information (E));

         declare
            Col : Integer := Analyzer.Column;
         begin
            if Saved_Line (Col) ='"' then
               raise String_Error;
            else
               raise Lexical_Error;
            end if;
         end;

   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Handle;

   function Read_List (LT : Types.List_Types)
   return Types.Mal_Handle is

      use Types;
      List_SP, MTA, Params, Expr, Close_Lambda : Mal_Handle;
      List_P : List_Ptr;
      Close : String (1..1) := (1 => Types.Closing (LT));

   begin

      List_SP := New_List_Mal_Type (List_Type => LT);

      -- Need to append to a variable so...
      List_P := Deref_List (List_SP);

      MTA := Read_Form;

      if Deref (MTA).Sym_Type = Atom and then
         Deref_Atom (MTA).Get_Atom = "fn*" then

         Params := Read_Form;
         Expr := Read_Form;
         Close_Lambda := Read_Form;  -- the ) at the end of the lambda
         return New_Lambda_Mal_Type (Params, Expr);

      else

         loop
            exit when Is_Null (MTA) or else
                      (Deref (MTA).Sym_Type = Atom and then
                       Atom_Mal_Type (Deref (MTA).all).Get_Atom = Close);
            Append (List_P.all, MTA);
            MTA := Read_Form;
         end loop;
         return List_SP;
      end if;

   exception
      when Lexical_Error =>

        -- List_MT about to go out of scope but its a Mal_Handle
        -- so it is automatically garbage collected.

        return New_Error_Mal_Type (Str => "expected '" & Close & "'");

   end Read_List;

   function Read_Form return Types.Mal_Handle is
      use Types;
      MTS : Mal_Handle;
   begin

      MTS := Get_Token;

      if Is_Null (MTS) then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      if Deref (MTS).Sym_Type = Atom then

         declare
            Symbol : String := Atom_Mal_Type (Deref (MTS).all).Get_Atom;
         begin
            -- Listy things and quoting...
            if Symbol = "(" then
               return Read_List (List_List);
            elsif Symbol = "[" then
               return Read_List (Vector_List);
            elsif Symbol = "{" then
               return Read_List (Hashed_List);
            elsif Symbol = "^" then
               declare
                  Meta, Obj : Mal_Handle;
               begin
                  Meta := Read_Form;
                  Obj := Read_Form;
                  declare
                     MT : Mal_Ptr := Deref (Obj);
                  begin
                     Set_Meta (MT.all, Meta);
                  end;
                  return Obj;
               end;
            elsif Symbol = ACL.Apostrophe & "" then
               return New_Unitary_Mal_Type (Func => Quote, Op => Read_Form);
            elsif Symbol = ACL.Grave & "" then
               return New_Unitary_Mal_Type (Func => Quasiquote, Op => Read_Form);
            elsif Symbol = ACL.Tilde & "" then
               return New_Unitary_Mal_Type (Func => Unquote, Op => Read_Form);
            elsif Symbol = ACL.Commercial_At & "" then
               return New_Unitary_Mal_Type (Func => Deref, Op => Read_Form);
            else
               return MTS;
            end if;
         end;

      elsif Deref(MTS).Sym_Type = Unitary and then
            Unitary_Mal_Type (Deref (MTS).all).Get_Func = Splice_Unquote then

         return New_Unitary_Mal_Type (Func => Splice_Unquote, Op => Read_Form);

      else
         return MTS;
      end if;

   exception
      when String_Error =>
        return New_Error_Mal_Type (Str => "expected '""'");
   end Read_Form;

   procedure Lex_Init (S : String) is
   begin
      Analyzer.Reset;
      Input_Feeder.Set (S);
      Saved_Line (1..S'Length) := S;  -- Needed for error recovery
   end Lex_Init;

   function Read_Str (S : String) return Types.Mal_Handle is
      I, Str_Len : Natural := S'Length;
   begin
      -- Filter out lines consisting of only whitespace and/or comments
      I := 1;
      while I <= Str_Len and then
            Ada.Strings.Maps.Is_In (S (I), Lisp_Whitespace) loop
         I := I + 1;
      end loop;
      if I > Str_Len or else S (I) = ';' then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      Lex_Init (S);

      return Read_Form;
   end Read_Str;

end Reader;

with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Exceptions;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Opentoken.Recognizer.Character_Set;
with Opentoken.Recognizer.Identifier;
with Opentoken.Recognizer.Integer;
with Opentoken.Recognizer.Keyword;
with Opentoken.Recognizer.Line_Comment;
with Opentoken.Recognizer.Real;
with Opentoken.Recognizer.Separator;
with Opentoken.Recognizer.Single_Character_Set;
with Opentoken.Recognizer.String;
with OpenToken.Text_Feeder.String;
with Opentoken.Token.Enumerated.Analyzer;
with Smart_Pointers;

package body Reader is

   package ACL renames Ada.Characters.Latin_1;

   type Lexemes is (Whitespace, Comment,
                    Int, Float_Tok, Sym,
                    Nil, True_Tok, False_Tok,
                    LE_Tok, GE_Tok, Exp_Tok, Splice_Unq,
                    Str, Atom);

   package Lisp_Tokens is
     new Opentoken.Token.Enumerated (Lexemes, Lexemes'Image, 10);

   package Tokenizer is new Lisp_Tokens.Analyzer (Int, Atom);

   LE_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("<="));

   GE_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get (">="));

   Exp_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("**"));

   Splice_Unq_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("~@"));

   Nil_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("nil"));

   True_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("true"));

   False_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Keyword.Get ("false"));

   Int_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Integer.Get);

   Float_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Real.Get);

   -- Use the C style for escaped strings.
   String_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.String.Get
         (Escapeable => True,
          Double_Delimiter => False));

   -- Atom definition
   -- Note Start_Chars includes : for keywords.
   Start_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Letter_Set,
        Ada.Strings.Maps.To_Set (":*"));

   Body_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Alphanumeric_Set,
        Ada.Strings.Maps.To_Set ("-!*?"));

   Atom_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.Identifier.Get (Start_Chars, Body_Chars));

   Lisp_Syms : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set ("[]{}()'`~^@&+-*/<>=");

   Sym_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Single_Character_Set.Get (Lisp_Syms));

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set
       (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma);

   Whitesp_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Character_Set.Get (Lisp_Whitespace));

   Comment_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Line_Comment.Get (";"));

   Syntax : constant Tokenizer.Syntax :=
     (Int        => Int_Recognizer,
      Float_Tok  => Float_Recognizer,
      Sym        => Sym_Recognizer,
      Nil        => Nil_Recognizer,
      True_Tok   => True_Recognizer,
      False_Tok  => False_Recognizer,
      LE_Tok     => LE_Recognizer,
      GE_Tok     => GE_Recognizer,
      Exp_Tok    => Exp_Recognizer,
      Splice_Unq => Splice_Unq_Recognizer,
      Str        => String_Recognizer,
      Atom       => Atom_Recognizer,
      Whitespace => Whitesp_Recognizer,
      Comment    => Comment_Recognizer);

   Input_Feeder : aliased OpenToken.Text_Feeder.String.Instance;

   Analyzer : Tokenizer.Instance :=
     Tokenizer.Initialize (Syntax, Input_Feeder'access);

   -- This is raised if an invalid character is encountered
   Lexical_Error : exception;

   -- The unterminated string error
   String_Error : exception;

   function Get_Token_String return String is
   begin
      return Tokenizer.Lexeme (Analyzer);
   end Get_Token_String;

   function Get_Token_Char return Character is
      S : String := Tokenizer.Lexeme (Analyzer);
   begin
      return S (S'First);
   end Get_Token_Char;

   function Convert_String (S : String) return String is
      use Ada.Strings.Unbounded;
      Res : Unbounded_String;
      I : Positive;
      Str_Last : Natural;
   begin
      Str_Last := S'Last;
      I := S'First;
      while I <= Str_Last loop
         if S (I) = '\' then
            if I+1 > Str_Last then
               Append (Res, S (I));
               I := I + 1;
            elsif S (I+1) = 'n' then
               Append (Res, Ada.Characters.Latin_1.LF);
               I := I + 2;
            elsif S (I+1) = '"' then
               Append (Res, S (I+1));
               I := I + 2;
            elsif S (I+1) = '\' then
               Append (Res, S (I+1));
               I := I + 2;
            else
               Append (Res, S (I));
               I := I + 1;
            end if;
         else
            Append (Res, S (I));
            I := I + 1;
         end if;
      end loop;
      return To_String (Res);
   end Convert_String;

   -- Saved_Line is needed to detect the unterminated string error.
   Saved_Line : String (1..Max_Line_Len);

   function Get_Token return Types.Mal_Handle is
      use Types;
      Res : Types.Mal_Handle;
   begin
      Tokenizer.Find_Next (Analyzer);
      case Tokenizer.ID (Analyzer) is
         when Int =>
            Res := New_Int_Mal_Type
              (Int => Mal_Integer'Value (Get_Token_String));
         when Float_Tok =>
            Res := New_Float_Mal_Type
              (Floating => Mal_Float'Value (Get_Token_String));
         when Sym =>
            Res := New_Atom_Mal_Type (Str => Get_Token_Char & "");
         when Nil =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when True_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when False_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when LE_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when GE_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when Exp_Tok =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
         when Splice_Unq =>
            Res := New_Unitary_Mal_Type
              (Func => Splice_Unquote,
               Op => Smart_Pointers.Null_Smart_Pointer);
         when Str =>
            Res := New_String_Mal_Type
              (Str => Convert_String (Get_Token_String));
         when Atom =>
            Res := New_Atom_Mal_Type (Str => Get_Token_String);
      end case;
      return Res;

   exception

      when E : OpenToken.Syntax_Error =>

-- Extra debug info
--         declare
--            Err_Pos : Integer := Analyzer.Column + 1;
--         begin
--            for J in 1..Err_Pos + 5 loop
--               Ada.Text_IO.Put (Ada.Text_IO.Standard_Error, ' ');
--            end loop;
--            Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, "^");
--         end;
--
--         Ada.Text_IO.Put_Line
--           (Ada.Text_IO.Standard_Error,
--            Ada.Exceptions.Exception_Information (E));

         declare
            Col : Integer := Analyzer.Column;
         begin
            if Saved_Line (Col) ='"' then
               raise String_Error;
            else
               raise Lexical_Error;
            end if;
         end;

   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Handle;

   function Read_List (LT : Types.List_Types)
   return Types.Mal_Handle is

      use Types;
      MTA : Mal_Handle;

   begin

      MTA := Read_Form;

      if Deref (MTA).Sym_Type = Atom and then
         Deref_Atom (MTA).Get_Atom = "fn*" then

         declare
            Params, Expr, Close_Lambda : Mal_Handle;
         begin
            Params := Read_Form;
            Expr := Read_Form;
            Close_Lambda := Read_Form;  -- the ) at the end of the lambda
            return New_Lambda_Mal_Type (Params, Expr);
         exception
            when Lexical_Error =>

              -- List_MT about to go out of scope but its a Mal_Handle
              -- so it is automatically garbage collected.

              return New_Error_Mal_Type (Str => "Lexical error in fn*");

         end;

      else

         declare
            List_SP : Mal_Handle;
            List_P : List_Ptr;
            Close : String (1..1) := (1 => Types.Closing (LT));
         begin
            List_SP := New_List_Mal_Type (List_Type => LT);

            -- Need to append to a variable so...
            List_P := Deref_List (List_SP);
            loop
               exit when Is_Null (MTA) or else
                         (Deref (MTA).Sym_Type = Atom and then
                          Atom_Mal_Type (Deref (MTA).all).Get_Atom = Close);
               Append (List_P.all, MTA);
               MTA := Read_Form;
            end loop;
            return List_SP;
         exception
            when Lexical_Error =>

              -- List_MT about to go out of scope but its a Mal_Handle
              -- so it is automatically garbage collected.

              return New_Error_Mal_Type (Str => "expected '" & Close & "'");

         end;
      end if;

   exception
      when Lexical_Error =>

        return New_Error_Mal_Type (Str => "Lexical error in Read_List");

   end Read_List;

   function Read_Form return Types.Mal_Handle is
      use Types;
      MTS : Mal_Handle;
   begin

      MTS := Get_Token;

      if Is_Null (MTS) then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      if Deref (MTS).Sym_Type = Atom then

         declare
            Symbol : String := Atom_Mal_Type (Deref (MTS).all).Get_Atom;
         begin
            -- Listy things and quoting...
            if Symbol = "(" then
               return Read_List (List_List);
            elsif Symbol = "[" then
               return Read_List (Vector_List);
            elsif Symbol = "{" then
               return Read_List (Hashed_List);
            elsif Symbol = "^" then
               declare
                  Meta, Obj : Mal_Handle;
               begin
                  Meta := Read_Form;
                  Obj := Read_Form;
                  declare
                     MT : Mal_Ptr := Deref (Obj);
                  begin
                     Set_Meta (MT.all, Meta);
                  end;
                  return Obj;
               end;
            elsif Symbol = ACL.Apostrophe & "" then
               return New_Unitary_Mal_Type (Func => Quote, Op => Read_Form);
            elsif Symbol = ACL.Grave & "" then
               return New_Unitary_Mal_Type (Func => Quasiquote, Op => Read_Form);
            elsif Symbol = ACL.Tilde & "" then
               return New_Unitary_Mal_Type (Func => Unquote, Op => Read_Form);
            elsif Symbol = ACL.Commercial_At & "" then
               return New_Unitary_Mal_Type (Func => Deref, Op => Read_Form);
            else
               return MTS;
            end if;
         end;

      elsif Deref(MTS).Sym_Type = Unitary and then
            Unitary_Mal_Type (Deref (MTS).all).Get_Func = Splice_Unquote then

         return New_Unitary_Mal_Type (Func => Splice_Unquote, Op => Read_Form);

      else
         return MTS;
      end if;

   exception
      when String_Error =>
        return New_Error_Mal_Type (Str => "expected '""'");
   end Read_Form;

   procedure Lex_Init (S : String) is
   begin
      Analyzer.Reset;
      Input_Feeder.Set (S);
      Saved_Line (1..S'Length) := S;  -- Needed for error recovery
   end Lex_Init;

   function Read_Str (S : String) return Types.Mal_Handle is
      I, Str_Len : Natural := S'Length;
   begin
      -- Filter out lines consisting of only whitespace and/or comments
      I := 1;
      while I <= Str_Len and then
            Ada.Strings.Maps.Is_In (S (I), Lisp_Whitespace) loop
         I := I + 1;
      end loop;
      if I > Str_Len or else S (I) = ';' then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      Lex_Init (S);

      return Read_Form;
   end Read_Str;

end Reader;

Ada: make vars/exceptions more local in read_list


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../../License.txt

with CommonText;
with Ada.Calendar;
with Ada.Strings.Wide_Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;

package AdaBase.Results is

   package CT   renames CommonText;
   package AC   renames Ada.Calendar;
   package SUW  renames Ada.Strings.Wide_Unbounded;
   package SUWW renames Ada.Strings.Wide_Wide_Unbounded;

   subtype textual   is CT.Text;
   subtype textwide  is SUW.Unbounded_Wide_String;
   subtype textsuper is SUWW.Unbounded_Wide_Wide_String;

   TARGET_TYPE_TOO_NARROW : exception;
   CONVERSION_FAILED      : exception;
   UNSUPPORTED_CONVERSION : exception;
   COLUMN_DOES_NOT_EXIST  : exception;
   CONSTRUCTOR_DO_NOT_USE : exception;

   -------------------------------------------
   --  Supported Field Types (Standardized) --
   -------------------------------------------

   type nbyte1 is mod 2 ** 8;
   type nbyte2 is mod 2 ** 16;
   type nbyte3 is mod 2 ** 24;
   type nbyte4 is mod 2 ** 32;
   type nbyte8 is mod 2 ** 64;
   type byte8  is range -2 ** 63 .. 2 ** 63 - 1;
   type byte4  is range -2 ** 31 .. 2 ** 31 - 1;
   type byte3  is range -2 ** 23 .. 2 ** 23 - 1;
   type byte2  is range -2 ** 15 .. 2 ** 15 - 1;
   type byte1  is range -2 **  7 .. 2 **  7 - 1;
   type real9  is digits 9;
   type real18 is digits 18;

   subtype nbyte0 is Boolean;

   type chain is array (Positive range <>) of nbyte1;
   type enumtype is record
      enumeration : textual;
      index       : Natural;
   end record;
   type settype is array (Positive range <>) of enumtype;

   type nbyte0_access  is access all nbyte0;
   type nbyte1_access  is access all nbyte1;
   type nbyte2_access  is access all nbyte2;
   type nbyte3_access  is access all nbyte3;
   type nbyte4_access  is access all nbyte4;
   type nbyte8_access  is access all nbyte8;
   type byte1_access   is access all byte1;
   type byte2_access   is access all byte2;
   type byte3_access   is access all byte3;
   type byte4_access   is access all byte4;
   type byte8_access   is access all byte8;
   type real9_access   is access all real9;
   type real18_access  is access all real18;
   type str1_access    is access all textual;
   type str2_access    is access all textwide;
   type str4_access    is access all textsuper;
   type time_access    is access all AC.Time;
   type chain_access   is access all chain;     --  stored as access
   type enum_access    is access all enumtype;
   type settype_access is access all settype;   --  stored as access

   ------------------------------------------------
   --  CONSTANTS FOR PARAMETER TYPE DEFINITIONS  --
   ------------------------------------------------
   PARAM_IS_BOOLEAN   : constant nbyte0 := False;
   PARAM_IS_NBYTE_1   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_2   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_3   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_4   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_8   : constant nbyte1 := 0;
   PARAM_IS_BYTE_1    : constant nbyte1 := 0;
   PARAM_IS_BYTE_2    : constant nbyte1 := 0;
   PARAM_IS_BYTE_3    : constant nbyte1 := 0;
   PARAM_IS_BYTE_4    : constant nbyte1 := 0;
   PARAM_IS_BYTE_8    : constant nbyte1 := 0;
   PARAM_IS_REAL_9    : constant real9  := 0.0;
   PARAM_IS_REAL_18   : constant real18 := 0.0;
   PARAM_IS_CHAIN     : constant chain := (1 .. 1 => 0);
   PARAM_IS_ENUM      : constant enumtype := (CT.blank, 0);
   PARAM_IS_SET       : constant settype := (1 .. 1 => (CT.blank, 0));
   PARAM_IS_TEXTUAL   : constant textual := CT.blank;
   PARAM_IS_TEXTWIDE  : constant textwide := SUW.Null_Unbounded_Wide_String;
   PARAM_IS_TEXTSUPER : constant textsuper :=
                       SUWW.Null_Unbounded_Wide_Wide_String;
   PARAM_IS_TIMESTAMP : constant AC.Time := AC.Time_Of (AC.Year_Number'First,
                                                        AC.Month_Number'First,
                                                        AC.Day_Number'First);

end AdaBase.Results;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../../License.txt

with CommonText;
with Ada.Calendar;
with Ada.Strings.Wide_Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;

package AdaBase.Results is

   package CT   renames CommonText;
   package AC   renames Ada.Calendar;
   package SUW  renames Ada.Strings.Wide_Unbounded;
   package SUWW renames Ada.Strings.Wide_Wide_Unbounded;

   subtype textual   is CT.Text;
   subtype textwide  is SUW.Unbounded_Wide_String;
   subtype textsuper is SUWW.Unbounded_Wide_Wide_String;

   TARGET_TYPE_TOO_NARROW : exception;
   CONVERSION_FAILED      : exception;
   UNSUPPORTED_CONVERSION : exception;
   COLUMN_DOES_NOT_EXIST  : exception;
   CONSTRUCTOR_DO_NOT_USE : exception;

   -------------------------------------------
   --  Supported Field Types (Standardized) --
   -------------------------------------------

   type nbyte1 is mod 2 ** 8;
   type nbyte2 is mod 2 ** 16;
   type nbyte3 is mod 2 ** 24;
   type nbyte4 is mod 2 ** 32;
   type nbyte8 is mod 2 ** 64;
   type byte8  is range -2 ** 63 .. 2 ** 63 - 1;
   type byte4  is range -2 ** 31 .. 2 ** 31 - 1;
   type byte3  is range -2 ** 23 .. 2 ** 23 - 1;
   type byte2  is range -2 ** 15 .. 2 ** 15 - 1;
   type byte1  is range -2 **  7 .. 2 **  7 - 1;
   type real9  is digits 9;
   type real18 is digits 18;

   subtype nbyte0 is Boolean;

   type chain is array (Positive range <>) of nbyte1;
   type enumtype is record
      enumeration : textual;
      index       : Natural;
   end record;
   type settype is array (Positive range <>) of enumtype;

   type nbyte0_access  is access all nbyte0;
   type nbyte1_access  is access all nbyte1;
   type nbyte2_access  is access all nbyte2;
   type nbyte3_access  is access all nbyte3;
   type nbyte4_access  is access all nbyte4;
   type nbyte8_access  is access all nbyte8;
   type byte1_access   is access all byte1;
   type byte2_access   is access all byte2;
   type byte3_access   is access all byte3;
   type byte4_access   is access all byte4;
   type byte8_access   is access all byte8;
   type real9_access   is access all real9;
   type real18_access  is access all real18;
   type str1_access    is access all textual;
   type str2_access    is access all textwide;
   type str4_access    is access all textsuper;
   type time_access    is access all AC.Time;
   type chain_access   is access all chain;     --  stored as access
   type enum_access    is access all enumtype;
   type settype_access is access all settype;   --  stored as access

   ------------------------------------------------
   --  CONSTANTS FOR PARAMETER TYPE DEFINITIONS  --
   ------------------------------------------------
   PARAM_IS_BOOLEAN   : constant nbyte0 := False;
   PARAM_IS_NBYTE_1   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_2   : constant nbyte2 := 0;
   PARAM_IS_NBYTE_3   : constant nbyte3 := 0;
   PARAM_IS_NBYTE_4   : constant nbyte4 := 0;
   PARAM_IS_NBYTE_8   : constant nbyte8 := 0;
   PARAM_IS_BYTE_1    : constant byte1 := 0;
   PARAM_IS_BYTE_2    : constant byte2 := 0;
   PARAM_IS_BYTE_3    : constant byte3 := 0;
   PARAM_IS_BYTE_4    : constant byte4 := 0;
   PARAM_IS_BYTE_8    : constant byte8 := 0;
   PARAM_IS_REAL_9    : constant real9  := 0.0;
   PARAM_IS_REAL_18   : constant real18 := 0.0;
   PARAM_IS_CHAIN     : constant chain := (1 .. 1 => 0);
   PARAM_IS_ENUM      : constant enumtype := (CT.blank, 0);
   PARAM_IS_SET       : constant settype := (1 .. 1 => (CT.blank, 0));
   PARAM_IS_TEXTUAL   : constant textual := CT.blank;
   PARAM_IS_TEXTWIDE  : constant textwide := SUW.Null_Unbounded_Wide_String;
   PARAM_IS_TEXTSUPER : constant textsuper :=
                       SUWW.Null_Unbounded_Wide_Wide_String;
   PARAM_IS_TIMESTAMP : constant AC.Time := AC.Time_Of (AC.Year_Number'First,
                                                        AC.Month_Number'First,
                                                        AC.Day_Number'First);

end AdaBase.Results;

Fix parameter constant definitions

Fix parameter constant definitions


--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'Range);
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (I) := '_';
         else
            Result (I) := Str (I);
         end if;
      end loop;

      return Result;
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;
         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. 6 * Str'Last);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;
         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

Fix Ahven XML generation - Correctly escape the <, >, & and ' which appear in test names


-----------------------------------------------------------------------
--  druss-tools -- Druss main tool
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;  use GNAT.Command_Line;
with Ada.Command_Line;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Util.Commands;
with Util.Http.Clients.Curl;
with Util.Log.Loggers;
with Util.Properties;
with Druss.Config;
with Druss.Commands;
procedure Druss.Tools is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   Log_Config : Util.Properties.Manager;
   Config     : Ada.Strings.Unbounded.Unbounded_String;
   Output     : Ada.Strings.Unbounded.Unbounded_String;
   Debug      : Boolean := False;
   Verbose    : Boolean := False;
   First      : Natural := 0;
   All_Args   : Util.Commands.Default_Argument_List (0);
   Console    : aliased Druss.Commands.Text_Consoles.Console_Type;
begin
   Log_Config.Set ("log4j.rootCategory", "DEBUG,console");
   Log_Config.Set ("log4j.appender.console", "Console");
   Log_Config.Set ("log4j.appender.console.level", "ERROR");
   Log_Config.Set ("log4j.appender.console.layout", "level-message");
   Log_Config.Set ("log4j.appender.stdout", "Console");
   Log_Config.Set ("log4j.appender.stdout.level", "INFO");
   Log_Config.Set ("log4j.appender.stdout.layout", "message");
   Log_Config.Set ("log4j.logger.Util", "FATAL");
   Log_Config.Set ("log4j.logger.Bbox", "FATAL");

   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Commands.Initialize;
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");
   --  Parse the command line
   loop
      case Getopt ("* v d o: c:") is
         when ASCII.NUL => exit;

         when 'c' =>
            Config := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'o' =>
            Output := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'd' =>
            Debug := True;

         when 'v' =>
            Verbose := True;

         when '*' =>
            exit;

         when others =>
            null;
      end case;
      First := First + 1;
   end loop;
   if Verbose or Debug then
      Log_Config.Set ("log4j.appender.console.level", "INFO");
      Log_Config.Set ("log4j.logger.Util", "WARN");
      Log_Config.Set ("log4j.logger.Bbox", "ERR");
   end if;
   if Debug then
      Log_Config.Set ("log4j.appender.console.level", "DEBUG");
   end if;
   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Config.Initialize (To_String (Config));
   Util.Http.Clients.Curl.Register;
   if First >= Ada.Command_Line.Argument_Count then
      Ada.Text_IO.Put_Line ("Missing command name to execute.");
      Druss.Commands.Driver.Usage (All_Args);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   declare
      Cmd_Name : constant String := Full_Switch;
      Args     : Util.Commands.Default_Argument_List (First + 1);
      Ctx      : Druss.Commands.Context_Type;
   begin
      Ctx.Console := Console'Unchecked_Access;
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Driver.Execute (Cmd_Name, Args, Ctx);
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Ada.Command_Line.Set_Exit_Status (2);

end Druss.Tools;

-----------------------------------------------------------------------
--  druss-tools -- Druss main tool
--  Copyright (C) 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;  use GNAT.Command_Line;
with Ada.Command_Line;
with Ada.Text_IO;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Util.Commands;
with Util.Http.Clients.Curl;
with Util.Log.Loggers;
with Util.Properties;
with Druss.Config;
with Druss.Commands;
procedure Druss.Tools is

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   Log_Config  : Util.Properties.Manager;
   Config      : Ada.Strings.Unbounded.Unbounded_String;
   Output      : Ada.Strings.Unbounded.Unbounded_String;
   Debug       : Boolean := False;
   Verbose     : Boolean := False;
   Interactive : Boolean := False;
   First       : Natural := 0;
   All_Args    : Util.Commands.Default_Argument_List (0);
   Console     : aliased Druss.Commands.Text_Consoles.Console_Type;
   Ctx         : Druss.Commands.Context_Type;
begin
   Log_Config.Set ("log4j.rootCategory", "DEBUG,console");
   Log_Config.Set ("log4j.appender.console", "Console");
   Log_Config.Set ("log4j.appender.console.level", "ERROR");
   Log_Config.Set ("log4j.appender.console.layout", "level-message");
   Log_Config.Set ("log4j.appender.stdout", "Console");
   Log_Config.Set ("log4j.appender.stdout.level", "INFO");
   Log_Config.Set ("log4j.appender.stdout.layout", "message");
   Log_Config.Set ("log4j.logger.Util", "FATAL");
   Log_Config.Set ("log4j.logger.Bbox", "FATAL");

   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Commands.Initialize;
   Ctx.Console := Console'Unchecked_Access;
   Initialize_Option_Scan (Stop_At_First_Non_Switch => True, Section_Delimiters => "targs");
   --  Parse the command line
   loop
      case Getopt ("* v d i o: c:") is
         when ASCII.NUL => exit;

         when 'c' =>
            Config := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'o' =>
            Output := Ada.Strings.Unbounded.To_Unbounded_String (Parameter);

         when 'd' =>
            Debug := True;

         when 'i' =>
            Interactive := True;

         when 'v' =>
            Verbose := True;

         when '*' =>
            exit;

         when others =>
            null;
      end case;
      First := First + 1;
   end loop;
   if Verbose or Debug then
      Log_Config.Set ("log4j.appender.console.level", "INFO");
      Log_Config.Set ("log4j.logger.Util", "WARN");
      Log_Config.Set ("log4j.logger.Bbox", "ERR");
   end if;
   if Debug then
      Log_Config.Set ("log4j.appender.console.level", "DEBUG");
   end if;
   Util.Log.Loggers.Initialize (Log_Config);
   Druss.Config.Initialize (To_String (Config));
   Util.Http.Clients.Curl.Register;

   --  Enter in the interactive mode.
   if Interactive then
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Interactive (Ctx);
      return;
   end if;
   if First >= Ada.Command_Line.Argument_Count then
      Ada.Text_IO.Put_Line ("Missing command name to execute.");
      Druss.Commands.Driver.Usage (All_Args);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;
   declare
      Cmd_Name : constant String := Full_Switch;
      Args     : Util.Commands.Default_Argument_List (First + 1);
   begin
      Druss.Config.Get_Gateways (Ctx.Gateways);
      Druss.Commands.Driver.Execute (Cmd_Name, Args, Ctx);
   end;

exception
   when E : Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option: " & Ada.Exceptions.Exception_Message (E));
      Ada.Command_Line.Set_Exit_Status (2);

end Druss.Tools;

Add -i option to enter in the interactive mode


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2017, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This package provides an interface to the on-board "window watchdog"
--  provided by the STM32F4 family.

--  Important: see Figure 215 in RM0090, he STM32 reference manual,
--  illustrating the watchdog behavior and significant events.
--  Note that time is increasing to the right in the figure.
--  www.st.com/resource/en/reference_manual/DM00031020.pdf

package STM32.WWDG is  --  the Window Watchdog

   procedure Enable_Watchdog_Clock;

   procedure Reset_Watchdog;
   --  Resets the peripheral using the RCC

   type Prescalers is
     (Divider_1,
      Divider_2,
      Divider_4,
      Divider_8)
     with Size => 2;

   procedure Set_Watchdog_Prescaler (Value : Prescalers);
   --  Set the divider used to derive the watchdog counter clock frequency
   --  driving the countdown timer. The value is PCLK1 / 4096 / divider-value.
   --  For example, assuming PCLK1 of 45MHz and Divider_8, we'd get:
   --     45_000_000 / 4096 / 8 = 1373 Hz
   --  You'd want to know that value if you want to calculate the time span
   --  values for the refresh window, for example. See the demo program for
   --  doing that.
   --
   --  Note that the watchdog counter only counts down to 16#40# (64) before
   --  triggering the reset, and the upper limit for the counter value is 127,
   --  so there is a relatively limited number of counts available for the
   --  refresh window to be open. Therefore, the frequency at which the
   --  watchdog clock drives the counter is a significant factor in the
   --  total possible time span for the refresh window.

   subtype Downcounter is UInt7 range 16#40# .. UInt7'Last;
   --  16#40# is the last value of the countdown counter prior to a reset. When
   --  the count goes to 16#3F# the high-oder bit being cleared triggers the
   --  reset (if the watchdog is activated). Thus we never want to specify a
   --  counter value less than 16#40#.

   procedure Set_Watchdog_Window (Window_Start_Count : Downcounter);
   --  Set the value of the countdown counter for when the refresh window is
   --  to open. In figure 215, this is the counter value at the start of the
   --  "refresh allowed" interval. It is an arbitrary, user-defined value.
   --
   --  The last counter value prior to reset is always 64 (16#40#). At 16#3F#
   --  the high-order counter bit (T6 in the figure) clears, causing the
   --  watchdog to trigger the system reset (when activated).
   --
   --  To prevent a reset, the watchdog counter must be refreshed by the
   --  application but only when the counter is lower than Value and greater
   --  than 16#3F#.

   procedure Activate_Watchdog (New_Count : Downcounter);
   --  Set the watchdog counter to begin counting down from New_Count and
   --  activate the watchdog. In the figure, this is the counter value at
   --  the start of the "refresh not allowed" interval. It is an arbitrary,
   --  user-defined value.
   --
   --  Once activated there is no way to deactivate the watchdog other
   --  than a system reset.
   --
   --  Note that, as a "window" watchdog, the period in which the counter can
   --  be refreshed does not open immediately upon activating the watchdog.

   procedure Refresh_Watchdog_Counter (New_Count : Downcounter);
   --  Set the counter to begin counting down from New_Count. Used to refresh
   --  the watchdog counter in order to prevent the watchdog timeout. In the
   --  figure, this is the counter value at the start of the "refresh not
   --  allowed" interval. It is an arbitrary, user-defined value, but is likely
   --  the same value passed to Activate_Watchdog. The difference between this
   --  routine and the activating routine is soley the activation.

   procedure Enable_Early_Wakeup_Interrupt;
   --  When enabled, an interrupt occurs whenever the counter reaches the value
   --  16#40#, ie one counter decrement period before the counter causes a
   --  system reset. Once enabled, this interrupt can only be disabled by
   --  hardware after a system reset.

   function Early_Wakeup_Interrupt_Indicated return Boolean
     with Inline;
   --  Set by hardware when the counter has reached the value 16#40#, the
   --  counter value just prior to the reset being triggered. Always set,
   --  even if the interrupt is not enabled.

   procedure Clear_Early_Wakeup_Interrupt
     with Inline;
   --  Clears the status bit

   function WWDG_Reset_Indicated return Boolean;
   --  Indicated in the RCC peripheral

   procedure Clear_WWDG_Reset_Flag;
   --  In the RCC peripheral

   procedure Reset_System;
   --  an immediate software-driven reset, just as if the count hit 16#3F#

end STM32.WWDG;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2017, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This package provides an interface to the on-board "window watchdog"
--  provided by the STM32F4 family.

--  Important: see Figure 215 in RM0090, the STM32 reference manual,
--  illustrating the watchdog behavior and significant events.
--  Note that time is increasing to the right in the figure.
--  www.st.com/resource/en/reference_manual/DM00031020.pdf

package STM32.WWDG is  --  the Window Watchdog
   pragma Elaborate_Body;

   procedure Enable_Watchdog_Clock;

   procedure Reset_Watchdog;
   --  Resets the peripheral using the RCC

   type Prescalers is
     (Divider_1,
      Divider_2,
      Divider_4,
      Divider_8)
     with Size => 2;
   --  These prescalers are clock frequency dividers, with numeric divisor
   --  values corresponding to the digits in the names. The dividers are used
   --  to determine the watchdog counter clock frequency driving the countdown
   --  timer.
   --
   --  The frequency is computed as follows:
   --     PCLK1 / 4096 / divider-value
   --  For example, assuming PCLK1 of 45MHz and Divider_8, we'd get:
   --     45_000_000 / 4096 / 8 => 1373 Hz
   --
   --  The frequency can be used to calculate the time span values for the
   --  refresh window, for example. See the demo program for doing that.

   procedure Set_Watchdog_Prescaler (Value : Prescalers);
   --  Set the divider used to derive the watchdog counter clock frequency
   --  driving the countdown timer.
   --
   --  Note that the watchdog counter only counts down to 16#40# (64) before
   --  triggering the reset, and the upper limit for the counter value is 127,
   --  so there is a relatively limited number of counts available for the
   --  refresh window to be open. Therefore, the frequency at which the
   --  watchdog clock drives the counter is a significant factor in the
   --  total possible time span for the refresh window.

   subtype Downcounter is UInt7 range 16#40# .. UInt7'Last;
   --  16#40# is the last value of the countdown counter prior to a reset. When
   --  the count goes to 16#3F# the high-oder bit being cleared triggers the
   --  reset (if the watchdog is activated). Thus we never want to specify a
   --  counter value less than 16#40#.

   procedure Set_Watchdog_Window (Window_Start_Count : Downcounter);
   --  Set the value of the countdown counter for when the refresh window is
   --  to open. In figure 215, this is the counter value at the start of the
   --  "refresh allowed" interval. It is an arbitrary, user-defined value.
   --
   --  The last counter value prior to reset is always 64 (16#40#). At 16#3F#
   --  the high-order counter bit (T6 in the figure) clears, causing the
   --  watchdog to trigger the system reset (when activated).
   --
   --  To prevent a reset, the watchdog counter must be refreshed by the
   --  application but only when the counter is lower than Value and greater
   --  than 16#3F#.

   procedure Activate_Watchdog (New_Count : Downcounter);
   --  Set the watchdog counter to begin counting down from New_Count and
   --  activate the watchdog. In the figure, this is the counter value at
   --  the start of the "refresh not allowed" interval. It is an arbitrary,
   --  user-defined value.
   --
   --  Once activated there is no way to deactivate the watchdog other
   --  than a system reset.
   --
   --  Note that, as a "window" watchdog, the period in which the counter can
   --  be refreshed does not open immediately upon activating the watchdog.

   procedure Refresh_Watchdog_Counter (New_Count : Downcounter);
   --  Set the counter to begin counting down from New_Count. Used to refresh
   --  the watchdog counter in order to prevent the watchdog timeout. In the
   --  figure, this is the counter value at the start of the "refresh not
   --  allowed" interval. It is an arbitrary, user-defined value, but is likely
   --  the same value passed to Activate_Watchdog. The difference between this
   --  routine and the activating routine is soley the activation.

   procedure Enable_Early_Wakeup_Interrupt;
   --  When enabled, an interrupt occurs whenever the counter reaches the value
   --  16#40#, ie one counter decrement period before the counter causes a
   --  system reset. Once enabled, this interrupt can only be disabled by
   --  hardware after a system reset.

   function Early_Wakeup_Interrupt_Indicated return Boolean
     with Inline;
   --  Set by hardware when the counter has reached the value 16#40#, the
   --  counter value just prior to the reset being triggered. Always set,
   --  even if the interrupt is not enabled.

   procedure Clear_Early_Wakeup_Interrupt
     with Inline;
   --  Clears the status bit

   function WWDG_Reset_Indicated return Boolean;
   --  Indicated in the RCC peripheral

   procedure Clear_WWDG_Reset_Flag;
   --  In the RCC peripheral

   procedure Reset_System;
   --  an immediate software-driven reset, just as if the count hit 16#3F#

end STM32.WWDG;

Move comment explaining the prescalers to the prescaler type decl. Fix typo in comment header. All pragma Elaborate_Body.