compile.pas

源代码

  clBtnText = TColor(COLOR_BTNTEXT or $80000000);
  clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000);
  clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000);
  cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000);
  cl3DLight = TColor(COLOR_3DLIGHT or $80000000);
  clInfoText = TColor(COLOR_INFOTEXT or $80000000);
  clInfoBk = TColor(COLOR_INFOBK or $80000000);

  clBlack = TColor($000000);
  clMaroon = TColor($000080);
  clGreen = TColor($008000);
  clOlive = TColor($008080);
  clNavy = TColor($800000);
  clPurple = TColor($800080);
  clTeal = TColor($808000);
  clGray = TColor($808080);
  clSilver = TColor($C0C0C0);
  clRed = TColor($0000FF);
  clLime = TColor($00FF00);
  clYellow = TColor($00FFFF);
  clBlue = TColor($FF0000);
  clFuchsia = TColor($FF00FF);
  clAqua = TColor($FFFF00);
  clLtGray = TColor($C0C0C0);
  clDkGray = TColor($808080);
  clWhite = TColor($FFFFFF);
  clNone = TColor($1FFFFFFF);
  clDefault = TColor($20000000);

type
  TColorEntry = record
    Value: TColor;
    Name: string;
  end;

const
  Colors: array[0..41] of TColorEntry = (
    (Value: clBlack; Name: 'clBlack'),
    (Value: clMaroon; Name: 'clMaroon'),
    (Value: clGreen; Name: 'clGreen'),
    (Value: clOlive; Name: 'clOlive'),
    (Value: clNavy; Name: 'clNavy'),
    (Value: clPurple; Name: 'clPurple'),
    (Value: clTeal; Name: 'clTeal'),
    (Value: clGray; Name: 'clGray'),
    (Value: clSilver; Name: 'clSilver'),
    (Value: clRed; Name: 'clRed'),
    (Value: clLime; Name: 'clLime'),
    (Value: clYellow; Name: 'clYellow'),
    (Value: clBlue; Name: 'clBlue'),
    (Value: clFuchsia; Name: 'clFuchsia'),
    (Value: clAqua; Name: 'clAqua'),
    (Value: clWhite; Name: 'clWhite'),
    (Value: clScrollBar; Name: 'clScrollBar'),
    (Value: clBackground; Name: 'clBackground'),
    (Value: clActiveCaption; Name: 'clActiveCaption'),
    (Value: clInactiveCaption; Name: 'clInactiveCaption'),
    (Value: clMenu; Name: 'clMenu'),
    (Value: clWindow; Name: 'clWindow'),
    (Value: clWindowFrame; Name: 'clWindowFrame'),
    (Value: clMenuText; Name: 'clMenuText'),
    (Value: clWindowText; Name: 'clWindowText'),
    (Value: clCaptionText; Name: 'clCaptionText'),
    (Value: clActiveBorder; Name: 'clActiveBorder'),
    (Value: clInactiveBorder; Name: 'clInactiveBorder'),
    (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
    (Value: clHighlight; Name: 'clHighlight'),
    (Value: clHighlightText; Name: 'clHighlightText'),
    (Value: clBtnFace; Name: 'clBtnFace'),
    (Value: clBtnShadow; Name: 'clBtnShadow'),
    (Value: clGrayText; Name: 'clGrayText'),
    (Value: clBtnText; Name: 'clBtnText'),
    (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
    (Value: clBtnHighlight; Name: 'clBtnHighlight'),
    (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
    (Value: cl3DLight; Name: 'cl3DLight'),
    (Value: clInfoText; Name: 'clInfoText'),
    (Value: clInfoBk; Name: 'clInfoBk'),
    (Value: clNone; Name: 'clNone'));

function IdentToColor(const Ident: string; var Color: Longint): Boolean;
var
  I: Integer;
begin
  for I := Low(Colors) to High(Colors) do
    if CompareText(Colors[I].Name, Ident) = 0 then
    begin
      Result := True;
      Color := Longint(Colors[I].Value);
      Exit;
    end;
  Result := False;
end;

function StringToColor(const S: string): TColor;
begin
  if not IdentToColor(S, Longint(Result)) then
    Result := TColor(StrToInt(S));
end;

function IsRelativePath(const Filename: String): Boolean;
var
  L: Integer;
begin
  Result := True;
  L := Length(Filename);
  if ((L >= 1) and (Filename[1] = '\')) or
     ((L >= 2) and (Filename[1] in ['A'..'Z', 'a'..'z']) and (Filename[2] = ':')) then
    Result := False;
end;

function GetSelfFilename: String;
{ Returns Filename of the calling DLL or application. (ParamStr(0) can only
  return the filename of the calling application.) }
var
  Buf: array[0..MAX_PATH-1] of Char;
begin
  SetString(Result, Buf, GetModuleFileName(HInstance, Buf, SizeOf(Buf)))
end;

function CreateMemoryStreamFromFile(const Filename: String): TMemoryStream;
{ Creates a TMemoryStream and loads the contents of the specified file into it }
var
  F: TFile;
  SizeOfFile: Cardinal;
begin
  Result := TMemoryStream.Create;
  try
    { Why not use TMemoryStream.LoadFromFile here?
      1. On Delphi 2 it opens files for exclusive access (not good).
      2. It doesn't give specific error messages. }
    F := TFile.Create(Filename, fdOpenExisting, faRead, fsRead);
    try
      SizeOfFile := F.CappedSize;
      Result.SetSize(SizeOfFile);
      F.ReadBuffer(Result.Memory^, SizeOfFile);
    finally
      F.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function FileSizeAndCRCIs(const Filename: String; const Size: Cardinal;
  const CRC: Longint): Boolean;
var
  F: TFile;
  SizeOfFile: Integer64;
  Buf: String;
begin
  Result := False;
  try
    F := TFile.Create(Filename, fdOpenExisting, faRead, fsRead);
    try
      SizeOfFile := F.Size;
      if (SizeOfFile.Lo = Size) and (SizeOfFile.Hi = 0) then begin
        SetLength(Buf, Size);
        F.ReadBuffer(Buf[1], Size);
        if GetCRC32(Buf[1], Size) = CRC then
          Result := True;
      end;
    finally
      F.Free;
    end;
  except
  end;
end;

function IsX86Executable(const F: TFile): Boolean;
const
  IMAGE_NT_SIGNATURE = $00004550;  { 'PE'#0#0 }
  IMAGE_FILE_MACHINE_I386 = $014C;
var
  DosHeader: array[0..63] of Byte;
  PEHeaderOffset: Longint;
  PESigAndHeader: packed record
    Sig: DWORD;
    Machine: Word;
  end;
begin
  Result := False;
  if F.Read(DosHeader, SizeOf(DosHeader)) = SizeOf(DosHeader) then begin
    if (DosHeader[0] = Ord('M')) and (DosHeader[1] = Ord('Z')) then begin
      PEHeaderOffset := PLongint(@DosHeader[60])^;
      if PEHeaderOffset > 0 then begin
        F.Seek(PEHeaderOffset);
        if F.Read(PESigAndHeader, SizeOf(PESigAndHeader)) = SizeOf(PESigAndHeader) then begin
          if (PESigAndHeader.Sig = IMAGE_NT_SIGNATURE) and
             (PESigAndHeader.Machine = IMAGE_FILE_MACHINE_I386) then
            Result := True;
        end;
      end;
    end;
  end;
  F.Seek(0);
end;

function CountChars(const S: String; C: Char): Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 1 to Length(S) do
    if S[I] = C then
      Inc(Result);
end;

function IsValidIdentString(const S: String; AllowBackslash, AllowOperators: Boolean): Boolean;
var
  I, N: Integer;
begin
  if S = '' then
    Result := False
  else if not AllowOperators and ((CompareText(S, 'not') = 0) or
     (CompareText(S, 'and') = 0) or (CompareText(S, 'or') = 0)) then
    Result := False
  else begin
    N := Length(S);
    for I := 1 to N do
      if not ((S[I] in ['A'..'Z', 'a'..'z', '_']) or
              ((I > 1) and (S[I] in ['0'..'9'])) or
              (AllowBackslash and (I > 1) and (I < N) and (S[I] = '\'))) then begin
        Result := False;
        Exit;
      end;
    Result := True;
  end;
end;

procedure SkipWhitespace(var S: PChar);
begin
  while S^ in [#1..' '] do
    Inc(S);
end;

function UnescapeBraces(const S: String): String;
{ Changes all '{{' to '{'. Assumes that S does not contain any constants; you
  should check before calling. }
var
  I: Integer;
begin
  Result := S;
  I := 1;
  while I < Length(Result) do begin
    if Result[I] = '{' then begin
      Inc(I);
      if Result[I] = '{' then
        Delete(Result, I, 1);
    end
    else begin
      if Result[I] in CompilerLeadBytes then
        Inc(I);
      Inc(I);
    end;
  end;
end;

type
  HCRYPTPROV = DWORD;

const
  PROV_RSA_FULL = 1;
  CRYPT_VERIFYCONTEXT = $F0000000;

function CryptAcquireContext(var phProv: HCRYPTPROV; pszContainer: PAnsiChar;
  pszProvider: PAnsiChar; dwProvType: DWORD; dwFlags: DWORD): BOOL;
  stdcall; external advapi32 name 'CryptAcquireContextA';
function CryptReleaseContext(hProv: HCRYPTPROV; dwFlags: DWORD): BOOL;
  stdcall; external advapi32 name 'CryptReleaseContext';
function CryptGenRandom(hProv: HCRYPTPROV; dwLen: DWORD; pbBuffer: Pointer): BOOL;
  stdcall; external advapi32 name 'CryptGenRandom';

var
  CryptProv: HCRYPTPROV;

procedure GenerateRandomBytes(var Buffer; Bytes: Cardinal);
var
  ErrorCode: DWORD;
begin
  if CryptProv = 0 then begin
    if not CryptAcquireContext(CryptProv, nil, nil, PROV_RSA_FULL,
       CRYPT_VERIFYCONTEXT) then begin
      ErrorCode := GetLastError;
      raise Exception.CreateFmt('CryptAcquireContext failed with code 0x%.8x: %s',
        [ErrorCode, Win32ErrorString(ErrorCode)]);
    end;
    { Note: CryptProv is released in the 'finalization' section of this unit }
  end;
  FillChar(Buffer, Bytes, 0);
  if not CryptGenRandom(CryptProv, Bytes, @Buffer) then begin
    ErrorCode := GetLastError;
    raise Exception.CreateFmt('CryptGenRandom failed with code 0x%.8x: %s',
      [ErrorCode, Win32ErrorString(ErrorCode)]);
  end;
end;

{ TLowFragList }

procedure TLowFragList.Grow;
var
  Delta: Integer;
begin
  { Delphi 2's TList.Grow induces memory fragmentation big time. This is the
    Grow code from Delphi 3 and later. }
  if Capacity > 64 then Delta := Capacity div 4 else
    if Capacity > 8 then Delta := 16 else
      Delta := 4;
  SetCapacity(Capacity + Delta);
end;

{ THashStringList }

destructor THashStringList.Destroy;
begin
  Clear;
  inherited;
end;

function THashStringList.Add(const S: String): Integer;
var
  LS: String;
begin
  Result := FCount;
  if Result = FCapacity then
    Grow;
  LS := PathLowercase(S);
  Pointer(FList[Result].Str) := nil;  { since Grow doesn't zero init }
  FList[Result].Str := S;
  FList[Result].Hash := GetCRC32(Pointer(LS)^, Length(LS));
  Inc(FCount);
end;

procedure THashStringList.Clear;
begin
  if FCount > 0 then
    Finalize(FList[0], FCount);
  FCount := 0;
  FCapacity := 0;
  ReallocMem(FList, 0);
end;

function THashStringList.Get(Index: Integer): String;
begin
  if (Index < 0) or (Index >= FCount) then
    raise EStringListError.CreateFmt('THashStringList: Index %d is out of bounds',
      [Index]);
  Result := FList[Index].Str;
end;

procedure THashStringList.Grow;
var
  Delta, NewCapacity: Integer;
begin
  if FCapacity > 64 then Delta := FCapacity div 4 else
    if FCapacity > 8 then Delta := 16 else
      Delta := 4;
  NewCapacity := FCapacity + Delta;
  if NewCapacity > MaxListSize then
    raise EStringListError.Create('THashStringList: Exceeded maximum list size');
  ReallocMem(FList, NewCapacity * SizeOf(FList[0]));
  FCapacity := NewCapacity;
end;

function THashStringList.CaseInsensitiveIndexOf(const S: String): Integer;
var
  LS: String;
  Hash: Longint;
  I: Integer;
begin
  LS := PathLowercase(S);
  Hash := GetCRC32(Pointer(LS)^, Length(LS));
  for I := 0 to FCount-1 do
    if (FList[I].Hash = Hash) and (PathLowercase(FList[I].Str) = LS) then begin
      Result := I;
      Exit;
    end;
  Result := -1;
end;

{ TCompressionHandler }

type
  TCompressionHandler = class
  private
    FCompiler: TSetupCompiler;
    FCompressor: TCustomCompressor;
    FChunkBytesRead: Integer64;
    FChunkBytesWritten: Integer64;
    FChunkEncrypted: Boolean;
    FChunkFirstSlice: Integer;
    FChunkStarted: Boolean;
    FChunkStartOffset: Longint;
    FCryptContext: TArcFourContext;
    FCurSlice: Integer;
    FDestFile: TFile;
    FDestFileIsDiskSlice: Boolean;
    FInitialBytesCompressedSoFar: Integer64;
    FSliceBaseOffset: Cardinal;
    FSliceBytesLeft: Cardinal;
    procedure EndSlice;
    procedure NewSlice(const Filename: String);
  public
    constructor Create(ACompiler: TSetupCompiler; const InitialSliceFilename: String);
    destructor Destroy; override;
    procedure CompressFile(const SourceFile: TFile; Bytes: Integer64;
      const CallOptimize: Boolean; var MD5Sum: TMD5Digest);
    procedure EndChunk;
    procedure Finish;
    procedure NewChunk(const ACompressorClass: TCustomCompressorClass;
      const ACompressLevel: Integer; const AUseEncryption: Boolean;
      const ACryptKey: String);
    procedure ProgressProc(BytesProcessed: Cardinal);