-----------------------------------------------------------------------
--  upnp-ssdp -- UPnP SSDP operations
--  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;
with Ada.Strings.Unbounded;
with Ada.Calendar;
with System;
with Interfaces.C.Strings;
with Util.Log.Loggers;

package body UPnP.SSDP is
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("UPnP.SSDP");

   Group : constant String := "239.255.255.250";

   type Sockaddr is record
      Sa_Family : Interfaces.C.unsigned_short;
      Sa_Port   : Interfaces.C.unsigned_short;
      Sa_Addr   : aliased Interfaces.C.char_array (1 .. 8);
   end record;
   pragma Convention (C, Sockaddr);

   type If_Address;
   type If_Address_Access is access all If_Address;
   type If_Address is record
      Ifa_Next  : If_Address_Access;
      Ifa_Name  : Interfaces.C.Strings.chars_ptr;
      Ifa_Flags : Interfaces.C.unsigned;
      Ifa_Addr  : access Sockaddr;
   end record;
   pragma Convention (C, If_Address);

   function Sys_getifaddrs (ifap : access If_Address_Access) return Interfaces.C.int;
   pragma Import (C, Sys_getifaddrs, "getifaddrs");

   procedure Sys_freeifaddrs (ifap : If_Address_Access);
   pragma Import (C, Sys_freeifaddrs, "freeifaddrs");

   function Sys_Inet_Ntop (Af : in Interfaces.C.unsigned_short;
                           Addr : System.Address;
                           Dst  : in Interfaces.C.Strings.chars_ptr;
                           Size : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Inet_Ntop, "inet_ntop");

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type);
   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String);

   --  ------------------------------
   --  Initialize the SSDP scanner by opening the UDP socket.
   --  ------------------------------
   procedure Initialize (Scanner : in out Scanner_Type) is
      Address      : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Log.Info ("Discovering gateways on the network");

      Address.Addr := GNAT.Sockets.Any_Inet_Addr;
      GNAT.Sockets.Create_Socket (Scanner.Socket, GNAT.Sockets.Family_Inet,
                                  GNAT.Sockets.Socket_Datagram);
      GNAT.Sockets.Bind_Socket (Scanner.Socket, Address);
      GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                      (GNAT.Sockets.Add_Membership, GNAT.Sockets.Inet_Addr (Group),
                                       GNAT.Sockets.Any_Inet_Addr));
   end Initialize;

   --  ------------------------------
   --  Find the IPv4 addresses of the network interfaces.
   --  ------------------------------
   procedure Find_IPv4_Addresses (Scanner : in out Scanner_Type;
                                  IPs     : out Util.Strings.Sets.Set) is
      pragma Unreferenced (Scanner);
      use type Interfaces.C.int;
      use type Interfaces.C.Strings.chars_ptr;

      Iflist   : aliased If_Address_Access;
      Ifp      : If_Address_Access;
      R        : Interfaces.C.Strings.chars_ptr;
   begin
      if Sys_getifaddrs (Iflist'Access) = 0 then
         R := Interfaces.C.Strings.New_String ("xxx.xxx.xxx.xxx.xxx");
         Ifp := Iflist;
         while Ifp /= null loop
            if Sys_Inet_Ntop (Ifp.Ifa_Addr.Sa_Family, Ifp.Ifa_Addr.Sa_Addr'Address, R, 17)
              /= Interfaces.C.Strings.Null_Ptr
            then
               Log.Debug ("Found interface: {0} - IP {1}",
                          Interfaces.C.Strings.Value (Ifp.Ifa_Name),
                          Interfaces.C.Strings.Value (R));
               if Interfaces.C.Strings.Value (R) /= "::" then
                  IPs.Include (Interfaces.C.Strings.Value (R));
               end if;
            end if;
            Ifp := Ifp.Ifa_Next;
         end loop;
         Interfaces.C.Strings.Free (R);
         Sys_freeifaddrs (Iflist);
      end if;
   end Find_IPv4_Addresses;

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type) is
      Last : Ada.Streams.Stream_Element_Offset;
      Buf  : Ada.Streams.Stream_Element_Array (1 .. Content'Length);
      for Buf'Address use Content'Address;
      pragma Import (Ada, Buf);
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Socket, Buf, Last, To);
   end Send;

   --  ------------------------------
   --  Send the SSDP discovery UDP packet on the UPnP multicast group 239.255.255.250.
   --  Set the "ST" header to the given target.  The UDP packet is sent on each interface
   --  whose IP address is defined in the set <tt>IPs</tt>.
   --  ------------------------------
   procedure Send_Discovery (Scanner : in out Scanner_Type;
                             Target  : in String;
                             IPs     : in Util.Strings.Sets.Set) is
      Address : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Address.Addr := GNAT.Sockets.Inet_Addr (Group);
      Address.Port := 1900;
      for IP of IPs loop
         GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                         (GNAT.Sockets.Multicast_If,
                                          GNAT.Sockets.Inet_Addr (IP)));

         Log.Debug ("Sending SSDP search for IGD device from {0}", IP);
         Send (Scanner.Socket, "M-SEARCH * HTTP/1.1" & ASCII.CR & ASCII.LF &
                 "HOST: 239.255.255.250:1900" & ASCII.CR & ASCII.LF &
                 "ST: " & Target & ASCII.CR & ASCII.LF &
                 "MAN: ""ssdp:discover""" & ASCII.CR & ASCII.LF &
                 "MX: 2" & ASCII.CR & ASCII.LF, Address'Access);
      end loop;
   end Send_Discovery;

   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String) is
      function Get_Line return String;

      Data         : Ada.Streams.Stream_Element_Array (0 .. 1500);
      Last         : Ada.Streams.Stream_Element_Offset;
      Pos   : Ada.Streams.Stream_Element_Offset := Data'First;

      function Get_Line return String is
         First : constant Ada.Streams.Stream_Element_Offset := Pos;
      begin
         while Pos <= Last loop
            if Data (Pos) = 16#0D# and then Pos + 1 <= Last and then Data (Pos + 1) = 16#0A# then
               declare
                  Result : String (1 .. Natural (Pos - First));
                  P      : Natural := 1;
               begin
                  for I in First .. Pos - 1 loop
                     Result (P) := Character'Val (Data (I));
                     P := P + 1;
                  end loop;
                  Log.Debug ("L: {0}", Result);
                  Pos := Pos + 2;
                  return Result;
               end;
            end if;
            Pos := Pos + 1;
         end loop;
         return "";
      end Get_Line;

   begin
      Desc := Ada.Strings.Unbounded.To_Unbounded_String ("");
      GNAT.Sockets.Receive_Socket (Socket, Data, Last);
      if Get_Line /= "HTTP/1.1 200 OK" then
         Log.Debug ("Receive a non HTTP/1.1 response");
         return;
      end if;
      loop
         declare
            Line : constant String := Get_Line;
            Pos  : constant Natural := Util.Strings.Index (Line, ':');
            Pos2 : Natural := Pos + 1;
         begin
            exit when Pos = 0;
            while Pos2 < Line'Last and then Line (Pos2) = ' ' loop
               Pos2 := Pos2 + 1;
            end loop;
            if Line (1 .. Pos) = "ST:" then
               if Line (Pos2 .. Line'Last) /= Target then
                  return;
               end if;
            elsif Line (1 .. Pos) = "LOCATION:" then
               Desc := Ada.Strings.Unbounded.To_Unbounded_String (Line (Pos2 .. Line'Last));
               Log.Debug ("Found a IGD device: {0}", Ada.Strings.Unbounded.To_String (Desc));
               return;
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception received", E);
   end Receive;

   --  ------------------------------
   --  Receive the UPnP SSDP discovery messages for the given target.
   --  Call the <tt>Process</tt> procedure for each of them.  The <tt>Desc</tt> parameter
   --  represents the UPnP location header which gives the UPnP XML root descriptor.
   --  Wait at most the given time.
   --  ------------------------------
   procedure Discover (Scanner : in out Scanner_Type;
                       Target  : in String;
                       Process : not null access procedure (Desc : in String);
                       Wait    : in Duration) is
      use type Ada.Calendar.Time;
      use type GNAT.Sockets.Selector_Status;

      Sel      : GNAT.Sockets.Selector_Type;
      Rset     : GNAT.Sockets.Socket_Set_Type;
      Wset     : GNAT.Sockets.Socket_Set_Type;
      Status   : GNAT.Sockets.Selector_Status;
      Desc     : Ada.Strings.Unbounded.Unbounded_String;
      Deadline : constant Ada.Calendar.Time := Ada.Calendar.Clock + Wait;
      Remain   : Duration;
   begin
      GNAT.Sockets.Create_Selector (Sel);
      loop
         GNAT.Sockets.Empty (Rset);
         GNAT.Sockets.Empty (Wset);
         GNAT.Sockets.Set (Rset, Scanner.Socket);

         Remain := Deadline - Ada.Calendar.Clock;
         exit when Remain < 0.0;
         GNAT.Sockets.Check_Selector (Selector     => Sel,
                                      R_Socket_Set => Rset,
                                      W_Socket_Set => Wset,
                                      Status       => Status,
                                      Timeout      => Remain);
         exit when Status = GNAT.Sockets.Expired;
         Receive (Scanner.Socket, Target, Desc);
         declare
            URI  : constant String := Ada.Strings.Unbounded.To_String (Desc);
            Pos  : constant Natural := Util.Strings.Index (URI, ':');
         begin
            if Pos > 0 and URI (URI'First .. Pos + 2) = "http://" then
               Process (URI);
            end if;
         end;
      end loop;
   end Discover;

   --  ------------------------------
   --  Release the socket.
   --  ------------------------------
   overriding
   procedure Finalize (Scanner : in out Scanner_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Scanner.Socket /= GNAT.Sockets.No_Socket then
         GNAT.Sockets.Close_Socket (Scanner.Socket);
      end if;
   end Finalize;

end UPnP.SSDP;

-----------------------------------------------------------------------
--  upnp-ssdp -- UPnP SSDP operations
--  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;
with Ada.Strings.Unbounded;
with Ada.Calendar;
with System;
with Interfaces.C.Strings;
with Util.Log.Loggers;

package body UPnP.SSDP is
   use type Ada.Streams.Stream_Element_Offset;
   use type Ada.Streams.Stream_Element;

   --  The logger
   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("UPnP.SSDP");

   Group : constant String := "239.255.255.250";

   type Sockaddr is record
      Sa_Family : Interfaces.C.unsigned_short;
      Sa_Port   : Interfaces.C.unsigned_short;
      Sa_Addr   : aliased Interfaces.C.char_array (1 .. 8);
   end record;
   pragma Convention (C, Sockaddr);

   type If_Address;
   type If_Address_Access is access all If_Address;
   type If_Address is record
      Ifa_Next  : If_Address_Access;
      Ifa_Name  : Interfaces.C.Strings.chars_ptr;
      Ifa_Flags : Interfaces.C.unsigned;
      Ifa_Addr  : access Sockaddr;
   end record;
   pragma Convention (C, If_Address);

   function Sys_getifaddrs (ifap : access If_Address_Access) return Interfaces.C.int;
   pragma Import (C, Sys_getifaddrs, "getifaddrs");

   procedure Sys_freeifaddrs (ifap : If_Address_Access);
   pragma Import (C, Sys_freeifaddrs, "freeifaddrs");

   function Sys_Inet_Ntop (Af : in Interfaces.C.unsigned_short;
                           Addr : System.Address;
                           Dst  : in Interfaces.C.Strings.chars_ptr;
                           Size : in Interfaces.C.int) return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Sys_Inet_Ntop, "inet_ntop");

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type);
   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String);

   --  ------------------------------
   --  Initialize the SSDP scanner by opening the UDP socket.
   --  ------------------------------
   procedure Initialize (Scanner : in out Scanner_Type) is
      Address      : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Log.Info ("Discovering gateways on the network");

      Address.Addr := GNAT.Sockets.Any_Inet_Addr;
      Address.Port := 0;
      GNAT.Sockets.Create_Socket (Scanner.Socket, GNAT.Sockets.Family_Inet,
                                  GNAT.Sockets.Socket_Datagram);
      GNAT.Sockets.Bind_Socket (Scanner.Socket, Address);
      GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                      (GNAT.Sockets.Add_Membership, GNAT.Sockets.Inet_Addr (Group),
                                       GNAT.Sockets.Any_Inet_Addr));
   end Initialize;

   --  ------------------------------
   --  Find the IPv4 addresses of the network interfaces.
   --  ------------------------------
   procedure Find_IPv4_Addresses (Scanner : in out Scanner_Type;
                                  IPs     : out Util.Strings.Sets.Set) is
      pragma Unreferenced (Scanner);
      use type Interfaces.C.int;
      use type Interfaces.C.Strings.chars_ptr;

      Iflist   : aliased If_Address_Access;
      Ifp      : If_Address_Access;
      R        : Interfaces.C.Strings.chars_ptr;
   begin
      if Sys_getifaddrs (Iflist'Access) = 0 then
         R := Interfaces.C.Strings.New_String ("xxx.xxx.xxx.xxx.xxx");
         Ifp := Iflist;
         while Ifp /= null loop
            if Sys_Inet_Ntop (Ifp.Ifa_Addr.Sa_Family, Ifp.Ifa_Addr.Sa_Addr'Address, R, 17)
              /= Interfaces.C.Strings.Null_Ptr
            then
               Log.Debug ("Found interface: {0} - IP {1}",
                          Interfaces.C.Strings.Value (Ifp.Ifa_Name),
                          Interfaces.C.Strings.Value (R));
               if Interfaces.C.Strings.Value (R) /= "::" then
                  IPs.Include (Interfaces.C.Strings.Value (R));
               end if;
            end if;
            Ifp := Ifp.Ifa_Next;
         end loop;
         Interfaces.C.Strings.Free (R);
         Sys_freeifaddrs (Iflist);
      end if;
   end Find_IPv4_Addresses;

   procedure Send (Socket  : in GNAT.Sockets.Socket_Type;
                   Content : in String;
                   To      : access GNAT.Sockets.Sock_Addr_Type) is
      Last : Ada.Streams.Stream_Element_Offset;
      Buf  : Ada.Streams.Stream_Element_Array (1 .. Content'Length);
      for Buf'Address use Content'Address;
      pragma Import (Ada, Buf);
      pragma Unreferenced (Last);
   begin
      GNAT.Sockets.Send_Socket (Socket, Buf, Last, To);
   end Send;

   --  ------------------------------
   --  Send the SSDP discovery UDP packet on the UPnP multicast group 239.255.255.250.
   --  Set the "ST" header to the given target.  The UDP packet is sent on each interface
   --  whose IP address is defined in the set <tt>IPs</tt>.
   --  ------------------------------
   procedure Send_Discovery (Scanner : in out Scanner_Type;
                             Target  : in String;
                             IPs     : in Util.Strings.Sets.Set) is
      Address : aliased GNAT.Sockets.Sock_Addr_Type;
   begin
      Address.Addr := GNAT.Sockets.Inet_Addr (Group);
      Address.Port := 1900;
      for IP of IPs loop
         GNAT.Sockets.Set_Socket_Option (Scanner.Socket, GNAT.Sockets.IP_Protocol_For_IP_Level,
                                         (GNAT.Sockets.Multicast_If,
                                          GNAT.Sockets.Inet_Addr (IP)));

         Log.Debug ("Sending SSDP search for IGD device from {0}", IP);
         Send (Scanner.Socket, "M-SEARCH * HTTP/1.1" & ASCII.CR & ASCII.LF &
                 "HOST: 239.255.255.250:1900" & ASCII.CR & ASCII.LF &
                 "ST: " & Target & ASCII.CR & ASCII.LF &
                 "MAN: ""ssdp:discover""" & ASCII.CR & ASCII.LF &
                 "MX: 2" & ASCII.CR & ASCII.LF, Address'Access);
      end loop;
   end Send_Discovery;

   procedure Receive (Socket : in GNAT.Sockets.Socket_Type;
                      Target : in String;
                      Desc   : out Ada.Strings.Unbounded.Unbounded_String) is
      function Get_Line return String;

      Data         : Ada.Streams.Stream_Element_Array (0 .. 1500);
      Last         : Ada.Streams.Stream_Element_Offset;
      Pos   : Ada.Streams.Stream_Element_Offset := Data'First;

      function Get_Line return String is
         First : constant Ada.Streams.Stream_Element_Offset := Pos;
      begin
         while Pos <= Last loop
            if Data (Pos) = 16#0D# and then Pos + 1 <= Last and then Data (Pos + 1) = 16#0A# then
               declare
                  Result : String (1 .. Natural (Pos - First));
                  P      : Natural := 1;
               begin
                  for I in First .. Pos - 1 loop
                     Result (P) := Character'Val (Data (I));
                     P := P + 1;
                  end loop;
                  Log.Debug ("L: {0}", Result);
                  Pos := Pos + 2;
                  return Result;
               end;
            end if;
            Pos := Pos + 1;
         end loop;
         return "";
      end Get_Line;

   begin
      Desc := Ada.Strings.Unbounded.To_Unbounded_String ("");
      GNAT.Sockets.Receive_Socket (Socket, Data, Last);
      if Get_Line /= "HTTP/1.1 200 OK" then
         Log.Debug ("Receive a non HTTP/1.1 response");
         return;
      end if;
      loop
         declare
            Line : constant String := Get_Line;
            Pos  : constant Natural := Util.Strings.Index (Line, ':');
            Pos2 : Natural := Pos + 1;
         begin
            exit when Pos = 0;
            while Pos2 < Line'Last and then Line (Pos2) = ' ' loop
               Pos2 := Pos2 + 1;
            end loop;
            if Line (1 .. Pos) = "ST:" then
               if Line (Pos2 .. Line'Last) /= Target then
                  return;
               end if;
            elsif Line (1 .. Pos) = "LOCATION:" then
               Desc := Ada.Strings.Unbounded.To_Unbounded_String (Line (Pos2 .. Line'Last));
               Log.Debug ("Found a IGD device: {0}", Ada.Strings.Unbounded.To_String (Desc));
               return;
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception received", E);
   end Receive;

   --  ------------------------------
   --  Receive the UPnP SSDP discovery messages for the given target.
   --  Call the <tt>Process</tt> procedure for each of them.  The <tt>Desc</tt> parameter
   --  represents the UPnP location header which gives the UPnP XML root descriptor.
   --  Wait at most the given time.
   --  ------------------------------
   procedure Discover (Scanner : in out Scanner_Type;
                       Target  : in String;
                       Process : not null access procedure (Desc : in String);
                       Wait    : in Duration) is
      use type Ada.Calendar.Time;
      use type GNAT.Sockets.Selector_Status;

      Sel      : GNAT.Sockets.Selector_Type;
      Rset     : GNAT.Sockets.Socket_Set_Type;
      Wset     : GNAT.Sockets.Socket_Set_Type;
      Status   : GNAT.Sockets.Selector_Status;
      Desc     : Ada.Strings.Unbounded.Unbounded_String;
      Deadline : constant Ada.Calendar.Time := Ada.Calendar.Clock + Wait;
      Remain   : Duration;
   begin
      GNAT.Sockets.Create_Selector (Sel);
      loop
         GNAT.Sockets.Empty (Rset);
         GNAT.Sockets.Empty (Wset);
         GNAT.Sockets.Set (Rset, Scanner.Socket);

         Remain := Deadline - Ada.Calendar.Clock;
         exit when Remain < 0.0;
         GNAT.Sockets.Check_Selector (Selector     => Sel,
                                      R_Socket_Set => Rset,
                                      W_Socket_Set => Wset,
                                      Status       => Status,
                                      Timeout      => Remain);
         exit when Status = GNAT.Sockets.Expired;
         Receive (Scanner.Socket, Target, Desc);
         declare
            URI  : constant String := Ada.Strings.Unbounded.To_String (Desc);
            Pos  : constant Natural := Util.Strings.Index (URI, ':');
         begin
            if Pos > 0 and URI (URI'First .. Pos + 2) = "http://" then
               Process (URI);
            end if;
         end;
      end loop;
   end Discover;

   --  ------------------------------
   --  Release the socket.
   --  ------------------------------
   overriding
   procedure Finalize (Scanner : in out Scanner_Type) is
      use type GNAT.Sockets.Socket_Type;
   begin
      if Scanner.Socket /= GNAT.Sockets.No_Socket then
         GNAT.Sockets.Close_Socket (Scanner.Socket);
      end if;
   end Finalize;

end UPnP.SSDP;

Fix the socket port initialization

Fix the socket port initialization


-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local url = require("url")

name = "Yahoo"
type = "scrape"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    for i=1,201,10 do
        local ok = scrape(ctx, {['url']=buildurl(domain, i)})
        if not ok then
            break
        end

        checkratelimit()
    end
end

function buildurl(domain, pagenum)
    local next = tostring(pagenum)
    local query = "site:" .. domain .. " -domain:www." .. domain
    local params = {
        p=query,
        b=next,
        pz="10",
        bct="0",
        xargs="0",
    }

    return "https://search.yahoo.com/search?" .. url.build_query_string(params)
end

-- Copyright 2017 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local url = require("url")

name = "Yahoo"
type = "scrape"

function start()
    setratelimit(1)
end

function vertical(ctx, domain)
    for i=1,201,10 do
        local ok = scrape(ctx, {['url']=buildurl(domain, i)})
        if not ok then
            break
        end

        checkratelimit()
    end
end

function buildurl(domain, pagenum)
    local query = "site:" .. domain .. " -domain:www." .. domain
    local params = {
        p=query,
        b=pagenum,
        pz="10",
        bct="0",
        xargs="0",
    }

    return "https://search.yahoo.com/search?" .. url.build_query_string(params)
end

Simplify the buildurl function

Simplify the buildurl function


-----------------------------------------------------------------------
--  babel-base-users-tests - Unit tests for babel users
--  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 Util.Test_Caller;

package body Babel.Base.Users.Tests is

   use type Util.Strings.Name_Access;

   package Caller is new Util.Test_Caller (Test, "Base.Users");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Find",
                       Test_Find'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Find (T : in out Test) is
      Db   : Babel.Base.Users.Database;
      User : User_Type;
   begin
      User := Db.Find (0, 0);
      T.Assert (User.Name /= null, "User uid=0 was not found");
      T.Assert (User.Group /= null, "User gid=0 was not found");
      Util.Tests.Assert_Equals (T, "root", User.Name.all, "Invalid root user name");
      Util.Tests.Assert_Equals (T, "root", User.Group.all, "Invalid root group name");

      User := Db.Find ("bin", "daemon");
      T.Assert (User.Name /= null, "User bin was not found");
      T.Assert (User.Group /= null, "Group daemon was not found");
      Util.Tests.Assert_Equals (T, "bin", User.Name.all, "Invalid 'bin' user name");
      Util.Tests.Assert_Equals (T, "daemon", User.Group.all, "Invalid 'daemon' group name");
      T.Assert (User.Uid > 0, "Invalid 'bin' uid");
      T.Assert (User.Gid > 0, "Invalid 'daemon' gid");
   end Test_Find;

end Babel.Base.Users.Tests;

-----------------------------------------------------------------------
--  babel-base-users-tests - Unit tests for babel users
--  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 Util.Test_Caller;

package body Babel.Base.Users.Tests is

   use type Babel.Uid_Type;
   use type Babel.Gid_Type;
   use type Util.Strings.Name_Access;

   package Caller is new Util.Test_Caller (Test, "Base.Users");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Find",
                       Test_Find'Access);
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Get_Name",
                       Test_Get_Name'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Find (T : in out Test) is
      Db   : Babel.Base.Users.Database;
      User : User_Type;
   begin
      User := Db.Find (0, 0);
      T.Assert (User.Name /= null, "User uid=0 was not found");
      T.Assert (User.Group /= null, "User gid=0 was not found");
      Util.Tests.Assert_Equals (T, "root", User.Name.all, "Invalid root user name");
      Util.Tests.Assert_Equals (T, "root", User.Group.all, "Invalid root group name");

      User := Db.Find ("bin", "daemon");
      T.Assert (User.Name /= null, "User bin was not found");
      T.Assert (User.Group /= null, "Group daemon was not found");
      Util.Tests.Assert_Equals (T, "bin", User.Name.all, "Invalid 'bin' user name");
      Util.Tests.Assert_Equals (T, "daemon", User.Group.all, "Invalid 'daemon' group name");
      T.Assert (User.Uid > 0, "Invalid 'bin' uid");
      T.Assert (User.Gid > 0, "Invalid 'daemon' gid");
   end Test_Find;

   --  ------------------------------
   --  Test the Get_Name operation.
   --  ------------------------------
   procedure Test_Get_Name (T : in out Test) is
      Name : Name_Access;
      Db   : Database;
   begin
      Name := Db.Get_Name (0);
      T.Assert (Name /= null, "Get_Name (0) returned null");
      Util.Tests.Assert_Equals (T, "root", Name.all, "Invalid name returned for Get_Name (0)");

      Name := Db.Get_Name (1);
      T.Assert (Name /= null, "Get_Name (1) returned null");

      Name := Db.Get_Name (55555);
      T.Assert (Name = null, "Get_Name (55555) returned a non null name");
   end Test_Get_Name;

end Babel.Base.Users.Tests;

Implement the Test_Get_Name procedure to test the name resolution


-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  Copyright (C) 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 ASF.Factory;

package ASF.Components.Widgets.Factory is

   --  Get the widget component factory.
   function Definition return ASF.Factory.Factory_Bindings_Access;

end ASF.Components.Widgets.Factory;

-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  Copyright (C) 2013, 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.Factory;

package ASF.Components.Widgets.Factory is

   --  Register the widget component factory.
   procedure Register (Factory : in out ASF.Factory.Component_Factory);

end ASF.Components.Widgets.Factory;

Change the Definition function into a Register procedure


-----------------------------------------------------------------------
--  gen-artifacts-distribs-bundles -- Merge bundles for distribution artifact
--  Copyright (C) 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.Directories;
with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Text_IO;

with Util.Log.Loggers;
with Util.Properties;

package body Gen.Artifacts.Distribs.Bundles is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Bundles");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Bundle_Rule_Access := new Bundle_Rule;
   begin
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Bundle_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "bundle";
   end Get_Install_Name;

   --  ------------------------------
   --  Install the file File according to the distribution rule.
   --  Merge all the files listed in Files in the target path specified by Path.
   --  ------------------------------
   overriding
   procedure Install (Rule    : in Bundle_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      procedure Load_File (File : in File_Record);
      procedure Merge_Property (Name, Item : in Util.Properties.Value);
      procedure Save_Property (Name, Item : in Util.Properties.Value);

      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
      Output : Ada.Text_IO.File_Type;
      Merge  : Util.Properties.Manager;

      --  ------------------------------
      --  Merge the property into the target property list.
      --  ------------------------------
      procedure Merge_Property (Name, Item : in Util.Properties.Value) is
      begin
         Merge.Set (Name, Item);
      end Merge_Property;

      procedure Save_Property (Name, Item : in Util.Properties.Value) is
      begin
         Ada.Text_IO.Put (Output, Ada.Strings.Unbounded.To_String (Name));
         Ada.Text_IO.Put (Output, "=");
         Ada.Text_IO.Put_Line (Output, Ada.Strings.Unbounded.To_String (Item));
      end Save_Property;

      --  ------------------------------
      --  Append the file to the output
      --  ------------------------------
      procedure Load_File (File : in File_Record) is
         File_Path : constant String := Rule.Get_Source_Path (File);
         Props     : Util.Properties.Manager;
      begin
         Log.Info ("loading {0}", File_Path);

         Props.Load_Properties (Path => File_Path);

         Props.Iterate (Process => Merge_Property'Access);
      exception
         when Ex : Ada.IO_Exceptions.Name_Error =>
            Context.Error ("Cannot read {0}: ", File_Path, Ada.Exceptions.Exception_Message (Ex));

      end Load_File;

      Iter   : File_Cursor := Files.First;
   begin
      Ada.Directories.Create_Path (Dir);

      while File_Record_Vectors.Has_Element (Iter) loop
         File_Record_Vectors.Query_Element (Iter, Load_File'Access);
         File_Record_Vectors.Next (Iter);
      end loop;
      Ada.Text_IO.Open (File => Output, Mode => Ada.Text_IO.Out_File, Name => Path);
      Merge.Iterate (Process => Save_Property'Access);
      Ada.Text_IO.Close (File => Output);
   end Install;

end Gen.Artifacts.Distribs.Bundles;

-----------------------------------------------------------------------
--  gen-artifacts-distribs-bundles -- Merge bundles for distribution artifact
--  Copyright (C) 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.Directories;
with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Text_IO;

with Util.Log.Loggers;
with Util.Properties;

package body Gen.Artifacts.Distribs.Bundles is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Bundles");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Bundle_Rule_Access := new Bundle_Rule;
   begin
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Bundle_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "bundle";
   end Get_Install_Name;

   --  ------------------------------
   --  Install the file File according to the distribution rule.
   --  Merge all the files listed in Files in the target path specified by Path.
   --  ------------------------------
   overriding
   procedure Install (Rule    : in Bundle_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      procedure Load_File (File : in File_Record);
      procedure Merge_Property (Name, Item : in Util.Properties.Value);
      procedure Save_Property (Name, Item : in Util.Properties.Value);

      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
      Output : Ada.Text_IO.File_Type;
      Merge  : Util.Properties.Manager;

      --  ------------------------------
      --  Merge the property into the target property list.
      --  ------------------------------
      procedure Merge_Property (Name, Item : in Util.Properties.Value) is
      begin
         Merge.Set (Name, Item);
      end Merge_Property;

      procedure Save_Property (Name, Item : in Util.Properties.Value) is
      begin
         Ada.Text_IO.Put (Output, Ada.Strings.Unbounded.To_String (Name));
         Ada.Text_IO.Put (Output, "=");
         Ada.Text_IO.Put_Line (Output, Ada.Strings.Unbounded.To_String (Item));
      end Save_Property;

      --  ------------------------------
      --  Append the file to the output
      --  ------------------------------
      procedure Load_File (File : in File_Record) is
         File_Path : constant String := Rule.Get_Source_Path (File);
         Props     : Util.Properties.Manager;
      begin
         Log.Info ("loading {0}", File_Path);

         Props.Load_Properties (Path => File_Path);

         Props.Iterate (Process => Merge_Property'Access);
      exception
         when Ex : Ada.IO_Exceptions.Name_Error =>
            Context.Error ("Cannot read {0}: ", File_Path, Ada.Exceptions.Exception_Message (Ex));

      end Load_File;

      Iter   : File_Cursor := Files.First;
   begin
      Ada.Directories.Create_Path (Dir);

      while File_Record_Vectors.Has_Element (Iter) loop
         File_Record_Vectors.Query_Element (Iter, Load_File'Access);
         File_Record_Vectors.Next (Iter);
      end loop;
      Ada.Text_IO.Create (File => Output, Mode => Ada.Text_IO.Out_File, Name => Path);
      Merge.Iterate (Process => Save_Property'Access);
      Ada.Text_IO.Close (File => Output);
   end Install;

end Gen.Artifacts.Distribs.Bundles;

Fix creation of target bundle file

Fix creation of target bundle file


-----------------------------------------------------------------------
--  security-controllers-roles -- Simple role base security
--  Copyright (C) 2011 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.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler : in Role_Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

-----------------------------------------------------------------------
--  security-controllers-roles -- Simple role base security
--  Copyright (C) 2011 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.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   --  ------------------------------
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

Add permission parameter

Add permission parameter


-----------------------------------------------------------------------
--  EL.Beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010 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 EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is interface and Readonly_Bean;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Set the current row index.  Valid row indexes start at 1.
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is abstract;

   --  Get the element at the current row index.
   function Get_Row (From  : List_Bean) return EL.Objects.Object is abstract;

end EL.Beans;

-----------------------------------------------------------------------
--  EL.Beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010 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 EL.Objects;

package EL.Beans is

   --  Exception raised when the value identified by a name is not
   --  recognized.
   No_Value : exception;

   --  ------------------------------
   --  Read-only Bean interface.
   --  ------------------------------
   --  The ''Readonly_Bean'' interface allows to plug a complex
   --  runtime object to the expression resolver.  This interface
   --  must be implemented by any tagged record that should be
   --  accessed as a variable for an expression.
   --
   --  For example, if 'foo' is bound to an object implementing that
   --  interface, expressions like 'foo.name' will resolve to 'foo'
   --  and the 'Get_Value' method will be called with 'name'.
   --
   type Readonly_Bean is limited interface;
   type Readonly_Bean_Access is access all Readonly_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : Readonly_Bean;
                       Name : String) return EL.Objects.Object is abstract;

   --  ------------------------------
   --  Bean interface.
   --  ------------------------------
   --  The ''Bean'' interface allows to modify a property value.
   type Bean is limited interface and Readonly_Bean;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   procedure Set_Value (From  : in out Bean;
                        Name  : in String;
                        Value : in EL.Objects.Object) is abstract;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The <b>List_Bean</b> interface gives access to a list of objects.
   type List_Bean is limited interface and Readonly_Bean;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   function Get_Count (From : List_Bean) return Natural is abstract;

   --  Set the current row index.  Valid row indexes start at 1.
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural) is abstract;

   --  Get the element at the current row index.
   function Get_Row (From  : List_Bean) return EL.Objects.Object is abstract;

end EL.Beans;

Make the interface limited to allow limited types to implement the bean interfaces.


-----------------------------------------------------------------------
--  asf-servlets-faces-mappers -- Read faces specific configuration files
--  Copyright (C) 2015, 2016, 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 Ada.Strings.Unbounded;
with Servlet.Routes.Servlets;
with Servlet.Core;
with ASF.Routes;
package body ASF.Servlets.Faces.Mappers is

   use type ASF.Routes.Route_Type_Access;
   use type Servlet.Core.Servlet_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access is
      Disp  : constant Servlet.Core.Request_Dispatcher := Container.Get_Request_Dispatcher (View);
      Serv  : constant Servlet_Access := Servlet.Core.Get_Servlet (Disp);
   begin
      if Serv = null then
         raise Util.Serialize.Mappers.Field_Error with "No servlet mapped to view " & View;
      end if;
      return Serv; --  Servlet.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet;
   end Find_Servlet;

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the URL_MAPPING, URL_PATTERN, VIEW_ID field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Field is
         when URL_PATTERN =>
            N.URL_Pattern := Value;

         when VIEW_ID =>
            N.View_Id := Value;

         when URL_MAPPING =>
            declare
               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);

               View    : constant String := To_String (N.View_Id);
               Servlet : constant ASF.Servlets.Servlet_Access := Find_Servlet (N.Handler, View);

               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
                  To : ASF.Routes.Faces_Route_Type_Access;
               begin
                  if Route.Is_Null then
                     To := new ASF.Routes.Faces_Route_Type;
                     To.View    := Ada.Strings.Unbounded.To_Unbounded_String (View);
                     To.Servlet := Servlet;
                     Route := ASF.Routes.Route_Type_Refs.Create (To.all'Access);
                  end if;
               end Insert;

            begin
               N.Handler.Add_Route (Pattern   => To_String (N.URL_Pattern),
                                    ELContext => N.Context.all,
                                    Process   => Insert'Access);
            end;
      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules <b>url-mapping</b>.
   --  ------------------------------
   package body Reader_Config is
   begin
      Mapper.Add_Mapping ("faces-config", SMapper'Access);
      Mapper.Add_Mapping ("module", SMapper'Access);
      Mapper.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Mapper, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("url-mapping", URL_MAPPING);
   SMapper.Add_Mapping ("url-mapping/pattern", URL_PATTERN);
   SMapper.Add_Mapping ("url-mapping/view-id", VIEW_ID);
end ASF.Servlets.Faces.Mappers;

-----------------------------------------------------------------------
--  asf-servlets-faces-mappers -- Read faces specific configuration files
--  Copyright (C) 2015, 2016, 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 Ada.Strings.Unbounded;
with Servlet.Core;
with ASF.Routes;
package body ASF.Servlets.Faces.Mappers is

   use type ASF.Routes.Route_Type_Access;
   use type Servlet.Core.Servlet_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access;

   function Find_Servlet (Container : in Servlet_Registry_Access;
                          View      : in String)
                          return ASF.Servlets.Servlet_Access is
      Disp  : constant Servlet.Core.Request_Dispatcher := Container.Get_Request_Dispatcher (View);
      Serv  : constant Servlet_Access := Servlet.Core.Get_Servlet (Disp);
   begin
      if Serv = null then
         raise Util.Serialize.Mappers.Field_Error with "No servlet mapped to view " & View;
      end if;
      return Serv; --  Servlet.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet;
   end Find_Servlet;

   --  ------------------------------
   --  Save in the servlet config object the value associated with the given field.
   --  When the URL_MAPPING, URL_PATTERN, VIEW_ID field
   --  is reached, insert the new configuration rule in the servlet registry.
   --  ------------------------------
   procedure Set_Member (N     : in out Servlet_Config;
                         Field : in Servlet_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Field is
         when URL_PATTERN =>
            N.URL_Pattern := Value;

         when VIEW_ID =>
            N.View_Id := Value;

         when URL_MAPPING =>
            declare
               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref);

               View    : constant String := To_String (N.View_Id);
               Servlet : constant ASF.Servlets.Servlet_Access := Find_Servlet (N.Handler, View);

               procedure Insert (Route : in out ASF.Routes.Route_Type_Ref) is
                  To : ASF.Routes.Faces_Route_Type_Access;
               begin
                  if Route.Is_Null then
                     To := new ASF.Routes.Faces_Route_Type;
                     To.View    := Ada.Strings.Unbounded.To_Unbounded_String (View);
                     To.Servlet := Servlet;
                     Route := ASF.Routes.Route_Type_Refs.Create (To.all'Access);
                  end if;
               end Insert;

            begin
               N.Handler.Add_Route (Pattern   => To_String (N.URL_Pattern),
                                    ELContext => N.Context.all,
                                    Process   => Insert'Access);
            end;
      end case;
   end Set_Member;

   SMapper : aliased Servlet_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the servlet and mapping rules <b>url-mapping</b>.
   --  ------------------------------
   package body Reader_Config is
   begin
      Mapper.Add_Mapping ("faces-config", SMapper'Access);
      Mapper.Add_Mapping ("module", SMapper'Access);
      Mapper.Add_Mapping ("web-app", SMapper'Access);
      Config.Handler := Handler;
      Config.Context := Context;
      Servlet_Mapper.Set_Context (Mapper, Config'Unchecked_Access);
   end Reader_Config;

begin
   SMapper.Add_Mapping ("url-mapping", URL_MAPPING);
   SMapper.Add_Mapping ("url-mapping/pattern", URL_PATTERN);
   SMapper.Add_Mapping ("url-mapping/view-id", VIEW_ID);
end ASF.Servlets.Faces.Mappers;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  Atlas-server -- Application server
--  Copyright (C) 2011 unknown
--  Written by unknown (unknown@company.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 Util.Log.loggers;

with ASF.Server.Web;

with Atlas.Applications;
procedure Atlas.Server is

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;
   WS      : ASF.Server.Web.AWS_Container;
begin
   Atlas.Applications.Initialize (App);
   WS.Register_Application (Atlas.Applications.CONTEXT_PATH, App.all'Access);
   Log.Info ("Connect you browser to: http://localhost:8080/atlas/index.html");
   WS.Start;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E: others =>
      Log.Error ("Exception in server: " &
                 Ada.Exceptions.Exception_Name (E) & ": " &
                 Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

-----------------------------------------------------------------------
--  Atlas-server -- Application server
--  Copyright (C) 2011, 2012, 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.Exceptions;

with Util.Log.Loggers;

with ASF.Server.Web;

with Atlas.Applications;
procedure Atlas.Server is

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;
   WS      : ASF.Server.Web.AWS_Container;
begin
   Atlas.Applications.Initialize (App);
   WS.Register_Application (Atlas.Applications.CONTEXT_PATH, App.all'Access);
   Log.Info ("Connect you browser to: http://localhost:8080/atlas/index.html");
   WS.Start;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E : others =>
      Log.Error ("Exception in server: " &
                 Ada.Exceptions.Exception_Name (E) & ": " &
                 Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

Fix compilation warnings

Fix compilation warnings


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

with Ada.Text_IO;
with Ada.Characters.Latin_1;

package body Port_Specification.Makefile is

   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;

   --------------------------------------------------------------------------------------------
   --  generator
   --------------------------------------------------------------------------------------------
   procedure generator
     (specs         : Portspecs;
      variant       : String;
      opsys         : supported_opsys;
      arch_standard : supported_arch;
      osrelease     : String;
      osmajor       : String;
      osversion     : String;
      option_string : String;
      output_file   : String
     )
   is
      procedure send (data : String; use_put : Boolean := False);
      procedure send (varname, value : String);
      procedure send (varname : String; value : HT.Text);
      procedure send (varname : String; crate : string_crate.Vector; flavor : Positive := 1);
      procedure send (varname : String; crate : list_crate.Map; flavor : Positive := 1);
      procedure send (varname : String; value : Boolean; dummy : Boolean);
      procedure send (varname : String; value, default : Integer);
      procedure print_item (position : string_crate.Cursor);
      procedure dump_list (position : list_crate.Cursor);
      procedure dump_distfiles (position : string_crate.Cursor);
      procedure dump_ext_zip   (position : string_crate.Cursor);
      procedure dump_ext_7z    (position : string_crate.Cursor);
      procedure dump_ext_lha   (position : string_crate.Cursor);
      procedure dump_extract_head_tail (position : list_crate.Cursor);
      procedure dump_dirty_extract (position : string_crate.Cursor);

      write_to_file   : constant Boolean := (output_file /= "");
      makefile_handle : TIO.File_Type;
      varname_prefix  : HT.Text;

      procedure send (data : String;  use_put : Boolean := False) is
      begin
         if write_to_file then
            if use_put then
               TIO.Put (makefile_handle, data);
            else
               TIO.Put_Line (makefile_handle, data);
            end if;
         else
            if use_put then
               TIO.Put (data);
            else
               TIO.Put_Line (data);
            end if;
         end if;
      end send;

      procedure send (varname, value : String) is
      begin
         send (varname & LAT.Equals_Sign & value);
      end send;

      procedure send (varname : String; value : HT.Text) is
      begin
         if not HT.IsBlank (value) then
            send (varname & LAT.Equals_Sign & HT.USS (value));
         end if;
      end send;

      procedure send (varname : String; value : Boolean; dummy : Boolean) is
      begin
         if value then
            send (varname & LAT.Equals_Sign & "yes");
         end if;
      end send;

      procedure send (varname : String; value, default : Integer) is
      begin
         if value /= default then
            send (varname & LAT.Equals_Sign & HT.int2str (value));
         end if;
      end send;

      procedure send (varname : String; crate : string_crate.Vector; flavor : Positive := 1) is
      begin
         if crate.Is_Empty then
            return;
         end if;
         case flavor is
            when 1 =>
               send (varname & "=", True);
               crate.Iterate (Process => print_item'Access);
               send ("");
            when 2 =>
               varname_prefix := HT.SUS (varname);
               crate.Iterate (Process => dump_distfiles'Access);
            when 3 =>
               crate.Iterate (Process => dump_ext_zip'Access);
            when 4 =>
               crate.Iterate (Process => dump_ext_7z'Access);
            when 5 =>
               crate.Iterate (Process => dump_ext_lha'Access);
            when 7 =>
               crate.Iterate (Process => dump_dirty_extract'Access);
            when others =>
               null;
         end case;
      end send;

      procedure send (varname : String; crate : list_crate.Map; flavor : Positive := 1) is
      begin
         varname_prefix := HT.SUS (varname);
         case flavor is
            when 1 => crate.Iterate (Process => dump_list'Access);
            when 6 => crate.Iterate (Process => dump_extract_head_tail'Access);
            when others => null;
         end case;
      end send;

      procedure dump_list (position : list_crate.Cursor)
      is
         NDX : String := HT.USS (varname_prefix)  & "_" &
                         HT.USS (list_crate.Element (position).group) & LAT.Equals_Sign;
      begin
         send (NDX, True);
         list_crate.Element (position).list.Iterate (Process => print_item'Access);
         send ("");
      end dump_list;

      procedure dump_extract_head_tail (position : list_crate.Cursor)
      is
         NDX : String := HT.USS (varname_prefix)  & "_" &
                         HT.USS (list_crate.Element (position).group) & LAT.Equals_Sign;
      begin
         if not list_crate.Element (position).list.Is_Empty then
            send (NDX, True);
            list_crate.Element (position).list.Iterate (Process => print_item'Access);
            send ("");
         end if;
      end dump_extract_head_tail;

      procedure print_item (position : string_crate.Cursor)
      is
         index : Natural := string_crate.To_Index (position);
      begin
         if index > 1 then
            send (" ", True);
         end if;
         send (HT.USS (string_crate.Element (position)), True);
      end print_item;

      procedure dump_distfiles (position : string_crate.Cursor)
      is
         index : Natural := string_crate.To_Index (position);
         NDX   : String  := HT.USS (varname_prefix)  & "_" & HT.int2str (index) & LAT.Equals_Sign;
      begin
         send (NDX & HT.USS (string_crate.Element (position)));
      end dump_distfiles;

      procedure dump_ext_zip (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=/usr/bin/unzip -qo");
         send ("EXTRACT_TAIL_" & N & "=-d ${EXTRACT_WRKDIR_" & N & "}");
      end dump_ext_zip;

      procedure dump_ext_7z (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=7z x -bd -y -o${EXTRACT_WRKDIR_" & N & "} >/dev/null");
         send ("EXTRACT_TAIL_" & N & "=# empty");
      end dump_ext_7z;

      procedure dump_ext_lha (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=lha xfpw=${EXTRACT_WRKDIR_" & N & "}");
         send ("EXTRACT_TAIL_" & N & "=# empty");
      end dump_ext_lha;

      procedure dump_dirty_extract (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("DIRTY_EXTRACT_" & N & "=yes");
      end dump_dirty_extract;

   begin
      if not specs.variant_exists (variant) then
         TIO.Put_Line ("Error : Variant '" & variant & "' does not exist!");
         return;
      end if;

      if write_to_file then
        TIO.Create (File => makefile_handle,
                    Mode => TIO.Out_File,
                    Name => output_file);
      end if;

      --  TODO: Check these to see if they are actually used.
      --  The pkg manifests did use many of these, but they will be generated by ravenadm

      send ("# Makefile has been autogenerated by ravenadm tool" & LAT.LF);

      send ("NAMEBASE",         HT.USS (specs.namebase));
      send ("VERSION",          HT.USS (specs.version));
      send ("REVISION",         specs.revision, 0);
      send ("EPOCH",            specs.epoch, 0);
      send ("KEYWORDS",         specs.keywords);    --  probably remove
      send ("VARIANT",          variant);
      send ("DL_SITES",         specs.dl_sites);
      send ("DISTFILE",         specs.distfiles, 2);
      send ("DIST_SUBDIR",      specs.dist_subdir);
      send ("DISTNAME",         specs.distname);
      send ("DF_INDEX",         specs.df_index);
      send ("EXTRACT_ONLY",     specs.extract_only);
      send ("DIRTY_EXTRACT",    specs.extract_dirty, 7);
      send ("ZIP-EXTRACT",      specs.extract_zip, 3);
      send ("7Z-EXTRACT",       specs.extract_7z, 4);
      send ("LHA-EXTRACT",      specs.extract_lha, 5);
      send ("EXTRACT_HEAD",     specs.extract_head, 6);
      send ("EXTRACT_TAIL",     specs.extract_tail, 6);
      send ("NO_BUILD",         specs.skip_build, True);
      send ("BUILD_WRKSRC",     specs.build_wrksrc);
      send ("BUILD_TARGET",     specs.build_target);
      send ("MAKEFILE",         specs.makefile);
      send ("MAKE_ENV",         specs.make_env);
      send ("MAKE_ARGS",        specs.make_args);
      send ("CFLAGS",           specs.cflags);
      send ("CXXFLAGS",         specs.cxxflags);
      send ("CPPFLAGS",         specs.cppflags);
      send ("LDFLAGS",          specs.ldflags);
      send ("SINGLE_JOB",       specs.single_job, True);
      send ("DESTDIR_VIA_ENV",  specs.destdir_env, True);
      send ("DESTDIRNAME",      specs.destdirname);

      --  TODO: This is not correct, placeholder.  rethink.
      send (".include " & LAT.Quotation & "/usr/raven/share/mk/raven.mk" & LAT.Quotation);

      if write_to_file then
         TIO.Close (makefile_handle);
      end if;
   exception
      when others =>
         if TIO.Is_Open (makefile_handle) then
            TIO.Close (makefile_handle);
         end if;
   end generator;

end Port_Specification.Makefile;

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

with Utilities;
with Ada.Text_IO;
with Ada.Characters.Latin_1;

package body Port_Specification.Makefile is

   package UTL renames Utilities;
   package TIO renames Ada.Text_IO;
   package LAT renames Ada.Characters.Latin_1;

   --------------------------------------------------------------------------------------------
   --  generator
   --------------------------------------------------------------------------------------------
   procedure generator
     (specs         : Portspecs;
      variant       : String;
      opsys         : supported_opsys;
      arch_standard : supported_arch;
      osrelease     : String;
      osmajor       : String;
      osversion     : String;
      option_string : String;
      output_file   : String
     )
   is
      procedure send (data : String; use_put : Boolean := False);
      procedure send (varname, value : String);
      procedure send (varname : String; value : HT.Text);
      procedure send (varname : String; crate : string_crate.Vector; flavor : Positive := 1);
      procedure send (varname : String; crate : list_crate.Map; flavor : Positive := 1);
      procedure send (varname : String; value : Boolean; dummy : Boolean);
      procedure send (varname : String; value, default : Integer);
      procedure print_item (position : string_crate.Cursor);
      procedure dump_list (position : list_crate.Cursor);
      procedure dump_distfiles (position : string_crate.Cursor);
      procedure dump_ext_zip   (position : string_crate.Cursor);
      procedure dump_ext_7z    (position : string_crate.Cursor);
      procedure dump_ext_lha   (position : string_crate.Cursor);
      procedure dump_line      (position : string_crate.Cursor);
      procedure dump_extract_head_tail (position : list_crate.Cursor);
      procedure dump_dirty_extract (position : string_crate.Cursor);
      procedure dump_standard_target (target : String);
      procedure dump_opsys_target    (target : String);

      write_to_file   : constant Boolean := (output_file /= "");
      makefile_handle : TIO.File_Type;
      varname_prefix  : HT.Text;

      procedure send (data : String;  use_put : Boolean := False) is
      begin
         if write_to_file then
            if use_put then
               TIO.Put (makefile_handle, data);
            else
               TIO.Put_Line (makefile_handle, data);
            end if;
         else
            if use_put then
               TIO.Put (data);
            else
               TIO.Put_Line (data);
            end if;
         end if;
      end send;

      procedure send (varname, value : String) is
      begin
         send (varname & LAT.Equals_Sign & value);
      end send;

      procedure send (varname : String; value : HT.Text) is
      begin
         if not HT.IsBlank (value) then
            send (varname & LAT.Equals_Sign & HT.USS (value));
         end if;
      end send;

      procedure send (varname : String; value : Boolean; dummy : Boolean) is
      begin
         if value then
            send (varname & LAT.Equals_Sign & "yes");
         end if;
      end send;

      procedure send (varname : String; value, default : Integer) is
      begin
         if value /= default then
            send (varname & LAT.Equals_Sign & HT.int2str (value));
         end if;
      end send;

      procedure send (varname : String; crate : string_crate.Vector; flavor : Positive := 1) is
      begin
         if crate.Is_Empty then
            return;
         end if;
         case flavor is
            when 1 =>
               send (varname & "=", True);
               crate.Iterate (Process => print_item'Access);
               send ("");
            when 2 =>
               varname_prefix := HT.SUS (varname);
               crate.Iterate (Process => dump_distfiles'Access);
            when 3 =>
               crate.Iterate (Process => dump_ext_zip'Access);
            when 4 =>
               crate.Iterate (Process => dump_ext_7z'Access);
            when 5 =>
               crate.Iterate (Process => dump_ext_lha'Access);
            when 7 =>
               crate.Iterate (Process => dump_dirty_extract'Access);
            when others =>
               null;
         end case;
      end send;

      procedure send (varname : String; crate : list_crate.Map; flavor : Positive := 1) is
      begin
         varname_prefix := HT.SUS (varname);
         case flavor is
            when 1 => crate.Iterate (Process => dump_list'Access);
            when 6 => crate.Iterate (Process => dump_extract_head_tail'Access);
            when others => null;
         end case;
      end send;

      procedure dump_list (position : list_crate.Cursor)
      is
         NDX : String := HT.USS (varname_prefix)  & "_" &
                         HT.USS (list_crate.Element (position).group) & LAT.Equals_Sign;
      begin
         send (NDX, True);
         list_crate.Element (position).list.Iterate (Process => print_item'Access);
         send ("");
      end dump_list;

      procedure dump_extract_head_tail (position : list_crate.Cursor)
      is
         NDX : String := HT.USS (varname_prefix)  & "_" &
                         HT.USS (list_crate.Element (position).group) & LAT.Equals_Sign;
      begin
         if not list_crate.Element (position).list.Is_Empty then
            send (NDX, True);
            list_crate.Element (position).list.Iterate (Process => print_item'Access);
            send ("");
         end if;
      end dump_extract_head_tail;

      procedure print_item (position : string_crate.Cursor)
      is
         index : Natural := string_crate.To_Index (position);
      begin
         if index > 1 then
            send (" ", True);
         end if;
         send (HT.USS (string_crate.Element (position)), True);
      end print_item;

      procedure dump_line (position : string_crate.Cursor) is
      begin
         send (HT.USS (string_crate.Element (position)));
      end dump_line;

      procedure dump_distfiles (position : string_crate.Cursor)
      is
         index : Natural := string_crate.To_Index (position);
         NDX   : String  := HT.USS (varname_prefix)  & "_" & HT.int2str (index) & LAT.Equals_Sign;
      begin
         send (NDX & HT.USS (string_crate.Element (position)));
      end dump_distfiles;

      procedure dump_ext_zip (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=/usr/bin/unzip -qo");
         send ("EXTRACT_TAIL_" & N & "=-d ${EXTRACT_WRKDIR_" & N & "}");
      end dump_ext_zip;

      procedure dump_ext_7z (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=7z x -bd -y -o${EXTRACT_WRKDIR_" & N & "} >/dev/null");
         send ("EXTRACT_TAIL_" & N & "=# empty");
      end dump_ext_7z;

      procedure dump_ext_lha (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("EXTRACT_HEAD_" & N & "=lha xfpw=${EXTRACT_WRKDIR_" & N & "}");
         send ("EXTRACT_TAIL_" & N & "=# empty");
      end dump_ext_lha;

      procedure dump_dirty_extract (position : string_crate.Cursor)
      is
         N : String := HT.USS (string_crate.Element (position));
      begin
         send ("DIRTY_EXTRACT_" & N & "=yes");
      end dump_dirty_extract;

      procedure dump_standard_target (target : String)
      is
         target_text : HT.Text := HT.SUS (target);
      begin
         if specs.make_targets.Contains (target_text) then
            send (target & LAT.Colon);
            specs.make_targets.Element (target_text).list.Iterate (Process => dump_line'Access);
            send ("");
         end if;
      end dump_standard_target;

      procedure dump_opsys_target (target : String)
      is
         os_target  : HT.Text := HT.SUS (target & LAT.Hyphen & UTL.lower_opsys (opsys));
         std_target : String := target & "-opsys";
      begin
         if specs.make_targets.Contains (os_target) then
            send (std_target & LAT.Colon);
            specs.make_targets.Element (os_target).list.Iterate (Process => dump_line'Access);
            send ("");
         end if;
      end dump_opsys_target;

   begin
      if not specs.variant_exists (variant) then
         TIO.Put_Line ("Error : Variant '" & variant & "' does not exist!");
         return;
      end if;

      if write_to_file then
        TIO.Create (File => makefile_handle,
                    Mode => TIO.Out_File,
                    Name => output_file);
      end if;

      --  TODO: Check these to see if they are actually used.
      --  The pkg manifests did use many of these, but they will be generated by ravenadm

      send ("# Makefile has been autogenerated by ravenadm tool" & LAT.LF);

      send ("NAMEBASE",         HT.USS (specs.namebase));
      send ("VERSION",          HT.USS (specs.version));
      send ("REVISION",         specs.revision, 0);
      send ("EPOCH",            specs.epoch, 0);
      send ("KEYWORDS",         specs.keywords);    --  probably remove
      send ("VARIANT",          variant);
      send ("DL_SITES",         specs.dl_sites);
      send ("DISTFILE",         specs.distfiles, 2);
      send ("DIST_SUBDIR",      specs.dist_subdir);
      send ("DISTNAME",         specs.distname);
      send ("DF_INDEX",         specs.df_index);
      send ("EXTRACT_ONLY",     specs.extract_only);
      send ("DIRTY_EXTRACT",    specs.extract_dirty, 7);
      send ("ZIP-EXTRACT",      specs.extract_zip, 3);
      send ("7Z-EXTRACT",       specs.extract_7z, 4);
      send ("LHA-EXTRACT",      specs.extract_lha, 5);
      send ("EXTRACT_HEAD",     specs.extract_head, 6);
      send ("EXTRACT_TAIL",     specs.extract_tail, 6);
      send ("NO_BUILD",         specs.skip_build, True);
      send ("BUILD_WRKSRC",     specs.build_wrksrc);
      send ("BUILD_TARGET",     specs.build_target);
      send ("MAKEFILE",         specs.makefile);
      send ("MAKE_ENV",         specs.make_env);
      send ("MAKE_ARGS",        specs.make_args);
      send ("CFLAGS",           specs.cflags);
      send ("CXXFLAGS",         specs.cxxflags);
      send ("CPPFLAGS",         specs.cppflags);
      send ("LDFLAGS",          specs.ldflags);
      send ("SINGLE_JOB",       specs.single_job, True);
      send ("DESTDIR_VIA_ENV",  specs.destdir_env, True);
      send ("DESTDIRNAME",      specs.destdirname);

      declare
         function get_phasestr (index : Positive) return String;
         function get_prefix   (index : Positive) return String;
         function get_phasestr (index : Positive) return String is
         begin
            case index is
               when 1 => return "fetch";
               when 2 => return "extract";
               when 3 => return "patch";
               when 4 => return "configure";
               when 5 => return "build";
               when 6 => return "install";
               when others => return "";
            end case;
         end get_phasestr;
         function get_prefix (index : Positive) return String is
         begin
            case index is
               when 1 => return "pre-";
               when 2 => return "do-";
               when 3 => return "post-";
               when others => return "";
            end case;
         end get_prefix;
      begin
         for phase in Positive range 1 .. 6 loop
            for prefix in Positive range 1 .. 3 loop
               declare
                  target : String := get_prefix (prefix) & get_phasestr (phase);
               begin
                  dump_standard_target (target);
                  dump_opsys_target (target);
               end;
            end loop;
         end loop;
      end;

      --  TODO: This is not correct, placeholder.  rethink.
      send (".include " & LAT.Quotation & "/usr/raven/share/mk/raven.mk" & LAT.Quotation);

      if write_to_file then
         TIO.Close (makefile_handle);
      end if;
   exception
      when others =>
         if TIO.Is_Open (makefile_handle) then
            TIO.Close (makefile_handle);
         end if;
   end generator;

end Port_Specification.Makefile;

Add support for generating standard and -opsys targets

the -option targets still need to be implemented.


-----------------------------------------------------------------------
--  encodes -- Encodes strings
--  Copyright (C) 2010, 2011 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.Encoders;

procedure Encodes is

   use Util.Encoders;

   Encode : Boolean := True;
   Count  : constant Natural := Ada.Command_Line.Argument_Count;

begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: encodes {encoder} [-d|-e] string...");
      Ada.Text_IO.Put_Line ("Encoders: " & Util.Encoders.BASE_64 & ", "
                            & Util.Encoders.BASE_64_URL & ", "
                            & Util.Encoders.BASE_16);
      return;
   end if;
   declare
      Name : constant String := Ada.Command_Line.Argument (1);
      C    : constant Encoder := Util.Encoders.Create (Name);
   begin
      for I in 2 .. Count loop
         declare
            S : constant String := Ada.Command_Line.Argument (I);
         begin
            if S = "-d" then
               Encode := False;
            elsif S = "-e" then
               Encode := True;
            elsif Encode then
               Ada.Text_IO.Put_Line ("Encodes " & Name & ": " & C.Encode (S));
            else
               Ada.Text_IO.Put_Line ("Decodes " & Name & ": " & C.Decode (S));
            end if;
         end;
      end loop;
   end;
end Encodes;

-----------------------------------------------------------------------
--  encodes -- Encodes strings
--  Copyright (C) 2010, 2011 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.Encoders;

procedure Encodes is

   use Util.Encoders;

   Encode : Boolean := True;
   Count  : constant Natural := Ada.Command_Line.Argument_Count;

begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: encodes {encoder} [-d|-e] string...");
      Ada.Text_IO.Put_Line ("Encoders: " & Util.Encoders.BASE_64 & ", "
                            & Util.Encoders.BASE_64_URL & ", "
                            & Util.Encoders.BASE_16 & ", "
                            & Util.Encoders.HASH_SHA1);
      return;
   end if;
   declare
      Name : constant String := Ada.Command_Line.Argument (1);
      C    : constant Encoder := Util.Encoders.Create (Name);
   begin
      for I in 2 .. Count loop
         declare
            S : constant String := Ada.Command_Line.Argument (I);
         begin
            if S = "-d" then
               Encode := False;
            elsif S = "-e" then
               Encode := True;
            elsif Encode then
               Ada.Text_IO.Put_Line ("Encodes " & Name & ": " & C.Encode (S));
            else
               Ada.Text_IO.Put_Line ("Decodes " & Name & ": " & C.Decode (S));
            end if;
         end;
      end loop;
   end;
end Encodes;

Add sha1 encoding

Add sha1 encoding