mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 15:20:08 +02:00
2d454dc8fa
Each port that allows the usage of dynamic libraries should call InitSystemDynLibs during initialization of the System unit. The DynLibs unit has been adjusted to be a forwarder for the functions that now reside in the System unit (for backwards compatiblity just in case). Additionally the unit will register the DynLibsManager if it doesn't reside in the System unit anyway. Currently only the Windows targets (Win32, Win64 and WinCE) implement the DynLibsManager inside the System unit. For other systems using the LoadLibrary, etc. functions will lead to a run error/exception. If a port wants to implement its own DynLibsManager then it needs to define DISABLE_NO_DYNLIBS_MANAGER. TLibHandle, NilHandle and optionally TOrdinalEntry (it's set to SizeUInt otherwise) should be defined in sysdlh.inc which needs to be enabled using the define FPC_SYSTEM_HAS_SYSDLH (because there are targets which have FEATURE_DYNLIBS enabled, but don't support them... e.g. powerpc-wii -.-). The DynLibsManager contains methods for loading a library based on a RawByteString and based on a UnicodeString. BOTH should be implemented, but internally one can forward to the other. The loading by ordinal *can* be be implemented. If it is set to Nil then the implementation of GetProcAddress(lib,ordinal) will return Nil. + new functions SetDynLibsManager and GetDynLibsManager to set and retrieve the current DynLibsManager * provide interface of DynLibs unit in unit System git-svn-id: trunk@29613 -
445 lines
15 KiB
PHP
445 lines
15 KiB
PHP
{
|
|
Basic stuff for windows rtls
|
|
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2001 by Free Pascal development team
|
|
|
|
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.
|
|
|
|
**********************************************************************}
|
|
|
|
const
|
|
{ constants for GetStdHandle }
|
|
STD_INPUT_HANDLE = dword(-10);
|
|
STD_OUTPUT_HANDLE = dword(-11);
|
|
STD_ERROR_HANDLE = dword(-12);
|
|
INVALID_HANDLE_VALUE = THandle(-1);
|
|
|
|
IGNORE = 0; { Ignore signal }
|
|
INFINITE = longint($FFFFFFFF); { Infinite timeout }
|
|
|
|
{ flags for CreateFile }
|
|
GENERIC_READ=$80000000;
|
|
GENERIC_WRITE=$40000000;
|
|
CREATE_NEW = 1;
|
|
CREATE_ALWAYS = 2;
|
|
OPEN_EXISTING = 3;
|
|
OPEN_ALWAYS = 4;
|
|
TRUNCATE_EXISTING = 5;
|
|
|
|
FILE_ATTRIBUTE_ARCHIVE = 32;
|
|
FILE_ATTRIBUTE_COMPRESSED = 2048;
|
|
FILE_ATTRIBUTE_NORMAL = 128;
|
|
FILE_ATTRIBUTE_DIRECTORY = 16;
|
|
FILE_ATTRIBUTE_HIDDEN = 2;
|
|
FILE_ATTRIBUTE_READONLY = 1;
|
|
FILE_ATTRIBUTE_SYSTEM = 4;
|
|
FILE_ATTRIBUTE_TEMPORARY = 256;
|
|
|
|
{ Share mode open }
|
|
fmShareCompat = $00000000;
|
|
fmShareExclusive = $10;
|
|
fmShareDenyWrite = $20;
|
|
fmShareDenyRead = $30;
|
|
fmShareDenyNone = $40;
|
|
|
|
{ flags for SetFilePos }
|
|
FILE_BEGIN = 0;
|
|
FILE_CURRENT = 1;
|
|
FILE_END = 2;
|
|
|
|
{ GetFileType }
|
|
FILE_TYPE_UNKNOWN = 0;
|
|
FILE_TYPE_DISK = 1;
|
|
FILE_TYPE_CHAR = 2;
|
|
FILE_TYPE_PIPE = 3;
|
|
|
|
VER_PLATFORM_WIN32s = 0;
|
|
VER_PLATFORM_WIN32_WINDOWS = 1;
|
|
VER_PLATFORM_WIN32_NT = 2;
|
|
|
|
{ DllEntryPoint }
|
|
DLL_PROCESS_ATTACH = 1;
|
|
DLL_THREAD_ATTACH = 2;
|
|
DLL_PROCESS_DETACH = 0;
|
|
DLL_THREAD_DETACH = 3;
|
|
|
|
{ These constants are used for conversion of error codes }
|
|
{ from win32 i/o errors to tp i/o errors }
|
|
{ errors 1 to 18 are the same as in Turbo Pascal }
|
|
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING! }
|
|
|
|
{ The media is write protected. }
|
|
ERROR_WRITE_PROTECT = 19;
|
|
{ The system cannot find the device specified. }
|
|
ERROR_BAD_UNIT = 20;
|
|
{ The device is not ready. }
|
|
ERROR_NOT_READY = 21;
|
|
{ The device does not recognize the command. }
|
|
ERROR_BAD_COMMAND = 22;
|
|
{ Data error (cyclic redundancy check) }
|
|
ERROR_CRC = 23;
|
|
{ The program issued a command but the }
|
|
{ command length is incorrect. }
|
|
ERROR_BAD_LENGTH = 24;
|
|
{ The drive cannot locate a specific }
|
|
{ area or track on the disk. }
|
|
ERROR_SEEK = 25;
|
|
{ The specified disk or diskette cannot be accessed. }
|
|
ERROR_NOT_DOS_DISK = 26;
|
|
{ The drive cannot find the sector requested. }
|
|
ERROR_SECTOR_NOT_FOUND = 27;
|
|
{ The printer is out of paper. }
|
|
ERROR_OUT_OF_PAPER = 28;
|
|
{ The system cannot write to the specified device. }
|
|
ERROR_WRITE_FAULT = 29;
|
|
{ The system cannot read from the specified device. }
|
|
ERROR_READ_FAULT = 30;
|
|
{ A device attached to the system is not functioning.}
|
|
ERROR_GEN_FAILURE = 31;
|
|
{ The process cannot access the file because }
|
|
{ it is being used by another process. }
|
|
ERROR_SHARING_VIOLATION = 32;
|
|
{ A pipe has been closed on the other end }
|
|
{ Removing that error allows eof to works as on other OSes }
|
|
ERROR_BROKEN_PIPE = 109;
|
|
ERROR_DISK_FULL = 112;
|
|
ERROR_DIR_NOT_EMPTY = 145;
|
|
ERROR_ALREADY_EXISTS = 183;
|
|
|
|
EXCEPTION_MAXIMUM_PARAMETERS = 15;
|
|
|
|
FORMAT_MESSAGE_FROM_SYSTEM = 4096;
|
|
LANG_NEUTRAL = $00;
|
|
SUBLANG_DEFAULT = $00;
|
|
|
|
type
|
|
{UINT = longint;
|
|
BOOL = longint; obsolete }
|
|
UINT = cardinal;
|
|
BOOL = longbool;
|
|
// WCHAR = word;
|
|
{$ifdef FPC_OS_UNICODE}
|
|
LPTCH = ^word;
|
|
LPTSTR = ^word;
|
|
LPCTSTR = ^word;
|
|
{$else FPC_OS_UNICODE}
|
|
LPTCH = ^char;
|
|
LPTSTR = ^char;
|
|
LPCTSTR = ^char;
|
|
{$endif FPC_OS_UNICODE}
|
|
LPWSTR = ^wchar;
|
|
PVOID = pointer;
|
|
LPVOID = pointer;
|
|
LPCVOID = pointer;
|
|
LPDWORD = ^DWORD;
|
|
HLocal = THandle;
|
|
PStr = pchar;
|
|
LPStr = pchar;
|
|
PLPSTR = ^LPSTR;
|
|
PLPWSTR = ^LPWSTR;
|
|
|
|
{ WARNING
|
|
the variable argument list
|
|
is not implemented for FPC
|
|
va_list is just a dummy record
|
|
MvdV: Nevertheless it should be a pointer type, not a record}
|
|
va_list = pchar;
|
|
|
|
PSecurityAttributes = ^TSecurityAttributes;
|
|
TSecurityAttributes = record
|
|
nLength : DWORD;
|
|
lpSecurityDescriptor : Pointer;
|
|
bInheritHandle : BOOL;
|
|
end;
|
|
|
|
PProcessInformation = ^TProcessInformation;
|
|
TProcessInformation = record
|
|
hProcess: THandle;
|
|
hThread: THandle;
|
|
dwProcessId: DWORD;
|
|
dwThreadId: DWORD;
|
|
end;
|
|
|
|
PFileTime = ^TFileTime;
|
|
TFileTime = record
|
|
dwLowDateTime,
|
|
dwHighDateTime : DWORD;
|
|
end;
|
|
|
|
LPSystemTime= ^PSystemTime;
|
|
PSystemTime = ^TSystemTime;
|
|
TSystemTime = record
|
|
wYear,
|
|
wMonth,
|
|
wDayOfWeek,
|
|
wDay,
|
|
wHour,
|
|
wMinute,
|
|
wSecond,
|
|
wMilliseconds: Word;
|
|
end;
|
|
|
|
TTlsDirectory=packed record
|
|
data_start, data_end : pointer;
|
|
index_pointer, callbacks_pointer : pointer;
|
|
zero_fill_size : dword;
|
|
flags : dword;
|
|
end;
|
|
|
|
PExceptionRecord = ^TExceptionRecord;
|
|
TExceptionRecord = record
|
|
ExceptionCode : cardinal;
|
|
ExceptionFlags : cardinal;
|
|
ExceptionRecord : PExceptionRecord;
|
|
ExceptionAddress : Pointer;
|
|
NumberParameters : Longint;
|
|
ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
|
|
end;
|
|
|
|
TSystemInfo = record
|
|
case LongInt of
|
|
0 : ( dwOemId : DWord;
|
|
dwPageSize : DWord;
|
|
lpMinimumApplicationAddress : Pointer;
|
|
lpMaximumApplicationAddress : Pointer;
|
|
dwActiveProcessorMask : PDWord;
|
|
dwNumberOfProcessors : DWord;
|
|
dwProcessorType : DWord;
|
|
dwAllocationGranularity : DWord;
|
|
wProcessorLevel : Word;
|
|
wProcessorRevision : Word;
|
|
);
|
|
1 : (
|
|
wProcessorArchitecture : Word;
|
|
wReserved : Word;
|
|
);
|
|
end;
|
|
PSystemInfo = ^TSystemInfo;
|
|
|
|
|
|
{ misc. functions }
|
|
function GetLastError : DWORD;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetLastError';
|
|
|
|
procedure SetLastError(dwErrCode : DWORD);
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetLastError';
|
|
|
|
{ time and date functions }
|
|
function GetTickCount : DWORD;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetTickCount';
|
|
|
|
{$ifndef WINCE}
|
|
{ process functions }
|
|
procedure ExitProcess(uExitCode : UINT);
|
|
stdcall;external KernelDLL name 'ExitProcess';
|
|
|
|
{ Startup }
|
|
procedure GetStartupInfo(p : pointer);
|
|
stdcall;external KernelDLL name 'GetStartupInfoA';
|
|
function GetStdHandle(nStdHandle:DWORD):THANDLE;
|
|
stdcall;external KernelDLL name 'GetStdHandle';
|
|
|
|
{$ifdef FPC_UNICODE_RTLx}
|
|
{ command line/environment functions }
|
|
|
|
function GetCommandLine : pwidechar;
|
|
stdcall;external KernelDLL name 'GetCommandLineW';
|
|
{$else}
|
|
function GetCommandLine : pchar;
|
|
stdcall;external KernelDLL name 'GetCommandLineA';
|
|
{$endif}
|
|
|
|
function GetCurrentProcessId:DWORD;
|
|
stdcall; external KernelDLL name 'GetCurrentProcessId';
|
|
|
|
function Win32GetCurrentThreadId:DWORD;
|
|
stdcall; external KernelDLL name 'GetCurrentThreadId';
|
|
|
|
function GetCurrentProcess : THandle;
|
|
stdcall;external 'kernel32' name 'GetCurrentProcess';
|
|
|
|
function ReadProcessMemory(process : THandle;address : pointer;dest : pointer;size : ptruint;bytesread : pptruint) : longbool;
|
|
stdcall;external 'kernel32' name 'ReadProcessMemory';
|
|
|
|
{ module functions }
|
|
function GetModuleFileName(l1:THandle;p:PChar;l2:longint):longint;
|
|
stdcall;external KernelDLL name 'GetModuleFileNameA';
|
|
|
|
function GetModuleHandle(p : PChar) : THandle;
|
|
stdcall;external KernelDLL name 'GetModuleHandleA';
|
|
|
|
{$else WINCE}
|
|
|
|
{ module functions }
|
|
function GetModuleFileName(l1:THandle;p:PWideChar;l2:longint):longint;
|
|
cdecl;external KernelDLL name 'GetModuleFileNameW';
|
|
|
|
function GetModuleHandle(p : PWideChar) : THandle;
|
|
cdecl;external KernelDLL name 'GetModuleHandleW';
|
|
|
|
{$endif WINCE}
|
|
{ file functions }
|
|
function WriteFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
|
|
overlap:pointer):longint;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'WriteFile';
|
|
function ReadFile(fh:thandle;buf:pointer;len:longint;var loaded:longint;
|
|
overlap:pointer):longint;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'ReadFile';
|
|
function CloseHandle(h : thandle) : longint;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'CloseHandle';
|
|
function SetFilePointer(l1,l2 : thandle;l3 : pointer;l4 : longint) : longint;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetFilePointer';
|
|
function GetFileSize(h:thandle;p:pointer) : longint;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetFileSize';
|
|
function SetEndOfFile(h : thandle) : longbool;
|
|
{$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'SetEndOfFile';
|
|
|
|
procedure GetSystemInfo(lpSystemInfo: PSystemInfo); {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'GetSystemInfo';
|
|
|
|
function WinLoadLibraryW(lpLibFileName:pwidechar):THandle; {$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'LoadLibraryW';
|
|
function WinLoadLibraryA(lpLibFileName:pwidechar):THandle; {$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'LoadLibraryA';
|
|
function WinGetProcAddress(hModule:THandle; lpProcName:pchar):pointer; {$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'GetProcAddress';
|
|
function WinFreeLibrary(hLibModule:THandle):ByteBool; {$ifdef wince}cdecl{$else}stdcall{$endif};external KernelDLL name 'FreeLibrary';
|
|
|
|
function FormatMessageW(dwFlags:DWORD; lpSource:LPCVOID; dwMessageId:DWORD; dwLanguageId:DWORD; lpBuffer:LPWSTR;nSize:DWORD; Arguments:va_list):DWORD;{$ifdef wince}cdecl{$else}stdcall{$endif}; external KernelDLL name 'FormatMessageW';
|
|
|
|
{$ifndef WINCE}
|
|
function GetFileType(Handle:thandle):DWord;
|
|
stdcall;external KernelDLL name 'GetFileType';
|
|
|
|
{ File }
|
|
function DeleteFileW(p : punicodechar) : longint;
|
|
stdcall;external KernelDLL name 'DeleteFileW';
|
|
function MoveFileW(old,_new : punicodechar) : longint;
|
|
stdcall;external KernelDLL name 'MoveFileW';
|
|
function CreateFileW(lpFileName:punicodechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
|
|
lpSecurityAttributes:PSECURITYATTRIBUTES; dwCreationDisposition:DWORD;
|
|
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):THandle;
|
|
stdcall;external KernelDLL name 'CreateFileW';
|
|
function GetFileAttributesW(p : punicodechar) : dword;
|
|
stdcall;external KernelDLL name 'GetFileAttributesW';
|
|
|
|
{ Directory }
|
|
function CreateDirectoryW(name : pointer;sec : pointer) : longbool;
|
|
stdcall;external KernelDLL name 'CreateDirectoryW';
|
|
function RemoveDirectoryW(name:pointer):longbool;
|
|
stdcall;external KernelDLL name 'RemoveDirectoryW';
|
|
function SetCurrentDirectoryW(name : pointer) : longbool;
|
|
stdcall;external KernelDLL name 'SetCurrentDirectoryW';
|
|
function GetCurrentDirectoryW(bufsize : longint;name : punicodechar) : Dword;
|
|
stdcall;external KernelDLL name 'GetCurrentDirectoryW';
|
|
function GetFullPathNameW (lpFileName: PUnicodeChar; nBufferLength: DWord;
|
|
lpBuffer: PUnicodeChar; var lpFilePart: PUnicodeChar): DWord;
|
|
stdcall; external KernelDLL name 'GetFullPathNameW';
|
|
function SetEnvironmentVariableW (lpName: PUnicodeChar; lpValue: PUnicodeChar): BOOL;
|
|
stdcall; external KernelDLL name 'SetEnvironmentVariableW';
|
|
|
|
{ Console functions needed for WriteFile fix for bug 17550 }
|
|
function GetConsoleMode(hConsoleHandle:thandle; lpMode:LPDWORD):BOOL;
|
|
stdcall;external KernelDLL name 'GetConsoleMode';
|
|
function GetConsoleOutputCP : UINT;
|
|
stdcall; external KernelDLL name 'GetConsoleOutputCP';
|
|
function GetOEMCP: UINT;
|
|
stdcall; external KernelDLL name 'GetOEMCP';
|
|
|
|
function SysAllocStringLen(psz:pointer;len:dword):pointer;
|
|
stdcall; external 'oleaut32.dll' name 'SysAllocStringLen';
|
|
procedure SysFreeString(bstr:pointer);
|
|
stdcall; external 'oleaut32.dll' name 'SysFreeString';
|
|
function SysReAllocStringLen(var bstr:pointer;psz: pointer;
|
|
len:dword): Integer; stdcall;external 'oleaut32.dll' name 'SysReAllocStringLen';
|
|
{$endif WINCE}
|
|
|
|
Procedure Errno2InOutRes(oserror: longword);
|
|
var
|
|
res : Word;
|
|
Begin
|
|
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
|
|
case oserror of
|
|
ERROR_WRITE_PROTECT..ERROR_GEN_FAILURE :
|
|
begin
|
|
{ This is the offset to the Win32 to add to directly map }
|
|
{ to the DOS/TP compatible error codes when in this range }
|
|
res := word(oserror)+131;
|
|
end;
|
|
ERROR_DISK_FULL :
|
|
res := 101;
|
|
ERROR_DIR_NOT_EMPTY,
|
|
ERROR_ALREADY_EXISTS,
|
|
ERROR_SHARING_VIOLATION :
|
|
begin
|
|
res :=5;
|
|
end;
|
|
else
|
|
begin
|
|
{ other error codes can directly be mapped }
|
|
res := Word(oserror);
|
|
end;
|
|
end;
|
|
InOutRes:=res;
|
|
end;
|
|
|
|
|
|
function OleStrToString(source: PWideChar) : UnicodeString;inline;
|
|
begin
|
|
OleStrToStrVar(source,result);
|
|
end;
|
|
|
|
|
|
procedure OleStrToStrVar(source : PWideChar;var dest : UnicodeString);inline;
|
|
begin
|
|
WideCharLenToStrVar(source,length(WideString(pointer(source))),dest);
|
|
end;
|
|
|
|
|
|
procedure OleStrToStrVar(source : PWideChar;var dest : AnsiString);inline;
|
|
begin
|
|
WideCharLenToStrVar(source,length(WideString(pointer(source))),dest);
|
|
end;
|
|
|
|
|
|
function StringToOleStr(const source : ansistring) : PWideChar;inline;
|
|
begin
|
|
result:=nil;
|
|
widestringmanager.Ansi2WideMoveProc(pchar(pointer(source)),StringCodePage(source),widestring(pointer(result)),length(source));
|
|
end;
|
|
|
|
|
|
function StringToOleStr(const source : UnicodeString) : PWideChar;inline;
|
|
begin
|
|
result:=nil;
|
|
{ will call UnicodeString overload if FPC_WIDESTRING_EQUAL_UNICODESTRING is set }
|
|
SetString(widestring(pointer(result)),PWideChar(source),length(source));
|
|
end;
|
|
|
|
|
|
{$ifndef WINCE}
|
|
{$define FPC_HAS_TRANSLATEPLACEHOLDERCP}
|
|
function TranslatePlaceholderCP(cp: TSystemCodePage): TSystemCodePage; {$ifdef SYSTEMINLINE}inline;{$endif}
|
|
begin
|
|
TranslatePlaceholderCP:=cp;
|
|
case cp of
|
|
CP_OEMCP:
|
|
TranslatePlaceholderCP:=GetOEMCP;
|
|
CP_ACP:
|
|
TranslatePlaceholderCP:=DefaultSystemCodePage;
|
|
end;
|
|
end;
|
|
{$endif not WINCE}
|
|
|
|
{$define HAS_GETCPUCOUNT}
|
|
function GetCPUCount: LongWord;
|
|
var
|
|
info: TSystemInfo;
|
|
begin
|
|
FillChar(info, SizeOf(info), 0);
|
|
GetSystemInfo(@info);
|
|
Result := info.dwNumberOfProcessors;
|
|
end;
|