File: fileutil.pas

package info (click to toggle)
lazarus 4.0%2Bdfsg-3
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 275,760 kB
  • sloc: pascal: 2,341,904; xml: 509,420; makefile: 348,726; cpp: 93,608; sh: 3,387; java: 609; perl: 297; sql: 222; ansic: 137
file content (250 lines) | stat: -rw-r--r-- 8,962 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
{
 *****************************************************************************
  This file is part of LazUtils.

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}

{ ****************************************************************************
BB: 2013-05-19

Note to developers:

This unit should contain functions and procedures to
maintain compatibility with Delphi's FileUtil unit.

File routines that specifically deal with UTF8 filenames should go into
the LazFileUtils unit.

***************************************************************************** }
unit FileUtil;

{$mode objfpc}{$H+}
{$i lazutils_defines.inc}

interface

uses
  Classes, SysUtils, StrUtils,
  // LazUtils
  Masks, LazUTF8, LazFileUtils,
  Contnrs;

{$IF defined(Windows) or defined(darwin) or defined(HASAMIGA)}
{$define CaseInsensitiveFilenames}
{$ENDIF}
{$IF defined(CaseInsensitiveFilenames) or defined(darwin)}
{$define NotLiteralFilenames}
{$ENDIF}

const
  UTF8FileHeader = #$ef#$bb#$bf;
  FilenamesCaseSensitive = {$IFDEF CaseInsensitiveFilenames}false{$ELSE}true{$ENDIF};// lower and upper letters are treated the same
  FilenamesLiteral = {$IFDEF NotLiteralFilenames}false{$ELSE}true{$ENDIF};// file names can be compared using = string operator

// basic functions similar to the RTL but working with UTF-8 instead of the
// system encoding

// AnsiToUTF8 and UTF8ToAnsi need a widestring manager under Linux, BSD, MacOSX
// but normally these OS use UTF-8 as system encoding so the widestringmanager
// is not needed.

// file and directory operations
function ComparePhysicalFilenames(const Filename1, Filename2: string): integer;
function CompareFilenames(Filename1: PChar; Len1: integer;
  Filename2: PChar; Len2: integer; ResolveLinks: boolean): integer; overload;
function ExtractShortPathNameUTF8(Const FileName : String) : String;
function DeleteDirectory(const DirectoryName: string; OnlyChildren: boolean): boolean;
function ProgramDirectory: string;
function ProgramDirectoryWithBundle: string;

function ExpandUNCFileNameUTF8(const FileName: string): string;
function FileSize(const Filename: string): int64; overload; inline;
function FilenameHasPascalExt(const Filename: string): boolean;
function FileIsInPath(const Filename, Path: string): boolean;
function FileIsInDirectory(const Filename, Directory: string): boolean;

function GetAllFilesMask: string; inline;
function GetExeExt: string; inline;
function ReadFileToString(const Filename: string): string;

// file search
type
  TSearchFileInPathFlag = (
    sffDontSearchInBasePath, // do not search in BasePath, search only in SearchPath.
    sffSearchLoUpCase,
    sffFile, // must be file, not directory
    sffExecutable, // file must be executable
    sffDequoteSearchPath // ansi dequote
    );
  TSearchFileInPathFlags = set of TSearchFileInPathFlag;
const
  sffFindProgramInPath = [
    {$IFDEF Unix}sffDontSearchInBasePath,{$ENDIF}
    {$IFDEF Windows}sffDequoteSearchPath,{$ENDIF}
    sffFile,
    sffExecutable
    ];

function SearchFileInPath(const Filename, BasePath: string;
  SearchPath: string; const Delimiter: string;
  Flags: TSearchFileInPathFlags): string; overload;
function SearchAllFilesInPath(const Filename, BasePath, SearchPath,
  Delimiter: string; Flags: TSearchFileInPathFlags): TStrings;
function FindDiskFilename(const Filename: string): string;
function FindDiskFileCaseInsensitive(const Filename: string): string;
function FindDefaultExecutablePath(const Executable: string; const BaseDir: string = ''): string;

