← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/include/fileutil.inc

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/include/fileutil.inc
1
 
{%MainUnit ../filectrl.pp}
2
 
{******************************************************************************
3
 
                                  Filectrl
4
 
 ******************************************************************************
5
 
 
6
 
 *****************************************************************************
7
 
 *                                                                           *
8
 
 *  This file is part of the Lazarus Component Library (LCL)                 *
9
 
 *                                                                           *
10
 
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
11
 
 *  for details about the copyright.                                         *
12
 
 *                                                                           *
13
 
 *  This program is distributed in the hope that it will be useful,          *
14
 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
15
 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
16
 
 *                                                                           *
17
 
 *****************************************************************************
18
 
}
19
 
 
20
 
var
21
 
  FNeedRTLAnsi: boolean = false;
22
 
  FNeedRTLAnsiValid: boolean = false;
23
 
 
24
 
 
25
 
procedure SetNeedRTLAnsi(NewValue: boolean);
26
 
begin
27
 
  FNeedRTLAnsi:=NewValue;
28
 
  FNeedRTLAnsiValid:=true;
29
 
end;
30
 
 
31
 
function IsASCII(const s: string): boolean; inline;
32
 
var
33
 
  i: Integer;
34
 
begin
35
 
  for i:=1 to length(s) do if ord(s[i])>127 then exit(false);
36
 
  Result:=true;
37
 
end;
38
 
 
39
 
function UTF8ToSys(const s: string): string;
40
 
begin
41
 
  if NeedRTLAnsi and (not IsASCII(s)) then
42
 
    Result := UTF8ToAnsi(s)
43
 
  else
44
 
    Result := s;
45
 
end;
46
 
 
47
 
function SysToUTF8(const s: string): string;
48
 
begin
49
 
  if NeedRTLAnsi and (not IsASCII(s)) then
50
 
    Result:=AnsiToUTF8(s)
51
 
  else
52
 
    Result:=s;
53
 
end;
54
 
 
55
 
{$IFDEF darwin}
56
 
function GetDarwinSystemFilename(Filename: string): string;
57
 
var
58
 
  s: CFStringRef;
59
 
  l: CFIndex;
60
 
begin
61
 
  if Filename='' then exit('');
62
 
  s:=CFStringCreateWithCString(nil,Pointer(Filename),kCFStringEncodingUTF8);
63
 
  l:=CFStringGetMaximumSizeOfFileSystemRepresentation(s);
64
 
  SetLength(Result,l);
65
 
  if Result<>'' then begin
66
 
    CFStringGetFileSystemRepresentation(s,@Result[1],length(Result));
67
 
    SetLength(Result,StrLen(PChar(Result)));
68
 
  end;
69
 
  CFRelease(s);
70
 
end;
71
 
{$ENDIF}
72
 
 
73
 
function FileAgeUTF8(const FileName: String): Longint;
74
 
begin
75
 
  Result:=SysUtils.FileAge(UTF8ToSys(Filename));
76
 
end;
77
 
 
78
 
function ExpandFileNameUTF8(const FileName: string): string;
79
 
begin
80
 
  Result:=SysToUTF8(SysUtils.ExpandFileName(UTF8ToSys(Filename)));
81
 
end;
82
 
 
83
 
function ExpandUNCFileNameUTF8(const FileName: string): string;
84
 
begin
85
 
  Result:=SysToUTF8(SysUtils.ExpandUNCFileName(UTF8ToSys(Filename)));
86
 
end;
87
 
 
88
 
function ExtractShortPathNameUTF8(const FileName: String): String;
89
 
begin
90
 
  {$ifdef ver2_2_0}
91
 
  Result := '';
92
 
  {$else}
93
 
  Result:=SysToUTF8(SysUtils.ExtractShortPathName(UTF8ToSys(FileName)));
94
 
  {$endif}
95
 
end;
96
 
 
97
 
function FileSetDateUTF8(const FileName: String; Age: Longint): Longint;
98
 
begin
99
 
  Result:=SysUtils.FileSetDate(UTF8ToSys(Filename),Age);
100
 
end;
101
 
 
102
 
function ParamStrUTF8(Param: Integer): string;
103
 
begin
104
 
  Result:=SysToUTF8(ObjPas.ParamStr(Param));
105
 
end;
106
 
 
107
 
function GetEnvironmentStringUTF8(Index: Integer): String;
108
 
begin
109
 
  // on Windows SysUtils.GetEnvironmentString returns OEM encoded string
110
 
  // so ConsoleToUTF8 function should be used!
111
 
  // RTL issue: http://bugs.freepascal.org/view.php?id=15233
112
 
  Result:=ConsoleToUTF8(SysUtils.GetEnvironmentString(Index));
113
 
end;
114
 
 
115
 
function GetEnvironmentVariableUTF8(const EnvVar: String): String;
116
 
begin
117
 
  // on Windows SysUtils.GetEnvironmentString returns OEM encoded string
118
 
  // so ConsoleToUTF8 function should be used!
119
 
  // RTL issue: http://bugs.freepascal.org/view.php?id=15233
120
 
  Result:=ConsoleToUTF8(SysUtils.GetEnvironmentVariable(UTF8ToSys(EnvVar)));
121
 
end;
122
 
 
123
 
function GetAppConfigDirUTF8(Global: Boolean): string;
124
 
begin
125
 
  Result:=SysToUTF8(SysUtils.GetAppConfigDir(Global));
126
 
end;
127
 
 
128
 
function GetAppConfigFileUTF8(Global: Boolean; SubDir: boolean): string;
129
 
begin
130
 
  Result:=SysToUTF8(SysUtils.GetAppConfigFile(Global,SubDir));
131
 
end;
132
 
 
133
 
function SysErrorMessageUTF8(ErrorCode: Integer): String;
134
 
begin
135
 
  Result:=SysToUTF8(SysUtils.SysErrorMessage(ErrorCode));
136
 
end;
137
 
 
138
 
{------------------------------------------------------------------------------
139
 
  DirPathExists
140
 
 ------------------------------------------------------------------------------}
141
 
function DirPathExists(const FileName: String): Boolean;
142
 
var
143
 
  F: Longint;
144
 
  dirExist: Boolean;
145
 
begin
146
 
  dirExist := false;
147
 
 
148
 
  F := FileGetAttrUTF8(ChompPathDelim(FileName));
149
 
  if F <> -1 then
150
 
    if (F and faDirectory) <> 0 then
151
 
      dirExist := true;
152
 
  Result := dirExist;
153
 
end;
154
 
 
155
 
{------------------------------------------------------------------------------
156
 
  function CompareFilenames(const Filename1, Filename2: string): integer;
157
 
 ------------------------------------------------------------------------------}
158
 
function CompareFilenames(const Filename1, Filename2: string): integer;
159
 
{$IFDEF darwin}
160
 
var
161
 
  F1: CFStringRef;
162
 
  F2: CFStringRef;
163
 
{$ENDIF}
164
 
begin
165
 
  {$IFDEF darwin}
166
 
  if Filename1=Filename2 then exit(0);
167
 
  if (Filename1='') or (Filename2='') then
168
 
    exit(length(Filename2)-length(Filename1));
169
 
  F1:=CFStringCreateWithCString(nil,Pointer(Filename1),kCFStringEncodingUTF8);
170
 
  F2:=CFStringCreateWithCString(nil,Pointer(Filename2),kCFStringEncodingUTF8);
171
 
  Result:=CFStringCompare(F1,F2,kCFCompareNonliteral
172
 
        {$IFDEF CaseInsensitiveFilenames}+kCFCompareCaseInsensitive{$ENDIF});
173
 
  CFRelease(F1);
174
 
  CFRelease(F2);
175
 
  {$ELSE}
176
 
    {$IFDEF CaseInsensitiveFilenames}
177
 
    Result:=AnsiCompareText(Filename1, Filename2);
178
 
    {$ELSE}
179
 
    Result:=CompareStr(Filename1, Filename2);
180
 
    {$ENDIF}
181
 
  {$ENDIF}
182
 
end;
183
 
 
184
 
function CompareFilenamesIgnoreCase(const Filename1, Filename2: string
185
 
  ): integer;
186
 
{$IFDEF darwin}
187
 
var
188
 
  F1: CFStringRef;
189
 
  F2: CFStringRef;
190
 
{$ENDIF}
191
 
begin
192
 
  {$IFDEF darwin}
193
 
  if Filename1=Filename2 then exit(0);
194
 
  F1:=CFStringCreateWithCString(nil,Pointer(Filename1),kCFStringEncodingUTF8);
