Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

source: trunk/Library/ACLFileUtility.pas@ 380

Last change on this file since 380 was 17, checked in by RBRi, 19 years ago
+ Library
Property svn:eol-style set to `native`
File size: 31.6 KB

Rev	Line
[17]	1	Unit ACLFileUtility;
	2
	3	Interface
	4
	5	uses
	6	SysUtils, Classes,
	7	ACLUtility;
	8
	9	const
	10	InvalidFilenameCharacters =
	11	'* ? \ / : < > \|"';
	12	const
	13	HelpPathEnvironmentVar = 'HELP';
	14	BookshelfEnvironmentVar = 'BOOKSHELF';
	15
	16	Function IsValidFilename( const Filename: string ): boolean;
	17
	18	// Returns true for e.g.
	19	// C: or C:\
	20	Function IsRootDir( const Path: string ): boolean;
	21
	22	// Returns true if the dir is not . or ..
	23	Function IsNotDots( const Filename: string ): boolean;
	24
	25	// Expands the path given, relative to BaseDir
	26	// Handles leading \ for root dir,
	27	// .. for parent, . (ignored),
	28	// drive spec at start,
	29	// ignores repeated \ e.g. \\
	30	Function ExpandPath( BaseDir: string;
	31	Path: string ): string;
	32
	33	Function ParentDir( Dir: string ): string;
	34
	35	Function StripDrive( Path: string ): string;
	36
	37	Function ChangeDrive( Path: string;
	38	NewDrive: string ): string;
	39
	40	Procedure MakeFileReadOnly( Filename: string );
	41
	42	Procedure MakeFileReadWrite( Filename: string );
	43
	44	// Deletes files incl readonly
	45	Function MyDeleteFile( Path: string ): boolean;
	46
	47	// Adds a slash to dir if not present
	48	Function AddSlash( Dir: string ): string;
	49
	50	// same, but if empty doesn't add slash
	51	function AddSlashNoRoot( Dir: string ): string;
	52
	53	// Remove slash from end of dir if present
	54	Function RemoveSlash( Dir: string ): string;
	55
	56	// Remove leading slashes from dir if present
	57	Function RemoveLeadingSlashes( Dir: string ): string;
	58
	59	// Returns true if it succeeds in removing the directory
	60	// Always removes readonly files
	61	Function DeleteTree( path: string ): boolean;
	62
	63	Procedure ClearDirectory( Directory: string );
	64
	65	// Get the TMP directory
	66	Function TempDir: string;
	67
	68	// Return a list of files in the given Dir
	69	Procedure GetFilesForDir( Dir: string; List: TStrings );
	70
	71	// Return a list of files in the given Dir. using the given filter
	72	Procedure GetFilteredFilesForDir( Dir: string;
	73	Filter: string;
	74	List: TStrings );
	75
	76	// Returns list of files given dir, using given mask (
	77	// Mask may contain more than one filter e.g. .c;.h
	78	Procedure GetMaskedFilesForDir( Dir: string;
	79	Mask: string;
	80	List: TStrings );
	81
	82	Procedure ListDirectory( const Dir: string;
	83	const Filter: string;
	84	Files: TStrings;
	85	SubDirectories: TStrings );
	86
	87	Procedure ListDirectoryAdditive( const Dir: string;
	88	const Filter: string;
	89	const RelativePath: string;
	90	Files: TStrings;
	91	SubDirectories: TStrings );
	92
	93	// If you don't want subdirectories, leave it nil
	94	Procedure ListDirectoryRecursive( const Dir: string;
	95	const Filter: string;
	96	Files: TStrings;
	97	SubDirectories: TStrings );
	98
	99	Procedure ListDirectoryRecursiveAdditive( const Dir: string;
	100	const Filter: string;
	101	const RelativePath: string;
	102	Files: TStrings;
	103	SubDirectories: TStrings );
	104
	105	Procedure ListDirectoryRecursiveAdditive2( const Dir: string;
	106	const Filter: string;
	107	const RelativePath: string;
	108	Files: TStrings;
	109	SubDirectories: TStrings;
	110	const TerminateCheck: TTerminateCheck;
	111	const UseTerminateCheck: boolean );
	112
	113	// Return a list of files in the given path
	114	Procedure GetFilesForPath( PathEnvVar: string;
	115	Mask: string;
	116	List: TStrings );
	117
	118	// Breaks up specified Env var path
	119	Procedure GetDirsInPath( PathEnvVar: string;
	120	List: TStrings );
	121
	122	// Finds the first matching file
	123	Function GetFirstMatchingFile( Dir: string;
	124	Filter: string ): string;
	125
	126	// In the directory startpath, create directory and subdirectories
	127	// specified in DirsString
	128	// e.g. bob\bill\fred will make bob, then bill in bob, then fred in bob
	129	// returns path to lowest dir created
	130	Function MakeDirs( FullPath: string ):string;
	131
	132	// Returns current path incl drive
	133	Function GetCurrentDir: string;
	134
	135	// Returns date/time of last modification of file
	136	// Returns 0.0 if error
	137	Function FileDateTime( filename: string ): TDateTime;
	138
	139	// Returns true if file exists and is read only
	140	Function FileIsReadOnly( filename: string ):Boolean;
	141
	142	{$ifdef os2}
	143	Function ExtractFileDrive( Path: string ): string;
	144
	145	Function DirectoryExists( Dir: string ):boolean;
	146
	147	Procedure AnsiReadLn( Var TheFile: Text;
	148	Var Line: AnsiString );
	149
	150	Function GetFileSize( Filename: string ): longint;
	151
	152	{$endif}
	153
	154	Function SearchPath( PathEnvVar: string;
	155	Filename: string;
	156	Var FilenameFound: string ): boolean;
	157
	158	{$ifdef os2}
	159	Function SearchHelpPaths( const Filename: string;
	160	var ResultFilename: string;
	161	const IncludeAppDir: boolean ): boolean;
	162
	163	// Find the help file for the current app based on LANG
	164	Function FindDefaultLanguageHelpFile( const AppName: string ): string;
	165	{$endif}
	166
	167	Function RunProgram( FileName: string;
	168	Parameters: string ): boolean;
	169
	170	function DriveLetterToNumber( const Drive: char ): longint;
	171
	172	function DriveNumberToLetter( const DriveNumber: longint ): char;
	173
	174	function GetVolumeLabel( Drive: char ): string;
	175
	176	function GetBootDrive: char;
	177
	178	Function GetLogFilesDir: string;
	179
	180	Implementation
	181
	182	uses
	183	{$ifdef os2}
	184	BseDos, DOS, Os2Def,
	185	{$else}
	186	Windows, FileCtrl,
	187	{$endif}
	188	ACLFindFunctions, ACLStringUtility,
	189	ACLString;
	190
	191	Function IsValidFilename( const Filename: string ): boolean;
	192	var
	193	i: longint;
	194	begin
	195	Result := false;
	196
	197	for i := 1 to Length( Filename ) do
	198	begin
	199	if Filename[ i ]
	200	in [ '*','?','\','/',':','<','>','\|','"' ] then
	201	exit;
	202	end;
	203
	204	Result := true;
	205	end;
	206
	207
	208	Function IsRootDir( const Path: string ): boolean;
	209	begin
	210	Result := false;
	211	case Length( Path ) of
	212	2:
	213	Result := IsAlpha( Path[ 1 ] )
	214	and ( Path[ 2 ] = ':' );
	215
	216	3:
	217	Result := IsAlpha( Path[ 1 ] )
	218	and ( Path[ 2 ] = ':' )
	219	and ( Path[ 3 ] = '\' );
	220	end;
	221	end;
	222
	223	Function IsNotDots( const Filename: string ): boolean;
	224	begin
	225	Result := ( Filename <> '.' )
	226	and ( Filename <> '..' );
	227	end;
	228
	229	Function ParentDir( Dir: string ): string;
	230	var
	231	SlashPos: integer;
	232	begin
	233	Dir := RemoveSlash( Dir );
	234	for SlashPos := Length( Dir ) downto 1 do
	235	begin
	236	if Dir[ SlashPos ] = '\' then
	237	begin
	238	result:= StrLeft( Dir, SlashPos );
	239	exit;
	240	end;
	241	end;
	242	result:= '';
	243	end;
	244
	245	Function ExpandPath( BaseDir: string;
	246	Path: string ): string;
	247	var
	248	Dir: string;
	249	begin
	250	Result:= AddSlash( BaseDir );
	251	Path := trim( path );
	252	if Length( Path ) > 1 then
	253	begin
	254	// check for drive spec
	255	if Path[ 2 ] = ':' then
	256	begin
	257	Result := StrLeft( Path, 2 ) + '\';
	258	Delete( Path, 1, 2 );
	259	Path := RemoveLeadingSlashes( Path );
	260	end
	261	end;
	262
	263	if Length( Path ) > 0 then
	264	begin
	265	// check for root dir spec
	266	if Path[ 1 ] = '\' then
	267	begin
	268	// take just the drive from the basedir
	269	Result := StrLeft( BaseDir, 2 );
	270	Path := RemoveLeadingSlashes( Path );
	271	end;
	272	end;
	273
	274	while Length( Path ) > 0 do
	275	begin
	276	Dir := ExtractNextValue( Path, '\' );
	277	if Dir = '..' then
	278	begin
	279	Result := ParentDir( Result );
	280	end
	281	else if Dir = '.' then
	282	begin
	283	; // nothing to do
	284	end
	285	else
	286	begin
	287	Result := Result + Dir + '\';
	288	end;
	289
	290	// strip any extra leading slashes
	291	Path := RemoveLeadingSlashes( Path );
	292
	293	end;
	294	if Length( Result ) = 2 then
	295	if Result[ 2 ] = ':' then
	296	// just a drive spec X:, so add a slash
	297	Result := Result + '\';
	298	end;
	299
	300	{$ifdef os2}
	301	Function ExtractFileDrive( Path: string ): string;
	302	begin
	303	Result:= '';
	304	if Length( Path ) < 2 then
	305	exit;
	306	if Path[ 2 ] = ':' then
	307	Result:= Copy( Path, 1, 2 );
	308	end;
	309	{$endif}
	310
	311	Function ChangeDrive( Path: string;
	312	NewDrive: string ): string;
	313	var
	314	CurrentDrive: string;
	315	begin
	316	Result:= Path;
	317	CurrentDrive:= ExtractFileDrive( Path );
	318	Result:= RemoveSlash( NewDrive )
	319	+ StrRightFrom( Path, Length( CurrentDrive ) + 1 );
	320	end;
	321
	322	Function StripDrive( Path: string ): string;
	323	begin
	324	Result:= ChangeDrive( Path, '' );
	325	end;
	326
	327	Procedure MakeFileReadOnly( Filename: string );
	328	var
	329	Attributes: longint;
	330	begin
	331	Attributes:= FileGetAttr( FileName );
	332	Attributes:= Attributes or faReadonly;
	333	FileSetAttr( FileName, Attributes );
	334	end;
	335
	336	Procedure MakeFileReadWrite( Filename: string );
	337	var
	338	Attributes: longint;
	339	begin
	340	Attributes:= FileGetAttr( FileName );
	341	Attributes:= Attributes and not faReadonly;
	342	FileSetAttr( FileName, Attributes );
	343	end;
	344
	345	// Deletes files incl readonly
	346	Function MyDeleteFile( Path: string ): boolean;
	347	begin
	348	MakeFileReadWrite( Path );
	349	{$ifdef os2}
	350	Result:= DeleteFile( Path );
	351	{$else}
	352	Result:= DeleteFile( PChar( Path ) );
	353	{$endif}
	354	end;
	355
	356	// Adds a slash if need to Dir
	357	function AddSlash( Dir: string ): string;
	358	begin
	359	if Dir='' then
	360	Result:= '\'
	361	else
	362	if Dir[ length( Dir ) ]<>'\' then
	363	Result:= Dir + '\'
	364	else
	365	Result:= Dir;
	366	end;
	367
	368	function AddSlashNoRoot( Dir: string ): string;
	369	begin
	370	if Dir='' then
	371	Result := ''
	372	else
	373	if Dir[ length( Dir ) ]<>'\' then
	374	Result:= Dir + '\'
	375	else
	376	Result:= Dir;
	377	end;
	378
	379	// Remove slash from end of dir if present
	380	function RemoveSlash( Dir: string ): string;
	381	begin
	382	Result:= Dir;
	383	if Result <> '' then
	384	if Result[ length( Result ) ]='\' then
	385	Delete( Result, length( Result ), 1 );
	386	end;
	387
	388	Function RemoveLeadingSlashes( Dir: string ): string;
	389	begin
	390	Result := Dir;
	391	while Length( Result ) > 0 do
	392	begin
	393	if Result[ 1 ] <> '\' then
	394	break;
	395	Delete( Result, 1, 1 );
	396	end;
	397	end;
	398
	399	Function DeleteTree( path: string ): boolean;
	400	Var
	401	SearchResults: TSearchData;
	402	rc:integer;
	403	Directories: TStringList;
	404	DirectoryIndex: longint;
	405	FullPath: string;
	406	Begin
	407	path:= AddSlash( path );
	408	Directories:= TStringList.Create;
	409	rc:= MyFindFirst( path+'*', SearchResults );
	410	while rc = 0 do
	411	begin
	412	if IsNotDots( SearchResults.Name ) then
	413	begin
	414	FullPath:= path + SearchResults.Name;
	415	if SearchResults.Attr And faDirectory > 0 then
	416	Directories.Add( FullPath )
	417	else
	418	MyDeleteFile( FullPath );
	419	end;
	420	rc:= MyFindNext( SearchResults );
	421	end;
	422
	423	SysUtils.FindClose( SearchResults );
	424
	425	// Now delete directories
	426	for DirectoryIndex:= 0 to Directories.Count-1 do
	427	DeleteTree( Directories[ DirectoryIndex ] );
	428
	429	Directories.Destroy;
	430
	431	// Finally remove the directory itself
	432	RmDir( StrLeftWithout( path, 1 ) );
	433	Result:= (IOResult=0);
	434	End;
	435
	436	Procedure ClearDirectory( Directory: string );
	437	Var
	438	SearchResults: TSearchData;
	439	rc:integer;
	440	FileName: string;
	441	Begin
	442	Directory:= AddSlash( Directory );
	443	rc:= MyFindFirst( Directory + '*', SearchResults );
	444	while rc=0 do
	445	begin
	446	FileName:= Directory + SearchResults.Name;
	447	if SearchResults.Attr and faDirectory = 0 then
	448	MyDeleteFile( FileName );
	449	rc:= MyFindNext( SearchResults );
	450	end;
	451	SysUtils.FindClose( SearchResults );
	452	End;
	453
	454	{$ifdef win32}
	455	Function GetEnv( VariableName: string ): string;
	456	var
	457	RequiredSize: integer;
	458	begin
	459	RequiredSize := GetEnvironmentVariable( PChar( VariableName ), nil, 0 );
	460	if RequiredSize = 0 then
	461	begin
	462	// not defined ?
	463	Result := '';
	464	exit;
	465	end;
	466	SetLength( Result, RequiredSize + 1 );
	467	GetEnvironmentVariable( PChar( VariableName ),
	468	PChar( Result ),
	469	RequiredSize );
	470	SetLength( Result, StrLen( PChar( Result ) ) );
	471	end;
	472	{$endif}
	473
	474	Function TempDir: string;
	475	Begin
	476	// GetTempPath( sizeof( Buffer ), Buffer ); // doesn't work on W2k
	477	Result:= GetEnv( 'TMP' );
	478	if result <> '' then
	479	if not DirectoryExists( Result ) then
	480	result := '';
	481
	482	if Result = '' then
	483	Result := GetEnv( 'TEMP' );
	484
	485	if result <> '' then
	486	if not DirectoryExists( Result ) then
	487	result := '';
	488	Result:= AddSlash( Result );
	489	end;
	490
	491	// Return a list of files in the given Dir. using the given filter
	492	Procedure GetFilteredFilesForDir( Dir: string;
	493	Filter: string;
	494	List: TStrings );
	495	Var
	496	SearchResults: TSearchData;
	497	rc:integer;
	498	Begin
	499	Dir:= AddSlash( Dir );
	500	rc:= MyFindFirst( Dir+Filter, SearchResults );
	501	while rc=0 do
	502	begin
	503	if SearchResults.Attr and faDirectory = 0 then
	504	List.Add( dir + SearchResults.Name );
	505	rc:= MyFindNext( SearchResults );
	506	end;
	507	MyFindClose( SearchResults );
	508	End;
	509
	510	Procedure GetFilesForDir( Dir: string; List: TStrings );
	511	Begin
	512	GetFilteredFilesForDir( Dir, '*', List );
	513	End;
	514
	515	Procedure GetMaskedFilesForDir( Dir: string;
	516	Mask: string;
	517	List: TStrings );
	518	Var
	519	Filter: string;
	520	Begin
	521	while Mask <> '' do
	522	begin
	523	Filter:= ExtractNextValue( Mask, ';' );
	524	GetFilteredFilesForDir( Dir, Filter, List );
	525	end;
	526	End;
	527
	528	Procedure ListDirectoryAdditive( const Dir: string;
	529	const Filter: string;
	530	const RelativePath: string;
	531	Files: TStrings;
	532	SubDirectories: TStrings );
	533	Var
	534	SearchResults: TSearchData;
	535	rc: integer;
	536	Mask: string;
	537	RemainingFIlter: string;
	538	Begin
	539	if Assigned( Files ) then
	540	begin
	541	RemainingFilter := Filter;;
	542
	543	while RemainingFIlter <> '' do
	544	begin
	545	Mask:= ExtractNextValue( RemainingFilter, ';' );
	546	rc:= MyFindFirst( AddSlash( Dir ) + Mask, SearchResults );
	547	while rc = 0 do
	548	begin
	549	if SearchResults.Attr And faDirectory = 0 then
	550	begin
	551	Files.Add( AddSlashNoRoot( RelativePath )
	552	+ SearchResults.Name );
	553	end;
	554	rc:= MyFindNext( SearchResults );
	555	end;
	556
	557	MyFindClose( SearchResults );
	558	end;
	559	end;
	560
	561	if Assigned( SubDirectories ) then
	562	begin
	563	rc:= MyFindFirst( AddSlash( Dir ) + '*', SearchResults );
	564	while rc = 0 do
	565	begin
	566	if SearchResults.Attr And faDirectory > 0 then
	567	begin
	568	if IsNotDots( SearchResults.Name ) then
	569	begin
	570	SubDirectories.Add( SearchResults.Name )
	571	end
	572	end;
	573	rc:= MyFindNext( SearchResults );
	574	end;
	575	MyFindClose( SearchResults );
	576	end;
	577
	578	End;
	579
	580	Procedure ListDirectory( const Dir: string;
	581	const Filter: string;
	582	Files: TStrings;
	583	SubDirectories: TStrings );
	584	begin
	585	if Assigned( Files ) then
	586	Files.Clear;
	587	if Assigned( SubDirectories ) then
	588	SubDirectories.Clear;
	589	ListDirectoryAdditive( Dir,
	590	Filter,
	591	'', // no relative path
	592	Files,
	593	SubDirectories );
	594	end;
	595
	596	Procedure ListDirectoryRecursiveAdditive2( const Dir: string;
	597	const Filter: string;
	598	const RelativePath: string;
	599	Files: TStrings;
	600	SubDirectories: TStrings;
	601	const TerminateCheck: TTerminateCheck;
	602	const UseTerminateCheck: boolean );
	603	var
	604	i: integer;
	605	Directories: TStringList;
	606	Directory: string;
	607	begin
	608	Directories := TStringList.Create;
	609	ListDirectoryAdditive( Dir,
	610	Filter,
	611	RelativePath,
	612	Files,
	613	Directories );
	614	for i := 0 to Directories.Count - 1 do
	615	begin
	616	// if Assigned( TerminateCheck ) then - doesn't work in sibyl
	617	if UseTerminateCheck then
	618	if TerminateCheck then
	619	break;
	620	Directory := Directories[ i ];
	621
	622	if Assigned( SubDirectories ) then
	623	SubDirectories.Add( AddSlashNoRoot( RelativePath )
	624	+ Directory );
	625
	626	ListDirectoryRecursiveAdditive2( AddSlash( Dir )
	627	+ Directory,
	628	Filter,
	629	AddSlashNoRoot( RelativePath )
	630	+ Directory,
	631	Files,
	632	SubDirectories,
	633	TerminateCheck,
	634	UseTerminateCheck );
	635	end;
	636	Directories.Destroy;
	637	end;
	638
	639	Procedure ListDirectoryRecursiveAdditive( const Dir: string;
	640	const Filter: string;
	641	const RelativePath: string;
	642	Files: TStrings;
	643	SubDirectories: TStrings );
	644	begin
	645	ListDirectoryRecursiveAdditive2( Dir,
	646	Filter,
	647	RelativePath,
	648	Files,
	649	SubDirectories,
	650	nil,
	651	false );
	652	end;
	653
	654	Procedure ListDirectoryRecursive( const Dir: string;
	655	const Filter: string;
	656	Files: TStrings;
	657	SubDirectories: TStrings );
	658	begin
	659	if Assigned( Files ) then
	660	Files.Clear;
	661	if Assigned( SubDirectories ) then
	662	SubDirectories.Clear;
	663	ListDirectoryRecursiveAdditive( Dir,
	664	Filter,
	665	'',
	666	Files,
	667	SubDirectories );
	668	end;
	669
	670	Procedure GetFilesForPath( PathEnvVar: string;
	671	Mask: string;
	672	List: TStrings );
	673	var
	674	rc: longint;
	675	Path: TAString;
	676	Dir: TAstring;
	677	NextDir: longint;
	678	{$ifdef os2}
	679	pszPath: PChar;
	680	szEnvVar: cstring;
	681	{$else}
	682	pszPath: array[ 0..2000 ] of char;
	683	{$endif}
	684	begin
	685	{$ifdef os2}
	686	szEnvVar:= PathEnvVar;
	687	rc := DosScanEnv( szEnvVar, pszPath );
	688	{$else}
	689	rc := GetEnvironmentVariable( Pchar( PathEnvVar ),
	690	pszPath,
	691	sizeof( pszPath ) );
	692	{$endif}
	693	if rc <> 0 then
	694	exit;
	695	Path:= TAString.CreateFromPChar( pszPath );
	696	Dir:= TAstring.Create;
	697
	698	NextDir:= 0;
	699
	700	while NextDir < Path.Length do
	701	begin
	702	Path.ExtractNextValue( NextDir, Dir, ';' );
	703	GetMaskedFilesForDir( ExpandFileName( Dir.AsString ),
	704	Mask,
	705	List );
	706	end;
	707
	708	Dir.Destroy;
	709	Path.Destroy;
	710
	711	end;
	712
	713	Procedure GetDirsInPath( PathEnvVar: string;
	714	List: TStrings );
	715	var
	716	rc: longint;
	717	Path: TAString;
	718	Dir: TAstring;
	719	NextDir: longint;
	720	{$ifdef os2}
	721	pszPath: PChar;
	722	szEnvVar: cstring;
	723	{$else}
	724	pszPath: array[ 0..2000 ] of char;
	725	{$endif}
	726	begin
	727	{$ifdef os2}
	728	szEnvVar:= PathEnvVar;
	729	rc := DosScanEnv( szEnvVar, pszPath );
	730	{$else}
	731	rc := GetEnvironmentVariable( Pchar( PathEnvVar ),
	732	pszPath,
	733	sizeof( pszPath ) );
	734	{$endif}
	735	if rc <> 0 then
	736	exit;
	737	Path:= TAString.CreateFromPChar( pszPath );
	738	Dir:= TAstring.Create;
	739	List.Clear;
	740
	741	NextDir:= 0;
	742
	743	while NextDir < Path.Length do
	744	begin
	745	Path.ExtractNextValue( NextDir, Dir, ';' );
	746	List.Add( Dir.AsString );
	747	end;
	748
	749	Dir.Destroy;
	750	Path.Destroy;
	751
	752	end;
	753
	754	Function GetFirstMatchingFile( Dir: string;
	755	Filter: string ): string;
	756	Var
	757	SearchResults: TSearchData;
	758	rc:integer;
	759	Begin
	760	result := '';
	761	Dir:= AddSlash( Dir );
	762	rc:= MyFindFirst( Dir+Filter, SearchResults );
	763	while rc=0 do
	764	begin
	765	if SearchResults.Attr and faDirectory = 0 then
	766	begin
	767	result := dir + SearchResults.Name;
	768	break;
	769	end;
	770	rc:= MyFindNext( SearchResults );
	771	end;
	772	MyFindClose( SearchResults );
	773	End;
	774
	775	Function MakeDirs( FullPath: string ): string;
	776	Var
	777	RemainingDirs: string;
	778	NewDir: string;
	779	CreatePath:string;
	780	Begin
	781	CreatePath:= '';
	782
	783	// Iterate thru specified dirs
	784	RemainingDirs:= FullPath;
	785	while trim( RemainingDirs )<>'' do
	786	begin
	787	NewDir:= ExtractNextValue( RemainingDirs, '\' );
	788	if NewDir<>'' then
	789	begin
	790	CreatePath:= CreatePath + NewDir;
	791	if not DirectoryExists( CreatePath ) then
	792	begin
	793	MkDir( CreatePath );
	794	end;
	795	CreatePath:= CreatePath + '\';
	796	end;
	797	end;
	798	// Remove the end \
	799	Result:= RemoveSlash( CreatePath );
	800	end;
	801
	802	// Returns current path incl drive
	803	{$ifdef os2}
	804	Function GetCurrentDir: string;
	805	Var
	806	CurrentDir: cstring[ 200 ];
	807	CurrentDirLen: longword;
	808	CurrentDisk: longword;
	809	DiskMap: longword;
	810	Begin
	811	CurrentDirLen:= sizeof( CurrentDir );
	812	DosQueryCurrentDisk( CurrentDisk, DiskMap );
	813	DosQueryCurrentDir( CurrentDisk,
	814	CurrentDir,
	815	CurrentDirLen );
	816
	817	// Form drive part
	818	Result:= Chr( Ord( 'A' ) + CurrentDisk - 1 ) + ':\';
	819	// Add directory
	820	Result:= AddSlash( Result + CurrentDir );
	821	End;
	822	{$else}
	823	Function GetCurrentDir: string;
	824	begin
	825	GetDir( 0, Result );
	826	end;
	827	{$endif}
	828
	829	Function FileDateTime( filename: string ):TDateTime;
	830	Var
	831	FileDate: longint;
	832	Begin
	833	FileDate:=FileAge( filename );
	834	if FileDate=-1 then
	835	begin
	836	Result:=0.0;
	837	exit;
	838	end;
	839	Result:=FileDateToDateTime( FileDate );
	840	end;
	841
	842	Function FileIsReadOnly( filename: string ):Boolean;
	843	Begin
	844	Result:=( FileGetAttr( filename ) and faReadonly ) >0;
	845	End;
	846
	847	Procedure AnsiReadLn( Var TheFile: Text;
	848	Var Line: AnsiString );
	849	Var
	850	C: Char;
	851	FoundCR: boolean;
	852	Begin
	853	Line:= '';
	854	FoundCR:= false;
	855	while not eof( TheFile ) do
	856	begin
	857	Read( TheFile, C );
	858	if ( C=#10 ) then
	859	begin
	860	if FoundCR then
	861	exit; // reached end of line
	862	end
	863	else
	864	begin
	865	if FoundCR then
	866	// last CR was not part of CR/LF so add to string
	867	line:= line+#13;
	868	end;
	869	FoundCR:= (C=#13);
	870	if not FoundCR then // don't handle 13's till later
	871	begin
	872	line:= line+C;
	873	end;
	874	end;
	875
	876	if FoundCR then
	877	// CR was last char of file, but no LF so add to string
	878	line:= line+#13;
	879	End;
	880
	881	{$ifdef os2}
	882	Function DirectoryExists( Dir: string ):boolean;
	883	Var
	884	SearchRec: TSearchData;
	885	rc: longint;
	886	DriveMap: LongWord;
	887	ActualDrive: LongWord;
	888	Drive: Char;
	889	DriveNum: longword;
	890	DriveBit: longword;
	891	Begin
	892	Result:= false;
	893	Dir:= RemoveSlash( Dir );
	894	if Dir = '' then
	895	begin
	896	Result:= true;
	897	exit;
	898	end;
	899	if length( Dir ) = 2 then
	900	if Dir[ 2 ] = ':' then
	901	begin
	902	// a drive only has been specified
	903	Drive:= UpCase( Dir[ 1 ] );
	904	if ( Drive < 'A' ) or ( Drive > 'Z' ) then
	905	exit;
	906	DosQueryCurrentDisk( ActualDrive, DriveMap );
	907	DriveNum:= Ord( Drive ) - Ord( 'A' ) + 1; // A -> 1, B -> 2...
	908	DriveBit:= 1 shl (DriveNum-1); // 2^DriveNum
	909	if ( DriveMap and ( DriveBit ) > 0 ) then
	910	Result:= true;
	911	exit;
	912	end;
	913
	914	rc:= MyFindFirst( Dir, SearchRec );
	915	if rc = 0 then
	916	if ( SearchRec.Attr and faDirectory )>0 then
	917	Result:= true;
	918	MyFindClose( SearchRec );
	919	End;
	920
	921	Function GetFileSize( Filename: string ): longint;
	922	var
	923	szFilename: Cstring;
	924	FileInfo: FILESTATUS3; /* File info buffer */
	925	rc: APIRET; /* Return code */
	926	begin
	927	szFilename:= FileName;
	928	rc := DosQueryPathInfo( szFilename,
	929	1,
	930	FileInfo,
	931	sizeof( FileInfo ) );
	932	if rc = 0 then
	933	Result:= FileInfo.cbFile
	934	else
	935	Result:= -1;
	936	end;
	937	{$endif}
	938
	939	{$ifdef os2}
	940	Function SearchPath( PathEnvVar: string;
	941	Filename: string;
	942	Var FilenameFound: string ): boolean;
	943	var
	944	szEnvVar: cstring;
	945	szFilename: cstring;
	946	szFilenameFound: cstring;
	947	rc: APIRET;
	948	begin
	949	Result:= false;
	950	FilenameFound:= '';
	951
	952	szEnvVar:= PathEnvVar;
	953	szFilename:= Filename;
	954	rc:= DosSearchPath( SEARCH_IGNORENETERRS
	955	+ SEARCH_ENVIRONMENT
	956	+ SEARCH_CUR_DIRECTORY,
	957	szEnvVar,
	958	szFilename,
	959	szFilenameFound,
	960	sizeof( szFilenameFound ) );
	961
	962	if rc = 0 then
	963	begin
	964	Result:= true;
	965	FilenameFound:= szFilenameFound;
	966	end
	967	end;
	968	{$else}
	969
	970	Function SearchPath( PathEnvVar: string;
	971	Filename: string;
	972	Var FilenameFound: string ): boolean;
	973	var
	974	Buffer: array[ 0.._MAX_PATH ] of char;
	975	rc: DWORD;
	976	FilePart: PChar;
	977	begin
	978	Result:= false;
	979	FilenameFound:= '';
	980
	981	rc:= Windows.SearchPath( PChar( PathEnvVar ),
	982	PChar( Filename ),
	983	nil,
	984	sizeof( Buffer ),
	985	Buffer,
	986	FilePart );
	987
	988	if rc = 0 then
	989	begin
	990	Result:= true;
	991	FilenameFound:= Buffer;
	992	end
	993	end;
	994	{$endif}
	995
	996	{$ifdef os2}
	997	Function RunProgram( FileName: string;
	998	Parameters: string ): boolean;
	999	var
	1000	Dir: string;
	1001	Found: boolean;
	1002	Dummy: string;
	1003	Extension: string;
	1004	begin
	1005	Dir:= ExtractFilePath( FileName );
	1006	if Dir = '' then
	1007	Found:= SearchPath( 'PATH',
	1008	Filename,
	1009	Dummy )
	1010	else
	1011	// file path specified...
	1012	Found:= FileExists( FileName );
	1013
	1014	if not Found then
	1015	begin
	1016	Result:= false;
	1017	exit;
	1018	end;
	1019
	1020	Result:= true;
	1021
	1022	Extension:= ExtractFileExt( FileName );
	1023	if StringsSame( Extension, '.exe' ) then
	1024	Exec( FileName,
	1025	Parameters )
	1026	else
	1027	Exec( 'cmd.exe',
	1028	'/c '
	1029	+ FileName
	1030	+ ' '
	1031	+ Parameters );
	1032
	1033	end;
	1034	{$else}
	1035	Function RunProgram( FileName: string;
	1036	Parameters: string ): boolean;
	1037	Var
	1038	StartupInfo: TStartupInfo;
	1039	ProcessInfo: TProcessInformation;
	1040	NameAndArgs: string;
	1041	Begin
	1042	NameAndArgs:= FileName+' '+Parameters;
	1043
	1044	// Initialize some variables to create a process
	1045	ZeroMemory( @StartupInfo, SizeOf( StartupInfo ) );
	1046
	1047	StartupInfo.cb := SizeOf( StartupInfo );
	1048	StartupInfo.dwFlags := STARTF_USESTDHANDLES;
	1049
	1050	// Create the process
	1051	Result:= CreateProcess( Nil, // use next param for exe name
	1052	PChar( NameAndArgs ), // command line
	1053	Nil, // no security attributes
	1054	Nil, // no thread security attributes
	1055	True, // do inherit handles
	1056	CREATE_NEW_PROCESS_GROUP, // so we can send
	1057	// it Ctrl signals
	1058	Nil, // no new environment
	1059	Nil, // use current directory
	1060	StartupInfo,
	1061	ProcessInfo );
	1062	if not Result then
	1063	exit;
	1064
	1065	end;
	1066	{$endif}
	1067
	1068	function DriveLetterToNumber( const Drive: char ): longint;
	1069	begin
	1070	if ( Drive >= 'a' )
	1071	and ( Drive <= 'z' ) then
	1072	Result := Ord( Drive ) - Ord( 'a' ) + 1
	1073
	1074	else if ( Drive >= 'A' )
	1075	and ( Drive <= 'Z' ) then
	1076	Result := Ord( Drive ) - Ord( 'A' ) + 1
	1077
	1078	else
	1079	// not a valid drive letter
	1080	Result := 0;
	1081
	1082	end;
	1083
	1084	function DriveNumberToLetter( const DriveNumber: longint ): char;
	1085	begin
	1086	Result := Chr( DriveNumber - 1 + Ord( 'A' ) );
	1087	end;
	1088
	1089	function GetVolumeLabel( Drive: char ): string;
	1090	{$ifdef os2}
	1091	var
	1092	rc: APIRET;
	1093	FileSystemInfo: FSINFO;
	1094	e: EInOutError;
	1095	begin
	1096	DosErrorAPI( FERR_DISABLEHARDERR );
	1097	result := '';
	1098	rc := DosQueryFSInfo( DriveLetterToNumber( Drive ),
	1099	FSIL_VOLSER,
	1100	FileSystemInfo,
	1101	sizeof( FileSystemInfo ) );
	1102	if rc = 0 then
	1103	begin
	1104	Result := StrNPas( Addr( FileSystemInfo.vol.szVolLabel ),
	1105	FileSystemInfo.vol.cch );
	1106	Result := LowerCase( Result );
	1107	end;
	1108	DosErrorAPI( FERR_ENABLEHARDERR );
	1109
	1110	if rc <> 0 then
	1111	begin
	1112	e := EInOutError.Create( 'Cannot read drive '
	1113	+ Drive
	1114	+ ':' );
	1115	e.ErrorCode := rc;
	1116	raise e;
	1117	end;
	1118	end;
	1119	{$endif}
	1120	{$ifdef win32}
	1121	var
	1122	VolumeName: array[ 0..MAX_PATH ] of char;
	1123	FileSystemName: array[ 0..MAX_PATH ] of char;
	1124	SerialNumber: DWORD;
	1125	MaximumFilenameComponentLength: DWORD;
	1126	FileSystemFlags: DWORD;
	1127	OldErrorMode: DWORD;
	1128	e: EInOutError;
	1129	begin
	1130	OldErrorMode := SetErrorMode( SEM_FAILCRITICALERRORS );
	1131	if GetVolumeInformation(
	1132	PChar( Drive ), // root directory of the file system
	1133	VolumeName, // name of the volume
	1134	sizeof( VolumeName ), // length of VolumeNameBuffer
	1135	@ SerialNumber, // volume serial number
	1136	MaximumFilenameComponentLength, // system's maximum filename length
	1137	FileSystemFlags, // address of file system flags
	1138	FileSystemName, // address of name of file system
	1139	sizeof( FileSystemName ) // length of lpFileSystemNameBuffer
	1140	) then
	1141	begin
	1142	Result := VolumeName;
	1143	end
	1144	else
	1145	begin
	1146	e := EInOutError.Create( 'Cannot read drive '
	1147	+ Drive
	1148	+ ':' );
	1149	e.ErrorCode := GetLastError;
	1150	raise e;
	1151	end;
	1152	SetErrorMode( OldErrorMode );
	1153	end;
	1154	{$endif}
	1155
	1156	function GetBootDrive: char;
	1157	{$ifdef os2}
	1158	var
	1159	buffer: longword;
	1160	begin
	1161	DosQuerySysInfo( QSV_BOOT_DRIVE,
	1162	QSV_BOOT_DRIVE,
	1163	buffer,
	1164	sizeof( buffer ) );
	1165	Result := chr( ord( 'A' ) + buffer - 1 );
	1166	end;
	1167	{$endif}
	1168	{$ifdef win32}
	1169	var
	1170	WindowsDir: array[ 0..MAX_PATH ] of char;
	1171	begin
	1172	GetWindowsDirectory( WindowsDir,
	1173	sizeof( WindowsDir ) );
	1174	if Strlen( WindowsDir ) > 0 then
	1175	Result := WindowsDir[ 0 ] // not it's an array not a string!
	1176	else
	1177	Result := 'C'; // what the ...!
	1178	end;
	1179	{$endif}
	1180
	1181	Function GetLogFilesDir: string;
	1182	begin
	1183	{$ifdef os2}
	1184	// ecomstation 1.1 compat
	1185	Result := GetEnv( 'LOGFILES' );
	1186	if Result <> '' then
	1187	begin
	1188	Result := AddSlash( Result );
	1189	exit;
	1190	end;
	1191	{$endif}
	1192	Result := AddSlash( GetApplicationDir )
	1193	end;
	1194
	1195	{$ifdef os2}
	1196	Function SearchHelpPaths( const Filename: string;
	1197	var ResultFilename: string;
	1198	const IncludeAppDir: boolean ): boolean;
	1199	begin
	1200	Result := SearchPath( HelpPathEnvironmentVar,
	1201	FileName,
	1202	ResultFilename );
	1203	if not Result then
	1204	Result := SearchPath( BookshelfEnvironmentVar,
	1205	FileName,
	1206	ResultFilename );
	1207	if ( not Result ) and IncludeAppDir then
	1208	begin
	1209	ResultFilename := AddSlash( GetApplicationDir )
	1210	+ Filename;
	1211	Result := FileExists( ResultFilename );
	1212	if not Result then
	1213	ResultFilename := '';
	1214	end;
	1215
	1216	end;
	1217
	1218	Function FindDefaultLanguageHelpFile( const AppName: string ): string;
	1219	var
	1220	LanguageVar: string;
	1221	MajorLanguage: string;
	1222	MinorLanguage: string;
	1223	begin
	1224	LanguageVar := GetEnv( 'LANG' );
	1225
	1226	result := '';
	1227
	1228	if LanguageVar = '' then
	1229	LanguageVar := 'EN_US';
	1230
	1231	MajorLanguage := ExtractNextValue( LanguageVar, '_' );
	1232	MinorLanguage := ExtractNextValue( LanguageVar, '_' );
	1233
	1234	// note there might be some other stuff on the end of LANG
	1235	// such as ES_ES_EURO...
	1236
	1237	if MinorLanguage <> '' then
	1238	begin
	1239	if SearchHelpPaths( AppName
	1240	+ '_'
	1241	+ MajorLanguage
	1242	+ '_'
	1243	+ MinorLanguage
	1244	+ '.hlp',
	1245	Result,
	1246	true ) then
	1247	begin
	1248	// found a specifc language
	1249	exit;
	1250	end;
	1251	end;
	1252
	1253	// try generic language?
	1254	if SearchHelpPaths( AppName
	1255	+ '_'
	1256	+ MajorLanguage
	1257	+ '.hlp',
	1258	Result,
	1259	true ) then
	1260	begin
	1261	exit;
	1262	end;
	1263
	1264	SearchHelpPaths( AppName + '.hlp', Result, true );
	1265
	1266	end;
	1267	{$endif}
	1268
	1269	Initialization
	1270	End.
	1271

Note: See TracBrowser for help on using the repository browser.

Download in other formats: