File : adagio-searches-hit_family.adb
------------------------------------------------------------------------------
-- ADAGIO - ADALID - AENEA. --
-- --
-- Copyright (C) 2003 --
-- A. Mosteo. --
-- --
-- Authors: A. Mosteo. (adagio@mosteo.com) --
-- --
-- If you have any questions in regard to this software, please address --
-- them to the above email. --
-- --
-- This program is free software; you can redistribute it and/or modify --
-- it under the terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 2 of the License, or (at --
-- your option) any later version. --
-- --
-- This program is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public License --
-- along with this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- You are not allowed to use any part of this code to develop a program --
-- whose output would be used to harass or prosecute other users of the --
-- networks Adagio connects with. All data collected with Adagio or a tool --
-- containing Adagio code about other network users must remain --
-- confidential and cannot be made public by any mean, nor be used to --
-- harass or legally prosecute these users. --
------------------------------------------------------------------------------
-- $Id: adagio-upload.ads,v 1.4 2004/01/21 21:05:51 Jano Exp $
-- Root package for all search packages
with Adagio.Convert;
with Adagio.G2.Hit;
with Adagio.Misc;
with Adagio.Trace;
with Agpl.Counter.Multi;
with Agpl.Sequence;
with Agpl.Strings;
with Aws.Url;
with Ada.Tags; use Ada.Tags;
with Ada.Unchecked_Deallocation;
package body Adagio.Searches.Hit_Family is
package Id_Sequence is new Agpl.Sequence (Family_Id);
Ids : Id_Sequence.Object;
------------------------------------------------------------------------
-- Add_Hit --
------------------------------------------------------------------------
-- Adds a hit. It must be compatible
procedure Add_Hit (This : in out Object; H : in Hit.Object'Class) is
New_Hit : Hit.Object_Access := new Hit.Object'Class'(H);
Success : Boolean;
J : Hit_Map.Iterator_Type;
begin
-- Merge hits just in case
Hash_Dictionary.Merge (This.Hashes, Hit.Get_Hashes (H));
-- Add the hit
Hit_Map.Insert (This.Hits, Hit.Get_Id (H), New_Hit, J, Success);
if not Success then
Hit.Free (New_Hit);
Trace.Log ("FAILED HIT ADDITION: " & Hit.Get_Id (H), Trace.Always);
end if;
exception
when E : others =>
Trace.Log ("Hit_Family.Add_Hit: " & Trace.Report (E), Trace.Error);
Hit.Free (New_Hit);
end Add_Hit;
------------------------------------------------------------------------
-- Contains --
------------------------------------------------------------------------
function Contains (This : in Object; H : in Hit.Object'Class) return Boolean is
use Hit_Map;
begin
return Is_In (Hit.Get_Id (H), This.Hits);
end;
------------------------------------------------------------------------
-- Create --
------------------------------------------------------------------------
-- A seed hit is needed
procedure Create (This : out object; From : in Hit.Object'Class) is
New_Hit : Hit.Object_Access := new Hit.Object'Class'(From);
begin
Ids.Get_Next (This.Id);
This.Name := U (Hit.Get_Name (From));
This.Size := Hit.Get_Size (From);
This.Hashes := Hit.Get_Hashes (From);
Hit_Map.Insert (This.Hits, Hit.Get_Id (From), New_Hit);
exception
when E : others =>
Trace.Log ("Hit_Family.Create: " & Trace.Report (E), Trace.Error);
Hit.Free (New_Hit);
end Create;
------------------------------------------------------------------------
-- Equal --
------------------------------------------------------------------------
function Equal (L, R : in Object) return Boolean is
begin
return L.Id = R.Id;
end Equal;
------------------------------------------------------------------------
-- Free --
------------------------------------------------------------------------
procedure Free (This : in out Object_Access) is
procedure Del is new Unchecked_Deallocation (Object, Object_Access);
begin
Del (This);
end Free;
------------------------------------------------------------------------
-- Finalize --
------------------------------------------------------------------------
procedure Finalize (This : in out Object) is
use Hit_Map;
I : Iterator_Type := First (This.Hits);
begin
while I /= Back (This.Hits) loop
Hit.Free (Element (I));
I := Succ (I);
end loop;
end Finalize;
------------------------------------------------------------------------
-- Get_Id --
------------------------------------------------------------------------
-- Get an unique id for the family (meaningless, for indexing)
function Get_Id (This : in Object) return String is
begin
return Agpl.Strings.Trim (This.Id'Img);
end Get_Id;
------------------------------------------------------------------------
-- Get_Link --
------------------------------------------------------------------------
-- Will provide a link for the hit
-- Will try to get a Sha1 magnet and if not, a ed2k link
-- May raise No_Such_Hash if none of the two available
function Get_Link (This : in Object) return String is
begin
return Get_Magnet (This);
end Get_Link;
------------------------------------------------------------------------
-- Get_Magnet --
------------------------------------------------------------------------
-- Will try to get a magnet link for sha1 hashes
-- Raise No_Such_Hash if unable to obtain it
function Get_Magnet (This : in Object) return String is
use Hash_Dictionary;
Hashes : Pair_Array := Get_Contents (This.Hashes);
begin
for I in Hashes'Range loop
if S (Hashes (I).Key) = "sha1" then
return
"magnet:?xt=urn:sha1:" &
S (Hashes (I).Value) &
"&dn=" & Aws.Url.Encode (S (This.Name));
end if;
end loop;
raise No_Such_Hash;
end Get_Magnet;
------------------------------------------------------------------------
-- Has_New_Hits --
------------------------------------------------------------------------
function Has_New_Hits (This : in Object) return Boolean is
use Hit_Map;
I : Iterator_Type := First (This.Hits);
begin
while I /= Back (This.Hits) loop
if Hit.Is_New (Element (I).all) then
return true;
end if;
I := Succ (I);
end loop;
return false;
end Has_New_Hits;
------------------------------------------------------------------------
-- Is_Compatible --
------------------------------------------------------------------------
-- Says if a hit is compatible with this family
function Is_Compatible (This : in Object; H : in Hit.Object'Class) return Boolean is
begin
return Hash_Dictionary.Are_Compatible (
This.Hashes,
Hit.Get_Hashes (H));
end Is_Compatible;
------------------------------------------------------------------------
-- Num_Firewalled_Hits --
------------------------------------------------------------------------
function Num_Firewalled_Hits (This : in Object) return Natural is
use Hit_Map;
I : Iterator_Type := First (This.Hits);
Num : Natural := 0;
begin
while I /= Back (This.Hits) loop
if Hit.Is_Firewalled (Element (I).all) then
Num := Num + 1;
end if;
I := Succ (I);
end loop;
return Num;
end Num_Firewalled_Hits;
------------------------------------------------------------------------
-- Num_Hits --
------------------------------------------------------------------------
function Num_Hits (This : in Object) return Natural is
begin
return Hit_Map.Length (This.Hits);
end Num_Hits;
------------------------------------------------------------------------
-- Num_New_Hits --
------------------------------------------------------------------------
function Num_New_Hits (This : in Object) return Natural is
use Hit_Map;
I : Iterator_Type := First (This.Hits);
Num : Natural := 0;
begin
while I /= Back (This.Hits) loop
if Hit.Is_New (Element (I).all) then
Num := Num + 1;
end if;
I := Succ (I);
end loop;
return Num;
end Num_New_Hits;
------------------------------------------------------------------------
-- Set_Expanded --
------------------------------------------------------------------------
procedure Set_Expanded (This : in out Object; Expanded : in Boolean := true) is
begin
This.Expanded := Expanded;
end Set_Expanded;
------------------------------------------------------------------------
-- Http_Report --
------------------------------------------------------------------------
procedure Http_Report (This : in out Object; Data : in out Data_Set) is
use Hit_Map;
I : Iterator_Type := First (This.Hits);
NHits : Natural := Length (This.Hits);
Extra : Ustring;
use ASU;
begin
if NHits = 1 then
Extra := U (Hit.Get_Extra (Element (First (This.Hits)).all));
end if;
-- Get common name, size, extras:
declare
Names, Sizes : Agpl.Counter.Multi.Object;
I : Iterator_Type := First (This.Hits);
package MCounter renames Agpl.Counter.Multi;
Aux_Hit : G2.Hit.Object;
Inited : Boolean := false;
begin
while I /= Back (This.Hits) loop
-- Merge extra info
if Element (I).all'Tag = G2.Hit.Object'Tag then
if Inited then
G2.Hit.Merge (Aux_Hit, G2.Hit.Object (Element (I).all));
else
Aux_Hit := G2.Hit.Object (Element (I).all);
Inited := true;
end if;
end if;
-- Name & Size
MCounter.Add (Names, Hit.Get_Name (Element (I).all));
MCounter.Add (Sizes, File_Size'Image (Hit.Get_Size (Element (I).all)));
I := Succ (I);
end loop;
This.Name := U (MCounter.Max_Key (Names));
This.Size := File_Size'Value (MCounter.Max_Key (Sizes));
if Extra = Null_Ustring and then Inited then
Extra := U (G2.Hit.Get_Extra (Aux_Hit));
end if;
end;
-- Firstly, the family header
declare
Row : Data_Row;
Prefix : constant String := S (Rpad (Natural (This.Id))) & "1";
begin
-- Hits
Append (Row, (
U (Misc.To_String (Num_Hits (This))),
U (S (Rpad (Num_Hits (This))) & Prefix)));
-- New hits
Append (Row, (
U (Misc.To_String (Num_New_Hits (This))),
U (S (Rpad (Num_New_Hits (This))) & Prefix)));
-- Fwd hits
Append (Row, (
U (Misc.To_String (Num_Firewalled_Hits (This))),
U (S (Rpad (Num_Firewalled_Hits (This))) & Prefix)));
-- Name
Append (Row, (
This.Name,
U (S (This.Name) & Prefix)));
-- Size
Append (Row, (
U (Convert.To_Size (This.Size)),
U (S (Rpad (This.Size)) & Prefix)));
-- Extra
Append (Row, (Extra, Extra & U (Prefix)));
-- Hit?
Append (Row, (
U (Boolean'Image (false)),
U (Boolean'Image (false) & Prefix)));
-- Expanded?
Append (Row, (
U (Boolean'Image (This.Expanded)),
U (Boolean'Image (This.Expanded) & Prefix)));
-- Id
Append (Row, (
U (Misc.To_String (Natural (This.Id))),
U (Misc.To_String (Natural (This.Id)) & Prefix)));
-- Magnet
Append (Row, (
U (Get_Link (This)),
U (Get_Link (This) & Prefix)));
Append (Data, Row);
end;
-- Hits
declare
Prefix : constant String := S (Rpad (Natural (This.Id))) & "0";
Nums : array (Boolean) of Natural := (false => 0, true => 1);
begin
while I /= Back (This.Hits) loop
declare
Row : Data_Row;
H : Hit.Object'Class renames Element (I).all;
begin
if This.Expanded then
-- Hits
Append (Row, (
Null_Ustring,
U (S (Rpad (Num_Hits (This))) & Prefix)));
-- New hits
Append (Row, (
U (Misc.To_String (Nums (Hit.Is_New (H)))),
U (S (Rpad (Num_New_Hits (This))) &
Prefix & S (Rpad (Nums (Hit.Is_New (H)), 2)))));
-- Fwd hits
Append (Row, (
U (Misc.To_String (Nums (Hit.Is_Firewalled (H)))),
U (S (Rpad (Num_Firewalled_Hits (This))) &
Prefix & S (Rpad (Nums (Hit.Is_Firewalled (H)), 2)))));
-- Name
Append (Row, (
U (Hit.Get_Name (H)),
U (S (This.Name) & Prefix & Hit.Get_Name (H))));
-- Size
Append (Row, (
U (Convert.To_Size (Hit.Get_Size (H))),
U (S (Rpad (This.Size)) & Prefix & S (Rpad (Hit.Get_Size (H))))));
-- Extra
Append (Row, (
U (Hit.Get_Extra (H)),
Extra & Prefix & Hit.Get_Extra (H)));
-- Hit?
Append (Row, (
U (Boolean'Image (true)),
U (Boolean'Image (false) & Prefix & Boolean'Image (true))));
-- Expanded?
Append (Row, (
U (Boolean'Image (This.Expanded)),
U (Boolean'Image (This.Expanded) & Prefix &
Boolean'Image (This.Expanded))));
-- Id
Append (Row, (
U (Misc.To_String (Natural (This.Id))),
U (Misc.To_String (Natural (This.Id)) & Prefix)));
-- Magnet
Append (Row, (
U (Get_Link (This)),
U (Get_Link (This) & Prefix)));
Append (Data, Row);
end if;
Hit.Set_New (H, false);
end;
I := Succ (I);
end loop;
end;
end Http_Report;
end Adagio.Searches.Hit_Family;