сканирование сайта

[sasha0808]

Добрый день.
Как сделать чтоб вводишь URL сайта а тебе выдавало все найденные внутренние страницы на сайте?
я вроде написал, но работает некорректно.
пробовал писать не главную страницу а ссылку на карту сайта, в этом случае количество найденных ссылок правильно пишет, а выводит только 1!

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, StdCtrls, RegExpr, XPMan;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    IdHTTP1: TIdHTTP;
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    SaveDialog1: TSaveDialog;
    Label2: TLabel;
    Label3: TLabel;
    procedure Linker(URL:String);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  Checked,Remain:TStringlist;

procedure TForm1.Linker(URL:String);
var
  Cache,link: string;
  i:integer;
  reg: TRegExpr;
begin

  try
  Cache:=Form1.IdHttp1.Get(URL);
  reg:=TRegExpr.Create;
    reg.Expression:='(?i)(href=)([^ >]+)';
    if reg.Exec(Cache) then
    begin
      repeat
        link:=reg.Match[0];
        delete(link,1,5);
        for i:=1 to length(link) do
        begin
          if link[i]='"' then delete(link,i,1);
          if ord(link[i])=39 then delete(link,i,1);
        end;
        if  ((link[1]='/')or (link[1]='\')) then
          link:=Form1.Edit1.text+link;
        if  ((link[1]<>'/') and (link[1]<>'\')) and (pos('http://',link)=0) then
          link:=Form1.Edit1.text+'/'+link;
       if (pos('mailto:',link)=0) and (pos('ftp://',link)=0) and
          (pos(Form1.edit1.text,link)<>0) and (pos(link,checked.Text)=0) then
            begin
             Checked.Add(link);
             Form1.Memo1.lines.Add(link);
             linker(link);
            end;
      until not reg.ExecNext;
    end;
  finally
    reg.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
linker(edit1.text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Checked:=TStringList.create;
Remain:=TStringList.create;
end;



procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
Form1.Memo1.Lines.SaveToFile(Form1.SaveDialog1.FileName + '.');
end;

end.

[Stilet]

delete(link,1,5);

А зачем это? Если делать по старинке без регулярок, то:

Cache:=Form1.IdHttp1.Get(URL);
i:=pos('href="',Cache);
while i<>0 do begin
 delete(Cache,1,i+6);
 i:=pos('"',Cache);
 Checked.Add(copy(Cache,1,i-1));
 i:=pos('href="',Cache);
end;

[sasha0808]

Немного доработал. там выдавало ошибку и процесс не происходил.
вот доработанный код, но проблема все равно осталась.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, StdCtrls, RegExpr, XPMan;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    IdHTTP1: TIdHTTP;
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    SaveDialog1: TSaveDialog;
    Label2: TLabel;
    Label3: TLabel;
    procedure Linker(URL:String);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  Checked,Remain:TStringlist;

procedure TForm1.Linker(URL:String);
var
  Cache,link: string;
  n,i:integer;
  reg: TRegExpr;
begin
  Cache:=IdHttp1.Get(URL);
  Checked.Add(url);
  Memo1.Lines.Add(url);
  reg:=TRegExpr.Create;
  memo1.Clear;
  n:=0;
  try
    reg.Expression:='<a[^>]+href=([^ >]+)';
    if reg.Exec(Cache) then begin
      repeat
        link:=reg.Match[0];
        //Äîðàáàòûâàåì ññûëêó
        if (ord(link[length(link)])=39) or (link[length(link)]='"')
        or (link[length(link)]=' ') or (link[length(link)]='>') then
          delete(link,length(link),1);
        delete(link,1,pos('href=',link)+4);
        if (ord(link[1])=39) or (link[1]='"')
        or (link[1]=' ') or (link[1]='>') then
          delete(link,1,1);
        //Äîáàâëÿåì íà÷àëî ñàéòà
        if (pos('http://',link)=0) and ((link[1]='\') or (link[1]='/')) then link:=Edit1.Text+link;
        if (pos('http://',link)=0) and (link[1]<>'\') and (link[1]<>'/') and (Edit1.Text[length(edit1.text)]<>'/') then link:=Edit1.Text+'/'+link;
        //Ïîñëåäíÿÿ ïðîâåðêà è
           äîáàâëÿåì â ìåìî
        if (pos('mailto:',link)=0) and (pos(edit1.text,link)<>0) then
          if (pos(link,checked.Text)=0) and (pos(link,remain.Text)=0) then
            Remain.Add(link);
        n:=n+1;
      until not reg.ExecNext;
    end else
      Memo1.Lines.Add('Ññûëêè íå íàéäåíû!');
  finally
    reg.Free;
  end;
  Label3.Caption:=IntToStr(n);
  Cache:='';
if remain.Count<>0 then
  for i:=0 to remain.Count-1 do
   Memo1.Lines.Add(remain[i]);
    //linker(remain[i]);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
linker(edit1.text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Checked:=TStringList.create;
Remain:=TStringList.create;
end;



procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
Form1.Memo1.Lines.SaveToFile(Form1.SaveDialog1.FileName + '.');
end;

end.

[Stilet]

Я правильно понял - регулярками принципиально?

[sasha0808]

Сообщение от Stilet

Я правильно понял - регулярками принципиально?

нет не принципиально, я просто не понял что вы предлагаете!?

[Stilet]

Я предлагаю все что у тебя между repeat...until выкинуть
Замену я предложил выше.

[sasha0808]

Stilet, в таком случае программа вообще виснет, и только снятие задачи через диспетчер помогает!

[Stilet]

Дай угадаю: отладка - зло?
Хотя бы покажи как переделал, может копипасте втупую подгадило ))

[sasha0808]

Сейчас программа возвращает урл тот который вводишь

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdHTTP, StdCtrls, RegExpr, XPMan;

type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
IdHTTP1: TIdHTTP;
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
SaveDialog1: TSaveDialog;
Label2: TLabel;
Label3: TLabel;
procedure Linker(URL:String);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

var
Checked,Remain:TStringlist;

procedure TForm1.Linker(URL:String);
var
Cache,link: string;
n,i:integer;
reg: TRegExpr;
begin
Cache:=IdHttp1.Get(URL);
Checked.Add(url);
Memo1.Lines.Add(url);
reg:=TRegExpr.Create;

n:=0;
try
reg.Expression:='<a[^>]+href=([^ >]+)';
if reg.Exec(Cache) then begin
repeat
Cache:=Form1.IdHttp1.Get(URL);
i:=pos('href="',Cache);
while i<>0 do begin
delete(Cache,1,i+6);
i:=pos('"',Cache);
Checked.Add(copy(Cache,1,i-1));
i:=pos('href="',Cache);
end;
until not reg.ExecNext;
end else
Memo1.Lines.Add('!');
finally
reg.Free;
end;
Label3.Caption:=IntToStr(n);
Cache:='';
if remain.Count<>0 then
for i:=0 to remain.Count-1 do
Memo1.Lines.Add(remain[i]);
//linker(remain[i]);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
linker(edit1.text);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Checked:=TStringList.create;
Remain:=TStringList.create;
end;



procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
Form1.Memo1.Lines.SaveToFile(Form1. SaveDialog1.FileName + '.');
end;

end.

В общем я хочу сделать чтоб все адреса вытаскивала программа вместе с title страницы

[sasha0808]

Кто поможет написать такую программу?