Add missing files of issue #19837

git-svn-id: trunk@39247 -

.gitattributes

@@ -4815,6 +4815,8 @@ ide/include/netbsd/lazconf.inc svneol=native#text/pascal
 ide/include/solaris/lazconf.inc svneol=native#text/plain
 ide/include/unix/lazbaseconf.inc svneol=native#text/pascal
 ide/include/win/lazbaseconf.inc svneol=native#text/plain
+ide/include/win/raw_window.pas svneol=native#text/plain
+ide/include/win/redirect_stderr.pas svneol=native#text/plain
 ide/include/win32/lazconf.inc svneol=native#text/pascal
 ide/include/win64/lazconf.inc svneol=native#text/plain
 ide/infobuild.lfm svneol=native#text/plain

ide/include/win/raw_window.pas

@@ -0,0 +1,163 @@
+unit raw_window;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  SysUtils, Windows, Messages;
+
+procedure ShowWindow(AStr : String);
+
+implementation
+
+Var
+  WndHandle,
+  ButtonHandle,
+  EditHandle : HWND;
+  OldSubProc : WNDPROC;
+
+function isset(value: dword; bit: byte): boolean;
+begin
+   result := value and (1 shl pred(bit)) <> 0;
+end;
+
+function WindowWndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam) : LRESULT; stdcall;
+Var
+  ControlCode, ControlID : Word;
+begin
+  Result := 0;
+  Case uMsg  Of
+    WM_DESTROY : PostQuitMessage(0);
+    WM_COMMAND : Begin
+                   ControlCode := HiWord(wParam);
+                   ControlID := LoWord(wParam);
+                   Case ControlCode Of
+                     BN_CLICKED : If lParam = ButtonHandle Then
+                                    PostMessage(WndHandle, WM_CLOSE, 0, 0);
+                   end;
+                 end;
+    WM_SETFOCUS:  SetFocus(EditHandle);
+    Else
+      Result := Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
+  End;
+
+end;
+
+function EditSubProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam) : LRESULT; stdcall;
+Var
+  AKeyboardState : TKeyboardState;
+Begin
+  Case uMsg of
+    WM_KEYDOWN : Begin
+                   GetKeyboardState(AKeyboardState);
+                   If isset(AKeyboardState[VK_CONTROL], 8) And isset(AKeyboardState[VK_A], 8) Then Begin
+                     SendMessage(EditHandle, EM_SETSEL, 0, -1);
+                     Exit(0);
+                   end;
+                   If isset(AKeyboardState[VK_CONTROL], 8) And isset(AKeyboardState[VK_C], 8) Then Begin
+                     PostMessage(EditHandle, WM_COPY, 0, 0);
+                     Exit(0);
+                   End;
+                   If isset(AKeyboardState[VK_RETURN], 8) Or isset(AKeyboardState[VK_ESCAPE], 8)  Then Begin
+                     PostMessage(ButtonHandle, BM_CLICK, 0, 0);
+                     Exit(0);
+                   end;
+
+                 end;
+  End;
+  Result := CallWindowProc(OldSubProc, Ahwnd, uMsg, wParam, lParam);
+end;
+
+
+procedure ShowWindow(AStr : String);
+Var
+  A_Atom : TAtom = 0;
+  WndClass : TWndClass;
+  Msg: TMsg;
+  ScreenWidth, ScreenHeight, MiddleX, MiddleY : LongInt;
+Begin
+  FillChar(WndClass, SizeOf(TWndClass), 0);
+
+  ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
+  ScreenHeight := GetSystemMetrics(SM_CYSCREEN);
+
+  MiddleX := (ScreenWidth - 500) Div 2;
+  MiddleY := (ScreenHeight - 500) div 2;
+
+  WndClass.lpszClassName:= 'HEAPTRACE_CLASS';
+  WndClass.lpfnWndProc :=  @WindowWndProc;
+
+  WndClass.hInstance := hInstance;
+  WndClass.hbrBackground:= 1;
+  WndClass.style := CS_HREDRAW or CS_VREDRAW;
+  WndClass.hCursor := LoadCursor(0, IDC_ARROW);
+
+  A_Atom := RegisterClass(WndClass);
+
+  WndHandle := CreateWindow(
+   WndClass.lpszClassName , // lpClassName, optional
+   'Heaptrace results', // lpWindowName, optional
+   WS_OVERLAPPEDWINDOW or WS_VISIBLE , // dwStyle
+   MiddleX, // x
+   MiddleY, // y
+   500, // nWidth
+   500, // nHeight
+   0, // hWndParent
+   0, // hMenu
+   WndClass.hInstance, // hInstance
+   nil  // lpParam
+   );
+
+  // Button control
+
+  ButtonHandle := CreateWindow(
+   'BUTTON' , // lpClassName, optional
+   'OK', // lpWindowName, optional
+   WS_TABSTOP or WS_VISIBLE or WS_CHILD or BS_DEFPUSHBUTTON , // dwStyle
+   400, // x
+   400, // y
+   50, // nWidth
+   50, // nHeight
+   WndHandle, // hWndParent
+   0, // hMenu
+   WndClass.hInstance, // hInstance
+   nil  // lpParam
+   );
+
+  // Edit control
+
+  EditHandle := CreateWindow(
+   'EDIT' , // lpClassName, optional
+   NIL, // lpWindowName, optional
+   WS_CHILD or WS_VISIBLE or WS_VSCROLL or WS_HSCROLL or WS_BORDER or ES_LEFT or ES_MULTILINE or ES_AUTOHSCROLL or ES_AUTOVSCROLL or ES_READONLY, // dwStyle
+   10, // x
+   10, // y
+   450, // nWidth
+   370, // nHeight
+   WndHandle, // hWndParent
+   0, // hMenu
+   WndClass.hInstance, // hInstance
+   nil  // lpParam
+   );
+
+  SetWindowText(EditHandle, PChar(UTF8ToAnsi(AStr)));
+
+  OldSubProc := Windows.WNDPROC(GetWindowLongPtr(EditHandle, GWL_WNDPROC));
+  SetWindowLongPtr(EditHandle, GWL_WNDPROC, PtrUint(@EditSubProc));
+
+  BringWindowToTop(WndHandle);
+  SetFocus(EditHandle);
+
+  while GetMessage(Msg,0,0,0) do
+    DispatchMessage(Msg);
+
+  DestroyWindow(ButtonHandle);
+  DestroyWindow(EditHandle);
+  DestroyWindow(WndHandle);
+
+  UnregisterClass(WndClass.lpszClassName, WndClass.hInstance);
+end;
+
+end.
+

