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.