VPF::Не получается с потоками - Форум программистов

Zlo

Дата 15.4.2007, 01:22 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 235
Регистрация: 18.9.2004

Репутация: 1
Всего: 1

Блин не работают патоки незнаю как сделать... подскажите пожалуйста!

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, StdCtrls, ExtCtrls, Menus, ComCtrls, IdCookieManager,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,
  OleCtrls, SHDocVw,ActiveX, XPMan, ShellAPI, IdAntiFreezeBase,
  IdAntiFreeze, Spin;

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    Edit1: TEdit;
    GroupBox2: TGroupBox;
    StaticText1: TStaticText;
    Edit2: TEdit;
    StaticText2: TStaticText;
    Edit3: TEdit;
    CheckBox1: TCheckBox;
    GroupBox3: TGroupBox;
    StaticText3: TStaticText;
    StaticText4: TStaticText;
    StaticText5: TStaticText;
    StaticText6: TStaticText;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    SpinEdit1: TSpinEdit;
    StaticText7: TStaticText;
    GroupBox4: TGroupBox;
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Timer1: TTimer;
    Timer2: TTimer;
    procedure Button3Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  TGrabber = class(TThread)
  private
    FForumUrl:String;
    FForumPass:String;
    FForumLogin:String;
    FFAuth:Boolean;
    Rezyltat:String;
  protected
    procedure Execute; override;
    procedure ForumPageCount;
  public
    property Url: string write FForumUrl;
    property Password: string write FForumPass;
    property Login: string write FForumLogin;
    property Authentification: Boolean write FFAuth;
    constructor create1;
  end;

type
  TZaxvat = class(TThread)
  private
    FForumUrl:String;
  protected
    procedure Execute; override;
  public
    property Url: string write FForumUrl;
    constructor create2;
  end;

var
  Form1: TForm1;
  MyThread: array[1..255] of TThread;
  IdHTTP1:TIdHTTP;
  NewThread:TGrabber;
  UserListAcc:TStringList;
  PageNumber:integer;
  
implementation

{$R *.dfm}
constructor TGrabber.create1;
begin
 inherited create(true);
 FreeOnTerminate := true;
end;


constructor TZaxvat.create2;
begin
 inherited create(true);
 FreeOnTerminate := true;
end;

{++++++++++++++++++++++++++++++++++++++++}
procedure TGrabber.ForumPageCount;
begin
   Form1.Label1.Caption:=Rezyltat;
end;

procedure TGrabber.Execute;
var
  i:integer;
  Url,spage,username:string;
  DataLoging,AuthKeyFind:TStringList;
begin
{++++++++}
  idHTTP1:=TidHTTP.Create(nil);
  idHTTP1.HandleRedirects:=true;
  idHTTP1.AllowCookies:=true;
  idHTTP1.Request.UserAgent:='Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; DigExt)';

  DataLoging:=TStringList.Create;//Data POST
  AuthKeyFind:=TStringList.Create;

if FFAuth=true then begin
  //Url:=FForumUrl+'ipb.html?act=Login&CODE=01';
  Url:=FForumUrl+'index.php?act=Login&CODE=01&CookieDate=1';
  DataLoging.Add('referer='+FForumUrl);
  DataLoging.Add('UserName='+FForumLogin);
  DataLoging.Add('PassWord='+FForumPass);
  DataLoging.Add('CookieDate=1');
  //DataLoging.Add('submit=%C2%EE%E9%F2%E8%21');

  try
    AuthKeyFind.Text:=idHTTP1.Post(url,DataLoging); //Send POST
  except end;

  for i:=1500 to AuthKeyFind.Count-1 do begin {Ïåðåõîä íà ãëàâíóþ ñòðàíèöó}
      if Pos('"redirectfoot"',AuthKeyFind[i])>0 then begin
          Url:=Copy(AuthKeyFind[i],Pos('http:',AuthKeyFind[i]),Length(AuthKeyFind[i])-Pos('http:',AuthKeyFind[i]));
          Url:=Copy(Url,1,Pos(';',Url)-1);
          break;
      end;
  end;
  AuthKeyFind.Text:=idHTTP1.Get(Url);
