xmlada_22.0.0_b322ae27/tests/schema/schematest.adb

------------------------------------------------------------------------------
--                     XML/Ada - An XML suite for Ada95                     --
--                                                                          --
--                     Copyright (C) 2007-2017, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

--  Run the automatic testsuite for XML Schema from www.w3c.org
--  You can download these from the web (see the URL constant below)
--  Also:
--   http://www.w3.org/XML/2004/xml-schema-test-suite/index.html
--
--  Some tests are disabled through the "disable" file

with Ada.Command_Line;          use Ada.Command_Line;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Exceptions;            use Ada.Exceptions;
with Ada.Float_Text_IO;         use Ada.Float_Text_IO;
with Ada.Strings.Hash;
with Ada.Strings.Maps;          use Ada.Strings.Maps;
with Ada.Strings.Unbounded;     use Ada.Strings.Unbounded;
with Ada.Text_IO;               use Ada.Text_IO;
with DOM.Core.Documents;        use DOM.Core.Documents;
with DOM.Core.Nodes;            use DOM.Core, DOM.Core.Nodes;
with DOM.Readers;               use DOM.Readers;
with GNAT.Command_Line;         use GNAT.Command_Line;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib;               use GNAT.OS_Lib;
with Input_Sources.File;        use Input_Sources, Input_Sources.File;
with Sax.Readers;               use Sax.Readers;
with Sax.Symbols;               use Sax.Symbols;
with Sax.Utils;                 use Sax.Utils;
with Schema.Readers;            use Schema.Readers;
with Schema.Schema_Readers;     use Schema.Schema_Readers;
with Schema.Validators;         use Schema.Validators;