195
 
  F2:=CFStringCreateWithCString(nil,Pointer(Filename2),kCFStringEncodingUTF8);
196
 
  Result:=CFStringCompare(F1,F2,kCFCompareNonliteral+kCFCompareCaseInsensitive);
197
 
  CFRelease(F1);
198
 
  CFRelease(F2);
199
 
  {$ELSE}
200
 
  Result:=AnsiCompareText(Filename1, Filename2);
201
 
  {$ENDIF}
202
 
end;
203
 
 
204
 
{------------------------------------------------------------------------------
205
 
  function CompareFilenames(const Filename1, Filename2: string;
206
 
    ResolveLinks: boolean): integer;
207
 
 ------------------------------------------------------------------------------}
208
 
function CompareFilenames(const Filename1, Filename2: string;
209
 
  ResolveLinks: boolean): integer;
210
 
var
211
 
  File1: String;
212
 
  File2: String;
213
 
begin
214
 
  File1:=Filename1;
215
 
  File2:=Filename2;
216
 
  if ResolveLinks then begin
217
 
    File1:=ReadAllLinks(File1,false);
218
 
    if (File1='') then File1:=Filename1;
219
 
    File2:=ReadAllLinks(File2,false);
220
 
    if (File2='') then File2:=Filename2;
221
 
  end;
222
 
  Result:=CompareFilenames(File1,File2);
223
 
end;
224
 
 
225
 
function CompareFilenames(Filename1: PChar; Len1: integer;
226
 
  Filename2: PChar; Len2: integer; ResolveLinks: boolean): integer;
227
 
var
228
 
  File1: string;
229
 
  File2: string;
230
 
  {$IFNDEF NotLiteralFilenames}
231
 
  i: Integer;
232
 
  {$ENDIF}
233
 
begin
234
 
  if (Len1=0) or (Len2=0) then begin
235
 
    Result:=Len1-Len2;
236
 
    exit;
237
 
  end;
238
 
  if ResolveLinks then begin
239
 
    SetLength(File1,Len1);
240
 
    System.Move(Filename1^,File1[1],Len1);
241
 
    SetLength(File2,Len2);
242
 
    System.Move(Filename2^,File2[1],Len2);
243
 
    Result:=CompareFilenames(File1,File2,true);
244
 
  end else begin
245
 
    {$IFDEF NotLiteralFilenames}
246
 
    SetLength(File1,Len1);
247
 
    System.Move(Filename1^,File1[1],Len1);
248
 
    SetLength(File2,Len2);
249
 
    System.Move(Filename2^,File2[1],Len2);
250
 
    Result:=CompareFilenames(File1,File2);
251
 
    {$ELSE}
252
 
    Result:=0;
253
 
    i:=0;
254
 
    while (Result=0) and ((i<Len1) and (i<Len2)) do begin
255
 
      Result:=Ord(Filename1[i])
256
 
             -Ord(Filename2[i]);
257
 
      Inc(i);
258
 
    end;
259
 
    if Result=0 Then
260
 
      Result:=Len1-Len2;
261
 
    {$ENDIF}
262
 
  end;
263
 
end;
264
 
 
265
 
function FilenameIsWinAbsolute(const TheFilename: string): boolean;
266
 
begin
267
 
  Result:=((length(TheFilename)>=2) and (TheFilename[1] in ['A'..'Z','a'..'z'])
268
 
           and (TheFilename[2]=':'))
