PHP to Delphi

[moscow]

<?php
if(isset($_GET["email"])) {
$mail =file_get_contents($_GET["email"]);
preg_match_all("/[\.\-_A-Za-z0-9]+?@[\.\-A-Za-z0-9]+?[\.A-Za-z0-9]{2,}/", $mail, $text_arr);
$arr = $text_arr[0];
$result = array_unique($arr);
foreach($result as $text)
echo "$text </br>";
}
else
{
echo "Ошибка!!! </br>";
echo "Введите (Например <strong>". $_SERVER["SCRIPT_NAME"] ."?email=http://otvet.mail.ru/</strong>)";
}
?>

Как осуществить на дельфи?

[mss]

Ты по-простому, по рабоче-крестьянски скажи, без всяких ПХП - тебе чего нужно-то ?) Все email-адреса что ли выковырять из содержимого некоего имеющегося текстового файла ?

[moscow]

mss, да. Понимаю что этот PHP-код все емайлы вытаскивает со страницы.
Парсер писал но не такой. Этот с выражением какбэ универсальный будет.
Нужно чтобы пояснили или указали где можно урок посмотреть. Как с этим выражением послать запрос и потом вывести результат. Поиском ничего не нашел, и обратился сюда.

Извиняюсь нашел: http://programmersforum.ru/showthread.php?t=57210
Но от советов по PHP кода в дельфи не *помешает.

[notHaker]

function isValidMail(lpszMail : string) : bool;
var
	lpszServerName : string;
	lpszUserName : string;
	dwIndex : DWORD;
begin
	result := false;
	lpszServerName := mail2url(lpszMail);
	if lenght(lpszServerName) <= 0 then exit;
	result := isValidUrl(lpszServerName);
	if not result then exit;
	lpszUserName := mail2username(lpszMail);
	if lenght(lpszUserName) <= 0 then exit;
	result := isValidUserName(lpszUserName);
end;

function isValidUserName(lpszUserName : string) : bool;
var 
	dwIndex : DWORD;
	dwCharsCount : DWORD;
begin
	lpszUserName := AnsiLowerCase(lpszUserName);
	dwIndex := 0;
	result := false;
	dwCharsCount := lenght(lpszUserName);
	while dwIndex < dwCharsCount do
	begin
	//правила
		if (ord(lpszUserName[dwIndex]) and $F0) <> 0 then exit; //кирилица запрещена
		case lpszUserName[dwIndex] of
			// все разрешённые символы 
			'.' : if ( dwIndex = 0 ) and ( dwIndex >= (dwCharsCount - 1)) then exit; //первым символом быть не может
			'-' : if ( dwIndex = 0 ) and ( dwIndex >= (dwCharsCount - 1)) then exit; 
			//и тд.
		else
		//правило : все англ. символы и цифры разрешены иначе вылет
			if  ((ord(lpszUserName[dwIndex]) < ord('0')) or (ord(lpszUserName[dwIndex]) > ord('9'))) and
				((ord(lpszUserName[dwIndex]) < ord('a')) or (ord(lpszUserName[dwIndex]) > ord('z'))) then
			exit;
		end;
		inc(dwIndex);
	end;
	result := true;	
end;

function isValidUrl(lpszUrl : string) : bool;
var 
	dwIndex : DWORD;
	dwCharsCount : DWORD;
begin
	lpszUrl := AnsiLowerCase(lpszUrl);
	dwIndex := 0;
	result := false;
	dwCharsCount := lenght(lpszUrl);
	while dwIndex < dwCharsCount do
	begin
		if (ord(lpszUrl[dwIndex]) and $F0) <> 0 then exit;
		case lpszUrl[dwIndex] of
			// все разрешённые символы 
			'.' : if ( dwIndex = 0 ) and ( dwIndex >= (dwCharsCount - 1)) then exit; //первым символом быть не может
			'-' : if ( dwIndex = 0 ) and ( dwIndex >= (dwCharsCount - 1)) then exit; 
			//и тд.
		else
			if  ((ord(lpszUrl[dwIndex]) < ord('0')) or (ord(lpszUrl[dwIndex]) > ord('9'))) and
				((ord(lpszUrl[dwIndex]) < ord('a')) or (ord(lpszUrl[dwIndex]) > ord('z'))) then
			exit;
		end;
		inc(dwIndex);
	end;
	result := true;	
end;

function mail2url(lpszMail : string) : string; //извлекает url серверa
var
	dwPosition : DWORD;
begin
	dwPosition := pos('@', lpszMail);
	if ( lenght(lpszMail) < 3 ) or (dwPosition <= 0) then exit;
	result := copy(lpszMail, dwPosition + 1, lenght(lpszMail) - dwPosition);
end;

function mail2username(lpszMail : string) : string; //извлекает имя. даже если вписали с паролем
var
	dwPosition : DWORD;
begin
	dwPosition := pos('@', lpszMail);
	if ( lenght(lpszMail) < 3 ) or (dwPosition <= 0) then exit;
	result := copy(lpszMail, 1, dwPosition - 1);
	dwPosition := pos(':', result);
	if ( dwPosition > 1 ) and ( dwPosition < lenght(result)) then
		result := copy(result, 1, dwPosition - 1)
	else
		result := '';
