mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 12:59:24 +02:00
* unified some win32/win64 code
git-svn-id: trunk@11745 -
This commit is contained in:
florian
parent
6ba813b261
commit
a8804cf2a6
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -6173,6 +6173,7 @@ rtl/win/sysos.inc svneol=native#text/plain
|
||||
rtl/win/sysosh.inc svneol=native#text/plain
|
||||
rtl/win/systhrd.inc svneol=native#text/plain
|
||||
rtl/win/sysutils.pp svneol=native#text/plain
|
||||
rtl/win/syswin.inc svneol=native#text/plain
|
||||
rtl/win/tthread.inc svneol=native#text/plain
|
||||
rtl/win/varutils.pp svneol=native#text/plain
|
||||
rtl/win/video.pp svneol=native#text/plain
|
||||
|
||||
188
rtl/win/syswin.inc
Normal file
188
rtl/win/syswin.inc
Normal file
@ -0,0 +1,188 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1999-2008 by Florian Klaempfl and Pavel Ozerski
|
||||
member of the Free Pascal development team.
|
||||
|
||||
FPC Pascal system unit part shared by win32/win64.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
{****************************************************************************
|
||||
Error Message writing using messageboxes
|
||||
****************************************************************************}
|
||||
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
stdcall;external 'user32' name 'MessageBoxA';
|
||||
|
||||
const
|
||||
ErrorBufferLength = 1024;
|
||||
var
|
||||
ErrorBuf : array[0..ErrorBufferLength] of char;
|
||||
ErrorLen : SizeInt;
|
||||
|
||||
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
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
Dec(F.BufPos,i);
|
||||
end;
|
||||
ErrorWrite:=0;
|
||||
End;
|
||||
|
||||
|
||||
Function ErrorClose(Var F: TextRec): Integer;
|
||||
begin
|
||||
if ErrorLen>0 then
|
||||
begin
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
ErrorLen:=0;
|
||||
ErrorClose:=0;
|
||||
end;
|
||||
|
||||
|
||||
Function ErrorOpen(Var F: TextRec): Integer;
|
||||
Begin
|
||||
TextRec(F).InOutFunc:=@ErrorWrite;
|
||||
TextRec(F).FlushFunc:=@ErrorWrite;
|
||||
TextRec(F).CloseFunc:=@ErrorClose;
|
||||
ErrorLen:=0;
|
||||
ErrorOpen:=0;
|
||||
End;
|
||||
|
||||
|
||||
procedure AssignError(Var T: Text);
|
||||
begin
|
||||
Assign(T,'');
|
||||
TextRec(T).OpenFunc:=@ErrorOpen;
|
||||
Rewrite(T);
|
||||
end;
|
||||
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
|
||||
displayed in a messagebox }
|
||||
StdInputHandle:=longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
|
||||
StdOutputHandle:=longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
|
||||
StdErrorHandle:=longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
|
||||
if not IsConsole then
|
||||
begin
|
||||
AssignError(stderr);
|
||||
AssignError(StdOut);
|
||||
Assign(Output,'');
|
||||
Assign(Input,'');
|
||||
Assign(ErrOutput,'');
|
||||
end
|
||||
else
|
||||
begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ProcessID cached to avoid repeated calls to GetCurrentProcess. }
|
||||
|
||||
var
|
||||
ProcessID: SizeUInt;
|
||||
|
||||
function GetProcessID: SizeUInt;
|
||||
begin
|
||||
GetProcessID := ProcessID;
|
||||
end;
|
||||
|
||||
|
||||
{******************************************************************************
|
||||
Unicode
|
||||
******************************************************************************}
|
||||
|
||||
procedure Win32Unicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
|
||||
var
|
||||
destlen: SizeInt;
|
||||
begin
|
||||
// retrieve length including trailing #0
|
||||
// not anymore, because this must also be usable for single characters
|
||||
destlen:=WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil);
|
||||
// this will null-terminate
|
||||
setlength(dest, destlen);
|
||||
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil);
|
||||
end;
|
||||
|
||||
procedure Win32Ansi2UnicodeMove(source:pchar;var dest:UnicodeString;len:SizeInt);
|
||||
var
|
||||
destlen: SizeInt;
|
||||
begin
|
||||
// retrieve length including trailing #0
|
||||
// not anymore, because this must also be usable for single characters
|
||||
destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
|
||||
// this will null-terminate
|
||||
setlength(dest, destlen);
|
||||
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
|
||||
end;
|
||||
|
||||
|
||||
function Win32UnicodeUpper(const s : UnicodeString) : UnicodeString;
|
||||
begin
|
||||
result:=s;
|
||||
UniqueString(result);
|
||||
if length(result)>0 then
|
||||
CharUpperBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
|
||||
function Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
|
||||
begin
|
||||
result:=s;
|
||||
UniqueString(result);
|
||||
if length(result)>0 then
|
||||
CharLowerBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
|
||||
{ there is a similiar procedure in sysutils which inits the fields which
|
||||
are only relevant for the sysutils units }
|
||||
procedure InitWin32Widestrings;
|
||||
begin
|
||||
{ Widestring }
|
||||
widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
|
||||
widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
|
||||
widestringmanager.UpperWideStringProc:=@Win32WideUpper;
|
||||
widestringmanager.LowerWideStringProc:=@Win32WideLower;
|
||||
{$ifndef VER2_2}
|
||||
{ Unicode }
|
||||
widestringmanager.Unicode2AnsiMoveProc:=@Win32Unicode2AnsiMove;
|
||||
widestringmanager.Ansi2UnicodeMoveProc:=@Win32Ansi2UnicodeMove;
|
||||
widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper;
|
||||
widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower;
|
||||
{$endif VER2_2}
|
||||
end;
|
||||
@ -958,253 +958,81 @@ function Win32WideLower(const s : WideString) : WideString;
|
||||
CharLowerBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
{******************************************************************************
|
||||
Unicode
|
||||
******************************************************************************}
|
||||
{******************************************************************************}
|
||||
{ include code common with win64 }
|
||||
|
||||
procedure Win32Unicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
|
||||
var
|
||||
destlen: SizeInt;
|
||||
begin
|
||||
// retrieve length including trailing #0
|
||||
// not anymore, because this must also be usable for single characters
|
||||
destlen:=WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil);
|
||||
// this will null-terminate
|
||||
setlength(dest, destlen);
|
||||
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil);
|
||||
end;
|
||||
{$I syswin.inc}
|
||||
{******************************************************************************}
|
||||
|
||||
procedure Win32Ansi2UnicodeMove(source:pchar;var dest:UnicodeString;len:SizeInt);
|
||||
var
|
||||
destlen: SizeInt;
|
||||
begin
|
||||
// retrieve length including trailing #0
|
||||
// not anymore, because this must also be usable for single characters
|
||||
destlen:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
|
||||
// this will null-terminate
|
||||
setlength(dest, destlen);
|
||||
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], destlen);
|
||||
end;
|
||||
|
||||
|
||||
function Win32UnicodeUpper(const s : UnicodeString) : UnicodeString;
|
||||
begin
|
||||
result:=s;
|
||||
UniqueString(result);
|
||||
if length(result)>0 then
|
||||
CharUpperBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
|
||||
function Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
|
||||
begin
|
||||
result:=s;
|
||||
UniqueString(result);
|
||||
if length(result)>0 then
|
||||
CharLowerBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
|
||||
{ there is a similiar procedure in sysutils which inits the fields which
|
||||
are only relevant for the sysutils units }
|
||||
procedure InitWin32Widestrings;
|
||||
begin
|
||||
{ Widestring }
|
||||
widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
|
||||
widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
|
||||
widestringmanager.UpperWideStringProc:=@Win32WideUpper;
|
||||
widestringmanager.LowerWideStringProc:=@Win32WideLower;
|
||||
{$ifndef VER2_2}
|
||||
{ Unicode }
|
||||
widestringmanager.Unicode2AnsiMoveProc:=@Win32Unicode2AnsiMove;
|
||||
widestringmanager.Ansi2UnicodeMoveProc:=@Win32Ansi2UnicodeMove;
|
||||
widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper;
|
||||
widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower;
|
||||
{$endif VER2_2}
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Error Message writing using messageboxes
|
||||
****************************************************************************}
|
||||
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
stdcall;external 'user32' name 'MessageBoxA';
|
||||
|
||||
const
|
||||
ErrorBufferLength = 1024;
|
||||
var
|
||||
ErrorBuf : array[0..ErrorBufferLength] of char;
|
||||
ErrorLen : longint;
|
||||
|
||||
Function ErrorWrite(Var F: TextRec): Integer;
|
||||
{
|
||||
An error message should always end with #13#10#13#10
|
||||
}
|
||||
var
|
||||
i : longint;
|
||||
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
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
Dec(F.BufPos,i);
|
||||
end;
|
||||
ErrorWrite:=0;
|
||||
End;
|
||||
|
||||
|
||||
Function ErrorClose(Var F: TextRec): Integer;
|
||||
begin
|
||||
if ErrorLen>0 then
|
||||
begin
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
ErrorLen:=0;
|
||||
ErrorClose:=0;
|
||||
end;
|
||||
|
||||
|
||||
Function ErrorOpen(Var F: TextRec): Integer;
|
||||
Begin
|
||||
TextRec(F).InOutFunc:=@ErrorWrite;
|
||||
TextRec(F).FlushFunc:=@ErrorWrite;
|
||||
TextRec(F).CloseFunc:=@ErrorClose;
|
||||
ErrorLen:=0;
|
||||
ErrorOpen:=0;
|
||||
End;
|
||||
|
||||
|
||||
procedure AssignError(Var T: Text);
|
||||
begin
|
||||
Assign(T,'');
|
||||
TextRec(T).OpenFunc:=@ErrorOpen;
|
||||
Rewrite(T);
|
||||
end;
|
||||
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
|
||||
displayed in a messagebox }
|
||||
StdInputHandle:=longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
|
||||
StdOutputHandle:=longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
|
||||
StdErrorHandle:=longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
|
||||
if not IsConsole then
|
||||
begin
|
||||
AssignError(stderr);
|
||||
AssignError(StdOut);
|
||||
Assign(Output,'');
|
||||
Assign(Input,'');
|
||||
Assign(ErrOutput,'');
|
||||
end
|
||||
else
|
||||
begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ProcessID cached to avoid repeated calls to GetCurrentProcess. }
|
||||
|
||||
var
|
||||
ProcessID: SizeUInt;
|
||||
|
||||
function GetProcessID: SizeUInt;
|
||||
begin
|
||||
GetProcessID := ProcessID;
|
||||
end;
|
||||
|
||||
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
|
||||
type
|
||||
tdosheader = packed record
|
||||
e_magic : word;
|
||||
e_cblp : word;
|
||||
e_cp : word;
|
||||
e_crlc : word;
|
||||
e_cparhdr : word;
|
||||
e_minalloc : word;
|
||||
e_maxalloc : word;
|
||||
e_ss : word;
|
||||
e_sp : word;
|
||||
e_csum : word;
|
||||
e_ip : word;
|
||||
e_cs : word;
|
||||
e_lfarlc : word;
|
||||
e_ovno : word;
|
||||
e_res : array[0..3] of word;
|
||||
e_oemid : word;
|
||||
e_oeminfo : word;
|
||||
e_res2 : array[0..9] of word;
|
||||
e_lfanew : longint;
|
||||
end;
|
||||
tpeheader = packed record
|
||||
PEMagic : longint;
|
||||
Machine : word;
|
||||
NumberOfSections : word;
|
||||
TimeDateStamp : longint;
|
||||
PointerToSymbolTable : longint;
|
||||
NumberOfSymbols : longint;
|
||||
SizeOfOptionalHeader : word;
|
||||
Characteristics : word;
|
||||
Magic : word;
|
||||
MajorLinkerVersion : byte;
|
||||
MinorLinkerVersion : byte;
|
||||
SizeOfCode : longint;
|
||||
SizeOfInitializedData : longint;
|
||||
SizeOfUninitializedData : longint;
|
||||
AddressOfEntryPoint : longint;
|
||||
BaseOfCode : longint;
|
||||
BaseOfData : longint;
|
||||
ImageBase : longint;
|
||||
SectionAlignment : longint;
|
||||
FileAlignment : longint;
|
||||
MajorOperatingSystemVersion : word;
|
||||
MinorOperatingSystemVersion : word;
|
||||
MajorImageVersion : word;
|
||||
MinorImageVersion : word;
|
||||
MajorSubsystemVersion : word;
|
||||
MinorSubsystemVersion : word;
|
||||
Reserved1 : longint;
|
||||
SizeOfImage : longint;
|
||||
SizeOfHeaders : longint;
|
||||
CheckSum : longint;
|
||||
Subsystem : word;
|
||||
DllCharacteristics : word;
|
||||
SizeOfStackReserve : longint;
|
||||
SizeOfStackCommit : longint;
|
||||
SizeOfHeapReserve : longint;
|
||||
SizeOfHeapCommit : longint;
|
||||
LoaderFlags : longint;
|
||||
NumberOfRvaAndSizes : longint;
|
||||
DataDirectory : array[1..$80] of byte;
|
||||
end;
|
||||
begin
|
||||
result:=tpeheader((pointer(SysInstance)+(tdosheader(pointer(SysInstance)^).e_lfanew))^).SizeOfStackReserve;
|
||||
end;
|
||||
type
|
||||
tdosheader = packed record
|
||||
e_magic : word;
|
||||
e_cblp : word;
|
||||
e_cp : word;
|
||||
e_crlc : word;
|
||||
e_cparhdr : word;
|
||||
e_minalloc : word;
|
||||
e_maxalloc : word;
|
||||
e_ss : word;
|
||||
e_sp : word;
|
||||
e_csum : word;
|
||||
e_ip : word;
|
||||
e_cs : word;
|
||||
e_lfarlc : word;
|
||||
e_ovno : word;
|
||||
e_res : array[0..3] of word;
|
||||
e_oemid : word;
|
||||
e_oeminfo : word;
|
||||
e_res2 : array[0..9] of word;
|
||||
e_lfanew : longint;
|
||||
end;
|
||||
tpeheader = packed record
|
||||
PEMagic : longint;
|
||||
Machine : word;
|
||||
NumberOfSections : word;
|
||||
TimeDateStamp : longint;
|
||||
PointerToSymbolTable : longint;
|
||||
NumberOfSymbols : longint;
|
||||
SizeOfOptionalHeader : word;
|
||||
Characteristics : word;
|
||||
Magic : word;
|
||||
MajorLinkerVersion : byte;
|
||||
MinorLinkerVersion : byte;
|
||||
SizeOfCode : longint;
|
||||
SizeOfInitializedData : longint;
|
||||
SizeOfUninitializedData : longint;
|
||||
AddressOfEntryPoint : longint;
|
||||
BaseOfCode : longint;
|
||||
BaseOfData : longint;
|
||||
ImageBase : longint;
|
||||
SectionAlignment : longint;
|
||||
FileAlignment : longint;
|
||||
MajorOperatingSystemVersion : word;
|
||||
MinorOperatingSystemVersion : word;
|
||||
MajorImageVersion : word;
|
||||
MinorImageVersion : word;
|
||||
MajorSubsystemVersion : word;
|
||||
MinorSubsystemVersion : word;
|
||||
Reserved1 : longint;
|
||||
SizeOfImage : longint;
|
||||
SizeOfHeaders : longint;
|
||||
CheckSum : longint;
|
||||
Subsystem : word;
|
||||
DllCharacteristics : word;
|
||||
SizeOfStackReserve : longint;
|
||||
SizeOfStackCommit : longint;
|
||||
SizeOfHeapReserve : longint;
|
||||
SizeOfHeapCommit : longint;
|
||||
LoaderFlags : longint;
|
||||
NumberOfRvaAndSizes : longint;
|
||||
DataDirectory : array[1..$80] of byte;
|
||||
end;
|
||||
begin
|
||||
result:=tpeheader((pointer(SysInstance)+(tdosheader(pointer(SysInstance)^).e_lfanew))^).SizeOfStackReserve;
|
||||
end;
|
||||
|
||||
{
|
||||
const
|
||||
Exe_entry_code : pointer = @Exe_entry;
|
||||
Dll_entry_code : pointer = @Dll_entry;
|
||||
}
|
||||
|
||||
begin
|
||||
{ get some helpful informations }
|
||||
|
||||
@ -996,127 +996,11 @@ function Win32WideLower(const s : WideString) : WideString;
|
||||
CharLowerBuff(LPWSTR(result),length(result));
|
||||
end;
|
||||
|
||||
{******************************************************************************}
|
||||
{ include code common with win64 }
|
||||
|
||||
{ there is a similiar procedure in sysutils which inits the fields which
|
||||
are only relevant for the sysutils units }
|
||||
procedure InitWin32Widestrings;
|
||||
begin
|
||||
widestringmanager.Wide2AnsiMoveProc:=@Win32Wide2AnsiMove;
|
||||
widestringmanager.Ansi2WideMoveProc:=@Win32Ansi2WideMove;
|
||||
widestringmanager.UpperWideStringProc:=@Win32WideUpper;
|
||||
widestringmanager.LowerWideStringProc:=@Win32WideLower;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Error Message writing using messageboxes
|
||||
****************************************************************************}
|
||||
|
||||
function MessageBox(w1:longint;l1,l2:pointer;w2:longint):longint;
|
||||
stdcall;external 'user32' name 'MessageBoxA';
|
||||
|
||||
const
|
||||
ErrorBufferLength = 1024;
|
||||
var
|
||||
ErrorBuf : array[0..ErrorBufferLength] of char;
|
||||
ErrorLen : longint;
|
||||
|
||||
Function ErrorWrite(Var F: TextRec): Integer;
|
||||
{
|
||||
An error message should always end with #13#10#13#10
|
||||
}
|
||||
var
|
||||
p : pchar;
|
||||
i : longint;
|
||||
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
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
Dec(F.BufPos,i);
|
||||
end;
|
||||
ErrorWrite:=0;
|
||||
End;
|
||||
|
||||
|
||||
Function ErrorClose(Var F: TextRec): Integer;
|
||||
begin
|
||||
if ErrorLen>0 then
|
||||
begin
|
||||
MessageBox(0,@ErrorBuf,pchar('Error'),0);
|
||||
ErrorLen:=0;
|
||||
end;
|
||||
ErrorLen:=0;
|
||||
ErrorClose:=0;
|
||||
end;
|
||||
|
||||
|
||||
Function ErrorOpen(Var F: TextRec): Integer;
|
||||
Begin
|
||||
TextRec(F).InOutFunc:=@ErrorWrite;
|
||||
TextRec(F).FlushFunc:=@ErrorWrite;
|
||||
TextRec(F).CloseFunc:=@ErrorClose;
|
||||
ErrorLen:=0;
|
||||
ErrorOpen:=0;
|
||||
End;
|
||||
|
||||
|
||||
procedure AssignError(Var T: Text);
|
||||
begin
|
||||
Assign(T,'');
|
||||
TextRec(T).OpenFunc:=@ErrorOpen;
|
||||
Rewrite(T);
|
||||
end;
|
||||
|
||||
|
||||
procedure SysInitStdIO;
|
||||
begin
|
||||
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
|
||||
displayed in a messagebox }
|
||||
StdInputHandle:=THandle(GetStdHandle(STD_INPUT_HANDLE));
|
||||
StdOutputHandle:=THandle(GetStdHandle(STD_OUTPUT_HANDLE));
|
||||
StdErrorHandle:=THandle(GetStdHandle(STD_ERROR_HANDLE));
|
||||
if not IsConsole then
|
||||
begin
|
||||
AssignError(stderr);
|
||||
AssignError(StdOut);
|
||||
Assign(Output,'');
|
||||
Assign(Input,'');
|
||||
Assign(ErrOutput,'');
|
||||
end
|
||||
else
|
||||
begin
|
||||
OpenStdIO(Input,fmInput,StdInputHandle);
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
end;
|
||||
|
||||
(* ProcessID cached to avoid repeated calls to GetCurrentProcess. *)
|
||||
|
||||
var
|
||||
ProcessID: SizeUInt;
|
||||
|
||||
function GetProcessID: SizeUInt;
|
||||
begin
|
||||
GetProcessID := ProcessID;
|
||||
end;
|
||||
|
||||
{$I syswin.inc}
|
||||
{******************************************************************************}
|
||||
|
||||
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;assembler;
|
||||
asm
|
||||
|
||||
Loading…
Reference in New Issue
Block a user