自己写了个通过PIPE显示或纪录运行日志的，CPU占用比较低，大家玩玩吧，多提意见哦(10分)

服务器：
program Logger;

{$APPTYPE CONSOLE}

uses
Windows, sysutils;

function DateStr: string;
begin
result := FormatDateTime('SS:ZZZ ', Now);
end;

const
BUFSIZE = 1024;
PIPE_TIMEOUT = 2000;
type
PPIPEINST = ^TPIPEINST;
TPIPEINST = packed record
oOverlap: OVERLAPPED;
hPipeInst: THANDLE;
chBuf: array[0..BUFSIZE] of char;
cbToWrite: DWORD;
end;
var
hPipe: THandle;
hConnectEvent: THandle;
oConnect: OVERLAPPED;
lpPipeInst: PPIPEINST;
dwWait, cbBytes: DWORD;
fSuccess, fPendingIO: Boolean;
LogFileName: string;
ThisPipeName: string;
ShouldSaveToFile: Boolean;

function ConnectToNewClient(h: THANDLE; pOVL: POVERLAPPED): Boolean;
var
fConnected, fPendingIO: Boolean;
Err: DWORD;
begin
fConnected := false;
fPendingIO := FALSE;

// Start an overlapped connection for this pipe instance.
fConnected := ConnectNamedPipe(hPipe, pOVL);

// Overlapped ConnectNamedPipe should return zero.
if (fConnected) then
exit;
Err := GetLastError;
case (Err) of
ERROR_IO_PENDING:
begin
fPendingIO := TRUE;
end;

// Client is already connected, so signal an event.
else
begin
if (Err = ERROR_PIPE_CONNECTED) and (SetEvent(pOVl.hEvent)) then
begin
exit;
end
else
begin
exit;
end;
end;
result := FPendingIO;
end;
end;

function CreateAndConnectInstance(pOVL: POVERLAPPED): Boolean;
var
PipeName: string;
begin
Pipename := '//./pipe/' + ThisPipeName;

hPipe := CreateNamedPipe(
Pchar(Pipename), // pipe name
PIPE_ACCESS_DUPLEX + // read/write access
FILE_FLAG_OVERLAPPED, // overlapped mode
PIPE_TYPE_MESSAGE + // message-type pipe
PIPE_READMODE_MESSAGE + // message read mode
PIPE_WAIT, // blocking mode
PIPE_UNLIMITED_INSTANCES, // unlimited instances
BUFSIZE, // output buffer size
BUFSIZE, // input buffer size
PIPE_TIMEOUT, // client time-out
nil); // no security attributes
if (hPipe = INVALID_HANDLE_VALUE) then
exit;
result := ConnectToNewClient(hPipe, pOVL);
end;

procedure DisconnectAndClose(pp: PPIPEINST);
begin


if (not DisconnectNamedPipe(lpPipeInst.hPipeInst)) then
exit;
CloseHandle(lpPipeInst.hPipeInst);

// Release the storage for the pipe instance.

if (lpPipeInst <> nil) then
GlobalFree(Cardinal(lpPipeInst));
end;