end;
  AuthKeyFind.Free;
  DataLoging.Clear;
  Url:=FForumUrl+'?name_box=begins&sort_key=members_display_name&sort_order=asc&filter=3&act=members&max_results=50&aim=&yahoo=&icq=&msn=&posts=&joined=&lastpost=&lastvisit=&signature=&homepage=&name=&photoonly=&st=0';
  try
    DataLoging.Text:=idHTTP1.Get(Url);
  except end;
  //JmpBeg:=0;
  for i:=1 to DataLoging.Count-1 do begin
      if Pos('page-jump',DataLoging[i])>0 then begin
         spage:=Copy(DataLoging[i],Pos('page-jump',DataLoging[i]),Length(DataLoging[i])-Pos('page-jump',DataLoging[i]));
         spage:=Copy(spage,Pos('>',spage)+1,Pos(' ',spage)-Pos('>',spage)-1);
         //JmpBeg:=i;
         break;
      end;
  end;

  Rezyltat:=spage;
  Synchronize(ForumPageCount);
   for i:=1 to 3 do
   begin
     MyThread[i] := TZaxvat.create2;
     MyThread[i].Resume;
   end;
end;

procedure TZaxvat.Execute;
const
  teg1='<td class="row2"><b><a href="';
var
  i,j,PageCount,PageCol,JmpBeg:integer;
  Url,spage,username:string;
  FileUserList,DataLoging:TStringList;
  idHTTP2:TidHTTP;
begin
  idHTTP2:=TidHTTP.Create(nil);
  idHTTP2:=idHTTP1;

  DataLoging:=TStringList.Create;//Data POST
  FileUserList:=TStringList.Create;

Url:=FForumUrl+'?name_box=begins&sort_key=members_display_name&sort_order=asc&filter=3&act=members&max_results=50&aim=&yahoo=&icq=&msn=&posts=&joined=&lastpost=&lastvisit=&signature=&homepage=&name=&photoonly=&st=0';
  try
    DataLoging.Text:=idHTTP2.Get(Url+'10');
  except end;
  for i:=1 to DataLoging.Count-1 do begin
      if Pos('page-jump',DataLoging[i])>0 then begin
         spage:=Copy(DataLoging[i],Pos('page-jump',DataLoging[i]),Length(DataLoging[i])-Pos('page-jump',DataLoging[i]));
         spage:=Copy(spage,Pos('>',spage)+1,Pos(' ',spage)-Pos('>',spage)-1);
         break;
      end;
  end;

  PageCount:=StrToInt(spage);
  PageCol:=-50;
  Url:=FForumUrl+'?name_box=begins&sort_key=members_display_name&sort_order=asc&filter=3&act=members&max_results=50&aim=&yahoo=&icq=&msn=&posts=&joined=&lastpost=&lastvisit=&signature=&homepage=&name=&photoonly=&st=';

  FileUserList.Clear;

  for i:=1 to PageCount-1 do begin
      PageCol:=PageCol+50;
      try
        DataLoging.Text:=idHTTP2.Get(Url+IntToStr(PageCol));
      except end;
      {Rezyltat:=DataLoging.Text;
      Synchronize(Htm);}
      for j:=1 to DataLoging.Count-1 do begin
        if Pos(teg1,DataLoging[j])>0 then begin
          username:=Copy(DataLoging[j],Pos(teg1,DataLoging[j])+Length(teg1),Length(DataLoging[j])-Pos(teg1,DataLoging[j])-Length(teg1));
          if Pos('>',username)>0 then begin
             username:=Copy(username,Pos('>',username),Length(username)-Pos('>',username));
             username:=Copy(username,Pos('>',username)+1,Pos('<',username)-Pos('>',username)-1);
             FileUserList.Add(username);

             //Rezyltat:=username;
             //Synchronize(UserAdd);
          end;
        end;
      end;
      //Synchronize(WorkPage);
      UserListAcc.Text:=UserListAcc.Text+FileUserList.Text;
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
   NewThread:=TGrabber.Create(true);
   NewThread.FreeOnTerminate := True;

   NewThread.Url:=Edit1.Text;
   NewThread.Login:=Edit2.Text;
   NewThread.Password:=Edit3.Text;
   NewThread.Authentification:=CheckBox1.Checked;
   NewThread.Resume;
   Timer1.Enabled:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    UserListAcc:=TStringList.Create;
    PageNumber:=0;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
    Memo1.Text:=UserListAcc.Text;
end;

end.

MetalFan

Дата 15.4.2007, 09:44 (ссылка)

(нет голосов)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

и что не работает?
выкладывай пример приложения в аттаче. мне навпример влом переносить в делфи твой код, чтобы проверить...

--------------------

There are always someone smarter than you...

Zlo

Дата 15.4.2007, 14:51 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 235
Регистрация: 18.9.2004

Репутация: 1
Всего: 1

Цитата(MetalFan @ 15.4.2007, 09:44

)

выкладывай пример приложения в аттаче. мне навпример влом переносить в делфи твой код, чтобы проверить...

Вот пожалуйста

Присоединённый файл ( Кол-во скачиваний: 8 )

