WebSVN – autosfx – Blame – /zmstr1900102/SFX/ZMSFXProcs19.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	(******************************************************************)
		2	(* SFX for DelZip v1.8 *)
		3	(* Copyright 1997, Microchip Systems / Carl Bunton *)
		4	(* e-mail: Twojags@cris.com *)
		5	(* Web-page: http://www.concentric.net/~twojags *)
		6	(* *)
		7	(* modified by Markus Stephany *)
		8	(* modified by Russell Peters, Roger Aelbrecht
		9	This library is free software; you can redistribute it and/or
		10	modify it under the terms of the GNU Lesser General Public
		11	License as published by the Free Software Foundation; either
		12	version 2.1 of the License, or (at your option) any later version.
		13
		14	This library is distributed in the hope that it will be useful,
		15	but WITHOUT ANY WARRANTY; without even the implied warranty of
		16	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
		17	Lesser General Public License (licence.txt) for more details.
		18
		19	You should have received a copy of the GNU Lesser General Public
		20	License along with this library; if not, write to the Free Software
		21	Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
		22
		23	contact: problems AT delphizip DOT org
		24	updates: http://www.delphizip.org
		25
		26	modified 2008-11-03
		27	---------------------------------------------------------------------------*)
		28	unit ZMSFXProcs19;
		29
		30	{
		31	this unit contains utility functions and main function used by delzipsfx
		32
		33	}
		34
		35	interface
		36
		37	{ modifications marked with ##FR are enhancements and bug fixes by
		38	Frank Reichert F.Rei@gmx.de, thanks!
		39
		40
		41
		42
		43
		44
		45	!!!!!!!!!!!!! spanning/multivolume support based on Roger Aelbrecht's BCB
		46	version of the sfx; thanks a lot Roger! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		47
		48
		49	}
		50
		51	uses Messages, Windows, ZMSFXDefs19, ZMSFXInt19, ZMSFXStrings19,
		52	{$ifdef DEBUG_SFX}
		53	SysUtils, // Run1,
		54	{$endif}
		55	ZMSFXStructs19;
		56
		57	// execute
		58	procedure Run;
		59
		60	// resize or move a control on the main dialog (or the dialog itself)
		61	// depending on the visibility of the files listview
		62	procedure ResizeControl(const wnd: HWND; const bReposition: boolean; yDiff: integer);
		63
		64	// enable/disable all child controls of the given window
		65	// except of progress bars
		66	procedure EnableChildren(const wnd: HWND; const bEnable: boolean);
		67
		68	// get the text for the run checkbox
		69	function GetRunCheckBoxText: string;
		70
		71	// get an error message if ExcuteCMD failed
		72	function GetRunErrorMessage: string;
		73
		74	// compare two strings / case insesitive
		75	function CompareText(const s1, s2: string): boolean;
		76
		77	// get an argument out of VStr_SFX_CmdLine
		78	function GetArgument(const iIndex: integer): string;
		79
		80	// check whether the file to execute is an .inf installation file
		81	function TestForInf(const sr1: string): boolean;
		82
		83	// format a string (replace '><' by args)
		84	function FmtStr1(const sFormat: string; const arg1: string): string;
		85	function FmtStrID1(id: integer; const arg1: string): string;
		86	function FmtStr2(const sFormat: string; const arg1, arg2: string): string;
		87	//function FmtStr3(const sFormat: string; const arg1, arg2, arg3: string): string;
		88	//function FmtStrID2(id: integer; const arg1, arg2: string): string;
		89
		90	// angus johnson, ajohnson@rpi.net.au
		91	// set the filetime of an extracted file to the value stored in the archive
		92	procedure FileSetDate(const hFile: THandle; const iAge: integer);
		93
		94	// unstore the current archive file / uncompressed
		95	procedure Unstore;
		96
		97	// force the existence of a directory (and its parents)
		98	function ForceDirectories(sDir: string): boolean; // RCV04
		99
		100	// change input file position
		101	function FSeek(const Offset: int64; const MoveMethod: word): int64; //##FR was procedure
		102
		103	// fill crc32 buffer
		104	procedure Crc32_Buf(str: PByte; len: integer; var crc: cardinal);
		105
		106	// handle relative paths, strip directory name
		107	function ExtractFileName(const sFileName: string): string;
		108
		109	// return the smaller value
		110	function Min(const I1, I2: longint): longint;
		111
		112	// ensure trailing backslash
		113	function AppendDirSeparator(const sDir: string): string; //##FR modified
		114
		115	// ensure NO trailing backslash
		116	function RemoveDirSeparator(const sDir: string): string;
		117
		118	// does the directory exist?
		119	function DirectoryExists(const sDir: string): boolean;
		120
		121	// does the file exist?
		122	function FileExists(const sFileName: string): boolean;
		123
		124	// extract the file's path
		125	function ExtractFilePath(const sFilename: string): string;
		126
		127	// replace environment vars by their contents
		128	function ExpandEnv(const Str: string): string;
		129
		130	// show a message box
		131	function MsgBox(const wndpar: HWND; const sMsg, sTitle: string;
		132	const uType: cardinal): integer;
		133
		134	// show an error message
		135	procedure ErrorMsgBox(const wndPar: HWND; const sMsg: string);
		136	procedure ErrorMsgBoxFmt1(const wndPar: HWND; id: integer; const arg1: string);
		137
		138	// read from input file
		139	function FRead(var Buffer; const cNum: cardinal): cardinal;
		140
		141	// read from a file and bail if not all data could be read
		142	procedure CheckFRead(var Buffer; const cNumBytes: cardinal);
		143
		144	// write to a file and bail if not all data could be written
		145	procedure CheckFWrite(const FH: THandle; const Buffer; const cNumBytes: cardinal;
		146	const FileName: string);
		147
		148
		149	// read TSFXFileHeader from input file
		150	procedure GetDefParams;
		151
		152	// execute the command-line read from the sfx header, if any
		153	function ExecuteCMD: cardinal;
		154
		155	// check password
		156	function decrypt_pw(Encrypt_Head: PAnsiChar; EncHead_len: byte; BitFlag: word;
		157	CRC, FileDate: longint; const sPassword: AnsiString): boolean;
		158
		159	// decrypt arcive contents
		160	function decrypt_byte: integer;
		161
		162	// Update the encryption keys with the next byte of plain text
		163	procedure UpdateKeys(c: byte);
		164
		165	// initially fill the crc table
		166	procedure Make_CRC32Table;
		167
		168	// from Angus Johnson's TZip-SFX code:
		169	// get the executable's file size to get rid of caring about the exe size
		170	function GetExeSize: cardinal;
		171
		172	// from Angus Johnson's TZip-SFX code:
		173	// fill the listview
		174	procedure FillListView(wndOwner: hWnd);
		175
		176	// fatal error, exit
		177	procedure ErrorHaltID(id: integer); overload;
		178	procedure ErrorHaltFmt(id: integer; const arg1: string);
		179	procedure ErrorHalt(const sMsg: string);
		180
		181	function Extract(wndOwner: hWnd): boolean;
		182
		183	function StrGetEditText(wndPar: HWND): string;
		184
		185
		186	// listview handling
		187	procedure AddFilesListViewCol(const wndDlg: HWND; const iIndex: integer;
		188	const szCaption: string; const iDirection, iWidth: integer);
		189
		190	procedure SelectAllInFilesListView(const wndDlg: HWND);
		191
		192	// get current directory
		193	function GetCurDir: string;
		194
		195	// add an entry to the list view
		196	procedure AddFileToList(const wndOwner: HWND; const sName: string;
		197	const Rec: TZ64CentralEntry; const IsDir: boolean);
		198	// const Rec: TZipCentralHeader; const IsDir: boolean);
		199
		200	procedure SetLangStrings(hLC: hWnd);
		201
		202	// return pointer to temporary buffer of at least size
		203	function GetXBuf(size: integer): pByte;
		204
		205	// dispatch windows messages
		206	procedure ProcessMessages;
		207
		208	// Int to Str
		209	function Int2Str(n: int64; wide: integer = -1): String;
		210
		211	// return the Detached name
		212	function DetachedName(const num: string): string;
		213
		214	function LoadResource(id: integer): Pointer;
		215
		216	// cleanup, free globals
		217	procedure Finish;
		218	//{$endif}
		219
		220	// check codepage of filename
		221	implementation
		222
		223	uses
		224	ZMSFXDialogs19, ZMSFXVars19, ZMSFXInflate19, ZMSFXWinTrust;//, SysUtils;
		225
		226	var
		227	xbuf: PByte = nil;
		228	xbufsize: integer = 0;
		229
		230	// return pointer to temporary buffer of at least size
		231	function GetXBuf(size: integer): pByte;
		232	begin
		233	if (xbuf <> nil) and (xbufsize > 0) and (size <= xbufsize) then
		234	begin
		235	// use the existing buffer
		236	Result := pByte(xbuf);
		237	Exit;
		238	end;
		239
		240	if (size > xbufsize) or (size < 0) or (xbuf = nil) or (xbufsize <= 0) then
		241	begin
		242	// clear old buf
		243	if xbuf <> nil then
		244	FreeMem(xbuf);
		245	xbuf := nil;
		246	xbufsize := 0;
		247	Result := nil;
		248	if size <= 0 then
		249	exit;
		250	end;
		251	xbufsize := succ(size or $3FF);
		252	GetMem(xbuf, xbufsize);
		253	Result := pByte(xbuf);
		254	if Result = nil then
		255	ErrorHalt('no memory'); // probably need error message
		256	end;
		257
		258	type
		259	TCharSet = set of AnsiChar;
		260	function CharInSet(c: Char; theSet: TCharSet): boolean;
		261	{$IFDEF UNICODE}
		262	var
		263	ac: AnsiChar;
		264	{$ENDIF}
		265	begin
		266	{$IFDEF UNICODE}
		267	Result := False;
		268	if c < HIGH(AnsiChar) then
		269	begin
		270	ac := AnsiChar(Ord(c) and $FF);
		271	Result := ac in theSet;
		272	end;
		273	{$ELSE}
		274	Result := c in theSet;
		275	{$ENDIF}
		276	end;
		277
		278	procedure BadArchive;
		279	begin
		280	ErrorHaltFmt(SFX_Err_Archive, VStr_ExeName);
		281	end;
		282
		283	// find extra data tag
		284	// IN x => extra data, size = length extra data
		285	// found x => tag data, size = data size, result = true
		286	// not found size = <= 0, result = true;
		287	function ExtraData(var x: pByte; var size: integer; tag: word): boolean;
		288	type
		289	TagHead = packed record
		290	tg: WORD;
		291	sz: WORD;
		292	end;
		293	pTagHead = ^TagHead;
		294	var
		295	hed: TagHead;
		296	begin
		297	Result := False;
		298	// size := 0;
		299	while size > (sizeof(TagHead) + 2) do
		300	begin
		301	hed := pTagHead(x)^;
		302	dec(size, sizeof(TagHead));
		303	if hed.tg = Tag then
		304	begin
		305	Result := hed.sz <= size;
		306	if Result then
		307	begin
		308	inc(x, sizeof(TagHead));
		309	size := hed.sz;
		310	end
		311	else
		312	size := -1; // invalid
		313	exit;
		314	end;
		315	dec(size, hed.sz);
		316	inc(x, hed.sz + sizeof(TagHead));
		317	end;
		318	size := 0;
		319	end;
		320
		321	(*----------------------------------------------------------------------------
		322	3.4.0.0 17 Oct 2007 RA new function check if EOC is needed
		323	*)
		324	function NeedEOC64(const EOC: TZipEndOfCentral): bool;
		325	begin
		326	Result := ((EOC.TotalEntries = MAX_WORD) or (EOC.CentralOffSet = MAX_UNSIGNED) or
		327	(EOC.CentralEntries = MAX_WORD) or (EOC.CentralSize = MAX_UNSIGNED) or
		328	(EOC.ThisDiskNo = MAX_WORD) or (EOC.CentralDiskNo = MAX_WORD));
		329	end;
		330
		331	(*----------------------------------------------------------------------------
		332	3.4.0.0 17 Oct 2007 RA new function locate and read EOC64
		333	result:= 0 = OK ; <0 error
		334	*)
		335	procedure GetEOC64(EOCOffset: word; var EOC64: TZipEOC64);
		336	var
		337	Posn: int64;
		338	Loc: TZip64EOCLocator;
		339	begin
		340	Posn := EOCOffset - SizeOf(TZip64EOCLocator);
		341	// TZip64EOCLocator Loc;
		342	if (Posn >= 0) then
		343	begin
		344	FSeek(Posn, FILE_BEGIN);
		345	if (FRead(Loc, SizeOf(TZip64EOCLocator)) <> SizeOf(TZip64EOCLocator)) then
		346	BadArchive;
		347	if (Loc.LocSig = ZipEOC64LocatorSig) then
		348	begin
		349	// locator found
		350	if (FSeek(int64(Loc.EOC64RelOfs), 0) < 0) then
		351	BadArchive;
		352	if (FRead(EOC64, SizeOf(TZipEOC64)) <> SizeOf(TZipEOC64)) then
		353	BadArchive;
		354	if (EOC64.EOC64Sig <> ZipEndCentral64Sig) then
		355	BadArchive;
		356	end;
		357	end;
		358	end;
		359
		360	(*----------------------------------------------------------------------------
		361	3.4.0.0 12 May 2007 RA new function
		362	copy CFH to Z64CFH and read Z64 data if needed
		363	*)
		364	procedure GetZ64Entry(const CFH: TZipCentralHeader; var Z64CFH: TZ64CentralEntry);
		365	var
		366	xlen: integer;
		367	p: pByte;
		368	wsz: word;
		369	begin
		370	Move(CFH.HeaderSig, Z64CFH.HeaderSig, 22); // copy headersig to crc32
		371	Z64CFH.FileNameLen := CFH.FileNameLen;
		372	Z64CFH.ExtraLen := CFH.ExtraLen;
		373	Z64CFH.FileComLen := CFH.FileComLen;
		374	Z64CFH.IntFileAtt := CFH.IntFileAtt;
		375	Z64CFH.ExtFileAtt := CFH.ExtFileAtt;
		376	Z64CFH.ComprSize := CFH.ComprSize; // values to be corrected for Z64
		377	Z64CFH.UnComprSize := CFH.UnComprSize;
		378	Z64CFH.RelOffLocal := CFH.RelOffLocal;
		379	Z64CFH.DiskStart := CFH.DiskStart;
		380	Z64CFH.MTime := 0;
		381	Z64CFH.ATime := 0;
		382	Z64CFH.CTime := 0;
		383	if CFH.ExtraLen = 0 then
		384	Exit; // no extra data
		385	// any ntfs stamps?
		386	xlen := CFH.ExtraLen;
		387	p := xbuf;
		388	// if ExtraData(p, xlen, NTFS_STAMP_TAG) and (xlen >= 24) then
		389	if ExtraData(p, xlen, NTFS_STAMP_TAG) and (xlen >= 32) then
		390	begin
		391	Inc(p, 4); // skip Reserved and find sub-tag 1
		392	if ExtraData(p, xlen, 1) and (xlen >= 24) then
		393	begin
		394	Z64CFH.MTime := PXNTFData(p)^.MTime;
		395	Z64CFH.ATime := PXNTFData(p)^.ATime;
		396	Z64CFH.CTime := PXNTFData(p)^.CTime;
		397	end;
		398	end;
		399	if (CFH.VersionNeed < 45) {or (CFH.ExtraLen = 0)} then
		400	Exit; // nocorrection needed
		401	if (CFH.UnComprSize <> MAX_UNSIGNED) and (CFH.ComprSize <> MAX_UNSIGNED) and
		402	(CFH.RelOffLocal <> MAX_UNSIGNED) and (CFH.DiskStart = MAX_WORD) then
		403	Exit; // not Zip64
		404	xlen := CFH.ExtraLen;
		405	p := xbuf;
		406	if not ExtraData(p, xlen, Zip64_data_tag) then
		407	BadArchive; // no Zip64 data
		408	wsz := xlen;
		409	if (CFH.UnComprSize = MAX_UNSIGNED) then
		410	begin
		411	if (wsz < 8) then
		412	BadArchive;
		413	Z64CFH.UnComprSize := pInt64(p)^;
		414	Inc(p, Sizeof(int64));
		415	wsz := wsz - word(SizeOf(int64));
		416	end;
		417	if (CFH.ComprSize = MAX_UNSIGNED) then
		418	begin
		419	if (wsz < 8) then
		420	BadArchive;
		421	Z64CFH.ComprSize := pInt64(p)^;
		422	Inc(p, Sizeof(int64));
		423	wsz := wsz - word(SizeOf(int64));
		424	end;
		425	if (CFH.RelOffLocal = MAX_UNSIGNED) then
		426	begin
		427	if (wsz < 8) then
		428	BadArchive;
		429	Z64CFH.RelOffLocal := pInt64(p)^;
		430	Inc(p, Sizeof(int64));
		431	wsz := wsz - word(SizeOf(int64));
		432	end;
		433	if (CFH.DiskStart = MAX_WORD) then
		434	begin
		435	if (wsz < 4) then
		436	BadArchive;
		437	Z64CFH.DiskStart := pInt64(p)^;
		438	end;
		439	end;
		440
		441	// return default Ansi codepage for locale
		442	function DefCP(LangID: integer): integer;
		443	var
		444	tmp: array[0..15] of char;
		445	i: integer;
		446	c: char;
		447	begin
		448	Result := 0;
		449	if GetLocaleInfo(LangID, LOCALE_IDEFAULTANSICODEPAGE, PChar(@tmp[0]), 6) <> 0 then
		450	begin
		451	Result := 0;
		452	i := 0;
		453	c := tmp[0];
		454	while CharInSet(c, ['0'..'9']) do
		455	begin
		456	Result := (Result * 10) + (ord(c)-ord('0'));
		457	inc(i);
		458	if i > 6 then
		459	break;
		460	c := tmp[i];
		461	end;
		462	end;
		463	end;
		464
		465	// set the filetime of an extracted file to the value stored in the archive
		466	procedure FileSetDate(const hFile: THandle; const iAge: integer);
		467	var
		468	LocalFileTime, FileTime: TFileTime;
		469	begin
		470	DosDateTimeToFileTime(HIWORD(iAge), LOWORD(iAge), LocalFileTime);
		471	LocalFileTimeToFileTime(LocalFileTime, FileTime);
		472	SetFileTime(hFile, nil, nil, @FileTime);
		473	end;
		474
		475	(--------------------------------------------------------------------------)
		476
		477	function UpdC32(Octet: byte; Crc: cardinal): cardinal;
		478	begin
		479	Result := VArr_CRC32Table[byte(Crc xor cardinal(Octet))] xor
		480	((Crc shr 8) and $00FFFFFF);
		481	end;
		482
		483	(--------------------------------------------------------------------------)
		484
		485	// fill crc32 buffer
		486
		487	procedure Crc32_Buf(str: PByte; len: integer; var crc: cardinal);
		488	begin
		489	while len > 0 do
		490	begin
		491	crc := UpdC32(byte(str^), crc);
		492	Inc(str);
		493	Dec(len);
		494	end;
		495	end;
		496
		497	(--------------------------------------------------------------------------)
		498
		499	// return the smaller value
		500
		501	function Min(const I1, I2: longint): longint;
		502	begin
		503	if I2 < I1 then
		504	Result := I2
		505	else
		506	Result := I1;
		507	end;
		508
		509	(--------------------------------------------------------------------------)
		510
		511	// unstore the current archive file / uncompressed
		512
		513	procedure Unstore;
		514	var
		515	c: cardinal;
		516	cNumBytes: TWriteFileWritten;
		517	OutBuf: PAnsiChar;
		518	begin
		519	GetMem(OutBuf, Min(VInt_BytesToGo, WSIZE) + 2);
		520	try
		521	while VInt_BytesToGo > 0 do
		522	begin
		523	cNumBytes := Min(VInt_BytesToGo, WSIZE);
		524	CheckFRead(OutBuf^, cNumBytes);
		525	Dec(VInt_BytesToGo, cNumBytes);
		526	if (VRec_ZipHeader.Flag and 1) = 1 then
		527	for c := 0 to cNumBytes - 1 do
		528	begin
		529	OutBuf[c] := AnsiChar(Byte(OutBuf[c]) xor decrypt_byte);
		530	{update_keys} UpdateKeys(byte(OutBuf[c]));
		531	end;
		532	CheckFWrite(VH_OutFile, OutBuf^, cNumBytes, VStr_OutFile);
		533	Crc32_Buf(PByte(outbuf), cNumBytes, VDW_CRC32Val);
		534	end;
		535	finally
		536	FreeMem(OutBuf);
		537	end;
		538	end;
		539
		540	(--------------------------------------------------------------------------)
		541
		542
		543	// change input file position
		544
		545	function FSeek(const Offset: int64; const MoveMethod: word): int64; //##FR
		546	{$IFDEF VERD6up}
		547	begin
		548	Result := FileSeek(VH_InFile, Offset, MoveMethod);
		549	end;
		550	{$ELSE}
		551	type
		552	I64Rec = packed record
		553	case integer of
		554	0: (I: int64);
		555	1: (Lo, Hi: cardinal);
		556	end;
		557	var
		558	r: I64Rec;
		559	begin
		560	r.I := Offset;
		561	r.Lo := SetFilePointer(VH_InFile, integer(r.Lo), @r.Hi, MoveMethod);
		562	if (r.Lo = cardinal(-1)) and (GetLastError <> 0) then
		563	r.I := -1;
		564	Result := r.i;
		565	end;
		566
		567	{$ENDIF}
		568	(--------------------------------------------------------------------------)
		569
		570	// read from input file
		571
		572	function FRead(var Buffer; const cNum: cardinal): cardinal;
		573	var
		574	dummy: TWriteFileWritten;
		575	begin
		576	if ReadFile(VH_InFile, Buffer, cNum, dummy, nil) then
		577	Result := dummy
		578	else
		579	Result := 0;
		580	end;
		581
		582	(--------------------------------------------------------------------------)
		583
		584
		585	// read from a file and bail if not all data could be read
		586
		587	procedure CheckFRead(var Buffer; const cNumBytes: cardinal);
		588	var
		589	Read: TWriteFileWritten;
		590	begin
		591	Read := 0;
		592
		593	if (not ReadFile(VH_InFile, Buffer, cNumBytes, Read, nil)) or
		594	(cardinal(Read) <> cNumBytes) then
		595	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		596	end;
		597
		598	(--------------------------------------------------------------------------)
		599
		600
		601	// write to a file and bail ifnot all data could be written
		602
		603	procedure CheckFWrite(const FH: THandle; const Buffer; const cNumBytes: cardinal;
		604	const FileName: string);
		605	var
		606	Written: TWriteFileWritten;
		607	begin
		608	Written := 0;
		609	// stop overrun
		610	if cNumBytes > VInt_MaxWrite then
		611	ErrorHaltFmt(SFX_Err_CannotWriteFile, FileName);
		612	// write to memory if file not open and address set
		613	if (FH = INVALID_HANDLE_VALUE) and (VP_SBuf <> nil) then
		614	begin
		615	Move(Buffer, VP_SBuf^, cNumBytes);
		616	Inc(VP_SBuf, cNumBytes);
		617	Written := cNumBytes;
		618	end
		619	else
		620
		621	// don't know why, but sometimes WriteFile returns FALSE though
		622	// all bytes have successfully been written, so do not check the API's result
		623	WriteFile(FH, Buffer, cNumBytes, Written, nil);
		624
		625	// seems to reliably show that all's ok or not
		626	if cardinal(Written) <> cNumBytes then
		627	ErrorHaltFmt(SFX_Err_CannotWriteFile, FileName);
		628	VInt_MaxWrite := VInt_MaxWrite - cNumBytes;
		629	end;
		630
		631	(--------------------------------------------------------------------------)
		632
		633
		634	// extract the file's path
		635	function ExtractFilePath(const sFilename: string): string;
		636	var
		637	i: integer;
		638	begin
		639	(* Handle archive relative paths *)
		640	i := Length(sFilename);
		641	if (i = 3) and (Pos(':', sFilename) > 0) then
		642	Result := sFilename
		643	else
		644	begin
		645	while (i > 0) and not CharInSet(sFilename[i], ['\', '/', ':']) do
		646	Dec(i);
		647	if i > 0 then
		648	begin
		649	if CharInSet(sFilename[i], ['\', '/']) then
		650	if i <> 3 then
		651	Dec(i)
		652	else
		653	if sFilename[2] <> ':' then
		654	Dec(i);
		655	end;
		656	Result := Copy(sFilename, 1, i);
		657	end;
		658	end;
		659
		660	(--------------------------------------------------------------------------)
		661
		662	// handle relative paths, strip directory name
		663
		664	function ExtractFileName(const sFileName: string): string;
		665	var
		666	I: integer;
		667	begin
		668	(* Handle archive relative paths *)
		669	I := Length(sFileName);
		670	while (I > 0) and not CharInSet(sFileName[I], ['\', '/', ':']) do
		671	Dec(I);
		672	Result := Copy(sFileName, I + 1, MaxInt);
		673	end;
		674
		675	(--------------------------------------------------------------------------)
		676
		677
		678	// does the directory exist?
		679	function DirectoryExists(const sDir: string): boolean;
		680	var
		681	Code: integer;
		682	begin
		683	Code := GetFileAttributes(PChar(sDir));
		684	Result := (Code <> -1) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0);
		685	end;
		686
		687	(--------------------------------------------------------------------------)
		688
		689	// does the file exist?
		690	function FileExists(const sFileName: string): boolean;
		691	var
		692	Code: Cardinal;
		693	begin
		694	Code := GetFileAttributes(PChar(sFileName));
		695	Result := (Code <> Cardinal(-1));
		696	end;
		697
		698	(--------------------------------------------------------------------------)
		699
		700	// force the existence of a directory (and its parents)
		701
		702	function ForceDirectories(sDir: string): boolean;
		703	begin
		704	Result := True;
		705	sDir := RemoveDirSeparator(sDir);
		706	if Length(sDir) = 0 then
		707	exit;
		708	if DirectoryExists(sDir) or (ExtractFilePath(sDir) = sDir) then
		709	Exit; // avoid 'xyz:\' problem.
		710	if not ForceDirectories(ExtractFilePath(sDir)) then
		711	Result := False
		712	else
		713	Result := CreateDirectory(PChar(sDir), nil);
		714	end;
		715
		716	(--------------------------------------------------------------------------)
		717
		718	// ensure trailing backslash
		719
		720	function AppendDirSeparator(const sDir: string): string; //##FR modified
		721	var
		722	i: integer;
		723	begin
		724	i := Length(sDir);
		725	Result := sDir;
		726	if i > 0 then
		727	if Result[i] <> Chr_DirSep then
		728	Result := Result + Chr_DirSep;
		729	end;
		730
		731	(--------------------------------------------------------------------------)
		732
		733	// ensure NO trailing backslash
		734
		735	function RemoveDirSeparator(const sDir: string): string;
		736	begin
		737	Result := sDir;
		738	while (Length(Result) > 0) and (Result[Length(Result)] = Chr_DirSep) do
		739	SetLength(Result, Length(Result) - 1);
		740	end;
		741
		742	(--------------------------------------------------------------------------)
		743
		744	// expand environment variables
		745
		746	function ExpandEnv(const Str: string): string;
		747	var
		748	pch: PChar;
		749	begin
		750	GetMem(pch, MAX_PATH * 2);
		751	try
		752	FillChar(pch^, MAX_PATH * 2, 0);
		753	if ExpandEnvironmentStrings(PChar(Str), pch, (MAX_PATH * 2) - 1) > 0 then
		754	Result := pch
		755	else
		756	Result := '';
		757	finally
		758	FreeMem(pch);
		759	end;
		760	end;
		761
		762	(--------------------------------------------------------------------------)
		763
		764	// show a message box
		765
		766	function MsgBox(const wndpar: HWND; const sMsg, sTitle: string;
		767	const uType: cardinal): integer;
		768	begin
		769	Result := MessageBox(wndPar, PChar(sMsg), PChar(sTitle), uType or MB_TASKMODAL);
		770	end;
		771
		772	(--------------------------------------------------------------------------)
		773	// show an error message
		774
		775	procedure ErrorMsgBox(const wndPar: HWND; const sMsg: string);
		776	begin
		777	MsgBox(wndPar, sMsg, PChar(SFXString(SFX_Cap_Err)), MB_ICONSTOP);
		778	end;
		779
		780	procedure ErrorMsgBoxFmt1(const wndPar: HWND; id: integer; const arg1: string);
		781	begin
		782	ErrorMsgBox(wndPar, FmtStrID1(id, arg1));
		783	end;
		784
		785	(--------------------------------------------------------------------------)
		786
		787	// compare two strings / case insensitive
		788
		789	function CompareText(const s1, s2: string): boolean;
		790	begin
		791	Result := (Length(s1) = Length(s2)) and (lstrcmpi(PChar(s1), PChar(s2)) = 0);
		792	end;
		793
		794	(--------------------------------------------------------------------------)
		795
		796	// to check correct file size of the input file +++ 08/13/98
		797
		798	function FindEOCRecord: cardinal;
		799	var
		800	pRec: PZipEndOfCentral;
		801	cBufferSize, cRead, cFilePos: cardinal;
		802	pBuffer: PAnsiChar;
		803	cCurrentPos: cardinal;
		804	c: cardinal;
		805	//loop counter only var for compiler optimization (register value) ##FR
		806	bOK: boolean;
		807	begin
		808	Result := HIGH(cardinal);
		809	// get the needed size of the buffer ( max 65536 + SizeOf( eocd ), min SizeOf( file ) )
		810	bOK := False;
		811	cBufferSize := GetFileSize(VH_InFile, nil) - cardinal(VInt_FileBegin);
		812	if cBufferSize > 65558 then
		813	cBufferSize := 65558;
		814
		815	if cBufferSize > sizeof(TZipEndOfCentral) then
		816	//if smaller, then no correct zip file
		817	begin
		818	GetMem(pBuffer, cBufferSize);
		819	try
		820	cCurrentPos := FSeek(0, FILE_CURRENT); //##FR mark the current file pos
		821	cFilePos := FSeek(-cBufferSize, FILE_END);
		822	//FSeek is now a function, not a proc, see sfxmisc.pas
		823	cRead := FRead(pBuffer[0], cBufferSize);
		824	FSeek(cCurrentPos, FILE_BEGIN); //##FR jump back to marked filepos
		825	if cRead = cBufferSize then
		826	for c := 0 to cBufferSize - sizeof(TZipEndOfCentral) do
		827	begin
		828	pRec := Pointer(cardinal(pBuffer) + c);
		829	if pRec^.HeaderSig = ZipEndOfCentralSig then
		830	begin
		831	// eocd is found, now check if size is correct ( = pos+22+eocd.commentsize)
		832	if (pRec^.ZipCommentLen + cFilePos + c +
		833	sizeof(TZipEndOfCentral)) = GetFileSize(VH_InFile, nil) then
		834	begin
		835	bOK := True; // set ok flag
		836	Result := cFilePos + c;
		837	Break;
		838	end;
		839	end;
		840	end;
		841	finally
		842	FreeMem(pBuffer);
		843	end;
		844	end;
		845
		846	if not bOK then
		847	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		848	end;
		849
		850	(--------------------------------------------------------------------------)
		851
		852	// get the index of a string in an array / case insensitive
		853
		854	function StrArrayIndexOf(s1: string; const args: array of string): integer;
		855	var
		856	i: integer;
		857	begin
		858	Result := -1;
		859	for i := Low(args) to High(args) do
		860	if CompareText(s1, args[i]) then
		861	begin
		862	Result := i;
		863	Break;
		864	end;
		865	end;
		866
		867	(--------------------------------------------------------------------------)
		868
		869	// read a sfx header string
		870	{$IFDEF UNICODE}
		871	procedure ReadSFXString(var sToRead: string; const iLen: integer);
		872	var
		873	utf8s: UTF8String;
		874	begin
		875	if iLen > 0 then
		876	begin
		877	SetLength(utf8s, iLen);
		878	CheckFRead(utf8s[1], iLen);
		879	end;
		880	sToRead := String(utf8s);
		881	end;
		882	{$ELSE}
		883	procedure ReadSFXString(var sToRead: string; const iLen: integer);
		884	begin
		885	if iLen > 0 then
		886	begin
		887	SetLength(sToRead, iLen);
		888	CheckFRead(sToRead[1], iLen);
		889	end;
		890	end;
		891	{$ENDIF}
		892
		893	(--------------------------------------------------------------------------)
		894
		895	// read a path from registry or return ''
		896	function GetPathFromRegistry(sPath: string): string;
		897	var
		898	sRoot, sValue, sSuffix, sData: string;
		899	i: integer;
		900	c: cardinal;
		901	hkRoot, hkOpen: HKEY;
		902	begin
		903	// format hkxy\reg path\value[\|suffix]
		904	Result := '';
		905	sRoot := '';
		906	sValue := '';
		907	sSuffix := '';
		908
		909	i := Pos(Chr_DirSep, sPath); // root\...
		910	if i > 0 then
		911	begin
		912	sRoot := Copy(sPath, 1, i - 1);
		913	Delete(sPath, 1, i);
		914	i := Pos('\|', sPath); // ...\|suffix
		915	if i > 0 then
		916	begin
		917	sSuffix := Copy(sPath, i + 1, MaxInt);
		918	Delete(sPath, i, MaxInt);
		919	end;
		920
		921	i := Length(sPath);
		922	while (i > 0) and (sPath[i] <> Chr_DirSep) do
		923	Dec(i);
		924	if (i > 0) and (i < Length(sPath)) then // ..\value
		925	begin
		926	sValue := Copy(sPath, i + 1, MaxInt);
		927	Delete(sPath, i, MaxInt);
		928	end;
		929
		930	case StrArrayIndexOf(sRoot, ['HKEY_CURRENT_USER', 'HKCU',
		931	'HKEY_LOCAL_MACHINE', 'HKLM', 'HKEY_USERS', 'HKU']) of
		932	0, 1: hkRoot := HKEY_CURRENT_USER;
		933	2, 3: hkRoot := HKEY_LOCAL_MACHINE;
		934	4, 5: hkRoot := HKEY_USERS;
		935	else
		936	hkRoot := 0;
		937	end;
		938	if (hkRoot <> 0) and (RegOpenKey(hkRoot, PChar(sPath), hkOpen) =
		939	ERROR_SUCCESS) then
		940	begin
		941	SetLength(sData, MAX_PATH * 2);
		942	c := Length(sData);
		943	if RegQueryValueEx(hkOpen, PChar(sValue), nil, nil, PByte(PChar(sData)),
		944	@c) = ERROR_SUCCESS then
		945	begin
		946	SetLength(sData, c - 1); // assumed to be reg_sz or reg_expand_sz
		947	i := Pos(';', sData);
		948	if i > 0 then
		949	Delete(sData, i, MaxInt);
		950	Result := AppendDirSeparator(PChar(sData)) + sSuffix;
		951	end;
		952	RegCloseKey(hkRoot);
		953	end;
		954	end;
		955	end;
		956
		957	(--------------------------------------------------------------------------)
		958
		959	// expand path to include drive
		960	function ExpandPath(const sRel: string): string;
		961	var
		962	p: PChar;
		963	begin
		964	SetLength(Result, MAX_PATH * 2);
		965	SetLength(Result, GetFullPathName(PChar(sRel), Length(Result), PChar(Result), p));
		966	end;
		967
		968	(--------------------------------------------------------------------------)
		969
		970	// build a volatile path name (sfx_<unique name>)
		971	function GetUniqueVolatilePath: string;
		972	var
		973	LStrDir: string;
		974	LIntLoop: integer;
		975	begin
		976	VBool_CheckDeleteVolatilePath := False;
		977	Result := AppendDirSeparator(ExpandEnv('%temp%')) + 'sfx';
		978	for LIntLoop := 0 to 99999 do // just 8 chars (dos conventions)
		979	begin
		980	LStrDir := Int2Str(LIntLoop, 0);
		981	LStrDir := Copy('0000', 1, 5 - Length(LStrDir)) + LStrDir;
		982	if not FileExists(Result + LStrDir) then
		983	begin
		984	Result := AppendDirSeparator(Result + LStrDir);
		985	VBool_CheckDeleteVolatilePath := True;
		986	VStr_VolatilePath := Result; // remember volatile path
		987	VStr_VolatilePath_Unexpanded := 'sfx' + LStrDir;
		988	Break;
		989	end;
		990	end;
		991	end;
		992
		993	(--------------------------------------------------------------------------)
		994	function PRIMARYLANGID(lang: LANGID): LANGID; inline;
		995	begin
		996	Result := WORD(lang) and $3FF;
		997	end;
		998
		999	procedure ClearLang(var dest: PByte);
		1000	begin
		1001	ReAllocMem(dest, 0);
		1002	VInt_CP := 0;
		1003	end;
		1004
		1005	// MaxCSize protects agains overruns on invalid data
		1006	function LoadStrings(var dest: PByte; MaxCSize: Integer): integer;
		1007	var
		1008	DHead: TSFXStringsData;
		1009	begin
		1010	// load strings
		1011	Result := 0;
		1012	ReAllocMem(dest, 0);
		1013	CheckFRead(DHead, sizeof(TSFXStringsData));
		1014	if DHead.CSize > MaxCSize then
		1015	Result := -1 // failed sanity check
		1016	else
		1017	begin
		1018	ReAllocMem(dest, DHead.USize + 4);
		1019	VP_SBuf := dest;
		1020	VDW_CRC32Val := CRC_MASK;
		1021	VInt_MaxWrite := DHead.USize;
		1022	VInt_BytesToGo := DHead.CSize;
		1023	InFlate(nil, 0);
		1024	end;
		1025	if (Result <> 0) or (DHead.CRC <> (VDW_CRC32Val xor $FFFFFFFF)) then
		1026	begin
		1027	ClearLang(dest);
		1028	Result := -1;
		1029	end;
		1030	end;
		1031
		1032
		1033	// Set language strings
		1034	procedure SetLangStrings(hLC: hWnd);
		1035	var
		1036	UILang: LANGID;
		1037	i, lng: integer;
		1038	idx: cardinal;
		1039	PHead: PSFX_LanguageData;
		1040	tmp: PChar;
		1041	begin
		1042	if (hLC = 0) {or (VRec_SHeader.Count < 1) or (pl = nil)} then
		1043	exit;
		1044	UILang := GetUserDefaultLangID;
		1045	idx := 0;
		1046
		1047	tmp := PChar(GetXBuf(256));
		1048	// add US (English) first
		1049	// if GetLocaleInfo($0409, LOCALE_SNATIVELANGNAME, tmp, 120) <> 0 then
		1050	// SendMessage(hLC, CB_ADDSTRING, 0, integer(tmp));
		1051	SendMessage(hLC, CB_ADDSTRING, 0, LPARAM(pChar('Default (US)')));
		1052	i := 1;
		1053	PHead := LoadResource(SFX_LANG_BASE + i);
		1054	while (PHead <> nil) and (PHead^.LangID <> 0) do
		1055	begin
		1056	lng := PHead^.LangID;
		1057	if GetLocaleInfo(Lng, LOCALE_SNATIVELANGNAME, tmp, 120) <> 0 then
		1058	begin
		1059	SendMessage(hLC, CB_ADDSTRING, 0, LPARAM(tmp));
		1060	if PRIMARYLANGID(lng) = PRIMARYLANGID(UILang) then
		1061	idx := i;
		1062	end;
		1063	inc(i);
		1064	PHead := LoadResource(SFX_LANG_BASE + i);
		1065	end;
		1066	SendMessage(hLC, CB_SETCURSEL, idx, 0); // set default
		1067	end;
		1068
		1069
		1070	function LoadLang(var dest: PByte; resID: integer): integer;
		1071	const
		1072	MaxCSize = 10000; // ???
		1073	var
		1074	PHead: PSFX_LanguageData;
		1075	p: PAnsiChar;
		1076	begin
		1077	// load selected strings
		1078	Result := 0;
		1079	ClearLang(dest);
		1080	if resID <= 0 then
		1081	exit; // use default
		1082	Result := -1;
		1083	PHead := LoadResource(resID);
		1084	if (PHead <> nil) and (PHead^.CSize < MaxCSize) then
		1085	begin
		1086	Result := PHead^.LangID;
		1087	VInt_CP := DefCP(Result);
		1088	ReAllocMem(dest, PHead.USize + 4);
		1089	VP_SBuf := dest;
		1090	VDW_CRC32Val := CRC_MASK;
		1091	VInt_MaxWrite := PHead.USize;
		1092	VInt_BytesToGo := PHead.CSize;
		1093	p := PAnsiChar(PHead);
		1094	inc(p, sizeof(TSFX_LanguageData)); // point to data
		1095	InFlate(p ,PHead.CSize);
		1096	end;
		1097	if (Result <= 0) or (PHead.CRC <> (VDW_CRC32Val xor $FFFFFFFF)) then
		1098	begin
		1099	ClearLang(dest);
		1100	Result := -1;
		1101	end;
		1102	VP_SBuf := nil;
		1103	end;
		1104
		1105	procedure SetLanguage;
		1106	var
		1107	Def: LANGID;
		1108	i, pri: integer;
		1109	psd: PSFX_LanguageData;
		1110	begin
		1111	VRec_Strings := nil;
		1112	// strings are optional
		1113	psd := LoadResource(SFX_LANG_BASE + 1);
		1114	if psd <> nil then
		1115	begin
		1116	// we have strings - load initial
		1117	pri := -1;
		1118	// try for 'default' language
		1119	Def := GetUserDefaultLangID;
		1120	if Def <> $0409 then
		1121	begin
		1122	i := 1;//0;
		1123	while psd <> nil do
		1124	begin
		1125	if psd^.LangID = Def then
		1126	break;
		1127	if (PRIMARYLANGID(psd^.LangID) = PRIMARYLANGID(Def)) then
		1128	pri := i;
		1129	inc(i);
		1130	psd := LoadResource(SFX_LANG_BASE + i); // try next
		1131	end;
		1132	if pri > 0 then
		1133	LoadLang(VRec_Strings, SFX_LANG_BASE + pri);
		1134	end;
		1135	// Display the dialog
		1136	if DialogBox(hInstance, Str_Dlg_Language, 0, @LanguageQueryDialogProc) =
		1137	ID_BTN_NO then
		1138	Halt;
		1139
		1140	// load selected strings
		1141	if (VInt_CurLang <> pri) then
		1142	begin
		1143	if (VInt_CurLang > 0) then
		1144	LoadLang(VRec_Strings, SFX_LANG_BASE + VInt_CurLang)
		1145	else
		1146	ClearLang(VRec_Strings);
		1147	end;
		1148	end;
		1149	VP_SBuf := nil;
		1150	end;
		1151
		1152	// Returns a boolean indicating whether or not we're running under XP or later.
		1153	function WinVersion: integer;
		1154	var
		1155	osv: TOSVERSIONINFO;
		1156	begin
		1157	osv.dwOSVersionInfoSize := sizeOf(OSVERSIONINFO);
		1158	GetVersionEx(osv);
		1159	Result := (osv.dwMajorVersion *1000) + osv.dwMinorVersion;
		1160	end;
		1161
		1162	// check manual override of AutoRun
		1163	function Manual: Boolean;
		1164	var
		1165	cp: PChar;
		1166	c0, c1, c2: Char;
		1167	begin
		1168	Result := False;
		1169	cp := GetCommandLine;
		1170	if cp = nil then
		1171	Exit;
		1172	c0 := #0;
		1173	c1 := #0;
		1174	c2 := #0;
		1175	while cp^ <> #0 do
		1176	begin
		1177	c0 := c1;
		1178	c1 := c2;
		1179	c2 := cp^;
		1180	cp := CharNext(cp);
		1181	end;
		1182	if c0 > ' ' then
		1183	Exit;
		1184	if c1 <> '/' then
		1185	Exit;
		1186	Result := (c2 = 'm') or (c2 = 'M');
		1187	end;
		1188
		1189	// read TSFXFileHeader from input file
		1190	procedure GetDefParams; // reads the values from the special header
		1191	type
		1192	T_DetachedArgs = packed record
		1193	Size: WORD; // size of full record including sig
		1194	Pads: WORD; // number of bytes to keep DWORD aligned
		1195	end;
		1196	var
		1197	Sig: cardinal;
		1198	CmdStrs: PByte;
		1199	PathSize: Integer;
		1200	StartMsgSize: Integer;
		1201	begin
		1202	CmdStrs := nil;
		1203	VInt_FileBegin := GetExeSize;
		1204	VP_SBuf := nil;
		1205	FSeek(VInt_FileBegin, FILE_BEGIN);
		1206
		1207	CheckFRead(VRec_SFXHeader, sizeof(VRec_SFXHeader));
		1208
		1209	with VRec_SFXHeader do
		1210	begin
		1211	if (Signature <> SFX_HEADER_SIG) then
		1212	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		1213	// get command strings
		1214	if (so_CompressedCmd and Options) <> 0 then
		1215	begin
		1216	if LoadStrings(CmdStrs, VRec_SFXHeader.Size - sizeof(VRec_SFXHeader)) <> 0 then
		1217	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		1218	VP_SBuf := nil;
		1219	FSeek(VInt_FileBegin + VRec_SFXHeader.Size, FILE_BEGIN);
		1220	end
		1221	else
		1222	begin
		1223	ReAllocMem(CmdStrs, size - sizeof(TSFXFileHeader));
		1224	CheckFRead(CmdStrs^, size - sizeof(TSFXFileHeader));
		1225	end;
		1226	// check for sfx header
		1227	VInt_SpanType := SFXSpanTypeNone; // default
		1228
		1229	VStr_SFX_Caption := LoadSFXStr(CmdStrs, sc_Caption);
		1230	if VStr_SFX_Caption = '' then
		1231	VStr_SFX_Caption := SFXString(SFX_Cap_App);
		1232
		1233	VStr_SFX_Path := LoadSFXStr(CmdStrs, sc_Path);
		1234	VStr_SFX_CmdLine := LoadSFXStr(CmdStrs, sc_CmdLine);
		1235	VStr_SFX_RegFailPath := LoadSFXStr(CmdStrs, sc_RegFailPath);
		1236	VStr_SFX_StartMsg := LoadSFXStr(CmdStrs, sc_StartMsg);
		1237	ReAllocMem(CmdStrs, 0); // finished with it
		1238	PathSize := Length(VStr_SFX_Path);
		1239	StartMsgSize := Length(VStr_SFX_StartMsg);
		1240
		1241	//get the path from registry, added 10/10/98 ##FR
		1242	if CompareText('HK', Copy(VStr_SFX_Path, 1, 2)) then
		1243	begin
		1244	VStr_SFX_Path := GetPathFromRegistry(VStr_SFX_Path);
		1245	if VStr_SFX_Path = '' then
		1246	begin
		1247	if VStr_SFX_RegFailPath <> '' then
		1248	VStr_SFX_Path := VStr_SFX_RegFailPath
		1249	else
		1250	VStr_SFX_Path := '><'; // substitue to temp path below
		1251	end;
		1252	end;
		1253
		1254	while Pos('><', VStr_SFX_Path) > 0 do
		1255	VStr_SFX_Path := FmtStr1(VStr_SFX_Path, AppendDirSeparator(ExpandEnv('%temp%')));
		1256
		1257	// added april 20, 2002: substitute environment variables
		1258	if (so_ExpandVariables and Options) <> 0 then
		1259	begin
		1260	VStr_SFX_Path := ExpandEnv(VStr_SFX_Path);
		1261	VStr_SFX_Caption := ExpandEnv(VStr_SFX_Caption);
		1262	VStr_SFX_StartMsg := ExpandEnv(VStr_SFX_StartMsg);
		1263	VStr_SFX_CmdLine := ExpandEnv(VStr_SFX_CmdLine);
		1264	end;
		1265
		1266	if PathSize = 0 then // Stored path
		1267	VStr_ExtractPath := GetCurDir
		1268	else
		1269	begin
		1270	// aug 26, 2002: added support for volatile extract directory
		1271	if CompareText(VStr_SFX_Path, '<VOLATILE>') then
		1272	VStr_ExtractPath := GetUniqueVolatilePath
		1273	else
		1274	VStr_ExtractPath := ExpandPath(VStr_SFX_Path);
		1275	end;
		1276
		1277	// shall we show the message ?
		1278	if (StartMsgSize > 0) and (MsgBox(0, VStr_SFX_StartMsg, VStr_SFX_Caption,
		1279	StartMsgType) in [idCancel, idAbort, idNo, IDCLOSE]) then
		1280	Halt;
		1281
		1282	// check autorun flag
		1283	if ((so_AutoRun or so_CheckAutoRunFileName) and Options) =
		1284	(so_AutoRun or so_CheckAutoRunFileName) then
		1285	begin
		1286	if ((WinVersion >= 6000) and (nvVerifyTrust(VStr_ExeName) <> 0)) or Manual or
		1287	(CompareText(ExtractFileName(VStr_ExeName), 'Setup.exe') or
		1288	(ExtractFileName(VStr_ExeName)[1] = '!')) then
		1289	Options := Options and (not so_AutoRun);
		1290	end;
		1291	end;
		1292
		1293	// at beginning of file or detached header
		1294	// might have detached header
		1295	CheckFRead(Sig, sizeof(Sig));
		1296	(*@@
		1297	if (Sig = SFX_DETACHED_HEADER_SIG) then
		1298	begin
		1299	// load detached name
		1300	CheckFRead(DetArgs, sizeof(DetArgs));
		1301	i := DetArgs.Size - SizeOf(TSFXDetachedHeader) - DetArgs.Pads;
		1302	ReadSFXString(VStr_DetachName, i);
		1303	// skip pads
		1304	if DetArgs.Pads > 0 then
		1305	FSeek(DetArgs.Pads, FILE_CURRENT);
		1306	CheckFRead(Sig, sizeof(Sig));
		1307	end;
		1308	*)
		1309	// check the signature following
		1310	if Sig = ZipCentralHeaderSig then
		1311	VInt_SpanType := SFXSpanTypeMultiVol; // is span but type unknown
		1312	// reposition to before local/central signature
		1313	VInt_FileBegin := FSeek(-sizeof(Sig), FILE_CURRENT);
		1314	end;
		1315
		1316	(--------------------------------------------------------------------------)
		1317
		1318	//// get operating system type (nt/win)
		1319	//function IsWinNT: boolean;
		1320	//var
		1321	// osvi: TOSVersionInfo;
		1322	//begin
		1323	// osvi.dwOSVersionInfoSize := SizeOf(OSvi);
		1324	// Result := GetVersionEx(OSVI) and (osvi.dwPlatformID = VER_PLATFORM_WIN32_NT);
		1325	//end;
		1326
		1327	(--------------------------------------------------------------------------)
		1328
		1329	//##FR execute inf-scripts using rundll, not nice but works!
		1330
		1331	function ExecInf(const Path: String): cardinal;
		1332	(*var
		1333	osvi: TOSVersionInfo;*)
		1334	//var
		1335	// cmd: AnsiString;
		1336	// HINSTANCE: HINST;
		1337	begin
		1338	// HINSTANCE
		1339	Result := ShellExecute(VH_MainWnd, PChar('open'), PChar('rundll32.exe'),
		1340	PChar('SetupApi,InstallHinfSection DefaultInstall 132 ' + Path),
		1341	nil, SW_SHOW);
		1342	// Result := HINSTANCE;// > 32;
		1343	(*if Param = '.ntx86' then Param := Param + ' '
		1344	else
		1345	Param := '';
		1346
		1347	if IsWinNT
		1348	then
		1349	Path := 'rundll32.exe setupapi.dll,
		1350	InstallHinfSection DefaultInstall' + Param + '132 ' + Path
		1351	else*)
		1352	// cmd := 'rundll.exe setupapi.dll,InstallHinfSection DefaultInstall 132 '
		1353	// + AnsiString(Path);
		1354	// Result := WinExec(PAnsiChar(cmd), SW_SHOW);
		1355	// Result := WinExec(PAnsiChar(
		1356	// 'rundll.exe setupapi.dll,InstallHinfSection DefaultInstall 132 '
		1357	// + Path), SW_SHOW);
		1358	(*osvi.dwOSVersionInfoSize := SizeOf(OSvi);
		1359	if GetVersionEx(OSVI) then
		1360	begin
		1361	case osvi.dwPlatformID of
		1362	VER_PLATFORM_WIN32_WINDOWS: Path :=
		1363	'rundll.exe setupx.dll,InstallHinfSection DefaultInstall 132 ' + Path;
		1364	VER_PLATFORM_WIN32_NT: Path :=
		1365	'rundll32.exe setupapi.dll,InstallHinfSection DefaultInstall' +
		1366	Param + '132 ' + Path;
		1367	else
		1368	// no win32 s
		1369	end;
		1370	Result := WinExec(PChar(Path), SW_SHOW);
		1371	end;*)
		1372
		1373	end;
		1374
		1375	(--------------------------------------------------------------------------)
		1376
		1377	function Trim(s: string): string;
		1378	// strip trailing #0 and double separators
		1379	begin
		1380	Result := PChar(s);
		1381	while Pos('\\', Result) > 0 do
		1382	Delete(Result, Pos('\\', Result), 1);
		1383	end;
		1384
		1385	(--------------------------------------------------------------------------)
		1386
		1387	// remove extract directory next time a user logs on
		1388
		1389	procedure RemoveDirEx;
		1390	var
		1391	LStrCmd: string;
		1392	LHKSub: HKEY;
		1393	LBoolSuccess: boolean;
		1394	begin
		1395	// if IsWinNT then
		1396	// if Win32Platform = VER_PLATFORM_WIN32_NT then
		1397	if WinVersion >= 5000 then
		1398	// the following does not work with all types of drives
		1399	(*LStrCmd := 'cmd.exe /c @if exist "'+RemoveDirSeparator(VStr_VolatilePath)+
		1400	'\nul" rd /s /q "'+RemoveDirSeparator(VStr_VolatilePath)+'"'*)
		1401	LStrCmd := 'cmd.exe /c @rd /s /q "%temp%\' + VStr_VolatilePath_Unexpanded + '">nul 2>nul'
		1402	else
		1403	// the following does not work with all types of drives
		1404	(*LStrCmd := 'command.com /c @if exist "'+RemoveDirSeparator(VStr_VolatilePath)+
		1405	'\nul" deltree /y "'+RemoveDirSeparator(VStr_VolatilePath)+'"';*)
		1406	LStrCmd := 'command.com /c deltree /y "%temp%\' + VStr_VolatilePath_Unexpanded + '">nul';
		1407
		1408	if RegCreateKey(HKEY_LOCAL_MACHINE,
		1409	'Software\Microsoft\Windows\CurrentVersion\RunOnce', LHKSub) = ERROR_SUCCESS then
		1410	begin
		1411	LBoolSuccess := RegSetValueEx(LHKSub, PChar(VStr_VolatilePath_Unexpanded),
		1412	0, REG_SZ, PChar(LStrCmd), Length(LStrCmd) + 1) = ERROR_SUCCESS;
		1413	RegCloseKey(LHKSub);
		1414	end
		1415	else
		1416	LBoolSuccess := False;
		1417
		1418	// try current user if not successfull
		1419	if (not LBoolSuccess) and (RegCreateKey(HKEY_CURRENT_USER,
		1420	'Software\Microsoft\Windows\CurrentVersion\RunOnce', LHKSub) =
		1421	ERROR_SUCCESS) then
		1422	begin
		1423	RegSetValueEx(LHKSub, PChar(VStr_VolatilePath_Unexpanded), 0,
		1424	REG_SZ, PChar(LStrCmd), Length(LStrCmd) + 1);
		1425	RegCloseKey(LHKSub);
		1426	end;
		1427	end;
		1428
		1429	(--------------------------------------------------------------------------)
		1430
		1431	//##FR modified to enable inf-scripts
		1432
		1433	function ExecuteCMD: cardinal;
		1434	// parses and executes the stored command line after extraction
		1435	var
		1436	sr1, sr2: string;
		1437	srOld: string;
		1438	begin
		1439	Result := 0;
		1440	sr1 := Trim(GetArgument(1));
		1441	sr2 := Trim(GetArgument(2));
		1442	srOld := GetCurDir;
		1443	if Length(VStr_ExtractPath) <> 0 then
		1444	ChDir(VStr_ExtractPath);
		1445	if Length(sr1) > 4 then
		1446	begin
		1447	if TestForInf(sr1) then
		1448	Result := ExecInf(sr1) //error if < 32
		1449	else
		1450	Result := ShellExecute(0, 'open', PChar(sr1), PChar(sr2),
		1451	PChar(VStr_ExtractPath), SW_SHOW);
		1452	end;
		1453	ChDir(srOld);
		1454	// aug 26, 2002: added support for volatile extract path
		1455	if (Result >= 32) and VBool_CheckDeleteVolatilePath and
		1456	CompareText(RemoveDirSeparator(VStr_VolatilePath),
		1457	RemoveDirSeparator(VStr_ExtractPath)) and
		1458	DirectoryExists(RemoveDirSeparator(VStr_VolatilePath)) then
		1459	RemoveDirEx;
		1460	end;
		1461
		1462	(--------------------------------------------------------------------------)
		1463
		1464
		1465	function FmtStrID1(id: integer; const arg1: string): string;
		1466	begin
		1467	Result := FmtStr1(SFXString(id), arg1);
		1468	end;
		1469
		1470	function FmtStr1(const sFormat: string; const arg1: string): string;
		1471	var
		1472	j: integer;
		1473	begin
		1474	Result := sFormat;
		1475	j := Pos('><', Result);
		1476	if j > 0 then
		1477	Result := Copy(Result, 1, j - 1) + arg1 + Copy(Result, j + 2, MaxInt);
		1478	end;
		1479
		1480	function FmtStr2(const sFormat: string; const arg1, arg2: string): string;
		1481	begin
		1482	Result := FmtStr1(FmtStr1(sFormat, arg1), arg2);
		1483	end;
		1484
		1485	(--------------------------------------------------------------------------)
		1486
		1487	function GetArgument(const iIndex: integer): string;
		1488	// gets an argument from the stored command line
		1489	// 1 : the part before the pipe (if there's no pipe,
		1490	// returns the whole command line)
		1491	// 2 : the part after the pipe (if no pipe, returns "")
		1492	// all "><" will be replaced by the extraction path
		1493	var
		1494	pip: integer;
		1495	begin
		1496	VStr_ExtractPath := AppendDirSeparator(VStr_ExtractPath);
		1497	Result := VStr_SFX_CmdLine;
		1498	pip := Pos('\|', Result);
		1499	if pip = 0 then
		1500	begin
		1501	if iIndex = 2 then
		1502	Result := '';
		1503	end
		1504	else
		1505	begin
		1506	if iIndex = 1 then
		1507	Result := Copy(Result, 1, pip - 1)
		1508	else
		1509	Result := Copy(Result, pip + 1, MAXINT);
		1510	end;
		1511
		1512	while Pos('><', Result) > 0 do
		1513	Result := FmtStr1(Result, VStr_ExtractPath);
		1514
		1515	// get the short (8+3)-filename (it seems that shellexecute has some problems with lfn)
		1516	GetShortPathName(PChar(Result), PChar(Result), Length(Result));
		1517	end;
		1518
		1519	(--------------------------------------------------------------------------)
		1520
		1521	function TestForInf(const sr1: string): boolean;
		1522	begin
		1523	Result := CompareText('.inf', Copy(sr1, Length(sr1) - 3, 4));
		1524	end;
		1525
		1526	(--------------------------------------------------------------------------)
		1527
		1528	function GetRunString(const sRun, sInst: string): string;
		1529	var
		1530	sr1: string;
		1531	begin
		1532	sr1 := ExtractFileName(GetArgument(1));
		1533	if TestForInf(sr1) then
		1534	Result := FmtStr2(sRun, sr1, ExtractFileName(GetArgument(2)))
		1535	else
		1536	begin
		1537	if sr1 = '' then
		1538	begin
		1539	sr1 := GetArgument(1);
		1540	if sr1 <> '' then
		1541	sr1 := ExtractFileName(RemoveDirSeparator(sr1));
		1542	end;
		1543	Result := FmtStr2(sInst, sr1, ExtractFileName(GetArgument(2)));
		1544	end;
		1545	end;
		1546
		1547	(--------------------------------------------------------------------------)
		1548
		1549	function GetRunCheckBoxText: string;
		1550	begin
		1551	Result := GetRunString(SFXString(SFX_Msg_RunCheckBox_Run),
		1552	SFXString(SFX_Msg_RunCheckBox_Inst));
		1553	end;
		1554
		1555	(--------------------------------------------------------------------------)
		1556
		1557	// get an error message if ExcuteCMD failed
		1558	function GetRunErrorMessage: string;
		1559	begin
		1560	Result := GetRunString(SFXString(SFX_Err_Run_Run), SFXString(SFX_Err_Run_Inst));
		1561	end;
		1562
		1563	(--------------------------------------------------------------------------)
		1564
		1565
		1566	procedure ProcessMessages;
		1567	var
		1568	Msg: TMsg;
		1569	begin
		1570	{ PeekMessage(Msg, 0, 0, 0, PM_REMOVE);
		1571	TranslateMessage(Msg);
		1572	DispatchMessage(Msg); }
		1573	while (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) do
		1574	begin
		1575	if not IsDialogMessage(0, msg) then
		1576	begin
		1577	TranslateMessage(msg);
		1578	DispatchMessage(msg);
		1579	end;
		1580	end;
		1581	end;
		1582
		1583	(--------------------------------------------------------------------------)
		1584
		1585	procedure Make_CRC32Table;
		1586	var
		1587	i, j: word;
		1588	r: cardinal;
		1589	const
		1590	CRCPOLY = $EDB88320;
		1591	UCHAR_MAX = 255;
		1592	CHAR_BIT = 8;
		1593	begin
		1594	for i := 0 to UCHAR_MAX do
		1595	begin
		1596	r := i;
		1597	for j := CHAR_BIT downto 1 do
		1598	if (r and 1) > 0 then
		1599	r := (r shr 1) xor CRCPOLY
		1600	else
		1601	r := r shr 1;
		1602	VArr_CRC32Table[i] := r;
		1603	end;
		1604	end;
		1605
		1606	(--------------------------------------------------------------------------)
		1607
		1608	// Update the encryption keys with the next byte of plain text
		1609
		1610	procedure UpdateKeys(c: byte);
		1611	begin
		1612	VArr_CryptKey[0] := UpdC32(c, VArr_CryptKey[0]);
		1613	VArr_CryptKey[1] := VArr_CryptKey[1] + VArr_CryptKey[0] and $000000FF;
		1614	VArr_CryptKey[1] := VArr_CryptKey[1] * 134775813 + 1;
		1615	VArr_CryptKey[2] := UpdC32(HIBYTE(HIWORD(VArr_CryptKey[1])), VArr_CryptKey[2]);
		1616	end;
		1617
		1618	(--------------------------------------------------------------------------)
		1619
		1620	// Initialize the encryption keys and the random header according to the given password.
		1621
		1622	procedure seedk(passwd: AnsiString);
		1623	var
		1624	i: byte;
		1625	begin
		1626	VArr_CryptKey[0] := 305419896;
		1627	VArr_CryptKey[1] := 591751049;
		1628	VArr_CryptKey[2] := 878082192;
		1629	for i := 1 to LENGTH(passwd) do
		1630	UpdateKeys(byte(passwd[i]));
		1631	end;
		1632
		1633	(--------------------------------------------------------------------------)
		1634
		1635	// Return the next byte in the pseudo-random sequence
		1636
		1637	function decrypt_byte: integer;
		1638	var
		1639	temp: word;
		1640	begin
		1641	temp := word(VArr_CryptKey[2] or 2);
		1642	Result := integer(word((temp * (temp xor 1)) shr 8) and $FF);
		1643	end;
		1644
		1645	(--------------------------------------------------------------------------)
		1646
		1647	function decrypt_pw(Encrypt_Head: PAnsiChar; EncHead_len: byte; BitFlag: word;
		1648	CRC, FileDate: longint; const sPassword: AnsiString): boolean;
		1649	var
		1650	i, c, b: byte;
		1651	begin
		1652	Result := False;
		1653	if sPassword = '' then
		1654	Exit;
		1655	seedk(sPassword);
		1656	for i := 0 to EncHead_len - 1 do
		1657	begin
		1658	c := byte(Encrypt_Head[i + EncHead_len]) xor decrypt_byte;
		1659	UpdateKeys(c);
		1660	Encrypt_Head[i] := AnsiChar(c);
		1661	end;
		1662
		1663	(* version 2.0+ *)
		1664	b := byte(Encrypt_Head[EncHead_len - 1]);
		1665
		1666	if not ((BitFlag and 8) = 8) then
		1667	begin
		1668	if b = HIBYTE(HIWORD(crc)) then
		1669	Result := True;
		1670	end
		1671	else
		1672	begin
		1673	if b = LOWORD(FileDate) shr 8 then
		1674	Result := True;
		1675	end;
		1676	end;
		1677
		1678	(--------------------------------------------------------------------------)
		1679
		1680	// added october 10, 1998
		1681	// enable/disable all children of the given parent window
		1682	// this is used to disable all main dialog's controls during archive extraction
		1683	// thanks to David - Kazuya david-kazuya@usa.net for report
		1684
		1685	procedure EnableChildren(const wnd: HWND; const bEnable: boolean);
		1686
		1687	function FindChE(wnd: HWND; lParam: LPARAM): Bool; stdcall;
		1688	var
		1689	pCH: array[0..64] of char;
		1690	begin
		1691	Result := True;
		1692	GetClassName(wnd, @pCH, 63);
		1693	if IsWindowVisible(wnd) and (pCH <> 'msctls_progress32') then
		1694	EnableWindow(wnd, boolean(lParam));
		1695	end;
		1696
		1697	begin
		1698	EnumChildWindows(wnd, @FindChE, integer(bEnable));
		1699	end;
		1700
		1701	(--------------------------------------------------------------------------)
		1702
		1703	// resize dialog/control
		1704
		1705	procedure ResizeControl(const wnd: HWND; const bReposition: boolean; yDiff: integer);
		1706	var
		1707	pl: TWindowPlacement;
		1708	begin
		1709	yDiff := MulDiv(yDiff, HIWORD(GetDialogBaseUnits), 8);
		1710	pl.length := sizeof(pl);
		1711	GetWindowPlacement(wnd, @pl);
		1712	if bReposition then
		1713	pl.rcNormalPosition.Top :=
		1714	pl.rcNormalPosition.Top + yDiff;
		1715	pl.rcNormalPosition.Bottom := pl.rcNormalPosition.Bottom + yDiff;
		1716	SetWindowPlacement(wnd, @pl);
		1717	end;
		1718
		1719	(--------------------------------------------------------------------------)
		1720
		1721	// from Angus Johnson's TZip-SFX code:
		1722	// get the executable's file size to get rid of caring about the exe size
		1723	function GetExeSize: cardinal;
		1724	{$ifdef DEBUG_SFX}
		1725	begin
		1726	Result := Test_Stub_Size;
		1727	end;
		1728	{$else}
		1729	var
		1730	p: PByte;
		1731	i, NumSections: integer;
		1732	const
		1733	IMAGE_PE_SIGNATURE = $00004550;
		1734	begin
		1735	Result := 0;
		1736	p := pointer(hinstance);
		1737	if (PImageDosHeader(p).e_magic <> IMAGE_DOS_SIGNATURE) then
		1738	exit;
		1739	Inc(p, PImageDosHeader(p)._lfanew);
		1740	if (PCardinal(p)^ <> IMAGE_PE_SIGNATURE) then
		1741	exit;
		1742	Inc(p, sizeof(cardinal));
		1743	NumSections := PImageFileHeader(p).NumberOfSections;
		1744	Inc(p, sizeof(TImageFileHeader) + sizeof(TImageOptionalHeader));
		1745	for i := 1 to NumSections do
		1746	begin
		1747	with PImageSectionHeader(p)^ do
		1748	if PointerToRawData + SizeOfRawData > Result then
		1749	Result := PointerToRawData + SizeOfRawData;
		1750	Inc(p, sizeof(TImageSectionHeader));
		1751	end;
		1752	end;
		1753	{$endif}
		1754	(--------------------------------------------------------------------------)
		1755
		1756	const
		1757	MAX_IDX = ($80000000 div sizeof(TZ64CentralEntry)) - 1; // 2G storage limit
		1758	// storage for records in list view
		1759	type
		1760	PCentralRecords = ^TCentralRecords;
		1761	TCentralRecords = packed array[0..MAX_IDX] of TZ64CentralEntry;
		1762
		1763	var
		1764	p_Items: PCentralRecords = nil;
		1765	cb_Items: cardinal = 0;
		1766
		1767	function AddToItemData(const rec: TZ64CentralEntry): cardinal;
		1768	begin
		1769	if (cb_Items and 63) = 0 then
		1770	ReAllocMem(p_Items, sizeof(TZ64CentralEntry) * (cb_Items + 64));
		1771
		1772	Inc(cb_Items);
		1773	p_Items^[cb_Items - 1] := rec;
		1774	Result := cb_Items - 1;
		1775	end;
		1776
		1777	// add an entry to the list view
		1778	procedure AddFileToList(const wndOwner: HWND; const sName: string;
		1779	const Rec: TZ64CentralEntry; const IsDir: boolean);
		1780	var
		1781	recItem: TLVItem;
		1782	wndLV: HWND;
		1783	iiItem: integer;
		1784	sfi: TSHFileInfo;
		1785	s: string;
		1786	begin
		1787	wndLV := GetDlgItem(wndOwner, ID_LV_FILES);
		1788	if not IsDir then
		1789	SHGetFileInfo(PChar(ExtractFileName(sName)), FILE_ATTRIBUTE_NORMAL, sfi,
		1790	sizeof(sfi), SHGFI_USEFILEATTRIBUTES or SHGFI_SMALLICON or SHGFI_SYSICONINDEX)
		1791	else
		1792	SHGetFileInfo(PChar(ExtractFileName(RemoveDirSeparator(sName))),
		1793	FILE_ATTRIBUTE_DIRECTORY, sfi, sizeof(sfi), SHGFI_USEFILEATTRIBUTES or
		1794	SHGFI_SMALLICON or SHGFI_SYSICONINDEX);
		1795
		1796	with recItem do
		1797	begin
		1798	mask := LVIF_TEXT or LVIF_PARAM or LVIF_STATE or LVIF_IMAGE;
		1799	iItem := MaxInt;
		1800	iSubItem := 0;
		1801	// select only if no file selection is allowed (just for visual feedback)
		1802	if (so_AskFiles and VRec_SFXHeader.Options) = 0 then
		1803	state := 0
		1804	else
		1805	state := LVIS_SELECTED;
		1806	stateMask := LVIS_SELECTED;
		1807	pszText := PChar(sName);
		1808	cchTextMax := Length(sName);
		1809	iImage := sfi.iIcon;
		1810	lParam := AddToItemData(Rec);
		1811	end;
		1812	iiItem := SendMessage(wndLV, LVM_INSERTITEM, 0, integer(@recItem));
		1813
		1814	with recItem do
		1815	begin
		1816	mask := LVIF_TEXT;// or LVIF_PARAM;
		1817	iItem := iiItem;
		1818	iSubItem := 1;
		1819	s := Int2Str(Rec.UnComprSize, 0);
		1820	pszText := PChar(s);
		1821	cchTextMax := Length(s);
		1822	end;
		1823	SendMessage(wndLV, LVM_SETITEM, 0, integer(@recItem));
		1824	end;
		1825
		1826	(--------------------------------------------------------------------------)
		1827
		1828	// retrieve an item from the list
		1829	function GetFileFromList(const wndOwner: HWND; const iiItem: integer;
		1830	var Rec: TZ64CentralEntry): string;
		1831	var
		1832	Item: TLVItem;
		1833	wndLV: HWND;
		1834	szBuf: array[0..MAX_PATH * 2] of char;
		1835	begin
		1836	wndLV := GetDlgItem(wndOwner, ID_LV_FILES);
		1837
		1838	// get lparam stored in routine above
		1839	with Item do
		1840	begin
		1841	iItem := iiItem;
		1842	iSubItem := 0;
		1843	mask := LVIF_PARAM;
		1844	end;
		1845	SendMessage(wndLV, LVM_GETITEM, 0, integer(@Item));
		1846	Rec := p_Items^[Item.lParam];
		1847
		1848	// path+file
		1849	with Item do
		1850	begin
		1851	iItem := iiItem;
		1852	iSubItem := 0;
		1853	mask := LVIF_TEXT;
		1854	pszText := @szBuf;
		1855	cchTextMax := sizeof(szBuf);
		1856	end;
		1857	SetString(Result, Item.pszText, SendMessage(wndLV, LVM_GETITEMTEXT,
		1858	iiItem, integer(@Item)));
		1859	end;
		1860
		1861	(--------------------------------------------------------------------------)
		1862
		1863	procedure DeSelectInFilesListView(const wndDlg: HWND; const iItem: integer);
		1864	var
		1865	Item: TLVItem;
		1866	begin
		1867	with Item do
		1868	begin
		1869	stateMask := LVIS_SELECTED;
		1870	state := 0;
		1871	end;
		1872	SendDlgItemMessage(wndDlg, ID_LV_FILES, LVM_SETITEMSTATE, iItem, longint(@Item));
		1873	end;
		1874
		1875	(--------------------------------------------------------------------------)
		1876
		1877	// may 11, 2002: show first selected item on extraction failure
		1878	procedure ShowFirstSelected(const wndList: HWND);
		1879	var
		1880	i: integer;
		1881	begin
		1882	for i := 0 to Pred(SendMessage(wndList, LVM_GETITEMCOUNT, 0, 0)) do
		1883	if SendMessage(wndList, LVM_GETITEMSTATE, i, LVIS_SELECTED) = LVIS_SELECTED then
		1884	begin
		1885	SendMessage(wndList, LVM_ENSUREVISIBLE, i, integer(False));
		1886	Break;
		1887	end;
		1888	end;
		1889
		1890	// check whether spanned or multivol archive
		1891	procedure CheckSpan;
		1892	var
		1893	len: integer;
		1894	sName: string;
		1895	begin
		1896	// prepare name using defaults unless supplied
		1897	if VStr_DetachName = '' then
		1898	VStr_DetachName := ExtractFileName(VStr_ExeName);
		1899	len := Length(VStr_DetachName);
		1900	while (len > 0) and (VStr_DetachName[len] <> '.') do
		1901	dec(len);
		1902	if (len > 0) then
		1903	begin
		1904	if VInt_SpanType = SFXSpanTypeUnknown then
		1905	VStr_DetachExt := Copy(VStr_DetachName, len, 255)
		1906	else
		1907	VStr_DetachExt := '.zip';
		1908	VStr_DetachName := Copy(VStr_DetachName, 1, len -1);
		1909	end
		1910	else
		1911	VStr_DetachExt := '.zip';
		1912	VStr_DetachName := AppendDirSeparator(ExtractFilePath(VStr_ExeName)) +
		1913	VStr_DetachName;
		1914	VInt_SpanType := SFXSpanTypeMultiVol;
		1915	VStr_SourceDir := AppendDirSeparator(ExtractFilePath(VStr_ExeName));
		1916	if VStr_SourceDir = '' then
		1917	begin
		1918	len := GetCurrentDirectory(0, nil);
		1919	if len > 0 then
		1920	begin
		1921	SetLength(sName, len + 5);
		1922	GetCurrentDirectory(len + 2, pChar(sName));
		1923	VStr_SourceDir := AppendDirSeparator(pChar(sName));
		1924	end;
		1925	end;
		1926	VBool_FixedDrive := GetDriveType(PChar(VStr_SourceDir)) in
		1927	[DRIVE_FIXED, DRIVE_REMOTE, DRIVE_RAMDISK];
		1928	if not VBool_FixedDrive then
		1929	begin
		1930	sName := DetachedName('001');
		1931	if not FileExists(sName) then
		1932	VInt_SpanType := SFXSpanTypeSpanned;
		1933	end;
		1934	end;
		1935
		1936	(*----------------------------------------------------------------------------
		1937	3.3.1.0 11 Aug 2007 RA difference for dir and nondir in AddFileTo List addded
		1938	3.3.0.0 24 Jan 2006 RA soCreateEmptyDirs added
		1939	fill the list view
		1940	*)
		1941	procedure FillListView(wndOwner: hWnd);
		1942	type
		1943	PUString_Data = ^UString_Data;
		1944	UString_Data = packed record
		1945	// tag: word;
		1946	// totsiz: word;
		1947	version: byte;
		1948	origcrc: DWORD;
		1949	end;
		1950	const
		1951	PKZIPW25: Integer = 25;//(FS_FAT * 256) + 25;
		1952	PKZIPW26 = 26;//(FS_FAT * 256) + 26;
		1953	PKZIPW40 = 40;//(FS_FAT * 256) + 40;
		1954	UNIXATTRS = $FFFF0000;
		1955	WZIP = $0B32;//(FS_NTFS * 256) + 50;
		1956	// FS_FAT: Integer = 0;
		1957	// FS_HPFS: Integer = 6;
		1958	// FS_NTFS: Integer = 11;
		1959	// FLAG_UTF8_BIT = $1000;
		1960	var
		1961	eoc: TZipEndOfCentral;
		1962	i, j: cardinal;
		1963	cfh: TZipCentralHeader;
		1964	buffer: array [0..MAX_PATH + 2] of AnsiChar;
		1965	fn: string;
		1966	p: PByte;
		1967	x: integer;
		1968	fnp: PAnsiChar; // source filename pointer;
		1969	fnsz: integer; // source filename size
		1970	fncp: integer; // source filename codepage
		1971
		1972	EOC64: TZipEOC64;
		1973	Z64CFH: TZ64CentralEntry;
		1974	EocPos, CenSize, TotalEntries: int64;
		1975	HasEoc64: boolean;
		1976	over, sz: integer;
		1977	crc: cardinal;
		1978	pp: PUString_Data;
		1979	BadName: boolean;
		1980	hasUPath: Boolean;
		1981	begin
		1982	EocPos := FSeek(FindEOCRecord, FILE_BEGIN);
		1983
		1984	CheckFRead(eoc, sizeof(eoc));
		1985	HasEoc64 := NeedEOC64(EOC);
		1986	if (HasEoc64) then
		1987	GetEOC64(EocPos, EOC64);
		1988	//how far out the header offsets are from reality (due to sfx stub)
		1989	if HasEoc64 and (EOC.CentralSize = MAX_UNSIGNED) then
		1990	censize := EOC64.CentralSize
		1991	else
		1992	censize := EOC.CentralSize;// EOC64.CentralSize : EOC.CentralSize;
		1993	VDW_OffsetDelta := EocPos - censize;
		1994	if HasEoc64 and (EOC.CentralOffSet = MAX_UNSIGNED) then
		1995	VDW_OffsetDelta := VDW_OffsetDelta - EOC64.CentralOffSet
		1996	else
		1997	VDW_OffsetDelta := VDW_OffsetDelta - EOC.CentralOffSet;
		1998	if (HasEoc64) then
		1999	VDW_OffsetDelta := VDW_OffsetDelta - EOC64.vsize + 12 + SizeOf(TZip64EOCLocator);
		2000	if HasEOC64 then
		2001	censize := censize + EOC64.vsize + 12
		2002	else
		2003	censize := censize + SizeOf(EOC);
		2004	FSeek(-censize, FILE_CURRENT);
		2005	TotalEntries := EOC.TotalEntries;
		2006	if (HasEoc64 and (TotalEntries = MAX_WORD)) then
		2007	TotalEntries := EOC64.TotalEntries;
		2008
		2009	// is it multi-disk
		2010	if EOC.ThisDiskNo <> 0 then
		2011	CheckSpan;
		2012
		2013	//how far out the header offsets are from reality (due to sfx stub)
		2014	for i := 0 to TotalEntries - 1 do
		2015	begin
		2016	CheckFRead(cfh, sizeof(cfh));
		2017	if (cfh.HeaderSig <> ZipCentralHeaderSig) or (cfh.FileNameLen = 0) or
		2018	(cfh.FileNameLen > 500) then
		2019	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		2020
		2021	CheckFRead(buffer[0], cfh.FileNameLen);
		2022	buffer[cfh.FileNameLen] := #0;
		2023	// read extra data
		2024	p := nil;
		2025	over := 0;
		2026	x := cfh.ExtraLen;
		2027	if x > 0 then
		2028	begin
		2029	if x > 2048 then
		2030	begin
		2031	over := 2048 - x;
		2032	x := 2048;
		2033	end;
		2034	p := GetXBuf(x);
		2035	if p <> nil then
		2036	xbuf^ := 0;
		2037	if x > 0 then
		2038	CheckFRead(p^, x);
		2039	end;
		2040	GetZ64Entry(cfh, Z64cfh);
		2041	BadName := false;
		2042	fnp := PAnsiChar(@buffer[0]); // filename source
		2043	fnsz := cfh.FileNameLen;//-1; // filename source length
		2044	fncp := 0;
		2045	hasUPath := False;
		2046
		2047	if (p <> nil) and (cfh.VersionMadeBy0 >= 20) then
		2048	begin
		2049	sz := cfh.ExtraLen;
		2050	if ExtraData(p, sz, UPath_Data_Tag) and
		2051	(sz > sizeof(UString_Data)) then
		2052	begin
		2053	pp := PUString_Data(p);;
		2054	crc := $FFFFFFFF;
		2055	Crc32_Buf(@buffer[0], cfh.FileNameLen, crc);
		2056	crc := crc xor $FFFFFFFF;
		2057	if (pp^.version = 1) and (crc = pp^.origcrc) then
		2058	begin
		2059	sz := sz - sizeof(UString_Data);
		2060	inc(p, sizeof(UString_Data));
		2061	if sz > 0 then
		2062	begin
		2063	fnp := PAnsiChar(p);
		2064	fnsz := sz;
		2065	fncp := CP_UTF8;
		2066	hasUPath := True;
		2067	end;
		2068	end;
		2069	end;
		2070	end;
		2071
		2072	if not hasUPath then
		2073	begin
		2074	fncp := CP_ACP;
		2075	if (cfh.Flag and FLAG_UTF8_BIT) <> 0 then
		2076	fncp := CP_UTF8
		2077	else
		2078	begin
		2079	if (cfh.VersionMadeBy1 = FS_FAT) or
		2080	(cfh.VersionMadeBy1 = FS_HPFS) or
		2081	((cfh.VersionMadeBy1 = FS_NTFS) and (cfh.VersionMadeBy0 = 50)) then
		2082	fncp := CP_OEMCP;
		2083	end;
		2084	end;
		2085
		2086	fn := To_Str(fncp, fnp, fnsz, true, BadName);
		2087	//swap slashes and get last char ...
		2088	for J := 1 to Length(fn) do
		2089	begin
		2090	if fn[j] = '/' then
		2091	fn[j] := Chr_DirSep;
		2092	if fn[j] = '?' then
		2093	BadName := True;
		2094	end;
		2095
		2096	if BadName then
		2097	begin
		2098	fn := SFXString(SFX_Err_InvalidFileName) + ' "' + fn + '"';
		2099	x := MessageBox(wndOwner, pChar(fn), PChar(SFXString(SFX_Cap_Err)),
		2100	MB_OKCANCEL or MB_ICONSTOP or MB_TASKMODAL);
		2101	if x = IDOK then
		2102	continue;
		2103	break;
		2104	end;
		2105
		2106	// skip directory entries
		2107	if fn[Length(fn)] <> Chr_DirSep then
		2108	begin
		2109	//store each filename and absolute file offset of cfh record ...
		2110	AddFileToList(wndOwner, fn, Z64cfh, False);
		2111	end
		2112	else
		2113	// new 09/19/2005, recreate empty directories
		2114	if (so_CreateEmptyDirs and VRec_SFXHeader.Options) <> 0 then
		2115	AddFileToList(wndOwner, fn, Z64cfh, True);
		2116
		2117	if (over + cfh.FileComLen) <> 0 then
		2118	FSeek(over + cfh.FileComLen, FILE_CURRENT);
		2119	end;
		2120
		2121	end;
		2122
		2123	(--------------------------------------------------------------------------)
		2124
		2125	// close a handle, if not already closed
		2126	function CheckCloseHandle(var H: THandle): boolean;
		2127	begin
		2128	if (H <> 0) and (H <> INVALID_HANDLE_VALUE) then
		2129	Result := CloseHandle(H)
		2130	else
		2131	Result := True;
		2132	H := INVALID_HANDLE_VALUE;
		2133	end;
		2134
		2135	// create a 00x number string
		2136	procedure Str_3(const i: integer; var S: string);
		2137	begin
		2138	S := Int2Str(i, 3);
		2139	// Str(i, S);
		2140	// while Length(s) < 3 do
		2141	// s := '0' + s;
		2142	end;
		2143
		2144	function IsRightDisk(DiskSeq: integer): boolean;
		2145	var
		2146	SSeq: string;
		2147	Dummy1, Dummy2, DiskSerial: cardinal;
		2148	VolName: array[0..MAX_PATH] of char;
		2149	sTemp: string;
		2150	begin
		2151	Result := DiskSeq = VInt_LastSeq;
		2152	if Result then
		2153	exit;
		2154	Str_3(DiskSeq + 1, SSeq);
		2155	if VInt_SpanType = SFXSpanTypeSpanned then
		2156	begin
		2157	// get volume info
		2158	GetVolumeInformation(PChar(VStr_SourceDir), VolName, MAX_PATH, @DiskSerial, Dummy1,
		2159	Dummy2, nil, 0);
		2160	STemp := VolName;
		2161	// must be pkback# 00x
		2162	Result := CompareText(STemp, 'PKBACK# ' + SSeq);
		2163	if Result and (not CompareText(VStr_ExeName, DetachedName(''))) then
		2164	begin
		2165	if not CheckCloseHandle(VH_InFile) then
		2166	ErrorHaltFmt(SFX_Err_CannotCloseFile, VStr_ExeName);
		2167	VStr_ExeName := DetachedName(''); // use detached name
		2168	// Open the input archive on this disk.
		2169	VH_Infile := CreateFile(PChar(VStr_ExeName), GENERIC_READ,
		2170	FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
		2171	if VH_Infile = INVALID_HANDLE_VALUE then
		2172	ErrorHaltFmt(SFX_Err_CannotOpenFile, VStr_ExeName);
		2173	// assume no shifted offset on detached archives
		2174	VDW_OffsetDelta := 0;
		2175	end;
		2176	end
		2177	else
		2178	begin
		2179	// multi volume, filename = xyz00x.(xyz) and Actual File
		2180	Result := CompareText(VStr_ExeName, DetachedName(SSeq));
		2181	end;
		2182	end;
		2183
		2184	procedure GetNewDisk(wndOwner: HWND; DiskSeq: integer);
		2185	var
		2186	SSeq: string;
		2187	begin
		2188	if not CheckCloseHandle(VH_InFile) then
		2189	ErrorHaltFmt(SFX_Err_CannotCloseFile, VStr_ExeName);
		2190
		2191	Str_3(DiskSeq + 1, SSeq);
		2192	repeat
		2193	if not VBool_FixedDrive then
		2194	begin
		2195	if MsgBox(wndOwner, FmtStr2(SFXString(SFX_Msg_InsertDiskVolume),
		2196	SSeq, VStr_SourceDir), VStr_SFX_Caption, MB_OKCANCEL) = idCancel then
		2197	ErrorHalt('');
		2198	end;
		2199
		2200	if VInt_SpanType = SFXSpanTypeMultiVol then
		2201	VStr_ExeName := DetachedName(SSeq)
		2202	else
		2203	VStr_ExeName := DetachedName('');
		2204	until IsRightDisk(DiskSeq);
		2205
		2206	// Open the input archive on this disk.
		2207	VH_Infile := CreateFile(PChar(VStr_ExeName), GENERIC_READ, FILE_SHARE_READ,
		2208	nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
		2209	if VH_Infile = INVALID_HANDLE_VALUE then
		2210	ErrorHaltFmt(SFX_Err_CannotOpenFile, VStr_ExeName);
		2211	// assume no shifted offset on detached archives
		2212	VDW_OffsetDelta := 0;
		2213	VInt_LastSeq := DiskSeq;
		2214	end;
		2215
		2216
		2217	(*----------------------------------------------------------------------------
		2218	added version 3.0 May 1, 2003
		2219	read data and copy in temp file if needed or skip to next local header *)
		2220	procedure RWJoinData(wndOwner: HWND; var Buffer; ReadLen: integer;
		2221	var DiskNbr: word; Copy: boolean);
		2222	var
		2223	SizeR, ToRead: integer;
		2224	begin
		2225	while ReadLen > 0 do
		2226	begin
		2227	ToRead := min(ReadLen, SFXBufSize);
		2228	SizeR := FRead(Buffer, ToRead);
		2229	if SizeR <> ToRead then
		2230	begin
		2231	// Check if we are at the end of a input disk.
		2232	if (VInt_SpanType = SFXSpanTypeNone) or
		2233	(FSeek(0, FILE_CURRENT) <> FSeek(0, FILE_END)) then
		2234	ErrorHaltID(SFX_Err_ArchiveCorrupted);
		2235
		2236	// It seems we are at the end, so get a next disk.
		2237	Inc(DiskNbr);
		2238	GetNewDisk(wndOwner, DiskNbr);
		2239	end;
		2240
		2241	if SizeR > 0 then
		2242	begin
		2243	if Copy then
		2244	CheckFWrite(VH_TempFile, Buffer, SizeR, VStr_TempFile);
		2245	ReadLen := ReadLen - SizeR;
		2246	end;
		2247	end;
		2248	end;
		2249
		2250	// open the correct archive in spanned, multivolue or detached sfx's
		2251	procedure OpenRightArchive(wndOwner: HWND; const DiskNumber: integer);
		2252	begin
		2253	if not IsRightDisk(DiskNumber) then
		2254	GetNewDisk(wndOwner, DiskNumber); // we need another disk
		2255	end;
		2256
		2257
		2258
		2259	// spanned archive, extract local header and file data to a temporary file
		2260	procedure ExtractToTempFile(const wndOwner: HWND; var LocalOffset: cardinal;
		2261	var OldHandle: THandle);
		2262	var
		2263	Buf: array[0..SFXBufSize] of Char;
		2264	DataToCopy: cardinal;
		2265	begin
		2266	if VStr_TempFile = '' then
		2267	begin
		2268	ZeroMemory(@buf, sizeof(buf));
		2269	// create a temporaray filename
		2270	SetLength(VStr_TempFile, MAX_PATH * 2);
		2271	if GetTempFileName(PChar(AppendDirSeparator(ExpandEnv('%temp%'))),
		2272	'SFX', 0, Buf) <> 0 then
		2273	begin
		2274	VStr_TempFile := buf;
		2275	DeleteFile(buf); // because created by GetTempFileName
		2276	end
		2277	else
		2278	ErrorHaltFmt(SFX_Err_CannotOpenFile, VStr_TempFile);
		2279	end;
		2280
		2281	// create temp file to copy the deflated file from the archive and prepare it for inflate
		2282	VH_TempFile := CreateFile(PChar(VStr_TempFile), GENERIC_READ or
		2283	GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY, 0);
		2284
		2285	if VH_TEMPFILE = INVALID_HANDLE_VALUE then
		2286	ErrorHaltFmt(SFX_Err_CannotWriteFile, VStr_TempFile);
		2287
		2288	FSeek(LocalOffset, FILE_BEGIN);
		2289	// read the local header
		2290	VInt_MaxWrite := sizeof(buf); // do not allow overlength
		2291	RWJoinData(wndOwner, Buf, sizeof(TZipLocalHeader), VRec_ZipHeader.DiskStart,
		2292	True);
		2293	with PZipLocalHeader(@Buf)^ do
		2294	begin
		2295	if HeaderSig <> ZipLocalHeaderSig then
		2296	BadArchive;
		2297	DataToCopy := VRec_ZipHeader.ComprSize + FileNameLen + ExtraLen;
		2298	// ext local header?
		2299	if (Flag and 8) = 8 then
		2300	DataToCopy := DataToCopy + sizeof(TZipExtLocalHeader);
		2301	end;
		2302	VInt_MaxWrite := DataToCopy; // do not allow overlength
		2303	RWJoinData(wndOwner, Buf, DataToCopy, VRec_ZipHeader.DiskStart, True);
		2304	OldHandle := VH_InFile;
		2305	VH_InFile := VH_TempFile;
		2306	LocalOffset := 0;
		2307	end;
		2308
		2309	// reattach current archive and close tempfile
		2310	procedure RollBackTempFile(const wndOwner: HWND; const OldHandle: THandle);
		2311	begin
		2312	VH_InFile := OldHandle;
		2313	if not CheckCloseHandle(VH_TempFile) then
		2314	ErrorMsgBoxFmt1(wndOwner, SFX_Err_CannotCloseFile, VStr_TempFile);
		2315	DeleteFile(PChar(VStr_TempFile));
		2316	end;
		2317
		2318	function ExtractFile(wndOwner: hWnd; const Filename: string;
		2319	const rec: TZ64CentralEntry; var bPasswordFailed: boolean): boolean;
		2320	var
		2321	EncryptHDR: PAnsiChar;
		2322	i: integer;
		2323	rLocal: TZipLocalHeader;
		2324	bIsTempFile: boolean;
		2325	clOffset: cardinal;
		2326	oldH: THandle;
		2327	begin
		2328	bPasswordFailed := False;
		2329	bIsTempFile := False;
		2330	Result := False;
		2331	// mst may 07, 2002: removed a sleep(100) where did this come from?
		2332	VRec_ZipHeader := rec;
		2333	with VRec_ZipHeader do
		2334	begin
		2335	if HeaderSig <> ZipCentralHeaderSig then
		2336	BadArchive;
		2337	if not (ComprMethod in [0, 8]) then
		2338	ErrorMsgBoxFmt1(wndOwner, SFX_Err_ZipUnknownComp, '')
		2339	else
		2340	begin
		2341	clOffset := RelOffLocal + VDW_OffsetDelta;
		2342	if (VInt_SpanType <> SFXSpanTypeNone{0}) then
		2343	begin
		2344	// assure the right disk is opened
		2345	OpenRightArchive(wndOwner, DiskStart);
		2346
		2347	// join the possibly split data in a temporary file
		2348	ExtractToTempFile(wndOwner, clOffset, oldH);
		2349	bIsTempFile := True;
		2350	end;
		2351
		2352	try
		2353	// goto beginning of local header...
		2354	FSeek(clOffset, FILE_BEGIN);
		2355	CheckFRead(rLocal, sizeof(rLocal));
		2356	if rLocal.HeaderSig <> ZipLocalHeaderSig then
		2357	BadArchive;
		2358
		2359	// mst may 07, 2002: added extrafieldlen to go to correct position
		2360	// e.g. for zipfiles created with infozip's zip.exe
		2361	FSeek(rLocal.FileNameLen + rLocal.ExtraLen, FILE_CURRENT);
		2362	VInt_BytesToGo := ComprSize;
		2363	VInt_MaxWrite := UnComprSize; // do not allow overlength
		2364
		2365	//password stuff...
		2366	if (Flag and 1) = 1 then //if a password used...
		2367	begin
		2368	Dec(VInt_BytesToGo, RAND_HEAD_LEN);
		2369	GetMem(EncryptHDR, RAND_HEAD_LEN * 2);
		2370	try
		2371	CheckFRead(EncryptHDR[0], RAND_HEAD_LEN);
		2372	//make a copy of encrypted header in upper half of buffer...
		2373	Move(EncryptHDR[0], EncryptHDR[RAND_HEAD_LEN], RAND_HEAD_LEN);
		2374	if VStr_Password = '' then
		2375	bPasswordFailed := True
		2376	else
		2377	bPasswordFailed :=
		2378	not decrypt_pw(EncryptHDR, RAND_HEAD_LEN, Flag,
		2379	CRC32, ModifTime, VStr_Password);
		2380	if bPasswordFailed then
		2381	for i := 0 to 2 do
		2382	begin
		2383	if DialogBox(hInstance, Str_Dlg_Password, wndOwner,
		2384	@PasswordQueryDialogProc) <> idOk then
		2385	Break;
		2386	bPasswordFailed :=
		2387	not decrypt_pw(EncryptHDR, RAND_HEAD_LEN, Flag,
		2388	CRC32, ModifTime, VStr_Password);
		2389	if not bPasswordFailed then
		2390	Break;
		2391	Windows.Beep(0, 0); //it's a dud, ? try again...
		2392	end;
		2393	finally
		2394	FreeMem(EncryptHDR);
		2395	end;
		2396	end;
		2397
		2398	if bPasswordFailed then
		2399	Exit;
		2400
		2401	VDW_CRC32Val := CRC_MASK;
		2402	ProcessMessages;
		2403	if VBool_Cancelled then
		2404	Exit;
		2405
		2406	VStr_OutFile := FileName;
		2407	VH_OutFile := CreateFile(PChar(Filename), GENERIC_WRITE,
		2408	FILE_SHARE_WRITE, nil, CREATE_ALWAYS, ExtFileAtt and $7F, 0);
		2409
		2410	if VH_OutFile = INVALID_HANDLE_VALUE then
		2411	begin
		2412	ErrorMsgBoxFmt1(wndOwner, SFX_Err_CannotWriteFile, VStr_OutFile);
		2413	Exit;
		2414	end;
		2415
		2416	try
		2417	case ComprMethod of
		2418	0: Unstore;
		2419	8: Inflate(nil, 0);
		2420	end;
		2421	// set file time
		2422	if CTime = 0 then
		2423	FileSetDate(VH_OutFile, ModifTime + 65536 * ModifDate)
		2424	else
		2425	begin
		2426	SetFileTime(VH_OutFile, @CTime, @ATime, @MTime);
		2427	end;
		2428
		2429	// 01/13/04: do crc32 checking, bail a warning message
		2430	// but do not stop if checksums do not match
		2431	if rec.CRC32 <> (VDW_CRC32Val xor $FFFFFFFF) then
		2432	begin
		2433	ErrorMsgBoxFmt1(wndOwner, SFX_Err_CRC32, VStr_OutFile);
		2434	Result := False;
		2435	end
		2436	else
		2437	Result := True;
		2438
		2439	finally
		2440	if not CheckCloseHandle(VH_OutFile) then
		2441	begin
		2442	ErrorMsgBoxFmt1(wndOwner, SFX_Err_CannotCloseFile, VStr_OutFile);
		2443	Result := False;
		2444	end;
		2445	end;
		2446	finally
		2447	if bIsTempFile then
		2448	RollBackTempFile(wndOwner, oldH);
		2449	end;
		2450	end;
		2451	end;
		2452	end;
		2453
		2454	(--------------------------------------------------------------------------)
		2455
		2456	function Extract(wndOwner: hWnd): boolean;
		2457	var
		2458	i, FileCount: longint;
		2459	wndList: HWND;
		2460	wndProgressBar: HWND;
		2461	bExtracted, bPWFailed: boolean;
		2462	recCentral: TZ64CentralEntry;
		2463	begin
		2464	wndList := GetDlgItem(wndOwner, ID_LV_FILES);
		2465	wndProgressBar := GetDlgItem(wndOwner, ID_PRG_EXTRACT);
		2466	FileCount := SendMessage(wndList, LVM_GETITEMCOUNT, 0, 0);
		2467	SendMessage(wndProgressBar, PBM_SETRANGE, 0, FileCount shl 16);
		2468	SendMessage(wndProgressBar, PBM_SETPOS, 0, 0);
		2469
		2470	VInt_LastSeq := -1;
		2471	bPWFailed := False;
		2472	bExtracted := False;
		2473	for i := 0 to FileCount - 1 do
		2474	begin
		2475	ProcessMessages;
		2476	if VBool_Cancelled then
		2477	Break;
		2478
		2479	// update progres bar
		2480	SendMessage(wndProgressBar, PBM_SETPOS, i + 1, 0);
		2481
		2482	if SendMessage(wndList, LVM_GETITEMSTATE, i, LVIS_SELECTED) = LVIS_SELECTED then
		2483	//if selected then...
		2484	begin
		2485	//get the target filename...
		2486	VStr_CurrentFile := AppendDirSeparator(VStr_ExtractPath) +
		2487	GetFileFromList(wndOwner, i, recCentral);
		2488
		2489	if (VStr_CurrentFile <> '') and
		2490	(VStr_CurrentFile[Length(VStr_CurrentFile)] = Chr_DirSep) then
		2491	begin
		2492	if (so_CreateEmptyDirs and VRec_SFXHeader.Options) <> 0 then
		2493	begin
		2494	if not ForceDirectories(RemoveDirSeparator(VStr_CurrentFile)) then
		2495	begin
		2496	ErrorMsgBoxFmt1(wndOwner, SFX_Err_Directory,
		2497	RemoveDirSeparator(VStr_CurrentFile));
		2498	bExtracted := False;
		2499	end
		2500	else
		2501	bExtracted := True;
		2502	end
		2503	else
		2504	bExtracted := False;
		2505	end
		2506	else
		2507	begin
		2508	if not ForceDirectories(ExtractFilePath(VStr_CurrentFile)) then
		2509	begin
		2510	ErrorMsgBoxFmt1(wndOwner, SFX_Err_Directory,
		2511	RemoveDirSeparator(VStr_CurrentFile));
		2512	Break;
		2513	end;
		2514
		2515	if (Integer(VRec_SFXHeader.DefOVW) <> som_Overwrite) and
		2516	FileExists(PChar(VStr_CurrentFile)) then
		2517	begin
		2518	if Integer(VRec_SFXHeader.DefOVW) = som_Skip then
		2519	continue;
		2520	case DialogBox(hInstance, Str_Dlg_FileExists, wndOwner,
		2521	@FileExistsDialogProc) of
		2522	ID_BTN_YES: ;
		2523	ID_BTN_NO: continue;
		2524	end;
		2525	end;
		2526
		2527	// make sure the correct zip archive is open
		2528	if (VInt_SpanType <> SFXSpanTypeNone{0}) then
		2529	OpenRightArchive(wndOwner, recCentral.DiskStart);
		2530
		2531	bExtracted := ExtractFile(wndOwner, VStr_CurrentFile, recCentral,
		2532	bPWFailed);
		2533	end;
		2534
		2535	if bPWFailed then
		2536	break //stop further processing!!!
		2537	else
		2538	if bExtracted then
		2539	//unselect the file if successfully extracted with no errors...
		2540	DeSelectInFilesListView(wndOwner, i);
		2541	end;
		2542	end;
		2543	Result := SendMessage(wndList, LVM_GETSELECTEDCOUNT, 0, 0) = 0;
		2544	if not Result then
		2545	ShowFirstSelected(wndList); //may 11, 2002 : better visual feedback
		2546	end;
		2547
		2548	(--------------------------------------------------------------------------)
		2549
		2550	procedure ErrorHaltFmt(id: integer; const arg1: string);
		2551	begin
		2552	ErrorHalt(FmtStrID1(id, arg1));
		2553	end;
		2554
		2555	procedure ErrorHaltID(id: integer);
		2556	begin
		2557	ErrorHalt(SFXString(id));
		2558	end;
		2559
		2560	// fatal error, exit
		2561	procedure ErrorHalt(const sMsg: string);
		2562	{$ifdef DEBUG_SFX}
		2563	var err: DWORD; m: string;
		2564	begin
		2565	err := GetLastError;
		2566	m := sMsg;
		2567	if err <> 0 then
		2568	m := m + ' ['+ IntToHex(err, 8) + ' '+ SysErrorMessage(err)+']';
		2569	if m <> '' then
		2570	ErrorMsgBox(0, m{sMsg});
		2571	raise Exception.Create('Program halted');
		2572	// Halt(1);
		2573	end;
		2574	{$else}
		2575	begin
		2576	if sMsg <> '' then
		2577	ErrorMsgBox(0, sMsg);
		2578	Halt(1);
		2579	end;
		2580	{$endif}
		2581	(--------------------------------------------------------------------------)
		2582
		2583	function StrGetEditText(wndPar: HWND): string;
		2584	begin
		2585	SetLength(Result, GetWindowTextLength(GetDlgItem(wndPar, ID_EDITBOX)) * 2);
		2586	if Result <> '' then
		2587	begin
		2588	GetDlgItemText(wndPar, ID_EDITBOX, PChar(Result), Length(Result));
		2589	Result := PChar(Result); // match length
		2590	end;
		2591	end;
		2592
		2593	procedure AddFilesListViewCol(const wndDlg: HWND; const iIndex: integer;
		2594	const szCaption: string; const iDirection, iWidth: integer);
		2595	var
		2596	wndLV: HWND;
		2597	recCol: TLVColumn;
		2598	begin
		2599	wndLV := GetDlgItem(wndDlg, ID_LV_FILES);
		2600	with recCol do
		2601	begin
		2602	mask := LVCF_FMT or LVCF_SUBITEM or LVCF_TEXT or LVCF_WIDTH;
		2603	fmt := iDirection;
		2604	cx := iWidth;
		2605	pszText := PChar(szCaption);
		2606	cchTextMax := Length(szCaption);
		2607	iSubItem := iIndex;
		2608	end;
		2609	SendMessage(wndLV, LVM_INSERTCOLUMN, iIndex, integer(@recCol));
		2610	end;
		2611
		2612	procedure SelectAllInFilesListView(const wndDlg: HWND);
		2613	var
		2614	Item: TLVItem;
		2615	begin
		2616	with Item do
		2617	begin
		2618	stateMask := LVIS_SELECTED;
		2619	state := LVIS_SELECTED;
		2620	end;
		2621	SendDlgItemMessage(wndDlg, ID_LV_FILES, LVM_SETITEMSTATE, -1, longint(@Item));
		2622	end;
		2623
		2624	// get current directory
		2625	function GetCurDir: string;
		2626	var
		2627	szBuf: array[0..MAX_PATH] of char;
		2628	begin
		2629	SetString(Result, szBuf, GetCurrentDirectory(MAX_PATH, szBuf));
		2630	end;
		2631
		2632	function Int2Str(n: int64; wide: integer = -1): String;
		2633	var
		2634	rev: array[0..25] of Char;
		2635	i, k: Integer;
		2636	prev: PChar;
		2637	begin
		2638	i := 0;
		2639	prev := @rev[25];
		2640	prev^ := #0;
		2641	while n <> 0 do
		2642	begin
		2643	inc(i);
		2644	dec(prev);
		2645	k := n mod 10;
		2646	prev^ := Char(Ord('0') + k);
		2647	n := n div 10;
		2648	end;
		2649	while (i < wide) and (i < 24) do
		2650	begin
		2651	inc(i);
		2652	dec(prev);
		2653	prev^ := '0';
		2654	end;
		2655	Result := String(prev);
		2656	end;
		2657
		2658	// return the Detached name
		2659	function DetachedName(const num: string): string;
		2660	begin
		2661	Result := VStr_DetachName;
		2662	if num <> '' then
		2663	Result := Result + num;
		2664	Result := Result + VStr_DetachExt;
		2665	end;
		2666
		2667	function LoadResource(id: integer): Pointer;
		2668	var
		2669	hFind, hRes: THandle;
		2670	Begin
		2671	Result := nil;
		2672	hFind := Windows.FindResource(HInstance, PChar(id), RT_RCDATA);
		2673	if hFind <> 0 then
		2674	begin
		2675	hRes := Windows.LoadResource(HInstance, hFind);
		2676	if hRes <> 0 then
		2677	Result := Windows.LockResource(hRes);
		2678	end;
		2679	End;
		2680
		2681
		2682	procedure Finish;
		2683	begin
		2684	if xbuf <> nil then
		2685	FreeMem(xbuf);
		2686	// FreeMem(VRec_Langs);
		2687	ReAllocMem(p_Items, 0);
		2688	if not CheckCloseHandle(VH_InFile) then
		2689	ErrorMsgBoxFmt1(0, SFX_Err_CannotCloseFile, VStr_ExeName);
		2690	if not CheckCloseHandle(VH_TempFile) then
		2691	ErrorMsgBoxFmt1(0, SFX_Err_CannotCloseFile, VStr_TempFile);
		2692	if VStr_TempFile <> '' then
		2693	DeleteFile(PChar(VStr_TempFile));
		2694	if not CheckCloseHandle(VH_OutFile) then
		2695	ErrorMsgBoxFmt1(0, SFX_Err_CannotCloseFile, VStr_OutFile);
		2696	FreeMem(VRec_Strings);
		2697	FreeMem(VRec_DefStrings);
		2698	end;
		2699
		2700	procedure Run;
		2701	var
		2702	sfi: TSHFileInfo; // to get shell image list handle
		2703	{$IFNDEF DEBUG_SFX}
		2704	pBuf: array[0..MAX_PATH] of Char; // buffer for paramstr(0)
		2705	{$ENDIF}
		2706	sVar: string;
		2707	CCInfo: TCCInitCommonControlsEx;
		2708	begin
		2709	// may 11, 2002: added support for environment variable %TICKS%
		2710	sVar := Int2Str(GetTickCount, 0);
		2711	SetEnvironmentVariable('TICKS', PChar(sVar));
		2712
		2713	// initialize common controls (for the progress bar and listview)
		2714	CCInfo.dwICC := ICC_LISTVIEW_CLASSES or ICC_PROGRESS_CLASS or ICC_STANDARD_CLASSES;
		2715	CCInfo.dwSize := sizeof(TCCInitCommonControlsEx);
		2716	InitCommonControlsEx(@CCInfo);
		2717
		2718	// Created in the initialisation section of SFXDialogs.pas
		2719	Make_CRC32Table;
		2720
		2721	// get default strings
		2722	if LoadLang(VRec_DefStrings, SFX_LANG_BASE) <= 0 then
		2723	ErrorHaltID(SFX_Err_Archive);
		2724	VStr_SFX_Caption := SFXString(SFX_Cap_App);
		2725	SetLanguage;
		2726	VStr_SFX_Caption := SFXString(SFX_Cap_App); // may be diferent language
		2727
		2728	{$IFNDEF DEBUG_SFX}
		2729	// needs less code than ParamStr(0)
		2730	SetString(VStr_ExeName, pBuf, GetModuleFileName(0, pBuf, sizeof(pBuf)));
		2731	{$ENDIF}
		2732
		2733	// open the archive file (i myself!)
		2734	VH_InFile := CreateFile(PChar(VStr_ExeName), GENERIC_READ, FILE_SHARE_READ, nil,
		2735	OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
		2736
		2737	// If error, notify and abort
		2738	if VH_InFile = INVALID_HANDLE_VALUE then
		2739	ErrorHaltFmt(SFX_Err_Archive, VStr_ExeName);
		2740
		2741	// read the TSFXFileHeader record (and the appended strings) from the file
		2742	GetDefParams;
		2743
		2744	// get the shell's image list handle
		2745	FillChar(sfi, sizeof(sfi),0);
		2746	VH_ShellImageList := SHGetFileInfo(PChar(VStr_ExeName), 0, sfi, sizeof(sfi),
		2747	SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
		2748
		2749	// Display the dialog
		2750	DialogBox(hInstance, Str_Dlg_Main, 0, @MainDialogProc);
		2751	end;
		2752
		2753	{$ifndef DEBUG_SFX}
		2754	initialization
		2755	VStr_SFX_Caption := '';//SFXString(SFX_Cap_App);
		2756
		2757	finalization
		2758	// cleanup
		2759	Finish;
		2760	{$endif}
		2761	end.
		2762

Subversion Repositories autosfx

autosfx/zmstr1900102/SFX/ZMSFXProcs19.pas – Rev 1