compile.pas

源代码

    function ReserveBytesOnSlice(const Bytes: Cardinal): Boolean;
    procedure WriteProc(const Buf; BufSize: Longint);
    property ChunkBytesRead: Integer64 read FChunkBytesRead;
    property ChunkBytesWritten: Integer64 read FChunkBytesWritten;
    property ChunkEncrypted: Boolean read FChunkEncrypted;
    property ChunkFirstSlice: Integer read FChunkFirstSlice;
    property ChunkStartOffset: Longint read FChunkStartOffset;
    property ChunkStarted: Boolean read FChunkStarted;
    property CurSlice: Integer read FCurSlice;
  end;

constructor TCompressionHandler.Create(ACompiler: TSetupCompiler;
  const InitialSliceFilename: String);
begin
  inherited Create;
  FCompiler := ACompiler;
  FCurSlice := -1;
  NewSlice(InitialSliceFilename);
end;

destructor TCompressionHandler.Destroy;
begin
  { These should have already been freed via proper calls, but in case of an
    exception they might not have been. }
  FreeAndNil(FCompressor);
  FreeAndNil(FDestFile);
  inherited;
end;

procedure TCompressionHandler.Finish;
begin
  EndChunk;
  EndSlice;
end;

procedure TCompressionHandler.EndSlice;
var
  DiskSliceHeader: TDiskSliceHeader;
begin
  if Assigned(FDestFile) then begin
    if FDestFileIsDiskSlice then begin
      DiskSliceHeader.TotalSize := FDestFile.Size.Lo;
      FDestFile.Seek(SizeOf(DiskSliceID));
      FDestFile.WriteBuffer(DiskSliceHeader, SizeOf(DiskSliceHeader));
    end;
    FreeAndNil(FDestFile);
  end;
end;

procedure TCompressionHandler.NewSlice(const Filename: String);

  function GenerateSliceFilename(const Compiler: TSetupCompiler;
    const ASlice: Integer): String;
  var
    Major, Minor: Integer;
  begin
    Major := ASlice div Compiler.SlicesPerDisk + 1;
    Minor := ASlice mod Compiler.SlicesPerDisk;
    if Compiler.SlicesPerDisk = 1 then
      Result := Format('%s-%d.bin', [Compiler.OutputBaseFilename, Major])
    else
      Result := Format('%s-%d%s.bin', [Compiler.OutputBaseFilename, Major,
        Chr(Ord('a') + Minor)]);
  end;

var
  DiskHeader: TDiskSliceHeader;
begin
  EndSlice;
  Inc(FCurSlice);
  if (FCurSlice > 0) and not FCompiler.DiskSpanning then
    FCompiler.AbortCompileFmt(SCompilerMustUseDiskSpanning,
      [FCompiler.DiskSliceSize]);
  if Filename = '' then begin
    FDestFileIsDiskSlice := True;
    FDestFile := TFile.Create(FCompiler.OutputDir +
      GenerateSliceFilename(FCompiler, FCurSlice), fdCreateAlways, faReadWrite, fsNone);
    FDestFile.WriteBuffer(DiskSliceID, SizeOf(DiskSliceID));
    DiskHeader.TotalSize := 0;
    FDestFile.WriteBuffer(DiskHeader, SizeOf(DiskHeader));
    FSliceBaseOffset := 0;
    FSliceBytesLeft := FCompiler.DiskSliceSize - (SizeOf(DiskSliceID) + SizeOf(DiskHeader));
  end
  else begin
    FDestFileIsDiskSlice := False;
    FDestFile := TFile.Create(Filename, fdOpenExisting, faReadWrite, fsNone);
    FDestFile.SeekToEnd;
    FSliceBaseOffset := FDestFile.Position.Lo;
    FSliceBytesLeft := Cardinal(FCompiler.DiskSliceSize) - FSliceBaseOffset;
  end;
end;

