seo-include/FWURLPosition.pas

unit FWURLPosition;

interface

uses
  SysUtils,
  Windows,
  WinInet;

type
  TDynByteArray = array of Byte;

  TAdvancedInteger = record
    LowPart, HighPart: Integer;
  end;

  TFWUrlCounter = (ucAlexa, ucGoogle, ucYandex);
  TFWUrlCounters = set of TFWUrlCounter;

  TFWURLPosition = class
  private
    FYandexTIC, FGooglePR, FAlexaRank: Integer;
  protected
    function PageRankCheckSum(const URL: string): string;
  protected
    function DelHttp(URL: String): String;
    function GetUrl(const URL: String): String;
    procedure GetYandexTIC(URL: String);
    procedure GetGooglePR(URL: String);
    procedure GetAlexaRank(URL: String);
  public
    constructor Create;
    procedure GetURLPosition(URL: String; Counters: TFWUrlCounters);
    property AlexaRank: Integer read FAlexaRank;
    property GooglePR: Integer read FGooglePR;
    property YandexTIC: Integer read FYandexTIC;
  end;

implementation

{ TFWURLPosition }

constructor TFWURLPosition.Create;
begin
  FAlexaRank := -1;
  FGooglePR := -1;
  FYandexTIC := -1;
end;

function TFWURLPosition.DelHttp(URL: String): String;
begin
  if Pos('http://', URL) > 0 then
    Delete(URL, 1, 7);
  Result := Copy(URL, 1, Pos('/', URL) - 1);
  if Result = '' then
    Result := URL;
end;

procedure TFWURLPosition.GetAlexaRank(URL: String);
const
  Request = 'http://data.alexa.com/data?cli=10&dat=snbamz&url=';
  http = 'http://';
var
  XMLData: String;
  AlexaRank: Integer;
begin
  URL := DelHttp(URL);
  XMLData := GetUrl(Request + URL);
  AlexaRank := Pos('REACH RANK="', XMLData);
  try
    if AlexaRank = 0 then
      Abort;
    Delete(XMLData, 1, AlexaRank + 11);
    AlexaRank := Pos('"', XMLData);
    if AlexaRank = 0 then
      Abort;
    FAlexaRank := StrToInt(Copy(XMLData, 1, AlexaRank - 1));
  except
    FAlexaRank := -1;
  end;
end;

function ConvertStrToInt(pStr: PAnsiChar; Init, Factor: Integer): Integer;
begin
  Result := Init;
  while pStr^<>#0 do
  begin
    Result := Result*Factor;
    inc(Result, ord(pStr^));
    inc(pStr);
  end;
end;

function HashURL(pStr: PAnsiChar): Integer;
var
  C1, C2, T1, T2: Cardinal;
begin
  C1 := ConvertStrToInt(pStr, $1505, $21);
  C2 := ConvertStrToInt(pStr, 0, $1003F);
  C1 := C1 shr 2;
  C1 := ((C1 shr 4) and $3FFFFC0) or (C1 and $3F);
  C1 := ((C1 shr 4) and $3FFC00) or (C1 and $3FF);
  C1 := ((C1 shr 4) and $3C000) or (C1 and $3FFF);

  T1 := (C1 and $3C0) shl 4;
  T1 := T1 or (C1 and $3C);
  T1 := (T1 shl 2) or (C2 and $F0F);

  T2 := (C1 and $FFFFC000) shl 4;
  T2 := T2 or (C1 and $3C00);
  T2 := (T2 shl $A) or (C2 and $F0F0000);

  Result := Integer(T1 or T2);
end;

function CheckHash(HashInt: Cardinal): AnsiChar;
var
  Check, Remainder: Integer;
  Flag: Boolean;
begin
  Check := 0;
  Flag := False;
  repeat
    Remainder := HashInt mod 10;
    HashInt := HashInt div 10;
    if Flag then
    begin
      inc(Remainder, Remainder);
      Remainder := (Remainder div 10) + (Remainder mod 10);
    end;
    inc(Check, Remainder);
    Flag := not Flag;
  until HashInt=0;

  Check := Check mod 10;
  if Check<>0 then
  begin
    Check := 10-Check;
    if Flag then
    begin
      if (Check mod 2)=1 then
        inc(Check, 9);
      Check := Check shr 1;
    end;
  end;
  inc(Check, $30);
  Result := AnsiChar(Check);
end;

