博客园_万一的 Delphi 博客

给 System.Zip 增加了个(多文件解压时的)解压进度事件

2012-02-04T05:51:00Z

很喜欢 System.Zip; 手头的程序需要把压缩后的一组文件从内存流解压, 这用 System.Zip 非常简单, 但我需要呈现解压进度, 同时给出当前文件名.

因此给 System.Zip.TZipFile 添加了一个 OnUnZipProgress 事件.

在 System.Zip 的基础上添加了不足 10 行代码, 新加代码都在行尾标记了 ///.

修改后的文件(Zip2.pas):

unit Zip2;

interface

uses
  System.SysUtils,
  System.IOUtils,
  System.Generics.Collections,
  System.Classes;

type
  TZipCompression = (
    zcStored    = 0,
    zcShrunk,
    zcReduce1,
    zcReduce2,
    zcReduce3,
    zcReduce4,
    zcImplode,
    zcTokenize,
    zcDeflate,
    zcDeflate64,
    zcPKImplode,
    {11 RESERVED}
    zcBZIP2    = 12,
    {13 RESERVED}
    zcLZMA     = 14,
    {15-17 RESERVED}
    zcTERSE    = 18,
    zcLZ77,
    zcWavePack = 97,
    zcPPMdI1
  );

function TZipCompressionToString(Compression: TZipCompression): string;
const
  SIGNATURE_ZIPENDOFHEADER: UInt32 = $06054B50;
  SIGNATURE_CENTRALHEADER:  UInt32 = $02014B50;
  SIGNATURE_LOCALHEADER:    UInt32 = $04034B50;

  LOCALHEADERSIZE = 26;
  CENTRALHEADERSIZE = 42;

type
  TZipEndOfCentralHeader = packed record
    DiskNumber:          UInt16;
    CentralDirStartDisk: UInt16;
    NumEntriesThisDisk:  UInt16;
    CentralDirEntries:   UInt16;
    CentralDirSize:      UInt32;
    CentralDirOffset:    UInt32;
    CommentLength:       UInt16;
  end;

  TZipHeader = packed record
    MadeByVersion:      UInt16;
    RequiredVersion:    UInt16;
    Flag:               UInt16;
    CompressionMethod:  UInt16;
    ModifiedDateTime:   UInt32;
    CRC32:              UInt32;
    CompressedSize:     UInt32;
    UncompressedSize:   UInt32;
    FileNameLength:     UInt16;
    ExtraFieldLength:   UInt16;
    FileCommentLength:  UInt16;
    DiskNumberStart:    UInt16;
    InternalAttributes: UInt16;
    ExternalAttributes: UInt32;
    LocalHeaderOffset:  UInt32;
    FileName: RawByteString;
    ExtraField: TBytes;
    FileComment: RawByteString;
  end;
  PZipHeader = ^TZipHeader;

  EZipException = class( Exception );

  TZipMode = (zmClosed, zmRead, zmReadWrite, zmWrite);

  TZipFile = class;

  TStreamConstructor = reference to function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream;

  TUnZipProgressEvent = procedure(Sender: TObject; ACount,AIndex: Integer; AFileName: string) of object; ///

  TZipFile = class
  private type
    TCompressionDict = TDictionary< TZipCompression , TPair<TStreamConstructor, TStreamConstructor > >;
  private class var
    FCompressionHandler: TCompressionDict;
  private
    FMode: TZipMode;
    FStream: TStream;
    FFileStream: TFileStream;
    FStartFileData: Int64;
    FEndFileData: Int64;
    FFiles: TList<TZipHeader>;
    FComment: String;
    FUTF8Support: Boolean;
    function GetFileComment(Index: Integer): string;
    function GetFileCount: Integer;
    function GetFileInfo(Index: Integer): TZipHeader;
    function GetFileInfos: TArray<TZipHeader>;
    function GetFileName(Index: Integer): string;
    function GetFileNames: TArray<string>;
    procedure ReadCentralHeader;
    procedure SetFileComment(Index: Integer; Value: string);
    procedure SetUTF8Support(const Value: Boolean);
    function LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
  protected                                                                ///
    FOnUnZipProgress: TUnZipProgressEvent;                                 ///
    procedure DoUnZipProgress(ACount,AIndex: Integer; AFileName: string);  ///
  public
    class constructor Create;
    class destructor Destroy;
    class procedure RegisterCompressionHandler(Compression: TZipCompression;
      CompressStream, DecompressStream: TStreamConstructor);
    class function IsValid(ZipFileName: string): Boolean; static;
    class procedure ExtractZipFile(ZipFileName: string; Path: string); static;
    class procedure ZipDirectoryContents(ZipFileName: string; Path: string;
      Compression: TZipCompression = zcDeflate); static;
    constructor Create;
    destructor Destroy; override;
    procedure Open(ZipFileName: string; OpenMode: TZipMode); overload;
    procedure Open(ZipFileStream: TStream; OpenMode: TZipMode); overload;
    procedure Close;
    procedure Extract(FileName: string; Path: string = ''; CreateSubdirs: Boolean=True); overload;
    procedure Extract(Index: Integer; Path: string = ''; CreateSubdirs: Boolean=True); overload;
    procedure ExtractAll(Path: string = '');
    procedure Read(FileName: string; out Bytes: TBytes); overload;
    procedure Read(Index: Integer; out Bytes: TBytes); overload;
    procedure Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader); overload;
    procedure Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader); overload;
    procedure Add(FileName: string; ArchiveFileName: string = '';
      Compression: TZipCompression = zcDeflate); overload;
    procedure Add(Data: TBytes; ArchiveFileName: string;
      Compression: TZipCompression = zcDeflate); overload;
    procedure Add(Data: TStream; ArchiveFileName: string;
      Compression: TZipCompression = zcDeflate); overload;
    procedure Add(Data: TStream; LocalHeader: TZipHeader;
      CentralHeader: PZipHeader = nil); overload;
    function IndexOf(FileName: string): Integer;
    property Mode: TZipMode read FMode;
    property FileCount: Integer read GetFileCount;
    property FileNames: TArray<string> read GetFileNames;
    property FileInfos: TArray<TZipHeader> read GetFileInfos;
    property FileName[Index: Integer]: string read GetFileName;
    property FileInfo[Index: Integer]: TZipHeader read GetFileInfo;
    property FileComment[Index: Integer]: string read GetFileComment write SetFileComment;
    property Comment: string read FComment write FComment;
    property UTF8Support: Boolean read FUTF8Support write SetUTF8Support default True;
    property OnUnZipProgress: TUnZipProgressEvent read FOnUnZipProgress write FOnUnZipProgress; ///
  end;

implementation

uses
  System.RTLConsts,
  System.ZLib;

type
  TOem437String = type AnsiString(437);

procedure VerifyRead(Stream: TStream; var Buffer; Count: Integer);
begin
  if Stream.Read(Buffer, Count) <> Count then
  raise EZipException.CreateRes(@SZipErrorRead) at ReturnAddress;
end;

procedure VerifyWrite(Stream: TStream; var Buffer; Count: Integer);
begin
  if Stream.Write(Buffer, Count) <> Count then
    raise EZipException.CreateRes(@SZipErrorWrite) at ReturnAddress;
end;

type
  TStoredStream = class( TStream )
  private
    FStream: TStream;
    FPos: Int64;
  protected
    function GetSize: Int64; override;
  public
    constructor Create( Stream: TStream );
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  end;

{ TStoredStream }

constructor TStoredStream.Create(Stream: TStream);
begin
  FStream := Stream;
  FPos := FStream.Position;
end;

function TStoredStream.GetSize: Int64;
begin
  Result := FStream.Size;
end;

function TStoredStream.Read(var Buffer; Count: Integer): Longint;
begin
  Result := FStream.Read(Buffer, Count);
end;

function TStoredStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := FStream.Seek(Offset, Origin)
end;

function TStoredStream.Write(const Buffer; Count: Integer): Longint;
begin
  Result := FStream.Write(Buffer, Count);
end;

function TZipCompressionToString(Compression: TZipCompression): string;
begin
  case Compression of
    zcStored:    Result := 'Stored';
    zcShrunk:    Result := 'Shrunk';
    zcReduce1:   Result := 'Reduced1';
    zcReduce2:   Result := 'Reduced2';
    zcReduce3:   Result := 'Reduced3';
    zcReduce4:   Result := 'Reduced4';
    zcImplode:   Result := 'Imploded';
    zcTokenize:  Result := 'Tokenized';
    zcDeflate:   Result := 'Deflated';
    zcDeflate64: Result := 'Deflated64';
    zcPKImplode: Result := 'Imploded(TERSE)';
    zcBZIP2:     Result := 'BZIP2';
    zcLZMA:      Result := 'LZMA';
    zcTERSE:     Result := 'TERSE';
    zcLZ77:      Result := 'LZ77';
    zcWavePack:  Result := 'WavPack';
    zcPPMdI1:    Result := 'PPMd version I, Rev 1';
    else
      Result := 'Unknown';
  end;
end;

{ TZipFile }

function TZipFile.GetFileComment(Index: Integer): string;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  Result := string(FFiles[Index].FileComment);
end;

function TZipFile.GetFileCount: Integer;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  Result := FFiles.Count;
end;

function TZipFile.GetFileInfo(Index: Integer): TZipHeader;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  Result := FFiles[Index];
end;

function TZipFile.GetFileInfos: TArray<TZipHeader>;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  Result := FFiles.ToArray;
end;

function TZipFile.GetFileName(Index: Integer): string;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  Result := string(FFiles[Index].FileName);
end;

function TZipFile.GetFileNames: TArray<string>;
var
  I: Integer;
begin
  if FMode = zmClosed then
    raise EZipException.CreateRes(@SZipNotOpen);
  SetLength(Result, FFiles.Count);
  for I := 0 to High(Result) do
    Result[I] := string(FFiles[I].FileName);
end;

procedure TZipFile.ReadCentralHeader;
var
  I: Integer;
  Signature: UInt32;
  LEndHeader: TZipEndOfCentralHeader;
  LHeader: TZipHeader;
begin
  FFiles.Clear;
  if FStream.Size = 0 then
    Exit;
  if not LocateEndOfCentralHeader(LEndHeader) then
    raise EZipException.CreateRes(@SZipErrorRead);
  FStream.Position := LEndHeader.CentralDirOffset;
  FEndFileData := LEndHeader.CentralDirOffset;
  for I := 0 to LEndHeader.CentralDirEntries - 1 do
  begin
    FStream.Read(Signature, Sizeof(Signature));
    if Signature <> SIGNATURE_CENTRALHEADER then
      raise EZipException.CreateRes(@SZipInvalidCentralHeader);
    VerifyRead(FStream, LHeader.MadeByVersion, CENTRALHEADERSIZE);
    if LHeader.FileNameLength > 0 then
    begin
      SetLength(LHeader.FileName, LHeader.FileNameLength);
      if (LHeader.Flag and (1 SHL 11)) <> 0 then
        SetCodepage(LHeader.FileName, 65001, False)
      else
        SetCodepage(LHeader.FileName, 437, False);
      VerifyRead(FStream, LHeader.FileName[1], LHeader.FileNameLength);
    end;
    if LHeader.ExtraFieldLength > 0 then
    begin
      SetLength(LHeader.ExtraField, LHeader.ExtraFieldLength);
      VerifyRead(FStream, LHeader.ExtraField[0], LHeader.ExtraFieldLength);
    end;
    if LHeader.FileCommentLength > 0 then
    begin
      SetLength(LHeader.FileComment, LHeader.FileCommentLength);
      if (LHeader.Flag and (1 SHL 11)) <> 0 then
        SetCodepage(LHeader.FileName, 65001, False)
      else
        SetCodepage(LHeader.FileName, 437, False);
      VerifyRead(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
    end;
    if (LHeader.Flag and (1 shl 11)) = 0 then
      FUTF8Support := False;

    FFiles.Add(LHeader);
  end;
end;

procedure TZipFile.SetFileComment(Index: Integer; Value: string);
var
  LFile: TZipHeader;
begin
  if not (FMode in [zmReadWrite, zmWrite]) then
    raise EZipException.CreateRes(@SZipNoWrite);
  LFile := FFiles[Index];
  if Length(Value) > $FFFF then
    SetLength(Value, $FFFF);
  if UTF8Support then
    LFile.FileComment := UTF8Encode(Value)
  else
    LFile.FileComment := TOem437String(Value);

  LFile.FileCommentLength := Length(LFile.FileComment);
  FFiles[Index] := LFile;
end;

procedure TZipFile.SetUTF8Support(const Value: Boolean);
begin
  if Value = FUTF8Support then Exit;
  if not (FMode in [zmReadWrite, zmWrite]) then
    raise EZipException.CreateRes(@SZipNoWrite);
  if FFiles.Count <> 0 then
    raise EZipException.CreateRes(@SZipNotEmpty);

  FUTF8Support := Value;
end;

class constructor TZipFile.Create;
begin
  FCompressionHandler := TCompressionDict.Create;

  RegisterCompressionHandler(zcStored,
    function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
    begin
      Result := TStoredStream.Create(InStream);
    end,
    function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
    begin
      Result := TStoredStream.Create(InStream);
    end);

  RegisterCompressionHandler(zcDeflate,
    function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
    begin
      Result := TZCompressionStream.Create(InStream, zcDefault, -15);
    end,
    function(InStream: TStream; const ZipFile: TZipFile; const Item: TZipHeader): TStream
    begin
      Result := TZDecompressionStream.Create(InStream, -15);
    end);
end;

class destructor TZipFile.Destroy;
begin
  FCompressionHandler.Free;
end;

class procedure TZipFile.RegisterCompressionHandler(
  Compression: TZipCompression; CompressStream, DecompressStream: TStreamConstructor);
begin
  FCompressionHandler.AddOrSetValue(Compression,
    TPair<TStreamConstructor, TStreamConstructor>.Create(CompressStream, DecompressStream));
end;

class function TZipFile.IsValid(ZipFileName: string): Boolean;
var
  Z: TZipFile;
  Header: TZipEndOfCentralHeader;
begin
  Result := False;
  try
    Z := tzipfile.Create;
    try
      Z.FStream := TFileStream.Create(ZipFileName, fmOpenRead);
      try
        Result := Z.LocateEndOfCentralHeader(Header);
      finally
        Z.FStream.Free;
      end;
    finally
      Z.Free;
    end;
  except on E: Exception do
  end;
end;

function TZipFile.LocateEndOfCentralHeader(var Header: TZipEndOfCentralHeader): Boolean;
var
  I: Integer;
  LBackRead, LReadSize, LMaxBack: UInt32;
  LBackBuf: array[0..$404-1] of Byte;
begin
  if FStream.Size < $FFFF then
    LMaxBack := FStream.Size
  else
    LMaxBack := $FFFF;
  LBackRead := 4;
  while LBackRead < LMaxBack do
  begin
    if LBackRead + Cardinal(Length(LBackBuf) - 4) > LMaxBack then
      LBackRead := LMaxBack
    else
      Inc(LBackRead, Length(LBackBuf) -4);
    FStream.Position := FStream.Size - LBackRead;
    if Length(LBackBuf) < (FStream.Size - FStream.Position) then
      LReadSize := Length(LBackBuf)
    else
      LReadSize := FStream.Size - FStream.Position;

    VerifyRead(FStream, LBackBuf[0], LReadSize);

    for I := LReadSize - 4 downto 0 do
    begin
      if PCardinal(@LBackBuf[I])^ = SIGNATURE_ZIPENDOFHEADER then
      begin
        Move(LBackBuf[I+4], Header, SizeOf(Header));
        if Header.CommentLength > 0 then
        begin
          FStream.Position := FStream.Size - LBackRead + I + 4 + SizeOf(Header);
          SetLength(FComment, Header.CommentLength);
          FStream.Read(FComment[1], Header.CommentLength);
        end
        else
          FComment := '';
        Exit(True);
      end;
    end;
  end;
  Result := False;
end;

class procedure TZipFile.ExtractZipFile(ZipFileName: string; Path: string);
var
  LZip: TZipFile;
begin
  LZip := TZipFile.Create;
  try
    LZip.Open(ZipFileName, zmRead);
    LZip.ExtractAll(Path);
    LZip.Close;
  finally
    LZip.Free;
  end;
end;

class procedure TZipFile.ZipDirectoryContents(ZipFileName: string; Path: string;
  Compression: TZipCompression);
var
  LZipFile: TZipFile;
  LFile: string;
  LZFile: string;
begin
  LZipFile := TZipFile.Create;
  try
    LZipFile.Open(ZipFileName, zmWrite);
    if Path[Length(Path)] <> PathDelim then
      Path := Path + PathDelim;

    for LFile in TDirectory.GetFiles(Path, '*', TSearchOption.soAllDirectories) do  
    begin
{$IFDEF MSWINDOWS}
      LZFile := StringReplace(
        Copy(LFile, Length(Path)+1, Length(LFile)), '\', '/', [rfReplaceAll]);
{$ELSE}
      LZFile := Copy(LFile, Length(Path)+1, Length(LFile));
{$ENDIF MSWINDOWS}
      LZipFile.Add(LFile, LZFile, Compression);
    end;
  finally
    LZipFile.Free;
  end;
end;

constructor TZipFile.Create;
begin
  inherited Create;
  FFiles := TList<TZipHeader>.Create;
  FMode := zmClosed;
  FUTF8Support := True;
end;

destructor TZipFile.Destroy;
begin
  Close;
  FFiles.Free;
  inherited;
end;

procedure TZipFile.DoUnZipProgress(ACount, AIndex: Integer; AFileName: string); ///
begin                                                                           ///
  if Assigned(FOnUnZipProgress) then                                            ///
    FOnUnZipProgress(Self, ACount, AIndex, AFileName);
end;

procedure TZipFile.Open(ZipFileName: string; OpenMode: TZipMode);
var
  LMode: LongInt;
  LFileStream: TFileStream;
begin
  Close;
  case OpenMode of
    zmRead:      LMode := fmOpenRead;
    zmReadWrite: LMode := fmOpenReadWrite;
    zmWrite:     LMode := fmCreate;
    else
      raise EZipException.CreateRes(@sArgumentInvalid);
  end;
  LFileStream := TFileStream.Create(ZipFileName, LMode);
  try
    Open(LFileStream, OpenMode);
    FFileStream := LFileStream;
  except
    FreeAndNil(LFileStream);
    raise;
  end;
end;

procedure TZipFile.Open(ZipFileStream: TStream; OpenMode: TZipMode);
begin
  Close;
  if OpenMode = zmClosed then
    raise EZipException.CreateRes(@sArgumentInvalid);
  if (OpenMode = zmRead) and (ZipFileStream.Size = 0) then
    raise EZipException.CreateRes(@SReadError);

  FStream := ZipFileStream;
  FStartFileData := FStream.Position;
  if OpenMode in [zmRead, zmReadWrite] then
  try
    ReadCentralHeader;
  except
    FStream := nil;
    raise;
  end;
  FMode := OpenMode;
end;

procedure TZipFile.Close;
var
  LHeader: TZipHeader;
  LEndOfHeader: TZipEndOfCentralHeader;
  I: Integer;
  Signature: UInt32;
begin
  try
    if (FMode = zmReadWrite) or (FMode = zmWrite) then
    begin
      FStream.Position := FEndFileData;
      Signature := SIGNATURE_CENTRALHEADER;
      for I := 0 to FFiles.Count - 1 do
      begin
        LHeader := FFiles[I];
        VerifyWrite(FStream, Signature, SizeOf(Signature));
        VerifyWrite(FStream, LHeader.MadeByVersion,  CENTRALHEADERSIZE);
        if LHeader.FileNameLength <> 0 then
          VerifyWrite(FStream, LHeader.FileName[1], LHeader.FileNameLength);
        if LHeader.ExtraFieldLength <> 0 then
          VerifyWrite(FStream, LHeader.ExtraField[1], LHeader.ExtraFieldLength);
        if LHeader.FileCommentLength <> 0 then
          VerifyWrite(FStream, LHeader.FileComment[1], LHeader.FileCommentLength);
      end;
      FillChar(LEndOfHeader, Sizeof(LEndOfHeader), 0);
      LEndOfHeader.CentralDirEntries := FFiles.Count;
      LEndOfHeader.NumEntriesThisDisk := FFiles.Count;
      LEndOfHeader.CentralDirSize := FStream.Position - FEndFileData;
      LEndOfHeader.CentralDirOffset := FEndFileData;
      if Length(FComment) > $FFFF then
        SetLength(FComment, $FFFF);
      LEndofHeader.CommentLength := Length(FComment);
      Signature := SIGNATURE_ZIPENDOFHEADER;
      VerifyWrite(FStream, Signature, SizeOf(Signature));
      VerifyWrite(FStream, LEndOfHeader, SizeOf(LEndOfHeader));
      if LEndOfHeader.CommentLength > 0 then
        VerifyWrite(FStream, FComment[1], LEndOfHeader.CommentLength);
    end;
  finally
    FMode := zmClosed;
    FFiles.Clear;
    FStream := nil;
    if Assigned(FFileStream) then
      FreeAndNil(FFileStream);
  end;
end;

procedure TZipFile.Extract(FileName: string; Path: string; CreateSubDirs: Boolean);
begin
  Extract(IndexOf(FileName), Path, CreateSubdirs);
end;

procedure TZipFile.Extract(Index: Integer; Path: string; CreateSubdirs: Boolean);
var
  LInStream, LOutStream: TStream;
  LHeader: TZipHeader;
  LDir, LFileName: string;
  Bytes: array [0..4095] of Byte;
  ReadBytes: Int64;
begin
  Read(Index, LInStream, LHeader);
  try
    LFileName := string(FFiles[Index].FileName);
{$IFDEF MSWINDOWS}
    LFileName := StringReplace(LFileName, '/', '\', [rfReplaceAll]);
{$ENDIF}
    if CreateSubdirs then
      LFileName := TPath.Combine(Path, LFileName)
    else
      LFileName := TPath.Combine(Path, ExtractFileName(LFileName));
    LDir := ExtractFileDir(LFileName);
    if CreateSubdirs and (LDir <> '') then
      TDirectory.CreateDirectory(ExtractFileDir(LFileName));
    if LFileName[Length(LFileName)] = PathDelim then
      Exit;
    LOutStream := TFileStream.Create(LFileName, fmCreate);
    try
      if (LHeader.Flag and (1 SHL 3)) = 0 then
        if FFiles[Index].UncompressedSize > 0 then
          LOutStream.CopyFrom(LInStream, FFiles[Index].UncompressedSize)
        else
        begin
          while True do
          begin
            ReadBytes := LInStream.Read(Bytes, Length(Bytes));
            LOutStream.Write(Bytes, ReadBytes);
            if ReadBytes < Length(Bytes) then
              break;
          end;
        end;
    finally
      LOutStream.Free;
    end;
  finally
    LInStream.Free;
  end;
end;

procedure TZipFile.ExtractAll(Path: string);
var
  I: Integer;
begin
  if not (FMode in [zmReadWrite, zmRead]) then
    raise EZipException.CreateRes(@SZipNoRead);
  for I := 0 to FFiles.Count - 1 do
  begin                                           ///
    Extract(I, Path);
    DoUnZipProgress(FileCount, I+1, FileName[I]); ///
  end;                                            ///
end;

procedure TZipFile.Read(FileName: string; out Bytes: TBytes);
begin
  Read(IndexOf(FileName), Bytes);
end;

procedure TZipFile.Read(Index: Integer; out Bytes: TBytes);
var
  LStream: TStream;
  LHeader: TZipHeader;
  ReadStart, ReadBytes: Int64;
begin
  Read(Index, LStream, LHeader);
  try
    if (LHeader.Flag and (1 SHL 3)) = 0 then
    begin
      SetLength(Bytes, FFiles[Index].UncompressedSize);
      if FFiles[Index].UncompressedSize > 0 then
        VerifyRead(LStream, Bytes[0], LHeader.UncompressedSize);
    end
    else
    begin
      SetLength(Bytes, 4096);
      ReadStart := 0;
      ReadBytes := 0;
      while True do
      begin
        ReadBytes := LStream.Read(Bytes[ReadStart], Length(Bytes)-ReadStart);
        if ReadBytes < (Length(Bytes) - ReadStart) then
          break;
        ReadStart := ReadStart + ReadBytes;
        SetLength(Bytes, Length(Bytes)*2);
      end;
      SetLength(Bytes, ReadStart + ReadBytes);
    end;
  finally
    LStream.Free;
  end;
end;

procedure TZipFile.Read(FileName: string; out Stream: TStream; out LocalHeader: TZipHeader);
begin
  Read(IndexOf(FileName), Stream, LocalHeader);
end;

procedure TZipFile.Read(Index: Integer; out Stream: TStream; out LocalHeader: TZipHeader);
var
  Signature: UInt32;
begin
  if not (FMode in [zmReadWrite, zmRead]) then
    raise EZipException.CreateRes(@SZipNoRead);

  if (Index < 0) or (Index > FFiles.Count) then
    raise EZipException.CreateRes(@SFileNotFound);

  LocalHeader.MadeByVersion := 0;
  LocalHeader.FileComment        := '';
  LocalHeader.FileCommentLength  := 0;
  LocalHeader.DiskNumberStart    := 0;
  LocalHeader.InternalAttributes := 0;
  LocalHeader.ExternalAttributes := 0;
  LocalHeader.LocalHeaderOffset  := 0;

  FStream.Position := FFiles[Index].LocalHeaderOffset + FStartFileData;
  FStream.Read(Signature, Sizeof(Signature));
  if Signature <> SIGNATURE_LOCALHEADER then
    raise EZipException.CreateRes(@SZipInvalidLocalHeader);
  FStream.Read(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
  SetLength(LocalHeader.FileName, LocalHeader.FileNameLength);
  SetLength(LocalHeader.ExtraField, LocalHeader.ExtraFieldLength);
  if (LocalHeader.Flag and (1 SHL 11)) <> 0 then
    SetCodepage(LocalHeader.FileName, 65001, False)
  else
    SetCodepage(LocalHeader.FileName, 437, False);
  FStream.Read(LocalHeader.FileName[1], LocalHeader.FileNameLength);
  if LocalHeader.ExtraFieldLength > 0 then
    FStream.Read(LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
  Stream := FCompressionHandler[TZipCompression(FFiles[Index].CompressionMethod)].Value(FStream, Self, LocalHeader);
end;

procedure TZipFile.Add(Data: TStream; LocalHeader: TZipHeader; CentralHeader: PZipHeader);
var
  DataStart: Int64;
  LCompressStream: TStream;
  Signature: UInt32;
  LStartPos: Int64;
  LBuffer: array[0..$4000] of Byte;
begin
  FStream.Position := FEndFileData;
  LocalHeader.LocalHeaderOffset := FEndFileData;
  if LocalHeader.MadeByVersion < 20 then
    LocalHeader.MadeByVersion := 20;
  if LocalHeader.RequiredVersion < 20 then
    LocalHeader.RequiredVersion := 20;

  LocalHeader.FileNameLength   := Length(LocalHeader.FileName);
  LocalHeader.ExtraFieldLength := Length(LocalHeader.ExtraField);

  if CentralHeader = nil then
    CentralHeader := @LocalHeader
  else
  begin
    CentralHeader^.FileNameLength   := Length(CentralHeader^.FileName);
    CentralHeader^.ExtraFieldLength := Length(CentralHeader^.ExtraField);
  end;
  CentralHeader^.FileCommentLength  := Length(CentralHeader^.FileComment);

  Signature := SIGNATURE_LOCALHEADER;
  VerifyWrite(FStream, Signature, SizeOf(Signature));
  VerifyWrite(FStream, LocalHeader.RequiredVersion, LOCALHEADERSIZE);
  VerifyWrite(FStream, LocalHeader.FileName[1], LocalHeader.FileNameLength);
  if LocalHeader.ExtraFieldLength > 0 then
    VerifyWrite(FStream, LocalHeader.ExtraField[0], LocalHeader.ExtraFieldLength);
  LStartPos := FStream.Position;
  DataStart := Data.Position;
  LocalHeader.UncompressedSize := Data.Size - DataStart;
  LCompressStream := FCompressionHandler[TZipCompression(LocalHeader.CompressionMethod)].Key(FStream, self, LocalHeader);
  try
    LCompressStream.CopyFrom(Data, LocalHeader.UncompressedSize);
  finally
    LCompressStream.Free;
  end;

  LocalHeader.CompressedSize := FStream.Position - LStartPos;
  Data.Position := DataStart;
  while Data.Position < LocalHeader.UncompressedSize do
    LocalHeader.CRC32 := crc32(LocalHeader.CRC32, @LBuffer[0],
      Data.Read(LBuffer, SizeOf(LBuffer)));
  CentralHeader.UnCompressedSize := LocalHeader.UnCompressedSize;
  CentralHeader.CompressedSize := LocalHeader.CompressedSize;
  CentralHeader.CRC32 := LocalHeader.CRC32;
  FEndFileData := FStream.Position;
  FStream.Position := LocalHeader.LocalHeaderOffset + SizeOf(UInt32);
  FStream.Write(LocalHeader.RequiredVersion, LOCALHEADERSIZE);
  FFiles.Add(CentralHeader^);
end;

procedure TZipFile.Add(FileName: string; ArchiveFileName: string;
  Compression: TZipCompression);
var
  LInStream: TStream;
  LHeader: TZipHeader;
begin
  if not (FMode in [zmReadWrite, zmWrite]) then
    raise EZipException.CreateRes(@SZipNoWrite);

  if not FCompressionHandler.ContainsKey(Compression) then
    raise EZipException.CreateResFmt(@SZipNotSupported, [
      TZipCompressionToString(Compression) ]);

  FillChar(LHeader, sizeof(LHeader), 0);
  LHeader.Flag := 0;
  LInStream := TFileStream.Create(FileName, fmOpenRead);
  try
    LHeader.Flag := 0;
    LHeader.CompressionMethod := UInt16(Compression);
    LHeader.ModifiedDateTime := DateTimeToFileDate( tfile.GetLastWriteTime(FileName) );
    LHeader.UncompressedSize := LInStream.Size;
    LHeader.InternalAttributes := 0;
    LHeader.ExternalAttributes := 0;
    if ArchiveFileName = '' then
      ArchiveFileName := ExtractFileName(FileName);
    if FUTF8Support then
    begin
      LHeader.Flag := LHeader.Flag or (1 SHL 11);
      LHeader.FileName := UTF8Encode(ArchiveFileName);
    end
    else
      LHeader.FileName := TOem437String(ArchiveFileName);
    LHeader.FileNameLength := Length(LHeader.FileName);

    LHeader.ExtraFieldLength := 0;
    Add(LInStream, LHeader);
  finally
    LInStream.Free;
  end;
end;

procedure TZipFile.Add(Data: TBytes; ArchiveFileName: string;
  Compression: TZipCompression);
var
  LInStream: TStream;
begin
  if not (FMode in [zmReadWrite, zmWrite]) then
    raise EZipException.CreateRes(@SZipNoWrite);

  if not FCompressionHandler.ContainsKey(Compression) then
    raise EZipException.CreateResFmt(@SZipNotSupported, [
      TZipCompressionToString(Compression) ]);

  LInStream := TBytesStream.Create(Data);
  try
    Add(LInStream, ArchiveFileName, Compression);
  finally
    LInStream.Free;
  end;
end;

procedure TZipFile.Add(Data: TStream; ArchiveFileName: string;
  Compression: TZipCompression);
var
  LHeader: TZipHeader;
begin
  if not (FMode in [zmReadWrite, zmWrite]) then
    raise EZipException.CreateRes(@SZipNoWrite);

  if not FCompressionHandler.ContainsKey(Compression) then
    raise EZipException.CreateResFmt(@SZipNotSupported, [
      TZipCompressionToString(Compression) ]);

  FillChar(LHeader, sizeof(LHeader), 0);
  LHeader.Flag := 0;
  LHeader.CompressionMethod := UInt16(Compression);
  LHeader.ModifiedDateTime := DateTimeToFileDate( Now );
  LHeader.InternalAttributes := 0;
  LHeader.ExternalAttributes := 0;
  if FUTF8Support then
  begin
    LHeader.Flag := LHeader.Flag or (1 SHL 11);
    LHeader.FileName := UTF8Encode(ArchiveFileName);
  end
  else
    LHeader.FileName := TOem437String(ArchiveFileName);
  LHeader.FileNameLength := Length(LHeader.FileName);

  LHeader.ExtraFieldLength := 0;
  Add(Data, LHeader);
end;

function TZipFile.IndexOf(FileName: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FFiles.Count - 1 do
    if string(FFiles[I].FileName) = FileName then
      Exit(I);
end;

end.

测试:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure OnProgress(Sender: TObject; ACount,AIndex: Integer; AFileName: string);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Zip2;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TZipFile.Create do
  begin
    OnUnZipProgress := OnProgress;
    Open('C:\Temp\Test.zip', zmRead);
    ExtractAll('C:\Temp\Test\');
    Free;
  end;
end;

procedure TForm1.OnProgress(Sender: TObject; ACount, AIndex: Integer; AFileName: string);
begin
  Caption := Format('%d/%d: %s', [AIndex, ACount, AFileName]);
  Application.ProcessMessages;
end;

end.

本文链接

把一个"结构体"当做属性后碰到的问题

2012-01-05T08:56:00Z

当我把一个"结构体"在类中当做属性后, 在实用中可以直接读取结构体成员, 但不能直接写入...

下面是由此引发的小练习:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  end;

  TMyClass = class
  strict private
    FPos: TPoint;
    procedure SetPos(const Value: TPoint);
  public
    property Pos: TPoint read FPos write SetPos; //属性 Pos 对应一个点结构
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMyClass }

procedure TMyClass.SetPos(const Value: TPoint);
begin
  FPos := Value;
end;


{测试}

procedure TForm1.Button1Click(Sender: TObject);
var
  obj: TMyClass;
begin
  obj := TMyClass.Create;
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]); //可以直接访问结构中的元素
//  obj.Pos.X := 11;  //但不能直接给结构中的元素赋值
//  obj.Pos.Y := 22;
  obj.Free;
end;

//变通一
procedure TForm1.Button2Click(Sender: TObject);
var
  obj: TMyClass;
begin
  obj := TMyClass.Create;
  obj.Pos := Point(22,33); //
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]);
  obj.Free;
end;

//变通二
procedure TForm1.Button3Click(Sender: TObject);
var
  obj: TMyClass;
  pt: TPoint;
begin
  obj := TMyClass.Create;
  pt.X := 33;
  pt.Y := 44;
  obj.Pos := pt;
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]);
  obj.Free;
end;

//变通三(假如属性的 get 不是方法)
procedure TForm1.Button4Click(Sender: TObject);
var
  obj: TMyClass;
  p: PPoint;
begin
  obj := TMyClass.Create;
  p := Addr(obj.Pos);
  p.X := 44;
  p.Y := 55;
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]);
  obj.Free;
end;

//变通四(假如属性的 get 不是方法)
procedure TForm1.Button5Click(Sender: TObject);
var
  obj: TMyClass;
begin
  obj := TMyClass.Create;
  PPoint(Addr(obj.Pos)).X := 55;
  PPoint(Addr(obj.Pos)).Y := 66;
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]);
  obj.Free;
end;

end.

练习二:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

  TMyClass = class
  private
    FPos: TPoint;
    function GetPos: TPoint;
    procedure SetPos(const Value: TPoint);
    function GetXY(const Index: Integer): Integer;
    procedure SetXY(const Index, Value: Integer);
  public
    property Pos: TPoint read GetPos write SetPos;
    property X: Integer index 0 read GetXY write SetXY;
    property Y: Integer index 1 read GetXY write SetXY;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMyClass }

function TMyClass.GetPos: TPoint;
begin
  Result := FPos;
end;

procedure TMyClass.SetPos(const Value: TPoint);
begin
  FPos := Value;
end;

function TMyClass.GetXY(const Index: Integer): Integer;
begin
  Result := 0;
  case Index of
    0: Result := FPos.X;
    1: Result := FPos.Y;
  end;
end;

procedure TMyClass.SetXY(const Index, Value: Integer);
begin
  case Index of
    0: FPos.X := Value;
    1: FPos.Y := Value;
  end;
end;

{测试}
procedure TForm1.FormCreate(Sender: TObject);
var
  obj: TMyClass;
begin
  obj := TMyClass.Create;
  obj.X := 11;
  obj.Y := 22;
  ShowMessageFmt('%d, %d', [obj.Pos.X, obj.Pos.Y]);
  obj.Free;
end;

end.

本文链接

覆盖、再覆盖

2012-01-03T14:09:00Z

在实践中真的会发现更多问题.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

  IA = Interface
    function GetName: string;
    property Name: string read GetName;
  end;

  TC1 = class(TInterfacedObject, IA)
    function GetName: string; virtual;
  end;

  TC2 = class(TC1)
    function GetName: string; override; //覆盖
  end;

  TC3 = class(TC2)
    function GetName: string; override; //再覆盖
  end;

  TC4 = class(TC3)
    function GetName: string; override; //再覆盖
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TC1 }

function TC1.GetName: string;
begin
  Result := 'C1';
