From 6a2aac0449af3a53e2e8502cd5955d3b0e6374e5 Mon Sep 17 00:00:00 2001 From: lazarus Date: Sat, 15 Dec 2001 22:57:37 +0000 Subject: [PATCH] MG: added file procs git-svn-id: trunk@532 - --- .gitattributes | 1 + components/codetools/fileprocs.pas | 166 +++++++++++++++++++++++++++++ 2 files changed, 167 insertions(+) create mode 100644 components/codetools/fileprocs.pas diff --git a/.gitattributes b/.gitattributes index 2388755288..62848d3a9b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12,6 +12,7 @@ components/codetools/customcodetool.pas svneol=native#text/pascal components/codetools/definetemplates.pas svneol=native#text/pascal components/codetools/eventcodetool.pas svneol=native#text/pascal components/codetools/expreval.pas svneol=native#text/pascal +components/codetools/fileprocs.pas svneol=native#text/pascal components/codetools/finddeclarationtool.pas svneol=native#text/pascal components/codetools/keywordfunclists.pas svneol=native#text/pascal components/codetools/linkscanner.pas svneol=native#text/pascal diff --git a/components/codetools/fileprocs.pas b/components/codetools/fileprocs.pas new file mode 100644 index 0000000000..fc22a73131 --- /dev/null +++ b/components/codetools/fileprocs.pas @@ -0,0 +1,166 @@ +{ + *************************************************************************** + * * + * This source is free software; you can redistribute it and/or modify * + * it under the terms of the GNU General Public License as published by * + * the Free Software Foundation; either version 2 of the License, or * + * (at your option) any later version. * + * * + * This code is distributed in the hope that it will be useful, but * + * WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * + * General Public License for more details. * + * * + * A copy of the GNU General Public License is available on the World * + * Wide Web at . You can also * + * obtain it by writing to the Free Software Foundation, * + * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * + * * + *************************************************************************** + + Author: Mattias Gaertner + + Abstract: + - simple file functions + + + ToDo: +} +unit FileProcs; + +{$ifdef FPC}{$mode objfpc}{$endif}{$H+} + +interface + +{$I codetools.inc} + +uses + {$IFDEF MEM_CHECK} + MemCheck, + {$ENDIF} + Classes, SysUtils; + +const + // ToDo: find the constant in the fpc units. + EndOfLine:shortstring={$IFDEF win32}#13+{$ENDIF}#10; + +// files +function CompareFilenames(const Filename1, Filename2: string): integer; +function DirectoryExists(DirectoryName: string): boolean; +function ExtractFileNameOnly(const AFilename: string): string; +function FilenameIsAbsolute(TheFilename: string):boolean; +function ForceDirectory(DirectoryName: string): boolean; +procedure CheckIfFileIsExecutable(const AFilename: string); + + +implementation + + +// to get more detailed error messages consider the os + {$IFDEF Linux} +uses + {$IFDEF Ver1_0} + Linux + {$ELSE} + Unix + {$ENDIF} + ; + {$ENDIF} + +function CompareFilenames(const Filename1, Filename2: string): integer; +begin + {$IFDEF WIN32} + Result:=AnsiCompareText(Filename1, Filename2); + {$ELSE} + Result:=AnsiCompareStr(Filename1, Filename2); + {$ENDIF} +end; + +function FileIsExecutable(const AFilename: string): boolean; +begin + try + CheckIfFileIsExecutable(AFilename); + Result:=true; + except + Result:=false; + end; +end; + +procedure CheckIfFileIsExecutable(const AFilename: string); +var AText: string; +begin + // TProcess does not report, if a program can not be executed + // to get good error messages consider the OS + if not FileExists(AFilename) then begin + raise Exception.Create('file "'+AFilename+'" does not exist'); + end; + {$IFDEF linux} + if not{$IFDEF Ver1_0}Linux{$ELSE}Unix{$ENDIF}.Access( + AFilename,{$IFDEF Ver1_0}Linux{$ELSE}Unix{$ENDIF}.X_OK) then + begin + AText:='"'+AFilename+'"'; + case LinuxError of + sys_eacces: AText:='execute access denied for '+AText; + sys_enoent: AText:='a directory component in '+AText + +' does not exist or is a dangling symlink'; + sys_enotdir: AText:='a directory component in '+Atext+' is not a directory'; + sys_enomem: AText:='insufficient memory'; + sys_eloop: AText:=AText+' has a circular symbolic link'; + else + AText:=AText+' is not executable'; + end; + raise Exception.Create(AText); + end; + {$ENDIF linux} + + // ToDo: windows and xxxbsd +end; + +function ExtractFileNameOnly(const AFilename: string): string; +var ExtLen: integer; +begin + Result:=ExtractFilename(AFilename); + ExtLen:=length(ExtractFileExt(Result)); + Result:=copy(Result,1,length(Result)-ExtLen); +end; + +function FilenameIsAbsolute(TheFilename: string):boolean; +begin + Result:=(ExpandFileName(TheFilename)=TheFilename); +end; + +function DirectoryExists(DirectoryName: string): boolean; +var sr: TSearchRec; +begin + if (DirectoryName<>'') + and (DirectoryName[length(DirectoryName)]=OSDirSeparator) then + DirectoryName:=copy(DirectoryName,1,length(DirectoryName)-1); + if FindFirst(DirectoryName,faAnyFile,sr)=0 then + Result:=((sr.Attr and faDirectory)>0) + else + Result:=false; + FindClose(sr); +end; + +function ForceDirectory(DirectoryName: string): boolean; +var i: integer; + Dir: string; +begin + DoDirSeparators(DirectoryName); + i:=1; + while i<=length(DirectoryName) do begin + if DirectoryName[i]=OSDirSeparator then begin + Dir:=copy(DirectoryName,1,i-1); + if not DirectoryExists(Dir) then begin + Result:=CreateDir(Dir); + if not Result then exit; + end; + end; + end; + Result:=true; +end; + + +end. + +