ide/include/win/redirect_stderr.pas

@@ -0,0 +1,113 @@
+unit redirect_stderr;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  heaptrc, SysUtils, raw_window;
+  
+Var
+  DoShowWindow : Boolean = True;
+
+implementation
+
+const
+  ErrorBufferLength = 2 * 1024;
+
+var
+  ErrorBuf : array[0..ErrorBufferLength] of char;
+  ErrorLen : SizeInt;
+
+  ErrorMsg : String = '';
+  MyStdErr : Text;
+
+Function ErrorWrite(Var F: TextRec): Integer;
+{
+  An error message should always end with #13#10#13#10
+}
+var
+  i : SizeInt;
+Begin
+  while F.BufPos>0 do
+    begin
+      begin
+        if F.BufPos+ErrorLen>ErrorBufferLength then
+          i:=ErrorBufferLength-ErrorLen
+        else
+          i:=F.BufPos;
+        Move(F.BufPtr^,ErrorBuf[ErrorLen],i);
+        inc(ErrorLen,i);
+        ErrorBuf[ErrorLen]:=#0;
+      end;
+      if ErrorLen >= ErrorBufferLength then
+        begin
+          ErrorMsg := ErrorMsg + String(ErrorBuf);
+          ErrorLen:=0;
+          ErrorBuf[ErrorLen]:=#0;
+        end;
+      Dec(F.BufPos,i);
+    end;
+  ErrorWrite:=0;
+End;
+
+
+Function ErrorClose(Var F: TextRec): Integer;
+begin
+  if ErrorLen>0 then
+   begin
+     ErrorMsg := ErrorMsg + String(ErrorBuf);
+     ErrorLen:=0;     
+   end;
+  If (ErrorMsg <> '') And DoShowWindow Then Begin
+    ShowWindow(ErrorMsg);
+    ErrorMsg := '';
+  end;
+  ErrorLen:=0;
+  ErrorBuf[ErrorLen]:=#0;
+  ErrorClose:=0;
+end;
+
+Function ErrorFlush(Var F: TextRec): Integer;
+begin
+  ErrorWrite(F);
+  if ErrorLen>0 then
+   begin
+     ErrorMsg := ErrorMsg + String(ErrorBuf);
+     ErrorLen:=0;     
+   end;
+  ErrorLen:=0;
+  ErrorBuf[ErrorLen]:=#0;
+  ErrorFlush:=0;
+end;
+
+Function ErrorOpen(Var F: TextRec): Integer;
+Begin
+  TextRec(F).InOutFunc:=@ErrorWrite;
+  TextRec(F).FlushFunc:=@ErrorFlush;
+  TextRec(F).CloseFunc:=@ErrorClose;
+  ErrorLen:=0;
+  ErrorBuf[ErrorLen]:=#0;
+  ErrorOpen:=0;
+  ErrorMsg := '';
+End;
+
+
+procedure AssignError(Var T: Text);
+begin
+  Assign(T,'');
+
+  TextRec(T).OpenFunc:=@ErrorOpen;
+
+  Rewrite(T);
+end;
+
+initialization
+  AssignError(MyStdErr);
+  SetHeapTraceOutput(MyStdErr);
+
+
+finalization
+
+end.
+