DELPHI纖程的演示

DELPHI纖程的演示

DELPHI7編譯運行經過。

纖程實現單元：

unit FiberFun;

//Fiber(纖程測試Demo)
//2018/04/11
//QQ: 287413288

//參考 https://www.cnblogs.com/lanuage/p/7725683.html

interface

uses Windows,Messages,classes,SysUtils,ComObj;

type
TFiber=class(TThread)
private
FMainHandle:HWnd;
FData:string;
FWorkDone:Boolean;
procedure WriteLog(const Value:string);
protected
hFiberMain:Pointer;
hFiberA:Pointer;
hFiberB:Pointer;
procedure Execute();override;
public
constructor Create();
public
property WorkDone:Boolean Read FWorkDone;
property MainWndHandle:HWnd read FMainHandle write FMainHandle;//主窗體句柄
end;

const
WM_WRITE_LOG = WM_USER + 1;

implementation

const
kernel32 = 'kernel32.dll';

/// <summary>
/// 在主纖程中調用CreateFiber函數建立子纖程
/// D7自帶的 CreateFiber()聲明有錯誤
/// </summary>
/// <param name="dwStackSize"></param>
/// <param name="lpStartAddress"></param>
/// <param name="lpParameter"></param>
/// <returns></returns>
function CreateFiber(dwStackSize: DWORD; lpStartAddress: TFNFiberStartRoutine;
lpParameter: Pointer): Pointer; stdcall;external kernel32;

/// <summary>
/// 將一個線程轉化爲纖程（或者說將一個線程與纖程綁定，之後能夠將該纖程看作主纖程）
/// </summary>
/// <param name="lpParameter">這個函數傳入一個參數，相似於CreateThread函數中的線程函數參數，若是咱們在主纖程中須要使用到它，能夠使用宏GetFiberData取得這個參數。 </param>
/// <returns></returns>
function ConvertThreadToFiber(lpParameter:Pointer):Pointer; stdcall;external kernel32; // fiber data for new fiber);

//BOOL ConvertFiberToThread(VOID);
/// <summary>
/// 將一個纖程轉化爲線程
/// </summary>
/// <returns></returns>
function ConvertFiberToThread():BOOL;stdcall;external kernel32;

/// <summary>
/// 子纖程A的處理函數
/// </summary>
/// <param name="lpParameter"></param>
procedure FiberProcA(lpParameter:Pointer);stdcall;
var
Index:Integer;
Obj:TFiber;
begin
Obj := TFiber(lpParameter);
Assert(Obj <> nil,'FiberProcA;lpParameter=nil');
Obj.WriteLog(format('FiberProcA;ThreadId=%d;[BEGIN]',[GetCurrentThreadId]));
for Index := 1 to 20 do
begin
Obj.WriteLog(format('FiberProcA;ThreadId=%d;Index=%d',[GetCurrentThreadId,Index]));
Obj.FData := ComObj.CreateClassID();
SwitchToFiber(Obj.hFiberB);
Sleep(50);
end;
obj.Terminate();
SwitchToFiber(Obj.hFiberB);
Obj.WriteLog(format('FiberProcA;ThreadId=%d;[END]',[GetCurrentThreadId]));
SwitchToFiber(Obj.hFiberMain);
end;

/// <summary>
/// 子纖程B的處理函數
/// </summary>
/// <param name="lpParameter"></param>
procedure FiberProcB(lpParameter:Pointer);stdcall;
var
Obj:TFiber;
begin
Obj := TFiber(lpParameter);
Assert(Obj <> nil,'FiberProcB;lpParameter=nil');
Obj.WriteLog(format('FiberProcB;ThreadId=%d;[BEGIN]',[GetCurrentThreadId]));
while(not obj.Terminated) do
begin
Obj.WriteLog(format('FiberProcB;ThreadId=%d;Data=%s',[GetCurrentThreadId,Obj.FData]));
//Sleep(10);
SwitchToFiber(Obj.hFiberA);
end;
Obj.WriteLog(format('FiberProcB;ThreadId=%d;[END]',[GetCurrentThreadId]));
SwitchToFiber(Obj.hFiberA);
end;

{ TFiber }

constructor TFiber.Create;
begin
inherited Create(TRUE);
FWorkDone := FALSE;
end;

procedure TFiber.Execute;
begin
FWorkDone := FALSE;
WriteLog(format('TFiberThread;[BEGIN];ThreadId=%d',[GetCurrentThreadId]));
// 轉換到纖程
hFiberMain := ConvertThreadToFiber(nil);
if hFiberMain = nil then
raise Exception.CreateFmt('ConvertThreadToFiber Failure LastErrorCode=%d',[GetLastError()]);
// 建立子纖程A
hFiberA :=CreateFiber(1024,Pointer(@FiberProcA),Pointer(Self));
if hFiberA = nil then
raise Exception.CreateFmt('CreateFiber Failure LastErrorCode=%d',[GetLastError()]);
// 建立子纖程B
hFiberB :=CreateFiber(1024,Pointer(@FiberProcB),Pointer(Self));
if hFiberB = nil then
raise Exception.CreateFmt('CreateFiber Failure LastErrorCode=%d',[GetLastError()]);
// 切換到纖程A
SwitchToFiber(hFiberA);
// 刪除纖程
DeleteFiber(hFiberA);
DeleteFiber(hFiberB);
// 變回線程
ConvertFiberToThread();
WriteLog(format('TFiberThread;[END];ThreadId=%d',[GetCurrentThreadId]));
FWorkDone := TRUE;
end;

procedure TFiber.WriteLog(const Value: string);
var
Msg:string;
begin
Msg := formatDateTime('YYYY-MM-DD hh:mm:ss.zzz',Now) + ':' + Value;
SendMessage(MainWndHandle,WM_WRITE_LOG,WPARAM(Msg),0);
end;

end.

調用：

unit Main;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,StdCtrls, ExtCtrls, ComCtrls,FiberFun;

type
TfrmMain = class(TForm)
StatusBar1: TStatusBar;
Panel1: TPanel;
mmLog: TMemo;
btnStartFiber: TButton;
procedure btnStartFiberClick(Sender: TObject);
private
{ Private declarations }
protected
procedure WndProc(var MsgRec:TMessage);override;
public
{ Public declarations }
end;

var
frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btnStartFiberClick(Sender: TObject);
var
Obj:TFiber;
begin
btnStartFiber.Enabled := FALSE;
mmLog.Clear();
Obj := TFiber.Create();
Obj.MainWndHandle := Self.Handle;
Obj.FreeOnTerminate := FALSE;
Obj.Resume();
while(not Obj.WorkDone) do
begin
Application.ProcessMessages();
Sleep(10);
end;
Obj.Free();
btnStartFiber.Enabled := TRUE;
end;

procedure TfrmMain.WndProc(var MsgRec: TMessage);
begin
if MsgRec.Msg = WM_WRITE_LOG then
begin
mmLog.Lines.Add(string(MsgRec.WParam));
end
else
inherited;
end;

end.