Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

source: branches/2.19_branch/Library/ACLFileUtility.pas@ 338

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

Line
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: