--  bkp-files -- File and directories
-----------------------------------------------------------------------
--  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.Log.Loggers;
with Util.Files;
with Util.Encoders.Base16;
package body Babel.Files is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bkp.Files");

   Hex_Encoder : Util.Encoders.Base16.Encoder;

   --  ------------------------------
   --  Compare two files on their name and directory.
   --  ------------------------------
   function "<" (Left, Right : in File_Type) return Boolean is
      use type Ada.Strings.Unbounded.Unbounded_String;
   begin
      if Left = NO_FILE then
         return False;
      elsif Right = NO_FILE then
         return True;
      elsif Left.Dir = Right.Dir then
         return Left.Name < Right.Name;
      elsif Left.Dir = NO_DIRECTORY then
         return True;
      elsif Right.Dir = NO_DIRECTORY then
         return False;
      else
         return Left.Dir.Path < Right.Dir.Path;
      end if;
   end "<";

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      use Ada.Strings.Unbounded;
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Allocate a Directory_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type is
      use Ada.Strings.Unbounded;

      Result : constant Directory_Type := new Directory '(Len    => Name'Length,
                                                          Id     => NO_IDENTIFIER,
                                                          Parent => Dir,
                                                          Name   => Name,
                                                          others => <>);
   begin
      if Dir /= null then
         Result.Path := To_Unbounded_String
           (Util.Files.Compose (To_String (Dir.Path), Name));
      else
         Result.Path := To_Unbounded_String (Name);
      end if;
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Return true if the file is a new file.
   --  ------------------------------
   function Is_New (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      return Element.Id = NO_IDENTIFIER;
   end Is_New;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   --  ------------------------------
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array) is
      use type Util.Encoders.SHA1.Hash_Array;
   begin
      if (Element.Status and FILE_HAS_SHA1) /= 0 and then Element.SHA1 /= Signature then
         Element.Status := Element.Status or FILE_MODIFIED;
      end if;
      Element.Status := Element.Status or FILE_HAS_SHA1;
      Element.SHA1   := Signature;
   end Set_Signature;

   --  ------------------------------
   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   --  ------------------------------
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size) is
   begin
      if Element.Size /= Size then
         Element.Size := Size;
         Element.Status := Element.Status or FILE_MODIFIED;
      end if;
   end Set_Size;

   --  ------------------------------
   --  Set the owner and group of the file.
   --  ------------------------------
   procedure Set_Owner (Element : in File_Type;
                        User    : in Uid_Type;
                        Group   : in Gid_Type) is
   begin
      Element.User  := User;
      Element.Group := Group;
   end Set_Owner;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

   --  ------------------------------
   --  Return the SHA1 signature computed for the file.
   --  ------------------------------
   function Get_SHA1 (Element : in File_Type) return String is
   begin
      return Hex_Encoder.Transform (Element.SHA1);
   end Get_SHA1;

   --  ------------------------------
   --  Return the file size.
   --  ------------------------------
   function Get_Size (Element : in File_Type) return File_Size is
   begin
      return Element.Size;
   end Get_Size;

   --  ------------------------------
   --  Return the file modification date.
   --  ------------------------------
   function Get_Date (Element : in File_Type) return Ada.Calendar.Time is
   begin
      return Element.Date;
   end Get_Date;

   --  ------------------------------
   --  Return the user uid.
   --  ------------------------------
   function Get_User (Element : in File_Type) return Uid_Type is
   begin
      return Element.User;
   end Get_User;

   --  ------------------------------
   --  Return the group gid.
   --  ------------------------------
   function Get_Group (Element : in File_Type) return Gid_Type is
   begin
      return Element.Group;
   end Get_Group;

   --  ------------------------------
   --  Return the file unix mode.
   --  ------------------------------
   function Get_Mode (Element : in File_Type) return File_Mode is
   begin
      return Element.Mode;
   end Get_Mode;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_File (Into    : in out Default_Container;
                       Element : in File_Type) is
   begin
      Into.Files.Append (Element);
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_Directory (Into    : in out Default_Container;
                            Element : in Directory_Type) is
   begin
      Into.Dirs.Append (Element);
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return File_Type is
      pragma Unreferenced (From, Name);
   begin
      return NO_FILE;
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return Directory_Type is
      pragma Unreferenced (From, Name);
   begin
      return NO_DIRECTORY;
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   procedure Set_Directory (Into      : in out Default_Container;
                            Directory : in Directory_Type) is
   begin
      Into.Current := Directory;
      Into.Files.Clear;
      Into.Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Execute the Process procedure on each directory found in the container.
   --  ------------------------------
   overriding
   procedure Each_Directory (Container : in Default_Container;
                             Process   : not null access
                               procedure (Dir : in Directory_Type)) is
      Iter : Directory_Vectors.Cursor := Container.Dirs.First;
   begin
      while Directory_Vectors.Has_Element (Iter) loop
         Process (Directory_Vectors.Element (Iter));
         Directory_Vectors.Next (Iter);
      end loop;
   end Each_Directory;

   --  ------------------------------
   --  Execute the Process procedure on each file found in the container.
   --  ------------------------------
   overriding
   procedure Each_File (Container : in Default_Container;
                        Process   : not null access
                          procedure (F : in File_Type)) is
      Iter : File_Vectors.Cursor := Container.Files.First;
   begin
      while File_Vectors.Has_Element (Iter) loop
         Process (File_Vectors.Element (Iter));
         File_Vectors.Next (Iter);
      end loop;
   end Each_File;

end Babel.Files;

--  bkp-files -- File and directories
-----------------------------------------------------------------------
--  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 Ada.Calendar.Conversions;
with Interfaces.C;

with Util.Log.Loggers;
with Util.Files;
with Util.Encoders.Base16;
package body Babel.Files is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Bkp.Files");

   Hex_Encoder : Util.Encoders.Base16.Encoder;

   --  ------------------------------
   --  Compare two files on their name and directory.
   --  ------------------------------
   function "<" (Left, Right : in File_Type) return Boolean is
      use type Ada.Strings.Unbounded.Unbounded_String;
   begin
      if Left = NO_FILE then
         return False;
      elsif Right = NO_FILE then
         return True;
      elsif Left.Dir = Right.Dir then
         return Left.Name < Right.Name;
      elsif Left.Dir = NO_DIRECTORY then
         return True;
      elsif Right.Dir = NO_DIRECTORY then
         return False;
      else
         return Left.Dir.Path < Right.Dir.Path;
      end if;
   end "<";

   --  ------------------------------
   --  Allocate a File_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type is
      use Ada.Strings.Unbounded;
      Result : constant File_Type := new File '(Len    => Name'Length,
                                                Id     => NO_IDENTIFIER,
                                                Dir    => Dir,
                                                Name   => Name,
                                                others => <>);
   begin
      return Result;
   end Allocate;

   --  ------------------------------
   --  Allocate a Directory_Type entry with the given name for the directory.
   --  ------------------------------
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type is
      use Ada.Strings.Unbounded;

      Result : constant Directory_Type := new Directory '(Len    => Name'Length,
                                                          Id     => NO_IDENTIFIER,
                                                          Parent => Dir,
                                                          Name   => Name,
                                                          others => <>);
   begin
      if Dir /= null then
         Result.Path := To_Unbounded_String
           (Util.Files.Compose (To_String (Dir.Path), Name));
      else
         Result.Path := To_Unbounded_String (Name);
      end if;
      return Result;
   end Allocate;

   --  ------------------------------
   --  Return true if the file was modified and need a backup.
   --  ------------------------------
   function Is_Modified (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      if Element.Id = NO_IDENTIFIER then
         return True;
      elsif (Element.Status and FILE_MODIFIED) /= 0 then
         return True;
      else
         return False;
      end if;
   end Is_Modified;

   --  ------------------------------
   --  Return true if the file is a new file.
   --  ------------------------------
   function Is_New (Element : in File_Type) return Boolean is
      use type ADO.Identifier;
   begin
      return Element.Id = NO_IDENTIFIER;
   end Is_New;

   --  ------------------------------
   --  Set the file as modified.
   --  ------------------------------
   procedure Set_Modified (Element : in File_Type) is
   begin
      Element.Status := Element.Status or FILE_MODIFIED;
   end Set_Modified;

   --  ------------------------------
   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   --  ------------------------------
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array) is
      use type Util.Encoders.SHA1.Hash_Array;
   begin
      if (Element.Status and FILE_HAS_SHA1) /= 0 and then Element.SHA1 /= Signature then
         Element.Status := Element.Status or FILE_MODIFIED;
      end if;
      Element.Status := Element.Status or FILE_HAS_SHA1;
      Element.SHA1   := Signature;
   end Set_Signature;

   --  ------------------------------
   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   --  ------------------------------
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size) is
   begin
      if Element.Size /= Size then
         Element.Size := Size;
         Element.Status := Element.Status or FILE_MODIFIED;
      end if;
   end Set_Size;

   --  ------------------------------
   --  Set the owner and group of the file.
   --  ------------------------------
   procedure Set_Owner (Element : in File_Type;
                        User    : in Uid_Type;
                        Group   : in Gid_Type) is
   begin
      Element.User  := User;
      Element.Group := Group;
   end Set_Owner;

   --  ------------------------------
   --  Set the file modification date.
   --  ------------------------------
   procedure Set_Date (Element : in File_Type;
                       Date    : in Util.Systems.Types.Timespec) is
   begin
      Element.Date := Ada.Calendar.Conversions.To_Ada_Time (Interfaces.C.long (Date.tv_sec));
   end Set_Date;

   --  ------------------------------
   --  Return the path for the file.
   --  ------------------------------
   function Get_Path (Element : in File_Type) return String is
   begin
      if Element.Dir = null then
         return Element.Name;
      else
         return Util.Files.Compose (Get_Path (Element.Dir), Element.Name);
      end if;
   end Get_Path;

   --  ------------------------------
   --  Return the path for the directory.
   --  ------------------------------
   function Get_Path (Element : in Directory_Type) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Element.Path);
   end Get_Path;

   --  ------------------------------
   --  Return the SHA1 signature computed for the file.
   --  ------------------------------
   function Get_SHA1 (Element : in File_Type) return String is
   begin
      return Hex_Encoder.Transform (Element.SHA1);
   end Get_SHA1;

   --  ------------------------------
   --  Return the file size.
   --  ------------------------------
   function Get_Size (Element : in File_Type) return File_Size is
   begin
      return Element.Size;
   end Get_Size;

   --  ------------------------------
   --  Return the file modification date.
   --  ------------------------------
   function Get_Date (Element : in File_Type) return Ada.Calendar.Time is
   begin
      return Element.Date;
   end Get_Date;

   --  ------------------------------
   --  Return the user uid.
   --  ------------------------------
   function Get_User (Element : in File_Type) return Uid_Type is
   begin
      return Element.User;
   end Get_User;

   --  ------------------------------
   --  Return the group gid.
   --  ------------------------------
   function Get_Group (Element : in File_Type) return Gid_Type is
   begin
      return Element.Group;
   end Get_Group;

   --  ------------------------------
   --  Return the file unix mode.
   --  ------------------------------
   function Get_Mode (Element : in File_Type) return File_Mode is
   begin
      return Element.Mode;
   end Get_Mode;

   --  ------------------------------
   --  Add the file with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_File (Into    : in out Default_Container;
                       Element : in File_Type) is
   begin
      Into.Files.Append (Element);
   end Add_File;

   --  ------------------------------
   --  Add the directory with the given name in the container.
   --  ------------------------------
   overriding
   procedure Add_Directory (Into    : in out Default_Container;
                            Element : in Directory_Type) is
   begin
      Into.Dirs.Append (Element);
   end Add_Directory;

   --  ------------------------------
   --  Create a new file instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return File_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Create a new directory instance with the given name in the container.
   --  ------------------------------
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return Directory_Type is
   begin
      return Allocate (Name => Name,
                       Dir  => Into.Current);
   end Create;

   --  ------------------------------
   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   --  ------------------------------
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return File_Type is
      pragma Unreferenced (From, Name);
   begin
      return NO_FILE;
   end Find;

   --  ------------------------------
   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   --  ------------------------------
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return Directory_Type is
      pragma Unreferenced (From, Name);
   begin
      return NO_DIRECTORY;
   end Find;

   --  ------------------------------
   --  Set the directory object associated with the container.
   --  ------------------------------
   procedure Set_Directory (Into      : in out Default_Container;
                            Directory : in Directory_Type) is
   begin
      Into.Current := Directory;
      Into.Files.Clear;
      Into.Dirs.Clear;
   end Set_Directory;

   --  ------------------------------
   --  Execute the Process procedure on each directory found in the container.
   --  ------------------------------
   overriding
   procedure Each_Directory (Container : in Default_Container;
                             Process   : not null access
                               procedure (Dir : in Directory_Type)) is
      Iter : Directory_Vectors.Cursor := Container.Dirs.First;
   begin
      while Directory_Vectors.Has_Element (Iter) loop
         Process (Directory_Vectors.Element (Iter));
         Directory_Vectors.Next (Iter);
      end loop;
   end Each_Directory;

   --  ------------------------------
   --  Execute the Process procedure on each file found in the container.
   --  ------------------------------
   overriding
   procedure Each_File (Container : in Default_Container;
                        Process   : not null access
                          procedure (F : in File_Type)) is
      Iter : File_Vectors.Cursor := Container.Files.First;
   begin
      while File_Vectors.Has_Element (Iter) loop
         Process (File_Vectors.Element (Iter));
         File_Vectors.Next (Iter);
      end loop;
   end Each_File;

