Delphi控件源码

开发平台：
Delphi

Mmmemmap.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMMemMap;
{$I COMPILER.INC}
{.$DEFINE _MMDEBUG}
interface
uses
    Windows,
    Messages,
    SysUtils,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    MMObj,
    MMUtils,
    MMString;
type
    EMMMemMapFileError = class(Exception);
    TMMAccessMode = (amRead, amReadWrite);
    TMMShareMode  = (smNone, smRead, smWrite, smReadWrite);
    TMMCreateMode = (cmCreateNew, cmCreateAlways, cmOpenExisting,
                     cmOpenAlways, cmTruncateExisting );
    {-- TMMMemMapFile ---------------------------------------------------}
    TMMMemMapFile = class(TMMNonVisualComponent)
    private
       FAccessMode : TMMAccessMode;
       FShareMode  : TMMShareMode;
       FCreateMode : TMMCreateMode;
       FActive     : Boolean;
       FFileData   : Pointer;
       FFileName   : TFileName;
       FFileSize   : Longint;
       HFile       : THandle;
       HFileMapping: THandle;
       FProtect    : Longint;
       FMapAccess  : Longint;
       FHighSize   : Longint;
       FMapOffset  : LongInt;
       FMapSize    : LongInt;
       FDataPtr    : Pointer;
       procedure CreateFileHandle;
       procedure CloseFileHandle;
       procedure CreateFileView;
       procedure CloseFileView;
       procedure SetActive(aValue: Boolean);
       procedure SetFileName(aValue: TFileName);
       procedure SetFileSize(aValue: Longint);
       procedure SetMapOffset(Value: LongInt);
       procedure SetMapSize(Value: LongInt);
       function  GetFileData : Pointer;
       function  GetHandle : THandle;
       function  GetMapSize : LongInt;
    public
       constructor Create(AOwner: TComponent); override;
       destructor Destroy; override;
       procedure  OpenFile;
       procedure  FlushFile;
       procedure  CloseFile;
       property   Handle: THandle read GetHandle;
       property   Active: Boolean read FActive write SetActive;
       property   FileData: Pointer read GetFileData;
    published
       property CreateMode: TMMCreateMode read FCreateMode write FCreateMode default cmOpenAlways;
       property AccessMode: TMMAccessMode read FAccessMode write FAccessMode default amReadWrite;
       property ShareMode: TMMShareMode read FShareMode write FShareMode default smReadWrite;
       property FileName: TFileName read FFileName write SetFileName;
       property FileSize: Longint read FFileSize write SetFileSize;
       property MapOffset: LongInt read FMapOffset write SetMapOffset;
       property MapSize  : LongInt read GetMapSize write SetMapSize;
    end;
implementation
var
   AllocationGranularity: LongInt = 0;
{------------------------------------------------------------------------}
function FormatError(Text: String): String;
begin
   Result := Text+' '+IntToStr(GetLastError)+',  '+SysErrorMessage(GetLastError);
end;
{-- TMMMemMapFile -------------------------------------------------------}
constructor TMMMemMapFile.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   HFile := INVALID_HANDLE_VALUE;
   FAccessMode := amReadWrite;
   FShareMode := smReadWrite;
   FCreateMode := cmOpenAlways;
   FActive := False;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMMemMapFile -------------------------------------------------------}
destructor TMMMemMapFile.Destroy;
begin
   CloseFile;
   inherited Destroy;
end;
{-- TMMMemMapFile -------------------------------------------------------}
{ Open and Close methods are another way of changing the Active property.}
procedure TMMMemMapFile.CloseFile;
begin
   Active := False;
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.OpenFile;
begin
   Active := True;