function TFWURLPosition.PageRankCheckSum(const URL: string): string;
var
  HashInt: Cardinal;
begin
  HashInt := Cardinal(HashURL(PAnsiChar(AnsiString(URL))));
  Result := Format('7%s%u', [CheckHash(HashInt), HashInt]);
end;

procedure TFWURLPosition.GetGooglePR(URL: String);
const
  Request = 'http://toolbarqueries.google.com/tbr?client=navclient-auto&ch=%s&features=Rank&q=info:%s';
  http = 'http://';
var
  XMLData, AResult: String;
  Checksum: String;
  DataPos: Integer;
begin
  if Pos('http://', URL) > 0 then
    Delete(URL, 1, 7);
  try
    Checksum := PageRankCheckSum(URL);
    XMLData := GetUrl(Format(Request, [Checksum, URL]));
    DataPos := Pos('RANK_', UpperCase(XMLData));
    if DataPos = 0 then
    begin
      FGooglePR := 0;
      Exit;
    end;
    Delete(XMLData, 1, DataPos + 6);
    DataPos := Pos(':', UpperCase(XMLData));
    Delete(XMLData, 1, DataPos);
    AResult := XMLData[1];
    if Length(XMLData) > 1 then
      if XMLData[2] = '0' then
        AResult := AResult + '0';
    FGooglePR := StrToInt(AResult);
  except
    FGooglePR := -1;
  end;
end;

function TFWURLPosition.GetUrl(const URL: String): String;
const
  HTTP_PORT = 80;
  Header = 'Content-Type: application/x-www-form-urlencoded' + sLineBreak;
var
  FSession, FConnect, FRequest: HINTERNET;
  FHost, FScript: String;
  Buff: array [0 .. 1023] of Char;
  BytesRead: Cardinal;
begin
  Result := '';
  FHost := DelHttp(URL);
  FScript := URL;
  Delete(FScript, 1, Pos(FHost, FScript) + Length(FHost));
  FSession := InternetOpen('DMFR', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if not Assigned(FSession) then
    Exit;
  try
    FConnect := InternetConnect(FSession, PChar(FHost), HTTP_PORT, nil, 'HTTP/1.0', INTERNET_SERVICE_HTTP, 0, 0);
    if not Assigned(FConnect) then
      Exit;
    try
      FRequest := HttpOpenRequest(FConnect, 'GET', PChar(FScript), 'HTTP/1.0', '', nil, INTERNET_FLAG_RELOAD, 0);
      if not Assigned(FConnect) then
        Exit;
      try
        if not(HttpAddRequestHeaders(FRequest, Header, Length(Header), HTTP_ADDREQ_FLAG_REPLACE or HTTP_ADDREQ_FLAG_ADD)) then
          Exit;
        if not(HttpSendRequest(FRequest, nil, 0, nil, 0)) then
          Exit;
        FillChar(Buff, SizeOf(Buff), 0);
        repeat
          Result := Result + String(PAnsiChar(@Buff));
          FillChar(Buff, SizeOf(Buff), 0);
          InternetReadFile(FRequest, @Buff, SizeOf(Buff), BytesRead);
        until BytesRead = 0;
      finally
        InternetCloseHandle(FRequest);
      end;
    finally
      InternetCloseHandle(FConnect);
    end;
  finally
    InternetCloseHandle(FSession);
  end;
end;

procedure TFWURLPosition.GetURLPosition(URL: String; Counters: TFWUrlCounters);
begin
  if ucAlexa in Counters then
    GetAlexaRank(URL);
  if ucGoogle in Counters then
    GetGooglePR(URL);
  if ucYandex in Counters then
    GetYandexTIC(URL);
end;

procedure TFWURLPosition.GetYandexTIC(URL: String);
const
  Request = 'http://bar-navig.yandex.ru/u?ver=2&show=32&url=';
  http = 'http://';
var
  XMLData: String;
  TIC: Integer;
begin
  if LowerCase(Copy(URL, 1, 7)) <> http then
    URL := http + URL;
  XMLData := GetUrl(Request + URL);
  TIC := Pos('value="', XMLData);
  try
    if TIC = 0 then
      Abort;
    Delete(XMLData, 1, TIC + 6);
    TIC := Pos('"', XMLData);
    if TIC = 0 then
      Abort;
    FYandexTIC := StrToInt(Copy(XMLData, 1, TIC - 1));
  except
    FYandexTIC := -1;
  end;
end;

end.