end;

валидность емейлов.

ничего нипонятно. скажи ещё конкретней, что тебе нужно? поставь задачу.
если тебе нужно повторить пэхэпешный код, то юзай Indy.

Если нужно дёргать мейлы, то можно просто парсить по ключу или ключевому слову (@,Собачка и т.д.) всю страницу. получать страницу можно через Indy. Также можно сообразить сёрфер-сборщик, ищущий по списку url. Правда то, что здесь обсуждается по сути спамерский костыль. А вы, спамеры, фсе плахие

ЗЫ: могут быть ошибки. компилера под рукой неть.

[fate]

что этот PHP-код все емайлы вытаскивает со страницы.

я писал как-то для себя код который рекурсивно обходит страницы сайта и вытаскивает ссылки и email адреса, если еще нужен могу выложить

[moscow]

Только сегодня наткнулся на PHP код, c регулярными выражениями не сталкивался. Писал примитивно:

function Pars(T_ : string; var ForS: string; _T: string): string;
бла бла бла
end;

procedure TNewThread.Execute;
бла бла бла
x:=Pars('<p align="center">'+#13#10, a, '&nbsp;&nbsp;&nbsp;');
бла бла бла
end;

Вот сейчас гуглю, скачал TRegExpr уроки смотрю но пока подходящих для начала не нашел.

fate, можно исходник чтобы сесть и разбираться. Как раз он по описанию работы сходиться с моей темой. Бла, честно тема эта просто заинтересовала.

[fate]

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Urlmon, StdCtrls,RegExpr, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP;
 
type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Button1: TButton;
    Memo1: TMemo;
    Label1: TLabel;
    IdHTTP1: TIdHTTP;
    Label2: TLabel;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure pars(url:string);
   function duble(const line: string;memo:Tmemo):boolean;
   function parsurl(const str:string):string;
   procedure parsEmail(const str:string);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
  host:string; q:integer;
  start,beg,b:boolean;
implementation

{$R *.dfm}
 
procedure TForm1.Button1Click(Sender: TObject);
var str:string;
begin
if start then begin
memo1.Clear; memo2.Clear;
host:=parsurl(edit1.text);
Button1.Caption:='Стоп';
start:=false; beg:=true;
pars(edit1.text); end else begin
Button1.Caption:='Пуск';
start:=true; beg:=false;
end;
end;
 
 

function TForm1.duble(const line: string;memo:Tmemo):boolean;
var i:integer;
begin
for i:=0 to memo.Lines.Count-1 do
  if memo.Lines[i]= line then begin
  result:=true; break; end else result:=false;
end;
 
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
//label1.Caption:=inttostr(ord(Key));
end;

procedure TForm1.pars(url: string);
var list:Tstringlist;
reg:TRegExpr;
begin
inc(q);
URLDownloadToFile(nil,Pchar(url),pchar('index'+inttostr(q)+'.html'),0,nil);
list:=Tstringlist.Create;
reg:=TRegExpr.Create;
if FileExists('index'+inttostr(q)+'.html') then begin
list.LoadFromFile('index'+inttostr(q)+'.html');
DeleteFile('index'+inttostr(q)+'.html'); end else exit;


reg.Expression:='[a][\s]{1,}(href=")([^"]+)';
if reg.Exec(list.Text) then
Repeat
if (reg.Match[2]<>'#')and(not duble(reg.Match[2],memo1))and(beg) then begin
  memo1.Lines.Add(reg.Match[2]);
    parsEmail(list.Text);
  Application.ProcessMessages;
  label1.Caption:=inttostr(memo1.Lines.Count+1);
      if reg.Match[2][1]='/' then begin
          pars('http://'+host+reg.Match[2]); b:=false;
      end else
        if copy(reg.Match[2],1,4)='http' then begin
            if parsurl(reg.Match[2])=host then
              pars(reg.Match[2]);
            b:=false;
        end else b:=true;

      if b then
        pars('http://'+host+'/'+reg.Match[2]);
end;
 Until not reg.ExecNext else ShowMessage('неа');
 
//DeleteFile('index'+inttostr(q)+'.html');
list.Free;
reg.Free;
 
end;

procedure TForm1.parsEmail(const str: string);
var  reg:TRegExpr;
begin
reg:=TRegExpr.Create;
reg.Expression:='[/.\w/-]{1,20}[@][\w]{1,10}[/.][\w]{1,3}';
if reg.Exec(str) then
repeat
if not duble(reg.Match[0],memo2) then
memo2.Lines.Add(reg.Match[0]);
until not reg.ExecNext;
reg.Free;
end;

function TForm1.parsurl(const str: string): string;
var  reg:TRegExpr;
begin
reg:=TRegExpr.Create;
reg.Expression:='(http://www)[/.]([^\/]+)';
if reg.Exec(str) then
result:=reg.Match[2] else begin
reg.Expression:='(http://)([^\/]+)';
reg.Exec(str);
result:=reg.Match[2];
end;

reg.Free;
end;

initialization
q:=0; start:=true; b:=true; beg:=true;
end.

[moscow]

fate, спасибо большое. То что надо.
Тема закрыта.