Subversion Repositories autosfx

unit ZMCore19;

 

 

 

 

 

 

 

 

 

 

  Classes, SysUtils, Controls, Forms, Dialogs,

  ZipMstr19, ZMXcpt19, ZMDelZip19, ZMStructs19, ZMCompat19;

 

  zprFile = 0;

  zprArchive = 1;

  zprCopyTemp = 2;

  zprSFX = 3;

  zprHeader = 4;

  zprFinish = 5;

  zprCompressed = 6;

  zprCentral = 7;

  zprChecking = 8;

  zprLoading = 9;

  zprJoining = 10;

  zprSplitting = 11;

  zprWriting = 12;

 

  EXT_EXE = '.EXE';

  EXT_EXEL = '.exe';

  EXT_ZIP = '.ZIP';

  EXT_ZIPL = '.zip';

  PRE_INTER = 'ZI$';

  PRE_SFX = 'ZX$';

 

  TZLoadOpts = (zloNoLoad, zloFull, zloSilent);

 

  TZMVerbosity = (zvOff, zvVerbose, zvTrace);

  TZMEncodingDir = (zedFromInt, zedToInt);

  TZipShowProgress = (zspNone, zspFull, zspExtra);

 

  TZipAllwaysItems = (zaaYesOvrwrt);

  TZipAnswerAlls = set of TZipAllwaysItems;

 

  TZipNameType = (zntExternal, zntInternal);

 

  TProgDetails = class(TZMProgressDetails)

  private

    fDelta: Int64;

    fInBatch: Boolean;

    fItemCount: Int64;

    fItemName: TZMString;

    fItemNumber: Integer;

    fItemPosition: Int64;

    fItemSize: Int64;

    fProgType: TZMProgressType;

    fTotalPosition: Int64;

    fTotalSize: Int64;

    fWritten: Int64;

  protected

    function GetBytesWritten: Int64; override;

    function GetDelta: Int64; override;

    function GetItemName: TZMString; override;

    function GetItemNumber: Integer; override;

    function GetItemPosition: Int64; override;

    function GetItemSize: Int64; override;

    function GetOrder: TZMProgressType; override;

    function GetTotalCount: Int64; override;

    function GetTotalPosition: Int64; override;

    function GetTotalSize: Int64; override;

  public

    procedure Advance(adv: Int64);

    procedure AdvanceXtra(adv: Cardinal);

    procedure Clear;

    procedure SetCount(Count: Int64);

    procedure SetEnd;

    procedure SetItem(const FName: TZMString; FSize: Int64);

    procedure SetItemXtra(const xmsg: TZMString; FSize: Int64);

    procedure SetSize(FullSize: Int64);

    procedure Written(bytes: Int64);

    property BytesWritten: Int64 read GetBytesWritten write fWritten;

    property InBatch: Boolean Read fInBatch;

    property ItemName: TZMString read GetItemName write fItemName;

    property ItemNumber: Integer read GetItemNumber write fItemNumber;

    property ItemPosition: Int64 read GetItemPosition write fItemPosition;

    property ItemSize: Int64 read GetItemSize write fItemSize;

    property Order: TZMProgressType read GetOrder write fProgType;

    property TotalCount: Int64 read GetTotalCount write fItemCount;

    property TotalPosition: Int64 read GetTotalPosition write fTotalPosition;

    property TotalSize: Int64 read GetTotalSize write fTotalSize;

  end;

 

  TZCentralValues = (zcvDirty, zcvEmpty, zcvError, zcvBadStruct, zcvBusy);

  TZCentralStatus = set of TZCentralValues;

 

  TZMPipeImp = class(TZMPipe)

  private

    FAttributes: Cardinal;

    FDOSDate: Cardinal;

    FFileName: string;

    FOwnsStream: boolean;

    FSize: Integer;

    FStream: TStream;

  protected

    function GetAttributes: Cardinal; override;

    function GetDOSDate: Cardinal; override;

    function GetFileName: string; override;

    function GetOwnsStream: boolean; override;

    function GetSize: Integer; override;

    function GetStream: TStream; override;

    procedure SetAttributes(const Value: Cardinal); override;

    procedure SetDOSDate(const Value: Cardinal); override;

    procedure SetFileName(const Value: string); override;

    procedure SetOwnsStream(const Value: boolean); override;

    procedure SetSize(const Value: Integer); override;

    procedure SetStream(const Value: TStream); override;

  public

    procedure AfterConstruction; override;

    procedure AssignTo(Dest: TZMPipeImp);

    procedure BeforeDestruction; override;

  end;

 

  TZMPipeListImp = class(TZMPipeList)

  private

    List: TList;

  protected

    function GetCount: Integer; override;

    function GetPipe(Index: Integer): TZMPipe; override;

    procedure SetCount(const Value: Integer); override;

    procedure SetPipe(Index: Integer; const Value: TZMPipe); override;

  public

    function Add(aStream: TStream; const FileName: string; Own: boolean): integer; override;

    procedure AfterConstruction; override;

    procedure AssignTo(Dest: TZMPipeListImp);

    procedure BeforeDestruction; override;

    procedure Clear; override;

    function HasStream(Index: Integer): boolean;

    function KillStream(Index: Integer): boolean;

  end;

 

  MAX_PIPE = 9;

 

 

  TZMCore = class

  private

    fAnswerAll: TZipAnswerAlls;

    fCancel: Integer;

    fCheckNo: Integer;

    fConfirmErase: Boolean;

    FEncodeAs: TZMEncodingOpts;

    FEncoding_CP: Cardinal;

    fFErrCode: Integer;

    fFileCleanup: TStringList;

    fFSpecArgs: TStrings;

    fFSpecArgsExcl: TStrings;

    fHandle: Cardinal;

    fHowToDelete: TZMDeleteOpts;

    FIgnoreDirOnly: Boolean;

    fKeepFreeOnAllDisks: Cardinal;

    fKeepFreeOnDisk1: Cardinal;

    fMaster: TCustomZipMaster19;

    FMaxVolumeSize: Int64;

    fMinFreeVolumeSize: Integer;

    FNoSkipping: TZMSkipAborts;

    fShowProgress: TZipShowProgress;

    fSniffer: Cardinal;

    fSniffNo: Integer;

    fSpanOptions: TZMSpanOpts;

    fUnattended: Boolean;

    fUseUTF8: Boolean;

    fWinXP: Boolean;

    FWriteOptions: TZMWriteOpts;

    function GetErrMessage: TZMString;

    function GetTotalWritten: Int64;

    procedure SetCancel(Value: Integer);

    procedure SetErrCode(Value: Integer);

    procedure SetProgDetail(const Value: TProgDetails);

    procedure SetTotalWritten(const Value: Int64);

  protected

    FAddOptions: TZMAddOpts;

    fBusy: Boolean;

    fEncoding: TZMEncodingOpts;

    FErrMessage: TZMString;

    fEventErr: String;

    FDllErrCode: Integer;

    fIsDestructing: Boolean;

    fNotMainTask: Boolean;

    fProgDetails: TProgDetails;

    FTempDir: String;

    fVerbosity: TZMVerbosity;

    procedure EncodingChanged(New_Enc: TZMEncodingOpts); virtual; abstract;

    procedure Encoding_CPChanged(New_CP: Cardinal); virtual; abstract;

    // 1 Locate sniffer and get overrides

    function FindSniffer: Cardinal;

    function GetTotalSizeToProcess: Int64;

    procedure ReportToSniffer(err: Integer; const msg: TZMString);

    procedure SetEncoding(const Value: TZMEncodingOpts);

    procedure SetEncoding_CP(const Value: Cardinal); //virtual;

    procedure StartUp; virtual;

    property Sniffer: Cardinal Read fSniffer Write fSniffer;

    property SniffNo: Integer Read fSniffNo Write fSniffNo;

  public

    constructor Create(AMaster: TCustomZipMaster19);

    procedure AddCleanupFile(const fn: String; always: Boolean = False);

    procedure AfterConstruction; override;

    procedure BeforeDestruction; override;

    procedure CheckCancel;

    procedure CleanupFiles(IsError: Boolean);

    procedure Clear; virtual;

    procedure ClearErr;

    procedure Diag(const msg: String);

    procedure Done(Good: boolean = true); virtual;

    function FNMatch(const pattern, spec: TZMString): Boolean;

    function KeepAlive: Boolean;

    procedure Kill; virtual;

    function MakeTempFileName(Prefix, Extension: String): String;

    function NextCheckNo: Integer;

    procedure OnDirUpdate;

    procedure OnNewName(idx: Integer);

    function RemoveFileCleanup(const fn: String): Boolean;

    procedure ReportMessage(err: Integer; const msg: TZMString);

    procedure ReportMessage1(err: Integer; const msg: TZMString);

    procedure ReportMsg(id: Integer; const Args: array of const );

    procedure ReportProgress(ActionCode: TActionCodes; ErrorCode: Integer; msg:

        TZMString; File_Size: Int64);

    function ReportSkipping(const FName: String; err: Integer;

      typ: TZMSkipTypes): Boolean;

    procedure ShowExceptionError(const ZMExcept: Exception);

    procedure ShowMsg(const msg: TZMString; err: Integer; display: Boolean);

    procedure ShowZipFmtMsg(id: Integer; const Args: array of const ;

      display: Boolean);

    procedure ShowZipMessage(Ident: Integer; const UserStr: String);

    procedure ShowZipMsg(Ident: Integer; display: Boolean);

    function ZipFmtLoadStr(id: Integer; const Args: array of const ): TZMString;

    function ZipLoadStr(id: Integer): TZMString;

    function ZipMessageDialog(const title: String; var msg: String;

      context: Integer; btns: TMsgDlgButtons): TModalResult;

    procedure ZipMessageDlg(const msg: String; context: Integer);

    function ZipMessageDlgEx(const title, msg: String; context: Integer;

      btns: TMsgDlgButtons): TModalResult;

    property AddOptions: TZMAddOpts read FAddOptions write FAddOptions;

    property AnswerAll: TZipAnswerAlls Read fAnswerAll Write fAnswerAll;

    property Busy: Boolean Read fBusy Write fBusy;

    property Cancel: Integer Read fCancel Write SetCancel;

    property ConfirmErase

      : Boolean Read fConfirmErase Write fConfirmErase default True;

    property EncodeAs: TZMEncodingOpts read FEncodeAs write FEncodeAs;

    property Encoding: TZMEncodingOpts Read fEncoding Write SetEncoding;

    property ErrCode: Integer Read fFErrCode Write SetErrCode;

    property ErrMessage: TZMString read GetErrMessage write FErrMessage;

    property FSpecArgs: TStrings Read fFSpecArgs Write fFSpecArgs;

    property FSpecArgsExcl: TStrings Read fFSpecArgsExcl Write fFSpecArgsExcl;

    property DllErrCode: Integer read FDllErrCode write FDllErrCode;

    property Encoding_CP: Cardinal read FEncoding_CP write SetEncoding_CP;

    property Handle: Cardinal Read fHandle;

    property HowToDelete: TZMDeleteOpts Read fHowToDelete Write fHowToDelete;

    property IgnoreDirOnly: Boolean read FIgnoreDirOnly;

    property KeepFreeOnAllDisks

      : Cardinal Read fKeepFreeOnAllDisks Write fKeepFreeOnAllDisks;

    property KeepFreeOnDisk1

      : Cardinal Read fKeepFreeOnDisk1 Write fKeepFreeOnDisk1;

    property Master: TCustomZipMaster19 Read fMaster;

    property MaxVolumeSize: Int64 read FMaxVolumeSize write FMaxVolumeSize;

    property MinFreeVolumeSize

      : Integer Read fMinFreeVolumeSize Write fMinFreeVolumeSize;

    property NoSkipping: TZMSkipAborts read FNoSkipping;

    property NotMainTask: Boolean Read fNotMainTask Write fNotMainTask;

    property ProgDetail: TProgDetails Read fProgDetails Write SetProgDetail;

    property ShowProgress

      : TZipShowProgress Read fShowProgress Write fShowProgress;

    property SpanOptions: TZMSpanOpts Read fSpanOptions Write fSpanOptions;

    property TempDir: String read FTempDir write FTempDir;

    property TotalWritten: Int64 read GetTotalWritten write SetTotalWritten;

    property Unattended: Boolean Read fUnattended Write fUnattended;

    property UseUTF8: Boolean read fUseUTF8 write fUseUTF8;

    property Verbosity: TZMVerbosity Read fVerbosity Write fVerbosity;

    property WinXP: Boolean Read fWinXP;

    property WriteOptions: TZMWriteOpts read FWriteOptions write FWriteOptions;

  end;

 

 

 

