1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Abstract:
22 ToDo...
23 }
24 unit redirect_stderr;
25
26 {$mode objfpc}{$H+}
27 {$I ide.inc}
28
29 interface
30
31 {$IFDEF EnableRedirectStdErr}
32 uses
33 heaptrc, SysUtils, raw_window;
34 {$ENDIF}
35
36 Var
37 DoShowWindow : Boolean = True;
38
39 implementation
40
41 {$IFDEF EnableRedirectStdErr}
42 const
43 ErrorBufferLength = 2 * 1024;
44
45 var
46 ErrorBuf : array[0..ErrorBufferLength] of char;
47 ErrorLen : SizeInt;
48
49 ErrorMsg : String = '';
50 MyStdErr : Text;
51
ErrorWritenull52 Function ErrorWrite(Var F: TextRec): Integer;
53 {
54 An error message should always end with #13#10#13#10
55 }
56 var
57 i : SizeInt;
58 Begin
59 while F.BufPos>0 do
60 begin
61 if F.BufPos+ErrorLen>ErrorBufferLength then
62 i:=ErrorBufferLength-ErrorLen
63 else
64 i:=F.BufPos;
65 Move(F.BufPtr^,ErrorBuf[ErrorLen],i);
66 inc(ErrorLen,i);
67 ErrorBuf[ErrorLen]:=#0;
68 if ErrorLen >= ErrorBufferLength then
69 begin
70 ErrorMsg := ErrorMsg + String(ErrorBuf);
71 ErrorLen:=0;
72 ErrorBuf[ErrorLen]:=#0;
73 end;
74 Dec(F.BufPos,i);
75 end;
76 ErrorWrite:=0;
77 End;
78
79
ErrorClosenull80 Function ErrorClose(Var F: TextRec): Integer;
81 begin
82 if ErrorLen>0 then
83 begin
84 ErrorMsg := ErrorMsg + String(ErrorBuf);
85 ErrorLen:=0;
86 end;
87 If (ErrorMsg <> '') And DoShowWindow Then Begin
88 ShowWindow(ErrorMsg);
89 ErrorMsg := '';
90 end;
91 ErrorLen:=0;
92 ErrorBuf[ErrorLen]:=#0;
93 ErrorClose:=0;
94 end;
95
ErrorFlushnull96 Function ErrorFlush(Var F: TextRec): Integer;
97 begin
98 ErrorWrite(F);
99 if ErrorLen>0 then
100 begin
101 ErrorMsg := ErrorMsg + String(ErrorBuf);
102 ErrorLen:=0;
103 end;
104 ErrorLen:=0;
105 ErrorBuf[ErrorLen]:=#0;
106 ErrorFlush:=0;
107 end;
108
ErrorOpennull109 Function ErrorOpen(Var F: TextRec): Integer;
110 Begin
111 TextRec(F).InOutFunc:=@ErrorWrite;
112 TextRec(F).FlushFunc:=@ErrorFlush;
113 TextRec(F).CloseFunc:=@ErrorClose;
114 ErrorLen:=0;
115 ErrorBuf[ErrorLen]:=#0;
116 ErrorOpen:=0;
117 ErrorMsg := '';
118 End;
119
120
121 procedure AssignError(Var T: Text);
122 begin
123 Assign(T,'');
124 TextRec(T).OpenFunc:=@ErrorOpen;
125 Rewrite(T);
126 end;
127
128 initialization
129 AssignError(MyStdErr);
130 SetHeapTraceOutput(MyStdErr);
131
132 {$ENDIF}
133
134 end.
135
136