unit Robots;

interface

uses
   System.SysUtils, System.Classes, StrUtils;

type

   TxRobots = class
   private
      sRobots   : TStringList;
      sRules    : TStringList;
      FUserAgent: string;

      procedure ParseRules;

   public
      function URLisDisallow(AURL: string): boolean;

      constructor Create(ARobots: string; AUserAgent: string);
      destructor Destroy; override;
   end;

implementation

{ TxRobots }

constructor TxRobots.Create(ARobots: string; AUserAgent: string);
begin
   sRules := TStringList.Create;
   sRules.Sorted := true;

   sRobots := TStringList.Create;
   sRobots.Text := ARobots;
   FUserAgent := AUserAgent;
   ParseRules;
end;

destructor TxRobots.Destroy;
begin
   if Assigned(sRobots) then
      sRobots.Free;
   sRules.Free;
end;

procedure TxRobots.ParseRules;
var
   i, j: integer;
   tmp : string;
begin
   for i := 0 to sRobots.Count - 1 do
   begin
      // Чекаем наш user-agent
      if pos('user-agent:', LowerCase(sRobots[i])) > 0 then
      begin
         // Проверка на комментарии
         if pos('#', tmp) > 0 then
            tmp := Trim(Copy(tmp, 1, pos('#', tmp) - 1));

         // убрали директиву
         tmp := Trim(StringReplace(sRobots[i], 'user-agent:', '', [rfIgnoreCase]));

         // Если наш user-agent
         if tmp = FUserAgent then
            Break;
      end;
   end;

   for j := i + 1 to sRobots.Count - 1 do
   begin
      // Если строка не пустая и не начинается с комментария
      if (Trim(sRobots[j]) <> '') AND (Trim(sRobots[j])[1] <> '#') then
      begin
         tmp := sRobots[j];

         // Если в строке есть комментарии - удаляем, на случай если в комментарии будут ключевые директивы
         if pos('#', tmp) > 0 then
            tmp := Trim(Copy(tmp, 1, pos('#', tmp) - 1));

         // Если правило запрещающее
         if pos('disallow', LowerCase(tmp)) > 0 then
            sRules.AddObject(Trim(StringReplace(tmp, 'disallow:', '', [rfIgnoreCase])), TObject(0))

            // Если правило разрешающее
         else if pos('allow', LowerCase(tmp)) > 0 then
            sRules.AddObject(Trim(StringReplace(tmp, 'allow:', '', [rfIgnoreCase])), TObject(1))
         else
            Break; // Если директивы указанной секции кончились
      end;
   end;
end;

function TxRobots.URLisDisallow(AURL: string): boolean;
var
   i, j      : integer;
   st        : TStringList;
   xURL      : string;
   xRules    : string;
   isRightStr: boolean;
   isFind    : boolean;
begin
   Result := false;
   isFind := false;

   st := TStringList.Create;
   st.Delimiter := '*';

   for i := sRules.Count - 1 downto 0 do
   begin
      if isFind then // Если правило для URL найдено
         Break;

      xURL := AURL;
      isRightStr := false; // Наличие символа $

      st.DelimitedText := sRules[i]; // Текущее правило
      for j := 0 to st.Count - 1 do
      begin
         if st[j] = '' then
            Continue;

         xRules := st[j];
         isRightStr := RightStr(xRules, 1) = '$';
         if isRightStr then                    // Если найден $ в конце
            Delete(xRules, Length(xRules), 1); // убираем

         if pos(xRules, xURL) > 0 then // Если в URL найдено правило
         begin
            Delete(xURL, 1, pos(xRules, xURL) + Length(xRules) - 1); // Удаляем то, что проверили
            isFind := NOT(isRightStr AND (xURL <> '')); // Если найден ограничитель $, но URL не конечный
            Continue;
         end
         else
         begin
            isFind := false;
            Break;
         end;
      end;
   end;

   if isFind then
      Result := integer(sRules.Objects[i]) = 0; // Если правило найдено, возвращаем Allow или Disallow
end;

end.

   TxRules = record
      isSingle: boolean;
      isStrict: boolean;
      isDisallow: boolean;
      Rules: array of string;
   end;

   xRules: array of TxRules;



function TxRobots.isDisallow(aURL: string): boolean;
var
   i, j, N, R: integer;
   isFind    : boolean;
   isLast    : boolean;
begin
   R := 1;
   isFind := false;
   
   for i := Low(xRules) to High(xRules) do
   begin
   
      if xRules[i].isSingle then // Если правило без подстановки
      begin
         if xRules[i].isStrict then // Если стоит ограничитель $
            isFind := (StartsStr(xRules[i].Rules[0], aURL)) AND ((Length(xRules[i].Rules[0]) = Length(aURL))) // Проверяем на точное совпадение
         else
            isFind := (StartsStr(xRules[i].Rules[0], aURL)); // Иначе на вхождение
      end      
      else
      begin   
             
         for j := Low(xRules[i].Rules) to High(xRules[i].Rules) do // Если есть подстановка *
         begin
            isFind := false;              
            if (j = 0) then // Проверяем первое вхождение
            begin
               if (xRules[i].Rules[0] <> '') then // Если первый символ не знак подстановки *
               begin
                  isFind := StartsStr(xRules[i].Rules[0], aURL); // Проверяем начальное вхождение
                  R := Length(xRules[i].Rules[0]) + 1; // Запоминаем позицию
               end
               else
                  Continue;
            end             
            else
            begin              
               N := PosEx(xRules[i].Rules[j], aURL, R); // Ищем вхождение 
               if N > 0 then
               begin
                  R := N;
                  isLast := (j = High(xRules[i].Rules)) AND (xRules[i].isStrict); // Если у правила есть ограничитель $
                  isFind := NOT(isLast AND (Length(aURL) - R + 1 <> Length(xRules[i].Rules[j]))); // Если есть ограничитель, но URL не кончился
               end;                  
            end;      
                        
            if NOT isFind then
               Break;                     
         end; 
      end; 
      
      if isFind then
      begin
         isFind := xRules[i].isDisallow;
         Break;
      end;        
   end;
   
   Result := isFind;
end;