unit win32filemapping;

{$mode objfpc}
{$CALLING STDCALL}
{$I-}

interface
implementation
uses
 Windows, SysUtils;

// HANDLE CreateFileMappingA( HANDLE hFile, LPSECURITY_ATTRIBUTES lpAttributes, DWORD flProtect, DWORD dwMaximumSizeHigh, DWORD dwMaximumSizeLow, LPCTSTR lpName);
function CreateFileMappingA( hFile: DWORD; lpAttrib: Pointer; flProtect, MaxSizeHigh, MaxSizeLow: DWORD; FmemName: PChar ): DWORD;
                                                                          stdcall; external 'kernel32.dll' name 'CreateFileMappingA';
//HANDLE WINAPI OpenFileMappingA( DWORD dwDesiredAccess, BOOL bInheritHandle, LPCTSTR lpName );
function OpenFileMappingA( DesiredAccess: DWORD; InheritHandle: Boolean; FmemName: PChar ): DWORD;
                                                                          stdcall; external 'kernel32.dll' name 'OpenFileMappingA';
//LPVOID MapViewOfFile( HANDLE hFileMappingObject, DWORD dwDesiredAccess, DWORD dwFileOffsetHigh, DWORD dwFileOffsetLow, SIZE_T dwNumberOfBytesToMap );
function MapViewOfFile( hFile, DesiredAccess, FileOffsetHigh, FileOffsetLow, NbrOfBytesToMap: DWORD ): Pointer;
                                                                          stdcall; external 'kernel32.dll' name 'MapViewOfFile';
// BOOL WINAPI UnmapViewOfFile( LPCVOID lpBaseAddress );
function UnmapViewOfFile( BaseAddress: Pointer ): Boolean;
                                                                          stdcall; external 'kernel32.dll' name 'UnmapViewOfFile';
//void RtlMoveMemory( PVOID Destination, const VOID *Source, SIZE_T Length );
procedure RtlMoveMemory( Destination, Source: Pointer; Length: DWORD )
                                                                          stdcall; external 'kernel32.dll' name 'RtlMoveMemory';
//BOOL FlushViewOfFile( LPCVOID lpBaseAddress, SIZE_T dwNumberOfBytesToFlush );
function FlushViewOfFile( MapBaseAdr: Pointer; BytesToFlush: DWORD ): Boolean;
                                                                          stdcall; external 'kernel32.dll' name 'FlushViewOfFile';
//BOOL CloseHandle( HANDLE hObject );
function CloseHandle( hFile: DWORD ): Boolean;
                                                                          stdcall; external 'kernel32.dll' name 'CloseHandle';
//BOOL DeleteFileA( LPCTSTR lpFileName );
function DeleteFileA( FmemName: PChar ): Boolean;
                                                                          stdcall; external 'kernel32.dll' name 'DeleteFileA';

//==============================================================================
function FPC_CreateFileMapA( Hndle: DWORD; SecAtrib: Pointer; MapAccMode, MemHighAdr, MemLowAdr: DWORD; FmemName: PChar ): DWORD; stdcall;
begin
  OutputDebugString(PChar(Format('CFSM: Before CFM',[])));
  FPC_CreateFileMapA := CreateFileMappingA( Hndle, SecAtrib, MapAccMode, MemHighAdr, MemLowAdr, FmemName );
  OutputDebugString(PChar(Format('CFSM: After CFM, H= %d',[FPC_CreateFileMapA])));
end;
//==============================================================================
function FPC_OpenFileMapA( AccessMethod: DWORD; InherHandle: Boolean; FmemName: PChar ): DWORD; stdcall;
begin
  FPC_OpenFileMapA := OpenFileMappingA( AccessMethod, InherHandle, FmemName );
end;
//==============================================================================
function  FPC_MapViewOfFile( Hndle, MemAccess, MemHighAdr, MemLowAdr, BytesToMap: DWORD ): Pointer; stdcall;
begin
  OutputDebugString(PChar(Format('CFSM: Before MVF',[])));
  FPC_MapViewOfFile := MapViewOfFile( Hndle, MemAccess, MemHighAdr, MemLowAdr, BytesToMap );
  OutputDebugString(PChar(Format('CFSM: After MVF, P= %d',[FPC_MapViewOfFile])));
end;
//==============================================================================
function  FPC_UnmapViewOfFile( MapBaseAdr: Pointer ): Boolean; stdcall;
begin
  FPC_UnmapViewOfFile := UnmapViewOfFile( MapBaseAdr );
end;
//==============================================================================
function  FPC_FlushViewOfFile( FMapBaseAdr: Pointer; BytesToFlush: DWORD ): Boolean; stdcall;
begin
    FPC_FlushViewOfFile := FlushViewOfFile( FMapBaseAdr, BytesToFlush );
end;
//==============================================================================
function  FPC_CloseHandle( Hndle: DWord ): Boolean; stdcall;
begin
    FPC_CloseHandle := CloseHandle( Hndle );
end;
//==============================================================================
function  FPC_DeleteFileA( FmemName: PChar ): Boolean; stdcall;
begin
    FPC_DeleteFileA := DeleteFileA ( FmemName );
end;
//==============================================================================
procedure  FPC_RtlMoveMemory( Destination, Source: Pointer; Length: DWORD ); stdcall;
begin
    RtlMoveMemory( Destination, Source, Length  );
