- Код: Выделить всё
unit System;
interface
{$I-,Q-,H-,R-,V-,S-}
{$mode objfpc}
{systemh.inc}
type
DWord = LongWord;
Cardinal = LongWord;
Integer = SmallInt;
UInt64 = QWord;
{$ifdef CPU64}
SizeInt = Int64;
SizeUInt = QWord;
PtrInt = Int64;
PtrUInt = QWord;
ValSInt = Int64;
ValUInt = QWord;
{$endif CPU64}
{$ifdef CPU32}
SizeInt = Longint;
SizeUInt = DWord;
PtrInt = Longint;
PtrUInt = DWord;
ValSInt = Longint;
ValUInt = Cardinal;
{$endif CPU32}
PChar = ^Char;
PPChar = ^PChar;
TAnsiChar = Char;
AnsiChar = Char;
PAnsiChar = PChar;
PPAnsiChar = PPChar;
HRESULT = type Longint;
{$ifndef FPUNONE}
TDateTime = type Double;
{$endif}
TError = type Longint;
{$ifndef FPUNONE}
PSingle = ^Single;
PDouble = ^Double;
PExtended = ^Extended;
{$endif}
PCurrency = ^Currency;
{$ifdef SUPPORT_COMP}
PComp = ^Comp;
{$endif SUPPORT_COMP}
PSmallInt = ^Smallint;
PShortInt = ^Shortint;
PInteger = ^Integer;
PByte = ^Byte;
PWord = ^Word;
PDWord = ^DWord;
PLongWord = ^LongWord;
PLongint = ^Longint;
PCardinal = ^Cardinal;
PQWord = ^QWord;
PInt64 = ^Int64;
PPtrInt = ^PtrInt;
PPtrUInt = ^PtrUInt;
PSizeInt = ^SizeInt;
PPointer = ^Pointer;
PPPointer = ^PPointer;
PBoolean = ^Boolean;
PWordBool = ^WordBool;
PLongBool = ^LongBool;
PShortString = ^ShortString;
PAnsiString = ^AnsiString;
PWideString = ^WideString;
PVariant = ^Variant;
POleVariant = ^OleVariant;
WChar = WideChar;
UnicodeChar = WideChar;
PWideChar = ^WideChar;
PPWideChar = ^PWideChar;
PUnicodeChar = ^UnicodeChar;
TProcedure = procedure;
{sysos.inc}
type
{$ifdef CPU64}
THandle = QWord;
ULONG_PTR = QWord;
{$else CPU64}
THandle = DWord;
ULONG_PTR = DWord;
{$endif CPU64}
TThreadID = THandle;
SIZE_T = ULONG_PTR;
UINT = Cardinal;
BOOL = LongBool;
{$ifdef UNICODE}
LPTCH = ^Word;
LPTSTR = ^Word;
LPCTSTR = ^Word;
{$else UNICODE}
LPTCH = ^Char;
LPTSTR = ^Char;
LPCTSTR = ^Char;
{$endif UNICODE}
LPWSTR = ^WChar;
PVOID = Pointer;
LPVOID = Pointer;
LPCVOID = Pointer;
LPDWORD = ^DWORD;
HLocal = THandle;
PStr = PChar;
LPStr = PChar;
PLPSTR = ^LPSTR;
PLPWSTR = ^LPWSTR;
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
DebugInfo: Pointer;
LockCount: Longint;
RecursionCount: Longint;
OwningThread: THandle;
LockSemaphore: THandle;
SpinCount: ULONG_PTR;
end;
{objpash.inc}
type
PGuid = ^TGuid;
TGuid = record
end;
PVarRec = ^TVarRec;
TVarRec = record
end;
IUnknown = interface
end;
IInterface = IUnknown;
{$I setjumph.inc}
var
ExitCode: Longint = 0;
IsLibrary: Boolean;
HInstance: THandle;
DllReason: Longint;
type
TDLL_Entry_Hook = procedure;
const
Dll_Process_Detach_Hook: TDLL_Entry_Hook = nil;
procedure Move(const Source; var Dest; Count: SizeInt);
procedure FillChar(var Dest; Count: SizeInt; Value: AnsiChar);
implementation
function GetModuleHandle(lpModuleName: PChar): THandle; stdcall;
external 'kernel32.dll' name 'GetModuleHandleA';
procedure ExitProcess(uExitCode: UINT); stdcall;
external 'kernel32.dll' name 'ExitProcess';
procedure PascalMain; stdcall; external name 'PASCALMAIN';
procedure FPC_Do_Exit; stdcall; external name 'FPC_DO_EXIT';
procedure FPC_InitializeUnits; [public, alias: 'FPC_INITIALIZEUNITS'];
begin
end;
procedure FPC_LibInitializeUnits; [public, alias: 'FPC_LIBINITIALIZEUNITS'];
begin
end;
procedure Exe_Entry; [public, alias: '_FPC_EXE_Entry'];
begin
IsLibrary := False;
HInstance := GetModuleHandle(nil);
PascalMain;
end;
{$I setjump.inc}
const
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
DLLExitOK: Boolean = True;
var
DllBuf: Jmp_buf;
procedure ExitDLL(ExitCode: Longint);
begin
DLLExitOK := (ExitCode = 0);
LongJmp(DllBuf, 1);
end;
function Dll_Entry: LongBool; [public, alias: '_FPC_DLL_Entry'];
begin
IsLibrary := True;
Dll_Entry := True;
case DllReason of
DLL_PROCESS_ATTACH:
begin
if (SetJmp(DllBuf) = 0) then
PascalMain
else
Dll_Entry := DLLExitOK;
end;
DLL_PROCESS_DETACH :
begin
if (SetJmp(DllBuf) = 0) then
FPC_Do_Exit;
if Assigned(Dll_Process_Detach_Hook) then
Dll_Process_Detach_Hook;
end;
end;
end;
procedure _FPC_WinMainCRTStartup; stdcall; public name '_WinMainCRTStartup';
begin
Exe_Entry;
end;
procedure _FPC_DLLWinMainCRTStartup(_HInstance: THandle;
_DllReason, _DllParam: Longint); stdcall; public name '_DLLWinMainCRTStartup';
begin
HInstance := _HInstance;
DllReason := _DllReason;
DLL_Entry;
end;
procedure Do_Exit; [public, alias: 'FPC_DO_EXIT'];
begin
if IsLibrary then
ExitDLL(ExitCode)
else
ExitProcess(ExitCode);
end;
procedure MoveMemory(Dest: PVOID; Source: PVOID; Count: SIZE_T); stdcall;
external 'ntdll.dll' name 'RtlMoveMemory';
procedure FillMemory(Dest: PVOID; Count: SIZE_T; Fill: Byte); stdcall;
external 'ntdll.dll' name 'RtlFillMemory';
procedure Move(const Source; var Dest; Count: SizeInt);
begin
MoveMemory(@Dest, @Source, Count);
end;
procedure FillChar(var Dest; Count: SizeInt; Value: AnsiChar);
begin
FillMemory(@Dest, Count, Byte(Value));
end;
end.
Код DLL:
- Код: Выделить всё
library dll;
uses
Windows,
Messages;
var
FileMapping: THandle = 0;
MappingData: PLongint = nil;
procedure DoProcessAttach;
begin
FileMapping := CreateFileMapping(INVALID_HANDLE_VALUE,
nil, PAGE_READWRITE, 0, SizeOf(Longint), 'sdasdasd');
if (FileMapping = 0) then
ShowLastErrorMessage('FileMapping');
if (FileMapping <> 0) then
MappingData := MapViewOfFile(FileMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if (MappingData = nil) then
ShowLastErrorMessage('MapViewOfFile');
end;
procedure DoProcessDetach;
begin
if (FileMapping <> 0) then
begin
if Assigned(MappingData) then
UnmapViewOfFile(MappingData);
CloseHandle(FileMapping);
end;
end;
begin
Dll_Process_Detach_Hook := @DoProcessDetach;
DoProcessAttach;
end.
Этот код работает в Win32 и Win64. Но после добавления в DoProcessAttach пары локальных переменных:
- Код: Выделить всё
procedure DoProcessAttach;
var
VersionInfo: TOSVersionInfo;
SecurityAttributes: TSecurityAttributes;
begin
FileMapping := CreateFileMapping(INVALID_HANDLE_VALUE,
nil, PAGE_READWRITE, 0, SizeOf(Longint), 'sdasdasd');
if (FileMapping = 0) then
ShowLastErrorMessage('FileMapping');
if (FileMapping <> 0) then
MappingData := MapViewOfFile(FileMapping, FILE_MAP_ALL_ACCESS, 0, 0, 0);
if (MappingData = nil) then
ShowLastErrorMessage('MapViewOfFile');
end;
MapViewOfFile начинает возвращать nil с ошибкой "Access denied". Глюк возникает только в Win64. Даже гипотез никаких нет - как добавление неиспользуемых локальных переменных может повлиять на MapViewOfFile? С одной стороны явный баг FPC, который должен игнорировать несипользуемые переменные, с другой - их все-таки испольовать потом потребуется и баг не исчезнет
Может кто сталкивался с подобным или имеет опыт более правильной кастрации RTL для DLL?
версия 2.4.0
и в функцию CreateFileMappingA попадают не те данные.
