(* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * The Original Code is TurboPower Abbrevia * * The Initial Developer of the Original Code is * TurboPower Software * * Portions created by the Initial Developer are Copyright (C) 1997-2002 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) {*********************************************************} {* ABBREVIA: AbUtils.pas *} {*********************************************************} {* ABBREVIA: Utility classes and routines *} {*********************************************************} unit AbUtils; {$I AbDefine.inc} interface uses {$IFDEF MSWINDOWS} Windows, {$ENDIF} {$IFDEF LibcAPI} Libc, {$ENDIF} {$IFDEF FPCUnixAPI} baseunix, {$IFDEF Linux} initc, {$ENDIF} unix, {$ENDIF} {$IFDEF PosixAPI} Posix.SysStatvfs, Posix.SysStat, Posix.Utime, Posix.Base, Posix.Unistd, Posix.Fcntl, Posix.SysTypes, {$ENDIF} {$IFDEF UNIX} DateUtils, {$ENDIF} {$IFDEF HasAnsiStrings} System.AnsiStrings, {$ENDIF} SysUtils, Classes, AbCharset; type {describe the pending action for an archive item} TAbArchiveAction = (aaFailed, aaNone, aaAdd, aaDelete, aaFreshen, aaMove, aaReplace, aaStreamAdd); TAbProcessType = (ptAdd, ptDelete, ptExtract, ptFreshen, ptMove, ptReplace, ptFoundUnhandled); TAbLogType = (ltAdd, ltDelete, ltExtract, ltFreshen, ltMove, ltReplace, ltStart, ltFoundUnhandled); TAbErrorClass = (ecAbbrevia, ecInOutError, ecFilerError, ecFileCreateError, ecFileOpenError, ecCabError, ecOther); const AbPathDelim = PathDelim; { Delphi/Linux constant } AbPathSep = PathSep; { Delphi/Linux constant } AbDosPathDelim = '\'; AbUnixPathDelim = '/'; AbDosPathSep = ';'; AbUnixPathSep = ':'; AbDosAnyFile = '*.*'; AbUnixAnyFile = '*'; AbAnyFile = {$IFDEF UNIX} AbUnixAnyFile; {$ELSE} AbDosAnyFile; {$ENDIF} AbThisDir = '.'; AbParentDir = '..'; type TAbArchiveType = (atUnknown, atZip, atSpannedZip, atSelfExtZip, atTar, atGzip, atGzippedTar, atCab, atBzip2, atBzippedTar); {$IF NOT DECLARED(DWORD)} type DWORD = LongWord; {$IFEND} {$IF NOT DECLARED(PtrInt)} type // Delphi 7-2007 declared NativeInt incorrectly {$IFDEF CPU386} PtrInt = LongInt; PtrUInt = LongWord; {$ELSE} PtrInt = NativeInt; PtrUInt = NativeUInt; {$ENDIF} {$IFEND} { System-encoded SBCS string (formerly AnsiString) } type AbSysString = {$IFDEF Posix}UTF8String{$ELSE}AnsiString{$ENDIF}; const AbCrc32Table : array[0..255] of DWord = ( $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f, $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9, $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d ); type TAbPathType = ( ptNone, ptRelative, ptAbsolute ); {===Helper functions===} function AbCopyFile(const Source, Destination: string; FailIfExists: Boolean): Boolean; procedure AbCreateDirectory( const Path : string ); {creates the requested directory tree. CreateDir is insufficient, because if you have a path x:\dir, and request x:\dir\sub1\sub2, (/dir and /dir/sub1/sub2 on Unix) it fails.} function AbCreateTempFile(const Dir : string) : string; function AbGetTempDirectory : string; {-Return the system temp directory} function AbGetTempFile(const Dir : string; CreateIt : Boolean) : string; function AbDrive(const ArchiveName : string) : Char; function AbDriveIsRemovable(const ArchiveName : string) : Boolean; function AbFileMatch(FileName : string; FileMask : string ) : Boolean; {see if FileName matches FileMask} procedure AbFindFiles(const FileMask : string; SearchAttr : Integer; FileList : TStrings; Recurse : Boolean ); procedure AbFindFilesEx( const FileMask : string; SearchAttr : Integer; FileList : TStrings; Recurse : Boolean ); function AbAddBackSlash(const DirName : string) : string; function AbFindNthSlash( const Path : string; n : Integer ) : Integer; {return the position of the character just before the nth backslash} function AbGetDriveFreeSpace(const ArchiveName : string) : Int64; {return the available space on the specified drive } function AbGetPathType( const Value : string ) : TAbPathType; {returns path type - none, relative or absolute} {$IFDEF MSWINDOWS} function AbGetShortFileSpec(const LongFileSpec : string ) : string; {$ENDIF} procedure AbIncFilename( var Filename : string; Value : Word ); procedure AbParseFileName( FileSpec : string; out Drive : string; out Path : string; out FileName : string ); procedure AbParsePath( Path : string; SubPaths : TStrings ); {- break abart path into subpaths --- Path : abbrevia/examples -> SubPaths[0] = abbrevia SubPaths[1] = examples} function AbPatternMatch(const Source : string; iSrc : Integer; const Pattern : string; iPat : Integer ) : Boolean; { recursive routine to see if the source string matches the pattern. Both ? and * wildcard characters are allowed.} function AbPercentage(V1, V2 : Int64) : Byte; {-Returns the ratio of V1 to V2 * 100} procedure AbStripDots( var FName : string ); {-strips relative path information} procedure AbStripDrive( var FName : string ); {-strips the drive off a filename} procedure AbFixName( var FName : string ); {-changes backslashes to forward slashes} procedure AbUnfixName( var FName : string ); {-changes forward slashes to backslashes} procedure AbUpdateCRC( var CRC : LongInt; const Buffer; Len : Integer ); function AbUpdateCRC32(CurByte : Byte; CurCrc : LongInt) : LongInt; {-Returns an updated crc32} function AbCRC32Of( const aValue : RawByteString ) : LongInt; function AbWriteVolumeLabel(const VolName : string; Drive : Char) : Cardinal; const AB_SPAN_VOL_LABEL = 'PKBACK# %3.3d'; function AbGetVolumeLabel(Drive : Char) : string; procedure AbSetSpanVolumeLabel(Drive: Char; VolNo : Integer); function AbTestSpanVolumeLabel(Drive: Char; VolNo : Integer): Boolean; procedure AbSetFileAttr(const aFileName : string; aAttr: Integer); {-Sets platform-native file attributes (DOS attr or Unix mode)} function AbFileGetSize(const aFileName : string) : Int64; type TAbAttrExRec = record Time: TDateTime; Size: Int64; Attr: Integer; Mode: {$IFDEF UNIX}mode_t{$ELSE}Cardinal{$ENDIF}; end; function AbFileGetAttrEx(const aFileName: string; out aAttr: TAbAttrExRec) : Boolean; function AbSwapLongEndianness(Value : LongInt): LongInt; { date and time stuff } const Date1900 {: LongInt} = $0001AC05; {Julian day count for 01/01/1900 -- TDateTime Start Date} Date1970 {: LongInt} = $00020FE4; {Julian day count for 01/01/1970 -- Unix Start Date} Unix0Date: TDateTime = 25569; {Date1970 - Date1900} SecondsInDay = 86400; {Number of seconds in a day} SecondsInHour = 3600; {Number of seconds in an hour} SecondsInMinute = 60; {Number of seconds in a minute} HoursInDay = 24; {Number of hours in a day} MinutesInHour = 60; {Number of minutes in an hour} MinutesInDay = 1440; {Number of minutes in a day} function AbUnixTimeToLocalDateTime(UnixTime : LongInt) : TDateTime; function AbLocalDateTimeToUnixTime(DateTime : TDateTime) : LongInt; function AbDosFileDateToDateTime(FileDate, FileTime : Word) : TDateTime; function AbDateTimeToDosFileDate(Value : TDateTime) : LongInt; function AbGetFileTime(const aFileName: string): TDateTime; function AbSetFileTime(const aFileName: string; aValue: TDateTime): Boolean; { file attributes } function AbDOS2UnixFileAttributes(Attr: LongInt): LongInt; function AbUnix2DosFileAttributes(Attr: LongInt): LongInt; { AnisStrings } function AbLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString; {$IFDEF HasInline}inline;{$ENDIF} function AbStrLen(const Str: PAnsiChar): Cardinal; {$IFDEF HasInline}inline;{$ENDIF} function AbStrPCopy(Dest: PAnsiChar; const Source: AnsiString): PAnsiChar; {$IFDEF HasInline}inline;{$ENDIF} function AbStrPLCopy(Dest: PAnsiChar; const Source: AnsiString; MaxLen: Cardinal): PAnsiChar; {$IFDEF HasInline}inline;{$ENDIF} { UNIX File Types and Permissions } const AB_FMODE_FILE = $0000; AB_FMODE_FIFO = $1000; AB_FMODE_CHARSPECFILE = $2000; AB_FMODE_DIR = $4000; AB_FMODE_BLOCKSPECFILE = $6000; AB_FMODE_FILE2 = $8000; AB_FMODE_FILELINK = $A000; AB_FMODE_SOCKET = $C000; AB_FPERMISSION_OWNERREAD = $0100; { read by owner } AB_FPERMISSION_OWNERWRITE = $0080; { write by owner } AB_FPERMISSION_OWNEREXECUTE = $0040; { execute/search by owner } AB_FPERMISSION_GROUPREAD = $0020; { read by group } AB_FPERMISSION_GROUPWRITE = $0010; { write by group } AB_FPERMISSION_GROUPEXECUTE = $0008; { execute/search by group } AB_FPERMISSION_OTHERREAD = $0004; { read by other } AB_FPERMISSION_OTHERWRITE = $0002; { write by other } AB_FPERMISSION_OTHEREXECUTE = $0001; { execute/search by other } AB_FPERMISSION_GENERIC = AB_FPERMISSION_OWNERREAD or AB_FPERMISSION_OWNERWRITE or AB_FPERMISSION_GROUPREAD or AB_FPERMISSION_OTHERREAD; { Unicode backwards compatibility functions } {$IFNDEF UNICODE} function CharInSet(C: AnsiChar; CharSet: TSysCharSet): Boolean; {$ENDIF} implementation uses StrUtils, AbConst, AbExcept; {$IF DEFINED(FPCUnixAPI)} function mktemp(template: PAnsiChar): PAnsiChar; cdecl; external clib name 'mktemp'; {$ELSEIF DEFINED(PosixAPI)} function mktemp(template: PAnsiChar): PAnsiChar; cdecl; external libc name _PU + 'mktemp'; {$IFEND} {$IF DEFINED(FPCUnixAPI) AND DEFINED(Linux)} // FreePascal libc definitions type nl_item = cint; const __LC_CTYPE = 0; _NL_CTYPE_CLASS = (__LC_CTYPE shl 16); _NL_CTYPE_CODESET_NAME = (_NL_CTYPE_CLASS)+14; function nl_langinfo(__item: nl_item): PAnsiChar; cdecl; external clib name 'nl_langinfo'; {$IFEND} {===platform independent routines for platform dependent stuff=======} function ExtractShortName(const SR : TSearchRec) : string; begin {$IFDEF MSWINDOWS} {$WARN SYMBOL_PLATFORM OFF} if SR.FindData.cAlternateFileName[0] <> #0 then Result := SR.FindData.cAlternateFileName else Result := SR.FindData.cFileName; {$WARN SYMBOL_PLATFORM ON} {$ENDIF} {$IFDEF UNIX} Result := SR.Name; {$ENDIF} end; {====================================================================} { ========================================================================== } function AbCopyFile(const Source, Destination: string; FailIfExists: Boolean): Boolean; {$IFDEF UNIX} var DesStream, SrcStream: TFileStream; {$ENDIF} begin {$IFDEF UNIX} Result := False; if not FailIfExists or not FileExists(Destination) then try SrcStream := TFileStream.Create(Source, fmOpenRead or fmShareDenyWrite); try DesStream := TFileStream.Create(Destination, fmCreate); try DesStream.CopyFrom(SrcStream, 0); Result := True; finally DesStream.Free; end; finally SrcStream.Free; end; except // Ignore errors and just return false end; {$ENDIF UNIX} {$IFDEF MSWINDOWS} Result := CopyFile(PChar(Source), PChar(Destination), FailIfExists); {$ENDIF MSWINDOWS} end; { -------------------------------------------------------------------------- } procedure AbCreateDirectory( const Path : string ); {creates the requested directory tree. CreateDir is insufficient, because if you have a path x:\dir, and request x:\dir\sub1\sub2, (/dir and /dir/sub1/sub2 on Unix) it fails.} var iStartSlash : Integer; i : Integer; TempPath : string; begin if DirectoryExists( Path ) then Exit; {see how much of the path currently exists} if Pos( '\\', Path ) > 0 then {UNC Path \\computername\sharename\path1..\pathn} iStartSlash := 5 else {standard Path drive:\path1..\pathn} iStartSlash := 2; repeat {find the Slash at iStartSlash} i := AbFindNthSlash( Path, iStartSlash ); {get a temp path to try: drive:\path1} TempPath := Copy( Path, 1, i ); {if it doesn't exist, create it} if not DirectoryExists( TempPath ) then MkDir( TempPath ); inc( iStartSlash ); until ( Length( TempPath ) = Length( Path ) ); end; { -------------------------------------------------------------------------- } function AbCreateTempFile(const Dir : string) : string; begin Result := AbGetTempFile(Dir, True); end; { -------------------------------------------------------------------------- } function AbGetTempDirectory : string; begin {$IFDEF MSWiNDOWS} SetLength(Result, MAX_PATH); SetLength(Result, GetTempPath(Length(Result), PChar(Result))); {$ENDIF} {$IFDEF UNIX} Result := '/tmp/'; {$ENDIF} end; { -------------------------------------------------------------------------- } function AbGetTempFile(const Dir : string; CreateIt : Boolean) : string; var TempPath : string; {$IFDEF MSWINDOWS} FileNameZ : array [0..259] of char; {$ENDIF} {$IFDEF UNIX} hFile: Integer; FileName: AbSysString; {$ENDIF} begin if DirectoryExists(Dir) then TempPath := Dir else TempPath := AbGetTempDirectory; {$IFDEF MSWINDOWS} GetTempFileName(PChar(TempPath), 'VMS', Word(not CreateIt), FileNameZ); Result := string(FileNameZ); {$ENDIF} {$IFDEF UNIX} FileName := AbSysString(TempPath) + 'VMSXXXXXX'; mktemp(PAnsiChar(AbSysString(FileName))); Result := string(FileName); if CreateIt then begin hFile := FileCreate(Result); if hFile <> -1 then FileClose(hFile); end; {$ENDIF} end; { -------------------------------------------------------------------------- } function AbDrive(const ArchiveName : string) : Char; var iPos: Integer; Path : string; begin Path := ExpandFileName(ArchiveName); iPos := Pos(':', Path); if (iPos <= 0) then Result := 'A' else Result := Path[1]; end; { -------------------------------------------------------------------------- } function AbDriveIsRemovable(const ArchiveName : string) : Boolean; {$IFDEF MSWINDOWS} var Path: string; {$ENDIF} begin {$IFDEF MSWINDOWS} Path := ExpandFileName(ArchiveName); if AnsiStartsText('\\?\UNC\', Path) then Delete(Path, 1, 8) else if AnsiStartsText('\\?\', Path) then Delete(Path, 1, 4); Path := IncludeTrailingPathDelimiter(ExtractFileDrive(Path)); Result := GetDriveType(PChar(Path)) = DRIVE_REMOVABLE; {$ENDIF} {$IFDEF LINUX} {LINUX -- Following may not cover all the bases} Result := AnsiStartsText('/mnt/floppy', ExtractFilePath(ExpandFileName(ArchiveName))); {$ENDIF} {$IFDEF DARWIN} Result := False; {$ENDIF} end; { -------------------------------------------------------------------------- } function AbGetDriveFreeSpace(const ArchiveName : string) : Int64; { attempt to find free space (in bytes) on drive/volume, returns -1 if fails for some reason } {$IFDEF MSWINDOWS} var FreeAvailable, TotalSpace: Int64; begin if GetDiskFreeSpaceEx(PChar(ExtractFilePath(ExpandFileName(ArchiveName))), FreeAvailable, TotalSpace, nil) then Result := FreeAvailable else Result := -1; {$ENDIF} {$IFDEF UNIX} var FStats : {$IFDEF PosixAPI}_statvfs{$ELSE}TStatFs{$ENDIF}; begin {$IF DEFINED(LibcAPI)} if statfs(PAnsiChar(ExtractFilePath(ArchiveName)), FStats) = 0 then Result := Int64(FStats.f_bAvail) * Int64(FStats.f_bsize) {$ELSEIF DEFINED(FPCUnixAPI)} if fpStatFS(PAnsiChar(ExtractFilePath(ArchiveName)), @FStats) = 0 then Result := Int64(FStats.bAvail) * Int64(FStats.bsize) {$ELSEIF DEFINED(PosixAPI)} if statvfs(PAnsiChar(AbSysString(ExtractFilePath(ArchiveName))), FStats) = 0 then Result := Int64(FStats.f_bavail) * Int64(FStats.f_bsize) {$IFEND} else Result := -1; {$ENDIF} end; { -------------------------------------------------------------------------- } function AbFileMatch(FileName: string; FileMask: string ): Boolean; {see if FileName matches FileMask} var DirMatch : Boolean; MaskDir : string; begin FileName := UpperCase( FileName ); FileMask := UpperCase( FileMask ); MaskDir := ExtractFilePath( FileMask ); if MaskDir = '' then DirMatch := True else DirMatch := AbPatternMatch( ExtractFilePath( FileName ), 1, MaskDir, 1 ); Result := DirMatch and AbPatternMatch( ExtractFileName( FileName ), 1, ExtractFileName( FileMask ), 1 ); end; { -------------------------------------------------------------------------- } procedure AbFindFiles( const FileMask : string; SearchAttr : Integer; FileList : TStrings; Recurse : Boolean ); var NewFile : string; SR : TSearchRec; Found : Integer; NameMask: string; begin Found := FindFirst( FileMask, SearchAttr, SR ); if Found = 0 then begin try NameMask := UpperCase(ExtractFileName(FileMask)); while Found = 0 do begin NewFile := ExtractFilePath( FileMask ) + SR.Name; if (SR.Name <> AbThisDir) and (SR.Name <> AbParentDir) and AbPatternMatch(UpperCase(SR.Name), 1, NameMask, 1) then if (SR.Attr and faDirectory) <> 0 then FileList.Add( NewFile + PathDelim ) else FileList.Add( NewFile ); Found := FindNext( SR ); end; finally FindClose( SR ); end; end; if not Recurse then Exit; NewFile := ExtractFilePath( FileMask ); if ( NewFile <> '' ) and ( NewFile[Length(NewFile)] <> AbPathDelim) then NewFile := NewFile + AbPathDelim; NewFile := NewFile + AbAnyFile; Found := FindFirst( NewFile, faDirectory or SearchAttr, SR ); if Found = 0 then begin try while ( Found = 0 ) do begin if ( SR.Name <> AbThisDir ) and ( SR.Name <> AbParentDir ) and ((SR.Attr and faDirectory) > 0 ) then AbFindFiles( ExtractFilePath( NewFile ) + SR.Name + AbPathDelim + ExtractFileName( FileMask ), SearchAttr, FileList, True ); Found := FindNext( SR ); end; finally FindClose( SR ); end; end; end; { -------------------------------------------------------------------------- } procedure AbFindFilesEx( const FileMask : string; SearchAttr : Integer; FileList : TStrings; Recurse : Boolean ); var I, J: Integer; MaskPart: string; begin I := 1; while I <= Length(FileMask) do begin J := I; while (I <= Length(FileMask)) and (FileMask[I] <> AbPathSep) do Inc(I); MaskPart := Trim(Copy(FileMask, J, I - J)); if (I <= Length(FileMask)) and (FileMask[I] = AbPathSep) then Inc(I); AbFindFiles(MaskPart, SearchAttr, FileList, Recurse); end; end; { -------------------------------------------------------------------------- } function AbAddBackSlash(const DirName : string) : string; { Add a default slash to a directory name } const AbDelimSet : set of AnsiChar = [AbPathDelim, ':', #0]; begin Result := DirName; if Length(DirName) = 0 then Exit; if not CharInSet(DirName[Length(DirName)], AbDelimSet) then Result := DirName + AbPathDelim; end; { -------------------------------------------------------------------------- } function AbFindNthSlash( const Path : string; n : Integer ) : Integer; { return the position of the character just before the nth slash } var i : Integer; Len : Integer; iSlash : Integer; begin Len := Length( Path ); Result := Len; iSlash := 0; i := 0; while i <= Len do begin if Path[i] = AbPathDelim then begin inc( iSlash ); if iSlash = n then begin Result := pred( i ); break; end; end; inc( i ); end; end; { -------------------------------------------------------------------------- } function AbGetPathType( const Value : string ) : TAbPathType; { returns path type - none, relative or absolute } begin Result := ptNone; {$IFDEF MSWINDOWS} {check for drive/unc info} if ( Pos( '\\', Value ) > 0 ) or ( Pos( ':', Value ) > 0 ) then {$ENDIF MSWINDOWS} {$IFDEF UNIX} { UNIX absolute paths start with a slash } if (Value[1] = AbPathDelim) then {$ENDIF UNIX} Result := ptAbsolute else if ( Pos( AbPathDelim, Value ) > 0 ) or ( Pos( AB_ZIPPATHDELIM, Value ) > 0 ) then Result := ptRelative; end; { -------------------------------------------------------------------------- } {$IFDEF MSWINDOWS} {$WARN SYMBOL_PLATFORM OFF} function AbGetShortFileSpec(const LongFileSpec : string ) : string; var SR : TSearchRec; Search : string; Drive : string; Path : string; FileName : string; Found : Integer; SubPaths : TStrings; i : Integer; begin AbParseFileName( LongFileSpec, Drive, Path, FileName ); SubPaths := TStringList.Create; try AbParsePath( Path, SubPaths ); Search := Drive; Result := Search + AbPathDelim; if SubPaths.Count > 0 then for i := 0 to pred( SubPaths.Count ) do begin Search := Search + AbPathDelim + SubPaths[i]; Found := FindFirst( Search, faHidden + faSysFile + faDirectory, SR ); if Found <> 0 then raise EAbException.Create( 'Path not found' ); try Result := Result + ExtractShortName(SR) + AbPathDelim; finally FindClose( SR ); end; end; Search := Search + AbPathDelim + FileName; Found := FindFirst( Search, faReadOnly + faHidden + faSysFile + faArchive, SR ); if Found <> 0 then raise EAbFileNotFound.Create; try Result := Result + ExtractShortName(SR); finally FindClose( SR ); end; finally SubPaths.Free; end; end; {$WARN SYMBOL_PLATFORM ON} {$ENDIF} { -------------------------------------------------------------------------- } procedure AbIncFilename( var Filename : string; Value : Word ); { place value at the end of filename, e.g. Files.C04 } var Ext : string; I : Word; begin I := (Value + 1) mod 100; Ext := ExtractFileExt(Filename); if (Length(Ext) < 2) then Ext := '.' + Format('%.2d', [I]) else Ext := Ext[1] + Ext[2] + Format('%.2d', [I]); Filename := ChangeFileExt(Filename, Ext); end; { -------------------------------------------------------------------------- } procedure AbParseFileName( FileSpec : string; out Drive : string; out Path : string; out FileName : string ); var i : Integer; iColon : Integer; iStartSlash : Integer; begin if Pos( AB_ZIPPATHDELIM, FileSpec ) > 0 then AbUnfixName( FileSpec ); FileName := ExtractFileName( FileSpec ); Path := ExtractFilePath( FileSpec ); {see how much of the path currently exists} iColon := Pos( ':', Path ); if Pos( '\\', Path ) > 0 then begin {UNC Path \\computername\sharename\path1..\pathn} {everything up to the 4th slash is the drive} iStartSlash := 4; i := AbFindNthSlash( Path, iStartSlash ); Drive := Copy( Path, 1, i ); Delete( Path, 1, i + 1 ); end else if iColon > 0 then begin Drive := Copy( Path, 1, iColon ); Delete( Path, 1, iColon ); if Path[1] = AbPathDelim then Delete( Path, 1, 1 ); end; end; { -------------------------------------------------------------------------- } procedure AbParsePath( Path : string; SubPaths : TStrings ); { break abart path into subpaths --- Path : abbrevia/examples > SubPaths[0] = abbrevia SubPaths[1] = examples} var i : Integer; iStart : Integer; iStartSlash : Integer; SubPath : string; begin if Path = '' then Exit; if Path[ Length( Path ) ] = AbPathDelim then Delete( Path, Length( Path ), 1 ); iStart := 1; iStartSlash := 1; repeat {find the Slash at iStartSlash} i := AbFindNthSlash( Path, iStartSlash ); {get the subpath} SubPath := Copy( Path, iStart, i - iStart + 1 ); iStart := i + 2; inc( iStartSlash ); SubPaths.Add( SubPath ); until ( i = Length( Path ) ); end; { -------------------------------------------------------------------------- } function AbPatternMatch(const Source : string; iSrc : Integer; const Pattern : string; iPat : Integer ) : Boolean; { recursive routine to see if the source string matches the pattern. Both ? and * wildcard characters are allowed. Compares Source from iSrc to Length(Source) to Pattern from iPat to Length(Pattern)} var Matched : Boolean; k : Integer; begin if Length( Source ) = 0 then begin Result := Length( Pattern ) = 0; Exit; end; if iPat = 1 then begin if ( CompareStr( Pattern, AbDosAnyFile) = 0 ) or ( CompareStr( Pattern, AbUnixAnyFile ) = 0 ) then begin Result := True; Exit; end; end; if Length( Pattern ) = 0 then begin Result := (Length( Source ) - iSrc + 1 = 0); Exit; end; while True do begin if ( Length( Source ) < iSrc ) and ( Length( Pattern ) < iPat ) then begin Result := True; Exit; end; if Length( Pattern ) < iPat then begin Result := False; Exit; end; if Pattern[iPat] = '*' then begin k := iPat; if ( Length( Pattern ) < iPat + 1 ) then begin Result := True; Exit; end; while True do begin Matched := AbPatternMatch( Source, k, Pattern, iPat + 1 ); if Matched or ( Length( Source ) < k ) then begin Result := Matched; Exit; end; inc( k ); end; end else begin if ( (Pattern[iPat] = '?') and ( Length( Source ) <> iSrc - 1 ) ) or ( Pattern[iPat] = Source[iSrc] ) then begin inc( iPat ); inc( iSrc ); end else begin Result := False; Exit; end; end; end; end; { -------------------------------------------------------------------------- } function AbPercentage(V1, V2 : Int64) : Byte; { Returns the ratio of V1 to V2 * 100 } begin if V2 <= 0 then Result := 0 else if V1 >= V2 then Result := 100 else Result := (V1 * 100) div V2; end; { -------------------------------------------------------------------------- } procedure AbStripDots( var FName : string ); { strips relative path information, e.g. ".."} begin while Pos( AbParentDir + AbPathDelim, FName ) = 1 do System.Delete( FName, 1, 3 ); end; { -------------------------------------------------------------------------- } procedure AbStripDrive( var FName : string ); { strips the drive off a filename } var Drive, Path, Name : string; begin AbParseFileName( FName, Drive, Path, Name ); FName := Path + Name; end; { -------------------------------------------------------------------------- } procedure AbFixName( var FName : string ); { changes backslashes to forward slashes } var i : Integer; begin for i := 1 to Length( FName ) do if FName[i] = AbPathDelim then FName[i] := AB_ZIPPATHDELIM; end; { -------------------------------------------------------------------------- } procedure AbUnfixName( var FName : string ); { changes forward slashes to backslashes } var i : Integer; begin for i := 1 to Length( FName ) do if FName[i] = AB_ZIPPATHDELIM then FName[i] := AbPathDelim; end; { -------------------------------------------------------------------------- } procedure AbUpdateCRC( var CRC : LongInt; const Buffer; Len : Integer ); var BufPtr : PByte; i : Integer; CRCTemp : DWORD; begin BufPtr := @Buffer; CRCTemp := CRC; for i := 0 to pred( Len ) do begin CRCTemp := AbCrc32Table[ Byte(CrcTemp) xor (BufPtr^) ] xor ((CrcTemp shr 8) and $00FFFFFF); Inc(BufPtr); end; CRC := CRCTemp; end; { -------------------------------------------------------------------------- } function AbUpdateCRC32(CurByte : Byte; CurCrc : LongInt) : LongInt; { Return the updated 32bit CRC } { Normally a good candidate for basm, but Delphi32's code generation couldn't be beat on this one!} begin Result := DWORD(AbCrc32Table[ Byte(CurCrc xor LongInt( CurByte ) ) ] xor ((CurCrc shr 8) and DWORD($00FFFFFF))); end; { -------------------------------------------------------------------------- } function AbCRC32Of( const aValue : RawByteString ) : LongInt; begin Result := -1; AbUpdateCRC(Result, aValue[1], Length(aValue)); Result := not Result; end; { -------------------------------------------------------------------------- } function AbWriteVolumeLabel(const VolName : string; Drive : Char) : Cardinal; var Temp : string; Vol : array[0..11] of Char; Root : array[0..3] of Char; begin Temp := VolName; StrCopy(Root, '%:' + AbPathDelim); Root[0] := Drive; if Length(Temp) > 11 then SetLength(Temp, 11); StrPCopy(Vol, Temp); {$IFDEF MSWINDOWS} if Windows.SetVolumeLabel(Root, Vol) then Result := 0 else Result := GetLastError; {$ENDIF MSWINDOWS} {$IFDEF UNIX} { Volume labels not supported on Unix } Result := 0; {$ENDIF UNIX} end; { -------------------------------------------------------------------------- } {$IFDEF MSWINDOWS} function AbOffsetFromUTC: LongInt; { local timezone's offset from UTC in seconds (UTC = local + bias) } var TZI: TTimeZoneInformation; begin case GetTimeZoneInformation(TZI) of TIME_ZONE_ID_UNKNOWN: Result := TZI.Bias; TIME_ZONE_ID_DAYLIGHT: Result := TZI.Bias + TZI.DaylightBias; TIME_ZONE_ID_STANDARD: Result := TZI.Bias + TZI.StandardBias else Result := 0 end; Result := Result * SecondsInMinute; end; {$ENDIF} { -------------------------------------------------------------------------- } function AbUnixTimeToLocalDateTime(UnixTime : LongInt) : TDateTime; { convert UTC unix date to Delphi TDateTime in local timezone } {$IFDEF MSWINDOWS} var Hrs, Mins, Secs : Word; TodaysSecs : LongInt; Time: TDateTime; begin UnixTime := UnixTime - AbOffsetFromUTC; TodaysSecs := UnixTime mod SecondsInDay; Hrs := TodaysSecs div SecondsInHour; TodaysSecs := TodaysSecs - (Hrs * SecondsInHour); Mins := TodaysSecs div SecondsInMinute; Secs := TodaysSecs - (Mins * SecondsInMinute); if TryEncodeTime(Hrs, Mins, Secs, 0, Time) then Result := Unix0Date + (UnixTime div SecondsInDay) + Time else Result := 0; {$ENDIF} {$IFDEF UNIX} begin Result := FileDateToDateTime(UnixTime); {$ENDIF} end; { -------------------------------------------------------------------------- } function AbLocalDateTimeToUnixTime(DateTime : TDateTime) : LongInt; { convert local Delphi TDateTime to UTC unix date } {$IFDEF MSWINDOWS} var Hrs, Mins, Secs, MSecs : Word; Dt, Tm : TDateTime; begin Dt := Trunc(DateTime); Tm := DateTime - Dt; if Dt < Unix0Date then Result := 0 else Result := Trunc(Dt - Unix0Date) * SecondsInDay; DecodeTime(Tm, Hrs, Mins, Secs, MSecs); Result := Result + (Hrs * SecondsInHour) + (Mins * SecondsInMinute) + Secs; Result := Result + AbOffsetFromUTC; {$ENDIF} {$IFDEF UNIX} begin Result := DateTimeToFileDate(DateTime); {$ENDIF} end; { -------------------------------------------------------------------------- } function AbDosFileDateToDateTime(FileDate, FileTime : Word) : TDateTime; {$IFDEF MSWINDOWS} var Temp : LongInt; begin LongRec(Temp).Lo := FileTime; LongRec(Temp).Hi := FileDate; Result := FileDateToDateTime(Temp); {$ENDIF MSWINDOWS} {$IFDEF UNIX} var Yr, Mo, Dy : Word; Hr, Mn, S : Word; begin Yr := FileDate shr 9 + 1980; Mo := FileDate shr 5 and 15; if Mo < 1 then Mo := 1; if Mo > 12 then Mo := 12; Dy := FileDate and 31; if Dy < 1 then Dy := 1; if Dy > DaysInAMonth(Yr, Mo) then Dy := DaysInAMonth(Yr, Mo); Hr := FileTime shr 11; if Hr > 23 then Hr := 23; Mn := FileTime shr 5 and 63; if Mn > 59 then Mn := 59; S := FileTime and 31 shl 1; if S > 59 then S := 59; Result := EncodeDate(Yr, Mo, Dy) + EncodeTime(Hr, Mn, S, 0); {$ENDIF UNIX} end; function AbDateTimeToDosFileDate(Value : TDateTime) : LongInt; {$IFDEF MSWINDOWS} begin Result := DateTimeToFileDate(Value); {$ENDIF MSWINDOWS} {$IFDEF UNIX} var Yr, Mo, Dy : Word; Hr, Mn, S, MS: Word; begin DecodeDate(Value, Yr, Mo, Dy); if (Yr < 1980) or (Yr > 2107) then { outside DOS file date year range } Yr := 1980; DecodeTime(Value, Hr, Mn, S, MS); LongRec(Result).Lo := (S shr 1) or (Mn shl 5) or (Hr shl 11); LongRec(Result).Hi := Dy or (Mo shl 5) or (Word(Yr - 1980) shl 9); {$ENDIF UNIX} end; { -------------------------------------------------------------------------- } function AbGetFileTime(const aFileName: string): TDateTime; var Attr: TAbAttrExRec; begin AbFileGetAttrEx(aFileName, Attr); Result := Attr.Time; end; function AbSetFileTime(const aFileName: string; aValue: TDateTime): Boolean; begin {$IFDEF MSWINDOWS} Result := FileSetDate(aFileName, AbDateTimeToDosFileDate(aValue)) = 0; {$ENDIF} {$IFDEF UNIX} Result := FileSetDate(aFileName, AbLocalDateTimeToUnixTime(aValue)) = 0; {$ENDIF} end; { -------------------------------------------------------------------------- } function AbSwapLongEndianness(Value : LongInt): LongInt; { convert BigEndian <-> LittleEndian 32-bit value } type TCastArray = array [0..3] of Byte; var i : Integer; begin for i := 3 downto 0 do TCastArray(Result)[3-i] := TCastArray(Value)[i]; end; { -------------------------------------------------------------------------- } function AbDOS2UnixFileAttributes(Attr: LongInt): LongInt; begin {$WARN SYMBOL_PLATFORM OFF} Result := { default permissions } AB_FPERMISSION_OWNERREAD or AB_FPERMISSION_GROUPREAD or AB_FPERMISSION_OTHERREAD; if (Attr and faReadOnly) = 0 then Result := Result or AB_FPERMISSION_OWNERWRITE; if (Attr and faDirectory) <> 0 then Result := Result or AB_FMODE_DIR or AB_FPERMISSION_OWNEREXECUTE or AB_FPERMISSION_GROUPEXECUTE or AB_FPERMISSION_OTHEREXECUTE else Result := Result or AB_FMODE_FILE; {$WARN SYMBOL_PLATFORM ON} end; { -------------------------------------------------------------------------- } function AbUnix2DosFileAttributes(Attr: LongInt): LongInt; begin {$WARN SYMBOL_PLATFORM OFF} Result := 0; case (Attr and $F000) of AB_FMODE_FILE, AB_FMODE_FILE2: { standard file } Result := 0; AB_FMODE_DIR: { directory } Result := Result or faDirectory; AB_FMODE_FIFO, AB_FMODE_CHARSPECFILE, AB_FMODE_BLOCKSPECFILE, AB_FMODE_FILELINK, AB_FMODE_SOCKET: Result := Result or faSysFile; end; if (Attr and AB_FPERMISSION_OWNERWRITE) <> AB_FPERMISSION_OWNERWRITE then Result := Result or faReadOnly; {$WARN SYMBOL_PLATFORM ON} end; { -------------------------------------------------------------------------- } procedure AbSetFileAttr(const aFileName : string; aAttr: Integer); begin {$WARN SYMBOL_PLATFORM OFF} {$IFDEF MSWINDOWS} FileSetAttr(aFileName, aAttr); {$ENDIF} {$IF DEFINED(LibcAPI) OR DEFINED(PosixAPI)} chmod(PAnsiChar(AbSysString(aFileName)), aAttr); {$ELSEIF DEFINED(FPCUnixAPI)} fpchmod(aFileName, aAttr); {$IFEND} {$WARN SYMBOL_PLATFORM ON} end; { -------------------------------------------------------------------------- } function AbFileGetSize(const aFileName : string) : Int64; var SR: TAbAttrExRec; begin if AbFileGetAttrEx(aFileName, SR) then Result := SR.Size else Result := -1; end; { -------------------------------------------------------------------------- } function AbFileGetAttrEx(const aFileName: string; out aAttr: TAbAttrExRec) : Boolean; var {$IFDEF MSWINDOWS} FileDate: LongRec; FindData: TWin32FindData; LocalFileTime: TFileTime; {$ENDIF} {$IFDEF FPCUnixAPI} StatBuf: stat; {$ENDIF} {$IFDEF LibcAPI} StatBuf: TStatBuf64; {$ENDIF} {$IFDEF PosixAPI} StatBuf: _stat; {$ENDIF} begin aAttr.Time := 0; aAttr.Size := -1; aAttr.Attr := -1; aAttr.Mode := 0; {$IFDEF MSWINDOWS} Result := GetFileAttributesEx(PChar(aFileName), GetFileExInfoStandard, @FindData); if Result then begin if FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime) and FileTimeToDosDateTime(LocalFileTime, FileDate.Hi, FileDate.Lo) then aAttr.Time := FileDateToDateTime(Integer(FileDate)); LARGE_INTEGER(aAttr.Size).LowPart := FindData.nFileSizeLow; LARGE_INTEGER(aAttr.Size).HighPart := FindData.nFileSizeHigh; aAttr.Attr := FindData.dwFileAttributes; aAttr.Mode := AbDOS2UnixFileAttributes(FindData.dwFileAttributes); end; {$ENDIF} {$IFDEF UNIX} {$IFDEF FPCUnixAPI} Result := (FpStat(aFileName, StatBuf) = 0); {$ENDIF} {$IFDEF LibcAPI} // Work around Kylix QC#2761: Stat64, et al., are defined incorrectly Result := (__lxstat64(_STAT_VER, PAnsiChar(aFileName), StatBuf) = 0); {$ENDIF} {$IFDEF PosixAPI} Result := (stat(PAnsiChar(AbSysString(aFileName)), StatBuf) = 0); {$ENDIF} if Result then begin aAttr.Time := FileDateToDateTime(StatBuf.st_mtime); aAttr.Size := StatBuf.st_size; aAttr.Attr := AbUnix2DosFileAttributes(StatBuf.st_mode); aAttr.Mode := StatBuf.st_mode; end; {$ENDIF UNIX} end; const MAX_VOL_LABEL = 16; function AbGetVolumeLabel(Drive : Char) : string; {-Get the volume label for the specified drive.} {$IFDEF MSWINDOWS} var Root : string; Flags, MaxLength : DWORD; NameSize : Integer; VolName : string; {$ENDIF} begin {$IFDEF MSWINDOWS} NameSize := 0; Root := Drive + ':\'; SetLength(VolName, MAX_VOL_LABEL); Result := ''; if GetVolumeInformation(PChar(Root), PChar(VolName), Length(VolName), nil, MaxLength, Flags, nil, NameSize) then Result := VolName; {$ELSE} Result := ''; //Stop Gap, spanning support needs to be rethought for Unix {$ENDIF} end; procedure AbSetSpanVolumeLabel(Drive: Char; VolNo : Integer); begin AbWriteVolumeLabel(Format(AB_SPAN_VOL_LABEL, [VolNo]), Drive); end; function AbTestSpanVolumeLabel(Drive: Char; VolNo : Integer): Boolean; var VolLabel, TestLabel : string; begin TestLabel := Format(AB_SPAN_VOL_LABEL, [VolNo]); VolLabel := UpperCase(AbGetVolumeLabel(Drive)); Result := VolLabel = TestLabel; end; { Unicode backwards compatibility functions } {$IFNDEF UNICODE} function CharInSet(C: AnsiChar; CharSet: TSysCharSet): Boolean; begin Result := C in CharSet; end; {$ENDIF} function AbLeftStr(const AText: AnsiString; const ACount: Integer): AnsiString; begin {$IFDEF HasAnsiStrings} Result := System.AnsiStrings.LeftStr(AText, ACount); {$ELSE} Result := StrUtils.LeftStr(AText, ACount); {$ENDIF} end; function AbStrLen(const Str: PAnsiChar): Cardinal; begin {$IFDEF HasAnsiStrings} Result := System.AnsiStrings.StrLen(Str); {$ELSE} Result := SysUtils.StrLen(Str); {$ENDIF} end; function AbStrPCopy(Dest: PAnsiChar; const Source: AnsiString): PAnsiChar; begin {$IFDEF HasAnsiStrings} Result := System.AnsiStrings.StrPCopy(Dest, Source); {$ELSE} Result := SysUtils.StrPCopy(Dest, Source); {$ENDIF} end; function AbStrPLCopy(Dest: PAnsiChar; const Source: AnsiString; MaxLen: Cardinal): PAnsiChar; begin {$IFDEF HasAnsiStrings} Result := System.AnsiStrings.StrPLCopy(Dest, Source, MaxLen); {$ELSE} Result := SysUtils.StrPLCopy(Dest, Source, MaxLen); {$ENDIF} end; end.