end;
//==============================================================================
CONST
  READ  = 1;
  WRITE = 2;

type
  TCntlBlock  = array [0..3]    of DWORD;
  TXferBufr   = array [0..256]  of DWORD;
var
  MapTmp:   array [0..1024] of Byte;
function FPC_AccessFileMap( var CntlBlock: TCntlBlock; var XferBufr: TXferBufr ): Boolean stdcall;
var
  ChrShift: Array [0..3] of DWORD = (0,8,16,24);
  RdOrWrt,  MaxDWords, CharCnt, DWdIdx, ChrIdx, DWdChr, DWd_MapAdr: DWORD;
  DWdXfer, ShiftVal: Integer;
  MapTmpPtr:  PByte;
  MapFilePtr: PByte;
  Test:     Byte;
begin
  MapTmpPtr  := @MapTmp[0];
  RdOrWrt    := CntlBlock[0];
  MaxDWords  := CntlBlock[1];
  CharCnt    := CntlBlock[2];
  DWd_MapAdr := CntlBlock[3]; // Integer containing Ptr to MapBufr
  //MapFilePtr := PByte(DWd_MapAdr);
  OutputDebugString(PChar(Format('CFSM: After var init,RdOrWrt = %d, MaxDWords = %d, CharCnt = %d, MapTmpPtr= %d. MapFilePtr= %d. ', [RdOrWrt,MaxDWords,CharCnt,DWORD(MapTmpPtr),DWORD(MapTmpPtr)])));
  FPC_AccessFileMap := FALSE;
  if( ( ( MaxDWords * 4) >=  CharCnt ) and ( CharCnt > 0 ) ) then
  begin
       if RdOrWrt = READ then  // Build Int XferBufr from MapFile access.
       begin
            OutputDebugString(PChar(Format('CFSM: Lets Xfer data, in read loop, Xter[0,1,2,3] = %x, %x, %x, %x.',[XferBufr[0],XferBufr[1],XferBufr[2],XferBufr[3]])));
            //RtlMoveMemory(  MapTmpPtr, MapFilePtr, CharCnt );
            for ChrIdx := 0 to CharCnt-1 do MapTmp[ChrIdx] := MapTmp[ChrIdx];
            OutputDebugString(PChar(Format('CFSM: AFM Read Move Complete!!',[])));
            for ChrIdx := 0 to CharCnt-1 do
            begin
                 DWdChr := DWORD(MapTmp[ChrIdx]);
                 OutputDebugString(PChar(Format('CFSM: After DWORD DWdIdx = %d, DWrdChr = %x.',[DWdIdx,DWdChr])));
                 XferBufr[DWdIdx] := XferBufr[DWdIdx] or ( (DWORD(MapTmp[ChrIdx])) shl ChrShift[ChrIdx and 3] );
                 OutputDebugString(PChar(Format('CFSM: Read From Map Buffer, XferBufr[DWdIdx] = %x, ChrIdx = %d.',[XferBufr[DWdIdx],ChrIdx])));
            end;
            FPC_AccessFileMap := TRUE;
            OutputDebugString(PChar(Format('CFSM: AFM Read Complete!!',[])));
       end
       else //THEN  RdOrWrt = Write // Write chars from XferBufr into MapFile access
       begin
            OutputDebugString(PChar(Format('CFSM: Lets Xfer data, in write loop, Xter[0,1,2,3] = %x, %x, %x, %x.',[XferBufr[0],XferBufr[1],XferBufr[2],XferBufr[3]])));
            for ChrIdx := 0 to CharCnt-1 do
            begin
                 //OutputDebugString(PChar(Format('CFSM: Xfer[] = %x. ',[XferBufr[ChrIdx DIV 4]])));
                 OutputDebugString(PChar(Format('CFSM: After DWORD DWdXfer = %x, ShiftVal = %d, ChrIdx=%d, CharCnt=%d.',[DWdXfer,ShiftVal,ChrIdx,CharCnt])));
                 MapTmp[ChrIdx] := ((XferBufr[ChrIdx DIV 4]) SHR (ChrShift[ChrIdx AND 3]));
                 OutputDebugString(PChar(Format('CFSM: After DWORD MapTmp[ChrIdx] = %x',[MapTmp[ChrIdx]])));
                 //OutputDebugString(PChar(Format('CFSM: Write to Map Buffer, DWdXfer = %x , ChrIdx =%d , ChrShift[ChrIdx and 3] =%x, ',[DWdXfer,ChrShift[ChrIdx and 3]])));
            end;
            //RtlMoveMemory( MapFilePtr, MapTmpPtr, CharCnt );
            for ChrIdx := 0 to CharCnt-1 do MapTmp[ChrIdx] := MapTmp[ChrIdx];
            FPC_AccessFileMap := TRUE;
            OutputDebugString(PChar(Format('CFSM: AFM Write RtlMove Complete!!',[])));
       end;
  end;
end;

//==============================================================================
exports
       FPC_CreateFileMapA,
       FPC_OpenFileMapA,
       FPC_MapViewOfFile,
       FPC_UnmapViewOfFile,
       FPC_FlushViewOfFile,
       FPC_AccessFileMap,
       FPC_CloseHandle,
       FPC_DeleteFileA;
end.