end Babel.Files;

Implement the Set_Date operation

Implement the Set_Date operation


-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Ada.Strings.Unbounded;

with Bfd.Symbols;
with Bfd.Files;

with Util.Refs;

with MAT.Types;
package MAT.Symbols.Targets is

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

end MAT.Symbols.Targets;

-----------------------------------------------------------------------
--  mat-symbols-targets - Symbol files management
--  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 Ada.Strings.Unbounded;

with Bfd.Symbols;
with Bfd.Files;

with Util.Refs;

with MAT.Types;
package MAT.Symbols.Targets is

   type Target_Symbols is new Util.Refs.Ref_Entity with record
      File    : Bfd.Files.File_Type;
      Symbols : Bfd.Symbols.Symbol_Table;
   end record;
   type Target_Symbols_Access is access all Target_Symbols;

   --  Open the binary and load the symbols from that file.
   procedure Open (Symbols : in out Target_Symbols;
                   Path    : in String);

   --  Find the nearest source file and line for the given address.
   procedure Find_Nearest_Line (Symbols : in Target_Symbols;
                                Addr    : in MAT.Types.Target_Addr;
                                Name    : out Ada.Strings.Unbounded.Unbounded_String;
                                Func    : out Ada.Strings.Unbounded.Unbounded_String;
                                Line    : out Natural);

   package Target_Symbols_Refs is
     new Util.Refs.References (Target_Symbols, Target_Symbols_Access);

   subtype Target_Symbols_Ref is Target_Symbols_Refs.Ref;

end MAT.Symbols.Targets;

Declare Target_Symbols_Ref subtype

Declare Target_Symbols_Ref subtype