end;

{ TC2 }

function TC2.GetName: string;
begin
  Result := 'C2';
end;

{ TC3 }

function TC3.GetName: string;
begin
  Result := 'C3';
end;

{ TC4 }

function TC4.GetName: string;
begin
  Result := inherited + '0';
end;


{测试}
procedure TForm1.FormCreate(Sender: TObject);
var
  v1,v2,v3,v4: IA;
begin
  v1 := TC1.Create;
  v2 := TC2.Create;
  v3 := TC3.Create;
  v4 := TC4.Create;
  ShowMessageFmt('%s, %s, %s, %s', [v1.Name, v2.Name, v3.Name, v4.Name]); //C1, C2, C3, C30
end;

end.

本文链接

以接口为主导的设计中, 我在使用的框架模式

2012-01-03T10:01:00Z

在今后的 Delphi 中, 以接口、结构为主的设计应该会越来越多, 因为这样太方便了.

System.RegularExpressions 就是以结构为主体设计的非常好的示范; 但更多东西使用接口会更合适.

有见过他人早就使用接口写程序, 从手头的这个程序开始我才开始使用.

现在基本总结出四种框架模式: 1、直接实现; 2、间接实现(或叫继承实现); 3、覆盖实现; 4、委托实现.

一、直接实现:

下例中虽有 TMy1、TMy2, 但在具体应用中使用的应是 IMy1、IMy2, 这就是我所谓的以接口为主导.
TMy1、TMy2 直接实现了所属接口的所有方法, 这是我所谓的直接实现.
这样可能会有代码重复, 但如果程序很小, 还是挺实用的.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

  IA = Interface
    procedure Method_A;
  end;

  IB = Interface(IA)
    procedure Method_B;
  end;

  IMy1 = Interface(IB)
    procedure Method_My1;
  end;

  IMy2 = Interface(IB)
    procedure Method_My2;
  end;

  TMy1 = class(TInterfacedObject, IMy1)
    procedure Method_A;
    procedure Method_B;
    procedure Method_My1;
  end;

  TMy2 = class(TInterfacedObject, IMy2)
    procedure Method_A;
    procedure Method_B;
    procedure Method_My2;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMy1 }