procedure Schematest is

   URL : constant String :=
      "http://www.w3.org/XML/2004/xml-schema-test-suite/xmlschema2006-11-06/"
      & "xsts-2007-06-20.tar.gz";

   Testdir : constant String := "xmlschema2006-11-06";

   Alternative_Dir : constant String :=
     "XML/xml-schema-test-suite/2004-01-14/xmlschema2006-11-06";
   --  Where we might find the CVS checkout of W3C, which contains more
   --  up-to-date metadata. Whenever possible, we use files from this
   --  directory

   Disable_File_List : constant String := "disable";

   Check_Alternative_Dir : Boolean := False;

   Verbose       : Boolean := False;
   Debug         : Boolean := False;

   Show_Files : Boolean := False;
   --  Whether to show the XML and XSD file names in test results

   Show_Descr : Boolean := False;
   --  Whether to show group descriptions

   Symbols : Symbol_Table;
   Test_Set_Ref : Symbol;
   Test_Group   : Symbol;
   S_Annotation : Symbol;
   S_Schema_Test, S_Instance_Test, S_Documentation, S_Description : Symbol;
   S_Instance_Document, S_Schema_Document, S_Current, S_Expected : Symbol;

   S_Validity, S_Status, S_Name, S_Href, S_Schema_Version : Symbol;
   S_Release_Date, S_Xlink : Symbol;

   --  Shared symbol table (optional, this would be created automatically by
   --  each parser otherwise, it is just more efficient in the number of calls
   --  to malloc this way)

   Accepted_Only      : Boolean := True;
   --  If true, then only tests that are marked as "accepted" are run. Some
   --  tests might be under discussion, and have a status of "queried". Such
   --  tests are not run.

   XSD_Version : XSD_Versions := XSD_1_1;
   XML_Version : constant XML_Versions := XML_1_0_Third_Edition;

   type Test_Kind is (Not_Accepted,
                      XSD_Should_Fail,
                      XSD_Should_Pass,
                      XML_Should_Pass,
                      XML_Should_Fail);
   subtype Display_Test_Kind
     is Test_Kind range XSD_Should_Fail .. XML_Should_Fail;

   type Result_Kind   is (Passed, Failed, Not_Implemented, Internal_Error);
   type Result_Count  is array (Test_Kind, Result_Kind) of Natural;
   --  The various categories of errors:
   --  Either the XSD was valid, but rejected by XML/Ada.
   --  Or the XSD was invalid, but accepted by XML/Ada
   --  Or the XML was valid, but validation failed in XML/Ada
   --  Or the XML was invalid, but validation passed in XML/Ada
   --  Or an internal unknown error.

   type Test_Result is record
      Name   : Ada.Strings.Unbounded.Unbounded_String;
      Msg    : Ada.Strings.Unbounded.Unbounded_String;
      XSD    : Ada.Strings.Unbounded.Unbounded_String;
      XML    : Ada.Strings.Unbounded.Unbounded_String;
      Kind   : Test_Kind;
      Result : Result_Kind;
   end record;

   Disable_Count : Natural := 0;

   package Test_Result_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Test_Result);
   use Test_Result_Lists;

   type Group_Result is record
      Name          : Ada.Strings.Unbounded.Unbounded_String;
      Descr         : Ada.Strings.Unbounded.Unbounded_String;
      Tests         : Test_Result_Lists.List;
      Disabled      : Boolean := False;
      Counts        : Result_Count := (others => (others => 0));
      Parsed_XSD    : Natural := 0;
      Parsed_XML    : Natural := 0;
   end record;

   Filter : array (Test_Kind) of Boolean := (others => True);
   Result_Filter : array (Result_Kind) of Boolean := (others => True);
   Filter_Group_Name : Ada.Strings.Unbounded.Unbounded_String;

   function Image (Num : Integer; Width : Natural) return String;
   --  Return the image of [Num], on [Width] characters.
   --  This includes the leading whitespace

   procedure Run_Testsuite  (Filename : String);
   procedure Run_Testset (Filename : String; Grammar : in out XML_Grammar);
   procedure Run_Test_Group
     (Testset  : String;
      Group    : Node;
      Base_Dir : String;
      Grammar  : in out XML_Grammar);
   procedure Parse_Schema_Test
     (Group          : in out Group_Result;
      Schema         : Node;
      Base_Dir       : String;
      Failed_Grammar : out Boolean;
      Grammar        : in out XML_Grammar;
      Schema_Files   : out Unbounded_String);
   procedure Parse_Instance_Test
     (Group          : in out Group_Result;
      Schema         : Unbounded_String;
      Test           : Node;
      Base_Dir       : String;
      Grammar        : XML_Grammar;
      Failed_Grammar : Boolean);
   --  Run the testsuite whose description is in Filename

   function Get_Attribute (N : Node; Attribute : Symbol) return String;
   function Get_Attribute_NS (N : Node; URI, Local : Symbol) return String;
   --  Query an attribute from N. The empty string is returned if the attribute
   --  does not exists

   procedure Parse_Disabled;
   --  Parse the list of disabled tests

   package Group_Hash is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => String,
      Element_Type    => Group_Result,
      Hash            => Ada.Strings.Hash,
      Equivalent_Keys => "=");
   use Group_Hash;

   Groups : Group_Hash.Map;

   type Outcome_Value is (Valid, Invalid, NotKnown);
   function Get_Expected (N : Node) return Outcome_Value;
   --  Whether the test is expected to be valid or invalid

   type Status_Value is (Accepted, Queried);
   function Get_Status (N : Node) return Status_Value;
   --  Get the status of the test

   procedure Print_Group_Results (Group : Group_Result);
   --  Print the results for the specific group

   procedure Print_Results (Version, Release : String);
   --  Print overview of results

   procedure Set_Description
     (Result : in out Group_Result;
      Annotation : Node);
   --  Set the description of the group

   procedure Load (File : String; Input : in out File_Input'Class);
   --  Open File, loading from the alternative directory if the file is
   --  found, or from Testdir otherwise

   ----------
   -- Load --
   ----------

   procedure Load (File : String; Input : in out File_Input'Class) is
   begin
      if Check_Alternative_Dir then
         if Is_Regular_File (Alternative_Dir & Directory_Separator & File) then
            if Verbose then
               Put_Line
                 ("Load " & Alternative_Dir & Directory_Separator & File);
            end if;

            Open (Alternative_Dir & Directory_Separator & File, Input);
            return;
         end if;
      end if;

      if Verbose then
         Put_Line ("Load " & Testdir & Directory_Separator & File);
      end if;

      Open (Testdir & Directory_Separator & File, Input);
   end Load;

   --------------------
   -- Parse_Disabled --
   --------------------

   procedure Parse_Disabled is
      File : File_Type;
      Line : String (1 .. 1024);
      Last : Natural;
   begin
      Open (File, Mode => In_File, Name => Disable_File_List);

      while not End_Of_File (File) loop
         Get_Line (File, Line, Last);
         if Line (1) /= '-' and then Line (1) /= ' ' then
            Groups.Include
              (Key => Line (1 .. Last),
               New_Item => Group_Result'
                 (Name     => To_Unbounded_String (Line (1 .. Last)),
                  Disabled => True,
                  others   => <>));
            Disable_Count := Disable_Count + 1;
         end if;
      end loop;

      Close (File);

   exception
      when Name_Error =>
         null;
   end Parse_Disabled;

   -------------------
   -- Get_Attribute --
   -------------------

   function Get_Attribute (N : Node; Attribute : Symbol) return String is
      Attr : constant Node := Get_Named_Item (Attributes (N), Attribute);
   begin
      if Attr = null then
         return "";
      else
         return Node_Value (Attr);
      end if;
   end Get_Attribute;

   ----------------------
   -- Get_Attribute_NS --
   ----------------------

   function Get_Attribute_NS (N : Node; URI, Local : Symbol) return String is
      Attr : constant Node := Get_Named_Item_NS
        (Attributes (N), URI, Local);
   begin
      if Attr = null then
         return "";
      else
         return Node_Value (Attr);
      end if;
   end Get_Attribute_NS;

   ------------------
   -- Get_Expected --
   ------------------

   function Get_Expected (N : Node) return Outcome_Value is
      N2 : Node := First_Child (N);
   begin
      while N2 /= null loop
         if Local_Name (N2) = S_Expected then
            if Get_Attribute (N2, S_Validity) = "valid" then
               return Valid;
            elsif Get_Attribute (N2, S_Validity) = "invalid" then
               return Invalid;
            end if;

         end if;
         N2 := Next_Sibling (N2);
      end loop;
      return NotKnown;
   end Get_Expected;

   ----------------
   -- Get_Status --
   ----------------

   function Get_Status (N : Node) return Status_Value is
      N2 : Node := First_Child (N);
   begin
      while N2 /= null loop
         if Local_Name (N2) = S_Current then
            if Get_Attribute (N2, S_Status) = "accepted"
              or else Get_Attribute (N2, S_Status) = "stable"
            then
               return Accepted;
            elsif Get_Attribute (N2, S_Status) = "queried"
              or else Get_Attribute (N2, S_Status) = "disputed-spec"
              or else Get_Attribute (N2, S_Status) = "disputed-test"
              or else Get_Attribute (N2, S_Status) = "disputedTest"
            then
               return Queried;
            else
               Put_Line ("Invalid status: " & Get_Attribute (N2, S_Status));
               raise Program_Error;
            end if;

         end if;
         N2 := Next_Sibling (N2);
      end loop;

      return Accepted;
   end Get_Status;

   -----------------------
   -- Parse_Schema_Test --
   -----------------------

   procedure Parse_Schema_Test
     (Group          : in out Group_Result;
      Schema         : Node;
      Base_Dir       : String;
      Failed_Grammar : out Boolean;
      Grammar        : in out XML_Grammar;
      Schema_Files   : out Unbounded_String)
   is
      Result   : Test_Result;
      Name     : constant String := Get_Attribute (Schema, S_Name);
      XSD_Reader   : Schema_Reader;
      Input    : File_Input;
      N        : Node := First_Child (Schema);
      Outcome  : constant Outcome_Value := Get_Expected (Schema);
   begin
      if Verbose then
         Put_Line ("Parse_Schema_Test: " & Name);
      end if;

      Failed_Grammar := False;
      Result.Name    := To_Unbounded_String (Name);
      Result.Result  := Passed;
      Schema_Files   := Null_Unbounded_String;

      if Accepted_Only and then Get_Status (Schema) /= Accepted then
         --  Do not increment Group.Test_Count
         Result.Kind    := Not_Accepted;
         Failed_Grammar := True;
      else
         if Outcome = Invalid then
            Result.Kind := XSD_Should_Fail;
         else
            Result.Kind := XSD_Should_Pass;
         end if;

         if not Filter (Result.Kind) then
            return;
         end if;

         begin
            Set_Symbol_Table (XSD_Reader, Symbols);  --  optional (efficiency)
            Set_Grammar (XSD_Reader, Grammar);
            Use_Basename_In_Error_Messages (XSD_Reader, True);

            Set_XML_Version (XSD_Reader, XML_Version);

            while N /= null loop
               if Local_Name (N) = S_Schema_Document then
                  Group.Parsed_XSD := Group.Parsed_XSD + 1;

                  if Schema_Files /= Null_Unbounded_String then
                     Append (Schema_Files, " - ");
                  end if;

                  Load (Base_Dir & Get_Attribute_NS (N, S_Xlink, S_Href),
                        Input);

                  if Verbose then
                     Put_Line ("  Will parse: " & Get_System_Id (Input));
                  end if;

                  Result.XSD := To_Unbounded_String (Get_System_Id (Input));
                  Append (Schema_Files, Result.XSD);

                  Parse (XSD_Reader, Input);
                  Close (Input);
               end if;

               N := Next_Sibling (N);
            end loop;

            Grammar := Get_Grammar (XSD_Reader);

            Free (XSD_Reader);

            if Outcome = Invalid then
               Result.Result := Failed;
               Failed_Grammar := True;
            else
               Result.Result := Passed;
            end if;

         exception
            when Standard.Schema.XML_Not_Implemented
               | Standard.Schema.XML_Limitation =>
               Close (Input);
               Result.Result := Not_Implemented;
               Result.Msg  := To_Unbounded_String
                  (Get_Error_Message (XSD_Reader));
               Failed_Grammar := True;

            when XML_Validation_Error =>
               Close (Input);
               Result.Msg  :=
                 To_Unbounded_String (Get_Error_Message (XSD_Reader));
               Failed_Grammar := True;

               if Outcome = Valid then
                  Result.Result := Failed;
               else
                  Result.Result := Passed;
               end if;

            when E : XML_Fatal_Error =>
               Close (Input);
               Result.Msg  := To_Unbounded_String (Exception_Message (E));
               if Outcome = Valid then
                  Result.Result := Failed;
               else
                  Result.Result := Passed;
               end if;

            when E : others =>
               Close (Input);
               Result.Result := Internal_Error;
               Result.Msg  := To_Unbounded_String (Exception_Information (E));
               Failed_Grammar := True;
         end;
      end if;

      Group.Counts (Result.Kind, Result.Result) :=
        Group.Counts (Result.Kind, Result.Result) + 1;
      Append (Group.Tests, Result);
   end Parse_Schema_Test;

   -------------------------
   -- Parse_Instance_Test --
   -------------------------

   procedure Parse_Instance_Test
     (Group     : in out Group_Result;
      Schema    : Unbounded_String;
      Test      : Node;
      Base_Dir  : String;
      Grammar   : XML_Grammar;
      Failed_Grammar : Boolean)
   is
      Result   : Test_Result;
      Name     : constant String := Get_Attribute (Test, S_Name);
      Outcome  : constant Outcome_Value := Get_Expected (Test);
      N        : Node := First_Child (Test);
      Inst_Reader   : Validating_Reader;
      Input    : File_Input;
      Tmp_Gr   : Group_Result;
   begin
      if Verbose then
         Put_Line ("Parse_Instance_Test: " & Name);
      end if;

      if Find (Groups, To_String (Group.Name) & " / " & Name) /=
        Group_Hash.No_Element
      then
         Tmp_Gr := Group_Hash.Element
           (Groups, To_String (Group.Name) & " / " & Name);
         if Tmp_Gr.Disabled then
            Put_Line ("Test: " & To_String (Tmp_Gr.Name) & " (disabled)");
            New_Line;
            return;
         end if;
      end if;

      Result.Name   := To_Unbounded_String (Name);
      Result.Result := Passed;
      Result.XSD    := Schema;

      if Accepted_Only and then Get_Status (Test) /= Accepted then
         --  Do not increment Group.Test_Count
         Result.Kind := Not_Accepted;
         Group.Counts (Result.Kind, Result.Result) :=
           Group.Counts (Result.Kind, Result.Result) + 1;
         Append (Group.Tests, Result);
         return;
      elsif Outcome = Valid then
         Result.Kind := XML_Should_Pass;
      else
         Result.Kind := XML_Should_Fail;
      end if;

      if not Filter (Result.Kind) then
         return;
      end if;

      Set_Symbol_Table (Inst_Reader, Symbols);  --  optional, for efficiency
      Use_Basename_In_Error_Messages (Inst_Reader, True);
      Set_Grammar (Inst_Reader, Grammar);
      Set_Feature (Inst_Reader, Schema_Validation_Feature, True);
      Set_XML_Version (Inst_Reader, XML_Version);

      while N /= null loop
         if Local_Name (N) = S_Instance_Document then
            begin
               Group.Parsed_XML := Group.Parsed_XML + 1;

               Result.Result := Passed;
               Load (Base_Dir & Get_Attribute_NS (N, S_Xlink, S_Href), Input);
               Result.XML := To_Unbounded_String (Get_System_Id (Input));

               if Failed_Grammar then
                  if Outcome = Valid then
                     Result.Result := Failed;
                     Result.Msg  :=
                       To_Unbounded_String ("XSD file could not be parsed");

                  else
                     --  We did expect to fail anyway. The error message might
                     --  not be correct though
                     null;
                  end if;

               else
                  Parse (Inst_Reader, Input);
                  Close (Input);

                  if Outcome = Invalid then
                     Result.Result := Failed;
                  end if;
               end if;

            exception
               when Standard.Schema.XML_Not_Implemented
                  | Standard.Schema.XML_Limitation =>
                  Close (Input);
                  Result.Result := Not_Implemented;
                  Result.Msg  := To_Unbounded_String
                    (Get_Error_Message (Inst_Reader));

               when XML_Validation_Error =>
                  Close (Input);
                  Result.Msg  :=
                    To_Unbounded_String (Get_Error_Message (Inst_Reader));
                  if Outcome = Valid then
                     Result.Result := Failed;
                  else
                     Result.Result := Passed;
                  end if;

               when E : XML_Fatal_Error =>
                  Close (Input);
                  Result.Msg  := To_Unbounded_String (Exception_Message (E));
                  if Outcome = Valid then
                     Result.Result := Failed;
                  else
                     Result.Result := Passed;
                  end if;

               when E : others =>
                  Close (Input);
                  Result.Result := Internal_Error;
                  Result.Msg  :=
                     To_Unbounded_String (Exception_Information (E));
            end;

            Group.Counts (Result.Kind, Result.Result) :=
              Group.Counts (Result.Kind, Result.Result) + 1;
            Append (Group.Tests, Result);  --  A copy of Result
         end if;
         N := Next_Sibling (N);
      end loop;

      Free (Inst_Reader);
   end Parse_Instance_Test;

   ---------------------
   -- Set_Description --
   ---------------------

   procedure Set_Description
     (Result : in out Group_Result;
      Annotation : Node)
   is
      N  : Node := First_Child (Annotation);
      N2, N3 : Node;
   begin
      while N /= null loop
         if Local_Name (N) = S_Documentation then
            N2 := First_Child (N);
            while N2 /= null loop
               if Local_Name (N2) = S_Description then
                  N3 := First_Child (N2);
                  while N3 /= null loop
                     Append (Result.Descr, Node_Value (N3));
                     N3 := Next_Sibling (N3);
                  end loop;

               elsif Node_Type (N2) = Text_Node then
                  Append (Result.Descr, Node_Value (N2));
               end if;

               N2 := Next_Sibling (N2);
            end loop;
         end if;

         N := Next_Sibling (N);
      end loop;

      Trim (Result.Descr,
            To_Set (" " & ASCII.HT & ASCII.LF),
            To_Set (" " & ASCII.HT & ASCII.LF));
   end Set_Description;

   --------------------
   -- Run_Test_Group --
   --------------------

   procedure Run_Test_Group
     (Testset    : String;
      Group      : Node;
      Base_Dir   : String;
      Grammar    : in out XML_Grammar)
   is
      Name           : constant String := Get_Attribute (Group, S_Name);
      N              : Node := First_Child (Group);
      Schema_Files   : Unbounded_String;
      Result         : Group_Result;
      Failed_Grammar : Boolean := False;
   begin
      Result.Name := To_Unbounded_String (Testset & " / " & Name);
      Result.Counts := (others => (others => 0));

      if Filter_Group_Name /= ""
         and then Filter_Group_Name /= Result.Name
      then
         return;
      end if;

      Reset (Grammar);  --  Optional optimization, keep the meta-schema
      Set_XSD_Version (Grammar, XSD_Version);

      if Find (Groups, To_String (Result.Name)) /= Group_Hash.No_Element then
         Result := Group_Hash.Element (Groups, To_String (Result.Name));
         if Result.Disabled then
            Put_Line ("Grp: " & To_String (Result.Name) & " (disabled)");
            New_Line;
            return;
         else
            Put_Line ("Reusing existing group for "
                      & To_String (Result.Name));
         end if;
      end if;

      while N /= null loop
         if Local_Name (N) = S_Annotation then
            Set_Description (Result, N);

         elsif Local_Name (N) = S_Schema_Test then
            Parse_Schema_Test
              (Result, N, Base_Dir,
               Failed_Grammar => Failed_Grammar,
               Grammar        => Grammar,
               Schema_Files   => Schema_Files);

            --  If we failed to parse the grammar, that might be accepted, so
            --  we'll still run each test, marking them all as "can't parse"
            --  (which might be the expected result)
            --  ??? For now, we simply do not run any of the tests. But there
            --  are situations where XML/Ada report an error on the XSD rather
            --  than on the XML (for instance disallowedSubst00503m4_n where
            --  we restrict a type that has block="restriction").

            exit when Failed_Grammar;

         elsif Local_Name (N) = S_Instance_Test then
            Parse_Instance_Test (Result, Schema_Files, N, Base_Dir, Grammar,
                                 Failed_Grammar);
         end if;

         N := Next_Sibling (N);
      end loop;

      Print_Group_Results (Result);
      Group_Hash.Include (Groups, Name, Result);
   end Run_Test_Group;

   -----------------
   -- Run_Testset --
   -----------------

   procedure Run_Testset (Filename : String; Grammar : in out XML_Grammar) is
      Input  : File_Input;
      Reader : Tree_Reader;
      N      : Node;
      Name   : Unbounded_String;
   begin
      Set_Symbol_Table (Reader, Symbols);  --  optional, for efficiency

      Load (Filename, Input);
      Parse (Reader, Input);
      Close (Input);

      N := Get_Element (Get_Tree (Reader));
      Name := To_Unbounded_String (Get_Attribute (N, S_Name));

      if Verbose then
         Put_Line ("Testset: " & To_String (Name));
      end if;

      N := First_Child (N);
      while N /= null loop
         if Local_Name (N) = Test_Group then
            Run_Test_Group
              (Testset    => To_String (Name),
               Group      => N,
               Base_Dir   => Dir_Name (Filename),
               Grammar    => Grammar);
         end if;

         N := Next_Sibling (N);
      end loop;

      Free (Reader);
   end Run_Testset;

   -------------------
   -- Run_Testsuite --
   -------------------

   procedure Run_Testsuite (Filename : String) is
      Input  : File_Input;
      Reader : Tree_Reader;
      N, Top  : Node;
      Grammar : XML_Grammar := No_Grammar;
   begin
      Set_Symbol_Table (Reader, Symbols);  --  optional, for efficiency
      Set_XML_Version (Reader, XML_Version);

      Load (Filename, Input);
      Parse (Reader, Input);
      Close (Input);

      Top := Get_Element (Get_Tree (Reader));

      N := First_Child (Top);
      while N /= null loop
         if Local_Name (N) = Test_Set_Ref then
            Run_Testset
              (Dir_Name (Filename) & Get_Attribute_NS (N, S_Xlink, S_Href),
               Grammar => Grammar);
         end if;

         N := Next_Sibling (N);
      end loop;

      Print_Results (Version => Get_Attribute (Top, S_Schema_Version),
                     Release => Get_Attribute (Top, S_Release_Date));
      Free (Reader);
   end Run_Testsuite;

   -------------------------
   -- Print_Group_Results --
   -------------------------

   procedure Print_Group_Results (Group : Group_Result) is
      Cursor : Test_Result_Lists.Cursor := First (Group.Tests);
      Test   : Test_Result;
      Show_Group : Boolean := False;
      Count      : Integer;
      All_Passed : Integer := 0;
      All_Failed : Integer := 0;
   begin
      --  If one of the tests should be printed, display whole group
      while Has_Element (Cursor) loop
         if Result_Filter (Test_Result_Lists.Element (Cursor).Result) then
            Show_Group := True;
            exit;
         end if;
         Next (Cursor);
      end loop;

      if not Show_Group then
         return;
      end if;

      for K in Result_Kind loop
         for T in Test_Kind loop
            if K = Passed then
               All_Passed := All_Passed + Group.Counts (T, K);
            else
               All_Failed := All_Failed + Group.Counts (T, K);
            end if;
         end loop;
      end loop;

      Put_Line ("Grp: " & To_String (Group.Name));

      if Show_Descr and then Group.Descr /= "" then
         Put_Line ("  " & To_String (Group.Descr));
      end if;

      if Group.Disabled then
         Put_Line ("  --disabled--");

      else
         Put (" ");

         for T in Test_Kind'Range loop
            Count := 0;
            for K in Result_Kind'Range loop
               Count := Count + Group.Counts (T, K);
            end loop;

            if Count /= 0 then
               case T is
                  when Not_Accepted    => Put (" na=" & Count'Img);
                  when XSD_Should_Fail => Put (" sf=" & Count'Img);
                  when XSD_Should_Pass => Put (" sp=" & Count'Img);
                  when XML_Should_Pass => Put (" xp=" & Count'Img);
                  when XML_Should_Fail => Put (" xf=" & Count'Img);
               end case;
            end if;
         end loop;

         Put_Line ("} (xsd=" & Group.Parsed_XSD'Img
                   & " xml="  & Group.Parsed_XML'Img
                   & ") OK=" & All_Passed'Img
                   & " FAILED=" & All_Failed'Img);

         Cursor := First (Group.Tests);
         while Has_Element (Cursor) loop
            Test := Test_Result_Lists.Element (Cursor);

            if Result_Filter (Test.Result) then
               case Test.Result is
                  when Passed          => Put ("  OK ");
                  when Failed          => Put ("  KO ");
                  when Not_Implemented => Put ("  NI ");
                  when Internal_Error  => Put ("  IE ");
               end case;

               case Test.Kind is
                  when Not_Accepted    => Put ("NA ");
                  when XSD_Should_Fail => Put ("XSDi ");
                  when XSD_Should_Pass => Put ("XSDv ");
                  when XML_Should_Fail => Put ("XSDv-XMLi ");
                  when XML_Should_Pass => Put ("XSDv-XMLv ");
               end case;

               Put_Line (To_String (Test.Name));

               if Show_Files then
                  Put ("    ./testschema");
                  if Test.XSD /= "" then
                     Put (" -xsd " & To_String (Test.XSD));
                  end if;

                  if Test.XML /= "" then
                     Put (" " & To_String (Test.XML));
                  end if;

                  New_Line;
               end if;

               if Test.Msg /= "" then
                  case Test.Result is
                     when Passed          => Put ("  -OK ");
                     when Failed          => Put ("  -KO ");
                     when Not_Implemented => Put ("  -NI ");
                     when Internal_Error  => Put ("  -IE ");
                  end case;
                  Put_Line (To_String (Test.Msg));
               end if;
            end if;

            Next (Cursor);
         end loop;

         New_Line;
      end if;
   end Print_Group_Results;

   -----------
   -- Image --
   -----------

   function Image (Num : Integer; Width : Natural) return String is
      Str : constant String := Integer'Image (Num);
   begin
      if Str'Length < Width then
         return (1 .. Width - Str'Length => ' ') & Str;
      else
         return Str;
      end if;
   end Image;

   -------------------
   -- Print_Results --
   -------------------

   procedure Print_Results (Version, Release : String) is
      Total_Tests : Natural := 0;
      Total_XML   : Natural := 0;
      Total_XSD   : Natural := 0;
      Total       : Result_Count := (others => (others => 0));
      Grand_Total : array (Result_Kind) of Natural := (others => 0);
      Group       : Group_Hash.Cursor := Group_Hash.First (Groups);
      Gr          : Group_Result;
      In_Category : Natural;
      NI_Category : Natural;
   begin
      while Has_Element (Group) loop
         Gr := Group_Hash.Element (Group);

         for T in Display_Test_Kind loop
            for R in Gr.Counts'Range (2) loop
               Total (T, R) := Total (T, R) + Gr.Counts (T, R);
               Total_Tests := Total_Tests + Gr.Counts (T, R);
               Grand_Total (R) := Grand_Total (R) + Gr.Counts (T, R);
            end loop;
         end loop;

         Total_XML   := Total_XML   + Gr.Parsed_XML;
         Total_XSD   := Total_XSD   + Gr.Parsed_XSD;

         Next (Group);
      end loop;

      Put_Line ("  " & Total_XSD'Img
                & " XSD files (not including those parsed from XML)");
      Put_Line ("  " & Total_XML'Img & " XML files");

      New_Line;
      Put_Line ("Version: " & Version);
      Put ("Release: " & Release);
      if Check_Alternative_Dir then
         Put (" (Comparing with latest CVS baselines from W3C");
      end if;
      New_Line;

      Put_Line ("URL: " & URL);

      if Accepted_Only then
         Put_Line ("Tests marked by W3C as non-accepted were not run");
      end if;

      Put_Line ("+-----------+--------+--------+--------+------+----+");
      Put_Line ("|           | Total  | Passed | Failed | NI   | IE |"
                & " Passed/Applicable");
      Put_Line ("+-----------+--------+--------+--------+------+----+");

      for T in Display_Test_Kind loop
         Put ("| ");
         case T is
            when XSD_Should_Pass => Put ("XSDv     ");
            when XSD_Should_Fail => Put ("XSDi     ");
            when XML_Should_Pass => Put ("XSDv-XMLv");
            when XML_Should_Fail => Put ("XSDv-XMLi");
         end case;

         In_Category := 0;
         NI_Category := 0;
         for R in Result_Kind loop
            if R = Not_Implemented then
               NI_Category := NI_Category + Total (T, R);
            end if;

            In_Category := In_Category + Total (T, R);
         end loop;

         Put (" |" & Image (In_Category, 7)
              & " |" & Image (Total (T, Passed), 7)
              & " |" & Image (Total (T, Failed), 7)
              & " |" & Image (Total (T, Not_Implemented), 5)
              & " |" & Image (Total (T, Internal_Error), 3)
              & " | (");
         Put (100.0 * Float (Total (T, Passed))
              / Float (In_Category - NI_Category),
              Aft => 2, Exp => 0);
         Put_Line (" %)");
      end loop;

      Put_Line ("+-----------+--------+--------+--------+------+----+");
      Put      ("|     Total |"
                & Image (Total_Tests, 7)
                & " |" & Image (Grand_Total (Passed), 7)
                & " |" & Image (Grand_Total (Failed), 7)
                & " |" & Image (Grand_Total (Not_Implemented), 5)
                & " |" & Image (Grand_Total (Internal_Error), 3)
                & " | (");
      Put (100.0 * Float (Grand_Total (Passed))
           / Float (Total_Tests - Grand_Total (Not_Implemented)),
           Aft => 2, Exp => 0);
      Put_Line (" %)");
      Put      ("|  Disabled |" & Image (Disable_Count, 7));
      Put_Line (" |        |        |      |    |");
      Put_Line ("+-----------+--------+--------+--------+------+----+");
   end Print_Results;

   Setting  : Boolean;
begin
   if not Is_Directory (Testdir) then
      Put_Line (Standard_Error, "No such directory: " & Testdir);
      return;
   end if;

   --  Since we are going to create multiple parsers, we will share the symbol
   --  table, which saves on the number of calls to malloc().
   --  This is however optional, since a parser would create its own symbol
   --  table when appropriate

   declare
      S : constant Symbol_Table_Access := new Symbol_Table_Record;
   begin
      Symbols := Symbol_Table_Pointers.Allocate (S);

      Test_Set_Ref := Find (S, "testSetRef");
      Test_Group   := Find (S, "testGroup");
      S_Annotation := Find (S, "annotation");
      S_Schema_Test := Find (S, "schemaTest");
      S_Instance_Test := Find (S, "instanceTest");
      S_Documentation := Find (S, "documentation");
      S_Description   := Find (S, "Description");
      S_Instance_Document := Find (S, "instanceDocument");
      S_Schema_Document := Find (S, "schemaDocument");
      S_Current := Find (S, "current");
      S_Expected := Find (S, "expected");
      S_Validity := Find (S, "validity");
      S_Status   := Find (S, "status");
      S_Name     := Find (S, "name");
      S_Href     := Find (S, "href");
      S_Schema_Version := Find (S, "schemaVersion");
      S_Release_Date   := Find (S, "releaseDate");
      S_Xlink := Find (S, "http://www.w3.org/1999/xlink");
   end;

   loop
      case Getopt ("v d a h f -run: -descr -show: -xsd10 -group:"
                   & " -cvs") is
         when 'h'    =>
            Put_Line ("-v   Verbose mode");
            Put_Line ("-d   Debug mode");
            Put_Line ("-f   Show XSD and XML file names in results");
            Put_Line ("-a   Also run ambiguous tests under discussion");
            Put_Line ("--run [NA,SP,SF,XP,XF] only run those tests.");
            Put_Line ("     Separate categories with commas.");
            Put_Line ("     This will also only matching groups.");
            Put_Line ("--show [Passed,Failed,NI,IE] only show those results");
            Put_Line ("--group name     Only run tests from this group");
            Put_Line ("--descr Show group descriptions");
            Put_Line ("--cvs   Check the CVS checkout of W3C (see README file)"
                      & " for more up-to-date data");
            Put_Line ("--xsd10 Support for version XSD 1.0");
            return;

         when 'v' => Verbose := True;
         when 'd' => Debug   := True;
         when 'f' => Show_Files := True;

         when '-' =>
            if Full_Switch = "-cvs" then
               Check_Alternative_Dir := True;

            elsif Full_Switch = "-xsd10" then
               XSD_Version := XSD_1_0;

            elsif Full_Switch = "-group" then
               Filter_Group_Name := To_Unbounded_String (Parameter);

            elsif Full_Switch = "-run" then
               Setting := Full_Switch = "-run";

               Filter := (others => not Setting);
               declare
                  F : constant String := Parameter;
                  Prev : Integer := F'First;
                  Pos  : Integer := F'First - 1;
               begin
                  loop
                     Pos := Pos + 1;
                     if Pos > F'Last or else F (Pos) = ',' then
                        if F (Prev .. Pos - 1) = "SF" then
                           Filter (XSD_Should_Fail) := Setting;
                        elsif F (Prev .. Pos - 1) = "SP" then
                           Filter (XSD_Should_Pass) := Setting;
                        elsif F (Prev .. Pos - 1) = "XF" then
                           Filter (XML_Should_Fail) := Setting;
                        elsif F (Prev .. Pos - 1) = "XP" then
                           Filter (XML_Should_Pass) := Setting;
                        elsif F (Prev .. Pos - 1) = "NA" then
                           Filter (Not_Accepted) := Setting;
                        else
                           Put_Line ("Invalid filter: " & F (Prev .. Pos - 1));
                           return;
                        end if;

                        Prev := Pos + 1;
                        exit when Pos > F'Last;
                     end if;
                  end loop;
               end;

            elsif Full_Switch = "-show" then
               Result_Filter := (others => False);
               declare
                  F : constant String := Parameter;
                  Prev : Integer := F'First;
                  Pos  : Integer := F'First - 1;
               begin
                  loop
                     Pos := Pos + 1;
                     if Pos > F'Last or else F (Pos) = ',' then
                        if F (Prev .. Pos - 1) = "Passed" then
                           Result_Filter (Passed) := True;
                        elsif F (Prev .. Pos - 1) = "Failed" then
                           Result_Filter (Failed) := True;
                        elsif F (Prev .. Pos - 1) = "NI" then
                           Result_Filter (Not_Implemented) := True;
                        elsif F (Prev .. Pos - 1) = "IE" then
                           Result_Filter (Internal_Error) := True;
                        else
                           Put_Line ("Invalid filter: " & F (Prev .. Pos - 1));
                           return;
                        end if;

                        Prev := Pos + 1;
                        exit when Pos > F'Last;
                     end if;
                  end loop;
               end;

            elsif Full_Switch = "-descr" then
               Show_Descr := True;

            else
               Put_Line ("Invalid switch: -" & Full_Switch);
            end if;
         when 'a'    => Accepted_Only := False;
         when others => exit;
      end case;
   end loop;

   Parse_Disabled;

   if Debug then
      Schema.Set_Debug_Output (True);
   end if;

   Put_Line (Base_Name (Command_Name, ".exe"));

   Run_Testsuite ("suite.xml");
end Schematest;