Project.zip 15,02 Kb

ama_kid

Дата 15.4.2007, 18:38 (ссылка)

(нет голосов)

Загрузка ...

АСУТП-кодер

Профиль
Группа: Комодератор
Сообщений: 1460
Регистрация: 5.3.2007
Где: Москва

Репутация: 15
Всего: 95

Zlo
Ну не знаю... У меня твоя программа отрабатывает точно так, как написано... Что конкретно не нравиться-то тебе? Обрисовываю существующую схему: по кнопке "Старт" запускается поток Grabber (я не вникал в то, что он делает, какую-то инфу по линку берет), исполняет цикл по количеству DataLoging.Count и в конце своей работы запускает три потока Zaxvat. Сам поток Grabber завершается, ибо у него не стоит цикл "while not Terminated". Потоки Zaxvat также берут какие-то данные, тоже что-то с ними делают в конечном цикле по количеству элементов и аналогично завершают свою работу (ибо у них тоже нет задачи работать вечно). Что тебя в этой их работе не устраивает? Тебе надо, чтобы какой-то поток (возможно Grabber) крутился вечно? Ну так запускай его метод Execute крутиться while not Terminated... Повторюсь еще раз - у меня на машине потоки запускаются и свою задачу отрабатывают (это на случай, если под "не работают потоки" ты подразумеваешь "не запускаются потоки")

--------------------

самурай без меча подобен самураю с мечом, но только без меча

Zlo

Дата 15.4.2007, 22:06 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 235
Регистрация: 18.9.2004

Репутация: 1
Всего: 1

Дело в том что поток Zaxvat собственно собирает инфу со страниц и записывает ее в глобальную переменную, таймер на форме каждые 4 секунды забирает инфу из переменной и втыкает ее мемо, но этого не происходит :(
Кто в патоках шарит можете посмотреть хоть прально патоки реализованы? Я вот думаю может они отваливаются во время работы? Или умирают вместе с патоком который их запустил?

ama_kid

Дата 16.4.2007, 06:49 (ссылка)

(нет голосов)

Загрузка ...

АСУТП-кодер

Профиль
Группа: Комодератор
Сообщений: 1460
Регистрация: 5.3.2007
Где: Москва

Репутация: 15
Всего: 95

Цитата(Zlo @ 15.4.2007, 22:06

)

Я вот думаю может они отваливаются во время работы? Или умирают вместе с патоком который их запустил?

Они умирают практически сразу осле запуска, выполнив свою задачу. Метод Excecute - это метод времени жизни потока, дойдя до конца этой процедуры, поток умирает. Каждый твой поток - доходит до конца этого метода. Если ты не хочешь чтобы поток завершался - зацикливай (только грамотно, с возможностью выхода) этот метод. Пример:

Код


procedure TMyThread.Execute;
begin
 while not Terminated do
  begin
    ...
   {SomeWork}
    ...
  end;
end;

Таким образом, поток не умрет, выполним один раз свою задачу, а будет её выполнять пока не пришла команда Terminate.

--------------------

самурай без меча подобен самураю с мечом, но только без меча

Zlo

Дата 23.4.2007, 22:44 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 235
Регистрация: 18.9.2004

Репутация: 1
Всего: 1

Дык если патоки отрабатывают то почему тогда не видно результатов их работы?

Farmazon

Дата 24.4.2007, 12:23 (ссылка)

(нет голосов)

Загрузка ...

Разработчик

Профиль
Группа: Участник
Сообщений: 265
Регистрация: 7.7.2006

Репутация: нет
Всего: 5

У тя 2ой таймер отвечает за передачу данных от переменной в текстовое поле, а ты зупущаешь первый...

Это сообщение отредактировал(а) Farmazon - 24.4.2007, 12:45

--------------------

Таково моё общее мнение.

Farmazon

Дата 24.4.2007, 12:47 (ссылка)

(нет голосов)

Загрузка ...

Разработчик

Профиль
Группа: Участник
Сообщений: 265
Регистрация: 7.7.2006

Репутация: нет
Всего: 5

А воще смысл переменной UserListAcc? Нельзя штоли сразу в текстовое поле добавлять?...

...

Работать с объектом класса TStringList как со строкой - это жесть. (хех... сам был такой smile

)

например вместо:

Код


UserListAcc.Text:=UserListAcc.Text+FileUserList.Text;

лучше:

Код


UserListAcc.AddStrings(FileUserList);

это куда эфективнее... и писать меньше...

ПС: звиняйте за оффтоп...

Это сообщение отредактировал(а) Farmazon - 24.4.2007, 20:00

--------------------

Таково моё общее мнение.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »