[fpc-devel] StdOut capture for FPC RTL

[Anton Kavalenka]

Dear All.

Currently to implement logger we use the following approach (the code 
was implemented for Delphi/Kylix/FPC).
Logger is intended for displaying in the GUI outputs of several threads 
and child processes and also for storage into internal bases.

Logic is the following:

Get stdout handle (duplicate it under linux),
create pipe,
replace the stdout (keeping the old stdout) for current process with 
write handle of pipe,

There are following problems with FPC
Under Windows: I have to call *rewrite(output) *for every thread which 
wants to use  new (captured) stdout

So the questions:
How to force all the threads of process and all DLLs write into same 
captured stdout?
How to revert stdout back (stop capturing)?

procedure TLogger.Start;
{$IFDEF LINUX}
{$ifdef fpc}
type TPipeDescriptors=TFilDes;
{$endif}
var
   pds:TPipeDescriptors;
   {$ENDIF}
begin
  if fCaptureStdout then
   {$IFDEF MSWINDOWS}
     hConsole := GetStdHandle(STD_OUTPUT_HANDLE);
   {$ELSE}
     {$ifdef fpc}
     hConsole := fpdup(StdOutputHandle);;//stdout;
     {$else}
     hConsole := dup(STDOUT_FILENO);;//stdout;
     {$endif}
   {$ENDIF}

   {$IFDEF MSWINDOWS}
     CreatePipe(hReadPipe, hWritePipe, nil, 0);
   {$ENDIF}

   {$IFDEF LINUX}
     {$ifdef fpc}
     fppipe(pds);
     hReadPipe:=pds[0];
     hWritePipe:=pds[1];
     {$else}
     pipe(pds);
     hReadPipe:=pds.ReadDes;
     hWritePipe:=pds.WriteDes;
     {$endif}
   {$ENDIF}

   if fCaptureStdout then
   begin
     {$IFDEF MSWINDOWS}
       if not SetStdHandle(STD_OUTPUT_HANDLE, hWritePipe)
       then MessageBox(0,PChar(Format('Function: SetStdHandle(%x,%x), 
Error: %d',[STD_OUTPUT_HANDLE, hWritePipe, GetLastError])),'Failed',0);
      {$IFDEF fpc}
* StdOutputHandle:=hWritePipe; // modify global runtime handle*
      {$ENDIF}
       if GetStdHandle(STD_OUTPUT_HANDLE)<>hWritePipe then
       begin
         safeputs('Looks like SetStdHandle failed in Windows 7, will try 
AllocConsole workaround'#13#10,hWritePipe);
         if not fWinConsole then
         begin
           AllocConsole;
           FreeConsole;
           SetStdHandle(STD_OUTPUT_HANDLE, hWritePipe);
         end;
         if GetStdHandle(STD_OUTPUT_HANDLE)<>hWritePipe then
         begin
           safeputs('AllocConsole workaround failed, will use 
GlobalWritePipe workaround'#13#10,hWritePipe);
           GlobalWritePipe:=hWritePipe;
           TTextRec(output).Handle:=hWritePipe;
         end;
       end;
*rewrite(output);*
     {$ENDIF}
     {$IFDEF LINUX}
       {$ifdef fpc}
       fpdup2(hWritePipe, StdOutputHandle);
       {$else}
       dup2(hWritePipe, STDOUT_FILENO);
       {$endif}
     {$ENDIF}
   end;
end;


finalizing capture made via

procedure TLogger.Stop;
var dummy:integer;
{$IFDEF LINUX}
   p:pointer;
{$ENDIF}
begin
     if fExitFlag then Exit;

     fExitFlag := True;

   // make empty write to wake up the thread sleeping on read operation
   dummy:=0;
   FileWrite(hWritePipe,dummy,1);

   if hThread<>0 then
   begin
     {$IFDEF MSWINDOWS}
     if WaitForSingleObject(hThread,2000)=WAIT_TIMEOUT
     then begin
       TerminateThread(hThread,0);
       MessageBeep(UINT(-1));
       writeln('Thread was terminated abnormally');
     end;
     Closehandle(hThread);
     {$ENDIF}
     {$IFDEF LINUX}
         {$ifndef FPC} // Kylix
       pthread_join(hThread,nil); //Unfortunately, will wait INFINITEly
       pthread_detach(hThread);
       {$else}
       WaitForThreadTerminate (hThread, 2000); // implies pthread_join
       KillThread(hThread); // implies pthread_detach and pthread_kill
       {$endif}
     {$ENDIF}
     hThread:=0;
   end;

   if fCaptureStdout then
   begin
     {$IFDEF MSWINDOWS}
       SetStdHandle(STD_OUTPUT_HANDLE, hConsole);
       if GlobalWritePipe = hWritePipe then 
GlobalWritePipe:=INVALID_HANDLE_VALUE;
     {$ENDIF}
     {$IFDEF LINUX}
       {$ifdef fpc}
       fpdup2(hConsole, StdOutputHandle);
       {$else}
       dup2(hConsole, STDOUT_FILENO);
       {$endif}
     {$ENDIF}
     rewrite(output);
   end;

     if hReadPipe <> 0 then
     begin
     FileClose(hReadPipe);
         hReadPipe := 0;
     end;

   if hWritePipe <> 0 then
     begin
     FileClose(hWritePipe);
         hWritePipe := 0;
     end;


     if IsLogFileOpened then
     begin
     FileClose(hLogFile);
         hLogFile := 0;
     end;
end;





-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.freepascal.org/pipermail/fpc-devel/attachments/20101124/858f11b8/attachment.html>