end;
{-- TMMMemMapFile -------------------------------------------------------}
{  NOTE: if the file not exits, set new fileName and then the req. size  }
procedure TMMMemMapFile.SetFileName(aValue: TFileName);
begin
   if (aValue <> FFileName) then
   begin
      if Active then CloseFile;
      FFileName := aValue;
      if (FFileName <> '') and FileExists(FFileName) then
      begin
         { look if the file is OK. }
         CreateFileHandle;
         { Get the size of the file and make this the default value for }
         { the mapped file                                              }
         FFileSize := Windows.GetFileSize(HFile, @FHighSize);
      end
      else FFileSize := 0;
      FMapOffset := 0 ;
      FMapSize   := 0 ; { Map all file }
      CloseFileHandle;
      { Don't allow use of files larger than 4gig ... for now }
      if FHighSize <> 0 then
      begin
         FFileName := '';
         FFileSize := 0;
         raise EMMMemMapFileError.Create(LoadResStr(IDS_MMTOBIG));
      end;
   end;
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.SetFileSize(aValue: Longint);
begin
   if (aValue <> FFileSize) then
   begin
      FFileSize := Max(aValue,0);
      if Active then
      begin
         { set the new FileSize }
         Active := False;
         Active := True;
      end;
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
{ This routine creates the file kernal object.                           }
procedure TMMMemMapFile.CreateFileHandle;
const
  AccessFlags : array[TMMAccessMode] of LongInt =
                      (GENERIC_READ,GENERIC_READ or GENERIC_WRITE);
  ShareFlags  : array[TMMShareMode] of LongInt =
                      (0,FILE_SHARE_READ,FILE_SHARE_WRITE,
                      FILE_SHARE_READ or FILE_SHARE_WRITE);
  CreateFlags : array[TMMCreateMode] of LongInt =
                      (CREATE_NEW,CREATE_ALWAYS,OPEN_EXISTING,
                      OPEN_ALWAYS,TRUNCATE_EXISTING);
Var
  dwAccess, dwShare, dwCreate: Longint;
begin
   { If a handle is open, make sure to close it }
   CloseFileHandle;
   // FFileSize := 0;
   { Determine settings for CreateFile call }
   case FAccessMode of
        amRead:
        begin
           FProtect   := PAGE_READONLY;
           FMapAccess := FILE_MAP_READ;
        end;
        amReadWrite:
        begin
           FProtect   := PAGE_READWRITE;
           FMapAccess := FILE_MAP_ALL_ACCESS;
        end;
   end;
   dwAccess := AccessFlags[FAccessMode];
   dwShare  := ShareFlags[FShareMode];
   dwCreate := CreateFlags[FCreateMode];
   {$IFDEF _MMDEBUG}
   DB_WriteStrLn(0,'Filename: ' + FFileName) ;
   DB_FormatLn(0,'AccessMode: %x ShareMode: %x CreateMode: %x', [dwAccess, dwShare, dwCreate]);
   {$ENDIF}
   { Call CreateFile, and check for success }
   HFile := CreateFile(PChar(FFileName), dwAccess, dwShare, nil, dwCreate,
                       FILE_ATTRIBUTE_NORMAL, 0);
   if HFile = INVALID_HANDLE_VALUE then
   begin
      { Removed to avoid file name lost when sharing violation occured }
      { FFileName := '';}
      FFileSize := 0;
      raise EMMMemMapFileError.Create(FormatError('CreateFile failed with Error Code:'));
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.CloseFileHandle;
begin
   if HFile <> INVALID_HANDLE_VALUE then
   begin
      CloseHandle(HFile);
      HFile := INVALID_HANDLE_VALUE;
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.CreateFileView;
var
    ActualOffs, ActualSize : LongInt ;
begin
   if (HFile <> INVALID_HANDLE_VALUE) and (HFileMapping = 0) then
   begin
      {$IFDEF _MMDEBUG}
      DB_WriteStrLn('FFileSize = ' + IntToStr(FFileSize));
      {$ENDIF}
      HFileMapping := CreateFileMapping(HFile, nil, FProtect, 0, FFileSize, nil);
      if (HFileMapping = 0) then
          raise EMMMemMapFileError.Create(FormatError('CreateFileMapping failed with Error Code:'));
      {$IFDEF _MMDEBUG}
      DB_FormatLn('Offs: %d Size: %d', [FMapOffset,FMapSize]);
      {$ENDIF}
      if FMapOffset >= FFileSize then
         raise  EMMMemMapFileError.Create(LoadResStr(IDS_MMBEYOND));
      if FMapOffset + FMapSize > FFileSize then
         raise  EMMMemMapFileError.Create(LoadResStr(IDS_MMEXCEED));
      ActualOffs := FMapOffset - FMapOffset mod AllocationGranularity ;
      ActualSize := FMapOffset - ActualOffs + FMapSize ;
      FDataPtr   := nil ;
      FFileData  := MapViewOfFile(HFileMapping, FMapAccess, 0, ActualOffs, ActualSize);
      if FFileData = nil then
         raise EMMMemMapFileError.Create(FormatError('MapViewOfFile failed with Error Code:'));
      FDataPtr   := FFileData ;
      Inc(PChar(FDataPtr),FMapOffset-ActualOffs);
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.CloseFileView;
begin
   if (FFileData <> nil) then
   begin
      UnmapViewOfFile(FFileData);
      FFileData := nil;
   end;
   if (HFileMapping <> 0) then
   begin
      CloseHandle(HFileMapping);
      HFileMapping := 0;
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
{ Setting Active to true establishes the mapping and commits physical    }
{ storage to the region.                                                 }
procedure TMMMemMapFile.SetActive(aValue: Boolean);
begin
   if FActive <> aValue then
   begin
      if Not (csDesigning in ComponentState) then
      begin
         if aValue then
         begin
            try
               CreateFileHandle;
               CreateFileView;
            except
               CloseFileView;
               CloseFileHandle;
               raise;
            end;
         end
         else
         begin
            CloseFileView;
            CloseFileHandle;
         end;
      end;
      FActive := aValue;
   end;
end;
{-- TMMMemMapFile -------------------------------------------------------}
{ Allow the user to flush the data if desired.                           }
procedure TMMMemMapFile.FlushFile;
begin
   if FActive then FlushViewOfFile(FFileData, FFileSize);
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.SetMapOffset(Value: LongInt);
begin
   if (Value < 0) or ((FFileSize <> 0) and (Value >= FFileSize)) then
       raise EMMMemMapFileError.Create(LoadResStr(IDS_MMINVALIDOFFSET));
    if Value <> FMapOffset then
    begin
       FMapOffset := Value;
       if Active then
       begin
          Active := False;
          Active := True;
       end;
    end;
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
end;
{-- TMMMemMapFile -------------------------------------------------------}
procedure TMMMemMapFile.SetMapSize(Value: LongInt);
begin
   if (Value < 0) or (Value + FMapOffset > FFileSize) then
      raise EMMMemMapFileError.Create(LoadResStr(IDS_MMINVALIDSIZE));
   if (Value <> FMapSize) then
   begin
      FMapSize := Value;
      if Active then
      begin
         Active := False;
         Active := True;
      end;
   end;
   {$IFDEF TRIAL}
   {$DEFINE _HACK3}
   {$I MMHACK.INC}
   {$ENDIF}
end;
{-- TMMMemMapFile -------------------------------------------------------}
function TMMMemMapFile.GetFileData: Pointer;
begin
   if not Active then OpenFile;
   Result := FDataPtr;
end;
{-- TMMMemMapFile -------------------------------------------------------}
function TMMMemMapFile.GetHandle: THandle;
begin
   if not Active then OpenFile;
   Result := HFile;
end;
{-- TMMMemMapFile -------------------------------------------------------}
function TMMMemMapFile.GetMapSize: LongInt;
begin
   if (FMapSize <> 0) then
      Result := FMapSize
   else
      Result := FFileSize - FMapOffset;
end;
{------------------------------------------------------------------------}
procedure InitAllocGran;
var
    SI: TSYSTEMINFO;
begin
   GetSystemInfo(SI);
   AllocationGranularity := SI.dwAllocationGranularity;
end;
initialization
   InitAllocGran;
end.

						