| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Работа с FB из нескольких потоков

Страницы:   < 1 2 >

jack128 ©   (2007-05-30 15:44:00) 

День добрый.
Есть база на FB1.5
Есть многопоточное приложение. В каждом потоке создается свой экземпляр IBDatabase, свои IBTransaction и и тд..  ПРоблема в том, что если один поток апдейтит базы, то второй даже не может к базе подключится, а первый просто виснит.. Висит всё на вызове функции Fisc_attach_database, то есть непосредственно в клиентской библиотеке gds32.dll..

Ну вопрос очевиден:  Что делать? (с)

Вот минимальный пример, для компиляции - просто поменяйте значения констант DataBaseName и SQLQuery

Pas:
unit Unit2;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, IBDatabase, IBSQL, StdCtrls;

type
 TForm2 = class(TForm)
   Button1: TButton;
   Button2: TButton;
   Memo1: TMemo;
   procedure Button2Click(Sender: TObject);
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form2: TForm2;

implementation

{$R *.dfm}

const
 DataBaseName = 'D:\Женя\Grand\Modules\CertMaker.new\Center\Server\CMMANBASE.FDB';
 SQLQuery = 'update rfolders set title = title';

type
 TIBThread = class(TThread)
 strict private
   FDatabase: TIBDatabase;
   FStr: string;
   procedure DoAddLineToMemo;
 protected
   procedure Execute; override; final;
   procedure DoExecute; virtual; abstract;
 protected
   property Database: TIBDatabase read FDatabase;
   function CreateTransaction(ForWrite: boolean): TIBTransaction;
   procedure AddLineToMemo(const S: string);
 end;

 TIBWriteThread = class(TIBThread)
 protected
   procedure DoExecute; override;
 end;

 TIBStartReadTransactionThread = class(TIBThread)
 protected
   procedure DoExecute; override;
 end;

{ TIBThread }

procedure TIBThread.AddLineToMemo(const S: string);
begin
 FStr := S;
 Synchronize(DoAddLineToMemo);
end;

function TIBThread.CreateTransaction(ForWrite: boolean): TIBTransaction;
const
 TransactionParams: array[False..True] of string = (
   'read_committed'#13#10+
   'rec_version'#13#10+
   'nowait'#13#10+
   'read',

   'read_committed'#13#10+
   'rec_version'#13#10+
   'nowait');
begin
 Result := TIBTransaction.Create(FDatabase);
 Result.DefaultDatabase := FDatabase;
 Result.Params.Text := TransactionParams[ForWrite];
end;

procedure TIBThread.DoAddLineToMemo;
begin
 Form2.Memo1.Lines.Add(FStr)
end;

procedure TIBThread.Execute;
begin
 AddLineToMemo('Начало работы потока');
 try
   try
     FDatabase := TIBDatabase.Create(nil);
     try
       FDatabase.DatabaseName := DatabaseName;
       with FDatabase.Params do
       begin
         Values['lc_ctype'] := 'WIN1251';
         Values['user_name'] := 'SYSDBA';
         Values['password'] := 'masterkey';
       end;
       FDatabase.LoginPrompt := False;
       FDatabase.Connected := True;
       DoExecute;
     finally
       FreeAndNil(FDatabase);
     end;
   except
     on E: Exception do
       AddLineToMemo('Ошибка: ' + E.Message);
   end;
 finally
   AddLineToMemo('Окончание работы потока');
 end;
end;

{ TWriteThread }

procedure TIBWriteThread.DoExecute;
var
 SQL: TIBSQL;
 Count: Integer;
begin
 inherited;
 SQL := TIBSQL.Create(Database);
 try
   SQL.Transaction := CreateTransaction(True);
   SQL.Transaction.StartTransaction;
   SQL.SQL.Text := SQLQuery;
   Count := 0;
   while not Terminated do
   begin
     SQL.ExecQuery;
     if SQL.Open then
       SQL.Close;
     Inc(Count);
     if (Count mod 20) = 0 then
     begin
       AddLineToMemo('Пишущий поток всё еще работает...');
       Count := 0;
     end;
   end;
 finally
   if (SQL.Transaction <> nil) and SQL.Transaction.InTransaction then
     SQL.Transaction.Commit;
   SQL.Free;
 end;
end;

{ TIBStartReadTransactionThread }

procedure TIBStartReadTransactionThread.DoExecute;
var
 Transaction: TIBTransaction;
begin
 inherited;
 Transaction := CreateTransaction(False);
 try
   AddLineToMemo('Перед стартом транзакции');
   Transaction.StartTransaction;
   AddLineToMemo('Перед коммитом транзакции');
   Transaction.Commit;
   AddLineToMemo('После коммита транзакции');    
 finally
   Transaction.Free;
 end;
end;

procedure TForm2.Button1Click(Sender: TObject);
begin
 with TIBWriteThread.Create(True) do
 begin
   FreeOnTerminate := True;
   Resume
 end;
end;

procedure TForm2.Button2Click(Sender: TObject);
begin
 with TIBStartReadTransactionThread.Create(True) do
 begin
   FreeOnTerminate := True;
   Resume
 end;
end;

end.

Dfm:
object Form2: TForm2
 Left = 0
 Top = 0
 Caption = 'Form2'
 ClientHeight = 286
 ClientWidth = 367
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'Tahoma'
 Font.Style = []
 OldCreateOrder = False
 DesignSize = (
   367
   286)
 PixelsPerInch = 96
 TextHeight = 13
 object Button1: TButton
   Left = 24
   Top = 240
   Width = 138
   Height = 25
   Anchors = [akLeft, akBottom]
   Caption = 'Start write thread'
   TabOrder = 0
   OnClick = Button1Click
 end
 object Button2: TButton
   Left = 168
   Top = 240
   Width = 161
   Height = 25
   Anchors = [akLeft, akBottom]
   Caption = 'Start Transaction thread'
   TabOrder = 1
   OnClick = Button2Click
 end
 object Memo1: TMemo
   Left = 24
   Top = 8
   Width = 305
   Height = 209
   Anchors = [akLeft, akTop, akRight, akBottom]
   Lines.Strings = (
     'Memo1')
   TabOrder = 2
 end
end

---

jack128   (2007-05-30 16:36:00) [21]

поставил 2,0,1 - всё работает.. Глючит полуторка??

---

Сергей М.   (2007-05-30 16:32:00) [22]

> jack128 ©   (30.05.07 15:44)


Смелый ты мужик)

Прямо в доп.потоке валишь в мемо строчки)

---

jack128   (2007-05-30 16:27:00) [23]

"Interbase Express10,10" и Delphi 2006 соответственно..

---

Desdechado   (2007-05-30 16:20:00) [24]

IBX и Delphi каких версий?

---

Jan1   (2007-05-30 16:06:00) [25]

Delphi7+FB2.0 нет никаких зависаний.

---

Страницы:   < 1 2 >

Наверх