procedure TMy1.Method_A;
begin
  ShowMessage('A');
end;

procedure TMy1.Method_B;
begin
  ShowMessage('B');
end;

procedure TMy1.Method_My1;
begin
  ShowMessage('My1');
end;

{ TMy2 }

procedure TMy2.Method_A;
begin
  ShowMessage('A');
end;

procedure TMy2.Method_B;
begin
  ShowMessage('B');
end;

procedure TMy2.Method_My2;
begin
  ShowMessage('My2');
end;

{测试}
procedure TForm1.FormCreate(Sender: TObject);
var
  v1: IMy1;
  v2: IMy2;
begin
  v1 := TMy1.Create;
  v1.Method_A;
  v1.Method_B;
  v1.Method_My1;

  v2 := TMy2.Create;
  v2.Method_A;
  v2.Method_B;
  v2.Method_My2;
end;

end.

二、间接实现:

下面例子通过一个间接的 TB 类, 避免了 TMy1、TMy2 中可能会重复的代码.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

  IA = Interface
    procedure Method_A;
  end;

  IB = Interface(IA)
    procedure Method_B;
  end;

  TB = class(TInterfacedObject, IB)
    procedure Method_A;
    procedure Method_B;
  end;

  IMy1 = Interface(IB)
    procedure Method_My1;
  end;

  IMy2 = Interface(IB)
    procedure Method_My2;
  end;

  TMy1 = class(TB, IMy1)
    procedure Method_My1;
  end;

  TMy2 = class(TB, IMy2)
    procedure Method_My2;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TB }

procedure TB.Method_A;
begin
  ShowMessage('A');
end;

procedure TB.Method_B;
begin
  ShowMessage('B');
end;

{ TMy1 }

procedure TMy1.Method_My1;
begin
  ShowMessage('My1');
end;

{ TMy2 }

procedure TMy2.Method_My2;
begin
  ShowMessage('My2');
end;

{测试}
procedure TForm1.FormCreate(Sender: TObject);
var
  v1: IMy1;
  v2: IMy2;
begin
  v1 := TMy1.Create;
  v1.Method_A;
  v1.Method_B;
  v1.Method_My1;

  v2 := TMy2.Create;
  v2.Method_A;
  v2.Method_B;
  v2.Method_My2;
end;

end.

三、覆盖实现:

从 TB 继承的过程中当然也可以通过覆盖虚函数而实现多态, 下面的 TMy2 就这么做了.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

  IA = Interface
    procedure Method_A;
  end;

  IB = Interface(IA)
    procedure Method_B;
  end;

  TB = class(TInterfacedObject, IB)
    procedure Method_A; virtual;
    procedure Method_B; virtual;
  end;

  IMy1 = Interface(IB)
    procedure Method_My1;
  end;

  IMy2 = Interface(IB)
    procedure Method_My2;
  end;

  TMy1 = class(TB, IMy1)
    procedure Method_My1;
  end;

  TMy2 = class(TB, IMy2)
    procedure Method_A; override;
    procedure Method_B; override;
    procedure Method_My2;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TB }

procedure TB.Method_A;
begin
  ShowMessage('A');
end;

procedure TB.Method_B;
begin
  ShowMessage('B');
end;

{ TMy1 }

procedure TMy1.Method_My1;
begin
  ShowMessage('My1');
end;

{ TMy2 }

procedure TMy2.Method_A;
begin
  ShowMessage('A_My2');
end;

procedure TMy2.Method_B;
begin
  ShowMessage('B_My2');
end;

procedure TMy2.Method_My2;
begin
  ShowMessage('My2');
end;

{测试}
procedure TForm1.FormCreate(Sender: TObject);
var
  v1: IMy1;
  v2: IMy2;
begin
  v1 := TMy1.Create;
  v1.Method_A;
  v1.Method_B;
  v1.Method_My1;

  v2 := TMy2.Create;
  v2.Method_A;
  v2.Method_B;
  v2.Method_My2;
end;

end.

四、委托实现:

接口中的方法是肯定要实现的, 但也可以通过 implements 关键字借用(或叫委托)其它的实现;
但, 官方文档说这只适用于 Win32. 就是说这种方法在 Win64 和其它系统都不行, 还学它干嘛?

本文链接

混合排序小练习

2011-12-31T05:30:00Z

2011 年的最后一天了...

混合排序 -> 搅乱、重新洗牌; 以 Integer 动态数组为例.

//两个辅助函数 Swap、ToStr, 分别用于交换数组元素和呈现为字符串
procedure Swap(var Arr: TArray<Integer>; a,b: Cardinal);
var
  tmp: Integer;
begin
  if (a >= Length(Arr)) or (b >= Length(Arr)) or (a = b) then Exit;
  tmp := Arr[a];
  Arr[a] := Arr[b];
  Arr[b] := tmp;
end;

function ToStr(const Arr: TArray<Integer>): string;
var
  n: Integer;
begin
  for n in Arr do
    Result := Result + IntToStr(n) + sLineBreak;
end;
//-----------------------------------------------------------------

{1、简单反排序}
procedure SimpleShuffle(var Arr: TArray<Integer>);
var
  r,i: Integer; //分别用作随机索引、遍历索引
begin
  for i := 0 to Length(Arr) - 1 do
  begin
    r := Random(Length(Arr));
    Swap(Arr, i, r);
  end;
end;

{2、好的反排序}
procedure GoodShuffle(var Arr: TArray<Integer>);
var
  r,i: Integer;
begin
  for i := Length(Arr) - 1 downto 0 do
  begin
    r := Random(i + 1);
    if r <> i then Swap(Arr, i, r);
  end;
end;

{测试}
procedure TForm1.Button1Click(Sender: TObject);
var
  arr1,arr2: TArray<Integer>;
begin
  arr1 := TArray<Integer>.Create(0, 1, 2, 3, 4, 5, 6, 7, 8, 9); //
  arr2 := Copy(arr1);                                           //

//  SimpleShuffle(arr2);
  GoodShuffle(arr2);

  Memo1.Text := ToStr(arr1);
  Memo2.Text := ToStr(arr2);
end;

本文链接