[Source] InfoServer v2.0

[whit3_sh4rk]

Olá, deu um trabalhinho formatar para que parecesse igual no delphi, algumas partes negritas e talz, mas é para a melhor visualização.

Irei explicar a parte que foi incrementada na versão 2.0, pois a outra já foi explicada em outro post.

Aqui vai uma screenshot:


Por trás do LLista, foi colocado uma outra listbox com o nome de LInfo, será usada ocultamente mais adiante.
O componente ao lado direito do iHTTP, chama-se idAntiFreeze, e é utilizado para evitar travamentos do iHTTP.

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, StrUtils, ExtCtrls, ScktComp, IdBaseComponent,
  IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, IdAntiFreezeBase,
  IdAntiFreeze;

var
  ThreadSID, ThreadSHandle : Cardinal;
  O_F: integer;

Variáveis:
ThreadSID será usado no parâmetro de criação da thread.
ThreadSHandle será usado para identificar a thread criada, para que assim eu possa finalizar a correta caso houvesse várias, por exemplo.

Para saber mais sobre os parâmetros da API CreateThread, acesse:
MSDN - CreateThread

function FURL (Site : String) : String;
var
PNome : String;
begin
PNome := '';
if pos ('/', Site) <> 0 then
PNome := copy (Site, 1, pos ('/', Site) - 1);
Result := PNome;
end;

Função FURL:
Se estiver um site assim:
http://www.site.com/path/lala/index.jsp
Ficará
http://www.site.com

procedure TfrmLS.iHTTPStatus(ASender: TObject; const AStatus: TIdStatus;
  const AStatusText: String);
begin
O_F:=0;
if AStatusText = 'Disconnected.' then
Inc(O_F);
end;

procedure TfrmLS.TTimer(Sender: TObject);
begin
if O_F = 1 then
begin
LLista.ItemIndex:=LLista.ItemIndex+1;
MassIS;
end
else
end;

iHTTP - OnStatus:
Coloquei para confirmar quando realmente a conexão for terminada, para assim partir para o próximo site da lista.
Se tiver desconectado o valor de O_F será 1.

T - OnTimer:
Tentei usar o procedimento que está no timer no evento OnStatus do iHTTP, só que não funcionou, então tive que colocar separadamente.
Caso O_F seja 1, significa que já desconectou, então ele executa o processo de "scan" para o próximo item da lista. Se não houver desconectado nada é efeito e após 2seg(intervalo do timer), ele volta fazer esse procedimento.

