WebSVN – autosfx – Blame – /zmstr1900102/ZMCore19.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit ZMCore19;
		2
		3	(*
		4	ZMCore19.pas - event triggering
		5	TZipMaster19 VCL by Chris Vleghert and Eric W. Engler
		6	v1.9
		7	Copyright (C) 2009 Russell Peters
		8
		9
		10	This library is free software; you can redistribute it and/or
		11	modify it under the terms of the GNU Lesser General Public
		12	License as published by the Free Software Foundation; either
		13	version 2.1 of the License, or (at your option) any later version.
		14
		15	This library is distributed in the hope that it will be useful,
		16	but WITHOUT ANY WARRANTY; without even the implied warranty of
		17	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
		18	Lesser General Public License (licence.txt) for more details.
		19
		20	You should have received a copy of the GNU Lesser General Public
		21	License along with this library; if not, write to the Free Software
		22	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
		23
		24	contact: problems AT delphizip DOT org
		25	updates: http://www.delphizip.org
		26
		27	modified 2009-08-19
		28	--------------------------------------------------------------------------- *)
		29
		30	interface
		31
		32	// {$DEFINE DEBUG_PROGRESS}
		33
		34	uses
		35	Classes, SysUtils, Controls, Forms, Dialogs,
		36	ZipMstr19, ZMXcpt19, ZMDelZip19, ZMStructs19, ZMCompat19;
		37
		38	const
		39	zprFile = 0;
		40	zprArchive = 1;
		41	zprCopyTemp = 2;
		42	zprSFX = 3;
		43	zprHeader = 4;
		44	zprFinish = 5;
		45	zprCompressed = 6;
		46	zprCentral = 7;
		47	zprChecking = 8;
		48	zprLoading = 9;
		49	zprJoining = 10;
		50	zprSplitting = 11;
		51	zprWriting = 12;
		52
		53	const
		54	EXT_EXE = '.EXE';
		55	EXT_EXEL = '.exe';
		56	EXT_ZIP = '.ZIP';
		57	EXT_ZIPL = '.zip';
		58	PRE_INTER = 'ZI$';
		59	PRE_SFX = 'ZX$';
		60
		61	type
		62	TZLoadOpts = (zloNoLoad, zloFull, zloSilent);
		63
		64	type
		65	TZMVerbosity = (zvOff, zvVerbose, zvTrace);
		66	TZMEncodingDir = (zedFromInt, zedToInt);
		67	TZipShowProgress = (zspNone, zspFull, zspExtra);
		68
		69	TZipAllwaysItems = (zaaYesOvrwrt);
		70	TZipAnswerAlls = set of TZipAllwaysItems;
		71
		72	type
		73	TZipNameType = (zntExternal, zntInternal);
		74
		75	type
		76	TProgDetails = class(TZMProgressDetails)
		77	private
		78	fDelta: Int64;
		79	fInBatch: Boolean;
		80	fItemCount: Int64;
		81	fItemName: TZMString;
		82	fItemNumber: Integer;
		83	fItemPosition: Int64;
		84	fItemSize: Int64;
		85	fProgType: TZMProgressType;
		86	fTotalPosition: Int64;
		87	fTotalSize: Int64;
		88	fWritten: Int64;
		89	protected
		90	function GetBytesWritten: Int64; override;
		91	function GetDelta: Int64; override;
		92	function GetItemName: TZMString; override;
		93	function GetItemNumber: Integer; override;
		94	function GetItemPosition: Int64; override;
		95	function GetItemSize: Int64; override;
		96	function GetOrder: TZMProgressType; override;
		97	function GetTotalCount: Int64; override;
		98	function GetTotalPosition: Int64; override;
		99	function GetTotalSize: Int64; override;
		100	public
		101	procedure Advance(adv: Int64);
		102	procedure AdvanceXtra(adv: Cardinal);
		103	procedure Clear;
		104	procedure SetCount(Count: Int64);
		105	procedure SetEnd;
		106	procedure SetItem(const FName: TZMString; FSize: Int64);
		107	procedure SetItemXtra(const xmsg: TZMString; FSize: Int64);
		108	procedure SetSize(FullSize: Int64);
		109	procedure Written(bytes: Int64);
		110	property BytesWritten: Int64 read GetBytesWritten write fWritten;
		111	property InBatch: Boolean Read fInBatch;
		112	property ItemName: TZMString read GetItemName write fItemName;
		113	property ItemNumber: Integer read GetItemNumber write fItemNumber;
		114	property ItemPosition: Int64 read GetItemPosition write fItemPosition;
		115	property ItemSize: Int64 read GetItemSize write fItemSize;
		116	property Order: TZMProgressType read GetOrder write fProgType;
		117	property TotalCount: Int64 read GetTotalCount write fItemCount;
		118	property TotalPosition: Int64 read GetTotalPosition write fTotalPosition;
		119	property TotalSize: Int64 read GetTotalSize write fTotalSize;
		120	end;
		121
		122	type
		123	TZCentralValues = (zcvDirty, zcvEmpty, zcvError, zcvBadStruct, zcvBusy);
		124	TZCentralStatus = set of TZCentralValues;
		125
		126	type
		127	TZMPipeImp = class(TZMPipe)
		128	private
		129	FAttributes: Cardinal;
		130	FDOSDate: Cardinal;
		131	FFileName: string;
		132	FOwnsStream: boolean;
		133	FSize: Integer;
		134	FStream: TStream;
		135	protected
		136	function GetAttributes: Cardinal; override;
		137	function GetDOSDate: Cardinal; override;
		138	function GetFileName: string; override;
		139	function GetOwnsStream: boolean; override;
		140	function GetSize: Integer; override;
		141	function GetStream: TStream; override;
		142	procedure SetAttributes(const Value: Cardinal); override;
		143	procedure SetDOSDate(const Value: Cardinal); override;
		144	procedure SetFileName(const Value: string); override;
		145	procedure SetOwnsStream(const Value: boolean); override;
		146	procedure SetSize(const Value: Integer); override;
		147	procedure SetStream(const Value: TStream); override;
		148	public
		149	procedure AfterConstruction; override;
		150	procedure AssignTo(Dest: TZMPipeImp);
		151	procedure BeforeDestruction; override;
		152	end;
		153
		154	TZMPipeListImp = class(TZMPipeList)
		155	private
		156	List: TList;
		157	protected
		158	function GetCount: Integer; override;
		159	function GetPipe(Index: Integer): TZMPipe; override;
		160	procedure SetCount(const Value: Integer); override;
		161	procedure SetPipe(Index: Integer; const Value: TZMPipe); override;
		162	public
		163	function Add(aStream: TStream; const FileName: string; Own: boolean): integer; override;
		164	procedure AfterConstruction; override;
		165	procedure AssignTo(Dest: TZMPipeListImp);
		166	procedure BeforeDestruction; override;
		167	procedure Clear; override;
		168	function HasStream(Index: Integer): boolean;
		169	function KillStream(Index: Integer): boolean;
		170	end;
		171
		172	const
		173	MAX_PIPE = 9;
		174
		175
		176	type
		177	TZMCore = class
		178	private
		179	fAnswerAll: TZipAnswerAlls;
		180	fCancel: Integer;
		181	fCheckNo: Integer;
		182	fConfirmErase: Boolean;
		183	FEncodeAs: TZMEncodingOpts;
		184	FEncoding_CP: Cardinal;
		185	fFErrCode: Integer;
		186	fFileCleanup: TStringList;
		187	fFSpecArgs: TStrings;
		188	fFSpecArgsExcl: TStrings;
		189	fHandle: Cardinal;
		190	fHowToDelete: TZMDeleteOpts;
		191	FIgnoreDirOnly: Boolean;
		192	fKeepFreeOnAllDisks: Cardinal;
		193	fKeepFreeOnDisk1: Cardinal;
		194	fMaster: TCustomZipMaster19;
		195	FMaxVolumeSize: Int64;
		196	fMinFreeVolumeSize: Integer;
		197	FNoSkipping: TZMSkipAborts;
		198	fShowProgress: TZipShowProgress;
		199	fSniffer: Cardinal;
		200	fSniffNo: Integer;
		201	fSpanOptions: TZMSpanOpts;
		202	fUnattended: Boolean;
		203	{$IFNDEF UNICODE}
		204	fUseUTF8: Boolean;
		205	{$ENDIF}
		206	fWinXP: Boolean;
		207	FWriteOptions: TZMWriteOpts;
		208	function GetErrMessage: TZMString;
		209	function GetTotalWritten: Int64;
		210	procedure SetCancel(Value: Integer);
		211	procedure SetErrCode(Value: Integer);
		212	procedure SetProgDetail(const Value: TProgDetails);
		213	procedure SetTotalWritten(const Value: Int64);
		214	protected
		215	FAddOptions: TZMAddOpts;
		216	fBusy: Boolean;
		217	fEncoding: TZMEncodingOpts;
		218	FErrMessage: TZMString;
		219	fEventErr: String;
		220	FDllErrCode: Integer;
		221	fIsDestructing: Boolean;
		222	fNotMainTask: Boolean;
		223	fProgDetails: TProgDetails;
		224	FTempDir: String;
		225	fVerbosity: TZMVerbosity;
		226	procedure EncodingChanged(New_Enc: TZMEncodingOpts); virtual; abstract;
		227	procedure Encoding_CPChanged(New_CP: Cardinal); virtual; abstract;
		228	// 1 Locate sniffer and get overrides
		229	function FindSniffer: Cardinal;
		230	function GetTotalSizeToProcess: Int64;
		231	procedure ReportToSniffer(err: Integer; const msg: TZMString);
		232	procedure SetEncoding(const Value: TZMEncodingOpts);
		233	procedure SetEncoding_CP(const Value: Cardinal); //virtual;
		234	procedure StartUp; virtual;
		235	property Sniffer: Cardinal Read fSniffer Write fSniffer;
		236	property SniffNo: Integer Read fSniffNo Write fSniffNo;
		237	public
		238	constructor Create(AMaster: TCustomZipMaster19);
		239	procedure AddCleanupFile(const fn: String; always: Boolean = False);
		240	procedure AfterConstruction; override;
		241	procedure BeforeDestruction; override;
		242	procedure CheckCancel;
		243	procedure CleanupFiles(IsError: Boolean);
		244	procedure Clear; virtual;
		245	procedure ClearErr;
		246	procedure Diag(const msg: String);
		247	procedure Done(Good: boolean = true); virtual;
		248	function FNMatch(const pattern, spec: TZMString): Boolean;
		249	function KeepAlive: Boolean;
		250	procedure Kill; virtual;
		251	function MakeTempFileName(Prefix, Extension: String): String;
		252	function NextCheckNo: Integer;
		253	procedure OnDirUpdate;
		254	procedure OnNewName(idx: Integer);
		255	function RemoveFileCleanup(const fn: String): Boolean;
		256	procedure ReportMessage(err: Integer; const msg: TZMString);
		257	procedure ReportMessage1(err: Integer; const msg: TZMString);
		258	procedure ReportMsg(id: Integer; const Args: array of const );
		259	procedure ReportProgress(ActionCode: TActionCodes; ErrorCode: Integer; msg:
		260	TZMString; File_Size: Int64);
		261	function ReportSkipping(const FName: String; err: Integer;
		262	typ: TZMSkipTypes): Boolean;
		263	procedure ShowExceptionError(const ZMExcept: Exception);
		264	procedure ShowMsg(const msg: TZMString; err: Integer; display: Boolean);
		265	procedure ShowZipFmtMsg(id: Integer; const Args: array of const ;
		266	display: Boolean);
		267	procedure ShowZipMessage(Ident: Integer; const UserStr: String);
		268	procedure ShowZipMsg(Ident: Integer; display: Boolean);
		269	function ZipFmtLoadStr(id: Integer; const Args: array of const ): TZMString;
		270	function ZipLoadStr(id: Integer): TZMString;
		271	function ZipMessageDialog(const title: String; var msg: String;
		272	context: Integer; btns: TMsgDlgButtons): TModalResult;
		273	procedure ZipMessageDlg(const msg: String; context: Integer);
		274	function ZipMessageDlgEx(const title, msg: String; context: Integer;
		275	btns: TMsgDlgButtons): TModalResult;
		276	property AddOptions: TZMAddOpts read FAddOptions write FAddOptions;
		277	property AnswerAll: TZipAnswerAlls Read fAnswerAll Write fAnswerAll;
		278	property Busy: Boolean Read fBusy Write fBusy;
		279	property Cancel: Integer Read fCancel Write SetCancel;
		280	property ConfirmErase
		281	: Boolean Read fConfirmErase Write fConfirmErase default True;
		282	property EncodeAs: TZMEncodingOpts read FEncodeAs write FEncodeAs;
		283	property Encoding: TZMEncodingOpts Read fEncoding Write SetEncoding;
		284	property ErrCode: Integer Read fFErrCode Write SetErrCode;
		285	property ErrMessage: TZMString read GetErrMessage write FErrMessage;
		286	property FSpecArgs: TStrings Read fFSpecArgs Write fFSpecArgs;
		287	property FSpecArgsExcl: TStrings Read fFSpecArgsExcl Write fFSpecArgsExcl;
		288	property DllErrCode: Integer read FDllErrCode write FDllErrCode;
		289	property Encoding_CP: Cardinal read FEncoding_CP write SetEncoding_CP;
		290	property Handle: Cardinal Read fHandle;
		291	property HowToDelete: TZMDeleteOpts Read fHowToDelete Write fHowToDelete;
		292	property IgnoreDirOnly: Boolean read FIgnoreDirOnly;
		293	property KeepFreeOnAllDisks
		294	: Cardinal Read fKeepFreeOnAllDisks Write fKeepFreeOnAllDisks;
		295	property KeepFreeOnDisk1
		296	: Cardinal Read fKeepFreeOnDisk1 Write fKeepFreeOnDisk1;
		297	property Master: TCustomZipMaster19 Read fMaster;
		298	property MaxVolumeSize: Int64 read FMaxVolumeSize write FMaxVolumeSize;
		299	property MinFreeVolumeSize
		300	: Integer Read fMinFreeVolumeSize Write fMinFreeVolumeSize;
		301	property NoSkipping: TZMSkipAborts read FNoSkipping;
		302	property NotMainTask: Boolean Read fNotMainTask Write fNotMainTask;
		303	property ProgDetail: TProgDetails Read fProgDetails Write SetProgDetail;
		304	property ShowProgress
		305	: TZipShowProgress Read fShowProgress Write fShowProgress;
		306	property SpanOptions: TZMSpanOpts Read fSpanOptions Write fSpanOptions;
		307	property TempDir: String read FTempDir write FTempDir;
		308	property TotalWritten: Int64 read GetTotalWritten write SetTotalWritten;
		309	property Unattended: Boolean Read fUnattended Write fUnattended;
		310	{$IFNDEF UNICODE}
		311	property UseUTF8: Boolean read fUseUTF8 write fUseUTF8;
		312	{$ENDIF}
		313	property Verbosity: TZMVerbosity Read fVerbosity Write fVerbosity;
		314	property WinXP: Boolean Read fWinXP;
		315	property WriteOptions: TZMWriteOpts read FWriteOptions write FWriteOptions;
		316	end;
		317
		318	implementation
		319
		320	{$INCLUDE '.\ZipVers19.inc'}
		321
		322	uses Windows, Messages, ZMUtils19, ZMDlg19, ZMMsg19, ZMCtx19, ZMMsgStr19,
		323	ZMUTF819, ZMMatch19;
		324
		325	const
		326	SZipMasterSniffer = 'ZipMaster Sniffer';
		327	STZipSniffer = 'TZipSniffer';
		328	WM_SNIFF_START = WM_APP + $3F42;
		329	WM_SNIFF_STOP = WM_APP + $3F44;
		330	SNIFF_MASK = $FFFFFF;
		331	RESOURCE_ERROR: String =
		332	'ZMRes19_???.res is probably not linked to the executable' + #10 +
		333	'Missing String ID is: %d ';
		334
		335	{ TProgDetails }
		336	procedure TProgDetails.Advance(adv: Int64);
		337	begin
		338	fDelta := adv;
		339	fTotalPosition := fTotalPosition + adv;
		340	fItemPosition := fItemPosition + adv;
		341	fProgType := ProgressUpdate;
		342	end;
		343
		344	procedure TProgDetails.AdvanceXtra(adv: Cardinal);
		345	begin
		346	fDelta := adv;
		347	Inc(fItemPosition, adv);
		348	fProgType := ExtraUpdate;
		349	end;
		350
		351	procedure TProgDetails.Clear;
		352	begin
		353	fProgType := EndOfBatch;
		354	fDelta := 0;
		355	fItemCount := 0;
		356	fWritten := 0;
		357	fTotalSize := 0;
		358	fTotalPosition := 0;
		359	fItemSize := 0;
		360	fItemPosition := 0;
		361	fItemName := '';
		362	fItemNumber := 0;
		363	end;
		364
		365	function TProgDetails.GetBytesWritten: Int64;
		366	begin
		367	Result := fWritten;
		368	end;
		369
		370	function TProgDetails.GetDelta: Int64;
		371	begin
		372	Result := fDelta;
		373	end;
		374
		375	function TProgDetails.GetItemName: TZMString;
		376	begin
		377	Result := fItemName;
		378	end;
		379
		380	function TProgDetails.GetItemNumber: Integer;
		381	begin
		382	Result := fItemNumber;
		383	end;
		384
		385	function TProgDetails.GetItemPosition: Int64;
		386	begin
		387	Result := fItemPosition;
		388	end;
		389
		390	function TProgDetails.GetItemSize: Int64;
		391	begin
		392	Result := fItemSize;
		393	end;
		394
		395	function TProgDetails.GetOrder: TZMProgressType;
		396	begin
		397	Result := fProgType;
		398	end;
		399
		400	function TProgDetails.GetTotalCount: Int64;
		401	begin
		402	Result := fItemCount;
		403	end;
		404
		405	function TProgDetails.GetTotalPosition: Int64;
		406	begin
		407	Result := fTotalPosition;
		408	end;
		409
		410	function TProgDetails.GetTotalSize: Int64;
		411	begin
		412	Result := fTotalSize;
		413	end;
		414
		415	procedure TProgDetails.SetCount(Count: Int64);
		416	begin
		417	Clear;
		418	fItemCount := Count;
		419	fItemNumber := 0;
		420	fProgType := TotalFiles2Process;
		421	end;
		422
		423	procedure TProgDetails.SetEnd;
		424	begin
		425	fItemName := '';
		426	fItemSize := 0;
		427	fInBatch := False;
		428	fProgType := EndOfBatch;
		429	end;
		430
		431	procedure TProgDetails.SetItem(const FName: TZMString; FSize: Int64);
		432	begin
		433	Inc(fItemNumber);
		434	fItemName := FName;
		435	fItemSize := FSize;
		436	fItemPosition := 0;
		437	fProgType := NewFile;
		438	end;
		439
		440	procedure TProgDetails.SetItemXtra(const xmsg: TZMString; FSize: Int64);
		441	begin
		442	fItemName := xmsg;
		443	fItemSize := FSize;
		444	fItemPosition := 0;
		445	fProgType := NewExtra;
		446	end;
		447
		448	procedure TProgDetails.SetSize(FullSize: Int64);
		449	begin
		450	fTotalSize := FullSize;
		451	fTotalPosition := 0;
		452	fItemName := '';
		453	fItemSize := 0;
		454	fItemPosition := 0;
		455	fProgType := TotalSize2Process;
		456	fWritten := 0;
		457	fInBatch := True; // start of batch
		458	end;
		459
		460	procedure TProgDetails.Written(bytes: Int64);
		461	begin
		462	fWritten := bytes;
		463	end;
		464
		465	{ TZMCore }
		466	constructor TZMCore.Create(AMaster: TCustomZipMaster19);
		467	begin
		468	fMaster := AMaster;
		469	end;
		470
		471	procedure TZMCore.AddCleanupFile(const fn: String; always: Boolean = False);
		472	var
		473	f: String;
		474	obj: TObject;
		475	begin
		476	f := ExpandFileName(fn); // need full path incase current dir changes
		477	obj := nil;
		478	if always then
		479	obj := TObject(self);
		480	fFileCleanup.AddObject(f, obj);
		481	end;
		482
		483	procedure TZMCore.AfterConstruction;
		484	begin
		485	inherited;
		486	fHandle := Application.Handle;
		487	fProgDetails := TProgDetails.Create;
		488	fFSpecArgs := TStringList.Create;
		489	fFSpecArgsExcl := TStringList.Create;
		490	fFileCleanup := TStringList.Create;
		491	fHowToDelete := htdAllowUndo;
		492	fSpanOptions := [];
		493	FErrMessage := '';
		494	fFErrCode := -1;
		495	fVerbosity := zvOff;
		496	fUnattended := True; // during construction
		497	fEncoding := zeoAuto;
		498	FEncodeAs := zeoAuto;
		499	fVerbosity := zvOff;
		500	fTempDir := '';
		501	fNotMainTask := False;
		502	fWinXP := IsWinXP; // set flag;
		503	end;
		504
		505	procedure TZMCore.BeforeDestruction;
		506	begin
		507	fCancel := DS_Canceled;
		508	fVerbosity := zvOff;
		509	FreeAndNil(fFileCleanup);
		510	FreeAndNil(fProgDetails);
		511	FreeAndNil(fFSpecArgsExcl);
		512	FreeAndNil(fFSpecArgs);
		513	inherited;
		514	end;
		515
		516	procedure TZMCore.CheckCancel;
		517	begin
		518	KeepAlive;
		519	if fCancel <> 0 then
		520	raise EZipMaster.CreateResDisp(Cancel, True);
		521	end;
		522
		523	procedure TZMCore.CleanupFiles(IsError: Boolean);
		524	var
		525	AlwaysClean: Boolean;
		526	fn: String;
		527	i: Integer;
		528	begin
		529	if (fFileCleanup.Count > 0) then
		530	begin
		531	for i := fFileCleanup.Count - 1 downto 0 do
		532	begin
		533	fn := fFileCleanup[i];
		534	if Length(fn) < 2 then
		535	continue;
		536	AlwaysClean := fFileCleanup.Objects[i] <> nil;
		537	if IsError or AlwaysClean then
		538	begin
		539	if CharInSet(fn[Length(fn)], ['/', '\']) then
		540	begin
		541	fn := ExcludeTrailingBackslash(fn);
		542	if DirExists(fn) then
		543	RemoveDir(fn);
		544	end
		545	else
		546	begin
		547	if FileExists(fn) then
		548	SysUtils.DeleteFile(fn);
		549	end;
		550	end;
		551	end;
		552	fFileCleanup.Clear;
		553	end;
		554	end;
		555
		556	procedure TZMCore.Clear;
		557	begin
		558	Cancel := 0;
		559	ClearErr;
		560	fHowToDelete := htdAllowUndo;
		561	fUnattended := False;
		562	fEncoding := zeoAuto;
		563	FEncodeAs := zeoAuto;
		564	fVerbosity := zvOff;
		565	TProgDetails(fProgDetails).Clear;
		566	fFSpecArgs.Clear;
		567	fFSpecArgsExcl.Clear;
		568	fEventErr := '';
		569	fIsDestructing := False;
		570	fSpanOptions := [];
		571	FWriteOptions := [];
		572	end;
		573
		574	procedure TZMCore.ClearErr;
		575	begin
		576	FErrMessage := '';
		577	fFErrCode := 0;
		578	FDllErrCode := 0;
		579	end;
		580
		581	procedure TZMCore.Diag(const msg: String);
		582	begin
		583	if Verbosity >= zvVerbose then
		584	ShowMsg('Trace: ' + msg, 0, False); // quicker
		585	end;
		586
		587	procedure TZMCore.Done(Good: boolean = true);
		588	begin
		589	CleanupFiles(not Good);
		590	if Sniffer <> 0 then
		591	begin
		592	// send finished
		593	SendMessage(Sniffer, WM_SNIFF_STOP, 0, SniffNo);
		594	Sniffer := 0;
		595	end;
		596	fBusy := False;
		597	end;
		598
		599	function TZMCore.FindSniffer: Cardinal;
		600	var
		601	flgs: Cardinal;
		602	res: Integer;
		603	begin
		604	Result := FindWindow(PChar(STZipSniffer), PChar(SZipMasterSniffer));
		605	if Result <> 0 then
		606	begin
		607	res := SendMessage(Result, WM_SNIFF_START, Longint(Handle), Ord(Verbosity));
		608	if res < 0 then
		609	begin
		610	Result := 0; // invalid
		611	exit;
		612	end;
		613	// in range so hopefully valid response
		614	flgs := Cardinal(res) shr 24;
		615	if flgs >= 8 then
		616	begin
		617	Result := 0; // invalid
		618	exit;
		619	end;
		620	// treat it as valid
		621	if flgs > 3 then
		622	Verbosity := TZMVerbosity(flgs and 3); // force it
		623	SniffNo := res and SNIFF_MASK; // operation number
		624	end;
		625	end;
		626
		627	function TZMCore.FNMatch(const pattern, spec: TZMString): Boolean;
		628	begin
		629	{$IFDEF UNICODE}
		630	Result := FileNameMatch(pattern, spec);
		631	{$ELSE}
		632	Result := FileNameMatch(pattern, spec, UseUTF8);
		633	{$ENDIF}
		634	end;
		635
		636	(* ? TZMCore.GetErrMessage
		637	1.73 13 July 2003 RP only return ErrMessage if error
		638	*)
		639	function TZMCore.GetErrMessage: TZMString;
		640	begin
		641	Result := '';
		642	if ErrCode <> 0 then
		643	begin
		644	Result := FErrMessage;
		645	if Result = '' then
		646	Result := ZipLoadStr(ErrCode);
		647	if Result = '' then
		648	Result := ZipFmtLoadStr(GE_Unknown, [ErrCode]);
		649	end;
		650	end;
		651
		652	function TZMCore.GetTotalSizeToProcess: Int64;
		653	begin
		654	Result := TProgDetails(fProgDetails).TotalSize;
		655	end;
		656
		657	function TZMCore.GetTotalWritten: Int64;
		658	begin
		659	Result := ProgDetail.BytesWritten;
		660	end;
		661
		662	function TZMCore.KeepAlive: Boolean;
		663	var
		664	DoStop: Boolean;
		665	tmpCheckTerminate: TZMCheckTerminateEvent;
		666	tmpTick: TZMTickEvent;
		667	begin
		668	Result := Cancel <> 0;
		669	tmpTick := Master.OnTick;
		670	if assigned(tmpTick) then
		671	tmpTick(Master);
		672	tmpCheckTerminate := Master.OnCheckTerminate;
		673	if assigned(tmpCheckTerminate) then
		674	begin
		675	DoStop := Cancel <> 0;
		676	tmpCheckTerminate(Master, DoStop);
		677	if DoStop then
		678	Cancel := DS_Canceled;
		679	end
		680	else if not fNotMainTask then
		681	Application.ProcessMessages;
		682	end;
		683
		684	procedure TZMCore.Kill;
		685	begin
		686	fCancel := DS_Canceled;
		687	end;
		688
		689	(* ? TZMCore.MakeTempFileName
		690	Make a temporary filename like: C:\...\zipxxxx.zip
		691	Prefix and extension are default: 'zip' and '.zip'
		692	*)
		693	function TZMCore.MakeTempFileName(Prefix, Extension: String): String;
		694	var
		695	buf: String;
		696	len: DWORD;
		697	tmpDir: String;
		698	begin
		699	if Prefix = '' then
		700	Prefix := 'zip';
		701	if Extension = '' then
		702	Extension := EXT_ZIPL;
		703	if Length(fTempDir) = 0 then // Get the system temp dir
		704	begin
		705	// 1. The path specified by the TMP environment variable.
		706	// 2. The path specified by the TEMP environment variable, if TMP is not defined.
		707	// 3. The current directory, if both TMP and TEMP are not defined.
		708	len := GetTempPath(0, PChar(tmpDir));
		709	SetLength(tmpDir, len);
		710	GetTempPath(len, PChar(tmpDir));
		711	end
		712	else // Use Temp dir provided by ZipMaster
		713	begin
		714	tmpDir := DelimitPath(fTempDir, True);
		715	end;
		716	SetLength(buf, MAX_PATH + 12);
		717	if GetTempFileName(PChar(tmpDir), PChar(Prefix), 0, PChar(buf)) <> 0 then
		718	begin
		719	buf := PChar(buf);
		720	SysUtils.DeleteFile(buf); // Needed because GetTempFileName creates the file also.
		721	Result := ChangeFileExt(buf, Extension);
		722	// And finally change the extension.
		723	end;
		724	end;
		725
		726	function TZMCore.NextCheckNo: Integer;
		727	begin
		728	Inc(fCheckNo);
		729	Result := fCheckNo;
		730	end;
		731
		732	procedure TZMCore.OnDirUpdate;
		733	begin
		734	if assigned(Master.OnDirUpdate) then
		735	Master.OnDirUpdate(Master);
		736	end;
		737
		738	procedure TZMCore.OnNewName(idx: Integer);
		739	begin
		740	if assigned(Master.OnNewName) then
		741	Master.OnNewName(Master, idx);
		742	end;
		743
		744	function TZMCore.RemoveFileCleanup(const fn: String): Boolean;
		745	var
		746	f: String;
		747	i: Integer;
		748	begin
		749	Result := False;
		750	f := ExpandFileName(fn);
		751	for i := fFileCleanup.Count - 1 downto 0 do
		752	if AnsiSameText(fFileCleanup[i], f) then
		753	begin
		754	fFileCleanup.Delete(i);
		755	Result := True;
		756	break;
		757	end;
		758	end;
		759
		760	procedure TZMCore.ReportMessage(err: Integer; const msg: TZMString);
		761	begin
		762	if Sniffer <> 0 then
		763	ReportToSniffer(err, msg);
		764	ReportMessage1(err, msg);
		765	end;
		766
		767	procedure TZMCore.ReportMessage1(err: Integer; const msg: TZMString);
		768	var
		769	tmpMessage: TZMMessageEvent;
		770	begin
		771	if (err <> 0) and (ErrCode = 0) then // only catch first
		772	begin
		773	if DllErrCode = 0 then
		774	FDllErrCode := err;
		775	fFErrCode := err;
		776	FErrMessage := msg;
		777	end;
		778	tmpMessage := Master.OnMessage;
		779	if assigned(tmpMessage) then
		780	tmpMessage(Master, err, msg);
		781	KeepAlive; // process messages or check terminate
		782	end;
		783
		784	procedure TZMCore.ReportMsg(id: Integer; const Args: array of const );
		785	var
		786	msg: TZMString;
		787	p: Integer;
		788	begin
		789	msg := ZipFmtLoadStr(id, Args);
		790	if msg <> '' then
		791	begin
		792	p := 0;
		793	case msg[1] of
		794	'#':
		795	p := TM_Trace;
		796	'!':
		797	p := TM_Verbose;
		798	end;
		799	if p <> 0 then
		800	begin
		801	msg := ZipLoadStr(p) + copy(msg, 2, Length(msg) - 1);
		802	end;
		803	end;
		804	ReportMessage(0, msg);
		805	end;
		806
		807	(* ? TZMCore.ReportProgress
		808	1.77.2.0 14 September 2004 - RP fix setting ErrCode caused re-entry
		809	1.77.2.0 14 September 2004 - RP alter thread support & OnCheckTerminate
		810	1.77 16 July 2004 - RP preserve last errors ErrMessage
		811	1.76 24 April 2004 - only handle 'progress' and information
		812	*)
		813	procedure TZMCore.ReportProgress(ActionCode: TActionCodes; ErrorCode: Integer;
		814	msg: TZMString; File_Size: Int64);
		815	var
		816	Details: TProgDetails;
		817	SendDetails: Boolean;
		818	tmpProgress: TZMProgressEvent;
		819	begin
		820	if fIsDestructing then
		821	exit;
		822	if ActionCode <= zacXProgress then
		823	begin
		824	Details := fProgDetails as TProgDetails;
		825	SendDetails := True;
		826	case ActionCode of
		827	zacTick: { 'Tick' Just checking / processing messages }
		828	begin
		829	KeepAlive;
		830	SendDetails := False;
		831	end;
		832
		833	zacItem: { progress type 1 = StartUp any ZIP operation on a new file }
		834	Details.SetItem(msg, File_Size);
		835
		836	zacProgress: { progress type 2 = increment bar }
		837	Details.Advance(File_Size);
		838
		839	zacEndOfBatch: { end of a batch of 1 or more files }
		840	begin
		841	if Details.InBatch then
		842	Details.SetEnd
		843	else
		844	SendDetails := False;
		845	end;
		846
		847	zacCount: { total number of files to process }
		848	Details.SetCount(File_Size);
		849
		850	zacSize: { total size of all files to be processed }
		851	Details.SetSize(File_Size);
		852
		853	zacXItem: { progress type 15 = StartUp new extra operation }
		854	begin
		855	if ErrorCode < 20 then
		856	ErrorCode := PR_Progress + ErrorCode;
		857	msg := ZipLoadStr(ErrorCode);
		858	Details.SetItemXtra(msg, File_Size);
		859	end;
		860
		861	zacXProgress: { progress type 16 = increment bar for extra operation }
		862	Details.AdvanceXtra(File_Size);
		863	end; { end case }
		864	{$IFDEF DEBUG_PROGRESS}
		865	if Verbosity >= zvVerbose then
		866	case ActionCode of
		867	zacItem:
		868	Diag(Format('#Item - "%s" %d', [Details.ItemName, Details.ItemSize]));
		869	zacProgress:
		870	Diag(Format('#Progress - [inc:%d] ipos:%d isiz:%d, tpos:%d tsiz:%d',
		871	[File_Size, Details.ItemPosition, Details.ItemSize,
		872	Details.TotalPosition, Details.TotalSize]));
		873	zacEndOfBatch:
		874	if SendDetails then
		875	Diag('#End Of Batch')
		876	else
		877	Diag('#End Of Batch with no batch');
		878	zacCount:
		879	Diag(Format('#Count - %d', [Details.TotalCount]));
		880	zacSize:
		881	Diag(Format('#Size - %d', [Details.TotalSize]));
		882	zacXItem:
		883	Diag(Format('#XItem - %s size = %d', [Details.ItemName, File_Size]));
		884	zacXProgress:
		885	Diag(Format('#XProgress - [inc:%d] pos:%d siz:%d',
		886	[File_Size, Details.ItemPosition, Details.ItemSize]));
		887	end;
		888	{$ENDIF}
		889	tmpProgress := Master.OnProgress;
		890	if SendDetails and (assigned(tmpProgress)) then
		891	tmpProgress(Master, Details);
		892	end;
		893
		894	KeepAlive;
		895	end;
		896
		897	// returns True if skipping not allowed
		898	function TZMCore.ReportSkipping(const FName: String; err: Integer;
		899	typ: TZMSkipTypes): Boolean;
		900	var
		901	ti: Integer;
		902	tmpMessage: ZipMstr19.TZMMessageEvent;
		903	tmpSkipped: TZMSkippedEvent;
		904	begin
		905	Result := False;
		906	if typ in NoSkipping then
		907	begin
		908	if err = 0 then
		909	err := GE_NoSkipping;
		910	end;
		911	ti := err;
		912	if ti < 0 then
		913	ti := -ti;
		914	if (ti <> 0) and (typ in NoSkipping) then
		915	ti := -ti; // default to abort
		916	tmpSkipped := Master.OnSkipped;
		917	if assigned(tmpSkipped) then
		918	tmpSkipped(Master, FName, typ, ti)
		919	else if Verbosity >= zvVerbose then
		920	begin
		921	tmpMessage := Master.OnMessage;
		922	if assigned(tmpMessage) then
		923	tmpMessage(Master, GE_Unknown, ZipFmtLoadStr
		924	(GE_Skipped, [FName, Ord(typ)]));
		925	end;
		926	if ti < 0 then
		927	Result := True; // Skipping not allowed
		928	if Sniffer <> 0 then
		929	ReportToSniffer(0, Format('[Skipped] IN=%d,%d OUT=%d', [err, Ord(typ), Ord
		930	(Result)]));
		931	end;
		932
		933	procedure TZMCore.ReportToSniffer(err: Integer; const msg: TZMString);
		934	var
		935	aCopyData: TCopyDataStruct;
		936	msg8: UTF8String;
		937	begin
		938	if Sniffer = 0 then // should not happen
		939	exit;
		940	// always feed Sniffer with UTF8
		941	{$IFDEF UNICODE}
		942	msg8 := StrToUTF8(msg);
		943	{$ELSE}
		944	if UseUTF8 then
		945	msg8 := msg
		946	else
		947	msg8 := StrToUTF8(msg);
		948	{$ENDIF}
		949	aCopyData.dwData := Cardinal(err);
		950	aCopyData.cbData := (Length(msg8) + 1) * sizeof(AnsiChar);
		951	aCopyData.lpData := @msg8[1];
		952	if SendMessage(Sniffer, WM_COPYDATA, SniffNo, Longint(@aCopyData)) = 0 then
		953	Sniffer := 0; // could not process it -don't try again
		954	end;
		955
		956	procedure TZMCore.SetCancel(Value: Integer);
		957	begin
		958	fCancel := Value;
		959	end;
		960
		961	procedure TZMCore.SetEncoding(const Value: TZMEncodingOpts);
		962	begin
		963	if Encoding <> Value then
		964	begin
		965	FEncoding := Value;
		966	EncodingChanged(Value);
		967	end;
		968	end;
		969
		970	procedure TZMCore.SetEncoding_CP(const Value: Cardinal);
		971	begin
		972	if Encoding_CP <> Value then
		973	begin
		974	FEncoding_CP := Value;
		975	Encoding_CPChanged(Value);
		976	end;
		977	end;
		978
		979	(* ? TZMCore.SetErrCode
		980	Some functions return -error - normalise these values
		981	*)
		982	procedure TZMCore.SetErrCode(Value: Integer);
		983	begin
		984	if Value < 0 then
		985	fFErrCode := -Value
		986	else
		987	fFErrCode := Value;
		988	end;
		989
		990	procedure TZMCore.SetProgDetail(const Value: TProgDetails);
		991	begin
		992	// do not change
		993	end;
		994
		995	procedure TZMCore.SetTotalWritten(const Value: Int64);
		996	begin
		997	ProgDetail.Written(Value);
		998	end;
		999
		1000	(* ? TZMCore.ShowExceptionError
		1001	1.80 strings already formatted
		1002	// Somewhat different from ShowZipMessage() because the loading of the resource
		1003	// string is already done in the constructor of the exception class.
		1004	*)
		1005	procedure TZMCore.ShowExceptionError(const ZMExcept: Exception);
		1006	var
		1007	display: Boolean;
		1008	msg: String;
		1009	ResID: Integer;
		1010	begin
		1011	if ZMExcept is EZMException then
		1012	begin
		1013	ResID := EZMException(ZMExcept).ResID;
		1014	display := EZMException(ZMExcept).DisplayMsg;
		1015	{$IFDEF UNICODE}
		1016	msg := EZMException(ZMExcept).Message;
		1017	{$ELSE}
		1018	msg := EZMException(ZMExcept).TheMessage(UseUTF8);
		1019	{$ENDIF}
		1020	end
		1021	else
		1022	begin
		1023	ResID := GE_ExceptErr;
		1024	display := True;
		1025	msg := ZMExcept.Message;
		1026	end;
		1027	ShowMsg(msg, ResID, display);
		1028	end;
		1029
		1030	procedure TZMCore.ShowMsg(const msg: TZMString; err: Integer; display: Boolean);
		1031	begin
		1032	FErrMessage := msg;
		1033	if err < 0 then
		1034	fFErrCode := -err
		1035	else
		1036	fFErrCode := err;
		1037	if display and (not fUnattended) and (ErrCode <> GE_Abort) and
		1038	(ErrCode <> DS_Canceled) then
		1039	ZipMessageDlg(msg, zmtInformation + DHC_ZipMessage);
		1040
		1041	ReportMessage(ErrCode, msg);
		1042	end;
		1043
		1044	(* ? TZMCore.ShowZipFmtMsg
		1045	1.79 added
		1046	*)
		1047	procedure TZMCore.ShowZipFmtMsg(id: Integer; const Args: array of const ;
		1048	display: Boolean);
		1049	begin
		1050	if id < 0 then
		1051	id := -id;
		1052	ShowMsg(ZipFmtLoadStr(id, Args), id, display);
		1053	end;
		1054
		1055	(* ? TZMCore.ShowZipMessage
		1056	*)
		1057	procedure TZMCore.ShowZipMessage(Ident: Integer; const UserStr: String);
		1058	var
		1059	msg: String;
		1060	begin
		1061	if Ident < 0 then
		1062	Ident := -Ident;
		1063	msg := ZipLoadStr(Ident);
		1064	if msg = '' then
		1065	msg := Format(RESOURCE_ERROR, [Ident]);
		1066	msg := msg + UserStr;
		1067	ShowMsg(msg, Ident, True);
		1068	end;
		1069
		1070	procedure TZMCore.ShowZipMsg(Ident: Integer; display: Boolean);
		1071	var
		1072	msg: String;
		1073	begin
		1074	if Ident < 0 then
		1075	Ident := -Ident;
		1076	msg := ZipLoadStr(Ident);
		1077	if msg = '' then
		1078	msg := Format(RESOURCE_ERROR, [Ident]);
		1079	ShowMsg(msg, Ident, display);
		1080	end;
		1081
		1082	(* ? TZMCore.StartUp
		1083	*)
		1084	procedure TZMCore.StartUp;
		1085	var
		1086	s: String;
		1087	begin
		1088	fBusy := True;
		1089	Cancel := 0;
		1090	fAnswerAll := [];
		1091	ClearErr;
		1092	{$IFNDEF UNICODE}
		1093	fUseUTF8 := Master.UseUTF8;
		1094	{$ENDIF}
		1095	fHandle := Master.Handle;
		1096	FAddOptions := Master.AddOptions;
		1097	fUnattended := Master.Unattended;
		1098	fConfirmErase := Master.ConfirmErase;
		1099	fKeepFreeOnAllDisks := Master.KeepFreeOnAllDisks;
		1100	fKeepFreeOnDisk1 := Master.KeepFreeOnDisk1;
		1101	if Master.MaxVolumeSizeKb = 0 then
		1102	FMaxVolumeSize := Master.MaxVolumeSize
		1103	else
		1104	FMaxVolumeSize := Master.MaxVolumeSizeKb * 1024;
		1105	fMinFreeVolumeSize := Master.MinFreeVolumeSize;
		1106	FNoSkipping := Master.NoSkipping;
		1107	fSpanOptions := Master.SpanOptions;
		1108	FWriteOptions := Master.WriteOptions;
		1109	if Master.Trace then
		1110	fVerbosity := zvTrace
		1111	else if Master.Verbose then
		1112	fVerbosity := zvVerbose
		1113	else
		1114	fVerbosity := zvOff;
		1115	{f}Encoding := Master.Encoding;
		1116	Encoding_CP := Master.Encoding_CP;
		1117	FEncodeAs := Master.EncodeAs;
		1118	fHowToDelete := Master.HowToDelete;
		1119	TempDir := Master.TempDir;
		1120	fFSpecArgs.Assign(Master.FSpecArgs);
		1121	fFSpecArgsExcl.Assign(Master.FSpecArgsExcl);
		1122	FIgnoreDirOnly := not Master.UseDirOnlyEntries;
		1123	fNotMainTask := Master.NotMainThread;
		1124	if GetCurrentThreadID <> MainThreadID then
		1125	fNotMainTask := True;
		1126	Sniffer := FindSniffer;
		1127	if Sniffer <> 0 then
		1128	begin
		1129	if Master.Owner <> nil then
		1130	begin
		1131	s := Master.Owner.Name;
		1132	if s <> '' then
		1133	s := s + '.';
		1134	end;
		1135	if Master.Name = '' then
		1136	s := '<unknown>'
		1137	else
		1138	s := s + Master.Name;
		1139	if fNotMainTask then
		1140	s := '*' + s;
		1141	ReportToSniffer(0, 'Starting ' + s);
		1142	end;
		1143	fFileCleanup.Clear;
		1144	end;
		1145
		1146	function TZMCore.ZipFmtLoadStr(id: Integer; const Args: array of const )
		1147	: TZMString;
		1148	begin
		1149	Result := ZipLoadStr(id);
		1150
		1151	if Result <> '' then
		1152	Result := Format(Result, Args);
		1153	end;
		1154
		1155	function TZMCore.ZipLoadStr(id: Integer): TZMString;
		1156	begin
		1157	Result := LoadZipStr(id);
		1158	{$IFNDEF UNICODE}
		1159	if (Result <> '') and UseUTF8 then
		1160	Result := StrToUTF8(Result);
		1161	{$ENDIF}
		1162	end;
		1163
		1164	function TZMCore.ZipMessageDialog(const title: String; var msg: String;
		1165	context: Integer; btns: TMsgDlgButtons): TModalResult;
		1166	var
		1167	ctx: Integer;
		1168	dlg: TZipDialogBox;
		1169	s: String;
		1170	t: String;
		1171	tmpZipDialog: TZMDialogEvent;
		1172	begin
		1173	t := title;
		1174	if title = '' then
		1175	t := Application.title;
		1176	if Verbosity >= zvVerbose then
		1177	t := Format('%s (%d)', [t, context and MAX_WORD]);
		1178	tmpZipDialog := Master.OnZipDialog;
		1179	if assigned(tmpZipDialog) then
		1180	begin
		1181	s := msg;
		1182	ctx := context;
		1183	tmpZipDialog(Master, t, s, ctx, btns);
		1184	if (ctx > 0) and (ctx <= Ord(mrYesToAll)) then
		1185	begin
		1186	msg := s;
		1187	Result := TModalResult(ctx);
		1188	exit;
		1189	end;
		1190	end;
		1191	dlg := TZipDialogBox.CreateNew2(Application, context);
		1192	try
		1193	dlg.Build(t, msg, btns {$IFNDEF UNICODE}, UseUTF8 {$ENDIF});
		1194	dlg.ShowModal();
		1195	Result := dlg.ModalResult;
		1196	if dlg.DlgType = zmtPassword then
		1197	begin
		1198	if (Result = mrOk) then
		1199	msg := dlg.PWrd
		1200	else
		1201	msg := '';
		1202	end;
		1203	finally
		1204	FreeAndNil(dlg);
		1205	end;
		1206	end;
		1207
		1208	procedure TZMCore.ZipMessageDlg(const msg: String; context: Integer);
		1209	begin
		1210	ZipMessageDlgEx('', msg, context, [mbOK]);
		1211	end;
		1212
		1213	function TZMCore.ZipMessageDlgEx(const title, msg: String; context: Integer;
		1214	btns: TMsgDlgButtons): TModalResult;
		1215	var
		1216	m: String;
		1217	begin
		1218	m := msg;
		1219	Result := ZipMessageDialog(title, m, context, btns);
		1220	end;
		1221
		1222	procedure TZMPipeImp.AfterConstruction;
		1223	begin
		1224	inherited;
		1225	FStream := nil;
		1226	fSize := 0;
		1227	fDOSDate := Cardinal(DateTimeToFileDate(now));
		1228	fAttributes := 0;
		1229	end;
		1230
		1231	procedure TZMPipeImp.AssignTo(Dest: TZMPipeImp);
		1232	begin
		1233	if Dest <> self then
		1234	begin
		1235	Dest.Stream := FStream;
		1236	FStream := nil;
		1237	Dest.Size := FSize;
		1238	Dest.DOSDate := fDOSDate;
		1239	Dest.Attributes := FAttributes;
		1240	Dest.OwnsStream := FOwnsStream;
		1241	end;
		1242	end;
		1243
		1244	procedure TZMPipeImp.BeforeDestruction;
		1245	begin
		1246	if OwnsStream and (FStream <> nil) then
		1247	FStream.Free;
		1248	inherited;
		1249	end;
		1250
		1251	function TZMPipeImp.GetAttributes: Cardinal;
		1252	begin
		1253	Result := FAttributes;
		1254	end;
		1255
		1256	function TZMPipeImp.GetDOSDate: Cardinal;
		1257	begin
		1258	Result := FDOSDate;
		1259	end;
		1260
		1261	function TZMPipeImp.GetFileName: string;
		1262	begin
		1263	Result := FFileName;
		1264	end;
		1265
		1266	function TZMPipeImp.GetOwnsStream: boolean;
		1267	begin
		1268	Result := FOwnsStream;
		1269	end;
		1270
		1271	function TZMPipeImp.GetSize: Integer;
		1272	begin
		1273	Result := FSize;
		1274	end;
		1275
		1276	function TZMPipeImp.GetStream: TStream;
		1277	begin
		1278	Result := FStream;
		1279	end;
		1280
		1281	procedure TZMPipeImp.SetAttributes(const Value: Cardinal);
		1282	begin
		1283	FAttributes := Value;
		1284	end;
		1285
		1286	procedure TZMPipeImp.SetDOSDate(const Value: Cardinal);
		1287	begin
		1288	FDOSDate := Value;
		1289	end;
		1290
		1291	procedure TZMPipeImp.SetFileName(const Value: string);
		1292	begin
		1293	if FFileName <> Value then
		1294	begin
		1295	FFileName := Value;
		1296	end;
		1297	end;
		1298
		1299	procedure TZMPipeImp.SetOwnsStream(const Value: boolean);
		1300	begin
		1301	FOwnsStream := Value;
		1302	end;
		1303
		1304	procedure TZMPipeImp.SetSize(const Value: Integer);
		1305	begin
		1306	if Value <> FSize then
		1307	begin
		1308	if FStream = nil then
		1309	FSize := 0
		1310	else
		1311	begin
		1312	if Value > FStream.Size then
		1313	FSize := Integer(FStream.Size)
		1314	else
		1315	FSize := Value;
		1316	end;
		1317	end;
		1318	end;
		1319
		1320	procedure TZMPipeImp.SetStream(const Value: TStream);
		1321	begin
		1322	if FStream <> Value then
		1323	begin
		1324	if Value = nil then
		1325	FStream.Free;
		1326	FStream := Value;
		1327	if Value <> nil then
		1328	begin
		1329	FSize := Integer(FStream.Size);
		1330	FStream.Position := 0;
		1331	end;
		1332	end;
		1333	end;
		1334
		1335	function TZMPipeListImp.Add(aStream: TStream; const FileName: string; Own:
		1336	boolean): integer;
		1337	var
		1338	tmpPipe: TZMPipe;
		1339	begin
		1340	Result := List.Count;
		1341	tmpPipe := Pipe[Result];
		1342	tmpPipe.Stream := aStream;
		1343	tmpPipe.FileName := FileName;
		1344	tmpPipe.OwnsStream := Own;
		1345	end;
		1346
		1347	procedure TZMPipeListImp.AfterConstruction;
		1348	begin
		1349	inherited;
		1350	List := TList.Create;
		1351	end;
		1352
		1353	procedure TZMPipeListImp.AssignTo(Dest: TZMPipeListImp);
		1354	var
		1355	I: Integer;
		1356	begin
		1357	if (Dest <> nil) and (Dest <> Self) then
		1358	begin
		1359	Dest.Clear;
		1360	for I := 0 to Count - 1 do
		1361	Dest.List.Add(List[i]);
		1362	List.Clear;
		1363	end;
		1364	end;
		1365
		1366	procedure TZMPipeListImp.BeforeDestruction;
		1367	begin
		1368	Clear;
		1369	List.Free;
		1370	inherited;
		1371	end;
		1372
		1373	procedure TZMPipeListImp.Clear;
		1374	var
		1375	i: Integer;
		1376	tmp: TZMPipeImp;
		1377	begin
		1378	if (List <> nil) and (List.Count > 0) then
		1379	begin
		1380	for I := 0 to List.Count - 1 do
		1381	begin
		1382	if TObject(List[i]) is TZMPipeImp then
		1383	begin
		1384	tmp := TZMPipeImp(List[i]);
		1385	List[i] := nil;
		1386	tmp.Free;
		1387	end;
		1388	end;
		1389	List.Clear;
		1390	end;
		1391	end;
		1392
		1393	function TZMPipeListImp.GetCount: Integer;
		1394	begin
		1395	Result := List.Count;
		1396	end;
		1397
		1398	function TZMPipeListImp.GetPipe(Index: Integer): TZMPipe;
		1399	var
		1400	tmpPipe: TZMPipeImp;
		1401	begin
		1402	if (Index <0) or (Index > MAX_PIPE) then
		1403	raise EZipMaster.CreateResFmt(GE_RangeError, [Index, MAX_PIPE]);
		1404	if Index >= List.Count then
		1405	List.Count := Index + 1;
		1406	if not (TObject(List[Index]) is TZMPipeImp) then
		1407	begin
		1408	// need a new one
		1409	tmpPipe := TZMPipeImp.Create;
		1410	List[Index] := tmpPipe;
		1411	end;
		1412	Result := TZMPipeImp(List[Index]);
		1413	end;
		1414
		1415	function TZMPipeListImp.HasStream(Index: Integer): boolean;
		1416	begin
		1417	Result := (Index >= 0) and (Index < count) and (Pipe[Index].Stream <> nil);
		1418	end;
		1419
		1420	function TZMPipeListImp.KillStream(Index: Integer): boolean;
		1421	var
		1422	tmp: TZMPipe;
		1423	begin
		1424	Result := False;
		1425	if (Index >= 0) and (Index < count) then
		1426	begin
		1427	tmp := Pipe[Index];
		1428	if tmp.OwnsStream and (tmp.Stream <> nil) then
		1429	tmp.Stream := nil;
		1430	end;
		1431	end;
		1432
		1433	procedure TZMPipeListImp.SetCount(const Value: Integer);
		1434	var
		1435	I: Integer;
		1436	begin
		1437	if (Value <0) or (Value > MAX_PIPE) then
		1438	raise EZipMaster.CreateResInt(GE_RangeError, Value);
		1439	if Value > List.Count then
		1440	begin
		1441	I := List.Count;
		1442	while I < Value do
		1443	List.Add(nil);
		1444	end;
		1445	end;
		1446
		1447	procedure TZMPipeListImp.SetPipe(Index: Integer; const Value: TZMPipe);
		1448	var
		1449	tmpPipe: TZMPipeImp;
		1450	begin
		1451	if (Index <0) or (Index > MAX_PIPE) then
		1452	raise EZipMaster.CreateResInt(GE_RangeError, Index);
		1453	if Index >= List.Count then
		1454	List.Count := Index + 1;
		1455	if not (TObject(List[Index]) is TZMPipeImp) then
		1456	List[Index] := Value
		1457	else
		1458	begin
		1459	tmpPipe := TZMPipeImp(List[Index]);
		1460	if Value <> tmpPipe then
		1461	begin
		1462	tmpPipe.Free;
		1463	List[Index] := Value;
		1464	end;
		1465	end;
		1466	end;
		1467
		1468
		1469	end.

Subversion Repositories autosfx

autosfx/zmstr1900102/ZMCore19.pas – Rev 1