-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011, 2012, 2016, 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 Ada.Streams;
with Util.Streams.Texts;
with Util.Stacks;
with Util.Beans.Objects;
package Util.Serialize.IO.JSON is

   --  ------------------------------
   --  JSON Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating a JSON output stream.
   --  The stream object takes care of the JSON escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Start a JSON document.  This operation writes the initial JSON marker ('{').
   overriding
   procedure Start_Document (Stream : in out Output_Stream);

   --  Finish a JSON document by writing the final JSON marker ('}').
   overriding
   procedure End_Document (Stream : in out Output_Stream);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Start a new JSON object.  If the name is not empty, write it as a string
   --  followed by the ':' (colon).  The JSON object starts with '{' (curly brace).
   --  Example:   "list": {
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current JSON object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a JSON name/value pair.  The value is written according to its type
   --  Example:  "name": null
   --            "name": false
   --            "name": 12
   --            "name": "value"
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Starts a JSON array.
   --  Example:  "list": [
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a JSON array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Read a JSON file and return an object.
   function Read (Path : in String) return Util.Beans.Objects.Object;

private

   type Node_Info is record
      Is_Array   : Boolean := False;
      Has_Fields : Boolean := False;
   end record;
   type Node_Info_Access is access all Node_Info;

   package Node_Info_Stack is new Util.Stacks (Element_Type => Node_Info,
                                               Element_Type_Access => Node_Info_Access);

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Stack  : Node_Info_Stack.Stack;
      Stream : Util.Streams.Texts.Print_Stream_Access;
   end record;

   procedure Write_Field_Name (Stream : in out Output_Stream;
                               Name   : in String);

   type Token_Type is (T_EOF, T_LEFT_BRACE, T_RIGHT_BRACE, T_LEFT_BRACKET,
                       T_RIGHT_BRACKET, T_COLON, T_COMMA, T_TRUE, T_FALSE,
                       T_STRING, T_NUMBER, T_BOOLEAN, T_UNKNOWN, T_NULL);

   type Parser is new Util.Serialize.IO.Parser with record
      Token            : Ada.Strings.Unbounded.Unbounded_String;
      Pending_Token    : Token_Type := T_EOF;
      Line_Number      : Natural  := 1;
      Has_Pending_Char : Boolean := False;
      Pending_Char     : Character;
   end record;

end Util.Serialize.IO.JSON;

-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011, 2012, 2016, 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 Ada.Streams;
with Util.Streams.Texts;
with Util.Stacks;
with Util.Beans.Objects;
package Util.Serialize.IO.JSON is

   --  ------------------------------
   --  JSON Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating a JSON output stream.
   --  The stream object takes care of the JSON escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Start a JSON document.  This operation writes the initial JSON marker ('{').
   overriding
   procedure Start_Document (Stream : in out Output_Stream);

   --  Finish a JSON document by writing the final JSON marker ('}').
   overriding
   procedure End_Document (Stream : in out Output_Stream);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Start a new JSON object.  If the name is not empty, write it as a string
   --  followed by the ':' (colon).  The JSON object starts with '{' (curly brace).
   --  Example:   "list": {
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current JSON object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a JSON name/value pair.  The value is written according to its type
   --  Example:  "name": null
   --            "name": false
   --            "name": 12
   --            "name": "value"
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Starts a JSON array.
   --  Example:  "list": [
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a JSON array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Read a JSON file and return an object.
   function Read (Path : in String) return Util.Beans.Objects.Object;

private

   type Node_Info is record
      Is_Array   : Boolean := False;
      Is_Root    : Boolean := False;
      Has_Fields : Boolean := False;
   end record;
   type Node_Info_Access is access all Node_Info;

   package Node_Info_Stack is new Util.Stacks (Element_Type => Node_Info,
                                               Element_Type_Access => Node_Info_Access);

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Stack  : Node_Info_Stack.Stack;
      Stream : Util.Streams.Texts.Print_Stream_Access;
   end record;

   procedure Write_Field_Name (Stream : in out Output_Stream;
                               Name   : in String);

   type Token_Type is (T_EOF, T_LEFT_BRACE, T_RIGHT_BRACE, T_LEFT_BRACKET,
                       T_RIGHT_BRACKET, T_COLON, T_COMMA, T_TRUE, T_FALSE,
                       T_STRING, T_NUMBER, T_BOOLEAN, T_UNKNOWN, T_NULL);

   type Parser is new Util.Serialize.IO.Parser with record
      Token            : Ada.Strings.Unbounded.Unbounded_String;
      Pending_Token    : Token_Type := T_EOF;
      Line_Number      : Natural  := 1;
      Has_Pending_Char : Boolean := False;
      Pending_Char     : Character;
   end record;

end Util.Serialize.IO.JSON;

Add a Is_Root field to the Node_Info record


-----------------------------------------------------------------------
--  awa-oauth-filters -- OAuth filter
--  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 ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
with ASF.Principals;
with ASF.Filters;
with ASF.Servlets;
with ASF.Security.Filters;

with AWA.Users.Principals;
with AWA.OAuth.Services;
package AWA.OAuth.Filters is

   --  ------------------------------
   --  OAuth Authentication filter
   --  ------------------------------
   --  The <b>Auth_Filter</b> verifies that the access token passed for the OAuth
   --  operation is valid and it extracts the user to configure the request principal.
   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Initialize the filter.
   overriding
   procedure Initialize (Filter  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The Filter_Chain passed in to this
   --  method allows the Filter to pass on the request and response to the next
   --  entity in the chain.
   --
   --  Before passing the control to the next filter, initialize the service
   --  context to give access to the current application, current user and
   --  manage possible transaction rollbacks.
   overriding
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

private

   use Ada.Strings.Unbounded;

   type Auth_Filter is new ASF.Filters.Filter with record
      Realm : AWA.OAuth.Services.Auth_Manager_Access;
   end record;

end AWA.OAuth.Filters;

-----------------------------------------------------------------------
--  awa-oauth-filters -- OAuth filter
--  Copyright (C) 2017, 2018 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 ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
with ASF.Filters;
with ASF.Servlets;

with AWA.OAuth.Services;
package AWA.OAuth.Filters is

   --  ------------------------------
   --  OAuth Authentication filter
   --  ------------------------------
   --  The <b>Auth_Filter</b> verifies that the access token passed for the OAuth
   --  operation is valid and it extracts the user to configure the request principal.
   type Auth_Filter is new ASF.Filters.Filter with private;

   --  Initialize the filter.
   overriding
   procedure Initialize (Filter  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The Filter_Chain passed in to this
   --  method allows the Filter to pass on the request and response to the next
   --  entity in the chain.
   --
   --  Before passing the control to the next filter, initialize the service
   --  context to give access to the current application, current user and
   --  manage possible transaction rollbacks.
   overriding
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

private

   type Auth_Filter is new ASF.Filters.Filter with record
      Realm : AWA.OAuth.Services.Auth_Manager_Access;
   end record;

end AWA.OAuth.Filters;

Remove unused with clauses

Remove unused with clauses


-----------------------------------------------------------------------
--  cut -- Text Transformations
--  Copyright (C) 2012 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.Text_IO;
with Ada.Command_Line;
with Util.Strings;
with Util.Strings.Tokenizers;
procedure Cut is

   procedure Print_Token (Token : in String;
                          Done  : out Boolean) is
   begin
      Ada.Text_IO.Put_Line (Token);
      Done := False;
   end Print_Token;

   Count : constant Natural := Ada.Command_Line.Argument_Count;
begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: cut pattern ...");
      Ada.Text_IO.Put_Line ("Example: cut : $PATH");
      return;
   end if;
   declare
      Pattern : constant String := Ada.Command_Line.Argument (1);
   begin
      for I in 2 .. Count loop
         Util.Strings.Tokenizers.Iterate_Tokens (Content => Ada.Command_Line.Argument (I),
                                                 Pattern => Pattern,
                                                 Process => Print_Token'Access);
      end loop;
   end;
end Cut;

-----------------------------------------------------------------------
--  cut -- Text Transformations
--  Copyright (C) 2012, 2022 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.Text_IO;
with Ada.Command_Line;
with Util.Strings;
with Util.Strings.Tokenizers;
procedure Cut is
   procedure Print_Token (Token : in String;
                          Done  : out Boolean);

   procedure Print_Token (Token : in String;
                          Done  : out Boolean) is
   begin
      Ada.Text_IO.Put_Line (Token);
      Done := False;
   end Print_Token;

   Count : constant Natural := Ada.Command_Line.Argument_Count;
begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: cut pattern ...");
      Ada.Text_IO.Put_Line ("Example: cut : $PATH");
      return;
   end if;
   declare
      Pattern : constant String := Ada.Command_Line.Argument (1);
   begin
      for I in 2 .. Count loop
         Util.Strings.Tokenizers.Iterate_Tokens (Content => Ada.Command_Line.Argument (I),
                                                 Pattern => Pattern,
                                                 Process => Print_Token'Access);
      end loop;
   end;
end Cut;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  Copyright (C) 2012 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 Security.Permissions;

with ADO;
with AWA.Modules;

with EL.Expressions;

with AWA.Storages.Models;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package AWA.Images.Services is

   package ACL_Create_Storage is new Security.Permissions.Permission_ACL ("storage-create");
   package ACL_Delete_Storage is new Security.Permissions.Permission_ACL ("storage-delete");
   package ACL_Create_Folder is new Security.Permissions.Permission_ACL ("folder-create");

   PARAM_THUMBNAIL_COMMAND : constant String := "thumbnail_command";

   --  ------------------------------
   --  Image Service
   --  ------------------------------
   --  The Image_Service works closely with the storage service.  It extracts the
   --  information of an image, creates the image thumbnail.
   type Image_Service is new AWA.Modules.Module_Manager with private;
   type Image_Service_Access is access all Image_Service'Class;

   --  Initializes the image service.
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class);

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural);

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class);

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class);

private

   type Image_Service is new AWA.Modules.Module_Manager with record
      Thumbnail_Command : EL.Expressions.Expression;
   end record;

end AWA.Images.Services;

-----------------------------------------------------------------------
--  awa-images-services -- Image service
--  Copyright (C) 2012 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 Security.Permissions;

with ADO;
with AWA.Modules;

with EL.Expressions;

with AWA.Storages.Models;

--  == Storage Service ==
--  The <tt>Storage_Service</tt> provides the operations to access and use the persisent storage.
--  It controls the permissions that grant access to the service for users.
--
--  Other modules can be notified of storage changes by registering a listener
--  on the storage module.
package AWA.Images.Services is

   package ACL_Create_Storage is new Security.Permissions.Definition ("storage-create");
   package ACL_Delete_Storage is new Security.Permissions.Definition ("storage-delete");
   package ACL_Create_Folder is new Security.Permissions.Definition ("folder-create");

   PARAM_THUMBNAIL_COMMAND : constant String := "thumbnail_command";

   --  ------------------------------
   --  Image Service
   --  ------------------------------
   --  The Image_Service works closely with the storage service.  It extracts the
   --  information of an image, creates the image thumbnail.
   type Image_Service is new AWA.Modules.Module_Manager with private;
   type Image_Service_Access is access all Image_Service'Class;

   --  Initializes the image service.
   overriding
   procedure Initialize (Service : in out Image_Service;
                         Module  : in AWA.Modules.Module'Class);

   procedure Create_Thumbnail (Service : in Image_Service;
                               Source  : in String;
                               Into    : in String;
                               Width   : out Natural;
                               Height  : out Natural);

   --  Save the data object contained in the Data part element into the
   --  target storage represented by Into.
   procedure Create_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class);

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Service;
                           File    : in AWA.Storages.Models.Storage_Ref'Class);

private

   type Image_Service is new AWA.Modules.Module_Manager with record
      Thumbnail_Command : EL.Expressions.Expression;
   end record;

end AWA.Images.Services;

Use the Permissions.Definition generic package


-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014 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 Util.Listeners;

with Babel.Files;
with Babel.Files.Queues;
with Babel.Files.Buffers;
with Babel.Stores;
with Babel.Filters;
package Babel.Strategies is

   type Strategy_Type is abstract tagged limited private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   procedure Peek_Directory (Strategy  : in out Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is abstract;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class);

   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

   --  Set the listeners to inform about changes.
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List);

private

   type Strategy_Type is abstract tagged limited record
      Read_Store  : Babel.Stores.Store_Type_Access;
      Write_Store : Babel.Stores.Store_Type_Access;
      Filters     : Babel.Filters.Filter_Type_Access;
      Buffers     : Babel.Files.Buffers.Buffer_Pool_Access;
      Listeners   : access Util.Listeners.List;
   end record;

end Babel.Strategies;

-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014 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 Util.Listeners;

with Babel.Files;
with Babel.Files.Queues;
with Babel.Files.Buffers;
with Babel.Stores;
with Babel.Filters;
with Babel.Base;
package Babel.Strategies is

   type Strategy_Type is abstract tagged limited private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   procedure Peek_Directory (Strategy  : in out Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is abstract;

   --  Scan the directory
   procedure Scan (Strategy  : in out Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class);

   --  Scan the directories which are defined in the directory queue and
   --  use the file container to scan the files and directories.
   procedure Scan (Strategy  : in out Strategy_Type;
                   Queue     : in out Babel.Files.Queues.Directory_Queue;
                   Container : in out Babel.Files.File_Container'Class);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

   --  Set the listeners to inform about changes.
   procedure Set_Listeners (Strategy  : in out Strategy_Type;
                            Listeners : access Util.Listeners.List);

   --  Set the database for use by the strategy.
   procedure Set_Database (Strategy : in out Strategy_Type;
                           Database : in Babel.Base.Database_Access);

private

   type Strategy_Type is abstract tagged limited record
      Read_Store  : Babel.Stores.Store_Type_Access;
      Write_Store : Babel.Stores.Store_Type_Access;
      Filters     : Babel.Filters.Filter_Type_Access;
      Buffers     : Babel.Files.Buffers.Buffer_Pool_Access;
      Listeners   : access Util.Listeners.List;
      Database    : Babel.Base.Database_Access;
   end record;

end Babel.Strategies;

Define the Set_Database operation

Define the Set_Database operation


-----------------------------------------------------------------------
--  import -- Import some HTML content and generate Wiki text
--  Copyright (C) 2015, 2016 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.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Characters.Conversions;

with GNAT.Command_Line;

with Util.Files;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Strings.Transforms;

with Wiki.Filters.Html;
with Wiki.Filters.TOC;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Render.Wiki;
with Wiki.Documents;
with Wiki.Parsers;

procedure Import is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Characters.Conversions;

   procedure Usage;
   function Is_Url (Name : in String) return Boolean;
   procedure Parse_Url (Url : in String);
   procedure Parse (Content : in String);

   Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
   TOC         : aliased Wiki.Filters.TOC.TOC_Filter;
   Count       : Natural := 0;
   Html_Mode   : Boolean := True;
   Wiki_Mode   : Boolean := False;
   Syntax      : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Import HTML into a target Wiki format");
      Ada.Text_IO.Put_Line ("Usage: import [-t] [-m] [-M] [-d] [-c] {URL | file}");
      Ada.Text_IO.Put_Line ("  -t      Convert to text only");
      Ada.Text_IO.Put_Line ("  -m      Convert to Markdown");
      Ada.Text_IO.Put_Line ("  -M      Convert to Mediawiki");
      Ada.Text_IO.Put_Line ("  -d      Convert to Dotclear");
      Ada.Text_IO.Put_Line ("  -c      Convert to Creole");
   end Usage;

   procedure Parse (Content : in String) is
      Doc    : Wiki.Documents.Document;
      Engine : Wiki.Parsers.Parser;
   begin
      Engine.Add_Filter (TOC'Unchecked_Access);
      Engine.Add_Filter (Html_Filter'Unchecked_Access);
      if Wiki_Mode then
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Wiki.Wiki_Renderer;
         begin
            Engine.Set_Syntax (Wiki.SYNTAX_HTML);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access, Syntax);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      elsif Html_Mode then
         declare
            Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Html.Html_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      else
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Text.Text_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      end if;
   end Parse;

   procedure Parse_Url (Url : in String) is
      Command : constant String := "wget -q -O - " & Url;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer  : Util.Streams.Buffered.Buffered_Stream;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Pipe.Open (Command);
      Buffer.Initialize (null, Pipe'Unchecked_Access, 1024 * 1024);
      Buffer.Read (Content);
      Pipe.Close;
      if Pipe.Get_Exit_Status /= 0 then
         Ada.Text_IO.Put_Line (Command & " exited with status "
                               & Integer'Image (Pipe.Get_Exit_Status));
      else
         Parse (To_String (Content));
      end if;
   end Parse_Url;

   function Is_Url (Name : in String) return Boolean is
   begin
      if Name'Length <= 9 then
         return False;
      else
         return Name (Name'First .. Name'First + 6) = "http://"
           or Name (Name'First .. Name'First + 7) = "https://";
      end if;
   end Is_Url;

begin
   loop
      case Getopt ("m M d c t f:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;
            Wiki_Mode := True;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;
            Wiki_Mode := True;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;
            Wiki_Mode := True;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;
            Wiki_Mode := True;

         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Upper_Case (Parameter);
            begin
               Html_Filter.Hide (Wiki.Html_Tag'Value (Value & "_TAG"));
            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid tag " & Value);
            end;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         if Is_Url (Name) then
            Parse_Url (Name);
         else
            Util.Files.Read_File (Name, Data);
            Parse (To_String (Data));
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;

end Import;

-----------------------------------------------------------------------
--  import -- Import some HTML content and generate Wiki text
--  Copyright (C) 2015, 2016 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.Text_IO;
with Ada.IO_Exceptions;
with Ada.Strings.Unbounded;
with Ada.Characters.Conversions;

with GNAT.Command_Line;

with Util.Files;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Strings.Transforms;

with Wiki.Filters.Html;
with Wiki.Filters.TOC;
with Wiki.Streams.Builders;
with Wiki.Streams.Html.Builders;
with Wiki.Render.Html;
with Wiki.Render.Text;
with Wiki.Render.Wiki;
with Wiki.Documents;
with Wiki.Parsers;

procedure Import is

   use GNAT.Command_Line;
   use Ada.Strings.Unbounded;
   use Ada.Characters.Conversions;

   procedure Usage;
   function Is_Url (Name : in String) return Boolean;
   procedure Parse_Url (Url : in String);
   procedure Parse (Content : in String);

   Html_Filter : aliased Wiki.Filters.Html.Html_Filter_Type;
   TOC         : aliased Wiki.Filters.TOC.TOC_Filter;
   Count       : Natural := 0;
   Html_Mode   : Boolean := True;
   Wiki_Mode   : Boolean := False;
   Syntax      : Wiki.Wiki_Syntax := Wiki.SYNTAX_MARKDOWN;

   procedure Usage is
   begin
      Ada.Text_IO.Put_Line ("Import HTML into a target Wiki format");
      Ada.Text_IO.Put_Line ("Usage: import [-t] [-m] [-M] [-d] [-c] {URL | file}");
      Ada.Text_IO.Put_Line ("  -t      Convert to text only");
      Ada.Text_IO.Put_Line ("  -m      Convert to Markdown");
      Ada.Text_IO.Put_Line ("  -M      Convert to Mediawiki");
      Ada.Text_IO.Put_Line ("  -d      Convert to Dotclear");
      Ada.Text_IO.Put_Line ("  -c      Convert to Creole");
   end Usage;

   procedure Parse (Content : in String) is
      Doc    : Wiki.Documents.Document;
      Engine : Wiki.Parsers.Parser;
   begin
      Engine.Add_Filter (TOC'Unchecked_Access);
      Engine.Add_Filter (Html_Filter'Unchecked_Access);
      if Wiki_Mode then
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Wiki.Wiki_Renderer;
         begin
            Engine.Set_Syntax (Wiki.SYNTAX_HTML);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access, Syntax);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      elsif Html_Mode then
         declare
            Stream   : aliased Wiki.Streams.Html.Builders.Html_Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Html.Html_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      else
         declare
            Stream   : aliased Wiki.Streams.Builders.Output_Builder_Stream;
            Renderer : aliased Wiki.Render.Text.Text_Renderer;
         begin
            Engine.Set_Syntax (Syntax);
            Engine.Parse (To_Wide_Wide_String (Content), Doc);
            Renderer.Set_Output_Stream (Stream'Unchecked_Access);
            Renderer.Render (Doc);
            Ada.Text_IO.Put_Line (Stream.To_String);
         end;
      end if;
   end Parse;

   procedure Parse_Url (Url : in String) is
      Command : constant String := "wget -q -O - " & Url;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer  : Util.Streams.Buffered.Input_Buffer_Stream;
      Content : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Pipe.Open (Command);
      Buffer.Initialize (Pipe'Unchecked_Access, 1024 * 1024);
      Buffer.Read (Content);
      Pipe.Close;
      if Pipe.Get_Exit_Status /= 0 then
         Ada.Text_IO.Put_Line (Command & " exited with status "
                               & Integer'Image (Pipe.Get_Exit_Status));
      else
         Parse (To_String (Content));
      end if;
   end Parse_Url;

   function Is_Url (Name : in String) return Boolean is
   begin
      if Name'Length <= 9 then
         return False;
      else
         return Name (Name'First .. Name'First + 6) = "http://"
           or Name (Name'First .. Name'First + 7) = "https://";
      end if;
   end Is_Url;

begin
   loop
      case Getopt ("m M d c t f:") is
         when 'm' =>
            Syntax := Wiki.SYNTAX_MARKDOWN;
            Wiki_Mode := True;

         when 'M' =>
            Syntax := Wiki.SYNTAX_MEDIA_WIKI;
            Wiki_Mode := True;

         when 'c' =>
            Syntax := Wiki.SYNTAX_CREOLE;
            Wiki_Mode := True;

         when 'd' =>
            Syntax := Wiki.SYNTAX_DOTCLEAR;
            Wiki_Mode := True;

         when 't' =>
            Html_Mode := False;

         when 'f' =>
            declare
               Value : constant String := Util.Strings.Transforms.To_Upper_Case (Parameter);
            begin
               Html_Filter.Hide (Wiki.Html_Tag'Value (Value & "_TAG"));
            exception
               when Constraint_Error =>
                  Ada.Text_IO.Put_Line ("Invalid tag " & Value);
            end;

         when others =>
            exit;
      end case;
   end loop;

   loop
      declare
         Name : constant String := GNAT.Command_Line.Get_Argument;
         Data : Unbounded_String;
      begin
         if Name = "" then
            if Count = 0 then
               Usage;
            end if;
            return;
         end if;
         Count := Count + 1;
         if Is_Url (Name) then
            Parse_Url (Name);
         else
            Util.Files.Read_File (Name, Data);
            Parse (To_String (Data));
         end if;

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Ada.Text_IO.Put_Line ("Cannot read file '" & Name & "'");

      end;
   end loop;

exception
   when Invalid_Switch =>
      Ada.Text_IO.Put_Line ("Invalid option.");
      Usage;

end Import;

Update to use latest Ada Util library

Update to use latest Ada Util library


-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 2015 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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Level  : in Positive;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;
      Limit       : MAT.Types.Target_Time := MAT.Types.Target_Time (Level * 1_000_000);

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > Limit then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  MAT.Events.Tools.Collect_Info (Info, Event);
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Positive;
                          Exact  : in Boolean;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
            First     : Natural;
            Last      : Natural;
         begin
            if Exact then
               First := Depth;
            else
               First := Backtrace'First;
            end if;
            if Depth < Backtrace'Last then
               Last := Depth;
            else
               Last := Backtrace'Last;
            end if;
            for I in First .. Last loop
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Count := 0;
                        MAT.Events.Tools.Collect_Info (Info, Event);
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 2015 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 MAT.Frames;
package body MAT.Events.Timelines is

   use MAT.Events.Targets;

   ITERATE_COUNT : constant MAT.Events.Event_Id_Type := 10_000;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events'Class;
                      Level  : in Positive;
                      Into   : in out Timeline_Info_Vector) is
      use type MAT.Types.Target_Time;
      use type MAT.Types.Target_Size;
      procedure Collect (Event : in MAT.Events.Target_Event_Type);

      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Prev_Event  : MAT.Events.Target_Event_Type;
      Info        : Timeline_Info;
      First_Id    : MAT.Events.Event_Id_Type;
      Limit       : MAT.Types.Target_Time := MAT.Types.Target_Time (Level * 1_000_000);

      procedure Collect (Event : in MAT.Events.Target_Event_Type) is
         Dt : constant MAT.Types.Target_Time := Event.Time - Prev_Event.Time;
      begin
         if Dt > Limit then
            Into.Append (Info);
            Info.Malloc_Count := 0;
            Info.Realloc_Count := 0;
            Info.Free_Count := 0;
            Info.First_Event := Event;
            Info.Free_Size := 0;
            Info.Alloc_Size := 0;
            Prev_Event := Event;
         end if;
         Info.Last_Event := Event;
         if Event.Event = 2 then
            Info.Malloc_Count := Info.Malloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
         elsif Event.Event = 3 then
            Info.Realloc_Count := Info.Realloc_Count + 1;
            Info.Alloc_Size := Info.Alloc_Size + Event.Size;
            Info.Free_Size := Info.Free_Size + Event.Old_Size;
         elsif Event.Event = 4 then
            Info.Free_Count := Info.Free_Count + 1;
            Info.Free_Size := Info.Free_Size + Event.Size;
         end if;
      end Collect;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      Prev_Event      := First_Event;
      Info.First_Event := First_Event;
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Collect'Access);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Extract;

   --  ------------------------------
   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   --  ------------------------------
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Target_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Tools.Target_Event_Vector) is

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type);
      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type);

      First_Id    : MAT.Events.Event_Id_Type;
      Last_Id     : MAT.Events.Event_Id_Type;
      First_Event : MAT.Events.Target_Event_Type;
      Last_Event  : MAT.Events.Target_Event_Type;
      Addr        : MAT.Types.Target_Addr := Event.Addr;

      Done : exception;

      procedure Collect_Free (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_FREE and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Old_Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Addr;
         end if;
      end Collect_Free;

      procedure Collect_Alloc (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Event.Index = MAT.Events.MSG_MALLOC and then Event.Addr = Addr then
            List.Append (Event);
            raise Done;
         end if;
         if Event.Index = MAT.Events.MSG_REALLOC and then Event.Addr = Addr then
            List.Append (Event);
            if Positive (List.Length) >= Max then
               raise Done;
            end if;
            Addr := Event.Old_Addr;
         end if;
      end Collect_Alloc;

   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := Event.Id;
      if Event.Index = MAT.Events.MSG_FREE then
         --  Search backward for MSG_MALLOC and MSG_REALLOC.
         First_Id := First_Id - 1;
         while First_Id > First_Event.Id loop
            if First_Id > ITERATE_COUNT then
               Last_Id := First_Id - ITERATE_COUNT;
            else
               Last_Id := First_Event.Id;
            end if;
            Target.Iterate (Start   => First_Id,
                            Finish  => Last_Id,
                            Process => Collect_Alloc'Access);
            First_Id := Last_Id;
         end loop;
      else
         --  Search forward for MSG_REALLOC and MSG_FREE
         First_Id := First_Id + 1;
         while First_Id < Last_Event.Id loop
            Target.Iterate (Start   => First_Id,
                            Finish  => First_Id + ITERATE_COUNT,
                            Process => Collect_Free'Access);
            First_Id := First_Id + ITERATE_COUNT;
         end loop;
      end if;

   exception
      when Done =>
         null;
   end Find_Related;

   --  ------------------------------
   --  Find the sizes of malloc and realloc events which is selected by the given filter.
   --  Update the <tt>Sizes</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding size.
   --  ------------------------------
   procedure Find_Sizes (Target : in out MAT.Events.Targets.Target_Events'Class;
                         Filter : in MAT.Expressions.Expression_Type;
                         Sizes  : in out MAT.Events.Tools.Size_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Size : in MAT.Types.Target_Size;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Size);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for malloc or realloc events which are selected by the filter.
         if (Event.Index /= MAT.Events.MSG_MALLOC
             and Event.Index /= MAT.Events.MSG_FREE
             and Event.Index /= MAT.Events.MSG_REALLOC)
           or else not Filter.Is_Selected (Event)
         then
            return;
         end if;
         declare
            Pos : constant MAT.Events.Tools.Size_Event_Info_Cursor := Sizes.Find (Event.Size);
         begin
            if MAT.Events.Tools.Size_Event_Info_Maps.Has_Element (Pos) then
               --  Increment the count and update the last event.
               Sizes.Update_Element (Pos, Update_Size'Access);
            else
               declare
                  Info : MAT.Events.Tools.Event_Info_Type;
               begin
                  --  Insert a new size with the event.
                  Info.First_Event := Event;
                  MAT.Events.Tools.Collect_Info (Info, Event);
                  Sizes.Insert (Event.Size, Info);
               end;
            end if;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Sizes;

   --  ------------------------------
   --  Find the function address from the call event frames for the events which is selected
   --  by the given filter.  The function addresses are collected up to the given frame depth.
   --  Update the <tt>Frames</tt> map to keep track of the first event and last event and
   --  the number of events found for the corresponding frame address.
   --  ------------------------------
   procedure Find_Frames (Target : in out MAT.Events.Targets.Target_Events'Class;
                          Filter : in MAT.Expressions.Expression_Type;
                          Depth  : in Positive;
                          Exact  : in Boolean;
                          Frames : in out MAT.Events.Tools.Frame_Event_Info_Map) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type);

         procedure Update_Size (Key  : in MAT.Events.Tools.Frame_Key_Type;
                                Info : in out MAT.Events.Tools.Event_Info_Type) is
            pragma Unreferenced (Key);
         begin
            MAT.Events.Tools.Collect_Info (Info, Event);
         end Update_Size;

      begin
         --  Look for events which are selected by the filter.
         if not Filter.Is_Selected (Event) then
            return;
         end if;
         declare
            Backtrace : constant MAT.Frames.Frame_Table := MAT.Frames.Backtrace (Event.Frame);
            Key       : MAT.Events.Tools.Frame_Key_Type;
            First     : Natural;
            Last      : Natural;
         begin
            if Exact then
               First := Depth;
            else
               First := Backtrace'First;
            end if;
            if Depth < Backtrace'Last then
               Last := Depth;
            else
               Last := Backtrace'Last;
            end if;
            for I in First .. Last loop
               Key.Addr  := Backtrace (Backtrace'Last - I + 1);
               Key.Level := I;
               declare
                  Pos : constant MAT.Events.Tools.Frame_Event_Info_Cursor
                    := Frames.Find (Key);
               begin
                  if MAT.Events.Tools.Frame_Event_Info_Maps.Has_Element (Pos) then
                     --  Increment the count and update the last event.
                     Frames.Update_Element (Pos, Update_Size'Access);
                  else
                     declare
                        Info : MAT.Events.Tools.Event_Info_Type;
                     begin
                        --  Insert a new size with the event.
                        Info.First_Event := Event;
                        Info.Count := 0;
                        MAT.Events.Tools.Collect_Info (Info, Event);
                        Frames.Insert (Key, Info);
                     end;
                  end if;
               end;
            end loop;
         end;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Find_Frames;

   --  ------------------------------
   --  Collect the events that match the filter and append them to the events vector.
   --  ------------------------------
   procedure Filter_Events (Target : in out MAT.Events.Targets.Target_Events'Class;
                            Filter : in MAT.Expressions.Expression_Type;
                            Events : in out MAT.Events.Tools.Target_Event_Vector) is
      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type);

      procedure Collect_Event (Event : in MAT.Events.Target_Event_Type) is
      begin
         if Filter.Is_Selected (Event) then
            Events.Append (Event);
         end if;
      end Collect_Event;

   begin
      Target.Iterate (Process => Collect_Event'Access);
   end Filter_Events;

end MAT.Events.Timelines;

Implement the Filter_Events procedure

Implement the Filter_Events procedure


-----------------------------------------------------------------------
--  wiki-parsers-html -- Wiki HTML parser
--  Copyright (C) 2015, 2016 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 Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.UString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.UString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.UString) is
      C : Wiki.Strings.WChar;
   begin
      Name := Wiki.Strings.To_UString ("");
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.UString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.UString;
      Value : Wiki.Strings.UString;
   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Wiki.Helpers.Is_Space (C) and Wiki.Strings.Length (Name) > 0 then
            Attributes.Append (P.Attributes, Name, Wiki.Strings.Null_UString);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Wiki.Strings.Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Wiki.Strings.Null_UString);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      Name : Wiki.Strings.UString;
      C    : Wiki.Strings.WChar;
      Tag  : Wiki.Html_Tag;
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      declare
         Token : constant Wiki.Strings.WString := Wiki.Strings.To_WString (Name);
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Is_Hidden := False;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Is_Hidden := True;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end;
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

-----------------------------------------------------------------------
--  wiki-parsers-html -- Wiki HTML parser
--  Copyright (C) 2015, 2016 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 Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString) is
      C : Wiki.Strings.WChar;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Wide_Wide_Builders.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
--      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Wide_Wide_Builders.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      procedure Append_Attribute (Name : in Wiki.Strings.WString);

      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.BString (64);
      Value : Wiki.Strings.BString (256);

      procedure Append_Attribute (Name : in Wiki.Strings.WString) is

         procedure Attribute_Value (Value : in Wiki.Strings.WString);

         procedure Attribute_Value (Value : in Wiki.Strings.WString) is
         begin
            Attributes.Append (P.Attributes, Name, Value);
         end Attribute_Value;

         procedure Attribute_Value is
           new Wiki.Strings.Wide_Wide_Builders.Get (Attribute_Value);

      begin
         Attribute_Value (Value);
      end Append_Attribute;
      pragma Inline_Always (Append_Attribute);

      procedure Append_Attribute is
        new Wiki.Strings.Wide_Wide_Builders.Get (Append_Attribute);

   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Value);
         elsif Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
            Put_Back (P, C);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
         end if;
      end loop;

      --  Add any pending attribute.
      if Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
         Append_Attribute (Name);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      C    : Wiki.Strings.WChar;

      procedure Add_Element (Token : in Wiki.Strings.WString);

      procedure Add_Element (Token : in Wiki.Strings.WString) is
         Tag  : Wiki.Html_Tag;
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Is_Hidden := False;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Is_Hidden := True;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end Add_Element;
      pragma Inline_Always (Add_Element);

      procedure Add_Element is
        new Wiki.Strings.Wide_Wide_Builders.Get (Add_Element);
      pragma Inline_Always (Add_Element);

      Name : Wiki.Strings.BString (64);
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Add_Element (Name);
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

Use Wiki.Strings.BString for the attribute name and attribute value (reduce dynamic memory allocation)