Я уже пару часов четно пытаюсь написать сам, ничего не выходит уж слишком много нужно предусмотреть. В доказательство выше сказаного ниже выложил код в последней вариации, программа вообще зависает! Дак вот, что я хотел спросить, может есть уже готовые процедуры парсинга емэйлов с HTML страницы? Code: unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; Button1: TButton; Memo2: TMemo; Label1: TLabel; Memo3: TMemo; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); var mail:Tstringlist; i,z,x,v:integer; s:string; begin i:=1; z:=0; while memo1.Lines.Count>=i do begin if pos('@', memo1.Lines[i])>1 then // парсим все строки с значком "@" begin memo2.Lines.Add(memo1.Lines[i]); end; i:=i+1; end; i:=0; end; procedure TForm1.Button2Click(Sender: TObject); var mail:Tstringlist; i,z,x,v:integer; s:string; begin for i :=0 to memo2.Lines.Count do //убираем все коменты begin s:=memo2.Lines[i]; if pos('<!--',s)<>0 then begin memo2.Lines.Delete(i); end; if pos('--!>',s)<>0 then begin memo2.Lines.Delete(i); end; end; for i:=0 to memo2.Lines.Count do begin s:= memo2.Lines[i]; while pos('<',s)>0 do // все теги со страницы begin x:=0; z:=0; z:=pos('<',s); x:=pos('>',s); if x<>z then begin v:=x-z+1; delete(s,z,v); end; end; memo3.Lines.Add(s); end; end; end.
Тебе подойдут регуярные выражения http://3.bp.blogspot.com/_dS8cdXcqCug/SLPuFJMVhoI/AAAAAAAAAAs/VUpYAby4EGo/s1600-h/regular_expressions_cheat_sheet.png тут вот уже даже готовое выражение есть.
про регулярные выражения я читаю, а есть у кого мысли как реализовать посредством pos, delete, сору, length?
Можно спросить, НАХ*Я ??? Если регулярными вытащить можно просто раз плюнуть!!! Code: var RegExp : TRegExpr; begin RegExp.Exepssion := 'Здесь регулярка на мейл'; //в гугле одни только примеры с ними if RegExp.Exec(Здесь строка например HTML код который ты получид) then begin repeat Memo1.lines.append(RegExp.Match[1]); // здесь уже либо 0 либо 1 until not RegExp.ExecNext; end; Модуль TRegExpr - можно забрать здесь так же почитать там неплохо объясняется _http://forum.vingrad.ru/articles/topic-213075.html
Кстати да, я буквально недавно читал, что он нагружает проц. Пото му, что создаёт новый обхект для каждого вычисления и убивает его после окончания. Кстати я как раз эту статью и читаю.
Ну тогда надо assembler использовать для программирования если у вас дома первая ЭВМ. P.S. хочу сообщить на дворе 21 ВЕК
у меня сохранились данные с профилировки утилиты тоже с регулярками связана 6,51 секунды за 2.126.031 вызов это время требуемое на матчинг всех имен экспорта/импорта из exe dll файлов (всего их 15.754 (dll/exe) маппится это обход всего диска) основной затык в функции которая первая обращается к памяти только что отмапленного файла 222,61 секунды на рисунке это ParseImport а сам маппинг бесплатный почти 54,58 это вместе с открытием и маппингом
Ищешь индекс символа @, копируешь слово от первого пробела перед этим словом и первого после слова, ну или место пробела может быть #13.
ну так можно найти в слове символ '@', найти последнюю точку '.' и вытащить всё, что между ними. рег. выражение делает то же самое, только оно в одну строчку записывается
писалось когда то для вот этого XSpryt , но там все было заточено под свои типы и работу с памятью, собственно сам алгоритм парсинга работает, для метода в лоб нормально. Перекидала под Ваши нужды. Процедура PHP: //Процедура заносит все e-mail из строки procedure get_mail(list: TStrings; const str: string); cdecl; var ln_str : integer; // длинна строки s_f,s_e: integer; // начало и конец e-mail i,j : integer; // вспомогательные begin ln_str := length(str); if (ln_str <> 0) then begin for i:=0 to ln_str do begin if str[i] = chr($40) then begin s_f:=1; s_e:=1; for j:=i-1 downto 0 do if not (str[j] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then if s_f=1 then s_f:=j+1; for j:=i+1 to length(str) do if not (str[j] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) then if s_e=1 then s_e:=j; // !!! WARNING ;-) тут внимательнее list.add( copy(str,s_f,s_e-s_f) ); end; end; end; end; //Использование: get_mail(memo1.lines,'sj [email protected] ahaqr iu/=?:*¹[email protected]_i.ru??ôhr ur');
Вот так корректнее : Code: function ParseEmails(Const Emails : TStrings; Const Text : PString) : Boolean; Var i, s, e : Cardinal; function PassageSymbol(dx : Shortint) : Cardinal; Begin {$WARNINGS OFF} Result := i; while (Result+dx > 1) and (Result+dx <= Length(Text^)) and (Text^[Result+dx] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) do Result := Result + dx; {$WARNINGS ON} end; Begin Result := Length(Text^) <> 0; if not Result then Exit; i := 1; while i <= Length(Text^) do if Text^[i] = '@' then Begin s := PassageSymbol(-1); e := PassageSymbol(1); if (s = i) or (e = i) then Begin Inc(i); Continue; end; Emails.Add(Copy(Text^, s, e - s + 1)); i := e + 1; end else Inc(i); end;
а вот захотела я так, ибо функция у меня лично находится в (dll,so,dylib - собственно на экспорте строго указываю, собственно как и в хиддерах потом, правильно так видимо. в данном случае оно не так уж и важно) Я выше упоминала, что у меня все реализовано на динамических массивах, а этот код просто быстрый порт под нужды ТС. Ну кто будет в динамическую библиотеку передавать TStrings ?? ну бред же, в общем директива там никчему за не надобностью. Просто отголоски портирования. По поводу сомнительности кода: ln_str := length(str); - чтобы не определять длину каждый раз if (ln_str <> 0) then begin - а вот это было действительно лишним. Но собственно, спасибо Вам за указание безолаберности кода, правильно, нечего расслабляться. Однако не примите за критику, хотела бы обратить Ваше внимание вот на что: 1. Length(Text^) - зачем столько раз определять длину. 2. отключение и игнорирование варнингов не гуд, пусть даже тут это ни чем не грозит. 3. использование в подфункции типа [ShortInt с диапозоном -128 +128] однако по RFC 3696 мы можем пролететь на проверке с таким типом. Но это просто либо упущено из виду либо не знание спецификации, что собственно не критично. Вот ниже выдержка от туда, так что мой совет расширить диапозон, для стабильности функции. PHP: function ParseEmails(Const Emails : TStrings; Const Text : PString): longint; var i,s,e,l : longint; function Fringe(p: longint; dx : smallint): longint; begin Result := p; while (Result+dx > 1) and (Result+dx <= l) and (Text^[Result+dx] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '-', '.']) do Result := Result + dx; end; Begin result := 0; l := Length(Text^); if (l=0) then exit; i := 1; while i <= l do if Text^[i] = '@' then begin s := Fringe(i,-1); e := Fringe(i,1); if (s = i) or (e = i) then begin inc(i); continue; end; Emails.Add(Copy(Text^, s, e - s + 1)); inc(result); i := e + 1; end else inc(i); end;
Не люблю плодить переменные, функция малюсенькая - особо много не прибавит добавление переменной. В том то и дело, что Length возвращает Int, а я использую UInt. Вообще не ясно почему решили использовать в Length знаковое целое, т.к. она не может выдать отрицательный результат. Предупреждения в таких местах нужно убирать, если нереально за диапазоны выйти. Я скорее более важные предупреждения увижу если таких тьма не будет вылезать. Ну да, не подумал, я думаю это не критично.
Ну смотри, если использовать Const Text : String; то вся строка будет скопированна при вызове функции, а если использовать Var Text : String; то будет передан как бэ указатель, но это не кошерно, т.к. я ее изменять не буду, и из-за этого я частенько использую указатель, хотя сама по себе переменная String в Delphi является указателем. Может просто по не знанию тонкостей так делаю, даже если мне и разъяснят - все равно буду через указатели делать. Ну да, я видно тут не прав, раньше в циклах тоже использовал заранее рассчитанные данные, потом забил, т.к. профиту не много, а так пишешь на лету и как то не задумываешься если маленькая функция, вообще ее не плохо было бы еще inline сделать.