procedure TfrmLS.lbCClick(Sender: TObject);
begin
if FileExists(ExtractFilePath(ParamStr(0))+'Lista.txt') then
begin
LLista.Items.LoadFromFile('Lista.txt');
LLista.Enabled:=true;
bIniciar.Enabled:=true;
lbL.Enabled:=true;
lbT.Enabled:=true;
lbStatus.Color:=clGreen;
lbStatus.Caption:='Lista carregada!';
end else begin
lbStatus.Color:=clRed;
lbStatus.Caption:='Lista não encontrada!';
MessageBox(0,PChar('Não foi encontrado a lista em:'+#13#10+ExtractFilePath(ParamStr(0))+'Lista.txt'),PChar('Erro'),MB_ICONERROR);
end;
end;

lbC - Evento OnClick:
Verifica se a lista de sites existe, se existir, carrega-a dentro do listbox(LLista).

procedure TfrmLS.lbTClick(Sender: TObject);
begin
lbStatus.Color:=clNavy;
lbStatus.Caption:='Essa lista contém '+IntToStr(LLista.Count)+' sites.';
end;

lbT - Evento OnClick:
Mostra o número de linhas que existe no listbox LLista, o que afinal corresponde ao número de sites.

procedure TfrmLS.lbLClick(Sender: TObject);
begin
LLista.Items.Clear;
LLista.Enabled:=false;
lbL.Enabled:=false;
lbT.Enabled:=false;
bIniciar.Enabled:=false;
lbStatus.Color:=clNavy;
lbStatus.Caption:='Mass InfoServer';
end;

lbL - Evento OnClick:
Limpa e desativa o listbox LLista, em seguida coloca a mensagem inicial no status.

procedure TfrmLS.bIniciarClick(Sender: TObject);
begin
bCancelar.Enabled:=true;
bIniciar.Enabled:=false;
edS.Enabled:=false;
LLista.Enabled:=false;
lbL.Enabled:=false;
lbStatus.Color:=clNavy;
lbStatus.Caption:='Formatando URL..';
LLista.Enabled:=false;
frmIS.Top:=frmIS.Top+999;
ThreadSHandle := CreateThread(nil, 0, @ThreadS,nil,0,ThreadSID);
end;

bIniciar - Evento OnClick:
Muda o texto do status, esconde o formulário principal e inicia a thread.

procedure ThreadS;SafeCall;
var
identro, ifora, L: integer;
Lista: TStringList;
begin
Lista := TStringList.Create;
frmLS.LLista.Items.Text:=AnsiReplaceStr(frmLS.LLista.Items.Text,'http://','');
for L:=0 to frmLS.LLista.Items.Count-1 do
begin
if frmLS.LLista.Items[L] = #13 then
frmLS.LLista.Items.Delete(L);
end;
for L:=0 to frmLS.LLista.Items.Count-1 do
begin
frmLS.LLista.Items[L]:=FURL(frmLS.LLista.Items[L]);
end;
frmLS.lbStatus.Color:=clNavy;
frmLS.LLista.Enabled:=false;
frmLS.lbStatus.Caption:='Iniciando scan..';
Lista.Text:=frmLS.LLista.Items.Text;
{ Rotina para remover itens duplicados }
identro := 0;
while (identro <= (Lista.Count-1)) do
begin
ifora := 0;
while (ifora <= (Lista.Count-1)) do
begin
if (Lista[identro] = Lista[ifora]) and (ifora <> identro) then
Lista.Delete(ifora);
Inc(ifora);
end;
Inc(identro);
end;
{ Fim }
frmLS.LLista.Items.Assign(Lista);
frmLS.lbStatus.Caption:='Iniciando scan..';
frmLS.LLista.ItemIndex:=0;
frmLS.MassIS;
TerminateThread(ThreadSHandle,0);
end;

Thread:
Resolvi colocar esses procedimentos numa thread, para evitar sobrecarregamento do programa, ele congelar/travar/etc..
O que a thread faz é o seguinte:
[li] Remove o 'http://' das URLs..
[li] Remove linhas em branco
[li] Usa a função FURL em todas os itens(sites) da listbox
[li] Remove itens duplicados
[li] e Inicia a procedure MassIS

procedure TfrmLS.MassIS;
var
L: integer;
begin
T.Enabled:=true;
if LLista.Items[LLista.ItemIndex] = '' then
begin
LLista.ItemIndex:=LLista.ItemIndex+1;
LLista.Items.Delete(LLista.ItemIndex-1);
end;
try
  try
  iHTTP.ReadTimeout:=StrToInt(edTimeout.Text);
  iHTTP.Head('http://'+LLista.Items[LLista.ItemIndex]);
  except
  on E:Exception do
  begin
  lbStatus.Caption:=e.message;
  if lbStatus.Caption = 'Connect timed out.' then
  LInfo.Items.Add(LLista.Items[LLista.ItemIndex]+' : '+'Timeout');
  end;
end;
  finally
  if iHTTP.Response.Server = '' then
  begin
  lbStatus.Font.Color:=clRed;
  lbStatus.Caption:='Não disponível';
  iHTTP.Disconnect;
  end else
  begin
  lbStatus.Font.Color:=clNavy;
  lbStatus.Caption:=iHTTP.Response.Server;
  iHTTP.Disconnect;
  end;
end;
if Pos(edS.Text,lbStatus.Caption) > 0 then
begin
LSites.Items.Add(LLista.Items[LLista.ItemIndex]);
LInfo.Items.Add(LLista.Items[LLista.ItemIndex]+' : '+lbStatus.Caption)
end;
L:=LLista.Items.Count-1;
if L = LLista.ItemIndex then
begin
lbStatus.Caption:='Fim do scan!';
frmIS.Top:=frmIS.Top-999;
bCancelar.Enabled:=false;
lbT.Enabled:=false;
lbL.Enabled:=false;
edS.Enabled:=true;
LLista.Enabled:=true;
T.Enabled:=false;
LInfo.Items.SaveToFile('Resultado.txt');
LLista.Items.Clear;
LLista.Items.Add('Resultados salvo em: Resultado.txt');
LInfo.Items.Clear;
Exit;
end else
T.Enabled:=true;
end;

MassIS]
Mais uma vez, antes de iniciar o "scan", ele checa se o item selecionado é espaço em branco, se for, ele deleta-o.
Após isso, é configurado o timeout no componente idHTTP(iHTTP), e após isso é requisitado o cabeçalho ao site selecionado, se ocorrer algum erro, é mostrado a mensagem no status, se for timeout, é adicionado essa informação ao listbox oculto(LInfo). Se ocorrer tudo certo, ele checa o server, se for nulo, é avisado no status(Não disponível), se retornar um server normalmente, é mostrado no status e em seguida é verificado se o que o você colocou para separar, por exemplo Apache, existe no server mostrado, se existir ele adiciona aos dois listbox, o LSites e no LInfo. E finalmente, ele verifica se o item selecionado é o último da lista, se for ele termina o "scan" e salva o resultado, se não for ele ativa o timer(T).


Bom, é isso. Espero que seja útil e que principalmente tenham entendido.

[]s

[shake]

Grande whit3_sh4rk,
vlw por compartilhar este source/tutorial com a galera.
Está bem explicado.
Ótima fonte de estudo.
Já estou dando uma olhadinha no source.

Abraços

[rodweb]

só dei uma passada nele, da pra ver que está bem explicado, parabêns..vlw o code...

[whit3_sh4rk]

Trankilo, espero que tenham ajudado vocês mesmo.

[]s

[TGA]

TGA

Parabéns mano, muito bem explicado 
Abraços..

[Skayler]

whit3_sh4rk, arrebento, muito bom velho!
Parabéns.

[]'s


Skayler

[tiaguito-.-]

whit3_sh4rk, outra vez nos surpreendendo vc tem futuro..

^.-