function TCompressionHandler.ReserveBytesOnSlice(const Bytes: Cardinal): Boolean;
begin
  if FSliceBytesLeft >= Bytes then begin
    Dec(FSliceBytesLeft, Bytes);
    Result := True;
  end
  else
    Result := False;
end;

procedure TCompressionHandler.NewChunk(const ACompressorClass: TCustomCompressorClass;
  const ACompressLevel: Integer; const AUseEncryption: Boolean;
  const ACryptKey: String);

  procedure InitEncryption;
  var
    Salt: TSetupSalt;
    Context: TMD5Context;
    Hash: TMD5Digest;
  begin
    { Generate and write a random salt. This salt is hashed into the key to
      prevent the same key from ever being used twice (theoretically). }
    GenerateRandomBytes(Salt, SizeOf(Salt));
    FDestFile.WriteBuffer(Salt, SizeOf(Salt));

    { Create an MD5 hash of the salt plus ACryptKey, and use that as the key }
    MD5Init(Context);
    MD5Update(Context, Salt, SizeOf(Salt));
    MD5Update(Context, Pointer(ACryptKey)^, Length(ACryptKey));
    Hash := MD5Final(Context);
    ArcFourInit(FCryptContext, Hash, SizeOf(Hash));

    { Discard first 1000 bytes of the output keystream, since according to
      <http://en.wikipedia.org/wiki/RC4_(cipher)>, "the first few bytes of
      output keystream are strongly non-random." }
    ArcFourDiscard(FCryptContext, 1000);
  end;

var
  MinBytesLeft: Cardinal;
begin
  EndChunk;

  { If there isn't enough room left to start a new chunk on the current slice,
    start a new slice }
  MinBytesLeft := SizeOf(ZLIBID);
  if AUseEncryption then
    Inc(MinBytesLeft, SizeOf(TSetupSalt));
  Inc(MinBytesLeft);  { for at least one byte of data }
  if FSliceBytesLeft < MinBytesLeft then
    NewSlice('');

  FChunkFirstSlice := FCurSlice;
  FChunkStartOffset := FDestFile.Position.Lo - FSliceBaseOffset;
  FDestFile.WriteBuffer(ZLIBID, SizeOf(ZLIBID));
  Dec(FSliceBytesLeft, SizeOf(ZLIBID));
  FChunkBytesRead.Hi := 0;
  FChunkBytesRead.Lo := 0;
  FChunkBytesWritten.Hi := 0;
  FChunkBytesWritten.Lo := 0;
  FInitialBytesCompressedSoFar := FCompiler.BytesCompressedSoFar;

  FCompressor := ACompressorClass.Create(WriteProc, ProgressProc, ACompressLevel);

  FChunkEncrypted := AUseEncryption;
  if AUseEncryption then
    InitEncryption;

  FChunkStarted := True;
end;

procedure TCompressionHandler.EndChunk;
begin
  if Assigned(FCompressor) then begin
    FCompressor.Finish;
    FreeAndNil(FCompressor);
    { In case we didn't get a ProgressProc call after the final block: }
    FCompiler.BytesCompressedSoFar := FInitialBytesCompressedSoFar;
    Inc6464(FCompiler.BytesCompressedSoFar, FChunkBytesRead);
    FCompiler.CallIdleProc;
  end;

  FChunkStarted := False;
end;

procedure TCompressionHandler.CompressFile(const SourceFile: TFile;
  Bytes: Integer64; const CallOptimize: Boolean; var MD5Sum: TMD5Digest);
var
  Context: TMD5Context;
  BufSize: Cardinal;
  Buf: array[0..65535] of Byte;
  CallEncoder: TCallInstructionOptimizer;
begin
  MD5Init(Context);
  if CallOptimize then
    CallEncoder := TCallInstructionOptimizer.Create(True)
  else
    CallEncoder := nil;
  try
    while True do begin
      BufSize := SizeOf(Buf);
      if (Bytes.Hi = 0) and (Bytes.Lo < BufSize) then
        BufSize := Bytes.Lo;
      if BufSize = 0 then
        Break;

      SourceFile.ReadBuffer(Buf, BufSize);
      Inc64(FChunkBytesRead, BufSize);
      Dec64(Bytes, BufSize);
      MD5Update(Context, Buf, BufSize);
      if CallOptimize then
        CallEncoder.Code(Buf, BufSize);
      FCompressor.Compress(Buf, BufSize);
    end;
  finally
    CallEncoder.Free;
  end;
  MD5Sum := MD5Final(Context);
end;

procedure TCompressionHandler.WriteProc(const Buf; BufSize: Longint);
var
  P, P2: Pointer;
  S: Cardinal;
begin
  FCompiler.CallIdleProc;
  P := @Buf;
  while BufSize > 0 do begin
    S := BufSize;
    if FSliceBytesLeft = 0 then
      NewSlice('');
    if S > Cardinal(FSliceBytesLeft) then
      S := FSliceBytesLeft;

    if not FChunkEncrypted then
      FDestFile.WriteBuffer(P^, S)
    else begin
      { Using encryption. Can't modify Buf in place so allocate a new,
        temporary buffer. }
      GetMem(P2, S);
      try
        ArcFourCrypt(FCryptContext, P^, P2^, S);
        FDestFile.WriteBuffer(P2^, S)
      finally
        FreeMem(P2);
      end;
    end;

    Inc64(FChunkBytesWritten, S);
    Inc(Cardinal(P), S);
    Dec(BufSize, S);
    Dec(FSliceBytesLeft, S);
  end;
end;

procedure TCompressionHandler.ProgressProc(BytesProcessed: Cardinal);
begin
  Inc64(FCompiler.BytesCompressedSoFar, BytesProcessed);
  FCompiler.CallIdleProc;
end;

{ TSetupCompiler }

constructor TSetupCompiler.Create(AOwner: TComponent);
begin
  inherited Create;
  ScriptFiles := TStringList.Create;
  ParseFilenameStack := TStringList.Create;
  LanguageEntries := TLowFragList.Create;
  CustomMessageEntries := TLowFragList.Create;
  PermissionEntries := TLowFragList.Create;
  TypeEntries := TLowFragList.Create;
  ComponentEntries := TLowFragList.Create;
  TaskEntries := TLowFragList.Create;
  DirEntries := TLowFragList.Create;
  FileEntries := TLowFragList.Create;
  FileLocationEntries := TLowFragList.Create;
  IconEntries := TLowFragList.Create;
  IniEntries := TLowFragList.Create;
  RegistryEntries := TLowFragList.Create;
  InstallDeleteEntries := TLowFragList.Create;
  UninstallDeleteEntries := TLowFragList.Create;
  RunEntries := TLowFragList.Create;
  UninstallRunEntries := TLowFragList.Create;
  FileLocationEntryFilenames := THashStringList.Create;
  WarningsList := TStringList.Create;
  ExpectedCustomMessageNames := TStringList.Create;
  LangDataList := TLowFragList.Create;
  DebugInfo := TMemoryStream.Create;
  CodeDebugInfo := TMemoryStream.Create;
  CodeText := TStringList.Create;
  CodeCompiler := TScriptCompiler.Create;
end;

destructor TSetupCompiler.Destroy;
begin
  CodeCompiler.Free;
  CodeText.Free;
  CodeDebugInfo.Free;
  DebugInfo.Free;
  LangDataList.Free;
  ExpectedCustomMessageNames.Free;
  WarningsList.Free;
  FileLocationEntryFilenames.Free;
  UninstallRunEntries.Free;
  RunEntries.Free;
  UninstallDeleteEntries.Free;
  InstallDeleteEntries.Free;
  RegistryEntries.Free;
  IniEntries.Free;
  IconEntries.Free;
  FileLocationEntries.Free;
  FileEntries.Free;
  DirEntries.Free;
  TaskEntries.Free;
  ComponentEntries.Free;
  TypeEntries.Free;
  PermissionEntries.Free;
  CustomMessageEntries.Free;
  LanguageEntries.Free;
  ParseFilenameStack.Free;
  ScriptFiles.Free;
  inherited Destroy;
end;

procedure TSetupCompiler.InitZipDLL;
var
  M: HMODULE;
begin
  if ZipInitialized then
    Exit;
  M := SafeLoadLibrary(CompilerDir + 'iszlib.dll', SEM_NOOPENFILEERRORBOX);
  if M = 0 then
    AbortCompileFmt('Failed to load iszlib.dll (%d)', [GetLastError]);
  if not ZlibInitCompressFunctions(M) then
    AbortCompile('Failed to get address of functions in iszlib.dll');
  ZipInitialized := True;
end;

procedure TSetupCompiler.InitBzipDLL;
var
  M: HMODULE;
begin
  if BzipInitialized then
    Exit;
  M := SafeLoadLibrary(CompilerDir + 'isbzip.dll', SEM_NOOPENFILEERRORBOX);
  if M = 0 then
    AbortCompileFmt('Failed to load isbzip.dll (%d)', [GetLastError]);
  if not BZInitCompressFunctions(M) then
    AbortCompile('Failed to get address of functions in isbzip.dll');
  BzipInitialized := True;
end;

procedure TSetupCompiler.InitLZMADLL;
var
  M: HMODULE;
begin
  if LZMAInitialized then
    Exit;
  M := SafeLoadLibrary(CompilerDir + 'islzma.dll', SEM_NOOPENFILEERRORBOX);
  if M = 0 then
    AbortCompileFmt('Failed to load islzma.dll (%d)', [GetLastError]);
  if not LZMAInitCompressFunctions(M) then
    AbortCompile('Failed to get address of functions in islzma.dll');
  LZMAInitialized := True;
end;

procedure TSetupCompiler.InitCryptDLL;
var
  M: HMODULE;
begin
  if CryptInitialized then
    Exit;
  M := SafeLoadLibrary(CompilerDir + 'iscrypt.dll', SEM_NOOPENFILEERRORBOX);
  if M = 0 then
    AbortCompileFmt('Failed to load iscrypt.dll (%d)', [GetLastError]);
  if not ArcFourInitFunctions(M) then
    AbortCompile('Failed to get address of functions in iscrypt.dll');
  CryptInitialized := True;
end;

function TSetupCompiler.ParseFilename: String;
begin
  if ParseFilenameStack.Count > 0 then
    Result := ParseFilenameStack[ParseFilenameStack.Count-1]
  else
    Result := '';
end;

procedure TSetupCompiler.WriteDebugEntry(Kind: TDebugEntryKind; Index: Integer);
var
  Rec: TDebugEntry;
begin
  if ParseFilename = '' then
    Rec.LineNumber := LineNumber
  else
    Rec.LineNumber := 0;
  Rec.Kind := Ord(Kind);
  Rec.Index := Index;
  DebugInfo.WriteBuffer(Rec, SizeOf(Rec));
  Inc(DebugEntryCount);
end;

procedure TSetupCompiler.WriteCompiledCodeText(const CompiledCodeText: String);
begin
  CompiledCodeTextLength := Length(CompiledCodeText);
  CodeDebugInfo.WriteBuffer(CompiledCodeText[1], CompiledCodeTextLength);
end;

procedure TSetupCompiler.WriteCompiledCodeDebugInfo(const CompiledCodeDebugInfo: String);
begin
  CompiledCodeDebugInfoLength := Length(CompiledCodeDebugInfo);
  CodeDebugInfo.WriteBuffer(CompiledCodeDebugInfo[1], CompiledCodeDebugInfoLength);
end;

procedure TSetupCompiler.ShiftDebugEntryIndexes(AKind: TDebugEntryKind);
{ Increments the Index field of each debug entry of the specified kind by 1.
  This has to be called when a new entry is inserted at the *front* of an
  *Entries array, since doing that causes the indexes of existing entries to
  shift. }
var
  Rec: PDebugEntry;