type

  { TFileIterator }

  TFileIterator = class
  private
    FPath: String;
    FLevel: Integer;
    FFileInfo: TSearchRec;
    FSearching: Boolean;
    function GetFileName: String;
  public
    procedure Stop;
    function IsDirectory: Boolean;
  public
    property FileName: String read GetFileName;
    property FileInfo: TSearchRec read FFileInfo;
    property Level: Integer read FLevel;
    property Path: String read FPath;
    property Searching: Boolean read FSearching;
  end;

  TFileFoundEvent = procedure (FileIterator: TFileIterator) of object;
  TDirectoryFoundEvent = procedure (FileIterator: TFileIterator) of object;
  TDirectoryEnterEvent = procedure (FileIterator: TFileIterator) of object;
  TQueryFileFoundEvent = procedure (FileIterator: TFileIterator; const Fn: String; var Accept: Boolean) of object;
  TQueryDirectoryFoundEvent = procedure (FileIterator: TFileIterator; const Dir: String; var Accept: Boolean) of object;

  { TFileSearcher }

  TFileSearcher = class(TFileIterator)
  private
    FMaskSeparator: char;
    FPathSeparator: char;
    FFollowSymLink: Boolean;
    FOnFileFound: TFileFoundEvent;
    FOnDirectoryFound: TDirectoryFoundEvent;
    FOnDirectoryEnter: TDirectoryEnterEvent;
    FFileAttribute: Word;
    FDirectoryAttribute: Word;
    FOnQueryFileFound: TQueryFileFoundEvent;
    FOnQueryDirectoryEnter: TQueryDirectoryFoundEvent;
    FCircularLinkDetection: Boolean;
    VisitedDirs: TFPStringHashTable;
    procedure RaiseSearchingError;
  protected
    procedure DoDirectoryEnter; virtual;
    procedure DoDirectoryFound; virtual;
    procedure DoFileFound; virtual;
    procedure DoQueryFileFound(const Fn: String; var Accept: Boolean);
    procedure DoQueryDirectoryEnter(const Dir: String; var Accept: Boolean);
  public
    constructor Create;
    procedure Search(const ASearchPath: String; const ASearchMask: String = '';
      ASearchSubDirs: Boolean = True; CaseSensitive: Boolean = False);
  public
    property MaskSeparator: char read FMaskSeparator write FMaskSeparator;
    property PathSeparator: char read FPathSeparator write FPathSeparator;
    property FollowSymLink: Boolean read FFollowSymLink write FFollowSymLink;
    property FileAttribute: Word read FFileAttribute write FFileAttribute default faAnyfile;
    property DirectoryAttribute: Word read FDirectoryAttribute write FDirectoryAttribute default faDirectory;
    property CircularLinkdetection: Boolean read FCircularLinkdetection write FCircularLinkdetection default False;
    property OnDirectoryFound: TDirectoryFoundEvent read FOnDirectoryFound write FOnDirectoryFound;
    property OnFileFound: TFileFoundEvent read FOnFileFound write FOnFileFound;
    property OnDirectoryEnter: TDirectoryEnterEvent read FOnDirectoryEnter write FOnDirectoryEnter;
    property OnQueryFileFound: TQueryFileFoundEvent read FOnQueryFileFound write FOnQueryFileFound;
    property OnQueryDirectoryEnter: TQueryDirectoryFoundEvent read FOnQueryDirectoryEnter write FOnQueryDirectoryEnter;
  end;

  { TListFileSearcher }

  TListFileSearcher = class(TFileSearcher)
  private
    FList: TStrings;
  protected
    procedure DoFileFound; override;
  public
    constructor Create(AList: TStrings);
  end;

  { TListDirectoriesSearcher }

  TListDirectoriesSearcher = class(TFileSearcher)
  private
    FDirectoriesList :TStrings;
  protected
    procedure DoDirectoryFound; override;
  public
    constructor Create(AList: TStrings);
  end;

function FindAllFiles(const SearchPath: String; const SearchMask: String = '';
  SearchSubDirs: Boolean = True; DirAttr: Word = faDirectory;
  MaskSeparator: char = ';'; PathSeparator: char = ';'): TStringList; overload;
procedure FindAllFiles(AList: TStrings; const SearchPath: String;
  const SearchMask: String = ''; SearchSubDirs: Boolean = True; DirAttr: Word = faDirectory;
  MaskSeparator: char = ';'; PathSeparator: char = ';'); overload;

function FindAllDirectories(const SearchPath: string;
  SearchSubDirs: Boolean = True; PathSeparator: char = ';'): TStringList; overload;
procedure FindAllDirectories(AList: TStrings; const SearchPath: String;
  SearchSubDirs: Boolean = true; PathSeparator: char = ';'); overload;

// flags for copy
type
  TCopyFileFlag = (
    cffOverwriteFile,
    cffCreateDestDirectory,
    cffPreserveTime
    );
  TCopyFileFlags = set of TCopyFileFlag;

// Copy a file and a whole directory tree
function CopyFile(const SrcFilename, DestFilename: string;
                  Flags: TCopyFileFlags=[cffOverwriteFile]; ExceptionOnError: Boolean=False): boolean;
function CopyFile(const SrcFilename, DestFilename: string; PreserveTime: boolean; ExceptionOnError: Boolean=False): boolean;
function CopyDirTree(const SourceDir, TargetDir: string; Flags: TCopyFileFlags=[]): Boolean;

// filename parts
const
  PascalFileExt: array[1..3] of string = ('.pas','.pp','.p');
  PascalSourceExt: array[1..6] of string = ('.pas','.pp','.p','.lpr','.dpr','.dpk');

  AllDirectoryEntriesMask = '*';

implementation

uses
{$IFDEF windows}
  Windows;
{$ELSE}
  {$IFDEF HASAMIGA}
  AmigaDOS;
  {$ELSE}
  Unix;
  {$ENDIF}
{$ENDIF}

{$I fileutil.inc}
{$IFDEF windows}
  {$i winfileutil.inc}
{$ELSE}
  {$IFDEF HASAMIGA}
  {$i unixfileutil.inc}   // Reuse UNIX code for Amiga
  {$ELSE}
  {$i unixfileutil.inc}
  {$ENDIF}
{$ENDIF}

end.