269
 
     or ((length(TheFilename)>=2)
270
 
         and (TheFilename[1]='\') and (TheFilename[2]='\'));
271
 
end;
272
 
 
273
 
function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
274
 
begin
275
 
  Result:=(TheFilename<>'') and (TheFilename[1]='/');
276
 
end;
277
 
 
278
 
{------------------------------------------------------------------------------
279
 
  function FilenameIsPascalUnit(const Filename: string): boolean;
280
 
 ------------------------------------------------------------------------------}
281
 
function FilenameIsPascalUnit(const Filename: string): boolean;
282
 
var
283
 
  i: Integer;
284
 
begin
285
 
  for i:=Low(PascalFileExt) to High(PascalFileExt) do
286
 
    if CompareFileExt(Filename,PascalFileExt[i],false)=0 then
287
 
      exit(true);
288
 
  Result:=false;
289
 
end;
290
 
 
291
 
{------------------------------------------------------------------------------
292
 
  function AppendPathDelim(const Path: string): string;
293
 
 ------------------------------------------------------------------------------}
294
 
function AppendPathDelim(const Path: string): string;
295
 
begin
296
 
  if (Path<>'') and (Path[length(Path)]<>PathDelim) then
297
 
    Result:=Path+PathDelim
298
 
  else
299
 
    Result:=Path;
300
 
end;
301
 
 
302
 
{------------------------------------------------------------------------------
303
 
  function TrimFilename(const AFilename: string): string;
304
 
 ------------------------------------------------------------------------------}
305
 
function TrimFilename(const AFilename: string): string;
306
 
// trim double path delims, heading and trailing spaces
307
 
// and special dirs . and ..
308
 
 
309
 
  function FilenameIsTrimmed(const TheFilename: string): boolean;
310
 
  var
311
 
    l: Integer;
312
 
    i: Integer;
313
 
  begin
314
 
    Result:=false;
315
 
    if TheFilename='' then begin
316
 
      Result:=true;
317
 
      exit;
318
 
    end;
319
 
    // check heading spaces
320
 
    if TheFilename[1]=' ' then exit;
321
 
    // check trailing spaces
322
 
    l:=length(TheFilename);
323
 
    if TheFilename[l]=' ' then exit;
324
 
    i:=1;
325
 
    while i<=l do begin
326
 
      case TheFilename[i] of
327
 
      
328
 
      PathDelim:
329
 
        // check for double path delimiter
330
 
        if (i<l) and (TheFilename[i+1]=PathDelim) then exit;
331
 
        
332
 
      '.':
333
 
        if (i=1) or (TheFilename[i-1]=PathDelim) then begin
334
 
          // check for . directories
335
 
          if ((i<l) and (TheFilename[i+1]=PathDelim)) or ((i=l) and (i>1)) then exit;
336
 
          // check for .. directories
337
 
          if (i<l) and (TheFilename[i+1]='.')
338
 
          and ((i+1=l) or ((i+2<=l) and (TheFilename[i+2]=PathDelim))) then exit;
339
 
        end;
340
 
 
341
 
      end;
342
 
      inc(i);
343
 
    end;
344
 
    Result:=true;
345
 
  end;
346
 
 
347
 
var SrcPos, DestPos, l, DirStart: integer;
348
 
  c: char;
349
 
  MacroPos: LongInt;
350
 
begin
351
 
  Result:=AFilename;
352
 
  if FilenameIsTrimmed(Result) then exit;
353
 
 
354
 
  l:=length(AFilename);
355
 
  SrcPos:=1;
356
 
  DestPos:=1;
357
 
 
358
 
  // skip trailing spaces
359
 
  while (l>=1) and (AFilename[l]=' ') do dec(l);
360
 
 
361
 
  // skip heading spaces
362
 
  while (SrcPos<=l) and (AFilename[SrcPos]=' ') do inc(SrcPos);
363
 
 
364
 
  // trim double path delims and special dirs . and ..
365
 
  while (SrcPos<=l) do begin
366
 
    c:=AFilename[SrcPos];
367
 
    // check for double path delims
368
 
    if (c=PathDelim) then begin
369
 
      inc(SrcPos);
370
 
      {$IFDEF WINDOWS}
371
 
      if (DestPos>2)
372
 
      {$ELSE}
373
 
      if (DestPos>1)
374
 
      {$ENDIF}
375
 
      and (Result[DestPos-1]=PathDelim) then begin
376
 
        // skip second PathDelim
377
 
        continue;
378
 
      end;
379
 
      Result[DestPos]:=c;
380
 
      inc(DestPos);
381
 
      continue;
382
 
    end;
383
 
    // check for special dirs . and ..
384
 
    if (c='.') then begin
385
 
      if (SrcPos<l) then begin
386
 
        if (AFilename[SrcPos+1]=PathDelim)
387
 
        and ((DestPos=1) or (AFilename[SrcPos-1]=PathDelim)) then begin
388
 
          // special dir ./
389
 
          // -> skip
390
 
          inc(SrcPos,2);
391
 
          continue;
392
 
        end else if (AFilename[SrcPos+1]='.')
393
 
        and (SrcPos+1=l) or (AFilename[SrcPos+2]=PathDelim) then
394
 
        begin
395
 
          // special dir ..
396
 
          //  1. ..      -> keep
397
 
          //  2. /..     -> skip .., keep /
398
 
          //  3. C:..    -> keep
399
 
          //  4. C:\..   -> skip .., keep C:\
400
 
          //  5. \\..    -> skip .., keep \\
401
 
          //  6. xxx../..   -> keep
402
 
          //  7. xxxdir$Macro/..  -> keep
403
 
          //  8. xxxdir/..  -> trim dir and skip ..
404
 
          if DestPos=1 then begin
405
 
            //  1. ..      -> keep
406
 
          end else if (DestPos=2) and (Result[1]=PathDelim) then begin
407
 
            //  2. /..     -> skip .., keep /
408
 
            inc(SrcPos,2);
409
 
            continue;
410
 
          {$IFDEF WINDOWS}
411
 
          end else if (DestPos=3) and (Result[2]=':')
412
 
          and (Result[1] in ['a'..'z','A'..'Z']) then begin
413
 
            //  3. C:..    -> keep
414
 
          end else if (DestPos=4) and (Result[2]=':') and (Result[3]=PathDelim)
415
 
          and (Result[1] in ['a'..'z','A'..'Z']) then begin
416
 
            //  4. C:\..   -> skip .., keep C:\
417
 
            inc(SrcPos,2);
418
 
            continue;
419
 
          end else if (DestPos=3) and (Result[1]=PathDelim)
420
 
          and (Result[2]=PathDelim) then begin
421
 
            //  5. \\..    -> skip .., keep \\
422
 
            inc(SrcPos,2);
423
 
            continue;
424
 
          {$ENDIF}
425
 
          end else if (DestPos>1) and (Result[DestPos-1]=PathDelim) then begin
426
 
            if (DestPos>3)
427
 
            and (Result[DestPos-2]='.') and (Result[DestPos-3]='.')
428
 
            and ((DestPos=4) or (Result[DestPos-4]=PathDelim)) then begin
429
 
              //  6. ../..   -> keep
430
 
            end else begin
431
 
              //  7. xxxdir/..  -> trim dir and skip ..
432
 
              DirStart:=DestPos-2;
433
 
              while (DirStart>1) and (Result[DirStart-1]<>PathDelim) do
434
 
                dec(DirStart);
435
 
              MacroPos:=DirStart;
436
 
              while MacroPos<DestPos do begin
437
 
                if (Result[MacroPos]='$')
438
 
                and (Result[MacroPos+1] in ['(','a'..'z','A'..'Z']) then begin
439
 
                  // 8. directory contains a macro -> keep
440
 
                  break;
441
 
                end;
442
 
                inc(MacroPos);
443
 
              end;
444
 
              if MacroPos=DestPos then begin
445
 
                DestPos:=DirStart;
446
 
                inc(SrcPos,2);
447
 
                continue;
448
 
              end;
449
 
            end;
450
 
          end;
451
 
        end;
452
 
      end else begin
453
 
        // special dir . at end of filename
454
 
        if DestPos=1 then begin
455
 
          Result:='.';
456
 
          exit;
457
 
        end else begin
458
 
          // skip
459
 
          break;
460
 
        end;
461
 
      end;
462
 
    end;
463
 
    // copy directory
464
 
    repeat
465
 
      Result[DestPos]:=c;
466
 
      inc(DestPos);
467
 
      inc(SrcPos);
468
 
      if (SrcPos>l) then break;
469
 
      c:=AFilename[SrcPos];
470
 
      if c=PathDelim then break;
471
 
    until false;
472
 
  end;
473
 
  // trim result
474
 
  if DestPos<=length(AFilename) then
475
 
    SetLength(Result,DestPos-1);
476
 
end;
477
 
 
478
 
function ExtractFileNameWithoutExt(const AFilename: string): string;
479
 
var
480
 
  p: Integer;
481
 
begin
482
 
  Result:=AFilename;
483
 
  p:=length(Result);
484
 
  while (p>0) do begin
485
 
    case Result[p] of
486
 
      PathDelim: exit;
487
 
      '.': exit(copy(Result,1, p-1));
488
 
    end;
489
 
    dec(p);
490
 
  end;
491
 
end;
492
 
 
493
 
{------------------------------------------------------------------------------
494
 
  function CompareFileExt(const Filename, Ext: string;
495
 
    CaseSensitive: boolean): integer;
496
 
    
497
 
  Ext can contain a point or not
498
 
 ------------------------------------------------------------------------------}
499
 
function CompareFileExt(const Filename, Ext: string;
500
 
  CaseSensitive: boolean): integer;
501
 
var
502
 
  n, e : AnsiString;
503
 
  FileLen, FilePos, ExtLen, ExtPos: integer;
504
 
begin
505
 
  FileLen:=length(Filename);
506
 
  ExtLen:=length(Ext);
507
 
  FilePos:=FileLen;
508
 
  while (FilePos>=1) and (Filename[FilePos]<>'.') do dec(FilePos);
509
 
  if FilePos<1 then begin
510
 
    // no extension in filename
511
 
    Result:=1;
512
 
    exit;
513
 
  end;
514
 
  // skip point
515
 
  inc(FilePos);
516
 
  ExtPos:=1;
517
 
  if (ExtPos<=ExtLen) and (Ext[1]='.') then inc(ExtPos);
518
 
 
519
 
  // compare extensions
520
 
  n:=Copy(Filename, FilePos, length(FileName));
521
 
  e:=Copy(Ext, ExtPos, length(Ext));
522
 
  if CaseSensitive then
523
 
    Result:=CompareStr(n, e)
524
 
  else
525
 
    Result:=AnsiCompareText(n, e);
526
 
  if Result<0 then Result:=1
527
 
  else if Result>0 then Result:=1;
528
 
end;
529
 
 
530
 
function CompareFileExt(const Filename, Ext: string): integer;
531
 
begin
532
 
  Result:=CompareFileExt(Filename,Ext,false);
533
 
end;
534
 
 
535
 
{------------------------------------------------------------------------------
536
 
  function ChompPathDelim(const Path: string): string;
537
 
 ------------------------------------------------------------------------------}
538
 
function ChompPathDelim(const Path: string): string;
539
 
begin
540
 
  if (Path<>'') and (Path[length(Path)]=PathDelim) then
541
 
    Result:=LeftStr(Path,length(Path)-1)
542
 
  else
543
 
    Result:=Path;
544
 
end;
545
 
 
546
 
{------------------------------------------------------------------------------
547
 
  function FileIsText(const AFilename: string): boolean;
548
 
 ------------------------------------------------------------------------------}
549
 
function FileIsText(const AFilename: string): boolean;
550
 
var
551
 
  FileReadable: Boolean;
552
 
begin
553
 
  Result:=FileIsText(AFilename,FileReadable);
554
 
  if FileReadable then ;
555
 
end;
556
 
 
557
 
function FileIsText(const AFilename: string; out FileReadable: boolean): boolean;
558
 
const
559
 
  BufLen = 1024;
560
 
var
561
 
  fs: TFileStream;
562
 
  Buf: string;
563
 
  Len: integer;
564
 
  NewLine: boolean;
565
 
  p: PChar;
566
 
  ZeroAllowed: Boolean;
567
 
begin
568
 
  Result:=false;
569
 
  FileReadable:=true;
570
 
  try
571
 
    fs := TFileStream.Create(UTF8ToSys(AFilename), fmOpenRead or fmShareDenyNone);
572
 
    try
573
 
      // read the first 1024 bytes
574
 
      Len:=BufLen;
575
 
      SetLength(Buf,BufLen+1);
576
 
      Len:=fs.Read(Buf[1],BufLen);
577
 
      if Len>0 then begin
578
 
        Buf[Len+1]:=#0;
579
 
        p:=PChar(Buf);
580
 
        ZeroAllowed:=false;
581
 
        if (p[0]=#$EF) and (p[1]=#$BB) and (p[2]=#$BF) then begin
582
 
          // UTF-8 BOM (Byte Order Mark)
583
 
          inc(p,3);
584
 
        end else if (p[0]=#$FF) and (p[1]=#$FE) then begin
585
 
          // ucs-2le BOM FF FE
586
 
          inc(p,2);
587
 
          ZeroAllowed:=true;
588
 
        end else if (p[0]=#$FE) and (p[1]=#$FF) then begin
589
 
          // ucs-2be BOM FE FF
590
 
          inc(p,2);
591
 
          ZeroAllowed:=true;
592
 
        end;
593
 
        NewLine:=false;
594
 
        while true do begin
595
 
          case p^ of
596
 
          #0:
597
 
            if p-PChar(Buf)>=Len then
598
 
              break
599
 
            else if not ZeroAllowed then
600
 
              exit;
601
 
          // #10,#13: new line
602
 
          // #12: form feed
603
 
          // #26: end of file
604
 
          #1..#8,#11,#14..#25,#27..#31: exit;
605
 
          #10,#13: NewLine:=true;
606
 
          end;
607
 
          inc(p);
608
 
        end;
609
 
        if NewLine or (Len<1024) then
610
 
          Result:=true;
611
 
      end else
612
 
        Result:=true;
613
 
    finally
614
 
      fs.Free;
615
 
    end;
616
 
  except
617
 
    on E: Exception do begin
618
 
      FileReadable:=false;
619
 
    end;
620
 
  end;
621
 
end;
622
 
 
623
 
function TryReadAllLinks(const Filename: string): string;
624
 
begin
625
 
  Result:=ReadAllLinks(Filename,false);
626
 
  if Result='' then
627
 
    Result:=Filename;
628
 
end;
629
 
 
630
 
{------------------------------------------------------------------------------
631
 
  function ExtractFileNameOnly(const AFilename: string): string;
632
 
 ------------------------------------------------------------------------------}
633
 
function ExtractFileNameOnly(const AFilename: string): string;
634
 
var
635
 
  StartPos: Integer;
636
 
  ExtPos: Integer;
637
 
begin
638
 
  StartPos:=length(AFilename)+1;
639
 
  while (StartPos>1)
640
 
  and (AFilename[StartPos-1]<>PathDelim)
641
 
  {$IFDEF Windows}and (AFilename[StartPos-1]<>':'){$ENDIF}
642
 
  do
643
 
    dec(StartPos);
644
 
  ExtPos:=length(AFilename);
645
 
  while (ExtPos>=StartPos) and (AFilename[ExtPos]<>'.') do
646
 
    dec(ExtPos);
647
 
  if (ExtPos<StartPos) then ExtPos:=length(AFilename)+1;
648
 
  Result:=copy(AFilename,StartPos,ExtPos-StartPos);
649
 
end;
650
 
 
651
 
 
652
 
{------------------------------------------------------------------------------
653
 
  function ForceDirectory(DirectoryName: string): boolean;
654
 
 ------------------------------------------------------------------------------}
655
 
function ForceDirectory(DirectoryName: string): boolean;
656
 
var i: integer;
657
 
  Dir: string;
658
 
begin
659
 
  DoDirSeparators(DirectoryName);
660
 
  DirectoryName := AppendPathDelim(DirectoryName);
661
 
  i:=1;
662
 
  while i<=length(DirectoryName) do begin
663
 
    if DirectoryName[i]=PathDelim then begin
664
 
      Dir:=copy(DirectoryName,1,i-1);
665
 
      if not DirPathExists(Dir) then begin
666
 
        Result:=CreateDirUTF8(Dir);
667
 
        if not Result then exit;
668
 
      end;
669
 
    end;
670
 
    inc(i);
671
 
  end;
672
 
  Result:=true;
673
 
end;
674
 
 
675
 
{------------------------------------------------------------------------------
676
 
  function DeleteDirectory(const DirectoryName: string;
677
 
    OnlyChilds: boolean): boolean;
678
 
 ------------------------------------------------------------------------------}
679
 
function DeleteDirectory(const DirectoryName: string;
680
 
  OnlyChilds: boolean): boolean;
681
 
var
682
 
  FileInfo: TSearchRec;
683
 
  CurSrcDir: String;
684
 
  CurFilename: String;
685
 
begin
686
 
  Result:=false;
687
 
  CurSrcDir:=CleanAndExpandDirectory(DirectoryName);
688
 
  if FindFirstUTF8(CurSrcDir+GetAllFilesMask,faAnyFile,FileInfo)=0 then begin
689
 
    repeat
690
 
      // check if special file
691
 
      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then
692
 
        continue;
693
 
      CurFilename:=CurSrcDir+FileInfo.Name;
694
 
      if (FileInfo.Attr and faDirectory)>0 then begin
695
 
        if not DeleteDirectory(CurFilename,false) then exit;
696
 
      end else begin
697
 
        if not DeleteFileUTF8(CurFilename) then exit;
698
 
      end;
699
 
    until FindNextUTF8(FileInfo)<>0;
700
 
  end;
701
 
  FindCloseUTF8(FileInfo);
702
 
  if (not OnlyChilds) and (not RemoveDirUTF8(DirectoryName)) then exit;
703
 
  Result:=true;
704
 
end;
705
 
 
706
 
{------------------------------------------------------------------------------
707
 
  function ProgramDirectory: string;
708
 
 ------------------------------------------------------------------------------}
709
 
function ProgramDirectory: string;
710
 
var
711
 
  Flags: TSearchFileInPathFlags;
712
 
begin
713
 
  Result:=ParamStrUTF8(0);
714
 
  if ExtractFilePath(Result)='' then begin
715
 
    // program was started via PATH
716
 
    {$IFDEF WINDOWS}
717
 
    Flags:=[];
718
 
    {$ELSE}
719
 
    Flags:=[sffDontSearchInBasePath];
720
 
    {$ENDIF}
721
 
    Result:=SearchFileInPath(Result,'',GetEnvironmentVariableUTF8('PATH'),':',Flags);
722
 
  end;
723
 
  // resolve links
724
 
  Result:=ReadAllLinks(Result,false);
725
 
  // extract file path and expand to full name
726
 
  Result:=ExpandFileNameUTF8(ExtractFilePath(Result));
727
 
end;
728
 
 
729
 
function DirectoryIsWritable(const DirectoryName: string): boolean;
730
 
var
731
 
  TempFilename: String;
732
 
  fs: TFileStream;
733
 
  s: String;
734
 
begin
735
 
  TempFilename:=GetTempFilename(DirectoryName,'tstperm');
736
 
  Result:=false;
737
 
  try
738
 
    fs:=TFileStream.Create(UTF8ToSys(TempFilename),fmCreate);
739
 
    s:='WriteTest';
740
 
    fs.Write(s[1],length(s));
741
 
    fs.Free;
742
 
    DeleteFileUTF8(TempFilename);
743
 
    Result:=true;
744
 
  except
745
 
  end;
746
 
end;
747
 
 
748
 
{------------------------------------------------------------------------------
749
 
  function CleanAndExpandFilename(const Filename: string): string;
750
 
 ------------------------------------------------------------------------------}
751
 
function CleanAndExpandFilename(const Filename: string): string;
752
 
begin
753
 
  Result:=ExpandFileNameUTF8(TrimFileName(Filename));
754
 
end;
755
 
 
756
 
{------------------------------------------------------------------------------
757
 
  function CleanAndExpandDirectory(const Filename: string): string;
758
 
 ------------------------------------------------------------------------------}
759
 
function CleanAndExpandDirectory(const Filename: string): string;
760
 
begin
761
 
  Result:=AppendPathDelim(CleanAndExpandFilename(Filename));
762
 
end;
763
 
 
764
 
function CreateAbsoluteSearchPath(const SearchPath, BaseDirectory: string
765
 
  ): string;
766
 
var
767
 
  PathLen: Integer;
768
 
  EndPos: Integer;
769
 
  StartPos: Integer;
770
 
  CurDir: String;
771
 
  NewCurDir: String;
772
 
  DiffLen: Integer;
773
 
  BaseDir: String;
774
 
begin
775
 
  Result:=SearchPath;
776
 
  if (SearchPath='') or (BaseDirectory='') then exit;
777
 
  BaseDir:=AppendPathDelim(BaseDirectory);
778
 
 
779
 
  PathLen:=length(Result);
780
 
  EndPos:=1;
781
 
  while EndPos<=PathLen do begin
782
 
    StartPos:=EndPos;
783
 
    while (Result[StartPos]=';') do begin
784
 
      inc(StartPos);
785
 
      if StartPos>PathLen then exit;
786
 
    end;
787
 
    EndPos:=StartPos;
788
 
    while (EndPos<=PathLen) and (Result[EndPos]<>';') do inc(EndPos);
789
 
    CurDir:=copy(Result,StartPos,EndPos-StartPos);
790
 
    if not FilenameIsAbsolute(CurDir) then begin
791
 
      NewCurDir:=BaseDir+CurDir;
792
 
      if NewCurDir<>CurDir then begin
793
 
        DiffLen:=length(NewCurDir)-length(CurDir);
794
 
        Result:=copy(Result,1,StartPos-1)+NewCurDir
795
 
                +copy(Result,EndPos,PathLen-EndPos+1);
796
 
        inc(EndPos,DiffLen);
797
 
        inc(PathLen,DiffLen);
798
 
      end;
799
 
    end;
800
 
    StartPos:=EndPos;
801
 
  end;
802
 
end;
803
 
 
804
 
function CreateRelativePath(const Filename, BaseDirectory: string;
805
 
  UsePointDirectory: boolean): string;
806
 
var
807
 
  FileNameLength: Integer;
808
 
  BaseDirLen: Integer;
809
 
  SamePos: Integer;
810
 
  UpDirCount: Integer;
811
 
  BaseDirPos: Integer;
812
 
  ResultPos: Integer;
813
 
  i: Integer;
814
 
  FileNameRestLen: Integer;
815
 
  CmpBaseDirectory: String;
816
 
  CmpFilename: String;
817
 
  p: Integer;
818
 
  DirCount: Integer;
819
 
begin
820
 
  Result:=Filename;
821
 
  if (BaseDirectory='') or (Filename='') then exit;
822
 
 
823
 
  {$IFDEF MSWindows}
824
 
  // check for different windows file drives
825
 
  if (CompareText(ExtractFileDrive(Filename),
826
 
                  ExtractFileDrive(BaseDirectory))<>0)
827
 
  then
828
 
    exit;
829
 
  {$ENDIF}
830
 
  CmpBaseDirectory:=BaseDirectory;
831
 
  CmpFilename:=Filename;
832
 
  {$IFDEF darwin}
833
 
  CmpBaseDirectory:=GetDarwinSystemFilename(CmpBaseDirectory);
834
 
  CmpFilename:=GetDarwinSystemFilename(CmpFilename);
835
 
  {$ENDIF}
836
 
  {$IFDEF CaseInsensitiveFilenames}
837
 
  CmpBaseDirectory:=AnsiUpperCaseFileName(CmpBaseDirectory);
838
 
  CmpFilename:=AnsiUpperCaseFileName(CmpFilename);
839
 
  {$ENDIF}
840
 
 
841
 
  FileNameLength:=length(CmpFilename);
842
 
  while (FileNameLength>0) and (CmpFilename[FileNameLength]=PathDelim) do
843
 
    dec(FileNameLength);
844
 
  BaseDirLen:=length(CmpBaseDirectory);
845
 
  while (BaseDirLen>0) and (CmpBaseDirectory[BaseDirLen]=PathDelim) do
846
 
    dec(BaseDirLen);
847
 
  if BaseDirLen=0 then exit;
848
 
 
849
 
  //WriteLn('CreateRelativePath START ',copy(CmpBaseDirectory,1,BaseDirLen),' ',copy(CmpFilename,1,FileNameLength));
850
 
 
851
 
  // count shared directories
852
 
  p:=1;
853
 
  DirCount:=0;
854
 
  BaseDirPos:=p;
855
 
  while (p<=FileNameLength) and (BaseDirPos<=BaseDirLen)
856
 
  and (CmpFileName[p]=CmpBaseDirectory[BaseDirPos]) do
857
 
  begin
858
 
    if CmpFilename[p]=PathDelim then
859
 
    begin
860
 
      inc(DirCount);
861
 
      repeat
862
 
        inc(p);
863
 
      until (p>FileNameLength) or (CmpFilename[p]<>PathDelim);
864
 
      repeat
865
 
        inc(BaseDirPos);
866
 
      until (BaseDirPos>BaseDirLen) or (CmpBaseDirectory[BaseDirPos]<>PathDelim);
867
 
    end else begin
868
 
      inc(p);
869
 
      inc(BaseDirPos);
870
 
    end;
871
 
  end;
872
 
  UpDirCount:=0;
873
 
  if ((BaseDirPos>BaseDirLen) or (CmpBaseDirectory[BaseDirPos]=PathDelim))
874
 
  and ((p>FileNameLength) or (CmpFilename[p]=PathDelim)) then
875
 
  begin
876
 
    inc(DirCount);
877
 
    inc(BaseDirPos);
878
 
  end else
879
 
    inc(UpDirCount);
880
 
  if DirCount=0 then exit;
881
 
  if FilenameIsAbsolute(BaseDirectory) and (DirCount=1) then exit;
882
 
 
883
 
  // calculate needed up directories
884
 
  while (BaseDirPos<=BaseDirLen) do begin
885
 
    if (CmpBaseDirectory[BaseDirPos]=PathDelim) then
886
 
    begin
887
 
      inc(UpDirCount);
888
 
      repeat
889
 
        inc(BaseDirPos);
890
 
      until (BaseDirPos>BaseDirLen) or (CmpBaseDirectory[BaseDirPos]<>PathDelim);
891
 
    end else
892
 
      inc(BaseDirPos);
893
 
  end;
894
 
 
895
 
  // create relative filename
896
 
  SamePos:=1;
897
 
  p:=0;
898
 
  FileNameLength:=length(Filename);
899
 
  while (SamePos<=FileNameLength) do begin
900
 
    if (Filename[SamePos]=PathDelim) then begin
901
 
      repeat
902
 
        inc(SamePos);
903
 
      until (SamePos>FileNameLength) or (Filename[SamePos]<>PathDelim);
904
 
      inc(p);
905
 
      if p>=DirCount then
906
 
        break;
907
 
    end else
908
 
      inc(SamePos);
909
 
  end;
910
 
  FileNameRestLen:=FileNameLength-SamePos+1;
911
 
  //writeln('DirCount=',DirCount,' UpDirCount=',UpDirCount,' FileNameRestLen=',FileNameRestLen,' SamePos=',SamePos);
912
 
  SetLength(Result,3*UpDirCount+FileNameRestLen);
913
 
  ResultPos:=1;
914
 
  for i:=1 to UpDirCount do begin
915
 
    Result[ResultPos]:='.';
916
 
    Result[ResultPos+1]:='.';
917
 
    Result[ResultPos+2]:=PathDelim;
918
 
    inc(ResultPos,3);
919
 
  end;
920
 
  if FileNameRestLen>0 then
921
 
    System.Move(Filename[SamePos],Result[ResultPos],FileNameRestLen);
922
 
 
923
 
  if UsePointDirectory and (Result='') and (Filename<>'') then
924
 
    Result:='.'; // Filename is the BaseDirectory
925
 
end;
926
 
 
927
 
function CreateAbsolutePath(const Filename, BaseDirectory: string): string;
928
 
begin
929
 
  if (Filename='') or FilenameIsAbsolute(Filename) then
930
 
    Result:=Filename
931
 
  {$IFDEF Windows}
932
 
  else if (Filename[1]='\') then
933
 
    // only use drive of BaseDirectory
934
 
    Result:=ExtractFileDrive(BaseDirectory)+Filename
935
 
  {$ENDIF}
936
 
  else
937
 
    Result:=AppendPathDelim(BaseDirectory)+Filename;
938
 
  Result:=TrimFilename(Result);
939
 
end;
940
 
 
941
 
{------------------------------------------------------------------------------
942
 
  function FileIsInPath(const Filename, Path: string): boolean;
943
 
 ------------------------------------------------------------------------------}
944
 
function FileIsInPath(const Filename, Path: string): boolean;
945
 
var
946
 
  ExpFile: String;
947
 
  ExpPath: String;
948
 
  l: integer;
949
 
begin
950
 
  ExpFile:=CleanAndExpandFilename(Filename);
951
 
  ExpPath:=CleanAndExpandDirectory(Path);
952
 
  l:=length(ExpPath);
953
 
  Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l]=PathDelim)
954
 
          and (CompareFilenames(ExpPath,LeftStr(ExpFile,l))=0);
955
 
end;
956
 
 
957
 
{------------------------------------------------------------------------------
958
 
  function FileIsInPath(const Filename, Path: string): boolean;
959
 
 ------------------------------------------------------------------------------}
960
 
function FileIsInDirectory(const Filename, Directory: string): boolean;
961
 
var
962
 
  ExpFile: String;
963
 
  ExpDir: String;
964
 
  LenFile: Integer;
965
 
  LenDir: Integer;
966
 
  p: LongInt;
967
 
begin
968
 
  ExpFile:=CleanAndExpandFilename(Filename);
969
 
  ExpDir:=CleanAndExpandDirectory(Directory);
970
 
  LenFile:=length(ExpFile);
971
 
  LenDir:=length(ExpDir);
972
 
  p:=LenFile;
973
 
  while (p>0) and (ExpFile[p]<>PathDelim) do dec(p);
974
 
  Result:=(p=LenDir) and (p<LenFile)
975
 
          and (CompareFilenames(ExpDir,LeftStr(ExpFile,p))=0);
976
 
end;
977
 
 
978
 
{------------------------------------------------------------------------------
979
 
  function CopyFile(const SrcFilename, DestFilename: string): boolean;
980
 
 ------------------------------------------------------------------------------}
981
 
function CopyFile(const SrcFilename, DestFilename: string): boolean;
982
 
begin
983
 
  Result := CopyFile(SrcFilename, DestFilename, false);
984
 
end;
985
 
 
986
 
{------------------------------------------------------------------------------
987
 
  function CopyFile(const SrcFilename, DestFilename: string PreserveTime:
988
 
    boolean): boolean;
989
 
 ------------------------------------------------------------------------------}
990
 
function CopyFile(const SrcFilename, DestFilename: String; PreserveTime: Boolean): Boolean;
991
 
var
992
 
  SrcFS: TFileStream;
993
 
  DestFS: TFileStream;
994
 
begin
995
 
  try
996
 
    SrcFS := TFileStream.Create(UTF8ToSys(SrcFilename), fmOpenRead or fmShareDenyWrite);
997
 
    try
998
 
      DestFS := TFileStream.Create(UTF8ToSys(DestFilename), fmCreate);
999
 
      try
1000
 
        DestFS.CopyFrom(SrcFS, SrcFS.Size);
1001
 
      finally
1002
 
        DestFS.Free;
1003
 
      end;
1004
 
      if PreserveTime then
1005
 
        FileSetDateUTF8(DestFilename, FileGetDate(SrcFS.Handle));
1006
 
    finally
1007
 
      SrcFS.Free;
1008
 
    end;
1009
 
    Result := True;
1010
 
  except
1011
 
    Result := False;
1012
 
  end;
1013
 
end;
1014
 
 
1015
 
{------------------------------------------------------------------------------
1016
 
  function GetTempFilename(const Directory, Prefix: string): string;
1017
 
 ------------------------------------------------------------------------------}
1018
 
function GetTempFilename(const Directory, Prefix: string): string;
1019
 
var
1020
 
  i: Integer;
1021
 
  CurPath: String;
1022
 
begin
1023
 
  CurPath:=AppendPathDelim(ExpandFileNameUTF8(Directory))+Prefix;
1024
 
  i:=1;
1025
 
  repeat
1026
 
    Result:=CurPath+IntToStr(i)+'.tmp';
1027
 
    if not (FileExistsUTF8(Result) or DirectoryExistsUTF8(Result)) then exit;
1028
 
    inc(i);
1029
 
  until false;
1030
 
end;
1031
 
 
1032
 
{------------------------------------------------------------------------------
1033
 
  function SearchFileInPath(const Filename, BasePath, SearchPath,
1034
 
    Delimiter: string; Flags: TSearchFileInPathFlags): string;
1035
 
 ------------------------------------------------------------------------------}
1036
 
function SearchFileInPath(const Filename, BasePath, SearchPath,
1037
 
  Delimiter: string; Flags: TSearchFileInPathFlags): string;
1038
 
var
1039
 
  p, StartPos, l: integer;
1040
 
  CurPath, Base: string;
1041
 
begin
1042
 
//debugln('[SearchFileInPath] Filename="',Filename,'" BasePath="',BasePath,'" SearchPath="',SearchPath,'" Delimiter="',Delimiter,'"');
1043
 
  if (Filename='') then begin
1044
 
    Result:='';
1045
 
    exit;
1046
 
  end;
1047
 
  // check if filename absolute
1048
 
  if FilenameIsAbsolute(Filename) then begin
1049
 
    if FileExistsUTF8(Filename) then begin
1050
 
      Result:=CleanAndExpandFilename(Filename);
1051
 
      exit;
1052
 
    end else begin
1053
 
      Result:='';
1054
 
      exit;
1055
 
    end;
1056
 
  end;
1057
 
  Base:=CleanAndExpandDirectory(BasePath);
1058
 
  // search in current directory
1059
 
  if (not (sffDontSearchInBasePath in Flags))
1060
 
  and FileExistsUTF8(Base+Filename) then begin
1061
 
    Result:=CleanAndExpandFilename(Base+Filename);
1062
 
    exit;
1063
 
  end;
1064
 
  // search in search path
1065
 
  StartPos:=1;
1066
 
  l:=length(SearchPath);
1067
 
  while StartPos<=l do begin
1068
 
    p:=StartPos;
1069
 
    while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
1070
 
    CurPath:=TrimFilename(copy(SearchPath,StartPos,p-StartPos));
1071
 
    if CurPath<>'' then begin
1072
 
      if not FilenameIsAbsolute(CurPath) then
1073
 
        CurPath:=Base+CurPath;
1074
 
      Result:=CleanAndExpandFilename(AppendPathDelim(CurPath)+Filename);
1075
 
      if FileExistsUTF8(Result) then exit;
1076
 
    end;
1077
 
    StartPos:=p+1;
1078
 
  end;
1079
 
  Result:='';
1080
 
end;
1081
 
 
1082
 
function SearchAllFilesInPath(const Filename, BasePath, SearchPath,
1083
 
  Delimiter: string; Flags: TSearchFileInPathFlags): TStrings;
1084
 
  
1085
 
  procedure Add(NewFilename: string);
1086
 
  var
1087
 
    i: Integer;
1088
 
  begin
1089
 
    NewFilename:=TrimFilename(NewFilename);
1090
 
    if not FileExistsUTF8(NewFilename) then exit;
1091
 
    if Result=nil then begin
1092
 
      Result:=TStringList.Create;
1093
 
    end else begin
1094
 
      for i:=0 to Result.Count-1 do
1095
 
        if CompareFilenames(Result[i],NewFilename)=0 then exit;
1096
 
    end;
1097
 
    Result.Add(NewFilename);
1098
 
  end;
1099
 
  
1100
 
var
1101
 
  p, StartPos, l: integer;
1102
 
  CurPath, Base: string;
1103
 
begin
1104
 
  Result:=nil;
1105
 
  if (Filename='') then exit;
1106
 
  // check if filename absolute
1107
 
  if FilenameIsAbsolute(Filename) then begin
1108
 
    Add(CleanAndExpandFilename(Filename));
1109
 
    exit;
1110
 
  end;
1111
 
  Base:=CleanAndExpandDirectory(BasePath);
1112
 
  // search in current directory
1113
 
  if (not (sffDontSearchInBasePath in Flags)) then begin
1114
 
    Add(CleanAndExpandFilename(Base+Filename));
1115
 
  end;
1116
 
  // search in search path
1117
 
  StartPos:=1;
1118
 
  l:=length(SearchPath);
1119
 
  while StartPos<=l do begin
1120
 
    p:=StartPos;
1121
 
    while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p);
1122
 
    CurPath:=TrimFilename(copy(SearchPath,StartPos,p-StartPos));
1123
 
    if CurPath<>'' then begin
1124
 
      if not FilenameIsAbsolute(CurPath) then
1125
 
        CurPath:=Base+CurPath;
1126
 
      Add(CleanAndExpandFilename(AppendPathDelim(CurPath)+Filename));
1127
 
    end;
1128
 
    StartPos:=p+1;
1129
 
  end;
1130
 
end;
1131
 
 
1132
 
function FindDiskFilename(const Filename: string): string;
1133
 
// Searches for the filename case on disk.
1134
 
// The file must exist.
1135
 
// For example:
1136
 
//   If Filename='file' and there is only a 'File' then 'File' will be returned.
1137
 
var
1138
 
  StartPos: Integer;
1139
 
  EndPos: LongInt;
1140
 
  FileInfo: TSearchRec;
1141
 
  CurDir: String;
1142
 
  CurFile: String;
1143
 
  AliasFile: String;
1144
 
  Ambiguous: Boolean;
1145
 
begin
1146
 
  Result:=Filename;
1147
 
  if not FileExistsUTF8(Filename) then exit;
1148
 
  // check every directory and filename
1149
 
  StartPos:=1;
1150
 
  {$IFDEF WINDOWS}
1151
 
  // uppercase Drive letter and skip it
1152
 
  if ((length(Result)>=2) and (Result[1] in ['A'..'Z','a'..'z'])
1153
 
  and (Result[2]=':')) then begin
1154
 
    StartPos:=3;
1155
 
    if Result[1] in ['a'..'z'] then
1156
 
      Result[1]:=upcase(Result[1]);
1157
 
  end;
1158
 
  {$ENDIF}
1159
 
  repeat
1160
 
    // skip PathDelim
1161
 
    while (StartPos<=length(Result)) and (Result[StartPos]=PathDelim) do
1162
 
      inc(StartPos);
1163
 
    // find end of filename part
1164
 
    EndPos:=StartPos;
1165
 
    while (EndPos<=length(Result)) and (Result[EndPos]<>PathDelim) do
1166
 
      inc(EndPos);
1167
 
    if EndPos>StartPos then begin
1168
 
      // search file
1169
 
      CurDir:=copy(Result,1,StartPos-1);
1170
 
      CurFile:=copy(Result,StartPos,EndPos-StartPos);
1171
 
      AliasFile:='';
1172
 
      Ambiguous:=false;
1173
 
      if FindFirstUTF8(CurDir+GetAllFilesMask,faAnyFile,FileInfo)=0 then
1174
 
      begin
1175
 
        repeat
1176
 
          // check if special file
1177
 
          if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
1178
 
          then
1179
 
            continue;
1180
 
          if CompareFilenamesIgnoreCase(FileInfo.Name,CurFile)=0 then begin
1181
 
            //debugln('FindDiskFilename ',FileInfo.Name,' ',CurFile);
1182
 
            if FileInfo.Name=CurFile then begin
1183
 
              // file found, has already the correct name
1184
 
              AliasFile:='';
1185
 
              break;
1186
 
            end else begin
1187
 
              // alias found, but has not the correct name
1188
 
              if AliasFile='' then begin
1189
 
                AliasFile:=FileInfo.Name;
1190
 
              end else begin
1191
 
                // there are more than one candidate
1192
 
                Ambiguous:=true;
1193
 
              end;
1194
 
            end;
1195
 
          end;
1196
 
        until FindNextUTF8(FileInfo)<>0;
1197
 
      end;
1198
 
      FindCloseUTF8(FileInfo);
1199
 
      if (AliasFile<>'') and (not Ambiguous) then begin
1200
 
        // better filename found -> replace
1201
 
        Result:=CurDir+AliasFile+copy(Result,EndPos,length(Result));
1202
 
      end;
1203
 
    end;
1204
 
    StartPos:=EndPos+1;
1205
 
  until StartPos>length(Result);
1206
 
end;
1207
 
 
1208
 
function FindDiskFileCaseInsensitive(const Filename: string): string;
1209
 
var
1210
 
  FileInfo: TSearchRec;
1211
 
  ShortFilename: String;
1212
 
  CurDir: String;
1213
 
begin
1214
 
  Result:='';
1215
 
  CurDir:=ExtractFilePath(Filename);
1216
 
  if FindFirstUTF8(CurDir+GetAllFilesMask,faAnyFile, FileInfo)=0 then begin
1217
 
    ShortFilename:=ExtractFilename(Filename);
1218
 
    repeat
1219
 
      // check if special file
1220
 
      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
1221
 
      then
1222
 
        continue;
1223
 
      if CompareFilenamesIgnoreCase(FileInfo.Name,ShortFilename)=0 then begin
1224
 
        if FileInfo.Name=ShortFilename then begin
1225
 
          // fits exactly
1226
 
          Result:=Filename;
1227
 
          break;
1228
 
        end;
1229
 
        // fits case insensitive
1230
 
        Result:=CurDir+FileInfo.Name;
1231
 
        // search further
1232
 
      end;
1233
 
    until FindNextUTF8(FileInfo)<>0;
1234
 
  end;
1235
 
  FindCloseUTF8(FileInfo);
1236
 
end;
1237
 
 
1238
 
function FindDefaultExecutablePath(const Executable: string): string;
1239
 
begin
1240
 
  if FilenameIsAbsolute(Executable) then begin
1241
 
    Result:=Executable;
1242
 
    if FileExistsUTF8(Result) then exit;
1243
 
    {$IFDEF Windows}
1244
 
    if ExtractFileExt(Result)='' then begin
1245
 
      Result:=Result+'.exe';
1246
 
      if FileExistsUTF8(Result) then exit;
1247
 
    end;
1248
 
    {$ENDIF}
1249
 
  end else begin
1250
 
    Result:=SearchFileInPath(Executable,'',
1251
 
                             GetEnvironmentVariableUTF8('PATH'), PathSeparator,
1252
 
                             [sffDontSearchInBasePath]);
1253
 
    if Result<>'' then exit;
1254
 
    {$IFDEF Windows}
1255
 
    if ExtractFileExt(Executable)='' then begin
1256
 
      Result:=SearchFileInPath(Executable+'.exe','',
1257
 
                               GetEnvironmentVariableUTF8('PATH'), PathSeparator,
1258
 
                               [sffDontSearchInBasePath]);
1259
 
      if Result<>'' then exit;
1260
 
    end;
1261
 
    {$ENDIF}
1262
 
  end;
1263
 
  Result:='';
1264
 
end;
1265
 
 
1266
 
type
1267
 
 
1268
 
  { TListFileSearcher }
1269
 
 
1270
 
  TListFileSearcher = class(TFileSearcher)
1271
 
  private
1272
 
    FList: TStrings;
1273
 
  protected
1274
 
    procedure DoFileFound; override;
1275
 
  public
1276
 
    constructor Create(AList: TStrings);
1277
 
  end;
1278
 
 
1279
 
{ TListFileSearcher }
1280
 
 
1281
 
procedure TListFileSearcher.DoFileFound;
1282
 
begin
1283
 
  FList.Add(FileName);
1284
 
end;
1285
 
 
1286
 
constructor TListFileSearcher.Create(AList: TStrings);
1287
 
begin
1288
 
  FList := AList;
1289
 
end;
1290
 
 
1291
 
function FindAllFiles(const SearchPath: String; SearchMask: String;
1292
 
  SearchSubDirs: Boolean): TStringList;
1293
 
var
1294
 
  Searcher: TListFileSearcher;
1295
 
begin
1296
 
  Result := TStringList.Create;
1297
 
  Searcher := TListFileSearcher.Create(Result);
1298
 
  try
1299
 
    Searcher.Search(SearchPath, SearchMask, SearchSubDirs);
1300
 
  finally
1301
 
    Searcher.Free;
1302
 
  end;
1303
 
end;
1304
 
 
1305
 
{ TFileIterator }
1306
 
 
1307
 
function TFileIterator.GetFileName: String;
1308
 
begin
1309
 
  Result := FPath + FFileInfo.Name;
1310
 
end;
1311
 
 
1312
 
procedure TFileIterator.Stop;
1313
 
begin
1314
 
  FSearching := False;
1315
 
end;
1316
 
 
1317
 
function TFileIterator.IsDirectory: Boolean;
1318
 
begin
1319
 
  Result := (FFileInfo.Attr and faDirectory) <> 0;
1320
 
end;
1321
 
 
1322
 
{ TFileSearcher }
1323
 
 
1324
 
procedure TFileSearcher.RaiseSearchingError;
1325
 
begin
1326
 
  raise Exception.Create('The file searcher is already searching!');
1327
 
end;
1328
 
 
1329
 
procedure TFileSearcher.DoDirectoryEnter;
1330
 
begin
1331
 
  //
1332
 
end;
1333
 
 
1334
 
procedure TFileSearcher.DoDirectoryFound;
1335
 
begin
1336
 
  if Assigned(FOnDirectoryFound) then OnDirectoryFound(Self);
1337
 
end;
1338
 
 
1339
 
procedure TFileSearcher.DoFileFound;
1340
 
begin
1341
 
  if Assigned(FOnFileFound) then OnFileFound(Self);
1342
 
end;
1343
 
 
1344
 
constructor TFileSearcher.Create;
1345
 
begin
1346
 
  FSearching := False;
1347
 
end;
1348
 
 
1349
 
procedure TFileSearcher.Search(const ASearchPath: String; ASearchMask: String;
1350
 
  ASearchSubDirs: Boolean; AMaskSeparator: char);
1351
 
var
1352
 
  MaskList: TMaskList;
1353
 
 
1354
 
  procedure DoSearch(const APath: String; const ALevel: Integer);
1355
 
  var
1356
 
    P: String;
1357
 
    PathInfo: TSearchRec;
1358
 
  begin
1359
 
    P := APath + AllDirectoryEntriesMask;
1360
 
 
1361
 
    if FindFirstUTF8(P, faAnyFile, PathInfo) = 0 then
1362
 
    try
1363
 
      begin
1364
 
        repeat
1365
 
          // skip special files
1366
 
          if (PathInfo.Name = '.') or (PathInfo.Name = '..') or
1367
 
            (PathInfo.Name = '') then Continue;
1368
 
 
1369
 
          if (PathInfo.Attr and faDirectory) = 0 then
1370
 
          begin
1371
 
            if (MaskList = nil) or MaskList.Matches(PathInfo.Name) then
1372
 
            begin
1373
 
              FPath := APath;
1374
 
              FLevel := ALevel;
1375
 
              FFileInfo := PathInfo;
1376
 
              DoFileFound;
1377
 
            end;
1378
 
          end
1379
 
          else
1380
 
          begin
1381
 
            FPath := APath;
1382
 
            FLevel := ALevel;
1383
 
            FFileInfo := PathInfo;
1384
 
            DoDirectoryFound;
1385
 
          end;
1386
 
 
1387
 
        until (FindNextUTF8(PathInfo) <> 0) or not FSearching;
1388
 
      end;
1389
 
    finally
1390
 
      FindCloseUTF8(PathInfo);
1391
 
    end;
1392
 
    
1393
 
    if ASearchSubDirs or (ALevel > 0) then // search recursively in directories
1394
 
      if FindFirstUTF8(P, faAnyFile, PathInfo) = 0 then
1395
 
      try
1396
 
        begin
1397
 
          repeat
1398
 
            if (PathInfo.Name = '.') or (PathInfo.Name = '..') or
1399
 
              (PathInfo.Name = '') or ((PathInfo.Attr and faDirectory) = 0) then Continue;
1400
 
              
1401
 
            FPath := APath;
1402
 
            FLevel := ALevel;
1403
 
            FFileInfo := PathInfo;
1404
 
            DoDirectoryEnter;
1405
 
            if not FSearching then Break;
1406
 
            
1407
 
            DoSearch(AppendPathDelim(APath + PathInfo.Name), Succ(ALevel));
1408
 
            
1409
 
          until (FindNextUTF8(PathInfo) <> 0);
1410
 
        end;
1411
 
      finally
1412
 
        FindCloseUTF8(PathInfo);
1413
 
      end;
1414
 
  end;
1415
 
 
1416
 
begin
1417
 
  if FSearching then RaiseSearchingError;
1418
 
 
1419
 
  MaskList := TMaskList.Create(ASearchMask,AMaskSeparator);
1420
 
  // empty mask = all files mask
1421
 
  if MaskList.Count = 0 then FreeAndNil(MaskList);
1422
 
 
1423
 
  FSearching := True;
1424
 
  try
1425
 
    DoSearch(AppendPathDelim(ASearchPath), 0);
1426
 
  finally
1427
 
    FSearching := False;
1428
 
    if MaskList <> nil then MaskList.Free;
1429
 
  end;
1430
 
end;
1431
 
 
1432
 
function GetAllFilesMask: string;
1433
 
begin
1434
 
  {$IFDEF WINDOWS}
1435
 
  Result:='*.*';
1436
 
  {$ELSE}
1437
 
  Result:='*';
1438
 
  {$ENDIF}
1439
 
end;
1440
 
 
1441
 
function GetExeExt: string;
1442
 
begin
1443
 
  {$IFDEF WINDOWS}
1444
 
  Result:='.exe';
1445
 
  {$ELSE}
1446
 
  Result:='';
1447
 
  {$ENDIF}
1448
 
end;
1449
 
 
1450
 
{------------------------------------------------------------------------------
1451
 
  function ReadFileToString(const Filename: string): string;
1452
 
 ------------------------------------------------------------------------------}
1453
 
function ReadFileToString(const Filename: String): String;
1454
 
var
1455
 
  fs: TFileStream;
1456
 
begin
1457
 
  Result := '';
1458
 
  try
1459
 
    fs := TFileStream.Create(UTF8ToSys(Filename), fmOpenRead or fmShareDenyWrite);
1460
 
    try
1461
 
      Setlength(Result, fs.Size);
1462
 
      if Result <> '' then
1463
 
        fs.Read(Result[1], Length(Result));
1464
 
    finally
1465
 
      fs.Free;
1466
 
    end;
1467
 
  except
1468
 
    Result := '';
1469
 
  end;
1470
 
end;
1471
 
 
1472
 
{------------------------------------------------------------------------------
1473
 
  function FileSearchUTF8(const Name, DirList: String): String;
1474
 
 ------------------------------------------------------------------------------}
1475
 
function FileSearchUTF8(const Name, DirList: String; ImplicitCurrentDir : Boolean = True): String;
1476
 
Var
1477
 
  I : longint;
1478
 
  Temp : String;
1479
 
 
1480
 
begin
1481
 
  Result:=Name;
1482
 
  temp:=SetDirSeparators(DirList);
1483
 
  // Start with checking the file in the current directory
1484
 
  If ImplicitCurrentDir and (Result <> '') and FileExistsUTF8(Result) Then
1485
 
    exit;
1486
 
  while True do begin
1487
 
    If Temp = '' then
1488
 
      Break; // No more directories to search - fail
1489
 
    I:=pos(PathSeparator,Temp);
1490
 
    If I<>0 then
1491
 
      begin
1492
 
        Result:=Copy (Temp,1,i-1);
1493
 
        system.Delete(Temp,1,I);
1494
 
      end
1495
 
    else
1496
 
      begin
1497
 
        Result:=Temp;
1498
 
        Temp:='';
1499
 
      end;
1500
 
    If Result<>'' then
1501
 
      Result:=IncludeTrailingPathDelimiter(Result)+name;
1502
 
    If (Result <> '') and FileExistsUTF8(Result) Then
1503
 
      exit;
1504
 
  end;
1505
 
  Result:='';
1506
 
end;
1507
 
 
1508
 
{------------------------------------------------------------------------------
1509
 
  function ForceDirectoriesUTF8(const Dir: string): Boolean;
1510
 
 ------------------------------------------------------------------------------}
1511
 
function ForceDirectoriesUTF8(const Dir: string): Boolean;
1512
 
 
1513
 
  var
1514
 
    E: EInOutError;
1515
 
    ADrv : String;
1516
 
 
1517
 
  function DoForceDirectories(Const Dir: string): Boolean;
1518
 
  var
1519
 
    ADir : String;
1520
 
    APath: String;
1521
 
  begin
1522
 
    Result:=True;
1523
 
    ADir:=ExcludeTrailingPathDelimiter(Dir);
1524
 
    if (ADir='') then Exit;
1525
 
    if Not DirectoryExistsUTF8(ADir) then
1526
 
      begin
1527
 
        APath := ExtractFilePath(ADir);
1528
 
        //this can happen on Windows if user specifies Dir like \user\name/test/
1529
 
        //and would, if not checked for, cause an infinite recusrsion and a stack overflow
1530
 
        if (APath = ADir) then Result := False
1531
 
          else Result:=DoForceDirectories(APath);
1532
 
      If Result then
1533
 
        Result := CreateDirUTF8(ADir);
1534
 
      end;
1535
 
  end;
1536
 
 
1537
 
  function IsUncDrive(const Drv: String): Boolean;
1538
 
  begin
1539
 
    Result := (Length(Drv) > 2) and (Drv[1] = PathDelim) and (Drv[2] = PathDelim);
1540
 
  end;
1541
 
 
1542
 
begin
1543
 
  Result := False;
1544
 
  ADrv := ExtractFileDrive(Dir);
1545
 
  if (ADrv<>'') and (not DirectoryExistsUTF8(ADrv))
1546
 
  {$IFNDEF FORCEDIR_NO_UNC_SUPPORT} and (not IsUncDrive(ADrv)){$ENDIF} then Exit;
1547
 
  if Dir='' then
1548
 
    begin
1549
 
      E:=EInOutError.Create(SCannotCreateEmptyDir);
1550
 
      E.ErrorCode:=3;
1551
 
      Raise E;
1552
 
    end;
1553
 
  Result := DoForceDirectories(SetDirSeparators(Dir));
1554
 
end;
1555
 
 
1556
 
{------------------------------------------------------------------------------
1557
 
  function ForceDirectoriesUTF8(const Dir: string): Boolean;
1558
 
 ------------------------------------------------------------------------------}
1559
 
function FileIsReadOnlyUTF8(const FileName: String): Boolean;
1560
 
begin
1561
 
  Result:=FileGetAttrUTF8(FileName) and faReadOnly > 0;
1562
 
end;
1563