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

Rev	Author	Line No.	Line
1	daniel-mar	1	unit ZMUtils19;
		2
		3	(*
		4	ZMUtils19.pas - Some utility functions
		5	Copyright (C) 2009, 2010 by Russell J. Peters, Roger Aelbrecht,
		6	Eric W. Engler and Chris Vleghert.
		7
		8	This file is part of TZipMaster Version 1.9.
		9
		10	TZipMaster is free software: you can redistribute it and/or modify
		11	it under the terms of the GNU Lesser General Public License as published by
		12	the Free Software Foundation, either version 3 of the License, or
		13	(at your option) any later version.
		14
		15	TZipMaster 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
		18	GNU Lesser General Public License for more details.
		19
		20	You should have received a copy of the GNU Lesser General Public License
		21	along with TZipMaster. If not, see <http://www.gnu.org/licenses/>.
		22
		23	contact: problems@delphizip.org (include ZipMaster in the subject).
		24	updates: http://www.delphizip.org
		25	DelphiZip maillist subscribe at http://www.freelists.org/list/delphizip
		26
		27	modified 2010-06-26
		28	---------------------------------------------------------------------------*)
		29
		30	{$INCLUDE '.\ZipVers19.inc'}
		31
		32	{$IFDEF VERD6up}
		33	{$WARN UNIT_PLATFORM OFF}
		34	{$WARN SYMBOL_PLATFORM OFF}
		35	{$ENDIF}
		36
		37	interface
		38
		39	uses
		40	SysUtils, Windows, Classes;
		41
		42	type
		43	TPathSlashDirection = (psdExternal, psdInternal);
		44	// DeleteOpts = (htdFinal, htdAllowUndo);
		45
		46	type
		47	{$IFDEF UNICODE}
		48	TZMRawBytes = RawByteString;
		49	{$ELSE}
		50	TZMRawBytes = AnsiString;
		51	{$ENDIF}
		52
		53
		54	const // QueryZip return bit values and errors
		55	zqbStartEXE = 1; // is EXE file may be SFX
		56	zqbStartLocal = 2; // normal zip file start
		57	zqbStartSpan = 4; // first part of span
		58	zqbStartCentral = 8; // continuing Central Header
		59	zqbHasComment = 16;
		60	// zqbGoodComment = 16; // comment length good (no junk at end)
		61	zqbHasLocal = 32; // first Central entry points to local header
		62	zqbHasCentral = 64; // Central entry where it should be
		63	zqbHasEOC = 128; // End of Central entry
		64	zqbHasLoc64 = 256; // EOC64 locator entry
		65	zqbHasEOC64 = 512; // Zip64 EOC
		66	zqbJunkAtEnd = 1024; // junk at end of zip
		67	zqbIsDiskZero = 2048; // is disk 0
		68
		69	zqFieldError = -5; // bad field value
		70	zqFileError = -7; // file handling error
		71	zqGeneralError = -9; // unspecified failure
		72
		73
		74	function AbsErr(err: Integer): Integer;
		75	function DelimitPath(const Path: String; Sep: Boolean): String;
		76
		77	function DirExists(const FName: String): Boolean;
		78
		79	function DiskAvailable(const path: String): Boolean;
		80
		81	function EraseFile(const FName: String; permanent: Boolean): Integer;
		82	function ExtractNameOfFile(const FileName: String): String;
		83
		84	function ExeVersion(const FName: String; var MS, LS: DWORD): Boolean;
		85	function ExeVers(const FName: String): Integer;
		86	function VersStr(vers: Integer; Comma: Boolean = False): String;
		87
		88	function FileSeek64(Handle: Integer; const Offset: Int64; Origin: Integer): Int64;
		89
		90	// stable replacement for depreciated FileAge()
		91	function File_Age(const FName: String): Cardinal;
		92
		93	procedure File_Close(var fh: Integer);
		94
		95	procedure File_Delete(const FName: String);
		96
		97	function File_Size(const FSpec: TFilename): Int64;
		98
		99	function ForceDirectory(const DirName: String): Boolean;
		100
		101	function GetVolumeLabel(const drive: String): String;
		102
		103	function Hi64(i: Int64): Cardinal;
		104
		105	function IsSameFile(const FName1, FName2: String): Boolean;
		106
		107	function IsWild(const FSpec: String): Boolean;
		108	// returns position of first wild character or 0
		109	function HasWild(const FSpec: String): Integer;
		110	function HasWildW(const FSpec: WideString): Integer;
		111
		112	// true we're running under XP or later.
		113	function IsWinXP: Boolean;
		114	function WinVersion: Integer;
		115
		116	function Lo64(i: Int64): Cardinal;
		117
		118	function PathConcat(const path, extra: String): String;
		119
		120	function QueryZip(const FName: String): Integer;
		121
		122	function SetSlash(const path: String; dir: TPathSlashDirection): String;
		123	function SetSlashW(const path: WideString; dir: TPathSlashDirection): WideString;
		124
		125	function StrToOEM(const astr: String): String;
		126	function OEMToStr(const astr: Ansistring): String;
		127	//1 return True if contains chars (<#31 ?) >#126
		128	function StrHasExt(const astr: String): Boolean; overload;
		129	{$IFDEF UNICODE}
		130	function StrHasExt(const astr: AnsiString): Boolean; overload;
		131	function StrHasExt(const astr: TZMRawBytes): Boolean; overload;
		132	{$ENDIF}
		133	function LastPos(const s: String; ch: Char; before: Integer = MAXINT): Integer;
		134	function LastPosW(const s: WideString; wch: Widechar; before: Integer = MAXINT): Integer;
		135
		136	function CalcCRC32(const mem; len: Integer; init: DWORD): DWORD;
		137
		138	function OpenResStream(const ResName: String; const rtype: PChar): TResourceStream;
		139
		140	function IsFolder(const Name: String): Boolean;
		141	{$IFDEF UNICODE}
		142	overload;
		143	function IsFolder(const name: TZMRawBytes): boolean; overload;
		144	{$ENDIF}
		145
		146	function CanHash(const FSpec: String): Boolean;
		147
		148	// return true if filename is obviously invalid
		149	function NameIsBad(const astr: String): Boolean;
		150
		151	// return exe size (if < 4G)
		152	// 0 _ not exe
		153	function ExeSize(const Name: String): Cardinal; overload;
		154	function ExeSize(fileHandle: Integer): Cardinal; overload;
		155
		156
		157	// check for SFX header or detached header
		158	// return <0 error
		159	const
		160	cstNone = 0; // not found
		161	cstExe = 1; // might be stub of unknown type
		162	cstSFX17 = 17; // found 1.7 SFX headers
		163	cstSFX19 = 19; // found 1.9 SFX headers
		164	cstDetached = 2048; // is detached - if name specified ZipName will modified for it
		165
		166	function CheckSFXType(const fileHandle: Integer; var ZipName: String;
		167	var size: Integer): Integer; overload;
		168	function CheckSFXType(const Name: String; var ZipName: String;
		169	var size: Integer): Integer; overload;
		170
		171	function FileDateToLocalDateTime(stamp: Integer): TDateTime;
		172
		173	// -------------------------- ------------ -------------------------
		174	implementation
		175
		176	uses ZMStructs19, ShellApi, Forms, ZMUTF819, ZMSFXInt19;
		177
		178	type
		179	TInt64Rec = packed record
		180	case Integer of
		181	0: (I: Int64);
		182	1: (Lo, Hi: Cardinal);
		183	end;
		184
		185	const
		186	CRC32Table: array[0..255] of DWORD = (
		187	$00000000, $77073096, $EE0E612C, $990951BA,
		188	$076DC419, $706AF48F, $E963A535, $9E6495A3,
		189	$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
		190	$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
		191	$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
		192	$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
		193	$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
		194	$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
		195	$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
		196	$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
		197	$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
		198	$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
		199	$26D930AC, $51DE003A, $C8D75180, $BFD06116,
		200	$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
		201	$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
		202	$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
		203
		204	$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
		205	$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
		206	$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
		207	$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
		208	$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
		209	$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
		210	$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
		211	$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
		212	$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
		213	$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
		214	$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
		215	$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
		216	$5005713C, $270241AA, $BE0B1010, $C90C2086,
		217	$5768B525, $206F85B3, $B966D409, $CE61E49F,
		218	$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
		219	$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
		220
		221	$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
		222	$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
		223	$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
		224	$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
		225	$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
		226	$F762575D, $806567CB, $196C3671, $6E6B06E7,
		227	$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
		228	$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
		229	$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
		230	$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
		231	$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
		232	$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
		233	$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
		234	$CC0C7795, $BB0B4703, $220216B9, $5505262F,
		235	$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
		236	$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
		237
		238	$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
		239	$9C0906A9, $EB0E363F, $72076785, $05005713,
		240	$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
		241	$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
		242	$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
		243	$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
		244	$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
		245	$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
		246	$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
		247	$A7672661, $D06016F7, $4969474D, $3E6E77DB,
		248	$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
		249	$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
		250	$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
		251	$BAD03605, $CDD70693, $54DE5729, $23D967BF,
		252	$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
		253	$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
		254
		255	//--------------------------------------------------------
		256	function Lo64(i: Int64): Cardinal;
		257	var
		258	r: TInt64Rec;
		259	begin
		260	r.I := i;
		261	Result := r.Lo;
		262	end;
		263
		264	function Hi64(i: Int64): Cardinal;
		265	var
		266	r: TInt64Rec;
		267	begin
		268	r.I := i;
		269	Result := r.Hi;
		270	end;
		271
		272	//--------------------------------------------------------
		273	function AbsErr(err: Integer): Integer;
		274	begin
		275	if err < 0 then
		276	Result := -err
		277	else
		278	Result := err;
		279	end;
		280
		281	function DelimitPath(const Path: String; Sep: Boolean): String;
		282	begin
		283	Result := Path;
		284	if Length(Path) = 0 then
		285	begin
		286	if Sep then
		287	Result := PathDelim{'\'};
		288	exit;
		289	end;
		290	if (AnsiLastChar(Path)^ = PathDelim) <> Sep then
		291	begin
		292	if Sep then
		293	Result := Path + PathDelim
		294	else
		295	Result := Copy(Path, 1, pred(Length(Path)));
		296	end;
		297	end;
		298
		299	(*? DirExists
		300	1.73 12 July 2003 return true empty string (current directory)
		301	*)
		302	function DirExists(const FName: String): Boolean;
		303	var
		304	Code: DWORD;
		305	dir: String;
		306	begin
		307	Result := True; // current directory exists
		308	dir := DelimitPath(FName, False);
		309	if FName <> '' then
		310	begin
		311	Code := GetFileAttributes(PChar(dir{FName}));
		312	Result := (Code <> MAX_UNSIGNED) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0);
		313	end;
		314	end;
		315
		316	function DiskAvailable(const path: String): Boolean;
		317	var
		318	drv: Integer;
		319	em: Cardinal;
		320	pth: String;
		321	begin
		322	Result := False;
		323	pth := ExpandUNCFileName(path);
		324	if (length(pth) > 1) and (pth[2] = DriveDelim) then
		325	// if (length(pth) >1) and (pth[2] = ':') then
		326	begin
		327	drv := Ord(Uppercase(pth)[1]) - $40;
		328	em := SetErrorMode(SEM_FAILCRITICALERRORS);
		329	Result := DiskSize(drv) <> -1;
		330	SetErrorMode(em);
		331	end;
		332	end;
		333
		334	(*? EraseFile
		335	1.77 moved from ZMaster
		336	Delete a file and put it in the recyclebin on demand.
		337	*)
		338	function EraseFile(const FName: String; permanent: Boolean): Integer;
		339	var
		340	DelFileName: String;
		341	SHF: TSHFileOpStruct;
		342	begin
		343	// If we do not have a full path then FOF_ALLOWUNDO does not work!?
		344	DelFileName := FName;
		345	if ExtractFilePath(FName) = '' then
		346	DelFileName := GetCurrentDir() + PathDelim{'\'} + FName;
		347
		348	Result := -1;
		349	// We need to be able to 'Delete' without getting an error
		350	// if the file does not exists as in ReadSpan() can occur.
		351	if not FileExists(DelFileName) then
		352	Exit;
		353	// with SHF do
		354	// begin
		355	SHF.Wnd := Application.Handle;
		356	SHF.wFunc := FO_DELETE;
		357	SHF.pFrom := PChar(DelFileName + #0);
		358	SHF.pTo := nil;
		359	SHF.fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
		360	if not permanent then
		361	SHF.fFlags := SHF.fFlags or FOF_ALLOWUNDO;
		362	// end;
		363	Result := SHFileOperation(SHF);
		364	end;
		365
		366	function ExeVersion(const FName: String; var MS, LS: DWORD): Boolean;
		367	var
		368	Dummy: DWORD;
		369	VerInfo: Pointer;
		370	VerInfoSize: DWORD;
		371	VerValue: PVSFixedFileInfo;
		372	VerValueSize: DWORD;
		373	begin
		374	Result := False;
		375	if FileExists(FName) then
		376	begin
		377	VerInfoSize := GetFileVersionInfoSize(PChar(FName), Dummy);
		378	GetMem(VerInfo, VerInfoSize);
		379	try
		380	if GetFileVersionInfo(PChar(FName), 0, VerInfoSize, VerInfo) then
		381	begin
		382	VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
		383	MS := VerValue^.dwFileVersionMS;
		384	LS := VerValue^.dwFileVersionLS;
		385	Result := True;
		386	end;
		387	finally
		388	FreeMem(VerInfo, VerInfoSize);
		389	end;
		390	end;
		391	end;
		392
		393	// format M.N.RR.BBB
		394	// return Version as used by DelphiZip
		395	function ExeVers(const FName: String): Integer;
		396	var
		397	LS: DWORD;
		398	MS: DWORD;
		399	begin
		400	Result := -1;
		401	if ExeVersion(FName, MS, LS) then
		402	begin
		403	Result := (Integer(MS) shr 16) * 1000000;
		404	Result := Result + (Integer(MS and $FFFF) * 100000);
		405	Result := Result + ((Integer(LS) shr 16) * 10000);
		406	Result := Result + Integer(LS and $FFFF) mod 1000;
		407	end;
		408	end;
		409
		410	function ExtractNameOfFile(const FileName: String): String;
		411	var
		412	I: Integer;
		413	J: Integer;
		414	begin
		415	I := LastDelimiter(PathDelim + DriveDelim, FileName);
		416	J := LastDelimiter('.', FileName);
		417	if (J <= I) then
		418	begin
		419	J := MaxInt;
		420	end; // no ext
		421	Result := Copy(FileName, I + 1, J - (I + 1));
		422	end;
		423
		424	function VersStr(vers: Integer; Comma: Boolean = False): String;
		425	const
		426	fmt: array [Boolean] of String =
		427	('%d.%d.%d.%4.4d', '%d,%d,%d,%d');
		428	begin
		429	Result := Format(fmt[Comma], [vers div 1000000, (vers mod 1000000) div
		430	100000, (vers mod 100000) div 10000, vers mod 1000]);
		431	end;
		432
		433	function OpenResStream(const ResName: String; const rtype: PChar): TResourceStream;
		434	var
		435	hFindRes: Cardinal;
		436	idNo: Integer;
		437	inst: Integer;
		438	rsn: PChar;
		439	begin
		440	Result := nil;
		441	try
		442	rsn := PChar(ResName);
		443	// idno := 0;
		444	inst := HInstance;
		445	if (Length(ResName) > 1) and (ResName[1] = '#') then
		446	begin
		447	idNo := StrToInt(copy(ResName, 2, 25));
		448	rsn := PChar(idNo);
		449	end;
		450	hFindRes := FindResource(inst, rsn, rtype);
		451	if (hFindRes = 0) and ModuleIsLib then
		452	begin
		453	inst := MainInstance;
		454	hFindRes := FindResource(inst, rsn, rtype);
		455	end;
		456	if hFindRes <> 0 then
		457	Result := TResourceStream.Create(inst, ResName, rtype);
		458	except
		459	Result := nil;
		460	end;
		461	end;
		462
		463	function File_Age(const FName: String): Cardinal;
		464	var
		465	FindData: TWin32FindData;
		466	Handle: THandle;
		467	LocalFileTime: TFileTime;
		468	begin
		469	Handle := FindFirstFile(PChar(FName), FindData);
		470	if Handle <> INVALID_HANDLE_VALUE then
		471	begin
		472	FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
		473	Windows.FindClose(Handle);
		474	if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,
		475	LongRec(Result).Lo) then
		476	Exit;
		477	end;
		478	Result := Cardinal(-1);
		479	end;
		480
		481	procedure File_Close(var fh: Integer);
		482	var
		483	h: Integer;
		484	begin
		485	if fh <> Invalid_Handle then
		486	begin
		487	h := fh;
		488	fh := Invalid_Handle;
		489	FileClose(h);
		490	end;
		491	end;
		492
		493	procedure File_Delete(const FName: String);
		494	begin
		495	if FileExists(FName) then
		496	SysUtils.DeleteFile(FName);
		497	end;
		498
		499	function FileSeek64(Handle: Integer; const Offset: Int64; Origin: Integer): Int64;
		500	{$IFDEF VERD6up}
		501	begin
		502	Result := FileSeek(Handle, Offset, Origin);
		503	end;
		504	{$ELSE}
		505	//function FileSeek64(Handle: Integer; const Offset: Int64; Origin: Integer): Int64;
		506	var
		507	r: TInt64Rec;
		508	begin
		509	r.I := Offset;
		510	r.Lo := SetFilePointer(Handle, Integer(r.Lo), @r.Hi, Origin);
		511	if (r.Lo = Cardinal(-1)) and (GetLastError <> 0) then
		512	r.I := -1;
		513	Result := r.i;
		514	end;
		515
		516	{$ENDIF}
		517
		518	function File_Size(const FSpec: TFilename): Int64;
		519	var
		520	sr: TSearchRec;
		521	begin
		522	Result := 0;
		523	if SysUtils.FindFirst(FSpec, faAnyFile, sr) = 0 then
		524	begin
		525	Result := sr.Size;
		526	SysUtils.FindClose(sr);
		527	end;
		528	end;
		529
		530	(*? ForceDirectory
		531	1.73 RP utilities
		532	*)
		533	function ForceDirectory(const DirName: String): Boolean;
		534	var
		535	sDir: String;
		536	begin
		537	Result := True;
		538	if DirName <> '' then
		539	begin
		540	sDir := DelimitPath(DirName, False);
		541	if DirExists(sDir) or (ExtractFilePath(sDir) = sDir) then
		542	exit; // avoid 'c:\xyz:\' problem.
		543
		544	if ForceDirectory(ExtractFilePath(sDir)) then
		545	Result := CreateDirectory(PChar(sDir), nil)
		546	else
		547	Result := False;
		548	end;
		549	end;
		550
		551	(*? HasWild
		552	returns position of first wild character or 0
		553	*)
		554	function HasWild(const FSpec: String): Integer;
		555	var
		556	c: Char;
		557	i: Integer;
		558	begin
		559	Result := 0;
		560	for i := 1 to Length(FSpec) do
		561	begin
		562	c := FSpec[i];
		563	if (c = WILD_MULTI) or (c = WILD_CHAR) then
		564	begin
		565	Result := i;
		566	break;
		567	end;
		568	end;
		569	end;
		570
		571
		572	(*? HasWildW
		573	returns position of first wild character or 0
		574	*)
		575	function HasWildW(const FSpec: WideString): Integer;
		576	var
		577	c: Widechar;
		578	i: Integer;
		579	begin
		580	Result := 0;
		581	for i := 1 to Length(FSpec) do
		582	begin
		583	c := FSpec[i];
		584	if (c = WILD_MULTI) or (c = WILD_CHAR) then
		585	begin
		586	Result := i;
		587	break;
		588	end;
		589	end;
		590	end;
		591
		592	(*? IsWild
		593	1.73.4
		594	returns true if filespec contains wildcard(s)
		595	*)
		596	function IsWild(const FSpec: String): Boolean;
		597	var
		598	c: Char;
		599	i: Integer;
		600	len: Integer;
		601	begin
		602	Result := True;
		603	len := Length(FSpec);
		604	i := 1;
		605	while i <= len do
		606	begin
		607	c := FSpec[i];
		608	if (c = WILD_MULTI) or (c = WILD_CHAR) then
		609	exit;
		610	Inc(i);
		611	end;
		612	Result := False;
		613	end;
		614
		615	function CanHash(const FSpec: String): Boolean;
		616	var
		617	c: Char;
		618	i: Integer;
		619	len: Integer;
		620	begin
		621	Result := False;
		622	len := Length(FSpec);
		623	i := 1;
		624	while i <= len do
		625	begin
		626	c := FSpec[i];
		627	if (c = WILD_MULTI) or (c = WILD_CHAR) or (c = SPEC_SEP) then
		628	exit;
		629	Inc(i);
		630	end;
		631	Result := True;
		632	end;
		633
		634	// Returns a boolean indicating whether or not we're running under XP or later.
		635	function IsWinXP: Boolean;
		636	var
		637	osv: TOSVERSIONINFO;
		638	begin
		639	osv.dwOSVersionInfoSize := sizeOf(OSVERSIONINFO);
		640	GetVersionEx(osv);
		641	// result := ( osv.dwPlatformId = VER_PLATFORM_WIN32_NT );
		642	Result := (osv.dwMajorVersion > 5) or ((osv.dwMajorVersion = 5) and
		643	(osv.dwMinorVersion >= 1));
		644	end;
		645
		646	// Returns a boolean indicating whether or not we're running under XP or later.
		647	function WinVersion: Integer;
		648	var
		649	osv: TOSVERSIONINFO;
		650	begin
		651	osv.dwOSVersionInfoSize := sizeOf(OSVERSIONINFO);
		652	GetVersionEx(osv);
		653	Result := (osv.dwMajorVersion * 100) + osv.dwMinorVersion;
		654	end;
		655
		656	(*? SetSlash
		657	1.76 use enum TPathSlashDirection = (psdExternal, psdInternal)
		658	1.73
		659	forwardSlash = false = Windows normal backslash '\'
		660	forwardSlash = true = forward slash '/'
		661	*)
		662	function SetSlash(const path: String; dir: TPathSlashDirection): String;
		663	{$IFDEF Delphi7up}
		664	begin
		665	if dir = psdInternal then
		666	Result := AnsiReplaceStr(path, PathDelim, PathDelimAlt)
		667	else
		668	Result := AnsiReplaceStr(path, PathDelimAlt, PathDelim);
		669	end;
		670	{$ELSE}
		671	var
		672	c, f, r: Char;
		673	i, len: Integer;
		674	begin
		675	Result := path;
		676	len := Length(path);
		677	if dir = psdInternal then
		678	begin
		679	f := PathDelim{'\'};
		680	r := PathDelimAlt;//'/';
		681	end
		682	else
		683	begin
		684	f := PathDelimAlt;//'/';
		685	r := PathDelim{'\'};
		686	end;
		687	i := 1;
		688	while i <= len do
		689	begin
		690	c := path[i];
		691	{$ifndef UNICODE}
		692	if c in LeadBytes then
		693	begin
		694	Inc(i, 2);
		695	continue;
		696	end;
		697	{$endif}
		698	if c = f then
		699	Result[i] := r;
		700	Inc(i);
		701	end;
		702	end;
		703
		704	{$ENDIF}
		705
		706	function SetSlashW(const path: WideString; dir: TPathSlashDirection): WideString;
		707	var
		708	c: Widechar;
		709	f: Widechar;
		710	i: Integer;
		711	len: Integer;
		712	r: Widechar;
		713	begin
		714	Result := path;
		715	len := Length(path);
		716	if dir = psdInternal then
		717	begin
		718	f := PathDelim{'\'};
		719	r := PathDelimAlt;//'/';
		720	end
		721	else
		722	begin
		723	f := PathDelimAlt;//'/';
		724	r := PathDelim{'\'};
		725	end;
		726	i := 1;
		727	while i <= len do
		728	begin
		729	c := path[i];
		730	if c = f then
		731	Result[i] := r;
		732	Inc(i);
		733	end;
		734	end;
		735
		736	//---------------------------------------------------------------------------
		737	// concat path
		738	function PathConcat(const path, extra: String): String;
		739	var
		740	pathLen: Integer;
		741	pathLst: Char;
		742	begin
		743	pathLen := Length(path);
		744	Result := path;
		745	if pathLen > 0 then
		746	begin
		747	// pathLst := path[pathLen];
		748	pathLst := AnsiLastChar(path)^;
		749	if (pathLst <> DriveDelim{':'}) and (Length(extra) > 0) then
		750	if (extra[1] = PathDelim{'\'}) = (pathLst = PathDelim{'\'}) then
		751	if pathLst = PathDelim{'\'} then
		752	Result := Copy(path, 1, pathLen - 1) // remove trailing
		753	else
		754	Result := path + PathDelim;//'\';
		755	end;
		756	Result := Result + extra;
		757	end;
		758
		759
		760	//const // QueryZip return bit values and errors
		761	// zqbStartEXE = 1; // is EXE file may be SFX
		762	// zqbStartLocal = 2; // normal zip file start
		763	// zqbStartSpan = 4; // first part of span
		764	// zqbStartCentral = 8; // continuing Central Header
		765	// zqbHasComment = 16;
		766	//// zqbGoodComment = 16; // comment length good (no junk at end)
		767	// zqbHasLocal = 32; // first Central entry points to local header
		768	// zqbHasCentral = 64; // Central entry where it should be
		769	// zqbHasEOC = 128; // End of Central entry
		770	// zqbHasLoc64 = 256; // EOC64 locator entry
		771	// zqbHasEOC64 = 512; // Zip64 EOC
		772	// zqbJunkAtEnd = 1024; // junk at end of zip
		773	// zqbIsDiskZero = 2048; // is disk 0
		774
		775	// zqFieldError = -5; // bad field value
		776	// zqFileError = -7; // file handling error
		777	// zqGeneralError = -9; // unspecified failure
		778
		779	function QueryZip(const FName: String): Integer;
		780	const
		781	FileMask = (zqbStartEXE or zqbStartLocal or zqbStartSpan or
		782	zqbStartCentral or zqbHasComment or zqbJunkAtEnd);//zqbGoodComment);
		783	var
		784	Buf: array of Byte;
		785	BufPos: Integer;
		786	CenDisk: Cardinal;
		787	CenOfs: Int64;
		788	DoCenDir: Boolean;
		789	EOC: TZipEndOfCentral;
		790	EOCLoc: TZip64EOCLocator;
		791	EOCPossible: Boolean;
		792	FileHandle: Integer;
		793	File_Sze: Int64;
		794	fn: String;
		795	fs: Int64;
		796	Need64: Boolean;
		797	pEOC: PZipEndOfCentral;
		798	pEOCLoc: PZip64EOCLocator;
		799	Pos0: Integer;
		800	ReadPos: Cardinal;
		801	res: Integer;
		802	Sig: Cardinal;
		803	Size: Integer;
		804	ThisDisk: Cardinal;
		805	// tmp: Integer;
		806	// tmp64: int64;
		807
		808	function NeedLoc64(const QEOC: TZipEndOfCentral): Boolean;
		809	begin
		810	Result := (QEOC.ThisDiskNo = MAX_WORD) or (QEOC.CentralDiskNo = MAX_WORD) or
		811	(QEOC.CentralEntries = MAX_WORD) or (QEOC.TotalEntries = MAX_WORD) or
		812	(QEOC.CentralSize = MAX_UNSIGNED) or (QEOC.CentralOffset = MAX_UNSIGNED);
		813	end;
		814	// check central entry and, if same disk, its local header signal
		815	function CheckCen(fh: Integer; This_Disk: Cardinal; CenOf: Int64): Integer;
		816	type
		817	TXData_tag = packed record
		818	tag: Word;
		819	siz: Word;
		820	end;
		821	PXData_tag = ^TXData_tag;
		822
		823	var
		824	ret: Integer;
		825	CentralHead: TZipCentralHeader;
		826	Sgn: Cardinal;
		827	Ofs: Int64;
		828	xbuf: array of Byte;
		829	xlen, ver: Integer;
		830	wtg, wsz: Word;
		831	has64: Boolean;
		832	p: PByte;
		833	begin // verify start of central
		834	ret := 0;
		835	Result := zqFieldError;
		836	if (FileSeek64(fh, CenOf, soFromBeginning) <> -1) and
		837	(FileRead(fh, CentralHead, sizeof(CentralHead)) = sizeof(CentralHead)) and
		838	(CentralHead.HeaderSig = CentralFileHeaderSig) then
		839	begin
		840	ret := zqbHasCentral; // has linked Central
		841	if (CentralHead.DiskStart = This_Disk) then
		842	begin
		843	ver := CentralHead.VersionNeeded;
		844	if (ver and VerMask) > ZIP64_VER then
		845	exit;
		846	Ofs := CentralHead.RelOffLocal;
		847	if (Ofs = MAX_UNSIGNED) and ((ver and VerMask) >= ZIP64_VER) then
		848	begin
		849	if ver > 45 then
		850	exit; // bad version
		851	// have to read extra data
		852	xlen := CentralHead.FileNameLen + CentralHead.ExtraLen;
		853	SetLength(xbuf, xlen); // easier to read filename + extra
		854	if FileRead(fh, xbuf, xlen) <> xlen then
		855	exit; // error
		856	// find Zip64 extra data
		857	has64 := False;
		858	xlen := CentralHead.ExtraLen;
		859	p := @xbuf[CentralHead.FileNameLen];
		860	wsz := 0; // keep compiler happy
		861	while xlen > sizeof(TXData_tag) do
		862	begin
		863	wtg := PXData_tag(p)^.tag;
		864	wsz := PXData_tag(p)^.siz;
		865	if wtg = Zip64_data_tag then
		866	begin
		867	has64 := xlen >= (wsz + sizeof(TXData_tag));
		868	break;
		869	end;
		870	Inc(p, wsz + sizeof(TXData_tag));
		871	end;
		872	if (not has64) or (wsz > (xlen - sizeof(TXData_tag))) then
		873	exit; // no data so rel ofs is bad
		874	Inc(p, sizeof(TXData_tag)); // past header
		875	// locate offset - values only exist if needed
		876	if CentralHead.UncomprSize = MAX_UNSIGNED then
		877	begin
		878	if wsz < sizeof(Int64) then
		879	exit; // bad
		880	Inc(p, sizeof(Int64));
		881	Dec(wsz, sizeof(Int64));
		882	end;
		883	if CentralHead.ComprSize = MAX_UNSIGNED then
		884	begin
		885	if wsz < sizeof(Int64) then
		886	exit; // bad
		887	Inc(p, sizeof(Int64));
		888	Dec(wsz, sizeof(Int64));
		889	end;
		890	if wsz < sizeof(Int64) then
		891	exit; // bad
		892	Ofs := PInt64(p)^;
		893	end;
		894	if (FileSeek64(fh, Ofs{Int64(CentralHead.RelOffLocal)}, 0) <> -1) and
		895	(FileRead(fh, Sgn, sizeof(Sgn)) = sizeof(Sgn)) and
		896	(Sgn = LocalFileHeaderSig) then
		897	ret := zqbHasCentral or zqbHasLocal; // linked local
		898	end;
		899	end;
		900	Result := ret;
		901	end;
		902
		903	begin
		904	EOCPossible := False;
		905	Result := zqFileError;
		906	DoCenDir := True; // test central too
		907	if (FName <> '') and (FName[1] = '\|') then
		908	begin
		909	DoCenDir := False;
		910	fn := copy(FName, 2, length(FName) - 1);
		911	end
		912	else
		913	fn := FName;
		914	fn := Trim(fn);
		915	if fn = '' then
		916	exit;
		917	FileHandle := Invalid_Handle;
		918	res := 0;
		919	try
		920	try
		921	// Open the input archive, presumably the last disk.
		922	FileHandle := FileOpen(fn, fmShareDenyWrite or fmOpenRead);
		923	if FileHandle = Invalid_Handle then
		924	exit;
		925	Result := 0; // rest errors normally file too small
		926
		927	// first we check if the start of the file has an IMAGE_DOS_SIGNATURE
		928	if (FileRead(FileHandle, Sig, sizeof(Cardinal)) <> sizeof(Cardinal)) then
		929	exit;
		930	if LongRec(Sig).Lo = IMAGE_DOS_SIGNATURE then
		931	res := zqbStartEXE
		932	else
		933	if Sig = LocalFileHeaderSig then
		934	res := zqbStartLocal
		935	else
		936	if Sig = CentralFileHeaderSig then
		937	res := zqbStartCentral
		938	// part of split Central Directory
		939	else
		940	if Sig = ExtLocalSig then
		941	res := zqbStartSpan; // first part of span
		942
		943	// A test for a zip archive without a ZipComment.
		944	fs := FileSeek64(FileHandle, -Int64(sizeof(EOC)), soFromEnd);
		945	if fs = -1 then
		946	exit; // not zip - too small
		947	File_Sze := fs;
		948	// try no comment
		949	if (FileRead(FileHandle, EOC, sizeof(EOC)) = sizeof(EOC)) and
		950	(EOC.HeaderSig = EndCentralDirSig) and (EOC.ZipCommentLen = 0) then
		951	begin
		952	EOCPossible := True;
		953	res := res or zqbHasEOC;// or zqbGoodComment; // EOC
		954	CenDisk := EOC.CentralDiskNo;
		955	ThisDisk := EOC.ThisDiskNo;
		956	CenOfs := EOC.CentralOffset;
		957	Need64 := NeedLoc64(EOC);
		958	if (CenDisk = 0) and (ThisDisk = 0) then
		959	res := res or zqbIsDiskZero;
		960	// check Zip64 EOC
		961	if Need64 and (fs > sizeof(TZip64EOCLocator)) then
		962	begin // check for locator
		963	if (FileSeek64(FileHandle, fs - sizeof(TZip64EOCLocator), soFromBeginning) <>
		964	-1) and (FileRead(FileHandle, EOCLoc, sizeof(TZip64EOCLocator)) =
		965	sizeof(TZip64EOCLocator)) and (EOCLoc.LocSig = EOC64LocatorSig) then
		966	begin // found possible locator
		967	res := res or zqbHasLoc64;
		968	CenDisk := 0;
		969	ThisDisk := 1;
		970	CenOfs := -1;
		971	end;
		972	end;
		973	if DoCenDir and (CenDisk = ThisDisk) then
		974	begin
		975	res := res or CheckCen(FileHandle, ThisDisk, CenOfs);
		976	exit;
		977	end;
		978	res := res and FileMask; // remove rest
		979	end;
		980	// try to locate EOC
		981	Inc(File_Sze, sizeof(EOC));
		982	Size := MAX_WORD + sizeof(EOC) + sizeof(TZip64EOCLocator);
		983	if Size > File_Sze then
		984	Size := File_Sze;
		985	SetLength(Buf, Size);
		986	Pos0 := Size - (MAX_WORD + sizeof(TZipEndOfCentral));
		987	if Pos0 < 0 then
		988	Pos0 := 0; // lowest buf position for eoc
		989	ReadPos := File_Sze - Size;
		990	if (FileSeek64(FileHandle, Int64(ReadPos), soFromBeginning) <> -1) and
		991	(FileRead(FileHandle, Buf[0], Size) = Size) then
		992	begin
		993	// Finally try to find the EOC record within the last 65K...
		994	BufPos := Size - (sizeof(EOC));
		995	pEOC := PZipEndOfCentral(@Buf[Size - sizeof(EOC)]);
		996	// reverse search
		997	while BufPos > Pos0 do // reverse search
		998	begin
		999	Dec(BufPos);
		1000	Dec(PAnsiChar(pEOC));
		1001	if pEOC^.HeaderSig = EndCentralDirSig then
		1002	begin // possible EOC found
		1003	res := res or zqbHasEOC; // EOC
		1004	// check correct length comment
		1005	if (BufPos + sizeof(EOC) + pEOC^.ZipCommentLen) <= Size then
		1006	res := res or zqbHasComment; // good comment length
		1007	if (BufPos + sizeof(EOC) + pEOC^.ZipCommentLen) <> Size then
		1008	res := res or zqbJunkAtEnd; // has junk
		1009	CenDisk := pEOC^.CentralDiskNo;
		1010	ThisDisk := pEOC^.ThisDiskNo;
		1011	if (CenDisk = 0) and (ThisDisk = 0) then
		1012	res := res or zqbIsDiskZero;
		1013	CenOfs := pEOC^.CentralOffset;
		1014	Need64 := NeedLoc64(pEOC^);
		1015	// check Zip64 EOC
		1016	if Need64 and ((BufPos - sizeof(TZip64EOCLocator)) >= 0) then
		1017	begin // check for locator
		1018	pEOCLoc := PZip64EOCLocator(@Buf[BufPos - sizeof(TZip64EOCLocator)]);
		1019	if pEOCLoc^.LocSig = EOC64LocatorSig then
		1020	begin // found possible locator
		1021	res := res or zqbHasLoc64;
		1022	CenDisk := 0;
		1023	ThisDisk := 1;
		1024	CenOfs := -1;
		1025	end;
		1026	end;
		1027	if DoCenDir and (CenDisk = ThisDisk) then
		1028	begin // verify start of central
		1029	res := res or CheckCen(FileHandle, ThisDisk, CenOfs);
		1030	break;
		1031	end;
		1032	res := res and FileMask; // remove rest
		1033	break;
		1034	end;
		1035	end; // while
		1036	end;
		1037	if EOCPossible then
		1038	res := res or zqbHasEOC;
		1039	except
		1040	Result := zqGeneralError;
		1041	end;
		1042	finally
		1043	File_Close(FileHandle);
		1044	if Result = 0 then
		1045	Result := res;
		1046	end;
		1047	end;
		1048	//? QueryZip
		1049
		1050	function GetVolumeLabel(const drive: String): String;
		1051	var
		1052	Bits: set of 0..25;
		1053	DriveLetter: Char;
		1054	drv: String;
		1055	NamLen: Cardinal;
		1056	Num: Integer;
		1057	OldErrMode: DWord;
		1058	SysFlags: DWord;
		1059	SysLen: DWord;
		1060	VolNameAry: array[0..MAX_BYTE] of Char;
		1061	begin
		1062	Result := '';
		1063	NamLen := MAX_BYTE;
		1064	SysLen := MAX_BYTE;;
		1065	VolNameAry[0] := #0;
		1066	drv := UpperCase(ExpandFileName(drive));
		1067	DriveLetter := drv[1];
		1068	if DriveLetter <> PathDelim{'\'} then // Only for local drives
		1069	begin
		1070	if (DriveLetter < 'A') or (DriveLetter > 'Z') then
		1071	exit;
		1072	Integer(Bits) := GetLogicalDrives();
		1073	Num := Ord(DriveLetter) - Ord('A');
		1074	if not (Num in Bits) then
		1075	exit;
		1076	end;
		1077	OldErrMode := SetErrorMode(SEM_FAILCRITICALERRORS);
		1078	// Turn off critical errors:
		1079	if GetVolumeInformation(PChar(drv), VolNameAry, NamLen, nil, SysLen,
		1080	SysFlags, nil, 0) then
		1081	Result := VolNameAry;
		1082	SetErrorMode(OldErrMode);
		1083	// Restore critical errors:
		1084	end;
		1085
		1086	function IsSameFile(const FName1, FName2: String): Boolean;
		1087	var
		1088	ff1: Boolean;
		1089	ff2: Boolean;
		1090	sr1: TSearchRec;
		1091	sr2: TSearchRec;
		1092	begin
		1093	if CompareText(ExpandFileName(FName1), ExpandFileName(FName2)) = 0 then
		1094	begin
		1095	Result := True;
		1096	exit;
		1097	end;
		1098	Result := False;
		1099	// in windows no alias so names must match
		1100	if CompareText(ExtractFileName(FName1), ExtractFileName(FName2)) = 0 then
		1101	begin
		1102	ff1 := FindFirst(FName1, faAnyFile, sr1) = 0;
		1103	ff2 := FindFirst(FName2, faAnyFile, sr2) = 0;
		1104	if (ff1 = ff2) and not ff1 then
		1105	exit;// neither found assume different
		1106	// Result := CompareText(FName1, FName2) = 0;
		1107	{ $ WARN SYMBOL_PLATFORM OFF}
		1108	if ff1 = ff2 then
		1109	Result := CompareMem(@sr1.FindData, @sr2.FindData, 2 + (4 * 4));// both exist
		1110	if ff1 then
		1111	SysUtils.FindClose(sr1);
		1112	if ff2 then
		1113	SysUtils.FindClose(sr2);
		1114	end;
		1115	end;
		1116
		1117	function OEMToStr(const astr: Ansistring): String;
		1118	var
		1119	buf: String;
		1120	begin
		1121	SetLength(buf, Length(astr) + 3); // allow worst case
		1122	OemToChar(PAnsiChar(astr), PChar(buf));
		1123	Result := PChar(buf);
		1124	end;
		1125
		1126	function StrToOEM(const astr: String): String;
		1127	var
		1128	buf: Ansistring;
		1129	begin
		1130	SetLength(buf, Length(astr) + 3); // allow worst case
		1131	CharToOem(PChar(astr), PAnsiChar(buf));
		1132	buf := PAnsiChar(buf); // remove trailing nul
		1133	Result := String(buf);
		1134	end;
		1135
		1136	{
		1137	return true if contains chars (<#31 ?) >#126
		1138	}
		1139	function StrHasExt(const astr: String): Boolean;
		1140	var
		1141	i: Integer;
		1142	begin
		1143	Result := False;
		1144	for i := 1 to Length(astr) do
		1145	if (astr[i] > #126) or (astr[i] < #31) then
		1146	begin
		1147	Result := True;
		1148	break;
		1149	end;
		1150	end;
		1151
		1152	{$IFDEF UNICODE}
		1153	function StrHasExt(const astr: AnsiString): Boolean;
		1154	var
		1155	i: integer;
		1156	begin
		1157	Result := false;
		1158	for i := 1 to Length(astr) do
		1159	if (astr[i] > #126) or (astr[i] < #31) then
		1160	begin
		1161	Result := True;
		1162	break;
		1163	end;
		1164	end;
		1165
		1166	function StrHasExt(const astr: TZMRawBytes): Boolean;
		1167	var
		1168	i: integer;
		1169	begin
		1170	Result := false;
		1171	for i := 1 to Length(astr) do
		1172	if (astr[i] > #126) or (astr[i] < #31) then
		1173	begin
		1174	Result := True;
		1175	break;
		1176	end;
		1177	end;
		1178	{$ENDIF}
		1179
		1180	function CalcCRC32(const mem; len: Integer; init: DWORD): DWORD;
		1181	var
		1182	i: Integer;
		1183	p: pByte;
		1184	begin
		1185	p := @mem;
		1186	Result := init;
		1187	if (p <> nil) and (len > 0) then
		1188	begin
		1189	Result := Result xor $FFFFFFFF;
		1190	for i := 1 to len do
		1191	begin
		1192	Result := (Result shr 8) xor CRC32Table[(p^ xor Byte(Result))];
		1193	Inc(p);
		1194	end;
		1195	Result := Result xor $FFFFFFFF;
		1196	end;
		1197	end;
		1198
		1199	function LastPos(const s: String; ch: Char; before: Integer = MAXINT): Integer;
		1200	var
		1201	i: Integer;
		1202	begin
		1203	Result := 0; // not found
		1204	for i := 1 to Length(s) do
		1205	begin
		1206	if i >= before then
		1207	break;
		1208	if s[i] = ch then
		1209	Result := i;
		1210	end;
		1211	end;
		1212
		1213	function LastPosW(const s: WideString; wch: Widechar; before: Integer = MAXINT): Integer;
		1214	var
		1215	i: Integer;
		1216	begin
		1217	Result := 0; // not found
		1218	for i := 1 to Length(s) do
		1219	begin
		1220	if i >= before then
		1221	break;
		1222	if s[i] = wch then
		1223	Result := i;
		1224	end;
		1225	end;
		1226
		1227	function IsFolder(const Name: String): Boolean;
		1228	var
		1229	ch: Char;
		1230	begin
		1231	Result := False;
		1232	if Name <> '' then
		1233	begin
		1234	ch := Name[Length(Name)];
		1235	Result := (ch = PathDelim) or (ch = PathDelimAlt);
		1236	end;
		1237	end;
		1238
		1239
		1240	{$IFDEF UNICODE}
		1241	function IsFolder(const name: TZMRawBytes): boolean;
		1242	var
		1243	ch: AnsiChar;
		1244	begin
		1245	Result := False;
		1246	if name <> '' then
		1247	begin
		1248	ch := name[Length(name)];
		1249	Result := (ch = PathDelim) or (ch = PathDelimAlt);
		1250	end;
		1251	end;
		1252	{$ENDIF}
		1253
		1254	// return true if filename is obviously invalid
		1255	function NameIsBad(const astr: String): Boolean;
		1256	var
		1257	i: Integer;
		1258	begin
		1259	Result := (astr = '') or (astr[1] = ' ') or (astr[1] = '\') or
		1260	(Length(astr) > MAX_PATH);
		1261	if not Result then
		1262	for i := 1 to Length(astr) do
		1263	{$IFDEF UNICODE}
		1264	if CharInSet(astr[i], [#0..#31, ':', '<', '>', '\|', '*', '?']) then
		1265	{$ELSE}
		1266	if astr[i] in [#0..#31, ':', '<', '>', '\|', '*', '?'] then
		1267	{$ENDIF}
		1268	begin
		1269	Result := True;
		1270	break;
		1271	end;
		1272	if not Result then
		1273	Result := (AnsiPos('..', astr) > 0) or (AnsiPos('\ ', astr) > 0) or
		1274	(AnsiPos(' \', astr) > 0);
		1275	end;
		1276
		1277	// return exe size (if < 4G)
		1278	// 0 _ not exe
		1279	function ExeSize(fileHandle: Integer): Cardinal;
		1280	var
		1281	bad: Boolean;
		1282	did: Integer;
		1283	sig: DWORD;
		1284	dosHeader: TImageDOSHeader;
		1285	fileHeader: TImageFileHeader;
		1286	sectionHeader: TImageSectionHeader;
		1287	i, NumSections: Integer;
		1288	sectionEnd: Cardinal;
		1289	const
		1290	IMAGE_PE_SIGNATURE = $00004550;
		1291	IMAGE_DOS_SIGNATURE = $5A4D;
		1292	IMAGE_FILE_MACHINE_I386 = $14C;
		1293	begin
		1294	Result := 0;
		1295	bad := True;
		1296	if fileHandle <> -1 then
		1297	begin
		1298	try
		1299	FileSeek(fileHandle, 0, soFromBeginning);
		1300	while True do
		1301	begin
		1302	did := FileRead(fileHandle, dosHeader, sizeof(TImageDOSHeader));
		1303	if (did <> sizeof(TImageDOSHeader)) or
		1304	(dosHeader.e_magic <> IMAGE_DOS_SIGNATURE) then
		1305	break;
		1306	if FileSeek(fileHandle, dosHeader._lfanew, 0) < 0 then
		1307	break;
		1308	did := FileRead(fileHandle, sig, sizeof(DWORD));
		1309	if (did <> sizeof(DWORD)) or (sig <> IMAGE_PE_SIGNATURE) then
		1310	break;
		1311	did := FileRead(fileHandle, fileHeader, sizeof(TImageFileHeader));
		1312	if (did <> sizeof(TImageFileHeader)) or
		1313	(fileHeader.Machine <> IMAGE_FILE_MACHINE_I386) then
		1314	break;
		1315	NumSections := fileHeader.NumberOfSections;
		1316	if FileSeek(fileHandle, sizeof(TImageOptionalHeader), 1) < 0 then
		1317	break;
		1318	bad := False;
		1319	for i := 1 to NumSections do
		1320	begin
		1321	did := FileRead(fileHandle, sectionHeader, sizeof(TImageSectionHeader));
		1322	if (did <> sizeof(TImageSectionHeader)) then
		1323	begin
		1324	bad := True;
		1325	break;
		1326	end;
		1327	sectionEnd := sectionHeader.PointerToRawData + sectionHeader.SizeOfRawData;
		1328	if sectionEnd > Result then
		1329	Result := sectionEnd;
		1330	end;
		1331	end;
		1332	except
		1333	bad := True;
		1334	end;
		1335	end;
		1336	if bad then
		1337	Result := 0;
		1338	end;
		1339
		1340	function ExeSize(const Name: String): Cardinal;
		1341	var
		1342	fh: Integer;
		1343	begin
		1344	Result := 0;
		1345	fh := FileOpen(Name, fmOpenRead);
		1346	if fh <> -1 then
		1347	begin
		1348	Result := ExeSize(fh);
		1349	File_Close(fh);
		1350	end;
		1351	end;
		1352
		1353	// return <0 error
		1354	//const
		1355	// cstNone = 0; // not found
		1356	// cstExe = 1; // might be stub of unknown type
		1357	// cstSFX17 = 2; // found 1.7 SFX headers
		1358	// cstSFX19 = 4; // found 2.0 SFX headers
		1359	// cstDetached = 64; // is detached
		1360	// -7 = Open, read or seek error
		1361	// -8 = memory error
		1362	// -9 = exception error
		1363	// -10 = all other exceptions
		1364
		1365	// check for SFX header or detached header
		1366	function CheckSFXType(const fileHandle: Integer; var ZipName: String;
		1367	var size: Integer): Integer;
		1368	type
		1369	T_header = packed record
		1370	Sig: DWORD;
		1371	Size: Word;
		1372	X: Word;
		1373	end;
		1374	var
		1375	nsize: Integer;
		1376	hed: T_header;
		1377	SFXHeader_end: TSFXFileEndOfHeader_17;
		1378	Detached: TSFXDetachedHeader_17;
		1379	tmp: Ansistring;
		1380	begin
		1381	Result := 0; // default none
		1382	try
		1383	size := ExeSize(fileHandle);
		1384	if size > 0 then
		1385	begin
		1386	ZipName := ExtractNameOfFile(ZipName) + '.zip'; // use default
		1387	while Result = 0 do // HOTFIX-MARX-A
		1388	begin
		1389	Result := -7; // error - maybe read error?
		1390	if FileSeek(fileHandle, size, soFromBeginning) <> size then
		1391	Break;
		1392	// at end of stub - read file header
		1393	if FileRead(fileHandle, hed, sizeof(T_header)) <> sizeof(T_header) then
		1394	break;
		1395	// valid?
		1396	case hed.Sig of
		1397	SFX_HEADER_SIG:
		1398	begin
		1399	// it is new header
		1400	size := size + sizeof(T_header);
		1401	// skip file header
		1402	nsize := Hed.Size - SizeOf(T_header);
		1403	if FileSeek(fileHandle, nsize, soFromCurrent) < 0 then
		1404	break; // error
		1405	// at end of stub - read file header
		1406	if FileRead(fileHandle, hed, sizeof(T_header)) <> sizeof(T_header) then
		1407	break; // invalid
		1408	size := size + nsize;
		1409	if hed.Sig = CentralFileHeaderSig then
		1410	Result := cstSFX19 or cstDetached // found new detached
		1411	else
		1412	if hed.Sig = LocalFileHeaderSig then
		1413	Result := cstSFX19; // found new
		1414	Break;
		1415	end;
		1416	SFX_HEADER_SIG_17:
		1417	begin
		1418	// is old header
		1419	size := size + sizeof(T_header);
		1420	// skip file header
		1421	nsize := Hed.Size - SizeOf(T_header);
		1422	if FileSeek(fileHandle, nsize, soFromCurrent) < 0 then
		1423	break; // error
		1424	if FileRead(fileHandle, SFXHeader_end, sizeof(SFXHeader_end)) <>
		1425	sizeof(SFXHeader_end) then
		1426	break; // invalid
		1427	if (SFXHeader_end.Signature <> SFX_HEADER_END_SIG_17) then
		1428	break; // invalid
		1429	// ignore header size check
		1430	size := size + nsize + sizeof(SFXHeader_end);
		1431	// at end of file header - check for detached header
		1432	if FileRead(fileHandle, detached, sizeof(TSFXDetachedHeader_17)) <>
		1433	sizeof(TSFXDetachedHeader_17) then
		1434	break; // not detached
		1435	if detached.Signature = SFX_DETACHED_HEADER_SIG_17 then
		1436	begin
		1437	size := size + sizeof(TSFXDetachedHeader_17);
		1438	if Detached.NameLen > 0 then
		1439	begin
		1440	SetLength(tmp, Detached.NameLen);
		1441	if FileRead(fileHandle, PAnsiChar(tmp)^, Detached.NameLen) <>
		1442	Integer(Detached.NameLen) then
		1443	break; // invalid
		1444	ZipName := String(tmp) + ExtractFileExt(ZipName);
		1445	size := size + Integer(Detached.NameLen);
		1446	end;
		1447	if Detached.ExtLen > 0 then
		1448	begin
		1449	SetLength(tmp, Detached.ExtLen);
		1450	if FileRead(fileHandle, PAnsiChar(tmp)^, Detached.ExtLen) <>
		1451	Integer(Detached.ExtLen) then
		1452	break; // invalid
		1453	size := size + Integer(Detached.ExtLen);
		1454	ZipName := ExtractNameOfFile(ZipName) + '.' + string(tmp);
		1455	end;
		1456	// at end of file header - check for detached header end
		1457	if (FileRead(fileHandle, detached, sizeof(TSFXDetachedHeader_17)) <>
		1458	sizeof(TSFXDetachedHeader_17)) or
		1459	(detached.Signature <> SFX_DETACHED_HEADER_END_SIG_17) then
		1460	break; // invalid
		1461	size := size + sizeof(TSFXDetachedHeader_17);
		1462	if FileRead(fileHandle, hed, sizeof(DWORD)) <> sizeof(DWORD) then
		1463	break; // invalid
		1464	if hed.Sig = CentralFileHeaderSig then
		1465	Result := cstSFX17 or cstDetached; // found old detached
		1466	end;
		1467	if detached.Signature = LocalFileHeaderSig then
		1468	Result := cstSFX17; // found old
		1469	Break;
		1470	end;
		1471	else
		1472	Result := cstExe; // possibly stub of different loader
		1473	end;
		1474	end;
		1475	end;
		1476	except
		1477	Result := -10;
		1478	end;
		1479	end;
		1480
		1481	function CheckSFXType(const Name: String; var ZipName: String;
		1482	var size: Integer): Integer;
		1483	var
		1484	fh: Integer;
		1485	begin
		1486	Result := 0;
		1487	if AnsiCompareText(ExtractFileExt(Name), '.exe') = 0 then
		1488	begin
		1489	fh := FileOpen(Name, fmOpenRead);
		1490	if fh <> -1 then
		1491	begin
		1492	ZipName := Name;
		1493	Result := CheckSFXType(fh, ZipName, size);
		1494	File_Close(fh);
		1495	end;
		1496	end;
		1497	end;
		1498
		1499	function FileDateToLocalDateTime(stamp: Integer): TDateTime;
		1500	var
		1501	LocTime, FTime: TFileTime;
		1502	SysTime: TSystemTime;
		1503	begin
		1504	Result := 0;
		1505	if DosDateTimeToFileTime(LongRec(stamp).Hi, LongRec(stamp).Lo, LocTime) and
		1506	LocalFileTimeToFileTime(LocTime, FTime) and
		1507	FileTimeToSystemTime(FTime, SysTime) then
		1508	Result := SystemTimeToDateTime(SysTime);
		1509	end;
		1510
		1511	end.
		1512

Subversion Repositories autosfx

autosfx/zmstr1900102/ZMUtils19.pas – Rev 1