source: trunk/NewView/FileUtilsUnit.pas@ 82

Last change on this file since 82 was 82, checked in by RBRi, 18 years ago

file util refactoring and many more unit tests
  • Property svn:eol-style set to native
File size: 13.9 KB
RevLine 
[82]1Unit FileUtilsUnit;
2
3// NewView - a new OS/2 Help Viewer
4// Copyright 2006/2007 Ronald Brill (rbri at rbri dot de)
5// This software is released under the GNU Public License - see readme.txt
6
7// Helper functions for file handling
8
9Interface
10
11uses
12 Classes,
13 ACLUtility;
14
15
16const
17 DirectorySeparator = '\';
18 PATH_SEPARATOR = ';';
19
20 // TODO
21 HelpPathEnvironmentVar = 'HELP';
22 BookshelfEnvironmentVar = 'BOOKSHELF';
23 LanguageEnvironmentVar = 'LANG';
24 DEFAULT_LANGUAGE = 'EN_US';
25 HELP_FILE_EXTENSION = '.hlp';
26
27
28 // Adds a slash to the end of dir if not present
29 // if aDir is empty this returns '\'
30 Function AddDirectorySeparator(aDirectory : String) : String;
31
32 // Adds a slash to the end of dir if not present
33 // if aDir is empty this returns ''
34 Function AddDirectorySeparatorIfNotEmpty(aDirectory: String) : String;
35
36 // Removes a directory seperator from the end of aDirectory
37 // (if present)
38 Function RemoveRightDirectorySeparator(aDirectory : String) : String;
39
40 // Expands the path given, relative to aBaseDirectory
41 // Handles leading \ for root dir,
42 // .. for parent, . (ignored),
43 // drive spec at start,
44 // ignores repeated \ e.g. \\
45 Function ExpandPath(aBaseDirectory : String; aPath : String): String;
46
47 Function GetLogFilesDir: String;
48
49 Function SearchPath(const aPathEnvVar: String; const aFilename: String; var aResultFilename: String) : boolean;
50
51 Function SearchHelpPaths(const aFilename: String; var aResultFilename: String; const anIncludeAppDir: boolean) : boolean;
52
53 // Find the help file for the current app based on LANG
54 Function FindDefaultLanguageHelpFile(const anApplicationName: String; const aLanguage : String) : String;
55
56 // Breaks up specified Env var path
57 Procedure GetDirsInPath(const aPathEnvVar: String; var aList: TStrings);
58
59 // searches for all files in aDirectory matching aFilter and add
60 // them to aList
61 // it is possible to define different filter if you separate them by semicolon
62 Procedure ListFilesInDirectory(const aDirectory: String; const aFilter: String; var aList: TStrings);
63
64 // searches for all directories in aDirectory and add them to aList
65 Procedure ListSubDirectories(const aDirectory: String; var aList: TStrings);
66
67 Procedure ListFilesInDirectoryRecursiveWithTermination(const aDirectory : String;
68 const aFilter : String;
69 var aList : TStrings;
70 const aTerminateCheck : TTerminateCheck;
71 const aUseTerminateCheck : boolean);
72
73 Function ParentDir(const aDirectory : String) : String;
74
75 Function DirectoryExists(const aDirectory : String) : boolean;
76
77Implementation
78
79uses
80 Dos,
81 BseDos,
82 Os2Def,
83 SysUtils,
84 StringUtilsUnit;
85
86 Function AddDirectorySeparator(aDirectory : String) : String;
87 begin
88 if aDirectory = '' then
89 begin
90 Result:= DirectorySeparator;
91 exit;
92 end;
93
94 if aDirectory[length(aDirectory)] <> DirectorySeparator then
95 begin
96 Result := aDirectory + DirectorySeparator;
97 exit;
98 end;
99
100 Result := aDirectory;
101 end;
102
103
104 Function AddDirectorySeparatorIfNotEmpty(aDirectory: String): String;
105 begin
106 if aDirectory = '' then
107 begin
108 Result := '';
109 exit;
110 end;
111 Result := AddDirectorySeparator(aDirectory);
112 end;
113
114
115 Function RemoveRightDirectorySeparator(aDirectory : String) : String;
116 begin
117 Result := StrTrimRightChars(aDirectory, [DirectorySeparator]);
118 end;
119
120
121 Function ExpandPath(aBaseDirectory : String; aPath : String): String;
122 var
123 tmpDirectory: String;
124 tmpDirectories : TStringList;
125 i : integer;
126 begin
127 Result:= aBaseDirectory;
128
129 if aPath = '' then
130 begin
131 Result := StrTrimRightChars(Result, [DirectorySeparator]);
132 exit;
133 end;
134
135 aPath := trim(aPath);
136 if Length(aPath) > 1 then
137 begin
138 // check for drive spec
139 if aPath[2] = ':' then
140 begin
141 Result := AddDirectorySeparator(aPath);
142 if Length(aPath) > 3 then
143 begin
144 Result := StrTrimRightChars(Result, [DirectorySeparator]);
145 end;
146 exit;
147 end
148 end;
149
150 if Length(aPath) > 0 then
151 begin
152 // check for root dir spec
153 if aPath[1] = DirectorySeparator then
154 begin
155 // take just the drive from the basedir
156 if aBaseDirectory[2] = ':' then
157 begin
158 Result := StrLeft(aBaseDirectory, 2);
159 end
160 else
161 begin
162 Result := DirectorySeparator;
163 end;
164 aPath := StrTrimLeftChars(aPath, [DirectorySeparator]);
165 end;
166 end;
167
168 tmpDirectories := TStringList.Create;
169 StrExtractStringsIgnoreEmpty(tmpDirectories, aPath, [DirectorySeparator], #0);
170 for i := 0 to tmpDirectories.count-1 do
171 begin
172 tmpDirectory := tmpDirectories[i];
173 if tmpDirectory = '..' then
174 begin
175 if NOT ((Length(Result) = 2) AND (Result[2] = ':')) then
176 begin
177 Result := ParentDir(Result);
178 end;
179 end
180 else if tmpDirectory = '.' then
181 begin
182 ; // nothing to do
183 end
184 else
185 begin
186 Result := AddDirectorySeparator(Result) + tmpDirectory;
187 end;
188
189 // strip any extra leading slashes
190 aPath := StrTrimLeftChars(aPath, [DirectorySeparator]);
191 end;
192 tmpDirectories.Destroy;
193
194// Result := StrTrimRightChars(Result, [DirectorySeparator]);
195
196 if Length(Result) = 2 then
197 begin
198 if Result[2] = ':' then
199 begin
200 // just a drive spec X:, so add a slash
201 Result := Result + DirectorySeparator;
202 end;
203 end;
204 end;
205
206 Function GetLogFilesDir: String;
207 begin
208 // ecomstation 1.1 compat
209 Result := GetEnv('LOGFILES');
210 if Result <> '' then
211 begin
212 Result := AddDirectorySeparator(Result);
213 exit;
214 end;
215 // TODO
216 Result := AddDirectorySeparator(GetApplicationDir);
217 end;
218
219
220 Function SearchPath(const aPathEnvVar: String;
221 const aFilename: String;
222 var aResultFilename: String) : boolean;
223 var
224 tmpSzEnvVar : CString;
225 tmpSzFilename : CString;
226 tmpSzFilenameFound : CString;
227 tmpRC: APIRET;
228 begin
229 Result := false;
230 aResultFilename := '';
231
232 tmpSzEnvVar := aPathEnvVar;
233 tmpSzFilename := aFilename;
234 tmpRC := DosSearchPath( SEARCH_IGNORENETERRS
235 + SEARCH_ENVIRONMENT
236 + SEARCH_CUR_DIRECTORY,
237 tmpSzEnvVar,
238 tmpSzFilename,
239 tmpSzFilenameFound,
240 sizeof(tmpSzFilenameFound));
241 if tmpRC = 0 then
242 begin
243 Result := true;
244 aResultFilename := tmpSzFilenameFound;
245 end;
246 end;
247
248
249 Function SearchHelpPaths(const aFilename: String;
250 var aResultFilename: String;
251 const anIncludeAppDir: boolean) : boolean;
252 begin
253 Result := SearchPath(HelpPathEnvironmentVar, aFileName, aResultFilename);
254 if not Result then
255 begin
256 Result := SearchPath(BookshelfEnvironmentVar, aFileName, aResultFilename);
257 end;
258
259 if (not Result) and anIncludeAppDir then
260 begin
261 aResultFilename := AddDirectorySeparator(GetApplicationDir) + aFilename;
262 Result := FileExists(aResultFilename);
263 if not Result then
264 begin
265 aResultFilename := '';
266 end;
267 end;
268 end;
269
270
271 Function FindDefaultLanguageHelpFile(const anApplicationName: String; const aLanguage : String) : String;
272 var
273 tmpLanguage : String;
274 tmpLanguageParts : TStringList;
275 tmpMajorLanguage : String;
276 tmpMinorLanguage : String;
277 begin
278 Result := '';
279
280 tmpLanguage := aLanguage;
281 if aLanguage = '' then
282 begin
283 tmpLanguage := DEFAULT_LANGUAGE;
284 end;
285
286 tmpLanguageParts := TStringList.Create;
287 StrExtractStrings(tmpLanguageParts, tmpLanguage, ['_'], #0);
288
289 tmpMajorLanguage := '';
290 if tmpLanguageParts.count > 0 then
291 begin
292 tmpMajorLanguage := tmpLanguageParts[0];
293 end;
294
295 tmpMinorLanguage := '';
296 if tmpLanguageParts.count > 1 then
297 begin
298 tmpMinorLanguage := tmpMinorLanguage[1];
299 end;
300
301 tmpLanguageParts.Destroy;
302
303 // note there might be some other stuff on the end of LANG
304 // such as ES_ES_EURO...
305 if tmpMinorLanguage <> '' then
306 begin
307 if SearchHelpPaths( anApplicationName
308 + '_' + tmpMajorLanguage
309 + '_' + tmpMinorLanguage
310 + HELP_FILE_EXTENSION,
311 Result,
312 true ) then
313 begin
314 // found a specifc language
315 exit;
316 end;
317 end;
318
319 // try generic language?
320 if SearchHelpPaths( anApplicationName
321 + '_' + tmpMajorLanguage
322 + HELP_FILE_EXTENSION,
323 Result,
324 true ) then
325 begin
326 exit;
327 end;
328
329 // nothing specific, search for default
330 SearchHelpPaths(anApplicationName + HELP_FILE_EXTENSION, Result, true);
331 end;
332
333
334 Procedure GetDirsInPath(const aPathEnvVar: String; var aList: TStrings);
335 var
336 tmpRC : APIRET;
337 tmpPszPathEnvVar : PChar;
338 tmpSzEnvVar : CString;
339 begin
340 // do this in any case also if there is an error
341 // to garantie a defined behavior
342 aList.Clear;
343
344 tmpSzEnvVar := aPathEnvVar;
345 tmpRC := DosScanEnv(tmpSzEnvVar, tmpPszPathEnvVar);
346
347 if tmpRC <> 0 then
348 begin
349 exit;
350 end;
351
352 StrExtractStringsIgnoreEmpty(aList, StrPas(tmpPszPathEnvVar), [PATH_SEPARATOR], #0);
353 end;
354
355
356 Procedure ListFilesInDirectory(const aDirectory: String; const aFilter: String; var aList: TStrings);
357 var
358 tmpRC : APIRET;
359 tmpSearchResults: TSearchRec;
360 tmpMask: String;
361 tmpFilterParts : TStringList;
362 i : integer;
363 begin
364 tmpFilterParts := TStringList.Create;
365 StrExtractStrings(tmpFilterParts, aFilter, [PATH_SEPARATOR], #0);
366
367 for i:=0 to tmpFilterParts.count-1 do
368 begin
369 tmpMask := tmpFilterParts[i];
370 tmpRC := FindFirst(AddDirectorySeparator(aDirectory) + tmpMask, faAnyFile, tmpSearchResults);
371
372 while tmpRC = 0 do
373 begin
374 if tmpSearchResults.Attr And faDirectory = 0 then
375 begin
376 aList.Add(AddDirectorySeparatorIfNotEmpty(aDirectory) + tmpSearchResults.Name );
377 end;
378
379 tmpRC := FindNext(tmpSearchResults);
380 end;
381
382 FindClose(tmpSearchResults);
383 end;
384 tmpFilterParts.Destroy;
385 end;
386
387
388 Procedure ListSubDirectories(const aDirectory: String; var aList: TStrings);
389 var
390 tmpRC : APIRET;
391 tmpSearchResults: TSearchRec;
392 tmpName : String;
393 begin
394
395 tmpRC := FindFirst(AddDirectorySeparator(aDirectory) + '*', faDirectory or faMustDirectory, tmpSearchResults);
396 if (tmpRC <> 0) then
397 begin
398 exit;
399 end;
400
401 while tmpRC = 0 do
402 begin
403 tmpName := tmpSearchResults.Name;
404 if (tmpName <> '.') AND (tmpName <> '..') then
405 begin
406 aList.Add(AddDirectorySeparatorIfNotEmpty(aDirectory) + tmpSearchResults.Name );
407 end;
408 tmpRC := FindNext(tmpSearchResults);
409 end;
410 FindClose(tmpSearchResults);
411 end;
412
413
414 Procedure ListFilesInDirectoryRecursiveWithTermination(const aDirectory : String;
415 const aFilter : String;
416 var aList : TStrings;
417 const aTerminateCheck : TTerminateCheck;
418 const aUseTerminateCheck : boolean);
419 var
420 i : integer;
421 tmpSubDirectories : TStringList;
422 tmpSubDirectory : String;
423 begin
424 // at first add all files from the directory itself
425 ListFilesInDirectory(aDirectory, aFilter, aList);
426
427 // now determine all subdirectories
428 tmpSubDirectories := TStringList.Create;
429 ListSubDirectories(aDirectory, tmpSubDirectories);
430
431 for i := 0 to tmpSubDirectories.Count - 1 do
432 begin
433 // if Assigned( TerminateCheck ) then - doesn't work in sibyl
434 if aUseTerminateCheck then
435 if aTerminateCheck then
436 break;
437
438 tmpSubDirectory := tmpSubDirectories[i];
439
440 ListFilesInDirectoryRecursiveWithTermination(tmpSubDirectory, aFilter, aList, aTerminateCheck, aUseTerminateCheck);
441 end;
442 tmpSubDirectories.Destroy;
443 end;
444
445
446 Function ParentDir(const aDirectory : String) : String;
447 var
448 tmpPos: integer;
449 begin
450 tmpPos := Length(aDirectory);
451
452 // ends with slash
453 while (aDirectory[tmpPos] = DirectorySeparator) AND (tmpPos > 0) do
454 begin
455 dec(tmpPos);
456 end;
457
458 // find slash
459 while (aDirectory[tmpPos] <> DirectorySeparator) AND (tmpPos > 0) do
460 begin
461 dec(tmpPos);
462 end;
463
464 result:= StrLeft(aDirectory, tmpPos-1);
465 end;
466
467
468 Function DirectoryExists(const aDirectory : String) : boolean;
469 Var
470 tmpRC : APIRET;
471 tmpSearchResults : TSearchRec;
472 tmpDriveMap : ULONG;
473 tmpActualDrive : ULONG;
474 tmpDrive : Char;
475 tmpDriveNum : integer;
476 tmpDriveBit : longword;
477 tmpDirectory : String;
478 Begin
479 Result := false;
480 tmpDirectory := RemoveRightDirectorySeparator(aDirectory);
481 if tmpDirectory = '' then
482 begin
483 Result:= true;
484 exit;
485 end;
486
487 if Length(tmpDirectory) = 2 then
488 begin
489 if tmpDirectory[2] = ':' then
490 begin
491 // a drive only has been specified
492 tmpDrive:= UpCase(tmpDirectory[1] );
493 if (tmpDrive < 'A') or (tmpDrive > 'Z') then
494 begin
495 // invalid drive; return false;
496 exit;
497 end;
498
499 DosQueryCurrentDisk(tmpActualDrive, tmpDriveMap);
500 tmpDriveNum := Ord(tmpDrive) - Ord('A') + 1; // A -> 1, B -> 2...
501 tmpDriveBit := 1 shl (tmpDriveNum-1); // 2^DriveNum
502
503 Result := tmpDriveMap and (tmpDriveBit) > 0;
504 exit;
505 end;
506 end;
507
508 tmpRC := FindFirst(tmpDirectory, faDirectory or faMustDirectory, tmpSearchResults);
509 if tmpRC = 0 then
510 begin
511 Result:= true;
512 FindClose(tmpSearchResults);
513 end;
514 end;
515
516
517Initialization
518End.
Note: See TracBrowser for help on using the repository browser.