uses Windows, Messages, ZMUtils19, ZMDlg19, ZMMsg19, ZMCtx19, ZMMsgStr19,

  ZMUTF819, ZMMatch19;

 

  SZipMasterSniffer = 'ZipMaster Sniffer';

  STZipSniffer = 'TZipSniffer';

  WM_SNIFF_START = WM_APP + $3F42;

  WM_SNIFF_STOP = WM_APP + $3F44;

  SNIFF_MASK = $FFFFFF;

  RESOURCE_ERROR: String =

    'ZMRes19_???.res is probably not linked to the executable' + #10 +

    'Missing String ID is: %d ';

 

  { TProgDetails }

procedure TProgDetails.Advance(adv: Int64);

  fDelta := adv;

  fTotalPosition := fTotalPosition + adv;

  fItemPosition := fItemPosition + adv;

  fProgType := ProgressUpdate;

 

procedure TProgDetails.AdvanceXtra(adv: Cardinal);

  fDelta := adv;

  Inc(fItemPosition, adv);

  fProgType := ExtraUpdate;

 

procedure TProgDetails.Clear;

  fProgType := EndOfBatch;

  fDelta := 0;

  fItemCount := 0;

  fWritten := 0;

  fTotalSize := 0;

  fTotalPosition := 0;

  fItemSize := 0;

  fItemPosition := 0;

  fItemName := '';

  fItemNumber := 0;

 

function TProgDetails.GetBytesWritten: Int64;

  Result := fWritten;

 

function TProgDetails.GetDelta: Int64;

  Result := fDelta;

 

function TProgDetails.GetItemName: TZMString;

  Result := fItemName;

 

function TProgDetails.GetItemNumber: Integer;

  Result := fItemNumber;

 

function TProgDetails.GetItemPosition: Int64;

  Result := fItemPosition;

 

function TProgDetails.GetItemSize: Int64;

  Result := fItemSize;

 

function TProgDetails.GetOrder: TZMProgressType;

  Result := fProgType;

 

function TProgDetails.GetTotalCount: Int64;

  Result := fItemCount;

 

function TProgDetails.GetTotalPosition: Int64;

  Result := fTotalPosition;

 

function TProgDetails.GetTotalSize: Int64;

  Result := fTotalSize;

 

procedure TProgDetails.SetCount(Count: Int64);

  Clear;

  fItemCount := Count;

  fItemNumber := 0;

  fProgType := TotalFiles2Process;

 

procedure TProgDetails.SetEnd;

  fItemName := '';

  fItemSize := 0;

  fInBatch := False;

  fProgType := EndOfBatch;

 

procedure TProgDetails.SetItem(const FName: TZMString; FSize: Int64);

  Inc(fItemNumber);

  fItemName := FName;

  fItemSize := FSize;

  fItemPosition := 0;

  fProgType := NewFile;

 

procedure TProgDetails.SetItemXtra(const xmsg: TZMString; FSize: Int64);

  fItemName := xmsg;

  fItemSize := FSize;

  fItemPosition := 0;

  fProgType := NewExtra;

 