procedure SaveToFile(Info: string);
var
F: THandle;
dwIOSize: DWORD;
begin
if not ShouldSaveToFile then
exit;
if FileExists(LogFileName) then
F := CreateFile(PChar(LogFileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)
else
F := CreateFile(PChar(LogFileName), GENERIC_WRITE, 0, nil, CREATE_NEW, FILE_ATTRIBUTE_ARCHIVE, 0);
if F <> INVALID_HANDLE_VALUE then
begin
FileSeek(F, 0, 2);
Info := Info + #13#10;
WriteFile(F, PChar(Info)^, length(Info), dwIOSize, nil);
CloseHandle(F);
end;
{
if FileExists(LogFileName) then
F := TFileStream.Create(LogFileName, fmOpenWrite)
else
F := TFileStream.Create(LogFileName, fmCreate);
if assigned(F) then
begin
F.Seek(0, 2);
Info := Info + #13#10;
F.Write(PChar(Info)^, length(Info));
F.Free;
end;
}
end;

procedure CompletedWriteRoutine(dwErr: DWORD; cbWritten: DWORD; pOVL: POVERLAPPED); stdcall; forward;

procedure CompletedReadRoutine(dwErr: DWORD; cbBytesRead: DWORD; pOVL: POVERLAPPED); stdcall;
var
lpPipeInst: PPIPEINST;
FWrite: Boolean;
Info: string;
begin
FWrite := false;
lpPipeInst := PPIPEINST(pOVL);
Info := string(lpPipeInst.chBuf);
delete(Info, cbBytesRead + 1, BUFSIZE - cbBytesRead);
Info := DateStr + Info;
SaveToFile(Info);
Writeln(Info);
if ((dwErr = 0) and (cbBytesRead <> 0)) then
begin
// GetDataToWriteToClient(lpPipeInst);
lpPipeInst.cbToWrite := 0;
fWrite := WriteFileEx(
lpPipeInst.hPipeInst,
@(lpPipeInst.chBuf[0]),
lpPipeInst.cbToWrite,
lpPipeInst.oOverlap,
@CompletedWriteRoutine);

end;
if (not fWrite) then
DisconnectAndClose(lpPipeInst);
end;

procedure CompletedWriteRoutine(dwErr: DWORD; cbWritten: DWORD; pOVL: POVERLAPPED); stdcall;
var
lpPipeInst: PPIPEINST;
FRead: Boolean;
begin
fRead := FALSE;
lpPipeInst := PPIPEINST(pOVL);
if ((dwErr = 0) and (cbWritten = lpPipeInst.cbToWrite)) then
begin
fRead := ReadFileEx(
lpPipeInst.hPipeInst,
@(lpPipeInst.chBuf[0]),
BUFSIZE,
@(lpPipeInst.oOverlap),
@CompletedReadRoutine);
end;
if (not fRead) then
DisconnectAndClose(lpPipeInst);
end;
begin
try
ShouldSaveToFile := true;
ThisPipeName := 'G5DEBUG';
LogFileName := 'C:/Log.txt';
case ParamCount of
0:
begin
end;
1:
begin
ThisPipeName := ParamStr(1);
ShouldSaveToFile := false;
end;
2:
begin
ThisPipeName := ParamStr(1);
LogFileName := ParamStr(2);
end;
end;
hConnectEvent := CreateEvent(
nil, // no security attribute
true, // manual reset event
true, // initial state = signaled
nil); // unnamed event object
if (hConnectEvent = INVALID_HANDLE_VALUE) then
exit;
oConnect.hEvent := hConnectEvent;
fPendingIO := CreateAndConnectInstance(@oConnect);

WriteLn('<===G5Studio Logger Version 0.1===>');
WriteLn('Usage : Logger [<pipename> <logfilename>]');
WriteLn('Defaultipname=G5DEBUG logfilename=C:/LOG.TXT');
WriteLn(' Logger DEBUGMSG C:/LOG.TXT');
WriteLn(' Logger DEBUGMSG means no logfile be writen');
WriteLn('');
WriteLn(Format('Current ParamsIPE=%s,LOG=%s', [ThisPipeName, LogFileName]));
while (true) do
begin
// Wait for a client to connect, or for a read or write
// operation to be completed, which causes a completion
// routine to be queued for execution.

dwWait := WaitForSingleObjectEx(
hConnectEvent, // event object to wait for
INFINITE, // waits indefinitely
TRUE); // alertable wait enabled

case (dwWait) of
0:
begin
if (fPendingIO) then
begin
fSuccess := GetOverlappedResult(
hPipe, // pipe handle
oConnect, // OVERLAPPED structure
cbBytes, // bytes transferred
FALSE); // does not wait
if (not fSuccess) then
exit;
end;

// Allocate storage for this instance.

lpPipeInst := PPIPEINST(GlobalAlloc(GPTR, sizeof(TPIPEINST)));
if (lpPipeInst = nil) then
exit;

lpPipeInst.hPipeInst := hPipe;

// Start the read operation for this client.
// Note that this same routine is later used as a
// completion routine after a write operation.

lpPipeInst.cbToWrite := 0;

CompletedWriteRoutine(0, 0, @(lpPipeInst.oOverlap));

// Create new pipe instance for the next client.

fPendingIO := CreateAndConnectInstance(
@oConnect);
end;

// The wait is satisfied by a completed read or write
// operation. This allows the system to execute the
// completion routine.

WAIT_IO_COMPLETION:
begin
end;
else
begin
exit;
// MyErrExit("WaitForSingleObjectEx");
end;
end;
end;
finally

end;
end.
需要调试的程序里面，加入以下单元，然后设置FLog属性为TRUE,可以修改PIPENAME为你想要得名字，不过名称一定要与服务器使用的管道名称一样
unit U_Logger;

interface
uses Windows, sysutils, syncobjs;
type
TRunLogger = class
private
FPipeName: string;
FCrit: TCriticalSection;
FHandle: THandle;
FIndent: Integer;
Ticks: DWORD;
procedure SetPipeName(S: string);
public
FLog: Boolean;
constructor Create(DebugerName: string = 'G5DEBUG');
destructor Destroy; override;
procedure WriteFmt(FormatStr: string; const Args: array of const; Indent: Integer = 0);
procedure Write(FormatStr: string; Indent: Integer = 0);
property PipeName: string read FPipeName write SetPipeName;
procedure TryOpenPipe;
end;
var
Logger: TRunLogger;
procedure LogIt(const FmtStr: string; args: array of const; Indent: Integer = 0);
implementation
uses FileCtrl;
{ TRunLogger }

procedure LogIt(const FmtStr: string; args: array of const; indent: Integer = 0);
begin
Logger.WriteFmt(FmtStr, Args, indent);
end;

constructor TRunLogger.Create(DebugerName: string);
begin
FPipeName := '//./pipe/' + DebugerName;
FHandle := 0;
FCrit := TCriticalSection.Create;
Ticks:=0;
end;

destructor TRunLogger.Destroy;
begin
FCrit.leave;
FCrit.free;
if FHandle <> 0 then
CloseHandle(FHandle);
inherited;
end;

procedure TRunLogger.WriteFmt(FormatStr: string;
const Args: array of const; Indent: Integer = 0);
begin
if not FLog then
exit;
Write(Format(FormatStr, Args), Indent);
end;

procedure TRunLogger.Write(FormatStr: string; Indent: Integer = 0);
var
dwIOSize: DWORD;
P: PChar;
i: integer;
dd: string;
begin
if not FLog then
exit;
FCrit.Enter;
if (FHandle = 0) or (FHandle = INVALID_HANDLE_VALUE) then
begin
tryOpenPipe;
end;
if FHandle <> INVALID_HANDLE_VALUE then
begin
dwIOSize := 0;
if Indent > 0 then
begin
FormatStr := FormatStr + ':Enter';
end
else if Indent < 0 then
begin
FIndent := FIndent + Indent;
FormatStr := FormatStr + ':Leave';
Indent := 0;
end;
for i := 0 to Findent - 1 do
begin
dd := dd + '| ';
end;
FIndent := FIndent + Indent;
if not WriteFile(FHandle, pChar(dd + FormatStr)^, length(dd + FormatStr), dwIOSize, nil) then
begin
CloseHandle(FHandle);
FHandle:=0;
end;
end;
FCrit.Leave;
end;

procedure TRunLogger.SetPipeName(S: string);
begin
FPipeName := '//./pipe/' + S;
end;

procedure TRunLogger.TryOpenPipe;
var
NT: DWORD;
begin
NT := GetTickCount;
if (Ticks = 0) or (NT - Ticks >= 1000) then
begin
Ticks:=NT;
FHandle := CreateFile(PChar(PipeName),
GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);
end;
end;

initialization
Logger := TRunLogger.Create('G5DEBUG');
finalization
Logger.Free;
end.

没人提意见？

老兄，要本运行不起来，怎么回事？
我的客户端：
program TestClient;
{$APPTYPE CONSOLE}
uses
SysUtils, U_Logger;
begin
LogIt('hello world', []);
Writeln('hello world');
end.

还有你的函数
function ConnectToNewClient(h: THANDLE; pOVL: POVERLAPPED): Boolean;
感觉很不合理
Delphi的编绎后的警告、提示信息一般有它的作用，一般情况下是根据它的信息找
出对应的代码，调整代码后，自然会把那些信息去了，可别小看这些warn,hint的信息哦。[]

SaveToFile中，CreateFile有个标志是file not exists then create, else open
F := CreateFile(PChar(LogFileName), GENERIC_WRITE, 0, nil, OPEN_ALWAYS,
FILE_ATTRIBUTE_ARCHIVE, 0);

感觉你是标准VC程序员，呵呵。[]
快把能调试的代码写出来。[]

program Project1;

{$APPTYPE CONSOLE}

uses
SysUtils,
U_Logger in '../Work/G5Studio标准模块/Logger/Client/U_Logger.pas';

begin
{ TODO -oUser -cConsole Main : Insert code here }
Logger.FLog:=true;
Logit('呵呵，这下好了:%s',['是吗?'],1);
Logit('呵呵，这下好了:%s',['是吗?'],1);
Logit('呵呵，这下好了:%s',['是吗?'],1);
Logit('呵呵，这下好了:%s',['是吗?'],-1);
Logit('呵呵，这下好了:%s',['是吗?'],-1);
Logit('呵呵，这下好了:%s',['是吗?'],-1);
Logit('等到信息完全些过去啊:%s',['是吗?']);
Sleep(1000);
end.

对了，u_logger.pas新版本：
unit U_Logger;

interface
uses Windows, sysutils, syncobjs;
type
TRunLogger = class
public
OVL: OVERLAPPED;
private
FPipeName: string;
FCrit: TCriticalSection;
FHandle: THandle;
FIndent: Integer;
Ticks: DWORD;
procedure SetPipeName(S: string);
public
FLog: Boolean;
constructor Create(DebugerName: string = 'G5DEBUG');
destructor Destroy; override;
procedure WriteFmt(FormatStr: string; const Args: array of const; Indent: Integer = 0);
procedure Write(FormatStr: string; Indent: Integer = 0);
property PipeName: string read FPipeName write SetPipeName;
procedure TryOpenPipe;
end;
var
Logger: TRunLogger;
procedure LogIt(const FmtStr: string; args: array of const; Indent: Integer = 0);
implementation
uses FileCtrl;
{ TRunLogger }

procedure LogIt(const FmtStr: string; args: array of const; indent: Integer = 0);
begin
Logger.WriteFmt(FmtStr, Args, indent);
end;

constructor TRunLogger.Create(DebugerName: string);
begin
FPipeName := '//./pipe/' + DebugerName;
FHandle := 0;
FCrit := TCriticalSection.Create;
Ticks := 0;
end;

destructor TRunLogger.Destroy;
begin
FCrit.leave;
FCrit.free;
if FHandle <> 0 then
CloseHandle(FHandle);
inherited;
end;

procedure TRunLogger.WriteFmt(FormatStr: string;
const Args: array of const; Indent: Integer = 0);
begin
if not FLog then
exit;
Write(Format(FormatStr, Args), Indent);
end;

procedure TRunLogger.Write(FormatStr: string; Indent: Integer = 0);
var
dwIOSize: DWORD;
P: PChar;
i: integer;
dd: string;
begin
if not FLog then
exit;
FCrit.Enter;
if (FHandle = 0) or (FHandle = INVALID_HANDLE_VALUE) then
begin
tryOpenPipe;
end;
if FHandle <> INVALID_HANDLE_VALUE then
begin
dwIOSize := 0;
if Indent > 0 then
begin
FormatStr := FormatStr + ':Enter';
end
else if Indent < 0 then
begin
FIndent := FIndent + Indent;
FormatStr := FormatStr + ':Leave';
Indent := 0;
end;
for i := 0 to Findent - 1 do
begin
dd := dd + '| ';
end;
FIndent := FIndent + Indent;
if (not WriteFile(FHandle, pChar(dd + FormatStr)^, length(dd + FormatStr), dwIOSize, @OVL))
and (GetLastError <> ERROR_IO_PENDING) then
begin
CloseHandle(FHandle);
FHandle := 0;
end;
end;
SetLastError(0);
FCrit.Leave;
end;

procedure TRunLogger.SetPipeName(S: string);
begin
FPipeName := '//./pipe/' + S;
end;

procedure TRunLogger.TryOpenPipe;
var
NT: DWORD;
begin
NT := GetTickCount;
if (Ticks = 0) or (NT - Ticks >= 1000) then
begin
Ticks := NT;
FHandle := CreateFile(PChar(PipeName),
GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
end;
end;

initialization
Logger := TRunLogger.Create('G5DEBUG');
finalization
Logger.Free;
end.

原来客户端有错，现在可以了。不错

PIPE是什么呀？

就是：一句话讲不清，但很有用，如果想知道就F1的那个东西啊

[8D]

再2000上运行要出错误，再写之前加个readfile的请求，读取0字节，就好了