-----------------------------------------------------------------------
--  util-system-os -- Windows system operations
--  Copyright (C) 2011, 2012, 2015, 2018, 2019, 2021, 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.Unchecked_Deallocation;
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;
with Util.Systems.Constants;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   type Process_Identifier is new Integer;

   function Get_Last_Error return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   function Errno return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD
     with Import => True, Convention => Stdcall, Link_Name => "WaitForSingleObject";

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Interfaces.C.int := 0;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := 16#fffffff6#;
   STD_OUTPUT_HANDLE : constant DWORD := 16#fffffff5#;
   STD_ERROR_HANDLE  : constant DWORD := 16#fffffff4#;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   function Get_Std_Handle (Kind : in DWORD) return File_Type
     with Import => True, Convention => Stdcall, Link_Name => "GetStdHandle";

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function STDOUT_FILENO return File_Type
     is (Get_Std_Handle (STD_OUTPUT_HANDLE));

   function STDERR_FILENO return File_Type
     is (Get_Std_Handle (STD_ERROR_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CloseHandle";

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "DuplicateHandle";

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL
   with Import => True, Convention => Stdcall, Link_Name => "ReadFile";

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "WriteFile";

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CreatePipe";

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type FileTime is record
      dwLowDateTime  : DWORD;
      dwHighDateTime : DWORD;
   end record;
   type LPFILETIME is access all FileTime;

   function To_Time (Time : in FileTime) return Util.Systems.Types.Time_Type;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "GetCurrentProcess";

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetExitCodeProcess";

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handles    : in BOOL;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access)
                            return Integer
     with Import => True, Convention => Stdcall, Link_Name => "CreateProcessW";

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "TerminateProcess";

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_stat64";

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;

   function Sys_Lstat (Path : in String;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_lstat64";

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t;

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "CreateFileW";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type;

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer;

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer;

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_chmod";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => Stdcall, Link_Name => "strerror";

   function Sys_GetHandleInformation (Fd : in HANDLE; Flags : access DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetHandleInformation";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   function To_WSTR (Value : in String) return Wchar_Ptr;

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Interfaces.C.wchar_array,
                                      Name   => Wchar_Ptr);

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in String;
                        Newpath  : in String) return Integer
     with Import => True, Convention => C, Link_Name => "rename";

   function Sys_Unlink (Path  : in String) return Integer
     with Import => True, Convention => C, Link_Name => "unlink";

   type DIR is new System.Address;

   Null_Dir : constant DIR := DIR (System.Null_Address);

   --  Equivalent to Posix opendir (3) but handles some portability issues.
   --  We could use opendir, readdir_r and closedir but the __gnat_* alternative
   --  solves
   function Opendir (Directory : in String) return DIR
      with Import, External_Name => "__gnat_opendir", Convention => C;

   function Readdir (Directory : in DIR;
                     Buffer    : in System.Address;
                     Last      : not null access Integer) return System.Address
      with Import, External_Name => "__gnat_readdir", Convention => C;

   function Closedir (Directory : in DIR) return Integer
      with Import, External_Name => "__gnat_closedir", Convention => C;

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

-----------------------------------------------------------------------
--  util-system-os -- Windows system operations
--  Copyright (C) 2011, 2012, 2015, 2018, 2019, 2021, 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.Unchecked_Deallocation;
with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Systems.Types;
with Util.Systems.Constants;

--  The <b>Util.Systems.Os</b> package defines various types and operations which are specific
--  to the OS (Windows).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '\';

   --  The path separator.
   Path_Separator      : constant Character := ';';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.CR & ASCII.LF;

   --  Defines several windows specific types.
   type BOOL is mod 8;

   type WORD is new Interfaces.C.short;

   type DWORD is new Interfaces.C.unsigned_long;

   type PDWORD is access all DWORD;
   for PDWORD'Size use Standard'Address_Size;

   type Process_Identifier is new Integer;

   function Get_Last_Error return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   function Errno return Integer
     with Import => True, Convention => Stdcall, Link_Name => "GetLastError";

   --  Some useful error codes (See Windows document "System Error Codes (0-499)").
   ERROR_BROKEN_PIPE : constant Integer := 109;

   --  ------------------------------
   --  Handle
   --  ------------------------------

   --  The windows HANDLE is defined as a void* in the C API.
   subtype HANDLE is Util.Systems.Types.HANDLE;

   use type Util.Systems.Types.HANDLE;

   INVALID_HANDLE_VALUE : constant HANDLE := -1;

   type PHANDLE is access all HANDLE;
   for PHANDLE'Size use Standard'Address_Size;

   function Wait_For_Single_Object (H : in HANDLE;
                                    Time : in DWORD) return DWORD
     with Import => True, Convention => Stdcall, Link_Name => "WaitForSingleObject";

   type Security_Attributes is record
      Length              : DWORD;
      Security_Descriptor : System.Address;
      Inherit             : Interfaces.C.int := 0;
   end record;
   type LPSECURITY_ATTRIBUTES is access all Security_Attributes;
   for LPSECURITY_ATTRIBUTES'Size use Standard'Address_Size;

   --  ------------------------------
   --  File operations
   --  ------------------------------
   subtype File_Type is Util.Systems.Types.File_Type;

   NO_FILE : constant File_Type := 0;

   STD_INPUT_HANDLE  : constant DWORD := 16#fffffff6#;
   STD_OUTPUT_HANDLE : constant DWORD := 16#fffffff5#;
   STD_ERROR_HANDLE  : constant DWORD := 16#fffffff4#;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   function Get_Std_Handle (Kind : in DWORD) return File_Type
     with Import => True, Convention => Stdcall, Link_Name => "GetStdHandle";

   function STDIN_FILENO return File_Type
     is (Get_Std_Handle (STD_INPUT_HANDLE));

   function STDOUT_FILENO return File_Type
     is (Get_Std_Handle (STD_OUTPUT_HANDLE));

   function STDERR_FILENO return File_Type
     is (Get_Std_Handle (STD_ERROR_HANDLE));

   function Close_Handle (Fd : in File_Type) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CloseHandle";

   function Duplicate_Handle (SourceProcessHandle : in HANDLE;
                              SourceHandle        : in HANDLE;
                              TargetProcessHandle : in HANDLE;
                              TargetHandle        : in PHANDLE;
                              DesiredAccess       : in DWORD;
                              InheritHandle       : in BOOL;
                              Options             : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "DuplicateHandle";

   function Read_File (Fd      : in File_Type;
                       Buf     : in System.Address;
                       Size    : in DWORD;
                       Result  : in PDWORD;
                       Overlap : in System.Address) return BOOL
   with Import => True, Convention => Stdcall, Link_Name => "ReadFile";

   function Write_File (Fd      : in File_Type;
                        Buf     : in System.Address;
                        Size    : in DWORD;
                        Result  : in PDWORD;
                        Overlap : in System.Address) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "WriteFile";

   function Create_Pipe (Read_Handle :  in PHANDLE;
                         Write_Handle : in PHANDLE;
                         Attributes   : in LPSECURITY_ATTRIBUTES;
                         Buf_Size     : in DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "CreatePipe";

   subtype LPWSTR is Interfaces.C.Strings.chars_ptr;
   subtype LPCSTR is Interfaces.C.Strings.chars_ptr;
   subtype PBYTE is Interfaces.C.Strings.chars_ptr;
   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype LPCTSTR is System.Address;
   subtype LPTSTR is System.Address;
   type CommandPtr is access all Interfaces.C.wchar_array;

   NULL_STR : constant LPWSTR := Interfaces.C.Strings.Null_Ptr;

   type FileTime is record
      dwLowDateTime  : DWORD;
      dwHighDateTime : DWORD;
   end record;
   type LPFILETIME is access all FileTime;

   function To_Time (Time : in FileTime) return Util.Systems.Types.Time_Type;

   type Startup_Info is record
      cb              : DWORD := 0;
      lpReserved      : LPWSTR := NULL_STR;
      lpDesktop       : LPWSTR := NULL_STR;
      lpTitle         : LPWSTR := NULL_STR;
      dwX             : DWORD := 0;
      dwY             : DWORD := 0;
      dwXsize         : DWORD := 0;
      dwYsize         : DWORD := 0;
      dwXCountChars   : DWORD := 0;
      dwYCountChars   : DWORD := 0;
      dwFillAttribute : DWORD := 0;
      dwFlags         : DWORD := 0;
      wShowWindow     : WORD := 0;
      cbReserved2     : WORD := 0;
      lpReserved2     : PBYTE := Interfaces.C.Strings.Null_Ptr;
      hStdInput       : HANDLE := 0;
      hStdOutput      : HANDLE := 0;
      hStdError       : HANDLE := 0;
   end record;
   type Startup_Info_Access is access all Startup_Info;

   type PROCESS_INFORMATION is record
      hProcess    : HANDLE := NO_FILE;
      hThread     : HANDLE := NO_FILE;
      dwProcessId : DWORD;
      dwThreadId  : DWORD;
   end record;
   type Process_Information_Access is access all PROCESS_INFORMATION;

   function Get_Current_Process return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "GetCurrentProcess";

   function Get_Exit_Code_Process (Proc : in HANDLE;
                                   Code : in PDWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetExitCodeProcess";

   function Create_Process (Name               : in LPCTSTR;
                            Command            : in System.Address;
                            Process_Attributes : in LPSECURITY_ATTRIBUTES;
                            Thread_Attributes  : in LPSECURITY_ATTRIBUTES;
                            Inherit_Handles    : in BOOL;
                            Creation_Flags     : in DWORD;
                            Environment        : in LPTSTR;
                            Directory          : in LPCTSTR;
                            Startup_Info       : in Startup_Info_Access;
                            Process_Info       : in Process_Information_Access)
                            return Integer
     with Import => True, Convention => Stdcall, Link_Name => "CreateProcessW";

   --  Terminate the windows process and all its threads.
   function Terminate_Process (Proc : in HANDLE;
                               Code : in DWORD) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "TerminateProcess";

   function Sys_Stat (Path : in LPWSTR;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_stat64";

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;

   function Sys_Lstat (Path : in String;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_stat64";

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t;

   FILE_SHARE_WRITE         : constant DWORD := 16#02#;
   FILE_SHARE_READ          : constant DWORD := 16#01#;

   GENERIC_READ             : constant DWORD := 16#80000000#;
   GENERIC_WRITE            : constant DWORD := 16#40000000#;

   CREATE_NEW               : constant DWORD := 1;
   CREATE_ALWAYS            : constant DWORD := 2;
   OPEN_EXISTING            : constant DWORD := 3;
   OPEN_ALWAYS              : constant DWORD := 4;
   TRUNCATE_EXISTING        : constant DWORD := 5;

   FILE_APPEND_DATA         : constant DWORD := 4;

   FILE_ATTRIBUTE_ARCHIVE   : constant DWORD := 16#20#;
   FILE_ATTRIBUTE_HIDDEN    : constant DWORD := 16#02#;
   FILE_ATTRIBUTE_NORMAL    : constant DWORD := 16#80#;
   FILE_ATTRIBUTE_READONLY  : constant DWORD := 16#01#;
   FILE_ATTRIBUTE_TEMPORARY : constant DWORD := 16#100#;

   function Create_File (Name           : in LPCTSTR;
                         Desired_Access : in DWORD;
                         Share_Mode     : in DWORD;
                         Attributes     : in LPSECURITY_ATTRIBUTES;
                         Creation       : in DWORD;
                         Flags          : in DWORD;
                         Template_File  : HANDLE) return HANDLE
     with Import => True, Convention => Stdcall, Link_Name => "CreateFileW";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type;

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer;

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer;

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => Stdcall, Link_Name => "_chmod";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => Stdcall, Link_Name => "strerror";

   function Sys_GetHandleInformation (Fd : in HANDLE; Flags : access DWORD) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetHandleInformation";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   function To_WSTR (Value : in String) return Wchar_Ptr;

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Interfaces.C.wchar_array,
                                      Name   => Wchar_Ptr);

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in String;
                        Newpath  : in String) return Integer
     with Import => True, Convention => C, Link_Name => "rename";

   function Sys_Unlink (Path  : in String) return Integer
     with Import => True, Convention => C, Link_Name => "unlink";

   type DIR is new System.Address;

   Null_Dir : constant DIR := DIR (System.Null_Address);

   --  Equivalent to Posix opendir (3) but handles some portability issues.
   --  We could use opendir, readdir_r and closedir but the __gnat_* alternative
   --  solves
   function Opendir (Directory : in String) return DIR
      with Import, External_Name => "__gnat_opendir", Convention => C;

   function Readdir (Directory : in DIR;
                     Buffer    : in System.Address;
                     Last      : not null access Integer) return System.Address
      with Import, External_Name => "__gnat_readdir", Convention => C;

   function Closedir (Directory : in DIR) return Integer
      with Import, External_Name => "__gnat_closedir", Convention => C;

private

   --  kernel32 is used on Windows32 as well as Windows64.
   pragma Linker_Options ("-lkernel32");

end Util.Systems.Os;

Fix for Windows

Fix for Windows


-----------------------------------------------------------------------
--  asf-views-facelets -- Facelets representation and management
--  Copyright (C) 2009, 2010, 2011, 2014, 2015, 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.Exceptions;
with Ada.Directories;
with Ada.Unchecked_Deallocation;
with ASF.Views.Nodes.Reader;
with Input_Sources.File;
with Sax.Readers;
with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;
package body ASF.Views.Facelets is

   use ASF.Views.Nodes;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Views.Facelets");

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => ASF.Views.File_Info,
                                      Name   => ASF.Views.File_Info_Access);

   --  Find in the factory for the facelet with the given name.
   procedure Find (Factory : in out Facelet_Factory;
                   Name    : in Unbounded_String;
                   Result  : out Facelet);

   --  Load the facelet node tree by reading the facelet XHTML file.
   procedure Load (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                   Result  : out Facelet);

   --  Update the factory to store the facelet node tree
   procedure Update (Factory : in out Facelet_Factory;
                     Name    : in Unbounded_String;
                     Item    : in Facelet);

   --  ------------------------------
   --  Returns True if the facelet is null/empty.
   --  ------------------------------
   function Is_Null (F : Facelet) return Boolean is
   begin
      return F.Root = null;
   end Is_Null;

   --  ------------------------------
   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   --  ------------------------------
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet) is
      Res   : Facelet;
      Fname : constant Unbounded_String := To_Unbounded_String (Name);
   begin
      Log.Debug ("Find facelet {0}", Name);

      Find (Factory, Fname, Res);
      if Res.Root = null then
         Load (Factory, Name, Context, Res);
         if Res.Root = null then
            Result.Root := null;
            return;
         end if;
         Update (Factory, Fname, Res);
      end if;
      Result.Root := Res.Root;
      Result.File := Res.File;
   end Find_Facelet;

   --  ------------------------------
   --  Create the component tree from the facelet view.
   --  ------------------------------
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.Base.UIComponent_Access) is
      Old : Unbounded_String;
   begin
      if View.Root /= null then
         Context.Set_Relative_Path (Path     => ASF.Views.Relative_Path (View.File.all),
                                    Previous => Old);
         View.Root.Build_Children (Parent => Root, Context => Context);
         Context.Set_Relative_Path (Path => Old);
      end if;
   end Build_View;

   --  ------------------------------
   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   --  ------------------------------
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Components          : access ASF.Factory.Component_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean) is
   begin
      Log.Info ("Set facelet search directory to: '{0}'", Paths);

      Factory.Factory := Components;
      Factory.Paths := To_Unbounded_String (Paths);
      Factory.Ignore_White_Spaces := Ignore_White_Spaces;
      Factory.Ignore_Empty_Lines  := Ignore_Empty_Lines;
      Factory.Escape_Unknown_Tags := Escape_Unknown_Tags;
   end Initialize;

   --  ------------------------------
   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   --  ------------------------------
   function Find_Facelet_Path (Factory : Facelet_Factory;
                               Name    : String) return String is
   begin
      return Util.Files.Find_File_Path (Name, To_String (Factory.Paths));
   end Find_Facelet_Path;

   --  ------------------------------
   --  Find in the factory for the facelet with the given name.
   --  ------------------------------
   procedure Find (Factory : in out Facelet_Factory;
                   Name    : in Unbounded_String;
                   Result  : out Facelet) is
      use Ada.Directories;
      use Ada.Calendar;
   begin
      Result.Root := null;
      Result := Factory.Map.Find (Name);
      if Result.Root /= null and then
        Modification_Time (Result.File.Path) > Result.Modify_Time
      then
            Result.Root := null;
            Log.Info ("Ignoring cache because file '{0}' was modified",
                      Result.File.Path);
      end if;
   end Find;

   --  ------------------------------
   --  Load the facelet node tree by reading the facelet XHTML file.
   --  ------------------------------
   procedure Load (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                   Result  : out Facelet) is
      Path   : constant String := Find_Facelet_Path (Factory, Name);
   begin
      if Path = "" or else not Ada.Directories.Exists (Path) then
         Log.Warn ("Cannot read '{0}': file does not exist", Path);
         Result.Root := null;
         return;
      end if;

      declare
         Pos    : constant Integer := Path'Last - Name'Length + 1;
         File   : File_Info_Access;
         Reader : ASF.Views.Nodes.Reader.Xhtml_Reader;
         Read   : Input_Sources.File.File_Input;
         Mtime  : Ada.Calendar.Time;
         Ctx    : aliased EL.Contexts.Default.Default_Context;
      begin
         if Pos <= Path'First then
            File := Create_File_Info (Path, Path'First);
         else
            File := Create_File_Info (Path, Pos);
         end if;
         Log.Info ("Loading facelet: '{0}' - {1} - {2}", Path, Name,
                   Natural'Image (File.Relative_Pos));

         Ctx.Set_Function_Mapper (Context.Get_Function_Mapper);
         Mtime  := Ada.Directories.Modification_Time (Path);
         Input_Sources.File.Open (Path, Read);

         --  If True, xmlns:* attributes will be reported in Start_Element
         Reader.Set_Feature (Sax.Readers.Namespace_Prefixes_Feature, False);
         Reader.Set_Feature (Sax.Readers.Validation_Feature, False);

         Reader.Set_Ignore_White_Spaces (Factory.Ignore_White_Spaces);
         Reader.Set_Escape_Unknown_Tags (Factory.Escape_Unknown_Tags);
         Reader.Set_Ignore_Empty_Lines (Factory.Ignore_Empty_Lines);
         begin
            Reader.Parse (File, Read, Factory.Factory, Ctx'Unchecked_Access);

         exception
            when ASF.Views.Nodes.Reader.Parsing_Error =>
               Free (File);

            when E : others =>
               Free (File);
               Log.Error ("Unexpected exception while reading: '{0}': {1}: {2}", Path,
                          Ada.Exceptions.Exception_Name (E), Ada.Exceptions.Exception_Message (E));
         end;
         Result.Root := Reader.Get_Root;
         Result.File := File;
         if File = null then
            if Result.Root /= null then
               Result.Root.Delete;
            end if;
            Result.Root := null;
         else
            Result.Modify_Time := Mtime;
         end if;
         Input_Sources.File.Close (Read);
      end;
   end Load;

   --  ------------------------------
   --  Update the factory to store the facelet node tree
   --  ------------------------------
   procedure Update (Factory : in out Facelet_Factory;
                     Name    : in Unbounded_String;
                     Item    : in Facelet) is
   begin
      Factory.Map.Insert (Name, Item);
   end Update;

   --  ------------------------------
   --  Clear the facelet cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Facelet_Factory) is
   begin
      Log.Info ("Clearing facelet cache");

      Factory.Map.Clear;
   end Clear_Cache;

   protected body Facelet_Cache is

      --  ------------------------------
      --  Find the facelet entry associated with the given name.
      --  ------------------------------
      function Find (Name : in Unbounded_String) return Facelet is
         Pos    : constant Facelet_Maps.Cursor := Map.Find (Name);
      begin
         if Facelet_Maps.Has_Element (Pos) then
            return Element (Pos);
         else
            return Empty;
         end if;
      end Find;

      --  ------------------------------
      --  Insert or replace the facelet entry associated with the given name.
      --  ------------------------------
      procedure Insert (Name : in Unbounded_String;
                        Item : in Facelet) is
      begin
         Map.Include (Name, Item);
      end Insert;

      --  ------------------------------
      --  Clear the cache.
      --  ------------------------------
      procedure Clear is
      begin
         loop
            declare
               Pos  : Facelet_Maps.Cursor := Map.First;
               Node : Facelet;
            begin
               exit when not Has_Element (Pos);
               Node := Element (Pos);
               Map.Delete (Pos);
               Free (Node.File);
               ASF.Views.Nodes.Destroy (Node.Root);
            end;
         end loop;
      end Clear;

   end Facelet_Cache;

   --  ------------------------------
   --  Free the storage held by the factory cache.
   --  ------------------------------
   overriding
   procedure Finalize (Factory : in out Facelet_Factory) is
   begin
      Factory.Clear_Cache;
   end Finalize;

end ASF.Views.Facelets;

-----------------------------------------------------------------------
--  asf-views-facelets -- Facelets representation and management
--  Copyright (C) 2009, 2010, 2011, 2014, 2015, 2017, 2019 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.Exceptions;
with Ada.Directories;
with Ada.Unchecked_Deallocation;
with ASF.Views.Nodes.Reader;
with Input_Sources.File;
with Sax.Readers;
with EL.Contexts.Default;
with Util.Files;
with Util.Log.Loggers;
package body ASF.Views.Facelets is

   use ASF.Views.Nodes;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Views.Facelets");

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => ASF.Views.File_Info,
                                      Name   => ASF.Views.File_Info_Access);

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Facelet_Type,
                                      Name   => Facelet_Access);

   --  Find in the factory for the facelet with the given name.
   procedure Find (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Result  : out Facelet);

   --  Load the facelet node tree by reading the facelet XHTML file.
   procedure Load (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                   Result  : out Facelet);

   --  Update the factory to store the facelet node tree
   procedure Update (Factory : in out Facelet_Factory;
                     Facelet : in Facelet_Access);

   --  ------------------------------
   --  Returns True if the facelet is null/empty.
   --  ------------------------------
   function Is_Null (F : Facelet) return Boolean is
   begin
      return F.Facelet = null;
   end Is_Null;

   --  ------------------------------
   --  Get the facelet identified by the given name.  If the facelet is already
   --  loaded, the cached value is returned.  The facelet file is searched in
   --  a set of directories configured in the facelet factory.
   --  ------------------------------
   procedure Find_Facelet (Factory : in out Facelet_Factory;
                           Name    : in String;
                           Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                           Result  : out Facelet) is
   begin
      Log.Debug ("Find facelet {0}", Name);

      Find (Factory, Name, Result);
      if Result.Facelet = null then
         Load (Factory, Name, Context, Result);
         if Result.Facelet = null then
            return;
         end if;
         Update (Factory, Result.Facelet);
      end if;
   end Find_Facelet;

   --  ------------------------------
   --  Create the component tree from the facelet view.
   --  ------------------------------
   procedure Build_View (View    : in Facelet;
                         Context : in out ASF.Contexts.Facelets.Facelet_Context'Class;
                         Root    : in ASF.Components.Base.UIComponent_Access) is
      Old : Unbounded_String;
   begin
      if View.Facelet /= null then
         Context.Set_Relative_Path (Path     => ASF.Views.Relative_Path (View.Facelet.File.all),
                                    Previous => Old);
         View.Facelet.Root.Build_Children (Parent => Root, Context => Context);
         Context.Set_Relative_Path (Path => Old);
      end if;
   end Build_View;

   --  ------------------------------
   --  Initialize the facelet factory.
   --  Set the search directories for facelet files.
   --  Set the ignore white space configuration when reading XHTML files.
   --  Set the ignore empty lines configuration when reading XHTML files.
   --  Set the escape unknown tags configuration when reading XHTML files.
   --  ------------------------------
   procedure Initialize (Factory             : in out Facelet_Factory;
                         Components          : access ASF.Factory.Component_Factory;
                         Paths               : in String;
                         Ignore_White_Spaces : in Boolean;
                         Ignore_Empty_Lines  : in Boolean;
                         Escape_Unknown_Tags : in Boolean) is
   begin
      Log.Info ("Set facelet search directory to: '{0}'", Paths);

      Factory.Factory := Components;
      Factory.Paths := To_Unbounded_String (Paths);
      Factory.Ignore_White_Spaces := Ignore_White_Spaces;
      Factory.Ignore_Empty_Lines  := Ignore_Empty_Lines;
      Factory.Escape_Unknown_Tags := Escape_Unknown_Tags;
   end Initialize;

   --  ------------------------------
   --  Find the facelet file in one of the facelet directories.
   --  Returns the path to be used for reading the facelet file.
   --  ------------------------------
   function Find_Facelet_Path (Factory : Facelet_Factory;
                               Name    : String) return String is
   begin
      return Util.Files.Find_File_Path (Name, To_String (Factory.Paths));
   end Find_Facelet_Path;

   --  ------------------------------
   --  Find in the factory for the facelet with the given name.
   --  ------------------------------
   procedure Find (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Result  : out Facelet) is
      use Ada.Directories;
      use Ada.Calendar;
   begin
      Result.Facelet := Factory.Map.Find (Name);
      if Result.Facelet /= null then
         declare
            Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         begin
            if Result.Facelet.Check_Time < Now then
               if Modification_Time (Result.Facelet.File.Path) > Result.Facelet.Modify_Time then
                  Result.Facelet := null;
                  Log.Info ("Ignoring cache because file '{0}' was modified",
                            Result.Facelet.File.Path);
               else
                  Result.Facelet.Check_Time := Now + CHECK_FILE_DELAY;
               end if;
            end if;
         end;
      end if;
   end Find;

   --  ------------------------------
   --  Load the facelet node tree by reading the facelet XHTML file.
   --  ------------------------------
   procedure Load (Factory : in out Facelet_Factory;
                   Name    : in String;
                   Context : in ASF.Contexts.Facelets.Facelet_Context'Class;
                   Result  : out Facelet) is
      Path   : constant String := Find_Facelet_Path (Factory, Name);
   begin
      if Path = "" or else not Ada.Directories.Exists (Path) then
         Log.Warn ("Cannot read '{0}': file does not exist", Path);
         Result.Facelet := null;
         return;
      end if;

      declare
         use type Ada.Calendar.Time;
         Pos    : constant Integer := Path'Last - Name'Length + 1;
         Now    : constant Ada.Calendar.Time := Ada.Calendar.Clock + CHECK_FILE_DELAY;
         File   : File_Info_Access;
         Reader : ASF.Views.Nodes.Reader.Xhtml_Reader;
         Read   : Input_Sources.File.File_Input;
         Mtime  : Ada.Calendar.Time;
         Ctx    : aliased EL.Contexts.Default.Default_Context;
         Root   : ASF.Views.Nodes.Tag_Node_Access;
      begin
         if Pos <= Path'First then
            File := Create_File_Info (Path, Path'First);
         else
            File := Create_File_Info (Path, Pos);
         end if;
         Log.Info ("Loading facelet: '{0}' - {1} - {2}", Path, Name,
                   Natural'Image (File.Relative_Pos));

         Ctx.Set_Function_Mapper (Context.Get_Function_Mapper);
         Mtime  := Ada.Directories.Modification_Time (Path);
         Input_Sources.File.Open (Path, Read);

         --  If True, xmlns:* attributes will be reported in Start_Element
         Reader.Set_Feature (Sax.Readers.Namespace_Prefixes_Feature, False);
         Reader.Set_Feature (Sax.Readers.Validation_Feature, False);

         Reader.Set_Ignore_White_Spaces (Factory.Ignore_White_Spaces);
         Reader.Set_Escape_Unknown_Tags (Factory.Escape_Unknown_Tags);
         Reader.Set_Ignore_Empty_Lines (Factory.Ignore_Empty_Lines);
         begin
            Reader.Parse (File, Read, Factory.Factory, Ctx'Unchecked_Access);

         exception
            when ASF.Views.Nodes.Reader.Parsing_Error =>
               Free (File);

            when E : others =>
               Free (File);
               Log.Error ("Unexpected exception while reading: '{0}': {1}: {2}", Path,
                          Ada.Exceptions.Exception_Name (E), Ada.Exceptions.Exception_Message (E));
         end;
         Root := Reader.Get_Root;

         if File = null then
            if Root /= null then
               Root.Delete;
            end if;
            Result.Facelet := null;
         else
            Result.Facelet := new Facelet_Type '(Util.Refs.Ref_Entity with
                                                 Len         => Name'Length,
                                                 Root        => Root,
                                                 File        => File,
                                                 Modify_Time => Mtime,
                                                 Check_Time  => Now,
                                                 Name        => Name);
         end if;
         Input_Sources.File.Close (Read);
      end;
   end Load;

   --  ------------------------------
   --  Update the factory to store the facelet node tree
   --  ------------------------------
   procedure Update (Factory : in out Facelet_Factory;
                     Facelet : in Facelet_Access) is
   begin
      Factory.Map.Insert (Facelet);
   end Update;

   --  ------------------------------
   --  Clear the facelet cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Facelet_Factory) is
   begin
      Log.Info ("Clearing facelet cache");

      Factory.Map.Clear;
   end Clear_Cache;

   protected body Facelet_Cache is

      --  ------------------------------
      --  Find the facelet entry associated with the given name.
      --  ------------------------------
      function Find (Name : in String) return Facelet_Access is
         Key    : aliased Facelet_Type := Facelet_Type '(Util.Refs.Ref_Entity with
                                                         Len    => Name'Length,
                                                         Name   => Name,
                                                         others => <>);
         Pos    : constant Facelet_Sets.Cursor := Map.Find (Key'Unchecked_Access);
      begin
         if Facelet_Sets.Has_Element (Pos) then
            return Element (Pos);
         else
            return null;
         end if;
      end Find;

      --  ------------------------------
      --  Insert or replace the facelet entry associated with the given name.
      --  ------------------------------
      procedure Insert (Facelet : in Facelet_Access) is
      begin
         Map.Include (Facelet);
      end Insert;

      --  ------------------------------
      --  Clear the cache.
      --  ------------------------------
      procedure Clear is
      begin
         loop
            declare
               Pos  : Facelet_Sets.Cursor := Map.First;
               Node : Facelet_Access;
            begin
               exit when not Has_Element (Pos);
               Node := Element (Pos);
               Map.Delete (Pos);
               Free (Node.File);
               ASF.Views.Nodes.Destroy (Node.Root);
               Free (Node);
            end;
         end loop;
      end Clear;

   end Facelet_Cache;

   --  ------------------------------
   --  Free the storage held by the factory cache.
   --  ------------------------------
   overriding
   procedure Finalize (Factory : in out Facelet_Factory) is
   begin
      Factory.Clear_Cache;
   end Finalize;

end ASF.Views.Facelets;

Refactor Facelet_Type to avoir checking the file date change each time the facelet is fetch - store the facelet name within the record - update Check_Time and use it to avoid checking the file modification time if the Check_Time was not been reached yet


-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  Copyright (C) 2011, 2013 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.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number;
      Month       : Ada.Calendar.Month_Number;
      Month_Day   : Ada.Calendar.Day_Number;
      Day         : Ada.Calendar.Formatting.Day_Name;
      Hour        : Ada.Calendar.Formatting.Hour_Number;
      Minute      : Ada.Calendar.Formatting.Minute_Number;
      Second      : Ada.Calendar.Formatting.Second_Number;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset;
      Leap_Second : Boolean;
   end record;

   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0);

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the week at 00:00:00.
   function Get_Week_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the month at 00:00:00.
   function Get_Month_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  Copyright (C) 2011, 2013 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.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;

--  = Date Utilities =
--  The `Util.Dates` package provides various date utilities to help in formatting and parsing
--  dates in various standard formats.  It completes the standard `Ada.Calendar.Formatting` and
--  other packages by implementing specific formatting and parsing.
--
--  == Date Operations ==
--  Several operations allow to compute:
--
--    * The start of the day (0:00),
--    * The end of the day (24:00),
--    * The start of the week,
--    * The end of the week,
--    * The start of the month,
--    * The end of the month
--
--  @include util-dates-rfc7231.ads
--  @include util-dates-iso8601.ads
--  @include util-dates-formats.ads
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number;
      Month       : Ada.Calendar.Month_Number;
      Month_Day   : Ada.Calendar.Day_Number;
      Day         : Ada.Calendar.Formatting.Day_Name;
      Hour        : Ada.Calendar.Formatting.Hour_Number;
      Minute      : Ada.Calendar.Formatting.Minute_Number;
      Second      : Ada.Calendar.Formatting.Second_Number;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset;
      Leap_Second : Boolean;
   end record;

   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0);

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the week at 00:00:00.
   function Get_Week_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the beginning of the month at 00:00:00.
   function Get_Month_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

Add and update the documentation

Add and update the documentation