procedure TProgDetails.SetSize(FullSize: Int64);

  fTotalSize := FullSize;

  fTotalPosition := 0;

  fItemName := '';

  fItemSize := 0;

  fItemPosition := 0;

  fProgType := TotalSize2Process;

  fWritten := 0;

  fInBatch := True; // start of batch

 

procedure TProgDetails.Written(bytes: Int64);

  fWritten := bytes;

 

constructor TZMCore.Create(AMaster: TCustomZipMaster19);

  fMaster := AMaster;

 

procedure TZMCore.AddCleanupFile(const fn: String; always: Boolean = False);

  f: String;

  obj: TObject;

  f := ExpandFileName(fn); // need full path incase current dir changes

  obj := nil;

  if always then

    obj := TObject(self);

  fFileCleanup.AddObject(f, obj);

 

procedure TZMCore.AfterConstruction;

  inherited;

  fHandle := Application.Handle;

  fProgDetails := TProgDetails.Create;

  fFSpecArgs := TStringList.Create;

  fFSpecArgsExcl := TStringList.Create;

  fFileCleanup := TStringList.Create;

  fHowToDelete := htdAllowUndo;

  fSpanOptions := [];

  FErrMessage := '';

  fFErrCode := -1;

  fVerbosity := zvOff;

  fUnattended := True; // during construction

  fEncoding := zeoAuto;

  FEncodeAs := zeoAuto;

  fVerbosity := zvOff;

  fTempDir := '';

  fNotMainTask := False;

  fWinXP := IsWinXP; // set flag;

 

procedure TZMCore.BeforeDestruction;

  fCancel := DS_Canceled;

  fVerbosity := zvOff;

  FreeAndNil(fFileCleanup);

  FreeAndNil(fProgDetails);

  FreeAndNil(fFSpecArgsExcl);

  FreeAndNil(fFSpecArgs);

  inherited;

 

procedure TZMCore.CheckCancel;

  KeepAlive;

  if fCancel <> 0 then

    raise EZipMaster.CreateResDisp(Cancel, True);

 

procedure TZMCore.CleanupFiles(IsError: Boolean);

  AlwaysClean: Boolean;

  fn: String;

  i: Integer;

  if (fFileCleanup.Count > 0) then

  begin

    for i := fFileCleanup.Count - 1 downto 0 do

    begin

      fn := fFileCleanup[i];

      if Length(fn) < 2 then

        continue;

      AlwaysClean := fFileCleanup.Objects[i] <> nil;

      if IsError or AlwaysClean then

      begin

        if CharInSet(fn[Length(fn)], ['/', '\']) then

        begin

          fn := ExcludeTrailingBackslash(fn);

          if DirExists(fn) then

            RemoveDir(fn);

        end

        else

        begin

          if FileExists(fn) then

            SysUtils.DeleteFile(fn);

        end;

      end;

    end;

    fFileCleanup.Clear;

  end;

 

procedure TZMCore.Clear;

  Cancel := 0;

  ClearErr;

  fHowToDelete := htdAllowUndo;

  fUnattended := False;

  fEncoding := zeoAuto;

  FEncodeAs := zeoAuto;

  fVerbosity := zvOff;

  TProgDetails(fProgDetails).Clear;

  fFSpecArgs.Clear;

  fFSpecArgsExcl.Clear;

  fEventErr := '';

  fIsDestructing := False;

  fSpanOptions := [];

  FWriteOptions := [];

 

procedure TZMCore.ClearErr;

  FErrMessage := '';

  fFErrCode := 0;

  FDllErrCode := 0;

 

procedure TZMCore.Diag(const msg: String);

  if Verbosity >= zvVerbose then

    ShowMsg('Trace: ' + msg, 0, False); // quicker

 

procedure TZMCore.Done(Good: boolean = true);

  CleanupFiles(not Good);

  if Sniffer <> 0 then

  begin

    // send finished

    SendMessage(Sniffer, WM_SNIFF_STOP, 0, SniffNo);

    Sniffer := 0;

  end;

  fBusy := False;

 

function TZMCore.FindSniffer: Cardinal;

  flgs: Cardinal;

  res: Integer;

  Result := FindWindow(PChar(STZipSniffer), PChar(SZipMasterSniffer));

  if Result <> 0 then

  begin

    res := SendMessage(Result, WM_SNIFF_START, Longint(Handle), Ord(Verbosity));

    if res < 0 then

    begin

      Result := 0; // invalid

      exit;

    end;

    // in range so hopefully valid response

    flgs := Cardinal(res) shr 24;

    if flgs >= 8 then

    begin

      Result := 0; // invalid

      exit;

    end;

    // treat it as valid

    if flgs > 3 then

      Verbosity := TZMVerbosity(flgs and 3); // force it

    SniffNo := res and SNIFF_MASK; // operation number

  end;

 

function TZMCore.FNMatch(const pattern, spec: TZMString): Boolean;

  Result := FileNameMatch(pattern, spec);

  Result := FileNameMatch(pattern, spec, UseUTF8);

 

function TZMCore.GetErrMessage: TZMString;

  Result := '';

  if ErrCode <> 0 then

  begin

    Result := FErrMessage;

    if Result = '' then

      Result := ZipLoadStr(ErrCode);

    if Result = '' then

      Result := ZipFmtLoadStr(GE_Unknown, [ErrCode]);

  end;

 

function TZMCore.GetTotalSizeToProcess: Int64;

  Result := TProgDetails(fProgDetails).TotalSize;

 

function TZMCore.GetTotalWritten: Int64;

  Result := ProgDetail.BytesWritten;

 

function TZMCore.KeepAlive: Boolean;

  DoStop: Boolean;

  tmpCheckTerminate: TZMCheckTerminateEvent;

  tmpTick: TZMTickEvent;

  Result := Cancel <> 0;

  tmpTick := Master.OnTick;

  if assigned(tmpTick) then

    tmpTick(Master);

  tmpCheckTerminate := Master.OnCheckTerminate;

  if assigned(tmpCheckTerminate) then

  begin

    DoStop := Cancel <> 0;

    tmpCheckTerminate(Master, DoStop);

    if DoStop then

      Cancel := DS_Canceled;

  end

  else if not fNotMainTask then

    Application.ProcessMessages;

 

procedure TZMCore.Kill;

  fCancel := DS_Canceled;

 

function TZMCore.MakeTempFileName(Prefix, Extension: String): String;

  buf: String;

  len: DWORD;

  tmpDir: String;

  if Prefix = '' then

    Prefix := 'zip';

  if Extension = '' then

    Extension := EXT_ZIPL;

  if Length(fTempDir) = 0 then // Get the system temp dir

  begin

    // 1. The path specified by the TMP environment variable.

    // 2. The path specified by the TEMP environment variable, if TMP is not defined.

    // 3. The current directory, if both TMP and TEMP are not defined.

    len := GetTempPath(0, PChar(tmpDir));

    SetLength(tmpDir, len);

    GetTempPath(len, PChar(tmpDir));

  end

  else // Use Temp dir provided by ZipMaster

  begin

    tmpDir := DelimitPath(fTempDir, True);

  end;

  SetLength(buf, MAX_PATH + 12);

  if GetTempFileName(PChar(tmpDir), PChar(Prefix), 0, PChar(buf)) <> 0 then

  begin

    buf := PChar(buf);

    SysUtils.DeleteFile(buf); // Needed because GetTempFileName creates the file also.

    Result := ChangeFileExt(buf, Extension);

    // And finally change the extension.

  end;

 

function TZMCore.NextCheckNo: Integer;

  Inc(fCheckNo);

  Result := fCheckNo;

 

procedure TZMCore.OnDirUpdate;

  if assigned(Master.OnDirUpdate) then

    Master.OnDirUpdate(Master);

 

procedure TZMCore.OnNewName(idx: Integer);

  if assigned(Master.OnNewName) then

    Master.OnNewName(Master, idx);

 

function TZMCore.RemoveFileCleanup(const fn: String): Boolean;

  f: String;

  i: Integer;

  Result := False;

  f := ExpandFileName(fn);

  for i := fFileCleanup.Count - 1 downto 0 do

    if AnsiSameText(fFileCleanup[i], f) then

    begin

      fFileCleanup.Delete(i);

      Result := True;

      break;

    end;

 

procedure TZMCore.ReportMessage(err: Integer; const msg: TZMString);

  if Sniffer <> 0 then

    ReportToSniffer(err, msg);

  ReportMessage1(err, msg);

 

procedure TZMCore.ReportMessage1(err: Integer; const msg: TZMString);

  tmpMessage: TZMMessageEvent;

  if (err <> 0) and (ErrCode = 0) then // only catch first

  begin

    if DllErrCode = 0 then

      FDllErrCode := err;

    fFErrCode := err;

    FErrMessage := msg;

  end;

  tmpMessage := Master.OnMessage;

  if assigned(tmpMessage) then

    tmpMessage(Master, err, msg);

  KeepAlive; // process messages or check terminate

 

procedure TZMCore.ReportMsg(id: Integer; const Args: array of const );

  msg: TZMString;

  p: Integer;

  msg := ZipFmtLoadStr(id, Args);

  if msg <> '' then

  begin

    p := 0;

    case msg[1] of

      '#':

        p := TM_Trace;

      '!':

        p := TM_Verbose;

    end;

    if p <> 0 then

    begin

      msg := ZipLoadStr(p) + copy(msg, 2, Length(msg) - 1);

    end;

  end;

  ReportMessage(0, msg);

 

procedure TZMCore.ReportProgress(ActionCode: TActionCodes; ErrorCode: Integer;

    msg: TZMString; File_Size: Int64);

  Details: TProgDetails;

  SendDetails: Boolean;

  tmpProgress: TZMProgressEvent;

  if fIsDestructing then

    exit;

  if ActionCode <= zacXProgress then

  begin

    Details := fProgDetails as TProgDetails;

    SendDetails := True;

    case ActionCode of

      zacTick: { 'Tick' Just checking / processing messages }

        begin

          KeepAlive;

          SendDetails := False;

        end;

 

      zacItem: { progress type 1 = StartUp any ZIP operation on a new file }

        Details.SetItem(msg, File_Size);

 

      zacProgress: { progress type 2 = increment bar }

        Details.Advance(File_Size);

 

      zacEndOfBatch: { end of a batch of 1 or more files }

        begin

          if Details.InBatch then

            Details.SetEnd

          else

            SendDetails := False;

        end;

 

      zacCount: { total number of files to process }

        Details.SetCount(File_Size);

 

      zacSize: { total size of all files to be processed }

        Details.SetSize(File_Size);

 

      zacXItem: { progress type 15 = StartUp new extra operation }

        begin

          if ErrorCode < 20 then

            ErrorCode := PR_Progress + ErrorCode;

          msg := ZipLoadStr(ErrorCode);

          Details.SetItemXtra(msg, File_Size);

        end;

 

      zacXProgress: { progress type 16 = increment bar for extra operation }

        Details.AdvanceXtra(File_Size);

    end; { end case }

    if Verbosity >= zvVerbose then

      case ActionCode of

        zacItem:

          Diag(Format('#Item - "%s" %d', [Details.ItemName, Details.ItemSize]));

        zacProgress:

          Diag(Format('#Progress - [inc:%d] ipos:%d isiz:%d, tpos:%d tsiz:%d',

              [File_Size, Details.ItemPosition, Details.ItemSize,

              Details.TotalPosition, Details.TotalSize]));

        zacEndOfBatch:

          if SendDetails then

            Diag('#End Of Batch')

          else

            Diag('#End Of Batch with no batch');

        zacCount:

          Diag(Format('#Count - %d', [Details.TotalCount]));

        zacSize:

          Diag(Format('#Size - %d', [Details.TotalSize]));

        zacXItem:

          Diag(Format('#XItem - %s size = %d', [Details.ItemName, File_Size]));

        zacXProgress:

          Diag(Format('#XProgress - [inc:%d] pos:%d siz:%d',

              [File_Size, Details.ItemPosition, Details.ItemSize]));

      end;

    tmpProgress := Master.OnProgress;

    if SendDetails and (assigned(tmpProgress)) then

      tmpProgress(Master, Details);

  end;

 

  KeepAlive;

 

function TZMCore.ReportSkipping(const FName: String; err: Integer;

  typ: TZMSkipTypes): Boolean;

  ti: Integer;

  tmpMessage: ZipMstr19.TZMMessageEvent;

  tmpSkipped: TZMSkippedEvent;

  Result := False;

  if typ in NoSkipping then

  begin

    if err = 0 then

      err := GE_NoSkipping;

  end;

  ti := err;

  if ti < 0 then

    ti := -ti;

  if (ti <> 0) and (typ in NoSkipping) then

    ti := -ti; // default to abort

  tmpSkipped := Master.OnSkipped;

  if assigned(tmpSkipped) then

    tmpSkipped(Master, FName, typ, ti)

  else if Verbosity >= zvVerbose then

  begin

    tmpMessage := Master.OnMessage;

    if assigned(tmpMessage) then

      tmpMessage(Master, GE_Unknown, ZipFmtLoadStr

          (GE_Skipped, [FName, Ord(typ)]));

  end;

  if ti < 0 then

    Result := True; // Skipping not allowed

  if Sniffer <> 0 then

    ReportToSniffer(0, Format('[Skipped] IN=%d,%d OUT=%d', [err, Ord(typ), Ord

          (Result)]));

 

procedure TZMCore.ReportToSniffer(err: Integer; const msg: TZMString);

  aCopyData: TCopyDataStruct;

  msg8: UTF8String;

  if Sniffer = 0 then // should not happen

    exit;

  // always feed Sniffer with UTF8

  msg8 := StrToUTF8(msg);

  if UseUTF8 then

    msg8 := msg

  else

    msg8 := StrToUTF8(msg);

  aCopyData.dwData := Cardinal(err);

  aCopyData.cbData := (Length(msg8) + 1) * sizeof(AnsiChar);

  aCopyData.lpData := @msg8[1];

  if SendMessage(Sniffer, WM_COPYDATA, SniffNo, Longint(@aCopyData)) = 0 then

    Sniffer := 0; // could not process it -don't try again

 

procedure TZMCore.SetCancel(Value: Integer);

  fCancel := Value;

 

procedure TZMCore.SetEncoding(const Value: TZMEncodingOpts);

  if Encoding <> Value then

  begin

    FEncoding := Value;

    EncodingChanged(Value);

  end;

 

procedure TZMCore.SetEncoding_CP(const Value: Cardinal);

  if Encoding_CP <> Value then

  begin

    FEncoding_CP := Value;

    Encoding_CPChanged(Value);

  end;

 

procedure TZMCore.SetErrCode(Value: Integer);

  if Value < 0 then

    fFErrCode := -Value

  else

    fFErrCode := Value;

 

procedure TZMCore.SetProgDetail(const Value: TProgDetails);

  // do not change

 

procedure TZMCore.SetTotalWritten(const Value: Int64);

  ProgDetail.Written(Value);

 

procedure TZMCore.ShowExceptionError(const ZMExcept: Exception);

  display: Boolean;

  msg: String;

  ResID: Integer;

  if ZMExcept is EZMException then

  begin

    ResID := EZMException(ZMExcept).ResID;

    display := EZMException(ZMExcept).DisplayMsg;

    msg := EZMException(ZMExcept).Message;

    msg := EZMException(ZMExcept).TheMessage(UseUTF8);

  end

  else

  begin

    ResID := GE_ExceptErr;

    display := True;

    msg := ZMExcept.Message;

  end;

  ShowMsg(msg, ResID, display);

 

procedure TZMCore.ShowMsg(const msg: TZMString; err: Integer; display: Boolean);

  FErrMessage := msg;

  if err < 0 then

    fFErrCode := -err

  else

    fFErrCode := err;

  if display and (not fUnattended) and (ErrCode <> GE_Abort) and

    (ErrCode <> DS_Canceled) then

    ZipMessageDlg(msg, zmtInformation + DHC_ZipMessage);

 

  ReportMessage(ErrCode, msg);

 

procedure TZMCore.ShowZipFmtMsg(id: Integer; const Args: array of const ;

  display: Boolean);

  if id < 0 then

    id := -id;

  ShowMsg(ZipFmtLoadStr(id, Args), id, display);

 

procedure TZMCore.ShowZipMessage(Ident: Integer; const UserStr: String);

  msg: String;

  if Ident < 0 then

    Ident := -Ident;

  msg := ZipLoadStr(Ident);

  if msg = '' then

    msg := Format(RESOURCE_ERROR, [Ident]);

  msg := msg + UserStr;

  ShowMsg(msg, Ident, True);

 

procedure TZMCore.ShowZipMsg(Ident: Integer; display: Boolean);

  msg: String;

  if Ident < 0 then

    Ident := -Ident;

  msg := ZipLoadStr(Ident);

  if msg = '' then

    msg := Format(RESOURCE_ERROR, [Ident]);

  ShowMsg(msg, Ident, display);

 

procedure TZMCore.StartUp;

  s: String;

  fBusy := True;

  Cancel := 0;

  fAnswerAll := [];

  ClearErr;

  fUseUTF8 := Master.UseUTF8;

  fHandle := Master.Handle;

  FAddOptions := Master.AddOptions;

  fUnattended := Master.Unattended;

  fConfirmErase := Master.ConfirmErase;

  fKeepFreeOnAllDisks := Master.KeepFreeOnAllDisks;

  fKeepFreeOnDisk1 := Master.KeepFreeOnDisk1;

  if Master.MaxVolumeSizeKb = 0 then

    FMaxVolumeSize := Master.MaxVolumeSize

  else

    FMaxVolumeSize := Master.MaxVolumeSizeKb * 1024;

  fMinFreeVolumeSize := Master.MinFreeVolumeSize;

  FNoSkipping := Master.NoSkipping;

  fSpanOptions := Master.SpanOptions;

  FWriteOptions := Master.WriteOptions;

  if Master.Trace then

    fVerbosity := zvTrace

  else if Master.Verbose then

    fVerbosity := zvVerbose

  else

    fVerbosity := zvOff;

  {f}Encoding := Master.Encoding;

  Encoding_CP := Master.Encoding_CP;

  FEncodeAs := Master.EncodeAs;

  fHowToDelete := Master.HowToDelete;

  TempDir := Master.TempDir;

  fFSpecArgs.Assign(Master.FSpecArgs);

  fFSpecArgsExcl.Assign(Master.FSpecArgsExcl);

  FIgnoreDirOnly := not Master.UseDirOnlyEntries;

  fNotMainTask := Master.NotMainThread;

  if GetCurrentThreadID <> MainThreadID then

    fNotMainTask := True;

  Sniffer := FindSniffer;

  if Sniffer <> 0 then

  begin

    if Master.Owner <> nil then

    begin

      s := Master.Owner.Name;

      if s <> '' then

        s := s + '.';

    end;

    if Master.Name = '' then

      s := '<unknown>'

    else

      s := s + Master.Name;

    if fNotMainTask then

      s := '*' + s;

    ReportToSniffer(0, 'Starting ' + s);

  end;

  fFileCleanup.Clear;

 

function TZMCore.ZipFmtLoadStr(id: Integer; const Args: array of const )

  : TZMString;

  Result := ZipLoadStr(id);

 

  if Result <> '' then

    Result := Format(Result, Args);

 

function TZMCore.ZipLoadStr(id: Integer): TZMString;

  Result := LoadZipStr(id);

  if (Result <> '') and UseUTF8 then

    Result := StrToUTF8(Result);

 

function TZMCore.ZipMessageDialog(const title: String; var msg: String;

  context: Integer; btns: TMsgDlgButtons): TModalResult;

  ctx: Integer;

  dlg: TZipDialogBox;

  s: String;

  t: String;

  tmpZipDialog: TZMDialogEvent;

  t := title;

  if title = '' then

    t := Application.title;

  if Verbosity >= zvVerbose then

    t := Format('%s   (%d)', [t, context and MAX_WORD]);

  tmpZipDialog := Master.OnZipDialog;

  if assigned(tmpZipDialog) then

  begin

    s := msg;

    ctx := context;

    tmpZipDialog(Master, t, s, ctx, btns);

    if (ctx > 0) and (ctx <= Ord(mrYesToAll)) then

    begin

      msg := s;

      Result := TModalResult(ctx);

      exit;

    end;

  end;

  dlg := TZipDialogBox.CreateNew2(Application, context);

  try

    dlg.Build(t, msg, btns {$IFNDEF UNICODE}, UseUTF8 {$ENDIF});

    dlg.ShowModal();

    Result := dlg.ModalResult;

    if dlg.DlgType = zmtPassword then

    begin

      if (Result = mrOk) then

        msg := dlg.PWrd

      else

        msg := '';

    end;

  finally

    FreeAndNil(dlg);

  end;

 

procedure TZMCore.ZipMessageDlg(const msg: String; context: Integer);

  ZipMessageDlgEx('', msg, context, [mbOK]);

 

function TZMCore.ZipMessageDlgEx(const title, msg: String; context: Integer;

  btns: TMsgDlgButtons): TModalResult;

  m: String;

  m := msg;

  Result := ZipMessageDialog(title, m, context, btns);

 

procedure TZMPipeImp.AfterConstruction;

  inherited;

  FStream := nil;

  fSize := 0;

  fDOSDate := Cardinal(DateTimeToFileDate(now));

  fAttributes := 0;

 

procedure TZMPipeImp.AssignTo(Dest: TZMPipeImp);

  if Dest <> self then

  begin

    Dest.Stream := FStream;

    FStream := nil;

    Dest.Size := FSize;

    Dest.DOSDate := fDOSDate;

    Dest.Attributes := FAttributes;

    Dest.OwnsStream := FOwnsStream;

  end;

 

procedure TZMPipeImp.BeforeDestruction;

  if OwnsStream and (FStream <> nil) then

    FStream.Free;

  inherited;

 

function TZMPipeImp.GetAttributes: Cardinal;

  Result := FAttributes;

 

function TZMPipeImp.GetDOSDate: Cardinal;

  Result := FDOSDate;

 

function TZMPipeImp.GetFileName: string;

  Result := FFileName;

 

function TZMPipeImp.GetOwnsStream: boolean;

  Result := FOwnsStream;

 

function TZMPipeImp.GetSize: Integer;

  Result := FSize;

 

function TZMPipeImp.GetStream: TStream;

  Result := FStream;

 

procedure TZMPipeImp.SetAttributes(const Value: Cardinal);

  FAttributes := Value;

 

procedure TZMPipeImp.SetDOSDate(const Value: Cardinal);

  FDOSDate := Value;

 

procedure TZMPipeImp.SetFileName(const Value: string);

  if FFileName <> Value then

  begin

    FFileName := Value;

  end;

 

procedure TZMPipeImp.SetOwnsStream(const Value: boolean);

  FOwnsStream := Value;

 

procedure TZMPipeImp.SetSize(const Value: Integer);

  if Value <> FSize then

  begin

    if FStream = nil then

      FSize := 0

    else

    begin

      if Value > FStream.Size then

        FSize := Integer(FStream.Size)

      else

        FSize := Value;

    end;

  end;

 

procedure TZMPipeImp.SetStream(const Value: TStream);

  if FStream <> Value then

  begin

    if Value = nil then

      FStream.Free;

    FStream := Value;

    if Value <> nil then

    begin

      FSize := Integer(FStream.Size);

      FStream.Position := 0;

    end;

  end;

 

function TZMPipeListImp.Add(aStream: TStream; const FileName: string; Own:

    boolean): integer;

  tmpPipe: TZMPipe;

  Result := List.Count;

  tmpPipe := Pipe[Result];

  tmpPipe.Stream := aStream;

  tmpPipe.FileName := FileName;

  tmpPipe.OwnsStream := Own;

 

procedure TZMPipeListImp.AfterConstruction;

  inherited;

  List := TList.Create;

 

procedure TZMPipeListImp.AssignTo(Dest: TZMPipeListImp);

  I: Integer;

  if (Dest <> nil) and (Dest <> Self) then

  begin

    Dest.Clear;

    for I := 0 to Count - 1 do

      Dest.List.Add(List[i]);

    List.Clear;

  end;

 

procedure TZMPipeListImp.BeforeDestruction;

  Clear;

  List.Free;

  inherited;

 

procedure TZMPipeListImp.Clear;

  i: Integer;

  tmp: TZMPipeImp;

  if (List <> nil) and (List.Count > 0) then

  begin

    for I := 0 to List.Count - 1 do

    begin

     if TObject(List[i]) is TZMPipeImp then

      begin

        tmp := TZMPipeImp(List[i]);

        List[i] := nil;

        tmp.Free;

      end;

    end;

    List.Clear;

  end;

 

function TZMPipeListImp.GetCount: Integer;

  Result := List.Count;

 

function TZMPipeListImp.GetPipe(Index: Integer): TZMPipe;

  tmpPipe: TZMPipeImp;

  if (Index <0) or (Index > MAX_PIPE) then

    raise EZipMaster.CreateResFmt(GE_RangeError, [Index, MAX_PIPE]);

  if Index >= List.Count then

    List.Count := Index + 1;

   if not (TObject(List[Index]) is TZMPipeImp) then

   begin

     // need a new one

     tmpPipe := TZMPipeImp.Create;

     List[Index] := tmpPipe;

   end;

   Result := TZMPipeImp(List[Index]);

 

function TZMPipeListImp.HasStream(Index: Integer): boolean;

  Result := (Index >= 0) and (Index < count) and (Pipe[Index].Stream <> nil);

 

function TZMPipeListImp.KillStream(Index: Integer): boolean;

  tmp: TZMPipe;

  Result := False;

  if (Index >= 0) and (Index < count) then

  begin

    tmp := Pipe[Index];

    if tmp.OwnsStream and (tmp.Stream <> nil) then

      tmp.Stream := nil;

  end;

 

procedure TZMPipeListImp.SetCount(const Value: Integer);

  I: Integer;

  if (Value <0) or (Value > MAX_PIPE) then

    raise EZipMaster.CreateResInt(GE_RangeError, Value);

  if Value > List.Count then

  begin

    I := List.Count;

    while I < Value do

      List.Add(nil);

  end;